2
3
4
5
6
7
8 INTEGER IDIST, INFO, IRSIGN, MODE, N
9 DOUBLE PRECISION COND
10
11
12 INTEGER ISEED( 4 )
13 COMPLEX*16 D( * )
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94 DOUBLE PRECISION ONE
95 parameter( one = 1.0d0 )
96
97
98 INTEGER I
99 DOUBLE PRECISION ALPHA, TEMP
100 COMPLEX*16 CTEMP
101
102
103 DOUBLE PRECISION DLARAN
104 COMPLEX*16 ZLARND
106
107
109
110
111 INTRINSIC abs, dble, exp, log
112
113
114
115
116
117 info = 0
118
119
120
121 IF( n.EQ.0 )
122 $ RETURN
123
124
125
126 IF( mode.LT.-6 .OR. mode.GT.6 ) THEN
127 info = -1
128 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
129 $ ( irsign.NE.0 .AND. irsign.NE.1 ) ) THEN
130 info = -2
131 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
132 $ cond.LT.one ) THEN
133 info = -3
134 ELSE IF( ( mode.EQ.6 .OR. mode.EQ.-6 ) .AND.
135 $ ( idist.LT.1 .OR. idist.GT.4 ) ) THEN
136 info = -4
137 ELSE IF( n.LT.0 ) THEN
138 info = -7
139 END IF
140
141 IF( info.NE.0 ) THEN
142 CALL xerbla( 'ZLATM1', -info )
143 RETURN
144 END IF
145
146
147
148 IF( mode.NE.0 ) THEN
149 GO TO ( 10, 30, 50, 70, 90, 110 )abs( mode )
150
151
152
153 10 CONTINUE
154 DO 20 i = 1, n
155 d( i ) = one / cond
156 20 CONTINUE
157 d( 1 ) = one
158 GO TO 120
159
160
161
162 30 CONTINUE
163 DO 40 i = 1, n
164 d( i ) = one
165 40 CONTINUE
166 d( n ) = one / cond
167 GO TO 120
168
169
170
171 50 CONTINUE
172 d( 1 ) = one
173 IF( n.GT.1 ) THEN
174 alpha = cond**( -one / dble( n-1 ) )
175 DO 60 i = 2, n
176 d( i ) = alpha**( i-1 )
177 60 CONTINUE
178 END IF
179 GO TO 120
180
181
182
183 70 CONTINUE
184 d( 1 ) = one
185 IF( n.GT.1 ) THEN
186 temp = one / cond
187 alpha = ( one-temp ) / dble( n-1 )
188 DO 80 i = 2, n
189 d( i ) = dble( n-i )*alpha + temp
190 80 CONTINUE
191 END IF
192 GO TO 120
193
194
195
196 90 CONTINUE
197 alpha = log( one / cond )
198 DO 100 i = 1, n
199 d( i ) = exp( alpha*
dlaran( iseed ) )
200 100 CONTINUE
201 GO TO 120
202
203
204
205 110 CONTINUE
206 CALL zlarnv( idist, iseed, n, d )
207
208 120 CONTINUE
209
210
211
212
213 IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
214 $ irsign.EQ.1 ) THEN
215 DO 130 i = 1, n
216 ctemp =
zlarnd( 3, iseed )
217 d( i ) = d( i )*( ctemp / abs( ctemp ) )
218 130 CONTINUE
219 END IF
220
221
222
223 IF( mode.LT.0 ) THEN
224 DO 140 i = 1, n / 2
225 ctemp = d( i )
226 d( i ) = d( n+1-i )
227 d( n+1-i ) = ctemp
228 140 CONTINUE
229 END IF
230
231 END IF
232
233 RETURN
234
235
236
subroutine zlarnv(idist, iseed, n, x)