      SUBROUTINE PAIR_ENERGY(RSQ,EIJ)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Calculates the energy between a pair of atoms
!! Current supports 6 different pair potentials
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file
      IMPLICIT NONE

      REAL(kind = double) :: EIJ,RSQ
      REAL(kind = double) :: RRR,RR6,RR12
      REAL(kind = double) :: R,RDIF,RDIF2,RDIF3
      REAL(kind = double) :: RATIO,FACT1
      REAL(kind = double) :: FACTOR

      SELECT CASE (IPOT_TYPE) ! choose option depending on potential type

        CASE(1)   ! Cut LJ potential

          RRR = 1.0D0/RSQ
          RR6 = RRR*RRR*RRR
          RR12 = RR6*RR6
          EIJ = 4.0d0*EPS*(RR12 - RR6)

        CASE(2)   ! Splined-LJ potential

          IF(RSQ.LE.RCUT_INNER_SQ) THEN
            RRR = 1.0D0/RSQ
            RR6 = RRR*RRR*RRR
            RR12 = RR6*RR6
            EIJ = 4.0d0*EPS*(RR12 - RR6)
          ELSE
            R = SQRT(RSQ)
            RDIF = R - RCUT
            RDIF2 = RDIF*RDIF
            RDIF3 = RDIF2*RDIF
            EIJ = SPLINE_R2*RDIF2 + SPLINE_R3*RDIF3
          END IF

        CASE(3)   ! Smooth repulsive potential

          RATIO = RSQ/CUTSQ
          EIJ = EPS*(1.0D0 - RATIO)**4

        CASE(4)   ! m-n family of potentials

          FACTOR = 2.0D0 - RSQ
          EIJ = (M_RATIO*FACTOR**N_POWER - N_RATIO*FACTOR**M_POWER)

        CASE(5)   ! Lucy potential

          R = SQRT(RSQ)
          RATIO = R/RCUT
          FACT1 = (1.0D0 - RATIO)
          EIJ = EFACT_LUCY*FACT1**3*(1.0D0 + 3.0D0*RATIO)

        CASE(6)   ! Soft disk potential

          EIJ = 1.0D0/(RSQ**SOFT_N)

        CASE(7)   ! WCA potential

          RRR = 1.0D0/RSQ
          RR6 = RRR*RRR*RRR
          RR12 = RR6*RR6
          EIJ = 4.0d0*(RR12 - RR6) + 1.0d0

      END SELECT

      END SUBROUTINE


program test

  ! Import dependencies
  use lapack, only : dgetrf
  use linear_algebra
  use direct_linear_solve, only : dlufactor, dluppfactor

  implicit none

  integer, parameter :: sizes(6) = [200, 400, 800, 1000, 2000, 4000]
  integer :: i, npts

  ! Run for all problem sizes
  do i = 1, size(sizes)

     npts = sizes(i)

     call gesolve(npts)
     call geppsolve(npts)
     !call exact(npts)

  end do

!  call time_report(.false.)
!  call time_report(.true.)

contains

  subroutine geppsolve(npts)

    ! Problem setup
    integer, intent(in) :: npts

    ! Matrices and vectors
    real(8), allocatable, dimension(:,:) :: A, L, U, P
    real(8), allocatable, dimension(:)   :: x, xtmp, b, y

    ! Physics parameters
    real(8), parameter :: lambdas(2) = [0.0d0, 10.0d0]
    real(8) :: lambda
    integer :: flag, i, k

    ! Filename
    character(len=50) :: filename
    character(len=50) :: strlambda, strnpts

    ! Run for each lambda
    do k = 1, size(lambdas)

       lambda = lambdas(k)

       ! Create filename and open
       write(strlambda,*) int(lambda)
       write(strnpts,*) int(npts)
       filename = 'gepp-solution-lam-'// trim(adjustl(strlambda)) &
            & //"-npts-" // trim(adjustl(strnpts)) //'.dat'
       open(11,file=filename)
       write(11,*) "x ", "u"

       ! Allocate matrices
       allocate(A(npts, npts))
       allocate(L, U, P, source = A)
       A = 0.0d0
       L = 0.0d0
       U = 0.0d0
       P = 0.0d0

       ! Allocate vectors
       allocate(x(npts))
       allocate(xtmp, b, y, source = x)
       x    = 0.0d0
       xtmp = 0.0d0
       b    = 0.0d0

       ! Solve x
       call assemble_system(0.0d0, 1.0d0, npts, A, b, x, lambda)
       call dluppfactor(A, L, U, P, flag)
       b = matmul(P,b)
       call fwdsub(L, b, y, flag)
       call backsub(U, y, x, flag)

       ! Write output
       do i = 1, npts
          write(11, *) dble(i)/dble(npts), x(i)
       end do

       close(11)

       deallocate(A,L,U,P,x,xtmp,b,y)

    end do

  end subroutine geppsolve

  pure real(8) function uhat(x, lambda)

    real(8), intent(in) :: x
    real(8), intent(in) :: lambda

    real(8) :: alpha

    alpha = sqrt(lambda)
    uhat =  2.d0*exp(-alpha*x)*(exp(2.d0*alpha)-exp(2.d0*alpha*x))/(exp(2.d0*alpha)-1.d0)

  end function uhat

  subroutine gesolve(npts)

    ! Problem setup
    integer, intent(in) :: npts

    ! Matrices and vectors
    real(8), allocatable, dimension(:,:) :: A, L, U, P
    real(8), allocatable, dimension(:)   :: x, xtmp, b, y

    ! Physics parameters
    real(8), parameter :: lambdas(2) = [0.0d0, 10.0d0]
    real(8) :: lambda
    integer :: flag, i, k

    ! Filename
    character(len=50) :: filename
    character(len=50) :: strlambda, strnpts

    ! Run for each lambda
    do k = 1, size(lambdas)

       lambda = lambdas(k)

       ! Create filename and open
       write(strlambda,*) int(lambda)
       write(strnpts,*) int(npts)
       filename = 'ge-solution-lam-'// trim(adjustl(strlambda)) &
            & //"-npts-" // trim(adjustl(strnpts)) //'.dat'
       open(11,file=filename)
       write(11,*) "x ", "u"

       ! Allocate matrices
       allocate(A(npts, npts))
       allocate(L, U, P, source = A)
       A = 0.0d0
       L = 0.0d0
       U = 0.0d0
       P = 0.0d0

       ! Allocate vectors
       allocate(x(npts))
       allocate(xtmp, b, y, source = x)
       x    = 0.0d0
       xtmp = 0.0d0
       b    = 0.0d0

       ! Solve x
       call assemble_system(0.0d0, 1.0d0, npts, A, b, x, lambda)
       call dlufactor(A, L, U, flag)
       call fwdsub(L, b, y, flag)
       call backsub(U, y, x, flag)

       ! Write output
       do i = 1, npts
          write(11, *) dble(i)/dble(npts), x(i)
       end do

       close(11)

       deallocate(A,L,U,P,x,xtmp,b,y)

    end do

  end subroutine gesolve

  subroutine time_report(pivot)

    ! Problem setup
    integer :: npts
    logical :: pivot

    ! Matrices and vectors
    real(8), allocatable, dimension(:,:) :: A, L, U, P
    real(8), allocatable, dimension(:)   :: x, xtmp, b, y

    ! Timing variables
    real(8) :: total_start, total_finish, total_time
    real(8) :: assembly_start, assembly_finish, assembly_time
    real(8) :: factor_start, factor_finish, factor_time
    real(8) :: elim_start, elim_finish, elim_time

    integer, parameter :: sizes(6) = [200, 400, 800, 1000, 2000, 4000]
    real(8), parameter :: lambdas(2) = [0.0d0, 10.0d0]
    real(8) :: lambda
    integer :: flag, i, k

    ! Run for each lambda
    do k = 1, size(lambdas)

       lambda = lambdas(k)

       ! Write the time for each linear solve
       if (pivot .eqv. .false.) then
          if (k .eq. 1) then
             open(11, file='time_study_ge_lam0.dat')
          else
             open(11, file='time_study_ge_lam10.dat')
          end if
       else
          if (k .eq. 1) then
             open(11, file='time_study_gepp_lam0.dat')
          else
             open(11, file='time_study_gepp_lam10.dat')
          end if
       end if
       write(11, *) "size ", "factor_time ", "elim_time ", "total_time"

       ! Run for all problem sizes
       do i = 1, size(sizes)

          npts = sizes(i)

          ! Allocate matrices
          allocate(A(npts, npts))
          allocate(L, U, P, source = A)
          A = 0.0d0
          L = 0.0d0
          U = 0.0d0
          P = 0.0d0

          ! Allocate vectors
          allocate(x(npts))
          allocate(xtmp, b, y, source = x)
          x    = 0.0d0
          xtmp = 0.0d0
          b    = 0.0d0

          call cpu_time(total_start)

          ! Assemble linear system
          call cpu_time(assembly_start)
          call assemble_system(0.0d0, 1.0d0, npts, A, b, x, lambda)
          call cpu_time(assembly_finish)
          assembly_time = assembly_finish-assembly_start
          print *, "assembled system in ", assembly_time

          call cpu_time(factor_start)
          if (pivot .eqv. .false.) then
             ! Ax = b  is now LUx = b
             call dlufactor(A, L, U, flag)
          else
             call dluppfactor(A, L, U, P, flag)
             b = matmul(P,b)
          end if
          call cpu_time(factor_finish)
          factor_time = factor_finish-factor_start
          print *, "factorized matrix in ", factor_time

          call cpu_time(elim_start)

          ! Solve Ly = b
          call fwdsub(L, b, y, flag)

          ! Solve Ux = y
          call backsub(U, y, x, flag)

          call cpu_time(elim_finish)
          elim_time = elim_finish-elim_start
          print *, "elimination completed in ", elim_time

          call cpu_time(total_finish)
          total_time = total_finish - total_start
          print '("Time = ",f6.3," seconds.")', total_time

          ! Write output data
          write(11, *) npts, factor_time, elim_time, total_time

          deallocate(A,L,U,P,x,xtmp,b,y)

       end do

       close(11)

    end do

  end subroutine time_report

  ! Model problem to solve
  subroutine assemble_system(a, b, npts, V, rhs, u, lambda, homogenous)

    use linear_algebra, only : inv

    real(8), intent(in)  :: a, b ! bound of domain
    integer              :: npts ! number of points
    real(8), intent(out) :: V(npts,npts)
    real(8), intent(out) :: rhs(npts)
    real(8), intent(out) :: u(npts)
    real(8)              :: h
    real(8), intent(in)  :: lambda
    real(8), parameter   :: PI = 3.141592653589793d0
    integer              :: m, n, i, j
    logical, intent(in), optional :: homogenous

    h = (b-a)/dble(npts+1)
    V = 0.0d0

    m = npts
    n = npts
    do i = 1, m
       do j = 1, n
          if (i .eq. j-1) then
             V(i,j) = -1.0d0
          else if (i .eq. j+1) then
             V(i,j) = -1.0d0
          else if (i .eq. j) then
             V(i,i) = 2.0d0 + lambda*h*h
          else
             ! skip zeros
          end if
       end do
    end do

    if(present(homogenous)) then
       ! Assemble the RHS
       rhs = 0.0d0
       rhs(1)    = 2.0d0
       rhs(npts) = 0.0d0
    else
       ! Assemble the RHS
       rhs = 0.0d0
       rhs(1)    = 2.0d0 + h*h*(3.0d0*(dble(i)*h)**2.0d0 - 0.5d0)
       rhs(npts) = 0.0d0 + h*h*(3.0d0*(dble(npts)*h)**2.0d0 - 0.5d0)
    end if

    ! Initial solution profile (straight line)
    do i = 1, npts
       u(i) = 2.0d0 + ((0.0d0+2.0d0)/(b-a))*(dble(i)*h)
    end do

  end subroutine assemble_system

end program test


!############################################################################################
!
! Copyright 2021 Bharat Mahajan
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!    http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
!> \brief       Lorenz Test Main Program
!! \details     Main program to run Lorenz test.
!! \author      Bharat Mahajan
!! \date        09/17/2021
!
!############################################################################################

module LorenzDiffEq

    use FLINT

    use, intrinsic :: IEEE_ARITHMETIC

    implicit none

    ! user diff eq system

    type, extends(DiffEqSys) :: LorenzSys
        real(WP) :: sigma = 10.0_WP
        real(WP) :: rho = 28.0_WP
        real(WP) :: beta = 8.0_WP/3.0_WP
    contains
        procedure :: F => LorenzDE
    end type LorenzSys

    contains

    function LorenzDE(me, X, Y, Params)
        intrinsic :: size
        class(LorenzSys), intent(inout) :: me !< Differential Equation object
        real(WP), intent(in) :: X
        real(WP), intent(in), dimension(me%n) :: Y
        real(WP), intent(in), dimension(:), optional :: Params

        real(WP), dimension(size(Y)) :: LorenzDE

        LorenzDE(1) = me%sigma*(Y(2) - Y(1))
        LorenzDE(2) = Y(1)*(me%rho - Y(3)) - Y(2)
        LorenzDE(3) = Y(1)*Y(2) - me%beta*Y(3)
    end function LorenzDE

end module LorenzDiffEq

    program LorenzTest

    use iso_fortran_env, only: output_unit
    use FLINT
    use LorenzDiffEq

    implicit none

    ! Simulation Parameters

    ! Number of periodic orbits to run and loops for benchmark
    integer, parameter :: nloops = 100
    integer, parameter :: floops = 100000000

    ! solvers to run from 1 to 4
    integer, parameter :: nmethod = 4

    ! scalar tolerance
    real(WP), parameter :: rtol   = 1.0e-11_WP
    real(WP), parameter :: atol   = rtol*1.0e-3_WP

    ! max no. of steps
    integer, parameter :: MAX_STEPS = 100000
    logical, parameter :: CONST_STEPSZ = .FALSE.

    ! random dispersion of IC: this multiplies the random number
    real(WP), parameter :: randon = 0.000000000000_WP

    ! Interpolation points
    integer, parameter :: nIp = int(1000.0)

    ! results file
    character(len=20) :: fname = 'results_Lorenz.txt'
    character(len=20) :: spfname = 'states_ip_Lorenz.txt'

    type(ERK_class) :: erkvar
    type(LorenzSys) :: LorenzObj

    real(WP) :: x0, xf, xfval, rnum
    real(WP), dimension(3) :: y0, yf, y0r

    character(len=:), allocatable :: errstr

    real(WP) :: stepsz0, ipdx, stepsz
    real(WP), dimension(:), allocatable, target :: Xint, Xarr
    real(WP), dimension(:,:), allocatable, target :: Yint, Yarr
    integer :: stiffstatus, stifftestval
    integer :: nsteps, naccpt, nrejct, fcalls, steps, itr, nevents, ctr
    character(len=10) :: mname
    integer :: method

    real(WP) :: T0, Tf

    real(WP), dimension(3), parameter :: params = [10.0_WP, 28.0_WP, 8.0_WP/3.0_WP]

    y0 = [1.0_WP, 0.0_WP, 0.0_WP]

    x0 = 0.0_WP
    xF = 100.0_WP

    LorenzObj%n = 3
    LorenzObj%m = 0
    ! LorenzObj%G => SampleEvent

    stepsz0 = 0.0E-2_WP    ! let FLINT compute the initial step-size
    stifftestval = 1*0  ! check for stiffness and stop integration if stiff

    ! arrays for interpolated data
    ipdx = (xf-x0)/(nIp-1)
    Xarr = [(x0+ipdx*itr,itr=0,(nIp-1))]
    Xarr(nIp) = xf
    allocate(Yarr(3,size(Xarr)))

    ! create results file
    open(unit=17,file= fname, status = 'replace')
    write(17, *) '--- FLINT Stats ---'
    write(17, *) ' '
    write(17, *) 'A. Internal Step-size'
    write(17, '(6A12)') 'Method', 'Time(s)', 'FCalls', 'Accepted', 'Rejected', 'Total Steps'

    ! states using interpolation
    open(unit=19,file= spfname, status = 'replace')
    write(19, '(4A12)') 'X','Y1','Y2','Y3'

    ! Solution at internal step size

    do itr = 1, nmethod

        select case (itr)
        case (1)
            mname = 'DOP54'
            method = ERK_DOP54
        case (2)
            mname = 'DOP853'
            method = ERK_DOP853
        case (3)
            mname = 'Verner65E'
            method = ERK_Verner65E
        case (4)
            mname = 'Verner98R'
            method = ERK_Verner98R
        end select

        call erkvar%Init(LorenzObj, MAX_STEPS, Method=method, ATol=[atol], RTol=[rtol],&
            InterpOn=.FALSE.)
        if (erkvar%status == FLINT_SUCCESS) then

            y0r = y0
            call CPU_TIME(t0)
            do ctr = 1,nloops
                stiffstatus = stifftestval
                stepsz = stepsz0
                xfval = xf
                call RANDOM_NUMBER(rnum) ! randomize initial condition
                y0r(1) = y0r(1) + rnum*randon*y0r(1)

                call erkvar%Integrate(x0, y0r, xfval, yf, StepSz=stepsz, UseConstStepSz=CONST_STEPSZ, &
                    IntStepsOn=.FALSE.,StiffTest=stiffstatus)
            end do
            call CPU_TIME(tf)

            if (stiffstatus == -1) write(17, *) mname//': problem is stiff'

            if (erkvar%status == FLINT_SUCCESS .OR. erkvar%status == FLINT_EVENT_TERM &
                        .OR. erkvar%status == FLINT_ERROR_MAXSTEPS) then
                call erkvar%Info(stiffstatus, errstr, nAccept=naccpt, nReject=nrejct, nFCalls=fcalls, nSteps = steps)

                write(17, '(A12,1F12.3,4I12.1)') mname, (tf-t0), fcalls, naccpt, nrejct, steps
            else
                call erkvar%Info(stiffstatus, errstr)
                write(17,*) mname//': Integrate failed: ', erkvar%status, ':', errstr
            end if

            ! ! write states
            ! if (itr == 2) then
            !     do ctr = 1, size(Xint)
            !         write(18, '(7E18.9)') Xint(ctr), Yint(1:3,ctr)
            !     end do
            ! end if

            if (allocated(Xint)) deallocate(Xint)
            if (allocated(Yint)) deallocate(Yint)
        else
            write(17,*) mname//': Init failed: ', erkvar%status
        end if
    end do

     ! Solution at interpolated grid
     write(17, *) 'B. Interpolated Grid'
     write(17, '(6A12)') 'Method', 'Time(s)', 'FCalls', 'Accepted', 'Rejected', 'Total Steps'

     do itr = 1, nmethod

         select case (itr)
         case (1)
             mname = 'DOP54'
             method = ERK_DOP54
         case (2)
             mname = 'DOP853'
             method = ERK_DOP853
         case (3)
             mname = 'Verner65E'
             method = ERK_Verner65E
         case (4)
             mname = 'Verner98R'
             method = ERK_Verner98R
         end select

         call erkvar%Init(LorenzObj, MAX_STEPS, Method=method, ATol=[atol], RTol=[rtol],&
             InterpOn=.TRUE.)

         if (erkvar%status == FLINT_SUCCESS) then

             y0r = y0
             call CPU_TIME(t0)
             do ctr = 1,nloops
                 stiffstatus = stifftestval
                 stepsz = stepsz0
                 xfval = xf
                 call RANDOM_NUMBER(rnum) ! randomize initial condition
                 y0r(1) = y0r(1) + rnum*randon*y0r(1)
                 call erkvar%Integrate(x0, y0r, xfval, yf, StepSz=stepsz, UseConstStepSz=CONST_STEPSZ, &
                     StiffTest=stiffstatus, params=params)
             end do
             call CPU_TIME(tf)
             call erkvar%Interpolate(Xarr,Yarr,.TRUE.)

             if (stiffstatus == -1) write(17, *) mname//': problem is stiff'

             if (erkvar%status == FLINT_SUCCESS .OR. erkvar%status == FLINT_EVENT_TERM &
                         .OR. erkvar%status == FLINT_ERROR_MAXSTEPS) then
                 call erkvar%Info(stiffstatus, errstr, nAccept=naccpt, nReject=nrejct, nFCalls=fcalls, nSteps=steps)

                 write(17, '(A12,1F12.3,4I12.1)') mname, (tf-t0), fcalls, naccpt, nrejct, steps

             else
                 call erkvar%Info(stiffstatus, errstr)
                 write(17,*) mname//': Integrate failed: ', erkvar%status, ':',errstr
             end if

             ! write states
             if (itr == 2) then
                 do ctr = 1, size(Xarr)
                     write(19, '(7E18.9)') Xarr(ctr), Yarr(1:3,ctr)
                 end do
             end if

         else
             write(17,*) mname//': Init failed: ', erkvar%status
         end if
     end do

    ! function test
    y0r = y0*0.0_WP
    call CPU_TIME(t0)
    do ctr = 1,floops
        !y0 = y0 + 0.0001_WP*y0
        yf = LorenzObj%F(x0, y0, params)
        y0r = y0r + yf
    end do
    call CPU_TIME(tf)
    write(17, *) ' '
    write(17, '(I12,A13,F12.2,A5)') floops, ' Func calls: ', (tf-t0)*1.0e3_WP, ' ms'

    contains

    end program LorenzTest


!! CANTIDADES DERIVADAS DE LOS PARAMETROS DEL PROGRAMA !!

subroutine initial

    use arrays
    use global

    implicit none

    !cantidades derivadas de la metrica de Schwar
    alpha       = 1.0d0/sqrt(1.0d0 + 2.0d0/x)
    dalpha      = 1.0d0/(x**2*(1.0d0 + 2.0d0/x)**(3.0d0/2.0d0))
    beta        = 2.0d0/(x*(1.0d0 + 2.0d0/x))
    dbeta       = -2.0d0/(2.0d0 + x)**2.0d0
    gamma       = sqrt(x**4*(1.0d0 + 2.0d0/x))
    dgamma      = (x**2*(3.0d0 + 2.0d0*x))/sqrt(x**3*(2.0d0 + x))
    gamma_rr    = 1.0d0 + 2.0d0/x
    dgamma_rr   = -2.0d0/x**2

    !campos
    Phi         = amplitude*exp(-(x-x0)**2/sigma**2)
    Psi         = -2.0d0*Phi*((x-x0)/sigma**2)
    Pi          = 0.0d0

    call constriction_calc   !resolvemos las ecs. de ligadura

end subroutine initial


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Tool_Area_Polygon(x,y,nb,area)
	  !get area of a polygon

      ! Code converted using TO_F90 by Alan Miller
      ! Date: 2000-07-04  Time: 12:24:06

      IMPLICIT NONE
      integer nb
      double precision x(nb)
      double precision y(nb)
      INTEGER i, n, nm1
      double precision a,area

      !*****************************************************************

      ! GIVEN A SEQUENCE OF NB POINTS (X(I),Y(I)),  polyarea COMPUTES THE AREA
      ! BOUNDED BY THE CLOSED POLYGONAL CURVE WHICH PASSES THROUGH THE POINTS IN
      ! THE ORDER THAT THEY ARE INDEXED.  THE FINAL POINT OF THE CURVE IS ASSUMED
      ! TO BE THE FIRST POINT GIVEN.  THEREFORE, IT NEED NOT BE LISTED AT THE END
      ! OF X AND Y.  THE CURVE IS NOT REQUIRED TO BE SIMPLE.  e.g. It may cross over
      ! itself.

      !*****************************************************************

      n = nb
      IF ((x(1) .eq. x(n)) .AND. (y(1) .eq. y(n))) n = n - 1

      SELECT CASE (n)
      CASE (:2)
          area = 0.0D0

      CASE (3)
          area=0.5D0*((x(2)-x(1))*(y(3)-y(1))-(x(3)-x(1))*(y(2)-y(1)))

      CASE DEFAULT
          nm1 = n - 1
          a = x(1)*(y(2) - y(n)) + x(n)*(y(1) - y(nm1))

          DO  i = 2, nm1
              a = a + x(i)*(y(i+1) - y(i-1))
          END DO

          area = 0.5D0*a
      END SELECT

      RETURN
      END subroutine Tool_Area_Polygon


!-----------------------------------------------------------------------
      program test
      implicit none
      include 'ceed/fortran.h'

      integer ceed,err,i,j,kk
      real*8 a(16), q(16), qlambdaqt(16), lambda(4), sum

      character arg*32

      a = (/ 0.2, 0.0745355993, -0.0745355993, 0.0333333333,&
     &       0.0745355993, 1., 0.1666666667, -0.0745355993,&
     &      -0.0745355993, 0.1666666667, 1., 0.0745355993,&
     &      0.0333333333, -0.0745355993, 0.0745355993, 0.2 /)

      call getarg(1,arg)

      call ceedinit(trim(arg)//char(0),ceed,err)

     do i=0,3
       do j=1,4
         q(4*i+j)=a(4*i+j)
       enddo
     enddo

      call ceedsymmetricschurdecomposition(ceed,q,lambda,4,err)

!     Check A = Q lambda Q^T
      do i=0,3
        do j=0,3
          sum = 0
          do kk=0,3
            sum=sum+q(kk+i*4+1)*lambda(kk+1)*q(kk+j*4+1)
          enddo
          qlambdaqt(j+i*4+1)=sum
        enddo
      enddo
      do i=0,3
        do j=1,4
          if (abs(a(i*4+j) - qlambdaqt(i*4+j))>1.0D-14) then
! LCOV_EXCL_START
            write(*,'(A,I1,A,I1,A,F12.8,A,F12.8)') 'Error: [', &
     &      i,',',j-1,'] ',a(i*4+j),'!=',qlambdaqt(i*4+j)
! LCOV_EXCL_STOP
          endif
        enddo
      enddo

      call ceeddestroy(ceed,err)

      end
!-----------------------------------------------------------------------


program complex2
complex :: x
x = (3.0, 4.0)
x = x * 4.0
print *, x
x = 2 * x
print *, x
x = (x * (0.0, 3.0))
print *, x
end program


       function func(x)
        func=4.*x+5.
        end

        program ejercicio 9

        implicit none

        external func
        integer::N,i,f
        real::func,aa,bb,cc,Ym,Xm
        real,allocatable,dimension(:)::A,B,C,D, Dif

        open(20, FILE='ejercicio9.dat', STATUS='UNKNOWN')

   !   genero N numeros random entre 0 y 1 y los guardo en un vector A

        call error (A,N)

   !   genero Xn numeros en el intervalo(a,b) y los guardo en un vector B

        call  inter(B,N)

   !   evaluo los  numeros en el intervalo para obtener el valor de la
   !   funcion desplazada un numero random entre 0 y 1 en la funcion
    !  guardo los valores de Y en un vector llamado C

       allocate(C(N))

       do i=1,N

          C(i) = func(B(i)) + A(i)

       end do

   !    ajuste de puntos.

   !   obtengo mis valores medios

       do i= 1,N

          Xm= B(i)+ Xm
          Ym= C(i)+ Ym

       end do

       Ym=Ym/N
       Xm=Xm/N

   !   calculo el valor de la pendiente y de la ordenada

       cc=0
       aa=0
       bb=0

       do i = 1,N

          cc=B(i)*B(i)+cc

          aa=B(i)*C(i)+aa

      !si no pongo esto da todo mal

       end do

        aa=(aa-Xm*Ym*N)/(cc-Xm*Xm*N)
        bb=Ym-aa*Xm

           ! esta tmb es necesaria

 !     obtengo los puntos de la recta de ajuste y los guardo en un vector llamado D

       allocate(D(N))

       do i = 1,N
          D(i)=aa*(B(i))+bb

         end do

   !  comparacion de esos valores con los de al funcion

      allocate(Dif(N))

       do i = 1,N

          Dif(i) = C(i)-D(i)

       end do

   !   --------------------------------------------------------------
           write(20,*) "i  Xe   Ye  Ya   Ye-Ya"

       do i = 1,N

           write(20,*) i,B(i),C(i),D(i),Dif(i)

       end do
           write(20,*)'   '
           write(20,*) "LA RECTA AJUSTADA ES:",'  Y =',aa,'*   X   +',bb
           write(20,*)'   '

       pause
       deallocate(A,B,C,D,Dif)

        close(20)

!      ----------------------------------------------------------------
   !    subrutinas
!      ----------------------------------------------------------------

       contains

!      ----------------------------------------------------------------

        subroutine  error(A,N)

        implicit none
        INTEGER i, N
        real,allocatable,dimension(:)::A

        write(*,*) 'introduzca el numero de puntos que desea'
        read(*,*) N

       allocate(A(N))
        do i = 1, N
          A(i) = ran()
        end do
        end subroutine

!      ----------------------------------------------------------------

        subroutine  inter(B,N)

        real,allocatable,dimension(:)::B
        real::k,f
        integer:: N
        write(*,*) 'introduzca el numero menor del intervalo'
        read(*,*) k
        write(*,*) 'introduzca el numero mayor del intervalo'
        read(*,*) f

 !     presentacion de los datos

        write(20,*) ' '
        write(20,*) 'Notacion:'
        write(20,*) ' '
        write(20,*) "     Ye,Xe = valor de Y/X experimental"
        write(20,*) "     Ya = valor de Y ajustado"
        write(20,*) ' '
        write(20,*) "En el intervalo",'(',k,',',f,')'
        write(20,*) "usando ",N,' Puntos'

        allocate(B(N))

        do i = 1, N
           B(i)= ran ( )
           B(i)=k+B(i)*(f-k)

        end do

        end subroutine

!      ----------------------------------------------------------------

        end

!      ----------------------------------------------------------------


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2014 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!   This module computes the mean yaw moment using the far-field momentum formulation for a infinite depth
!   case according to equation 4.6 of R1
!
!  R1 Computation of Higher-Order Hydrodynamic Forces on Ships and Offshore Structures in Waves
!             http://dspace.mit.edu/bitstream/handle/1721.1/79979/42664020.pdf?sequence=1
!
! Contest Drift forces and QTF Implementation of Nemoh
!
!
! Changes in version 1.1 (Implementation of Higher Order Panel Methods)
!       Added COMMON_TYPE module as dependency
!
! Changes in version 1.2 (Dipoles Implementation in NEMOH)
!       Switch from ParamsCommon to ParamsCommonInf
!
!   @author yedtoss
!   @version 1.2

module COMPUTE_YAW_MOMENT_INF

    USE COMMON_TYPE
    USE COM_VAR
    USE UTILITY
    USE KOCHIN

    implicit none

contains

    complex function diff_func_yaw_infinite(theta, param)
        ! Simple wrapper to the kochin function
        USE KOCHIN

        REAL, INTENT(IN) :: theta
        COMPLEX:: fx
        TYPE(ParamsCommonInf) :: param

        CALL COMPUTE_KOCHIN(param%kwave, theta, fx, param%SolverVar)
        diff_func_yaw_infinite = fx

    end function diff_func_yaw_infinite

    complex function yawintegral_mz(theta, param)
        ! Derivative of the kochin function multiplied the the conjugate of the value of kochin function at theta

        USE KOCHIN
        REAL, INTENT(IN) :: theta
        TYPE(ParamsCommonInf) :: param
        COMPLEX :: HKochin

        CALL COMPUTE_KOCHIN(param%kwave, theta, HKochin, param%SolverVar)

        yawintegral_mz = CONJG(HKochin)*deriv_richardson_complex(diff_func_yaw_infinite,theta, 1, 1e-3, param)

    end function yawintegral_mz

    subroutine compute_yaw_moment_infinite(param, yaw_moment)
        ! This is the main subrouting computing the yaw moment
        ! It use romberg_trap_complex to integrate the function yawintegralfin_mz
        ! and deriv_richardson_complex to find the derivative of the diff_func_yaw_finite

        REAL :: PI
        TYPE(ParamsCommonInf) :: param ! input parameter
        REAL :: yaw_moment, tmp  ! yaw_moment is the output

        PI=4.*ATAN(1.)

        tmp = (-0.5*aimag(deriv_richardson_complex(diff_func_yaw_infinite,PI+param%beta, 1, 1e-3, param)))

        yaw_moment = (-RHO* (param%kwave)/(8*PI))*AIMAG(romberg_trap_complex(yawintegral_mz, 0., 2*PI, 1e-3, 2, param))

        yaw_moment = yaw_moment + RHO*param%w*param%AKH/param%kwave*tmp

    end subroutine compute_yaw_moment_infinite
end module COMPUTE_YAW_MOMENT_INF


C$Procedure      UCRSS ( Unitized cross product, 3x3 )

      SUBROUTINE UCRSS ( V1, V2, VOUT )

C$ Abstract
C
C      Compute the normalized cross product of two 3-vectors.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      VECTOR
C
C$ Declarations

      DOUBLE PRECISION   V1   ( 3 )
      DOUBLE PRECISION   V2   ( 3 )
      DOUBLE PRECISION   VOUT ( 3 )

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C       V1        I     Left vector for cross product.
C       V2        I     Right vector for cross product.
C       VOUT      O     Normalized cross product (V1xV2) / |V1xV2|.
C
C$ Detailed_Input
C
C      V1   A 3-vector.
C
C      V2   A 3-vector.
C
C$ Detailed_Output
C
C      VOUT is the result of the computation (V1xV2)/|V1xV2|
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      None.
C
C$ Examples
C
C      To get a unit normal to the plane spanned by two vectors
C      V1 and V2. Simply call
C
C         CALL UCRSS ( V1, V2, NORMAL )
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If the cross product of V1 and V2 yields the zero-vector, then
C        the zero-vector is returned instead of a vector of unit length.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.M. Owen       (JPL)
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     unitized cross product
C
C-&

C$ Revisions
C
C-    Beta Version 1.1.0, 10-JAN-1989 (WLT)
C
C     Error free specification added. In addition the algorithm was made
C     more robust in the sense that floating point overflows cannot
C     occur.
C
C-&
      DOUBLE PRECISION      VNORM
      DOUBLE PRECISION      VCROSS(3)
      DOUBLE PRECISION      VMAG

      DOUBLE PRECISION      MAXV1
      DOUBLE PRECISION      MAXV2

      DOUBLE PRECISION      TV1 ( 3 )
      DOUBLE PRECISION      TV2 ( 3 )

C
C     Get the biggest component of each of the two vectors.
C
      MAXV1 = MAX ( DABS(V1(1)), DABS(V1(2)), DABS(V1(3)) )
      MAXV2 = MAX ( DABS(V2(1)), DABS(V2(2)), DABS(V2(3)) )

C
C     Scale V1 and V2 by 1/MAXV1 and 1/MAXV2 respectively
C
      IF ( MAXV1 .NE. 0 ) THEN
         TV1(1) = V1(1)/MAXV1
         TV1(2) = V1(2)/MAXV1
         TV1(3) = V1(3)/MAXV1
      ELSE
         TV1(1) = 0.0D0
         TV1(2) = 0.0D0
         TV1(3) = 0.0D0
      END IF

      IF ( MAXV2 .NE. 0 ) THEN
         TV2(1) = V2(1)/MAXV2
         TV2(2) = V2(2)/MAXV2
         TV2(3) = V2(3)/MAXV2
      ELSE
         TV2(1) = 0.0D0
         TV2(2) = 0.0D0
         TV2(3) = 0.0D0
      END IF

C
C  Calculate the cross product of V1 and V2
C
      VCROSS(1) = TV1(2)*TV2(3) - TV1(3)*TV2(2)
      VCROSS(2) = TV1(3)*TV2(1) - TV1(1)*TV2(3)
      VCROSS(3) = TV1(1)*TV2(2) - TV1(2)*TV2(1)
C
C  Get the magnitude of VCROSS and normalize it
C
      VMAG = VNORM(VCROSS)

      IF (VMAG.GT.0.D0) THEN
         VOUT(1) = VCROSS(1) / VMAG
         VOUT(2) = VCROSS(2) / VMAG
         VOUT(3) = VCROSS(3) / VMAG
      ELSE
         VOUT(1) = 0.D0
         VOUT(2) = 0.D0
         VOUT(3) = 0.D0
      END IF

      RETURN
      END