      MODULE m_triang
      use m_juDFT
!-------------------------------------------------------------------
c     find a triangular decomposition of the irreducible wedge of
c     the first brillouin zone for a given k-mesh. k-points at all
c     vertices are assumed.
c     erich wimmer     july 1981
!-------------------------------------------------------------------

      IMPLICIT NONE

      CONTAINS
      SUBROUTINE triang(
     >                  v,nkpt,
     <                  it,ntria,at,att,l_f_t)

      USE m_constants

c     Arguments
      INTEGER, INTENT(IN)  :: nkpt
      REAL,    INTENT(IN)  :: v(3,nkpt)
      REAL,    INTENT(OUT) :: att , at(2*nkpt)
      INTEGER, INTENT(OUT) :: ntria , it(3,2*nkpt)
      LOGICAL, INTENT(INOUT) :: l_f_t
c     locals
      REAL    :: a, a1, d, dm, s0, s1, x1, x2, x3, y1, y2, y3
      INTEGER :: j , j1 , j2 , jc , jj , k , k1 , k2 , k3 , kk , l1 ,
     &           l2 , l3 , n , nt0 , nkpts
      LOGICAL :: new
c     constants
      REAL , PARAMETER :: zero = 0.0 , big = 1.e8 , tol = 1.e-5

      ntria = 0
      IF ( nkpt.LT.3 ) RETURN
c
c l_f_t=.true. means that we call from fertri and on output gives 'film'
c
      IF (l_f_t) THEN ! check for bulk
         DO j= 2,nkpt
            IF (abs(v(3,j)-v(3,1)).GT.1.0e-12) THEN
              l_f_t = .false.
              nkpts = j - 1
              IF ((mod(nkpt,nkpts).NE.0).OR.(j.LT.3)) THEN
                WRITE (oUnit,*)
     +             'tria=T & film=F requires k-point planes'
                WRITE (oUnit,*) 'with equally distributed k-points !'
c                 CALL juDFT_error("not a k-point set for tria=T & film=F",calledby="triang")
              ENDIF
!              RETURN
              GOTO 10
            ENDIF
         ENDDO
         l_f_t = .true.
         nkpts = nkpt
 10      CONTINUE
      ELSE
c
c l_f_t=.false. means that we call from evaldos
c
         nkpts = nkpt
         DO j= 2,nkpt
            IF (abs(v(3,j)-v(3,1)).GT.1.0e-12) THEN
              nkpts = j - 1
              GOTO 11
           ENDIF
        ENDDO
 11     CONTINUE
        IF ((mod(nkpt,nkpts).NE.0).OR.(j.LT.3)) THEN
          l_f_t = .false.
          RETURN
        ELSE
          l_f_t = .true.
        ENDIF
      ENDIF
c
c     create first triangle
c
      att = zero
      k1 = 1
      dm = big
      DO k = 2 , nkpts
         d = vd2(v(1,K1),v(2,k1),v(1,k),v(2,k))
         IF ( d.LT.dm ) THEN
            dm = d
            k2 = k
         ENDIF
      ENDDO
c
      dm = big
      new = .false.
      DO k = 1 , nkpts
         IF ( k.NE.k1 .AND. k.NE.k2 ) THEN
            d = VD2(V(1,k1),V(2,k1),V(1,k),V(2,k))
     &          + VD2(V(1,k2),V(2,k2),V(1,k),V(2,k))
            a = AREA(V(1,k1),V(2,k1),V(1,k2),V(2,k2),V(1,k),V(2,k))
            IF ( ABS(a).GE.TOL ) THEN
               IF ( d.LT.dm ) THEN
                  new = .TRUE.
                  dm = d
                  a1 = a
                  k3 = k
               ENDIF
            ENDIF
         ENDIF
      ENDDO
      IF ( new ) THEN
         Ntria = 1
         It(1,Ntria) = k1
         IF ( k3.LE.k2 ) THEN
            kk = k2
            k2 = k3
            k3 = kk
         ENDIF
         It(2,Ntria) = k2
         It(3,Ntria) = k3
         At(Ntria) = ABS(a1)/2
         Att = Att + At(Ntria)
c
c     create, if possible, a new triangle from each side of the mother
c     triangle nt0 with minimal sum of sides
c
         nt0 = 0
         DO WHILE ( .TRUE. )
            nt0 = nt0 + 1
            IF ( nt0.GT.Ntria ) RETURN
            DO l1 = 1 , 3
               l2 = MOD(l1,3) + 1
               l3 = MOD(l2,3) + 1
               k1 = It(l1,nt0)
               k2 = It(l2,nt0)
               IF ( k2.LE.k1 ) THEN
                  kk = k1
                  k1 = k2
                  k2 = kk
               ENDIF
c--->>     check if side k1-k2 belongs already to another triangle
               new = .TRUE.
               DO n = 1 , Ntria
                  IF ( n.NE.nt0 ) THEN
                     IF ( (k1.EQ.It(1,n) .AND. k2.EQ.It(2,n)) .OR.
     &                    (k1.EQ.It(1,n) .AND. k2.EQ.It(3,n)) .OR.
     &                    (k1.EQ.It(2,n) .AND. k2.EQ.It(3,n)) )
     &                    new = .FALSE.
                  ENDIF
               ENDDO
               IF ( new ) THEN
                  k3 = It(l3,nt0)
                  a = AREA(V(1,k1),V(2,k1),V(1,k2),V(2,k2),V(1,k3),
     &                V(2,k3))
                  s0 = SIGN(1.,a)
c--->>     a new triangle sharing the side k1-k2 with the mother
c--->>     triangle nt0 has to ly on the other side, i.e. the cross
c--->>     products (k2-k1)x(k3(old)-k1) and (k2-k1)x(k3(new)-k1)
c--->>     have to have opposite signs
                  dm = BIG
                  new = .FALSE.
                  DO k = 1 , Nkpts
                     IF ( k.NE.k1 .AND. k.NE.k2 ) THEN
c--->>     check if a new side, (k1,k) or (k2,k), belongs
c--->>     already to an older triangle
                        j1 = k1
                        j2 = k
                        DO j = 1 , 2
                           IF ( j2.LE.j1 ) THEN
                              jj = j1
                              j1 = j2
                              j2 = jj
                           ENDIF
                           jc = 0
                           DO n = 1 , Ntria
                              IF ( j1.EQ.It(1,n) .AND. j2.EQ.It(2,n)
     &                             .OR. j1.EQ.It(1,n) .AND.
     &                             j2.EQ.It(3,n) .OR. j1.EQ.It(2,n)
     &                             .AND. j2.EQ.It(3,n) ) jc = jc + 1
                           ENDDO
                           IF ( jc.EQ.2 ) GOTO 5
                           j1 = k2
                           j2 = k
                        ENDDO
                        a = AREA(V(1,k1),V(2,k1),V(1,k2),V(2,k2),V(1,k),
     &                      V(2,k))
                        IF ( ABS(a).GE.TOL ) THEN
                           s1 = SIGN(1.,a)
                           IF ( ABS(s1-s0).GE.TOL ) THEN
                              d = VD2(V(1,k1),V(2,k1),V(1,k),V(2,k))
     &                            + VD2(V(1,k2),V(2,k2),V(1,k),V(2,k))
                              IF ( d.LT.dm ) THEN
                                 new = .TRUE.
                                 dm = d
                                 a1 = a
                                 k3 = k
                              ENDIF
                           ENDIF
                        ENDIF
                     ENDIF
 5                ENDDO
                  IF ( new ) THEN
                     Ntria = Ntria + 1
                     IF ( Ntria>2*nkpt )  CALL juDFT_error("ntriad"
     +                    ,calledby ="triang")
c
                     IF ( k2.LE.k1 ) THEN
                        kk = k1
                        k1 = k2
                        k2 = kk
                     ENDIF
                     IF ( k3.LE.k1 ) THEN
                        kk = k1
                        k1 = k3
                        k3 = kk
                     ENDIF
                     IF ( k3.LE.k2 ) THEN
                        kk = k2
                        k2 = k3
                        k3 = kk
                     ENDIF
                     It(1,Ntria) = k1
                     It(2,Ntria) = k2
                     It(3,Ntria) = k3
                     At(Ntria) = ABS(a1)/2
                     Att = Att + At(Ntria)
                  ENDIF
               ENDIF
            ENDDO
         ENDDO
      ELSE
      ENDIF
c
99001 FORMAT (' $$$ error in triang: collinear k-points'/(5x,2F12.6))
c
      END SUBROUTINE triang
!-----------------------------------------------------
      REAL FUNCTION vd2(x1,y1,x2,y2)         ! distance between (x1,y1) and (x2,y2)
         REAL x1,y1,x2,y2
         vd2 = (x2-x1)**2 + (y2-y1)**2
      END FUNCTION vd2
      REAL FUNCTION area(x1,y1,x2,y2,x3,y3)  ! area of triangle (x1,y1),(x2,y2),(x3,y3)
         REAL x1,y1,x2,y2,x3,y3
         area = (x2-x1)*(y3-y1) - (x3-x1)*(y2-y1)
      END FUNCTION area
!-----------------------------------------------------
      END MODULE m_triang


function fminunc(N,fun,X,X0,grad,options,info,typical_val) result(residual)
!
!   Copyright 2017, Viktor Reshiak, All rights reserved.
!
!
!   Purpose
!   =======
!   Find minimum of the scalar function of several variables.
!
!
!   Method
!   ======
!   John Burkardt's f90 implementation of the TOMS 611 algorithm
!   ( model/trust-region approach and the double-dogleg technique )
!
!
!   IN
!   ==
!   1) N       - dimension of the input vector
!   3) fun     - objective function
!   5) X0      - (optional) initial guess as a separate vector
!   6) grad    - (optional) gradient of the objective function
!   7) options - (optional) struct with options of the solver
!
!
!   INOUT
!   =====
!   4) X       - initial guess / final solution
!
!
!   OUT
!   ===
!   8) info    - (optional) structure with information about solution process
!
	implicit none

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! dummy arguments

    procedure(fminunc_objective_fun)                       :: fun
    procedure(fminunc_objective_grad), optional            :: grad

    integer(kind=4), intent(in)                            :: N
       real(kind=8), intent(inout), dimension(N)           :: X
       real(kind=8), intent(in),    dimension(N), optional :: X0
       real(kind=8), intent(in),    dimension(N), optional :: typical_val

    type (fsolve_options), intent(in),  optional           :: options
    type (fsolve_info),    intent(out), optional           :: info

        real(kind=8) :: residual

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	! parameters of the sumsl/smsno solver

       real(kind=8), dimension(N)   :: d
    integer(kind=4)                 :: lv
       real(kind=8), dimension(:), allocatable  :: v
    integer(kind=4), parameter      :: liv = 60
!     integer(kind=4), parameter      :: lv  = 77 + N*(N+17)/2
    integer(kind=4), dimension(liv) :: iv
!        real(kind=8), dimension(lv)  :: v

    integer,      dimension(1) :: uip
    real(kind=8), dimension(1) :: urp

    external smsno

    ! dtrnlsp_init
    type(fsolve_options) :: op

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    lv  = 77 + N*(N+17)/2

    allocate( v(lv) )

    if ( present(options) ) then
        op = options
    else
        op = default_fsolve_options
    endif

    if ( present(X0) ) then
        X = X0
    endif

    ! scaling vector
    if ( present(typical_val) ) then
        ! TODO: is this correct?
        d = 1.0 / typical_val
    else
        d = 1.0d0
        !d(1:N/3) = 1.d3
    endif

    ! default options
    call deflt(2, iv, liv, lv, v)
    iv(17) = 10000
    iv(18) = 10000
    iv(21) = 0
    !v(31)  = 1.0e-10
    !v(32)  = 1.0e-10
    v(35) = 1.d-6

    call smsno ( N, d, X, objective_fun, iv, liv, lv, v, uip, urp, fun )

    !print*, iv(1), v(10)

    residual = v(10)

    contains

    subroutine objective_fun(dim_X,X,nf,f,uip,urp,ufp)
        integer,      intent(in)                     :: dim_X, nf
        real(kind=8), intent(in),  dimension(dim_X ) :: X
        real(kind=8), intent(out)                    :: f
        integer,      dimension(:)                   :: uip
        real(kind=8), dimension(:)                   :: urp
        external                                     :: ufp

        f = fun(dim_X,X)
    end

end function fminunc