Fcalva/OpenLibm
1
0
Fork 0
mirror of https://git.planet-casio.com/Lephenixnoir/OpenLibm.git synced 2025-01-01 06:23:39 +01:00
Code Issues Projects Releases Packages Wiki Activity Actions
OpenLibm/slatec/splpmn.f
Viral B. Shah c977aa998f Add Makefile.extras to build libopenlibm-extras. 
Replace amos with slatec
2012-12-31 16:37:05 -05:00

988 lines
33 KiB
Fortran
Raw Blame History

*DECK SPLPMN
SUBROUTINE SPLPMN (USRMAT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV,
+ BL, BU, IND, INFO, PRIMAL, DUALS, AMAT, CSC, COLNRM, ERD, ERP,
+ BASMAT, WR, RZ, RG, RPRIM, RHS, WW, LMX, LBM, IBASIS, IBB,
+ IMAT, IBRC, IPR, IWR)
C***BEGIN PROLOGUE SPLPMN
C***SUBSIDIARY
C***PURPOSE Subsidiary to SPLP
C***LIBRARY SLATEC
C***TYPE SINGLE PRECISION (SPLPMN-S, DPLPMN-D)
C***AUTHOR (UNKNOWN)
C***DESCRIPTION
C
C MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT.
C THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR.
C
C MAIN SUBROUTINE FOR SPLP PACKAGE.
C
C***SEE ALSO SPLP
C***ROUTINES CALLED IVOUT, LA05BS, PINITM, PNNZRS, PRWPGE, SASUM,
C SCLOSM, SCOPY, SDOT, SPINCW, SPINIT, SPLPCE,
C SPLPDM, SPLPFE, SPLPFL, SPLPMU, SPLPUP, SPOPT,
C SVOUT, XERMSG
C***COMMON BLOCKS LA05DS
C***REVISION HISTORY (YYMMDD)
C 811215 DATE WRITTEN
C 890531 Changed all specific intrinsics to generic. (WRB)
C 890605 Corrected references to XERRWV. (WRB)
C 890605 Removed unreferenced labels. (WRB)
C 891009 Removed unreferenced variable. (WRB)
C 891214 Prologue converted to Version 4.0 format. (BAB)
C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ)
C 900328 Added TYPE section. (WRB)
C 900510 Convert XERRWV calls to XERMSG calls. (RWC)
C***END PROLOGUE SPLPMN
REAL ABIG,AIJ,AMAT(*),ANORM,ASMALL,BASMAT(*),
* BL(*),BU(*),COLNRM(*),COSTS(*),COSTSC,CSC(*),DATTRV(*),
* DIRNRM,DUALS(*),DULNRM,EPS,TUNE,ERD(*),ERDNRM,ERP(*),FACTOR,GG,
* ONE,PRGOPT(*),PRIMAL(*),RESNRM,RG(*),RHS(*),RHSNRM,ROPT(07),
* RPRIM(*),RPRNRM,RZ(*),RZJ,SCALR,SCOSTS,SIZE,SMALL,THETA,
* TOLLS,UPBND,UU,WR(*),WW(*),XLAMDA,XVAL,ZERO,RDUM(01),TOLABS
C
INTEGER IBASIS(*),IBB(*),IBRC(LBM,2),IMAT(*),IND(*),
* IPR(*),IWR(*),INTOPT(08),IDUM(01)
C
C ARRAY LOCAL VARIABLES
C NAME(LENGTH) DESCRIPTION
C
C COSTS(NVARS) COST COEFFICIENTS
C PRGOPT( ) OPTION VECTOR
C DATTRV( ) DATA TRANSFER VECTOR
C PRIMAL(NVARS+MRELAS) AS OUTPUT IT IS PRIMAL SOLUTION OF LP.
C INTERNALLY, THE FIRST NVARS POSITIONS HOLD
C THE COLUMN CHECK SUMS. THE NEXT MRELAS
C POSITIONS HOLD THE CLASSIFICATION FOR THE
C BASIC VARIABLES -1 VIOLATES LOWER
C BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND
C DUALS(MRELAS+NVARS) DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE
C AS FIRST MRELAS ENTRIES.
C AMAT(LMX) SPARSE FORM OF DATA MATRIX
C IMAT(LMX) SPARSE FORM OF DATA MATRIX
C BL(NVARS+MRELAS) LOWER BOUNDS FOR VARIABLES
C BU(NVARS+MRELAS) UPPER BOUNDS FOR VARIABLES
C IND(NVARS+MRELAS) INDICATOR FOR VARIABLES
C CSC(NVARS) COLUMN SCALING
C IBASIS(NVARS+MRELAS) COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC
C IBB(NVARS+MRELAS) INDICATOR FOR NON-BASIC VARS., POLARITY OF
C VARS., AND POTENTIALLY INFINITE VARS.
C IF IBB(J).LT.0, VARIABLE J IS BASIC
C IF IBB(J).GT.0, VARIABLE J IS NON-BASIC
C IF IBB(J).EQ.0, VARIABLE J HAS TO BE IGNORED
C BECAUSE IT WOULD CAUSE UNBOUNDED SOLN.
C WHEN MOD(IBB(J),2).EQ.0, VARIABLE IS AT ITS
C UPPER BOUND, OTHERWISE IT IS AT ITS LOWER
C BOUND
C COLNRM(NVARS) NORM OF COLUMNS
C ERD(MRELAS) ERRORS IN DUAL VARIABLES
C ERP(MRELAS) ERRORS IN PRIMAL VARIABLES
C BASMAT(LBM) BASIS MATRIX FOR HARWELL SPARSE CODE
C IBRC(LBM,2) ROW AND COLUMN POINTERS FOR BASMAT(*)
C IPR(2*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE
C IWR(8*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE
C WR(MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE
C RZ(NVARS+MRELAS) REDUCED COSTS
C RPRIM(MRELAS) INTERNAL PRIMAL SOLUTION
C RG(NVARS+MRELAS) COLUMN WEIGHTS
C WW(MRELAS) WORK ARRAY
C RHS(MRELAS) HOLDS TRANSLATED RIGHT HAND SIDE
C
C SCALAR LOCAL VARIABLES
C NAME TYPE DESCRIPTION
C
C LMX INTEGER LENGTH OF AMAT(*)
C LPG INTEGER LENGTH OF PAGE FOR AMAT(*)
C EPS REAL MACHINE PRECISION
C TUNE REAL PARAMETER TO SCALE ERROR ESTIMATES
C TOLLS REAL RELATIVE TOLERANCE FOR SMALL RESIDUALS
C TOLABS REAL ABSOLUTE TOLERANCE FOR SMALL RESIDUALS.
C USED IF RELATIVE ERROR TEST FAILS.
C IN CONSTRAINT EQUATIONS
C FACTOR REAL .01--DETERMINES IF BASIS IS SINGULAR
C OR COMPONENT IS FEASIBLE. MAY NEED TO
C BE INCREASED TO 1.E0 ON SHORT WORD
C LENGTH MACHINES.
C ASMALL REAL LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
C ABIG REAL UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
C MXITLP INTEGER MAXIMUM NUMBER OF ITERATIONS FOR LP
C ITLP INTEGER ITERATION COUNTER FOR TOTAL LP ITERS
C COSTSC REAL COSTS(*) SCALING
C SCOSTS REAL TEMP LOC. FOR COSTSC.
C XLAMDA REAL WEIGHT PARAMETER FOR PEN. METHOD.
C ANORM REAL NORM OF DATA MATRIX AMAT(*)
C RPRNRM REAL NORM OF THE SOLUTION
C DULNRM REAL NORM OF THE DUALS
C ERDNRM REAL NORM OF ERROR IN DUAL VARIABLES
C DIRNRM REAL NORM OF THE DIRECTION VECTOR
C RHSNRM REAL NORM OF TRANSLATED RIGHT HAND SIDE VECTOR
C RESNRM REAL NORM OF RESIDUAL VECTOR FOR CHECKING
C FEASIBILITY
C NZBM INTEGER NUMBER OF NON-ZEROS IN BASMAT(*)
C LBM INTEGER LENGTH OF BASMAT(*)
C SMALL REAL EPS*ANORM USED IN HARWELL SPARSE CODE
C LP INTEGER USED IN HARWELL LA05*() PACK AS OUTPUT
C FILE NUMBER. SET=I1MACH(4) NOW.
C UU REAL 0.1--USED IN HARWELL SPARSE CODE
C FOR RELATIVE PIVOTING TOLERANCE.
C GG REAL OUTPUT INFO FLAG IN HARWELL SPARSE CODE
C IPLACE INTEGER INTEGER USED BY SPARSE MATRIX CODES
C IENTER INTEGER NEXT COLUMN TO ENTER BASIS
C NREDC INTEGER NO. OF FULL REDECOMPOSITIONS
C KPRINT INTEGER LEVEL OF OUTPUT, =0-3
C IDG INTEGER FORMAT AND PRECISION OF OUTPUT
C ITBRC INTEGER NO. OF ITERS. BETWEEN RECALCULATING
C THE ERROR IN THE PRIMAL SOLUTION.
C NPP INTEGER NO. OF NEGATIVE REDUCED COSTS REQUIRED
C IN PARTIAL PRICING
C JSTRT INTEGER STARTING PLACE FOR PARTIAL PRICING.
C
LOGICAL COLSCP,SAVEDT,CONTIN,CSTSCP,UNBND,
* FEAS,FINITE,FOUND,MINPRB,REDBAS,
* SINGLR,SIZEUP,STPEDG,TRANS,USRBAS,ZEROLV,LOPT(08)
CHARACTER*8 XERN1, XERN2
EQUIVALENCE (CONTIN,LOPT(1)),(USRBAS,LOPT(2)),
* (SIZEUP,LOPT(3)),(SAVEDT,LOPT(4)),(COLSCP,LOPT(5)),
* (CSTSCP,LOPT(6)),(MINPRB,LOPT(7)),(STPEDG,LOPT(8)),
* (IDG,INTOPT(1)),(IPAGEF,INTOPT(2)),(ISAVE,INTOPT(3)),
* (MXITLP,INTOPT(4)),(KPRINT,INTOPT(5)),(ITBRC,INTOPT(6)),
* (NPP,INTOPT(7)),(LPRG,INTOPT(8)),(EPS,ROPT(1)),(ASMALL,ROPT(2)),
* (ABIG,ROPT(3)),(COSTSC,ROPT(4)),(TOLLS,ROPT(5)),(TUNE,ROPT(6)),
* (TOLABS,ROPT(7))
C
C COMMON BLOCK USED BY LA05 () PACKAGE..
COMMON /LA05DS/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL
EXTERNAL USRMAT
C
C SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE.
C***FIRST EXECUTABLE STATEMENT SPLPMN
LP=0
C
C THE VALUES ZERO AND ONE.
ZERO=0.E0
ONE=1.E0
FACTOR=0.01E0
LPG=LMX-(NVARS+4)
IOPT=1
INFO=0
UNBND=.FALSE.
JSTRT=1
C
C PROCESS USER OPTIONS IN PRGOPT(*).
C CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED.
CALL SPOPT(PRGOPT,MRELAS,NVARS,INFO,CSC,IBASIS,ROPT,INTOPT,LOPT)
IF (.NOT.(INFO.LT.0)) GO TO 20002
GO TO 30001
20002 IF (.NOT.(CONTIN)) GO TO 20003
GO TO 30002
20006 GO TO 20004
C
C INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*).
20003 CALL PINITM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF)
C
C UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY.
20004 CALL SPLPUP(USRMAT,MRELAS,NVARS,PRGOPT,DATTRV,
* BL,BU,IND,INFO,AMAT,IMAT,SIZEUP,ASMALL,ABIG)
IF (.NOT.(INFO.LT.0)) GO TO 20007
GO TO 30001
C
C++ CODE FOR OUTPUT=YES IS ACTIVE
20007 IF (.NOT.(KPRINT.GE.1)) GO TO 20008
GO TO 30003
20011 CONTINUE
C++ CODE FOR OUTPUT=NO IS INACTIVE
C++ END
C
C INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN
C CHECK SUMS, AND FORM INITIAL BASIS MATRIX.
20008 CALL SPINIT(MRELAS,NVARS,COSTS,BL,BU,IND,PRIMAL,INFO,
* AMAT,CSC,COSTSC,COLNRM,XLAMDA,ANORM,RHS,RHSNRM,
* IBASIS,IBB,IMAT,LOPT)
IF (.NOT.(INFO.LT.0)) GO TO 20012
GO TO 30001
C
20012 NREDC=0
ASSIGN 20013 TO NPR004
GO TO 30004
20013 IF (.NOT.(SINGLR)) GO TO 20014
NERR=23
CALL XERMSG ('SLATEC', 'SPLPMN',
+ 'IN SPLP, A SINGULAR INITIAL BASIS WAS ENCOUNTERED.', NERR,
+ IOPT)
INFO=-NERR
GO TO 30001
20014 ASSIGN 20018 TO NPR005
GO TO 30005
20018 ASSIGN 20019 TO NPR006
GO TO 30006
20019 ASSIGN 20020 TO NPR007
GO TO 30007
20020 IF (.NOT.(USRBAS)) GO TO 20021
ASSIGN 20024 TO NPR008
GO TO 30008
20024 IF (.NOT.(.NOT.FEAS)) GO TO 20025
NERR=24
CALL XERMSG ('SLATEC', 'SPLPMN',
+ 'IN SPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.', NERR,
+ IOPT)
INFO=-NERR
GO TO 30001
20025 CONTINUE
20021 ITLP=0
C
C LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD.
ASSIGN 20029 TO NPR009
GO TO 30009
20029 ASSIGN 20030 TO NPR010
GO TO 30010
20030 ASSIGN 20031 TO NPR006
GO TO 30006
20031 ASSIGN 20032 TO NPR008
GO TO 30008
20032 IF (.NOT.(.NOT.FEAS)) GO TO 20033
C
C SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF
C COSTSC) AND PERFORM STANDARD PHASE-1.
IF(KPRINT.GE.2)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-1'')',
*IDG)
SCOSTS=COSTSC
COSTSC=ZERO
ASSIGN 20036 TO NPR007
GO TO 30007
20036 ASSIGN 20037 TO NPR009
GO TO 30009
20037 ASSIGN 20038 TO NPR010
GO TO 30010
20038 ASSIGN 20039 TO NPR006
GO TO 30006
20039 ASSIGN 20040 TO NPR008
GO TO 30008
20040 IF (.NOT.(FEAS)) GO TO 20041
C
C SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2.
IF(KPRINT.GT.1)CALL IVOUT(0,IDUM,'('' ENTER STANDARD PHASE-2'')',
*IDG)
XLAMDA=ZERO
COSTSC=SCOSTS
ASSIGN 20044 TO NPR009
GO TO 30009
20044 CONTINUE
20041 GO TO 20034
C CHECK IF ANY BASIC VARIABLES ARE STILL CLASSIFIED AS
C INFEASIBLE. IF ANY ARE, THEN THIS MAY NOT YET BE AN
C OPTIMAL POINT. THEREFORE SET LAMDA TO ZERO AND TRY
C TO PERFORM MORE SIMPLEX STEPS.
20033 I=1
N20046=MRELAS
GO TO 20047
20046 I=I+1
20047 IF ((N20046-I).LT.0) GO TO 20048
IF (PRIMAL(I+NVARS).NE.ZERO) GO TO 20045
GO TO 20046
20048 GO TO 20035
20045 XLAMDA=ZERO
ASSIGN 20050 TO NPR009
GO TO 30009
20050 CONTINUE
20034 CONTINUE
C
20035 ASSIGN 20051 TO NPR011
GO TO 30011
20051 IF (.NOT.(FEAS.AND.(.NOT.UNBND))) GO TO 20052
INFO=1
GO TO 20053
20052 IF (.NOT.((.NOT.FEAS).AND.(.NOT.UNBND))) GO TO 10001
NERR=1
CALL XERMSG ('SLATEC', 'SPLPMN',
+ 'IN SPLP, THE PROBLEM APPEARS TO BE INFEASIBLE', NERR, IOPT)
INFO=-NERR
GO TO 20053
10001 IF (.NOT.(FEAS .AND. UNBND)) GO TO 10002
NERR=2
CALL XERMSG ('SLATEC', 'SPLPMN',
+ 'IN SPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.',
+ NERR, IOPT)
INFO=-NERR
GO TO 20053
10002 IF (.NOT.((.NOT.FEAS).AND.UNBND)) GO TO 10003
NERR=3
CALL XERMSG ('SLATEC', 'SPLPMN',
+ 'IN SPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO HAVE ' //
+ 'NO FINITE SOLUTION.', NERR, IOPT)
INFO=-NERR
10003 CONTINUE
20053 CONTINUE
C
IF (.NOT.(INFO.EQ.(-1) .OR. INFO.EQ.(-3))) GO TO 20055
SIZE=SASUM(NVARS,PRIMAL,1)*ANORM
SIZE=SIZE/SASUM(NVARS,CSC,1)
SIZE=SIZE+SASUM(MRELAS,PRIMAL(NVARS+1),1)
I=1
N20058=NVARS+MRELAS
GO TO 20059
20058 I=I+1
20059 IF ((N20058-I).LT.0) GO TO 20060
NX0066=IND(I)
IF (NX0066.LT.1.OR.NX0066.GT.4) GO TO 20066
GO TO (20062,20063,20064,20065), NX0066
20062 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20068
GO TO 20058
20068 IF (.NOT.(PRIMAL(I).GT.BL(I))) GO TO 10004
GO TO 20058
10004 IND(I)=-4
GO TO 20067
20063 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 20071
GO TO 20058
20071 IF (.NOT.(PRIMAL(I).LT.BU(I))) GO TO 10005
GO TO 20058
10005 IND(I)=-4
GO TO 20067
20064 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BL(I))*FACTOR.EQ.SIZE)) GO TO 20074
GO TO 20058
20074 IF (.NOT.(PRIMAL(I).LT.BL(I))) GO TO 10006
IND(I)=-4
GO TO 20075
10006 IF (.NOT.(SIZE+ABS(PRIMAL(I)-BU(I))*FACTOR.EQ.SIZE)) GO TO 10007
GO TO 20058
10007 IF (.NOT.(PRIMAL(I).GT.BU(I))) GO TO 10008
IND(I)=-4
GO TO 20075
10008 GO TO 20058
20075 GO TO 20067
20065 GO TO 20058
20066 CONTINUE
20067 GO TO 20058
20060 CONTINUE
20055 CONTINUE
C
IF (.NOT.(INFO.EQ.(-2) .OR. INFO.EQ.(-3))) GO TO 20077
J=1
N20080=NVARS
GO TO 20081
20080 J=J+1
20081 IF ((N20080-J).LT.0) GO TO 20082
IF (.NOT.(IBB(J).EQ.0)) GO TO 20084
NX0091=IND(J)
IF (NX0091.LT.1.OR.NX0091.GT.4) GO TO 20091
GO TO (20087,20088,20089,20090), NX0091
20087 BU(J)=BL(J)
IND(J)=-3
GO TO 20092
20088 BL(J)=BU(J)
IND(J)=-3
GO TO 20092
20089 GO TO 20080
20090 BL(J)=ZERO
BU(J)=ZERO
IND(J)=-3
20091 CONTINUE
20092 CONTINUE
20084 GO TO 20080
20082 CONTINUE
20077 CONTINUE
C++ CODE FOR OUTPUT=YES IS ACTIVE
IF (.NOT.(KPRINT.GE.1)) GO TO 20093
ASSIGN 20096 TO NPR012
GO TO 30012
20096 CONTINUE
20093 CONTINUE
C++ CODE FOR OUTPUT=NO IS INACTIVE
C++ END
GO TO 30001
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (COMPUTE RIGHT HAND SIDE)
30010 RHS(1)=ZERO
CALL SCOPY(MRELAS,RHS,0,RHS,1)
J=1
N20098=NVARS+MRELAS
GO TO 20099
20098 J=J+1
20099 IF ((N20098-J).LT.0) GO TO 20100
NX0106=IND(J)
IF (NX0106.LT.1.OR.NX0106.GT.4) GO TO 20106
GO TO (20102,20103,20104,20105), NX0106
20102 SCALR=-BL(J)
GO TO 20107
20103 SCALR=-BU(J)
GO TO 20107
20104 SCALR=-BL(J)
GO TO 20107
20105 SCALR=ZERO
20106 CONTINUE
20107 IF (.NOT.(SCALR.NE.ZERO)) GO TO 20108
IF (.NOT.(J.LE.NVARS)) GO TO 20111
I=0
20114 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
IF (.NOT.(I.LE.0)) GO TO 20116
GO TO 20115
20116 RHS(I)=RHS(I)+AIJ*SCALR
GO TO 20114
20115 GO TO 20112
20111 RHS(J-NVARS)=RHS(J-NVARS)-SCALR
20112 CONTINUE
20108 GO TO 20098
20100 J=1
N20119=NVARS+MRELAS
GO TO 20120
20119 J=J+1
20120 IF ((N20119-J).LT.0) GO TO 20121
SCALR=ZERO
IF(IND(J).EQ.3.AND.MOD(IBB(J),2).EQ.0) SCALR=BU(J)-BL(J)
IF (.NOT.(SCALR.NE.ZERO)) GO TO 20123
IF (.NOT.(J.LE.NVARS)) GO TO 20126
I=0
20129 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
IF (.NOT.(I.LE.0)) GO TO 20131
GO TO 20130
20131 RHS(I)=RHS(I)-AIJ*SCALR
GO TO 20129
20130 GO TO 20127
20126 RHS(J-NVARS)=RHS(J-NVARS)+SCALR
20127 CONTINUE
20123 GO TO 20119
20121 CONTINUE
GO TO NPR010, (20030,20038)
C PROCEDURE (PERFORM SIMPLEX STEPS)
30009 ASSIGN 20134 TO NPR013
GO TO 30013
20134 ASSIGN 20135 TO NPR014
GO TO 30014
20135 IF (.NOT.(KPRINT.GT.2)) GO TO 20136
CALL SVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
CALL SVOUT(NVARS+MRELAS,RZ,'('' REDUCED COSTS'')',IDG)
20136 CONTINUE
20139 ASSIGN 20141 TO NPR015
GO TO 30015
20141 IF (.NOT.(.NOT. FOUND)) GO TO 20142
GO TO 30016
20145 CONTINUE
20142 IF (.NOT.(FOUND)) GO TO 20146
IF (KPRINT.GE.3) CALL SVOUT(MRELAS,WW,'('' SEARCH DIRECTION'')',
*IDG)
GO TO 30017
20149 IF (.NOT.(FINITE)) GO TO 20150
GO TO 30018
20153 ASSIGN 20154 TO NPR005
GO TO 30005
20154 GO TO 20151
20150 UNBND=.TRUE.
IBB(IBASIS(IENTER))=0
20151 GO TO 20147
20146 GO TO 20140
20147 ITLP=ITLP+1
GO TO 30019
20155 GO TO 20139
20140 CONTINUE
GO TO NPR009, (20029,20037,20044,20050)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE)
30002 LPR=NVARS+4
REWIND ISAVE
READ(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
KEY=2
IPAGE=1
GO TO 20157
20156 IF (NP.LT.0) GO TO 20158
20157 LPR1=LPR+1
READ(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
NP=IMAT(LMX-1)
IPAGE=IPAGE+1
GO TO 20156
20158 NPARM=NVARS+MRELAS
READ(ISAVE) (IBASIS(I),I=1,NPARM)
REWIND ISAVE
GO TO 20006
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (SAVE DATA ON FILE ISAVE)
C
C SOME PAGES MAY NOT BE WRITTEN YET.
30020 IF (.NOT.(AMAT(LMX).EQ.ONE)) GO TO 20159
AMAT(LMX)=ZERO
KEY=2
IPAGE=ABS(IMAT(LMX-1))
CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
C
C FORCE PAGE FILE TO BE OPENED ON RESTARTS.
20159 KEY=AMAT(4)
AMAT(4)=ZERO
LPR=NVARS+4
WRITE(ISAVE) (AMAT(I),I=1,LPR),(IMAT(I),I=1,LPR)
AMAT(4)=KEY
IPAGE=1
KEY=1
GO TO 20163
20162 IF (NP.LT.0) GO TO 20164
20163 CALL PRWPGE(KEY,IPAGE,LPG,AMAT,IMAT)
LPR1=LPR+1
WRITE(ISAVE) (AMAT(I),I=LPR1,LMX),(IMAT(I),I=LPR1,LMX)
NP=IMAT(LMX-1)
IPAGE=IPAGE+1
GO TO 20162
20164 NPARM=NVARS+MRELAS
WRITE(ISAVE) (IBASIS(I),I=1,NPARM)
ENDFILE ISAVE
C
C CLOSE FILE, IPAGEF, WHERE PAGES ARE STORED. THIS IS NEEDED SO THAT
C THE PAGES MAY BE RESTORED AT A CONTINUATION OF SPLP().
GO TO 20317
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (DECOMPOSE BASIS MATRIX)
C++ CODE FOR OUTPUT=YES IS ACTIVE
30004 IF (.NOT.(KPRINT.GE.2)) GO TO 20165
CALL IVOUT(MRELAS,IBASIS,
*'('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')',
*IDG)
C++ CODE FOR OUTPUT=NO IS INACTIVE
C++ END
C
C SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE.
20165 UU=0.1
CALL SPLPDM(
*MRELAS,NVARS,LMX,LBM,NREDC,INFO,IOPT,
*IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
*ANORM,EPS,UU,GG,
*AMAT,BASMAT,CSC,WR,
*SINGLR,REDBAS)
IF (.NOT.(INFO.LT.0)) GO TO 20168
GO TO 30001
20168 CONTINUE
GO TO NPR004, (20013,20204,20242)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (CLASSIFY VARIABLES)
C
C DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES
C -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND.
C (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS))
C TRANSLATE VARIABLE TO ITS UPPER BOUND, IF .GT. UPPER BOUND
30007 PRIMAL(NVARS+1)=ZERO
CALL SCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
I=1
N20172=MRELAS
GO TO 20173
20172 I=I+1
20173 IF ((N20172-I).LT.0) GO TO 20174
J=IBASIS(I)
IF (.NOT.(IND(J).NE.4)) GO TO 20176
IF (.NOT.(RPRIM(I).LT.ZERO)) GO TO 20179
PRIMAL(I+NVARS)=-ONE
GO TO 20180
20179 IF (.NOT.(IND(J).EQ.3)) GO TO 10009
UPBND=BU(J)-BL(J)
IF (J.LE.NVARS) UPBND=UPBND/CSC(J)
IF (.NOT.(RPRIM(I).GT.UPBND)) GO TO 20182
RPRIM(I)=RPRIM(I)-UPBND
IF (.NOT.(J.LE.NVARS)) GO TO 20185
K=0
20188 CALL PNNZRS(K,AIJ,IPLACE,AMAT,IMAT,J)
IF (.NOT.(K.LE.0)) GO TO 20190
GO TO 20189
20190 RHS(K)=RHS(K)-UPBND*AIJ*CSC(J)
GO TO 20188
20189 GO TO 20186
20185 RHS(J-NVARS)=RHS(J-NVARS)+UPBND
20186 PRIMAL(I+NVARS)=ONE
20182 CONTINUE
CONTINUE
10009 CONTINUE
20180 CONTINUE
20176 GO TO 20172
20174 CONTINUE
GO TO NPR007, (20020,20036)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS)
30005 NTRIES=1
GO TO 20195
20194 NTRIES=NTRIES+1
20195 IF ((2-NTRIES).LT.0) GO TO 20196
CALL SPLPCE(
*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)
IF (.NOT.(.NOT. SINGLR)) GO TO 20198
C++ CODE FOR OUTPUT=YES IS ACTIVE
IF (.NOT.(KPRINT.GE.3)) GO TO 20201
CALL SVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG)
CALL SVOUT(MRELAS,ERD,'('' EST. ERROR IN DUAL COMPS.'')',IDG)
20201 CONTINUE
C++ CODE FOR OUTPUT=NO IS INACTIVE
C++ END
GO TO 20193
20198 IF (NTRIES.EQ.2) GO TO 20197
ASSIGN 20204 TO NPR004
GO TO 30004
20204 CONTINUE
GO TO 20194
20196 CONTINUE
20197 NERR=26
CALL XERMSG ('SLATEC', 'SPLPMN',
+ 'IN SPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.',
+ NERR, IOPT)
INFO=-NERR
GO TO 30001
20193 CONTINUE
GO TO NPR005, (20018,20154,20243)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (CHECK FEASIBILITY)
C
C SEE IF NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT
C EQUATIONS.
C
C COPY RHS INTO WW(*), THEN UPDATE WW(*).
30008 CALL SCOPY(MRELAS,RHS,1,WW,1)
J=1
N20206=MRELAS
GO TO 20207
20206 J=J+1
20207 IF ((N20206-J).LT.0) GO TO 20208
IBAS=IBASIS(J)
XVAL=RPRIM(J)
C
C ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND.
IF (IND(IBAS).LE.3) XVAL=MAX(ZERO,XVAL)
C
C IF THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND.
IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20210
UPBND=BU(IBAS)-BL(IBAS)
IF (IBAS.LE.NVARS) UPBND=UPBND/CSC(IBAS)
XVAL=MIN(UPBND,XVAL)
20210 CONTINUE
C
C SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*)
IF (.NOT.(XVAL.NE.ZERO)) GO TO 20213
IF (.NOT.(IBAS.LE.NVARS)) GO TO 20216
I=0
20219 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,IBAS)
IF (.NOT.(I.LE.0)) GO TO 20221
GO TO 20220
20221 WW(I)=WW(I)-XVAL*AIJ*CSC(IBAS)
GO TO 20219
20220 GO TO 20217
20216 IF (.NOT.(IND(IBAS).EQ.2)) GO TO 20224
WW(IBAS-NVARS)=WW(IBAS-NVARS)-XVAL
GO TO 20225
20224 WW(IBAS-NVARS)=WW(IBAS-NVARS)+XVAL
20225 CONTINUE
20217 CONTINUE
20213 CONTINUE
GO TO 20206
C
C COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY.
20208 RESNRM=SASUM(MRELAS,WW,1)
FEAS=RESNRM.LE.TOLLS*(RPRNRM*ANORM+RHSNRM)
C
C TRY AN ABSOLUTE ERROR TEST IF THE RELATIVE TEST FAILS.
IF(.NOT. FEAS)FEAS=RESNRM.LE.TOLABS
IF (.NOT.(FEAS)) GO TO 20227
PRIMAL(NVARS+1)=ZERO
CALL SCOPY(MRELAS,PRIMAL(NVARS+1),0,PRIMAL(NVARS+1),1)
20227 CONTINUE
GO TO NPR008, (20024,20032,20040)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS)
30014 CALL SPINCW(
*MRELAS,NVARS,LMX,LBM,NPP,JSTRT,
*IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
*COSTSC,GG,ERDNRM,DULNRM,
*AMAT,BASMAT,CSC,WR,WW,RZ,RG,COSTS,COLNRM,DUALS,
*STPEDG)
C
GO TO NPR014, (20135,20246)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS)
30019 IF (.NOT.(ITLP.GT.MXITLP)) GO TO 20230
NERR=25
ASSIGN 20233 TO NPR011
GO TO 30011
C++ CODE FOR OUTPUT=YES IS ACTIVE
20233 IF (.NOT.(KPRINT.GE.1)) GO TO 20234
ASSIGN 20237 TO NPR012
GO TO 30012
20237 CONTINUE
20234 CONTINUE
C++ CODE FOR OUTPUT=NO IS INACTIVE
C++ END
IDUM(1)=0
IF(SAVEDT) IDUM(1)=ISAVE
WRITE (XERN1, '(I8)') MXITLP
WRITE (XERN2, '(I8)') IDUM(1)
CALL XERMSG ('SLATEC', 'SPLPMN',
* 'IN SPLP, MAX ITERATIONS = ' // XERN1 //
* ' TAKEN. UP-TO-DATE RESULTS SAVED ON FILE NO. ' // XERN2 //
* '. IF FILE NO. = 0, NO SAVE.', NERR, IOPT)
INFO=-NERR
GO TO 30001
20230 CONTINUE
GO TO 20155
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN)
30016 IF (.NOT.(.NOT.REDBAS)) GO TO 20239
ASSIGN 20242 TO NPR004
GO TO 30004
20242 ASSIGN 20243 TO NPR005
GO TO 30005
20243 ASSIGN 20244 TO NPR006
GO TO 30006
20244 ASSIGN 20245 TO NPR013
GO TO 30013
20245 ASSIGN 20246 TO NPR014
GO TO 30014
20246 CONTINUE
C
C ERASE NON-CYCLING MARKERS NEAR COMPLETION.
20239 I=MRELAS+1
N20247=MRELAS+NVARS
GO TO 20248
20247 I=I+1
20248 IF ((N20247-I).LT.0) GO TO 20249
IBASIS(I)=ABS(IBASIS(I))
GO TO 20247
20249 ASSIGN 20251 TO NPR015
GO TO 30015
20251 CONTINUE
GO TO 20145
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (COMPUTE NEW PRIMAL)
C
C COPY RHS INTO WW(*), SOLVE SYSTEM.
30006 CALL SCOPY(MRELAS,RHS,1,WW,1)
TRANS = .FALSE.
CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
CALL SCOPY(MRELAS,WW,1,RPRIM,1)
RPRNRM=SASUM(MRELAS,RPRIM,1)
GO TO NPR006, (20019,20031,20039,20244,20275)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (COMPUTE NEW DUALS)
C
C SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*).
30013 I=1
N20252=MRELAS
GO TO 20253
20252 I=I+1
20253 IF ((N20252-I).LT.0) GO TO 20254
J=IBASIS(I)
IF (.NOT.(J.LE.NVARS)) GO TO 20256
DUALS(I)=COSTSC*COSTS(J)*CSC(J) + XLAMDA*PRIMAL(I+NVARS)
GO TO 20257
20256 DUALS(I)=XLAMDA*PRIMAL(I+NVARS)
20257 CONTINUE
GO TO 20252
C
20254 TRANS=.TRUE.
CALL LA05BS(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS)
DULNRM=SASUM(MRELAS,DUALS,1)
GO TO NPR013, (20134,20245,20267)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION)
30015 CALL 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)
GO TO NPR015, (20141,20251)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS)
30017 CALL SPLPFL(
*MRELAS,NVARS,IENTER,ILEAVE,
*IBASIS,IND,IBB,
*THETA,DIRNRM,RPRNRM,
*CSC,WW,BL,BU,ERP,RPRIM,PRIMAL,
*FINITE,ZEROLV)
GO TO 20149
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (MAKE MOVE AND UPDATE)
30018 CALL SPLPMU(
*MRELAS,NVARS,LMX,LBM,NREDC,INFO,IENTER,ILEAVE,IOPT,NPP,JSTRT,
*IBASIS,IMAT,IBRC,IPR,IWR,IND,IBB,
*ANORM,EPS,UU,GG,RPRNRM,ERDNRM,DULNRM,THETA,COSTSC,XLAMDA,RHSNRM,
*AMAT,BASMAT,CSC,WR,RPRIM,WW,BU,BL,RHS,ERD,ERP,RZ,RG,COLNRM,COSTS,
*PRIMAL,DUALS,SINGLR,REDBAS,ZEROLV,STPEDG)
IF (.NOT.(INFO.EQ.(-26))) GO TO 20259
GO TO 30001
C++ CODE FOR OUTPUT=YES IS ACTIVE
20259 IF (.NOT.(KPRINT.GE.2)) GO TO 20263
GO TO 30021
20266 CONTINUE
C++ CODE FOR OUTPUT=NO IS INACTIVE
C++ END
20263 CONTINUE
GO TO 20153
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE(RESCALE AND REARRANGE VARIABLES)
C
C RESCALE THE DUAL VARIABLES.
30011 ASSIGN 20267 TO NPR013
GO TO 30013
20267 IF (.NOT.(COSTSC.NE.ZERO)) GO TO 20268
I=1
N20271=MRELAS
GO TO 20272
20271 I=I+1
20272 IF ((N20271-I).LT.0) GO TO 20273
DUALS(I)=DUALS(I)/COSTSC
GO TO 20271
20273 CONTINUE
20268 ASSIGN 20275 TO NPR006
GO TO 30006
C
C REAPPLY COLUMN SCALING TO PRIMAL.
20275 I=1
N20276=MRELAS
GO TO 20277
20276 I=I+1
20277 IF ((N20276-I).LT.0) GO TO 20278
J=IBASIS(I)
IF (.NOT.(J.LE.NVARS)) GO TO 20280
SCALR=CSC(J)
IF(IND(J).EQ.2)SCALR=-SCALR
RPRIM(I)=RPRIM(I)*SCALR
20280 GO TO 20276
C
C REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*)
20278 PRIMAL(1)=ZERO
CALL SCOPY(NVARS+MRELAS,PRIMAL,0,PRIMAL,1)
J=1
N20283=NVARS+MRELAS
GO TO 20284
20283 J=J+1
20284 IF ((N20283-J).LT.0) GO TO 20285
IBAS=ABS(IBASIS(J))
XVAL=ZERO
IF (J.LE.MRELAS) XVAL=RPRIM(J)
IF (IND(IBAS).EQ.1) XVAL=XVAL+BL(IBAS)
IF (IND(IBAS).EQ.2) XVAL=BU(IBAS)-XVAL
IF (.NOT.(IND(IBAS).EQ.3)) GO TO 20287
IF (MOD(IBB(IBAS),2).EQ.0) XVAL=BU(IBAS)-BL(IBAS)-XVAL
XVAL = XVAL+BL(IBAS)
20287 PRIMAL(IBAS)=XVAL
GO TO 20283
C
C COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS.
C OTHER ENTRIES ARE ZERO.
20285 J=1
N20290=NVARS
GO TO 20291
20290 J=J+1
20291 IF ((N20290-J).LT.0) GO TO 20292
RZJ=ZERO
IF (.NOT.(IBB(J).GT.ZERO .AND. IND(J).NE.4)) GO TO 20294
RZJ=COSTS(J)
I=0
20297 CALL PNNZRS(I,AIJ,IPLACE,AMAT,IMAT,J)
IF (.NOT.(I.LE.0)) GO TO 20299
GO TO 20298
20299 CONTINUE
RZJ=RZJ-AIJ*DUALS(I)
GO TO 20297
20298 CONTINUE
20294 DUALS(MRELAS+J)=RZJ
GO TO 20290
20292 CONTINUE
GO TO NPR011, (20051,20233)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C++ CODE FOR OUTPUT=YES IS ACTIVE
C PROCEDURE (PRINT PROLOGUE)
30003 IDUM(1)=MRELAS
CALL IVOUT(1,IDUM,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',IDG)
IDUM(1)=NVARS
CALL IVOUT(1,IDUM,'('' NUM. OF INDEPENDENT VARS., NVARS'')',IDG)
CALL IVOUT(1,IDUM,'('' DIMENSION OF COSTS(*)='')',IDG)
IDUM(1)=NVARS+MRELAS
CALL IVOUT(1,IDUM, '('' DIMENSIONS OF BL(*),BU(*),IND(*)''
*/'' PRIMAL(*),DUALS(*) ='')',IDG)
CALL IVOUT(1,IDUM,'('' DIMENSION OF IBASIS(*)='')',IDG)
IDUM(1)=LPRG+1
CALL IVOUT(1,IDUM,'('' DIMENSION OF PRGOPT(*)='')',IDG)
CALL IVOUT(0,IDUM,
* '('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''/
* '' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''/
* '' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',IDG)
CALL IVOUT(0,IDUM,
* '('' 1=VARIABLE HAS ONLY LOWER BOUND.''/
* '' 2=VARIABLE HAS ONLY UPPER BOUND.''/
* '' 3=VARIABLE HAS BOTH BOUNDS.''/
* '' 4=VARIABLE HAS NO BOUNDS, IT IS FREE.'')',IDG)
CALL SVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG)
CALL IVOUT(NVARS+MRELAS,IND,
* '('' CONSTRAINT INDICATORS'')',IDG)
CALL SVOUT(NVARS+MRELAS,BL,
*'('' LOWER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG)
CALL SVOUT(NVARS+MRELAS,BU,
*'('' UPPER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG)
IF (.NOT.(KPRINT.GE.2)) GO TO 20302
CALL IVOUT(0,IDUM,
* '(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES''
* '' EXCHANGED AT A ZERO''/'' STEP LENGTH'')',IDG)
CALL IVOUT(0,IDUM,
* '('' WHEN COL. NO. LEAVING=COL. NO. ENTERING, THE ENTERING ''
* ''VARIABLE MOVED''/'' TO ITS BOUND. IT REMAINS NON-BASIC.''/
* '' WHEN COL. NO. OF BASIS EXCHANGED IS NEGATIVE, THE LEAVING''/
* '' VARIABLE IS AT ITS UPPER BOUND.'')',IDG)
20302 CONTINUE
GO TO 20011
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (PRINT SUMMARY)
30012 IDUM(1)=INFO
CALL IVOUT(1,IDUM,'('' THE OUTPUT VALUE OF INFO IS'')',IDG)
IF (.NOT.(MINPRB)) GO TO 20305
CALL IVOUT(0,IDUM,'('' THIS IS A MINIMIZATION PROBLEM.'')',IDG)
GO TO 20306
20305 CALL IVOUT(0,IDUM,'('' THIS IS A MAXIMIZATION PROBLEM.'')',IDG)
20306 IF (.NOT.(STPEDG)) GO TO 20308
CALL IVOUT(0,IDUM,'('' STEEPEST EDGE PRICING WAS USED.'')',IDG)
GO TO 20309
20308 CALL IVOUT(0,IDUM,'('' MINIMUM REDUCED COST PRICING WAS USED.'')',
* IDG)
20309 RDUM(1)=SDOT(NVARS,COSTS,1,PRIMAL,1)
CALL SVOUT(1,RDUM,
* '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG)
CALL SVOUT(NVARS+MRELAS,PRIMAL,
* '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG)
CALL SVOUT(MRELAS+NVARS,DUALS,
* '('' THE OUTPUT DUAL VARIABLES'')',IDG)
CALL IVOUT(NVARS+MRELAS,IBASIS,
* '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
IDUM(1)=ITLP
CALL IVOUT(1,IDUM,'('' NO. OF ITERATIONS'')',IDG)
IDUM(1)=NREDC
CALL IVOUT(1,IDUM,'('' NO. OF FULL REDECOMPS'')',IDG)
GO TO NPR012, (20096,20237)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (PRINT ITERATION SUMMARY)
30021 IDUM(1)=ITLP+1
CALL IVOUT(1,IDUM,'(''0ITERATION NUMBER'')',IDG)
IDUM(1)=IBASIS(ABS(ILEAVE))
CALL IVOUT(1,IDUM,
* '('' INDEX OF VARIABLE ENTERING THE BASIS'')',IDG)
IDUM(1)=ILEAVE
CALL IVOUT(1,IDUM,'('' COLUMN OF THE BASIS EXCHANGED'')',IDG)
IDUM(1)=IBASIS(IENTER)
CALL IVOUT(1,IDUM,
* '('' INDEX OF VARIABLE LEAVING THE BASIS'')',IDG)
RDUM(1)=THETA
CALL SVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG)
IF (.NOT.(KPRINT.GE.3)) GO TO 20311
CALL SVOUT(MRELAS,RPRIM,'('' BASIC (INTERNAL) PRIMAL SOLN.'')',
* IDG)
CALL IVOUT(NVARS+MRELAS,IBASIS,
* '('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',IDG)
CALL IVOUT(NVARS+MRELAS,IBB,'('' IBB ARRAY'')',IDG)
CALL SVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG)
CALL SVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
20311 CONTINUE
GO TO 20266
C++ CODE FOR OUTPUT=NO IS INACTIVE
C++ END
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (RETURN TO USER)
30001 IF (.NOT.(SAVEDT)) GO TO 20314
GO TO 30020
20317 CONTINUE
20314 IF(IMAT(LMX-1).NE.(-1)) CALL SCLOSM(IPAGEF)
C
C THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN
C COMPILERS.
RETURN
END
Reference in a new issue View git blame Copy permalink