2
3
4
5
6
7
8 INTEGER IDIST, INFO, IRSIGN, MODE, N
9 REAL COND
10
11
12 INTEGER ISEED( 4 )
13 REAL 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 REAL ONE
93 parameter( one = 1.0e0 )
94 REAL HALF
95 parameter( half = 0.5e0 )
96
97
98 INTEGER I
99 REAL ALPHA, TEMP
100
101
102 REAL SLARAN
104
105
106 EXTERNAL slarnv, xerbla
107
108
109 INTRINSIC abs, exp, log, real
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( 'SLATM1', -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 / real( 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 ) / real( n-1 )
186 DO 80 i = 2, n
187 d( i ) = real( 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*
slaran( iseed ) )
198 100 CONTINUE
199 GO TO 120
200
201
202
203 110 CONTINUE
204 CALL slarnv( 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
real function slaran(iseed)