!************************************************************************ !* !* !* * Test problems for large NonSmooth UNConstrained minimization * !* !* by Napsu Karmitsa (2011) !* !* !* * Problems * !* !* 1. Generalization of MAXQ (convex). !* 2. Generalization of MXHILB (convex). !* 3. Chained LQ (convex). !* 4. Chained CB3 I (convex). !* 5. Chained CB3 II (convex). !* 6. Number of active faces (nonconvex). !* 7. Nonsmooth generalization of Brown function 2 (nonconvex). !* 8. Chained Mifflin 2 (nonconvex). !* 9. Chained crescent I (nonconvex). !* 10. Chained crescent II (nonconvex). !* !* !* * References* !* !* Haarala M., Miettinen K. and Mäkelä M.M.: New Limited Memory !* Bundle Method for Large-Scale Nonsmooth Optimization, Optimization !* Methods and Software, Vol. 19, No. 6, 2004, 673-692. !* !* !************************************************************************ !* !* !* File tnsunc.f95 includes two modules: MODULE problem_data and !* MODULE large_problems. MODULE problem_data is just for storing !* some global data needed in calculations (e.g. the number of the !* problem). MODULE large_problems includes the following subroutines !* !* S startx Initiation of variables. !* S func Computation of the value of the objective !* function. !* S subgra Computation of the subgradient of the !* objective function. !* S fungra Computation of the value and the subgradient !* of the objective function. !* !* For more details of these subroutines see below. !* !* In addition to these modules, you need a MODULE r_precision to run !* these problems (you may uncomment MODULE r_precision from below if !* you do not have it elsewhere). !* !MODULE r_precision ! ! IMPLICIT NONE ! INTEGER, PARAMETER, PUBLIC :: prec = SELECTED_REAL_KIND(2*PRECISION(1.0)) ! old DOUBLE PRECISION !! INTEGER, PARAMETER, PUBLIC :: prec = SELECTED_REAL_KIND(12) !! INTEGER, PARAMETER, PUBLIC :: prec = SELECTED_REAL_KIND(6) !END MODULE r_precision MODULE problem_data USE r_precision, ONLY : prec IMPLICIT NONE INTEGER, SAVE :: next, & ! Number of the problem hit ! Number of the active partial objective REAL(KIND=prec), SAVE :: f_sign ! sign of the active partial objective REAL(KIND=prec), DIMENSION(3), SAVE :: f_k ! partial values of the objective END MODULE problem_data MODULE large_problems USE r_precision, ONLY : prec USE problem_data, ONLY : next IMPLICIT NONE PRIVATE PUBLIC :: startx,func,subgra,fungra CONTAINS !************************************************************************ !* !* * SUBROUTINE startx * !* !* !* * Purpose * !* !* Initiation of x. !* !* !* * Calling sequence * !* !* CALL startx(n,x) !* !* !* * Parameters * !* !* II n Number of variables. !* RO x(n) Vector of variables. !* !* !* * Modules * !* !* problem_data, ONLY : next !* r_precision, ONLY : prec !* SUBROUTINE startx(n,x) ! USE problem_data, ONLY : next ! no need, if inside MODULE large_problems ! USE r_precision, ONLY : prec ! no need, if inside MODULE large_problems IMPLICIT NONE ! Scalar Arguments INTEGER, INTENT(IN) :: n ! Number of variables ! Array Arguments REAL(KIND=prec), DIMENSION(n), INTENT(OUT) :: x ! Vector of variables ! Local Arguments INTEGER :: i ! Intrinsic Functions INTRINSIC MOD,REAL SELECT CASE (next) ! Number of the problem CASE(1) ! Generalization of MAXQ (convex) DO i=1,n/2 x(i) = REAL(i, KIND=prec) END DO DO i=n/2+1,n x(i) = -REAL(i, KIND=prec) END DO CASE(2) ! Generalization of MXHILB (convex) DO i=1,n x(i) = 1.0_prec END DO CASE(3) ! Chained LQ (convex) DO i=1,n x(i) = -0.50_prec END DO CASE(4,5) ! Chained CB3 I and II (convex) DO i=1,n x(i) = 2.0_prec END DO CASE(6) ! Number of active faces (nonconvex) DO i=1,n x(i) = 1.0_prec END DO CASE(7) ! Nonsmooth generalization of Brown function 2 (nonconvex) DO i=1,n IF (MOD(i,2) == 1) THEN x(i) = -1.0_prec ELSE x(i) = 1.0_prec END IF END DO CASE(8) ! Chained Mifflin 2 (nonconvex) DO i=1,n x(i) = -1.0_prec END DO CASE(9,10) ! Chained crescent I and II (nonconvex) DO i=1,n IF (MOD(i,2) == 1) THEN x(i) = -1.50_prec ELSE x(i) = 2.0_prec END IF END DO CASE DEFAULT ! Error PRINT*,'Error: Not such a problem.' next=-1 END SELECT END SUBROUTINE startx !************************************************************************ !* !* * SUBROUTINE func * !* !* !* * Purpose * !* !* Computation of the value of the objective function. !* !* !* * Calling sequence * !* !* CALL func(n,x,f) !* !* !* * Parameters * !* !* II n Number of variables. !* RI x(n) Vector of variables. !* RO f Value of the objective function. !* !* !* * Modules * !* !* problem_data, ONLY : next,hit,f_sign,f_k !* r_precision, ONLY : prec !* SUBROUTINE func(n,x,f) ! USE problem_data, ONLY : next ! no need, if inside MODULE large_problems ! USE precision, ONLY : prec ! no need, if inside MODULE large_problems USE problem_data, ONLY : hit,f_sign,f_k IMPLICIT NONE ! Scalar Arguments INTEGER, INTENT(IN) :: n ! Number of variables REAL(KIND=prec), INTENT(OUT) :: f ! Value of the objective function ! Array Arguments REAL(KIND=prec), DIMENSION(n), INTENT(IN) :: x ! Vector of variables ! Local Arguments INTEGER :: i,j REAL(KIND=prec), PARAMETER :: zero=0.0, one=1.0, two=2.0 REAL(KIND=prec) :: y,z,v,w ! Intrinsic Functions INTRINSIC ABS,MAX,SIGN,LOG,EXP,REAL SELECT CASE (next) ! Number of the problem CASE (1) ! Generalization of MAXQ (convex) f=x(1)*x(1) hit=1 DO i=2,n y=x(i)*x(i) IF (y > f) THEN f=y hit=i END IF END DO CASE (2) ! Generalization of MXHILB (convex) f = zero hit = 1 DO j = 1,n f = f + x(j)/REAL(j, KIND=prec) END DO f_sign=SIGN(one,f) f = ABS(f) DO i = 2,n y = zero DO j = 1,n y = y + x(j)/REAL(i+j-1, KIND=prec) END DO z = ABS(y) IF (z > f) THEN f=z hit=i f_sign=SIGN(one,y) END IF END DO CASE (3) ! Chained LQ (convex) f=zero DO i=1,n-1 y = -x(i)-x(i+1) z = -x(i)-x(i+1)+(x(i)*x(i)+x(i+1)*x(i+1)-one) IF (y >= z) THEN f=f+y ELSE f=f+z END IF END DO CASE (4) ! Chained CB3 I (convex) f=zero DO i=1,n-1 z = x(i)*x(i)*x(i)*x(i)+x(i+1)*x(i+1) v = (two-x(i))*(two-x(i))+ & (two-x(i+1))*(two-x(i+1)) w = two*EXP(-x(i)+x(i+1)) y = MAX(z,v,w) f = f+y END DO CASE (5) ! Chained CB3 II (convex) f=zero f_k=zero DO i=1,n-1 f_k(1)=f_k(1)+x(i)*x(i)*x(i)*x(i)+x(i+1)*x(i+1) f_k(2)=f_k(2)+(two-x(i))*(two-x(i))+ & (two-x(i+1))*(two-x(i+1)) f_k(3)=f_k(3)+two*EXP(-x(i)+x(i+1)) END DO f=MAX(f_k(1),f_k(2),f_k(3)) CASE (6) ! Number of active faces (nonconvex) f_sign = one f_k(1) = -x(1) f = LOG(ABS(x(1))+one) hit = 1 DO i=2,n f_k(1) = f_k(1) - x(i) y = LOG(ABS(x(i))+one) IF(f < y) THEN hit = i f = y END IF END DO y = LOG(ABS(f_k(1))+one) IF(f < y) THEN hit=n+1 f = y IF (f_k(1) >= zero) f_sign = -one ELSE IF (x(hit) < zero) f_sign = -one END IF CASE (7) ! Nonsmooth generalization of Brown function 2 (nonconvex) f=zero DO i=1,n-1 y = ABS(x(i)) z = ABS(x(i+1)) v = x(i)*x(i)+one w = x(i+1)*x(i+1)+one f = f+z**v+y**w END DO CASE (8) ! Chained mifflin 2 (nonconvex) f=zero DO i=1,n-1 y = x(i)*x(i) + x(i+1)*x(i+1) - one f = f -x(i) + two*y + 1.75_prec*ABS(y) END DO CASE (9) ! Chained crescent I (nonconvex) f_k(1)=zero f_k(2)=zero DO i=1,n-1 f_k(1) = f_k(1) + x(i)*x(i) + (x(i+1)-one)*(x(i+1)-one) & + x(i+1) - one f_k(2) = f_k(2) - x(i)*x(i) - (x(i+1)-one)*(x(i+1)-one) & + x(i+1) + one END DO f = MAX(f_k(1),f_k(2)) CASE (10) ! Chained crescent II (nonconvex) f=zero DO i=1,n-1 y = x(i)*x(i) + (x(i+1)-one)*(x(i+1)-one) & + x(i+1) - one z = - x(i)*x(i) - (x(i+1)-one)*(x(i+1)-one) & + x(i+1) + one IF (y >= z) THEN f=f+y ELSE f=f+z END IF END DO CASE DEFAULT ! Error PRINT*,'Error: Not such a problem.' next=-1 END SELECT END SUBROUTINE func !************************************************************************ !* !* * SUBROUTINE subgra * !* !* !* * Purpose * !* !* Computation of the subgradient of the objective function. !* !* !* * Calling sequence * !* !* CALL subgra(n,x,g) !* !* !* * Parameters * !* !* II n Number of variables. !* RI x(n) Vector of variables. !* RO g(n) Subgradient of the objective function. !* !* !* * Modules * !* !* problem_data, ONLY : next,hit,f_sign,f_k !* r_precision, ONLY : prec !* SUBROUTINE subgra(n,x,g) ! USE problem_data, ONLY : next ! no need, if inside MODULE large_problems ! USE precision, ONLY : prec ! no need, if inside MODULE large_problems USE problem_data, ONLY : hit,f_sign,f_k IMPLICIT NONE ! Scalar Arguments INTEGER, INTENT(IN) :: n ! Number of variables ! Array Arguments REAL(KIND=prec), DIMENSION(n), INTENT(IN) :: x ! Vector of variables REAL(KIND=prec), DIMENSION(n), INTENT(OUT) :: g ! Subgradient of the objective ! Local Arguments INTEGER :: i,j REAL(KIND=prec), PARAMETER :: zero=0.0, one=1.0, two=2.0 REAL(KIND=prec) :: y,z,v,w,u ! Intrinsic Functions INTRINSIC ABS,MAX,SIGN,LOG,EXP,REAL SELECT CASE (next) ! Number of the problem CASE (1) ! Generalization of MAXQ (convex) g = zero g(hit) = two*x(hit) CASE (2) ! Generalization of MXHILB (convex) DO i = 1,n g(i) = f_sign/REAL(hit+i-1, KIND=prec) END DO CASE (3) ! Chained LQ (convex) g(1) = zero DO i=1,n-1 g(i+1) = zero y = -x(i)-x(i+1) z = -x(i)-x(i+1)+(x(i)*x(i)+x(i+1)*x(i+1)-one) IF (y >= z) THEN g(i) = g(i)-one g(i+1) = -one ELSE g(i) = g(i)-one+two*x(i) g(i+1) = -one+two*x(i+1) ENDIF END DO CASE (4) ! Chained CB3 I (convex) g(1) = zero DO i=1,n-1 g(i+1) = zero z = x(i)*x(i)*x(i)*x(i)+x(i+1)*x(i+1) v = (two-x(i))*(two-x(i))+ & (two-x(i+1))*(two-x(i+1)) w = two*EXP(-x(i)+x(i+1)) y = MAX(z,v,w) IF (y == z) THEN g(i) = g(i)+4.0_prec*x(i)*x(i)*x(i) g(i+1) = two*x(i+1) ELSE IF (y == v) THEN g(i) = g(i)+two*x(i)-4.0_prec g(i+1) = two*x(i+1)-4.0_prec ELSE g(i) = g(i) - w g(i+1) = w END IF END DO CASE (5) ! Chained CB3 II (convex) g(1)=zero y = MAX(f_k(1),f_k(2),f_k(3)) IF (y == f_k(1)) THEN DO i=1,n-1 g(i) = g(i)+4.0_prec*x(i)*x(i)*x(i) g(i+1) = two*x(i+1) END DO ELSE IF (y == f_k(2)) THEN DO i=1,n-1 g(i) = g(i)+two*x(i)-4.0_prec g(i+1) = two*x(i+1)-4.0_prec END DO ELSE DO i=1,n-1 g(i) = g(i) - two*EXP(-x(i)+x(i+1)) g(i+1) = two*EXP(-x(i)+x(i+1)) END DO END IF CASE (6) ! Number of active faces (nonconvex) IF (hit == n+1) THEN DO i=1,n g(i) = f_sign/(ABS(f_k(1))+one) END DO ELSE g = zero g(hit) = f_sign/(ABS(x(hit))+one) END IF CASE (7) ! Nonsmooth generalization of Brown function 2 (nonconvex) g(1)=zero DO i=1,n-1 y = ABS(x(i)) z = ABS(x(i+1)) v = x(i)*x(i)+one w = x(i+1)*x(i+1)+one u = zero IF (z > u) u = LOG(z) IF (x(i) < zero) THEN g(i) = g(i)-w*y**(w-one)+two*x(i)*u*z**v ELSE g(i) = g(i)+w*y**(w-one)+two*x(i)*u*z**v END IF u = zero IF (x(i+1) == zero) THEN g(i+1) = zero ELSE IF (x(i+1) < zero) THEN IF (y > u) u = LOG(y) g(i+1)=-v*z**(v-one)+two*x(i+1)*u*y**w ELSE IF (y > u) u = LOG(y) g(i+1)=v*z**(v-one)+two*x(i+1)*u*y**w END IF END DO CASE (8) ! Chained mifflin 2 (nonconvex) g(1)=zero DO i=1,n-1 y = x(i)*x(i) + x(i+1)*x(i+1) - one f_sign = SIGN(3.5_prec,y) + 4.0_prec g(i) = g(i) + f_sign*x(i) - one g(i+1) = f_sign*x(i+1) END DO CASE (9) ! Chained crescent I (nonconvex) g(1)=zero IF (f_k(1) >= f_k(2)) THEN DO i=1,n-1 g(i)=g(i)+two*x(i) g(i+1)=two*(x(i+1)-one) + one END DO ELSE DO i=1,n-1 g(i)=g(i)-two*x(i) g(i+1)=-two*(x(i+1)-one) + one END DO END IF CASE (10) ! Chained crescent II (nonconvex) g(1)=zero DO i=1,n-1 y = x(i)*x(i) + (x(i+1)-one)*(x(i+1)-one) & + x(i+1) - one z = - x(i)*x(i) - (x(i+1)-one)*(x(i+1)-one) & + x(i+1) + one IF (y >= z) THEN g(i)=g(i)+two*x(i) g(i+1)=two*(x(i+1)-one) + one ELSE g(i)=g(i)-two*x(i) g(i+1)=-two*(x(i+1)-one) + one END IF END DO CASE DEFAULT ! Error PRINT*,'Error: Not such a problem.' next=-1 END SELECT END SUBROUTINE subgra !************************************************************************ !* !* * SUBROUTINE fungra * !* !* !* * Purpose * !* !* Computation of the value and the subgradient of the objective !* function. !* !* !* * Calling sequence * !* !* CALL fungra(n,x,f,g) !* !* !* * Parameters * !* !* II n Number of variables. !* RI x(n) Vector of variables. !* RO f Value of the objective function. !* RO g(n) Subgradient of the objective function. !* !* !* * Modules * !* !* problem_data, ONLY : next,hit !* r_precision, ONLY : prec !* SUBROUTINE fungra(n,x,f,g) ! USE problem_data, ONLY : next ! no need, if inside MODULE large_problems ! USE precision, ONLY : prec ! no need, if inside MODULE large_problems ! USE problem_data, ONLY : hit ! no need, we can have local hit "pip" IMPLICIT NONE ! Scalar Arguments INTEGER, INTENT(IN) :: n ! Number of variables REAL(KIND=prec), INTENT(OUT) :: f ! Value of the objective ! Array Arguments REAL(KIND=prec), DIMENSION(n), INTENT(IN) :: x ! Vector of variables REAL(KIND=prec), DIMENSION(n), INTENT(OUT) :: g ! Subgradient ! Local Arguments INTEGER :: i,j,pip REAL(KIND=prec), PARAMETER :: zero=0.0, one=1.0, two=2.0 REAL(KIND=prec) :: y,z,v,w,u ! Intrinsic Functions INTRINSIC ABS,MAX,SIGN,LOG,EXP,REAL SELECT CASE (next) CASE (1) ! Generalization of MAXQ (convex) f = x(1)*x(1) g(1) = zero pip = 1 DO i=2,n y = x(i)*x(i) IF (y > f) THEN f = y pip = i END IF g(i) = zero END DO g(pip) = two*x(pip) CASE (2) ! Generalization of MXHILB (convex) f = zero pip = 1 DO j=1,n f = f + x(j)/REAL(j, KIND=prec) END DO g(1) = SIGN(one,f) f = ABS(f) DO i=2,n y = zero DO j=1,n y = y + x(j)/REAL(i+j-1, KIND=prec) END DO g(i) = SIGN(one,y) y = ABS(y) IF (y > f) THEN f = y pip = i END IF END DO z = g(pip) DO j=1,n g(j) = z/REAL(pip+j-1, KIND=prec) END DO CASE (3) ! Chained LQ (convex) f = zero g(1) = zero DO i=1,n-1 g(i+1) = zero y = -x(i)-x(i+1) z = -x(i)-x(i+1)+(x(i)*x(i)+x(i+1)*x(i+1)-one) IF (y >= z) THEN f = f+y g(i) = g(i)-one g(i+1) = -one ELSE f = f+z g(i) = g(i)-one+two*x(i) g(i+1) = -one+two*x(i+1) ENDIF END DO CASE (4) ! Chained CB3 I (convex) f = zero g(1) = zero DO i=1,n-1 g(i+1) = zero z = x(i)*x(i)*x(i)*x(i)+x(i+1)*x(i+1) v = (two-x(i))*(two-x(i))+(two-x(i+1))*(two-x(i+1)) w = two*EXP(-x(i)+x(i+1)) y = MAX(z,v,w) IF (y == z) THEN g(i) = g(i)+4.0_prec*x(i)*x(i)*x(i) g(i+1) = two*x(i+1) ELSE IF (y == v) THEN g(i) = g(i)+two*x(i)-4.0_prec g(i+1) = two*x(i+1)-4.0_prec ELSE g(i) = g(i) - w g(i+1) = w END IF f = f+y END DO CASE (5) ! Chained CB3 II (convex) f = zero g(1) = zero y = zero z = zero v = zero DO i=1,n-1 g(i+1) = zero y = y+x(i)*x(i)*x(i)*x(i)+x(i+1)*x(i+1) z = z+(two-x(i))*(two-x(i))+(two-x(i+1))*(two-x(i+1)) v = v+two*EXP(-x(i)+x(i+1)) END DO f=MAX(y,z,v) IF (f == y) THEN DO i=1,n-1 g(i) = g(i)+4.0_prec*x(i)*x(i)*x(i) g(i+1) = two*x(i+1) END DO ELSE IF (f == z) THEN DO i=1,n-1 g(i) = g(i)+two*x(i)-4.0_prec g(i+1) = two*x(i+1)-4.0_prec END DO ELSE DO i=1,n-1 g(i) = g(i) - two*EXP(-x(i)+x(i+1)) g(i+1) = two*EXP(-x(i)+x(i+1)) END DO END IF CASE (6) ! Number of active faces (nonconvex) w = one y = -x(1) f = LOG(ABS(x(1))+one) pip = 1 DO i=2,n y = y - x(i) z = LOG(ABS(x(i))+one) IF(f < z) THEN pip = i f = z END IF END DO z = LOG(ABS(y)+one) IF(f < z) THEN f = z IF (y >= zero) w = -one DO i=1,n g(i) = w/(ABS(y)+one) END DO ELSE IF (x(pip) < zero) w = -one g = zero g(pip) = w/(ABS(x(pip))+one) END IF CASE (7) ! Nonsmooth generalization of Brown function 2 (nonconvex) f = zero g(1) = zero DO i=1,n-1 y =ABS(x(i)) z =ABS(x(i+1)) v =x(i)*x(i)+one w =x(i+1)*x(i+1)+one f = f+z**v+y**w u = zero IF (z > u) u = LOG(z) IF (x(i) < zero) THEN g(i) = g(i)-w*y**(w-one)+two*x(i)*u*z**v ELSE g(i) = g(i)+w*y**(w-one)+two*x(i)*u*z**v END IF u = zero IF (x(i+1) == zero) THEN g(i+1)=zero ELSE IF (x(i+1) < zero) THEN IF (y > u) u = LOG(y) g(i+1)=-v*z**(v-one)+two*x(i+1)*u*y**w ELSE IF (y > u) u = LOG(y) g(i+1)=v*z**(v-one)+two*x(i+1)*u*y**w END IF END DO CASE (8) ! Chained mifflin 2 (nonconvex) f = zero g(1) = zero DO i=1,n-1 y = x(i)*x(i) + x(i+1)*x(i+1) - one f = f -x(i) + two*y + 1.75_prec*ABS(y) y = SIGN(3.5_prec,y) + 4.0_prec g(i) = g(i) + y*x(i) - one g(i+1) = y*x(i+1) END DO CASE (9) ! Chained crescent I (nonconvex) y = zero z = zero DO i=1,n-1 y = y + x(i)*x(i) + (x(i+1)-one)*(x(i+1)-one) & + x(i+1) - one z = z - x(i)*x(i) - (x(i+1)-one)*(x(i+1)-one) & + x(i+1) + one END DO f = MAX(y,z) g(1) = zero IF (y >= z) THEN DO i=1,n-1 g(i) = g(i)+two*x(i) g(i+1) = two*(x(i+1)-one) + one END DO ELSE DO i=1,n-1 g(i) = g(i)-two*x(i) g(i+1) = -two*(x(i+1)-one) + one END DO END IF CASE (10) ! Chained crescent II (nonconvex) f = zero g(1) = zero DO i=1,n-1 y = x(i)*x(i) + (x(i+1)-one)*(x(i+1)-one) & + x(i+1) - one z = - x(i)*x(i) - (x(i+1)-one)*(x(i+1)-one) & + x(i+1) + one IF (y >= z) THEN f = f+y g(i) = g(i)+two*x(i) g(i+1) = two*(x(i+1)-one) + one ELSE f = f+z g(i) = g(i)-two*x(i) g(i+1) = -two*(x(i+1)-one) + one END IF END DO CASE DEFAULT PRINT*,'Error: Not such a problem.' next=-1 END SELECT END SUBROUTINE fungra END MODULE large_problems