PLASMA  2.4.5
PLASMA - Parallel Linear Algebra for Scalable Multi-core Architectures
 All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros Groups
derrvx.f
Go to the documentation of this file.
1  SUBROUTINE derrvx( PATH, NUNIT )
2 *
3  include 'plasmaf.h'
4 *
5 * -- LAPACK test routine (version 3.1.1) --
6 * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
7 * January 2007
8 *
9 * .. Scalar Arguments ..
10  CHARACTER*3 path
11  INTEGER nunit
12 * ..
13 *
14 * Purpose
15 * =======
16 *
17 * DERRVX tests the error exits for the DOUBLE PRECISION driver routines
18 * for solving linear systems of equations.
19 *
20 * Arguments
21 * =========
22 *
23 * PATH (input) CHARACTER*3
24 * The LAPACK path name for the routines to be tested.
25 *
26 * NUNIT (input) INTEGER
27 * The unit number for output.
28 *
29 * =====================================================================
30 *
31 * .. Parameters ..
32  INTEGER nmax
33  parameter( nmax = 4 )
34 * ..
35 * .. Local Scalars ..
36  CHARACTER eq
37  CHARACTER*2 c2
38  INTEGER i, info, j
39  DOUBLE PRECISION rcond
40 * ..
41 * .. Local Arrays ..
42  INTEGER hl( 2 ), hpiv( 2 )
43  INTEGER ip( nmax ), iw( nmax )
44  DOUBLE PRECISION a( nmax, nmax ), af( nmax, nmax ), b( nmax ),
45  $ c( nmax ), r( nmax ), r1( nmax ), r2( nmax ),
46  $ w( 2*nmax ), x( nmax )
47 * ..
48 * .. External Functions ..
49  LOGICAL lsamen
50  EXTERNAL lsamen
51 * ..
52 * .. External Subroutines ..
53  EXTERNAL chkxer, dgbsv, dgbsvx, dgesv, dgesvx, dgtsv,
54  $ dgtsvx, dpbsv, dpbsvx, dposv, dposvx, dppsv,
55  $ dppsvx, dptsv, dptsvx, dspsv, dspsvx, dsysv,
56  $ dsysvx
57 * ..
58 * .. Scalars in Common ..
59  LOGICAL lerr, ok
60  CHARACTER*32 srnamt
61  INTEGER infot, nout
62 * ..
63 * .. Common blocks ..
64  common / infoc / infot, nout, ok, lerr
65  common / srnamc / srnamt
66 * ..
67 * .. Intrinsic Functions ..
68  INTRINSIC dble
69 * ..
70 * .. Executable Statements ..
71 *
72  nout = nunit
73  WRITE( nout, fmt = * )
74  c2 = path( 2: 3 )
75 *
76 * Disable PLASMA warnings/errors
77 *
78  CALL plasma_disable( plasma_warnings, info )
79  CALL plasma_disable( plasma_errors, info )
80 *
81 * Set the variables to innocuous values.
82 *
83  DO 20 j = 1, nmax
84  DO 10 i = 1, nmax
85  a( i, j ) = 1.d0 / dble( i+j )
86  af( i, j ) = 1.d0 / dble( i+j )
87  10 continue
88  b( j ) = 0.d0
89  r1( j ) = 0.d0
90  r2( j ) = 0.d0
91  w( j ) = 0.d0
92  x( j ) = 0.d0
93  c( j ) = 0.d0
94  r( j ) = 0.d0
95  ip( j ) = j
96  20 continue
97  eq = ' '
98  ok = .true.
99 *
100  IF( lsamen( 2, c2, 'GE' ) ) THEN
101 *
102 * ALLOCATE HL and HPIV
103 *
104  CALL plasma_alloc_workspace_dgetrf_incpiv(
105  $ 2, 1, hl, hpiv, info )
106 *
107 * PLASMA_DGESV
108 *
109  srnamt = 'DGESV '
110  infot = 1
111  CALL plasma_dgesv_incpiv( -1, 0, a, 1, hl, hpiv, b, 1, info )
112  CALL chkxer( 'DGESV ', infot, nout, info, ok )
113  infot = 2
114  CALL plasma_dgesv_incpiv( 0, -1, a, 1, hl, hpiv, b, 1, info )
115  CALL chkxer( 'DGESV ', infot, nout, info, ok )
116  infot = 4
117  CALL plasma_dgesv_incpiv( 2, 1, a, 1, hl, hpiv, b, 2, info )
118  CALL chkxer( 'DGESV ', infot, nout, info, ok )
119  infot = 8
120  CALL plasma_dgesv_incpiv( 2, 1, a, 2, hl, hpiv, b, 1, info )
121  CALL chkxer( 'DGESV ', infot, nout, info, ok )
122 *
123 * DEALLOCATE HL and HPIV
124 *
125  CALL plasma_dealloc_handle( hl, info )
126  CALL plasma_dealloc_handle( hpiv, info )
127 *
128 *
129 * DGESV
130 *
131  srnamt = 'DGESV '
132  infot = 1
133  CALL plasma_dgesv( -1, 0, a, 1, iwork, b, 1, info )
134  CALL chkxer( 'DGESV ', infot, nout, info, ok )
135  infot = 2
136  CALL plasma_dgesv( 0, -1, a, 1, iwork, b, 1, info )
137  CALL chkxer( 'DGESV ', infot, nout, info, ok )
138  infot = 4
139  CALL plasma_dgesv( 2, 1, a, 1, iwork, b, 2, info )
140  CALL chkxer( 'DGESV ', infot, nout, info, ok )
141  infot = 8
142  CALL plasma_dgesv( 2, 1, a, 2, iwork, b, 1, info )
143  CALL chkxer( 'DGESV ', infot, nout, info, ok )
144 *
145  ELSE IF( lsamen( 2, c2, 'PO' ) ) THEN
146 *
147 * DPOSV
148 *
149  srnamt = 'DPOSV '
150  infot = 1
151  CALL plasma_dposv( '/', 0, 0, a, 1, b, 1, info )
152  CALL chkxer( 'DPOSV ', infot, nout, info, ok )
153  infot = 2
154  CALL plasma_dposv( plasmaupper, -1, 0, a, 1, b, 1, info )
155  CALL chkxer( 'DPOSV ', infot, nout, info, ok )
156  infot = 3
157  CALL plasma_dposv( plasmaupper, 0, -1, a, 1, b, 1, info )
158  CALL chkxer( 'DPOSV ', infot, nout, info, ok )
159  infot = 5
160  CALL plasma_dposv( plasmaupper, 2, 0, a, 1, b, 2, info )
161  CALL chkxer( 'DPOSV ', infot, nout, info, ok )
162  infot = 7
163  CALL plasma_dposv( plasmaupper, 2, 0, a, 2, b, 1, info )
164  CALL chkxer( 'DPOSV ', infot, nout, info, ok )
165 *
166 * DPOSVX
167 *
168  srnamt = 'DPOSVX'
169  infot = 1
170  CALL dposvx( '/', 'U', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
171  $ rcond, r1, r2, w, iw, info )
172  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
173  infot = 2
174  CALL dposvx( 'N', '/', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
175  $ rcond, r1, r2, w, iw, info )
176  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
177  infot = 3
178  CALL dposvx( 'N', 'U', -1, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
179  $ rcond, r1, r2, w, iw, info )
180  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
181  infot = 4
182  CALL dposvx( 'N', 'U', 0, -1, a, 1, af, 1, eq, c, b, 1, x, 1,
183  $ rcond, r1, r2, w, iw, info )
184  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
185  infot = 6
186  CALL dposvx( 'N', 'U', 2, 0, a, 1, af, 2, eq, c, b, 2, x, 2,
187  $ rcond, r1, r2, w, iw, info )
188  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
189  infot = 8
190  CALL dposvx( 'N', 'U', 2, 0, a, 2, af, 1, eq, c, b, 2, x, 2,
191  $ rcond, r1, r2, w, iw, info )
192  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
193  infot = 9
194  eq = '/'
195  CALL dposvx( 'F', 'U', 0, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
196  $ rcond, r1, r2, w, iw, info )
197  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
198  infot = 10
199  eq = 'Y'
200  CALL dposvx( 'F', 'U', 1, 0, a, 1, af, 1, eq, c, b, 1, x, 1,
201  $ rcond, r1, r2, w, iw, info )
202  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
203  infot = 12
204  CALL dposvx( 'N', 'U', 2, 0, a, 2, af, 2, eq, c, b, 1, x, 2,
205  $ rcond, r1, r2, w, iw, info )
206  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
207  infot = 14
208  CALL dposvx( 'N', 'U', 2, 0, a, 2, af, 2, eq, c, b, 2, x, 1,
209  $ rcond, r1, r2, w, iw, info )
210  CALL chkxer( 'DPOSVX', infot, nout, info, ok )
211  END IF
212 *
213 * Print a summary line.
214 *
215  IF( ok ) THEN
216  WRITE( nout, fmt = 9999 )path
217  ELSE
218  WRITE( nout, fmt = 9998 )path
219  END IF
220 *
221  9999 format( 1x, a3, ' drivers passed the tests of the error exits' )
222  9998 format( ' *** ', a3, ' drivers failed the tests of the error ',
223  $ 'exits ***' )
224 *
225 * Enable PLASMA warnings/errors
226 *
227  CALL plasma_enable( plasma_warnings, info )
228  CALL plasma_enable( plasma_errors, info )
229 *
230  return
231 *
232 * End of DERRVX
233 *
234  END