C ================================================================= C File: genlin.f C ================================================================= C ================================================================= C Module: Auxiliary subroutines C ================================================================= C Last update of any of the component of this module: C C May 1st, 2008. C ****************************************************************** C ****************************************************************** subroutine solver(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype, +precond,checkder,lossfeas,epsfeas,epsopt,maxtotit,maxtotfc,iprint, +ncomp,mlcomp,f,cnorm,gpsupn,totiter,totfcnt,totgcnt,tothcnt, +totcgcnt,totchcnt,time,inform,wi1,wi2,wi3,wi4,wi5,wd1,wd2,wd3,wd4, +wd5,wd6,wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14,wd15,wd16,wd17,wd18, +wd19,wd20,wd21,wd22,wd23,wd24,lwd24,ldabar,Abar,ldh,H) implicit none C This subroutine: C C (1) Computes some machine-dependent constants. C C (2) Process the optionally input specification file genlin.dat. C C (3) Check analytic derivatives if desired by the user. C C (4) Open and close the output file genlin.out. C C (5) Computes the CPU elapsed time used by the solver. C C (6) Calls the solver (GENLIN). C C (7) Write an output file called solution.txt with the solution. C SCALAR ARGUMENTS logical checkder,lossfeas character * 6 precond integer gtype,hptype,intype,inform,iprint,ml,mleq,maxtotfc, + maxtotit,n,ncomp,mlcomp,totcgcnt,totfcnt,totgcnt,totiter, + totchcnt,tothcnt,lda,ldabar,ldh,lwd24 double precision epsfeas,epsopt,f,gpsupn,cnorm real time C ARRAY ARGUMENTS integer wi1(n),wi2(n),wi3(ml),wi4(2*n+ml),wi5(n+ml) double precision l(n),u(n),wd1(n),wd2(n),wd3(n),wd4(n),wd5(n), + wd6(n),wd7(n),wd8(n),wd9(n),wd10(n),wd11(n),wd12(n), + wd13(n),wd14(n),wd15(n),wd16(n),wd17(n),wd18(n),wd19(n), + wd20(n),wd21(n),wd22(ml),wd23(ml),wd24(lwd24),x(n), + A(lda,n),Abar(ldabar,ml),H(ldh,n),b(ml) C LOCAL SCALARS integer i integer totspgiter,totspgfcnt,tottniter,tottnfcnt,tottriter, + tottrfcnt,totispgiter,totispgfcnt,totiterql double precision bignum,macheps C double precision d1mach C DECLARATIONS RELATED TO THE TIME MEASUREMENT USING DTIME real dtime external dtime real dum(2) data dum/0.0,0.0/ C COMPUTE MACHINE-DEPENDENT CONSTANTS bignum = 1.0d+99 C macheps = d1mach(4) macheps = 1.0d-16 C OPEN THE OUTPUT FILE open(10,file='genlin.out') C SET SOME SOLVER ARGUMENTS USING THE SPECIFICATION FILE call fparam(gtype,hptype,intype,precond,checkder,lossfeas,epsfeas, +epsopt,maxtotit,maxtotfc,iprint,ncomp,mlcomp) C TEST DERIVATIVES #ifndef CUTEr if ( checkder ) then call checkd(n,l,u,wd1,wd2,wd3,wd4,macheps,inform) if ( inform .lt. 0 ) then if ( iprint .ge. 1 ) then write(*, 2000) inform write(10,2000) inform end if go to 500 end if end if #endif time = dtime(dum) C CALL THE LINEAR-CONSTRAINTS SOLVER GENLIN call easygenlin(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype, +precond,epsopt,epsfeas,lossfeas,maxtotit,maxtotfc,iprint,ncomp, +mlcomp,macheps,bignum,f,wd1,gpsupn,cnorm,totiter,totfcnt,totgcnt, +tothcnt,totcgcnt,totchcnt,totspgiter,totspgfcnt,tottniter, +tottnfcnt,tottriter,tottrfcnt,totispgiter,totispgfcnt,totiterql, +inform,ldabar,Abar,ldh,H,wi1,wi2,wi3,wi4,wi5,wd2,wd3,wd4,wd5,wd6, +wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14,wd15,wd16,wd17,wd18,wd19, +wd20,wd21,wd22,wd23,wd24,lwd24) if ( inform .lt. 0 ) then if ( iprint .ge. 1 ) then write(*, 2000) inform write(10,2000) inform end if end if time = dtime(dum) time = dum(1) C CLOSE THE OUTPUT FILE close(10) C SAVE THE SOLUTION open(10,file='solution.txt') C Solution point write(10,9000) do i = 1,n write(10,9010) i,x(i) end do close(10) C WRITE STATISTICS open(10,file='genlin-tabline.out') write(10,9050) time,inform,n,ml,totiter,totfcnt,totgcnt,tothcnt, +totcgcnt,totchcnt,totspgiter,totspgfcnt,tottniter,tottnfcnt, +tottriter,tottrfcnt,totispgiter,totispgfcnt,totiterql,f,cnorm, +gpsupn close(10) C RETURN 500 continue C NON-EXECUTABLE STATEMENTS 2000 format(/,' Flag of GENLIN = ',I3,' Fatal Error',/, + /,' The following codes means: ',/, + /,' -30 : error in projection subroutine', + /,' -40 : point is infeasible', + /,' -50 : error in QR decomposition', + /,' -70 : some linear constraints are inconsistent', + /,' -90 : error in evalf subroutine', + /,' -92 : error in evalg subroutine', + /,' -94 : error in evalh subroutine', + /,' -96 : error in evalhlp subroutine',/) 9000 format(/,'FINAL POINT:',//,2X,'INDEX',16X,'X(INDEX)') 9010 format( I7,1P,D24.16) 9050 format(F8.2,1X,I3,1X,I6,1X,I6,1X,I7,1X,I7,1X,I7,1X,I7,1X,I10,1X, + I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X, + I10,1X,I10,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1) end C ****************************************************************** C ****************************************************************** subroutine fparam(gtype,hptype,intype,precond,checkder,lossfeas, +epsfeas,epsopt,maxtotit,maxtotfc,iprint,ncomp,mlcomp) implicit none C This subroutine set some genlin arguments related to stopping C criteria and output. The setting values are taken fron file C genlin.dat. Nothing is done if the file does not exist. File C genlin.dat is an alternative to run GENLIN several times C with different arguments without having to compile it again. C SCALAR ARGUMENTS logical checkder,lossfeas character * 6 precond integer gtype,hptype,intype,iprint,maxtotfc,maxtotit,ncomp,mlcomp double precision epsfeas,epsopt C Parameters of the subroutine: C ============================= C C The parameters of this subroutine are the same parameters of C subroutine param. See the description of them in subroutine C param. C PARAMETERS integer nwords parameter ( nwords = 20 ) C DATA BLOCKS character * 1 lower(26),upper(26) data lower /'a','b','c','d','e','f','g','h','i','j','k','l','m', + 'n','o','p','q','r','s','t','u','v','w','x','y','z'/ data upper /'A','B','C','D','E','F','G','H','I','J','K','L','M', + 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ character * 10 dictionary(nwords) data dictionary( 1) /'ANALYTIC-G'/ data dictionary( 2) /'FINITE-DIF'/ data dictionary( 3) /'HESSIANS-P'/ data dictionary( 4) /'LAGRHESS-P'/ data dictionary( 5) /'INCREMENTA'/ data dictionary( 6) /'BFGS-QN-AP'/ data dictionary( 7) /'ADAPTIVE-H'/ data dictionary( 8) /'GENCAN-BDS'/ data dictionary( 9) /'BETRA-BDSO'/ data dictionary(10) /'UNPRECONDI'/ data dictionary(11) /'BFGS-QN-PR'/ data dictionary(12) /'CHECK-DERI'/ data dictionary(13) /'FEASIBILIT'/ data dictionary(14) /'AVOID-LOSS'/ data dictionary(15) /'OPTIMALITY'/ data dictionary(16) /'MAX-INNER-'/ data dictionary(17) /'MAX-FUNCTI'/ data dictionary(18) /'OUTPUT-DET'/ data dictionary(19) /'NCOMP-ARRA'/ data dictionary(20) /'MLCOMP-ARR'/ character * 38 description(nwords) data description( 1) /'ANALYTIC-GRADIENT '/ data description( 2) /'FINITE-DIFFERENCES-GRADIENT '/ data description( 3) /'HESSIANS-PROVIDED '/ data description( 4) /'LAGRHESS-PRODUCT-PROVIDED '/ data description( 5) /'INCREMENTAL-QUOTIENTS '/ data description( 6) /'BFGS-QN-APPROXIMATION '/ data description( 7) /'ADAPTIVE-HESSIAN '/ data description( 8) /'GENCAN-BDSOLVER '/ data description( 9) /'BETRA-BDSOLVER '/ data description(10) /'UNPRECONDITIONED-CG '/ data description(11) /'BFGS-QN-PRECONDITIONER '/ data description(12) /'CHECK-DERIVATIVES '/ data description(13) /'FEASIBILITY-TOLERANCE '/ data description(14) /'AVOID-LOSS-OF-FEASIBILITY '/ data description(15) /'OPTIMALITY-TOLERANCE '/ data description(16) /'MAX-INNER-ITERATIONS '/ data description(17) /'MAX-FUNCTION-EVALUATIONS '/ data description(18) /'OUTPUT-DETAIL '/ data description(19) /'NCOMP-ARRAY '/ data description(20) /'MLCOMP-ARRAY '/ character * 1 addinfo(nwords) data addinfo( 1) /' '/ data addinfo( 2) /' '/ data addinfo( 3) /' '/ data addinfo( 4) /' '/ data addinfo( 5) /' '/ data addinfo( 6) /' '/ data addinfo( 7) /' '/ data addinfo( 8) /' '/ data addinfo( 9) /' '/ data addinfo(10) /' '/ data addinfo(11) /' '/ data addinfo(12) /' '/ data addinfo(13) /'D'/ data addinfo(14) /' '/ data addinfo(15) /'D'/ data addinfo(16) /'I'/ data addinfo(17) /'I'/ data addinfo(18) /'I'/ data addinfo(19) /'I'/ data addinfo(20) /'I'/ C LOCAL SCALARS integer i,ifirst,ikey,ilast,inum,j double precision dnum C LOCAL ARRAYS character * 80 line character * 10 keyword C OPENING THE SPECIFICATION FILE open(20,err=300,file='genlin.dat',status='old') C MAIN LOOP write(*, 9005) write(10,9005) 100 continue C READING LINES read(20,fmt=1000,err=400,end=200) line C PROCESS LINES C Find first character i = 1 110 if ( i .le. 80 .and. line(i:i) .eq. ' ' ) then i = i + 1 go to 110 end if C Skip blank lines if ( i .gt. 80 ) then go to 100 end if ifirst = i C Skip comments if ( line(ifirst:ifirst) .eq. '*' .or. + line(ifirst:ifirst) .eq. '#' ) then go to 100 end if C Find the end of the keyword i = ifirst + 1 120 if ( i .le. 80 .and. line(i:i) .ne. ' ' ) then i = i + 1 go to 120 end if ilast = i - 1 C Obtain the first 10 characters and convert to upper-case keyword = ' ' do i = 1,min( 10, ilast - ifirst + 1 ) keyword(i:i) = line(ifirst+i-1:ifirst+i-1) do j = 1,26 if ( keyword(i:i) .eq. lower(j) ) then keyword(i:i) = upper(j) end if end do end do C Look up the keyword in the dictionary i = 1 130 if ( i .le. nwords .and. keyword .ne. dictionary(i) ) then i = i + 1 go to 130 end if C Ignore unknown keywords if ( i .gt. nwords ) then write(*, 9020) line(ifirst:ilast) write(10,9020) line(ifirst:ilast) go to 100 end if ikey = i C Read additional information if needed if ( addinfo(ikey) .ne. ' ' ) then C Skip blanks i = ilast + 1 140 if ( i .le. 80 .and. line(i:i) .eq. ' ' ) then i = i + 1 go to 140 end if C Ignore keywords without the required information if ( i .gt. 80 ) then write(*, 9030) description(ikey) write(10,9030) description(ikey) go to 100 end if C Read additional information if ( addinfo(ikey) .eq. 'I' ) then read(unit=line(i:80),fmt=2000) inum else if ( addinfo(ikey) .eq. 'D' ) then read(unit=line(i:80),fmt=3000) dnum end if end if C Process keyword if ( addinfo(ikey) .eq. ' ' ) then write(*, 9040) description(ikey) write(10,9040) description(ikey) else if ( addinfo(ikey) .eq. 'I' ) then write(*, 9041) description(ikey),inum write(10,9041) description(ikey),inum else if ( addinfo(ikey) .eq. 'D' ) then write(*, 9042) description(ikey),dnum write(10,9042) description(ikey),dnum end if C Set the corresponding genlin argument if ( ikey .eq. 1 ) then gtype = 0 else if ( ikey .eq. 2 ) then gtype = 1 else if ( ikey .eq. 3 ) then hptype = 0 else if ( ikey .eq. 4 ) then hptype = 1 else if ( ikey .eq. 5 ) then hptype = 3 else if ( ikey .eq. 6 ) then hptype = 4 else if ( ikey .eq. 7 ) then hptype = 6 else if ( ikey .eq. 8 ) then intype = 1 else if ( ikey .eq. 9 ) then intype = 2 else if ( ikey .eq. 10 ) then precond = 'NONE' else if ( ikey .eq. 11 ) then precond = 'QNCGNA' else if ( ikey .eq. 12 ) then checkder = .true. else if ( ikey .eq. 13 ) then epsfeas = dnum else if ( ikey .eq. 14 ) then lossfeas = .false. else if ( ikey .eq. 15 ) then epsopt = dnum else if ( ikey .eq. 16 ) then maxtotit = inum else if ( ikey .eq. 17 ) then maxtotfc = inum else if ( ikey .eq. 18 ) then iprint = inum else if ( ikey .eq. 19 ) then ncomp = inum else if ( ikey .eq. 20 ) then mlcomp = inum end if C IIERATE go to 100 C END OF LOOP C TERMINATIONS C CLOSING SPECIFICATION FILE 200 continue close(20) go to 500 C NO SPECIFICATION FILE 300 continue write(*, 9000) write(10,9000) go to 500 C ERROR READING THE SPECIFICATION FILE 400 continue write(*, 9010) write(10,9010) go to 500 C PRINTING PARAMETERS VALUES 500 continue write(*, 4000) gtype,hptype,intype,precond,checkder,lossfeas, +epsfeas,epsopt,maxtotit,maxtotfc,iprint,ncomp,mlcomp write(10,4000) gtype,hptype,intype,precond,checkder,lossfeas, +epsfeas,epsopt,maxtotit,maxtotfc,iprint,ncomp,mlcomp C NON-EXECUTABLE STATEMENTS 1000 format(A80) 2000 format(BN,I20) 3000 format(BN,F24.0) 4000 format(/,' GENLIN PARAMETERS:', + /,' gtype = ', I20, + /,' hptype = ', I20, + /,' intype = ', I20, + /,' precond = ', 14X,A6, + /,' checkder = ', 19X,L1, + /,' lossfeas = ', 19X,L1, + /,' epsfeas = ',8X,1P,D12.4, + /,' epsopt = ',8X,1P,D12.4, + /,' maxtotit = ', I20, + /,' maxtotfc = ', I20, + /,' iprint = ', I20, + /,' ncomp = ', I20, + /,' mlcomp = ', I20) 9000 format(/,' The optional specification file genlin.dat was not', + ' found in the current',/,' directory (this is not a', + ' problem nor an error). The default values for the',/, + ' GENLIN parameters will be used.') 9005 format(/,' Specification file genlin.dat is being used.') 9010 format(/,' Error reading specification file genlin.dat.') 9020 format( ' Ignoring unknown keyword ',A32) 9030 format( ' Ignoring incomplete keyword ',A32) 9040 format(1X,A32) 9041 format(1X,A32,5X,I20) 9042 format(1X,A32,1X,1P,D24.8) end #ifndef CUTEr C ***************************************************************** C ***************************************************************** subroutine checkd(n,l,u,wd1,wd2,wd3,x,macheps,inform) implicit none C This subrotutine checks the user supplied first and second C derivatives subroutines (evalg and evalh) for computing the C objective function gradient and Hessian, respectively. C SCALAR ARGUMENTS integer inform,n double precision macheps C ARRAY ARGUMENTS double precision l(n),u(n),wd1(n),wd2(n),wd3(n),x(n) C Parameters of the subroutine: C ============================= C C On Entry: C ========= C C N integer: Number of variables. C --------- C C L double precision l(n): Lower bounds. C ----------------------- C C U double precision u(n): Upper bounds. C ----------------------- C C WD1 ... WD3, X double precision wd1(n) ... wd3(n), x(n) C ------------------------------------------------------- C C N-dimensional double precision working vectors. C C MACHEPS double precision C ------------------------ C C Smallest positive number such that 1 + macheps is not equal to 1. C C On Return: C ========== C C INFORM integer: Output flag. C -------------- C LOCAL SCALARS character answer integer i double precision drand,seed,smalll,smallu inform = 0 C SET A RANDOM POINT seed = 17325.0d0 do i = 1,n smalll = max( l(i), - 1.0d0 ) smallu = min( u(i), 1.0d0 ) if ( .not. smalll .lt. smallu ) then smalll = l(i) smallu = u(i) end if x(i) = smalll + ( smallu - smalll ) * drand(seed) end do write(*,900) do i = 1,n write(*,910) i,x(i) end do C CHECK OBJECTIVE FUNCTION GRADIENT write(*,920) read(*,*) answer if ( answer .eq. 'A' .or. answer .eq. 'a' ) then go to 500 else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then call checkg(n,x,wd1,macheps,inform) if ( inform .lt. 0 ) then return end if end if C CHECK HESSIAN OF THE OBJECTIVE FUNCTION write(*,940) read(*,*) answer if ( answer .eq. 'A' .or. answer .eq. 'a' ) then go to 500 else if ( answer .eq. 'Y' .or. answer .eq. 'y' ) then call checkh(n,x,wd1,wd2,wd3,macheps,inform) if ( inform .lt. 0 ) then return end if end if C RETURN 500 continue write(*,*) 'Hit any letter to continue.' read(*,*) answer 900 format(/,1X,'Derivatives will be tested at the random point: ') 910 format( 1X,'x(',I6,') = ',1P,D15.8) 920 format(/,1X,'Check the gradient of the objective function?', + /,1X,'Type Y(es), N(o) or A(bort checking): ') 940 format(/,1X,'Check the Hessian matrix of the objective function?', + /,1X,'Type Y(es), N(o) or A(bort checking): ') end C ***************************************************************** C ***************************************************************** subroutine checkg(n,x,g,macheps,inform) implicit none C This subrotutine checks the user supplied subroutine evalg for C computing the gradient of the objective function using central C finite differences with two different discretization steps. C SCALAR ARGUMENTS integer inform,n double precision macheps C ARRAY ARGUMENTS double precision g(n),x(n) C Parameters of the subroutine: C ============================= C C On Entry: C ========= C C N integer: Number of variables. C --------- C C X double precision x(n): Point at which the gradient will be tested. C ----------------------- C C G double precision g(n) C ----------------------- C C N-dimensional double precision working vector. C C MACHEPS double precision C ------------------------ C C Smallest positive number such that 1 + macheps is not equal to 1. C C On Return: C ========== C C INFORM integer: Output flag. C -------------- C LOCAL SCALARS integer flag,i double precision fminus,fplus,gdiff1,gdiff2,maxerr,step1,step2,tmp inform = 0 call evalg(n,x,g,flag) if ( flag .ne. 0 ) then inform = - 92 return end if write(*,100) maxerr = 0.0d0 do i = 1,n tmp = x(i) step1 = macheps ** (1.0d0/3.0d0) * max( abs( tmp ), 1.0d0 ) x(i) = tmp + step1 call evalf(n,x,fplus,flag) if ( flag .ne. 0 ) then inform = - 90 return end if x(i) = tmp - step1 call evalf(n,x,fminus,flag) if ( flag .ne. 0 ) then inform = - 90 return end if gdiff1 = ( fplus - fminus ) / ( 2.0d0 * step1 ) step2 = macheps ** (1.0d0/3.0d0) * max( abs( tmp ), 1.0d-03 ) x(i) = tmp + step2 call evalf(n,x,fplus,flag) if ( flag .ne. 0 ) then inform = - 90 return end if x(i) = tmp - step2 call evalf(n,x,fminus,flag) if ( flag .ne. 0 ) then inform = - 90 return end if x(i) = tmp gdiff2 = ( fplus - fminus ) / ( 2.0d0 * step2 ) tmp = min( abs( g(i) - gdiff1 ), abs( g(i) - gdiff2 ) ) write(*,110) i,g(i),gdiff1,gdiff2,tmp maxerr = max( maxerr, tmp ) end do write(*,120) maxerr return 100 format(/,1X,'Gradient vector of the objective function.', + /,1X,'Index',13X,'evalg',2X,'Central diff (two different ', + 'steps)',4X,'Absolute error') 110 format( 1X,I5,4(3X,1P,D15.8)) 120 format( 1X,'Maximum absolute error = ',1P,D15.8) end C ***************************************************************** C ***************************************************************** subroutine checkh(n,x,g,gplus1,gplus2,macheps,inform) implicit none C This subrotutine checks the user supplied subroutine evalh for C computing the Hessian of the objective function using central C finite differences with two different discretization steps. C SCALAR ARGUMENTS integer inform,n double precision macheps C ARRAY ARGUMENTS double precision g(n),gplus1(n),gplus2(n),x(n) C Parameters of the subroutine: C ============================= C C On Entry: C ========= C C N integer: Number of variables. C --------- C C X double precision x(n): Point at which the Hessian will be tested. C ----------------------- C C G, GPLUS1, GPLUS2 double precision g(n), gplus1(n), gplus2(n) C ------------------------------------------------------------- C C N-dimensional double precision working vectors. C C MACHEPS double precision C ------------------------ C C Smallest positive number such that 1 + macheps is not equal to 1. C C On Return: C ========== C C INFORM integer: Output flag. C -------------- C PARAMETERS integer nsmax parameter ( nsmax = 1000 ) C LOCAL SCALARS logical nullcol integer flag,i,j,nnzh double precision elem,hdiff1,hdiff2,step1,step2,tmp C LOCAL ARRAYS integer hlin(nsmax**2),hcol(nsmax**2) double precision H(nsmax,nsmax),hval(nsmax**2),maxerr(nsmax) inform = 0 C Test viability if ( n .gt. nsmax ) then write(*,*) 'Subroutine CheckH uses dense matrices up to ', + 'dimension ',nsmax,' times ',nsmax,'. The ', + 'Hessian checking will be skipped.' go to 500 end if C Compute the gradient of the objective function at x call evalg(n,x,g,flag) if ( flag .ne. 0 ) then inform = - 92 return end if C Compute the Hessian of the objective function at x and save in a C dense matrix call evalsh(n,x,hlin,hcol,hval,nnzh,flag) if ( flag .ne. 0 ) then inform = - 94 return end if do j = 1,n do i = 1,n H(i,j) = 0.0d0 end do end do do i = 1,nnzh H(hlin(i),hcol(i)) = H(hlin(i),hcol(i)) + hval(i) end do C Test column by column write(*,100) do j = 1,n tmp = x(j) step1 = sqrt( macheps ) * max( abs( tmp ), 1.0d0 ) x(j) = tmp + step1 call evalg(n,x,gplus1,flag) if ( flag .ne. 0 ) then inform = - 92 return end if step2 = sqrt( macheps ) * max( abs( tmp ), 1.0d-03 ) x(j) = tmp + step2 call evalg(n,x,gplus2,flag) if ( flag .ne. 0 ) then inform = - 92 return end if x(j) = tmp write(*,105) j maxerr(j) = 0.0d0 nullcol = .true. do i = 1,n if ( i .ge. j ) then elem = H(i,j) else elem = H(j,i) end if hdiff1 = ( gplus1(i) - g(i) ) / step1 hdiff2 = ( gplus2(i) - g(i) ) / step2 tmp = min( abs( elem - hdiff1 ), abs( elem - hdiff2 ) ) if ( elem .ne. 0.0d0 .or. + hdiff1 .ne. 0.0d0 .or. hdiff2 .ne. 0.0d0 ) then if ( nullcol ) then nullcol = .false. write(*,106) end if write(*,110) i,elem,hdiff1,hdiff2,tmp end if maxerr(j) = max( maxerr(j), tmp ) end do if ( nullcol ) then write(*,115) else write(*,120) maxerr(j) end if end do write(*,*) do j = 1,n write(*,130) j,maxerr(j) end do 500 continue return 100 format(/,1X,'Hessian matrix of the objective function column by ', + 'column.') 105 format(/,1X,'Column: ',I6) 106 format(/,1X,'Index',13X,'evalh',3X,'Incr. Quoc. (two different ', + 'steps)',4X,'Absolute error') 110 format( 1X,I5,4(3X,1P,D15.8)) 115 format( 1X,'All the elements of this column are null.') 120 format( 1X,'Maximum absolute error = ',1P,D15.8) 130 format( 1X,'Column ',I6,' Maximum absolute error = ',1P,D15.8) end #endif C ***************************************************************** C ***************************************************************** subroutine evalobj(n,x,f,inform) implicit none C This subroutine computes the objective function. C SCALAR ARGUMENTS double precision f integer inform,n C ARRAY ARGUMENTS double precision x(n) C Parameters of the subroutine: C ============================= C C On Entry: C ========= C C N integer: Number of variables. C --------- C C X double precision x(n): Current point. C ----------------------- C C On Return: C ========== C C F double precision: Objective function value at x. C ------------------ C C INFORM integer C -------------- C C 0 means that the evaluation was successfuly done. C C Any other value means that some error occured during the C evaluation. C LOCAL SCALARS integer flag inform = 0 C COMPUTE OBJECTIVE FUNTION call evalf(n,x,f,flag) if ( flag .ne. 0 ) then inform = - 90 return end if end C ***************************************************************** C ***************************************************************** subroutine evalgr(n,x,g,gtype,macheps,inform) implicit none C SCALAR ARGUMENTS integer gtype,inform,n double precision macheps C ARRAY ARGUMENTS double precision g(n),x(n) C This subroutine computes the gradient of the objective function. C Parameters of the subroutine: C ============================= C C On Entry: C ========= C C N integer: Number of variables. C --------- C C X double precision x(n): Current point. C ----------------------- C C GTYPE integer: C ------------- C C 0 if true gradient is to be used and C 1 if finite differences should be used. C C MACHEPS double precision: Machine precision. C ------------------------ C C On Return: C ========== C C G double precision g(n): C -------------------------- C C Gradient of the objective function. C C INFORM integer C -------------- C C 0 means that the evaluation was successfuly done. C C Any other value means that some error occured during the C evaluation. C LOCAL SCALARS integer flag inform = 0 C COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION if ( gtype .eq. 0 ) then call evalg(n,x,g,flag) if ( flag .ne. 0 ) then inform = - 92 return end if else call evalgdiff(n,x,g,macheps,inform) if ( inform .lt. 0 ) then return end if end if end C ****************************************************************** C ****************************************************************** subroutine evalhess(n,x,ldh,H,inform) implicit none C This subroutine might compute the Hessian matrix of the objective C function. For achieving this objective YOU MAY MODIFY it according C to your problem. To modify this subroutine IS NOT MANDATORY. See C below where your modifications must be inserted. C C Parameters of the subroutine: C C On Entry C C n integer, C number of variables, C C x double precision x(n), C current point, C C ldh integer ldh, C leading dimension of matrix H, C C On Return C C H double precision H(ldh,n), C Hessian matrix of the objective function. Just the lower C triangular part of Hessian matrix must be computed, C C inform integer, C You must set it to any number different of 0 (zero) if C some error ocurred during the evaluation of the Hessian C matrix of the objective function. (For example, trying C to compute the square root of a negative number, C dividing by zero or a very small number, etc.) If C everything was o.k. you must set it equal to zero. C SCALAR ARGUMENTS integer inform,n,ldh C ARRAY ARGUMENTS double precision H(ldh,n),x(n) C LOCAL SCALARS integer flag inform = 0 call evalh(n,x,ldh,H,flag) if (flag .ne. 0) then inform = - 94 return end if end C ***************************************************************** C ***************************************************************** subroutine evalhessp(n,x,p,g,s,y,seucn,yeucn,sts,sty,lspgmi, +lspgma,samefa,gtype,hptype,aptype,hp,xp,macheps,inform,goth,hlspg, +hds,hstds) implicit none C SCALAR ARGUMENTS logical goth,samefa character * 6 aptype integer gtype,hptype,inform,n double precision hlspg,hstds,lspgma,lspgmi,macheps,seucn,sts,sty, + yeucn C ARRAY ARGUMENTS double precision hds(n),hp(n),g(n),p(n),s(n),x(n),xp(n),y(n) C PARAMETERS integer hnnzmax parameter ( hnnzmax = 500000 ) C COMMON SCALARS integer hlen C COMMON ARRAYS integer hcol(hnnzmax),hlin(hnnzmax) double precision hval(hnnzmax) C LOCAL SCALARS integer i,flag double precision c1,c2,psupn,ptds,pty,step,xsupn C COMMON BLOCK common /hessdata/ hval,hlin,hcol,hlen inform = 0 C ================================================================== C HESSIAN APPROXIMATION TYPE C ================================================================== C True hessian-vector product using the user-provided second C derivatives of the objective function and the constraints if ( hptype .eq. 0 ) then aptype = 'TRUEHE' C For user user-provided Hessian times vector subroutine else if ( hptype .eq. 1 ) then aptype = 'HLPROD' C Incremental quotients considering the non-differentiability of C the Hessian matrix else if ( hptype .eq. 2 ) then aptype = 'INCQUO' C Idem 2 else if ( hptype .eq. 3 ) then aptype = 'INCQUO' C Quasi-Newton correction of a Gauss-Newton approximation of the C Hessian matrix else if ( hptype .eq. 4 ) then aptype = 'QNCGNA' C Idem 2 else if ( hptype .eq. 5 ) then aptype = 'INCQUO' C Idem 2 else if ( hptype .eq. 6 ) then aptype = 'INCQUO' C Incremental quotients without considering the non-differentiability C of the Hessian matrix of the objective function else ! if ( hptype .eq. 9 ) then aptype = 'PUREIQ' end if if ( aptype .eq. 'TRUEHE' ) then go to 100 else if ( aptype .eq. 'HLPROD' ) then go to 200 else if ( aptype .eq. 'QNCGNA' ) then go to 300 else if ( aptype .eq. 'INCQUO' ) then go to 400 else ! if ( aptype .eq. 'PUREIQ' ) then go to 500 end if C ================================================================== C EXACT SECOND-DERIVATIVES OF THE OBJECTIVE FUNCTION AND THE C CONSTRAINTS WHERE PROVIDED BY THE USER. THE TRUE HESSIAN-VECTOR C PRODUCT WILL BE COMPUTED C ================================================================== 100 continue C ------------------------------------------------------------------ C COMPUTE THE HESSIAN IF THIS IS THE FIRST TIME THIS SUBBROUTINE IS C BEING CALLED C ------------------------------------------------------------------ if ( .not. goth ) then goth = .true. C COMPUTE THE HESSIAN OF THE OBJECTIVE FUNCTION call evalsh(n,x,hlin,hcol,hval,hlen,flag) if ( flag .ne. 0 ) then inform = - 94 return end if end if C ------------------------------------------------------------------ C COMPUTE hp = \nabla^2 f(x) p C ------------------------------------------------------------------ do i = 1,n hp(i) = 0.0d0 end do do i = 1,hlen if ( hlin(i) .ge. hcol(i) ) then hp(hlin(i)) = hp(hlin(i)) + hval(i) * p(hcol(i)) if ( hlin(i) .ne. hcol(i) ) then hp(hcol(i)) = hp(hcol(i)) + hval(i) * p(hlin(i)) end if end if end do go to 900 C ================================================================== C END OF USER-PROVIDED SECOND DERIVATIVES C ================================================================== C ================================================================== C A SUBROUTINE TO COMPUTE THE PRODUCT OF A VECTOR TIMES THE HESSIAN C OF THE OBJECTIVE WAS PROVIDED BY THE USER. THIS SUBROUTINE WILL C BE USED AND THEN THE FIRST-ORDER TERM WILL BE ADDED. C ================================================================== 200 continue C ------------------------------------------------------------------ C COMPUTE hp = ( \nabla^2 f(x) ) p C ------------------------------------------------------------------ call evalhp(n,x,p,hp,goth,flag) if ( flag .ne. 0 ) then inform = - 96 return end if go to 900 C ================================================================== C END OF USER-PROVIDED HESSIAN X VECTOR PRODUCT C ================================================================== C ================================================================== C QUASI-NEWTON CORRECTION OF THE GAUSS-NEWTON APPROXIMATION OF THE C HESSIAN MATRIX C ================================================================== 300 continue C ------------------------------------------------------------------ C COMPUTE THE QUASI-NEWTON CORRECTION OF THE GAUSS-NEWTON C APPROXIMATION OF H IF THIS IS THE FIRST TIME THIS SUBBROUTINE IS C BEING CALLED C ------------------------------------------------------------------ if ( .not. goth ) then goth = .true. call comph(n,s,sts,sty,lspgmi,lspgma,hlspg,hds,hstds) end if C ------------------------------------------------------------------ C COMPUTE THE STRUCTURED SPECTRAL CORRECTION S d, WHERE C S = ( lamspg I ) AND lamspg = s^t (y - rho A^T A s) / (s^t s) C ------------------------------------------------------------------ C hp = hlspg p do i = 1,n hp(i) = hlspg * p(i) end do C ------------------------------------------------------------------ C ADD THE BFGS CORRECTION B p, WHERE C B = [ y y ^t / ( y^t s ) ] - [ D s ( D s )^t / ( s^t D s ) ], AND C D = hlspg I + rho A^T A C ------------------------------------------------------------------ C hp = hp + B p = ( hlspg I + B ) p if ( samefa .and. sty .gt. 1.0d-08 * seucn * yeucn ) then pty = 0.0d0 ptds = 0.0d0 do i = 1,n pty = pty + p(i) * y(i) ptds = ptds + p(i) * hds(i) end do c1 = pty / sty c2 = ptds / hstds do i = 1,n hp(i) = hp(i) + c1 * y(i) - c2 * hds(i) end do end if go to 900 C ================================================================== C END OF GAUSS-NEWTON APPROXIMATION OF THE HESSIAN MATRIX C ================================================================== C ================================================================== C INCREMENTAL QUOTIENTS APPROXIMATION OF THE HESSIAN-VECTOR PRODUCT C TAKING CARE OF THE NON-DIFFERENTIABILITY C ================================================================== 400 continue C COMPUTE INCREMENTAL QUOTIENTS STEP xsupn = 0.0d0 psupn = 0.0d0 do i = 1,n xsupn = max( xsupn, abs( x(i) ) ) psupn = max( psupn, abs( p(i) ) ) end do step = sqrt( macheps ) * max( xsupn / psupn, 1.0d0 ) C SET THE POINT AT WHICH THE GRADIENT OF THE OBJECTIVE FUNCTION WILL C BE COMPUTED do i = 1,n xp(i) = x(i) + step * p(i) end do C COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION AT xp if ( gtype .eq. 0 ) then call evalg(n,xp,hp,flag) if ( flag .ne. 0 ) then inform = - 92 return end if else call evalgdiff(n,xp,hp,macheps,inform) if ( inform .lt. 0 ) then return end if end if C COMPUTE INCREMENTAL QUOTIENTS do i = 1,n hp(i) = ( hp(i) - g(i) ) / step end do go to 900 C ================================================================== C END OF INCREMENTAL QUOTIENTS APPROXIMATION OF THE HESSIAN-VECTOR C PRODUCT TAKING CARE OF THE NON-DIFFERENTIABILITY C ================================================================== C ================================================================== C PURE INCREMENTAL QUOTIENTS APPROXIMATION OF THE HESSIAN-VECTOR C PRODUCT (WITHOUT TAKING CARE OF THE NON-DIFFERENTIABILITY) C ================================================================== 500 continue C COMPUTE INCREMENTAL QUOTIENTS STEP xsupn = 0.0d0 psupn = 0.0d0 do i = 1,n xsupn = max( xsupn, abs( x(i) ) ) psupn = max( psupn, abs( p(i) ) ) end do step = sqrt( macheps ) * max( xsupn / psupn, 1.0d0 ) C SET THE POINT AT WHICH THE GRADIENT OF THE OBJECTIVE FUNCTION C WILL BE COMPUTED do i = 1,n xp(i) = x(i) + step * p(i) end do C COMPUTE THE GRADIENT OF THE OBJECTIVE FUNCTION AT xp call evalgr(n,xp,hp,gtype,macheps,inform) if ( inform .lt. 0 ) then return end if C COMPUTE INCREMENTAL QUOTIENTS do i = 1,n hp(i) = ( hp(i) - g(i) ) / step end do go to 900 C ================================================================== C END OF PURE INCREMENTAL QUOTIENTS APPROXIMATION OF THE HESSIAN- C VECTOR PRODUCT (WITHOUT TAKING CARE OF THE NON-DIFFERENTIABILITY) C ================================================================== 900 continue end C ***************************************************************** C ***************************************************************** subroutine comph(n,s,sts,sty,lspgmi,lspgma,hlspg,hds,hstds) implicit none C SCALAR ARGUMENTS integer n double precision lspgma,lspgmi,hlspg,hstds,sts,sty C ARRAY ARGUMENTS double precision hds(n),s(n) C Consider M the Hessian matrix of the objective function. C C This subroutine computes an approximation H of matrix M following C a very simple idea: "discard the second order terms and then C correct the remaining matrix in order to satisfy a secant C equation". C C Hence, H takes the form C C H = hlspg I, C C where C C hlspg = max(lspgmi, min(lspgma, s^T y / s^T s)) C C Note that this subroutine does not compute matrix H explicitly, C but computes some quantities that will be used latter, by C subroutine evalhd, to compute the product of H by a vector d. C C The quantities computed by this subroutine are: C C (a) hlspg = s^T y / (s^T s) C C (b) hds = hlspg s, and C C (c) hstds = . C LOCAL SCALARS integer i C ================================================================== C GAUSS-NEWTON CORRECTION OF THE HESSIAN MATRIX C ================================================================== C COMPUTE THE STRUCTURED SPECTRAL CORRECTION C ------------------------------------------------------------------ C hlspg = (s^t y) / (s^t s) C ------------------------------------------------------------------ if ( sty .le. 0.0d0 ) then hlspg = lspgmi else hlspg = max( lspgmi, min( sty / sts, lspgma ) ) end if do i = 1,n hds(i) = hlspg * s(i) end do hstds = hlspg * sts C ================================================================== C END OF GAUSS-NEWTON APPROXIMATION OF THE HESSIAN MATRIX C ================================================================== end C ***************************************************************** C ***************************************************************** subroutine compp(n,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma,samefa, +plspg,psmdy,psmdyty) implicit none C SCALAR ARGUMENTS logical samefa integer n double precision lspgma,lspgmi,plspg,psmdyty,seucn,sts,sty,yeucn C ARRAY ARGUMENTS double precision psmdy(n),s(n),y(n) C This subroutine computes: C C (a) plspg such that E = plspg I, C C (b) psmdy = s - E^-1 y, and C C (c) the inner product psmdty = . C C These quantities will be used latter, in subroutine applyp, to C compute z = P^{-1} r. C LOCAL SCALARS integer i C ------------------------------------------------------------------ C COMPUTE THE SPECTRAL CORRECTION E C ------------------------------------------------------------------ if ( sty .le. 0.0d0 ) then plspg = lspgmi else plspg = max( lspgmi, min( sty / sts, lspgma ) ) end if C ------------------------------------------------------------------ C COMPUTE THE BFGS CORRECTION Q OF E C C Q = [ (s - D^-1 y) s^t + s (s - D^-1 y)^t ] / s^t y - C [ s s^t ] / (s^t y)^2, C C WHERE D = E C ------------------------------------------------------------------ if ( samefa .and. sty .gt. 1.0d-08 * seucn * yeucn ) then psmdyty = 0.0d0 do i = 1,n psmdy(i) = s(i) - y(i) / plspg psmdyty = psmdyty + psmdy(i) * y(i) end do end if end C ****************************************************************** C ****************************************************************** subroutine evalgdiff(n,x,g,macheps,inform) implicit none C This subroutine approximates, by central finite differences, the C gradient of the objective function. C SCALAR ARGUMENTS integer inform,n double precision macheps C ARRAY ARGUMENTS double precision g(n),x(n) C Parameters of the subroutine: C ============================= C C On Entry: C ========= C C N integer: Number of variables. C --------- C C X double precision x(n): Current point. C ----------------------- C C MACHEPS double precision: Machine epsilon. C ------------------------ C C On Return: C ========== C C G double precision g(n): Gradient of the objective function. C ----------------------- C C INFORM integer C -------------- C C 0 means that the evaluation was successfuly done. C C Any other value means that some error occured during the C evaluation. C LOCAL SCALARS integer flag,j double precision fminus,fplus,step,tmp do j = 1,n tmp = x(j) step = macheps ** (1.0d0/3.0d0) * max( abs( tmp ), 1.0d0 ) x(j) = tmp + step call evalf(n,x,fplus,flag) if ( flag .ne. 0 ) then inform = - 90 return end if x(j) = tmp - step call evalf(n,x,fminus,flag) if ( flag .ne. 0 ) then inform = - 90 return end if g(j) = ( fplus - fminus ) / ( 2.0d0 * step ) x(j) = tmp end do end C ***************************************************************** C ***************************************************************** subroutine applyp(n,r,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma, +samefa,gotp,pdiag,plspg,psmdy,psmdyty,z) implicit none C SCALAR ARGUMENTS logical gotp,samefa integer n double precision lspgma,lspgmi,plspg,psmdyty,seucn,sts,sty,yeucn C ARRAY ARGUMENTS double precision pdiag(n),psmdy(n),r(n),s(n),y(n),z(n) C Consider the preconditioner P. C Given the quantities computed in advance in the subroutine compp, C this subroutine computes z = P^{-1} r. C LOCAL SCALARS integer i double precision c1,c2,psmdytr,str C ------------------------------------------------------------------ C COMPUTE P IF THIS IS THE FIRST TIME THIS SUBBROUTINE IS BEING C CALLED C ------------------------------------------------------------------ if ( .not. gotp ) then gotp = .true. call compp(n,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma,samefa, + plspg,psmdy,psmdyty) end if C ------------------------------------------------------------------ C COMPUTE z = E^{-1} r C ------------------------------------------------------------------ do i = 1,n z(i) = r(i) / ( plspg + pdiag(i) ) end do C ------------------------------------------------------------------ C ADD Q^{-1} r, WHERE C C Q^{-1} = [ (s - D^-1 y) s^t + s (s - D^-1 y)^t ] / s^t y - C [ s s^t ] / (s^t y)^2 C C AND C C D = E C ------------------------------------------------------------------ if ( samefa .and. sty .gt. 1.0d-08 * seucn * yeucn ) then str = 0.0d0 psmdytr = 0.0d0 do i = 1,n str = str + s(i) * r(i) psmdytr = psmdytr + psmdy(i) * r(i) end do c1 = str / sty c2 = psmdytr / sty - psmdyty * str / sty ** 2 do i = 1,n z(i) = z(i) + c1 * psmdy(i) + c2 * s(i) end do end if end C ================================================================= C Module: Linear-constraints solver GENLIN C ================================================================= C Last update of any of the component of this module: C C May 1st, 2008. subroutine easygenlin(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype, +precond,epsgpsn,epscsn,lossfeas,maxit,maxfc,iprint,ncomp,mlcomp, +macheps,bignum,f,g,gpsupn,csupn,iter,fcnt,gcnt,hcnt,cgcnt,chcnt, +spgiter,spgfcnt,tniter,tnfcnt,triter,trfcnt,ispgiter,ispgfcnt, +iterql,inform,ldabar,Abar,ldh,H,wi1,wi2,wi3,wi4,wi5,wd1,wd2,wd3, +wd4,wd5,wd6,wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14,wd15,wd16,wd17, +wd18,wd19,wd20,wd21,wd22,wd23,lwd23) implicit none C SCALAR ARGUMENTS logical lossfeas character * 6 precond integer cgcnt,chcnt,fcnt,gcnt,hcnt,gtype,hptype,intype,ml,mleq, + maxfc,maxit,n,ncomp,mlcomp,inform,iprint,iter,lda,ldabar, + ldh,lwd23 integer spgiter,spgfcnt,tniter,tnfcnt,triter,trfcnt,ispgiter, + ispgfcnt,iterql double precision bignum,epsgpsn,epscsn,f,gpsupn,csupn,macheps C ARRAY ARGUMENTS integer wi1(n),wi2(n),wi3(ml),wi4(2*n+ml),wi5(n+ml) double precision g(n),l(n),u(n),wd1(n),wd2(n),wd3(n),wd4(n), + wd5(n),wd6(n),wd7(n),wd8(n),wd9(n),wd10(n),wd11(n), + wd12(n),wd13(n),wd14(n),wd15(n),wd16(n),wd17(n),wd18(n), + wd19(n),wd20(n),wd21(ml),wd22(ml),wd23(lwd23),x(n), + A(lda,n),Abar(ldabar,ml),H(ldh,n),b(ml) C This subroutine aims to simplify the use of GENLIN and BETRALIN. C For this purpose it gives values to most of the GENLIN and c BETRALIN arguments and leaves to the user those arguments which C he/she may would like to set by him/herself. C C The arguments of EASYGENLIN are the input and output arguments of C GENLIN and BETRALIN that are supposed to be useful for a common C user. The input arguments are mostly related to basic problem C information, like dimension and bounds, and the initial point. C There are also input arguments related to simple stopping criteria C (like norm of the projected gradient, and maximum number of C iterations and functional evaluations). There are also two input C arguments related to control the amount of information written C into the screen. The output arguments are related to information C of the solution and some few performance measurements. Basically, C on return, EASYGENLIN gives to the user the solution, the C objective functional value and its gradient at the solution, C Euclidian and sup-norm of the projected gradient at the solution, C the number of iterations, functional, gradient and hessian C evaluations, Conjugate Gradient and Cholesky decomposition C iterations used to reach the solution, and, finally, a flag that C indicates the stopping criterion that was satisfied. C C All the other arguments of GENLIN and BETRALIN are setted with its C default values by EASYGENLIN. EASYGENLIN divides the arguments of C GENLIN and BETRALIN in two sets. Those that are related to the C behaviour of GENLIN and BETRALIN are declared as Fortran parameters C (constants). The other arguments of GENLIN and BETRALIN, most of C them related to alternative stopping criteria, and that may depend C of, for example, maxit, are declared as local variables of C EASYGENLIN. C C GENLIN and BETRALIN arguments that are defined as Fortran parameters C in this subroutine are GENLIN and BETRALIN arguments that should not C be modified by a common user. They are arguments that modify the C behaviour of GENLIN or BETRALIN and whose values were selected C because they are classical values in some cases or because some C numerical experiments seemed to indicate that they are the best C choices. C C GENLIN and BETRALIN arguments that are declared as local variables C in this subroutine are GENLIN and BETRALIN arguments that may be C modified if, with their suggested values, GENLIN and BETRALIN do C not give the desired result. Most of them are related to Conjugate C Gradients or to disabled stopping criteria that may be useful C in bad-scaled problems or problems with not trustable derivatives. C C Finally, this subroutine declares as local variables some C arguments of GENLIN and BETRALIN which in fact are output C arguments. Most of them are related to quantities that can be used C for statistics related to the GENLIN or BETRALIN performance, like C number Interpolation steps, etc. As we assume that this values are C not useful for the common user, this subroutine throw all of them C away. C C We describe below the meaning of the arguments of the EASYGENLIN C subroutine. More detailed descriptions as well as the descriptions C of all the other GENLIN and BETRALIN arguments that are not C arguments of EASYGENLIN are also described at the begining of the C GENLIN and BETRALIN subroutines. C C Parameters of the subroutine: C C On entry: C C n integer C number of variables C C x double precision x(n) C initial estimation of the solution C C l double precision l(n) C lower bounds on the variables C C u double precision u(n) C upper bounds on the variables C C ml integer C total number of linear constraints (excluding bounds) C C mleq integer C number of linear equality constraints (excluding bounds) C C lda integer C leading dimension of matrix A C C A double precision A(lda,n) C coeficients of linear constraints C C b double precision b(ml) C constant part of linear constraints C C gtype integer, C type of derivatives calculation according to the C following convention: C C = 0, true derivatives. In this case, subroutines evalg C and evaljac must be modified by the user to compute C the derivatives of the objective function and the C constraints. C = 1, finite differences approximation provided by C GENLIN. In this case, subroutines evalg and C evaljac may have an empty body but must be present. C It is also recommended that those empty-body C subroutines set flag = - 1. Last but not least, C the option gtype = 1 is not cheap neither safe. C C hptype integer C The way in which the product of the Hessian matrix C by a vector will be done C depends on the value of the parameter hptype in the C following way: C C = 0, means that the subroutine to compute the Hessian of C the objective function (evalh) was provided by the C user. So, the product of the Hessian times a vector C will be computed using the Hessian provided by this C subroutine. C C = 9, means that an incremental quotients approximation C will be used. This option requires the evaluation of C an extra gradient at each Conjugate Gradient C iteration. If gtype = 0 then this gradient evaluation C will be done using the user supplied subroutine C evalg. On the other hand, if gtype = 1, the gradient C calculation will be done using just calls to the user C provided subroutine evalf. nind calls will be done, C where nind is the dimension of the current face of C the active-set method. C C Options hptype = 2 and hptype = 3 are both identical to C hptype = 9. C C If you did not code subroutine evalg to compute the C gradient of the objective function then your options C finished here. C C = 4, means that the Hessian matrix will be approximated C and then the product of the Hessian approximation C by the vector will be computed exactly. The C approximation is a BFGS approximation of the C Hessian (without memory) and using the spectral C approximation (instead of the identity) as initial C approximation. C C Numerical experiments suggested that this option is C not convenient for unconstrained or just bound- C constrained problems. (Note that this option was C developed to be used in the Augmented Lagrangian C framework.) C C This option does NOT require an extra gradient C evaluation per iteration and, in this sense, each C CG iteration is computationally cheaper than a CG C iteration of the previous choices. C C Quadratic subproblems are convex with this choice. C C Options hptype = 5 and hptype = 6 are both identical to C hptype = 9. C C intype integer C decide which inner algorithm should be used to solve C linearly-constrained subproblems: C C = 1 means GENLIN is used. C C = 2 means dense version of BETRALIN is used. C C precond character * 6 C indicates the type of preconditioning that will be used C for Conjugates Gradients. C C 'NONE' means no preconditioner at all, C C 'QNCGNA' means Quasi-Newton Correction of the Gauss- C Newton approximation of the Hessian. The exact C form is this preconditioner is described in: C C E. G. Birgin and J. M. Martínez, "Structured C minimal-memory inexact quasi-Newton method and C secant preconditioners for Augmented Lagrangian C Optimization", Computational Optimization and C Applications, 39, pp, 1-16, 2008. C C epsgpsn double precision C GENLIN or BETRALIN stop declaring convergence if it finds C a point whos projected gradient sup-norm is smaller than C or equal to epsgpsn C C epscsn double precision C feasibility tolerance for the sup-norm of the linear C constraints C C lossfeas logical C if a loss of feasibility up to sqrt(epsfeas) is allowed C during the computations, lossfeas must be set to TRUE C (recommended). In this case, if the final iterate does C not satisfy the constraints with the desired precision, C we sugest that the user re-run the method using the final C point obtained as the initial point, using C lossfeas = FALSE C C maxit integer C GENLIN or BETRALIN stops declaring ''maximum number of C iteration achieved'' if the number of iterations exceeds C maxit C C maxfc integer C the same as before but with the number of functional C evaluations C C iprint integer C indicates the degree of details of the output generated C by GENLIN or BETRALIN. Setting iprint to a value smaller C than 2 will make GENLIN or BETRALIN to generate no output C at all. An iprint value greater than or equal to 2 will C generate information of every GENLIN and BETRALIN iteration. C An iprint value greater than or equal to 3 will also show C information of the Conjugate Gradient iterations (used to C compute the Truncated Newton direction) or trust region C iterations and also information related to the line C search procedures in the Spectral Projected Gradient C direction and the Truncated Newton direction. C C ncomp integer, C every time a vector is printed, just its first ncomp C component will be displayed. C C mlcomp integer, C every time a linear constrait is printed, just its first C mlcomp component will be displayed. C C macheps double precision C macheps is the smallest positive number such that C 1 + macheps is not equal to 1 C C bignum double precision C a big number like 1.0d+99 C C ldabar,ldh integer C leading dimension of matrices Abar and H C C Abar,H double precision Abar(ldabar,ml),H(ldh,n) C working matrix C C wi1,wi2 integer wi1,wi2(n) C n-dimensional working vectors of integers C C wi3 integer wi3(ml), C wi4 integer wi4(2*n+ml) C wi5 integer wi5(n+ml) C integer working vectors C C wd1, ..., wd20 double precision wd1(n), ..., wd20(n) C n-dimensional working vectors of doubles C C wd21,wd22 double precision wd21,wd22(ml) C double precision working vectors C C wd23 double precision wd23(lwd23) C double precision working vector C C On return: C C x double precision x(n) C estimation of the solution C C f double precision C objective function value at the solution C C g double precision g(n) C gradient of the objective function at the solution C C gpsupn double precision C sup-norm of the discontinuous projected gradient C C csupn double precision C sup-norm of the linear constraints C C iter integer C number of iterations used to reach the solution C C fcnt integer C number of functional evaluations C C gcnt integer C number of gradient evaluations C C hcnt integer C number of hessian evaluations C C cgcnt integer C number of Conjugate Gradient iterations C C chcnt integer C number of Cholesky decompositions C C spgiter integer C number of PSPG iterations C C spgfcnt integer C number of functional evaluations performed in PSPG C iterations C C tniter integer C number of Truncated-Newton iterations C C tnfcnt integer C number of functional evaluations performed in C Truncated-Newton iterations C C triter integer C number of Trust-region iterations C C trfcnt integer C number of functional evaluations performed in C Trust-region iterations C C ispgiter integer C number of inner SPG iterations C C ispgfcnt integer C number of functional evaluations performed in inner C SPG iterations C C iterql integer C number of calls to QL routine (used to perform C projections) C C inform integer C termination criteria. inform equal to 0 means that C GENLIN (BETRALIN) converged with the sup-norm of the C dicontinuous projected gradient stopping criterion. Other C positive values means that GENLIN or BETRALIN stopped by C a maybe not successful stopping criteria. A negative C value means that there was an error in the user-defined C subroutines that computes the objective function C (subroutine evalobj), the gradient (subroutine evalgr), C the Hessian-vector product (subroutine evalhd), or in the C projection routine. C C The values of inform mean: C C 0 = convergence with small sup-norm of the continuous C projected gradient (smaller than epsgpsn); C C 2 = the algorithm stopped by ''lack of progress'', that C means that f(xk) - f(x_{k+1}) <= epsnfp * C max{ f(x_j) - f(x_{j+1}, j < k } during maxitnfp C consecutive iterations. If desired, set maxitnfp C equal to maxit to inhibit this stopping criterion. C C 4 = the algorithm stopped because the functional value C is very small (smaller than fmin). If desired, set C fmin equal to minus bignum to inhibit this stopping C criterion. C C 5 = the algorithm stopped because the trust-region radius C is very small (smaller than macheps**(2.0d0/3.0d0)). C C 6 = too small step in a line search. After having made at C least mininterp interpolations, the steplength C becames small. ''small steplength'' means that we are C at point x with direction d and step alpha, such that C C | alpha * d(i) | <= macheps * max( | x(i) |, 1 ) C C for all i. C C In that case failure of the line search is declared C (may be the direction is not a descent direction due C to an error in the gradient calculations). If C desired, set mininterp equal to maxfc to inhibit this C stopping criterion. C C 7 = it was achieved the maximum allowed number of C iterations (maxit). C C 8 = it was achieved the maximum allowed number of C function evaluations (maxfc). C C 9 = the algorithm stopped because the function provided by C the user to decide whether or not the algorithm should C stop at the current iteration returned a true value. C C 10 = the algorithm stopped because a direction could not be C computed because of errors occured during its C calculations. C C -30 = the algorithm stopped in a feasible point because a C problem occured in projection subroutine. Probably, we C are asking for too much accuracy in projection; C C -40 = the algorithm stopped because the point infeasible. C Probably, we are asking for little accuracy in C projection; C C -50 = error in QR decomposition; C C -70 = some linear constraints are inconsistent; C C -90 = means that subroutine evalf retuned an error flag; C C -92 = means that subroutine evalg retuned an error flag; C C -94 = means that subroutine evalh retuned an error flag; C C HERE STARTS THE DESCRIPTION OF SOME GENLIN ARGUMENTS THAT ARE C BEING SETTED INSIDE EASYGENLIN. THE FIRST SET OF ARGUMENTS ARE C THOSE ARGUMENTS THAT WE WILL CALL ''CONSTANTS'' AND THAT, AS THEIR C VALUES ALTER THE BEHAVIOUR OF GENLIN, SHOULD NOT BE MODIFIED BY A C COMMON USER. C CONSTANTS FOR CLASSICAL LINE-SEARCH CONDITIONS (PSPG AND GENCAN) C gamma is the constant for the sufficient decrease ''Armijo C condition''. C theta is the constant for the ''angle condition''. C sigma1 and sigma2 are the constants for the safeguarding quadratic C interpolations. We use them in a rather unusual way. Instead of C discarding a new step anew if it does not belong to the interval C [ sigma1 * aprev, sigma2 * aprev ], we discard it if it does not C belong to the interval [ sigma1, sigma2 * aprev ]. In such a case C we take something similar to ''anew = aprev / 2''. double precision gamma,theta,sigma1,sigma2 parameter ( gamma = 1.0d-04 ) parameter ( theta = 1.0d-06 ) parameter ( sigma1 = 0.1d0 ) parameter ( sigma2 = 0.9d0 ) C CONSTANTS FOR CLASSICAL TRUST-REGION CONDITIONS (WFBETRA) C alpha id the constant for the sufficient decrease , when comparing C the predicted decrease of funcional value (given by the quadratic C model) and the real one. double precision alpha parameter (alpha = 0.1d0 ) C CONSTANTS FOR SPECIFIC PROCEDURES (NOT SO CLASSICAL) C In line searches, when interpolating, the step may become so C small that we should declare a line search failure indicating that C direction may not be a descent direction. This decision is never C take before doing at least mininterp interpolations. C In the line searches, when we need to interpolate and the result C of the quadratic interpolation is rejected, the new step is C computed as anew = aprev / etaint. C When computing the Newton direction by Conjugate Gradients we C never go further an artificial ''trust region''. This ''trust C radius'' is never smaller than delmin. C We always use as a first step in a line search procedure along a C first order direction the spectral steplength. This steplength C must belong to the interval [lspgmi,lspgma]. C When computing the direction using More-Sorensen's algorithm, the C successfull stopping criteria involve mseps. It can also stop C because it exceeded the maximum allowed number of iterations C msmaxit. mssig is a tolerance of how far from the boundary of the C trust-region a direction (that should be on the boundary) may be. C msrho is used to garantee that a certain direction to be computed C will be inside the feasible region. C phieps is used to decide if a point is minimizer of the quadratic C model (WFBETRA). msrho is used to shrink the trust region radius so C the next direction is inside the region defined by the constraints. integer mininterp parameter ( mininterp = 4 ) double precision etaint,delmin,lspgma,lspgmi parameter ( etaint = 2.0d0 ) parameter ( delmin = 1.0d+04 ) parameter ( lspgma = 1.0d+10 ) parameter ( lspgmi = 1.0d-10 ) integer msmaxit parameter ( msmaxit = 20 ) double precision mseps, mssig, phieps, msrho parameter ( mseps = 1.0d-08 ) parameter ( mssig = 0.1d+00 ) parameter ( phieps = 1.0d-05 ) parameter ( msrho = 0.7d+00 ) C HERE STARTS THE DESCRIPTION OF THE OTHER ARGUMENTS OF GENLIN BEING C SETTED BY EASYGENLIN. THESE ARGUMENTS MAY BE MODIFIED BY A COMMON C USER IF, WITH THEIR SUGGESTED VALUES, GENLIN DOES NOT GIVE THE C EXPECTED RESULT. C GENLIN AND BETRALIN INPUT ARGUMENTS THAT WILL BE SETTED BELOW integer cgscre,maxitnfp,maxitnqmp,trtype,ktest double precision cgepsf,cgepsi,cggpnf,cgmia,cgmib,delta0,epsnfp, +epsnqmp,fmin,trdelini,trdelmin C GENLIN ANS BETRALIN OUTPUT ARGUMENTS THAT WILL BE DISCARDED integer tnintcnt,tnintfe,tnstpcnt,promaxit double precision gpeucn2,projeps,toldgp C ARGUMENTS RELATED TO STOPPING CRITERIA (GENLIN AND BETRALIN) C maxitnfp means MAXimum of allowed number of iterations with No C Progress in the objective functional value. ''Progress'' from one C iteration to the next one refers to ( fnew - fprev ). Since the C begining of the algorithm we save the ''best progress'' and C consider that there was no progress in an iteration if the C progress of this iterations was smaller than epsnfp times the best C progress. Finally, the algorithm stops if there was no progress C during maxitnfp consecutive iterations. maxitnfp = 50 epsnfp = macheps C There is a stopping criterion that stops the method if a point C with a functional value smaller than fmin is found. The idea C behind this stopping criterion is to stop the method if the C objective function is not bounded from bellow. fmin = - 1.0d+20 C ARGUMENTS RELATED TO CONJUGATE GRADIENTS (GENCAN) C When computing the Truncated Newton direction by Conjugate C Gradients there is something similar to a ''trust-region radius''. C This trust radius is updated from iteration to iteration depending C on the agreement of the objective function and its quadratic C model. But an initial value for the trust radius is required. If C the user has a good guess for this initial value then it should be C passed to WFGENCAN using the delta0 arguments. On the other hand, C if delta0 is set to -1, a default value depending on the norm of C the current point will be used. delta0 = - 1.0d0 C The ''trust-region'' can be like a ball (using Euclidian norm) or C like a box (using sup-norm). This choice can be made using trtype C (TRust region TYPE) argument. trtype equal to 0 means Euclidian C norm and trtype equal to 1 means sup-norm. trtype = 0 C When the method is far from the solution, it may be not useful to C do a very large effort in computing the Truncated Newton direction C precisely. To avoid it, a fixed maximum number of iterations for C Conjugate Gradients can be given to WFGENCAN. If the user would like C to choose this maximum number of iterations for Conjugate C Gradient then it should use cgmia and cgmib arguments. On the other C hand, if he/she prefers to leave this task to WFGENCAN then he/she C should set cgmia = -1.0d0 and cgmib = -1.0d0. cgmia = - 1.0d0 cgmib = - 1.0d0 C If the task of deciding the accuracy for computing the Truncated C Newton direction is leaved to WFGENCAN then a default strategy based C on increasing accuracies will be used. The proximity to the C solution is estimated observing the norm of the projected gradient C at the current point and locating it between that norm at the C initial point and the expected value of that norm at the solution. C Then the accuracy for the Truncated Newton direction of the C current iteration will be computed taking a precision located in C the same relative position with respect to two given values for C the accuracies for the first and the last Truncated Newton C direction calculations. These two accuracies (cgepsi and cgepsf, C respectively) must be given by the user. Moreover, the expected C value of the projected gradient norm at the solution (cggpnf) must C also be given by the user who must indicate setting argument C cgscre to 1 or 2 if that norm is the Euclidian or the sup-norm. cggpnf = max( 1.0d-04, epsgpsn ) cgscre = 2 cgepsi = 1.0d-01 cgepsf = 1.0d-08 C The next two arguments are used for an alternative stopping C criterion for Conjugate Gradients. Conjugate Gradients method is C stopped if the quadratic model makes no progress during maxitnqmp C (MAXimum of ITerations with No Quadratic Model Progress) C consecutive iterations. In this context, ''no progress'' means C that the progress is smaller than epsnqmp (EPSilon to measure the C No Quadratic Model Progress) times the best progress obtained C during the previous iterations. epsnqmp = 1.0d-08 maxitnqmp = 5 C ARGUMENTS RELATED TO TRUST-REGION RADIUS (WFBETRA) C At each iteration, the trust-region radius must be greater then C trdelmin. This parameter is also used to decide if and trust-region C iteration or an inner spg iteration will be used inside a face. C trdelini is used to calculate the initial trust-region radius, that C will be greater or equal to trdelini. trdelini = 1.0d+02 trdelmin = 1.0d-08 C ARGUMENT RELATED WHEN CALCULATE PROJECTED GRADIENT C Since projection is expensive, the projected gradient is computed C only when ktest consecutive iterations made the number of C constraits in the active set bigger, or when it is necessary. ktest = 20 C SET PROJECTION PARAMETERS projeps = epscsn**1.25d0 promaxit = 5000 toldgp = 0.1d0 C FINALLY, CALL GENLIN call genlin(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype,precond, +epsgpsn,maxitnfp,epsnfp,fmin,maxit,maxfc,delta0,cgmia,cgmib, +cgscre,cggpnf,cgepsi,cgepsf,epsnqmp,maxitnqmp,etaint,mininterp, +trtype,iprint,ncomp,mlcomp,macheps,bignum,f,g,gpeucn2,gpsupn, +csupn,epscsn,lossfeas,iter,fcnt,gcnt,hcnt,cgcnt,chcnt,spgiter, +spgfcnt,ispgiter,ispgfcnt,tniter,tnfcnt,tnstpcnt,tnintcnt,tnintfe, +triter,trfcnt,iterql,inform,wd1,wd2,wd3,wd4,wd5,wi1,wi2,wi3,wd6, +wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14,wd15,wd16,wd17,wd18,wd23, +lwd23,wd21,wd19,wd20,ldabar,Abar,wd22,ldh,H,wi4,wi5,delmin, +lspgma,lspgmi,theta,gamma,sigma1,sigma2,msmaxit,msrho,mseps, +phieps,mssig,trdelini,trdelmin,alpha,projeps,promaxit,ktest, +toldgp) end C ****************************************************************** C ****************************************************************** subroutine genlin(n,x,l,u,ml,mleq,lda,A,b,gtype,hptype,intype, +precond,epsgpsn,maxitnfp,epsnfp,fmin,maxit,maxfc,udelta0,ucgmia, +ucgmib,cgscre,cggpnf,cgepsi,cgepsf,epsnqmp,maxitnqmp,etaint, +mininterp,trtype,iprint,ncomp,mlcomp,macheps,bignum,f,g,gpeucn2, +gpsupn,csupn,epscsn,lossfeas,iter,fcnt,gcnt,hcnt,cgcnt,chcnt, +spgiter,spgfcnt,ispgiter,ispgfcnt,tniter,tnfcnt,tnstpcnt,tnintcnt, +tnintfe,triter,trfcnt,iterql,inform,s,y,d,xprev,gprev,ind,ind2, +iact,wd1,wd2,wd3,wd4,wd5,wd6,wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd14, +lwd14,wd15,gz,dz,ldabar,Abar,tau,ldh,H,wi1,rbdind,delmin,lspgma, +lspgmi,theta,gamma,sigma1,sigma2,msmaxit,msrho,mseps,phieps,mssig, +trdelini,trdelmin,alpha,projeps,promaxit,ktest,toldgp) implicit none C SCALAR ARGUMENTS logical lossfeas character * 6 precond integer cgcnt,chcnt,cgscre,fcnt,gcnt,hcnt,gtype,hptype,intype, + inform,iprint,iter,ml,mleq,lda,maxfc,maxit,maxitnfp, + maxitnqmp,mininterp,n,ncomp,mlcomp,spgfcnt,spgiter, + ispgfcnt,ispgiter,tnfcnt,tnintcnt,tnintfe,tniter,tnstpcnt, + triter,trfcnt,iterql,trtype,ldabar,ldh,lwd14,msmaxit, + promaxit,ktest double precision bignum,cgepsf,cgepsi,cggpnf,delmin,epsgpsn, + epsnfp,epsnqmp,etaint,f,fmin,gamma,gpeucn2,gpsupn,csupn, + lspgma,lspgmi,macheps,sigma1,sigma2,theta,ucgmia,ucgmib, + udelta0,msrho,mseps,phieps,mssig,trdelini,trdelmin,alpha, + epscsn,projeps,toldgp C ARRAY ARGUMENTS integer ind(n),ind2(n),iact(ml),wi1(2*n+ml),rbdind(n+ml) double precision d(n),g(n),gprev(n),l(n),s(n),u(n),wd1(n),wd2(n), + wd3(n),wd4(n),wd5(n),wd6(n),wd7(n),wd8(n),wd9(n),wd10(n), + wd11(n),wd12(n),wd13(n),wd14(lwd14),wd15(ml),gz(n),dz(n), + x(n),xprev(n),y(n),H(ldh,n),A(lda,n),b(ml), + Abar(ldabar,ml),tau(ml) C Solves the linearly-constrained minimization problem C C Minimize f(x) C C subject to C C Aix = bi, i = 1, mleq C Cix >= di, i = mleq+1, ml C l <= x <= u C C using a method described in C C M. Andretta, E. G. Birgin and J. M. Martinez, ''Partial Spectral C Projected Gradient Method with Active-Set Strategy for Linearly C Constrained Optimization'', Submitted, 2008. C DATA BLOCKS character * 41 ittext(8) data ittext(1) /'(Used a PSPG iteration) '/ data ittext(2) /'(Used TN with the ANALYTIC HESSIAN) '/ data ittext(3) /'(Used TN with the USER HP PRODUCT) '/ data ittext(4) /'(Used TN with a QN HESSIAN APPROX) '/ data ittext(5) /'(Used TN with INCREMENTAL QUOTIENTS) '/ data ittext(6) /'(Used TN with PURE INCREMENTAL QUOTIENTS)'/ data ittext(7) /'(Used a inner SPG iteration) '/ data ittext(8) /'(Used a trust-region iteration) '/ C LOCAL SCALARS logical samefa,gencan,calcAx,frst,gotgp,gotgpp,gotd,changed character * 6 precondd integer fcntprev,infotmp,ittype,itnfpin,itnfpspg,nind,nind2, + nprint,cgcntprev,chcntprev,triterprev,informprev,mlprint, + index1,index2,i,ii,j,jj,k,nact,nliact,rbdlu,rbdli,tolact, + hitbd,intnan double precision bestprog,acgeps,bcgeps,currprog,fprev,lamspg, + seucn,ssupn,sts,sty,yeucn,xeucn2,xsupn,mslamb,trdelta, + stlen,newtrdelta,gzsupn,px,seed,maxstp,tmp,ax,ad,sgpsupn, + gsupn,toldgptmp C FUNCTIONS double precision drand C ================================================================== C Initialization C ================================================================== C Set some initial values: C just for printing, nprint = min0( n, ncomp ) mlprint = min0( ml, mlcomp ) C for testing progress in f and decrease of the sup-norm of the C internal gradient, fprev = bignum bestprog = 0.0d0 itnfpin = 0 itnfpspg = 0 C to sum something to initial point when f(x) or g(x) is NAN frst = .true. seed = 1234567.0d0 C for calculating More-Sorensen's direction, mslamb = 0.0d0 C for calculating matrix-vector product A x, and calcAx = .true. intnan = 0 toldgptmp = toldgp C for choosing the algorithm to be used within the faces, cgcntprev = 0 chcntprev = 0 triterprev = 0 informprev = 0 C counters. iter = 0 fcnt = 0 gcnt = 0 hcnt = 0 chcnt = 0 cgcnt = 0 spgiter = 0 spgfcnt = 0 ispgiter = 0 ispgfcnt = 0 triter = 0 trfcnt = 0 tniter = 0 tnfcnt = 0 tnstpcnt = 0 tnintcnt = 0 tnintfe = 0 hitbd = 0 iterql = 0 C Print problem information if( iprint .ge. 2 ) then write(*, 973) n write(*, 974) ml write(*, 975) mlprint do i = 1,mlprint write(*, 976) nprint, (A(i,j), j = 1, nprint) end do write(*, 977) mlprint,(b(i),i=1,mlprint) write(*, 978) nprint, (l(i),i=1,nprint) write(*, 979) nprint, (u(i),i=1,nprint) write(*, 980) nprint, (x(i),i=1,nprint) write(10,973) n write(10,974) ml write(10,975) mlprint do i = 1,mlprint write(10,976) nprint, (A(i,j), j = 1, nprint) end do write(10,977) mlprint,(b(i),i=1,mlprint) write(10,978) nprint, (l(i),i=1,nprint) write(10,979) nprint, (u(i),i=1,nprint) write(10,980) nprint, (x(i),i=1,nprint) end if C Project initial guess. If the initial guess is infeasible, C projection puts it into the politope. 600 continue iter = 1 call project(n, x, l, u, ml, mleq, lda, A, b, promaxit, projeps, + .false., epscsn, csupn, macheps, wi1, wd3, wd14, lwd14, wd4, + iterql, inform) calcAx = .false. if (inform .lt. 0) then if (iprint .ge. 2) then write(*, 1008) -70, -inform write(10,1008) -70, -inform end if inform = -70 return end if if (inform .eq. 2) then inform = -40 if (iprint .ge. 2) then write(*, 1009) inform write(10,1009) inform end if return end if C If x_i should be equal to l_i (u_i), but, instead, is too close C to it, set x_i = l_i (u_i). do i = 1,n if (x(i) .le. l(i) + + macheps**(2.0d0/3.0d0) * max(abs(l(i)), 1.0d0)) then x(i) = l(i) end if if (x(i) .ge. u(i) - + macheps**(2.0d0/3.0d0) * max(abs(u(i)), 1.0d0)) then x(i) = u(i) end if end do C Calculate wd14 = A x. if (calcAx) then do i = 1, ml wd14(i) = 0.0d0 end do do j = 1, n do i = 1, ml wd14(i) = wd14(i) + A(i,j) * x(j) end do end do end if C Check if point x is feasible. csupn = 0.0d0 do i = 1, mleq csupn = max(csupn, abs(wd14(i) - b(i))) end do do i = mleq+1, ml csupn = max(csupn, b(i)-wd14(i)) end do do i = 1, mleq if (abs(wd14(i) - b(i)) .gt. epscsn) then inform = -40 if (iprint .ge. 2) then write(*, 1011) inform, i write(10,1011) inform, i end if return end if end do do i = mleq+1, ml if (b(i) - wd14(i) .gt. epscsn) then inform = -40 if (iprint .ge. 2) then write(*, 1011) inform, i write(10,1011) inform, i end if return end if end do C Store in nind the number of free variables and in array ind their C identifiers. nind = 0 do i = 1, n if ((x(i) .gt. l(i)) .and. (x(i) .lt. u(i))) then nind = nind + 1 ind(nind) = i end if end do nind2 = nind do i = 1, nind2 ind2(i) = i end do C Store in nact the number of active linear constraints and in C array iact their identifiers. The last m - nact positions of C iact store the identifier of the non-active linear constraints. do i = 1, mleq iact(i) = i end do nact = mleq k = ml do i = mleq+1, ml if (abs(wd14(i)-b(i)) .le. epscsn) then nact = nact + 1 iact(nact) = i else iact(k) = i k = k - 1 end if end do C Compute x norms xeucn2 = 0.0d0 xsupn = 0.0d0 do i = 1,n xeucn2 = xeucn2 + x(i) ** 2 xsupn = max( xsupn, abs( x(i) ) ) end do C Compute function and gradient at the initial point call evalobj(n,x,f,inform) fcnt = fcnt + 1 if ( inform .lt. 0 ) then if ( frst ) then if ( iprint .ge. 2 ) then write(*, *) write(*, *) + 'f(x) is undefined. A perturbation is computed.' write(10,*) write(10,*) + 'f(x) is undefined. A perturbation is computed.' end if do i = 1,n px = sqrt(macheps) * max(abs(x(i)),1.0d0) x(i) = x(i) + px - px*drand(seed) end do frst = .false. go to 600 end if if ( iprint .ge. 2 ) then write(*, 1000) inform write(10,1000) inform end if return end if call evalgr(n,x,g,gtype,macheps,inform) gcnt = gcnt + 1 if ( inform .lt. 0 ) then if ( frst ) then if ( iprint .ge. 2 ) then write(*, *) write(*, *) + 'g(x) is undefined. A perturbation is computed.' write(10,*) write(10,*) + 'g(x) is undefined. A perturbation is computed.' end if do i = 1,n px = sqrt(macheps) * max(abs(x(i)),1.0d0) x(i) = x(i) + px - px*drand(seed) end do frst = .false. go to 600 end if if ( iprint .ge. 2 ) then write(*, 1000) inform write(10,1000) inform end if return end if C Compute discontinuous-project-gradient. samefa = .false. gotgp = .true. C Move all active linear constraints to the first rows of A. C Do the same with b. Update array wd14 (= A x). do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = wd14(i) wd14(i) = wd14(ii) wd14(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Move all "almost" active linear constraints to the first rows of A. C Do the same with b. tolact = nact do i = nact+1, ml ax = wd14(i) if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then tolact = tolact + 1 ii = tolact if (i .ne. ii) then do j = 1, n tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end do tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end if end do C Use only active constraits to project do i = 1,n wd1(i) = x(i) - g(i) end do call project(n, wd1, l, u, tolact, mleq, lda, A, b, promaxit, + projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, + lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then inform = -30 if (iprint .ge. 2) then write(*, 1007) inform write(10,1007) inform end if return end if do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian and Sup norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do C Test if inicial (projected) point is a solution C Test whether the discontinuous-projected-gradient Sup norm C is small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If there is at least 1 active linear constraint, we need C to calculate matrix Z. if (nact .gt. 0) then C Abar^T is formed by the columns of A corresponding to free C variables and rows of A corresponding to active constraints. do i = 1, nact ii = iact(i) do j = 1, nind jj = ind(j) Abar(j,i) = A(ii,jj) end do end do C Calculate QR factorization of Abar. do i = 1, nact wi1(i) = 0 end do call DGEQP3(nind, nact, Abar, ldabar, wi1, tau, wd14, lwd14, + inform) if (inform .ne. 0) then inform = -50 if (iprint .ge. 2) then write(*, 1010) inform write(10,1010) inform end if return end if C Count the number of LI rows of Abar (that is, the number of C non-null diagonal elements of R. k = min(nind, nact) nliact = 1 1 if (abs(Abar(nliact,nliact)) .gt. macheps**(2.0d0/3.0d0)) then nliact = nliact + 1 if (nliact .le. k) then go to 1 end if end if nliact = nliact - 1 else nliact = 0 end if C Compute s = x_aux - x_0, y = g_aux - g_0, and sts = 0.0d0 sty = 0.0d0 ssupn = 0.0d0 seucn = 0.0d0 yeucn = 0.0d0 do i = 1,n s(i) = 0.0d0 y(i) = 0.0d0 end do seucn = sqrt( sts ) yeucn = sqrt( yeucn ) C Compute a linear relation between gpeucn2 and cgeps2, i.e., C scalars a and b such that c C a * log10(||g_P(x_0)||_2^2) + b = log10(cgeps_0^2) and c C a * log10(||g_P(x_f)||_2^2) + b = log10(cgeps_f^2), c C where cgeps_0 and cgeps_f are provided. Note that if C cgeps_0 is equal to cgeps_f then cgeps will be always C equal to cgeps_0 and cgeps_f. C We introduce now a linear relation between gpsupn and cgeps also. if (cgscre .eq. 1) then acgeps = 2.0d0 * log10(cgepsf / cgepsi) / + log10(cggpnf ** 2 / gpeucn2) bcgeps = 2.0d0 * log10(cgepsi) - acgeps * log10(gpeucn2) else ! if (cgscre .eq. 2) then acgeps = log10(cgepsf / cgepsi) / log10(cggpnf / gpsupn) bcgeps = log10(cgepsi) - acgeps * log10(gpsupn) end if C And it will be used for the linear relation of cgmaxit C gpsupn0 = gpsupn C gpeucn20 = gpeucn2 C Print initial information if( iprint .ge. 2 ) then write(*, 981) iter write(*, 985) nprint,(x(i), i=1,nprint) write(*, 986) nprint,(g(i), i=1,nprint) write(*, 987) nprint,(wd1(i),i=1,nprint) write(*, 988) min0(nprint,nind2),nind2,(ind(ind2(i)), + i=1,min0(nprint,nind2)) write(*, 989) min0(mlprint,nact),nact,(iact(i), + i=1,min0(mlprint,nact)) write(*, 1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,nact,ml, + spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt write(10,981) iter write(10,985) nprint,(x(i), i=1,nprint) write(10,986) nprint,(g(i), i=1,nprint) write(10,987) nprint,(wd1(i),i=1,nprint) write(10,988) min0(nprint,nind2),nind2,(ind(ind2(i)), + i=1,min0(nprint,nind2)) write(10,989) min0(mlprint,nact),nact,(iact(i), + i=1,min0(mlprint,nact)) write(10,1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,nact,ml, + spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt end if C SAVING INTERMEDIATE DATA FOR CRASH REPORT open (20,file='genlin-tabline.out') write(20,3000) 0.0d0,99,n,ml,iter,fcnt,gcnt,hcnt,cgcnt,chcnt, + spgiter,spgfcnt,tniter,tnfcnt,triter,trfcnt,ispgiter, + ispgfcnt,iterql,f,csupn,gpsupn close(20) C Set initial trust-region radius. if (intype .ne. 1) then trdelta = max(trdelmin, trdelini * max(1.0d0, sqrt(xeucn2))) newtrdelta = 0.0d0 end if C ================================================================== C Main loop C ================================================================== 100 continue C ================================================================== C Save current values, f, x and g C ================================================================== fprev = f do i = 1,n xprev(i) = x(i) gprev(i) = g(i) end do gotgpp = gotgp C ================================================================== C Test stopping criteria C ================================================================== C Test whether the functional value is very small if ( f .le. fmin ) then inform = 4 if ( iprint .ge. 2 ) then write(*, 994) inform,fmin write(10,994) inform,fmin end if go to 500 end if C Test whether the number of iterations is exhausted if ( iter .ge. maxit ) then inform = 7 if ( iprint .ge. 2 ) then write(*, 997) inform,maxit write(10,997) inform,maxit end if go to 500 end if C Test whether the number of functional evaluations is exhausted if ( fcnt .ge. maxfc ) then inform = 8 if ( iprint .ge. 2 ) then write(*, 998) inform,maxfc write(10,998) inform,maxfc end if go to 500 end if C Test whether we performed many iterations without good progress C of the functional value currprog = abs(fprev - f) bestprog = max( currprog, bestprog ) if ( currprog .le. epsnfp * bestprog ) then if ( ittype .eq. 1 ) then itnfpspg = itnfpspg + 1 itnfpin = 0 else itnfpin = itnfpin + 1 itnfpspg = 0 end if if ( itnfpspg .ge. maxitnfp ) then inform = 2 if ( iprint .ge. 2 ) then write(*, 992) inform,epsnfp,maxitnfp write(10,992) inform,epsnfp,maxitnfp end if go to 500 end if if ( itnfpin .ge. maxitnfp ) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Too many inner iterations were performed with ', + ' no progress of the objective function. A PSPG ', + ' iteration will be forced now. ' write(10,*) write(10,*) + ' Too many inner iterations were performed with ', + ' no progress of the objective function. A PSPG ', + ' iteration will be forced now. ' end if spgiter = spgiter + 1 iter = iter + 1 C Set iteration type ittype = 1 C Compute spectral steplength if ( sty .le. 0.0d0 ) then lamspg = 1.0d0 else lamspg = sts / sty end if lamspg = min( lspgma, max( lspgmi, lamspg ) ) if (gotgp .and. (lamspg .eq. 1.0d0)) then do i = 1, n wd2(i) = wd1(i) end do gotd = .true. else gotd = .false. end if C Perform a line search with safeguarded quadratic C interpolation along the direction of the spectral C discontinuous projected gradient fcntprev = fcnt call pspgls(n,x,f,g,l,u,ml,mleq,lda,A,b,nact,iact,gotgp, + tolact,lamspg,etaint,mininterp,fmin,maxfc,iprint,wd1,stlen, + gotd,wd2,gamma,sigma1,sigma2,lossfeas,epscsn,projeps, + promaxit,macheps,toldgptmp,wi1,wd3,wd14,lwd14,wd15,wd4,fcnt, + intnan,iterql,inform) spgfcnt = spgfcnt + ( fcnt - fcntprev ) if ( inform .ne. 6 ) then gotgp = .false. end if if ( inform .lt. 0 ) then if ( iprint .ge. 2 ) then write(*, 1000) inform write(10,1000) inform end if return end if if ( inform .eq. 10 ) then if ( iprint .ge. 2 ) then write(*, 1012) inform write(10,1012) inform end if go to 500 end if C Calculate wd14 = A x. do i = 1, ml wd14(i) = 0.0d0 end do do j = 1, n do i = 1, ml wd14(i) = wd14(i) + A(i,j) * x(j) end do end do C Compute sup-norm of the linear constraits csupn = 0.0d0 do i = 1, mleq csupn = max(csupn, abs(wd14(i) - b(i))) end do do i = mleq+1, ml csupn = max(csupn, b(i)-wd14(i)) end do C Compute the gradient at the new iterate infotmp = inform call evalgr(n,x,g,gtype,macheps,inform) gcnt = gcnt + 1 if ( inform .lt. 0 ) then if ( iprint .ge. 2 ) then write(*, 1000) inform write(10,1000) inform end if return end if inform = infotmp C Compute gradient Euclidian and Sup norms. gsupn = 0.0d0 do i = 1, n gsupn = max(gsupn, abs(g(i))) end do C If gradient norm is smaller than eps, the norm of the C discontinuous-project-gradient is also smaller than eps. C In this case, the algorithm stops. if (gsupn .le. epsgpsn) then gotgp = .true. C Move all active linear constraints to the first rows of C A. Do the same with b. do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Move all "almost" active linear constraints to the C first rows of A. Do the same with b. tolact = nact do i = nact+1, ml wd15(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml wd15(i) = wd15(i) + A(i,j) * x(j) end do end do do i = nact+1, ml ax = wd15(i) if (ax-b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then tolact = tolact + 1 ii = tolact if (i .ne. ii) then do j = 1, n tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end do tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end if end do C Use only active constraits to project do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, + promaxit, projeps, lossfeas, epscsn, tmp, macheps, + wi1, wd3, wd14, lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' write(10,*) write(10,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' end if inform = infotmp gpsupn = 1.0d+99 gpeucn2 = 1.0d+99 else inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian and C Sup norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do end if C Test whether the discontinuous-projected-gradient Sup C norm is small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if end if go to 300 end if else itnfpin = 0 itnfpspg = 0 end if C ================================================================== C The stopping criteria were not satisfied, a new iteration will be C made C ================================================================== 110 continue C ================================================================== C Compute new iterate C ================================================================== C ================================================================== C The new iterate will belong to the closure of the current face C ================================================================== C Decide which inner algorithm will be used to compute the next C point if (intype .eq. 1) then gencan = .true. elseif (intype .eq. 2) then gencan = .false. else ! (intype .eq. 0) then if (.not. gencan .and. ((informprev .eq. 5) .or. + (informprev .eq. 6))) then gencan = .true. elseif ((triter .ne. triterprev) .and. + (triter-triterprev .ge. 7)) then gencan = .true. elseif ((chcnt .ne. chcntprev) .and. (chcnt-chcntprev + .ge. 10 * (triter-triterprev))) then gencan = .true. elseif (gencan .and. (informprev .eq. 6)) then gencan = .false. elseif ((cgcnt .ne. 0) .and. + (cgcnt - cgcntprev .ge. 0.6 * n)) then gencan = .false. elseif (n .le. 50) then gencan = .false. else gencan = .true. end if end if C Shrink gradient call shrink(nind, ind, n, g) C Project gradient onto null space of active constraints. If C there is no active constraints, gz = g. if (nact .gt. 0) then call multZT(nind, nliact, ldabar, Abar, tau, g, wd1, gz, + macheps) else do i = 1, nind gz(i) = g(i) end do end if gzsupn = 0.0d0 do i = 1, nind-nliact gzsupn = max(gzsupn, abs(gz(i))) end do C If the projection of the gradient onto null space of active C constraints is null, x is the minimizer in the current face. C The projected gradient is computed now to check if the point C is stationary. If it is not, use PSPG to leave the face. if (gzsupn .le. epsgpsn) then C Expand gradient call expand(nind, ind, n, g) C Move all active linear constraints to the first rows of A. C Do the same with b. do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Move all "almost" active linear constraints to the first rows C of A. Do the same with b. tolact = nact do i = nact+1, ml wd15(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml wd15(i) = wd15(i) + A(i,j) * x(j) end do end do do i = nact+1, ml ax = wd15(i) if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then tolact = tolact + 1 ii = tolact if (i .ne. ii) then do j = 1, n tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end do tmp = b(i) b(i) = b(ii) b(ii) = tmp tmp = wd15(i) wd15(i) = wd15(ii) wd15(ii) = tmp end if end if end do C Compute spectral steplength if ( sty .le. 0.0d0 ) then lamspg = 1.0d0 else lamspg = sts / sty end if lamspg = min( lspgma, max( lspgmi, lamspg ) ) C Use only active constraits to project do i = 1,n wd2(i) = x(i) - lamspg * g(i) end do infotmp = inform call project(n, wd2, l, u, tolact, mleq, lda, A, b, promaxit, + projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, + lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then inform = -30 if (iprint .ge. 2) then write(*, 1007) inform write(10,1007) inform end if return end if inform = infotmp do i = 1,n wd2(i) = wd2(i) - x(i) end do C Compute maximum step. do i = tolact+1, ml wd14(i) = 0.0d0 end do do j = 1, n do i = tolact+1, ml wd14(i) = wd14(i) + A(i,j) * wd2(j) end do end do maxstp = 1.0d0 do i = tolact+1, ml ad = wd14(i) ax = wd15(i) if (ad .lt. 0.0d0) then maxstp = min(maxstp, (b(i) - ax) / ad) end if end do do i = 1,n wd2(i) = maxstp * wd2(i) end do C Compute spectral-discontinuous-project-gradient Euclidian and Sup norms. sgpsupn = 0.0d0 do i = 1, n sgpsupn = max(sgpsupn, abs(wd2(i))) end do C If spectral step is 1, both spectral-discontinuous-project- C gradient and discontinuous-project-gradient are the same. if (lamspg .eq. 1.0d0) then do i = 1, n wd1(i) = wd2(i)/maxstp end do gpsupn = sgpsupn/maxstp gotgp = .true. C Test whether the discontinuous-projected-gradient Sup norm C is small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If the projection of the gradient onto null space of active C constraints is null, x is the minimizer in the current face. C The algorithm decided to stay in the current face, but there C is nothing to be done in it. So, a PSPG iteration is performed. if (iprint .ge. 2) then write(*, *) write(*, *) + ' The current point is a minimizer of the', + ' current face. A PSPG iteration will be used now.' write(10,*) write(10,*) + ' The current point is a minimizer of the', + ' current face. A PSPG iteration will be used now.' end if gotd = .true. go to 200 C If norm of spectral-discontinuous-project-gradient says the C current point is not a solution, perform a PSPG iteration to C leave the current face, without computing the discontinuous C project-gradient. elseif (((lamspg .gt. 1.0d0) .and. + (sgpsupn/maxstp .ge. lamspg*epsgpsn)) .or. + ((lamspg .lt. 1.0d0) .and. + (sgpsupn/maxstp .ge. epsgpsn))) then if (iprint .ge. 2) then write(*, *) write(*, *) + ' The current point is a minimizer of the', + ' current face. A PSPG iteration will be used now.' write(10,*) write(10,*) + ' The current point is a minimizer of the', + ' current face. A PSPG iteration will be used now.' end if gotgp = .false. gotd = .true. go to 200 C If norm of spectral-discontinuous-project-gradient says the C current point is a solution, compute the discontinuous C project-gradient and stop the algorithm. elseif (((lamspg .gt. 1.0d0) .and. + (sgpsupn/maxstp .le. epsgpsn)) .or. + ((lamspg .lt. 1.0d0) .and. + (lamspg .ge. sqrt(macheps)) .and. + (sgpsupn/maxstp .le. lamspg * epsgpsn))) then gotgp = .true. do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, + promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1, + wd3, wd14, lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' write(10,*) write(10,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' end if inform = infotmp gpsupn = 1.0d+99 gpeucn2 = 1.0d+99 else inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian and Sup norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do end if C Test whether the discontinuous-projected-gradient Sup norm is C small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If the projection of the gradient onto null space of active C constraints is null, x is the minimizer in the current face. C The algorithm decided to stay in the current face, but there C is nothing to be done in it. So, a PSPG iteration is performed. if (iprint .ge. 2) then write(*, *) write(*, *) + ' The current point is a minimizer of the', + ' current face. A PSPG iteration will be used now.' write(10,*) write(10,*) + ' The current point is a minimizer of the', + ' current face. A PSPG iteration will be used now.' end if gotd = .true. go to 200 C If norm of spectral-discontinuous-project-gradient does not give C any information about the norm of the discontinuous-project- C gradient, compute the latter and decide if the current point is C a solution or if the algorithm should leave the current face. else gotgp = .true. do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, + promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1, + wd3, wd14, lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then inform = -30 if (iprint .ge. 2) then write(*, 1007) inform write(10,1007) inform end if return end if inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian and Sup C norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do C Test whether the discontinuous-projected-gradient Sup norm C is small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If the projection of the gradient onto null space of active C constraints is null, x is the minimizer in the current face. C The algorithm decided to stay in the current face, but there C is nothing to be done in it. So, a PSPG iteration is performed. if (iprint .ge. 2) then write(*, *) write(*, *) + ' The current point is a minimizer of the', + ' current face. A PSPG iteration will be used now.' write(10,*) write(10,*) + ' The current point is a minimizer of the', + ' current face. A PSPG iteration will be used now.' end if gotd = .true. go to 200 end if end if C Shrink the point, its gradient and the bounds call shrink(nind,ind,n,x) call shrink(nind,ind,n,l) call shrink(nind,ind,n,u) cgcntprev = cgcnt triterprev = triter chcntprev = chcnt iter = iter + 1 if (gencan) then if ( ( precond .eq. 'QNCGNA' ) .and. ( nact .gt. 0 ) ) then precondd = 'NONE' else precondd = precond end if call wfgencan(n,nind,ind,nind2,ind2,x,l,u,ml,mleq,lda,A,b,f,g, + gz,nact,nliact,iact,ldabar,Abar,tau,iter,xsupn,xeucn2,gotgp, + gpsupn,gpeucn2,s,y,ssupn,seucn,yeucn,sts,sty,gtype,hptype, + trtype,precondd,iprint,ncomp,cgepsf,cgepsi,cgscre,acgeps, + bcgeps,delmin,ucgmia,ucgmib,udelta0,epsnqmp,maxitnqmp,theta, + lossfeas,epscsn,macheps,bignum,samefa,lspgmi,lspgma,etaint, + mininterp,fmin,maxfc,gamma,sigma1,sigma2,d,dz,wi1,wd1,wd2,wd3, + wd4,wd5,wd6,wd7,wd8,wd9,wd10,wd11,wd12,wd13,wd15,ittype,rbdlu, + rbdli,rbdind,fcnt,gcnt,hcnt,cgcnt,tniter,tnfcnt,tnstpcnt, + tnintcnt,tnintfe,inform) informprev = inform else call wfbetra(n,nind,ind,nind2,ind2,x,l,u,ml,mleq,lda,A,b,nact, + nliact,iact,samefa,gtype,f,g,gz,gzsupn,trdelta,newtrdelta, + mslamb,msrho,mseps,msmaxit,phieps,mssig,alpha,trdelmin,epsgpsn, + gamma,lspgmi,lspgma,sigma1,sigma2,etaint,mininterp,fmin, + lossfeas,epscsn,projeps,promaxit,macheps,iprint,ncomp,xeucn2, + sts,sty,maxfc,ldh,H,wd1,ldabar,Abar,tau,wi1,d,dz,wd3,wd14, + lwd14,wd4,wd5,wd6,wd15,rbdlu,rbdli,rbdind,triter,trfcnt, + ispgiter,ispgfcnt,fcnt,gcnt,hcnt,chcnt,iterql,ittype,inform) informprev = inform end if C Expand the point, its gradient and the bounds call expand(nind,ind,n,x) call expand(nind,ind,n,g) call expand(nind,ind,n,l) call expand(nind,ind,n,u) if ( inform .lt. 0 ) then if ( iprint .ge. 2 ) then write(*, 1000) inform write(10,1000) inform end if return end if C Calculate wd14 = A x. do i = 1, ml wd14(i) = 0.0d0 end do do j = 1, n do i = 1, ml wd14(i) = wd14(i) + A(i,j) * x(j) end do end do C Compute sup-norm of the linear constraits csupn = 0.0d0 do i = 1, mleq csupn = max(csupn, abs(wd14(i) - b(i))) end do do i = mleq+1, ml csupn = max(csupn, b(i)-wd14(i)) end do C Compute gradient Euclidian and Sup norms. gsupn = 0.0d0 do i = 1, n gsupn = max(gsupn, abs(g(i))) end do C If gradient norm is smaller than eps, the norm of the C discontinuous-project-gradient is also smaller than eps. C In this case, the algorithm stops. if (gsupn .le. epsgpsn) then gotgp = .true. C Move all active linear constraints to the first rows of A. C Do the same with b. do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Move all "almost" active linear constraints to the first rows C of A. Do the same with b. tolact = nact do i = nact+1, ml wd15(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml wd15(i) = wd15(i) + A(i,j) * x(j) end do end do do i = nact+1, ml ax = wd15(i) if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then tolact = tolact + 1 ii = tolact if (i .ne. ii) then do j = 1, n tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end do tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end if end do C Use only active constraits to project do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, promaxit, + projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, + lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' write(10,*) write(10,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' end if inform = infotmp gpsupn = 1.0d+99 gpeucn2 = 1.0d+99 else inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian and Sup norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do end if C Test whether the discontinuous-projected-gradient Sup norm is C small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if end if C If one of these stopping criteria were satisfied by the inner C algorithm, the point x might be a solution. So, the discontinuous C projected is computed if ( ( inform .eq. 6 ) .or. ( inform .eq. 10 ) .or. + ( ( .not. gencan ) .and. ( ( inform .eq. 1 ) .or. + ( inform .eq. 2 ) .or. ( inform .eq. 5 ) ) ) ) then C Move all active linear constraints to the first rows of A. C Do the same with b. do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Move all "almost" active linear constraints to the first rows C of A. Do the same with b. tolact = nact do i = nact+1, ml wd15(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml wd15(i) = wd15(i) + A(i,j) * x(j) end do end do do i = nact+1, ml ax = wd15(i) if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then tolact = tolact + 1 ii = tolact if (i .ne. ii) then do j = 1, n tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end do tmp = b(i) b(i) = b(ii) b(ii) = tmp tmp = wd15(i) wd15(i) = wd15(ii) wd15(ii) = tmp end if end if end do C Compute spectral steplength if ( sty .le. 0.0d0 ) then lamspg = 1.0d0 else lamspg = sts / sty end if lamspg = min( lspgma, max( lspgmi, lamspg ) ) C Use only active constraits to project do i = 1,n wd2(i) = x(i) - lamspg * g(i) end do infotmp = inform call project(n, wd2, l, u, tolact, mleq, lda, A, b, promaxit, + projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, + lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then inform = -30 if (iprint .ge. 2) then write(*, 1007) inform write(10,1007) inform end if return end if inform = infotmp do i = 1,n wd2(i) = wd2(i) - x(i) end do C Compute maximum step. do i = tolact+1, ml wd14(i) = 0.0d0 end do do j = 1, n do i = tolact+1, ml wd14(i) = wd14(i) + A(i,j) * wd2(j) end do end do maxstp = 1.0d0 do i = tolact+1, ml ad = wd14(i) ax = wd15(i) if (ad .lt. 0.0d0) then maxstp = min(maxstp, (b(i) - ax) / ad) end if end do do i = 1,n wd2(i) = maxstp * wd2(i) end do C Compute spectral-discontinuous-project-gradient Euclidian and Sup norms. sgpsupn = 0.0d0 do i = 1, n sgpsupn = max(sgpsupn, abs(wd2(i))) end do C If spectral step is 1, both spectral-discontinuous-project- C gradient and discontinuous-project-gradient are the same. if (lamspg .eq. 1.0d0) then do i = 1, n wd1(i) = wd2(i)/maxstp end do gpsupn = sgpsupn/maxstp gotgp = .true. C Test whether the discontinuous-projected-gradient Sup norm C is small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If the projection of the gradient onto null space of active C constraints is null, x is the minimizer in the current face. C The algorithm decided to stay in the current face, but there C is nothing to be done in it. So, a PSPG iteration is performed. gotd = .true. C If norm of spectral-discontinuous-project-gradient says the C current point is not a solution, perform a PSPG iteration to C leave the current face, without computing the discontinuous C project-gradient. elseif (((lamspg .gt. 1.0d0) .and. + (sgpsupn/maxstp .ge. lamspg*epsgpsn)) .or. + ((lamspg .lt. 1.0d0) .and. + (sgpsupn/maxstp .ge. epsgpsn))) then gotgp = .false. gotd = .true. C If norm of spectral-discontinuous-project-gradient says the C current point is a solution, compute the discontinuous C project-gradient and stop the algorithm. elseif (((lamspg .gt. 1.0d0) .and. + (sgpsupn/maxstp .le. epsgpsn)) .or. + ((lamspg .lt. 1.0d0) .and. + (lamspg .ge. sqrt(macheps)) .and. + (sgpsupn/maxstp .le. lamspg * epsgpsn))) then gotgp = .true. do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, + promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1, + wd3, wd14, lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' write(10,*) write(10,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' end if inform = infotmp gpsupn = 1.0d+99 gpeucn2 = 1.0d+99 else inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian and Sup norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do end if C Test whether the discontinuous-projected-gradient Sup norm is C small enough to declare convergence if ( sgpsupn/maxstp .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If the projection of the gradient onto null space of active C constraints is null, x is the minimizer in the current face. C The algorithm decided to stay in the current face, but there C is nothing to be done in it. So, a PSPG iteration is performed. gotd = .true. C If norm of spectral-discontinuous-project-gradient does not give C any information about the norm of the discontinuous-project- C gradient, compute the latter and decide if the current point is C a solution or if the algorithm should leave the current face. else gotgp = .true. do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, + promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1, + wd3, wd14, lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then inform = -30 if (iprint .ge. 2) then write(*, 1007) inform write(10,1007) inform end if return end if inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian and Sup C norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do C Test whether the discontinuous-projected-gradient Sup norm C is small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If the projection of the gradient onto null space of active C constraints is null, x is the minimizer in the current face. C The algorithm decided to stay in the current face, but there C is nothing to be done in it. So, a PSPG iteration is performed. gotd = .true. end if else gotgp = .false. end if C If the line search (interpolation) in the Truncated Newton C direction stopped due to a very small step (inform = 6), we C will discard this iteration and force a PSPG iteration if ( inform .eq. 10 ) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' It was not possible to compute direction due ', + ' to reounding errors. A PSPG iteration will be ', + ' forced now. ' write(10,*) write(10,*) + ' It was not possible to compute direction due ', + ' to reounding errors. A PSPG iteration will be ', + ' forced now. ' end if go to 200 end if C Note that tnls subroutine was coded in such a way that in case C of inform = 6 termination the subroutine discards all what was C done and returns with the same point it started if ( gencan .and. inform .eq. 6 ) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' The previous Newtonian iteration was discarded', + ' due to a termination for very small step in ', + ' the line search. A PSPG iteration will be ', + ' forced now. ' write(10,*) write(10,*) + ' The previous Newtonian iteration was discarded', + ' due to a termination for very small step in ', + ' the line search. A PSPG iteration will be ', + ' forced now. ' end if go to 200 end if if (.not. gencan) then C If the inner BETRA algorithm stops declaring "first-order C stationary point close to the boundary" (inform = 1) or C "second-order stationary point" (inform = 2), but the C projected discontinuous gradient is not null, use PSPG to leave the C current face. if ( ( inform .eq. 1 ) .or. ( inform .eq. 2 ) ) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' No work needs to be done in the current face. ', + ' A PSPG iteration will be forced now. ' write(10,*) write(10,*) + ' No work needs to be done in the current face. ', + ' A PSPG iteration will be forced now. ' end if go to 200 end if C If the inner BETRA algorithm stops because the trust-region C radius became too small without obtaining sufficient decrease C (inform = 5) then the main algorithm performes a global PSPG C iteration. if ( inform .eq. 5 ) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Trust-region radius became too small. A PSPG ', + ' iteration will be forced now. ' write(10,*) write(10,*) + ' Trust-region radius became too small. A PSPG ', + ' iteration will be forced now. ' end if go to 200 end if C If the inner BETRA algorithm stops because the direction d C computed is such that x is too close to x + d (inform = 6) then C the main algorithm performes a global PSPG iteration. if ( inform .eq. 6 ) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' The direction computed in the previous ', + ' trust-region iteration was too small. A PSPG ', + ' iteration will be forced now. ' write(10,*) write(10,*) + ' The direction computed in the previous ', + ' trust-region iteration was too small. A PSPG ', + ' iteration will be forced now. ' end if go to 200 end if end if go to 300 200 continue spgiter = spgiter + 1 iter = iter + 1 C Set iteration type ittype = 1 C Compute spectral steplength if (.not. gotd) then if ( sty .le. 0.0d0 ) then lamspg = 1.0d0 else lamspg = sts / sty end if lamspg = min( lspgma, max( lspgmi, lamspg ) ) if (gotgp .and. (lamspg .eq. 1.0d0)) then do i = 1, n wd2(i) = wd1(i) end do gotd = .true. end if else if (maxstp .le. 0.1d0) then if (toldgptmp .lt. 1.0d+99) then toldgptmp = toldgptmp*1.0d2 end if end if end if C Perform a line search with safeguarded quadratic interpolation C along the direction of the spectral discontinuous projected gradient fcntprev = fcnt call pspgls(n,x,f,g,l,u,ml,mleq,lda,A,b,nact,iact,gotgp,tolact, +lamspg,etaint,mininterp,fmin,maxfc,iprint,wd1,stlen,gotd,wd2, +gamma,sigma1,sigma2,lossfeas,epscsn,projeps,promaxit,macheps, +toldgptmp,wi1,wd3,wd14,lwd14,wd15,wd4,fcnt,intnan,iterql,inform) spgfcnt = spgfcnt + ( fcnt - fcntprev ) if ( inform .ne. 6 ) then gotgp = .false. end if if ( inform .lt. 0 ) then if ( iprint .ge. 2 ) then write(*, 1000) inform write(10,1000) inform end if return end if if ( inform .eq. 10 ) then if ( iprint .ge. 2 ) then write(*, 1012) inform write(10,1012) inform end if go to 500 end if C Calculate wd14 = A x. do i = 1, ml wd14(i) = 0.0d0 end do do j = 1, n do i = 1, ml wd14(i) = wd14(i) + A(i,j) * x(j) end do end do C Compute sup-norm of the linear constraits csupn = 0.0d0 do i = 1, mleq csupn = max(csupn, abs(wd14(i) - b(i))) end do do i = mleq+1, ml csupn = max(csupn, b(i)-wd14(i)) end do C Compute the gradient at the new iterate infotmp = inform call evalgr(n,x,g,gtype,macheps,inform) gcnt = gcnt + 1 if ( inform .lt. 0 ) then if ( iprint .ge. 2 ) then write(*, 1000) inform write(10,1000) inform end if return end if inform = infotmp C Compute gradient Euclidian and Sup norms. gsupn = 0.0d0 do i = 1, n gsupn = max(gsupn, abs(g(i))) end do C If gradient norm is smaller than eps, the norm of the C discontinuous-project-gradient is also smaller than eps. C In this case, the algorithm stops. if (gsupn .le. epsgpsn) then gotgp = .true. C Move all active linear constraints to the first rows of A. C Do the same with b. do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Move all "almost" active linear constraints to the first rows C of A. Do the same with b. tolact = nact do i = nact+1, ml wd15(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml wd15(i) = wd15(i) + A(i,j) * x(j) end do end do do i = nact+1, ml ax = wd15(i) if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then tolact = tolact + 1 ii = tolact if (i .ne. ii) then do j = 1, n tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end do tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end if end do C Use only active constraits to project do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, promaxit, + projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, + lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' write(10,*) write(10,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' end if inform = infotmp gpsupn = 1.0d+99 gpeucn2 = 1.0d+99 else inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian and Sup norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do end if C Test whether the discontinuous-projected-gradient Sup norm is C small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if end if 300 continue C ================================================================== C Prepare for the next iteration C ================================================================== C This adjustment/projection is ''por lo que las putas pudiera'' changed = .false. do i = 1,n if ( x(i) .le. l(i) + + macheps**(2.0d0/3.0d0) * max( abs( l(i) ), 1.0d0 ) ) then x(i) = l(i) changed = .true. else if (x(i). ge. u(i) - + macheps**(2.0d0/3.0d0) * max( abs( u(i) ), 1.0d0 ) ) then x(i) = u(i) changed = .true. end if end do C Calculate wd14 = A x. if (changed) then do i = 1, ml wd14(i) = 0.0d0 end do do j = 1, n do i = 1, ml wd14(i) = wd14(i) + A(i,j) * x(j) end do end do C Check if point x is feasible. Since the point calculated by the C inner algorithm is feasible, it is not feasible if the adjustment C of x made it infeasible. In this case, we set x as the point used C in the begining of the iteration and begin another iteration C asking for more precision in projection. csupn = 0.0d0 do i = 1, mleq csupn = max(csupn, abs(wd14(i) - b(i))) end do do i = mleq+1, ml csupn = max(csupn, b(i)-wd14(i)) end do if ((lossfeas .and. (csupn .gt. sqrt(epscsn))) .or. + (.not. lossfeas .and. (csupn .gt. epscsn))) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Point became infeasible due to rounding. The ', + ' iteration will be restarted. ' write(10,*) write(10,*) + ' Point became infeasible due to rounding. The ', + ' iteration will be restarted. ' end if do j = 1,n x(j) = xprev(j) g(j) = gprev(j) end do gotgp = gotgpp projeps = projeps * 1.0d-02 go to 110 end if end if C Compute x Euclidian norm xeucn2 = 0.0d0 xsupn = 0.0d0 do i = 1,n xeucn2 = xeucn2 + x(i) ** 2 xsupn = max( xsupn, abs( x(i) ) ) end do C Compute s = x_{k+1} - x_k, y = g_{k+1} - g_k, and sts = 0.0d0 sty = 0.0d0 ssupn = 0.0d0 yeucn = 0.0d0 do i = 1,n s(i) = x(i) - xprev(i) y(i) = g(i) - gprev(i) sts = sts + s(i) ** 2 sty = sty + s(i) * y(i) ssupn = max( ssupn, abs( s(i) ) ) yeucn = yeucn + y(i) ** 2 end do seucn = sqrt( sts ) yeucn = sqrt( yeucn ) C If maximum step length was used, update list of free variables C and list of active linear constraints. The QR decomposition is C updated. if (inform .eq. 3) then samefa = .false. C If a bound is achieved, put its index in the end of the list C of free variables (from index nind2 + 1). if (nact .eq. 0) then if (rbdlu .gt. 0) then k = 1 index1 = rbdind(k) if (index1 .gt. n) then index1 = index1 - n end if j = index1 if (rbdlu .eq. 1) then index2 = 0 else k = k + 1 index2 = rbdind(k) if (index2 .gt. n) then index2 = index2 - n end if end if do i = index1+1, nind if (i .eq. index2) then k = k + 1 if (k .gt. rbdlu) then index2 = 0 else index2 = rbdind(k) if (index2 .gt. n) then index2 = index2 - n end if end if else ind(j) = ind(i) j = j + 1 end if end do nind = nind - rbdlu nind2 = nind do i = 1, nind2 ind2(i) = i end do end if else if (rbdlu .gt. 0) then k = 1 j = 1 ii = rbdind(k) if (ii .gt. n) then ii = ii - n end if index1 = ind(ii) do i = 1, nind2 ii = ind2(i) if (ind(ii) .eq. index1) then k = k + 1 if (k .gt. rbdlu) then index1 = 0 else ii = rbdind(k) if (ii .gt. n) then ii = ii - n end if index1 = ind(ii) end if else ind2(j) = ind2(i) j = j + 1 end if end do nind2 = nind2 - rbdlu do k = 1, rbdlu ii = rbdind(k) if (ii .gt. n) then ii = ii - n end if ind2(nind2+k) = ii end do end if C Update QR factorization of Abar for bounds that are C attained, as if the bound were a linear constraint C being added to active set. do k = 1, rbdlu if (nliact .ge. nind) then go to 70 end if do i = 1, nind wd3(i) = 0.0d0 end do index1 = rbdind(k) if (index1 .gt. n) then wd3(index1-n) = -1.0d0 else wd3(index1) = 1.0d0 end if call updateQR(nind, nliact, ldabar, Abar, tau, wd3, wd4, + macheps) end do end if C If a linear constraint is attained, remove its index1 from the C list of inactive constraints (indices nact+1 to m of vector iact) C and insert it in the list of active constraints. 70 if (rbdli .gt. rbdlu) then k = rbdind(rbdli) index1 = k rbdind(rbdli) = iact(index1) do i = 1, rbdli-rbdlu-1 index2 = rbdind(rbdli-i) rbdind(rbdli-i) = iact(index2) do j = index1-1, index2+1, -1 iact(k) = iact(j) k = k - 1 end do index1 = index2 end do index2 = nact do j = index1-1, index2 + 1, -1 iact(k) = iact(j) k = k - 1 end do k = nact nact = nact + (rbdli - rbdlu) j = nact i = rbdlu+1 ii = rbdind(i) do j = nact, 1, -1 if ((k .lt. 1) .or. (ii .ge. iact(k))) then iact(j) = ii i = i + 1 if (i .gt. rbdli) then go to 80 end if ii = rbdind(i) else iact(j) = iact(k) k = k - 1 end if end do C If linear constraints were attained, QR factorization C of Abar is updated (or performed). 80 if (nact .eq. (rbdli - rbdlu)) then do i = 1, nact ii = iact(i) do j = 1, nind jj = ind(j) Abar(j,i) = A(ii,jj) end do end do C Calculate QR factorization of Abar. do i = 1, nact wi1(i) = 0 end do infotmp = inform call DGEQP3(nind, nact, Abar, ldabar, wi1, tau, wd14, + lwd14, inform) if (inform .ne. 0) then inform = -50 if (iprint .ge. 2) then write(*, 1010) inform write(10,1010) inform end if return end if inform = infotmp C Count the number of LI rows of Abar (that is, the number C of non-null diagonal elements of R. k = min(nind, nact) nliact = 1 3 if (abs(Abar(nliact,nliact)) .gt. + macheps**(2.0d0/3.0d0)) then nliact = nliact + 1 if (nliact .le. k) then go to 3 end if end if nliact = nliact - 1 else do k = rbdlu+1, rbdli if (nliact .ge. nind) then go to 90 end if index1 = rbdind(k) do i = 1, nind ii = ind(i) wd3(i) = A(index1,ii) end do call updateQR(nind, nliact, ldabar, Abar, tau, wd3, + wd4, macheps) end do end if end if C Recalculate the indices of free variables and active linear C constraints and perform QR decomposition. else if ((ittype .eq. 1) .or. (inform .eq. 4) .or. + (inform .eq. 8)) then samefa = .false. C Store in nind the number of free variables and in array ind C their identifiers. nind = 0 do i = 1, n if ((x(i) .gt. l(i)) .and. (x(i) .lt. u(i))) then nind = nind + 1 ind(nind) = i end if end do nind2 = nind do i = 1, nind2 ind2(i) = i end do C Store in nact the number of active linear constraints and in C array iact their identifiers. The last m - nact positions of C iact store the identifier of the non-active linear constraints. nact = mleq k = ml do i = mleq+1, ml if (abs(wd14(i)-b(i)) .le. epscsn) then nact = nact + 1 iact(nact) = i else iact(k) = i k = k - 1 end if end do C If there is at least 1 active linear constraint, we need C to calculate matrix Z. if (nact .eq. 0) then nliact = 0 else C Abar^T is formed by the columns of A corresponding to C free variables and rows of A corresponding to active C constraints. do i = 1, nact ii = iact(i) do j = 1, nind jj = ind(j) Abar(j,i) = A(ii,jj) end do end do C Calculate QR factorization of Abar. do i = 1, nact wi1(i) = 0 end do infotmp = inform call DGEQP3(nind, nact, Abar, ldabar, wi1, tau, wd14, lwd14, + inform) if (inform .ne. 0) then inform = -50 if (iprint .ge. 2) then write(*, 1010) inform write(10,1010) inform end if return end if inform = infotmp C Count the number of LI rows of Abar (that is, the number C of non-null diagonal elements of R. k = min(nind, nact) nliact = 1 5 if (abs(Abar(nliact,nliact)) .gt. + macheps**(2.0d0/3.0d0)) then nliact = nliact + 1 if (nliact .le. k) then go to 5 end if end if nliact = nliact - 1 end if else C If neither a new constraint is attained nor a global PSPG C iteration is performed, the new point belongs to the same face C as the previous one. samefa = .true. end if 90 continue C Print information of this iteration if ( iprint .ge. 2 ) then write(*, 983) iter,ittext(ittype) write(*, 985) nprint,(x(i), i=1,nprint) write(*, 986) nprint,(g(i), i=1,nprint) if (gotgp) then write(*, 987) nprint,(wd1(i),i=1,nprint) end if write(*, 988) min0(nprint,nind2),nind2,(ind(ind2(i)), + i=1,min0(nprint,nind2)) write(*, 989) min0(mlprint,nact),nact,(iact(i), + i=1,min0(mlprint,nact)) if (gotgp) then if (ittype .eq. 1) then write(*, 1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n, + nact,ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt, + hcnt,cgcnt,chcnt else write(*, 1002) f,csupn,sqrt(gpeucn2),gpsupn,gzsupn, + nind2,n,nact,ml,spgiter,tniter,ispgiter,triter, + fcnt,gcnt,hcnt,cgcnt,chcnt end if else if (ittype .eq. 1) then write(*, 1003) f,csupn,nind2,n,nact,ml,spgiter,tniter, + ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt else write(*, 1001) f,csupn,gzsupn,nind2,n,nact,ml,spgiter, + tniter,ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt end if end if write(10,983) iter,ittext(ittype) write(10,985) nprint,(x(i), i=1,nprint) write(10,986) nprint,(g(i), i=1,nprint) if (gotgp) then write(10,987) nprint,(wd1(i),i=1,nprint) end if write(10,988) min0(nprint,nind2),nind2,(ind(ind2(i)), + i=1,min0(nprint,nind2)) write(10,989) min0(mlprint,nact),nact,(iact(i), + i=1,min0(mlprint,nact)) if (gotgp) then if (ittype .eq. 1) then write(10,1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n, + nact,ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt, + hcnt,cgcnt,chcnt else write(10,1002) f,csupn,sqrt(gpeucn2),gpsupn,gzsupn, + nind2,n,nact,ml,spgiter,tniter,ispgiter,triter, + fcnt,gcnt,hcnt,cgcnt,chcnt end if else if (ittype .eq. 1) then write(10,1003) f,csupn,nind2,n,nact,ml,spgiter,tniter, + ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt else write(10,1001) f,csupn,gzsupn,nind2,n,nact,ml,spgiter, + tniter,ispgiter,triter,fcnt,gcnt,hcnt,cgcnt,chcnt end if end if end if C SAVING INTERMEDIATE DATA FOR CRASH REPORT open (20,file='genlin-tabline.out') write(20,3000) 0.0d0,99,n,ml,iter,fcnt,gcnt,hcnt,cgcnt,chcnt, + spgiter,spgfcnt,tniter,tnfcnt,triter,trfcnt,ispgiter, + ispgfcnt,iterql,f,csupn,gpsupn close(20) C If a boundary is hit, increase the counter hitbd. If this counter C reached the maximum number (ktest), compute continuous-project- C gradient and verify if the solution is found. If current point is C not the solution, compute internal discontinuous-project-gradient and C decide if the algorithm shoul stay in the current face. if ( inform .eq. 3 ) then hitbd = hitbd + 1 if ( hitbd .eq. ktest ) then hitbd = 0 C Move all active linear constraints to the first rows of A. C Do the same with b. do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Move all "almost" active linear constraints to the first rows C of A. Do the same with b. tolact = nact do i = nact+1, ml wd15(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml wd15(i) = wd15(i) + A(i,j) * x(j) end do end do do i = nact+1, ml ax = wd15(i) if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then tolact = tolact + 1 ii = tolact if (i .ne. ii) then do j = 1, n tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end do tmp = b(i) b(i) = b(ii) b(ii) = tmp tmp = wd15(i) wd15(i) = wd15(ii) wd15(ii) = tmp end if end if end do C Compute spectral steplength if ( sty .le. 0.0d0 ) then lamspg = 1.0d0 else lamspg = sts / sty end if lamspg = min( lspgma, max( lspgmi, lamspg ) ) C Use only active constraits to project do i = 1,n wd2(i) = x(i) - lamspg * g(i) end do infotmp = inform call project(n, wd2, l, u, tolact, mleq, lda, A, b, + promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1, + wd3, wd14, lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then inform = -30 if (iprint .ge. 2) then write(*, 1007) inform write(10,1007) inform end if return end if inform = infotmp do i = 1,n wd2(i) = wd2(i) - x(i) end do C Compute maximum step. do i = tolact+1, ml wd14(i) = 0.0d0 end do do j = 1, n do i = tolact+1, ml wd14(i) = wd14(i) + A(i,j) * wd2(j) end do end do maxstp = 1.0d0 do i = tolact+1, ml ad = wd14(i) ax = wd15(i) if (ad .lt. 0.0d0) then maxstp = min(maxstp, (b(i) - ax) / ad) end if end do do i = 1,n wd2(i) = maxstp * wd2(i) end do C Compute spectral-discontinuous-project-gradient Euclidian C and Sup norms. sgpsupn = 0.0d0 do i = 1, n sgpsupn = max(sgpsupn, abs(wd2(i))) end do C If spectral step is 1, both spectral-discontinuous-project- C gradient and discontinuous-project-gradient are the same. if (lamspg .eq. 1.0d0) then do i = 1, n wd1(i) = wd2(i)/maxstp end do gpsupn = sgpsupn/maxstp gotgp = .true. C Test whether the discontinuous-projected-gradient Sup norm C is small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If the boundary of constraints is hit for ktest C consecutive iterations, perform a PSPG iteration if (iprint .ge. 2) then write(*,*) write(*,*) + ' After hiting boundary of constraints ', ktest, + ' times, the algorithm decided to leaves the', + ' current face.' write(10,*) write(10,*) + ' After hiting boundary of constraints ', ktest, + ' times, the algorithm decided to leaves the', + ' current face.' end if gotd = .true. go to 200 C If norm of spectral-discontinuous-project-gradient says the C current point is not a solution, perform a PSPG iteration to C leave the current face, without computing the discontinuous C project-gradient. elseif (((lamspg .gt. 1.0d0) .and. + (sgpsupn/maxstp .ge. lamspg*epsgpsn)) .or. + ((lamspg .lt. 1.0d0) .and. + (sgpsupn/maxstp .ge. epsgpsn))) then if (iprint .ge. 2) then write(*,*) write(*,*) + ' After hiting boundary of constraints ', ktest, + ' times, the algorithm decided to leaves the', + ' current face.' write(10,*) write(10,*) + ' After hiting boundary of constraints ', ktest, + ' times, the algorithm decided to leaves the', + ' current face.' end if gotgp = .false. gotd = .true. go to 200 C If norm of spectral-discontinuous-project-gradient says the C current point is a solution, compute the discontinuous C project-gradient and stop the algorithm. elseif (((lamspg .gt. 1.0d0) .and. + (sgpsupn/maxstp .le. epsgpsn)) .or. + ((lamspg .lt. 1.0d0) .and. + (lamspg .ge. sqrt(macheps)) .and. + (sgpsupn/maxstp .le. lamspg * epsgpsn))) then gotgp = .true. do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, + promaxit, projeps, lossfeas, epscsn, tmp, macheps, + wi1, wd3, wd14, lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' write(10,*) write(10,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' end if inform = infotmp gpsupn = 1.0d+99 gpeucn2 = 1.0d+99 else inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian C and Sup norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do end if C Test whether the discontinuous-projected-gradient Sup norm is C small enough to declare convergence if ( sgpsupn/maxstp .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If the boundary of constraints is hit for ktest C consecutive iterations, perform a PSPG iteration if (iprint .ge. 2) then write(*,*) write(*,*) + ' After hiting boundary of constraints ', ktest, + ' times, the algorithm decided to leaves the', + ' current face.' write(10,*) write(10,*) + ' After hiting boundary of constraints ', ktest, + ' times, the algorithm decided to leaves the', + ' current face.' end if gotd = .true. go to 200 C If norm of spectral-discontinuous-project-gradient does not give C any information about the norm of the discontinuous-project- C gradient, compute the latter and decide if the current point is C a solution or if the algorithm should leave the current face. else gotgp = .true. do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, + promaxit, projeps, lossfeas, epscsn, tmp, macheps, + wi1, wd3, wd14, lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then inform = -30 if (iprint .ge. 2) then write(*, 1007) inform write(10,1007) inform end if return end if inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian C and Sup norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do C Test whether the discontinuous-projected-gradient Sup norm C is small enough to declare convergence if ( gpsupn .le. epsgpsn ) then inform = 0 if ( iprint .ge. 2 ) then write(*, 991) inform,epsgpsn write(10,991) inform,epsgpsn end if go to 500 end if C If the boundary of constraints is hit for ktest C consecutive iterations, perform a PSPG iteration if (iprint .ge. 2) then write(*,*) write(*,*) + ' After hiting boundary of constraints ', ktest, + ' times, the algorithm decided to leaves the', + ' current face.' write(10,*) write(10,*) + ' After hiting boundary of constraints ', ktest, + ' times, the algorithm decided to leaves the', + ' current face.' end if gotd = .true. go to 200 end if end if else gotgp = .false. hitbd = 0 end if C ================================================================== C Test some stopping criteria that may occur inside the line C searches or trust-region algorithm C ================================================================== if ( ( inform .eq. 6 ) .and. ( ittype .eq. 1 ) ) then if ( iprint .ge. 2 ) then write(*, 996) inform,mininterp write(10,996) inform,mininterp end if go to 500 end if C ================================================================== C Iterate C ================================================================== go to 100 C ================================================================== C End of main loop C ================================================================== C ================================================================== C Report output status and return C ================================================================== 500 continue C Compute discontinuous-project-gradient gp = P(x - g) - x, if it has C not been calculated. if ( .not. gotgp ) then C Move all active linear constraints to the first rows of A. C Do the same with b. do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Move all "almost" active linear constraints to the first rows C of A. Do the same with b. tolact = nact do i = nact+1, ml wd15(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml wd15(i) = wd15(i) + A(i,j) * x(j) end do end do do i = nact+1, ml ax = wd15(i) if (ax - b(i) .le. toldgptmp*max(1.0d0,abs(b(i)))) then tolact = tolact + 1 ii = tolact if (i .ne. ii) then do j = 1, n tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end do tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end if end do C Use only active constraits to project do i = 1,n wd1(i) = x(i) - g(i) end do infotmp = inform call project(n, wd1, l, u, tolact, mleq, lda, A, b, promaxit, + projeps, lossfeas, epscsn, tmp, macheps, wi1, wd3, wd14, + lwd14, wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then if ( iprint .ge. 2 ) then write(*,*) write(*,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' write(10,*) write(10,*) + ' Problem in projection subroutine. Projected ', + ' gradient could not be calculated. ' end if inform = infotmp gpsupn = 1.0d+99 gpeucn2 = 1.0d+99 else inform = infotmp do i = 1,n wd1(i) = wd1(i) - x(i) end do C Compute discontinuous-project-gradient Euclidian and Sup norms. gpsupn = 0.0d0 gpeucn2 = 0.0d0 do i = 1, n gpsupn = max(gpsupn, abs(wd1(i))) gpeucn2 = gpeucn2 + wd1(i)**2 end do end if end if C Print final information if ( iprint .ge. 2 ) then write(*, 982) iter write(*, 985) nprint,(x(i), i=1,nprint) write(*, 986) nprint,(g(i), i=1,nprint) write(*, 987) nprint,(wd1(i),i=1,nprint) write(*, 988) min0(nprint,nind2),nind2,(ind(ind2(i)), + i=1,min0(nprint,nind2)) write(*, 989) min0(mlprint,nact),nact,(iact(i), + i=1,min0(mlprint,nact)) if (ittype .eq. 1) then write(*, 1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,nact, + ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt, + cgcnt,chcnt else write(*, 1002) f,csupn,sqrt(gpeucn2),gpsupn,gzsupn,nind2,n, + nact,ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt, + cgcnt,chcnt end if write(10,982) iter write(10,985) nprint,(x(i), i=1,nprint) write(10,986) nprint,(g(i), i=1,nprint) write(10,987) nprint,(wd1(i),i=1,nprint) write(10,988) min0(nprint,nind2),nind2,(ind(ind2(i)), + i=1,min0(nprint,nind2)) write(10,989) min0(mlprint,nact),nact,(iact(i), + i=1,min0(mlprint,nact)) if (ittype .eq. 1) then write(10,1004) f,csupn,sqrt(gpeucn2),gpsupn,nind2,n,nact, + ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt, + cgcnt,chcnt else write(10,1002) f,csupn,sqrt(gpeucn2),gpsupn,gzsupn,nind2,n, + nact,ml,spgiter,tniter,ispgiter,triter,fcnt,gcnt,hcnt, + cgcnt,chcnt end if end if C Non-executable statements 973 format(/1X,'Entry to GENLIN. Number of variables: ',I6) 974 format(/1X,'Number of linear constraints: ',I6) 975 format(/1X,'Coefficients of linear constraints (first ', +I6, ' constraints): ') 976 format(/1X, '(first ',I6, ' components): ',/,6(1X,1PD11.4)) 977 format(/1X,'Right-hand side of linear constraints (first ', +I6, ' components): ',/,6(1X,1PD11.4)) 978 format(/1X,'Lower bounds (first ',I6, ' components): ', +/,6(1X,1PD11.4)) 979 format(/1X,'Upper bounds (first ',I6, ' components): ', +/,6(1X,1PD11.4)) 980 format(/1X,'Initial point (first ',I6, ' components): ', +/,6(1X,1PD11.4)) 981 format(/1X,'GENLIN iteration: ',I6,' (Initial point)') 982 format(/1X,'GENLIN iteration: ',I6,' (Final point)') 983 format(/1X,'GENLIN iteration: ',I6,1X,A41) 985 format(1X,'Current point (first ',I6, ' components): ', +/,6(1X,1PD11.4)) 986 format(1X,'Current gradient (first ',I6, ' components): ', +/,6(1X,1PD11.4)) 987 format(1X,'Current discontinuous projected gradient (first ',I6, +' components): ',/,6(1X,1PD11.4)) 988 format(1X,'Current free variables (first ',I6, +', total number ',I6,'): ',/,10(1X,I6)) 989 format(1X,'Current active linear constraints (first ',I6, +', total number ',I6,'): ',/,10(1X,I6)) 991 format(/1X,'Flag of GENLIN = ',I3, +' (convergence with sup-norm of the projected gradient', +/,1X,'smaller than ',1PD11.4,')') 992 format(/1X,'Flag of GENLIN = ',I3, +' (The algorithm stopped by lack of enough progress. This means', +/,1X,'that f(x_k) - f(x_{k+1}) .le. ',1PD11.4, +' * max [ f(x_j)-f(x_{j+1}, j < k ]',/,1X,'during ',I7, +' consecutive iterations)') 994 format(/1X,'Flag of GENLIN = ',I3, +' (The algorithm stopped because the functional value is', +/,1X,'smaller than ',1PD11.4,')') 996 format(/1X,'Flag of GENLIN = ',I3, +' (After having made at least ',I7,' interpolations, the',/, +' line search step became very small)') 997 format(/1X,'Flag of GENLIN = ',I3, +' (It exceeded the maximum allowed number of iterations', +/,1X,'(maxit=',I7,')') 998 format(/1X,'Flag of GENLIN = ',I3, +' (It exceeded the maximum allowed number of functional', +/,1X,'evaluations (maxfc=',I7,')') 1001 format(1X,'Functional value: ', 1PD11.4, +/,1X,'Sup-norm of the linear constraints: ',1PD11.4, +/,1X,'Sup-norm internal gradient: ',1PD11.4, +/,1X,'Free variables at this point: ',I7, +' (over a total of ',I7,')', +/,1X,'Active linear constraints at this point: ',I7, +' (over a total of ',I7,')', +/,1X,'PSPG iterations: ',I7, +/,1X,'TN iterations: ',I7, +/,1X,'inner SPG iterations: ',I7, +/,1X,'Trust-region iterations: ', I7, +/,1X,'Functional evaluations: ',I7, +/,1X,'Gradient evaluations: ',I7, +/,1X,'Hessian evaluations: ',I7, +/,1X,'Conjugate gradient iterations: ',I7, +/,1X,'Cholesky decompositions: ', I7) 1002 format(1X,'Functional value: ', 1PD11.4, +/,1X,'Sup-norm of the linear constraints: ',1PD11.4, +/,1X,'Euclidian-norm of the discontinuous projected gradient: ', +1PD11.4, +/,1X,'Sup-norm of the discontinuous projected gradient: ',1PD11.4, +/,1X,'Sup-norm internal gradient: ',1PD11.4, +/,1X,'Free variables at this point: ',I7, +' (over a total of ',I7,')', +/,1X,'Active linear constraints at this point: ',I7, +' (over a total of ',I7,')', +/,1X,'PSPG iterations: ',I7, +/,1X,'TN iterations: ',I7, +/,1X,'inner SPG iterations: ',I7, +/,1X,'Trust-region iterations: ', I7, +/,1X,'Functional evaluations: ',I7, +/,1X,'Gradient evaluations: ',I7, +/,1X,'Hessian evaluations: ',I7, +/,1X,'Conjugate gradient iterations: ',I7, +/,1X,'Cholesky decompositions: ', I7) 1003 format(1X,'Functional value: ', 1PD11.4, +/,1X,'Sup-norm of the linear constraints: ',1PD11.4, +/,1X,'Free variables at this point: ',I7, +' (over a total of ',I7,')', +/,1X,'Active linear constraints at this point: ',I7, +' (over a total of ',I7,')', +/,1X,'PSPG iterations: ',I7, +/,1X,'TN iterations: ',I7, +/,1X,'inner SPG iterations: ',I7, +/,1X,'Trust-region iterations: ', I7, +/,1X,'Functional evaluations: ',I7, +/,1X,'Gradient evaluations: ',I7, +/,1X,'Hessian evaluations: ',I7, +/,1X,'Conjugate gradient iterations: ',I7, +/,1X,'Cholesky decompositions: ', I7) 1004 format(1X,'Functional value: ', 1PD11.4, +/,1X,'Sup-norm of the linear constraints: ',1PD11.4, +/,1X,'Euclidian-norm of the discontinuous projected gradient: ', +1PD11.4, +/,1X,'Sup-norm of the discontinuous projected gradient: ',1PD11.4, +/,1X,'Free variables at this point: ',I7, +' (over a total of ',I7,')', +/,1X,'Active linear constraints at this point: ',I7, +' (over a total of ',I7,')', +/,1X,'PSPG iterations: ',I7, +/,1X,'TN iterations: ',I7, +/,1X,'inner SPG iterations: ',I7, +/,1X,'Trust-region iterations: ', I7, +/,1X,'Functional evaluations: ',I7, +/,1X,'Gradient evaluations: ',I7, +/,1X,'Hessian evaluations: ',I7, +/,1X,'Conjugate gradient iterations: ',I7, +/,1X,'Cholesky decompositions: ', I7) 1007 format(/1X,'Flag of GENLIN = ',I3, + ' (Problem in projection routine)') 1008 format(/1X,'Flag of GENLIN = ',I3, + ' (Constraint ', I3, ' is inconsistent)') 1009 format(/1X,'Flag of GENLIN = ',I3, + ' (Problem in projection routine. Point is infeasible)') 1010 format(/1X,'Flag of GENLIN = ',I3, + ' (Error in QR decomposition)') 1011 format(/1X,'Flag of GENLIN = ',I3, + ' (The algorithm stopped because the point is infeasible.', + /,1X,'Linear constraint ',I3,' is not satisfied)') 1012 format(/1X,'Flag of GENLIN = ',I3, + ' (The algorithm stopped because a feasible direction ', + ' could not be computed)') 1000 format(/1X,'Flag of GENLIN = ',I3,' Fatal Error') 3000 format(F8.2,1X,I3,1X,I6,1X,I6,1X,I7,1X,I7,1X,I7,1X,I7,1X,I10,1X, + I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X,I10,1X, + I10,1X,I10,1X,1P,D24.16,1X,1P,D7.1,1X,1P,D7.1) end C ****************************************************************** C ****************************************************************** subroutine wfgencan(n, nind, ind, nind2, ind2, x, l, u, ml, mleq, + lda, A, b, f, g, gz, nact, nliact, iact, ldabar, Abar, tau, + iter, xsupn, xeucn2, gotgp, gpsupn, gpeucn2, s, y, ssupn, + seucn, yeucn, sts, sty, gtype, hptype, trtype, precond, + iprint, ncomp, cgepsf, cgepsi, cgscre, acgeps, bcgeps, + delmin, ucgmia, ucgmib, udelta0, epsnqmp, maxitnqmp, theta, + lossfeas, epscsn, macheps, bignum, samefa, lspgmi, lspgma, + etaint, mininterp, fmin, maxfc, gamma, sigma1, sigma2, d, dz, + wi1, wd1, wd2, wd3, wd4, wd5, wd6, wd7, wd8, wd9, wd10, wd11, + wd12, wd13, wd14, ittype, rbdlu, rbdli, rbdind, fcnt, gcnt, + hcnt, cgcnt, tniter, tnfcnt, tnstpcnt, tnintcnt, tnintfe, + inform) C SCALAR ARGUMENTS logical lossfeas, samefa, gotgp character * 6 precond, aptype integer n, nind, nind2, ml, mleq, lda, nact, nliact, ldabar, iter, + gtype, hptype, trtype, iprint, ncomp, cgscre, maxitnqmp, + mininterp, maxfc, ittype, rbdlu, rbdli, fcnt, gcnt, hcnt, + cgcnt, tniter, tnfcnt, tnstpcnt, tnintcnt, tnintfe, inform double precision f, xsupn, xeucn2, gpsupn, gpeucn2, ssupn, seucn, + yeucn, sts, sty, cgepsf, cgepsi, acgeps, bcgeps, delmin, + ucgmia, ucgmib, udelta0, epsnqmp, theta, epscsn, macheps, + bignum, lspgmi, lspgma, etaint, fmin, gamma, sigma1, sigma2 C ARRAY ARGUMENTS integer ind(nind), ind2(nind), iact(ml), rbdind(n+ml), wi1(2*n+ml) double precision x(n), l(n), u(n), A(lda,n), b(ml), g(n), + gz(nind-nliact), Abar(ldabar,nliact), tau(nliact), s(n), + y(n), d(n), dz(nind-nliact), wd1(n), wd2(n), wd3(n), wd4(n), + wd5(n), wd6(n), wd7(n), wd8(n), wd9(n), wd10(n), wd11(n), + wd12(n), wd13(n), wd14(ml) C Solves the "unconstrained" minimization subproblem C C Minimize f(x) C C using a method described in C C E. G. Birgin and J. M. Martinez, ''Large-scale active-set box- C constrained optimization method with spectral projected C gradients'', Computational Optimization and Applications 23, pp. C 101-125, 2002. C C Description of WFGENCAN arguments: C C On Entry C C n integer C number of variables C C nind integer C dimension of reduced space C C ind integer ind(nind) C indices of free variables, including bounds that were C added to the active set and treated as linear constraints C to update the basis of the null space of the linear C constraints C C nind2 integer C dimension of reduced space C C ind2 integer ind2(nind2) C indices of the truely free variables C C x double precision x(n) C initial estimation of the solution C C l double precision l(n) C lower bounds on the variables C C u double precision u(n) C upper bounds on the variables C C ml integer C total number of linear constraints (excluding bounds) C C mleq integer C number of linear equality constraints (excluding bounds) C C lda integer C leading dimension of matrix A C C A double precision A(lda,n) C coeficients of linear constraints C C b double precision b(ml) C constant part of linear constraints C C f double precision C function value at x C C g double precision g(n) C gradient at x C C gz double precision gz(nind-nliact) C reduced gradient at x (Z^T g) C C nact integer C number of active linear constraints C C nliact integer C number of linearly independent active linear C constraints C C iact integer iact(ml) C indices of the active linear constraints. The last C m - nact positions of iact store the identifier of the C non-active linear constraints. C C ldabar integer C leading dimension of matrix Abar C C Abar double precision Abar(ldabar,nliact) C hold the LQ factorization of the matrix whose columns C correspond to the active linear constraints, after C eliminating the elements correnponding to fixed variables C C tau double precision tau(nliact) C used to retrieve the columns of Q from Abar C C iter integer C current linearly-constrained minimization iteration C C xsupn double precision C x infinity norm C C xeucn2 double precision C squared x Euclidian norm C C gotgp logical C true iff projected gradient at x was calculated C C gpsupn double precision C sup-norm of the continuous projected gradient at the C final estimation C C gpeucn2 double precision C squared euclidian-norm of the continuous projected C gradient at the final estimation C C s double precision s(n) C diference between x and initial point from previous C iteration C C y double precision y(n) C diference between g and the grandient of the initial C point from previous iteration C C ssupn double precision C s infinity norm C C seucn double precision C s Euclidian norm C C yeucn double precision C s Euclidian norm C C sts double precision C scalar product between s and s C C sty double precision C scalar product between s and y C C gtype integer C gtype indicates in which way the gradient of the C objective function will be computed. See the detailed C description of this parameter in subroutine param. C C RECOMMENDED: gtype = 0 C C CONSTRAINTS: allowed values are just 0 or 1. C C hptype integer C hptype indicates in which way the Hessian (or the matrix- C vector product) will be approximated. See the detailed C description of this parameter in subroutine param. C C RECOMMENDED: hptype = 0 C C CONSTRAINTS: any value from 0 to 6 and 9. C C trtype integer C Type of Conjugate Gradients ''trust-radius''. trtype C equal to 0 means Euclidian-norm trust-radius and trtype C equal to 1 means sup-norm trust radius C C RECOMMENDED: trtype = 0 C C CONSTRAINTS: allowed values are just 0 or 1. C C precond character * 6 C indicates the type of preconditioning that will be used C for Conjugates Gradients. C C 'NONE' means no preconditioner at all, C C 'QNCGNA' means Quasi-Newton Correction of the Gauss- C Newton approximation of the Hessian. The exact C form is this preconditioner is described in: C C E. G. Birgin and J. M. Martínez, "Structured C minimal-memory inexact quasi-Newton method and C secant preconditioners for Augmented Lagrangian C Optimization", Computational Optimization and C Applications, 39, pp, 1-16, 2008. C C iprint integer C Commands printing. Nothing is printed if iprint is C smaller than 2. If iprint is greater than or equal to C 2, WFGENCAN iterations information is printed. If C iprint is greater than or equal to 3, line searches C and Conjugate Gradients information is printed. C C RECOMMENDED: iprint = 2 C C CONSTRAINTS: allowed values are just 2 or 3. C C ncomp integer C This constant is just for printing. In a detailed C printing option, ncomp components of some vectors will C be printed C C RECOMMENDED: ncomp = 5 C C CONSTRAINTS: ncomp >= 0 C C cgepsf double precision C See below C C cgepsi double precision C small positive numbers for declaring convergence of the C Conjugate Gradients subalgorithm when ||r||_2 < cgeps * C ||rhs||_2, where r is the residual and rhs is the right C hand side of the linear system, i.e., CG stops when the C relative error of the solution is smaller than cgeps. C C cgeps varies from cgepsi to cgepsf in a way that depends C on cgscre as follows: C C i) CASE cgscre = 1: log10(cgeps^2) depends linearly on C log10(||g_P(x)||_2^2) which varies from ||g_P(x_0)||_2^2 C to epsgpen^2 C C ii) CASE cgscre = 2: log10(cgeps) depends linearly on C log10(||g_P(x)||_inf) which varies from ||g_P(x_0)||_inf C to epsgpsn C C RECOMMENDED: cgepsi = 1.0d-01, cgepsf = 1.0d-05 C C CONSTRAINTS: cgepsi >= cgepsf >= 0.0 C C cgscre integer C cgscre means conjugate gradient stopping criterion C relation. It is related to a stopping criterion of C Conjugate Gradients. This stopping criterion depends on C the norm of the residual of the linear system. The norm C of the residual should be less or equal than a ''small'' C quantity which decreases as we are approximating the C solution of the minimization problem (near the solution, C better the truncated-Newton direction we aim). Then, the C log of the required accuracy requested to Conjugate C Gradient has a linear dependence on the log of the norm C of the projected gradient. This linear relation uses the C squared Euclidian norm of the projected gradient if C cgscre is equal to 1 and uses the sup-norm if cgscre is C equal to 2. C C RECOMMENDED: cgscre = 2 C C CONSTRAINTS: allowed values for cgscre are just 1 or 2 C C acgeps double precision C see below C C bcgeps double precision C used to introduce linear relation between gpeucn2 and C cgeps2, i.e., scalars acgeps and bcgeps such that C C acgeps*log10(||g_P(x_0)||_2^2) + bcgeps = log10(cgeps_0^2) C C acgeps*log10(||g_P(x_f)||_2^2) + bcgeps = log10(cgeps_f^2), C C where cgeps_0 and cgeps_f are provided C C delmin double precision C Smaller Conjugate Gradients ''trust radius'' to compute C the Truncated Newton direction C C RECOMMENDED: delmin = 0.1 C C CONSTRAINTS: delmin > 0.0 C C ucgmia double precision C see below C C ucgmib double precision C the maximum allowed number of iterations for each run of C the Conjugate Gradient subalgorithm will be C C max( 1, int( ucgmia * nind + ucgmib ) ), C C where nind is the number of variables of the subproblem. C C The default value for this maximum number of CG iterations C is a linear function of the projected gradient sup-norm. C It goes from max( 1, 10 * log( nind ) ) when the method is C far from the solution to nind when the method is near to C the solution, where nind is the number of variables of the C subproblem (equal to the number of free variables). C C The default value will be used if the user sets ucgmia or C ucgmib to any non-positive value. C C RECOMMENDED: ucgmia = - 1 and ucgmib = - 1 C C CONSTRAINTS: there are no constraints for this argument C C udelta0 double precision C initial ''trust-radius'' for Conjugate Gradients. The C default value max( delmin, 0.1 * max( 1, ||x|| ) ) is C used if the user sets udelta0 <= 0. C C RECOMMENDED: udelta0 = - 1.0 C C CONSTRAINTS: there are no constraints for this argument C C epsnqmp double precision C See below C C maxitnqmp integer C This and the previous argument are used for a stopping C criterion of the Conjugate Gradients subalgorithm. If the C progress in the quadratic model is smaller than fraction C of the best progress ( epsnqmp * bestprog ) during C maxitnqmp consecutive iterations then CG is stopped C declaring ''not enough progress of the quadratic model''. C C RECOMMENDED: epsnqmp = 1.0d-04, maxitnqmp = 5 C C CONSTRAINTS: epsnqmp >= 0.0, maxitnqmp >= 1. C C theta double precision C Constant for the angle condition, i.e., at iteration k we C need a direction dk such that <= - theta C ||gk||_2 ||dk||_2, where gk is \nabla f(xk) C C RECOMMENDED: theta = 10^{-6} C C CONSTRAINTS: 0.0 < theta < 1.0 C C lossfeas logical C if a loss of feasibility up to sqrt(epsfeas) is allowed C during the computations, lossfeas must be set to TRUE C (recommended). In this case, if the final iterate does C not satisfy the constraints with the desired precision, C we sugest that the user re-run the method using the final C point obtained as the initial point, using C lossfeas = FALSE C C RECOMMENDED: lossfeas = TRUE C C epscsn double precision C feasibility tolerance for the sup-norm of the linear C constraints C C RECOMMENDED: epscsn = 10^{-8} C C CONSTRAINTS: epscsn > 0.0 C C macheps double precision C macheps is the smallest positive number such that C 1 + macheps is not equal to 1 C C bignum double precision C a big number, like 10^{99} C C samefa logical C true iff current point is in the same face as the C previous one C C lspgmi double precision C See below C C lspgma double precision C The spectral steplength, called lamspg, is projected onto C the box [lspgmi,lspgma] C C RECOMMENDED: lspgmi = 1.0d-10 and lspgma = 1.0d+10 C C CONSTRAINTS: lspgma >= lspgmi > 0.0 C C etaint double precision C Constant for the interpolation. See the description of C sigma1 and sigma2 above. Sometimes, in a line search, we C take the new trial step as the previous one divided by C etaint C C RECOMMENDED: etaint = 2.0 C C CONSTRAINTS: etaint > 1.0. C C mininterp integer C Constant for testing if, after having made at least C mininterp interpolations, the steplength is too small. In C that case, failure of the line search is declared (may be C the direction is not a descent direction due to an error C in the gradient calculations). Use mininterp greater C than or equal to maxfc for inhibit this stopping C criterion C C RECOMMENDED: mininterp = 4 C C CONSTRAINTS: mininterp >= 1 C C fmin double precision C function value for the stopping criteria f <= fmin C C There is a stopping criterion that stops WFGENCAN if a C point with a functional value smaller than fmin is found. C The idea behind this stopping criterion is to stop the C method if the objective function is not bounded from C bellow. C C RECOMMENDED: fmin = - bignum C C CONSTRAINTS: there are no constraints for this argument C C maxfc integer C maximum allowed number of functional evaluations C C RECOMMENDED: maxfc = 5 * maxit C C CONSTRAINTS: maxfc >= 1 C C C gamma double precision C Constant for the Armijo criterion C f(x + alpha d) <= f(x) + gamma * alpha * C C RECOMMENDED: gamma = 1.0d-04 C C CONSTRAINTS: 0.0 < gamma < 0.5. C C sigma1 double precision C See below C C sigma2 double precision C Constant for the safeguarded interpolation. If alpha_new C is not inside the interval [sigma1, sigma * alpha] then C we take alpha_new = alpha / etaint C C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 C C CONSTRAINTS: 0 < sigma1 < sigma2 < 1. C C d double precision d(n) C dz double precision dz(nind-nliact) C wd1,...,wd13 double precision wd1,..,wd13(n) C wd14 double precision wd14(ml) C working vectors C C On Return C C x double precision x(n) C final estimation to the solution within the face C C f double precision C function value at the final estimation C C g double precision g(n) C gradient at the final estimation C C ittype integer C iteration type. Set to 2-6 to mean truncated-Newton C C rbdlu integer C number of variables that reached a lower or upper C bound C C rbdli integer C total number of new active constraints. rbdli-rbdlu C is the number of linear constraints that are now C satisfied by equality C C rbdind integer rbdind(n+ml) C indices of bound and linear constraints that are C satisfied by equality at the new point x. That is, C indices of the constraints to be added to the active set) C C fcnt integer C number of function evaluations C C gcnt integer C number of gradient evaluations C C hcnt integer C number of hessian evaluations C C cgcnt integer C number of Conjugate Gradients iterations C C tniter integer C number of Truncated-Newton iterations C C tnfcnt integer C number of functional evaluations along Truncated-Newton C directions C C tnstpcnt integer C number of times the Newton point was accepted (without C interpolations nor extrapolations) C C tnintcnt integer C number of times a backtracking in a Truncated-Newton C direction was needed C C tnintfe integer C number of functional evaluations used in interpolations C along Truncated-Newton directions C C inform integer C This output parameter tells what happened in this C subroutine, according to the following conventions: C C 0 = convergence with an Armijo-like criterion C (f(xnew) <= f(x) + 1.0d-4 * alpha * ); C C 3 = new point x is in the boundary of the current face; C C 4 = the algorithm stopped because the functional value C is very small (smaller than fmin). If desired, set C fmin equal to minus bignum to inhibit this stopping C criterion; C C 6 = too small step in a line search. After having made at C least mininterp interpolations, the steplength C becames small. ''small steplength'' means that we are C at point x with direction d and step alpha, such that C C | alpha * d(i) | <= macheps * max( | x(i) |, 1 ) C C for all i. C C In that case failure of the line search is declared C (may be the direction is not a descent direction due C to an error in the gradient calculations). If C desired, set mininterp equal to maxfc to inhibit this C stopping criterion; C C 8 = it was achieved the maximum allowed number of C function evaluations (maxfc); C C 10 = new point x+alpha*d would be infeasible, so x is C returned; C C -90 = means that subroutine evalf retuned an error flag; C C -92 = means that subroutine evalg retuned an error flag; C C -94 = means that subroutine evalh retuned an error flag. C LOCAL SCALARS integer i, ii, j, jj, jjj, cgmaxit, cgiter, tnintprev, fcntprev double precision delta, amax, amaxx, cgeps, ax, ad if (iprint .ge. 3) then write(*, 990) write(10,990) end if tniter = tniter + 1 C Compute trust-region radius if (iter .eq. 1) then if (udelta0 .le. 0.0d0) then if (trtype .eq. 0) then delta = max(delmin, 0.1d0 * max(1.0d0, sqrt(xeucn2))) else ! if (trtype .eq. 1) then delta = max(delmin, 0.1d0 * max(1.0d0, xsupn)) end if else delta = max(delmin, udelta0) end if else if (trtype .eq. 0) then delta = max(delmin, 10.0d0 * sqrt(sts)) else ! if (trtype .eq. 1) then delta = max(delmin, 10.0d0 * ssupn) end if end if C Compute the descent direction solving the newtonian system by C conjugate gradients C Set conjugate gradient stopping criteria. Default values are C taken if you set ucgeps < 0 or ucgmia < 0 or ucgmib < 0. C Otherwise, the parameters cgeps and cgmaxit will be the ones C set by the user. if (ucgmia .lt. 0.0d0 .or. ucgmib .lt. 0.0d0) then c if ( cgscre .eq. 1 ) then c kappa = log10( gpeucn2 / gpeucn20 )/ c + log10( epsgpen2 / gpeucn20 ) c else ! if ( cgscre .eq. 2 ) then c kappa= log10( gpsupn / gpsupn0 ) / c + log10( epsgpsn / gpsupn0 ) c end if c kappa = max( 0.0d0, min( 1.0d0, kappa ) ) c cgmaxit = int( ( 1.0d0 - kappa ) * max( 1.0d0, c + min( dfloat( nind ), 10.0d0 * c + log10( dfloat( nind ) ) ) ) + kappa * dfloat( nind ) ) cgmaxit = max(1, min(2 * nind, 10000)) else cgmaxit = max(1, int(ucgmia * nind + ucgmib)) end if if (gotgp) then if (cgscre .eq. 1) then cgeps = sqrt(10.0d0 ** (acgeps * log10(gpeucn2) + bcgeps)) else ! if (cgscre .eq. 2) then cgeps = 10.0d0 ** (acgeps * log10(gpsupn) + bcgeps) end if cgeps = max(cgepsf, min(cgepsi, cgeps)) else cgeps = cgepsf end if C Call conjugate gradients call cgm(nind, ind, nind2, ind2, n, x, ml, mleq, lda, A, b, nact, + nliact, iact, ldabar, Abar, tau, g, gz, delta, l, u, cgeps, + epsnqmp, maxitnqmp, cgmaxit, gtype, hptype, trtype, precond, + samefa, aptype, s, y, seucn, yeucn, sts, sty, lspgmi, lspgma, + iprint, ncomp, dz, wd1, d, wd2, wd3, wd4, wd5, cgiter, rbdlu, + rbdli, rbdind, wi1, inform, wd6, wd7, wd8, wd9, wd10, wd11, + wd12, wd13, theta, macheps, bignum) hcnt = hcnt + 1 cgcnt = cgcnt + cgiter if (inform .lt. 0) then if (iprint .ge. 2) then write(*, 1000) inform write(10,1000) inform end if return end if C Set iteration type if (aptype .eq. 'TRUEHE') then ittype = 2 else if (aptype .eq. 'HLPROD') then ittype = 3 else if (aptype .eq. 'QNCGNA') then ittype = 4 else if (aptype .eq. 'INCQUO') then ittype = 5 else if (aptype .eq. 'PUREIQ') then ittype = 6 end if C Compute maximum step. If maximum step is taken, rbdlu variables C will reach lower or upper bound and rbdli - rbdlu linear C constraints will be active. Vector rbdind store in positions 1 C to rbdlu the indices of variables that will be reach the lower C bound and n + index of variables that will reach upper bound C if maximum step is taken; in position rbdlu + 1 to rbdli the C indices of linear constraints that will be active if maximum C step is taken if (inform .eq. 2) then amax = 1.0d0 else amax = bignum rbdlu = 0 do i = 1, nind2 ii = ind2(i) if (d(ii) .gt. 0.0d0) then amaxx = (u(ii) - x(ii)) / d(ii) if (amaxx .lt. amax - macheps * max(amax, 1.0d0)) then amax = amaxx rbdlu = 1 rbdind(rbdlu) = n + ii else if (amaxx .le. amax + macheps * max(amax, 1.0d0)) then rbdlu = rbdlu + 1 rbdind(rbdlu) = n + ii end if end if else if (d(ii) .lt. 0.0d0) then amaxx = (l(ii) - x(ii)) / d(ii) if (amaxx .lt. amax - macheps * max(amax, 1.0d0)) then amax = amaxx rbdlu = 1 rbdind(rbdlu) = ii else if (amaxx .le. amax + macheps * max(amax, 1.0d0)) then rbdlu = rbdlu + 1 rbdind(rbdlu) = ii end if end if end if end do C Look to the linear inequality constraints rbdli = rbdlu call expand(nind, ind, n, x) do i = nact+1, ml ii = iact(i) ad = 0.0d0 do j = 1, nind2 jj = ind2(j) jjj = ind(jj) ad = ad + A(ii,jjj) * d(jj) end do if (ad .lt. 0.0d0) then ax = 0.0d0 do j = 1, n ax = ax + A(ii,j) * x(j) end do amaxx = (b(ii) - ax) / ad if (amaxx .lt. amax - macheps * max(amax, 1.0d0)) then amax = amaxx rbdlu = 0 rbdli = 1 rbdind(rbdli) = i else if (amaxx .le. amax + macheps * max(amax, 1.0d0)) then rbdli = rbdli + 1 rbdind(rbdli) = i end if end if end if end do call shrink(nind, ind, n, x) end if C Perform the line search tnintprev = tnintcnt fcntprev = fcnt call tnls(nind, ind, nind2, ind2, n, x, ml, mleq, lda, A, b, l, u, + f, g, d, amax, nact, iact, rbdlu, rbdli, rbdind, etaint, + mininterp, fmin, maxfc, gtype, iprint, fcnt, gcnt, tnintcnt, + inform, wd1, wd14, gamma, sigma1, sigma2, lossfeas, epscsn, + macheps) if (inform .lt. 0) then if (iprint .ge. 2) then write(*, 1000) inform write(10,1000) inform end if return end if if (tnintcnt .gt. tnintprev) then tnintfe = tnintfe + (fcnt - fcntprev) else tnstpcnt = tnstpcnt + 1 end if tnfcnt = tnfcnt + (fcnt - fcntprev) 990 format(/,6x,'inner GENCAN iteration') 1000 format(/6X,'Flag of inner GENCAN = ',I3,' Fatal Error') end C ****************************************************************** C ****************************************************************** subroutine cgm(nind,ind,nind2,ind2,n,x,ml,mleq,lda,A,b,nact, +nliact,iact,ldabar,Abar,tau,g,gz,delta,l,u,eps,epsnqmp,maxitnqmp, +maxit,gtype,hptype,trtype,precond,samefa,aptype,s,y,seucn,yeucn, +sts,sty,lspgmi,lspgma,iprint,ncomp,d,dprev,zd,zdprev,zp,wd1,wd2, +iter,rbdlu,rbdli,rbdind,rbdposaind,inform,p,hp,r,z,pdiag,psmdy, +hds,wdn1,theta,macheps,bignum) implicit none C SCALAR ARGUMENTS logical samefa character * 6 aptype,precond integer gtype,hptype,inform,iprint,iter,ml,mleq,lda,maxit, + maxitnqmp,n,ncomp,nind,nind2,trtype,rbdlu,rbdli,nact, + nliact,ldabar double precision bignum,delta,eps,epsnqmp,lspgma,lspgmi,macheps, + seucn,sts,sty,theta,yeucn C ARRAY ARGUMENTS integer ind(nind),ind2(nind),iact(ml),rbdind(n+ml), + rbdposaind(n+ml) double precision d(n),g(n),gz(nind-nliact),hds(n),hp(n),l(n), + p(n),pdiag(n),psmdy(n),r(n),s(n),u(n),wdn1(n),x(n),y(n), + z(n),A(lda,n),b(ml),wd1(n),wd2(n),zp(n),dprev(n), + zdprev(n),zd(n),tau(nliact),Abar(ldabar,nliact) C This subroutine implements the Conjugate Gradients method for C minimizing the quadratic approximation q(d) of L(x,lambda,rho) C at x C C q(d) = 1/2 d^T H d + g^T d, C C where H is an approximation of the reduced Hessian matrix of the C objective function and g is its reduced gradient vector, C C subject to || d || <= delta and l <= x + d <= u. C C In the constraint ''|| d || <= delta'', the norm will be the C Euclidian-norm if the input parameter trtype is equal to 0, and C it will be the sup-norm if trtype is equal to 1. C C The method returns an approximation d of the solution such that C C (a) ||H d + g||_2 <= eps * ||g||_2, C C (b) ||d|| = delta or x + d is in the boundary of the feasible C set, or C C (c) ( p such that p^t H p = 0 ) and ( d = - amax g if such p was C found during the first CG iteration or the current point d C of CG if such p was found in any other iteration ). C C On Entry C C nind integer C number of free variables C C ind integer ind(n) C array which contains, in the first nind positions, the C identifiers of the free variables C C nind2 integer C number of truely free variables C C ind2 integer ind2(n) C array which contains, in the first nind2 positions, the C identifiers of the truely free variables C C n integer C dimension of the full space C C x double precision x(n) C point at which function L is being approximated by the C quadratic model C C The first nind positions of x contains the free variables C x_ind(1), x_ind(2), ..., x_ind(nind). C C ml integer C total number of linear constraints (excluding bounds) C C mleq integer C number of linear equality constraints (excluding bounds) C C lda integer C leading dimension of matrix A C C A double precision A(lda,n) C coeficients of linear constraints C C b double precision b(ml) C constant part of linear constraints C C nact integer C number of active linear constraints C C nliact integer C number of linearly independent active linear C constraints (nind-nliact is the dimension in C which this subroutine will work) C C iact integer iact(ml) C indices of the active linear constraints. The last C m - nact positions of iact store the identifier of the C non-active linear constraints. C C ldabar integer C leading dimension of matrix Abar C C Abar double precision Abar(ldabar,nliact) C hold the LQ factorization of the matrix whose columns C correspond to the active linear constraints, after C eliminating the elements correnponding to fixed variables C C tau double precision tau(nliact) C used to retrieve the columns of Q from Abar C C g double precision g(n) C linear coefficient of the quadratic function before C the multiplication by Z^T C C gz double precision gz(nind-nliact) C This is \nabla L(x) and it also contains in the first C nind positions the components g_ind(1), g_ind(2), ..., C g_ind(nind) times Z^T. C C IMPORTANT: the linear algebra of this subroutine lies in C a space of dimension nind-nliact. The value of the full C dimension n, the non-free variables (which are at the end C of array x) and its gradient components (which are at the C and of array g) are, at this moment, being used to C approximate the Hessian times vector products by C incremental quotients. C C delta double precision C "trust region radius" ( ||d|| <= delta ) C C l double precision l(n) C lower bounds on x + d. Its components are ordered in the C same way as x and g. C C u double precision u(n) C upper bounds on x + d. Its components are ordered in the C same way as x, g and l. C C eps double precision C tolerance for the stopping criterion ||H d + g||_2 < eps C * ||g||_2 C C epsnqmp double precision C See below C C maxitnqmp integer C This and the previous parameter are used for a stopping C criterion of the conjugate gradient subalgorithm. If the C progress in the quadratic model is less than or equal to C a fraction of the best progress ( epsnqmp * bestprog ) C during maxitnqmp consecutive iterations then CG stops by C not enough progress of the quadratic model. C C RECOMMENDED: epsnqmp = 1.0d-4, maxitnqmp = 5 C C maxit integer C maximum number of iterations. C C RECOMMENDED: maxit = nind C C gtype integer C type of gradient calculation C gtype = 0 means user suplied evalng subroutine, C gtype = 1 means central difference approximation. C C RECOMMENDED: gtype = 0 C C (provided you have the evalg subroutine) C C hptype integer C Type of Hessian-vector product calculation. See the C detailed explanation in the genlin parameters C description. C C RECOMMENDED: hptype = 0 C C trtype integer C type of "trust region" C trtype = 0 means Euclidian-norm trust-region C trtype = 1 means sup-norm trust-region C C RECOMMENDED: trtype = 0 C C precond character * 6 C indicates the type of preconditioning that will be used C for Conjugates Gradients. C C 'NONE' means no preconditioner at all, C C 'QNCGNA' means Quasi-Newton Correction of the Gauss- C Newton approximation of the Hessian. The exact C form is this preconditioner is described in: C C E. G. Birgin and J. M. Martínez, "Structured C minimal-memory inexact quasi-Newton method and C secant preconditioners for Augmented Lagrangian C Optimization", Computational Optimization and C Applications, 39, pp, 1-16, 2008. C C samefa logical C true iff current point is in the same face as the C previous one C C s double precision s(n) C diference between x and initial point from previous C iteration C C y double precision y(n) C diference between g and the grandient of the initial C point from previous iteration C C seucn double precision C s Euclidian norm C C yeucn double precision C s Euclidian norm C C sts double precision C scalar product between s and s C C sty double precision C scalar product between s and y C C lspgmi double precision C See below C C lspgma double precision C The spectral steplength, called lamspg, is projected onto C the box [lspgmi,lspgma] C C RECOMMENDED: lspgmi = 1.0d-10 and lspgma = 1.0d+10 C C CONSTRAINTS: lspgma >= lspgmi > 0.0 C C iprint integer C Commands printing. Nothing is printed if iprint is C smaller than 2. If iprint is greater than or equal to C 2, WFGENCAN iterations information is printed. If iprint C is greater than or equal to 3, line searches and C Conjugate Gradients information is printed. C C RECOMMENDED: iprint = 2 C C CONSTRAINTS: allowed values are just 2 or 3. C C ncomp integer C This constant is just for printing. In a detailed C printing option, ncomp component of some vectors will be C printed C C RECOMMENDED: ncomp = 5 C C CONSTRAINTS: ncomp >= 0 C C d,dprev,zp,wd1,wd2,p,hp,r,z,pdiag,psmdy,hds,wdn1 C double precision d,dprev,zp,wd1,wd2,p,hp,r,z,pdiag,psmdy, C hds,wdn1(n) C n-dimensional working vectors of doubles C C zdprev double precision zdprev(nind-nliact) C (nind-nliact)-dimensional working vectors of doubles C C rbsposaind integer rbdposaind(n+ml) C working vector of integers C C theta double precision C constant for the angle condition, i.e., at iteration k we C need a direction pk such that C C <= - theta ||gk||_2 ||pk||_2, C C where gk is \nabla L(xk) C C RECOMMENDED: theta = 10^{-6} C C macheps double precision C macheps is the smallest positive number such that C 1 + macheps is not equal to 1 C C bignum double precision C a big number, like 10^{99} C C On Return C C aptype character * 6 C type of matrix-vector product and preconditioner used C C zd double precision d(nind-nliact) C final estimation of the solution C C iter integer C number of Conjugate Gradient iterations performed C C rbdlu integer C number of variables that reached a lower or upper C bound C C rbdli integer C total number of new active constraints. rbdli-rbdlu C is the number of linear constraints that are now C satisfied by equality C C rbdind integer rbdind(n+ml) C indices of bound and linear constraints that are C satisfied by equality at the new point x. That is, C indices of the constraints to be added to the active set) C C inform integer C termination parameter: C C 0 = convergence with ||H d + g||_2 <= eps * ||g||_2; C C 1 = convergence to the boundary of ||d|| <= delta; C C 2 = convergence to the boundary of l <= x + d <= u; C C 3 = stopping with d = dk such that <= - theta C ||gk||_2 ||dk||_2 and > - theta C ||gk||_2 ||d_{k+1}||_2; C C 4 = not enough progress of the quadratic model during C maxitnqmp iterations, i.e., during maxitnqmp C iterations | q - qprev | <= macheps * max( | q |, 1 ) C C 6 = very similar consecutive iterates, for two C consecutive iterates x1 and x2 we have that C C | x2(i) - x1(i) | <= macheps * max ( | x1(i) |, 1 ) C C for all i. C C 7 = stopping with p such that p^T H p = 0 and g^T p = 0; C C 8 = too many iterations; C C < 0 = error in evalhessp subroutine. C LOCAL SCALARS character * 4 cgtype character * 6 rbdtypea character * 6 prectmp logical goth,gotp,negcur,restarted,samep integer i,ii,j,jj,itertmp,itnqmp,nred,rbdposalu, rbdposali double precision aa,alpha,amax,amax1,amax2,amax2x,bb,bestprog, + beta,cc,currprog,dd,dnorm2,gznorm2,gtd,gtp,hlspg,hstds, + norm2s,pnorm2,plspg,psmdyty,ptd,pthp,ptr,q,qprev,rnorm2, + ztrprev,ztr,znorm2,ax,azd,azp C ================================================================== C Initialization C ================================================================== restarted = .false. 001 continue goth = .false. gotp = .false. nred = nind - nliact gznorm2 = norm2s(nred,gz) iter = 0 itnqmp = 0 qprev = bignum bestprog = 0.0d0 do i = 1,nred d(i) = 0.0d0 r(i) = gz(i) end do do i = 1,nind zd(i) = 0.0d0 zdprev(i) = 0.0d0 end do q = 0.0d0 gtd = 0.0d0 dnorm2 = 0.0d0 rnorm2 = gznorm2 ztr = 0.0d0 C ================================================================== C Print initial information C ================================================================== if ( iprint .ge. 3 ) then if ( precond .eq. 'NONE' ) then cgtype = ' ' else cgtype = 'PREC' end if write(*, 980) cgtype,maxit,eps if ( trtype .eq. 0 ) then write(*, 981) delta else if ( trtype .eq. 1 ) then write(*, 982) delta else write(*, 983) end if write(*, 984) iter,sqrt(rnorm2),sqrt(dnorm2),q write(10,980) cgtype,maxit,eps if ( trtype .eq. 0 ) then write(10,981) delta else if ( trtype .eq. 1 ) then write(10,982) delta else write(10,983) end if write(10,984) iter,sqrt(rnorm2),sqrt(dnorm2),q end if C ================================================================== C Main loop C ================================================================== 100 continue C ================================================================== C Test stopping criteria C ================================================================== C if ||r||_2 = ||H d + g||_2 <= eps * ||g||_2 then stop if ( iter .ne. 0 .and. + ( ( rnorm2 .le. eps ** 2 * gznorm2 .and. iter .ge. 4 ) .or. + ( rnorm2 .le. 1.0d-16 ) ) ) then inform = 0 if ( iprint .ge. 3 ) then write(*, 990) inform write(10,990) inform end if go to 500 end if C if the maximum number of iterations was achieved then stop if ( iter .ge. max(4, maxit) ) then inform = 8 if ( iprint .ge. 3 ) then write(*, 998) inform write(10,998) inform end if go to 500 end if C ================================================================== C Preconditioner C ================================================================== if ( precond .eq. 'NONE' ) then do i = 1,nred z(i) = r(i) end do ztrprev = ztr ztr = rnorm2 znorm2 = rnorm2 else if ( precond .eq. 'QNCGNA' ) then call calcpz(nind,ind,n,r,s,y,seucn,yeucn,sts,sty,lspgmi, + lspgma,samefa,gotp,pdiag,plspg,psmdy,psmdyty,z) ztrprev = ztr ztr = 0.0d0 do i = 1,nred ztr = ztr + z(i) * r(i) end do znorm2 = norm2s(nred,z) end if C ================================================================== C Compute direction C ================================================================== if ( iter .eq. 0 ) then do i = 1,nred p(i) = - z(i) end do ptr = - ztr pnorm2 = znorm2 else beta = ztr / ztrprev do i = 1,nred p(i) = - z(i) + beta * p(i) end do if ( precond .eq. 'NONE' ) then pnorm2 = rnorm2 - 2.0d0 * beta * ( ptr + alpha * pthp ) + + beta ** 2 * pnorm2 ptr = - rnorm2 + beta * ( ptr + alpha * pthp ) else if ( precond .eq. 'QNCGNA' ) then ptr = 0.0d0 pnorm2 = 0.0d0 do i = 1,nred ptr = ptr + p(i) * r(i) pnorm2 = pnorm2 + p(i) ** 2 end do end if end if C Force p to be a descent direction of q(d), i.e., C <\nabla q(d), p> = = \le 0. if ( ptr .gt. 0.0d0 ) then do i = 1,nred p(i) = - p(i) end do ptr = - ptr end if C ================================================================== C Compute p^T Z^T H Z p C ================================================================== C zp = Z p call multZ(nind, nliact, ldabar, Abar, tau, p, zp, macheps) C wd1 = H zp = H Z p call calchessp(nind,ind,x,zp,g,n,x,s,y,seucn,yeucn,sts,sty,lspgmi, +lspgma,samefa,gtype,hptype,aptype,wd1,wdn1,macheps,inform,goth, +hlspg,hds,hstds) if ( inform .lt. 0 ) then if ( iprint .ge. 3 ) then write(*, 1000) inform write(10,1000) inform end if return end if C hp = Z^T wd1 = Z^T H zp = Z^T H Z p call multZT(nind, nliact, ldabar, Abar, tau, wd1, wd2, hp, + macheps) C Compute p^T hp = p^T Z^T wd1 = p^T Z^T H Z p pthp = 0.0d0 do i = 1,nred pthp = pthp + p(i) * hp(i) end do C ================================================================== C Compute maximum steps C ================================================================== C amax1 is the value of alpha such that ||d + alpha * p||_2 or C ||d + alpha * p||_\infty = delta ptd = 0.0d0 do i = 1,nred ptd = ptd + p(i) * d(i) end do C Euclidian-norm trust radius if ( trtype .eq. 0 ) then aa = pnorm2 bb = 2.0d0 * ptd cc = dnorm2 - delta ** 2 dd = sqrt( bb ** 2 - 4.0d0 * aa * cc ) amax1 = ( - bb + dd ) / ( 2.0d0 * aa ) else if ( trtype .eq. 1 ) then amax1 = bignum do i = 1,nred if ( p(i) .gt. 0.0d0 ) then amax1 = min( amax1, ( delta - d(i) ) / p(i) ) else if ( p(i) .lt. 0.0d0 ) then amax1 = min( amax1, ( - delta - d(i) ) / p(i) ) end if end do end if C amax2 is the maximum values of alpha such that C l <= x + d + alpha * p <= u amax2 = bignum rbdposalu = 0 do i = 1, nind2 ii = ind2(i) if (zp(ii) .gt. 0.0d0) then amax2x = (u(ii) - x(ii) - zd(ii)) / zp(ii) if (amax2x .lt. amax2 - macheps * max(amax2, 1.0d0)) then amax2 = amax2x rbdposalu = 1 rbdposaind(rbdposalu) = ii + n else if (amax2x .le. amax2+macheps * max(amax2, 1.0d0)) then rbdposalu = rbdposalu + 1 rbdposaind(rbdposalu) = ii + n end if else if (zp(ii) .lt. 0.0d0) then amax2x = (l(ii) - x(ii) - zd(ii)) / zp(ii) if (amax2x .lt. amax2 - macheps * max(amax2, 1.0d0)) then amax2 = amax2x rbdposalu = 1 rbdposaind(rbdposalu) = ii else if (amax2x .le. amax2+macheps * max(amax2, 1.0d0)) then rbdposalu = rbdposalu + 1 rbdposaind(rbdposalu) = ii end if end if end do C amax2 > 0 is also the maximum value of alpha such that C A(x + Z s + alpha * Z d) >= b C Look to the linear inequality constraints rbdposali = rbdposalu call expand(nind, ind, n, x) do i = nact+1, ml ii = iact(i) azp = 0.0d0 do j = 1, nind jj = ind(j) azp = azp + A(ii,jj) * zp(j) end do azd = 0.0d0 do j = 1, nind jj = ind(j) azd = azd + A(ii,jj) * zd(j) end do ax = 0.0d0 do j = 1, n ax = ax + A(ii,j) * x(j) end do if (azp .lt. 0.0d0) then amax2x = (b(ii) - azd - ax) / azp if (amax2x .lt. amax2 - macheps * max(amax2, 1.0d0)) then amax2 = amax2x rbdposalu = 0 rbdposali = 1 rbdposaind(rbdposali) = i else if (amax2x .le. amax2+macheps * max(amax2, 1.0d0)) then rbdposali = rbdposali + 1 rbdposaind(rbdposali) = i end if end if end do call shrink(nind, ind, n, x) C Compute amax as the minimum among amax1 and amax2 amax = min(amax1, amax2) C ================================================================== C Compute the step C ================================================================== negcur = .false. C If p^T H p > 0 then take the conjugate gradients step if ( pthp .gt. 0.0d0 ) then alpha = min( amax, ztr / pthp ) C Else, if we are at iteration zero then take the maximum C positive step in the minus gradient direction else if ( iter .eq. 0 ) then alpha = amax negcur = .true. C Otherwise, stop at the current iterate else inform = 7 if ( iprint .ge. 3 ) then write(*, 997) inform write(10,997) inform end if go to 500 end if C ================================================================== C Test the angle condition C ================================================================== gtp = 0.0d0 do i = 1,nred gtp = gtp + gz(i) * p(i) end do gtd = gtd + alpha * gtp dnorm2 = dnorm2 + alpha ** 2 * pnorm2 + 2.0d0 * alpha * ptd if ( gtd .gt. 0.0d0 .or. +gtd ** 2 .lt. theta ** 2 * gznorm2 * dnorm2 ) then if ( precond .ne. 'NONE' .and. iter .eq. 0 ) then if ( iprint .ge. 3 ) then write(*, 986) write(10,986) end if restarted = .true. itertmp = iter prectmp = precond precond = 'NONE' go to 001 end if inform = 3 if ( iprint .ge. 3 ) then write(*, 993) inform write(10,993) inform end if go to 500 end if C ================================================================== C Compute the quadratic model functional value at the new point C ================================================================== qprev = q q = q + 0.5d0 * alpha ** 2 * pthp + alpha * ptr C ================================================================== C Compute new d C ================================================================== do i = 1,nred dprev(i) = d(i) d(i) = d(i) + alpha * p(i) end do do i = 1, nind zdprev(i) = zd(i) zd(i) = zd(i) + alpha * zp(i) end do dnorm2 = dnorm2 + alpha**2 * pnorm2 + 2.0d0 * alpha * ptd C ================================================================== C Compute the residual r = H d + g C ================================================================== do i = 1,nred r(i) = r(i) + alpha * hp(i) end do rnorm2 = norm2s(nred,r) C ================================================================== C Increment number of iterations C ================================================================== iter = iter + 1 C ================================================================== C Print information of this iteration C ================================================================== if ( iprint .ge. 3 ) then write(*, 984) iter,sqrt(rnorm2),sqrt(dnorm2),q write(10,984) iter,sqrt(rnorm2),sqrt(dnorm2),q end if C ================================================================== C Test other stopping criteria C ================================================================== C Boundary of the feasible set if ( alpha .eq. amax2 ) then rbdlu = rbdposalu rbdli = rbdposali do i = 1, rbdli rbdind(i) = rbdposaind(i) end do if (rbdlu .eq. 0) then rbdtypea = 'linear' else if (rbdind(1) .gt. n) then rbdtypea = 'upper' else rbdtypea = 'lower' end if inform = 2 if (iprint .ge. 3) then if ( negcur ) then write(*, 999) write(10,999) end if if ( rbdli .eq. 0 ) then write(*, 987) inform write(10,987) inform else if (rbdlu .eq. 0) then write(*, 995) inform, rbdind(1) write(10,995) inform, rbdind(1) else if (rbdind(1) .gt. n) then write(*, 992) inform, ind(rbdind(1)-n), rbdtypea write(10,992) inform, ind(rbdind(1)-n), rbdtypea else write(*, 992) inform, ind(rbdind(1)), rbdtypea write(10,992) inform, ind(rbdind(1)), rbdtypea end if end if end if end if go to 500 end if C Boundary of the "trust region" if ( alpha .eq. amax1 ) then inform = 1 if ( iprint .ge. 3 ) then if ( negcur ) then write(*, 999) write(10,999) end if write(*, 991) inform write(10,991) inform end if go to 500 end if C Two consecutive iterates are too much close samep = .true. do i = 1,nred if ( abs( alpha * p(i) ) .gt. + macheps * max( abs( d(i) ) , 1.0d0 ) ) then samep = .false. end if end do if ( samep ) then inform = 6 if ( iprint .ge. 3 ) then write(*, 996) inform write(10,996) inform end if go to 500 end if C Many iterations without good progress of the quadratic model currprog = qprev - q bestprog = max( currprog, bestprog ) if ( currprog .le. epsnqmp * bestprog ) then itnqmp = itnqmp + 1 if ( itnqmp .ge. maxitnqmp ) then inform = 4 if ( iprint .ge. 3 ) then write(*, 994) inform,itnqmp,epsnqmp,bestprog write(10,994) inform,itnqmp,epsnqmp,bestprog end if go to 500 end if else itnqmp = 0 endif C ================================================================== C Iterate C ================================================================== go to 100 C ================================================================== C End of main loop C ================================================================== C ================================================================== C Return C ================================================================== 500 continue C Print final information if ( iprint .ge. 3 ) then write(*, 985) min0(nred,ncomp),(d(i),i=1,min0(nred,ncomp)) write(10,985) min0(nred,ncomp),(d(i),i=1,min0(nred,ncomp)) end if if ( restarted ) then iter = iter + itertmp precond = prectmp end if C Non-executable statements 980 format(/,6x,'Conjugate gradients ',A4,' (maxit= ',I7,' acc= ', *1PD11.4,')') 981 format(6x,'Using Euclidian trust region (delta= ',1PD11.4, *')') 982 format(6x,'Using sup-norm trust region (delta= ',1PD11.4,')') 983 format(6x,'Unknown trust-region type') 984 format(6x,'CG iter= ',I5,' rnorm: ',1PD11.4,' dnorm= ',1PD11.4, *' q= ',1PD11.4) 985 format(/,6x,'Truncated Newton direction (first ',I6, *' components): ',/,1(6x,6(1PD11.4,1x))) 986 format(6x,'The first CG-PREC iterate did not satisfy the angle ', *' condition. CG will be restarted without preconditioner)') 987 format(6x,'Flag of CG = ',I3, *' (Taking a too large step, no variable will reach its bound)') 990 format(6x,'Flag of CG = ',I3,' (Convergence with small residual)') 991 format(6x,'Flag of CG = ',I3, *' (Convergence to the trust region boundary)') 992 format(6x,'Flag of CG = ',I3, *' (Convergence to the boundary of the feasible set,',/,6x, *'taking step >= 1, variable ',I6,' will reach its ',A6, *' bound)') 995 format(6x,'Flag of CG = ',I3, + ' (Convergence to the boundary of the feasible set,',/,6x, + 'taking step >= 1, linear constraint ',I6, + ' will reach its bound)') 993 format(6x,'Flag of CG = ',I3, *' (The next CG iterate will not satisfy the angle condition)') 994 format(6x,'Flag of CG = ',I3, *' (Not enough progress in the quadratic model. This means',/,6x, *'that the progress of the last ',I7,' iterations was smaller ', *'than ',/,6x,1PD11.4,' times the best progress (',1PD11.4,')') 996 format(6x,'Flag of CG = ',I3, *' (Very near consecutive iterates)') 997 format(6x,'Flag of CG= ',I3, *' (p such that p^T H p = 0 was found)') 998 format(6x,'Flag of CG = ',I3,' (Too many GC iterations)') 999 format(6x,'p such that p^T H p = 0 was found. ', * 'Maximum step was taken.') 1000 format(6x,'Flag of CG = ',I3,' Fatal Error') end C ***************************************************************** C ***************************************************************** subroutine tnls(nind,ind,nind2,ind2,n,x,ml,mleq,lda,A,b,l,u,f,g,d, +amax,nact,iact,rbdlu,rbdli,rbdind,etaint,mininterp,fmin,maxfc, +gtype,iprint,fcnt,gcnt,intcnt,inform,xplus,wd1,gamma,sigma1, +sigma2,lossfeas,epscsn,macheps) implicit none C SCALAR ARGUMENTS logical lossfeas integer fcnt,gcnt,gtype,inform,intcnt,iprint,maxfc,mininterp,n, + nind,nind2,ml,mleq,nact,lda,rbdlu,rbdli double precision amax,etaint,f,fmin,gamma,epscsn,macheps,sigma1, + sigma2 C ARRAY ARGUMENTS integer ind(nind),ind2(nind),iact(ml),rbdind(n+ml) double precision d(n),g(n),l(n),u(n),x(n),xplus(n),wd1(ml), + A(lda,n),b(ml) C This subroutine implements the line search used in the Truncated C Newton direction. C C On Entry C C nind integer C number of free variables (this is thee dimension in C which this subroutine will work) C C ind integer ind(n) C array which contains, in the first nind positions, the C identifiers of the free variables C C nind2 integer C number of truely free variables C C ind2 integer ind2(n) C array which contains, in the first nind2 positions, the C identifiers of the truely free variables C C n integer C dimension of the full space C C x double precision x(n) C current point C C The first nind positions of x contains the free variables C x_ind(1), x_ind(2), ..., x_ind(nind). C C ml integer C total number of linear constraints (excluding bounds) C C mleq integer C number of linear equality constraints (excluding bounds) C C lda integer C leading dimension of matrix A C C A double precision A(lda,n) C coeficients of linear constraints C C b double precision b(ml) C constant part of linear constraints C C l double precision l(nind) C lower bounds on x. It components are ordered in the C same way as x and g. C C u double precision u(nind) C upper bounds on x. It components are ordered in the C same way as x, g and l. C C f double precision C functional value at x C C g double precision g(n) C gradient vector at x C C It also contains in the first nind positions the C components g_ind(1), g_ind(2), ..., g_ind(nind). C C IMPORTANT: the linear algebra of this subroutine lies in C a space of dimension nind. The value of the full C dimension n, the non-free variables (which are at the end C of array x) and its gradient components (which are at the C end of array g) are also used and updated any time the C gradient is being computed. C C d double precision d(nind) C descent direction C C amax double precision C C nact integer C number of active linear constraints C C iact integer iact(ml) C indices of the active linear constraints. The last C m - nact positions of iact store the identifier of the C non-active linear constraints. C C etaint double precision C constant for the interpolation. See the description of C sigma1 and sigma2 above. Sometimes we take as a new C trial step the previous one divided by etaint C C RECOMMENDED: etaint = 2.0 C C mininterp integer C constant for testing if, after having made at least C mininterp interpolations, the steplength is so small. C In that case failure of the line search is declared (may C be the direction is not a descent direction due to an C error in the gradient calculations) C C RECOMMENDED: mininterp = 4 C C fmin double precision C functional value for the stopping criteria f <= fmin C C maxfc integer C maximum number of functional evaluations C C gtype integer C type of gradient calculation C gtype = 0 means user suplied evalg subroutine, C gtype = 1 means central difference approximation. C C RECOMMENDED: gtype = 0 C C (provided you have the evalg subroutine) C C iprint integer C Commands printing. Nothing is printed if iprint is C smaller than 2. If iprint is greater than or equal to C 2, WFGENCAN iterations information is printed. If iprint C is greater than or equal to 3, line searches and C Conjugate Gradients information is printed. C C RECOMMENDED: iprint = 2 C C CONSTRAINTS: allowed values are just 2 or 3. C C xplus,wd1 double precision xplus,wd1(n) C n-dimensional working vectors of doubles C C gamma double precision C constant for the Armijo criterion C f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d> C C RECOMMENDED: gamma = 10^{-4} C C sigma1 double precision C sigma2 double precision C constant for the safeguarded interpolation C if alpha_new \notin [sigma1, sigma*alpha] then we take C alpha_new = alpha / etaint C C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 C C lossfeas logical C if a loss of feasibility up to sqrt(epsfeas) is allowed C during the computations, lossfeas must be set to TRUE C (recommended). In this case, if the final iterate does C not satisfy the constraints with the desired precision, C we sugest that the user re-run the method using the final C point obtained as the initial point, using C lossfeas = FALSE C C epscsn double precision C feasibility tolerance for the sup-norm of the linear C constraints C C macheps double precision C macheps is the smallest positive number such that C 1 + macheps is not equal to 1 C C On Return C C x double precision x(n) C new current point C C f double precision C functional value at x C C g double precision g(n) C gradient vector at x C C rbdlu integer C number of variables that reached a lower or upper C bound C C rbdli integer C total number of new active constraints. rbdli-rbdlu C is the number of linear constraints that are now C satisfied by equality C C rbdind integer rbdind(n+ml) C indices of bound and linear constraints that are C satisfied by equality at the new point x. That is, C indices of the constraints to be added to the active set) C C fcnt integer C number of functional evaluations used in this line search C C gcnt integer C number of gradient evaluations used in this line search C C intcnt integer C number of interpolations C C inform integer C This output parameter tells what happened in this C subroutine, according to the following conventions: C C 0 = convergence with an Armijo-like criterion C (f(xnew) <= f(x) + 1.0d-4 * alpha * ); C C 3 = new point x is in the boundary of the current face; C C 4 = the algorithm stopped because the functional value C is very small (f <= fmin); C C 6 = so small step in the line search. After having made C at least mininterp interpolations, the steplength C becames small. ``small steplength'' means that we are C at point x with direction d and step alpha such that C C |alpha * d(i)| <= macheps * max ( |x(i)|, 1 ) C C for all i. C C In that case failure of the line search is declared C (may be the direction is not a descent direction C due to an error in the gradient calculations). Use C mininterp > maxfc for inhibit this criterion; C C 8 = it was achieved the maximum allowed number of C function evaluations (maxfc); C C 10 = new point x+alpha*d is infeasible, so x is returned; C C < 0 = error in evalf or evalg subroutines. C LOCAL SCALARS logical samep integer i,ii,j,index,interp double precision alpha,atmp,fplus,gtd C ================================================================== C Initialization C ================================================================== C ================================================================== C Compute directional derivative C ================================================================== gtd = 0.0d0 do i = 1,nind gtd = gtd + g(i) * d(i) end do C ================================================================== C Compute first trial C ================================================================== alpha = min( 1.0d0, amax ) do i = 1,nind xplus(i) = x(i) + alpha * d(i) end do if (alpha .eq. amax) then do i = 1, rbdlu index = rbdind(i) if (index .gt. n) then xplus(index-n) = u(index-n) else xplus(index) = l(index) end if end do end if C Test whether at least mininterp interpolations were made and two C consecutive iterates are much close samep = .true. do i = 1,nind if ( abs( alpha * d(i) ) .gt. + macheps * max( abs( xplus(i) ), 1.0d0 ) ) then samep = .false. end if end do if ( samep ) then inform = 6 if ( iprint .ge. 3 ) then write(*, 996) inform write(10,996) inform end if go to 500 end if C Check if new point xtrial is feasible. If the lossfeas = true, C then a loss of feasibility up to sqrt(epscsn) is accepted do i = nind+1, n xplus(i) = x(i) end do do i = 1, ml wd1(i) = 0.0d0 end do call expand(nind, ind, n, xplus) do i = 1, n do j = 1, ml wd1(j) = wd1(j) + A(j,i) * xplus(i) end do end do call shrink(nind, ind, n, xplus) if (lossfeas) then do i = 1, mleq if (abs(wd1(i) - b(i)) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible.' write(*, *) ' Inner algoritm will stop.' write(10,*) ' x+d is infeasible.' write(10,*) ' Inner algoritm will stop.' end if inform = 10 return end if end do do i = mleq+1, ml if (b(i) - wd1(i) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible.' write(*, *) ' Inner algoritm will stop.' write(10,*) ' x+d is infeasible.' write(10,*) ' Inner algoritm will stop.' end if inform = 10 return end if end do else do i = 1, mleq if (abs(wd1(i) - b(i)) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible.' write(*, *) ' Inner algoritm will stop.' write(10,*) ' x+d is infeasible.' write(10,*) ' Inner algoritm will stop.' end if inform = 10 return end if end do do i = mleq+1, ml if (b(i) - wd1(i) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible.' write(*, *) ' Inner algoritm will stop.' write(10,*) ' x+d is infeasible.' write(10,*) ' Inner algoritm will stop.' end if inform = 10 return end if end do end if interp = 0 120 continue call calcobj(nind,ind,xplus,n,x,fplus,inform) fcnt = fcnt + 1 if ( inform .lt. 0 ) then C Print information of this iteration if ( iprint .ge. 3 ) then write(*, 999) alpha,fplus,fcnt write(10,999) alpha,fplus,fcnt end if if ( iprint .ge. 3 ) then write(*, *) ' f(x+d) is undefined.' write(*, *) ' Will interpolate.' write(10,*) ' f(x+d) is undefined.' write(10,*) ' Will interpolate.' end if C Compute new step interp = interp + 1 alpha = alpha / etaint C Compute new trial point do i = 1,nind xplus(i) = x(i) + alpha * d(i) end do C Test whether at least mininterp interpolations were made and C two consecutive iterates are much close samep = .true. do i = 1,nind if ( abs( alpha * d(i) ) .gt. + macheps * max( abs( xplus(i) ), 1.0d0 ) ) then samep = .false. end if end do if ( samep ) then inform = 6 if ( iprint .ge. 3 ) then write(*, 996) inform write(10,996) inform end if go to 500 end if go to 120 end if C Print initial information if ( iprint .ge. 3 ) then write(*, 980) amax write(*, 999) alpha,fplus,fcnt write(10,980) amax write(10,999) alpha,fplus,fcnt end if C ================================================================== C Test Armijo and beta-condition and decide for accepting the trial C point, interpolate or extrapolate. C ================================================================== c if ( amax .gt. 1.0d0 ) then if ( alpha .lt. amax ) then C x + d belongs to the interior of the feasible set if ( iprint .ge. 3 ) then write(*, *) ' x+d belongs to int of the feasible set' write(10,*) ' x+d belongs to int of the feasible set' end if C Verify Armijo if ( fplus .le. f + gamma * alpha * gtd ) then C Armijo condition holds if ( iprint .ge. 3 ) then write(*, *) ' Armijo condition holds' write(10,*) ' Armijo condition holds' end if C If interpolation is done to make the new point feasible f = fplus do i = 1,nind x(i) = xplus(i) end do call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform) gcnt = gcnt + 1 if ( inform .lt. 0 ) then if ( iprint .ge. 3 ) then write(*, 1000) inform write(10,1000) inform end if return end if inform = 0 if ( iprint .ge. 3 ) then write(*, 990) inform write(10,990) inform end if go to 500 else C Interpolate if ( iprint .ge. 3 ) then write(*, *) ' Armijo does not hold' write(*, *) ' We will interpolate' write(10,*) ' Armijo does not hold' write(10,*) ' We will interpolate' end if go to 200 end if else C x + d does not belong to the feasible set (amax <= 1) if ( iprint .ge. 3 ) then write(*, *) ' x+d does not belong to feasible set' write(10,*) ' x+d does not belong to feasible set' end if if ( fplus .lt. f ) then f = fplus do i = 1,nind x(i) = xplus(i) end do call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform) gcnt = gcnt + 1 if ( inform .lt. 0 ) then if ( iprint .ge. 3 ) then write(*, 1000) inform write(10,1000) inform end if return end if C New point x is in the boundary, rbdind is updated rbdlu = 0 do i = 1, nind2 ii = ind2(i) if (x(ii) .le. l(ii) + macheps * + max(abs(l(ii)), 1.0d0)) then x(ii) = l(ii) rbdlu = rbdlu + 1 rbdind(rbdlu) = ii else if (x(ii) .ge. u(ii) - macheps * + max(abs(u(ii)), 1.0d0)) then x(ii) = u(ii) rbdlu = rbdlu + 1 rbdind(rbdlu) = ii + n end if end do C Look to the linear inequality constraints rbdli = rbdlu call expand(nind, ind, n, x) do i = 1, ml-nact wd1(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml ii = iact(i) wd1(i-nact) = wd1(i-nact) + A(ii,j) * x(j) end do end do do i = nact+1, ml ii = iact(i) if (abs(wd1(i-nact)-b(ii)) .le. epscsn) then rbdli = rbdli + 1 rbdind(rbdli) = i end if end do call shrink(nind, ind, n, x) if (rbdli .gt. 0) then inform = 3 else inform = 0 end if go to 500 else C Interpolate if ( iprint .ge. 3 ) then write(*, *) ' f(x+d) >= f(x)' write(*, *) ' We will interpolate' write(10,*) ' f(x+d) >= f(x)' write(10,*) ' We will interpolate' end if go to 200 end if end if C ================================================================== C Interpolation C ================================================================== 200 continue intcnt = intcnt + 1 c interp = 0 210 continue C Test f going to -inf if ( fplus .le. fmin ) then C Finish the interpolation with the current point f = fplus do i = 1,nind x(i) = xplus(i) end do call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform) gcnt = gcnt + 1 if ( inform .lt. 0 ) then if ( iprint .ge. 3 ) then write(*, 1000) inform write(10,1000) inform end if return end if inform = 4 if ( iprint .ge. 3 ) then write(*, 994) inform write(10,994) inform end if go to 500 end if C Test maximum number of functional evaluations if ( fcnt .ge. maxfc ) then C As this is an abrupt termination then the current point of the C interpolation may be worst than the initial one C If the current point is better than the initial one then C finish the interpolation with the current point else discard C all we did inside this line search and finish with the initial C point if ( fplus .lt. f ) then f = fplus do i = 1,nind x(i) = xplus(i) end do call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform) gcnt = gcnt + 1 if ( inform .lt. 0 ) then if ( iprint .ge. 3 ) then write(*, 1000) inform write(10,1000) inform end if return end if end if inform = 8 if ( iprint .ge. 3 ) then write(*, 998) inform write(10,998) inform end if go to 500 end if C Test Armijo condition if ( fplus .le. f + gamma * alpha * gtd ) then C Finish the line search f = fplus do i = 1,nind x(i) = xplus(i) end do call calcgr(nind,ind,x,n,x,g,gtype,macheps,inform) gcnt = gcnt + 1 if ( inform .lt. 0 ) then if ( iprint .ge. 3 ) then write(*, 1000) inform write(10,1000) inform end if return end if if ( alpha .ge. amax ) then inform = 3 else inform = 0 end if if ( iprint .ge. 3 ) then write(*, 990) inform write(10,990) inform end if go to 500 end if C Compute new step interp = interp + 1 atmp = ( - gtd * alpha **2 ) / + (2.0d0 * ( fplus - f - alpha * gtd ) ) if ( ( atmp .lt. sigma1 * alpha ) .or. + ( atmp .gt. sigma2 * alpha ) ) then alpha = alpha / etaint else alpha = atmp end if C Compute new trial point do i = 1,nind xplus(i) = x(i) + alpha * d(i) end do call calcobj(nind,ind,xplus,n,x,fplus,inform) fcnt = fcnt + 1 if ( inform .lt. 0 ) then if ( iprint .ge. 3 ) then write(*, 1000) inform write(10,1000) inform end if return end if C Print information of this iteration if ( iprint .ge. 3 ) then write(*, 999) alpha,fplus,fcnt write(10,999) alpha,fplus,fcnt end if C Test whether at least mininterp interpolations were made and two C consecutive iterates are much close samep = .true. do i = 1,nind if ( abs( alpha * d(i) ) .gt. + macheps * max( abs( x(i) ), 1.0d0 ) ) then samep = .false. end if end do if ( interp .ge. mininterp .and. samep ) then C As this is an abrupt termination then the current point of the C interpolation may be worst than the initial one C The previous lines were commented because, as it is been used, C this subroutine must return with the initial point in case of C finding a very small interpolation step. From that initial C point, something different will be tried. inform = 6 if ( iprint .ge. 3 ) then write(*, 996) inform write(10,996) inform end if go to 500 end if C Else, iterate go to 210 C ================================================================== C End of interpolation C ================================================================== C ================================================================== C Return C ================================================================== 500 continue return C Non-executable statements 980 format(/,6X,'TN Line search (alphamax= ',1PD11.4,')') 999 format(6X,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I10) 990 format(6X,'Flag of TN Line search= ',I3, + ' (Armijo-like criterion satisfied)') 994 format(6X,'Flag of TN Line search= ',I3, + ' (Small functional value, smaller than ',/, + 6X,'parameter fmin)') 996 format(6X,'Flag of TN Line search= ',I3, + ' (Too small step in the interpolation)') 998 format(6X,'Flag of TN Line search= ',I3, + ' (Too many functional evaluations)') 1000 format(6X,'Flag of TN Line search = ',I3,' Fatal Error') end C ****************************************************************** C ****************************************************************** subroutine project(n, x, l, u, ml, mleq, lda, A, b, maxit, eps, +lossfeas, epsfeas, csupn, macheps, wi1, wd1, wd2, lwd2, xbest, +iterql, inform) C SCALAR ARGUMENTS logical lossfeas integer n, ml, mleq, lda, maxit, lwd2, iterql, inform double precision eps, epsfeas, csupn, macheps C ARRAY ARGUMENTS integer wi1(ml+n+n) double precision x(n), l(n), u(n), A(lda,n), b(ml), wd1(n), + wd2(lwd2), xbest(n) C Calculate the projection of x onto the polytope defined by C A_j x = b_j, j = 1, ..., meq C A_j x >= b_j, j = meq+1, ..., m C l <= x <= u C C This is equivalent to solve the problem C C min |x - xbar|_2 ^2 C st A_j x = b_j, j = 1, ..., meq C A_j x >= b_j, j = meq+1, ..., m C l <= x <= u C C On Entry C C n integer C dimension of x C C x double precision x(n) C vector in R^n to be projected C C l double precision l(n) C lower bounds C C u double precision u(n) C upper bounds C C ml integer C total number of linear constraints (excluding bounds) C C mleq integer C number of linear equality constraints (excluding bounds) C C lda integer C leading dimension of matrix A C C A double precision A(lda,n) C coeficients of linear constraints C C b double precision b(ml) C constant part of linear constraints C C maxit integer C maximum number of iterations allowed C C eps double precision C accuracy to be achieved C C lossfeas logical C if a loss of feasibility up to sqrt(epsfeas) is allowed C during the computations, lossfeas must be set to TRUE C (recommended). In this case, if the final iterate does C not satisfy the constraints with the desired precision, C we sugest that the user re-run the method using the final C point obtained as the initial point, using C lossfeas = FALSE C C epsfeas double precision C feasibility tolerance for the sup-norm of the linear C constraints C C macheps double preciosion C machine epsilon C C wi1 integer wi(n+n+ml) C wd1 double precision wd1(n) C wd2 double precision wd2(lwd2) C xbest double precision xbest(n) C working vectors C C lwd2 integer C length of wd2. Must be set to, at least, 1.5*n*n+10*n+ml C C On Return C C x double precision x(n) C projected vector C C csupn double precision C sup-norm of the constraints at x C C iterql integer C number of calls to QL routine C C inform integer C This output parameter tells what happened in this C subroutine, according to the following conventions: C C 0, projection terminated successfully; C C 1, point is feasible with tolerance sqrt(epscsn) (only C possible if lossfeas = TRUE); C C 2, point is infeasible; C C <0, the constraint with index abs(inform) and the C constraints whose indices are iact(k), k = 1, 2, nact, C are inconsistent C LOCAL SCALARS logical bigeps, smallereps integer i, j, nactp double precision epstmp, csupnbest, boxsupn, boxsupnbest bigeps = .false. smallereps = .false. csupnbest = 1.0d+99 boxsupnbest = 1.0d+99 C If there are only bound constraints, there no need to call the C quadratic programming solver. epstmp = eps C Call the quadratic programming solver. do i = 1, n wd1(i) = -x(i) end do 11 continue call QL00022(n, ml, mleq, lda, ml+n, A, b, wd1, l, u, x, nactp, + wi1, maxit, epstmp, inform, wd2, lwd2) iterql = iterql + 1 C Check if the solution is feasible. boxsupn = 0.0d0 do i = 1, n boxsupn = max(boxsupn, l(i) - x(i)) boxsupn = max(boxsupn, x(i) - u(i)) end do do i = 1, ml wd2(i) = 0.0d0 end do do j = 1, n do i = 1, ml wd2(i) = wd2(i) + A(i,j) * x(j) end do end do csupn = 0.0d0 do i = 1, mleq csupn = max(csupn, abs(wd2(i) - b(i))) end do do i = mleq+1, ml csupn = max(csupn, b(i) - wd2(i)) end do if (max(boxsupn,csupn) .gt. epsfeas) then go to 10 end if go to 20 10 continue if (max(csupn,boxsupn) .lt. max(csupnbest,boxsupnbest)) then csupnbest = csupn boxsupnbest = boxsupn do i = 1, n xbest(i) = x(i) end do end if if (bigeps .and. (inform .lt. 0)) then if (lossfeas .and. + (max(boxsupnbest,csupnbest) .le. sqrt(epsfeas))) then csupn = csupnbest do i = 1, n x(i) = xbest(i) end do inform = 1 end if return end if if (bigeps .or. (epstmp .lt. macheps) .or. + (smallereps .and. (inform .ne. 0))) then if (lossfeas) then if (max(boxsupnbest,csupnbest) .gt. sqrt(epsfeas)) then inform = 2 else csupn = csupnbest do i = 1, n x(i) = xbest(i) end do inform = 1 end if else inform = 2 end if return end if if (inform .eq. 0) then smallereps = .true. epstmp = epstmp * 1.0d-02 else bigeps = .true. epstmp = sqrt(eps) end if go to 11 20 continue inform = 0 end C ***************************************************************** C ***************************************************************** subroutine wfbetra(n, nind, ind, nind2, ind2, x, l, u, ml, mleq, + lda, A, b, nact, nliact, iact, samefa, gtype, f, g, gz, + gzsupn, delta, newdelta, mslamb, msrho, mseps, msmaxit, + phieps, mssig, alpha, delmin, epsg, gamma, lspgmi, lspgma, + sigma1, sigma2, etaint, mininterp, fmin, lossfeas, epscsn, + projeps, promaxit, macheps, iprint, ncomp, xeucn2, sts, sty, + maxfc, ldh, H, diag, ldabar, Abar, tau, wi1, d, dz, xtrial, + wd1, lwd1, wd2, wd3, wd4, wd5, rbdlu, rbdli, rbdind, triter, + trfcnt, ispgiter, ispgfcnt, fcnt, gcnt, hcnt, chcnt, iterql, + ittype, inform) C SCALAR ARGUMENTS logical samefa, lossfeas integer n, nind, nind2, ml, mleq, lda, nact, nliact, gtype, + msmaxit, mininterp, iprint, ncomp, maxfc, ldh, promaxit, + ldabar, lwd1, rbdlu, rbdli, triter, trfcnt, ispgiter, + ispgfcnt, fcnt, gcnt, hcnt, chcnt, iterql, ittype, inform double precision f, gzsupn, delta, newdelta, mslamb, msrho, mseps, + phieps, mssig, alpha, delmin, epsg, gamma, lspgmi, lspgma, + sigma1, sigma2, etaint, fmin, epscsn, projeps, macheps, + xeucn2, sts, sty C ARRAY ARGUMENTS integer ind(nind), ind2(nind), iact(ml), rbdind(nind+ml), + wi1(2*nind+ml) double precision x(n), l(n), u(n), g(n), gz(nind-nliact), + H(ldh,n), diag(nind), d(nind), dz(nind-nliact), xtrial(n), + wd1(lwd1), wd2(n), wd3(n), wd4(n), wd5(ml), A(lda,n), b(ml), + Abar(ldabar,nliact), tau(nliact) C Solves the "unconstrained" minimization subproblem C C Minimize f(x) C C using a method described in C C M. Andretta, E. G. Birgin and J. M. Martinez, ''Practical active-set C Euclidian trust-region method with spectral projected gradients for C bound-constrained minimization'', Optimization 54, pp. 305-325, 2005. C C Algorithm that finds a unconstrained minimizer of objective C function inside the polytope, hits the boundary (obtaining C function decrease), or finds an interior point where the objective C function has sufficient decrease (compared to its value at x). C C When the current point x is "close to" the boundary, a Spectral C Projected Gradient (SPG) iteration is used to calculate the new C point. If this new point is at the boundary, the algorithm stops. C Otherwise, a new iteration begins. C C When x is "far from" the boundary, trust-region radius is C determined and d is calculated using More-Sorensen algorithm to C solve the trust-region subproblem (which is to find a minimizer a C to a function quadratic model provided that the minimizer's C Euclidian-norm is smaller than a given delta). The new point is C xtrial = x + d. C C If xtrial lies outside the feasible region, it is truncated on C the boundary. This new y on the boundary will be candidate to be a C solution. If function value at new xtrial is smaller than function C value at x, inner algorithm stops with xtrial. Otherwise, the C trust-region radius is decreased so that the new solution d' to C the trust-region subproblem makes x + d' be interior to the C feasible region. More-Sorensen algorithm is used to calculate d' too. C C If xtrial lies inside the feasible region, sufficient decrease of C objective function is tested. If it is true, xtrial is accepted as C a solution candidate. If xtrial in on the boundary, inner algorithm C stops and if it is interior, a new iteration begins. If sufficient C decrease is not obtained, trust-region radius is decreased and a C new quadratic model minimizer is calculated (as in a classical C trust-region algorithm for unconstrained minimization). C C If gradient at current point is null, inner algorithm stops C declaring "first-order stationary point". If quadratic model C minimum is 0, inner algorithm stops declaring "second-order C stationary point". C C On Entry C C n integer C dimension of full space C C nind integer C dimension of reduced space C C ind integer ind(nind) C indices of free variables C C nind2 integer C dimension of reduced space C C ind2 integer ind2(nind2) C indices of truely free variables C C x double precision x(n) C initial point, interior to the current face C C l double precision l(n) C lower bounds on x C C u double precision u(n) C upper bounds on x C C ml integer C total number of linear constraints (excluding bounds) C C mleq integer C number of linear equality constraints (excluding bounds) C C lda integer C leading dimension of matrix A C C A double precision A(lda,n) C coeficients of linear constraints C C b double precision b(ml) C constant part of linear constraints C C nact integer C number of active linear constraints C C nliact integer C number of linearly independent active linear C constraints C C iact integer iact(ml) C indices of the active linear constraints. The last C m - nact positions of iact store the identifier of the C non-active linear constraints. C C samefa logical C true iff current point is in the same face as the C previous one C C gtype integer C Type of first derivatives calculation according to the C following convention: C C 0 = means true first derivatives. C C 1 = means that a finite difference approximation will C be used. C C f double precision C objective function value at x C C g double precision g(n) C gradient at x C C gz double precision gz(nind-nliact) C reduced gradient at x (Z^T g) C C gzsupn double precision C sup-norm of gz C C delta double precision C trust-region radius C C newdelta double precision C trust-region radius is set to the maximum between newdelta C and delta C C mslamb double precision C value that More-Sorensen algorithm calculates to find C the trust-region subproblem solution (MEQB) C C msrho double precision C distance from the boundary (to prevent that the error C in the length of step calculated by More-Sorensen C algorithm make the solution candidate lie outside the C feasible region) C C mseps double precision C tolerance for More-Sorensen algorithm (MEQB) C C msmaxit integer C maximum allowed number of MEQB iterations C C phieps double precision C allowed error in comparing the quadratic model value to C zero C C mssig double precision C allowed error to trust-region subproblem solution C (MEQB) C C alpha double precision C sufficient decrease occurs when ared >= alpha*pred C C delmin double precision C minimum value for trust-region radius (delta) in the C beginning of each iteration C C epsg double precision C allowed error for projected gradient norm C C gamma double precision C Armijo condition constant (SPG) C C lspgmi double precision C lower bound on spectral step (SPG) C C lspgma double precision C upper bound on spectral step (SPG) C C sigma1 double precision C safeguard for line search (lower) (SPG) C C sigma2 double precision C safeguard for line search (upper) (SPG) C C etaint double precision C constant for the interpolation. See the description of C sigma1 and sigma2 above. Sometimes we take as a new C trial step the previous one divided by etaint C C mininterp integer C constant for testing if, after having made at least C mininterp interpolations, the steplength is so small. In C that case failure of the line search is declared (may be C the direction is not a descent direction due to an error C in the gradient calculations) C C fmin double precision C function value for the stopping criteria f <= fmin C C There is a stopping criterion that stops BETRA if a C point with a functional value smaller than fmin is found. C The idea behind this stopping criterion is to stop the C method if the objective function is not bounded from C bellow. C C lossfeas logical C if a loss of feasibility up to sqrt(epsfeas) is allowed C during the computations, lossfeas must be set to TRUE C (recommended). In this case, if the final iterate does C not satisfy the constraints with the desired precision, C we sugest that the user re-run the method using the final C point obtained as the initial point, using C lossfeas = FALSE C C epscsn double precision C feasibility tolerance for the sup-norm of the linear C constraints C C macheps double precision C macheps is the smallest positive number such that C 1 + macheps is not equal to 1 C C projeps double precision C precision used in projection routine C C promaxit integer C maximum allowed number of iterations of QL routine used C in projection C C iprint integer C Commands printing. Nothing is printed if iprint is C smaller than 3. C C ncomp integer, C every time a vector is printed, just its first ncomp C component will be displayed. C C xeucn2 double precision C x squared Euclidian norm C C sts double precision C product s^T s, where s = x_{k+1} - x_k C C sty double precision C product s^T y, where y = g_{k+1} - g_k and s as above C C maxfc integer C maximum allowed number of function evaluations C C ldh integer C leading dimension of matrix H C C H double precision H(ldh,n) C working matrix C C ldabar integer C leading dimension of matrix Abar C C Abar double precision Abar(ldabar,ml) C hold the LQ factorization of the matrix whose columns C correspond to the active linear constraints, after C eliminating the elements correnponding to fixed variables C C tau double precision tau(nliact) C used to retrieve the columns of Q from Abar C C wi1 integer wi1(2*nind+ml) C working vector C C d double precision d(nind) C dz double precision dz(nind-nliact) C xtrial double precision xtrial(n) C diag double precision diag(nind) C wd1 double precision wd1(lwd1) C wd2 double precision wd2(n) C wd3 double precision wd3(n) C wd4 double precision wd4(n) C wd5 double precision wd5(ml) C working vectors C C On Return C C x double precision x(n) C solution candidate, with inform as described bellow C C f double precision C objective function value at x C C g double precision g(n) C gradient at x C C newdelta double precision C when the trust-region radius delta is decreased so that C the point x + d fit the current face, newdelta is set to C the previous value of delta. Otherwise, it is set to 0 C C rbdlu integer C number of variables that reached a lower or upper C bound C C rbdli integer C total number of new active constraints. rbdli-rbdlu C is the number of linear constraints that are now C satisfied by equality C C rbdind integer rbdind(n+ml) C indices of bound and linear constraints that are C satisfied by equality at the new point x. That is, C indices of the constraints to be added to the active set) C C triter integer C number of trust-region iterations C C trfcnt integer C number of function evaluations performed by trust-region C iterations C C ispgiter integer C number of inner SPG iterations C C ispgfcnt integer C number of function evaluations performed by inner SPG C C fcnt integer C total number of function evaluations C C gcnt integer C total number of gradient evaluations C C hcnt integer C total number of Hessian evaluations C C chcnt integer C number of Cholesky decompositions C C delta double precision C updated trut-region radius C C mslamb double precision C updated value for next iteration (see entry parameter) C C iterql integer C number of calls to QL routine (used in projection) C C ittype integer C iteration type: C 7, for inner SPG; C 8, for trust-region; C C inform integer C This output parameter tells what happened in this C subroutine, according to the following conventions: C C 0 = if sufficient decrease of function is achieved; C C 1 = if x is close to the boundary and is a first-order C stationary point; C C 2 = if x is a second-order stationary point; C C 3 = if x hit the boundary; C C 4 = if a very small function value is achieved; C C 5 = if trust-region radius is too small; C C 6 = if either the search direction or the step lenght if C too small; C C 8 = if maximum allowed number of function evaluations is C achieved; C C 10 = either the new point x+d would be infeasible or a C problem in projection subroutine prevented d from C being calculated. x is returned; C C -90 = means that subroutine evalf retuned an error flag; C C -92 = means that subroutine evalg retuned an error flag; C C -94 = means that subroutine evalh retuned an error flag; C LOCAL SCALARS logical samep, pd, checkfeas integer i, ii, j, jj, jjj, index, infotmp, fcntprev, nred double precision dbound, tmax, pred, ared, deucn, tmp, phi, + ftrial, lamspg, ad, ax C Print presentation information if (iprint .ge. 3) then write(*, 980) write(10,980) end if nred = nind - nliact if (.not. samefa) then delta = max(delta, newdelta) end if delta = max(delta, delmin) newdelta = 0.0d0 checkfeas = .true. C ================================================================== C Compute distance to the boundary C ================================================================== C step 1: calculate the distance between x and the boundary. C dbound is the largest positive delta such that the ball C centered at x with radius delta is still inside the C (set of constraints). dbound = 1.0d+30 do i = 1, nind2 ii = ind2(i) dbound = min(dbound, x(ii) - l(ii)) end do do i = 1, nind2 ii = ind2(i) dbound = min(dbound, u(ii) - x(ii)) end do C Look to the linear inequality constraints call expand(nind, ind, n, x) do i = 1, ml-nact wd5(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml ii = iact(i) wd5(i-nact) = wd5(i-nact) + A(ii,j) * x(j) end do end do call shrink(nind, ind, n, x) do i = nact+1, ml ii = iact(i) dbound = min(dbound, wd5(i-nact) - b(ii)) end do C ================================================================== C Close to the boundary: performe inner SPG iteration C ================================================================== C step 2: close to the boundary: if the gradient is null then C algorithm stops. Else, perform an inner SPG iteration. if (dbound .lt. 2.0d0 * delmin) then if (gzsupn .le. epsg) then inform = 1 if (iprint .ge. 3) then write(*, 983) inform write(10,983) inform end if return end if ittype = 7 C Compute spectral steplength if (sty .le. 0.0d0) then lamspg = 1.0d0 else lamspg = sts / sty end if lamspg = min(lspgma, max(lspgmi, lamspg)) fcntprev = fcnt C Shrink columns of A (like x). call shrinkcol(n, ml, nind, ind, lda, A) C Shrink x, l, u, A to the space of really free variable C (using nind2 and ind2). call shrink(nind2, ind2, nind, x) call shrink(nind2, ind2, nind, g) call shrink(nind2, ind2, nind, l) call shrink(nind2, ind2, nind, u) call shrinkcol(nind, ml, nind2, ind2, lda, A) call ispgls(n, nind, ind, nind2, ind2, x, f, g, l, u, ml, mleq, + lda, A, b, nact, iact, lamspg, etaint, mininterp, fmin, + maxfc, iprint, xtrial, tmax, d, gamma, sigma1, sigma2, + lossfeas, epscsn, projeps, promaxit, macheps, wi1, wd2, + wd1, lwd1, wd3, wd5, fcnt, iterql, inform) ispgfcnt = ispgfcnt + (fcnt - fcntprev) C Expand x, l, u, A to the space of free variable (given by nind C and ind). do i = nind2+1, nind d(i) = 0.0d0 end do call expand(nind2, ind2, nind, xtrial) call expand(nind2, ind2, nind, d) call expand(nind2, ind2, nind, x) call expand(nind2, ind2, nind, g) call expand(nind2, ind2, nind, l) call expand(nind2, ind2, nind, u) call expandcol(nind, ml, nind2, ind2, lda, A) C Expand columns of A (like x). call expandcol(n, ml, nind, ind, lda, A) if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 989) inform write(10,989) inform end if return end if ispgiter = ispgiter + 1 C Compute the gradient at the new iterate infotmp = inform call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform) gcnt = gcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 989) inform write(10,989) inform end if return end if inform = infotmp if (inform .eq. 6) then if (iprint .ge. 3) then write(*, 991) inform write(10,991) inform end if return elseif (inform .eq. 8) then if (iprint .ge. 3) then write(*, 987) inform write(10,987) inform end if return elseif (inform .eq. 4) then if (iprint .ge. 3) then write(*, 988) inform write(10,988) inform end if return elseif (inform .eq. 10) then return else go to 7 end if end if C ================================================================== C Far from the boundary: performe trust-region iteration C ================================================================== ittype = 8 triter = triter + 1 C step 3: far from the boundary, solve trust-region subproblem. C Evaluate function Hessian at x. call calchz(n, nind, ind, x, x, nliact, ldabar, Abar, tau, + macheps, wd2, wd3, wd4, ldh, H, diag, inform) hcnt = hcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 989) inform write(10,989) inform end if return end if C step 4: solve the trust-region subproblem using More-Sorensen's C algorithm to minimize "exactly" quadratics subjected to C balls. C If trust-region radius is too small, the inner algorithm stops. 4 continue c if (delta .lt. macheps**(2.0d0/3.0d0)) then if (delta .lt. macheps * max(1.0d0,sqrt(xeucn2))) then inform = 5 if (iprint .ge. 3) then write(*, 986) inform, delta write(10,986) inform, delta end if return end if if (.not. samefa) then mslamb = 0.0d0 end if call MEQB(nred, gz, ldh, H, diag, delta, mssig, 0.0d0, mseps, + macheps, msmaxit, iprint, wd2, wd3, wd4, mslamb, pd, dz, + chcnt, inform) C If maximum allowed number of MEQB iterations is achieved, another C direction d is calculated. if (inform .eq. 5) then if (iprint .ge. 3) then write(*, *) ' Since the direction calculation failed, ' write(*, *) ' dogleg direction will be computed' write(10,*) ' Since the direction calculation failed, ' write(10,*) ' dogleg direction will be computed' end if call dogleg(nred, gz, ldh, H, diag, pd, delta, macheps, wd2, + dz, inform) end if C If both internal gradient and Hessian matrix are null, subroutines C MEQB and dogleg stop with inform = 0 and then the inner algorithm C stops declaring "second-order stationary point". if (inform .eq. 0) then inform = 2 if (iprint .ge. 3) then write(*, 984) inform write(10,984) inform end if return end if C Evaluate the quadratic model of the objective function at d. call quad(nred, dz, gz, ldh, H, diag, wd2, phi) C If the value of the quadratic model at d is 0 it means that x is a C second-order stationary point. In this case, inner algorithm stops C declaring this. if ((abs(phi) .le. phieps) .and. (gzsupn .le. epsg)) then inform = 2 if (iprint .ge. 3) then write(*, 984) inform write(10,984) inform end if return end if C Calculate predicted decrease of objective function pred = abs(phi) C Calculate direction d = Z dz and adjust it. call multZ(nind, nliact, ldabar, Abar, tau, dz, d, macheps) C Print direction if (iprint .ge. 3) then write(*, 993) min0(nind,ncomp),(d(i),i=1,min0(nind,ncomp)) write(10,993) min0(nind,ncomp),(d(i),i=1,min0(nind,ncomp)) end if C Calculate d Euclidian-norm deucn = 0.0d0 do i = 1, nind deucn = deucn + d(i)**2 end do deucn = dsqrt(deucn) C Calculate point xtrial = x + d. do i = 1, nind xtrial(i) = x(i) + d(i) end do C If the new point x + Z dz is too close to the previous point x, C inner algorithm stops samep = .true. do i = 1, nind if (abs(d(i)) .gt. macheps * max(abs(xtrial(i)),1.0d0)) then samep = .false. end if end do if (samep) then inform = 6 if (iprint .ge. 3) then write(*, 991) inform write(10,991) inform end if return end if C Verify if xtrial is inside de feasible region. If not, interior is C set to false and tmax is set to the biggest positive scalar such C that x + tmax*d is inside the feasible region. tmax = 1.0d0 rbdlu = 0 do i = 1, nind2 ii = ind2(i) if (abs(d(ii)) .ge. macheps * max(abs(x(ii)), 1.0d0)) then if (xtrial(ii) .le. l(ii)) then tmp = (l(ii) - x(ii)) / d(ii) if (tmp .lt. tmax - macheps * max(tmax, 1.0d0)) then tmax = tmp rbdlu = 1 rbdind(rbdlu) = ii else if (tmp .le. tmax + macheps * max(tmax, 1.0d0)) then rbdlu = rbdlu + 1 rbdind(rbdlu) = ii end if end if else if (xtrial(ii) .ge. u(ii)) then tmp = (u(ii) - x(ii)) / d(ii) if (tmp .lt. tmax - macheps * max(tmax, 1.0d0)) then tmax = tmp rbdlu = 1 rbdind(rbdlu) = ii + n else if (tmp .le. tmax+ macheps * max(tmax, 1.0d0)) then rbdlu = rbdlu + 1 rbdind(rbdlu) = ii + n end if end if end if end if end if end do C Look to the linear inequality constraints rbdli = rbdlu call expand(nind, ind, n, x) do i = 1, ml-nact wd5(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml ii = iact(i) wd5(i-nact) = wd5(i-nact) + A(ii,j) * x(j) end do end do call shrink(nind, ind, n, x) do i = nact+1, ml ii = iact(i) ad = 0.0d0 do j = 1, nind2 jj = ind2(j) jjj = ind(jj) ad = ad + A(ii,jjj) * d(jj) end do ax = wd5(i-nact) if (abs(ad) .ge. macheps * max(abs(ax), 1.0d0)) then if (ax + ad .le. b(ii)) then tmp = (b(ii) - ax) / ad if (tmp .lt. tmax - macheps * max(tmax, 1.0d0)) then tmax = tmp rbdlu = 0 rbdli = 1 rbdind(rbdli) = i else if (tmp .le. tmax + macheps * max(tmax, 1.0d0)) then rbdli = rbdli + 1 rbdind(rbdli) = i end if end if end if end if end do C ================================================================== C Point on the boundary C ================================================================== C If xtrial is not interior to the polytope, xtrial = x + d is C replaced by xtrial = x + tmax*d. Now xtrial is definitely interior. C Actually, it is in the boundary. If the objective function C decreases in xtrial, the inner algorithm stops with xtrial as a C solution. Otherwise, a new trust-region radius delta is chosen C (smaller than dbound) and a new quadratic model minimizer is C calculated (which is necessarily interior because of the choice C of delta). if (rbdli .gt. 0) then if (iprint .ge. 3) then write(*, *) ' x+d is not interior to the feasible set' write(10,*) ' x+d is not interior to the feasible set' end if do i = 1, nind xtrial(i) = x(i) + tmax * d(i) end do C Set x(i) to l(i) or u(i) for the indices i that got to the C boundary (to prevent errors). do i = 1, rbdlu index = rbdind(i) if (index .gt. n) then xtrial(index-n) = u(index-n) else xtrial(index) = l(index) end if end do C Check if new point xtrial is feasible. If it is infeasible, due C to numerical errors, trust-region radius delta is decreased and C new direction is computed if (checkfeas) then do i = 1, ml wd5(i) = 0.0d0 end do do i = nind+1, n xtrial(i) = x(i) end do call expand(nind, ind, n, xtrial) do j = 1, n do i = 1, ml wd5(i) = wd5(i) + A(i,j) * xtrial(j) end do end do call shrink(nind, ind, n, xtrial) if (lossfeas) then do i = 1, mleq if (abs(wd5(i) - b(i)) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do do i = mleq+1, ml if (b(i) - wd5(i) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do else do i = 1, mleq if (abs(wd5(i) - b(i)) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do do i = mleq+1, ml if (b(i) - wd5(i) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do end if checkfeas = .false. end if C Compute functional value at xtrial call calcobj(nind, ind, xtrial, n, x, ftrial, inform) fcnt = fcnt + 1 trfcnt = trfcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, *) ' f(x+d) is undefined' write(10,*) ' f(x+d) is undefined' end if delta = 2.5d-1 * deucn triter = triter + 1 go to 4 end if C Print functional value if (iprint .ge. 3) then write(*, 994) delta, ftrial, fcnt write(10,994) delta, ftrial, fcnt end if C Test whether the number of functional evaluations is exhausted if (fcnt .ge. maxfc) then do i = 1, nind x(i) = xtrial(i) end do f = ftrial call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform) gcnt = gcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 989) inform write(10,989) inform end if else inform = 8 if (iprint .ge. 3) then write(*, 987) inform write(10,987) inform end if end if return end if C Test whether f is very small if (ftrial .le. fmin) then do i = 1, nind x(i) = xtrial(i) end do f = ftrial call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform) gcnt = gcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 989) inform write(10,989) inform end if else inform = 4 if (iprint .ge. 3) then write(*, 988) inform write(10,988) inform end if end if return end if C Test if function value decreases at xtrial if ((ftrial .le. f) .or. + ((deucn .le. macheps**(2.0d0/3.0d0) * sqrt(xeucn2)) .and. + (ftrial .le. f + macheps**(2.0d0/3.0d0) * abs(f)))) then if (iprint .ge. 3) then write(*, *) ' f(x+d) < f(x), x+d is accepted' write(10,*) ' f(x+d) < f(x), x+d is accepted' end if C Update the trust-region radius (which may or may not be C used) delta = 2.0d0 * delta C Calculate actual reduction of objective function ared = f - ftrial C Update x, f and g. do i = 1, nind x(i) = xtrial(i) end do f = ftrial call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform) gcnt = gcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 989) inform write(10,989) inform end if return end if inform = 3 go to 8 else newdelta = delta tmp = delmin + msrho * ((dbound / (1.0d0 + mssig)) - delmin) delta = max(delmin, tmp) triter = triter + 1 go to 4 end if end if C ================================================================== C Point interior to the feasible region C ================================================================== C step 5: in this case xtrial is inside the polytope. Acceptance or C rejection of the trust-region subproblem solution. C Check if new point xtrial is feasible. If it is infeasible, due C to numerical errors, trust-region radius delta is decreased and C new direction is computed if (checkfeas) then do i = 1, ml wd5(i) = 0.0d0 end do do i = nind+1, n xtrial(i) = x(i) end do call expand(nind, ind, n, xtrial) do j = 1, n do i = 1, ml wd5(i) = wd5(i) + A(i,j) * xtrial(j) end do end do call shrink(nind, ind, n, xtrial) if (lossfeas) then do i = 1, mleq if (abs(wd5(i) - b(i)) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do do i = mleq+1, ml if (b(i) - wd5(i) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do else do i = 1, mleq if (abs(wd5(i) - b(i)) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do do i = mleq+1, ml if (b(i) - wd5(i) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do end if checkfeas = .false. end if C Compute functional value at xtrial call calcobj(nind, ind, xtrial, n, x, ftrial, inform) fcnt = fcnt + 1 trfcnt = trfcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, *) ' f(x+d) is undefined' write(10,*) ' f(x+d) is undefined' end if delta = 2.5d-1 * deucn triter = triter + 1 go to 4 end if C Print functional value if (iprint .ge. 3) then write(*, 994) delta, ftrial, fcnt write(10,994) delta, ftrial, fcnt end if C Test whether the number of functional evaluations is exhausted if (fcnt .ge. maxfc) then do i = 1, nind x(i) = xtrial(i) end do f = ftrial call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform) gcnt = gcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 989) inform write(10,989) inform end if else inform = 8 if (iprint .ge. 3) then write(*, 987) inform write(10,987) inform end if end if return end if C Test whether f is very small if (ftrial .le. fmin) then do i = 1, nind x(i) = xtrial(i) end do f = ftrial call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform) gcnt = gcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 989) inform write(10,989) inform end if else inform = 4 if (iprint .ge. 3) then write(*, 988) inform write(10,988) inform end if end if return end if C Calculate actual reduction of objective function ared = f - ftrial C If there is not sufficient decrease of the function, the C trust-region radius is decreased and the new quadratic model C minimizer will be calculated. if (iprint .ge. 3) then write(*, 981) deucn, pred, ared write(10,981) deucn, pred, ared end if if ((deucn .le. macheps**(2.0d0/3.0d0) * sqrt(xeucn2)) .and. + (ared .le. macheps**(2.0d0/3.0d0) * abs(f))) then do i = 1, nind x(i) = xtrial(i) end do f = ftrial call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform) gcnt = gcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 992) inform write(10,992) inform end if return end if go to 8 end if if (((pred .gt. phieps) .and. (ared .lt. alpha*pred)) .or. + ((pred .le. phieps) .and. (f .lt. ftrial))) then delta = 2.5d-1 * deucn triter = triter + 1 go to 4 end if C Point xtrial is accepted. do i = 1, nind x(i) = xtrial(i) end do f = ftrial call calcgr(nind, ind, x, n, x, g, gtype, macheps, inform) gcnt = gcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 989) inform write(10,989) inform end if return end if go to 8 C ================================================================== C Prepare for next call to this routine C ================================================================== C If new point x is in the boundary, the inner algorithm stops C and returns x as solution. 7 rbdlu = 0 do i = 1, nind2 ii = ind2(i) if (x(ii) .le. l(ii) + macheps * max(abs(l(ii)), 1.0d0)) then x(ii) = l(ii) rbdlu = rbdlu + 1 rbdind(rbdlu) = ii else if (x(ii) .ge. u(ii)-macheps*max(abs(u(ii)), 1.0d0)) then x(ii) = u(ii) rbdlu = rbdlu + 1 rbdind(rbdlu) = ii + n end if end do C Look to the linear inequality constraints rbdli = rbdlu call expand(nind, ind, n, x) do i = 1, ml-nact wd5(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml ii = iact(i) wd5(i-nact) = wd5(i-nact) + A(ii,j) * x(j) end do end do do i = nact+1, ml ii = iact(i) if (abs(wd5(i-nact)-b(ii)) .le. epscsn) then rbdli = rbdli + 1 rbdind(rbdli) = i end if end do call shrink(nind, ind, n, x) C Update the trust-region radius (which may or may not be used). C This update can only be done when the current iteration was a C trust-region iteration (and not an inner SPG one). 8 if (ittype .eq. 8) then if (ared .lt. 2.5d-1 * pred) then delta = max(2.5d-1 * deucn, delmin) else if ((ared .ge. 0.5d0 * pred) .and. + (deucn .ge. delta - macheps**(2.0d0/3.0d0) * + max(delta, 1.0d0))) then delta = max(2.0d0 * delta, delmin) else delta = max(delta, delmin) end if end if end if C Print final information if (rbdli .gt. 0) then inform = 3 if (iprint .ge. 3) then write(*, 985) inform write(10,985) inform end if else inform = 0 if (iprint .ge. 3) then write(*, 982) inform write(10,982) inform end if end if C Non-executable statements 980 format(/,6x,'inner BETRA iteration') 981 format(6x,'dnorm= ',1PD11.4,' pred= ',1PD11.4,' ared= ',1PD11.4) 982 format(6X,'Flag of inner BETRA = ',I3, + 6X,' (sufficient decrease of function)') 983 format(6X, 'Flag of inner BETRA = ',I3, + 6X,' (first-order stationary point close to the boundary)') 984 format(6x,'Flag of inner BETRA = ',I3, + ' (second-order stationary point)') 985 format(6x,'Flag of inner BETRA = ',I3, + ' (point on the boundary)') 986 format(6x,'Flag of inner BETRA = ',I3, + ' (trust-region radius delta= ',1PD11.4, ' too small)') 987 format(6x,'Flag of inner BETRA = ',I3, + ' (Too many functional evaluations)') 988 format(6x,'Flag of inner BETRA = ',I3, + ' (Small functional value, smaller than ',/, + 6X,' parameter fmin)') 989 format(6X,'Flag of inner BETRA = ',I3,' Fatal Error') 991 format(6X,'Flag of inner BETRA = ',I3, + 6X,' (Search direction too small)') 992 format(6X,'Flag of inner BETRA = ',I3, + '(PROVISORIO)') 993 format(/,6X,'Computed direction (first ',I6, ' components): ',/, + 1(6X,6(1PD11.4,1X))) 994 format(/,6X,'delta= ',1PD11.4,' F= ',1PD11.4,' FE= ',I10) end C ***************************************************************** C ***************************************************************** subroutine shrinkcol(n, m, nind, ind, ldh, H) C SCALAR ARGUMENTS integer n, m, nind, ldh C ARRAY ARGUMENTS integer ind(nind) double precision H(ldh,n) C Reduce columns of matriz H from space of dimension n to a space C of dimension nind (space of free variables). To do so, in the C first nind components of each column of H are stored the values C corresponding to the free variables and in the last n - nind C components are stored the values of the fixed variables. C C On entry C C n integer C dimension of full space C C m integer C number of rows of H C C nind integer C dimension of reduced space C C ind integer ind(nind) C free variables indices on original space C C ldh integer C leading dimension of H C C H double precision H(ldh,n) C matrix whose columns are to be reduced to a space of C smaller dimension (reduced space) C C On Return C C H double precision H(ldh,n) C matrix whose columns are reduced to a space of smaller C dimension (reduced space). The first nind columns C correspond to the free variable values and the last C n - nind correspond to the fixed variable values C LOCAL SCALARS integer i, j, jj double precision tmp if (m .eq. 0) then return end if do j = 1, nind jj = ind(j) if (j .ne. jj) then do i = 1, m tmp = H(i,j) H(i,j) = H(i,jj) H(i,jj) = tmp end do end if end do end C ***************************************************************** C ***************************************************************** subroutine shrinkrow(n, nind, ind, ldh, H) C SCALAR ARGUMENTS integer n, nind, ldh C ARRAY ARGUMENTS integer ind(nind) double precision H(ldh,n) C Reduce rows of matriz H from space of dimension n to a space C of dimension nind (space of free variables). To do so, in the C first nind components of each row of H are stored the values C corresponding to the free variables and in the last n - nind C components are stored the values of the fixed variables. C C On entry C C n integer C dimension of full space C C nind integer C dimension of reduced space C C ind integer ind(nind) C free variables indices on original space C C ldh integer C leading dimension of H C C H double precision H(ldh,n) C matrix whose rows are to be reduced to a space of C smaller dimension (reduced space) C C On Return C C H double precision H(ldh,n) C matrix whose rows are reduced to a space of smaller C dimension (reduced space). The first nind rows C correspond to the free variable values and the last C n - nind correspond to the fixed variable values C LOCAL SCALARS integer i, ii, j, jj double precision tmp do j = 1, nind jj = ind(j) do i = 1, nind ii = ind(i) if (i .ne. ii) then tmp = H(i,jj) H(i,jj) = H(ii,jj) H(ii,jj) = tmp end if end do end do end C ***************************************************************** C ***************************************************************** subroutine expandcol(n, m, nind, ind, ldh, H) C SCALAR ARGUMENTS integer n, m, nind, ldh C ARRAY ARGUMENTS integer ind(nind) double precision H(ldh,n) C Expand columns of matriz H from space of dimension nind to a C space of dimension n. This is done by rearranging columns of H C so they are exactly the way they were before using the subroutine C shrinkcol. C C On Entry C C n integer C dimension of full space C C m integer C number of rows of H C C nind integer C dimension of reduced space C C ind integer ind(nind) C free variables indices on original space C C ldh integer C leading dimension of H C C H double precision H(ldh,n) C matrix whose columns are to be expanded to a space of C higher dimension (full space) C C On Return C C H double precision H(ldh,n) C matrix whose columns are expanded to a space of higher C dimension (full space) C LOCAL SCALARS integer i, j, jj double precision tmp if (m .eq. 0) then return end if do j = nind, 1, -1 jj = ind(j) if (j .ne. jj) then do i = 1, m tmp = H(i,j) H(i,j) = H(i,jj) H(i,jj) = tmp end do end if end do end C ***************************************************************** C ***************************************************************** subroutine calchz(n, nind, ind, x, xc, nliact, ldabar, Abar, + tau, macheps, wd1, wd2, wd3, ldh, H, diag, inform) C SCALAR ARGUMENTS integer n, nind, nliact, ldabar, ldh, inform double precision macheps C ARRAY ARGUMENTS integer ind(nind) double precision x(n), xc(n), Abar(ldabar,nliact), tau(nliact), + wd1(n), wd2(n), wd3(n), H(ldh,n), diag(nind) C Evaluate Hessian H at x and compute Z^T H Z. Because x is in the C reduced space of free variables, it is not possible to simply C call subroutine evalhess. It is necessary to copy to the end of x C the values of the n - nind fixed variables (which are in the last C n - nind positions of xc), rearrange vector x so it is in the C full space, use subroutine evalhess and shrink both x and H (so C both are in the reduced space of free variables). C C On Entry C C n integer C dimension of full space C C nind integer C dimension of the space of free variables C C ind integer ind(nind) C free variables indices on original space C C x double precision x(n) C point in the reduced space where the Hessian C evaluation is required C C xc double precision xc(n) C point that constains x fixes variables in its C n - nind last positions C C nliact integer C number of linearly independent active linear C constraints C ldabar integer C leading dimension of matrix Abar C C Abar double precision Abar(ldabar,nliact) C hold the LQ factorization of the matrix whose columns C correspond to the active linear constraints, after C eliminating the elements correnponding to fixed variables C C tau double precision tau(nliact) C used to retrieve the columns of Q from Abar C C macheps double precision C machine epsilon C C wd1,wd2,wd3 double precision wd1,wd2,wd3(n) C working vectors C C ldh integer C leading dimension of matrix H C C On Return C C H double precision H(ldh,nind-nliact) C reduced Hessian at x C C diag double precision diag(nind-nliact) C diagonal elements of H C C inform integer C 0, if no problem occurs; C <0, otherwise C LOCAL SCALARS integer i, j do i = nind+1, n x(i) = xc(i) end do call expand(nind, ind, n, x) call evalhess(n, x, ldh, H, inform) call shrink(nind, ind, n, x) call shrinkrow(n, nind, ind, ldh, H) call shrinkcol(n, nind, nind, ind, ldh, H) if (nliact .eq. 0) then go to 10 end if do j = nind, 1, -1 do i = 1, j-1 wd3(i) = H(j,i) end do do i = j, nind wd3(i) = H(i,j) end do call multZT(nind, nliact, ldabar, Abar, tau, wd3, wd1, wd2, + macheps) do i = 1, nind-nliact H(i,j) = wd2(i) end do end do do i = 1, nind-nliact do j = 1, nind wd3(j) = H(i,j) end do call multZT(nind, nliact, ldabar, Abar, tau, wd3, wd1, wd2, + macheps) do j = 1, nind-nliact H(i,j) = wd2(j) end do end do 10 continue do i = 1, nind-nliact diag(i) = H(i,i) end do end C ****************************************************************** C ****************************************************************** subroutine quad(nred, x, g, ldh, H, diag, wd, phi) C SCALAR ARGUMENTS integer nred, ldh double precision phi C ARRAY ARGUMENTS double precision x(nred), g(nred), H(ldh,nred), diag(nred), + wd(nred) C Evaluate the quadratic model phi(x) = 1/2 x^T H x + g^T x. C C On Entry C C nred integer C dimension of the reduced space C C x double precision x(nred) C point where the quadratic model is to be calculated C C g double precision g(nred) C vector used to define the quadratic model C (see comment above) C C ldh integer C leading dimension of matrix H C C H double precision H(ldh,nred) C symmetric lower triangular matrix used to define the C quadratic model (see comment above) C C diag double precision diag(nred) C diagonal of matrix H C C wd double precision wd(nred) C working vector C C On Return C C phi double precision C quadratic model value at x C LOCAL SCALARS integer i, j do i = 1, nred wd(i) = 0.0d0 end do do j = 1, nred do i = 1, j-1 wd(i) = wd(i) + H(j,i) * x(j) end do wd(i) = wd(i) + diag(i) * x(j) do i = j+1, nred wd(i) = wd(i) + H(i,j) * x(j) end do end do phi = 0.0d0 do i = 1, nred phi = phi + wd(i) * x(i) end do phi = phi * 0.5d0 do i = 1, nred phi = phi + g(i) * x(i) end do end C ****************************************************************** C ****************************************************************** subroutine ispgls(n, nind, ind, nind2, ind2, x, f, g, l, u, ml, + mleq, lda, A, b, nact, iact, lamspg, etaint, mininterp, fmin, + maxfc, iprint, xtrial, alpha, d, gamma, sigma1, sigma2, + lossfeas, epscsn, projeps, promaxit, macheps, wi1, wd1, wd2, + lwd2, wd3, bbar, fcnt, iterql, inform) C SCALAR ARGUMENTS logical lossfeas integer n, nind, nind2, ml, mleq, lda, nact, mininterp, maxfc, + iprint, promaxit, lwd2, fcnt, iterql, inform double precision f, lamspg, etaint, fmin, alpha, gamma, sigma1, + sigma2, epscsn, projeps, macheps C ARRAY ARGUMENTS integer ind(nind), ind2(nind), iact(ml), wi1(2*n+ml) double precision x(n), g(nind), l(n), u(n), A(lda,n), b(ml), + xtrial(n), d(nind), wd1(n), wd2(lwd2), wd3(n), bbar(ml) C Internal Spectral Projected Gradient method. C C On Entry C C n integer C the order of the x C C nind integer C dimension of reduced space C C ind integer ind(nind) C free variables indices on original space C C nind2 integer C dimension of reduced space C C ind2 integer ind2(nind2) C truely free variables indices on original space C C x double precision x(n) C current point C C f double precision C function value at the current point C C g double precision g(n) C gradient vector at the current point C C l double precision l(n) C lower bounds C C u double precision u(n) C upper bounds C C ml integer C total number of linear constraints (excluding bounds) C C mleq integer C number of linear equality constraints (excluding bounds) C C lda integer C leading dimension of matrix A C C A double precision A(lda,n) C coeficients of linear constraints, each row reduced to C the space of truely free variables C C b double precision b(ml) C constant part of linear constraints C C nact integer C number of active linear constraints C C nliact integer C number of linearly independent active linear C constraints C C iact integer iact(ml) C indices of the active linear constraints. The last C m - nact positions of iact store the identifier of the C non-active linear constraints. C C lamspg double precision C spectral steplength C C etaint double precision C constant for the interpolation. See the description of C sigma1 and sigma2 above. Sometimes we take as a new C trial step the previous one divided by etaint C C RECOMMENDED: etaint = 2.0 C C mininterp integer C constant for testing if, after having made at least C mininterp interpolations, the steplength is so small. In C that case failure of the line search is declared (may be C the direction is not a descent direction due to an error C in the gradient calculations) C C RECOMMENDED: mininterp = 4 C C fmin double precision C functional value for the stopping criterion f <= fmin C C maxfc integer C maximum number of functional evaluations C C iprint integer C Commands printing. Nothing is printed if iprint is C smaller than 3. C C RECOMMENDED: iprint = 2 C C CONSTRAINTS: allowed values are just 2 or 3. C C xtrial double precision xtrial(n) C d double precision d(n) C working vectors C C gamma double precision C constant for the Armijo criterion C f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d> C C RECOMMENDED: gamma = 10^{-4} C C sigma1 double precision C sigma2 double precision C constant for the safeguarded interpolation C if alpha_new \notin [sigma1, sigma2*alpha] then we take C alpha_new = alpha / etaint C C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 C C lossfeas logical C if a loss of feasibility up to sqrt(epsfeas) is allowed C during the computations, lossfeas must be set to TRUE C (recommended). In this case, if the final iterate does C not satisfy the constraints with the desired precision, C we sugest that the user re-run the method using the final C point obtained as the initial point, using C lossfeas = FALSE C C epscsn double precision C feasibility tolerance for the sup-norm of the linear C constraints C C projeps double precision C precision used in projection routine C C promaxit integer C maximum allowed number of iterations of QL routine used C in projection C C macheps double precision C macheps is the smallest positive number such that C 1 + macheps is not equal to 1 C C wi1 integer wi1(2*n+ml) C wd1 double precision wd1(n) C wd2 double precision wd2(lwd2) C wd3 double precision wd3(n) C bbar double precision bbar(ml) C working vectors C C On Return C C x double precision C final estimation of the solution C C f double precision C functional value at the final estimation C C alpha double precision C step lenght, such that x = x + alpha * d C C fcnt integer C number of functional evaluations C C iterql integer C number of calls to QL routine (used in projection) C C inform integer C This output parameter tells what happened in this C subroutine, according to the following conventions: C C 0 = convergence with an Armijo-like criterion C (f(xnew) <= f(x) + gamma * alpha * ); C C 4 = the algorithm stopped because the functional value C is smaller than fmin; C C 6 = too small step in the line search. After having made C at least mininterp interpolations, the steplength C becomes small. ''small steplength'' means that we are C at point x with direction d and step alpha, and, for C all i, C C | alpha * d(i) | <= macheps * max (|x(i)|, 1,0d0 ). C C In that case failure of the line search is declared C (maybe the direction is not a descent direction due C to an error in the gradient calculations). Use C mininterp > maxfc to inhibit this criterion; C C 8 = it was achieved the maximum allowed number of C function evaluations (maxfc); C C 10 = problem in projection subroutine. x is not modified; C C -90 = means that subroutine evalf retuned an error flag. C LOCAL SCALARS logical samep integer i, ii, j, interp double precision atmp, ftrial, gtd, dsupn, xsupn, tmp C Print presentation information if (iprint .ge. 3) then write(*, 980) lamspg write(10,980) lamspg end if C Initialization interp = 0 C Compute first trial point, spectral projected gradient direction, C and directional derivative . alpha = 1.0d0 do i = 1, nind2 xtrial(i) = x(i) - lamspg * g(i) end do do i = nind2+1, nind xtrial(i) = x(i) end do C Move all active linear constraints to the first rows of A. C Do the same with b. do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Calculate bbar = b - A_i*x_i, where x_i is a fixed variable C and A_i is the corresponding i-th column of A. do i = 1, ml bbar(i) = b(i) end do do j = nind2+1, n do i = 1, ml bbar(i) = bbar(i) - A(i,j) * x(j) end do end do C Project. call project(nind2, xtrial, l, u, ml, nact, lda, A, bbar, + promaxit, projeps, lossfeas, epscsn, tmp, macheps, wi1, wd1, + wd2, lwd2, wd3, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then inform = 10 if (iprint .ge. 3) then write(*, 988) inform write(10,988) inform end if return end if gtd = 0.0d0 dsupn = 0.0d0 xsupn = 0.0d0 do i = 1, nind2 d(i) = xtrial(i) - x(i) gtd = gtd + g(i) * d(i) dsupn = max(dsupn, abs(d(i))) xsupn = max(xsupn, abs(x(i))) end do interp = 0 90 continue if (nind .ne. nind2) then call expand(nind2, ind2, nind, xtrial) call expand(nind2, ind2, nind, x) end if call calcobj(nind, ind, xtrial, n, x, ftrial, inform) if (nind .ne. nind2) then call shrink(nind2, ind2, nind, xtrial) call shrink(nind2, ind2, nind, x) end if fcnt = fcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 981) alpha, ftrial, fcnt write(10,981) alpha, ftrial, fcnt end if if ( iprint .ge. 3 ) then write(*, *) ' f(x+d) is undefined.' write(*, *) ' Will interpolate.' write(10,*) ' f(x+d) is undefined.' write(10,*) ' Will interpolate.' end if C Compute new trial point interp = interp + 1 alpha = alpha / etaint do i = 1, nind2 xtrial(i) = x(i) + alpha * d(i) end do C Test whether direction d is too small samep = .true. do i = 1, nind2 if (abs(alpha * d(i)) .gt. macheps * + max(abs(x(i)),1.0d0)) then samep = .false. end if end do if (samep) then inform = 6 if (iprint .ge. 3) then write(*, 984) inform write(10,984) inform end if go to 500 end if go to 90 end if C Print information of the first trial if (iprint .ge. 3) then write(*, 981) alpha, ftrial, fcnt write(10,981) alpha, ftrial, fcnt end if C Main loop 100 continue C Test whether f is very small if (ftrial .le. fmin) then f = ftrial do i = 1, nind2 x(i) = xtrial(i) end do inform = 4 if (iprint .ge. 3) then write(*, 983) inform write(10,983) inform end if go to 500 end if C Test Armijo stopping criterion if (ftrial .le. f + gamma * alpha * gtd) then f = ftrial do i = 1, nind2 x(i) = xtrial(i) end do inform = 0 if (iprint .ge. 3) then write(*, 982) inform write(10,982) inform end if go to 500 end if if ( alpha * dsupn .le. macheps**(2.0d0/3.0d0) * xsupn .and. + ftrial - f .le. macheps**(2.0d0/3.0d0) * abs(f) ) then f = ftrial do i = 1, nind2 x(i) = xtrial(i) end do inform = 0 if ( iprint .ge. 3 ) then write(*, 987) inform write(10,987) inform end if go to 500 end if C Compute new step (safeguarded quadratic interpolation) atmp = (- gtd * alpha**2) / + (2.0d0 * (ftrial - f - alpha * gtd)) if ((atmp .lt. sigma1 * alpha) + .or. (atmp .gt. sigma2 * alpha)) then alpha = alpha / etaint else alpha = atmp end if interp = interp + 1 C Test whether direction d is too small samep = .true. do i = 1, nind2 if (abs(alpha * d(i)) .gt. macheps * max(abs(x(i)),1.0d0)) then samep = .false. end if end do if ((interp .ge. mininterp) .and. samep) then if (ftrial .lt. f) then f = ftrial do i = 1, nind2 x(i) = xtrial(i) end do end if inform = 6 if (iprint .ge. 3) then write(*, 984) inform write(10,984) inform end if go to 500 end if C Compute new trial point do i = 1, nind2 xtrial(i) = x(i) + alpha * d(i) end do if (nind .ne. nind2) then call expand(nind2, ind2, nind, xtrial) call expand(nind2, ind2, nind, x) end if call calcobj(nind, ind, xtrial, n, x, ftrial, inform) if (nind .ne. nind2) then call shrink(nind2, ind2, nind, xtrial) call shrink(nind2, ind2, nind, x) end if fcnt = fcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 986) inform write(10,986) inform end if return end if C Print information of the current trial if (iprint .ge. 3) then write(*, 981) alpha, ftrial, fcnt write(10,981) alpha, ftrial, fcnt end if C Test whether the number of functional evaluations is exhausted if (fcnt .ge. maxfc) then if (ftrial .lt. f) then f = ftrial do i = 1, nind2 x(i) = xtrial(i) end do end if inform = 8 if (iprint .ge. 3) then write(*, 985) inform write(10,985) inform end if go to 500 end if C Check if the solution is feasible. do i = 1, ml wd2(i) = 0.0d0 end do do j = 1, nind2 do i = 1, ml wd2(i) = wd2(i) + A(i,j) * xtrial(j) end do end do if (lossfeas) then do i = 1, mleq if (abs(wd2(i) - bbar(i)) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do do i = mleq+1, ml if (bbar(i) - wd2(i) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do else do i = 1, mleq if (abs(wd2(i) - bbar(i)) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do do i = mleq+1, ml if (bbar(i) - wd2(i) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do end if C Iterate go to 100 C Return 500 continue return C Non-executable statements 980 format(/,6x,'SPG (spectral steplength ',1PD11.4,')',/,/, + 6x,'SPG Line search') 981 format(6x,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I10) 982 format(6x,'Flag of SPG Line search = ',I3, + ' (Armijo-like criterion satisfied)') 983 format(6x,'Flag of SPG Line search = ',I3, + ' (Small functional value, smaller than ',/, + 6X,'parameter fmin)') 984 format(6x,'Flag of SPG Line search = ',I3, + ' (Too small step in the interpolation)') 985 format(6x,'Flag of SPG Line search = ',I3, + ' (Too many functional evaluations)') 986 format(6X,'Flag of SPG Line search = ',I3,' Fatal Error') 987 format(6X,'Flag of SPG Line search = ',I3, + '(PROVISORIO)') 988 format(6X,'Flag of SPG Line search = ',I3, + ' (Problem in projection routine)') end C ****************************************************************** C ****************************************************************** subroutine pspgls(n, x, f, g, l, u, ml, mleq, lda, A, b, nact, + iact, inorder, tolact, lamspg, etaint, mininterp, fmin, + maxfc, iprint, xtrial, alpha, gotd, d, gamma, sigma1, sigma2, + lossfeas, epscsn, projeps, promaxit, macheps, toldgp, wi1, + wd1, wd2, lwd2, wd3, wd4, fcnt, intnan, iterql, inform) C SCALAR ARGUMENTS logical inorder, gotd, lossfeas integer n, ml, mleq, lda, nact, tolact, mininterp, maxfc, + iprint, promaxit, lwd2, fcnt, intnan, iterql, inform double precision f, lamspg, etaint, fmin, alpha, gamma, sigma1, + sigma2, epscsn, projeps, macheps, toldgp C ARRAY ARGUMENTS integer iact(ml), wi1(2*n+ml) double precision x(n), g(n), l(n), u(n), A(lda,n), b(ml), + xtrial(n), d(n), wd1(n), wd2(lwd2), wd3(ml), wd4(n) C Internal Spectral Projected Gradient method. C C On Entry C C n integer C the order of the x C C x double precision x(n) C current point C C f double precision C function value at the current point C C g double precision g(n) C gradient vector at the current point C C l double precision l(n) C lower bounds C C u double precision u(n) C upper bounds C C ml integer C total number of linear constraints (excluding bounds) C C mleq integer C number of linear equality constraints (excluding bounds) C C lda integer C leading dimension of matrix A C C A double precision A(lda,n) C coeficients of linear constraints C C b double precision b(ml) C constant part of linear constraints C C nact integer C number of active linear constraints C C nliact integer C number of linearly independent active linear C constraints C C iact integer iact(ml) C indices of the active linear constraints. The last C m - nact positions of iact store the identifier of the C non-active linear constraints. C C inorder logical C true iff constraints are already in order: equality C constraints in the begging, then active constraints, then C "nearly active" constraints and then the rest C C tolact integer C if inorder is true, tolact must store the position where C the last "nearly active" constraint is stored, that is, C tolact stores the total number of equality, active and C "nearly active" constraints C C lamspg double precision C spectral steplength C C etaint double precision C constant for the interpolation. See the description of C sigma1 and sigma2 above. Sometimes we take as a new C trial step the previous one divided by etaint C C RECOMMENDED: etaint = 2.0 C C mininterp integer C constant for testing if, after having made at least C mininterp interpolations, the steplength is so small. In C that case failure of the line search is declared (may be C the direction is not a descent direction due to an error C in the gradient calculations) C C RECOMMENDED: mininterp = 4 C C fmin double precision C functional value for the stopping criterion f <= fmin C C maxfc integer C maximum number of functional evaluations C C iprint integer C Commands printing. Nothing is printed if iprint is C smaller than 3. C C RECOMMENDED: iprint = 2 C C CONSTRAINTS: allowed values are just 2 or 3. C C xtrial double precision xtrial(n) C d double precision d(n) C working vectors C C gotd logical C true iff direction d has already been computed C C gamma double precision C constant for the Armijo criterion C f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d> C C RECOMMENDED: gamma = 10^{-4} C C sigma1 double precision C sigma2 double precision C constant for the safeguarded interpolation C if alpha_new \notin [sigma1, sigma2*alpha] then we take C alpha_new = alpha / etaint C C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 C C lossfeas logical C if a loss of feasibility up to sqrt(epsfeas) is allowed C during the computations, lossfeas must be set to TRUE C (recommended). In this case, if the final iterate does C not satisfy the constraints with the desired precision, C we sugest that the user re-run the method using the final C point obtained as the initial point, using C lossfeas = FALSE C C epscsn double precision C feasibility tolerance for the sup-norm of the linear C constraints C C projeps double precision C precision used in projection routine C C promaxit integer C maximum allowed number of iterations of QL routine used C in projection C C macheps double precision C macheps is the smallest positive number such that C 1 + macheps is not equal to 1 C C toldgp double precision C only linear constraints i that satisfy C Ai x - bi <= toldgp*max(1,|bi|) are used in projection C to compute direction d C C wi1 integer wi1(2*n+ml) C wd1 double precision wd1(n) C wd2 double precision wd2(lwd2) C wd3 double precision wd3(ml) C wd4 double precision wd4(n) C working vectors C C intnan integer C maximum number of times the routine should try to recover C from an error occured during the objective function C evaluation C C On Return C C x double precision C final estimation of the solution C C f double precision C functional value at the final estimation C C alpha double precision C step lenght, such that x = x + alpha * d C C fcnt integer C number of functional evaluations C C iterql integer C number of calls to QL routine (used in projection) C C inform integer C This output parameter tells what happened in this C subroutine, according to the following conventions: C C 0 = convergence with an Armijo-like criterion C (f(xnew) <= f(x) + gamma * alpha * ); C C 4 = the algorithm stopped because the functional value C is smaller than fmin; C C 6 = too small step in the line search. After having made C at least mininterp interpolations, the steplength C becomes small. ''small steplength'' means that we are C at point x with direction d and step alpha, and, for C all i, C C | alpha * d(i) | <= macheps * max (|x(i)|, 1,0d0 ). C C In that case failure of the line search is declared C (maybe the direction is not a descent direction due C to an error in the gradient calculations). Use C mininterp > maxfc to inhibit this criterion; C C 8 = it was achieved the maximum allowed number of C function evaluations (maxfc); C C 10 = problem in projection subroutine. x is not modified; C C -90 = means that subroutine evalf retuned an error flag. C LOCAL SCALARS logical samep integer i, ii, j, interp double precision atmp, ftrial, gtd, dsupn, xsupn, tmp, maxstp, ax, + ad C Print presentation information if (iprint .ge. 3) then write(*, 980) lamspg write(10,980) lamspg end if C Initialization interp = 0 C If direction d has already been calculated, skip first part. if (gotd) then go to 10 end if C Compute spectral discontinuous projected gradient direction. do i = 1, n d(i) = x(i) - lamspg * g(i) end do if (.not. inorder) then C Move all active linear constraints to the first rows of A. C Do the same with b. do j = 1, n do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end if end do end do do i = mleq+1, nact ii = iact(i) if (i .ne. ii) then tmp = b(i) b(i) = b(ii) b(ii) = tmp end if end do C Change indices of active constraints. do i = mleq+1, nact iact(i) = i end do do i = nact+1, ml iact(i) = ml + nact + 1 - i end do C Move all "almost" active linear constraints to the first rows C of A. Do the same with b. tolact = nact do i = nact+1, ml wd3(i) = 0.0d0 end do do j = 1, n do i = nact+1, ml wd3(i) = wd3(i) + A(i,j) * x(j) end do end do do i = nact+1, ml ax = wd3(i) if (ax - b(i) .le. toldgp*max(1.0d0,abs(b(i)))) then tolact = tolact + 1 ii = tolact if (i .ne. ii) then do j = 1, n tmp = A(i,j) A(i,j) = A(ii,j) A(ii,j) = tmp end do tmp = b(i) b(i) = b(ii) b(ii) = tmp tmp = wd3(i) wd3(i) = wd3(ii) wd3(ii) = tmp end if end if end do end if C Use only active constraits to project call project(n, d, l, u, tolact, mleq, lda, A, b, promaxit, + projeps, lossfeas, epscsn, tmp, macheps, wi1, wd1, wd2, lwd2, + wd4, iterql, inform) if ((inform .lt. 0) .or. (inform .eq. 2)) then inform = 10 if (iprint .ge. 3) then write(*, 988) inform write(10,988) inform end if return end if do i = 1, n d(i) = d(i) - x(i) end do C Compute maximum step. do i = tolact+1, ml wd2(i) = 0.0d0 end do do j = 1, n do i = tolact+1, ml wd2(i) = wd2(i) + A(i,j) * d(j) end do end do maxstp = 1.0d0 do i = tolact+1, ml ad = wd2(i) ax = wd3(i) if (ad .lt. 0.0d0) then maxstp = min(maxstp, (b(i) - ax) / ad) end if end do do i = 1, n d(i) = maxstp * d(i) end do if (maxstp .le. 0.1d0) then if (toldgp .lt. 1.0d+99) then toldgp = toldgp*1.0d2 end if end if C Compute first point xtrial, g^td and norms of x and d. 10 continue alpha = 1.0d0 gtd = 0.0d0 dsupn = 0.0d0 xsupn = 0.0d0 do i = 1, n xtrial(i) = x(i) + d(i) gtd = gtd + g(i) * d(i) dsupn = max(dsupn, abs(d(i))) xsupn = max(xsupn, abs(x(i))) end do interp = 0 90 continue call evalobj(n, xtrial, ftrial, inform) fcnt = fcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 981) alpha, ftrial, fcnt write(10,981) alpha, ftrial, fcnt end if if ( intnan .gt. 100 ) then if ( iprint .ge. 3 ) then write(*, *) ' f(x+d) is undefined. PSPG will stop.' write(10,*) ' f(x+d) is undefined. PSPG will stop.' end if return end if if ( interp .gt. 4 ) then if ( iprint .ge. 3 ) then write(*, *) ' f(x+d) is undefined after 4' write(*, *) ' interpolations. PSPG will stop.' write(10,*) ' f(x+d) is undefined after 4' write(10,*) ' interpolations. PSPG will stop.' end if intnan = intnan + 1 return end if if ( iprint .ge. 3 ) then write(*, *) ' f(x+d) is undefined.' write(*, *) ' Will interpolate.' write(10,*) ' f(x+d) is undefined.' write(10,*) ' Will interpolate.' end if C Compute new trial point interp = interp + 1 alpha = alpha / etaint do i = 1, n xtrial(i) = x(i) + alpha * d(i) end do C Test whether direction d is too small samep = .true. do i = 1, n if (abs(alpha * d(i)) .gt. macheps * + max(abs(x(i)),1.0d0)) then samep = .false. end if end do if (samep) then inform = 6 if (iprint .ge. 3) then write(*, 984) inform write(10,984) inform end if go to 500 end if go to 90 end if if (interp .gt. 0) then intnan = intnan + 1 end if C Print information of the first trial if (iprint .ge. 3) then write(*, 981) alpha, ftrial, fcnt write(10,981) alpha, ftrial, fcnt end if C Main loop 100 continue C Test whether f is very small if (ftrial .le. fmin) then f = ftrial do i = 1, n x(i) = xtrial(i) end do inform = 4 if (iprint .ge. 3) then write(*, 983) inform write(10,983) inform end if go to 500 end if C Test Armijo stopping criterion if (ftrial .le. f + gamma * alpha * gtd) then f = ftrial do i = 1, n x(i) = xtrial(i) end do inform = 0 if (iprint .ge. 3) then write(*, 982) inform write(10,982) inform end if go to 500 end if if ( alpha * dsupn .le. macheps**(2.0d0/3.0d0) * xsupn .and. + ftrial - f .le. macheps**(2.0d0/3.0d0) * abs(f) ) then f = ftrial do i = 1,n x(i) = xtrial(i) end do inform = 0 if ( iprint .ge. 3 ) then write(*, 987) inform write(10,987) inform end if go to 500 end if C Compute new step (safeguarded quadratic interpolation) atmp = (- gtd * alpha**2) / + (2.0d0 * (ftrial - f - alpha * gtd)) if ((atmp .lt. sigma1 * alpha) .or. + (atmp .gt. sigma2 * alpha)) then alpha = alpha / etaint else alpha = atmp end if interp = interp + 1 C Test whether direction d is too small samep = .true. do i = 1, n if (abs(alpha * d(i)) .gt. macheps * max(abs(x(i)),1.0d0)) then samep = .false. end if end do if ((interp .ge. mininterp) .and. samep) then if (ftrial .lt. f) then f = ftrial do i = 1, n x(i) = xtrial(i) end do end if inform = 6 if (iprint .ge. 3) then write(*, 984) inform write(10,984) inform end if go to 500 end if C Compute new trial point do i = 1, n xtrial(i) = x(i) + alpha * d(i) end do call evalobj(n, xtrial, ftrial, inform) fcnt = fcnt + 1 if (inform .lt. 0) then if (iprint .ge. 3) then write(*, 986) inform write(10,986) inform end if return end if C Print information of the current trial if (iprint .ge. 3) then write(*, 981) alpha, ftrial, fcnt write(10,981) alpha, ftrial, fcnt end if C Test whether the number of functional evaluations is exhausted if (fcnt .ge. maxfc) then if (ftrial .lt. f) then f = ftrial do i = 1, n x(i) = xtrial(i) end do end if inform = 8 if (iprint .ge. 3) then write(*, 985) inform write(10,985) inform end if go to 500 end if C Check if the solution is feasible. do i = 1, ml wd2(i) = 0.0d0 end do do j = 1, n do i = 1, ml wd2(i) = wd2(i) + A(i,j) * xtrial(j) end do end do if (lossfeas) then do i = 1, mleq if (abs(wd2(i) - b(i)) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do do i = mleq+1, ml if (b(i) - wd2(i) .gt. sqrt(epscsn)) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do else do i = 1, mleq if (abs(wd2(i) - b(i)) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do do i = mleq+1, ml if (b(i) - wd2(i) .gt. epscsn) then if (iprint .ge. 3) then write(*, *) ' x+d is infeasible' write(10,*) ' x+d is infeasible' end if inform = 10 return end if end do end if C Iterate go to 100 C Return 500 continue return C Non-executable statements 980 format(/,6x,'PSPG (spectral steplength ',1PD11.4,')',/,/, + 6x,'PSPG Line search') 981 format(6x,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I10) 982 format(6x,'Flag of PSPG Line search = ',I3, + ' (Armijo-like criterion satisfied)') 983 format(6x,'Flag of PSPG Line search = ',I3, + ' (Small functional value, smaller than ',/, + 6X,'parameter fmin)') 984 format(6x,'Flag of PSPG Line search = ',I3, + ' (Too small step in the interpolation)') 985 format(6x,'Flag of PSPG Line search = ',I3, + ' (Too many functional evaluations)') 986 format(6X,'Flag of PSPG Line search = ',I3,' Fatal Error') 987 format(6X,'Flag of PSPG Line search = ',I3, + '(PROVISORIO)') 988 format(6X,'Flag of PSPG Line search = ',I3, + ' (Problem in projection routine)') end C ****************************************************************** C ****************************************************************** subroutine dogleg(n, g, ldh, H, diag, pd, delta, macheps, pu, p, + inform) C SCALAR ARGUMENTS logical pd integer n, ldh, inform double precision delta, macheps C ARRAY ARGUMENTS double precision g(n), H(ldh,n), diag(n), pu(n), p(n) C Compute approximate minimizer of the quadratic model using Dogleg C method when the Hessian is positive definite and Cauchy point C otherwise. C On Entry C C n integer C dimension C C g double precision g(n) C vector used to define the quadratic function C C ldh integer C leading dimension of matrix H C C H double precision H(ldh,n) C symmetric n x n matrix used to define the quadratic C function. Just the lower triangular portion must be C defined. Both the upper triangular portion and the C diagonal will be modified to store the Cholesky C decomposition of (B + lI) = R^TR C C diag double precision diag(n) C diagonal of matrix H C C pd logical C indicates if the last Cholesky decomposition of MEQB was C successfull. That is, if the last matrix used by MEQB was C positive definite C C delta double precision C trust-region radius C C macheps double precision C machine epsilon C C pu double precision pu(n) C working array C C On Return C C p double precision p(n) C solution to problem C minimize psi(w) C subjected to ||w|| <= delta C C inform integer C This output parameter tells what happened in this C subroutine, according to the following conventions: C C 0 = successfull exit. Both H and g are null; C C 1 = successfull exit; C LOCAL SCALARS integer i, j double precision pueucn, pueucn2, pbeucn2, geucn, geucn2, gthg, + coef, putpb, a, b, c, d, r, delta2 inform = 1 delta2 = delta**2 C If H is not positive definite, compute Cauchy point if (.not. pd) then go to 100 end if pbeucn2 = 0.0d0 do i = 1, n pbeucn2 = pbeucn2 + p(i)**2 end do c If Newton step is inside the trust region, this step is taken if (pbeucn2 .le. delta2) then go to 999 end if C If Newton step is outside the trust region, compute the C unconstrained minimizer pu of the quadratic function C Compute g^T H g do i = 1, n pu(i) = 0.0d0 end do do j = 1, n pu(j) = pu(j) + diag(j) * g(j) do i = j+1, n pu(i) = pu(i) + H(i,j) * g(j) end do end do gthg = 0.0d0 do i = 1, n gthg = gthg + pu(i)**2 end do C Compute g^T g. geucn2 = 0.0d0 do i = 1, n geucn2 = geucn2 + g(i)**2 end do C Compute pu = coef * g. coef = - geucn2 / gthg do i = 1, n pu(i) = coef * g(i) end do C If uncontrained minimizer is outside the trust region, it is C truncated at the border pueucn2 = 0.0d0 do i = 1, n pueucn2 = pueucn2 + pu(i)**2 end do pueucn = sqrt(pueucn2) if (pueucn2 .ge. delta2) then r = delta / pueucn do i = 1, n p(i) = r * pu(i) end do go to 999 end if C Compute step length in directions pu and pb. Direction p is a C linear combination of pu and pb. To compute the step length in C each direction, we have to solve (in r): C \| pu + (r - 1) (pb - pu) \|^2 = delta^2. putpb = 0.0d0 do i = 1, n putpb = putpb + pu(i) * p(i) end do a = pbeucn2 + pueucn2 - 2.0d0 * putpb b = - 2.0d0 * pbeucn2 - 4.0d0 * pueucn2 + 6.0d0 * putpb c = pbeucn2 + 4.0d0 * pueucn2 - 4.0d0 * putpb - (delta**2) d = b**2 - 4.0d0 * a * c if ((2.0d0 * abs(a) .lt. macheps**(2.0d0/3.0d0)) .or. + (d .lt. 0.0d0)) then go to 200 end if r = (- b + sqrt(d)) / (2.0d0 * a) if ((r .lt. 1.0d0) .or. (r .gt. 2.0d0)) then r = (- b - sqrt(d)) / (2.0d0 * a) end if r = r - 1.0d0 do i = 1, n p(i) = r * p(i) + (1.0d0 - r) * pu(i) end do go to 999 C Compute Cauchy point, when H is not positive definite 100 continue C Compute g^T H g do i = 1, n pu(i) = 0.0d0 end do do j = 1, n pu(j) = pu(j) + diag(j) * g(j) do i = j+1, n pu(i) = pu(i) + H(i,j) * g(j) end do end do gthg = 0.0d0 do i = 1, n gthg = gthg + pu(i)**2 end do C Compute g^T g geucn2 = 0.0d0 do i = 1, n geucn2 = geucn2 + g(i)**2 end do geucn = sqrt(geucn2) c Compute step length coef 200 if ((abs(gthg) .le. macheps**(2.0d0/3.0d0)) .and. + (geucn .le. macheps**(2.0d0/3.0d0))) then inform = 0 return end if if ((gthg .le. 0.0d0) .or. (geucn2*geucn .lt. delta*gthg)) then coef = - delta / geucn else coef = - geucn2 / gthg end if c Compute p = coef * g do i = 1, n p(i) = coef * g(i) end do 999 end C ****************************************************************** C ****************************************************************** subroutine MEQB(n, g, ldb, B, diag, delta, sigma1, sigma2, eps, + macheps, maxit, iprint, t, z, wd1, l, pd, p, chcnt, inform) C SCALAR ARGUMENTS logical pd integer n, ldb, maxit, iprint, chcnt, inform double precision delta, sigma1, sigma2, eps, macheps, l C ARRAY ARGUMENTS double precision g(n), B(ldb,n), diag(n), t(n), z(n), wd1(n), p(n) C Method to minimize quadratic functions subjected to ||w|| <= delta C C minimize psi(w) = 1/2 w^TBw + g^Tw C subject to ||w|| <= delta C C Method described in "Computing a trust region step", by More and C Sorensen. C C The main ideia of this method is to find a positive scalar \mslamb C that is a zero of the function C C phi(\mslamb) = 1/||p|| - 1/delta, C C where p is the solution of the linear system C C (B + \mslamb I)p = -g. C C Note that symmetric matrix B, vector g and positive real number C delta are presented in the minimization problem above. I is the C identity matrix. C C The method used to find the zero of that function is basically the C Newton method to find roots. C C On Entry C C n integer C dimension C C g double precision g(n) C vector used to define the quadratic function C C ldb integer C leading dimension of matrix B C C B double precision B(ldb,n) C symmetric n x n matrix used to define the quadratic C function. Just the lower triangular portion must be C defined. Both the upper triangular portion and the C diagonal will be modified to store the Cholesky C decomposition of (B + lI) = R^TR C C diag double precision diag(n) C diagonal of matrix B C C delta double precision C trust-region radius C C sigma1 double precision C allowed error for convergence criteria 1 and 2 C C sigma2 double precision C allowed error for convergence criteria 3 (hard case) C C eps double precision C allowed error C C macheps double precision C machine epsilon C C maxit integer C maximum number of allowed iterations C C iprint integer C data printing options: C C -1 = nothing is printed; C C 0 = just the data from final iteration is printed; C C >0 = data obtained at each iprint iterations is printed C C t double precision t(n) C z double precision z(n) C wd1 double precision wd1(n) C working vectors C C l double precision C initial value for mslamb C C On Return C C p double precision p(n) C solution to problem C minimize psi(w) C subjected to ||w|| <= delta C C l double precision C value that gives p as a solution to the minimization C problem, because p is also solution to C (B + l I)p = -g C C pd logical C set to true if the last Cholesky decomposition is C successfull C C chcnt integer C number of Cholesky decompositions C C inform integer C stores which convergence criteria was satisfied: C C 0 = both g and B are null; C C 1 = first convergence criterion is satisfied; C C 2 = second convergence criterion is satisfied; C C 3 = third convergence criterion is satisfied C C 5 = maximum allowed number of iterations is achieved; C LOCAL SCALARS integer i, j, idx, iter double precision ll, lu, ls, teucn2, peunc, peunc2, geucn, b1n, + tmp, d, ueucn2, rpeucn2, rzeucn2, tau, ptz, delta2, sgn, + luant, llant, lsant delta2 = delta**2 inform = -1 C step 1: initialize ls (lower bound on l) with max{-bii}, where bii C are the elements of the diagonal of B ls = -diag(1) do i = 2, n if (-diag(i) .gt. ls) then ls = -diag(i) end if end do C Calculate ||B||1, B dense b1n = 0.0d0 do j = 1, n tmp = 0.0d0 do i = 1, j-1 tmp = tmp + abs(B(j,i)) end do tmp = tmp + abs(diag(i)) do i = j+1, n tmp = tmp + abs(B(i,j)) end do if (tmp .gt. b1n) then b1n = tmp end if end do C step 2: initialize ll (lower bound on l) with C max{0, ls, ||g||/delta - ||B||1}, where ||B||1 is the C 1-norm of the matrix B geucn = 0.0d0 do i = 1, n geucn = geucn + g(i)**2 end do geucn = dsqrt(geucn) ll = (geucn / delta) - b1n ll = max(0.0d0, ll) ll = max(ls, ll) C step 3: initialize lu (upper bound on l) with ||g||/delta + ||B||1 lu = (geucn / delta) + b1n C If the matrix is null, there is nothing to be done if ((abs(ll) .le. macheps**(2.0d0/3.0d0)) .and. + (abs(lu) .le. macheps**(2.0d0/3.0d0)) .and. + (abs(ls) .le. macheps**(2.0d0/3.0d0))) then inform = 0 go to 21 end if C step 4: initialize iteration counter iter = 1 C step 5: safeguard of l (ensures that l is bigger than ll) 5 l = max(l, ll) C step 6: safeguard of l (ensures that l is smaller than lu) l = min(l, lu) C step 7: safeguard of l if ((l .le. ls + macheps**(2.0d0/3.0d0)*max(abs(ls),1.0d0)) .and. + (iter .ne. 1)) then l = max(1.0d-3 * lu, dsqrt(ll*lu)) end if C step 8: try to use the Cholesky decomposition: (B +lI) = R^TR. C If the decomposition is successfull, R is stored in the C upper triangular portion of B (including the diagonal) and C pd is set to true. C If the decomposition fails, d and idx are set as explained C before, pd is set to false, and the Euclidian-norm of u is C calculated (see explanation of variable ueucn2) call cholesky(n, ldb, B, l, diag, macheps, d, idx, pd) chcnt = chcnt + 1 C In this case (B + lI) is not positive definite, and d and idx are C calculated. Because p cannot be calculated (it is not possible to C solve the system using Cholesky factorization), the values of l, C ll and ls are updated, the iteration counter is increased and a C new iteration is started if (.not. pd) then C Print information (current iteration) if (iprint .ge. 3) then write(*, 980) iter write(*, 981) ls, ll, lu, l write(*, 988) write(10,980) iter write(10,981) ls, ll, lu, l write(10,988) end if llant = ll luant = lu lsant = ls if (lu-l .le. + macheps**(2.0d0/3.0d0)*max(abs(lu),1.0d0)) then lu = lu + macheps**(2.0d0/3.0d0)*max(abs(lu),1.0d0) l = lu else call calcu(idx, ldb, B, p, ueucn2) ll = max(l, ll) ls = max(l + (d / ueucn2), ls) ll = max(ll, ls) l = ls end if iter = iter + 1 C Test whether the number of iterations is exhausted if (iter .gt. maxit) then inform = 5 if (iprint .ge. 3) then write(*, 989) inform, maxit write(10,989) inform, maxit end if go to 22 end if go to 5 end if C step 9: solve R^TRp = -g for p and calculate the squared C Euclidian-norm of p call solvesys(n, ldb, B, g, p) C Euclidian-norm of Rp = p^T R^TRp = p^T (-g) = - p^Tg rpeucn2 = 0.0d0 do i = 1, n rpeucn2 = rpeucn2 - p(i) * g(i) end do peunc2 = 0.0d0 do i = 1, n peunc2 = peunc2 + p(i)**2 end do peunc = dsqrt(peunc2) C step 10: calculate z and tau, where tau * z is the approximation C of the eigenvector associated with the smallest C eigenvalue of B if (peunc .lt. delta) then C Calculate z call calcz(n, ldb, B, macheps, z) C Calculate z Euclidian-norm tmp = 0.0d0 do i = 1, n tmp = tmp + z(i)**2 end do tmp = dsqrt(tmp) C Divide z by its norm do i = 1, n z(i) = z(i) / tmp end do C Calculate the squared Euclidian-norm of the product Rz. C Note that z^T R^T Rz = z^T (B + lI) z do i = 1, n wd1(i) = 0.0d0 end do do j = 1, n do i = 1, j wd1(i) = wd1(i) + B(i,j) * z(j) end do end do rzeucn2 = 0.0d0 do i = 1, n rzeucn2 = rzeucn2 + wd1(i)**2 end do C Calculate tau ptz = 0.0d0 do i = 1, n ptz = ptz + p(i) * z(i) end do if (ptz .lt. 0.0d0) then sgn = -1.0d0 else sgn = 1.0d0 end if tmp = delta2 - peunc2 tau = (ptz**2) + tmp tau = tmp / (ptz + sgn * sqrt(tau)) end if C Print informations (current iteration) if (iprint .ge. 3) then write(*, 980) iter write(*, 981) ls, ll, lu, l write(*, 982) peunc write(10,980) iter write(10,981) ls, ll, lu, l write(10,982) peunc if (peunc .lt. delta) then write(*, 983) sqrt(peunc2 + 2 * tau * ptz + tau ** 2) write(10,983) sqrt(peunc2 + 2 * tau * ptz + tau ** 2) else write(*, 983) peunc write(10,983) peunc end if write(*, 985) delta write(10,985) delta end if C steps 11 and 12: update ll, lu and ls llant = ll luant = lu lsant = ls if (peunc .lt. delta) then lu = min(l, lu) ls = max(l - rzeucn2, ls) else ll = max(l, ll) end if C step 13: update ls when B + lI is not positive definite. C This was done right after the Cholesky decomposition C failure C step 14: update ll ll = max(ll, ls) C step 15: convergence test if ((abs(l) .le. eps) .and. (peunc .le. delta)) then inform = 1 go to 21 end if C step 16: second convergence test if (abs(delta - peunc) .le. sigma1*delta) then inform = 2 end if C step 17: convergence test for the hard case tmp = rpeucn2 + l * delta2 tmp = max(sigma2, tmp) tmp = tmp * sigma1 * (2 - sigma1) if ((peunc .lt. delta) .and. ((rzeucn2*(tau**2) .le. tmp) + .or. (lu - ll .le. eps))) then inform = inform + 3 go to 20 end if if (inform .eq. 2) then go to 21 end if C step 21: Calculate l to be used in the next iteration if ((abs(geucn) .gt. eps) .or. + ((l .le. ll + macheps**(2.0d0/3.0d0)*max(abs(ll),1.0d0)) + .and. (ls .le. ll))) then C Solve R^Tt = p for t and calculate t squared Euclidian-norm do i = 1, n t(i) = p(i) end do do j = 1, n do i = 1, j-1 t(j) = t(j) - B(i,j) * t(i) end do t(j) = t(j) / B(j,j) end do teucn2 = 0.0d0 do i = 1, n teucn2 = teucn2 + t(i)**2 end do C Update l using Newton's method update l = l + (peunc2 / teucn2) * ((peunc - delta) / delta) else l = ls end if C step 22: update iteration counter iter = iter + 1 C Test whether the number of iterations is exhausted if (iter .gt. maxit) then inform = 5 if (iprint .ge. 3) then write(*, 989) inform, maxit write(10,989) inform, maxit end if go to 22 end if C step 23: start a new iteration if ((abs(llant-ll) .le. + macheps**(2.0d0/3.0d0)*max(abs(ll),1.0d0)) .and. + (abs(luant-lu) .le. + macheps**(2.0d0/3.0d0)*max(abs(lu),1.0d0)) .and. + (abs(lsant-ls) .le. + macheps**(2.0d0/3.0d0)*max(abs(ls),1.0d0))) then ll = ll + macheps**(2.0d0/3.0d0)*max(abs(ll),1.0d0) lu = lu - macheps**(2.0d0/3.0d0)*max(abs(lu),1.0d0) end if go to 5 C steps 18, 19 and 20: C The solution is given by p in 3 cases: C - if the first convergence criterion is satisfied; C - if only the second convergence criterion is satisfied; C - if both the second and the third convergence criteria are C satisfied, but the squared Euclidian-norm of R(tau*z) is C strictly bigger than l*(delta2 - peunc2) C The solution is given by p + tau*z when: C - just the third convergence criterion is satisfied; C - both the second and the third convergence criteria are C satisfied, but the squared Euclidian-norm of R(tau*z) is smaller C or equal to l*(delta2 - peunc2) 20 tmp = (rzeucn2 * (tau**2)) - l * (delta2 - peunc2) if ((inform .eq. 3) .or. + ((inform .eq. 5) .and. (tmp .le. 0.0d0))) then peunc2 = 0.0d0 do i = 1, n p(i) = p(i) + tau * z(i) peunc2 = peunc2 + p(i)**2 end do peunc = dsqrt(peunc2) inform = 3 else inform = 2 end if C Print informations 21 if (iprint .ge. 3) then write(*, 986) iter write(*, 981) ls, ll, lu, l write(*, 987) inform write(*, 984) peunc write(10,986) iter write(10,981) ls, ll, lu, l write(10,987) inform write(10,984) peunc end if 22 continue C Non-executable statements 980 format(/6X,'MEQB iteration: ',I6) 981 format(6X,'ls = ',1PD11.4, + 6X,'ll = ',1PD11.4, + 6X,'lu = ',1PD11.4, + 6X,'l = ',1PD11.4) 982 format(6X,'Euclidian-norm of p: ',1PD11.4) 983 format(6X,'Euclidian-norm of p + z: ',1PD11.4) 984 format(6X,'Euclidian-norm of s (solution): ',1PD11.4) 985 format(6X,'delta: ',1PD11.4) 986 format(6X,'Number of iterations: ',I7) 987 format(6X, 'Flag of MEQB = ',I3, + 6X,' (convergence criterion satisfied)',/) 988 format(6X,'B + lI is not positive definite!') 989 format(6X,'Flag of MEQB = ',I3, + ' (It exceeded the maximum allowed number of iterations', + 6X,'(maxit=',I7,')',/) end C ****************************************************************** C ****************************************************************** subroutine cholesky(n, ldb, B, l, diag, macheps, d, idx, pd) C SCALAR ARGUMENTS logical pd integer n, ldb, idx double precision macheps, l, d C ARRAY ARGUMENTS double precision B(ldb,n), diag(n) C Cholesky decomposition. C If B + lI is a symmetric positive definite n x n matrix, B will C store R, where R is such that B + lI = R^TR and pd is set to true. C Because R is upper triangular, just this portion of B will be C changed. (remember the original diagonal of B is stored at diag). C If B + lI is not positive definite, pd is set to false and both d C and idx can be set (look the definition of the latter two below). C C On Entry C C n integer C dimension C C ldb integer C leading dimension of matrix B C C B double precision B(ldb,n) C symmetric n x n matrix (just the lower triangular portion C must be defined) C C l double precision C used to calculate B + lI C C diag double precision diag(n) C diagonal of matrix B C C macheps double precision C machine epsilon C C On Return C C B double precision B(ldb,n) C Cholesky decomposition of B + lI, when it is possible C to calculate, stored in the upper triangular part of C B (including the diagonal) C C idx integer C when B + lI is not positive definite, idx is the index C where the decomposition fails C C d double precision C when B + lI is not positive definite, the submatrix S C of (B + lI) with indices from 1 to idx and with d added C to the element in (idx,idx), is a singular matrix C C pd logical C true iff B + lI is positive definite C LOCAL SCALARS integer i, j, k double precision sum pd = .true. do j = 1, n sum = diag(j) + l do k = j - 1, 1, -1 sum = sum - B(k,j)**2 end do if (sum .le. -macheps**(2.0d0/3.0d0)) then d = - sum idx = j pd = .false. return else if (abs(sum) .le. macheps**(2.0d0/3.0d0)) then d = macheps**(2.0d0/3.0d0) idx = j pd = .false. return else B(j,j) = dsqrt(sum) end if do i = j+1, n sum = B(i,j) do k = j - 1, 1, -1 sum = sum - B(k,j) * B(k,i) end do B(j,i) = sum / B(j,j) end do end do end C ****************************************************************** C ****************************************************************** subroutine solvesys(n, lda, A, b, x) C SCALAR ARGUMENTS integer n, lda C ARRAY ARGUMENTS double precision A(lda,n), b(n), x(n) C Solve system Ax = -b, where A is the Cholesky decomposition of a C matrix B + lI. Just the upper triangular portion of A will be used C (as well as its diagonal). C C On Entry C C n integer C dimension C C lda integer C leading dimension of matrix A C C A double precision A(lda,n) C matrix n x n, containing R in its upper triangular C portion C C b double precision b(n) C negative of right hand side C C On Return C C x double precision x(n) C system solution C LOCAL SCALARS integer i, j do i = 1, n x(i) = -b(i) end do do j = 1, n do i = 1, j-1 x(j) = x(j) - A(i,j) * x(i) end do x(j) = x(j) / A(j,j) end do do j = n, 1, -1 x(j) = x(j) / A(j,j) do i = 1, j-1 x(i) = x(i) - A(i,j) * x(j) end do end do end C ****************************************************************** C ****************************************************************** subroutine calcu(k, lda, A, u, ueucn2) C SCALAR ARGUMENTS integer k, lda double precision ueucn2 C ARRAY ARGUMENTS double precision A(lda,k), u(k) C Solve a linear system of the form (A + ekek^Td)u = 0, where A is, C in fact, the Cholesky decomposition of B + lI until entry k-1 in C its upper portion (row number >= column number). C u is a vector of k positions with u(k) = 1. C C On Entry C C k integer C dimension of e C C lda integer C leading dimension if matrix A C C A double precision A(lda,k) C upper triangular matrix C C On Return C C u double precision u(k) C system solution C C ueucn2 double precision C u squared Euclidian-norm C LOCAL SCALARS integer i, j do i = 1, k-1 u(i) = -A(k,i) end do do j = 1, k-1 do i = 1, j-1 u(j) = u(j) - A(i,j) * u(i) end do u(j) = u(j) / A(j,j) end do do j = k-1, 1, -1 u(j) = u(j) / A(j,j) do i = 1, j-1 u(i) = u(i) - A(i,j) * u(j) end do end do u(k) = 1.0d0 ueucn2 = 0.0d0 do i = 1, k ueucn2 = ueucn2 + u(i)**2 end do end C ****************************************************************** C ****************************************************************** subroutine calcz(n, ldr, R, macheps, z) C SCALAR ARGUMENTS integer ldr, n double precision macheps C ARRAY ARGUMENTS double precision R(ldr,n), z(n) C Implementation of the technique presented by Cline, Moler, Stewart C and Wilkinson to estimate the condition number of a matrix. C This technique is used by the More-Sorensen method to calculate an C approximation to the eigenvector associated to the smallest C eigenvalue of a matrix B (\mslamb_1). C In this technique, when \mslamb approaches -\mslamb_1, \|Rz\| C approaches 0. This insures that z is an approximation to the C wanted eigenvector. C Basically, it solves R^Ty = e, choosing e(k) as 1 or -1 (whatever C gives maximum local growth of y). Then, it solves Rz = y. C C On Entry C C n integer C dimension of R C C ldr integer C leading dimension of R C C R double precision R(ldr,n) C upper triangular matrix (Cholesky decomposition of C B + lI) C C On Return C C z double precision z(n) C approximation of the eigenvector of B associated to C \mslamb_1 C LOCAL SCALARS integer i, k double precision w, wk, wkm, ek, s, sm, rkk, rki ek = 1.0d0 do i = 1, n z(i) = 0.0d0 end do do k = 1, n if (abs(z(k)) .gt. macheps**(2.0d0/3.0d0)) then ek = dsign(ek,-z(k)) end if rkk = R(k,k) if (abs(ek-z(k)) .gt. abs(rkk)) then s = abs(rkk) / abs(ek-z(k)) do i = 1, n z(i) = s * z(i) end do ek = s * ek end if wk = ek - z(k) wkm = -ek - z(k) s = abs(wk) sm = abs(wkm) if (rkk .eq. 0.0d0) then wk = 1.0d0 wkm = 1.0d0 else wk = wk / rkk wkm = wkm / rkk end if if (k .eq. n) then go to 10 end if do i = k+1, n rki = R(k,i) sm = sm + abs(z(i) + wkm * rki) z(i) = z(i) + wk * rki s = s + abs(z(i)) end do if (s .lt. sm - macheps**(2.0d0/3.0d0)*max(abs(sm),1.0d0)) then w = wkm - wk wk = wkm do i = k+1, n rki = R(k,i) z(i) = z(i) + w * rki end do end if 10 z(k) = wk end do C Divide z by its 1-norm to avoid overflow s = 0.0d0 do i = 1, n s = s + abs(z(i)) end do do i = 1, n z(i) = z(i) / s end do C Solve Rz = y do k = n, 1, -1 z(k) = z(k) / R(k,k) do i = 1, k-1 z(i) = z(i) - R(i,k) * z(k) end do end do end C ****************************************************************** C ****************************************************************** subroutine multQT(n, t, lda, A, tau, w, qw, macheps) C SCALAR ARGUMENTS integer n, t, lda double precision macheps C ARRAY ARGUMENTS double precision A(lda,t), tau(t), w(n), qw(n) C This routine multiplies vector w by matrix Q (from QR factorization C of matrix A). C The matrix Q is represented as a product of elementary reflectors C Q = H(1) H(2) . . . H(k), where k = min(m,n). C Each H(i) has the form H(i) = I - tau * v * v' C where tau is a real scalar, and v is a real vector with C v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored in A(i+1:m,i), and C tau in TAU(i). C C On Entry C C n integer C number of rows of A C C m integer C number of columns of A C C lda integer C leading dimension of A C C A double precision A(lda,m) C matrix factorized by DGEQP3 routine. v(i+1:m) is C stored in A(i+1:m,i) (see comment above) C C tau double precision tau(m) C coeficient used to calculate reflectors (returned C by DGEQP3 routine) C C w double precision w(n) C vector to be multiplied by Z C C macheps double precision C machine epsilon C C On return C C qw double precision qw(n) C result of vector w multiplied by Q. qw = Q w. C LOCAL SCALARS integer i, j double precision gama do i = 1, n qw(i) = w(i) end do do j = 1, t C Calculate gama = v(j:n)^T qw(j:n). gama = qw(j) do i = j+1, n gama = gama + A(i,j) * qw(i) end do C Calculate qw(j:n) = qw(j:n) - tau(j) gama v(j:n) C = qw(j:n) - tau(j) v(j:n)^T qw(j:n) v(j:n). if ((abs(gama) .gt. macheps) .and. + (abs(tau(j)) .gt. macheps)) then qw(j) = qw(j) - tau(j) * gama do i = j+1, n qw(i) = qw(i) - tau(j) * gama * A(i,j) end do end if end do end C ****************************************************************** C ****************************************************************** subroutine multZ(n, t, lda, A, tau, w, zw, macheps) C SCALAR ARGUMENTS integer n, t, lda double precision macheps C ARRAY ARGUMENTS double precision A(lda,t), tau(t), w(n-t), zw(n) C This routine multiplies vector w by matrix Z. Z is the matrix C formed by the last n-t columns of matrix Q (from QR factorization C of matrix A). C The matrix Q is represented as a product of elementary reflectors C Q = H(1) H(2) . . . H(t), where t <= min(m,n). C Each H(i) has the form H(i) = I - tau * v * v' C where tau is a real scalar, and v is a real vector with C v(1:i-1) = 0 and v(i) = 1; v(i+1:t) is stored in A(i+1:t,i), and C tau in TAU(i). C C On Entry C C n integer C number of rows of A C C t integer C n-t is the number of columns of Z C C lda integer C leading dimension of A C C A double precision A(lda,t) C matrix factorized by DGEQP3 routine. v(i+1:t) is C stored in A(i+1:t,i) (see comment above) C C tau double precision tau(t) C coeficient used to calculate reflectors (returned C by DGEQP3 routine) C C w double precision w(n-t) C vector to be multiplied by Z C C macheps double precision C machine epsilon C C On return C C zw double precision zw(n) C result of vector w multiplied by Z. zw = Z w. C LOCAL SCALARS integer i, j double precision gama C If t = 0 then Z = I if (t .eq. 0) then do i = 1, n zw(i) = w(i) end do return end if C Multiplies vector w by last n-t columns of Hm gama = 0.0d0 do i = n, t+1, -1 gama = gama + A(i,t) * w(i-t) end do do i = 1, t zw(i) = 0.0d0 end do do i = 1, n-t zw(t+i) = w(i) end do if ((abs(gama) .gt. macheps) .and. + (abs(tau(t)) .gt. macheps)) then zw(t) = zw(t) - tau(t) * gama do i = t+1, n zw(i) = zw(i) - tau(t) * gama * A(i,t) end do end if do j = t-1, 1, -1 C Calculate gama = v(j:n)^T zw(j:n). gama = zw(j) do i = j+1, n gama = gama + A(i,j) * zw(i) end do C Calculate wd(j:n) = zw(j:n) - tau(j) gama v(j:n) C = zw(j:n) - tau(j) v(j:n)^T zw(j:n) v(j:n). if ((abs(gama) .gt. macheps) .and. + (abs(tau(j)) .gt. macheps)) then zw(j) = zw(j) - tau(j) * gama do i = j+1, n zw(i) = zw(i) - tau(j) * gama * A(i,j) end do end if end do end C ****************************************************************** C ****************************************************************** subroutine multZT(n, t, lda, A, tau, w, wd, ztw, macheps) C ARRAY ARGUMENTS integer n, t, lda double precision macheps C ARRAY ARGUMENTS double precision A(lda,t), tau(t), w(n), wd(n), ztw(n-t) C This routine multiplies vector w by matrix Z^T. Z is the matrix C formed by the last n-t columns of matrix Q (from QR factorization C of matrix A). C The matrix Q is represented as a product of elementary reflectors C Q = H(1) H(2) . . . H(t), where t <= min(m,n). C Each H(i) has the form H(i) = I - tau * v * v' C where tau is a real scalar, and v is a real vector with C v(1:i-1) = 0 and v(i) = 1; v(i+1:t) is stored in A(i+1:t,i), and C tau in TAU(i). C C On Entry C C n integer C number of rows of A C C t integer C n-t is the number of columns of Z C C lda integer C leading dimension of A C C A double precision A(lda,t) C matrix factorized by DGEQP3 routine. v(i+1:t) is C stored in A(i+1:t,i) (see comment above) C C tau double precision tau(t) C coeficient used to calculate reflectors (returned C by DGEQP3 routine) C C w double precision w(n) C vector to be multiplied by Z^T C C wd double precision wd(n) C working vector C C macheps double precision C machine epsilon C C On return C C ztw double precision ztw(n-t) C result of vector w multiplied by Z^T . ztw = Z^T w. C LOCAL SCALARS integer i, j double precision gama C If t = 0 then Z = I if (t .eq. 0) then do i = 1, n ztw(i) = w(i) end do return end if do i = 1, n wd(i) = w(i) end do do j = 1, t-1 C Calculate gama = v(j:n)^T w(j:n). gama = wd(j) do i = j+1, n gama = gama + A(i,j) * wd(i) end do C Calculate wd(j:n) = wd(j:n) - tau(j) gama v(j:n) C = wd(j:n) - tau(j) v(j:n)^T w(j:n) v(j:n). if ((abs(gama) .gt. macheps) .and. + (abs(tau(j)) .gt. macheps)) then wd(j) = wd(j) - tau(j) * gama do i = j+1, n wd(i) = wd(i) - tau(j) * gama * A(i,j) end do end if end do C Multiplies vector w by last n-t rows of Hm gama = wd(t) do i = t+1, n gama = gama + A(i,t) * wd(i) end do do i = 1, n-t ztw(i) = wd(t+i) end do if ((abs(gama) .gt. macheps) .and. + (abs(tau(t)) .gt. macheps)) then do i = n-t, 1, -1 ztw(i) = ztw(i) - tau(t) * gama * A(i+t,t) end do end if end C ***************************************************************** C ***************************************************************** subroutine updateQR(n, nli, lda, A, tau, w, qw, macheps) C SCALAR ARGUMENTS integer n, nli, lda double precision macheps C ARRAY ARGUMENTS double precision A(lda,nli+1), tau(nli+1), w(n), qw(n) C This subroutine updates QR factorization of matrix Abar when C column w is to be inserted. C C On Entry C C n integer C number of rows of A C C nli integer C number of linear independent columns of A C C lda integer C leading dimension of A C C A double precision A(lda,nli+1) C matrix factorized by DGEQP3 routine. v(i+1:m) is C stored in A(i+1:m,i) (see previous routine's comment) C C tau double precision tau(nli+1) C coeficient used to calculate reflectors (returned C by DGEQP3 routine) C C w double precision w(n) C column to be inserted in A C C qw double precision qw(n) C working vector C C macheps double precision C machine epsilon C C On Return C C nli integer C updated number of linear independent columns of A C C A double precision A(lda,nli+1) C updated QR factorization C C tau double precision tau(nli+1) C updated coeficients C LOCAL SCALARS integer i, j double precision tau2 C Calculate qw = Q^T w call multQT(n, nli, lda, A, tau, w, qw, macheps) C Look for the first non-zero component of qw (from C the last position to the first). do i = n, 1, -1 if (abs(qw(i)) .gt. macheps**(2.0d0/3.0d0)) then go to 10 end if end do C If the first non-zero component of qw (from the last C position to the first) has index greater than nliact C it means the set of vectors formed by qw and the first C nliact columns of A is LI. In this case, we have to C update QR factorization of A. If the set is LD, C the factorization remains the same. 10 if (i .gt. nli) then C Increase the number of LI columns of A. nli = nli + 1 C Calculate reflector H such that H qw has non-zero C elements only in indices from 1 to nliact. call DLARFG(n-nli+1, qw(nli), qw(nli+1), 1, tau2) C Place qw as nliact-th column of A. do j = 1, n A(j,nli) = qw(j) end do tau(nli) = tau2 end if end C ****************************************************************** C ****************************************************************** subroutine calcobj(nind,ind,x,n,xc,f,inform) implicit none C SCALAR ARGUMENTS integer nind,n,inform double precision f C ARRAY ARGUMENTS integer ind(nind) double precision x(n),xc(n) C This subroutines computes the objective function. C C It is called from the reduced space (dimension nind), expands the C point x where the function will be evaluated and call the C subroutine evalf to compute the objective function Finally, C shrinks vector x to the reduced space. C C About subroutines named calc[something]. The subroutines whos C names start with ``calc'' work in (are called from) the reduced C space. Their tasks are (i) expand the arguments to the full space, C (ii) call the corresponding ``eval'' subroutine (which works in C the full space), and (iii) shrink the parameters again and also C shrink a possible output of the ``eval'' subroutine. Subroutines C of this type are: calcobj, calcgr and calchess. C The corresponding subroutines in the full space are the user C defined subroutines evalf, evalg and evalhd. C LOCAL SCALARS integer i C Complete x do i = nind + 1,n x(i) = xc(i) end do C Expand x to the full space call expand(nind,ind,n,x) C Compute f calling the user supplied subroutine evalf call evalobj(n,x,f,inform) C Shrink x to the reduced space call shrink(nind,ind,n,x) return end C ****************************************************************** C ****************************************************************** subroutine calcgr(nind,ind,x,n,xc,g,gtype,macheps,inform) implicit none C SCALAR ARGUMENTS integer gtype,inform,n,nind double precision macheps C ARRAY ARGUMENTS integer ind(nind) double precision x(n),xc(n),g(n) C This subroutine computes the gradient vector g of the objective C function. C C It is called from the reduced space (dimension nind), expands the C point x where the gradient will be evaluated and calls the user C supplied subroutine evalg to compute the gradient vector. Finally, C shrinks vectors x and g to the reduced space. C C About subroutines named calc[something]. The subroutines whos C names start with ``calc'' work in (are called from) the reduced C space. Their tasks are (i) expand the arguments to the full space, C (ii) call the corresponding ``eval'' subroutine (which works in C the full space), and (iii) shrink the parameters again and also C shrink a possible output of the ``eval'' subroutine. Subroutines C of this type are: calcobj, calcgr and calchess C The corresponding subroutines in the full space are the user C defined subroutines evalf, evalg and evalhd. C LOCAL SCALARS integer i C Complete x do i = nind + 1,n x(i) = xc(i) end do C Expand x to the full space call expand(nind,ind,n,x) C Compute the gradient vector calling the user supplied subroutine C evalg call evalgr(n,x,g,gtype,macheps,inform) C Shrink x and g to the reduced space call shrink(nind,ind,n,x) call shrink(nind,ind,n,g) return end C ****************************************************************** C ****************************************************************** subroutine calcpz(nind,ind,n,r,s,y,seucn,yeucn,sts,sty,lspgmi, +lspgma,samefa,gotp,pdiag,plspg,psmdy,psmdyty,z) implicit none C SCALAR ARGUMENTS logical gotp,samefa integer n,nind double precision lspgma,lspgmi,plspg,psmdyty,seucn,sts,sty,yeucn C ARRAY ARGUMENTS integer ind(nind) double precision r(n),s(n),pdiag(n),psmdy(n),y(n),z(n) C LOCAL SCALARS integer i C Complete r with zeroes do i = nind + 1,n r(i) = 0.0d0 end do C Expand r to the full space call expand(nind,ind,n,r) C Solve P z = r call applyp(n,r,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma,samefa,gotp, +pdiag,plspg,psmdy,psmdyty,z) C Shrink r and z to the reduced space call shrink(nind,ind,n,r) call shrink(nind,ind,n,z) end C ****************************************************************** C ****************************************************************** subroutine calchessp(nind,ind,x,p,g,n,xc,s,y,seucn,yeucn,sts,sty, +lspgmi,lspgma,samefa,gtype,hptype,aptype,hp,wdn1,macheps,inform, +goth,hlspg,hds,hstds) implicit none C This subroutine computes the product Hessian times vector p. As it C is called from the reduced space, it expands vectors x and p, C calls subroutine evalhessp to compute the Hessian times vector p C product, and shrinks vectors x, p and hp. C SCALAR ARGUMENTS logical goth,samefa character * 6 aptype integer gtype,hptype,inform,n,nind double precision hlspg,hstds,lspgma,lspgmi,macheps,seucn,sts,sty, + yeucn C ARRAY ARGUMENTS integer ind(nind) double precision g(n),hds(n),hp(n),p(n),wdn1(n),x(n),xc(n),s(n), + y(n) C LOCAL SCALARS integer i C Complete p with zeroes do i = nind + 1,n p(i) = 0.0d0 end do C Complete x do i = nind + 1,n x(i) = xc(i) end do C Expand x and p to the full space call expand(nind,ind,n,x) call expand(nind,ind,n,p) call expand(nind,ind,n,g) C Compute the Hessian-vector product call evalhessp(n,x,p,g,s,y,seucn,yeucn,sts,sty,lspgmi,lspgma, +samefa,gtype,hptype,aptype,hp,wdn1,macheps,inform,goth,hlspg,hds, +hstds) C Shrink x, p and hp to the reduced space call shrink(nind,ind,n,x) call shrink(nind,ind,n,p) call shrink(nind,ind,n,g) call shrink(nind,ind,n,hp) end C ****************************************************************** C ****************************************************************** subroutine shrink(nind,ind,n,v) implicit none C This subroutine shrinks vector v from the full dimension space C (dimension n) to the reduced space (dimension nind). C SCALAR ARGUMENTS integer n,nind C ARRAY ARGUMENTS integer ind(nind) double precision v(n) C Parameters of the subroutine: C ============================= C C On Entry: C ========= C C NIND integer: Dimension of the reduced space. C ------------ C C IND integer ind(nind) C --------------------- C C Components ind(1)-th, ..., ind(nind)-th are the components that C belong to the reduced space. C C N integer: Dimension of the full space. C --------- C C V double precision v(n): Vector to be shrinked. C ----------------------- C C On Return: C ========== C C V double precision v(n): Shrinked vector. C ----------------------- C LOCAL SCALARS integer i,indi double precision tmp do i = 1,nind indi = ind(i) if ( i .ne. indi ) then tmp = v(indi) v(indi) = v(i) v(i) = tmp end if end do return end C ****************************************************************** C ****************************************************************** subroutine expand(nind,ind,n,v) implicit none C This subroutine expands vector v from the reduced space C (dimension nind) to the full space (dimension n). C SCALAR ARGUMENTS integer n, nind C ARRAY ARGUMENTS integer ind(nind) double precision v(n) C Parameters of the subroutine: C ============================= C C On Entry: C ========= C C NIND integer: Dimension of the reduced space. C ------------ C C IND integer ind(nind) C --------------------- C C Components ind(1)-th, ..., ind(nind)-th are the components that C belong to the reduced space. C C N integer: Dimension of the full space. C --------- C C V double precision v(n): Vector to be expanded. C ----------------------- C C On Return: C ========== C C V double precision v(n): Expanded vector. C ----------------------- C LOCAL SCALARS integer i,indi double precision tmp do i = nind,1,- 1 indi = ind(i) if ( i .ne. indi ) then tmp = v(indi) v(indi) = v(i) v(i) = tmp end if end do return end C ***************************************************************** C ***************************************************************** double precision function norm2s(n,x) C This subroutine computes the squared Euclidian norm of an C n-dimensional vector. C SCALAR ARGUMENTS integer n C ARRAY ARGUMENTS double precision x(n) C Parameters of the subroutine: C ============================= C C On Entry: C ========= C C N integer: Dimension. C --------- C C X double precision x(n): Vector. C ----------------------- C C On Return: C ========== C C The function return the squared Euclidian norm of the C n-dimensional vector x. double precision hsldnrm2 norm2s = hsldnrm2(n,x,1) ** 2 return end C ****************************************************************** C ****************************************************************** DOUBLE PRECISION FUNCTION HSLDNRM2(N,DX,INCX) DOUBLE PRECISION ZERO,ONE PARAMETER (ZERO=0.0D0,ONE=1.0D0) DOUBLE PRECISION CUTLO,CUTHI PARAMETER (CUTLO=8.232D-11,CUTHI=1.304D19) INTEGER INCX,N DOUBLE PRECISION DX(*) DOUBLE PRECISION HITEST,SUM,XMAX INTEGER I,J,NEXT,NN INTRINSIC DABS,DSQRT,FLOAT IF (N.GT.0) GO TO 10 HSLDNRM2 = ZERO GO TO 300 10 ASSIGN 30 TO NEXT SUM = ZERO NN = N*INCX I = 1 20 GO TO NEXT 30 IF (DABS(DX(I)).GT.CUTLO) GO TO 85 ASSIGN 50 TO NEXT XMAX = ZERO 50 IF (DX(I).EQ.ZERO) GO TO 200 IF (DABS(DX(I)).GT.CUTLO) GO TO 85 ASSIGN 70 TO NEXT GO TO 105 100 I = J ASSIGN 110 TO NEXT SUM = (SUM/DX(I))/DX(I) 105 XMAX = DABS(DX(I)) GO TO 115 70 IF (DABS(DX(I)).GT.CUTLO) GO TO 75 110 IF (DABS(DX(I)).LE.XMAX) GO TO 115 SUM = ONE + SUM* (XMAX/DX(I))**2 XMAX = DABS(DX(I)) GO TO 200 115 SUM = SUM + (DX(I)/XMAX)**2 GO TO 200 75 SUM = (SUM*XMAX)*XMAX 85 HITEST = CUTHI/DFLOAT(N) DO 95 J = I,NN,INCX IF (DABS(DX(J)).GE.HITEST) GO TO 100 95 SUM = SUM + DX(J)**2 HSLDNRM2 = DSQRT(SUM) GO TO 300 200 CONTINUE I = I + INCX IF (I.LE.NN) GO TO 20 HSLDNRM2 = XMAX*DSQRT(SUM) 300 CONTINUE RETURN END C ****************************************************************** C ****************************************************************** double precision function drand(ix) C This is the random number generator of Schrage: C C L. Schrage, A more portable Fortran random number generator, ACM C Transactions on Mathematical Software 5 (1979), 132-138. double precision ix double precision a,p,b15,b16,xhi,xalo,leftlo,fhi,k data a/16807.d0/,b15/32768.d0/,b16/65536.d0/,p/2147483647.d0/ xhi= ix/b16 xhi= xhi - dmod(xhi,1.d0) xalo= (ix-xhi*b16)*a leftlo= xalo/b16 leftlo= leftlo - dmod(leftlo,1.d0) fhi= xhi*a + leftlo k= fhi/b15 k= k - dmod(k,1.d0) ix= (((xalo-leftlo*b16)-p)+(fhi-k*b15)*b16)+k if (ix.lt.0) ix= ix + p drand= ix*4.656612875d-10 return end C ****************************************************************** C ****************************************************************** DOUBLE PRECISION FUNCTION D1MACH(I) INTEGER I C C DOUBLE-PRECISION MACHINE CONSTANTS C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE. C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE. C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING. C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING. C D1MACH( 5) = LOG10(B) C INTEGER SMALL(2) INTEGER LARGE(2) INTEGER RIGHT(2) INTEGER DIVER(2) INTEGER LOG10(2) INTEGER SC, CRAY1(38), J COMMON /D9MACH/ CRAY1 SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC DOUBLE PRECISION DMACH(5) EQUIVALENCE (DMACH(1),SMALL(1)) EQUIVALENCE (DMACH(2),LARGE(1)) EQUIVALENCE (DMACH(3),RIGHT(1)) EQUIVALENCE (DMACH(4),DIVER(1)) EQUIVALENCE (DMACH(5),LOG10(1)) C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES. C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR C MANY MACHINES YET. C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1 C ON THE NEXT LINE DATA SC/0/ C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW. C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY C mail netlib@research.bell-labs.com C send old1mach from blas C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com. C C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES. C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/ C C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING C 32-BIT INTEGERS. C DATA SMALL(1),SMALL(2) / 8388608, 0 / C DATA LARGE(1),LARGE(2) / 2147483647, -1 / C DATA RIGHT(1),RIGHT(2) / 612368384, 0 / C DATA DIVER(1),DIVER(2) / 620756992, 0 / C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/ C C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES. C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 / C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 / C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 / C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 / C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/ C C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES. IF (SC .NE. 987) THEN DMACH(1) = 1.D13 IF ( SMALL(1) .EQ. 1117925532 * .AND. SMALL(2) .EQ. -448790528) THEN * *** IEEE BIG ENDIAN *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2146435071 LARGE(2) = -1 RIGHT(1) = 1017118720 RIGHT(2) = 0 DIVER(1) = 1018167296 DIVER(2) = 0 LOG10(1) = 1070810131 LOG10(2) = 1352628735 ELSE IF ( SMALL(2) .EQ. 1117925532 * .AND. SMALL(1) .EQ. -448790528) THEN * *** IEEE LITTLE ENDIAN *** SMALL(2) = 1048576 SMALL(1) = 0 LARGE(2) = 2146435071 LARGE(1) = -1 RIGHT(2) = 1017118720 RIGHT(1) = 0 DIVER(2) = 1018167296 DIVER(1) = 0 LOG10(2) = 1070810131 LOG10(1) = 1352628735 ELSE IF ( SMALL(1) .EQ. -2065213935 * .AND. SMALL(2) .EQ. 10752) THEN * *** VAX WITH D_FLOATING *** SMALL(1) = 128 SMALL(2) = 0 LARGE(1) = -32769 LARGE(2) = -1 RIGHT(1) = 9344 RIGHT(2) = 0 DIVER(1) = 9472 DIVER(2) = 0 LOG10(1) = 546979738 LOG10(2) = -805796613 ELSE IF ( SMALL(1) .EQ. 1267827943 * .AND. SMALL(2) .EQ. 704643072) THEN * *** IBM MAINFRAME *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2147483647 LARGE(2) = -1 RIGHT(1) = 856686592 RIGHT(2) = 0 DIVER(1) = 873463808 DIVER(2) = 0 LOG10(1) = 1091781651 LOG10(2) = 1352628735 ELSE IF ( SMALL(1) .EQ. 1120022684 * .AND. SMALL(2) .EQ. -448790528) THEN * *** CONVEX C-1 *** SMALL(1) = 1048576 SMALL(2) = 0 LARGE(1) = 2147483647 LARGE(2) = -1 RIGHT(1) = 1019215872 RIGHT(2) = 0 DIVER(1) = 1020264448 DIVER(2) = 0 LOG10(1) = 1072907283 LOG10(2) = 1352628735 ELSE IF ( SMALL(1) .EQ. 815547074 * .AND. SMALL(2) .EQ. 58688) THEN * *** VAX G-FLOATING *** SMALL(1) = 16 SMALL(2) = 0 LARGE(1) = -32769 LARGE(2) = -1 RIGHT(1) = 15552 RIGHT(2) = 0 DIVER(1) = 15568 DIVER(2) = 0 LOG10(1) = 1142112243 LOG10(2) = 2046775455 ELSE DMACH(2) = 1.D27 + 1 DMACH(3) = 1.D27 LARGE(2) = LARGE(2) - RIGHT(2) IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN CRAY1(1) = 67291416 DO 10 J = 1, 20 CRAY1(J+1) = CRAY1(J) + CRAY1(J) 10 CONTINUE CRAY1(22) = CRAY1(21) + 321322 DO 20 J = 22, 37 CRAY1(J+1) = CRAY1(J) + CRAY1(J) 20 CONTINUE IF (CRAY1(38) .EQ. SMALL(1)) THEN * *** CRAY *** CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0) SMALL(2) = 0 CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215) CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214) CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0) RIGHT(2) = 0 CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0) DIVER(2) = 0 CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215) CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388) ELSE WRITE(*,9000) STOP 779 END IF ELSE WRITE(*,9000) STOP 779 END IF END IF SC = 987 END IF * SANITY CHECK IF (DMACH(4) .GE. 1.0D0) STOP 778 IF (I .LT. 1 .OR. I .GT. 5) THEN WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.' STOP END IF D1MACH = DMACH(I) RETURN 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/ *' appropriate for your machine.') * /* Standard C source for D1MACH -- remove the * in column 1 */ *#include *#include *#include *double d1mach_(long *i) *{ * switch(*i){ * case 1: return DBL_MIN; * case 2: return DBL_MAX; * case 3: return DBL_EPSILON/FLT_RADIX; * case 4: return DBL_EPSILON; * case 5: return log10((double)FLT_RADIX); * } * fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); * exit(1); return 0; /* some compilers demand return values */ *} END SUBROUTINE I1MCRY(A, A1, B, C, D) **** SPECIAL COMPUTATION FOR OLD CRAY MACHINES **** INTEGER A, A1, B, C, D A1 = 16777216*B + C A = 16777216*A1 + D END