1*> \brief \b ZDRVRF4
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*  Definition:
9*  ===========
10*
11*       SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
12*      +                    LDA, D_WORK_ZLANGE )
13*
14*       .. Scalar Arguments ..
15*       INTEGER            LDA, LDC, NN, NOUT
16*       DOUBLE PRECISION   THRESH
17*       ..
18*       .. Array Arguments ..
19*       INTEGER            NVAL( NN )
20*       DOUBLE PRECISION   D_WORK_ZLANGE( * )
21*       COMPLEX*16         A( LDA, * ), C1( LDC, * ), C2( LDC, *),
22*      +                   CRF( * )
23*       ..
24*
25*
26*> \par Purpose:
27*  =============
28*>
29*> \verbatim
30*>
31*> ZDRVRF4 tests the LAPACK RFP routines:
32*>     ZHFRK
33*> \endverbatim
34*
35*  Arguments:
36*  ==========
37*
38*> \param[in] NOUT
39*> \verbatim
40*>          NOUT is INTEGER
41*>                The unit number for output.
42*> \endverbatim
43*>
44*> \param[in] NN
45*> \verbatim
46*>          NN is INTEGER
47*>                The number of values of N contained in the vector NVAL.
48*> \endverbatim
49*>
50*> \param[in] NVAL
51*> \verbatim
52*>          NVAL is INTEGER array, dimension (NN)
53*>                The values of the matrix dimension N.
54*> \endverbatim
55*>
56*> \param[in] THRESH
57*> \verbatim
58*>          THRESH is DOUBLE PRECISION
59*>                The threshold value for the test ratios.  A result is
60*>                included in the output file if RESULT >= THRESH.  To have
61*>                every test ratio printed, use THRESH = 0.
62*> \endverbatim
63*>
64*> \param[out] C1
65*> \verbatim
66*>          C1 is COMPLEX*16 array, dimension (LDC,NMAX)
67*> \endverbatim
68*>
69*> \param[out] C2
70*> \verbatim
71*>          C2 is COMPLEX*16 array, dimension (LDC,NMAX)
72*> \endverbatim
73*>
74*> \param[in] LDC
75*> \verbatim
76*>          LDC is INTEGER
77*>                The leading dimension of the array A.  LDA >= max(1,NMAX).
78*> \endverbatim
79*>
80*> \param[out] CRF
81*> \verbatim
82*>          CRF is COMPLEX*16 array, dimension ((NMAX*(NMAX+1))/2).
83*> \endverbatim
84*>
85*> \param[out] A
86*> \verbatim
87*>          A is COMPLEX*16 array, dimension (LDA,NMAX)
88*> \endverbatim
89*>
90*> \param[in] LDA
91*> \verbatim
92*>          LDA is INTEGER
93*>                The leading dimension of the array A.  LDA >= max(1,NMAX).
94*> \endverbatim
95*>
96*> \param[out] D_WORK_ZLANGE
97*> \verbatim
98*>          D_WORK_ZLANGE is DOUBLE PRECISION array, dimension (NMAX)
99*> \endverbatim
100*
101*  Authors:
102*  ========
103*
104*> \author Univ. of Tennessee
105*> \author Univ. of California Berkeley
106*> \author Univ. of Colorado Denver
107*> \author NAG Ltd.
108*
109*> \date November 2011
110*
111*> \ingroup complex16_lin
112*
113*  =====================================================================
114      SUBROUTINE ZDRVRF4( NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A,
115     +                    LDA, D_WORK_ZLANGE )
116*
117*  -- LAPACK test routine (version 3.4.0) --
118*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
119*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
120*     November 2011
121*
122*     .. Scalar Arguments ..
123      INTEGER            LDA, LDC, NN, NOUT
124      DOUBLE PRECISION   THRESH
125*     ..
126*     .. Array Arguments ..
127      INTEGER            NVAL( NN )
128      DOUBLE PRECISION   D_WORK_ZLANGE( * )
129      COMPLEX*16         A( LDA, * ), C1( LDC, * ), C2( LDC, *),
130     +                   CRF( * )
131*     ..
132*
133*  =====================================================================
134*     ..
135*     .. Parameters ..
136      DOUBLE PRECISION   ZERO, ONE
137      PARAMETER          ( ZERO = 0.0D+0, ONE  = 1.0D+0 )
138      INTEGER            NTESTS
139      PARAMETER          ( NTESTS = 1 )
140*     ..
141*     .. Local Scalars ..
142      CHARACTER          UPLO, CFORM, TRANS
143      INTEGER            I, IFORM, IIK, IIN, INFO, IUPLO, J, K, N,
144     +                   NFAIL, NRUN, IALPHA, ITRANS
145      DOUBLE PRECISION   ALPHA, BETA, EPS, NORMA, NORMC
146*     ..
147*     .. Local Arrays ..
148      CHARACTER          UPLOS( 2 ), FORMS( 2 ), TRANSS( 2 )
149      INTEGER            ISEED( 4 ), ISEEDY( 4 )
150      DOUBLE PRECISION   RESULT( NTESTS )
151*     ..
152*     .. External Functions ..
153      DOUBLE PRECISION   DLAMCH, DLARND, ZLANGE
154      COMPLEX*16         ZLARND
155      EXTERNAL           DLAMCH, DLARND, ZLANGE, ZLARND
156*     ..
157*     .. External Subroutines ..
158      EXTERNAL           ZHERK, ZHFRK, ZTFTTR, ZTRTTF
159*     ..
160*     .. Intrinsic Functions ..
161      INTRINSIC          DABS, MAX
162*     ..
163*     .. Scalars in Common ..
164      CHARACTER*32       SRNAMT
165*     ..
166*     .. Common blocks ..
167      COMMON             / SRNAMC / SRNAMT
168*     ..
169*     .. Data statements ..
170      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
171      DATA               UPLOS  / 'U', 'L' /
172      DATA               FORMS  / 'N', 'C' /
173      DATA               TRANSS / 'N', 'C' /
174*     ..
175*     .. Executable Statements ..
176*
177*     Initialize constants and the random number seed.
178*
179      NRUN = 0
180      NFAIL = 0
181      INFO = 0
182      DO 10 I = 1, 4
183         ISEED( I ) = ISEEDY( I )
184   10 CONTINUE
185      EPS = DLAMCH( 'Precision' )
186*
187      DO 150 IIN = 1, NN
188*
189         N = NVAL( IIN )
190*
191         DO 140 IIK = 1, NN
192*
193            K = NVAL( IIN )
194*
195            DO 130 IFORM = 1, 2
196*
197               CFORM = FORMS( IFORM )
198*
199               DO 120 IUPLO = 1, 2
200*
201                  UPLO = UPLOS( IUPLO )
202*
203                  DO 110 ITRANS = 1, 2
204*
205                     TRANS = TRANSS( ITRANS )
206*
207                     DO 100 IALPHA = 1, 4
208*
209                        IF ( IALPHA.EQ. 1) THEN
210                           ALPHA = ZERO
211                           BETA = ZERO
212                        ELSE IF ( IALPHA.EQ. 1) THEN
213                           ALPHA = ONE
214                           BETA = ZERO
215                        ELSE IF ( IALPHA.EQ. 1) THEN
216                           ALPHA = ZERO
217                           BETA = ONE
218                        ELSE
219                           ALPHA = DLARND( 2, ISEED )
220                           BETA = DLARND( 2, ISEED )
221                        END IF
222*
223*                       All the parameters are set:
224*                          CFORM, UPLO, TRANS, M, N,
225*                          ALPHA, and BETA
226*                       READY TO TEST!
227*
228                        NRUN = NRUN + 1
229*
230                        IF ( ITRANS.EQ.1 ) THEN
231*
232*                          In this case we are NOTRANS, so A is N-by-K
233*
234                           DO J = 1, K
235                              DO I = 1, N
236                                 A( I, J) = ZLARND( 4, ISEED )
237                              END DO
238                           END DO
239*
240                           NORMA = ZLANGE( 'I', N, K, A, LDA,
241     +                                      D_WORK_ZLANGE )
242*
243                        ELSE
244*
245*                          In this case we are TRANS, so A is K-by-N
246*
247                           DO J = 1,N
248                              DO I = 1, K
249                                 A( I, J) = ZLARND( 4, ISEED )
250                              END DO
251                           END DO
252*
253                           NORMA = ZLANGE( 'I', K, N, A, LDA,
254     +                                      D_WORK_ZLANGE )
255*
256                        END IF
257*
258*
259*                       Generate C1 our N--by--N Hermitian matrix.
260*                       Make sure C2 has the same upper/lower part,
261*                       (the one that we do not touch), so
262*                       copy the initial C1 in C2 in it.
263*
264                        DO J = 1, N
265                           DO I = 1, N
266                              C1( I, J) = ZLARND( 4, ISEED )
267                              C2(I,J) = C1(I,J)
268                           END DO
269                        END DO
270*
271*                       (See comment later on for why we use ZLANGE and
272*                       not ZLANHE for C1.)
273*
274                        NORMC = ZLANGE( 'I', N, N, C1, LDC,
275     +                                      D_WORK_ZLANGE )
276*
277                        SRNAMT = 'ZTRTTF'
278                        CALL ZTRTTF( CFORM, UPLO, N, C1, LDC, CRF,
279     +                               INFO )
280*
281*                       call zherk the BLAS routine -> gives C1
282*
283                        SRNAMT = 'ZHERK '
284                        CALL ZHERK( UPLO, TRANS, N, K, ALPHA, A, LDA,
285     +                              BETA, C1, LDC )
286*
287*                       call zhfrk the RFP routine -> gives CRF
288*
289                        SRNAMT = 'ZHFRK '
290                        CALL ZHFRK( CFORM, UPLO, TRANS, N, K, ALPHA, A,
291     +                              LDA, BETA, CRF )
292*
293*                       convert CRF in full format -> gives C2
294*
295                        SRNAMT = 'ZTFTTR'
296                        CALL ZTFTTR( CFORM, UPLO, N, CRF, C2, LDC,
297     +                               INFO )
298*
299*                       compare C1 and C2
300*
301                        DO J = 1, N
302                           DO I = 1, N
303                              C1(I,J) = C1(I,J)-C2(I,J)
304                           END DO
305                        END DO
306*
307*                       Yes, C1 is Hermitian so we could call ZLANHE,
308*                       but we want to check the upper part that is
309*                       supposed to be unchanged and the diagonal that
310*                       is supposed to be real -> ZLANGE
311*
312                        RESULT(1) = ZLANGE( 'I', N, N, C1, LDC,
313     +                                      D_WORK_ZLANGE )
314                        RESULT(1) = RESULT(1)
315     +                              / MAX( DABS( ALPHA ) * NORMA * NORMA
316     +                                   + DABS( BETA ) * NORMC, ONE )
317     +                              / MAX( N , 1 ) / EPS
318*
319                        IF( RESULT(1).GE.THRESH ) THEN
320                           IF( NFAIL.EQ.0 ) THEN
321                              WRITE( NOUT, * )
322                              WRITE( NOUT, FMT = 9999 )
323                           END IF
324                           WRITE( NOUT, FMT = 9997 ) 'ZHFRK',
325     +                        CFORM, UPLO, TRANS, N, K, RESULT(1)
326                           NFAIL = NFAIL + 1
327                        END IF
328*
329  100                CONTINUE
330  110             CONTINUE
331  120          CONTINUE
332  130       CONTINUE
333  140    CONTINUE
334  150 CONTINUE
335*
336*     Print a summary of the results.
337*
338      IF ( NFAIL.EQ.0 ) THEN
339         WRITE( NOUT, FMT = 9996 ) 'ZHFRK', NRUN
340      ELSE
341         WRITE( NOUT, FMT = 9995 ) 'ZHFRK', NFAIL, NRUN
342      END IF
343*
344 9999 FORMAT( 1X, ' *** Error(s) or Failure(s) while testing ZHFRK
345     +         ***')
346 9997 FORMAT( 1X, '     Failure in ',A5,', CFORM=''',A1,''',',
347     + ' UPLO=''',A1,''',',' TRANS=''',A1,''',', ' N=',I3,', K =', I3,
348     + ', test=',G12.5)
349 9996 FORMAT( 1X, 'All tests for ',A5,' auxiliary routine passed the ',
350     +        'threshold ( ',I6,' tests run)')
351 9995 FORMAT( 1X, A6, ' auxiliary routine: ',I6,' out of ',I6,
352     +        ' tests failed to pass the threshold')
353*
354      RETURN
355*
356*     End of ZDRVRF4
357*
358      END
359