OpenLibm/slatec/dplpce.f

*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