-
Notifications
You must be signed in to change notification settings - Fork 2
/
rgda_d.f
418 lines (416 loc) · 14.4 KB
/
rgda_d.f
1
2
3
4
5
6
7
8
9
10
11
12
13
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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
CM
c Create the RgDa versions from rgda_s.f
c
CM
C->>> ----------------------------------------------> ems_g_vr_rg_da <<<
c Gets the ranging information for a variable.
c
CM IF (sps_rgda .EQ. 1) THEN
C? subroutine ems_g_vr_rg_da_sps(
CM ELSE
subroutine ems_g_vr_rg_da_dse(
CM ENDIF
& c_n, en_vr_n, u_bc_rg_da, pv_c_n_ix,
& aa_up, aa_lo,
& pv_r_n_up, pv_r_n_lo,
& vr_in_r, st,
& lb, ub,
& pr_act, du_act,
& pv_c_v, pv_c_ix,
& pk_v,
& co_rg_up_co_v, co_rg_lo_co_v,
& co_rg_up_act_v, co_rg_lo_act_v,
& co_rg_up_en_vr, co_rg_lo_en_vr,
& co_rg_up_lv_vr, co_rg_lo_lv_vr)
implicit none
include 'EMSV.INC'
include 'EMSPM.INC'
include 'ITXITCS.INC'
include 'ICTVR.INC'
include 'RLCTVR.INC'
include 'EMSMSG.INC'
integer c_n, en_vr_n, pv_c_n_ix
logical u_bc_rg_da
double precision aa_up, aa_lo
integer pv_r_n_up, pv_r_n_lo
integer vr_in_r(0:n_r), st(0:mx_n_c+n_r)
double precision lb(0:mx_n_c+n_r), ub(0:mx_n_c+n_r)
double precision pr_act(0:mx_n_c+n_r), du_act(0:mx_n_c+n_r)
double precision pv_c_v(0:n_r)
double precision pk_v(0:n_r)
double precision co_rg_up_co_v(0:mx_n_c+n_r)
double precision co_rg_lo_co_v(0:mx_n_c+n_r)
double precision co_rg_up_act_v(0:mx_n_c+n_r)
double precision co_rg_lo_act_v(0:mx_n_c+n_r)
integer pv_c_ix(0:n_r)
integer co_rg_up_en_vr(0:mx_n_c+n_r)
integer co_rg_lo_en_vr(0:mx_n_c+n_r)
integer co_rg_up_lv_vr(0:mx_n_c+n_r)
integer co_rg_lo_lv_vr(0:mx_n_c+n_r)
double precision pv, rsdu, du_act_v
double precision co_rg_aa_up, co_rg_aa_lo
integer r_n, vr_n, en_vr_st, vr_st
logical ze_du_act, pos_du_act, neg_du_act
logical en_vr_mv_up, en_vr_mv_dn
integer ix_n, n_ix
c
c Analyse the nonbasic variable: its status and activities.
c
en_vr_st = st(en_vr_n)
du_act_v = du_act(en_vr_n)
ze_du_act = abs(du_act_v) .le. tl_du_ifs
if (ze_du_act) then
pos_du_act = .false.
neg_du_act = .false.
else
pos_du_act = du_act_v .gt. zero
neg_du_act = du_act_v .lt. zero
endif
en_vr_mv_up = iand(en_vr_st, up_bt) .ne. 0
en_vr_mv_dn = iand(en_vr_st, dn_bt) .ne. 0
c
c If the basis is optimal then nonbasic variables which are free to
c move up or down should not have a non-zero dual activity.
c
if (en_vr_mv_up .and. en_vr_mv_dn .and. .not.ze_du_act) then
if (ems_msg_no_prt_fm .ge. 1) write(ems_li, 9600)en_vr_n,
& lb(en_vr_n), pr_act(en_vr_n), ub(en_vr_n), du_act_v
call ems_msg_wr_li(er_msg_n)
ze_du_act = .true.
pos_du_act = .false.
neg_du_act = .false.
endif
c
c If the basis is optimal then nonbasic variables which are free to
c move up should not have a negative dual activity.
c
if (en_vr_mv_up .and. neg_du_act) then
if (ems_msg_no_prt_fm .ge. 1) write(ems_li, 9601)en_vr_n,
& lb(en_vr_n), pr_act(en_vr_n), ub(en_vr_n), du_act_v
call ems_msg_wr_li(er_msg_n)
ze_du_act = .true.
pos_du_act = .false.
neg_du_act = .false.
endif
c
c If the basis is optimal then nonbasic variables which are free to
c move down should not have a positive dual activity.
c
if (en_vr_mv_dn .and. pos_du_act) then
if (ems_msg_no_prt_fm .ge. 1) write(ems_li, 9602)en_vr_n,
& lb(en_vr_n), pr_act(en_vr_n), ub(en_vr_n), du_act_v
call ems_msg_wr_li(er_msg_n)
ze_du_act = .true.
pos_du_act = .false.
neg_du_act = .false.
endif
c
c Initialise the steps and pivotal rows for the primal ratio tests.
c
aa_up = inf
aa_lo = inf
pv_r_n_up = -1
pv_r_n_lo = -1
if (en_vr_mv_up) then
c
c If the entering variable is free to move up then make sure the
c upper range does not exceed any upper bound.
c
if (iand(en_vr_st, ub_bt) .ne. 0) then
aa_up = ub(en_vr_n) - pr_act(en_vr_n)
pv_r_n_up = 0
endif
endif
if (en_vr_mv_dn) then
c
c If the entering variable is free to move down then make sure the
c lower range does not exceed any lower bound.
c
if (iand(en_vr_st, lb_bt) .ne. 0) then
aa_lo = pr_act(en_vr_n) - lb(en_vr_n)
pv_r_n_lo = 0
endif
endif
c
c=======================================================================
c Perform the primal ratio tests for the nonbasic variable.
c
c
c Initialise the number of (true) nonzero values in the tableau
c column---if pv_c_ix(0) .le. n_r then zeros and repeated entries
c indexed by pv_c_ix(1:pv_c_ix(0)) will be removed in the first
c pass.
c
n_ix = 0
CM IF (sps_rgda .EQ. 1) THEN
C? do 10, ix_n = 1, pv_c_ix(0)
C? r_n = pv_c_ix(ix_n)
CM ELSE
do 10, r_n = 1, n_r
CM ENDIF
pv = pv_c_v(r_n)
if (pv .eq. zero) goto 10
pv_c_v(r_n) = zero
if (abs(pv) .le. pk_pv_c_ze) goto 10
c
c Pack the nonzero value for the second pass.
c
n_ix = n_ix + 1
pk_v(n_ix) = pv
pv_c_ix(n_ix) = r_n
c
c Determine the basic variable and its status---need the lb/ub bits
c
vr_n = vr_in_r(r_n)
vr_st = st(vr_n)
if (pv .gt. zero) then
if (iand(vr_st, ub_bt) .ne. 0) then
c
c Variable moves up to upper bound as entering variable increases
c
rsdu = ub(vr_n) - pr_act(vr_n)
if (rsdu .lt. aa_up*pv) then
aa_up = rsdu/pv
pv_r_n_up = r_n
endif
endif
if (iand(vr_st, lb_bt) .ne. 0) then
c
c Variable moves down to lower bound as entering variable decreases
c
rsdu = pr_act(vr_n) - lb(vr_n)
if (rsdu .lt. aa_lo*pv) then
aa_lo = rsdu/pv
pv_r_n_lo = r_n
endif
endif
else
if (iand(vr_st, ub_bt) .ne. 0) then
c
c Variable moves up to upper bound as entering variable decreases
c
rsdu = pr_act(vr_n) - ub(vr_n)
if (rsdu .gt. aa_lo*pv) then
aa_lo = rsdu/pv
pv_r_n_lo = r_n
endif
endif
if (iand(vr_st, lb_bt) .ne. 0) then
c
c Variable moves down to lower bound as entering variable increases
c
rsdu = lb(vr_n) - pr_act(vr_n)
if (rsdu .gt. aa_up*pv) then
aa_up = rsdu/pv
pv_r_n_up = r_n
endif
endif
endif
10 continue
aa_up = max(aa_up, zero)
aa_lo = max(aa_lo, zero)
pv_c_n_ix = n_ix
c
c=======================================================================
c Update the dual ratio tests for the basic variables.
c
if (.not. u_bc_rg_da) goto 7000
c
c Find the steps which respect the bounds
c
co_rg_aa_up = aa_up
if (.not. en_vr_mv_up) co_rg_aa_up = zero
co_rg_aa_lo = aa_lo
if (.not. en_vr_mv_dn) co_rg_aa_lo = zero
c
c pos_du_act => en_vr_mv_up and .not.en_vr_mv_dn
c neg_du_act => en_vr_mv_dn and .not.en_vr_mv_up
c
c ... since this part of the routine is not called for variables
c which are not free to move up or down.
do 20, ix_n = 1, n_ix
c
c Get the packed row number, value and corresponding variable number
c
r_n = pv_c_ix(ix_n)
pv = pk_v(ix_n)
vr_n = vr_in_r(r_n)
if (pv .gt. zero) then
c
c Update the cost range data for a positive pivot.
c
if (ze_du_act) then
if (en_vr_mv_up .and.
& (co_rg_lo_en_vr(vr_n) .ge. 0 .or.
& co_rg_aa_up*pv .gt. co_rg_lo_act_v(vr_n))) then
c
c There is a zero lower cost range for this basic variable and the
c nonbasic variable is either the first to give such a range or the
c the change in the primal activity with this nonbasic variable is
c the greatest so far.
c
c Record:
c the lower cost range
c the change in the primal activity
c the nonbasic variable number---negated to cheapen the test for
c whether a minimal (zero) lower cost range has been found.
c the direction in which the nonbasic variable changes.
c
co_rg_lo_co_v(vr_n) = zero
co_rg_lo_act_v(vr_n) = co_rg_aa_up*pv
co_rg_lo_en_vr(vr_n) = -en_vr_n
co_rg_lo_lv_vr(vr_n) = 1
endif
if (en_vr_mv_dn .and.
& (co_rg_up_en_vr(vr_n) .ge. 0 .or.
& co_rg_aa_lo*pv .gt. co_rg_up_act_v(vr_n))) then
c
c There is a zero upper cost range for this basic variable and the
c nonbasic variable is either the first to give such a range or the
c the change in the primal activity with this nonbasic variable is
c the greatest so far.
c
c Record:
c the upper cost range
c the change in the primal activity
c the nonbasic variable number---negated to cheapen the test for
c whether a minimal (zero) upper cost range has been found.
c the direction in which the nonbasic variable changes.
c
co_rg_up_co_v(vr_n) = zero
co_rg_up_act_v(vr_n) = co_rg_aa_lo*pv
co_rg_up_en_vr(vr_n) = -en_vr_n
co_rg_up_lv_vr(vr_n) = -1
endif
else if (pos_du_act) then
c
c The positive nonbasic dual activity moves down to zero as the
c basic cost decreases. The resulting basis change then increases
c the primal activity at zero (further) cost.
c
c Record:
c the upper cost range
c the change in the primal activity
c the nonbasic variable number
c the direction in which the nonbasic variable changes.
c
if (du_act_v .lt. co_rg_lo_co_v(vr_n)*pv) then
co_rg_lo_co_v(vr_n) = du_act_v/pv
co_rg_lo_act_v(vr_n) = co_rg_aa_up*pv
co_rg_lo_en_vr(vr_n) = en_vr_n
co_rg_lo_lv_vr(vr_n) = 1
endif
else
c
c The negative nonbasic dual activity moves up to zero as the
c basic cost increases. The resulting basis change then decreases
c the primal activity at zero (further) cost.
c
if (-du_act_v .lt. co_rg_up_co_v(vr_n)*pv) then
co_rg_up_co_v(vr_n) = -du_act_v/pv
co_rg_up_act_v(vr_n) = co_rg_aa_lo*pv
co_rg_up_en_vr(vr_n) = en_vr_n
co_rg_up_lv_vr(vr_n) = -1
endif
endif
else
c
c Update the cost range data for a negative pivot
c
if (ze_du_act) then
if (en_vr_mv_up .and.
& (co_rg_up_en_vr(vr_n) .ge. 0 .or.
& -co_rg_aa_up*pv .gt. co_rg_up_act_v(vr_n))) then
c
c There is a zero upper cost range for this basic variable and the
c nonbasic variable is either the first to give such a range or the
c the change in the primal activity with this nonbasic variable is
c the greatest so far.
c
c Record:
c the upper cost range
c the change in the primal activity
c the nonbasic variable number---negated to cheapen the test for
c whether a minimal (zero) upper cost range has been found.
c the direction in which the nonbasic variable changes.
c
co_rg_up_co_v(vr_n) = zero
co_rg_up_act_v(vr_n) = -co_rg_aa_up*pv
co_rg_up_en_vr(vr_n) = -en_vr_n
co_rg_up_lv_vr(vr_n) = 1
endif
if (en_vr_mv_dn .and.
& (co_rg_lo_en_vr(vr_n) .ge. 0 .or.
& -co_rg_aa_lo*pv .gt. co_rg_lo_act_v(vr_n))) then
c
c There is a zero lower cost range for this basic variable and the
c nonbasic variable is either the first to give such a range or the
c the change in the primal activity with this nonbasic variable is
c the greatest so far.
c
c Record:
c the lower cost range
c the change in the primal activity
c the nonbasic variable number---negated to cheapen the test for
c whether a minimal (zero) lower cost range has been found.
c the direction in which the nonbasic variable changes.
c
co_rg_lo_co_v(vr_n) = zero
co_rg_lo_act_v(vr_n) = -co_rg_aa_lo*pv
co_rg_lo_en_vr(vr_n) = -en_vr_n
co_rg_lo_lv_vr(vr_n) = -1
endif
else if (pos_du_act) then
c
c The positive nonbasic dual activity moves down to zero as the
c basic cost increases. The resulting basis change then increases
c the primal activity at zero (further) cost.
c
c Record:
c the upper cost range
c the change in the primal activity
c the nonbasic variable number
c the direction in which the nonbasic variable changes.
c
if (du_act_v .lt. -co_rg_up_co_v(vr_n)*pv) then
co_rg_up_co_v(vr_n) = -du_act_v/pv
co_rg_up_act_v(vr_n) = -co_rg_aa_up*pv
co_rg_up_en_vr(vr_n) = en_vr_n
co_rg_up_lv_vr(vr_n) = 1
endif
else
c
c The negative nonbasic dual activity moves up to zero as the
c basic cost decreases. The resulting basis change then decreases
c the primal activity at zero (further) cost.
c
c Record:
c the lower cost range
c the change in the primal activity
c the nonbasic variable number
c the direction in which the nonbasic variable changes.
c
if (-du_act_v .lt. -co_rg_lo_co_v(vr_n)*pv) then
co_rg_lo_co_v(vr_n) = du_act_v/pv
co_rg_lo_act_v(vr_n) = -co_rg_aa_lo*pv
co_rg_lo_en_vr(vr_n) = en_vr_n
co_rg_lo_lv_vr(vr_n) = -1
endif
endif
endif
20 continue
7000 continue
return
9600 format('Nonbasic variable ', i7,
& ' with Lb:Act:Ub ', g11.4, 2(':', g11.4),
& ' can move up and down but has non-zero dual activity ',
& g11.4, ': Treating this as zero')
9601 format('Nonbasic variable ', i7,
& ' with Lb:Act:Ub ', g11.4, 2(':', g11.4),
& ' can move up but has negative dual activity ',
& g11.4, ': Treating this as zero')
9602 format('Nonbasic variable ', i7,
& ' with Lb:Act:Ub ', g11.4, 2(':', g11.4),
& ' can move down but has positive dual activity ',
& g11.4, ': Treating this as zero')
end