PROGRAM SQP_test IMPLICIT NONE INTEGER :: n, nclin, ncnln, nctotl, nrowa, nrowj, nrowr, & liwork, lwork, i, ifail, iter, itmax, j, mode, msglvl, & nstate INTEGER, DIMENSION(:), ALLOCATABLE :: istate, iwork LOGICAL :: cold, fealin, ortho REAL :: bigbnd, epsaf, epsmch, eta, ftol, objf, rteps REAL, DIMENSION(:,:), ALLOCATABLE :: a, cjac, r REAL, DIMENSION(:), ALLOCATABLE :: x, bl, bu, c, clamda, & featol, objgrd, work, x02aje EXTERNAL x02aje, confun, e04vce, e04zce, objfun ! Asetetaan tehtävän dimensiot n = 2; nclin = 1; ncnln = 1; nctotl = n+nclin+ncnln nrowa = nclin; nrowj = ncnln; nrowr = n liwork = 3*n+nclin+2*ncnln lwork = 2*n*n+n*nclin+2*n*ncnln+20*n+11*nclin+21*ncnln ALLOCATE(a(nrowa,n), bl(nctotl), bu(nctotl), c(nrowj), & cjac(nrowj,n), clamda(nctotl), featol(nctotl), & objgrd(n), r(nrowr,n), work(lwork), x(n), & istate(nctotl), iwork(liwork)) ! Alkuasetukset nstate = 1; mode = 1; ifail = 1; msglvl = 1 bigbnd = 1.d10; itmax = 100; eta = 0.9d0 x = (/ 2.d0,2.d0 /); a = RESHAPE((/1.d0,-2.d0/), (/1,2/)) bl = (/ -10.d0,-5.d0,-1.d0,-1.d0 /) bu = (/ 10.d0,5.d0,-1.d0,1.d10 /) cold = .TRUE.; fealin = .TRUE.; ortho = .TRUE. ifail = 1 ! Tarkistetaan gradientit CALL e04zce(n, nclin, nrowj, confun, objfun, c, cjac, & objf, objgrd, x, work, lwork, ifail) IF (ifail == 0) THEN ! Gradienttivektori on ok... epsmch = x02aje() ! Selvitetään laskentatarkkuus ftol = 10.0d0*epsmch; rteps = SQRT(epsmch) featol(1:nctotl) = rteps CALL objfun(mode, n, x, objf, objgrd, nstate) epsaf = epsmch*ABS(objf) ifail = 1 ! Ratkaistaan tehtävä CALL e04vce(itmax, msglvl, n, nclin, ncnln, nctotl, & nrowa, nrowj, nrowr, bigbnd, epsaf, eta, ftol, a, & bl, bu, featol, confun, objfun, cold, fealin, ortho, & x, istate, r, iter, c, cjac, objf, objgrd, clamda, & iwork, liwork, work, lwork, ifail) IF (ifail /= 0) WRITE(*,*) 'e04vce:n ifail =', ifail ELSE WRITE(*,*) 'Virhe gradienttivektorissa. ifail =', ifail END IF END PROGRAM SQP_test