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/dplpmn.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 DPLPMN
SUBROUTINE DPLPMN (DUSRMT, 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 DPLPMN
C***SUBSIDIARY
C***PURPOSE Subsidiary to DSPLP
C***LIBRARY SLATEC
C***TYPE DOUBLE 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 DSPLP PACKAGE.
C
C***SEE ALSO DSPLP
C***ROUTINES CALLED DASUM, DCOPY, DDOT, DPINCW, DPINIT, DPINTM, DPLPCE,
C DPLPDM, DPLPFE, DPLPFL, DPLPMU, DPLPUP, DPNNZR,
C DPOPT, DPRWPG, DVOUT, IVOUT, LA05BD, SCLOSM, XERMSG
C***COMMON BLOCKS LA05DD
C***REVISION HISTORY (YYMMDD)
C 811215 DATE WRITTEN
C 890531 Changed all specific intrinsics to generic. (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 DPLPMN
DOUBLE PRECISION 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
DOUBLE PRECISION DDOT,DASUM
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 DOUBLE MACHINE PRECISION
C TUNE DOUBLE PARAMETER TO SCALE ERROR ESTIMATES
C TOLLS DOUBLE RELATIVE TOLERANCE FOR SMALL RESIDUALS
C TOLABS DOUBLE ABSOLUTE TOLERANCE FOR SMALL RESIDUALS.
C USED IF RELATIVE ERROR TEST FAILS.
C IN CONSTRAINT EQUATIONS
C FACTOR DOUBLE .01--DETERMINES IF BASIS IS SINGULAR
C OR COMPONENT IS FEASIBLE. MAY NEED TO
C BE INCREASED TO 1.D0 ON SHORT WORD
C LENGTH MACHINES.
C ASMALL DOUBLE LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
C ABIG DOUBLE 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 DOUBLE COSTS(*) SCALING
C SCOSTS DOUBLE TEMP LOC. FOR COSTSC.
C XLAMDA DOUBLE WEIGHT PARAMETER FOR PEN. METHOD.
C ANORM DOUBLE NORM OF DATA MATRIX AMAT(*)
C RPRNRM DOUBLE NORM OF THE SOLUTION
C DULNRM DOUBLE NORM OF THE DUALS
C ERDNRM DOUBLE NORM OF ERROR IN DUAL VARIABLES
C DIRNRM DOUBLE NORM OF THE DIRECTION VECTOR
C RHSNRM DOUBLE NORM OF TRANSLATED RIGHT HAND SIDE VECTOR
C RESNRM DOUBLE 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 DOUBLE 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 DOUBLE 0.1--USED IN HARWELL SPARSE CODE
C FOR RELATIVE PIVOTING TOLERANCE.
C GG DOUBLE 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 /LA05DD/ SMALL,LP,LENL,LENU,NCP,LROW,LCOL
EXTERNAL DUSRMT
C
C SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE.
C***FIRST EXECUTABLE STATEMENT DPLPMN
LP=0
C
C THE VALUES ZERO AND ONE.
ZERO=0.D0
ONE=1.D0
FACTOR=0.01D0
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 DPOPT(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 DPINTM(MRELAS,NVARS,AMAT,IMAT,LMX,IPAGEF)
C
C UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY.
20004 CALL DPLPUP(DUSRMT,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 DPINIT(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', 'DPLPMN',
+ 'IN DSPLP, 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', 'DPLPMN',
+ 'IN DSPLP, 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', 'DPLPMN',
+ 'IN DSPLP, 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', 'DPLPMN',
+ 'IN DSPLP, 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', 'DPLPMN',
+ 'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO ' //
+ 'HAVE NO FINITE SOLN.', NERR, IOPT)
INFO=-NERR
10003 CONTINUE
20053 CONTINUE
C
IF (.NOT.(INFO.EQ.(-1) .OR. INFO.EQ.(-3))) GO TO 20055
SIZE=DASUM(NVARS,PRIMAL,1)*ANORM
SIZE=SIZE/DASUM(NVARS,CSC,1)
SIZE=SIZE+DASUM(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 DCOPY(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 DPNNZR(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 DPNNZR(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 DVOUT(MRELAS,DUALS,'('' BASIC (INTERNAL) DUAL SOLN.'')',IDG)
CALL DVOUT(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 DVOUT(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 DPRWPG(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 DPRWPG(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 DPRWPG(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 DSPLP().
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 DPLPDM(
*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 DCOPY(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 DPNNZR(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 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)
IF (.NOT.(.NOT. SINGLR)) GO TO 20198
C++ CODE FOR OUTPUT=YES IS ACTIVE
IF (.NOT.(KPRINT.GE.3)) GO TO 20201
CALL DVOUT(MRELAS,ERP,'('' EST. ERROR IN PRIMAL COMPS.'')',IDG)
CALL DVOUT(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', 'DPLPMN',
+ 'IN DSPLP, 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 DCOPY(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 DPNNZR(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
CONTINUE
20217 CONTINUE
20213 CONTINUE
GO TO 20206
C
C COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY.
20208 RESNRM=DASUM(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 DCOPY(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 DPINCW(
*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', 'DPLPMN',
* 'IN DSPLP, 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 DCOPY(MRELAS,RHS,1,WW,1)
TRANS = .FALSE.
CALL LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,WW,TRANS)
CALL DCOPY(MRELAS,WW,1,RPRIM,1)
RPRNRM=DASUM(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 LA05BD(BASMAT,IBRC,LBM,MRELAS,IPR,IWR,WR,GG,DUALS,TRANS)
DULNRM=DASUM(MRELAS,DUALS,1)
GO TO NPR013, (20134,20245,20267)
C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION)
30015 CALL DPLPFE(
*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 DPLPFL(
*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 DPLPMU(
*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 DCOPY(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 DPNNZR(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 DVOUT(NVARS,COSTS,'('' ARRAY OF COSTS'')',IDG)
CALL IVOUT(NVARS+MRELAS,IND,
* '('' CONSTRAINT INDICATORS'')',IDG)
CALL DVOUT(NVARS+MRELAS,BL,
*'('' LOWER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',IDG)
CALL DVOUT(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)=DDOT(NVARS,COSTS,1,PRIMAL,1)
CALL DVOUT(1,RDUM,
* '('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',IDG)
CALL DVOUT(NVARS+MRELAS,PRIMAL,
* '('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',IDG)
CALL DVOUT(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 DVOUT(1,RDUM,'('' LENGTH OF THE EXCHANGE STEP'')',IDG)
IF (.NOT.(KPRINT.GE.3)) GO TO 20311
CALL DVOUT(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 DVOUT(MRELAS,RHS,'('' TRANSLATED RHS'')',IDG)
CALL DVOUT(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