55
56
57
58
59
60
61 INTEGER NIN, NOUT
62
63
64
65
66
67 INTEGER LDE
69 DOUBLE PRECISION ZERO
70 parameter( zero = 0.0d0 )
71
72
73 INTEGER I, IHI, ILO, INFO, J, KNT, N, NINFO
74 DOUBLE PRECISION EPS, RMAX, SAFMIN, VMAX, X
75
76
77 INTEGER LMAX( 2 )
78 DOUBLE PRECISION E( LDE, LDE ), EIN( LDE, LDE ), SCALE( LDE )
79
80
81 DOUBLE PRECISION DLAMCH
83
84
86
87
88 INTRINSIC abs, max
89
90
91
92 lmax( 1 ) = 0
93 lmax( 2 ) = 0
94 ninfo = 0
95 knt = 0
96 rmax = zero
99
100 10 CONTINUE
101
102 READ( nin, fmt = * )n, ilo, ihi
103 IF( n.EQ.0 )
104 $ GO TO 60
105
106 READ( nin, fmt = * )( scale( i ), i = 1, n )
107 DO 20 i = 1, n
108 READ( nin, fmt = * )( e( i, j ), j = 1, n )
109 20 CONTINUE
110
111 DO 30 i = 1, n
112 READ( nin, fmt = * )( ein( i, j ), j = 1, n )
113 30 CONTINUE
114
115 knt = knt + 1
116 CALL dgebak(
'B',
'R', n, ilo, ihi, scale, n, e,
lde, info )
117
118 IF( info.NE.0 ) THEN
119 ninfo = ninfo + 1
120 lmax( 1 ) = knt
121 END IF
122
123 vmax = zero
124 DO 50 i = 1, n
125 DO 40 j = 1, n
126 x = abs( e( i, j )-ein( i, j ) ) / eps
127 IF( abs( e( i, j ) ).GT.safmin )
128 $ x = x / abs( e( i, j ) )
129 vmax = max( vmax, x )
130 40 CONTINUE
131 50 CONTINUE
132
133 IF( vmax.GT.rmax ) THEN
134 lmax( 2 ) = knt
135 rmax = vmax
136 END IF
137
138 GO TO 10
139
140 60 CONTINUE
141
142 WRITE( nout, fmt = 9999 )
143 9999 FORMAT( 1x, '.. test output of DGEBAK .. ' )
144
145 WRITE( nout, fmt = 9998 )rmax
146 9998 FORMAT( 1x, 'value of largest test error = ', d12.3 )
147 WRITE( nout, fmt = 9997 )lmax( 1 )
148 9997 FORMAT( 1x, 'example number where info is not zero = ', i4 )
149 WRITE( nout, fmt = 9996 )lmax( 2 )
150 9996 FORMAT( 1x, 'example number having largest error = ', i4 )
151 WRITE( nout, fmt = 9995 )ninfo
152 9995 FORMAT( 1x, 'number of examples where info is not 0 = ', i4 )
153 WRITE( nout, fmt = 9994 )knt
154 9994 FORMAT( 1x, 'total number of examples tested = ', i4 )
155
156 RETURN
157
158
159
logical function lde(ri, rj, lr)
subroutine dgebak(job, side, n, ilo, ihi, scale, m, v, ldv, info)
DGEBAK
double precision function dlamch(cmach)
DLAMCH