2
3
4
5
6
7
8 INTEGER IDIST, INFO, IRSIGN, MODE, N
9 DOUBLE PRECISION COND
10
11
12 INTEGER ISEED( 4 )
13 DOUBLE PRECISION 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 DOUBLE PRECISION ONE
93 parameter( one = 1.0d0 )
94 DOUBLE PRECISION HALF
95 parameter( half = 0.5d0 )
96
97
98 INTEGER I
99 DOUBLE PRECISION ALPHA, TEMP
100
101
102 DOUBLE PRECISION DLARAN
104
105
106 EXTERNAL dlarnv, xerbla
107
108
109 INTRINSIC abs, dble, exp, log
110
111
112
113
114
115 info = 0
116
117
118
119 IF( n.EQ.0 )
120 $ RETURN
121
122
123
124 IF( mode.LT.-6 .OR. mode.GT.6 ) THEN
125 info = -1
126 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
127 $ ( irsign.NE.0 .AND. irsign.NE.1 ) ) THEN
128 info = -2
129 ELSE IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
130 $ cond.LT.one ) THEN
131 info = -3
132 ELSE IF( ( mode.EQ.6 .OR. mode.EQ.-6 ) .AND.
133 $ ( idist.LT.1 .OR. idist.GT.3 ) ) THEN
134 info = -4
135 ELSE IF( n.LT.0 ) THEN
136 info = -7
137 END IF
138
139 IF( info.NE.0 ) THEN
140 CALL xerbla( 'DLATM1', -info )
141 RETURN
142 END IF
143
144
145
146 IF( mode.NE.0 ) THEN
147 GO TO ( 10, 30, 50, 70, 90, 110 )abs( mode )
148
149
150
151 10 CONTINUE
152 DO 20 i = 1, n
153 d( i ) = one / cond
154 20 CONTINUE
155 d( 1 ) = one
156 GO TO 120
157
158
159
160 30 CONTINUE
161 DO 40 i = 1, n
162 d( i ) = one
163 40 CONTINUE
164 d( n ) = one / cond
165 GO TO 120
166
167
168
169 50 CONTINUE
170 d( 1 ) = one
171 IF( n.GT.1 ) THEN
172 alpha = cond**( -one / dble( n-1 ) )
173 DO 60 i = 2, n
174 d( i ) = alpha**( i-1 )
175 60 CONTINUE
176 END IF
177 GO TO 120
178
179
180
181 70 CONTINUE
182 d( 1 ) = one
183 IF( n.GT.1 ) THEN
184 temp = one / cond
185 alpha = ( one-temp ) / dble( n-1 )
186 DO 80 i = 2, n
187 d( i ) = dble( n-i )*alpha + temp
188 80 CONTINUE
189 END IF
190 GO TO 120
191
192
193
194 90 CONTINUE
195 alpha = log( one / cond )
196 DO 100 i = 1, n
197 d( i ) = exp( alpha*
dlaran( iseed ) )
198 100 CONTINUE
199 GO TO 120
200
201
202
203 110 CONTINUE
204 CALL dlarnv( idist, iseed, n, d )
205
206 120 CONTINUE
207
208
209
210
211 IF( ( mode.NE.-6 .AND. mode.NE.0 .AND. mode.NE.6 ) .AND.
212 $ irsign.EQ.1 ) THEN
213 DO 130 i = 1, n
215 IF( temp.GT.half )
216 $ d( i ) = -d( i )
217 130 CONTINUE
218 END IF
219
220
221
222 IF( mode.LT.0 ) THEN
223 DO 140 i = 1, n / 2
224 temp = d( i )
225 d( i ) = d( n+1-i )
226 d( n+1-i ) = temp
227 140 CONTINUE
228 END IF
229
230 END IF
231
232 RETURN
233
234
235