OpenLibm/slatec/splpfe.f

*DECK SPLPFE
      SUBROUTINE SPLPFE (MRELAS, NVARS, LMX, LBM, IENTER, IBASIS, IMAT,
     +   IBRC, IPR, IWR, IND, IBB, ERDNRM, EPS, GG, DULNRM, DIRNRM,
     +   AMAT, BASMAT, CSC, WR, WW, BL, BU, RZ, RG, COLNRM, DUALS,
     +   FOUND)
C***BEGIN PROLOGUE  SPLPFE
C***SUBSIDIARY
C***PURPOSE  Subsidiary to SPLP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (SPLPFE-S, DPLPFE-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/,/SASUM/DASUM/,
C     /SCOPY/DCOPY/.
C
C     THIS SUBPROGRAM IS PART OF THE SPLP( ) PACKAGE.
C     IT IMPLEMENTS THE PROCEDURE (FIND VARIABLE TO ENTER BASIS
C     AND GET SEARCH DIRECTION).
C     REVISED 811130-1100
C     REVISED YYMMDD-HHMM
C
C***SEE ALSO  SPLP
C***ROUTINES CALLED  IPLOC, LA05BS, PRWPGE, SASUM, SCOPY
C***REVISION HISTORY  (YYMMDD)
C   811215  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890605  Removed unreferenced labels.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C***END PROLOGUE  SPLPFE
      INTEGER IBASIS(*),IMAT(*),IBRC(LBM,2),IPR(*),IWR(*),IND(*),IBB(*)
      REAL             AMAT(*),BASMAT(*),CSC(*),WR(*),WW(*),BL(*),BU(*),
     * RZ(*),RG(*),COLNRM(*),DUALS(*),CNORM,DIRNRM,DULNRM,EPS,ERDNRM,GG,
     * ONE,RATIO,RCOST,RMAX,ZERO
      LOGICAL FOUND,TRANS
C***FIRST EXECUTABLE STATEMENT  SPLPFE
      LPG=LMX-(NVARS+4)
      ZERO=0.E0
      ONE=1.E0
      RMAX=ZERO
      FOUND=.FALSE.
      I=MRELAS+1
      N20002=MRELAS+NVARS
      GO TO 20003
20002 I=I+1
20003 IF ((N20002-I).LT.0) GO TO 20004
      J=IBASIS(I)
C
C     IF J=IBASIS(I) .LT. 0 THEN THE VARIABLE LEFT AT A ZERO LEVEL
C     AND IS NOT CONSIDERED AS A CANDIDATE TO ENTER.
      IF (.NOT.(J.GT.0)) GO TO 20006
C
C     DO NOT CONSIDER VARIABLES CORRESPONDING TO UNBOUNDED STEP LENGTHS.
      IF (.NOT.(IBB(J).EQ.0)) GO TO 20009
      GO TO 20002
20009 CONTINUE
C
C     IF A VARIABLE CORRESPONDS TO AN EQUATION(IND=3 AND BL=BU),
C     THEN DO NOT CONSIDER IT AS A CANDIDATE TO ENTER.
      IF (.NOT.(IND(J).EQ.3)) GO TO 20012
      IF (.NOT.((BU(J)-BL(J)).LE.EPS*(ABS(BL(J))+ABS(BU(J))))) GO TO 200
     *15
      GO TO 20002
20015 CONTINUE
20012 CONTINUE
      RCOST=RZ(J)
C
C     IF VARIABLE IS AT UPPER BOUND IT CAN ONLY DECREASE.  THIS
C     ACCOUNTS FOR THE POSSIBLE CHANGE OF SIGN.
      IF(MOD(IBB(J),2).EQ.0) RCOST=-RCOST
C
C     IF THE VARIABLE IS FREE, USE THE NEGATIVE MAGNITUDE OF THE
C     REDUCED COST FOR THAT VARIABLE.
      IF(IND(J).EQ.4) RCOST=-ABS(RCOST)
      CNORM=ONE
      IF(J.LE.NVARS)CNORM=COLNRM(J)
C
C     TEST FOR NEGATIVITY OF REDUCED COSTS.
      IF (.NOT.(RCOST+ERDNRM*DULNRM*CNORM.LT.ZERO)) GO TO 20018
      FOUND=.TRUE.
      RATIO=RCOST**2/RG(J)
      IF (.NOT.(RATIO.GT.RMAX)) GO TO 20021
      RMAX=RATIO
      IENTER=I
20021 CONTINUE
20018 CONTINUE
20006 GO TO 20002
C
C     USE COL. CHOSEN TO COMPUTE SEARCH DIRECTION.
20004 IF (.NOT.(FOUND)) GO TO 20024
      J=IBASIS(IENTER)
      WW(1)=ZERO
      CALL SCOPY(MRELAS,WW,0,WW,1)
      IF (.NOT.(J.LE.NVARS)) GO TO 20027
      IF (.NOT.(J.EQ.1)) GO TO 20030
      ILOW=NVARS+5
      GO TO 20031
20030 ILOW=IMAT(J+3)+1
20031 CONTINUE
      IL1=IPLOC(ILOW,AMAT,IMAT)
      IF (.NOT.(IL1.GE.LMX-1)) GO TO 20033
      ILOW=ILOW+2
      IL1=IPLOC(ILOW,AMAT,IMAT)
20033 CONTINUE
      IPAGE=ABS(IMAT(LMX-1))
      IHI=IMAT(J+4)-(ILOW-IL1)
20036 IU1=MIN(LMX-2,IHI)
      IF (.NOT.(IL1.GT.IU1)) GO TO 20038
      GO TO 20037
20038 CONTINUE
      DO 30 I=IL1,IU1
      WW(IMAT(I))=AMAT(I)*CSC(J)
30    CONTINUE
      IF (.NOT.(IHI.LE.LMX-2)) GO TO 20041
      GO TO 20037
20041 CONTINUE
      IPAGE=IPAGE+1
      KEY=1
      CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
      IL1=NVARS+5
      IHI=IHI-LPG
      GO TO 20036
20037 GO TO 20028
20027 IF (.NOT.(IND(J).EQ.2)) GO TO 20044
      WW(J-NVARS)=ONE
      GO TO 20045
20044 WW(J-NVARS)=-ONE
20045 CONTINUE
      CONTINUE
C
C     COMPUTE SEARCH DIRECTION.
20028 TRANS=.FALSE.
      CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
C
C     THE SEARCH DIRECTION REQUIRES THE FOLLOWING SIGN CHANGE IF EITHER
C     VARIABLE ENTERING IS AT ITS UPPER BOUND OR IS FREE AND HAS
C     POSITIVE REDUCED COST.
      IF (.NOT.(MOD(IBB(J),2).EQ.0.OR.(IND(J).EQ.4 .AND. RZ(J).GT.ZERO))
     *) GO TO 20047
      I=1
      N20050=MRELAS
      GO TO 20051
20050 I=I+1
20051 IF ((N20050-I).LT.0) GO TO 20052
      WW(I)=-WW(I)
      GO TO 20050
20052 CONTINUE
20047 DIRNRM=SASUM(MRELAS,WW,1)
C
C     COPY CONTENTS OF WR(*) TO DUALS(*) FOR USE IN
C     ADD-DROP (EXCHANGE) STEP, LA05CS( ).
      CALL SCOPY(MRELAS,WR,1,DUALS,1)
20024 RETURN
      END