*DECK DPLPCE SUBROUTINE DPLPCE (MRELAS, NVARS, LMX, LBM, ITLP, ITBRC, IBASIS, + IMAT, IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, TUNE, GG, AMAT, + BASMAT, CSC, WR, WW, PRIMAL, ERD, ERP, SINGLR, REDBAS) C***BEGIN PROLOGUE DPLPCE C***SUBSIDIARY C***PURPOSE Subsidiary to DSPLP C***LIBRARY SLATEC C***TYPE DOUBLE PRECISION (SPLPCE-S, DPLPCE-D) C***AUTHOR (UNKNOWN) C***DESCRIPTION C C THE EDITING REQUIRED TO CONVERT THIS SUBROUTINE FROM SINGLE TO C DOUBLE PRECISION INVOLVES THE FOLLOWING CHARACTER STRING CHANGES. C C USE AN EDITING COMMAND (CHANGE) /STRING-1/(TO)STRING-2/. C /REAL (12 BLANKS)/DOUBLE PRECISION/, C /SASUM/DASUM/,/DCOPY/,DCOPY/. C C REVISED 811219-1630 C REVISED YYMMDD-HHMM C C THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT CALCULATES C THE APPROXIMATE ERROR IN THE PRIMAL AND DUAL SYSTEMS. IT IS C THE MAIN PART OF THE PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL C SYSTEMS). C C***SEE ALSO DSPLP C***ROUTINES CALLED DASUM, DCOPY, DPRWPG, IDLOC, LA05BD C***REVISION HISTORY (YYMMDD) C 811215 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890605 Removed unreferenced labels. (WRB) C 890606 Changed references from IPLOC to IDLOC. (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C***END PROLOGUE DPLPCE INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*) DOUBLE PRECISION AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),PRIMAL(*), * ERD(*),ERP(*),EPS,ERDNRM,FACTOR,GG,ONE,ZERO,TEN,TUNE DOUBLE PRECISION DASUM LOGICAL SINGLR,REDBAS,TRANS,PAGEPL C***FIRST EXECUTABLE STATEMENT DPLPCE ZERO=0.D0 ONE=1.D0 TEN=10.D0 LPG=LMX-(NVARS+4) SINGLR=.FALSE. FACTOR=0.01 C C COPY COLSUMS IN WW(*), AND SOLVE TRANSPOSED SYSTEM. I=1 N20002=MRELAS GO TO 20003 20002 I=I+1 20003 IF ((N20002-I).LT.0) GO TO 20004 J=IBASIS(I) IF (.NOT.(J.LE.NVARS)) GO TO 20006 WW(I) = PRIMAL(J) GO TO 20007 20006 IF (.NOT.(IND(J).EQ.2)) GO TO 20009 WW(I)=ONE GO TO 20010 20009 WW(I)=-ONE 20010 CONTINUE 20007 CONTINUE GO TO 20002 C C PERTURB RIGHT-SIDE IN UNITS OF LAST BITS TO BETTER REFLECT C ERRORS IN THE CHECK SUM SOLNS. 20004 I=1 N20012=MRELAS GO TO 20013 20012 I=I+1 20013 IF ((N20012-I).LT.0) GO TO 20014 WW(I)=WW(I)+TEN*EPS*WW(I) GO TO 20012 20014 TRANS = .TRUE. CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) I=1 N20016=MRELAS GO TO 20017 20016 I=I+1 20017 IF ((N20016-I).LT.0) GO TO 20018 ERD(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE C C SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR. C THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. SINGLR=SINGLR.OR.(ERD(I).GE.FACTOR) GO TO 20016 20018 ERDNRM=DASUM(MRELAS,ERD,1) C C RECALCULATE ROW CHECK SUMS EVERY ITBRC ITERATIONS OR WHEN C A REDECOMPOSITION HAS OCCURRED. IF (.NOT.(MOD(ITLP,ITBRC).EQ.0 .OR. REDBAS)) GO TO 20020 C C COMPUTE ROW SUMS, STORE IN WW(*), SOLVE PRIMAL SYSTEM. WW(1)=ZERO CALL DCOPY(MRELAS,WW,0,WW,1) PAGEPL=.TRUE. J=1 N20023=NVARS GO TO 20024 20023 J=J+1 20024 IF ((N20023-J).LT.0) GO TO 20025 IF (.NOT.(IBB(J).GE.ZERO)) GO TO 20027 C C THE VARIABLE IS NON-BASIC. PAGEPL=.TRUE. GO TO 20023 20027 IF (.NOT.(J.EQ.1)) GO TO 20030 ILOW=NVARS+5 GO TO 20031 20030 ILOW=IMAT(J+3)+1 20031 IF (.NOT.(PAGEPL)) GO TO 20033 IL1=IDLOC(ILOW,AMAT,IMAT) IF (.NOT.(IL1.GE.LMX-1)) GO TO 20036 ILOW=ILOW+2 IL1=IDLOC(ILOW,AMAT,IMAT) 20036 CONTINUE IPAGE=ABS(IMAT(LMX-1)) GO TO 20034 20033 IL1=IHI+1 20034 IHI=IMAT(J+4)-(ILOW-IL1) 20039 IU1=MIN(LMX-2,IHI) IF (.NOT.(IL1.GT.IU1)) GO TO 20041 GO TO 20040 20041 CONTINUE DO 20 I=IL1,IU1 WW(IMAT(I))=WW(IMAT(I))+AMAT(I)*CSC(J) 20 CONTINUE IF (.NOT.(IHI.LE.LMX-2)) GO TO 20044 GO TO 20040 20044 CONTINUE IPAGE=IPAGE+1 KEY=1 CALL DPRWPG(KEY,IPAGE,LPG,AMAT,IMAT) IL1=NVARS+5 IHI=IHI-LPG GO TO 20039 20040 PAGEPL=IHI.EQ.(LMX-2) GO TO 20023 20025 L=1 N20047=MRELAS GO TO 20048 20047 L=L+1 20048 IF ((N20047-L).LT.0) GO TO 20049 J=IBASIS(L) IF (.NOT.(J.GT.NVARS)) GO TO 20051 I=J-NVARS IF (.NOT.(IND(J).EQ.2)) GO TO 20054 WW(I)=WW(I)+ONE GO TO 20055 20054 WW(I)=WW(I)-ONE 20055 CONTINUE CONTINUE 20051 CONTINUE GO TO 20047 C C PERTURB RIGHT-SIDE IN UNITS OF LAST BIT POSITIONS. 20049 I=1 N20057=MRELAS GO TO 20058 20057 I=I+1 20058 IF ((N20057-I).LT.0) GO TO 20059 WW(I)=WW(I)+TEN*EPS*WW(I) GO TO 20057 20059 TRANS = .FALSE. CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS) I=1 N20061=MRELAS GO TO 20062 20061 I=I+1 20062 IF ((N20061-I).LT.0) GO TO 20063 ERP(I)=MAX(ABS(WW(I)-ONE),EPS)*TUNE C C SYSTEM BECOMES SINGULAR WHEN ACCURACY OF SOLUTION IS .GT. FACTOR. C THIS VALUE (FACTOR) MIGHT NEED TO BE CHANGED. SINGLR=SINGLR.OR.(ERP(I).GE.FACTOR) GO TO 20061 20063 CONTINUE C 20020 RETURN END