! ------------------------------------------------------------------
! Programmer(s): David J. Gardner, and Cody J. Balos @ LLNL
! ------------------------------------------------------------------
! SUNDIALS Copyright Start
! Copyright (c) 2002-2021, Lawrence Livermore National Security
! and Southern Methodist University.
! All rights reserved.
!
! See the top-level LICENSE and NOTICE files for details.
!
! SPDX-License-Identifier: BSD-3-Clause
! SUNDIALS Copyright End
! ------------------------------------------------------------------
! The following is a simple example problem with an analytical
! solution.
!
!   dy/dt = lamda*y + 1/(1+t^2) - lamda*atan(t)
!
! for t in the interval [0.0, 10.0], with initial condition: y=0.
!
! The stiffness of the problem is directly proportional to the
! value of lamda. The value of lamda should be negative to
! result in a well-posed ODE; for values with magnitude larger
! than 100 the problem becomes quite stiff.
! ------------------------------------------------------------------

module ode_mod

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  !======= Declarations =========
  implicit none

  ! number of equations
  integer(c_long), parameter :: neq = 1

  ! ODE parameters
  double precision, parameter :: lamda = -100.0d0

contains

  ! ----------------------------------------------------------------
  ! RhsFn provides the right hand side function for the
  ! ODE: dy/dt = f(t,y)
  !
  ! Return values:
  !    0 = success,
  !    1 = recoverable error,
  !   -1 = non-recoverable error
  ! ----------------------------------------------------------------
  integer(c_int) function RhsFn(tn, sunvec_y, sunvec_f, user_data) &
       result(ierr) bind(C,name='RhsFn')

    !======= Inclusions ===========
    use, intrinsic :: iso_c_binding
    use fsundials_nvector_mod

    !======= Declarations =========
    implicit none

    ! calling variables
    real(c_double), value :: tn        ! current time
    type(N_Vector)        :: sunvec_y  ! solution N_Vector
    type(N_Vector)        :: sunvec_f  ! rhs N_Vector
    type(c_ptr), value    :: user_data ! user-defined data

    ! pointers to data in SUNDIALS vectors
    real(c_double), pointer :: yvec(:)
    real(c_double), pointer :: fvec(:)

    !======= Internals ============

    ! get data arrays from SUNDIALS vectors
    yvec => FN_VGetArrayPointer(sunvec_y)
    fvec => FN_VGetArrayPointer(sunvec_f)

    ! fill RHS vector
    fvec(1) = lamda*yvec(1) + 1.0/(1.0+tn*tn) - lamda*atan(tn)

    ! return success
    ierr = 0
    return

  end function RhsFn

end module ode_mod

program main

  !======= Inclusions ===========
  use, intrinsic :: iso_c_binding

  use fcvode_mod                    ! Fortran interface to CVODE
  use fsundials_context_mod         ! Fortran interface to SUNContext
  use fsundials_nvector_mod         ! Fortran interface to generic N_Vector
  use fnvector_serial_mod           ! Fortran interface to serial N_Vector
  use fsundials_nonlinearsolver_mod ! Fortran interface to generic SUNNonlinearSolver
  use fsunnonlinsol_fixedpoint_mod  ! Fortran interface to fixed point SUNNonlinearSolver
  use ode_mod                       ! ODE functions

  !======= Declarations =========
  implicit none

  ! local variables
  real(c_double) :: tstart     ! initial time
  real(c_double) :: tend       ! final time
  real(c_double) :: rtol, atol ! relative and absolute tolerance
  real(c_double) :: dtout      ! output time interval
  real(c_double) :: tout       ! output time
  real(c_double) :: tcur(1)    ! current time
  integer(c_int) :: ierr       ! error flag from C functions
  integer(c_int) :: nout       ! number of outputs
  integer(c_int) :: outstep    ! output loop counter
  type(c_ptr)    :: cvode_mem  ! CVODE memory
  type(c_ptr)    :: ctx        ! SUNDIALS simulation context

  type(N_Vector), pointer           :: sunvec_y ! sundials vector
  type(SUNNonlinearSolver), pointer :: sunnls   ! sundials fixed-point nonlinear solver

  ! solution vector, neq is set in the ode_mod module
  real(c_double) :: yvec(neq)

  !======= Internals ============

  ierr = FSUNContext_Create(c_null_ptr, ctx)

  ! initialize ODE
  tstart = 0.0d0
  tend   = 10.0d0
  tcur   = tstart
  tout   = tstart
  dtout  = 1.0d0
  nout   = ceiling(tend/dtout)

  ! initialize solution vector
  yvec(1) = 0.0d0

  ! create SUNDIALS N_Vector
  sunvec_y => FN_VMake_Serial(neq, yvec, ctx)
  if (.not. associated(sunvec_y)) then
     print *, 'ERROR: sunvec = NULL'
     stop 1
  end if

  ! create CVode memory
  cvode_mem = FCVodeCreate(CV_ADAMS, ctx)
  if (.not. c_associated(cvode_mem)) then
     print *, 'ERROR: cvode_mem = NULL'
     stop 1
  end if

  ! initialize CVode
  ierr = FCVodeInit(cvode_mem, c_funloc(RhsFn), tstart, sunvec_y)
  if (ierr /= 0) then
     print *, 'Error in FCVodeInit, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! set relative and absolute tolerances
  rtol = 1.0d-6
  atol = 1.0d-10

  ierr = FCVodeSStolerances(cvode_mem, rtol, atol)
  if (ierr /= 0) then
     print *, 'Error in FCVodeSStolerances, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! create fixed point nonlinear solver object
  sunnls => FSUNNonlinSol_FixedPoint(sunvec_y, 0, ctx)
  if (.not. associated(sunnls)) then
     print *,'ERROR: sunnls = NULL'
     stop 1
  end if

  ! attache nonlinear solver object to CVode
  ierr = FCVodeSetNonlinearSolver(cvode_mem, sunnls)
  if (ierr /= 0) then
    print *, 'Error in FCVodeSetNonlinearSolver, ierr = ', ierr, '; halting'
    stop 1
  end if

  ! Start time stepping
  print *, '   '
  print *, 'Finished initialization, starting time steps'
  print *, '   '
  print *, '       t           y        '
  print *, '----------------------------'
  print '(2x,2(es12.5,1x))', tcur, yvec(1)
  do outstep = 1,nout

     ! call CVode
     tout = min(tout + dtout, tend)
     ierr = FCVode(cvode_mem, tout, sunvec_y, tcur, CV_NORMAL)
     if (ierr /= 0) then
        print *, 'Error in FCVODE, ierr = ', ierr, '; halting'
        stop 1
     endif

     ! output current solution
     print '(2x,2(es12.5,1x))', tcur, yvec(1)

  enddo

  ! diagnostics output
  call CVodeStats(cvode_mem)

  ! clean up
  call FCVodeFree(cvode_mem)
  ierr = FSUNNonLinSolFree(sunnls)
  call FN_VDestroy(sunvec_y)
  ierr = FSUNContext_Free(ctx)

end program main

! ----------------------------------------------------------------
! CVodeStats
!
! Print CVODE statstics to standard out
! ----------------------------------------------------------------
subroutine CVodeStats(cvode_mem)

  !======= Inclusions ===========
  use iso_c_binding
  use fcvode_mod

  !======= Declarations =========
  implicit none

  type(c_ptr), intent(in) :: cvode_mem ! solver memory structure

  integer(c_int)  :: ierr          ! error flag

  integer(c_long) :: nsteps(1)     ! num steps
  integer(c_long) :: nfevals(1)    ! num function evals
  integer(c_long) :: nlinsetups(1) ! num linear solver setups
  integer(c_long) :: netfails(1)   ! num error test fails

  integer(c_int)  :: qlast(1)      ! method order in last step
  integer(c_int)  :: qcur(1)       ! method order for next step

  real(c_double)  :: hinused(1)    ! initial step size
  real(c_double)  :: hlast(1)      ! last step size
  real(c_double)  :: hcur(1)       ! step size for next step
  real(c_double)  :: tcur(1)       ! internal time reached

  integer(c_long) :: nniters(1)    ! nonlinear solver iterations
  integer(c_long) :: nncfails(1)   ! nonlinear solver fails

  !======= Internals ============

  ! general solver statistics
  ierr = FCVodeGetIntegratorStats(cvode_mem, nsteps, nfevals, nlinsetups, &
       netfails, qlast, qcur, hinused, hlast, hcur, tcur)
  if (ierr /= 0) then
     print *, 'Error in FCVodeGetIntegratorStats, ierr = ', ierr, '; halting'
     stop 1
  end if

  ! nonlinear solver statistics
  ierr = FCVodeGetNonlinSolvStats(cvode_mem, nniters, nncfails)
  if (ierr /= 0) then
     print *, 'Error in FCVodeGetNonlinSolvStats, ierr = ', ierr, '; halting'
     stop 1
  end if

  print *, ' '
  print *, ' General Solver Stats:'
  print '(4x,A,i9)'    ,'Total internal steps taken =',nsteps
  print '(4x,A,i9)'    ,'Total rhs function calls   =',nfevals
  print '(4x,A,i9)'    ,'Num lin solver setup calls =',nlinsetups
  print '(4x,A,i9)'    ,'Num error test failures    =',netfails
  print '(4x,A,i9)'    ,'Last method order          =',qlast
  print '(4x,A,i9)'    ,'Next method order          =',qcur
  print '(4x,A,es12.5)','First internal step size   =',hinused
  print '(4x,A,es12.5)','Last internal step size    =',hlast
  print '(4x,A,es12.5)','Next internal step size    =',hcur
  print '(4x,A,es12.5)','Current internal time      =',tcur
  print '(4x,A,i9)'    ,'Num nonlinear solver iters =',nniters
  print '(4x,A,i9)'    ,'Num nonlinear solver fails =',nncfails
  print *, ' '

  return

end subroutine CVodeStats


        MODULE functions
                IMPLICIT NONE

          REAL, PARAMETER :: PI = 4.0 * ATAN(1.0)
          REAL, PARAMETER :: Degree180 = 180.0
          REAL, PARAMETER :: R_to_D = Degree180/PI
          REAL, PARAMETER :: D_to_R = PI/Degree180

        CONTAINS

          REAL FUNCTION RadianToDegree(Radian)
                IMPLICIT NONE
                real, intent(in) :: Radian

                RadianToDegree = Radian * R_to_D
          END FUNCTION RadianToDegree

          REAL FUNCTION DegreeToRadian(Degree)
                IMPLICIT NONE
                real, intent(in) :: Degree

                DegreeToRadian = Degree * D_to_R
          END FUNCTION DegreeToRadian

          REAL FUNCTION MySIN(x)
                IMPLICIT NONE
                REAL, intent(in) :: x

                MySIN = SIN(DegreeToRadian(x))
          END FUNCTION MySIN

          REAL FUNCTION MyCOS(x)
                IMPLICIT NONE
                REAL, INTENT(in) :: x

                MyCOS = COS(DegreeToRadian(x))
          END FUNCTION MyCOS

        END MODULE functions

          PROGRAM  main
          USE  functions        ! use a module

          IMPLICIT  NONE

          integer :: n1, n2, i, j, k
          real :: bind_length, total_length, lattice, total_high
          real :: radis, angle, a1, b1, c1, d1
          real :: a2, b2, c2, d2, e2,f2
          real, allocatable :: x(:,:), y(:,:), xatom(:,:,:)
          real, allocatable :: yatom(:,:,:), high(:,:,:)
          real, allocatable :: fxatom(:,:,:), fyatom(:,:,:)
          real, allocatable :: fhigh(:,:,:)
          real :: total_cell

          OPEN(1,file='tube.dat')

          READ(1,*)
          READ(1,*) n1, n2
          READ(1,*) bind_length

         !armchair

          if(n2 .NE. 0) THEN
                radis = (6*n1*((bind_length/2)*SQRT(3.0)))/(2*PI)
                lattice = radis + (radis/2)
                total_high = (bind_length/2)*6
                total_cell = lattice*2
          angle = 360.0/n1

        if(total_cell .GE. 50) THEN
                total_cell = 49
        endif

         allocate(x(2,12), y(2,12), xatom(2,12,n1), yatom(2,12,n1))
         allocate(high(2,12,n1))

         x(1,1) = radis
         y(1,1) = 0

         x(1,2) = radis*MyCOS(360.0/(n1*6)) - 0*MySIN(360.0/(n1*6))
         y(1,2) = radis*MySIN(360.0/(n1*6)) + 0*MySIN(360.0/(n1*6))

         x(1,3) = radis*MyCOS((360.0/(n1*6)*3)) - 0*MySIN((360.0/(n1*6))*3)
         y(1,3) = radis*MySIN((360.0/(n1*6)*3)) + 0*MyCOS((360.0/(n1*6))*3)

         x(1,4) = radis*MyCOS((360.0/(n1*6)*4)) -0*MySIN((360.0/(n1*6))*4)
         y(1,4) = radis*MySIN((360.0/(n1*6)*4)) +0*MyCOS((360.0/(n1*6))*4)

         a1 = radis - 1.56377985
         b1 = radis + 1.56377985

         x(2,1) = a1
         y(2,1) = 0

         x(2,2) = b1
         y(2,2) = 0

         x(2,3) = b1*MyCOS(360.0/(n1*6)) - 0*MySIN(360.0/(n1*6))
         y(2,3) = b1*MySIN(360.0/(n1*6)) + 0*MySIN(360.0/(n1*6))

         x(2,4) = a1*MyCOS((360.0/(n1*6))) -0*MySIN((360.0/(n1*6)))
         y(2,4) = a1*MySIN((360.0/(n1*6))) +0*MyCOS((360.0/(n1*6)))

         x(2,5) = b1*MyCOS((360.0/(n1*6))*2) -0*MySIN((360.0/(n1*6))*2)
         y(2,5) = b1*MySIN((360.0/(n1*6))*2) +0*MyCOS((360.0/(n1*6))*2)

         x(2,6) = a1*MyCOS((360.0/(n1*6))*2) -0*MySIN((360.0/(n1*6))*2)
         y(2,6) = a1*MySIN((360.0/(n1*6))*2) +0*MyCOS((360.0/(n1*6))*2)

         x(2,7) = b1*MyCOS((360.0/(n1*6))*3) -0*MySIN((360.0/(n1*6))*3)
         y(2,7) = b1*MySIN((360.0/(n1*6))*3) +0*MyCOS((360.0/(n1*6))*3)

         x(2,8) = a1*MyCOS((360.0/(n1*6))*3) -0*MySIN((360.0/(n1*6))*3)
         y(2,8) = a1*MySIN((360.0/(n1*6))*3) +0*MyCOS((360.0/(n1*6))*3)

         x(2,9) = a1*MyCOS((360.0/(n1*6))*4) -0*MySIN((360.0/(n1*6))*4)
         y(2,9) = a1*MySIN((360.0/(n1*6))*4) +0*MyCOS((360.0/(n1*6))*4)

         x(2,10) = b1*MyCOS((360.0/(n1*6))*4) -0*MySIN((360.0/(n1*6))*4)
         y(2,10) = b1*MySIN((360.0/(n1*6))*4) +0*MyCOS((360.0/(n1*6))*4)

         x(2,11) = b1*MyCOS((360.0/(n1*6))*5) -0*MySIN((360.0/(n1*6))*5)
         y(2,11) = b1*MySIN((360.0/(n1*6))*5) +0*MyCOS((360.0/(n1*6))*5)

         x(2,12) = a1*MyCOS((360.0/(n1*6))*5) -0*MySIN((360.0/(n1*6))*5)
         y(2,12) = a1*MySIN((360.0/(n1*6))*5) +0*MyCOS((360.0/(n1*6))*5)

        do i = 1,4
                xatom(1,i,1) = x(1,i)
                yatom(1,i,1) = y(1,i)
        enddo

        do i = 1, 12
                xatom(2,i,1) = x(2,i)
                yatom(2,i,1) = y(2,i)
        enddo

        do j = 1, 4
         do i = 2, n1
                xatom(1,j,i) = MyCOS(angle)*xatom(1,j,i-1)&
                                -  MySIN(angle)*yatom(1,j,i-1)
                yatom(1,j,i) = xatom(1,j,i-1)*MySIN(angle)&
                                + yatom(1,j,i-1)*MyCOS(angle)

        enddo
        enddo

        do j = 1, 12
         do i = 2, n1
                xatom(2,j,i) = MyCOS(angle)*xatom(2,j,i-1)&
                                -  MySIN(angle)*yatom(2,j,i-1)
                yatom(2,j,i) = xatom(2,j,i-1)*MySIN(angle)&
                                + yatom(2,j,i-1)*MyCOS(angle)

        enddo
        enddo

        do i = 1, n1

        high(1,1,i) = 4*(bind_length/2)
        high(1,2,i) = bind_length/2
        high(1,3,i) = bind_length/2
        high(1,4,i) = 4*(bind_length/2)

        enddo

        do i = 1, n1

        high(2,1,i) = 2*(bind_length/2)
        high(2,2,i) = 6*(bind_length/2)
        high(2,3,i) = 3*(bind_length/2)
        high(2,4,i) = 5*(bind_length/2)
        high(2,5,i) = 0
        high(2,6,i) = 2*(bind_length/2)
        high(2,7,i) = 3*(bind_length/2)
        high(2,8,i) = 5*(bind_length/2)
        high(2,9,i) = 2*(bind_length/2)
        high(2,10,i) = 6*( bind_length/2)
        high(2,11,i) = 3*(bind_length/2)
        high(2,12,i) = 5*(bind_length/2)

        enddo

        allocate(fxatom(2,12,n1), fyatom(2,12,n1),fhigh(2,12,n1))

        do j = 1, 4
        do k = 1, n1

          fxatom(1,j,k) = (xatom(1,j,k)+lattice)/total_cell
          fyatom(1,j,k) = (yatom(1,j,k)+lattice)/total_cell

          fhigh(1,j,k) = high(1,j,k)/total_high

        enddo
        enddo

        do j = 1, 12
        do k = 1, n1

          fxatom(2,j,k) = (xatom(2,j,k)+lattice)/total_cell
          fyatom(2,j,k) = (yatom(2,j,k)+lattice)/total_cell

          fhigh(2,j,k) = high(2,j,k)/total_high

        enddo
        enddo

     open(24,file='tube.out')
 100  format(f20.16,3x,f20.16,3x,f20.16)

        write(24,*) total_cell, total_high, 'atom1= ', n1*4, 'atom2 =',n1*12

      do j = 1, 4
      do k = 1, n1

         write(24,100) fxatom(1,j,k), fyatom(1,j,k), fhigh(1,j,k)
      enddo
      enddo

      do j = 1, 12
      do k = 1, n1

         write(24,100) fxatom(2,j,k), fyatom(2,j,k), fhigh(2,j,k)
      enddo
      enddo

        endif

         !zig zag

          if(n2 .EQ. 0) THEN
                radis = (bind_length*3*(n1-1))/(2*PI)
                lattice = radis + (radis/2)*3
                total_high = ((bind_length/2)*SQRT(3.0))*6
                total_cell = lattice*2
          angle = 360.0/n1

        if(total_cell .GE. 50) THEN
                total_cell = 49
        endif

         allocate(x(2,12), y(2,12), xatom(2,12,n1), yatom(2,12,n1))
         allocate(high(2,12,n1))

         x(1,1) = radis
         y(1,1) = 0

         x(1,2) = radis
         y(1,2) = 0

         x(1,3) = radis*MyCOS((360.0/(n1*6)*3)) - 0*MySIN((360.0/(n1*6))*3)
         y(1,3) = radis*MySIN((360.0/(n1*6)*3)) + 0*MyCOS((360.0/(n1*6))*3)

         x(1,4) = radis*MyCOS((360.0/(n1*6)*3)) - 0*MySIN((360.0/(n1*6))*3)
         y(1,4) = radis*MySIN((360.0/(n1*6)*3)) + 0*MyCOS((360.0/(n1*6))*3)

         a1 = radis - 1.56377985
         b1 = radis + 1.56401799

         x(2,1) = a1*MyCOS((360.0/(n1*6)*1))&
                  -0*MySIN((360.0/(n1*6))*1)
         y(2,1) = a1*MySIN((360.0/(n1*6)*1))&
                  +0*MyCOS((360.0/(n1*6))*1)

         x(2,2) = a1*MyCOS((360.0/(n1*6)*1))&
                  -0*MySIN((360.0/(n1*6))*1)
         y(2,2) = a1*MySIN((360.0/(n1*6)*1))&
                  +0*MyCOS((360.0/(n1*6))*1)

         x(2,3) = a1*MyCOS((360.0/(n1*6)*1))&
                  -0*MySIN((360.0/(n1*6))*1)
         y(2,3) = a1*MySIN((360.0/(n1*6)*1))&
                  +0*MyCOS((360.0/(n1*6))*1)

         x(2,4) = b1*MyCOS((360.0/(n1*6)*2))&
                  -0*MySIN((360.0/(n1*6))*2)
         y(2,4) = b1*MySIN((360.0/(n1*6)*2))&
                  +0*MyCOS((360.0/(n1*6))*2)

         x(2,5) = b1*MyCOS((360.0/(n1*6)*2))&
                  -0*MySIN((360.0/(n1*6))*2)
         y(2,5) = b1*MySIN((360.0/(n1*6)*2))&
                  +0*MyCOS((360.0/(n1*6))*2)

         x(2,6) = b1*MyCOS((360.0/(n1*6)*2))&
                  -0*MySIN((360.0/(n1*6))*2)
         y(2,6) = b1*MySIN((360.0/(n1*6)*2))&
                  +0*MyCOS((360.0/(n1*6))*2)

         x(2,7) = a1*MyCOS((360.0/(n1*6)*4))&
                  -0*MySIN((360.0/(n1*6))*4)
         y(2,7) = a1*MySIN((360.0/(n1*6)*4))&
                  +0*MyCOS((360.0/(n1*6))*4)

         x(2,8) = a1*MyCOS((360.0/(n1*6)*4))&
                  -0*MySIN((360.0/(n1*6))*4)
         y(2,8) = a1*MySIN((360.0/(n1*6)*4))&
                  +0*MyCOS((360.0/(n1*6))*4)

         x(2,9) = a1*MyCOS((360.0/(n1*6)*4))&
                  -0*MySIN((360.0/(n1*6))*4)
         y(2,9) = a1*MySIN((360.0/(n1*6)*4))&
                  +0*MyCOS((360.0/(n1*6))*4)

         x(2,10) = b1*MyCOS((360.0/(n1*6)*5))&
                  -0*MySIN((360.0/(n1*6))*5)
         y(2,10) = b1*MySIN((360.0/(n1*6)*5))&
                  +0*MyCOS((360.0/(n1*6))*5)

         x(2,11) = b1*MyCOS((360.0/(n1*6)*5))&
                  -0*MySIN((360.0/(n1*6))*5)
         y(2,11) = b1*MySIN((360.0/(n1*6)*5))&
                  +0*MyCOS((360.0/(n1*6))*5)

         x(2,12) = b1*MyCOS((360.0/(n1*6)*5))&
                  -0*MySIN((360.0/(n1*6))*5)
         y(2,12) = b1*MySIN((360.0/(n1*6)*5))&
                  +0*MyCOS((360.0/(n1*6))*5)

        do i = 1,4
                xatom(1,i,1) = x(1,i)
                yatom(1,i,1) = y(1,i)
        enddo

        do i = 1, 12
                xatom(2,i,1) = x(2,i)
                yatom(2,i,1) = y(2,i)
        enddo

        do j = 1, 4
         do i = 2, n1
                xatom(1,j,i) = MyCOS(angle)*xatom(1,j,i-1)&
                                -  MySIN(angle)*yatom(1,j,i-1)
                yatom(1,j,i) = xatom(1,j,i-1)*MySIN(angle)&
                                + yatom(1,j,i-1)*MyCOS(angle)

        enddo
        enddo

        do j = 1, 12
         do i = 2, n1
                xatom(2,j,i) = MyCOS(angle)*xatom(2,j,i-1)&
                                -  MySIN(angle)*yatom(2,j,i-1)
                yatom(2,j,i) = xatom(2,j,i-1)*MySIN(angle)&
                                + yatom(2,j,i-1)*MyCOS(angle)

        enddo
        enddo

        c1 = (bind_length/2)*SQRT(3.0)

        do i = 1, n1

        high(1,1,i) = c1
        high(1,2,i) = c1*3
        high(1,3,i) = 0
        high(1,4,i) = c1*4

        enddo

        do i = 1, n1

        high(2,1,i) = 0
        high(2,2,i) = c1*2
        high(2,3,i) = c1*4
        high(2,4,i) = c1
        high(2,5,i) = c1*3
        high(2,6,i) = c1*5
        high(2,7,i) = c1
        high(2,8,i) = c1*3
        high(2,9,i) = c1*5
        high(2,10,i) = 0
        high(2,11,i) = c1*2
        high(2,12,i) = c1*4

        enddo

        allocate(fxatom(2,12,n1), fyatom(2,12,n1),fhigh(2,12,n1))

        do j = 1, 4
        do k = 1, n1

          fxatom(1,j,k) = (xatom(1,j,k)+lattice)/total_cell
          fyatom(1,j,k) = (yatom(1,j,k)+lattice)/total_cell

          fhigh(1,j,k) = high(1,j,k)/total_high

        enddo
        enddo

        do j = 1, 12
        do k = 1, n1

          fxatom(2,j,k) = (xatom(2,j,k)+lattice)/total_cell
          fyatom(2,j,k) = (yatom(2,j,k)+lattice)/total_cell

          fhigh(2,j,k) = high(2,j,k)/total_high

        enddo
        enddo

     open(24,file='tube.out')

        write(24,*) total_cell, total_high, 'atom1= ', n1*4, 'atom2=',n1*12

      do j = 1, 4
      do k = 1, n1

         write(24,100) fxatom(1,j,k), fyatom(1,j,k), fhigh(1,j,k)
      enddo
      enddo

      do j = 1, 12
      do k = 1, n1

         write(24,100) fxatom(2,j,k), fyatom(2,j,k), fhigh(2,j,k)
      enddo
      enddo

        endif

          END PROGRAM  main


      FUNCTION bessi0(x)
      REAL bessi0,x
      REAL ax
      DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9,y
      SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,q8,q9
      DATA p1,p2,p3,p4,p5,p6,p7/1.0d0,3.5156229d0,3.0899424d0,
     *1.2067492d0,0.2659732d0,0.360768d-1,0.45813d-2/
      DATA q1,q2,q3,q4,q5,q6,q7,q8,q9/0.39894228d0,0.1328592d-1,
     *0.225319d-2,-0.157565d-2,0.916281d-2,-0.2057706d-1,0.2635537d-1,
     *-0.1647633d-1,0.392377d-2/
      if (abs(x).lt.3.75) then
        y=(x/3.75)**2
        bessi0=p1+y*(p2+y*(p3+y*(p4+y*(p5+y*(p6+y*p7)))))
      else
        ax=abs(x)
        y=3.75/ax
        bessi0=(exp(ax)/sqrt(ax))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
     *(q7+y*(q8+y*q9))))))))
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/bessi0.for


      FUNCTION bessk0(x)
      REAL bessk0,x
CU    USES bessi0
      REAL bessi0
      DOUBLE PRECISION p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7,y
      SAVE p1,p2,p3,p4,p5,p6,p7,q1,q2,q3,q4,q5,q6,q7
      DATA p1,p2,p3,p4,p5,p6,p7/-0.57721566d0,0.42278420d0,0.23069756d0,
     *0.3488590d-1,0.262698d-2,0.10750d-3,0.74d-5/
      DATA q1,q2,q3,q4,q5,q6,q7/1.25331414d0,-0.7832358d-1,0.2189568d-1,
     *-0.1062446d-1,0.587872d-2,-0.251540d-2,0.53208d-3/
      if (x.le.2.0) then
        y=x*x/4.0
        bessk0=(-log(x/2.0)*bessi0(x))+(p1+y*(p2+y*(p3+y*(p4+y*(p5+y*
     *(p6+y*p7))))))
      else
        y=(2.0/x)
        bessk0=(exp(-x)/sqrt(x))*(q1+y*(q2+y*(q3+y*(q4+y*(q5+y*(q6+y*
     *q7))))))
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/bessk0.for


! An f77 subroutine to convolute a stick spectrum with a derivative
! gaussian line shape using fftpack5 routines
      subroutine convolute(spec,n,lw,sw)
      implicit none
      !Argument variables
      real spec(10000),lw,sw
      integer n

      !Local variables
      real wsave(33000),work(65536),r, pi
      complex scr1(32768),myi
      integer lensave,ierr,lenspec,lenwork,i,kb
      external cfft1i
      external cfft1f
      external cfft1b

      pi=3.14159265359
      kb = 1024
      myi = cmplx(0,1)
      lensave = 33000
      lenwork = 655536

! zero fill the spectrum to the next nearest power of 2
      do i = 1,5
        if(kb .gt. n) goto 10
        kb = kb * 2
      end do
 10   lenspec = kb
      do i=1,n
        scr1(i+(kb-n)/2) = cmplx(spec(i),0)
      end do

! Set up and perform the fft
      call cfft1i(kb,wsave,lensave,ierr)
      call cfft1f(kb,1,scr1,lenspec,wsave,lensave,work,lenwork,ierr)

! Multiply the FT by the convolution function
      r = 0.
      do i = 1, kb
        scr1(i) = scr1(i)*exp(-.5*(pi*lw*r/sw)**2) ! FT of a gaussian
        scr1(i) = scr1(i)*2.*pi*r*myi/n ! time domain first derivative
        r = r + 1.
      end do

! Perform the reverse FFT
      call cfft1b(kb,1,scr1,lenspec,wsave,lensave,work,lenwork,ierr)
      do i = 1,n
        spec(i) = n*real(scr1(i+(kb-n)/2))
      end do
      end subroutine convolute


subroutine CORRELS_NEW_STEP_DEF(corrs,metricG,n,centres)
  implicit none
  type(CorrelsRec),intent(inout) :: corrs
  integer,intent(in) :: n
  real(8),intent(in),dimension(3,3) :: metricG
  type(Particule),intent(in) :: centres(*)

  integer :: i,j,k,indexg,ng,nr
  real(8) :: r2,prepos(3),relpos(3),rmin,dr, dri

  nr=corrs%nr
  ng=corrs%ng
  rmin=corrs%rmin
  dr = corrs%dr
  dri = 1.d0/dr

  !$omp parallel do default(shared) private(i,j,prepos, relpos, indexg)
  do i=1,n
     do j=i+1,n
        prepos=centres(i)%pos-centres(j)%pos
        r2=sqrt(DIST2_MI(prepos,relpos,metricG))

        k=Indic_(centres(i)%famille,centres(j)%famille,nr)
        indexg=1+floor((r2-rmin)*dri)
        if(indexg>0.and.indexg<=ng) then
          !$omp atomic update
          corrs%nder(indexg,k)=corrs%nder(indexg,k)+2
        endif
     end do
  end do
  !$omp end parallel do
  corrs%step_calc=corrs%step_calc+1

end subroutine


      subroutine DSFITC(CCODE, XI, YI, SD, KORDER, NCOEF, TKNOTS,
     *                  BCOEF, RNORM, ISET, INFO, WORK)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DSFITC Krogh   Added external statement.
c>> 1996-01-23 DSGITC Krogh  Changes to simplify conversion to C.
c>> 1995-11-21 DSFITC Krogh  Converted from SFTRAN to Fortran 77.
c>> 1994-11-16 CLL Add loops to zero debug arrays XT() and RT().
c>> 1994-10-19 DSFITC Krogh  Changes to use M77CON
c>> 1994-01-31 DSFITC CLL Added test for SD(i) .le. 0 when SD(1) > 0.
c>> 1992-12-16 CLL Corrected formula for NEED2 and comments re WORK().
c>> 1992-11-12 C. L. Lawson, JPL  Initializing LEFT, J1, J2.
c>> 1992-10-27 C. L. Lawson, JPL
c>> 1989-03-02 C. L. Lawson, JPL
c>> 1989-02-23 C. L. Lawson, JPL
c>> 1988-04-01 C. L. Lawson, JPL
c
c        Weighted least squares fit to discrete data by a polynomial
c     spline function of order KORDER.  The user can specify equality or
c     inequality constraints.  The fitting equations as well as the
c     constraints may involve the value, a derivative of specified
c     order, or a definite integral of the spline function.  A fitting
c     equation or constraint may involve function or derivative values
c     at different points, and relations between derivatives of
c     different orders.
c
c        The order of a polynomial spline function is one
c     greater than the degree of its polynomial pieces.
c     Example: KORDER = 4 specifies a cubic spline function.
c
c        The "proper fitting interval" is from A = TKNOTS(KORDER) to
c     B = TKNOTS(NT+1-KORDER).  Extrapolation outside this interval
c     is permitted, but one must expect diminished accuracy at
c     extrapolated points.  The given data or constraint
c     abcissas may be outside [A, B], and subsequent evaluations can be
c     done at points X outside [A, B].
c     ------------------------------------------------------------------
c           Specification of fitting and constraint equations.
c
c        Let F denote the polynomial spline to be determined.  Let the
c     quadruple (CCODE(i), X(i), Y(i), SD(i)) be called the ith
c     specification row.  For each desired fitting equation or
c     constraint equation, (either of which we call a relation) the user
c     must specify one or two (consecutive) specification rows.
c
c        CCODE(i) consists of 4 characters, that we call
c     KIND, DERIV, RELOP, and ACTIVE.
c
c        KIND may be '1', '2', '3', or '4'.  KIND determines the kind of
c     relation being specified.  When KIND = '1' or '2' all
c     information for the relation is given in a single specification
c     row.  We call this Row i in the following discussion.
c     When KIND = '3' or '4', two consecutive specification rows are use
c     We call these Rows i and i+1.  We will complete the explanation of
c     KIND after describing DERIV, RELOP, and ACTIVE.
c
c        DERIV may be '0', '1', ..., or '9'.  This selects the order of
c     derivative of F to appear in the relation.  '0' denotes the value
c     of F itself.
c
c        RELOP may be '~', '=', '<', or '>'.
c     RELOP = '~' means the relation is to be a least-squares fitting
c     equation, '=' means an equality constraint equation, '<' means a
c     less-than-or-equal constraint equation, and '>' means a
c     greater-than-or-equal constraint equation.  When RELOP = '~',
c     SD(i) specifies the a priori standard deviation of the right-side
c     member of the equation.  When RELOP indicates a constraint
c     equation, SD(i) will be ignored.
c
c        ACTIVE may be 'A', 'N', or '!'.  Lower case 'a' and 'n' are
c     also accepted.  ACTIVE = 'A' means the current specification row
c     is active, i.e., a relation will be generated from these
c     specifications.  ACTIVE = 'N' means the specifications are not
c     active, i.e., no relation will be generated.  ACTIVE = '!' means
c     the current row is inactive and there are no following rows,
c     i.e., this marks the end of the specification data.  The user must
c     provide this termination signal.
c     When KIND = '3', or '4', meaning two specification rows are to
c     be interpreted together, the setting of ACTIVE = 'A' or
c     ACTIVE = 'N' must be consistent in these two rows.
c     Setting ACTIVE = '!' in only the first row is permitted, however,
c     since then the second row will not be accessed anyway.
c
c        The forms of the relations selected by KIND are:
c
c     KIND = 1:      G(X(i)) RELOP Y(i)
c
c        where G is the derivative of F selected by DERIV.
c
c     KIND = 2:      G(X(i)) - G(Y(i)) RELOP 0
c
c        where G is the derivative of F selected by DERIV.
c
c     KIND = 3:      G(X(i)) - Y(i+1) * H(X(i+1)) RELOP Y(i)
c
c        where G is the derivative of F selected by DERIV(i) and
c        and H is the derivative of F selected by DERIV(i+1).  In this
c        case KIND(i+1) and RELOP(i+1) are not used.
c
c     KIND = 4:      Integral from X(i) to X(i+1) of F RELOP Y(i)
c
c        In this case DERIV(i), KIND(i+1), DERIV(i+1), RELOP(i+1), and
c        Y(i+1) are not used.
c     ------------------------------------------------------------------
C     The linear algebra methods were designed by C.L.Lawson and
c     R.J.Hanson.  The method of representing spline functions is due
c     to Carl de Boor.  References:
C     "SOLVING LEAST SQUARES PROBLEMS", by Lawson and Hanson,
C     Prentice-Hall, 1974.
c     "A PRACTICAL GUIDE TO SPLINES" by Carl de Boor,
c     Springer-Verlag, 1978.
c     The functionality and user interface of this subprogram are
c     modeled on the "French Curve" subroutine, FC, developed by Hanson
c     and Lawson at JPL in 1970, and the subsequent version developed by
c     Hanson at Sandia in 1979.
c     March 1988, CLL, JPL.  Revised to conform to the Fortran 77
c     standard.  Intended for inclusion in the JPL MATH77 math library.
c     Feb 1989, CLL, JPL.  Revised to use KIND = 3 to specify an
c     integral, and added new kind of relation using KIND = 4.
c     ------------------------------------------------------------------
c                     SUBROUTINE ARGUMENTS
c
c  CCODE()  [in, char*4]  CCODE(i) is regarded as consisting of four
c           single-character fields.
c        CCODE(i)(1:1) = KIND  =  '1',  '2', '3', '4'.
c        CCODE(i)(2:2) = DERIV   =  '0',  '1', ..., '9'.
c        CCODE(i)(3:3) = RELOP  =  '~',  '=',  '<',  '>'.
c        CCODE(i)(4:4) = ACTIVE =  'A',  'N',  '!'
c        Where alphabetic characters are shown, the corresponding
c        lower case character is also acceptable.
c
c  X()  [in]  Abcissas for specification of fitting or
c        constraint equations.
c
c  Y()  [in]  Values or abcissas for specification
c        of fitting or constraint equations.
c
c  SD() [in]  Specifies the a priori standard deviation of error in the
c       right-side value in each fitting equation.
c       The weighted fitting algorithm will take account of these.
c       Optionally, the user may set SD(1) to a negative value.
c       Then this subr will use abs(SD(1)) as the standard deviation
c       for the right-side value in each fitting equation.  In this
c       latter case the SD() array can be dimensioned SD(1).
c       Note that a negative value in SD(1) will always be interpreted
c       in this way by this subr, even if the associated RELOP is not
c       '~' or if ACTIVE is not 'A'.
c
c  KORDER  [in]  Order of the spline basis functions.  The
c        polynomial degree of the spline segments is one less than the
c        order.  Example:  the order of a cubic spline is 4.
c        Require KORDER .ge. 1.  Internal arrays in subroutines used put
c        an upper limit of 20 on KORDER.
c
c  NCOEF  [in]  No. of B-spline coefficients to be determined.
c
c  (TKNOTS(j),j=1,NT, where NT = NCOEF+KORDER)  [in]  This is the deBoor
c     knot sequence for definition of the spline basis functions.
c     These values must be nondecreasing.
c     Repeated values are permitted, but values at
c     an index spacing of KORDER must be strictly increasing.
c        The first and last KORDER-1 values in TKNOTS() are needed to
c     support the deBoor method of representing splines.
c        The "proper fitting interval" is from
c     A = TKNOTS(KORDER) to B = TKNOTS(NT+1-KORDER).  One acceptable and
c     convenient way to set the first and last KORDER-1 knots is to set
c     the first KORDER-1 to A and the last KORDER-1 to B.
c        Continuity of the spline at knots interior to (A, B) will be of
c     order KORDER-2, unless a knot is repeated, in which case the order
c     of continuity will be decreased at that knot.
c
c  BCOEF()  [out]  An array of length NCOEF into which the computed
c        coefficients defining the fitted curve will be stored.  These
c        are coeffients relative to B-spline basis functions.
c        For I = 1, ..., NCOEF, the coefficient BCOEF(I)
c        is associated with the basis function whose support interval
c        runs from TKNOTS(I) to TKNOTS(I+KORDER).
c
c  RNORM   [out]  RNORM := sqrt( sum over the indices i for which
c         fitting was requested of [( (yfit(i) - Y(i))/SD(i))**2])
c
c  ISET()  [in integer]  Array of length 3.
c        ISET(1) = NINFO, the dimension of INFO().  A sufficiently
c           large value for NINFO is 7 + 2*(NCOEF + NS).
c        ISET(2) = NWORK, the dimension of WORK().  A sufficiently
c           large value for NWORK can be computed as follows:
c           See definition of NS, M1, and MFIT below under INFO().
c           NTOT = NCOEF + NS
c           MTOT = M1 + MFIT
c           MINMN = min(MTOT, NTOT)
c           NWORK = MTOT*NTOT + 3*MTOT + 6*NTOT + 3*MINMN + M1
c        ISET(3) = KPRINT, a print flag in the range [0, 4].  It is
c           passed on to DBLSE.  Larger values produce more printing.
c
c  INFO()  [out and scratch integer]  The first 7 elements of INFO()
c        are used to return information about the problem.  The
c        following 2*(NCOEF+NS) locations are used as scratch.
c        INFO(1) = IERR5, the Error status indicator.
c        Note that IERR4 comes from DBLSE.  Possible values of IERR5 are
c        as follows:
c
c        =    0 means no errors detected.
c        =  100 means  NCOEF .lt. 1
c        =  200 means  TKNOTS(I) .gt. TKNOTS(I+1)
c        =  250 means  TKNOTS(I) .ge. TKNOTS(I+KORDER)
c        =  300 means  NINFO or NWORK is too small.
c        =  500 means  DERIV has bad value.
c        =  600 means  RELOP has bad value.
c        =  700 means  KIND has bad value.
c        =  800 means  ACTIVE has bad value.
c        = 1000 + IERR4 means IERR4 .ne. 0 due to error
c                       detected in _BLSE.
c        = 1100 means  SD(1) = zero.
c        = 1200 means  SD(1) > zero and SD(i) .le. zero for some i.
c
c        INFO(2)  = NEED1, the dimension needed for INFO().
c        INFO(3)  = NEED2, the dimension needed for WORK().
c        INFO(4)  = M1, the number of constraints rows in the matrix
c           representation of the problem.  This will be a count of
c           the number of nonignored instances of CCODE(i) having
c           RELOP = '=', '<', or '>, and ACTIVE = 'A'.
c        INFO(5)  = MFIT, the number of least-squares equations.
c           This will be a count of
c           the number of nonignored instances of CCODE(i) having
c           RELOP = '~' and ACTIVE = 'A'.
c        INFO(6)  = NS, the number of slack variables.  This will be a
c           count of the number of nonignored instances of CCODE(i)
c           having RELOP = '<' or '>, and ACTIVE = 'A'.
c        INFO(7)  = NSETP, the number of variables in Set P at
c           termination.  These variables are at values determined by
c           solution of a system of equations.  The other NCOEF + NS
c           - NSETP variables will be at fixed values, either at one of
c           their bounds or at zero.
c
c  WORK()  [scratch]  Work space dimensioned NWORK.
c     ------------------------------------------------------------------
c          Important internal variables.
c
c  BASIS()  Array in which values of KORDER basis functions or their
c           will be stored.  Dimensioned using the parameter KMAX.
c           This puts an upper limit on permissible KORDER.
c  JCOL     Column of matrix into which first element of current
c           set of basis function values will be placed.
c           JCOL = LEFT - KORDER + 1.
c  KINFO    Parameter specifying the number of locations at the
c           beginning of INFO() used for specific items of returned
c           information.  Space beyond these locations is used for
c           scratch.
c  KMAX     Intermal dimensioning parameter.  The input value of KORDER
c           must not exceed KMAX.
c  KORDP1   = KORDER+1
C  KSIZE    Number of rows in current block.
c  LEFT     Index of current spline segment.  LEFT will satisfy
c           KORDER .le. LEFT .le. NCOEF.
c           The knot interval associated with index LEFT is from
c           T(LEFT) to T(LEFT+1).
c           Note that the union of these
c           segments is the "proper fitting interval".
c  ELIMIT   Limit on number of errors in initial scan of specs before
c           quitting.
c     ------------------------------------------------------------------
c--D replaces "?": ?SFITC, ?BLSE, ?SBASI, ?SBASD, ?SFIND, ?ERV1
c     Both versions use      ERMOR, ERMSG, IERM1, IERV1
c     ------------------------------------------------------------------
      external D1MACH
      integer ELIMIT, KINFO
      parameter(ELIMIT = 9, KINFO = 7)
      integer ACTIVE, DERIV, FAC
      integer I, IC, IERR4, IERR5
      integer INFO(*), IRCON, IRLS, IROW, ISET(3)
      integer IWBND, IWBVEC, IWCC, IWDIFF, IWINDX, IWJSTA
      integer IWRT, IWSIZ, IWSS, IWTNRM, IWWRK, IWXS, IWXT, IWZ
      integer J, J1, J2, JCOL, JS, KMAX, KORDER, KPRINT, LEFT
      integer M1, MFIT, MINMN, MN, MODE, MTOT
      integer NBADCC, NCOEF, NEED1, NEED2, NINFO, NTOT
      integer NS, NSETP, NT, NWORK, RELOP, KIND
      parameter(KMAX=20)
      double precision D1MACH
      double precision BASIS(KMAX), BCOEF(NCOEF), ONE
      double precision RNORM, RTVAL, SD(*), SDIC
      double precision TKNOTS(NCOEF+KORDER), TOL, UNBND
      double precision WORK(*), WT, WT1
      double precision X, XI(*), YI(*), ZERO
      character ATAB*6, CCODE(*)*4, DTAB*10
      character RTAB*4, NVTAB*4
      character MSG1*19, MSG3*19, MSG4*19
      logical   USEWT1
      parameter( ONE = 1.0D0, UNBND = 99.0D0, ZERO = 0.0D0)
      parameter(DTAB='0123456789', RTAB='~=<>')
      parameter(NVTAB='1234', ATAB=' AaNn!')
      data MSG1 / 'CCODE(I)(1:1) =  ' /
      data MSG3 / 'CCODE(I)(3:3) =  ' /
      data MSG4 / 'CCODE(I)(4:4) =  ' /
c     ------------------------------------------------------------------
      NINFO  = ISET(1)
      NWORK  = ISET(2)
      KPRINT = ISET(3)
      NT = NCOEF + KORDER
      IERR5 = 0
C
C          Exit immediately if NCOEF .lt. 1  or if
C          the knots fail to be nondecreasing.
c
      if ( NCOEF .lt. 1 ) then
         IERR5 = 100
         call IERM1('DSFITC',IERR5,0,
     *   'Require NCOEF .ge. 1', 'NCOEF',NCOEF,'.')
         go to 500
      end if
      if(KORDER .gt. KMAX) then
         IERR5 = 150
         call IERM1('DSFITC',IERR5,0,'Require KORDER .le. KMAX.',
     *   'KORDER',KORDER,',')
         call IERV1('KMAX',KMAX,'.')
         go to 500
      end if
c
      do 20 I = 1,NT-1
        if (TKNOTS(I) .gt. TKNOTS(I+1)) then
          IERR5 = 200
          call IERM1('DSFITC',IERR5,0,
     *    'Require knots, TKNOTS(I), to be nondecreasing.',
     *    'I',I,',')
          call DERV1('TKNOTS(I)',TKNOTS(I),',')
          call DERV1('TKNOTS(I+1)',TKNOTS(I+1),'.')
          go to 500
        end if
   20 continue
c
      do 40 I = 1,NCOEF
        if (TKNOTS(I) .ge. TKNOTS(I+KORDER)) then
          IERR5 = 250
          call IERM1('DSFITC',IERR5,0,
     *    'Require TKNOTS(I) < TKNOTS(I+KORDER).',
     *    'I',I,',')
          call DERV1('TKNOTS(I)',TKNOTS(I),',')
          call DERV1('TKNOTS(I+KORDER)',TKNOTS(I+KORDER),'.')
          go to 500
        end if
   40 continue
C
c     ------------------------------------------------------------------
C                                       TEST SD(1)
      if(SD(1) .lt. ZERO) then
         WT1 = -ONE/SD(1)
         USEWT1 = .true.
      else if( SD(1) .gt. ZERO) THEN
         USEWT1 = .false.
      else
         IERR5 = 1100
         call ERMSG('DSFITC',IERR5,0,'Require SD(1) .ne. Zero','.')
         go to 500
      end if
c
c     .  Determine M1, MFIT, NS, MTOT, and NTOT.
c     .  M1 = number of non-ignored constraint specifications.
c     .  MFIT = number of non-ignored least-squates equations.
c     .  NS = number of non-ignored constraints that
c     .  are inequality constraints and thus require a slack variable.
c     .  MTOT = M1 + MFIT
c     .  NTOT = NCOEF + NS
c
      NBADCC = 0
      M1   = 0
      MFIT = 0
      NS   = 0
      I = 1
c     do forever
   60 continue
         KIND = index(NVTAB, CCODE(I)(1:1))
         DERIV  = index(DTAB, CCODE(I)(2:2)) - 1
         RELOP = index(RTAB, CCODE(I)(3:3))
         ACTIVE = index(ATAB, CCODE(I)(4:4))/2
         if(ACTIVE .eq. 3) go to 180
c
c        .  CCODE(I)(1:1) =  1  2  3  4
c        .           KIND =  1  2  3  4
c
c        .  CCODE(I)(2:2) =  0  1  2  3  4  5  6  7  8  9
c        .          DERIV =  0  1  2  3  4  5  6  7  8  9
c
c        .  CCODE(I)(3:3) =  ~  =  <  >
c        .          RELOP =  1  2  3  4
c
c        .  CCODE(I)(4:4) =  A  a  N  n  !
c        .         ACTIVE =  1  1  2  2  3
c
         if(ACTIVE .eq. 1) then
C           do case(RELOP, 4)
            go to (110, 120, 130, 140), RELOP
C           case other
               IERR5 = 600
               call IERM1('DSFITC',IERR5,0,
     *         'RELOP = CCODE(I)(3:3) has invalid value.','I',I,',')
               MSG3(19:19) = CCODE(I)(3:3)
               call ERMOR(MSG3, '.')
               NBADCC = NBADCC+1
               go to 150
C           case 1
  110          MFIT = MFIT+1
               go to 150
C           case 2
  120          M1 = M1+1
               go to 150
C           case 3
  130          M1 = M1+1
               NS = NS+1
               go to 150
C           case 4
  140          M1 = M1+1
               NS = NS+1
  150       continue
c           end case
         else if(ACTIVE .ne. 2) then
               IERR5 = 800
               call IERM1('DSFITC',IERR5,0,
     *         'ACTIVE = CCODE(I)(4:4) has invalid value.','I',I,',')
               MSG4(19:19) = CCODE(I)(4:4)
               call ERMOR(MSG4, '.')
               NBADCC = NBADCC+1
         end if
c
         if(KIND .eq. 1 .or. KIND .eq. 2) then
            I = I+1
         else if(KIND .eq. 3 .or. KIND .eq. 4) then
            I = I+2
         else
            IERR5 = 700
            call IERM1('DSFITC',IERR5,0,
     *      'KIND = CCODE(I)(1:1) has invalid value.','I',I,',')
            MSG1(19:19) = CCODE(I)(1:1)
            call ERMOR(MSG1, '.')
            NBADCC = ELIMIT+1
         end if
         if(NBADCC .gt. ELIMIT) then
            call ERMSG('DSFITC',IERR5,0,
     *      'Quitting on bad values in CCODE()','.')
            go to 500
         end if
         go to 60
  180 continue
C     end forever
c
      if(NBADCC .ne. 0) then
         call ERMSG('DSFITC',IERR5,0,
     *    'Quitting on bad values in CCODE()','.')
         go to 500
      end if
      MTOT = M1 + MFIT
      NTOT = NCOEF + NS
*     print*,'DSFITC.. M1, MFIT, NCOEF, NS =',M1, MFIT, NCOEF, NS
      MINMN = min(MTOT, NTOT)
      INFO(4) = M1
      INFO(5) = MFIT
      INFO(6) = NS
c
c     .  Set indices to partition the work arrays INFO() and WORK().
c
      IWINDX = 1+KINFO
      IWJSTA = IWINDX+NTOT
      NEED1  = IWJSTA+NTOT - 1
      INFO(2) = NEED1
c
      MN = MTOT*NTOT
      IWBVEC = MN+1
      IWBND  = IWBVEC+MTOT
      IWXS   = IWBND +2*NTOT
      IWWRK  = IWXS+NTOT
      IWSIZ  = IWWRK+NTOT
      IWTNRM = IWSIZ+M1
      IWZ    = IWTNRM+NTOT
      IWCC   = IWZ+MINMN
      IWSS   = IWCC+MINMN
      IWXT   = IWSS+MINMN
      IWRT   = IWXT+NTOT
      IWDIFF = IWRT+MTOT
      NEED2  = IWDIFF+MTOT - 1
      INFO(3) = NEED2
c     .                                     Check NINFO and NWORK.
c
      if(NINFO .lt. NEED1 .or. NWORK .lt. NEED2) then
              IERR5 = 300
         call IERM1('DSFITC',IERR5,0,
     *   'Require NINFO .ge. NEED1 and NWORK .ge. NEED2.',
     *   'NINFO',NINFO,',')
         call IERV1('NEED1',NEED1,',')
         call IERV1('NWORK',NWORK,',')
         call IERV1('NEED2',NEED2,'.')
         go to 500
      end if
c     .                       Zero an MTOT x NTOT space for the matrix.
      do 200 I = 1, MN
         WORK(I) = ZERO
  200 continue
c     .                       Zero debug arrays XT() and RT() in WORK().
      do 210 j = 1, ntot
         work(iwxt + j - 1) = ZERO
  210 continue
      do 220 j = 1, mtot
         work(iwrt + j - 1) = ZERO
  220 continue
c
c     .  Set bounds for variables.  Storing into a 2 x NTOT space.
c
      do 240 J = 1,2*NTOT
         WORK(IWBND-1+J) = UNBND
  240 continue
      do 250 J = 1,NS
         WORK(IWBND+(NCOEF+J-1)*2) = ZERO
  250 continue
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c     Begin loop to form equations, both constraints and least-squares.
c
c     Initialize JS = column index of previous slack variable.
c             IRCON = row index of previous constraint equation.
c             IRLS  = row index of previous least-squares equation.
c               IC  = index of current specification data.
c             LEFT  = Arbitrary starting value for use by DSFIND.
c             J1,J2 = Arbitrary starting values for use by DSBASI.
c
      JS = NCOEF
      IRCON = 0
      IRLS  = M1
      IC    = 1
      J1    = 1
      J2    = 1
      LEFT  = 1
C     do forever
  300 continue
         ACTIVE = index(ATAB, CCODE(IC)(4:4))/2
         if(ACTIVE .eq. 3) go to 400
         if(ACTIVE .eq. 2) then
            IC = IC+1
            go to 300
         end if
         KIND= index(NVTAB, CCODE(IC)(1:1))
         RELOP = index(RTAB, CCODE(IC)(3:3))
c
c        .  CCODE(I)(1:1) =  1  2  3  4
c        .           KIND =  1  2  3  4
c
c        .  CCODE(I)(2:2) =  0  1  2  3  4  5  6  7  8  9
c        .          DERIV =  0  1  2  3  4  5  6  7  8  9
c
c        .  CCODE(I)(3:3) =  ~  =  <  >
c        .          RELOP =  1  2  3  4
c
c        .  CCODE(I)(4:4) =  A  a  N  n  !
c        .         ACTIVE =  1  1  2  2  3
c
c        .  Set matrix row index, IROW.
c        .  Set weight, WT, if RELOP = 1.
c        .  Store coefficient of +1 or -1 for slack variable if
c        .  RELOP is 3 or 4.
c
         if(RELOP .eq. 1) then
            IRLS = IRLS+1
            IROW = IRLS
            if( USEWT1) then
               WT = WT1
            else
               SDIC = SD(IC)
               if(SDIC .gt. ZERO) then
                  WT=ONE/SDIC
               else
                  IERR5 = 1200
                  call ERMSG('DSFITC',IERR5,0,
     *            'With SD(1) > 0  require all SD(I) > 0.', ',')
                  call DERV1('SD(1)',SD(1),',')
                  call IERV1('I',IC,',')
                  call DERV1('SD(I)',SDIC,'.')
                  go to 500
               end if
            end if
         else
            IRCON = IRCON+1
            IROW = IRCON
            if(RELOP .eq. 3) then
               JS = JS+1
               WORK(IROW+(JS-1)*MTOT) = ONE
            else if(RELOP .eq. 4) then
               JS = JS+1
               WORK(IROW+(JS-1)*MTOT) = -ONE
            end if
         end if
c
         if(KIND .eq. 4) then
c                        Setup for integral
            call DSBASI(KORDER, NCOEF, TKNOTS, XI(IC), XI(IC+1),
     *            J1, J2,  WORK(IWXS))
            do 320 J = J1, J2
               if(RELOP .eq. 1) then
                  WORK(IROW+(J-1)*MTOT) = WORK(IWXS-1+J) * WT
               else
                  WORK(IROW+(J-1)*MTOT) = WORK(IWXS-1+J)
               end if
  320       continue
c
            if(RELOP .eq. 1) then
               WORK(MN+IROW) = YI(IC) * WT
            else
               WORK(MN+IROW) = YI(IC)
            end if
c                        End of setup for integral
            IC = IC+2
         else
c                        Setup for value or derivative
c        .  DERIV = CCODE()(2:2) =  0  1  2  3  4  5  6  7  8  9
c
            DERIV  = index(DTAB, CCODE(IC)(2:2)) - 1
            X = XI(IC)
            FAC = ONE
c Negate KIND to flag that this is the first time accumulating values.
            KIND = -KIND
  340       continue
c                       Accumulate values into matrix
            call DSFIND(TKNOTS, KORDER, NCOEF+1, X, LEFT, MODE)
            call DSBASD(KORDER, LEFT, TKNOTS, X, DERIV, BASIS)
            JCOL = LEFT-KORDER+1
*           print*,'DSFITC..            X =',X
*           print*,'DSFITC.. IC,LEFT,JCOL =',IC,LEFT,JCOL
            if(RELOP .eq. 1) FAC = FAC * WT
            do 360 J = 1,KORDER
               WORK(IROW+(JCOL-1)*MTOT) =
     *               WORK(IROW+(JCOL-1)*MTOT) + FAC * BASIS(J)
               JCOL = JCOL + 1
  360       continue
c                       End of accumulate values into matrix
            if (KIND .lt. 0) then
c                       KIND is reset to positive here.
               KIND = -KIND
               if(KIND .eq. 1) then
                  RTVAL = YI(IC)
               else
c           .                              Here KIND = 2 or 3
                  if(KIND .eq. 2) then
                     FAC = -ONE
                     RTVAL = ZERO
                     X = YI(IC)
                  else
                     DERIV  = index(DTAB, CCODE(IC+1)(2:2)) - 1
                     FAC = -YI(IC+1)
                     RTVAL = YI(IC)
                     X = XI(IC+1)
                  end if
c Go back to accumulate values a second time and last time on this iter.
                  go to 340
               end if
            end if
c                                   Set right side of relation.
            if(RELOP .eq. 1) then
               WORK(MN+IROW) = RTVAL * WT
            else
               WORK(MN+IROW) = RTVAL
            end if
c                        End of setup for value or derivative
            IC = IC+1
            if(KIND .eq. 3) IC = IC+1
         end if
         go to 300
  400 continue
c     end forever
c     .                          End loop to form equations.
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
c     print'(1x/1x,a,i5,a,i5)','DSFITC..  MTOT =',MTOT,',   NTOT =',NTOT
c     print'(1x/1x,a/1x)','DSFITC.. Matrix going to DBLSE:'
c     do for I = 1,MTOT
c        print'(1x/1x,i5,3x,5g13.5/(9x,5g13.5))',
c    *    I,(WORK(I+(J-1)*MTOT),J=1,NTOT+1)
c     end for
c
c     .          All points have been processed.  Call for the solution.
c
      TOL = D1MACH(4)**(0.75d0)
      call DBLSE(WORK, MTOT, MTOT, NTOT, M1, WORK(MN+1),
     *     WORK(IWBND), UNBND, KPRINT, TOL, IERR4, WORK(IWXS),
     *     RNORM, NSETP,
     *     WORK(IWWRK), WORK(IWSIZ), WORK(IWTNRM), WORK(IWZ),
     *     WORK(IWCC), WORK(IWSS), INFO(IWINDX), INFO(IWJSTA),
     *     WORK(IWXT), WORK(IWRT), WORK(IWDIFF))
c
c     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      INFO(7) = NSETP
      if(IERR4 .ne. 0) then
         IERR5 = 1000 + IERR4
         call ERMSG('DSFITC',IERR5,0, 'Error noted in DBLSE.','.')
         go to 500
      end if
c
      do 440 I=1,NCOEF
         BCOEF(I) = WORK(IWXS-1+I)
  440 continue
      INFO(1) = IERR5
      return
c     ------------------------------------------------------------------
c                         ERROR RETURN
  500 do 520 I=1,NCOEF
         BCOEF(I)=ZERO
  520 continue
      INFO(1) = IERR5
      return
      end


      double precision function DSINHM (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>>   1998-10-29 DSINHM Krogh  Moved external statement up for mangle.
c>>   1994-10-20 DSINHM Krogh  Changes to use M77CON
c>>   1994-05-22 DSINHM WV Snyder JPL Make SP and DP alike using CHGTYP
c>>   1993-07-21 DSINHM WV Snyder JPL Original code
c
c     Compute SINH(X) - X.
c
c--D replaces "?": ?SINHM
      double precision X
      external D1MACH
      double precision CUT, D1MACH, E, ROUND, X2
      parameter (CUT = 0.25d0)
      double precision SP5, SP4, SP3, SP2, SP1, SQ1
      parameter ( SP5 = .255251817302048D-09)
      parameter ( SP4 = .723809046696880D-07)
      parameter ( SP3 = .109233297700241D-04)
      parameter ( SP2 = .954811583154274D-03)
      parameter ( SP1 = .452867078563929D-01)
      parameter ( SQ1 =-.471329214363072D-02*6.0D0)
      integer M, N
      save M, ROUND
      data M /-1/
c
      if (m .lt. 0) then
         round = d1mach(4)
         if (round .lt. 5.0d-14) then
c           Compute appropriate value of M depending on round-off.
            m = 3
            e = cut/6.0d0
10          if (e .gt. round) then
               m = m + 2
               e = e*cut*cut/(m*(m-1))
               go to 10
            end if
         end if
      end if
c
      if (round .lt. 5.0d-14) then
         n = m
         x2 = x*x
c        We assume m > 1
         dsinhm = 1.0d0 + x2/(n*(n-1))
20       if (n .gt. 5) then
            n = n - 2
            dsinhm = 1.0d0 + dsinhm*x2/(n*(n-1))
            go to 20
         end if
         dsinhm = x * x2 * dsinhm / 6.0d0
         return
      end if
c
c     Use a rational approximation when ABS(X) is less than 1.65,
c     else use the Fortran intrinsic function.
c
      if (x .lt. 1.65d0) then
         x2 = x*x
         dsinhm = ((((((sp5*x2+sp4)*x2+sp3)*x2+sp2)*x2+sp1)*x2+1.0d0)
     *            *x2*x)/(sq1*x2+6.0d0)
      else
         dsinhm = sinh(x) - x
      end if
      return
      end


      real(kind(0.0d0)) function volume (vecs, ndim)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  double
!...Translated by Pacific-Sierra Research 77to90  4.4G  17:49:42  03/20/06
!...Switches: -rl INDDO=2 INDIF=2
      implicit none
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      integer , intent(in) :: ndim
      real(double) , intent(in) :: vecs(3,ndim)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      real(double) :: a, b, gamma, sing, c, alpha, sina, beta, sinb
!-----------------------------------------------
!**********************************************************************
!
! VOLUME RETURNS (A) THE VOLUME OF A UNIT CELL IF NDIM=3
!                (B) THE AREA   OF A UNIT CELL IF NDIM=2
!                (C) THE LENGTH OF A UNIT CELL IF NDIM=1
!
!  ON INPUT VECS = ARRAY OF POINTS MARKING THE ENDS OF UNIT CELL VECTORS
!                  THE ORIGIN BEING (0.0, 0.0, 0.0)
!
!**********************************************************************
      a = sqrt(vecs(1,1)**2+vecs(2,1)**2+vecs(3,1)**2)
!
!    CASE 1: SYSTEM IS A POLYMER
!
      if (ndim == 1) then
        volume = a
        return
      endif
      b = sqrt(vecs(1,2)**2+vecs(2,2)**2+vecs(3,2)**2)
      gamma = sqrt((vecs(1,1)-vecs(1,2))**2+(vecs(2,1)-vecs(2,2))**2+(vecs(3,1)&
        -vecs(3,2))**2)
!
!     SING = SIN OF ANGLE BETWEEN FIRST AND SECOND VECTORS
!            OBTAINED FROM COSINE RULE C**2=A**2+B**2-2*A*B*COS(C)
!
      sing = sqrt(1.D0 - ((a*a + b*b - gamma*gamma)/(2.D0*a*b))**2)
!
!    CASE 2: SYSTEM IS A LAYER STRUCTURE
!
      if (ndim == 2) then
!
!   AREA OF A PARALLELOGRAM = BASE * HEIGHT
!
        volume = a*b*sing
        return
      endif
!
!    CASE 3: SYSTEM IS A SOLID
!
      c = sqrt(vecs(1,3)**2+vecs(2,3)**2+vecs(3,3)**2)
      alpha = sqrt((vecs(1,2)-vecs(1,3))**2+(vecs(2,2)-vecs(2,3))**2+(vecs(3,2)&
        -vecs(3,3))**2)
      sina = sqrt(1.D0 - ((b*b + c*c - alpha*alpha)/(2.D0*b*c))**2)
      beta = sqrt((vecs(1,1)-vecs(1,3))**2+(vecs(2,1)-vecs(2,3))**2+(vecs(3,1)-&
        vecs(3,3))**2)
      sinb = sqrt(1.D0 - ((a*a + c*c - beta*beta)/(2.D0*a*c))**2)
!
!     SINA = SIN OF ANGLE BETWEEN SECOND AND THIRD VECTORS
!     SINB = SIN OF ANGLE BETWEEN FIRST AND THIRD VECTORS
!
!     VOLUME OF A PARALLELEPIPED =A*SIN(ALPHA)*B*SIN(BETA)*C*SIN(GAMMA)
!
      volume = a*b*c*sina*sinb*sing
      return
      end function volume


program ch0709
    ! Means and Standard Deviations
    implicit none

    real :: mean = 0., ssq = 0., x, w, sd, r
    integer :: i, n

    print *, ' enter the number of readings'
    read *, n
    print *, ' enter the ', n, &
        ' values one per line'
    do i = 1, n
        read *, x
        w = x-mean
        r = i-1
        mean = (r*mean+x)/i
        ssq = ssq+w*w*r/i
    end do
    sd = (ssq/r)**0.5
    print *, ' mean is ', mean
    print *, ' standard deviation is ', sd
end program


subroutine interp_tk  (x    ,y     ,noval ,xx    ,yy    )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: interp_tk.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute_nearfar/interp_tk.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Interpolate to the y-value at xx
!
! Method used:
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
!

    use precision
    !
    implicit none
!
! Global variables
!
    integer ,                   intent (in)   ::   noval
    real(fp), dimension(noval), intent (in)   ::   x
    real(fp), dimension(noval), intent (in)   ::   y
    real(fp),                   intent (in)   ::   xx
    real(fp),                   intent (out)  ::   yy
!
! Local variables
!
    integer    ::   n
!
!! executable statements -------------------------------------------------------
!
    if (xx <= x(1)) then
       yy = y(1)
    elseif (xx >= x(noval)) then
       yy = y(noval)
    else
       do n = 2, noval
          if (xx >= x(n-1) .and. xx < x(n)) then
             yy = y(n-1) + ((xx - x(n-1))/(x(n) - x(n-1)))*(y(n) - y(n-1))
          endif
       enddo
    endif
end subroutine interp_tk