ex_nlsqp_bc_f90_x.f90

!*******************************************************************************
!   Copyright(C) 2004-2013 Intel Corporation. All Rights Reserved.
!   
!   The source code, information  and  material ("Material") contained herein is
!   owned  by Intel Corporation or its suppliers or licensors, and title to such
!   Material remains  with Intel Corporation  or its suppliers or licensors. The
!   Material  contains proprietary information  of  Intel or  its  suppliers and
!   licensors. The  Material is protected by worldwide copyright laws and treaty
!   provisions. No  part  of  the  Material  may  be  used,  copied, reproduced,
!   modified, published, uploaded, posted, transmitted, distributed or disclosed
!   in any way  without Intel's  prior  express written  permission. No  license
!   under  any patent, copyright  or  other intellectual property rights  in the
!   Material  is  granted  to  or  conferred  upon  you,  either  expressly,  by
!   implication, inducement,  estoppel or  otherwise.  Any  license  under  such
!   intellectual  property  rights must  be express  and  approved  by  Intel in
!   writing.
!   
!   *Third Party trademarks are the property of their respective owners.
!   
!   Unless otherwise  agreed  by Intel  in writing, you may not remove  or alter
!   this  notice or  any other notice embedded  in Materials by Intel or Intel's
!   suppliers or licensors in any way.
!
!*******************************************************************************
!   Content : TR Solver F90 example
!
!********************************************************************************


MODULE U_DATA
TYPE, PUBLIC :: MY_DATA
      INTEGER a
      INTEGER sum
END TYPE MY_DATA
END MODULE

!    nonlinear least square problem without boundary constraints
      INCLUDE 'mkl_rci.f90'
      PROGRAM EXAMPLE_EX_NLSQP_BC_F90_X
      USE MKL_RCI
      USE MKL_RCI_TYPE
      USE U_DATA
      IMPLICIT NONE
!     user's objective function
      EXTERNAL extendet_powell 
!     n - number of function variables
!     m - dimension of function value
      INTEGER n, m
      PARAMETER (n = 4)
      PARAMETER (m = 4)
!     precisions for stop-criteria (see manual for more detailes)
      REAL*8 eps(6)
!     solution vector. contains values x for f(x)
      REAL*8 x(n)
!     iter1 - maximum number of iterations
!     iter2 - maximum number of iterations of calculation of trial-step
      INTEGER iter1, iter2
      PARAMETER (iter1 = 1000)
      PARAMETER (iter2 = 100)
!     initial step bound
      REAL*8 rs
!     reverse communication interface parameter
      INTEGER RCI_Request
!     controls of rci cycle
      INTEGER successful
!     function (f(x)) value vector
      REAL*8 fvec(m)
!     jacobi matrix
      REAL*8 fjac(m*n)
!     lower and upper bounds
      REAL*8 LW(n)
      REAL*8 UP(n)
!     number of iterations
      INTEGER iter
!     number of stop-criterion
      INTEGER st_cr
!     initial and final residuals
      REAL*8 r1, r2
!     TR solver handle
      TYPE(HANDLE_TR) :: handle
!     cycle's counter
      INTEGER i
!    results of input parameter checking
      INTEGER info(6)

!     Additional users data
      TYPE(MY_DATA) :: m_data
      m_data%a = 1
      m_data%sum = 0
      rs = 0.0

!     set precisions for stop-criteria
      do i=1, 6
        eps(i) = 0.00001
      enddo
!     set the initial guess
      do i=1, n/4
        x(4 * (i-1) + 1) = 3.0
        x(4 * (i-1) + 2) = -1.0
        x(4 * (i-1) + 3) = 0.0
        x(4 * (i-1) + 4) = 1.0
      enddo
!     set initial values
      do i=1, m
        fvec(i) = 0.0
      enddo
      do i=1, m * n
        fjac(i) = 0.0
      enddo

!     set bounds
      do i=1, n/4
        LW(4 * (i-1) + 1) = 0.1;
        LW(4 * (i-1) + 2) = -20.0;
        LW(4 * (i-1) + 3) = -1.0;
        LW(4 * (i-1) + 4) = -1.0;
        UP(4 * (i-1) + 1) = 100.0;
        UP(4 * (i-1) + 2) = 20.0;
        UP(4 * (i-1) + 3) = 1.0;
        UP(4 * (i-1) + 4) = 50.0;
      enddo
!     initialize solver (allocate mamory, set initial values)
!       handle       in/out: TR solver handle
!       n       in:     number of function variables
!       m       in:     dimension of function value
!       x       in:     solution vector. contains values x for f(x)
!       LW           in:             lower bound
!       UP           in:             upper bound
!       eps     in:     precisions for stop-criteria
!       iter1   in:     maximum number of iterations
!       iter2   in:     maximum number of iterations of calculation of trial-step
!       rs      in:     initial step bound
      if (dtrnlspbc_init (handle,n,m,x,LW,UP,eps,iter1,iter2,rs).ne.TR_SUCCESS) then
!         if function does not complete successfully then print error message
         print*,'| error in dtrnlspbc_init'
!         Release internal MKL memory that might be used for computations.
!         NOTE: It is important to call the routine below to avoid memory leaks
!         unless you disable MKL Memory Manager
!         and exit
         call MKL_FREE_BUFFERS
         stop 1
      endif
!       Checks the correctness of handle and arrays containing Jacobian matrix, 
!       objective function, lower and upper bounds, and stopping criteria.
      if (dtrnlspbc_check (handle, n, m, fjac, fvec, LW, UP, eps, info) .ne. TR_SUCCESS) then
!         if function does not complete successfully then print error message
         print*,'| error in dtrnlspbc_init'
!         Release internal MKL memory that might be used for computations.
!         NOTE: It is important to call the routine below to avoid memory leaks
!         unless you disable MKL Memory Manager
         call MKL_FREE_BUFFERS
!         and exit
         stop 1
      else
        if ( &
!        The handle is not valid. 
          info(1) .ne. 0 .or. &
!        The fjac array is not valid.
          info(2) .ne. 0 .or. &
!        The fvec array is not valid.
          info(3) .ne. 0 .or. &
!        The LW array is not valid.
          info(4) .ne. 0 .or. &
!        The UP array is not valid.
          info(5) .ne. 0 .or. &
!        The eps array is not valid.
          info(6) .ne. 0 ) then
           print*,'| input parameters for dtrnlspbc_solve are not valid'
!            Release internal MKL memory that might be used for computations.
!            NOTE: It is important to call the routine below to avoid memory leaks
!            unless you disable MKL Memory Manager
!            and exit
            call MKL_FREE_BUFFERS
            stop 1
        endif
      endif
!     set initial rci cycle variables
      RCI_Request = 0
      successful = 0
!     rci cycle
      do while (successful .eq. 0)
!         call tr solver
!           handle               in/out: tr solver handle
!           fvec         in:     vector
!           fjac         in:     jacobi matrix
!           RCI_request in/out:  return number which denote next step for performing
        if (dtrnlspbc_solve (handle, fvec, fjac, RCI_Request) .ne. TR_SUCCESS) then
!             if function does not complete successfully then print error message
            print*, '| error in dtrnlspbc_solve'
!             Release internal MKL memory that might be used for computations.
!             NOTE: It is important to call the routine below to avoid memory leaks
!             unless you disable MKL Memory Manager
            call MKL_FREE_BUFFERS
!             and exit
            stop 1;
        endif
!       according with rci_request value we do next step
        if (RCI_Request .eq. -1 .or. &
             RCI_Request .eq. -2 .or. &
             RCI_Request .eq. -3 .or. &
             RCI_Request .eq. -4 .or. &
             RCI_Request .eq. -5 .or. RCI_Request .eq. -6) then
!             exit rci cycle
            successful = 1
        endif
        if (RCI_Request .eq. 1) then
!               recalculate function value
!               m            in:     dimension of function value
!               n            in:     number of function variables
!               x            in:     solution vector
!               fvec    out:    function value f(x)
            call extendet_powell (m, n, x, fvec, m_data)
        endif
        if (RCI_Request .eq. 2) then
!               compute jacobi matrix
!               extendet_powell      in:     external objective function
!               n               in:     number of function variables
!               m               in:     dimension of function value
!               fjac            out:    jacobi matrix
!               x               in:     solution vector
!               jac_eps         in:     jacobi calculation precision !/
            if (djacobix (extendet_powell,n,m,fjac,x,eps(1),%VAL(LOC(m_data))).ne.TR_SUCCESS) then
!                 if function does not complete successfully then print error message
                print*, '| error in djacobix'
!                 Release internal MKL memory that might be used for computations.
!                 NOTE: It is important to call the routine below to avoid memory leaks
!                 unless you disable MKL Memory Manager
                call MKL_FREE_BUFFERS
!                 and exit
                stop 1;
            endif
        endif
      enddo
!       get solution statuses
!       handle            in:        TR solver handle
!       iter              out:       number of iterations
!       st_cr             out:       number of stop criterion
!       r1                out:       initial residuals
!       r2                out:       final residuals
      if (dtrnlspbc_get (handle, iter, st_cr, r1, r2) .ne. TR_SUCCESS) then
!         if function does not complete successfully then print error message
        print*, '| error in dtrnlspbc_get'
!         Release internal MKL memory that might be used for computations.
!         NOTE: It is important to call the routine below to avoid memory leaks
!         unless you disable MKL Memory Manager
        call MKL_FREE_BUFFERS
!         and exit
        stop 1
      endif
      print*, 'Iterations : ',iter
      print*, 'Final residual : ',r2
      print*, 'Stop-criteria : ',st_cr
!     free handle memory
      if (dtrnlspbc_delete (handle) .ne. TR_SUCCESS) then
!         if function does not complete successfully then print error message
        print*, '| error in dtrnlspbc_delete'
!         Release internal MKL memory that might be used for computations.
!         NOTE: It is important to call the routine below to avoid memory leaks
!         unless you disable MKL Memory Manager
        call MKL_FREE_BUFFERS
!         and exit
        stop 1
      endif

!     Release internal MKL memory that might be used for computations.
!     NOTE: It is important to call the routine below to avoid memory leaks
!     unless you disable MKL Memory Manager
      call MKL_FREE_BUFFERS
!     if final residual less then required precision then print pass

      print*, 'User data ', m_data%sum

      if (r2 < 0.1) then
        print*, '|         dtrnlspbc powell............PASS'
        stop 0
!     else print failed
      else
        print*, '|         dtrnlspbc powell............FAILED'
        stop 1;
      endif
      END PROGRAM EXAMPLE_EX_NLSQP_BC_F90_X

!     nonlinear system equations without constraints
!     routine for extendet powell function calculation
!     m     in:     dimension of function value
!     n     in:     number of function variables
!     x     in:     vector for function calculating
!     f     out:    function value f(x)
!     user_data in: additional users data

      SUBROUTINE extendet_powell (m, n, x, f, user_data)
      USE U_DATA
      IMPLICIT NONE
      INTEGER m, n
      REAL*8  x(n), f(m)
      TYPE(MY_DATA) :: user_data
      INTEGER i

      user_data%sum = user_data%sum + user_data%a

      do i = 1, n/4
        f(4 * (i-1) + 1) = x(4 * (i-1) + 1) + 10.0 * x(4 * (i-1) + 2)
        f(4 * (i-1) + 2) = 2.2360679774998 * (x(4 * (i-1) + 3) - x(4 * (i-1) + 4))
        f(4 * (i-1) + 3) = (x(4 * (i-1) + 2) - 2.0 * x(4 * (i-1) + 3)) * (x(4 * (i-1) + 2) - 2.0 * x(4 * (i-1) + 3))
        f(4 * (i-1) + 4) = 3.1622776601684 * (x(4 * (i-1) + 1) - x(4 * (i-1) + 4)) * (x(4 * (i-1) + 1) - x(4 * (i-1) + 4))
      enddo
      ENDSUBROUTINE extendet_powell
For more complete information about compiler optimizations, see our Optimization Notice.