| [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]=dplpmn(dusrmt,mrelas,nvars,costs,prgopt,dattrv,bl,bu,ind,info,primal,duals,amat,csc,colnrm,erd, |
function [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]=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);
persistent abig aij anorm asmall colscp contin costsc cstscp dirnrm dulnrm eps erdnrm factor feas finite found gg gt100 gt1000 gt1100 gt1200 gt1300 gt1400 gt1500 gt1600 gt1700 gt1800 gt1900 gt200 gt2000 gt300 gt400 gt500 gt600 gt700 gt800 gt900 i ibas idg idum ienter ileave intopt iopt ipage ipagef iplace isave itbrc itlp j jstrt k key kprint lopt lpg lpr lpr1 lprg minprb mxitlp n20046 n20058 n20080 n20098 n20119 n20172 n20206 n20247 n20252 n20271 n20276 n20283 n20290 nerr np nparm npp npr004 npr005 npr006 npr007 npr008 npr009 npr010 npr011 npr012 npr013 npr014 npr015 nredc ntries nx0066 nx0091 nx0106 one rdum redbas resnrm rhsnrm ropt rprnrm rzj savedt scalr scosts singlr sizemlv sizeup stpedg theta tolabs tolls trans tune unbnd upbnd usrbas uu xern1 xern2 xlamda xval zero zerolv ;
if isempty(i), i=0; end;
if isempty(ibas), ibas=0; end;
if isempty(idg), idg=0; end;
if isempty(ienter), ienter=0; end;
if isempty(ileave), ileave=0; end;
if isempty(iopt), iopt=0; end;
if isempty(ipage), ipage=0; end;
if isempty(ipagef), ipagef=0; end;
if isempty(iplace), iplace=0; end;
if isempty(isave), isave=0; end;
if isempty(itbrc), itbrc=0; end;
if isempty(itlp), itlp=0; end;
if isempty(j), j=0; end;
if isempty(jstrt), jstrt=0; end;
if isempty(k), k=0; end;
if isempty(key), key=0; end;
if isempty(kprint), kprint=0; end;
global la05dd_7; if isempty(la05dd_7), la05dd_7=0; end;
global la05dd_3; if isempty(la05dd_3), la05dd_3=0; end;
global la05dd_4; if isempty(la05dd_4), la05dd_4=0; end;
global la05dd_2; if isempty(la05dd_2), la05dd_2=0; end;
if isempty(lpg), lpg=0; end;
if isempty(lpr), lpr=0; end;
if isempty(lpr1), lpr1=0; end;
if isempty(lprg), lprg=0; end;
global la05dd_6; if isempty(la05dd_6), la05dd_6=0; end;
if isempty(mxitlp), mxitlp=0; end;
if isempty(n20046), n20046=0; end;
if isempty(n20058), n20058=0; end;
if isempty(n20080), n20080=0; end;
if isempty(n20098), n20098=0; end;
if isempty(n20119), n20119=0; end;
if isempty(n20172), n20172=0; end;
if isempty(n20206), n20206=0; end;
if isempty(n20247), n20247=0; end;
if isempty(n20252), n20252=0; end;
if isempty(n20271), n20271=0; end;
if isempty(n20276), n20276=0; end;
if isempty(n20283), n20283=0; end;
if isempty(n20290), n20290=0; end;
global la05dd_5; if isempty(la05dd_5), la05dd_5=0; end;
if isempty(nerr), nerr=0; end;
if isempty(np), np=0; end;
if isempty(nparm), nparm=0; end;
if isempty(npp), npp=0; end;
if isempty(npr004), npr004=0; end;
if isempty(npr005), npr005=0; end;
if isempty(npr006), npr006=0; end;
if isempty(npr007), npr007=0; end;
if isempty(npr008), npr008=0; end;
if isempty(npr009), npr009=0; end;
if isempty(npr010), npr010=0; end;
if isempty(npr011), npr011=0; end;
if isempty(npr012), npr012=0; end;
if isempty(npr013), npr013=0; end;
if isempty(npr014), npr014=0; end;
if isempty(npr015), npr015=0; end;
if isempty(nredc), nredc=0; end;
if isempty(ntries), ntries=0; end;
if isempty(nx0066), nx0066=0; end;
if isempty(nx0091), nx0091=0; end;
if isempty(nx0106), nx0106=0; end;
if isempty(gt100), gt100=false; end;
if isempty(gt200), gt200=false; end;
if isempty(gt300), gt300=false; end;
if isempty(gt400), gt400=false; end;
if isempty(gt500), gt500=false; end;
if isempty(gt600), gt600=false; end;
if isempty(gt700), gt700=false; end;
if isempty(gt800), gt800=false; end;
if isempty(gt900), gt900=false; end;
if isempty(gt1000), gt1000=false; end;
if isempty(gt1100), gt1100=false; end;
if isempty(gt1200), gt1200=false; end;
if isempty(gt1300), gt1300=false; end;
if isempty(gt1400), gt1400=false; end;
if isempty(gt1500), gt1500=false; end;
if isempty(gt1600), gt1600=false; end;
if isempty(gt1700), gt1700=false; end;
if isempty(gt1800), gt1800=false; end;
if isempty(gt1900), gt1900=false; end;
if isempty(gt2000), gt2000=false; end;
%***BEGIN PROLOGUE DPLPMN
%***SUBSIDIARY
%***PURPOSE Subsidiary to DSPLP
%***LIBRARY SLATEC
%***TYPE doubleprecision (SPLPMN-S, DPLPMN-D)
%***AUTHOR (UNKNOWN)
%***DESCRIPTION
%
% MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT.
% THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR.
%
% MAIN SUBROUTINE FOR DSPLP PACKAGE.
%
%***SEE ALSO DSPLP
%***ROUTINES CALLED DASUM, DCOPY, DDOT, DPINCW, DPINIT, DPINTM, DPLPCE,
% DPLPDM, DPLPFE, DPLPFL, DPLPMU, DPLPUP, DPNNZR,
% DPOPT, DPRWPG, DVOUT, IVOUT, LA05BD, SCLOSM, XERMSG
%***COMMON BLOCKS LA05DD
%***REVISION HISTORY (YYMMDD)
% 811215 DATE WRITTEN
% 890531 Changed all specific intrinsics to generic. (WRB)
% 890605 Removed unreferenced labels. (WRB)
% 891009 Removed unreferenced variable. (WRB)
% 891214 Prologue converted to Version 4.0 format. (BAB)
% 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ)
% 900328 Added TYPE section. (WRB)
% 900510 Convert XERRWV calls to XERMSG calls. (RWC)
%***end PROLOGUE DPLPMN
if isempty(abig), abig=0; end;
if isempty(aij), aij=0; end;
amat_shape=size(amat);amat=reshape(amat,1,[]);
if isempty(anorm), anorm=0; end;
if isempty(asmall), asmall=0; end;
basmat_shape=size(basmat);basmat=reshape(basmat,1,[]);
bl_shape=size(bl);bl=reshape(bl,1,[]);
bu_shape=size(bu);bu=reshape(bu,1,[]);
colnrm_shape=size(colnrm);colnrm=reshape(colnrm,1,[]);
costs_shape=size(costs);costs=reshape(costs,1,[]);
if isempty(costsc), costsc=0; end;
csc_shape=size(csc);csc=reshape(csc,1,[]);
dattrv_shape=size(dattrv);dattrv=reshape(dattrv,1,[]);
if isempty(dirnrm), dirnrm=0; end;
duals_shape=size(duals);duals=reshape(duals,1,[]);
if isempty(dulnrm), dulnrm=0; end;
if isempty(eps), eps=0; end;
if isempty(tune), tune=0; end;
erd_shape=size(erd);erd=reshape(erd,1,[]);
if isempty(erdnrm), erdnrm=0; end;
erp_shape=size(erp);erp=reshape(erp,1,[]);
if isempty(factor), factor=0; end;
if isempty(gg), gg=0; end;
if isempty(one), one=0; end;
prgopt_shape=size(prgopt);prgopt=reshape(prgopt,1,[]);
primal_shape=size(primal);primal=reshape(primal,1,[]);
if isempty(resnrm), resnrm=0; end;
rg_shape=size(rg);rg=reshape(rg,1,[]);
rhs_shape=size(rhs);rhs=reshape(rhs,1,[]);
if isempty(rhsnrm), rhsnrm=0; end;
if isempty(ropt), ropt=zeros(1,07); end;
rprim_shape=size(rprim);rprim=reshape(rprim,1,[]);
if isempty(rprnrm), rprnrm=0; end;
rz_shape=size(rz);rz=reshape(rz,1,[]);
if isempty(rzj), rzj=0; end;
if isempty(scalr), scalr=0; end;
if isempty(scosts), scosts=0; end;
if isempty(sizemlv), sizemlv=0; end;
global la05dd_1; if isempty(la05dd_1), la05dd_1=0; end;
if isempty(theta), theta=0; end;
if isempty(tolls), tolls=0; end;
if isempty(upbnd), upbnd=0; end;
if isempty(uu), uu=0; end;
wr_shape=size(wr);wr=reshape(wr,1,[]);
ww_shape=size(ww);ww=reshape(ww,1,[]);
if isempty(xlamda), xlamda=0; end;
if isempty(xval), xval=0; end;
if isempty(zero), zero=0; end;
if isempty(rdum), rdum=zeros(1,01); end;
if isempty(tolabs), tolabs=0; end;
%
ibasis_shape=size(ibasis);ibasis=reshape(ibasis,1,[]);
ibb_shape=size(ibb);ibb=reshape(ibb,1,[]);
ibrc_orig=ibrc;ibrc_shape=[lbm,2];ibrc=reshape([ibrc_orig(1:min(prod(ibrc_shape),numel(ibrc_orig))),zeros(1,max(0,prod(ibrc_shape)-numel(ibrc_orig)))],ibrc_shape);
imat_shape=size(imat);imat=reshape(imat,1,[]);
ind_shape=size(ind);ind=reshape(ind,1,[]);
ipr_shape=size(ipr);ipr=reshape(ipr,1,[]);
iwr_shape=size(iwr);iwr=reshape(iwr,1,[]);
if isempty(intopt), intopt=zeros(1,08); end;
if isempty(idum), idum=zeros(1,01); end;
%
% ARRAY LOCAL VARIABLES
% NAME(LENGTH) DESCRIPTION
%
% COSTS(NVARS) COST COEFFICIENTS
% PRGOPT( ) OPTION VECTOR
% DATTRV( ) DATA TRANSFER VECTOR
% PRIMAL(NVARS+MRELAS) AS OUTPUT IT IS PRIMAL SOLUTION OF LP.
% INTERNALLY, THE FIRST NVARS POSITIONS HOLD
% THE COLUMN CHECK SUMS. THE NEXT MRELAS
% POSITIONS HOLD THE CLASSIFICATION FOR THE
% BASIC VARIABLES -1 VIOLATES LOWER
% BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND
% DUALS(MRELAS+NVARS) DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE
% AS FIRST MRELAS ENTRIES.
% AMAT(LMX) SPARSE FORM OF DATA MATRIX
% IMAT(LMX) SPARSE FORM OF DATA MATRIX
% BL(NVARS+MRELAS) LOWER BOUNDS FOR VARIABLES
% BU(NVARS+MRELAS) UPPER BOUNDS FOR VARIABLES
% IND(NVARS+MRELAS) INDICATOR FOR VARIABLES
% CSC(NVARS) COLUMN SCALING
% IBASIS(NVARS+MRELAS) COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC
% IBB(NVARS+MRELAS) INDICATOR FOR NON-BASIC VARS., POLARITY OF
% VARS., AND POTENTIALLY INFINITE VARS.
% IF IBB(J).LT.0, VARIABLE J IS BASIC
% IF IBB(J).GT.0, VARIABLE J IS NON-BASIC
% IF IBB(J).EQ.0, VARIABLE J HAS TO BE IGNORED
% BECAUSE IT WOULD CAUSE UNBOUNDED SOLN.
% WHEN MOD(IBB(J),2).EQ.0, VARIABLE IS AT ITS
% UPPER BOUND, OTHERWISE IT IS AT ITS LOWER
% BOUND
% COLNRM(NVARS) NORM OF COLUMNS
% ERD(MRELAS) ERRORS IN DUAL VARIABLES
% ERP(MRELAS) ERRORS IN PRIMAL VARIABLES
% BASMAT(LBM) BASIS MATRIX FOR HARWELL SPARSE CODE
% IBRC(LBM,2) ROW AND COLUMN POINTERS FOR BASMAT(*)
% IPR(2*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE
% IWR(8*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE
% WR(MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE
% RZ(NVARS+MRELAS) REDUCED COSTS
% RPRIM(MRELAS) INTERNAL PRIMAL SOLUTION
% RG(NVARS+MRELAS) COLUMN WEIGHTS
% WW(MRELAS) WORK ARRAY
% RHS(MRELAS) HOLDS TRANSLATED RIGHT HAND SIDE
%
% SCALAR LOCAL VARIABLES
% NAME TYPE DESCRIPTION
%
% LMX INTEGER LENGTH OF AMAT(*)
% LPG INTEGER LENGTH OF PAGE FOR AMAT(*)
% EPS DOUBLE MACHINE PRECISION
% TUNE DOUBLE PARAMETER TO SCALE ERROR ESTIMATES
% TOLLS DOUBLE RELATIVE TOLERANCE FOR SMALL RESIDUALS
% TOLABS DOUBLE ABSOLUTE TOLERANCE FOR SMALL RESIDUALS.
% USED IF RELATIVE ERROR TEST FAILS.
% IN CONSTRAINT EQUATIONS
% FACTOR DOUBLE .01--DETERMINES IF BASIS IS SINGULAR
% OR COMPONENT IS FEASIBLE. MAY NEED TO
% BE INCREASED TO 1.0D0 ON SHORT WORD
% LENGTH MACHINES.
% ASMALL DOUBLE LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
% ABIG DOUBLE UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
% MXITLP INTEGER MAXIMUM NUMBER OF ITERATIONS FOR LP
% ITLP INTEGER ITERATION COUNTER FOR TOTAL LP ITERS
% COSTSC DOUBLE COSTS(*) SCALING
% SCOSTS DOUBLE TEMP LOC. FOR COSTSC.
% XLAMDA DOUBLE WEIGHT PARAMETER FOR PEN. METHOD.
% ANORM DOUBLE NORM OF DATA MATRIX AMAT(*)
% RPRNRM DOUBLE NORM OF THE SOLUTION
% DULNRM DOUBLE NORM OF THE DUALS
% ERDNRM DOUBLE NORM OF ERROR IN DUAL VARIABLES
% DIRNRM DOUBLE NORM OF THE DIRECTION VECTOR
% RHSNRM DOUBLE NORM OF TRANSLATED RIGHT HAND SIDE VECTOR
% RESNRM DOUBLE NORM OF RESIDUAL VECTOR FOR CHECKING
% FEASIBILITY
% NZBM INTEGER NUMBER OF NON-ZEROS IN BASMAT(*)
% LBM INTEGER LENGTH OF BASMAT(*)
% SMALL DOUBLE EPS*ANORM USED IN HARWELL SPARSE CODE
% LP INTEGER USED IN HARWELL LA05*() PACK AS OUTPUT
% FILE NUMBER. SET=I1MACH(4) NOW.
% UU DOUBLE 0.1--USED IN HARWELL SPARSE CODE
% FOR RELATIVE PIVOTING TOLERANCE.
% GG DOUBLE OUTPUT INFO FLAG IN HARWELL SPARSE CODE
% IPLACE INTEGER INTEGER USED BY SPARSE MATRIX CODES
% IENTER INTEGER NEXT COLUMN TO ENTER BASIS
% NREDC INTEGER NO. OF FULL REDECOMPOSITIONS
% KPRINT INTEGER LEVEL OF OUTPUT, =0-3
% IDG INTEGER FORMAT AND PRECISION OF OUTPUT
% ITBRC INTEGER NO. OF ITERS. BETWEEN RECALCULATING
% THE ERROR IN THE PRIMAL SOLUTION.
% NPP INTEGER NO. OF NEGATIVE REDUCED COSTS REQUIRED
% IN PARTIAL PRICING
% JSTRT INTEGER STARTING PLACE FOR PARTIAL PRICING.
%
if isempty(colscp), colscp=false; end;
if isempty(savedt), savedt=false; end;
if isempty(contin), contin=false; end;
if isempty(cstscp), cstscp=false; end;
if isempty(unbnd), unbnd=false; end;
if isempty(feas), feas=false; end;
if isempty(finite), finite=false; end;
if isempty(found), found=false; end;
if isempty(minprb), minprb=false; end;
if isempty(redbas), redbas=false; end;
if isempty(singlr), singlr=false; end;
if isempty(sizeup), sizeup=false; end;
if isempty(stpedg), stpedg=false; end;
if isempty(trans), trans=false; end;
if isempty(usrbas), usrbas=false; end;
if isempty(zerolv), zerolv=false; end;
if isempty(lopt), lopt=zeros(1,08); end;
if isempty(xern1), xern1=repmat(' ',1,8); end;
if isempty(xern2), xern2=repmat(' ',1,8); end;
% equivalence(contin,lopt(1)) ::;
% equivalence(usrbas,lopt(2)) ::;
% equivalence(sizeup,lopt(3)) ::;
% equivalence(savedt,lopt(4)) ::;
% equivalence(colscp,lopt(5)) ::;
% equivalence(cstscp,lopt(6)) ::;
% equivalence(minprb,lopt(7)) ::;
% equivalence(stpedg,lopt(8)) ::;
% equivalence(idg,intopt(1)) ::;
% equivalence(ipagef,intopt(2)) ::;
% equivalence(isave,intopt(3)) ::;
% equivalence(mxitlp,intopt(4)) ::;
% equivalence(kprint,intopt(5)) ::;
% equivalence(itbrc,intopt(6)) ::;
% equivalence(npp,intopt(7)) ::;
% equivalence(lprg,intopt(8)) ::;
% equivalence(eps,ropt(1)) ::;
% equivalence(asmall,ropt(2)) ::;
% equivalence(abig,ropt(3)) ::;
% equivalence(costsc,ropt(4)) ::;
% equivalence(tolls,ropt(5)) ::;
% equivalence(tune,ropt(6)) ::;
% equivalence(tolabs,ropt(7)) ::;
%
% COMMON BLOCK USED BY LA05 () PACKAGE..
% common :: ;
%% common /la05dd/ small , lp , lenl , lenu , ncp , lrow , lcol;
%% common /la05dd/ la05dd_1 , la05dd_2 , la05dd_3 , la05dd_4 , la05dd_5 , la05dd_6 , la05dd_7;
%
% SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE.
%***FIRST EXECUTABLE STATEMENT DPLPMN
la05dd_2 = 0;
%
% THE VALUES ZERO AND ONE.
zero = 0.0d0;
one = 1.0d0;
factor = 0.01d0;
lpg = fix(lmx -(nvars+4));
iopt = 1;
info = 0;
unbnd = false;
jstrt = 1;
%
% PROCESS USER OPTIONS IN PRGOPT(*).
% CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED.
gt100=false;
gt200=false;
gt300=false;
gt400=false;
gt500=false;
gt600=false;
gt700=false;
gt800=false;
gt900=false;
gt1000=false;
gt1100=false;
gt1200=false;
gt1300=false;
gt1400=false;
gt1500=false;
gt1600=false;
gt1700=false;
gt1800=false;
gt1900=false;
gt2000=false;
while (1);
if(gt2000==0)
if(gt1900==0)
if(gt1800==0)
if(gt1700==0)
if(gt1600==0)
if(gt1500==0)
if(gt1400==0)
if(gt1300==0)
if(gt1200==0)
if(gt1100==0)
if(gt1000==0)
if(gt900==0)
if(gt800==0)
if(gt700==0)
if(gt600==0)
if(gt500==0)
if(gt400==0)
if(gt300==0)
if(gt200==0)
if(gt100==0)
[prgopt,mrelas,nvars,info,csc,ibasis,ropt,intopt,lopt]=dpopt(prgopt,mrelas,nvars,info,csc,ibasis,ropt,intopt,lopt);
if( info<0 )
break;
end;
if( contin )
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE)
lpr = fix(nvars + 4);
rewind isave;
[amat([1:lpr]) ,imat([1:lpr])]=readf(isave,['%f'],1);
key = 2;
ipage = 1;
while( true );
lpr1 = fix(lpr + 1);
[amat([lpr1:lmx]) ,imat([lpr1:lmx])]=readf(isave,['%f'],1);
[key,ipage,lpg,amat,imat]=dprwpg(key,ipage,lpg,amat,imat);
np = fix(imat(lmx-1));
ipage = fix(ipage + 1);
if( np<0 )
break;
end;
end;
nparm = fix(nvars + mrelas);
[ibasis([1:nparm])]=readf(isave,['%f'],1);
rewind isave;
else;
%
% INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*).
[mrelas,nvars,amat,imat,lmx,ipagef]=dpintm(mrelas,nvars,amat,imat,lmx,ipagef);
end;
%
% UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY.
[dusrmt,mrelas,nvars,prgopt,dattrv,bl,bu,ind,info,amat,imat,sizeup,asmall,abig]=dplpup(dusrmt,mrelas,nvars,prgopt,dattrv,bl,bu,ind,info,amat,imat,sizeup,asmall,abig);
if( info<0 )
break;
end;
%
%++ CODE FOR OUTPUT=YES IS ACTIVE
if( kprint>=1 )
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%++ CODE FOR OUTPUT=YES IS ACTIVE
% PROCEDURE (PRINT PROLOGUE)
idum(1) = fix(mrelas);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'(''1NUM. OF DEPENDENT VARS., MRELAS'')',idg);
idum(1) = fix(nvars);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' NUM. OF INDEPENDENT VARS., NVARS'')',idg);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' DIMENSION OF COSTS(*)='')',idg);
idum(1) = fix(nvars + mrelas);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' DIMENSIONS OF BL(*),BU(*),IND(*)'' /'' PRIMAL(*),DUALS&(*) ='')',idg);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' DIMENSION OF IBASIS(*)='')',idg);
idum(1) = fix(lprg + 1);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' DIMENSION OF PRGOPT(*)='')',idg);
[dumvar1,idum,dumvar3,idg]=ivout(0,idum,'('' 1-NVARS=INDEPENDENT VARIABLE INDICES.''/ &'' (NVARS+1)-(NVARS+MRELAS)=DEPENDENT VARIABLE INDICES.''/'' CONSTRAINT INDICATORS ARE 1-4 AND MEAN'')',idg);
[dumvar1,idum,dumvar3,idg]=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);
[nvars,costs,dumvar3,idg]=dvout(nvars,costs,'('' ARRAY OF COSTS'')',idg);
[dumvar1,ind,dumvar3,idg]=ivout(nvars+mrelas,ind,'('' CONSTRAINT INDICATORS'')',idg);
[dumvar1,bl,dumvar3,idg]=dvout(nvars+mrelas,bl,'('' LOWER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',idg);
[dumvar1,bu,dumvar3,idg]=dvout(nvars+mrelas,bu,'('' UPPER BOUNDS FOR VARIABLES (IGNORE UNUSED ENTRIES.)'')',idg);
if( kprint>=2 )
[dumvar1,idum,dumvar3,idg]=ivout(0,idum,'(''0NON-BASIC INDICES THAT ARE NEGATIVE SHOW VARIABLES'' &'' EXCHANGED AT A ZERO''/'' STEP LENGTH'')',idg);
[dumvar1,idum,dumvar3,idg]=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);
end;
end;
%++ CODE FOR OUTPUT=NO IS INACTIVE
%++ end
%
% INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN
% CHECK SUMS, AND FORM INITIAL BASIS MATRIX.
[mrelas,nvars,costs,bl,bu,ind,primal,info,amat,csc,costsc,colnrm,xlamda,anorm,rhs,rhsnrm,ibasis,ibb,imat,lopt]=dpinit(mrelas,nvars,costs,bl,bu,ind,primal,info,amat,csc,costsc,colnrm,xlamda,anorm,rhs,rhsnrm,ibasis,ibb,imat,lopt);
if( info<0 )
break;
end;
%
nredc = 0;
npr004 = 200;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (DECOMPOSE BASIS MATRIX)
%++ CODE FOR OUTPUT=YES IS ACTIVE
end;
gt100=0;
if( kprint>=2 )
[mrelas,ibasis,dumvar3,idg]=ivout(mrelas,ibasis,'('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')',idg);
end;
%++ CODE FOR OUTPUT=NO IS INACTIVE
%++ end
%
% SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE.
uu = 0.1;
[mrelas,nvars,lmx,lbm,nredc,info,iopt,ibasis,imat,ibrc,ipr,iwr,ind,ibb,anorm,eps,uu,gg,amat,basmat,csc,wr,singlr,redbas]=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( info<0 )
break;
end;
if( npr004==200 )
if( singlr )
nerr = 23;
[dumvar1,dumvar2,dumvar3,nerr,iopt]=xermsg('SLATEC','DPLPMN','IN DSPLP, A SINGULAR INITIAL BASIS WAS ENCOUNTERED.',nerr,iopt);
info = fix(-nerr);
break;
else;
npr005 = 300;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS)
ntries = 1;
end;
elseif( npr004==3900 ) ;
npr005 = 4000;
ntries = 1;
elseif( npr004==3200 ) ;
ntries = fix(ntries + 1);
else;
gt400=1;
continue;
end;
end;
gt200=0;
if((2-ntries)<0 )
gt1700=1;
continue;
%GOTO 1700
end;
[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]=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( singlr )
if( ntries==2 )
gt1700=1;
continue;
%GOTO 1700
end;
npr004 = 3200;
gt100=1;
continue;
else;
%++ CODE FOR OUTPUT=YES IS ACTIVE
if( kprint>=3 )
[mrelas,erp,dumvar3,idg]=dvout(mrelas,erp,'('' EST. ERROR IN PRIMAL COMPS.'')',idg);
%++ CODE FOR OUTPUT=NO IS INACTIVE
%++ end
[mrelas,erd,dumvar3,idg]=dvout(mrelas,erd,'('' EST. ERROR IN DUAL COMPS.'')',idg);
end;
if( npr005==300 )
npr006 = 400;
elseif( npr005==2600 ) ;
gt1300=1;
continue;
elseif( npr005==4000 ) ;
npr006 = 4100;
else;
gt1700=1;
continue;
end;
end;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (COMPUTE NEW PRIMAL)
%
% COPY RHS INTO WW(*), SOLVE SYSTEM.
end;
gt300=0;
[mrelas,rhs,dumvar3,ww]=dcopy(mrelas,rhs,1,ww,1);
trans = false;
[basmat,ibrc,lbm,mrelas,ipr,iwr,wr,gg,ww,trans]=la05bd(basmat,ibrc,lbm,mrelas,ipr,iwr,wr,gg,ww,trans);
[mrelas,ww,dumvar3,rprim]=dcopy(mrelas,ww,1,rprim,1);
[rprnrm ,mrelas,rprim]=dasum(mrelas,rprim,1);
if( npr006==400 )
npr007 = 500;
elseif( npr006==1000 ) ;
npr008 = 1100;
gt500 =1;
continue;
elseif( npr006==1500 ) ;
npr008 = 1600;
gt500 =1;
continue;
elseif( npr006==4100 ) ;
npr013 = 4200;
gt700 =1;
continue;
elseif( npr006==5000 ) ;
%
% REAPPLY COLUMN SCALING TO PRIMAL.
i = 1;
n20276 = fix(mrelas);
while((n20276-i)>=0 );
j = fix(ibasis(i));
if( j<=nvars )
scalr = csc(j);
if( ind(j)==2 )
scalr = -scalr;
end;
rprim(i) = rprim(i).*scalr;
end;
i = fix(i + 1);
end;
%
% REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*)
primal(1) = zero;
primal_orig=primal; [dumvar1,primal,dumvar3,dumvar4]=dcopy(nvars+mrelas,primal,0,primal,1); primal(dumvar4~=primal_orig)=dumvar4(dumvar4~=primal_orig);
j = 1;
n20283 = fix(nvars + mrelas);
while((n20283-j)>=0 );
ibas = fix(abs(ibasis(j)));
xval = zero;
if( j<=mrelas )
xval = rprim(j);
end;
if( ind(ibas)==1 )
xval = xval + bl(ibas);
end;
if( ind(ibas)==2 )
xval = bu(ibas) - xval;
end;
if( ind(ibas)==3 )
if( rem(ibb(ibas),2)==0 )
xval = bu(ibas) - bl(ibas) - xval;
end;
xval = xval + bl(ibas);
end;
primal(ibas) = xval;
j = fix(j + 1);
end;
%
% COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS.
% OTHER ENTRIES ARE ZERO.
j = 1;
n20290 = fix(nvars);
while((n20290-j)>=0 );
rzj = zero;
if( ibb(j)>zero && ind(j)~=4 )
rzj = costs(j);
i = 0;
while( true );
[i,aij,iplace,amat,imat,j]=dpnnzr(i,aij,iplace,amat,imat,j);
if( i<=0 )
break;
end;
rzj = rzj - aij.*duals(i);
end;
end;
duals(mrelas+j) = rzj;
j = fix(j + 1);
end;
if( npr011==1800 )
if( feas &&(~unbnd) )
info = 1;
elseif((~feas) &&(~unbnd) ) ;
nerr = 1;
[dumvar1,dumvar2,dumvar3,nerr,iopt]=xermsg('SLATEC','DPLPMN','IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE',nerr,iopt);
info = fix(-nerr);
elseif( feas && unbnd ) ;
nerr = 2;
[dumvar1,dumvar2,dumvar3,nerr,iopt]=xermsg('SLATEC','DPLPMN','IN DSPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.',nerr,iopt);
info = fix(-nerr);
elseif((~feas) && unbnd ) ;
nerr = 3;
[dumvar1,dumvar2,dumvar3,nerr,iopt]=xermsg('SLATEC','DPLPMN',['IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO ','HAVE NO FINITE SOLN.'],nerr,iopt);
info = fix(-nerr);
end;
%
if( info==(-1) || info==(-3) )
sizemlv = dasum(nvars,primal,1).*anorm;
sizemlv = sizemlv./dasum(nvars,csc,1);
sizemlv = sizemlv + dasum(mrelas,primal(sub2ind(size(primal),max(nvars+1,1)):end),1);
i = 1;
n20058 = fix(nvars + mrelas);
while((n20058-i)>=0 );
nx0066 = fix(ind(i));
if( nx0066>=1 && nx0066<=4 )
if( nx0066==2 )
if( sizemlv+abs(primal(i)-bu(i)).*factor~=sizemlv )
if( primal(i)>=bu(i) )
ind(i) = -4;
end;
end;
elseif( nx0066==3 ) ;
if( sizemlv+abs(primal(i)-bl(i)).*factor~=sizemlv )
if( primal(i)<bl(i) )
ind(i) = -4;
elseif( sizemlv+abs(primal(i)-bu(i)).*factor~=sizemlv ) ;
if( primal(i)>bu(i) )
ind(i) = -4;
end;
end;
end;
elseif( nx0066~=4 ) ;
if( sizemlv+abs(primal(i)-bl(i)).*factor~=sizemlv )
if( primal(i)<=bl(i) )
ind(i) = -4;
end;
end;
end;
end;
i = fix(i + 1);
end;
end;
%
if( info==(-2) || info==(-3) )
j = 1;
n20080 = fix(nvars);
while((n20080-j)>=0 );
if( ibb(j)==0 )
nx0091 = fix(ind(j));
if( nx0091>=1 && nx0091<=4 )
if( nx0091==2 )
bl(j) = bu(j);
ind(j) = -3;
elseif( nx0091~=3 ) ;
if( nx0091==4 )
bl(j) = zero;
bu(j) = zero;
ind(j) = -3;
else;
bu(j) = bl(j);
ind(j) = -3;
end;
end;
end;
end;
j = fix(j + 1);
end;
end;
%++ CODE FOR OUTPUT=YES IS ACTIVE
if( kprint<1 )
break;
end;
npr012 = 5300;
%++ CODE FOR OUTPUT=NO IS INACTIVE
%++ end
gt1900 =1;
continue;
elseif( npr011==3700 ) ;
gt1800 =1;
continue;
else;
gt1900 =1;
continue;
end;
else;
gt700 =1;
continue;
end;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (CLASSIFY VARIABLES)
%
% DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES
% -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND.
% (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS))
% TRANSLATE VARIABLE TO ITS UPPER BOUND, IF .GT. UPPER BOUND
end;
gt400=0;
primal(nvars+1) = zero;
[mrelas,dumvar2,dumvar3,dumvar2]=dcopy(mrelas,primal(sub2ind(size(primal),max(nvars+1,1)):end),0,primal(sub2ind(size(primal),max(nvars+1,1)):end),1); dumvar2i=find((primal(sub2ind(size(primal),max(nvars+1,1)):end))~=(dumvar2)); primal(nvars+1-1+dumvar2i)=dumvar2(dumvar2i);
i = 1;
n20172 = fix(mrelas);
while((n20172-i)>=0 );
j = fix(ibasis(i));
if( ind(j)~=4 )
if( rprim(i)<zero )
primal(i+nvars) = -one;
elseif( ind(j)==3 ) ;
upbnd = bu(j) - bl(j);
if( j<=nvars )
upbnd = upbnd./csc(j);
end;
if( rprim(i)>upbnd )
rprim(i) = rprim(i) - upbnd;
if( j>nvars )
rhs(j-nvars) = rhs(j-nvars) + upbnd;
else;
k = 0;
while( true );
[k,aij,iplace,amat,imat,j]=dpnnzr(k,aij,iplace,amat,imat,j);
if( k<=0 )
break;
end;
rhs(k) = rhs(k) - upbnd.*aij.*csc(j);
end;
end;
primal(i+nvars) = one;
end;
end;
end;
i = fix(i + 1);
end;
if( npr007==500 )
if( ~(usrbas) )
gt600 =1;
continue;
end;
npr008 = 600;
elseif( npr007~=1200 ) ;
ntries = fix(ntries + 1);
gt200 =1;
continue;
else;
npr009 = 1300;
npr013 = 2200;
gt700 =1;
continue;
end;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (CHECK FEASIBILITY)
%
% SEE IF NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT
% EQUATIONS.
%
% COPY RHS INTO WW(*), THEN UPDATE WW(*).
end;
gt500=0;
[mrelas,rhs,dumvar3,ww]=dcopy(mrelas,rhs,1,ww,1);
j = 1;
n20206 = fix(mrelas);
while((n20206-j)>=0 );
ibas = fix(ibasis(j));
xval = rprim(j);
%
% ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND.
if( ind(ibas)<=3 )
xval = max(zero,xval);
end;
%
% IF THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND.
if( ind(ibas)==3 )
upbnd = bu(ibas) - bl(ibas);
if( ibas<=nvars )
upbnd = upbnd./csc(ibas);
end;
xval = min(upbnd,xval);
end;
%
% SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*)
if( xval==zero )
j = fix(j + 1);
elseif( ibas>nvars ) ;
if( ind(ibas)==2 )
ww(ibas-nvars) = ww(ibas-nvars) - xval;
else;
ww(ibas-nvars) = ww(ibas-nvars) + xval;
end;
j = fix(j + 1);
else;
i = 0;
while( true );
[i,aij,iplace,amat,imat,ibas]=dpnnzr(i,aij,iplace,amat,imat,ibas);
if( i<=0 )
break;
end;
ww(i) = ww(i) - xval.*aij.*csc(ibas);
end;
j = fix(j + 1);
end;
end;
%
% COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY.
[resnrm ,mrelas,ww]=dasum(mrelas,ww,1);
feas = resnrm<=tolls.*(rprnrm.*anorm+rhsnrm);
%
% TRY AN ABSOLUTE ERROR TEST IF THE RELATIVE TEST FAILS.
if( ~feas )
feas = resnrm<=tolabs;
end;
if( feas )
primal(nvars+1) = zero;
[mrelas,dumvar2,dumvar3,dumvar2]=dcopy(mrelas,primal(sub2ind(size(primal),max(nvars+1,1)):end),0,primal(sub2ind(size(primal),max(nvars+1,1)):end),1); dumvar2i=find((primal(sub2ind(size(primal),max(nvars+1,1)):end))~=(dumvar2)); primal(nvars+1-1+dumvar2i)=dumvar2(dumvar2i);
end;
if( npr008==600 )
if( ~feas )
nerr = 24;
[dumvar1,dumvar2,dumvar3,nerr,iopt]=xermsg('SLATEC','DPLPMN','IN DSPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.',nerr,iopt);
info = fix(-nerr);
break;
end;
elseif( npr008~=1100 ) ;
if( npr008~=1600 )
gt900 =1;
continue;
end;
if( ~feas )
gt1500 =1;
continue;
end;
%
% SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2.
if( kprint>1 )
[dumvar1,idum,dumvar3,idg]=ivout(0,idum,'('' ENTER STANDARD PHASE-2'')',idg);
end;
xlamda = zero;
costsc = scosts;
npr009 = 1700;
npr013 = 2200;
gt700 =1;
continue;
elseif( feas ) ;
% CHECK IF ANY BASIC VARIABLES ARE STILL CLASSIFIED AS
% INFEASIBLE. IF ANY ARE, THEN THIS MAY NOT YET BE AN
% OPTIMAL POINT. THEREFORE SET LAMDA TO ZERO AND TRY
% TO PERFORM MORE SIMPLEX STEPS.
i = 1;
n20046 = fix(mrelas);
while((n20046-i)>=0 );
if( primal(i+nvars)~=zero )
xlamda = zero;
npr009 = 1700;
npr013 = 2200;
gt700 =1;
continue;
else;
i = fix(i + 1);
end;
end;
gt1500 =1;
continue;
else;
%
% SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF
% COSTSC) AND PERFORM STANDARD PHASE-1.
if( kprint>=2 )
[dumvar1,idum,dumvar3,idg]=ivout(0,idum,'('' ENTER STANDARD PHASE-1'')',idg);
end;
scosts = costsc;
costsc = zero;
npr007 = 1200;
gt400 =1;
continue;
end;
end;
gt600=0;
itlp = 0;
%
% LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD.
npr009 = 800;
% PROCEDURE (PERFORM SIMPLEX STEPS)
npr013 = 2200;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (COMPUTE NEW DUALS)
%
% SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*).
end;
gt700=0;
i = 1;
n20252 = fix(mrelas);
while((n20252-i)>=0 );
j = fix(ibasis(i));
if( j>nvars )
duals(i) = xlamda.*primal(i+nvars);
else;
duals(i) = costsc.*costs(j).*csc(j) + xlamda.*primal(i+nvars);
end;
i = fix(i + 1);
end;
%
trans = true;
[basmat,ibrc,lbm,mrelas,ipr,iwr,wr,gg,duals,trans]=la05bd(basmat,ibrc,lbm,mrelas,ipr,iwr,wr,gg,duals,trans);
[dulnrm ,mrelas,duals]=dasum(mrelas,duals,1);
if( npr013~=2200 )
if( npr013==4900 )
gt1600 =1;
continue;
end;
if( npr013~=4200 )
gt1000 =1;
continue;
end;
npr014 = 4300;
gt900 =1;
continue;
end;
gt800=0;
end;
npr014 = 2300;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS)
end;
gt900=0;
[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]=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);
%
if( npr014~=2300 )
if( npr014~=4300 )
gt1800 =1;
continue;
end;
gt1100 =1;
continue;
else;
if( kprint>2 )
[mrelas,duals,dumvar3,idg]=dvout(mrelas,duals,'('' BASIC (INTERNAL) DUAL SOLN.'')',idg);
[dumvar1,rz,dumvar3,idg]=dvout(nvars+mrelas,rz,'('' REDUCED COSTS'')',idg);
end;
npr015 = 2400;
end;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION)
end;
gt1000=0;
[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]=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);
if( npr015==2400 )
if( found )
gt1200 =1;
continue;
end;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN)
if( ~redbas )
npr004 = 3900;
gt100 =1;
continue;
end;
elseif( npr015==2500 ) ;
gt1200 =1;
continue;
else;
gt1600 =1;
continue;
end;
%
% ERASE NON-CYCLING MARKERS NEAR COMPLETION.
end;
gt1100=0;
i = fix(mrelas + 1);
n20247 = fix(mrelas + nvars);
while((n20247-i)>=0 );
ibasis(i) = fix(abs(ibasis(i)));
i = fix(i + 1);
end;
npr015 = 2500;
gt1000 =1;
continue;
end;
gt1200=0;
if( found )
if( kprint>=3 )
[mrelas,ww,dumvar3,idg]=dvout(mrelas,ww,'('' SEARCH DIRECTION'')',idg);
end;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS)
[mrelas,nvars,ienter,ileave,ibasis,ind,ibb,theta,dirnrm,rprnrm,csc,ww,bl,bu,erp,rprim,primal,finite,zerolv]=dplpfl(mrelas,nvars,ienter,ileave,ibasis,ind,ibb,theta,dirnrm,rprnrm,csc,ww,bl,bu,erp,rprim,primal,finite,zerolv);
if( finite )
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (MAKE MOVE AND UPDATE)
[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]=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( info==(-26) )
break;
end;
%++ CODE FOR OUTPUT=YES IS ACTIVE
if( kprint>=2 )
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (PRINT ITERATION SUMMARY)
idum(1) = fix(itlp + 1);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'(''0ITERATION NUMBER'')',idg);
idum(1) = fix(ibasis(abs(ileave)));
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' INDEX OF VARIABLE ENTERING THE BASIS'')',idg);
idum(1) = fix(ileave);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' COLUMN OF THE BASIS EXCHANGED'')',idg);
idum(1) = fix(ibasis(ienter));
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' INDEX OF VARIABLE LEAVING THE BASIS'')',idg);
rdum(1) = theta;
[dumvar1,rdum,dumvar3,idg]=dvout(1,rdum,'('' LENGTH OF THE EXCHANGE STEP'')',idg);
if( kprint>=3 )
%++ CODE FOR OUTPUT=NO IS INACTIVE
%++ end
[mrelas,rprim,dumvar3,idg]=dvout(mrelas,rprim,'('' BASIC (INTERNAL) PRIMAL SOLN.'')',idg);
[dumvar1,ibasis,dumvar3,idg]=ivout(nvars+mrelas,ibasis,'('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',idg);
[dumvar1,ibb,dumvar3,idg]=ivout(nvars+mrelas,ibb,'('' IBB ARRAY'')',idg);
[mrelas,rhs,dumvar3,idg]=dvout(mrelas,rhs,'('' TRANSLATED RHS'')',idg);
[mrelas,duals,dumvar3,idg]=dvout(mrelas,duals,'('' BASIC (INTERNAL) DUAL SOLN.'')',idg);
end;
end;
npr005 = 2600;
ntries = 1;
gt200 =1;
continue;
else;
unbnd = true;
ibb(ibasis(ienter)) = 0;
end;
elseif( npr009==800 ) ;
npr010 = 900;
gt1400 =1;
continue;
elseif( npr009==1700 ) ;
gt1500 =1;
continue;
elseif( npr009==1300 ) ;
npr010 = 1400;
gt1400 =1;
continue;
end;
end;
gt1300=0;
itlp = fix(itlp + 1);
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS)
if( itlp>mxitlp )
nerr = 25;
npr011 = 3700;
npr013 = 4900;
gt700 =1;
continue;
else;
npr015 = 2400;
gt1000 =1;
continue;
end;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (COMPUTE RIGHT HAND SIDE)
end;
gt1400=0;
rhs(1) = zero;
rhs_orig=rhs; [mrelas,rhs,dumvar3,dumvar4]=dcopy(mrelas,rhs,0,rhs,1); rhs(dumvar4~=rhs_orig)=dumvar4(dumvar4~=rhs_orig);
j = 1;
n20098 = fix(nvars + mrelas);
while((n20098-j)>=0 );
nx0106 = fix(ind(j));
if( nx0106>=1 && nx0106<=4 )
if( nx0106==2 )
scalr = -bu(j);
elseif( nx0106==3 ) ;
scalr = -bl(j);
elseif( nx0106==4 ) ;
scalr = zero;
else;
scalr = -bl(j);
end;
end;
if( scalr==zero )
j = fix(j + 1);
elseif( j>nvars ) ;
rhs(j-nvars) = rhs(j-nvars) - scalr;
j = fix(j + 1);
else;
i = 0;
while( true );
[i,aij,iplace,amat,imat,j]=dpnnzr(i,aij,iplace,amat,imat,j);
if( i<=0 )
break;
end;
rhs(i) = rhs(i) + aij.*scalr;
end;
j = fix(j + 1);
end;
end;
j = 1;
n20119 = fix(nvars + mrelas);
while((n20119-j)>=0 );
scalr = zero;
if( ind(j)==3 && rem(ibb(j),2)==0 )
scalr = bu(j) - bl(j);
end;
if( scalr==zero )
j = fix(j + 1);
elseif( j>nvars ) ;
rhs(j-nvars) = rhs(j-nvars) + scalr;
j = fix(j + 1);
else;
i = 0;
while( true );
[i,aij,iplace,amat,imat,j]=dpnnzr(i,aij,iplace,amat,imat,j);
if( i<=0 )
break;
end;
rhs(i) = rhs(i) - aij.*scalr;
end;
j = fix(j + 1);
end;
end;
if( npr010==900 )
npr006 = 1000;
gt300 =1;
continue;
else;
if( npr010~=1400 )
gt800 =1;
continue;
end;
npr006 = 1500;
gt300 =1;
continue;
end;
%
end;
gt1500=0;
npr011 = 1800;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE(RESCALE AND REARRANGE VARIABLES)
%
% RESCALE THE DUAL VARIABLES.
npr013 = 4900;
gt700 =1;
continue;
end;
gt1600=0;
if( costsc==zero )
npr006 = 5000;
else;
i = 1;
n20271 = fix(mrelas);
while((n20271-i)>=0 );
duals(i) = duals(i)./costsc;
i = fix(i + 1);
end;
npr006 = 5000;
end;
gt300 =1;
continue;
end;
gt1700=0;
nerr = 26;
[dumvar1,dumvar2,dumvar3,nerr,iopt]=xermsg('SLATEC','DPLPMN','IN DSPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.',nerr,iopt);
info = fix(-nerr);
break;
%++ CODE FOR OUTPUT=YES IS ACTIVE
end;
gt1800=0;
if( kprint<1 )
gt2000 =1;
continue;
end;
npr012 = 3800;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (PRINT SUMMARY)
end;
gt1900=0;
idum(1) = fix(info);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' THE OUTPUT VALUE OF INFO IS'')',idg);
if( minprb )
[dumvar1,idum,dumvar3,idg]=ivout(0,idum,'('' THIS IS A MINIMIZATION PROBLEM.'')',idg);
else;
[dumvar1,idum,dumvar3,idg]=ivout(0,idum,'('' THIS IS A MAXIMIZATION PROBLEM.'')',idg);
end;
if( stpedg )
[dumvar1,idum,dumvar3,idg]=ivout(0,idum,'('' STEEPEST EDGE PRICING WAS USED.'')',idg);
else;
[dumvar1,idum,dumvar3,idg]=ivout(0,idum,'('' MINIMUM REDUCED COST PRICING WAS USED.'')',idg);
end;
[rdum(1) ,nvars,costs,dumvar4,primal]=ddot(nvars,costs,1,primal,1);
[dumvar1,rdum,dumvar3,idg]=dvout(1,rdum,'('' OUTPUT VALUE OF THE OBJECTIVE FUNCTION'')',idg);
[dumvar1,primal,dumvar3,idg]=dvout(nvars+mrelas,primal,'('' THE OUTPUT INDEPENDENT AND DEPENDENT VARIABLES'')',idg);
[dumvar1,duals,dumvar3,idg]=dvout(mrelas+nvars,duals,'('' THE OUTPUT DUAL VARIABLES'')',idg);
[dumvar1,ibasis,dumvar3,idg]=ivout(nvars+mrelas,ibasis,'('' VARIABLE INDICES IN POSITIONS 1-MRELAS ARE BASIC.'')',idg);
idum(1) = fix(itlp);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' NO. OF ITERATIONS'')',idg);
idum(1) = fix(nredc);
[dumvar1,idum,dumvar3,idg]=ivout(1,idum,'('' NO. OF FULL REDECOMPS'')',idg);
if( npr012==5300 )
break;
end;
if( npr012~=3800 )
break;
end;
%++ CODE FOR OUTPUT=NO IS INACTIVE
%++ end
end;
gt2000=0;
idum(1) = 0;
if( savedt )
idum(1) = fix(isave);
end;
xern1=sprintf(['%8i'], mxitlp);
xern2=sprintf(['%8i'], idum(1));
[dumvar1,dumvar2,dumvar3,nerr,iopt]=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 = fix(-nerr);
%++ CODE FOR OUTPUT=NO IS INACTIVE
%++ end
break;
end;
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (RETURN TO USER)
if( savedt )
% CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
% PROCEDURE (SAVE DATA ON FILE ISAVE)
%
% SOME PAGES MAY NOT BE WRITTEN YET.
if( amat(lmx)==one )
amat(lmx) = zero;
key = 2;
ipage = fix(abs(imat(lmx-1)));
[key,ipage,lpg,amat,imat]=dprwpg(key,ipage,lpg,amat,imat);
end;
%
% FORCE PAGE FILE TO BE OPENED ON RESTARTS.
key = fix(amat(4));
amat(4) = zero;
lpr = fix(nvars + 4);
for i=(1):(lpr), for i=(1):(lpr), disp({amat(i) ,imat(i)}); end; end;
amat(4) = key;
ipage = 1;
key = 1;
while( true );
[key,ipage,lpg,amat,imat]=dprwpg(key,ipage,lpg,amat,imat);
lpr1 = fix(lpr + 1);
for i=(lpr1):(lmx), for i=(lpr1):(lmx), disp({amat(i) ,imat(i)}); end; end;
np = fix(imat(lmx-1));
ipage = fix(ipage + 1);
if( np<0 )
break;
end;
end;
nparm = fix(nvars + mrelas);
for i=(1):(nparm), disp({ibasis(i)}); end;
endfile isave;
if( imat(lmx-1)~=(-1) )
[ipagef]=sclosm(ipagef);
end;
amat_shape=zeros(amat_shape);amat_shape(:)=amat(1:numel(amat_shape));amat=amat_shape;
basmat_shape=zeros(basmat_shape);basmat_shape(:)=basmat(1:numel(basmat_shape));basmat=basmat_shape;
bl_shape=zeros(bl_shape);bl_shape(:)=bl(1:numel(bl_shape));bl=bl_shape;
bu_shape=zeros(bu_shape);bu_shape(:)=bu(1:numel(bu_shape));bu=bu_shape;
colnrm_shape=zeros(colnrm_shape);colnrm_shape(:)=colnrm(1:numel(colnrm_shape));colnrm=colnrm_shape;
costs_shape=zeros(costs_shape);costs_shape(:)=costs(1:numel(costs_shape));costs=costs_shape;
csc_shape=zeros(csc_shape);csc_shape(:)=csc(1:numel(csc_shape));csc=csc_shape;
dattrv_shape=zeros(dattrv_shape);dattrv_shape(:)=dattrv(1:numel(dattrv_shape));dattrv=dattrv_shape;
duals_shape=zeros(duals_shape);duals_shape(:)=duals(1:numel(duals_shape));duals=duals_shape;
erd_shape=zeros(erd_shape);erd_shape(:)=erd(1:numel(erd_shape));erd=erd_shape;
erp_shape=zeros(erp_shape);erp_shape(:)=erp(1:numel(erp_shape));erp=erp_shape;
prgopt_shape=zeros(prgopt_shape);prgopt_shape(:)=prgopt(1:numel(prgopt_shape));prgopt=prgopt_shape;
primal_shape=zeros(primal_shape);primal_shape(:)=primal(1:numel(primal_shape));primal=primal_shape;
rg_shape=zeros(rg_shape);rg_shape(:)=rg(1:numel(rg_shape));rg=rg_shape;
rhs_shape=zeros(rhs_shape);rhs_shape(:)=rhs(1:numel(rhs_shape));rhs=rhs_shape;
rprim_shape=zeros(rprim_shape);rprim_shape(:)=rprim(1:numel(rprim_shape));rprim=rprim_shape;
rz_shape=zeros(rz_shape);rz_shape(:)=rz(1:numel(rz_shape));rz=rz_shape;
wr_shape=zeros(wr_shape);wr_shape(:)=wr(1:numel(wr_shape));wr=wr_shape;
ww_shape=zeros(ww_shape);ww_shape(:)=ww(1:numel(ww_shape));ww=ww_shape;
ibasis_shape=zeros(ibasis_shape);ibasis_shape(:)=ibasis(1:numel(ibasis_shape));ibasis=ibasis_shape;
ibb_shape=zeros(ibb_shape);ibb_shape(:)=ibb(1:numel(ibb_shape));ibb=ibb_shape;
ibrc_orig(1:prod(ibrc_shape))=ibrc;ibrc=ibrc_orig;
imat_shape=zeros(imat_shape);imat_shape(:)=imat(1:numel(imat_shape));imat=imat_shape;
ind_shape=zeros(ind_shape);ind_shape(:)=ind(1:numel(ind_shape));ind=ind_shape;
ipr_shape=zeros(ipr_shape);ipr_shape(:)=ipr(1:numel(ipr_shape));ipr=ipr_shape;
iwr_shape=zeros(iwr_shape);iwr_shape(:)=iwr(1:numel(iwr_shape));iwr=iwr_shape;
return;
elseif( imat(lmx-1)~=(-1) ) ;
[ipagef]=sclosm(ipagef);
end;
%
% THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN
% COMPILERS.
amat_shape=zeros(amat_shape);amat_shape(:)=amat(1:numel(amat_shape));amat=amat_shape;
basmat_shape=zeros(basmat_shape);basmat_shape(:)=basmat(1:numel(basmat_shape));basmat=basmat_shape;
bl_shape=zeros(bl_shape);bl_shape(:)=bl(1:numel(bl_shape));bl=bl_shape;
bu_shape=zeros(bu_shape);bu_shape(:)=bu(1:numel(bu_shape));bu=bu_shape;
colnrm_shape=zeros(colnrm_shape);colnrm_shape(:)=colnrm(1:numel(colnrm_shape));colnrm=colnrm_shape;
costs_shape=zeros(costs_shape);costs_shape(:)=costs(1:numel(costs_shape));costs=costs_shape;
csc_shape=zeros(csc_shape);csc_shape(:)=csc(1:numel(csc_shape));csc=csc_shape;
dattrv_shape=zeros(dattrv_shape);dattrv_shape(:)=dattrv(1:numel(dattrv_shape));dattrv=dattrv_shape;
duals_shape=zeros(duals_shape);duals_shape(:)=duals(1:numel(duals_shape));duals=duals_shape;
erd_shape=zeros(erd_shape);erd_shape(:)=erd(1:numel(erd_shape));erd=erd_shape;
erp_shape=zeros(erp_shape);erp_shape(:)=erp(1:numel(erp_shape));erp=erp_shape;
prgopt_shape=zeros(prgopt_shape);prgopt_shape(:)=prgopt(1:numel(prgopt_shape));prgopt=prgopt_shape;
primal_shape=zeros(primal_shape);primal_shape(:)=primal(1:numel(primal_shape));primal=primal_shape;
rg_shape=zeros(rg_shape);rg_shape(:)=rg(1:numel(rg_shape));rg=rg_shape;
rhs_shape=zeros(rhs_shape);rhs_shape(:)=rhs(1:numel(rhs_shape));rhs=rhs_shape;
rprim_shape=zeros(rprim_shape);rprim_shape(:)=rprim(1:numel(rprim_shape));rprim=rprim_shape;
rz_shape=zeros(rz_shape);rz_shape(:)=rz(1:numel(rz_shape));rz=rz_shape;
wr_shape=zeros(wr_shape);wr_shape(:)=wr(1:numel(wr_shape));wr=wr_shape;
ww_shape=zeros(ww_shape);ww_shape(:)=ww(1:numel(ww_shape));ww=ww_shape;
ibasis_shape=zeros(ibasis_shape);ibasis_shape(:)=ibasis(1:numel(ibasis_shape));ibasis=ibasis_shape;
ibb_shape=zeros(ibb_shape);ibb_shape(:)=ibb(1:numel(ibb_shape));ibb=ibb_shape;
ibrc_orig(1:prod(ibrc_shape))=ibrc;ibrc=ibrc_orig;
imat_shape=zeros(imat_shape);imat_shape(:)=imat(1:numel(imat_shape));imat=imat_shape;
ind_shape=zeros(ind_shape);ind_shape(:)=ind(1:numel(ind_shape));ind=ind_shape;
ipr_shape=zeros(ipr_shape);ipr_shape(:)=ipr(1:numel(ipr_shape));ipr=ipr_shape;
iwr_shape=zeros(iwr_shape);iwr_shape(:)=iwr(1:numel(iwr_shape));iwr=iwr_shape;
end %subroutine dplpmn
%!!!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)
%!!IMPLICIT NONE
%!!!*--DPLPMN8
%!!REAL DUSRMT
%!!INTEGER i , ibas , idg , ienter , ileave , Info , iopt , ipage ,%!!ipagef , iplace , isave , itbrc , itlp , j , jstrt , k ,%!!key , kprint , Lbm , LCOl
%!!INTEGER LENl , LENu , Lmx , LP , lpg , lpr , lpr1 , lprg , LROw ,%!!Mrelas , mxitlp , n20046 , n20058 , n20080 , n20098 ,%!!n20119 , n20172 , n20206 , n20247 , n20252
%!!INTEGER n20271 , n20276 , n20283 , n20290 , NCP , nerr , np ,%!!nparm , npp , npr004 , npr005 , npr006 , npr007 , npr008 ,%!!npr009 , npr010 , npr011 , npr012 , npr013 , npr014
%!!INTEGER npr015 , nredc , ntries , Nvars , nx0066 , nx0091 , nx0106
%!!logical gt100,gt200,gt300,gt400,gt500,gt600,gt700,gt800,gt900,gt1000,gt1100,gt1200,gt1300,gt1400,gt1500,gt1600,gt1700,gt1800,gt1900,gt2000
%!!!***BEGIN PROLOGUE DPLPMN
%!!!***SUBSIDIARY
%!!!***PURPOSE Subsidiary to DSPLP
%!!!***LIBRARY SLATEC
%!!!***TYPE doubleprecision (SPLPMN-S, DPLPMN-D)
%!!!***AUTHOR (UNKNOWN)
%!!!***DESCRIPTION
%!!!
%!!! MARVEL OPTION(S).. OUTPUT=YES/NO TO ELIMINATE PRINTED OUTPUT.
%!!! THIS DOES NOT APPLY TO THE CALLS TO THE ERROR PROCESSOR.
%!!!
%!!! MAIN SUBROUTINE FOR DSPLP PACKAGE.
%!!!
%!!!***SEE ALSO DSPLP
%!!!***ROUTINES CALLED DASUM, DCOPY, DDOT, DPINCW, DPINIT, DPINTM, DPLPCE,
%!!! DPLPDM, DPLPFE, DPLPFL, DPLPMU, DPLPUP, DPNNZR,
%!!! DPOPT, DPRWPG, DVOUT, IVOUT, LA05BD, SCLOSM, XERMSG
%!!!***COMMON BLOCKS LA05DD
%!!!***REVISION HISTORY (YYMMDD)
%!!! 811215 DATE WRITTEN
%!!! 890531 Changed all specific intrinsics to generic. (WRB)
%!!! 890605 Removed unreferenced labels. (WRB)
%!!! 891009 Removed unreferenced variable. (WRB)
%!!! 891214 Prologue converted to Version 4.0 format. (BAB)
%!!! 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ)
%!!! 900328 Added TYPE section. (WRB)
%!!! 900510 Convert XERRWV calls to XERMSG calls. (RWC)
%!!!***end PROLOGUE DPLPMN
%!!DOUBLEPRECISION 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 , sizemlv ,%!!SMAll , theta , tolls , upbnd , uu , Wr(*) ,%!!Ww(*) , xlamda , xval , zero , rdum(01) , tolabs
%!!DOUBLEPRECISION DDOT , DASUM
%!!!
%!!INTEGER Ibasis(*) , Ibb(*) , Ibrc(Lbm,2) , Imat(*) , Ind(*) ,%!!Ipr(*) , Iwr(*) , intopt(08) , idum(01)
%!!!
%!!! ARRAY LOCAL VARIABLES
%!!! NAME(LENGTH) DESCRIPTION
%!!!
%!!! COSTS(NVARS) COST COEFFICIENTS
%!!! PRGOPT( ) OPTION VECTOR
%!!! DATTRV( ) DATA TRANSFER VECTOR
%!!! PRIMAL(NVARS+MRELAS) AS OUTPUT IT IS PRIMAL SOLUTION OF LP.
%!!! INTERNALLY, THE FIRST NVARS POSITIONS HOLD
%!!! THE COLUMN CHECK SUMS. THE NEXT MRELAS
%!!! POSITIONS HOLD THE CLASSIFICATION FOR THE
%!!! BASIC VARIABLES -1 VIOLATES LOWER
%!!! BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND
%!!! DUALS(MRELAS+NVARS) DUAL SOLUTION. INTERNALLY HOLDS R.H. SIDE
%!!! AS FIRST MRELAS ENTRIES.
%!!! AMAT(LMX) SPARSE FORM OF DATA MATRIX
%!!! IMAT(LMX) SPARSE FORM OF DATA MATRIX
%!!! BL(NVARS+MRELAS) LOWER BOUNDS FOR VARIABLES
%!!! BU(NVARS+MRELAS) UPPER BOUNDS FOR VARIABLES
%!!! IND(NVARS+MRELAS) INDICATOR FOR VARIABLES
%!!! CSC(NVARS) COLUMN SCALING
%!!! IBASIS(NVARS+MRELAS) COLS. 1-MRELAS ARE BASIC, REST ARE NON-BASIC
%!!! IBB(NVARS+MRELAS) INDICATOR FOR NON-BASIC VARS., POLARITY OF
%!!! VARS., AND POTENTIALLY INFINITE VARS.
%!!! IF IBB(J).LT.0, VARIABLE J IS BASIC
%!!! IF IBB(J).GT.0, VARIABLE J IS NON-BASIC
%!!! IF IBB(J).EQ.0, VARIABLE J HAS TO BE IGNORED
%!!! BECAUSE IT WOULD CAUSE UNBOUNDED SOLN.
%!!! WHEN MOD(IBB(J),2).EQ.0, VARIABLE IS AT ITS
%!!! UPPER BOUND, OTHERWISE IT IS AT ITS LOWER
%!!! BOUND
%!!! COLNRM(NVARS) NORM OF COLUMNS
%!!! ERD(MRELAS) ERRORS IN DUAL VARIABLES
%!!! ERP(MRELAS) ERRORS IN PRIMAL VARIABLES
%!!! BASMAT(LBM) BASIS MATRIX FOR HARWELL SPARSE CODE
%!!! IBRC(LBM,2) ROW AND COLUMN POINTERS FOR BASMAT(*)
%!!! IPR(2*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE
%!!! IWR(8*MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE
%!!! WR(MRELAS) WORK ARRAY FOR HARWELL SPARSE CODE
%!!! RZ(NVARS+MRELAS) REDUCED COSTS
%!!! RPRIM(MRELAS) INTERNAL PRIMAL SOLUTION
%!!! RG(NVARS+MRELAS) COLUMN WEIGHTS
%!!! WW(MRELAS) WORK ARRAY
%!!! RHS(MRELAS) HOLDS TRANSLATED RIGHT HAND SIDE
%!!!
%!!! SCALAR LOCAL VARIABLES
%!!! NAME TYPE DESCRIPTION
%!!!
%!!! LMX INTEGER LENGTH OF AMAT(*)
%!!! LPG INTEGER LENGTH OF PAGE FOR AMAT(*)
%!!! EPS DOUBLE MACHINE PRECISION
%!!! TUNE DOUBLE PARAMETER TO SCALE ERROR ESTIMATES
%!!! TOLLS DOUBLE RELATIVE TOLERANCE FOR SMALL RESIDUALS
%!!! TOLABS DOUBLE ABSOLUTE TOLERANCE FOR SMALL RESIDUALS.
%!!! USED IF RELATIVE ERROR TEST FAILS.
%!!! IN CONSTRAINT EQUATIONS
%!!! FACTOR DOUBLE .01--DETERMINES IF BASIS IS SINGULAR
%!!! OR COMPONENT IS FEASIBLE. MAY NEED TO
%!!! BE INCREASED TO 1.0D0 ON SHORT WORD
%!!! LENGTH MACHINES.
%!!! ASMALL DOUBLE LOWER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
%!!! ABIG DOUBLE UPPER BOUND FOR NON-ZERO MAGN. IN AMAT(*)
%!!! MXITLP INTEGER MAXIMUM NUMBER OF ITERATIONS FOR LP
%!!! ITLP INTEGER ITERATION COUNTER FOR TOTAL LP ITERS
%!!! COSTSC DOUBLE COSTS(*) SCALING
%!!! SCOSTS DOUBLE TEMP LOC. FOR COSTSC.
%!!! XLAMDA DOUBLE WEIGHT PARAMETER FOR PEN. METHOD.
%!!! ANORM DOUBLE NORM OF DATA MATRIX AMAT(*)
%!!! RPRNRM DOUBLE NORM OF THE SOLUTION
%!!! DULNRM DOUBLE NORM OF THE DUALS
%!!! ERDNRM DOUBLE NORM OF ERROR IN DUAL VARIABLES
%!!! DIRNRM DOUBLE NORM OF THE DIRECTION VECTOR
%!!! RHSNRM DOUBLE NORM OF TRANSLATED RIGHT HAND SIDE VECTOR
%!!! RESNRM DOUBLE NORM OF RESIDUAL VECTOR FOR CHECKING
%!!! FEASIBILITY
%!!! NZBM INTEGER NUMBER OF NON-ZEROS IN BASMAT(*)
%!!! LBM INTEGER LENGTH OF BASMAT(*)
%!!! SMALL DOUBLE EPS*ANORM USED IN HARWELL SPARSE CODE
%!!! LP INTEGER USED IN HARWELL LA05*() PACK AS OUTPUT
%!!! FILE NUMBER. SET=I1MACH(4) NOW.
%!!! UU DOUBLE 0.1--USED IN HARWELL SPARSE CODE
%!!! FOR RELATIVE PIVOTING TOLERANCE.
%!!! GG DOUBLE OUTPUT INFO FLAG IN HARWELL SPARSE CODE
%!!! IPLACE INTEGER INTEGER USED BY SPARSE MATRIX CODES
%!!! IENTER INTEGER NEXT COLUMN TO ENTER BASIS
%!!! NREDC INTEGER NO. OF FULL REDECOMPOSITIONS
%!!! KPRINT INTEGER LEVEL OF OUTPUT, =0-3
%!!! IDG INTEGER FORMAT AND PRECISION OF OUTPUT
%!!! ITBRC INTEGER NO. OF ITERS. BETWEEN RECALCULATING
%!!! THE ERROR IN THE PRIMAL SOLUTION.
%!!! NPP INTEGER NO. OF NEGATIVE REDUCED COSTS REQUIRED
%!!! IN PARTIAL PRICING
%!!! JSTRT INTEGER STARTING PLACE FOR PARTIAL PRICING.
%!!!
%!!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))
%!!EQUIVALENCE (usrbas,lopt(2))
%!!EQUIVALENCE (sizeup,lopt(3))
%!!EQUIVALENCE (savedt,lopt(4))
%!!EQUIVALENCE (colscp,lopt(5))
%!!EQUIVALENCE (cstscp,lopt(6))
%!!EQUIVALENCE (minprb,lopt(7))
%!!EQUIVALENCE (stpedg,lopt(8))
%!!EQUIVALENCE (idg,intopt(1))
%!!EQUIVALENCE (ipagef,intopt(2))
%!!EQUIVALENCE (isave,intopt(3))
%!!EQUIVALENCE (mxitlp,intopt(4))
%!!EQUIVALENCE (kprint,intopt(5))
%!!EQUIVALENCE (itbrc,intopt(6))
%!!EQUIVALENCE (npp,intopt(7))
%!!EQUIVALENCE (lprg,intopt(8))
%!!EQUIVALENCE (eps,ropt(1))
%!!EQUIVALENCE (asmall,ropt(2))
%!!EQUIVALENCE (abig,ropt(3))
%!!EQUIVALENCE (costsc,ropt(4))
%!!EQUIVALENCE (tolls,ropt(5))
%!!EQUIVALENCE (tune,ropt(6))
%!!EQUIVALENCE (tolabs,ropt(7))
%!!!
%!!! COMMON BLOCK USED BY LA05 () PACKAGE..
%!!COMMON /LA05DD/ SMAll , LP , LENl , LENu , NCP , LROw , LCOl
%!!EXTERNAL DUSRMT
%!!!
%!!! SET LP=0 SO NO ERROR MESSAGES WILL PRINT WITHIN LA05 () PACKAGE.
%!!!***FIRST EXECUTABLE STATEMENT DPLPMN
%!!LP = 0
%!!!
%!!! THE VALUES ZERO AND ONE.
%!!zero = 0.0D0
%!!one = 1.0D0
%!!factor = 0.01D0
%!!lpg = Lmx - (Nvars+4)
%!!iopt = 1
%!!Info = 0
%!!unbnd = false
%!!jstrt = 1
%!!!
%!!! PROCESS USER OPTIONS IN PRGOPT(*).
%!!! CHECK THAT ANY USER-GIVEN CHANGES ARE WELL-DEFINED.
%!!gt100=false
%!!gt200=false
%!!gt300=false
%!!gt400=false
%!!gt500=false
%!!gt600=false
%!!gt700=false
%!!gt800=false
%!!gt900=false
%!!gt1000=false
%!!gt1100=false
%!!gt1200=false
%!!gt1300=false
%!!gt1400=false
%!!gt1500=false
%!!gt1600=false
%!!gt1700=false
%!!gt1800=false
%!!gt1900=false
%!!gt2000=false
%!!do
%!! if (gt2000==0) then
%!! if (gt1900==0) then
%!! if (gt1800==0) then
%!! if (gt1700==0) then
%!! if (gt1600==0) then
%!! if (gt1500==0) then
%!! if (gt1400==0) then
%!! if (gt1300==0) then
%!! if (gt1200==0) then
%!! if (gt1100==0) then
%!! if (gt1000==0) then
%!! if (gt900==0) then
%!! if (gt800==0) then
%!! if (gt700==0) then
%!! if (gt600==0) then
%!! if (gt500==0) then
%!! if (gt400==0) then
%!! if (gt300==0) then
%!! if (gt200==0) then
%!! if (gt100==0) then
%!!CALL DPOPT(Prgopt,Mrelas,Nvars,Info,Csc,Ibasis,ropt,intopt,lopt)
%!!IF ( Info<0 ) exit
%!!IF ( contin ) THEN
%!! ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!! ! PROCEDURE (RETRIEVE SAVED DATA FROM FILE ISAVE)
%!! lpr = Nvars + 4
%!! REWIND isave
%!! READ (isave) (Amat(i),i=1,lpr) , (Imat(i),i=1,lpr)
%!! key = 2
%!! ipage = 1
%!! DO WHILE ( true )
%!! 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
%!! IF ( np<0 ) EXIT
%!! ENDDO
%!! nparm = Nvars + Mrelas
%!! READ (isave) (Ibasis(i),i=1,nparm)
%!! REWIND isave
%!!ELSE
%!! !
%!! ! INITIALIZE SPARSE DATA MATRIX, AMAT(*) AND IMAT(*).
%!! CALL DPINTM(Mrelas,Nvars,Amat,Imat,Lmx,ipagef)
%!!ENDIF
%!!!
%!!! UPDATE MATRIX DATA AND CHECK BOUNDS FOR CONSISTENCY.
%!!CALL DPLPUP(DUSRMT,Mrelas,Nvars,Prgopt,Dattrv,Bl,Bu,Ind,Info,Amat,%!!Imat,sizeup,asmall,abig)
%!!IF ( Info<0 ) GOTO 2100
%!!!
%!!!++ CODE FOR OUTPUT=YES IS ACTIVE
%!!IF ( kprint>=1 ) THEN
%!! ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!! !++ CODE FOR OUTPUT=YES IS ACTIVE
%!! ! PROCEDURE (PRINT PROLOGUE)
%!! 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 ( kprint>=2 ) THEN
%!! 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)
%!! ENDIF
%!!ENDIF
%!!!++ CODE FOR OUTPUT=NO IS INACTIVE
%!!!++ end
%!!!
%!!! INITIALIZATION. SCALE DATA, NORMALIZE BOUNDS, FORM COLUMN
%!!! CHECK SUMS, AND FORM INITIAL BASIS MATRIX.
%!!CALL DPINIT(Mrelas,Nvars,Costs,Bl,Bu,Ind,Primal,Info,Amat,Csc,%!!costsc,Colnrm,xlamda,anorm,Rhs,rhsnrm,Ibasis,Ibb,Imat,%!!lopt)
%!!IF ( Info<0 ) GOTO 2100
%!!!
%!!nredc = 0
%!!npr004 = 200
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (DECOMPOSE BASIS MATRIX)
%!!!++ CODE FOR OUTPUT=YES IS ACTIVE
%!!100 IF ( kprint>=2 ) CALL IVOUT(Mrelas,Ibasis,%!!'('' SUBSCRIPTS OF BASIC VARIABLES DURING REDECOMPOSITION'')'%!!,idg)
%!!!++ CODE FOR OUTPUT=NO IS INACTIVE
%!!!++ end
%!!!
%!!! SET RELATIVE PIVOTING FACTOR FOR USE IN LA05 () PACKAGE.
%!!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 ( Info<0 ) GOTO 2100
%!!IF ( npr004==200 ) THEN
%!! IF ( singlr ) THEN
%!! nerr = 23
%!! CALL XERMSG('SLATEC','DPLPMN',%!!'IN DSPLP, A SINGULAR INITIAL BASIS WAS ENCOUNTERED.'%!!,nerr,iopt)
%!! Info = -nerr
%!! GOTO 2100
%!! ELSE
%!! npr005 = 300
%!! ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!! ! PROCEDURE (COMPUTE ERROR IN DUAL AND PRIMAL SYSTEMS)
%!! ntries = 1
%!! ENDIF
%!!ELSEIF ( npr004==3900 ) THEN
%!! npr005 = 4000
%!! ntries = 1
%!!ELSEIF ( npr004==3200 ) THEN
%!! ntries = ntries + 1
%!!ELSE
%!! GOTO 400
%!!ENDIF
%!!200 IF ( (2-ntries)<0 ) GOTO 1700
%!!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 ( singlr ) THEN
%!! IF ( ntries==2 ) GOTO 1700
%!! npr004 = 3200
%!! GOTO 100
%!!ELSE
%!! !++ CODE FOR OUTPUT=YES IS ACTIVE
%!! IF ( kprint>=3 ) THEN
%!! CALL DVOUT(Mrelas,Erp,'('' EST. ERROR IN PRIMAL COMPS.'')',idg)
%!! !++ CODE FOR OUTPUT=NO IS INACTIVE
%!! !++ end
%!! CALL DVOUT(Mrelas,Erd,'('' EST. ERROR IN DUAL COMPS.'')',idg)
%!! ENDIF
%!! IF ( npr005==300 ) THEN
%!! npr006 = 400
%!! ELSEIF ( npr005==2600 ) THEN
%!! GOTO 1300
%!! ELSEIF ( npr005==4000 ) THEN
%!! npr006 = 4100
%!! ELSE
%!! GOTO 1700
%!! ENDIF
%!!ENDIF
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (COMPUTE NEW PRIMAL)
%!!!
%!!! COPY RHS INTO WW(*), SOLVE SYSTEM.
%!!300 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)
%!!IF ( npr006==400 ) THEN
%!! npr007 = 500
%!!ELSEIF ( npr006==1000 ) THEN
%!! npr008 = 1100
%!! GOTO 500
%!!ELSEIF ( npr006==1500 ) THEN
%!! npr008 = 1600
%!! GOTO 500
%!!ELSEIF ( npr006==4100 ) THEN
%!! npr013 = 4200
%!! GOTO 700
%!!ELSEIF ( npr006==5000 ) THEN
%!! !
%!! ! REAPPLY COLUMN SCALING TO PRIMAL.
%!! i = 1
%!! n20276 = Mrelas
%!! DO WHILE ( (n20276-i)>=0 )
%!! j = Ibasis(i)
%!! IF ( j<=Nvars ) THEN
%!! scalr = Csc(j)
%!! IF ( Ind(j)==2 ) scalr = -scalr
%!! Rprim(i) = Rprim(i)*scalr
%!! ENDIF
%!! i = i + 1
%!! ENDDO
%!! !
%!! ! REPLACE TRANSLATED BASIC VARIABLES INTO ARRAY PRIMAL(*)
%!! Primal(1) = zero
%!! CALL DCOPY(Nvars+Mrelas,Primal,0,Primal,1)
%!! j = 1
%!! n20283 = Nvars + Mrelas
%!! DO WHILE ( (n20283-j)>=0 )
%!! ibas = ABS(Ibasis(j))
%!! xval = zero
%!! IF ( j<=Mrelas ) xval = Rprim(j)
%!! IF ( Ind(ibas)==1 ) xval = xval + Bl(ibas)
%!! IF ( Ind(ibas)==2 ) xval = Bu(ibas) - xval
%!! IF ( Ind(ibas)==3 ) THEN
%!! IF ( MOD(Ibb(ibas),2)==0 ) xval = Bu(ibas) - Bl(ibas) - xval
%!! xval = xval + Bl(ibas)
%!! ENDIF
%!! Primal(ibas) = xval
%!! j = j + 1
%!! ENDDO
%!! !
%!! ! COMPUTE DUALS FOR INDEPENDENT VARIABLES WITH BOUNDS.
%!! ! OTHER ENTRIES ARE ZERO.
%!! j = 1
%!! n20290 = Nvars
%!! DO WHILE ( (n20290-j)>=0 )
%!! rzj = zero
%!! IF ( Ibb(j)>zero .AND. Ind(j)~=4 ) THEN
%!! rzj = Costs(j)
%!! i = 0
%!! DO WHILE ( true )
%!! CALL DPNNZR(i,aij,iplace,Amat,Imat,j)
%!! IF ( i<=0 ) EXIT
%!! rzj = rzj - aij*Duals(i)
%!! ENDDO
%!! ENDIF
%!! Duals(Mrelas+j) = rzj
%!! j = j + 1
%!! ENDDO
%!! IF ( npr011==1800 ) THEN
%!! IF ( feas .AND. (.NOT.unbnd) ) THEN
%!! Info = 1
%!! ELSEIF ( (.NOT.feas) .AND. (.NOT.unbnd) ) THEN
%!! nerr = 1
%!! CALL XERMSG('SLATEC','DPLPMN',%!!'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE',%!!nerr,iopt)
%!! Info = -nerr
%!! ELSEIF ( feas .AND. unbnd ) THEN
%!! nerr = 2
%!! CALL XERMSG('SLATEC','DPLPMN',%!!'IN DSPLP, THE PROBLEM APPEARS TO HAVE NO FINITE SOLUTION.'%!!,nerr,iopt)
%!! Info = -nerr
%!! ELSEIF ( (.NOT.feas) .AND. unbnd ) THEN
%!! nerr = 3
%!! CALL XERMSG('SLATEC','DPLPMN',%!!'IN DSPLP, THE PROBLEM APPEARS TO BE INFEASIBLE AND TO '%!!//'HAVE NO FINITE SOLN.',nerr,iopt)
%!! Info = -nerr
%!! ENDIF
%!! !
%!! IF ( Info==(-1) .OR. Info==(-3) ) THEN
%!! sizemlv = DASUM(Nvars,Primal,1)*anorm
%!! sizemlv = sizemlv/DASUM(Nvars,Csc,1)
%!! sizemlv = sizemlv + DASUM(Mrelas,Primal(Nvars+1),1)
%!! i = 1
%!! n20058 = Nvars + Mrelas
%!! DO WHILE ( (n20058-i)>=0 )
%!! nx0066 = Ind(i)
%!! IF ( nx0066>=1 .AND. nx0066<=4 ) THEN
%!! IF ( nx0066==2 ) THEN
%!! IF ( sizemlv+ABS(Primal(i)-Bu(i))*factor~=sizemlv ) THEN
%!! IF ( Primal(i)>=Bu(i) ) Ind(i) = -4
%!! ENDIF
%!! ELSEIF ( nx0066==3 ) THEN
%!! IF ( sizemlv+ABS(Primal(i)-Bl(i))*factor~=sizemlv ) THEN
%!! IF ( Primal(i)<Bl(i) ) THEN
%!! Ind(i) = -4
%!! ELSEIF ( sizemlv+ABS(Primal(i)-Bu(i))*factor~=sizemlv ) THEN
%!! IF ( Primal(i)>Bu(i) ) Ind(i) = -4
%!! ENDIF
%!! ENDIF
%!! ELSEIF ( nx0066~=4 ) THEN
%!! IF ( sizemlv+ABS(Primal(i)-Bl(i))*factor~=sizemlv ) THEN
%!! IF ( Primal(i)<=Bl(i) ) Ind(i) = -4
%!! ENDIF
%!! ENDIF
%!! ENDIF
%!! i = i + 1
%!! ENDDO
%!! ENDIF
%!! !
%!! IF ( Info==(-2) .OR. Info==(-3) ) THEN
%!! j = 1
%!! n20080 = Nvars
%!! DO WHILE ( (n20080-j)>=0 )
%!! IF ( Ibb(j)==0 ) THEN
%!! nx0091 = Ind(j)
%!! IF ( nx0091>=1 .AND. nx0091<=4 ) THEN
%!! IF ( nx0091==2 ) THEN
%!! Bl(j) = Bu(j)
%!! Ind(j) = -3
%!! ELSEIF ( nx0091~=3 ) THEN
%!! IF ( nx0091==4 ) THEN
%!! Bl(j) = zero
%!! Bu(j) = zero
%!! Ind(j) = -3
%!! ELSE
%!! Bu(j) = Bl(j)
%!! Ind(j) = -3
%!! ENDIF
%!! ENDIF
%!! ENDIF
%!! ENDIF
%!! j = j + 1
%!! ENDDO
%!! ENDIF
%!! !++ CODE FOR OUTPUT=YES IS ACTIVE
%!! IF ( kprint<1 ) GOTO 2100
%!! npr012 = 5300
%!! !++ CODE FOR OUTPUT=NO IS INACTIVE
%!! !++ end
%!! GOTO 1900
%!! ELSEIF ( npr011==3700 ) THEN
%!! GOTO 1800
%!! ELSE
%!! GOTO 1900
%!! ENDIF
%!!ELSE
%!! GOTO 700
%!!ENDIF
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (CLASSIFY VARIABLES)
%!!!
%!!! DEFINE THE CLASSIFICATION OF THE BASIC VARIABLES
%!!! -1 VIOLATES LOWER BOUND, 0 FEASIBLE, +1 VIOLATES UPPER BOUND.
%!!! (THIS INFO IS STORED IN PRIMAL(NVARS+1)-PRIMAL(NVARS+MRELAS))
%!!! TRANSLATE VARIABLE TO ITS UPPER BOUND, IF .GT. UPPER BOUND
%!!400 Primal(Nvars+1) = zero
%!!CALL DCOPY(Mrelas,Primal(Nvars+1),0,Primal(Nvars+1),1)
%!!i = 1
%!!n20172 = Mrelas
%!!DO WHILE ( (n20172-i)>=0 )
%!! j = Ibasis(i)
%!! IF ( Ind(j)~=4 ) THEN
%!! IF ( Rprim(i)<zero ) THEN
%!! Primal(i+Nvars) = -one
%!! ELSEIF ( Ind(j)==3 ) THEN
%!! upbnd = Bu(j) - Bl(j)
%!! IF ( j<=Nvars ) upbnd = upbnd/Csc(j)
%!! IF ( Rprim(i)>upbnd ) THEN
%!! Rprim(i) = Rprim(i) - upbnd
%!! IF ( j>Nvars ) THEN
%!! Rhs(j-Nvars) = Rhs(j-Nvars) + upbnd
%!! ELSE
%!! k = 0
%!! DO WHILE ( true )
%!! CALL DPNNZR(k,aij,iplace,Amat,Imat,j)
%!! IF ( k<=0 ) EXIT
%!! Rhs(k) = Rhs(k) - upbnd*aij*Csc(j)
%!! ENDDO
%!! ENDIF
%!! Primal(i+Nvars) = one
%!! ENDIF
%!! ENDIF
%!! ENDIF
%!! i = i + 1
%!!ENDDO
%!!IF ( npr007==500 ) THEN
%!! IF ( .NOT.(usrbas) ) GOTO 600
%!! npr008 = 600
%!!ELSEIF ( npr007~=1200 ) THEN
%!! ntries = ntries + 1
%!! GOTO 200
%!!ELSE
%!! npr009 = 1300
%!! npr013 = 2200
%!! GOTO 700
%!!ENDIF
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (CHECK FEASIBILITY)
%!!!
%!!! SEE IF NEARBY FEASIBLE POINT SATISFIES THE CONSTRAINT
%!!! EQUATIONS.
%!!!
%!!! COPY RHS INTO WW(*), THEN UPDATE WW(*).
%!!500 CALL DCOPY(Mrelas,Rhs,1,Ww,1)
%!!j = 1
%!!n20206 = Mrelas
%!!DO WHILE ( (n20206-j)>=0 )
%!! ibas = Ibasis(j)
%!! xval = Rprim(j)
%!! !
%!! ! ALL VARIABLES BOUNDED BELOW HAVE ZERO AS THAT BOUND.
%!! IF ( Ind(ibas)<=3 ) xval = MAX(zero,xval)
%!! !
%!! ! IF THE VARIABLE HAS AN UPPER BOUND, COMPUTE THAT BOUND.
%!! IF ( Ind(ibas)==3 ) THEN
%!! upbnd = Bu(ibas) - Bl(ibas)
%!! IF ( ibas<=Nvars ) upbnd = upbnd/Csc(ibas)
%!! xval = MIN(upbnd,xval)
%!! ENDIF
%!! !
%!! ! SUBTRACT XVAL TIMES COLUMN VECTOR FROM RIGHT-HAND SIDE IN WW(*)
%!! IF ( xval==zero ) THEN
%!! j = j + 1
%!! ELSEIF ( ibas>Nvars ) THEN
%!! IF ( Ind(ibas)==2 ) THEN
%!! Ww(ibas-Nvars) = Ww(ibas-Nvars) - xval
%!! ELSE
%!! Ww(ibas-Nvars) = Ww(ibas-Nvars) + xval
%!! ENDIF
%!! j = j + 1
%!! ELSE
%!! i = 0
%!! DO WHILE ( true )
%!! CALL DPNNZR(i,aij,iplace,Amat,Imat,ibas)
%!! IF ( i<=0 ) EXIT
%!! Ww(i) = Ww(i) - xval*aij*Csc(ibas)
%!! ENDDO
%!! j = j + 1
%!! ENDIF
%!!ENDDO
%!!!
%!!! COMPUTE NORM OF DIFFERENCE AND CHECK FOR FEASIBILITY.
%!!resnrm = DASUM(Mrelas,Ww,1)
%!!feas = resnrm<=tolls*(rprnrm*anorm+rhsnrm)
%!!!
%!!! TRY AN ABSOLUTE ERROR TEST IF THE RELATIVE TEST FAILS.
%!!IF ( .NOT.feas ) feas = resnrm<=tolabs
%!!IF ( feas ) THEN
%!! Primal(Nvars+1) = zero
%!! CALL DCOPY(Mrelas,Primal(Nvars+1),0,Primal(Nvars+1),1)
%!!ENDIF
%!!IF ( npr008==600 ) THEN
%!! IF ( .NOT.feas ) THEN
%!! nerr = 24
%!! CALL XERMSG('SLATEC','DPLPMN',%!!'IN DSPLP, AN INFEASIBLE INITIAL BASIS WAS ENCOUNTERED.'%!!,nerr,iopt)
%!! Info = -nerr
%!! GOTO 2100
%!! ENDIF
%!!ELSEIF ( npr008~=1100 ) THEN
%!! IF ( npr008~=1600 ) GOTO 900
%!! IF ( .NOT.feas ) GOTO 1500
%!! !
%!! ! SET LAMDA TO ZERO, COSTSC=SCOSTS, PERFORM STANDARD PHASE-2.
%!! IF ( kprint>1 ) CALL IVOUT(0,idum,'('' ENTER STANDARD PHASE-2'')'%!!,idg)
%!! xlamda = zero
%!! costsc = scosts
%!! npr009 = 1700
%!! npr013 = 2200
%!! GOTO 700
%!!ELSEIF ( feas ) THEN
%!! ! CHECK IF ANY BASIC VARIABLES ARE STILL CLASSIFIED AS
%!! ! INFEASIBLE. IF ANY ARE, THEN THIS MAY NOT YET BE AN
%!! ! OPTIMAL POINT. THEREFORE SET LAMDA TO ZERO AND TRY
%!! ! TO PERFORM MORE SIMPLEX STEPS.
%!! i = 1
%!! n20046 = Mrelas
%!! DO WHILE ( (n20046-i)>=0 )
%!! IF ( Primal(i+Nvars)~=zero ) THEN
%!! xlamda = zero
%!! npr009 = 1700
%!! npr013 = 2200
%!! GOTO 700
%!! ELSE
%!! i = i + 1
%!! ENDIF
%!! ENDDO
%!! GOTO 1500
%!!ELSE
%!! !
%!! ! SET LAMDA TO INFINITY BY SETTING COSTSC TO ZERO (SAVE THE VALUE OF
%!! ! COSTSC) AND PERFORM STANDARD PHASE-1.
%!! IF ( kprint>=2 ) CALL IVOUT(0,idum,%!!'('' ENTER STANDARD PHASE-1'')',idg)
%!! scosts = costsc
%!! costsc = zero
%!! npr007 = 1200
%!! GOTO 400
%!!ENDIF
%!!600 itlp = 0
%!!!
%!!! LAMDA HAS BEEN SET TO A CONSTANT, PERFORM PENALTY METHOD.
%!!npr009 = 800
%!!! PROCEDURE (PERFORM SIMPLEX STEPS)
%!!npr013 = 2200
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (COMPUTE NEW DUALS)
%!!!
%!!! SOLVE FOR DUAL VARIABLES. FIRST COPY COSTS INTO DUALS(*).
%!!700 i = 1
%!!n20252 = Mrelas
%!!DO WHILE ( (n20252-i)>=0 )
%!! j = Ibasis(i)
%!! IF ( j>Nvars ) THEN
%!! Duals(i) = xlamda*Primal(i+Nvars)
%!! ELSE
%!! Duals(i) = costsc*Costs(j)*Csc(j) + xlamda*Primal(i+Nvars)
%!! ENDIF
%!! i = i + 1
%!!ENDDO
%!!!
%!!trans = true
%!!CALL LA05BD(Basmat,Ibrc,Lbm,Mrelas,Ipr,Iwr,Wr,gg,Duals,trans)
%!!dulnrm = DASUM(Mrelas,Duals,1)
%!!IF ( npr013~=2200 ) THEN
%!! IF ( npr013==4900 ) GOTO 1600
%!! IF ( npr013~=4200 ) GOTO 1000
%!! npr014 = 4300
%!! GOTO 900
%!!ENDIF
%!!800 npr014 = 2300
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (INITIALIZE REDUCED COSTS AND STEEPEST EDGE WEIGHTS)
%!!900 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)
%!!!
%!!IF ( npr014~=2300 ) THEN
%!! IF ( npr014~=4300 ) GOTO 1800
%!! GOTO 1100
%!!ELSE
%!! IF ( kprint>2 ) THEN
%!! CALL DVOUT(Mrelas,Duals,'('' BASIC (INTERNAL) DUAL SOLN.'')',%!!idg)
%!! CALL DVOUT(Nvars+Mrelas,Rz,'('' REDUCED COSTS'')',idg)
%!! ENDIF
%!! npr015 = 2400
%!!ENDIF
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (FIND VARIABLE TO ENTER BASIS AND GET SEARCH DIRECTION)
%!!1000 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)
%!!IF ( npr015==2400 ) THEN
%!! IF ( found ) GOTO 1200
%!! ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!! ! PROCEDURE (REDECOMPOSE BASIS MATRIX AND TRY AGAIN)
%!! IF ( .NOT.redbas ) THEN
%!! npr004 = 3900
%!! GOTO 100
%!! ENDIF
%!!ELSEIF ( npr015==2500 ) THEN
%!! GOTO 1200
%!!ELSE
%!! GOTO 1600
%!!ENDIF
%!!!
%!!! ERASE NON-CYCLING MARKERS NEAR COMPLETION.
%!!1100 i = Mrelas + 1
%!!n20247 = Mrelas + Nvars
%!!DO WHILE ( (n20247-i)>=0 )
%!! Ibasis(i) = ABS(Ibasis(i))
%!! i = i + 1
%!!ENDDO
%!!npr015 = 2500
%!!GOTO 1000
%!!1200 IF ( found ) THEN
%!! IF ( kprint>=3 ) CALL DVOUT(Mrelas,Ww,'('' SEARCH DIRECTION'')',%!!idg)
%!! ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!! ! PROCEDURE (CHOOSE VARIABLE TO LEAVE BASIS)
%!! CALL DPLPFL(Mrelas,Nvars,ienter,ileave,Ibasis,Ind,Ibb,theta,%!!dirnrm,rprnrm,Csc,Ww,Bl,Bu,Erp,Rprim,Primal,finite,%!!zerolv)
%!! IF ( finite ) THEN
%!! ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!! ! PROCEDURE (MAKE MOVE AND UPDATE)
%!! 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 ( Info==(-26) ) GOTO 2100
%!! !++ CODE FOR OUTPUT=YES IS ACTIVE
%!! IF ( kprint>=2 ) THEN
%!! ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!! ! PROCEDURE (PRINT ITERATION SUMMARY)
%!! 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 ( kprint>=3 ) THEN
%!! !++ CODE FOR OUTPUT=NO IS INACTIVE
%!! !++ end
%!! 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)
%!! ENDIF
%!! ENDIF
%!! npr005 = 2600
%!! ntries = 1
%!! GOTO 200
%!! ELSE
%!! unbnd = true
%!! Ibb(Ibasis(ienter)) = 0
%!! ENDIF
%!!ELSEIF ( npr009==800 ) THEN
%!! npr010 = 900
%!! GOTO 1400
%!!ELSEIF ( npr009==1700 ) THEN
%!! GOTO 1500
%!!ELSEIF ( npr009==1300 ) THEN
%!! npr010 = 1400
%!! GOTO 1400
%!!ENDIF
%!!1300 itlp = itlp + 1
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (CHECK AND RETURN WITH EXCESS ITERATIONS)
%!!IF ( itlp>mxitlp ) THEN
%!! nerr = 25
%!! npr011 = 3700
%!! npr013 = 4900
%!! GOTO 700
%!!ELSE
%!! npr015 = 2400
%!! GOTO 1000
%!!ENDIF
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (COMPUTE RIGHT HAND SIDE)
%!!1400 Rhs(1) = zero
%!!CALL DCOPY(Mrelas,Rhs,0,Rhs,1)
%!!j = 1
%!!n20098 = Nvars + Mrelas
%!!DO WHILE ( (n20098-j)>=0 )
%!! nx0106 = Ind(j)
%!! IF ( nx0106>=1 .AND. nx0106<=4 ) THEN
%!! IF ( nx0106==2 ) THEN
%!! scalr = -Bu(j)
%!! ELSEIF ( nx0106==3 ) THEN
%!! scalr = -Bl(j)
%!! ELSEIF ( nx0106==4 ) THEN
%!! scalr = zero
%!! ELSE
%!! scalr = -Bl(j)
%!! ENDIF
%!! ENDIF
%!! IF ( scalr==zero ) THEN
%!! j = j + 1
%!! ELSEIF ( j>Nvars ) THEN
%!! Rhs(j-Nvars) = Rhs(j-Nvars) - scalr
%!! j = j + 1
%!! ELSE
%!! i = 0
%!! DO WHILE ( true )
%!! CALL DPNNZR(i,aij,iplace,Amat,Imat,j)
%!! IF ( i<=0 ) EXIT
%!! Rhs(i) = Rhs(i) + aij*scalr
%!! ENDDO
%!! j = j + 1
%!! ENDIF
%!!ENDDO
%!!j = 1
%!!n20119 = Nvars + Mrelas
%!!DO WHILE ( (n20119-j)>=0 )
%!! scalr = zero
%!! IF ( Ind(j)==3 .AND. MOD(Ibb(j),2)==0 ) scalr = Bu(j) - Bl(j)
%!! IF ( scalr==zero ) THEN
%!! j = j + 1
%!! ELSEIF ( j>Nvars ) THEN
%!! Rhs(j-Nvars) = Rhs(j-Nvars) + scalr
%!! j = j + 1
%!! ELSE
%!! i = 0
%!! DO WHILE ( true )
%!! CALL DPNNZR(i,aij,iplace,Amat,Imat,j)
%!! IF ( i<=0 ) EXIT
%!! Rhs(i) = Rhs(i) - aij*scalr
%!! ENDDO
%!! j = j + 1
%!! ENDIF
%!!ENDDO
%!!IF ( npr010==900 ) THEN
%!! npr006 = 1000
%!! GOTO 300
%!!ELSE
%!! IF ( npr010~=1400 ) GOTO 800
%!! npr006 = 1500
%!! GOTO 300
%!!ENDIF
%!!!
%!!1500 npr011 = 1800
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE(RESCALE AND REARRANGE VARIABLES)
%!!!
%!!! RESCALE THE DUAL VARIABLES.
%!!npr013 = 4900
%!!GOTO 700
%!!1600 IF ( costsc==zero ) THEN
%!! npr006 = 5000
%!!ELSE
%!! i = 1
%!! n20271 = Mrelas
%!! DO WHILE ( (n20271-i)>=0 )
%!! Duals(i) = Duals(i)/costsc
%!! i = i + 1
%!! ENDDO
%!! npr006 = 5000
%!!ENDIF
%!!GOTO 300
%!!1700 nerr = 26
%!!CALL XERMSG('SLATEC','DPLPMN',%!!'IN DSPLP, MOVED TO A SINGULAR POINT. THIS SHOULD NOT HAPPEN.'%!!,nerr,iopt)
%!!Info = -nerr
%!!GOTO 2100
%!!!++ CODE FOR OUTPUT=YES IS ACTIVE
%!!1800 IF ( kprint<1 ) GOTO 2000
%!!npr012 = 3800
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (PRINT SUMMARY)
%!!1900 idum(1) = Info
%!!CALL IVOUT(1,idum,'('' THE OUTPUT VALUE OF INFO IS'')',idg)
%!!IF ( minprb ) THEN
%!! CALL IVOUT(0,idum,'('' THIS IS A MINIMIZATION PROBLEM.'')',idg)
%!!ELSE
%!! CALL IVOUT(0,idum,'('' THIS IS A MAXIMIZATION PROBLEM.'')',idg)
%!!ENDIF
%!!IF ( stpedg ) THEN
%!! CALL IVOUT(0,idum,'('' STEEPEST EDGE PRICING WAS USED.'')',idg)
%!!ELSE
%!! CALL IVOUT(0,idum,'('' MINIMUM REDUCED COST PRICING WAS USED.'')'%!!,idg)
%!!ENDIF
%!!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)
%!!IF ( npr012==5300 ) GOTO 2100
%!!IF ( npr012~=3800 ) GOTO 2100
%!!!++ CODE FOR OUTPUT=NO IS INACTIVE
%!!!++ end
%!!2000 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
%!!!++ CODE FOR OUTPUT=NO IS INACTIVE
%!!!++ end
%!!! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!!! PROCEDURE (RETURN TO USER)
%!!2100 IF ( savedt ) THEN
%!! ! CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
%!! ! PROCEDURE (SAVE DATA ON FILE ISAVE)
%!! !
%!! ! SOME PAGES MAY NOT BE WRITTEN YET.
%!! IF ( Amat(Lmx)==one ) THEN
%!! Amat(Lmx) = zero
%!! key = 2
%!! ipage = ABS(Imat(Lmx-1))
%!! CALL DPRWPG(key,ipage,lpg,Amat,Imat)
%!! ENDIF
%!! !
%!! ! FORCE PAGE FILE TO BE OPENED ON RESTARTS.
%!! 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
%!! DO WHILE ( true )
%!! 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
%!! IF ( np<0 ) EXIT
%!! ENDDO
%!! nparm = Nvars + Mrelas
%!! WRITE (isave) (Ibasis(i),i=1,nparm)
%!! ENDFILE isave
%!! IF ( Imat(Lmx-1)~=(-1) ) CALL SCLOSM(ipagef)
%!! RETURN
%!!ELSEIF ( Imat(Lmx-1)~=(-1) ) THEN
%!! CALL SCLOSM(ipagef)
%!!ENDIF
%!!!
%!!! THIS TEST IS THERE ONLY TO AVOID DIAGNOSTICS ON SOME FORTRAN
%!!! COMPILERS.
%!!end subroutine DPLPMN
%DECK DPLPMU
|
|
