* HIRLAM and -ftree-loop-linear
@ 2007-12-14 22:30 Toon Moene
2007-12-15 22:55 ` Sebastian Pop
2007-12-16 14:33 ` Dorit Nuzman
0 siblings, 2 replies; 7+ messages in thread
From: Toon Moene @ 2007-12-14 22:30 UTC (permalink / raw)
To: Sebastian Pop, gcc mailing list
[-- Attachment #1: Type: text/plain, Size: 608 bytes --]
Sebastian,
Here are (attached) results for testing HIRLAM with and without
-ftree-loop-linear.
As you can see, the results are neutral: 4 loops fewer vectorized, but
about 50 fewer recognized.
Now I like to redo that test with -ftree-loop-distribution. Can you
send me a patch against the trunk (otherwise it won't be a fair comparison).
Kind regards,
--
Toon Moene - e-mail: toon@moene.indiv.nluug.nl - phone: +31 346 214290
Saturnushof 14, 3738 XG Maartensdijk, The Netherlands
At home: http://moene.indiv.nluug.nl/~toon/
GNU Fortran's path to Fortran 2003: http://gcc.gnu.org/wiki/Fortran2003
[-- Attachment #2: loop-tests.txt --]
[-- Type: text/plain, Size: 3839 bytes --]
Baseline, no source changes:
Mon Dec 10 17:45:19 UTC 2007 (revision 130746)
Compilation flags:
CCFLAGS := -g -O3 $(MACHINECPP) -ffast-math -fno-associative-math -march=native -mtune=native -ftree-vectorizer-verbose=2
FCFLAGS := -g -O3 -fbacktrace -ffpe-trap=invalid,zero,overflow -ffast-math -fno-associative-math -march=native -mtune=native -ftree-vectorizer-verbose=2
Loops vectorized:
5675
Loops not vectorized:
13705
Timings:
20061201_00/HL_Cycle_2006120100.html: FORECAST TOOK 12.7488 SECONDS
20061201_00/HL_Cycle_2006120100.html: FORECAST TOOK 2445.9609 SECONDS
20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 259.3362 SECONDS
20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 12.4408 SECONDS
20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 305.9351 SECONDS
20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 262.1124 SECONDS
20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 12.7448 SECONDS
20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 2323.3733 SECONDS
20061201_12r/HL_Cycle_2006120112r.html: FORECAST TOOK 412.7058 SECONDS
20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 264.5685 SECONDS
20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 12.6648 SECONDS
20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 306.7352 SECONDS
20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 261.5164 SECONDS
20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 12.7688 SECONDS
20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 2325.3774 SECONDS
20061202_00r/HL_Cycle_2006120200r.html: FORECAST TOOK 413.8739 SECONDS
Baseline, no source changes, with -ftree-loop-linear:
Mon Dec 10 17:45:19 UTC 2007 (revision 130746)
Compilation flags:
CCFLAGS := -g -O3 $(MACHINECPP) -ftree-loop-linear -ffast-math -fno-associative-math -march=native -mtune=native -ftree-vectorizer-verbose=2
FCFLAGS := -g -O3 -ftree-loop-linear -fbacktrace -ffpe-trap=invalid,zero,overflow -ffast-math -fno-associative-math -march=native -mtune=native -ftree-vectorizer-verbose=2
This compilation got one ICE:
rttov_aitosu.f90: In function 'rttov_aitosu':
rttov_aitosu.f90:4: error: definition in block 262 does not dominate use in block 134
for SSA_NAME: pretmp.240_59 in statement:
prephitmp.220_58 = PHI <pretmp.240_59(134), D.1480_1373(138)>
PHI argument
pretmp.240_59
for PHI node
prephitmp.220_58 = PHI <pretmp.240_59(134), D.1480_1373(138)>
rttov_aitosu.f90:4: internal compiler error: verify_ssa failed
Please submit a full bug report,
with preprocessed source if appropriate.
See <http://gcc.gnu.org/bugs.html> for instructions.
Worked around by compiling this file without -ftree-loop-linear
Loops vectorized:
5671
Loops not vectorized:
13655
Timings:
20061201_00/HL_Cycle_2006120100.html: FORECAST TOOK 12.5648 SECONDS
20061201_00/HL_Cycle_2006120100.html: FORECAST TOOK 2444.1208 SECONDS
20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 259.3402 SECONDS
20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 12.4728 SECONDS
20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 307.8672 SECONDS
20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 260.0323 SECONDS
20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 12.8608 SECONDS
20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 2310.2485 SECONDS
20061201_12r/HL_Cycle_2006120112r.html: FORECAST TOOK 411.3977 SECONDS
20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 261.1283 SECONDS
20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 12.7248 SECONDS
20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 308.1313 SECONDS
20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 262.7564 SECONDS
20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 12.6528 SECONDS
20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 2336.5620 SECONDS
20061202_00r/HL_Cycle_2006120200r.html: FORECAST TOOK 410.6577 SECONDS
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: HIRLAM and -ftree-loop-linear
2007-12-14 22:30 HIRLAM and -ftree-loop-linear Toon Moene
@ 2007-12-15 22:55 ` Sebastian Pop
2007-12-16 14:15 ` Toon Moene
2007-12-16 14:33 ` Dorit Nuzman
1 sibling, 1 reply; 7+ messages in thread
From: Sebastian Pop @ 2007-12-15 22:55 UTC (permalink / raw)
To: Toon Moene; +Cc: gcc mailing list
[-- Attachment #1: Type: text/plain, Size: 1284 bytes --]
On Dec 14, 2007 4:24 PM, Toon Moene <toon@moene.indiv.nluug.nl> wrote:
> Here are (attached) results for testing HIRLAM with and without
> -ftree-loop-linear.
>
Thanks Toon for checking this.
> Compilation flags:
>
> CCFLAGS := -g -O3 $(MACHINECPP) -ftree-loop-linear -ffast-math -fno-associative-math -march=native -mtune=native -ftree-vectorizer-verbose=2
> FCFLAGS := -g -O3 -ftree-loop-linear -fbacktrace -ffpe-trap=invalid,zero,overflow -ffast-math -fno-associative-math -march=native -mtune=native -ftree-vectorizer-verbose=2
>
> This compilation got one ICE:
>
> rttov_aitosu.f90: In function 'rttov_aitosu':
> rttov_aitosu.f90:4: error: definition in block 262 does not dominate use in block 134
> for SSA_NAME: pretmp.240_59 in statement:
> prephitmp.220_58 = PHI <pretmp.240_59(134), D.1480_1373(138)>
> PHI argument
> pretmp.240_59
> for PHI node
> prephitmp.220_58 = PHI <pretmp.240_59(134), D.1480_1373(138)>
> rttov_aitosu.f90:4: internal compiler error: verify_ssa failed
> Please submit a full bug report,
> with preprocessed source if appropriate.
> See <http://gcc.gnu.org/bugs.html> for instructions.
>
> Worked around by compiling this file without -ftree-loop-linear
>
Could you verify that the attached patch fixes also this problem?
Thanks again,
Sebastian
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 859_pr34123.diff --]
[-- Type: text/x-diff; name=859_pr34123.diff, Size: 8877 bytes --]
2007-12-15 Sebastian Pop <sebastian.pop@amd.com>
* lambda-code.c (can_duplicate_iv): New.
(cannot_convert_modify_to_perfect_nest): New.
(cannot_convert_bb_to_perfect_nest): New.
(can_convert_to_perfect_nest): Split up.
email:sebpop@gmail.com
branch:trunk
revision:HEAD
configure:
make:
check:
Index: testsuite/gcc.dg/tree-ssa/pr34123.c
===================================================================
--- testsuite/gcc.dg/tree-ssa/pr34123.c (revision 0)
+++ testsuite/gcc.dg/tree-ssa/pr34123.c (revision 0)
@@ -0,0 +1,18 @@
+/* { dg-do compile } */
+/* { dg-options "-O2 -ftree-loop-linear" } */
+
+/* Testcase by Martin Michlmayr <tbm@cyrius.com> */
+
+static unsigned char sbox[256] = {
+};
+void MD2Transform (unsigned char state[16])
+{
+ unsigned char t = 0;
+ int i, j;
+ for (i = 0; i < 16; i++)
+ {
+ for (j = 0; j < 2; j++)
+ t = (state[j] ^= sbox[t]);
+ t += i;
+ }
+}
Index: lambda-code.c
===================================================================
--- lambda-code.c (revision 130956)
+++ lambda-code.c (working copy)
@@ -2177,7 +2177,128 @@ can_put_after_inner_loop (struct loop *l
return true;
}
+/* Return true when the induction variable IV is simple enough to be
+ re-synthesized. */
+static bool
+can_duplicate_iv (tree iv, struct loop *loop)
+{
+ tree scev = instantiate_parameters
+ (loop, analyze_scalar_evolution (loop, iv));
+
+ if (!automatically_generated_chrec_p (scev))
+ {
+ tree step = evolution_part_in_loop_num (scev, loop->num);
+
+ if (step && step != chrec_dont_know && TREE_CODE (step) == INTEGER_CST)
+ return true;
+ }
+
+ return false;
+}
+
+/* If this is a scalar operation that can be put back into the inner
+ loop, or after the inner loop, through copying, then do so. This
+ works on the theory that any amount of scalar code we have to
+ reduplicate into or after the loops is less expensive that the win
+ we get from rearranging the memory walk the loop is doing so that
+ it has better cache behavior. */
+
+static bool
+cannot_convert_modify_to_perfect_nest (tree stmt, struct loop *loop)
+{
+
+ use_operand_p use_a, use_b;
+ imm_use_iterator imm_iter;
+ ssa_op_iter op_iter, op_iter1;
+ tree op0 = GIMPLE_STMT_OPERAND (stmt, 0);
+
+ /* The statement should not define a variable used in the inner
+ loop. */
+ if (TREE_CODE (op0) == SSA_NAME
+ && !can_duplicate_iv (op0, loop))
+ FOR_EACH_IMM_USE_FAST (use_a, imm_iter, op0)
+ if (bb_for_stmt (USE_STMT (use_a))->loop_father
+ == loop->inner)
+ return true;
+
+ FOR_EACH_SSA_USE_OPERAND (use_a, stmt, op_iter, SSA_OP_USE)
+ {
+ tree node, op = USE_FROM_PTR (use_a);
+
+ /* The variables should not be used in both loops. */
+ if (!can_duplicate_iv (op, loop))
+ FOR_EACH_IMM_USE_FAST (use_b, imm_iter, op)
+ if (bb_for_stmt (USE_STMT (use_b))->loop_father
+ == loop->inner)
+ return true;
+
+ /* The statement should not use the value of a scalar that was
+ modified in the loop. */
+ node = SSA_NAME_DEF_STMT (op);
+ if (TREE_CODE (node) == PHI_NODE)
+ FOR_EACH_PHI_ARG (use_b, node, op_iter1, SSA_OP_USE)
+ {
+ tree arg = USE_FROM_PTR (use_b);
+
+ if (TREE_CODE (arg) == SSA_NAME)
+ {
+ tree arg_stmt = SSA_NAME_DEF_STMT (arg);
+
+ if (bb_for_stmt (arg_stmt)
+ && (bb_for_stmt (arg_stmt)->loop_father
+ == loop->inner))
+ return true;
+ }
+ }
+ }
+
+ return false;
+}
+
+/* Return true when BB contains statements that can harm the transform
+ to a perfect loop nest. */
+
+static bool
+cannot_convert_bb_to_perfect_nest (basic_block bb, struct loop *loop)
+{
+ block_stmt_iterator bsi;
+ tree exit_condition = get_loop_exit_condition (loop);
+
+ for (bsi = bsi_start (bb); !bsi_end_p (bsi); bsi_next (&bsi))
+ {
+ tree stmt = bsi_stmt (bsi);
+
+ if (stmt == exit_condition
+ || not_interesting_stmt (stmt)
+ || stmt_is_bumper_for_loop (loop, stmt))
+ continue;
+
+ if (TREE_CODE (stmt) == GIMPLE_MODIFY_STMT)
+ {
+ if (cannot_convert_modify_to_perfect_nest (stmt, loop))
+ return true;
+
+ if (can_duplicate_iv (GIMPLE_STMT_OPERAND (stmt, 0), loop))
+ continue;
+
+ if (can_put_in_inner_loop (loop->inner, stmt)
+ || can_put_after_inner_loop (loop, stmt))
+ continue;
+ }
+
+ /* If the bb of a statement we care about isn't dominated by the
+ header of the inner loop, then we can't handle this case
+ right now. This test ensures that the statement comes
+ completely *after* the inner loop. */
+ if (!dominated_by_p (CDI_DOMINATORS,
+ bb_for_stmt (stmt),
+ loop->inner->header))
+ return true;
+ }
+
+ return false;
+}
/* Return TRUE if LOOP is an imperfect nest that we can convert to a
perfect one. At the moment, we only handle imperfect nests of
@@ -2187,117 +2308,22 @@ static bool
can_convert_to_perfect_nest (struct loop *loop)
{
basic_block *bbs;
- tree exit_condition, phi;
+ tree phi;
size_t i;
- block_stmt_iterator bsi;
- basic_block exitdest;
/* Can't handle triply nested+ loops yet. */
if (!loop->inner || loop->inner->inner)
return false;
bbs = get_loop_body (loop);
- exit_condition = get_loop_exit_condition (loop);
for (i = 0; i < loop->num_nodes; i++)
- {
- if (bbs[i]->loop_father == loop)
- {
- for (bsi = bsi_start (bbs[i]); !bsi_end_p (bsi); bsi_next (&bsi))
- {
- tree stmt = bsi_stmt (bsi);
-
- if (stmt == exit_condition
- || not_interesting_stmt (stmt)
- || stmt_is_bumper_for_loop (loop, stmt))
- continue;
-
- /* If this is a scalar operation that can be put back
- into the inner loop, or after the inner loop, through
- copying, then do so. This works on the theory that
- any amount of scalar code we have to reduplicate
- into or after the loops is less expensive that the
- win we get from rearranging the memory walk
- the loop is doing so that it has better
- cache behavior. */
- if (TREE_CODE (stmt) == GIMPLE_MODIFY_STMT)
- {
- use_operand_p use_a, use_b;
- imm_use_iterator imm_iter;
- ssa_op_iter op_iter, op_iter1;
- tree op0 = GIMPLE_STMT_OPERAND (stmt, 0);
- tree scev = instantiate_parameters
- (loop, analyze_scalar_evolution (loop, op0));
-
- /* If the IV is simple, it can be duplicated. */
- if (!automatically_generated_chrec_p (scev))
- {
- tree step = evolution_part_in_loop_num (scev, loop->num);
- if (step && step != chrec_dont_know
- && TREE_CODE (step) == INTEGER_CST)
- continue;
- }
-
- /* The statement should not define a variable used
- in the inner loop. */
- if (TREE_CODE (op0) == SSA_NAME)
- FOR_EACH_IMM_USE_FAST (use_a, imm_iter, op0)
- if (bb_for_stmt (USE_STMT (use_a))->loop_father
- == loop->inner)
- goto fail;
-
- FOR_EACH_SSA_USE_OPERAND (use_a, stmt, op_iter, SSA_OP_USE)
- {
- tree node, op = USE_FROM_PTR (use_a);
-
- /* The variables should not be used in both loops. */
- FOR_EACH_IMM_USE_FAST (use_b, imm_iter, op)
- if (bb_for_stmt (USE_STMT (use_b))->loop_father
- == loop->inner)
- goto fail;
-
- /* The statement should not use the value of a
- scalar that was modified in the loop. */
- node = SSA_NAME_DEF_STMT (op);
- if (TREE_CODE (node) == PHI_NODE)
- FOR_EACH_PHI_ARG (use_b, node, op_iter1, SSA_OP_USE)
- {
- tree arg = USE_FROM_PTR (use_b);
-
- if (TREE_CODE (arg) == SSA_NAME)
- {
- tree arg_stmt = SSA_NAME_DEF_STMT (arg);
-
- if (bb_for_stmt (arg_stmt)
- && (bb_for_stmt (arg_stmt)->loop_father
- == loop->inner))
- goto fail;
- }
- }
- }
-
- if (can_put_in_inner_loop (loop->inner, stmt)
- || can_put_after_inner_loop (loop, stmt))
- continue;
- }
-
- /* Otherwise, if the bb of a statement we care about isn't
- dominated by the header of the inner loop, then we can't
- handle this case right now. This test ensures that the
- statement comes completely *after* the inner loop. */
- if (!dominated_by_p (CDI_DOMINATORS,
- bb_for_stmt (stmt),
- loop->inner->header))
- goto fail;
- }
- }
- }
+ if (bbs[i]->loop_father == loop
+ && cannot_convert_bb_to_perfect_nest (bbs[i], loop))
+ goto fail;
/* We also need to make sure the loop exit only has simple copy phis in it,
- otherwise we don't know how to transform it into a perfect nest right
- now. */
- exitdest = single_exit (loop)->dest;
-
- for (phi = phi_nodes (exitdest); phi; phi = PHI_CHAIN (phi))
+ otherwise we don't know how to transform it into a perfect nest. */
+ for (phi = phi_nodes (single_exit (loop)->dest); phi; phi = PHI_CHAIN (phi))
if (PHI_NUM_ARGS (phi) != 1)
goto fail;
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: HIRLAM and -ftree-loop-linear
2007-12-15 22:55 ` Sebastian Pop
@ 2007-12-16 14:15 ` Toon Moene
0 siblings, 0 replies; 7+ messages in thread
From: Toon Moene @ 2007-12-16 14:15 UTC (permalink / raw)
To: Sebastian Pop; +Cc: gcc mailing list
Sebastian Pop wrote:
> I wrote:
>> rttov_aitosu.f90: In function 'rttov_aitosu':
>> rttov_aitosu.f90:4: error: definition in block 262 does not dominate use in block 134
>>
>> Worked around by compiling this file without -ftree-loop-linear
>>
>
> Could you verify that the attached patch fixes also this problem?
Unfortunately, it doesn't; I get exactly the same error message as before.
Kind regards,
--
Toon Moene - e-mail: toon@moene.indiv.nluug.nl - phone: +31 346 214290
Saturnushof 14, 3738 XG Maartensdijk, The Netherlands
At home: http://moene.indiv.nluug.nl/~toon/
GNU Fortran's path to Fortran 2003: http://gcc.gnu.org/wiki/Fortran2003
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: HIRLAM and -ftree-loop-linear
2007-12-14 22:30 HIRLAM and -ftree-loop-linear Toon Moene
2007-12-15 22:55 ` Sebastian Pop
@ 2007-12-16 14:33 ` Dorit Nuzman
2007-12-16 17:17 ` Toon Moene
2007-12-17 21:24 ` Toon Moene
1 sibling, 2 replies; 7+ messages in thread
From: Dorit Nuzman @ 2007-12-16 14:33 UTC (permalink / raw)
To: Toon Moene; +Cc: gcc mailing list, Sebastian Pop
> Sebastian,
>
> Here are (attached) results for testing HIRLAM with and without
> -ftree-loop-linear.
>
> As you can see, the results are neutral: 4 loops fewer vectorized, but
> about 50 fewer recognized.
>
any chance you kept the dumps and can report which loops were not
vectorized/recognized with -ftree-loop-linear (so we could see if these
represent missed vectorization opportunities?)
thanks,
dorit
> Now I like to redo that test with -ftree-loop-distribution. Can you
> send me a patch against the trunk (otherwise it won't be a fair
comparison).
>
> Kind regards,
>
> --
> Toon Moene - e-mail: toon@moene.indiv.nluug.nl - phone: +31 346 214290
> Saturnushof 14, 3738 XG Maartensdijk, The Netherlands
> At home: http://moene.indiv.nluug.nl/~toon/
> GNU Fortran's path to Fortran 2003: http://gcc.gnu.org/wiki/Fortran2003
> Baseline, no source changes:
>
> Mon Dec 10 17:45:19 UTC 2007 (revision 130746)
>
> Compilation flags:
>
> CCFLAGS := -g -O3 $(MACHINECPP) -ffast-math -fno-associative-math -
> march=native -mtune=native -ftree-vectorizer-verbose=2
> FCFLAGS := -g -O3 -fbacktrace -ffpe-trap=invalid,zero,overflow -
> ffast-math -fno-associative-math -march=native -mtune=native -ftree-
> vectorizer-verbose=2
>
> Loops vectorized:
> 5675
> Loops not vectorized:
> 13705
>
> Timings:
> 20061201_00/HL_Cycle_2006120100.html: FORECAST TOOK 12.7488 SECONDS
> 20061201_00/HL_Cycle_2006120100.html: FORECAST TOOK 2445.9609 SECONDS
> 20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 259.3362 SECONDS
> 20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 12.4408 SECONDS
> 20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 305.9351 SECONDS
> 20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 262.1124 SECONDS
> 20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 12.7448 SECONDS
> 20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 2323.3733 SECONDS
> 20061201_12r/HL_Cycle_2006120112r.html: FORECAST TOOK 412.7058 SECONDS
> 20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 264.5685 SECONDS
> 20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 12.6648 SECONDS
> 20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 306.7352 SECONDS
> 20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 261.5164 SECONDS
> 20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 12.7688 SECONDS
> 20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 2325.3774 SECONDS
> 20061202_00r/HL_Cycle_2006120200r.html: FORECAST TOOK 413.8739 SECONDS
>
> Baseline, no source changes, with -ftree-loop-linear:
>
> Mon Dec 10 17:45:19 UTC 2007 (revision 130746)
>
> Compilation flags:
>
> CCFLAGS := -g -O3 $(MACHINECPP) -ftree-loop-linear -ffast-math -fno-
> associative-math -march=native -mtune=native -ftree-vectorizer-verbose=2
> FCFLAGS := -g -O3 -ftree-loop-linear -fbacktrace -ffpe-trap=invalid,
> zero,overflow -ffast-math -fno-associative-math -march=native -
> mtune=native -ftree-vectorizer-verbose=2
>
> This compilation got one ICE:
>
> rttov_aitosu.f90: In function 'rttov_aitosu':
> rttov_aitosu.f90:4: error: definition in block 262 does not dominate
> use in block 134
> for SSA_NAME: pretmp.240_59 in statement:
> prephitmp.220_58 = PHI <pretmp.240_59(134), D.1480_1373(138)>
> PHI argument
> pretmp.240_59
> for PHI node
> prephitmp.220_58 = PHI <pretmp.240_59(134), D.1480_1373(138)>
> rttov_aitosu.f90:4: internal compiler error: verify_ssa failed
> Please submit a full bug report,
> with preprocessed source if appropriate.
> See <http://gcc.gnu.org/bugs.html> for instructions.
>
> Worked around by compiling this file without -ftree-loop-linear
>
> Loops vectorized:
> 5671
> Loops not vectorized:
> 13655
>
> Timings:
> 20061201_00/HL_Cycle_2006120100.html: FORECAST TOOK 12.5648 SECONDS
> 20061201_00/HL_Cycle_2006120100.html: FORECAST TOOK 2444.1208 SECONDS
> 20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 259.3402 SECONDS
> 20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 12.4728 SECONDS
> 20061201_06/HL_Cycle_2006120106.html: FORECAST TOOK 307.8672 SECONDS
> 20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 260.0323 SECONDS
> 20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 12.8608 SECONDS
> 20061201_12/HL_Cycle_2006120112.html: FORECAST TOOK 2310.2485 SECONDS
> 20061201_12r/HL_Cycle_2006120112r.html: FORECAST TOOK 411.3977 SECONDS
> 20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 261.1283 SECONDS
> 20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 12.7248 SECONDS
> 20061201_18/HL_Cycle_2006120118.html: FORECAST TOOK 308.1313 SECONDS
> 20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 262.7564 SECONDS
> 20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 12.6528 SECONDS
> 20061202_00/HL_Cycle_2006120200.html: FORECAST TOOK 2336.5620 SECONDS
> 20061202_00r/HL_Cycle_2006120200r.html: FORECAST TOOK 410.6577 SECONDS
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: HIRLAM and -ftree-loop-linear
2007-12-16 14:33 ` Dorit Nuzman
@ 2007-12-16 17:17 ` Toon Moene
2007-12-17 21:24 ` Toon Moene
1 sibling, 0 replies; 7+ messages in thread
From: Toon Moene @ 2007-12-16 17:17 UTC (permalink / raw)
To: Dorit Nuzman; +Cc: gcc mailing list, Sebastian Pop
Dorit Nuzman wrote:
> any chance you kept the dumps and can report which loops were not
> vectorized/recognized with -ftree-loop-linear (so we could see if these
> represent missed vectorization opportunities?)
I haven't, but it wouldn't be too much effort do this.
I'll try stage 1 tonight - i.e., to establish a base (with the latest
trunk check-out, not using -ftree-loop-linear), and then subsequently
using that flag.
Kind regards,
--
Toon Moene - e-mail: toon@moene.indiv.nluug.nl - phone: +31 346 214290
Saturnushof 14, 3738 XG Maartensdijk, The Netherlands
At home: http://moene.indiv.nluug.nl/~toon/
GNU Fortran's path to Fortran 2003: http://gcc.gnu.org/wiki/Fortran2003
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: HIRLAM and -ftree-loop-linear
2007-12-16 14:33 ` Dorit Nuzman
2007-12-16 17:17 ` Toon Moene
@ 2007-12-17 21:24 ` Toon Moene
2007-12-17 22:45 ` Toon Moene
1 sibling, 1 reply; 7+ messages in thread
From: Toon Moene @ 2007-12-17 21:24 UTC (permalink / raw)
To: Dorit Nuzman; +Cc: gcc mailing list, Sebastian Pop
[-- Attachment #1: Type: text/plain, Size: 856 bytes --]
Dorit Nuzman wrote:
> any chance you kept the dumps and can report which loops were not
> vectorized/recognized with -ftree-loop-linear (so we could see if these
> represent missed vectorization opportunities?)
It's a bit much to send you everything, so I'll just send you the diff +
two routines (from blas/lapack) that had differences (one positive, one
negative).
The sum total of 'LOOP VECTORIZED' messages:
$ wc -l vect.*
5651 vect.lin # -ftree-loop-linear
5673 vect.nolin # no -ftree-loop-linear
$ diff -cp vect.nolin vect.lin # attached
Hope this is useful,
--
Toon Moene - e-mail: toon@moene.indiv.nluug.nl - phone: +31 346 214290
Saturnushof 14, 3738 XG Maartensdijk, The Netherlands
At home: http://moene.indiv.nluug.nl/~toon/
GNU Fortran's path to Fortran 2003: http://gcc.gnu.org/wiki/Fortran2003
[-- Attachment #2: vect.diff --]
[-- Type: text/x-diff, Size: 12457 bytes --]
*** vect.nolin 2007-12-17 22:08:13.000000000 +0100
--- vect.lin 2007-12-17 22:05:06.000000000 +0100
*************** abgcri.f:147: note: LOOP VECTORIZED.
*** 2,8 ****
abgcri.f:159: note: LOOP VECTORIZED.
abgcri.f:170: note: LOOP VECTORIZED.
acconvad.f90:1076: note: LOOP VECTORIZED.
- acconvad.f90:1235: note: LOOP VECTORIZED.
acconvad.f90:1250: note: LOOP VECTORIZED.
acconvad.f90:1321: note: LOOP VECTORIZED.
acconvad.f90:1322: note: LOOP VECTORIZED.
--- 2,7 ----
*************** acconvad.f90:1368: note: LOOP VECTORIZED
*** 53,59 ****
acconvad.f90:1483: note: LOOP VECTORIZED.
acconvad.f90:2418: note: LOOP VECTORIZED.
acconvad.f90:2593: note: LOOP VECTORIZED.
- acconvad.f90:2719: note: LOOP VECTORIZED.
acconvad.f90:509: note: LOOP VECTORIZED.
acconvad.f90:784: note: LOOP VECTORIZED.
acconv.f90:355: note: LOOP VECTORIZED.
--- 52,57 ----
*************** bndrel.f:295: note: LOOP VECTORIZED.
*** 720,725 ****
--- 718,724 ----
bndrel.f:307: note: LOOP VECTORIZED.
bndrel.f:323: note: LOOP VECTORIZED.
bndrel.f:342: note: LOOP VECTORIZED.
+ b_obspace.f:1262: note: LOOP VECTORIZED.
b_obspace.f:1539: note: LOOP VECTORIZED.
b_obspace.f:1546: note: LOOP VECTORIZED.
b_obspace.f:815: note: LOOP VECTORIZED.
*************** bucomp.f:116: note: LOOP VECTORIZED.
*** 734,739 ****
--- 733,739 ----
bucomp.f:94: note: LOOP VECTORIZED.
bucrekey.f:90: note: LOOP VECTORIZED.
bucrekey.f:98: note: LOOP VECTORIZED.
+ bucrkey.f:95: note: LOOP VECTORIZED.
buedd.f:202: note: LOOP VECTORIZED.
buedd.f:215: note: LOOP VECTORIZED.
buedd.f:228: note: LOOP VECTORIZED.
*************** buepwt.f:170: note: LOOP VECTORIZED.
*** 756,761 ****
--- 756,763 ----
buepwt.f:184: note: LOOP VECTORIZED.
buepwt.f:255: note: LOOP VECTORIZED.
buepwt.f:270: note: LOOP VECTORIZED.
+ buetab.f:231: note: LOOP VECTORIZED.
+ buetab.f:246: note: LOOP VECTORIZED.
buetab.f:331: note: LOOP VECTORIZED.
buetab.f:336: note: LOOP VECTORIZED.
buetab.f:346: note: LOOP VECTORIZED.
*************** bufrsort.f90:879: note: LOOP VECTORIZED.
*** 807,812 ****
--- 809,816 ----
bufrsort_prepare.f90:197: note: LOOP VECTORIZED.
bufrthin.f:138: note: LOOP VECTORIZED.
bufr_traffic_info.f90:173: note: LOOP VECTORIZED.
+ bugbts.f:253: note: LOOP VECTORIZED.
+ bugbts.f:260: note: LOOP VECTORIZED.
bugbts.f:349: note: LOOP VECTORIZED.
bugbts.f:354: note: LOOP VECTORIZED.
bugbts.f:356: note: LOOP VECTORIZED.
*************** bustdr.f:120: note: LOOP VECTORIZED.
*** 863,868 ****
--- 867,873 ----
bustdr.f:133: note: LOOP VECTORIZED.
bustdr.f:149: note: LOOP VECTORIZED.
bustdr.f:164: note: LOOP VECTORIZED.
+ buta.f:261: note: LOOP VECTORIZED.
buta.f:470: note: LOOP VECTORIZED.
buta.f:476: note: LOOP VECTORIZED.
buta.f:672: note: LOOP VECTORIZED.
*************** cal_cov_multi.f:580: note: LOOP VECTORIZ
*** 904,910 ****
cal_cov_multi.f:941: note: LOOP VECTORIZED.
cal_cov_multi.f:942: note: LOOP VECTORIZED.
cal_cov_multi.f:943: note: LOOP VECTORIZED.
- cal_cov_multi.f:944: note: LOOP VECTORIZED.
cal_cov_multi.f:945: note: LOOP VECTORIZED.
cal_cov_multi.f:946: note: LOOP VECTORIZED.
cal_cov_multi.f:947: note: LOOP VECTORIZED.
--- 909,914 ----
*************** dgeev.f:6347: note: LOOP VECTORIZED.
*** 1337,1342 ****
--- 1341,1348 ----
dgeev.f:6391: note: LOOP VECTORIZED.
dgeev.f:6504: note: LOOP VECTORIZED.
dgeev.f:6525: note: LOOP VECTORIZED.
+ dgeev.f:6783: note: LOOP VECTORIZED.
+ dgeev.f:6822: note: LOOP VECTORIZED.
dgeev.f:772: note: LOOP VECTORIZED.
dgeev.f:843: note: LOOP VECTORIZED.
dgemm.f:231: note: LOOP VECTORIZED.
*************** extrob.f:390: note: LOOP VECTORIZED.
*** 1645,1652 ****
extrob.f:393: note: LOOP VECTORIZED.
extzer.f:132: note: LOOP VECTORIZED.
extzer.f:143: note: LOOP VECTORIZED.
- f02age.f:56: note: LOOP VECTORIZED.
- f02age.f:62: note: LOOP VECTORIZED.
fdvrfy.f:165: note: LOOP VECTORIZED.
fdvrfy.f:271: note: LOOP VECTORIZED.
fdvrfy.f:307: note: LOOP VECTORIZED.
--- 1651,1656 ----
*************** gemini_ad.f:739: note: LOOP VECTORIZED.
*** 1810,1815 ****
--- 1814,1820 ----
gemini_ad.f:812: note: LOOP VECTORIZED.
gemini.f:1317: note: LOOP VECTORIZED.
gemini.f:1647: note: LOOP VECTORIZED.
+ gemini.f:1664: note: LOOP VECTORIZED.
gemini.f:1884: note: LOOP VECTORIZED.
gemini.f:1923: note: LOOP VECTORIZED.
gemini.f:1943: note: LOOP VECTORIZED.
*************** gribiohixb.f:1849: note: LOOP VECTORIZED
*** 2023,2028 ****
--- 2028,2034 ----
gribiohixb.f:1926: note: LOOP VECTORIZED.
gribiohixb.f:231: note: LOOP VECTORIZED.
gribiohixb.f:2392: note: LOOP VECTORIZED.
+ grid2obspoints.f:95: note: LOOP VECTORIZED.
grid2obspointsfgat.f:129: note: LOOP VECTORIZED.
grid2obspointsfgat.f:249: note: LOOP VECTORIZED.
grid2obspointsfgat.f:307: note: LOOP VECTORIZED.
*************** mrtmsys.f:879: note: LOOP VECTORIZED.
*** 2778,2783 ****
--- 2784,2790 ----
mrtmsys.f:880: note: LOOP VECTORIZED.
mrtmsys.f:881: note: LOOP VECTORIZED.
mrtmsys.f:971: note: LOOP VECTORIZED.
+ mrtmsys.f:972: note: LOOP VECTORIZED.
mrtmsys.f:974: note: LOOP VECTORIZED.
mrtmsys.f:975: note: LOOP VECTORIZED.
mrtmsys.f:978: note: LOOP VECTORIZED.
*************** npsol.f:8203: note: LOOP VECTORIZED.
*** 3012,3018 ****
npsol.f:8328: note: LOOP VECTORIZED.
npsol.f:8333: note: LOOP VECTORIZED.
npsol.f:8540: note: LOOP VECTORIZED.
- npsol.f:8566: note: LOOP VECTORIZED.
npsol.f:8592: note: LOOP VECTORIZED.
npsol.f:8736: note: LOOP VECTORIZED.
npsol.f:8772: note: LOOP VECTORIZED.
--- 3019,3024 ----
*************** postpp.f:752: note: LOOP VECTORIZED.
*** 3353,3359 ****
postpp.f:790: note: LOOP VECTORIZED.
prcbuo.f:832: note: LOOP VECTORIZED.
prcshp.f:821: note: LOOP VECTORIZED.
- prcsyn.f:821: note: LOOP VECTORIZED.
precheck_cma.f90:152: note: LOOP VECTORIZED.
precip.f:56: note: LOOP VECTORIZED.
precond.f:355: note: LOOP VECTORIZED.
--- 3359,3364 ----
*************** prepare_scatt_work.f:714: note: LOOP VEC
*** 3408,3413 ****
--- 3413,3420 ----
prepare_seawinds_work.f:324: note: LOOP VECTORIZED.
prepare_ship_work.f:296: note: LOOP VECTORIZED.
prepare_ship_work.f:357: note: LOOP VECTORIZED.
+ prepare_ssmi_work.f:446: note: LOOP VECTORIZED.
+ prepare_ssmi_work.f:450: note: LOOP VECTORIZED.
prepare_synop_work.f:295: note: LOOP VECTORIZED.
prepare_synop_work.f:357: note: LOOP VECTORIZED.
prepare_temp_work.f:290: note: LOOP VECTORIZED.
*************** rttov_aitosu_ad.f90:492: note: LOOP VECT
*** 3908,3926 ****
rttov_aitosu_ad.f90:493: note: LOOP VECTORIZED.
rttov_aitosu_ad.f90:494: note: LOOP VECTORIZED.
rttov_aitosu_ad.f90:495: note: LOOP VECTORIZED.
- rttov_aitosu_ad.f90:603: note: LOOP VECTORIZED.
rttov_aitosu_ad.f90:608: note: LOOP VECTORIZED.
rttov_aitosu_ad.f90:609: note: LOOP VECTORIZED.
rttov_aitosu_ad.f90:610: note: LOOP VECTORIZED.
rttov_aitosu_ad.f90:611: note: LOOP VECTORIZED.
- rttov_aitosu.f90:132: note: LOOP VECTORIZED.
- rttov_aitosu.f90:133: note: LOOP VECTORIZED.
- rttov_aitosu.f90:134: note: LOOP VECTORIZED.
- rttov_aitosu.f90:136: note: LOOP VECTORIZED.
- rttov_aitosu.f90:189: note: LOOP VECTORIZED.
- rttov_aitosu.f90:190: note: LOOP VECTORIZED.
- rttov_aitosu.f90:191: note: LOOP VECTORIZED.
- rttov_aitosu.f90:193: note: LOOP VECTORIZED.
rttov_aitosu_tl.f90:182: note: LOOP VECTORIZED.
rttov_aitosu_tl.f90:183: note: LOOP VECTORIZED.
rttov_aitosu_tl.f90:184: note: LOOP VECTORIZED.
--- 3915,3924 ----
*************** rttov_integratesource_ad.f90:108: note:
*** 4187,4193 ****
rttov_integratesource_ad.f90:128: note: LOOP VECTORIZED.
rttov_integratesource_ad.f90:129: note: LOOP VECTORIZED.
rttov_integratesource_ad.f90:130: note: LOOP VECTORIZED.
- rttov_integratesource_ad.f90:131: note: LOOP VECTORIZED.
rttov_integratesource_ad.f90:132: note: LOOP VECTORIZED.
rttov_integratesource_ad.f90:133: note: LOOP VECTORIZED.
rttov_integratesource_ad.f90:134: note: LOOP VECTORIZED.
--- 4185,4190 ----
*************** rttov_intex_tl.f90:83: note: LOOP VECTOR
*** 4231,4236 ****
--- 4228,4234 ----
rttov_intext_prof.f90:156: note: LOOP VECTORIZED.
rttov_intext_prof.f90:186: note: LOOP VECTORIZED.
rttov_intext_prof.f90:192: note: LOOP VECTORIZED.
+ rttov_intext_prof.f90:251: note: LOOP VECTORIZED.
rttov_intext_prof.f90:253: note: LOOP VECTORIZED.
rttov_intext_prof.f90:259: note: LOOP VECTORIZED.
rttov_intext_prof.f90:273: note: LOOP VECTORIZED.
*************** rttov_k.f90:1096: note: LOOP VECTORIZED.
*** 4246,4257 ****
rttov_k.f90:1106: note: LOOP VECTORIZED.
rttov_k.f90:1123: note: LOOP VECTORIZED.
rttov_k.f90:1166: note: LOOP VECTORIZED.
- rttov_k.f90:1213: note: LOOP VECTORIZED.
- rttov_k.f90:1234: note: LOOP VECTORIZED.
- rttov_k.f90:1246: note: LOOP VECTORIZED.
- rttov_k.f90:1258: note: LOOP VECTORIZED.
- rttov_k.f90:1267: note: LOOP VECTORIZED.
- rttov_k.f90:1326: note: LOOP VECTORIZED.
rttov_k.f90:1381: note: LOOP VECTORIZED.
rttov_k.f90:1403: note: LOOP VECTORIZED.
rttov_k.f90:1413: note: LOOP VECTORIZED.
--- 4244,4249 ----
*************** signr.f:27: note: LOOP VECTORIZED.
*** 4647,4653 ****
simconv.f90:379: note: LOOP VECTORIZED.
simconv.f90:415: note: LOOP VECTORIZED.
simload.f90:216: note: LOOP VECTORIZED.
- simobs_diagnose.f:11: note: LOOP VECTORIZED.
sirhs.f:103: note: LOOP VECTORIZED.
sirhs.f:184: note: LOOP VECTORIZED.
sirhs.f:197: note: LOOP VECTORIZED.
--- 4639,4644 ----
*************** sposv.f:1197: note: LOOP VECTORIZED.
*** 4902,4924 ****
sposv.f:1202: note: LOOP VECTORIZED.
sposv.f:1204: note: LOOP VECTORIZED.
sposv.f:1210: note: LOOP VECTORIZED.
- sposv.f:1212: note: LOOP VECTORIZED.
sposv.f:1216: note: LOOP VECTORIZED.
- sposv.f:1218: note: LOOP VECTORIZED.
sposv.f:1223: note: LOOP VECTORIZED.
- sposv.f:1225: note: LOOP VECTORIZED.
sposv.f:1237: note: LOOP VECTORIZED.
- sposv.f:1239: note: LOOP VECTORIZED.
sposv.f:1244: note: LOOP VECTORIZED.
- sposv.f:1246: note: LOOP VECTORIZED.
sposv.f:1250: note: LOOP VECTORIZED.
- sposv.f:1252: note: LOOP VECTORIZED.
sposv.f:1259: note: LOOP VECTORIZED.
- sposv.f:1261: note: LOOP VECTORIZED.
sposv.f:1266: note: LOOP VECTORIZED.
- sposv.f:1268: note: LOOP VECTORIZED.
sposv.f:1272: note: LOOP VECTORIZED.
- sposv.f:1274: note: LOOP VECTORIZED.
sposv.f:792: note: LOOP VECTORIZED.
sposv.f:794: note: LOOP VECTORIZED.
sposv.f:798: note: LOOP VECTORIZED.
--- 4893,4906 ----
*************** ssyev.f:6339: note: LOOP VECTORIZED.
*** 5034,5050 ****
ssyev.f:6358: note: LOOP VECTORIZED.
ssyev.f:6358: note: LOOP VECTORIZED.
ssyev.f:635: note: LOOP VECTORIZED.
- ssyev.f:635: note: LOOP VECTORIZED.
ssyev.f:6363: note: LOOP VECTORIZED.
ssyev.f:6363: note: LOOP VECTORIZED.
ssyev.f:6408: note: LOOP VECTORIZED.
- ssyev.f:6408: note: LOOP VECTORIZED.
- ssyev.f:682: note: LOOP VECTORIZED.
ssyev.f:682: note: LOOP VECTORIZED.
ssyev.f:7075: note: LOOP VECTORIZED.
ssyev.f:7075: note: LOOP VECTORIZED.
ssyev.f:7338: note: LOOP VECTORIZED.
- ssyev.f:7338: note: LOOP VECTORIZED.
ssyev.f:7718: note: LOOP VECTORIZED.
ssyev.f:7718: note: LOOP VECTORIZED.
ssyev.f:7722: note: LOOP VECTORIZED.
--- 5016,5028 ----
*************** ssyev.f:9234: note: LOOP VECTORIZED.
*** 5094,5100 ****
ssyev.f:9243: note: LOOP VECTORIZED.
ssyev.f:9243: note: LOOP VECTORIZED.
ssyev.f:9426: note: LOOP VECTORIZED.
- ssyev.f:9426: note: LOOP VECTORIZED.
ssyev.f:953: note: LOOP VECTORIZED.
ssyev.f:953: note: LOOP VECTORIZED.
ssyev.f:959: note: LOOP VECTORIZED.
--- 5072,5077 ----
*************** stamic.f:1458: note: LOOP VECTORIZED.
*** 5150,5156 ****
stamic.f:1484: note: LOOP VECTORIZED.
stamic.f:1509: note: LOOP VECTORIZED.
stamic.f:1524: note: LOOP VECTORIZED.
- stamic.f:1537: note: LOOP VECTORIZED.
stamic.f:1563: note: LOOP VECTORIZED.
stamic.f:685: note: LOOP VECTORIZED.
stamic.f:757: note: LOOP VECTORIZED.
--- 5127,5132 ----
*************** syminv.f:207: note: LOOP VECTORIZED.
*** 5327,5336 ****
--- 5303,5314 ----
sync_timeslot_data.f90:326: note: LOOP VECTORIZED.
sync_timeslot_data.f90:341: note: LOOP VECTORIZED.
sync_timeslot_data.f90:434: note: LOOP VECTORIZED.
+ tables36.f:245: note: LOOP VECTORIZED.
tables36.f:437: note: LOOP VECTORIZED.
tables36.f:443: note: LOOP VECTORIZED.
tables36.f:642: note: LOOP VECTORIZED.
tables36.f:648: note: LOOP VECTORIZED.
+ tables.f:258: note: LOOP VECTORIZED.
tables.f:455: note: LOOP VECTORIZED.
tables.f:461: note: LOOP VECTORIZED.
tables.f:660: note: LOOP VECTORIZED.
[-- Attachment #3: sposv.f --]
[-- Type: text/plain, Size: 39774 bytes --]
SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* -- LAPACK driver routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. 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 SPOTF2( UPLO, N, A, LDA, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. 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 SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* March 31, 1993
*
* .. 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 SSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA,
$ BETA, C, LDC )
* .. Scalar Arguments ..
CHARACTER*1 UPLO, TRANS
INTEGER N, K, LDA, LDC
REAL ALPHA, BETA
* .. 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.
*
* Parameters
* ==========
*
* 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 ..
LOGICAL UPPER
INTEGER I, INFO, J, L, NROWA
REAL TEMP
* .. Parameters ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Executable Statements ..
*
* 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 STRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
$ B, LDB )
* .. Scalar Arguments ..
CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
INTEGER M, N, LDA, LDB
REAL ALPHA
* .. 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.
*
* Parameters
* ==========
*
* 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 ..
LOGICAL LSIDE, NOUNIT, UPPER
INTEGER I, INFO, J, K, NROWA
REAL TEMP
* .. Parameters ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Executable Statements ..
*
* 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
[-- Attachment #4: ssyev.f --]
[-- Type: text/plain, Size: 283213 bytes --]
INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
$ N4 )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. 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.
*
* 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
* = 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.
*
* 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.
*
* (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 )
*
* =====================================================================
*
* .. Local Scalars ..
LOGICAL CNAME, SNAME
CHARACTER*1 C1
CHARACTER*2 C2, C4
CHARACTER*3 C3
CHARACTER*6 SUBNAM
INTEGER I, IC, IZ, NB, NBMIN, NX
* ..
* .. Intrinsic Functions ..
INTRINSIC CHAR, ICHAR, INT, MIN, REAL
* ..
* .. Executable Statements ..
*
GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC
*
* Invalid value for ISPEC
*
ILAENV = -1
RETURN
*
100 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 10 I = 2, 6
IC = ICHAR( SUBNAM( I:I ) )
IF( IC.GE.97 .AND. IC.LE.122 )
$ SUBNAM( I:I ) = CHAR( IC-32 )
10 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 20 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 )
20 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 30 I = 2, 6
IC = ICHAR( SUBNAM( I:I ) )
IF( IC.GE.225 .AND. IC.LE.250 )
$ SUBNAM( I:I ) = CHAR( IC-32 )
30 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 ( 110, 200, 300 ) ISPEC
*
110 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 = 1
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 = 1
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
*
200 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
*
300 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 = 1
END IF
ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
IF( C3.EQ.'TRD' ) THEN
NX = 1
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
*
400 CONTINUE
*
* ISPEC = 4: number of shifts (used by xHSEQR)
*
ILAENV = 6
RETURN
*
500 CONTINUE
*
* ISPEC = 5: minimum column dimension (not used)
*
ILAENV = 2
RETURN
*
600 CONTINUE
*
* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
*
ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
RETURN
*
700 CONTINUE
*
* ISPEC = 7: number of processors (not used)
*
ILAENV = 1
RETURN
*
800 CONTINUE
*
* ISPEC = 8: crossover point for multishift (used by xHSEQR)
*
ILAENV = 50
RETURN
*
* End of ILAENV
*
END
LOGICAL FUNCTION LSAME( CA, CB )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. 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
subroutine saxpy(n,sa,sx,incx,sy,incy)
c
c constant times a vector plus a vector.
c uses unrolled loop for increments equal to one.
c jack dongarra, linpack, 3/11/78.
c modified 12/3/93, array(1) declarations changed to array(*)
c
real sx(*),sy(*),sa
integer i,incx,incy,ix,iy,m,mp1,n
c
if(n.le.0)return
if (sa .eq. 0.0) return
if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments
c not equal to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
sy(iy) = sy(iy) + sa*sx(ix)
ix = ix + incx
iy = iy + incy
10 continue
return
c
c code for both increments equal to 1
c
c
c clean-up loop
c
20 m = mod(n,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)
c
c copies a vector, x, to a vector, y.
c uses unrolled loops for increments equal to 1.
c jack dongarra, linpack, 3/11/78.
c modified 12/3/93, array(1) declarations changed to array(*)
c
real sx(*),sy(*)
integer i,incx,incy,ix,iy,m,mp1,n
c
if(n.le.0)return
if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments
c not equal to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
sy(iy) = sx(ix)
ix = ix + incx
iy = iy + incy
10 continue
return
c
c code for both increments equal to 1
c
c
c clean-up loop
c
20 m = mod(n,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)
c
c forms the dot product of two vectors.
c uses unrolled loops for increments equal to one.
c jack dongarra, linpack, 3/11/78.
c modified 12/3/93, array(1) declarations changed to array(*)
c
real sx(*),sy(*),stemp
integer i,incx,incy,ix,iy,m,mp1,n
c
stemp = 0.0e0
sdot = 0.0e0
if(n.le.0)return
if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments
c not equal to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
stemp = stemp + sx(ix)*sy(iy)
ix = ix + incx
iy = iy + incy
10 continue
sdot = stemp
return
c
c code for both increments equal to 1
c
c
c clean-up loop
c
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
SUBROUTINE SGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,
$ BETA, C, LDC )
* .. Scalar Arguments ..
CHARACTER*1 TRANSA, TRANSB
INTEGER M, N, K, LDA, LDB, LDC
REAL ALPHA, BETA
* .. 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.
*
* Parameters
* ==========
*
* 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 ..
LOGICAL NOTA, NOTB
INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB
REAL TEMP
* .. Parameters ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Executable Statements ..
*
* 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*1 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.
*
* Parameters
* ==========
*
* 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
* ..
* .. Executable Statements ..
*
* 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.
*
* Parameters
* ==========
*
* 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
* ..
* .. 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( 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
SUBROUTINE SLAE2( A, B, C, RT1, RT2 )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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 SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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
REAL FUNCTION SLAMCH( CMACH )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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
FIRST = .FALSE.
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
RETURN
*
* End of SLAMCH
*
END
*
************************************************************************
*
SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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
FIRST = .FALSE.
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
RETURN
*
* End of SLAMC1
*
END
*
************************************************************************
*
SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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
FIRST = .FALSE.
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
***
* 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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, 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
INTEGER BASE, EMIN
REAL START
* ..
*
* Purpose
* =======
*
* SLAMC4 is a service routine for SLAMC2.
*
* Arguments
* =========
*
* EMIN (output) EMIN
* 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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
REAL FUNCTION SLANST( NORM, N, D, E )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. 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 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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 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 (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 SLAPY2( X, Y )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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
SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. 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 SLARTG( F, G, CS, SN, R )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. 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.
*
* =====================================================================
*
* .. 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
FIRST = .FALSE.
SAFMIN = SLAMCH( 'S' )
EPS = SLAMCH( 'E' )
SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
$ LOG( SLAMCH( 'B' ) ) / TWO )
SAFMX2 = ONE / SAFMN2
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 SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* February 29, 1992
*
* .. 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,M)
* 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 SLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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 SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. Scalar Arguments ..
CHARACTER DIRECT, PIVOT, SIDE
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), C( * ), S( * )
* ..
*
* Purpose
* =======
*
* SLASR performs the transformation
*
* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side )
*
* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side )
*
* where A is an m by n real matrix and P is an orthogonal matrix,
* consisting of a sequence of plane rotations determined by the
* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
* and z = n when SIDE = 'R' or 'r' ):
*
* When DIRECT = 'F' or 'f' ( Forward sequence ) then
*
* P = P( z - 1 )*...*P( 2 )*P( 1 ),
*
* and when DIRECT = 'B' or 'b' ( Backward sequence ) then
*
* P = P( 1 )*P( 2 )*...*P( z - 1 ),
*
* where P( k ) is a plane rotation matrix for the following planes:
*
* when PIVOT = 'V' or 'v' ( Variable pivot ),
* the plane ( k, k + 1 )
*
* when PIVOT = 'T' or 't' ( Top pivot ),
* the plane ( 1, k + 1 )
*
* when PIVOT = 'B' or 'b' ( Bottom pivot ),
* the plane ( k, z )
*
* c( k ) and s( k ) must contain the cosine and sine that define the
* matrix P( k ). The two by two plane rotation part of the matrix
* P( k ), R( k ), is assumed to be of the form
*
* R( k ) = ( c( k ) s( k ) ).
* ( -s( k ) c( k ) )
*
* This version vectorises across rows of the array A when SIDE = 'L'.
*
* 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'
*
* 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 )
*
* 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)
*
* 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, S (input) REAL arrays, dimension
* (M-1) if SIDE = 'L'
* (N-1) if SIDE = 'R'
* c(k) and s(k) contain the cosine and sine that define the
* matrix P(k). The two by two plane rotation part of the
* matrix P(k), R(k), is assumed to be of 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' 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. 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 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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
* 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 SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
*
* -- LAPACK auxiliary routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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
* 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
REAL FUNCTION SNRM2 ( N, X, INCX )
* .. Scalar Arguments ..
INTEGER INCX, N
* .. Array Arguments ..
REAL X( * )
* ..
*
* SNRM2 returns the euclidean norm of a vector via the function
* name, so that
*
* SNRM2 := sqrt( x'*x )
*
*
*
* -- 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 ..
INTEGER IX
REAL ABSXI, NORM, SCALE, SSQ
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
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 SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK routine (version 2.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, 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 2.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, 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 SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 2.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, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* 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 (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.
*
* 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 ..
INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, 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
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 ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGQL', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Determine the block size.
*
NB = ILAENV( 1, 'SORGQL', ' ', M, N, K, -1 )
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 2.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, K, LDA, LWORK, M, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* 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 (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.
*
* 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 ..
INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, 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
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 ) ) THEN
INFO = -8
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGQR', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Determine the block size.
*
NB = ILAENV( 1, 'SORGQR', ' ', M, N, K, -1 )
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 SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER INFO, LDA, LWORK, N
* ..
* .. Array Arguments ..
REAL A( LDA, * ), TAU( * ), WORK( LWORK )
* ..
*
* 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 (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.
*
* 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, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL SORGQL, SORGQR, 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( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( LWORK.LT.MAX( 1, N-1 ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SORGTR', -INFO )
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
RETURN
*
* End of SORGTR
*
END
subroutine sscal(n,sa,sx,incx)
c
c scales a vector by a constant.
c uses unrolled loops for increment equal to 1.
c jack dongarra, linpack, 3/11/78.
c modified 3/93 to return if incx .le. 0.
c modified 12/3/93, array(1) declarations changed to array(*)
c
real sa,sx(*)
integer i,incx,m,mp1,n,nincx
c
if( n.le.0 .or. incx.le.0 )return
if(incx.eq.1)go to 20
c
c code for increment not equal to 1
c
nincx = n*incx
do 10 i = 1,nincx,incx
sx(i) = sa*sx(i)
10 continue
return
c
c code for increment equal to 1
c
c
c clean-up loop
c
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 SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
*
* -- LAPACK routine (version 2.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, * )
* ..
*
* 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 2.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, 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, LENDM1, LENDP1,
$ LENDSV, LM1, LSV, M, MM1, NM1, NMAXIT
REAL ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
$ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
$ SIGMA, SSFMAX, SSFMIN, TST
* ..
* .. 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
NM1 = N - 1
*
10 CONTINUE
IF( L1.GT.N )
$ GO TO 170
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.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
LENDM1 = LEND - 1
DO 60 M = L, LENDM1
TST = ABS( E( M ) )
IF( TST.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
*
MM1 = M - 1
DO 80 I = MM1, 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
IF( L.NE.LEND ) THEN
LENDP1 = LEND + 1
DO 110 M = L, LENDP1, -1
TST = ABS( E( M-1 ) )
IF( TST.LE. EPS2*ABS( D( M ) * D( M-1 ) ) )GO TO 120
110 CONTINUE
END IF
*
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
*
LM1 = L - 1
DO 130 I = M, LM1
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( LM1 ) = 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.EQ.NMAXIT ) THEN
DO 160 I = 1, N - 1
IF( E( I ).NE.ZERO )
$ INFO = INFO + 1
160 CONTINUE
RETURN
END IF
GO TO 10
*
* Sort eigenvalues in increasing order.
*
170 CONTINUE
CALL SLASRT( 'I', N, D, INFO )
*
RETURN
*
* End of SSTERF
*
END
subroutine sswap (n,sx,incx,sy,incy)
c
c interchanges two vectors.
c uses unrolled loops for increments equal to 1.
c jack dongarra, linpack, 3/11/78.
c modified 12/3/93, array(1) declarations changed to array(*)
c
real sx(*),sy(*),stemp
integer i,incx,incy,ix,iy,m,mp1,n
c
if(n.le.0)return
if(incx.eq.1.and.incy.eq.1)go to 20
c
c code for unequal increments or equal increments not equal
c to 1
c
ix = 1
iy = 1
if(incx.lt.0)ix = (-n+1)*incx + 1
if(incy.lt.0)iy = (-n+1)*incy + 1
do 10 i = 1,n
stemp = sx(ix)
sx(ix) = sy(iy)
sy(iy) = stemp
ix = ix + incx
iy = iy + incy
10 continue
return
c
c code for both increments equal to 1
c
c
c clean-up loop
c
20 m = mod(n,3)
if( m .eq. 0 ) go to 40
do 30 i = 1,m
stemp = sx(i)
sx(i) = sy(i)
sy(i) = stemp
30 continue
if( n .lt. 3 ) return
40 mp1 = m + 1
do 50 i = mp1,n,3
stemp = sx(i)
sx(i) = sy(i)
sy(i) = stemp
stemp = sx(i + 1)
sx(i + 1) = sy(i + 1)
sy(i + 1) = stemp
stemp = sx(i + 2)
sx(i + 2) = sy(i + 2)
sy(i + 2) = stemp
50 continue
return
end
SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. 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 (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.
*
* 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, INDTAU, INDWRK, ISCALE,
$ LLWORK, LOPT
REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
$ SMLNUM
* ..
* .. External Functions ..
LOGICAL LSAME
REAL SLAMCH, SLANSY
EXTERNAL 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' )
*
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
ELSE IF( LWORK.LT.MAX( 1, 3*N-1 ) ) THEN
INFO = -8
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYEV ', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
IF( N.EQ.1 ) THEN
W( 1 ) = A( 1, 1 )
WORK( 1 ) = 3
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 )
LOPT = 2*N + WORK( INDWRK )
*
* 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 ) = MAX( 3*N-1, LOPT )
*
RETURN
*
* End of SSYEV
*
END
SUBROUTINE SSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX,
$ BETA, Y, INCY )
* .. Scalar Arguments ..
REAL ALPHA, BETA
INTEGER INCX, INCY, LDA, N
CHARACTER*1 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.
*
* Parameters
* ==========
*
* 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
* ..
* .. 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 = 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 SSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA )
* .. Scalar Arguments ..
REAL ALPHA
INTEGER INCX, INCY, LDA, N
CHARACTER*1 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.
*
* Parameters
* ==========
*
* 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
* ..
* .. 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( 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 ..
CHARACTER*1 UPLO, TRANS
INTEGER N, K, LDA, LDB, LDC
REAL ALPHA, BETA
* .. 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.
*
* Parameters
* ==========
*
* 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 ..
LOGICAL UPPER
INTEGER I, INFO, J, L, NROWA
REAL TEMP1, TEMP2
* .. Parameters ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Executable Statements ..
*
* 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 SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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 SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 2.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* September 30, 1994
*
* .. 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 (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.
*
* 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.0 )
* ..
* .. Local Scalars ..
LOGICAL UPPER
INTEGER I, IINFO, IWS, J, KK, LDWORK, 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' )
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 ) THEN
INFO = -9
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SSYTRD', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.EQ.0 ) THEN
WORK( 1 ) = 1
RETURN
END IF
*
* Determine the block size.
*
NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
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 ) = IWS
RETURN
*
* End of SSYTRD
*
END
SUBROUTINE STRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA,
$ B, LDB )
* .. Scalar Arguments ..
CHARACTER*1 SIDE, UPLO, TRANSA, DIAG
INTEGER M, N, LDA, LDB
REAL ALPHA
* .. 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'.
*
* Parameters
* ==========
*
* 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 ..
LOGICAL LSIDE, NOUNIT, UPPER
INTEGER I, INFO, J, K, NROWA
REAL TEMP
* .. Parameters ..
REAL ONE , ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Executable Statements ..
*
* 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*B*A'.
*
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*1 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.
*
* Parameters
* ==========
*
* 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
* ..
* .. 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( 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 XERBLA( SRNAME, INFO )
*
* -- LAPACK auxiliary routine (version 2.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 SRNAME
INTEGER INFO
* ..
*
* Purpose
* =======
*
* XERBLA is an error handler for the LAPACK routines.
* It is called by an LAPACK routine if an input parameter has an
* invalid value. A message is printed and execution stops.
*
* Installers may consider modifying the STOP statement in order to
* call system-specific exception-handling facilities.
*
* Arguments
* =========
*
* SRNAME (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.
*
* =====================================================================
*
* .. Executable Statements ..
*
WRITE( *, FMT = 9999 )SRNAME, INFO
*
STOP
*
9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ',
$ 'an illegal value' )
*
* End of XERBLA
*
END
^ permalink raw reply [flat|nested] 7+ messages in thread
* Re: HIRLAM and -ftree-loop-linear
2007-12-17 21:24 ` Toon Moene
@ 2007-12-17 22:45 ` Toon Moene
0 siblings, 0 replies; 7+ messages in thread
From: Toon Moene @ 2007-12-17 22:45 UTC (permalink / raw)
To: Dorit Nuzman; +Cc: gcc mailing list, Sebastian Pop
[-- Attachment #1: Type: text/plain, Size: 740 bytes --]
I wrote:
> Dorit Nuzman wrote:
>
>> any chance you kept the dumps and can report which loops were not
>> vectorized/recognized with -ftree-loop-linear (so we could see if these
>> represent missed vectorization opportunities?)
>
> It's a bit much to send you everything, so I'll just send you the diff +
> two routines (from blas/lapack) that had differences (one positive, one
> negative).
Sigh, dgeev.f is the positive one (i.e., -ftree-loop-linear vectorized
more loops - attached).
--
Toon Moene - e-mail: toon@moene.indiv.nluug.nl - phone: +31 346 214290
Saturnushof 14, 3738 XG Maartensdijk, The Netherlands
At home: http://moene.indiv.nluug.nl/~toon/
GNU Fortran's path to Fortran 2003: http://gcc.gnu.org/wiki/Fortran2003
[-- Attachment #2: dgeev.f --]
[-- Type: text/plain, Size: 215139 bytes --]
SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
$ LDVR, WORK, LWORK, INFO )
*
* -- LAPACK driver routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* December 8, 1999
*
* .. 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 (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,
$ MAXB, 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, 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, MIN, 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.)
*
MINWRK = 1
IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
MINWRK = MAX( 1, 3*N )
MAXB = MAX( ILAENV( 8, 'DHSEQR', 'EN', N, 1, N, -1 ), 2 )
K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'EN', N, 1,
$ N, -1 ) ) )
HSWORK = MAX( K*( K+2 ), 2*N )
MAXWRK = MAX( MAXWRK, N+1, N+HSWORK )
ELSE
MINWRK = MAX( 1, 4*N )
MAXWRK = MAX( MAXWRK, 2*N+( N-1 )*
$ ILAENV( 1, 'DORGHR', ' ', N, 1, N, -1 ) )
MAXB = MAX( ILAENV( 8, 'DHSEQR', 'SV', N, 1, N, -1 ), 2 )
K = MIN( MAXB, N, MAX( 2, ILAENV( 4, 'DHSEQR', 'SV', N, 1,
$ N, -1 ) ) )
HSWORK = MAX( K*( K+2 ), 2*N )
MAXWRK = MAX( MAXWRK, N+1, N+HSWORK )
MAXWRK = MAX( MAXWRK, 4*N )
END IF
WORK( 1 ) = MAXWRK
END IF
IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
INFO = -13
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 DLABAD( SMALL, LARGE )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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
DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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 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 (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
SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
*
* -- LAPACK 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 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 = 0.8D+1 )
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 DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK 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 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).
*
* =====================================================================
*
* .. 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, LDWORK, LWKOPT, NB, NBMIN,
$ NH, NX
DOUBLE PRECISION EI
* ..
* .. Local Arrays ..
DOUBLE PRECISION T( LDT, NBMAX )
* ..
* .. External Subroutines ..
EXTERNAL DGEHD2, DGEMM, DLAHRD, DLARFB, 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 30 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 DLAHRD( 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(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 )
30 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 DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
$ LDZ, WORK, LWORK, INFO )
*
* -- LAPACK 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 COMPZ, JOB
INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
$ Z( LDZ, * )
* ..
*
* 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, 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, 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 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 )
$ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 70
60 CONTINUE
70 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 <= 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
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
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
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 )
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 )
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 )
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 )
*
IF( WANTZ ) THEN
*
* Accumulate transformations in the matrix Z
*
CALL DLARFX( 'Right', NH, NR, V, TAU, Z( ILO, K ), LDZ,
$ WORK )
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
WORK( 1 ) = MAX( 1, N )
RETURN
*
* End of DHSEQR
*
END
SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
$ LDVR, MM, M, WORK, INFO )
*
* -- LAPACK 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 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.
*
* 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, 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.
*
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 )
*
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 DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
$ INFO )
*
* -- LAPACK 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 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 DLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- 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 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 DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
*
* -- 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 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 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.
*
* 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 DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
$ ILOZ, IHIZ, Z, LDZ, INFO )
*
* -- 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 ..
LOGICAL WANTT, WANTZ
INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
* ..
* .. 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 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, 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, DLANV2, DLARFG, DROT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SIGN, 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
*
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 )
$ TST1 = DLANHS( '1', I-L+1, H( L, L ), LDH, WORK )
IF( ABS( H( K, K-1 ) ).LE.MAX( ULP*TST1, SMLNUM ) )
$ GO TO 30
20 CONTINUE
30 CONTINUE
L = K
IF( L.GT.ILO ) THEN
*
* 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
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
IF( DISC.GT.ZERO ) THEN
*
* Real roots: use Wilkinson's shift twice
*
DISC = SQRT( DISC )
AVE = HALF*( H33+H44 )
IF( ABS( H33 )-ABS( H44 ).GT.ZERO ) THEN
H33 = H33*H44 - H43H34
H44 = H33 / ( SIGN( DISC, AVE )+AVE )
ELSE
H44 = SIGN( DISC, AVE ) + AVE
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
*
* 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 )
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
*
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
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
*
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
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 )
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
*
* 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
RETURN
*
* End of DLAHQR
*
END
SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* -- 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
*
* .. 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 DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
*
* -- 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 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
DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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 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 (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
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.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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 DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
*
* -- LAPACK driver 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 ..
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 DLADIV( A, B, C, D, P, Q )
*
* -- LAPACK auxiliary routine (version 3.0) --
* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
* Courant Institute, Argonne National Lab, and Rice University
* October 31, 1992
*
* .. 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 DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK 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 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 (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 DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
$ T, LDT, C, LDC, WORK, LDWORK )
*
* -- 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 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 DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, 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, 1992
*
* .. 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 DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
*
* -- LAPACK 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 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 (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 DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK 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, 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 DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- 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 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 DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
*
* -- 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 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
^ permalink raw reply [flat|nested] 7+ messages in thread
end of thread, other threads:[~2007-12-17 21:24 UTC | newest]
Thread overview: 7+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2007-12-14 22:30 HIRLAM and -ftree-loop-linear Toon Moene
2007-12-15 22:55 ` Sebastian Pop
2007-12-16 14:15 ` Toon Moene
2007-12-16 14:33 ` Dorit Nuzman
2007-12-16 17:17 ` Toon Moene
2007-12-17 21:24 ` Toon Moene
2007-12-17 22:45 ` Toon Moene
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).