Line data    Source code

       1              : module test_newuoa
       2              : 
       3              :    use num_def
       4              :    use num_lib
       5              :    use const_def, only: dp
       6              : 
       7              :    implicit none
       8              : 
       9              :    integer :: nfcn
      10              : 
      11              : contains
      12              : 
      13            1 :    subroutine do_test_newuoa
      14              : 
      15              : !     The Chebyquad test problem (Fletcher, 1965) for N = 2,4,6 and 8,
      16              : !     with NPT = 2N+1.
      17              : !
      18           11 :       real(dp), dimension(10) :: X
      19        10001 :       real(dp), dimension(10000) :: W
      20              :       real(dp), parameter :: max_valid_value = 1d99
      21              :       real(dp) :: f, RHOBEG, RHOend
      22              :       integer :: IPRINT, I, N, NPT, MAXFUN
      23              :       include 'formats'
      24            1 :       IPRINT = 0
      25            1 :       MAXFUN = 5000
      26            1 :       RHOend = 1.0D-6
      27            4 :       do N = 2, 6, 2
      28            3 :          nfcn = 0
      29            3 :          NPT = 2*N + 1
      30           15 :          do I = 1, N
      31           15 :             X(I) = DBLE(I)/DBLE(N + 1)
      32              :          end do
      33            3 :          RHOBEG = 0.2D0*X(1)
      34            3 :          write (*, '(4X,A,I2,A,I3)') 'test NEWUOA with N =', N, ' and NPT =', NPT
      35            3 :          call NEWUOA(N, NPT, X, RHOBEG, RHOend, IPRINT, MAXFUN, W, CALFUN, max_valid_value)
      36            3 :          call calfun(n, x, f)
      37              :          !write(*,2) 'f', nfcn, f
      38            4 :          if (abs(f) > 1d-10) write (*, *) 'failed in test of newuoa: min f', f
      39              :       end do
      40            1 :    end subroutine do_test_newuoa
      41              : 
      42          313 :    subroutine calfun(n, x, f)
      43              :       use const_def, only: dp
      44              :       integer, intent(in) :: n
      45              :       real(dp), intent(in) :: x(*)
      46              :       real(dp), intent(out) :: f
      47              : 
      48              :       integer :: I, J, IW, NP
      49        34743 :       real(dp) :: Y(10, 10), sum
      50          313 :       nfcn = nfcn + 1
      51         1879 :       do J = 1, N
      52         1566 :          Y(1, J) = 1.0D0
      53         1879 :          Y(2, J) = 2.0D0*X(J) - 1.0D0
      54              :       end do
      55         1566 :       do I = 2, N
      56         8404 :       do J = 1, N
      57         8091 :          Y(I + 1, J) = 2.0D0*Y(2, J)*Y(I, J) - Y(I - 1, J)
      58              :       end do
      59              :       end do
      60          313 :       F = 0.0D0
      61          313 :       NP = N + 1
      62          313 :       IW = 1
      63         2192 :       do I = 1, NP
      64              :          SUM = 0.0D0
      65        11849 :          do J = 1, N
      66        11849 :             SUM = SUM + Y(I, J)
      67              :          end do
      68         1879 :          SUM = SUM/DBLE(N)
      69         1879 :          IF (IW > 0) SUM = SUM + 1.0D0/DBLE(I*I - 2*I)
      70         1879 :          IW = -IW
      71         2192 :          F = F + SUM*SUM
      72              :       end do
      73          313 :       return
      74              :    end subroutine CALFUN
      75              : 
      76              : end module test_newuoa