*DECK DPLPQX SUBROUTINE DPLPQX (LUN, KPRINT, IPASS) C***BEGIN PROLOGUE DPLPQX C***PURPOSE Quick check for DSPLP. C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (SPLPQX-S, DPLPQX-D) C***AUTHOR (UNKNOWN) C***ROUTINES CALLED DCOPY, DSPLP, DUSRMT, PASS C***REVISION HISTORY (YYMMDD) C ?????? DATE WRITTEN C 890911 Removed unnecessary intrinsics. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 901013 Added additional printout on failure. (RWC) C***END PROLOGUE DPLPQX IMPLICIT DOUBLE PRECISION (A-H,O-Z) EXTERNAL DUSRMT INTEGER ICNT, IND(60), IBASIS(60), IPASS, IWORK(900), ISOLN(14) DOUBLE PRECISION COSTS(37) DOUBLE PRECISION PRGOPT(50), DATTRV(210), BL(60), BU(60) DOUBLE PRECISION PRIMAL(60), DUALS(60) DOUBLE PRECISION WORK(800) DOUBLE PRECISION D(14,37) DOUBLE PRECISION ZERO INTEGER MRELAS,NVARS,INFO,LW,LIW C***FIRST EXECUTABLE STATEMENT DPLPQX IF(KPRINT.GE.2) WRITE(LUN,999) 999 FORMAT ('1 DSPLP QUICK CHECK') ICNT=1 ZERO = 0.0D0 IPASS=0 C DEFINE WORKING ARRAY LENGTHS LIW = 900 LW = 800 MRELAS = 14 NVARS = 37 C DEFINE THE ARRAY COSTS(*) FOR THE OBJECTIVE FUNCTION COSTS(1) = 1.030D0 COSTS(2) = 0.985D0 COSTS(3) = 0.997D0 COSTS(4) = 1.036D0 COSTS(5) = 1.005D0 COSTS(6) = 0.980D0 COSTS(7) = 1.004D0 COSTS(8) = 0.993D0 COSTS(9) = 1.018D0 COSTS(10) = 0.947D0 COSTS(11) = 0.910D0 COSTS(12) = 1.028D0 COSTS(13) = 0.957D0 COSTS(14) = 1.025D0 COSTS(15) = 1.036D0 COSTS(16) = 1.060D0 COSTS(17) = 0.954D0 COSTS(18) = 0.891D0 COSTS(19) = 0.921D0 COSTS(20) = 1.040D0 COSTS(21) = 0.912D0 COSTS(22) = 0.926D0 COSTS(23) = 1.000D0 COSTS(24) = 0.000D0 COSTS(25) = 0.000D0 COSTS(26) = 0.000D0 COSTS(27) = 0.000D0 COSTS(28) = 0.000D0 COSTS(29) = 0.000D0 COSTS(30) = 0.000D0 COSTS(31) = 0.000D0 COSTS(32) = 0.000D0 COSTS(33) = 0.000D0 COSTS(34) = 0.000D0 COSTS(35) = 0.000D0 COSTS(36) = 0.000D0 COSTS(37) = 0.000D0 C PLACE THE NONZERO INFORMATION ABOUT THE MATRIX IN DATTRV(*) CALL DCOPY(14*37, ZERO, 0, D, 1) D(1,1) = 1.04000D0 D(1,23) = 1.00000D0 D(1,24) = -1.00000D0 D(2,6) = 0.04125D0 D(2,7) = 0.05250D0 D(2,17) = 0.04875D0 D(2,24) = 1.00000D0 D(2,25) = -1.00000D0 D(3,8) = 0.05625D0 D(3,9) = 0.06875D0 D(3,11) = 0.02250D0 D(3,25) = 1.00000D0 D(3,26) = -1.00000D0 D(4,2) = 1.04000D0 D(4,3) = 1.05375D0 D(4,5) = 1.06125D0 D(4,12) = 0.08000D0 D(4,16) = 0.09375D0 D(4,18) = 0.03750D0 D(4,19) = 0.04625D0 D(4,20) = 0.08125D0 D(4,22) = 0.05250D0 D(4,26) = 1.00000D0 D(4,27) = -1.00000D0 D(5,10) = 0.04375D0 D(5,27) = 1.00000D0 D(5,28) = -1.00000D0 D(6,4) = 1.05875D0 D(6,13) = 0.04500D0 D(6,14) = 0.06375D0 D(6,15) = 0.06625D0 D(6,21) = 0.05000D0 D(6,28) = 1.00000D0 D(6,29) = -1.00000D0 D(7,6) = 1.04125D0 D(7,7) = 1.05250D0 D(7,8) = 1.05625D0 D(7,9) = 1.06875D0 D(7,11) = 0.02250D0 D(7,17) = 0.04875D0 D(7,29) = 1.00000D0 D(7,30) = -1.00000D0 D(8,10) = 1.04375D0 D(8,12) = 0.08000D0 D(8,13) = 0.04500D0 D(8,14) = 0.06375D0 D(8,15) = 0.06625D0 D(8,16) = 0.09375D0 D(8,18) = 0.03750D0 D(8,19) = 0.04625D0 D(8,20) = 0.08125D0 D(8,21) = 0.05000D0 D(8,22) = 0.05250D0 D(8,30) = 1.00000D0 D(8,31) = -1.00000D0 D(9,11) = 1.02250D0 D(9,17) = 0.04875D0 D(9,31) = 1.00000D0 D(9,32) = -1.00000D0 D(10,12) = 1.08000D0 D(10,13) = 1.04500D0 D(10,14) = 1.06375D0 D(10,15) = 1.06625D0 D(10,16) = 1.09375D0 D(10,18) = 0.03750D0 D(10,19) = 0.04625D0 D(10,20) = 0.08125D0 D(10,21) = 0.05000D0 D(10,22) = 0.05250D0 D(10,32) = 1.00000D0 D(10,33) = -1.00000D0 D(11,17) = 1.04875D0 D(11,33) = 1.00000D0 D(11,34) = -1.00000D0 D(12,18) = 1.03750D0 D(12,19) = 1.04625D0 D(12,20) = 1.08125D0 D(12,21) = 1.05000D0 D(12,22) = 0.05250D0 D(12,34) = 1.00000D0 D(12,35) = -1.00000D0 D(13,35) = 1.00000D0 D(13,36) = -1.00000D0 D(14,22) = 1.05250D0 D(14,36) = 1.00000D0 D(14,37) = -1.00000D0 KOUNT = 1 DO 20 MM=1,NVARS DATTRV(KOUNT) = -MM DO 10 KK=1,MRELAS IF (D(KK,MM).EQ.ZERO) GO TO 10 KOUNT = KOUNT + 1 DATTRV(KOUNT) = KK KOUNT = KOUNT + 1 DATTRV(KOUNT) = D(KK,MM) 10 CONTINUE KOUNT = KOUNT + 1 20 CONTINUE DATTRV(KOUNT) = ZERO C NON-NEGATIVITY CONSTRAINT DO 30 IC=1,NVARS BL(IC) = ZERO IND(IC) = 3 BU(IC) = 10000000.000D0 30 CONTINUE C LE CONSTRAINTS DO 40 IV=1,MRELAS IVV = IV + NVARS IND(IVV) = 3 BL(IVV) = 100.00000D0 BU(IVV) = 100000000.00000D0 40 CONTINUE PRGOPT(01) = 18 PRGOPT(02) = 59 PRGOPT(03) = 0 PRGOPT(04) = 1 PRGOPT(05) = 3 PRGOPT(06) = 8 PRGOPT(07) = 10 PRGOPT(08) = 11 PRGOPT(09) = 16 PRGOPT(10) = 17 PRGOPT(11) = 21 PRGOPT(12) = 22 PRGOPT(13) = 24 PRGOPT(14) = 25 PRGOPT(15) = 27 PRGOPT(16) = 28 PRGOPT(17) = 35 PRGOPT(18) = 21 PRGOPT(19) = 51 PRGOPT(20) = 0 PRGOPT(21) = 1 CALL DSPLP(DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, BL, * BU, IND, INFO, PRIMAL, DUALS, IBASIS, WORK, LW, IWORK, LIW) C C LOOK FOR THE KNOWN BASIS AT THE SOLN., NOW IS ISOLN(*). C DO 50 I=1,MRELAS ISOLN(I) = PRGOPT(I+3) 50 CONTINUE C IPASS = 1 DO 70 J=1,MRELAS DO 60 I=1,MRELAS IF (ISOLN(I).EQ.IBASIS(J)) GO TO 70 60 CONTINUE IPASS = 0 GO TO 80 70 CONTINUE C 80 IF (KPRINT.GE.2) WRITE (LUN, 99997) (ISOLN(I), IBASIS(I), * I=1,MRELAS) C IF (KPRINT.GE.2 .OR. (KPRINT.EQ.1.AND.IPASS.NE.1)) * CALL PASS (LUN, ICNT, IPASS) C C HERE IPASS=0 IF CODE FAILED QUICK CHECK; C =1 IF CODE PASSED QUICK CHECK. C IF (KPRINT.GE.1 .AND. IPASS.NE.1) WRITE (LUN,99999) IF (KPRINT.GE.2 .AND. IPASS.EQ.1) WRITE (LUN,99998) RETURN C 99997 FORMAT (/' ISOLN IBASIS'/(2I10)) 99998 FORMAT (/' ************ DSPLP PASSED ALL TESTS ****************') 99999 FORMAT (/' ************ DSPLP FAILED SOME TESTS ***************') END .