C NCLFORTSTART
      SUBROUTINE DTTEST(AVE1,VAR1,S1,AVE2,VAR2,S2,IFLAG,ALPHA,TVAL,IER)
c      implicit none

C NCL: prob = ttest (ave1,var1,s1,ave2,var2,s2,iflag,tval_opt)

c calculate student t-statistic + prob

c nomenclature:

c input  ave1,var1,s1 - average, variance and size (sample 1)
c .      ave2,var2,s2 - average, variance and size (sample 2)
c .                     Ideally, s1 and s2 >=30
c output alpha        - level of significance
c .                     probability that a random variable
c .                     following the students t distribution
c .                     will exceed tval in absolute value.
c .      tval         - t-value

c .                     e.g.,if df=14. and tval=1.761 then alpha=0.10.
c .                          for a 2 tailed test alpha=0.10 (or 10%)
c .                          means that the critical region has 5%
c .                          in each tail. note: some users set
c .                                  prob = 1.-alpha
c .                          upon return to the calling program.
c .      iflag        - set to False if population variances are equal
c .                     set to True if population variances are unequal
c .      ier          - error code

      DOUBLE PRECISION AVE1,VAR1,S1,AVE2,VAR2,S2,TVAL,ALPHA
      INTEGER IER
C NCLEND
      INTEGER IFLAG
      DOUBLE PRECISION DF,VARP
      DOUBLE PRECISION DBETAISLATEC

      IER = 0
C
C These following tests are done in the NCL C wrapper.
C
C      IF (S1.LT.2.0D0 .OR. S2.LT.2.0D0) IER = 1
C      IF (VAR1.LE.0.0D0 .OR. VAR2.LE.0.0D0) IER = IER + 10
C      IF (IER.NE.0) RETURN

      IF (IFLAG.EQ.0) THEN
          DF = S1 + S2 - 2.D0
          VARP = ((S1-1.D0)*VAR1+ (S2-1.D0)*VAR2)/DF
          TVAL = (AVE1-AVE2)/SQRT(VARP* (1.D0/S1+1.D0/S2))
      ELSE
          DF = (VAR1/S1+VAR2/S2)**2/ ((VAR1/S1)**2/ (S1-1.D0)+
     +         (VAR2/S2)**2/ (S2-1.D0))
          TVAL = (AVE1-AVE2)/SQRT(VAR1/S1+VAR2/S2)
C
C This following test is done in the NCL C wrapper.
C      ELSE
C          IER = -999
      END IF

      ALPHA = DBETAISLATEC(DF/ (DF+TVAL**2),0.5D0*DF,0.5D0)

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DFTEST(VAR1,VAR2,S1,S2,ALPHA,IER)
c c c implicit none

C NCL: prob = ftest (var1,var2,s1,s2)

c calculate student t-statistic + prob

c nomenclature:

c input  var1,s1      - variance and size (sample 1)
c .      var2,s2      - variance and size (sample 2)
c output alpha        - level of significance;
c .                     probability that a random variable
c .                     following the students t distribution
c .                     will exceed tval in absolute value.
c .      ier          - error code
c .                     ier.ne.0 then alpha=errval

      DOUBLE PRECISION VAR1,S1,VAR2,S2,ALPHA
      INTEGER IER
C NCLEND
      DOUBLE PRECISION DF1,DF2,FRAT
      DOUBLE PRECISION DBETAISLATEC

      IER = 0
      IF (S1.LT.2.0D0 .OR. S2.LT.2.0D0) IER = 1
      IF (VAR1.LE.0.0D0 .OR. VAR2.LE.0.0D0) IER = IER + 10
      IF (IER.NE.0) RETURN

      IF (VAR1.GT.VAR2) THEN
          FRAT = VAR1/VAR2
          DF1 = S1 - 1.D0
          DF2 = S2 - 1.D0
      ELSE
          FRAT = VAR2/VAR1
          DF1 = S2 - 1.D0
          DF2 = S1 - 1.D0
      END IF

      ALPHA = DBETAISLATEC(DF2/ (DF2+DF1*FRAT),0.5D0*DF2,0.5D0*DF1) +
     +        (1.D0-DBETAISLATEC(DF1/ (DF1+DF2/FRAT),0.5D0*DF1,
     +        0.5D0*DF2))

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DRTEST(R,N,PROB)
      IMPLICIT NONE
C Input
      INTEGER N
      DOUBLE PRECISION R
C Output
      DOUBLE PRECISION PROB
C NCLEND

C NCL: prob = rtest (r, n)

c nomenclature:
c Input
c .   r     - linear correlation coef
c .   n     - number of points used to calculate "r"
c Output
c .   prob  - calculated significance [0. < prob < 1.]

c Local variables

c c c real     betai
      DOUBLE PRECISION DBETAISLATEC
      DOUBLE PRECISION DF,TVAL

c calculate the significance level
c .   [see Numerical Recipies: Linear Correlation]
c .   [also: Climatic Change, WMO Tech Note 79, p66
c .          says "tval" formula is good for xn>=8]

      DF = N - 2.D0
      TVAL = R*SQRT(DF/ (1.D0-DMIN1(R*R,0.999D0)))
c c c prob  = betai ( 0.5*df, 0.5, df/(df+tval**2) )
      PROB = DBETAISLATEC(DF/ (DF+TVAL**2),0.5D0*DF,0.5D0)

      RETURN
      END

C NCLFORTSTART
      SUBROUTINE DEQVSIZ(X,NPTS,XMSG,SIGLVL,NEQV)
      IMPLICIT NONE
C Input
      INTEGER NPTS
      DOUBLE PRECISION X(NPTS),XMSG,SIGLVL
C Output
      INTEGER NEQV
C NCLEND

C NCL: neqv = eqv_sample_size (x,siglvl)
c      Only eqv size returned in NCL

C This assumes a red-noise process [r1>0.]

c nomenclature:
c Input
c .   x      - series
c .   npts   - number of pts
c .   xmsg   - missing code
c .   siglvl - significance level (eg: 0.05) at which the lag-1
c .            autocorrelation is to be tested.
c Output
c .   neqv   - Number of independent samples

c Local variables

c c c real     betai
      DOUBLE PRECISION DBETAISLATEC
      DOUBLE PRECISION XMEAN,XVAR,XSD,XCOV,XN,DF,SUM,TVAL,ALPHA,R1
      INTEGER N,LAG,JER,NPTUSED

      NEQV = -999

c compute 1st two moments

      CALL DSTAT2(X,NPTS,XMSG,XMEAN,XVAR,XSD,NPTUSED,JER)
      IF (NPTUSED.LE.0) THEN
          RETURN
      ELSEIF (NPTUSED.EQ.1 .OR. XVAR.EQ.0.D0) THEN
          NEQV = 1
          RETURN
      END IF

c compute lag-1 autocorrelation coef

      LAG  = 1
      XCOV = 0.D0
      XN   = 0.D0
      DO N = 2,NPTS
          IF (X(N).NE.XMSG .AND. X(N-LAG).NE.XMSG) THEN
              XCOV = XCOV + ((X(N)-XMEAN)* (X(N-LAG)-XMEAN))
              XN = XN + 1.D0
          END IF
      END DO

      IF (XN.GE.2.D0 .AND. XVAR.GT.0.D0) THEN
          R1 = (XCOV/ (XN-1.D0))/XVAR
      ELSE
          R1   = XMSG
          NEQV = -999
          RETURN
      END IF

c the approach below does not work when R1<0.

      IF (R1.LE.0.0D0) THEN
          NEQV = NPTUSED
          RETURN
      END IF

c calculate the significance level
c .   [see Numerical Recipies: Linear Correlation]
c .   [also: Climatic Change, WMO Tech Note 79, p66
c .          says "tval" formula is good for xn>=8]

      DF = NPTUSED - 2.D0
      TVAL = R1*SQRT(DF/ (1.D0-DMIN1(R1*R1,0.999D0)))
c c c alpha = betai ( 0.5*df, 0.5, df/(df+tval**2) )
      ALPHA = DBETAISLATEC(DF/ (DF+TVAL**2),0.5D0*DF,0.5D0)

c test r1 to see if it is sig different from zero at user
c specified level.

      NEQV = NPTUSED
      IF (ALPHA.LE.SIGLVL) THEN
          IF (XN.GE.50.D0 .AND. ABS(R1).NE.1.D0) THEN
              NEQV = XN* (1.D0-R1)/ (1.D0+R1)
          ELSE
              SUM = 1.0D0
              DO N = 1,NPTS
                  IF (X(N).NE.XMSG) THEN
                      SUM = SUM + 2.D0* (1.D0-N/XN)*R1**N
                  END IF
              END DO
              NEQV = XN/SUM
          END IF
          NEQV = MIN(NEQV,NPTUSED)
      END IF

      RETURN
      END


!-----------------------------------------------------------------------
! Solve tridiagonal matrix equation
!-----------------------------------------------------------------------
subroutine TRIDIAG(Nvec,Nmax,a,b,c,r,x)

implicit none

integer*8, intent(in) :: &
  Nvec,              &! Vector length
  Nmax                ! Maximum vector length

real*8, intent(in) :: &
  a(Nmax),           &! Below-diagonal matrix elements
  b(Nmax),           &! Diagonal matrix elements
  c(Nmax),           &! Above-diagonal matrix elements
  r(Nmax)             ! Matrix equation rhs

real*8, intent(out) :: &
  x(Nmax)             ! Solution vector

integer*8 :: n          ! Loop counter

! Work space
real*8 :: beta, gamma(Nvec)

beta = b(1)
x(1) = r(1) / beta

do n = 2, Nvec
  gamma(n) = c(n-1) / beta
  beta = b(n) - a(n)*gamma(n)
  x(n) = (r(n) - a(n)*x(n-1)) / beta
end do

do n = Nvec - 1, 1, -1
  x(n) = x(n) - gamma(n+1)*x(n+1)
end do

end subroutine TRIDIAG


!========================================================================
!
!                   S P E C F E M 2 D  Version 7 . 0
!                   --------------------------------
!
!     Main historical authors: Dimitri Komatitsch and Jeroen Tromp
!                        Princeton University, USA
!                and CNRS / University of Marseille, France
!                 (there are currently many more authors!)
! (c) Princeton University and CNRS / University of Marseille, April 2014
!
! This software is a computer program whose purpose is to solve
! the two-dimensional viscoelastic anisotropic or poroelastic wave equation
! using a spectral-element method (SEM).
!
! 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; either version 2 of the License, or
! (at your option) any later version.
!
! 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, write to the Free Software Foundation, Inc.,
! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
!
! The full text of the license is available in file "LICENSE".
!
!========================================================================

  subroutine lagrange_any(xi,NGLL,xigll,h,hprime)

! subroutine to compute the Lagrange interpolants based upon the interpolation points
! and their first derivatives at any point xi in [-1,1]

  implicit none

  double precision,intent(in) :: xi

  integer,intent(in) :: NGLL
  double precision,dimension(NGLL),intent(in) :: xigll
  double precision,dimension(NGLL),intent(out) :: h,hprime

  ! local parameters
  integer :: dgr,i,j
  double precision :: prod1,prod2,prod3
  double precision :: prod2_inv
  double precision :: sum
  double precision :: x0,x

! note: this routine is hit pretty hard by the mesher, optimizing the loops here will be beneficial

  do dgr = 1,NGLL

    prod1 = 1.0d0
    prod2 = 1.0d0

    ! lagrangian interpolants
    x0 = xigll(dgr)
    do i = 1,NGLL
      if (i /= dgr) then
        x = xigll(i)
        prod1 = prod1*(xi-x)
        prod2 = prod2*(x0-x)
      endif
    enddo

    ! takes inverse to avoid additional divisions
    ! (multiplications are cheaper than divisions)
    prod2_inv = 1.d0/prod2

    h(dgr) = prod1 * prod2_inv

    ! first derivatives
    sum = 0.0d0
    do i = 1,NGLL
      if (i /= dgr) then
        prod3 = 1.0d0
        do j = 1,NGLL
          if (j /= dgr .and. j /= i) prod3 = prod3*(xi-xigll(j))
        enddo
        sum = sum + prod3
      endif
    enddo

    hprime(dgr) = sum * prod2_inv

  enddo

  end subroutine lagrange_any

!
!=====================================================================
!

! subroutine to compute the derivative of the Lagrange interpolants
! at any given GLL point

  double precision function lagrange_deriv_GLL(i,j,ZGLL,NZ)

!------------------------------------------------------------------------
!
!     Compute the value of the derivative of the I-th
!     Lagrange interpolant through the
!     NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
!
!------------------------------------------------------------------------

  implicit none

  integer :: i,j,nz
  double precision :: zgll(0:nz-1)

  ! local parameters
  integer :: degpoly

  double precision, external :: pnleg,pndleg

  degpoly = nz - 1
  if (i == 0 .and. j == 0) then
    lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) * 0.25d0  ! / 4.d0
  else if (i == degpoly .and. j == degpoly) then
    lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) * 0.25d0  ! / 4.d0
  else if (i == j) then
    lagrange_deriv_GLL = 0.d0
  else
    lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
      (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
      + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
      (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
  endif

  end function lagrange_deriv_GLL

!
!=======================================================================
!

  double precision function hgll(I,Z,ZGLL,NZ)

!-------------------------------------------------------------
!
!  Compute the value of the Lagrangian interpolant L through
!  the NZ Gauss-Lobatto Legendre points ZGLL at point Z
!  See Nissen-Meyer et al., 2007, A two-dimensional spectral-element method for computing
!  spherical-earth seismograms - I. Moment-tensor source, Geophysical Journal International, p. 1087 eq. (A19)
!  !! Warning !! There is a minus sign missing in that paper (-1.d0)**(N+1)*(1.d0-Z)*PNDLEG(Z,N) / ALFAN
!
!-------------------------------------------------------------

  use constants, only: TINYVAL

  implicit none

  integer i,nz
  double precision z
  double precision ZGLL(0:nz-1)

  integer n
  double precision EPS,DZ,ALFAN
  double precision, external :: PNLEG,PNDLEG

  EPS = TINYVAL
  DZ = Z - ZGLL(I)
  if (abs(DZ) < EPS) then
   HGLL = 1.d0
   return
  endif
  N = NZ - 1
  ALFAN = dble(N)*(dble(N)+1.d0)
  if (I == 0) then
    HGLL = (-1.d0)**(N+1)*(1.d0-Z)*PNDLEG(Z,N) / ALFAN
  else if (I == N) then
    HGLL = (1.d0+Z)*PNDLEG(Z,N) / ALFAN
  else
    HGLL = - (1.d0-Z*Z)*PNDLEG(Z,N)/ (ALFAN*PNLEG(ZGLL(I),N)*(Z-ZGLL(I)))
  endif

  end function hgll

!
!=====================================================================
!

  double precision function hglj(I,Z,ZGLJ,NZ)

!-------------------------------------------------------------
!
!  Compute the value of the Lagrangian interpolant L through
!  the NZ Gauss-Lobatto Jacobi points ZGLJ at point Z
! See Nissen-Meyer et al., 2007, A two-dimensional spectral-element method for computing
! spherical-earth seismograms - I. Moment-tensor source, Geophysical Journal International, p. 1088 eq. (A26)
!
!-------------------------------------------------------------

  use constants, only: TINYVAL

  implicit none

  integer i,nz
  double precision z
  double precision ZGLJ(0:nz-1)

  integer n
  double precision EPS,DZ,ALFAN1,ALFAN2
  double precision, external :: PNGLJ,PNDGLJ

  EPS = TINYVAL
  DZ = Z - ZGLJ(I)
  if (abs(DZ) < EPS) then
   HGLJ = 1.d0
   return
  endif
  N = NZ - 1
  ALFAN1 = dble(N)+1.d0
  ALFAN2 = dble(N)*(dble(N)+2.d0)
  if (I == 0) then
    HGLJ = 2.d0*(-1.d0)**N*(Z-1.0d0)*PNDGLJ(Z,N) / (ALFAN1*ALFAN2)
  else if (I == N) then
    HGLJ = (1.d0+Z)*PNDGLJ(Z,N) / ALFAN2
  else
    HGLJ = - (1.d0-Z*Z)*PNDGLJ(Z,N) / (ALFAN2*PNGLJ(ZGLJ(I),N)*(Z-ZGLJ(I)))
  endif

  end function hglj

!
!=====================================================================
!

! subroutine to compute the derivative of the interpolants of the GLJ
! quadrature at the GLJ points at any given GLJ point

  double precision function poly_deriv_GLJ(I,j,ZGLJ,NZ)

!------------------------------------------------------------------------
!
!  Compute the value of the derivative of the I-th
!  polynomial interpolant of the GLJ quadrature through the
!  NZ Gauss-Lobatto-Jacobi (0,1) points ZGLJ at point ZGLJ(j)
! See Nissen-Meyer et al., 2007, A two-dimensional spectral-element method for computing
! spherical-earth seismograms - I. Moment-tensor source, Geophysical Journal International, p. 1088 eq. (A27)
!  WARNING: there is an error at line 7 of their equation
!  \partial_{\xi}\overline{l}_{i}(\overline{\xi}_{I})=\dfrac{1}{\overline{P}_{N}(\overline{\xi}_{i})(1-\overline{\xi}_{i})}
!
!------------------------------------------------------------------------

  implicit none

  integer i,j,nz
  double precision zglj(0:nz-1)

  integer degpoly

  double precision, external :: pnglj

  degpoly = nz - 1

  if (i == 0 .and. j == 0) then ! Case 1
    poly_deriv_GLJ = -dble(degpoly)*(dble(degpoly)+2.d0)/6.d0
  else if (i == 0 .and. 0 < j .and. j < degpoly) then ! Case 2
    poly_deriv_GLJ = 2.d0*(-1)**degpoly*pnglj(zglj(j),degpoly)/((1.d0+zglj(j))*(dble(degpoly)+1.d0))
  else if (i == 0 .and. j == degpoly) then ! Case 3
    poly_deriv_GLJ = (-1)**degpoly/(dble(degpoly)+1.d0)
  else if (0 < i .and. i < degpoly .and. j == 0) then ! Case 4
    poly_deriv_GLJ = (-1)**(degpoly+1)*(dble(degpoly)+1.d0)/(2.d0*pnglj(zglj(i),degpoly)*(1.d0+zglj(i)))
  else if (0 < i .and. i < degpoly .and. 0 < j .and. j < degpoly .and. i /= j) then ! Case 5
    poly_deriv_GLJ = 1.d0/(zglj(j)-zglj(i))*pnglj(zglj(j),degpoly)/pnglj(zglj(i),degpoly)
  else if (0 < i .and. i < degpoly .and. i == j) then  ! Case 6
    poly_deriv_GLJ = -1.d0/(2.d0*(1.d0+zglj(i)))
  else if (0 < i .and. i < degpoly .and. j == degpoly) then ! Case 7
    poly_deriv_GLJ = 1.d0/(pnglj(zglj(i),degpoly)*(1.d0-zglj(i)))
  else if (i == degpoly .and. j == 0) then ! Case 8
    poly_deriv_GLJ = (-1)**(degpoly+1)*(dble(degpoly)+1.d0)/4.d0
  else if (i == degpoly .and. 0 < j .and. j < degpoly) then ! Case 9
    poly_deriv_GLJ = -1.d0/(1.d0-zglj(j))*pnglj(zglj(j),degpoly)
  else if (i == degpoly .and. j == degpoly) then ! Case 10
    poly_deriv_GLJ = (dble(degpoly)*(dble(degpoly)+2.d0)-1.d0)/4.d0
  else
    stop 'Problem in poly_deriv_GLJ: in a perfect world this would NEVER appear'
  endif

  end function poly_deriv_GLJ


program tarefaa1
    implicit real(8) (a-h,o-z)
    character(70) c_filename
    character(10) c_planeta
    parameter (pi=4d0*atan(1d0))
    dimension ri(2), rmi(2), d2rdt2(2), v(2)

    n = 5d4

    open(20, file='entrada-a1-10407962.dat')

    do j = 1, 9
        read(20,*) c_planeta, a_massa, a_raio, a_exce, v0

        write(c_filename, '(A,A,A)') 'saida-a1-', trim(c_planeta), '-10407962.dat'

        Tp = sqrt(a_raio**3d0)
        dt = Tp/n
        GMs = 4*pi**2

!        v0 = sqrt(GMs/a_raio)
        v = (/0d0, v0 /)

        ri = (/ a_raio, 0d0 /)
        rmi = ri +v*dt

        write(*,*) c_planeta, Tp**2/dnorm(ri)**3, v0

        open(10, file=c_filename)

        write(10, *) ri

        do i = 1, int(Tp/dt)
            d2rdt2 = -GMs*ri/dnorm(ri)**3

            call verlet(rmi, ri, d2rdt2, dt)

            write(10, *) ri
        end do

        close(10)
    end do

contains
    function dnorm(r)
        implicit real(8) (a-h,o-z)
        dimension r(2)
        dnorm = sqrt(r(1)**2 + r(2)**2)
        return
    end function

    subroutine verlet(ri, rmi, d2rdt2, dt)
        implicit real(8) (a-h,o-z)
        dimension ri(2), rmi(2), raux(2), d2rdt2(2)

        raux = ri
        ri = 2*ri - rmi + d2rdt2*dt**2
        rmi = raux
    end subroutine

end program tarefaa1


      PROGRAM drddasl5
c>> 2008-10-26 DRDDASL5 Krogh Moved Format statements up for C conv.
c>> 2008-10-24 DRDDASL5 Krogh Removed in INCLUDE statement & cDEC$...
C>> 2008-08-27 DRDDASL5  solve for initial y' value, change user codes
C>> 2006-12-18 DRDDASL5  add total energy as a constraint.
C>> 2001-10-11 DRDDASL5  R. J. Hanson Example 5 Code, with Download

C     Solve a planar pendulum problem in rectangular coordinates.
C     The equation is transformed from "Index 3" to "Index 1"
C     by differentiating the length constraint twice.  The system
C     is integrated (using DDASSFA) using these three constraints,
C     including total energy.
C     In the second integration the problem is transformed from
C     "Index 3" to "Index 0" by differentiating the length constraint
C     three times.  The routine DDASSFB uses four constraints,
C     including total energy.
C     This example shows that the constraints remain satisfied,
C     and the integration can succeed with either approach.
C     It is more efficient to use the "Index 0" problem than
C     the "Index 1" problem.
C--D replaces "?": DR?DASL5, ?DASLS, ?DASLX, ?DASSFA, ?DASSFB

      EXTERNAL ddassfa,ddassfb,d1mach,ddasls
C     Set number of equations:
      INTEGER neq
      PARAMETER  (neq=5)
C     Set maximum number of constraints.
      INTEGER maxcon
      PARAMETER  (maxcon=4)
C     Work space sizes:
      INTEGER liw,lrw,ldc
      PARAMETER  (liw=30+neq)
      PARAMETER  (lrw=45+(5+2*maxcon+4)*neq+2*neq**2)
      PARAMETER  (ldc=2*neq)
      INTEGER ndig,kk
      DOUBLE PRECISION tol
C++S Default NDIG = 4
C++  Default NDIG = 11
C++ Substitute for NDIG below
      PARAMETER  (ndig=11)
      PARAMETER  (tol=10.d0**(-ndig))

      INTEGER i,info(16),idid,iwork(liw)
      DOUBLE PRECISION t,y(neq),yprime(neq),tout,rtol(neq),atol(neq),
     & rwork(lrw),length,drl,drv,c(ldc,neq),ftol,rnktol,
     & d1mach

      LOGICAL constraint
      INTEGER kr,kf,kc
      COMMON /counts/ kr,kf,kc

   70 FORMAT (14x,'Example Results for a Constrained Pendulum Problem, I
     &ndex 1')
   80 FORMAT (14x,'Initial Position and Derivative Values using DDASLS')
   90 FORMAT (6x,'At the time value',f10.2,2x,'the integration was stopp
     &ed.')
  100 FORMAT ('The pendulum length or variation has large weighted error
     &s.'/'These should remain less than 1 is magnitude:',10x,2f8.2/)
  110 FORMAT (14x,'Example Results for a Constrained Pendulum Problem, I
     &ndex 0')
  120 FORMAT (5x,'No. of Residual Evaluations',6x,'Factorizations',6x,'P
     &rojection Solves'/'Constraint Partials-',1x,i8,12x,i8,17x,i8/)
  130 FORMAT (/8x,'T',10x,'y_1',09x,'y_2',09x,'y_3',09x,'y_4',09x,'y_5'/
     &1p,6d12.4/)
  140 FORMAT (/8x,'T',09x,'y''_1',08x,'y''_2',08x,'y''_3',08x,'y''_4',
     & 08x,'y''_5'/1p,6d12.4/)

      WRITE (*,70)

C     Tolerances:
      DO 10 i=1,neq
        atol(i)=tol
        rtol(i)=tol
   10 CONTINUE
C     Setup options:
      DO 20 i=1,16
        info(i)=0
   20 CONTINUE
C     Use partial derivatives provided in user code:
      info(5)=2

C     Constrain solution, forward with 3 constraints:
      info(10)=3

C     Compute the initial value of YPRIME(*).
C     Base computation of the initial y' on the
C     report by Krogh, Hanson, (2008), "Solving
C     Constrained Differential-Algebraic Systems
C     Using Projections," (8/2008).
      t=0
C     Tolerances for a small F and a rank tolerance:
      ftol=d1mach(4)**(2./3.)
      rnktol=ftol
C     Give starting values to y and y' before Newton method:
      do 25 i = 1, neq
        y(i) = 0.D0
        yprime(i) = 0.D0
 25   continue
c     (Initial value for y(1) reset when ires is 0)
      CALL ddasls (ddassfa, neq, t, y, yprime, info, ftol, rnktol, c,
     & ldc, neq, idid, rwork, lrw, iwork, liw)
      WRITE (*,80)
C     Write the computed values for initial position and derivatives.
      WRITE (*,130) t,y
      WRITE (*,140) t,yprime

C     Now have initial values of y' so no need to compute them.
C     Allow more than nominal number of steps.
      info(12)=50000
C     This is the pendulum length
      length=1.1d0
C     This is how long we will integrate.
      kk=1000
      DO 30 i=1,kk,10
C     Integrate from T=I-1 to TOUT=T+10.
C     If the solution drifts away from the constraints, stop.
        t=i-1
        tout=t+10
        CALL ddaslx (ddassfa, neq, t, y, yprime, tout, info, rtol, atol,
     &    idid, rwork, lrw, iwork, liw)
C  Compute residuals on length and its variation.  They
C  should be smaller than the tolerances used.
        drl=(y(1)**2+y(2)**2-length**2)/(rtol(1)*length**2+atol(1))
        drv=(y(1)*y(3)+y(2)*y(4))/(rtol(1)*(abs(y(1)*y(3))+
     &       abs(y(1)*y(4)))+atol(1))
        constraint=abs(drl).le.1.d0.and.abs(drv).le.1.d0
        IF (.not.constraint) GO TO 40
   30 CONTINUE
   40 CONTINUE
      WRITE (*,130) tout,y
      WRITE (*,120) kr,kf,kc
      WRITE (*,90) tout
      IF (.not.constraint) THEN
        WRITE (*,100) drl,drv
      END IF

C     Start the integration over for the index 0 problem.
      info(1)=0
C     Set the number of constraints to 4.
      info(10)=4
C     Starting values to y and y' before Newton method:
      do 45 i = 1, neq
        y(i) = 0.D0
        yprime(i) = 0.D0
 45   continue
c     (Initial value for y(1) and yprime(4) reset when ires is 0)
      DO 50 i=1,kk,10
C     Integrate from T=I-1 to TOUT=T+10.
        t=i-1
        tout=t+10
        CALL ddaslx (ddassfb, neq, t, y, yprime, tout, info, rtol, atol,
     &    idid, rwork, lrw, iwork, liw)
C  Compute residuals on length and its variation.  They
C  should be smaller than the tolerances used.
        drl=(y(1)**2+y(2)**2-length**2)/(rtol(1)*length**2+atol(1))
        drv=(y(1)*y(3)+y(2)*y(4))/(rtol(1)*(abs(y(1)*y(3))+
     &       abs(y(1)*y(4)))+atol(1))
        constraint=abs(drl).le.1.d0.and.abs(drv).le.1.d0
        IF (.not.constraint) GO TO 60
   50 CONTINUE
   60 CONTINUE
      WRITE (*,110)
      WRITE (*,130) tout,y
      WRITE (*,120) kr,kf,kc
      WRITE (*,90) tout
      IF (.not.constraint) THEN
        WRITE (*,100) drl,drv
      END IF
      END

      SUBROUTINE ddassfa (t, y, yprime, delta, d, ldd, cj, ires, rwork,
     & iwork)
C     Routine for the swinging simple pendulum problem,
C     with constraints on the index 2 and 3 equations.
      DOUBLE PRECISION t,y(*),yprime(*),delta(*),d(ldd,5),cj,rwork(*),
     & lsq,mg
      INTEGER ires,iwork(*),ldd
      DOUBLE PRECISION one,two,zero,mass,length,gravity
      PARAMETER  (one=1.d0,two=2.d0,zero=0.d0,mass=1.d0,length=1.1d0,
     & gravity=9.806650d0)
      SAVE  mg,lsq
      INTEGER kr,kf,kc
      COMMON /counts/ kr,kf,kc
C This is the setup call.
      IF (ires.eq.0) THEN
        mg=mass*gravity
        lsq=length**2
        y(1)=length

C This is the only nonzero value for y'_4(0) but the startup
C procedure will compute it.  It is written here for
C reference.
C        YPRIME(4)=-Gravity
        kr=0
        kf=0
        kc=0
      END IF
      mg=mass*gravity
      lsq=length**2
C The system residual value.
      IF (ires.eq.1) THEN
        delta(1)=y(3)-yprime(1)
        delta(2)=y(4)-yprime(2)
        delta(3)=-y(1)*y(5)-mass*yprime(3)
        delta(4)=-y(2)*y(5)-mass*yprime(4)-mg
        delta(5)=mass*(y(3)**2+y(4)**2)-mg*y(2)-lsq*y(5)
C Count residual evaluations.
        kr=kr+1
      END IF

C The mixed partial derivative matrix DF/Dy + c * DF/Dy'
      IF (ires.eq.2) THEN
        d(1,1)=-cj
        d(3,1)=-y(5)

        d(2,2)=-cj
        d(4,2)=-y(5)
        d(5,2)=-mg

        d(1,3)=one
        d(3,3)=-mass*cj
        d(5,3)=two*mass*y(3)

        d(2,4)=one
        d(4,4)=d(3,3)
        d(5,4)=two*mass*y(4)

        d(3,5)=-y(1)
        d(4,5)=-y(2)
        d(5,5)=-lsq
        kf=kf+1
      END IF

C The constraining equations after the corrector has converged.
C Both partials and residuals are required.
      IF (ires.eq.5) THEN
        d(6,1)=y(1)*two
        d(6,2)=y(2)*two
        d(6,3)=zero
        d(6,4)=zero
        d(6,5)=zero

        d(7,1)=y(3)
        d(7,2)=y(4)
        d(7,3)=y(1)
        d(7,4)=y(2)
        d(7,5)=zero

C Constraining total energy -
        d(8,1)=zero
        d(8,2)=mg
        d(8,3)=mass*y(3)
        d(8,4)=mass*y(4)
        d(8,5)=zero
        delta(6)=y(1)**2+y(2)**2-lsq
        delta(7)=y(1)*y(3)+y(2)*y(4)
        delta(8)=0.5d0*mass*(y(3)**2+y(4)**2)+mg*y(2)
        kc=kc+1
      END IF

C  What follows are Partials w.r.t. T, Y' and Y, needed for
C  computing the starting values of y' based on the
C  Krogh/Hanson starting algorithm.
C  These values (6,7,8) of IRES occur only for use in
C  the computation of initial values for y'.
      IF (ires.eq.6) THEN
C  This is the partial of F, the residual function, w.r.t. T.
C  There is no explicit time dependence so this is zero.
C  The contents of DELTA(:) are set zero by the calling program
C  so there is nothing to do.
C        DELTA(1:6)=ZERO
      END IF

C  This is the partial of F w.r.t. y'.
C  Values not assigned are set zero by the calling program.
      IF (ires.eq.7) THEN
        d(1,1)=-one
        d(2,2)=-one
        d(3,3)=-mass
        d(4,4)=-mass
        kf=kf+1
      END IF

C  This is the partial of F w.r.t. y.
C  Values not assigned are set zero by the calling program.
      IF (ires.eq.8) THEN
        d(3,1)=-y(5)

        d(4,2)=-y(5)
        d(5,2)=-mg

        d(1,3)=one
        d(5,3)=two*mass*y(3)

        d(2,4)=one
        d(5,4)=two*mass*y(4)

        d(3,5)=-y(1)
        d(4,5)=-y(2)
        d(5,5)=-lsq
        kf=kf+1

      END IF
      END

      SUBROUTINE ddassfb (t, y, yprime, delta, p, ldp, cj, ires, rwork,
     & iwork)
C
C     Routine for the swinging simple pendulum problem,
C     with constraints on the index 1,2 amd 3 equations.
C     Use P(:,:) to distinguish from D(:,:) in routine DDASSFA.

      DOUBLE PRECISION t,y(*),yprime(*),delta(*),p(ldp,5),cj,rwork(*),
     & lsq,mg
      INTEGER ires,iwork(*),ldp
      DOUBLE PRECISION one,two,three,zero,mass,length,gravity
      PARAMETER  (one=1.d0,two=2.d0,three=3.d0,zero=0.d0,mass=1.d0,
     & length=1.1d0,gravity=9.806650d0)
      SAVE  mg,lsq
      INTEGER kr,kf,kc
      COMMON /counts/ kr,kf,kc
C This is the setup call.
      IF (ires.eq.0) THEN
        mg=mass*gravity
        lsq=length**2
        y(1)=length
        yprime(4)=-gravity
        kr=0
        kf=0
        kc=0
      END IF

C The sytem residual value.
      IF (ires.eq.1) THEN
        delta(1)=y(3)-yprime(1)
        delta(2)=y(4)-yprime(2)
        delta(3)=-y(1)*y(5)-mass*yprime(3)
        delta(4)=-y(2)*y(5)-mass*yprime(4)-mg
        delta(5)=-three*mg*y(4)-lsq*yprime(5)
        kr=kr+1
      END IF

C The partial derivative matrix.  Entries are all zero
C so only non-zero values are needed.
      IF (ires.eq.2) THEN
        p(1,1)=-cj
        p(3,1)=-y(5)

        p(2,2)=-cj
        p(4,2)=-y(5)

        p(1,3)=one
        p(3,3)=-mass*cj

        p(2,4)=one
        p(4,4)=p(3,3)
        p(5,4)=-three*mg

        p(3,5)=-y(1)
        p(4,5)=-y(2)
        p(5,5)=-lsq*cj
        kf=kf+1
      END IF

C The constraining equations after the corrector has converged.
C Both partials and residuals are required.
      IF (ires.eq.5) THEN
        p(6,1)=y(1)*two
        p(6,2)=y(2)*two
        p(6,3)=zero
        p(6,4)=zero
        p(6,5)=zero

        p(7,1)=y(3)
        p(7,2)=y(4)
        p(7,3)=y(1)
        p(7,4)=y(2)
        p(7,5)=zero

        p(8,1)=zero
        p(8,2)=-mg
        p(8,3)=two*mass*y(3)
        p(8,4)=two*mass*y(4)
        p(8,5)=-lsq
C Constraining total energy -
        p(9,1)=zero
        p(9,2)=mg
        p(9,3)=mass*y(3)
        p(9,4)=mass*y(4)
        p(9,5)=zero
        delta(6)=y(1)**2+y(2)**2-lsq
        delta(7)=y(1)*y(3)+y(2)*y(4)
        delta(8)=mass*(y(3)**2+y(4)**2)-mg*y(2)-lsq*y(5)
        delta(9)=0.5d0*mass*(y(3)**2+y(4)**2)+mg*y(2)
        kc=kc+1
      END IF
      END


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE GPOINTS3X3                                              C
C                                                                      C
C 3X3 GAUSS POINTS GENERATION                                          C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE GPOINTS3X3(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0)
C
      DIMENSION XP(2,9),XW(9),RLGP(2,9)
C
      CALL CLEARV(XW,9)
      CALL CLEAR(XP,2,9)
      CALL CLEAR(RLGP,2,9)
C
      RLGP(1,1)=-ONE
      RLGP(1,2)=ZERO
      RLGP(1,3)= ONE
      RLGP(1,4)=-ONE
      RLGP(1,5)=ZERO
      RLGP(1,6)= ONE
      RLGP(1,7)=-ONE
      RLGP(1,8)=ZERO
      RLGP(1,9)= ONE
C
      RLGP(2,1)=-ONE
      RLGP(2,2)=-ONE
      RLGP(2,3)=-ONE
      RLGP(2,4)=ZERO
      RLGP(2,5)=ZERO
      RLGP(2,6)=ZERO
      RLGP(2,7)= ONE
      RLGP(2,8)= ONE
      RLGP(2,9)= ONE
C
      XW(1)=0.555555555555556D0**2
      XW(2)=0.555555555555556D0*0.888888888888889D0
      XW(3)=0.555555555555556D0**2
C
      XW(4)=0.555555555555556D0*0.888888888888889D0
      XW(5)=0.888888888888889D0**2
      XW(6)=0.555555555555556D0*0.888888888888889D0
C
      XW(7)=0.555555555555556D0**2
      XW(8)=0.555555555555556D0*0.888888888888889D0
      XW(9)=0.555555555555556D0**2
C
      G=DSQRT(0.60D0)
      DO I=1,2
        DO J=1,9
          XP(I,J)=G*RLGP(I,J)
        END DO
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE GAUSS1D                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE GAUSS1D(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION XP(6),XW(6)
C
      XP(1)=-0.932469514203152
      XP(2)=-0.661209386466265
      XP(3)=-0.238619186083197
      XP(6)= 0.932469514203152
      XP(5)= 0.661209386466265
      XP(4)= 0.238619186083197
C
      XW(1)=0.171324492379170
      XW(2)=0.360761573048139
      XW(3)=0.467913934572691
      XW(6)=XW(1)
      XW(5)=XW(2)
      XW(4)=XW(3)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE GPOINTS2X2                                              C
C                                                                      C
C 2X2 GAUSS POINTS GENERATION                                          C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE GPOINTS2X2(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
C
      DIMENSION XP(2,9),XW(9)
C
      CALL CLEARV(XW,9)
      CALL CLEAR(XP,2,9)
C
      DO K1=1,4
        XW(K1)=ONE
      END DO
C
c      XP(1,1)=-0.288675134595
c      XP(2,1)=-0.288675134595
c      XP(1,2)= 0.288675134595
c      XP(2,2)=-0.288675134595
c      XP(1,3)=-0.288675134595
c      XP(2,3)= 0.288675134595
c      XP(1,4)= 0.288675134595
c      XP(2,4)= 0.288675134595
C

      XP(1,1)=-0.577350269189626
      XP(2,1)=-0.577350269189626
      XP(1,2)= 0.577350269189626
      XP(2,2)=-0.577350269189626
      XP(1,3)=-0.577350269189626
      XP(2,3)= 0.577350269189626
      XP(1,4)= 0.577350269189626
      XP(2,4)= 0.577350269189626
c
      RETURN
C
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C     SUBROUTINE GPOINTS7                                              C
C                                                                      C
C     7 GAUSS POINTS FOR TRIANGULAR DOMAINS                            C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE GPOINTS7(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
C
      DIMENSION XP(2,7),XW(7)
C
      CALL CLEARV(XW,7)
      CALL CLEAR(XP,2,7)
C

      XW(1)=0.1259391805448D0
      XW(2)=XW(1)
      XW(3)=XW(1)
      XW(4)=0.1323941527885D0
      XW(5)=XW(4)
      XW(6)=XW(4)
      XW(7)=0.225D0

C
      XP(1,1)= 0.1012865073235D0
      XP(1,2)= 0.7974269853531D0
      XP(1,3)= 0.1012865073235D0
      XP(1,4)= 0.4701420641051D0
      XP(1,5)= 0.4701420641051D0
      XP(1,6)= 0.0597158717898D0
      XP(1,7)= 0.3333333333333D0
C
      XP(2,1)= XP(1,1)
      XP(2,2)= XP(1,1)
      XP(2,3)= XP(1,2)
      XP(2,4)= XP(1,6)
      XP(2,5)= XP(1,4)
      XP(2,6)= XP(1,4)
      XP(2,7)= XP(1,7)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE GPOINTS3D2X2                                            C
C                                                                      C
C 2X2 GAUSS POINTS GENERATION                                          C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE GPOINTS3D2X2(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
C
      DIMENSION XP(3,8),XW(8)
C
      CALL CLEARV(XW,8)
      CALL CLEAR(XP,3,8)
C
      DO K1=1,8
        XW(K1)=ONE
      END DO
C
C     First layer
C

      XP(1,1)=-0.577350269189626
      XP(2,1)=-0.577350269189626
      XP(3,1)= 0.577350269189626

      XP(1,2)= 0.577350269189626
      XP(2,2)=-0.577350269189626
      XP(3,2)= 0.577350269189626

      XP(1,3)=-0.577350269189626
      XP(2,3)= 0.577350269189626
      XP(3,3)= 0.577350269189626

      XP(1,4)= 0.577350269189626
      XP(2,4)= 0.577350269189626
      XP(3,4)= 0.577350269189626
C
C     Second layer
C
      XP(1,5)=-0.577350269189626
      XP(2,5)=-0.577350269189626
      XP(3,5)=-0.577350269189626

      XP(1,6)= 0.577350269189626
      XP(2,6)=-0.577350269189626
      XP(3,6)=-0.577350269189626

      XP(1,7)=-0.577350269189626
      XP(2,7)= 0.577350269189626
      XP(3,7)=-0.577350269189626

      XP(1,8)= 0.577350269189626
      XP(2,8)= 0.577350269189626
      XP(3,8)=-0.577350269189626
c
      RETURN
C
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE GPOINTS3D2X2                                            C
C                                                                      C
C 2X2 GAUSS POINTS GENERATION                                          C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE GPOINTSW10(XP,XW)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0,HALF=0.5D0)
C
      DIMENSION XP(3,8),XW(8)
C
      CALL CLEARV(XW,8)
      CALL CLEAR(XP,3,8)
C
      DO K1=1,8
        XW(K1)=ONE
      END DO
C
C     First layer
C

      XP(1,1)=-0.577350269189626
      XP(2,1)=-0.577350269189626
      XP(3,1)= 0.577350269189626

      XP(1,2)= 0.577350269189626
      XP(2,2)=-0.577350269189626
      XP(3,2)= 0.577350269189626

      XP(1,3)=-0.577350269189626
      XP(2,3)= 0.577350269189626
      XP(3,3)= 0.577350269189626

      XP(1,4)= 0.577350269189626
      XP(2,4)= 0.577350269189626
      XP(3,4)= 0.577350269189626
C
C     Second layer
C
      XP(1,5)=-0.577350269189626
      XP(2,5)=-0.577350269189626
      XP(3,5)=-0.577350269189626

      XP(1,6)= 0.577350269189626
      XP(2,6)=-0.577350269189626
      XP(3,6)=-0.577350269189626

      XP(1,7)=-0.577350269189626
      XP(2,7)= 0.577350269189626
      XP(3,7)=-0.577350269189626

      XP(1,8)= 0.577350269189626
      XP(2,8)= 0.577350269189626
      XP(3,8)=-0.577350269189626
c
      RETURN
C
      END
C


      subroutine fdsim( n, ip, iq, ar, ma, d, rmu, y, s)

      implicit double precision (a-h,o-z)

c  generates a random time series for use with fracdf
c
c  Input :
c
c  n      integer  length of the time series
c  ip     integer  number of autoregressive parameters
c  ar     real    (ip) autoregressive parameters
c  ma     real    (iq) moving average parameters
c  d      real     fractional differencing parameters
c  rmu    real     time series mean
c  y      real    (n+iq) 1st n : normalized random numbers
c  s      real    (n+iq) workspace
c
c  Output :
c
c  s      real   (n) the generated time series

c-----------------------------------------------------------------------------
c
c        Simulates a series of length n from an ARIMA (p,d,q) model
c        with fractional d (0 < d < 0.5).
c
c-----------------------------------------------------------------------------

      integer            n, ip, iq
c     real               ar(ip), ma(iq), rmu, d
      real               ar(*), ma(*), rmu, d

      real               g0, vk, amk, sum, dk1, dk1d, dj, temp
c     real               y(n+iq), s(n+iq)
      real               y(*), s(*)

      double precision   dgamr, dgamma, dlamch

      real               gennor

      external           dgamr, dgamma, dlamch, gennor

      integer            k, j, i

      double precision   FLTMIN, FLTMAX, EPSMIN, EPSMAX
      common /MACHFD/    FLTMIN, FLTMAX, EPSMIN, EPSMAX
      save   /MACHFD/

      integer            IGAMMA, JGAMMA
      common /GAMMFD/    IGAMMA, JGAMMA
      save   /GAMMFD/

      real              zero, one, two
      parameter        (zero = 0.0, one = 1.0, two = 2.0)

c--------------------------------------------------------------------------

        IGAMMA = 0
        JGAMMA = 0

        FLTMIN  = dlamch( 'S' )
c       FLTMAX  = dlamch( 'O' )  not guaranteed to work
        FLTMAX  = 1.0 / FLTMIN
        BASE    = dlamch( 'B' )
        EPSMIN  = dlamch( 'E' )
        EPSMAX  = EPSMIN*BASE
c
c       Calculate g0

        temp = real(dgamr(dble(one-d)))
        if (IGAMMA .ne. 0) then
          do i = 1, n
            s(i) = zero
          end do
          return
        end if

        g0   = real(dgamma(dble(one-two*d)))*(temp*temp)
        if (IGAMMA .ne. 0) then
          do i = 1, n
            s(i) = zero
          end do
          return
        end if
c
c       Generate y(1)
c
       y(1) = gennor(0.,1.)*sqrt(g0)
c
c       Generate y(2) and initialise vk,phi(j)
c
       temp  = d / (one-d)
       vk    = g0*(one-(temp*temp))

       amk   = temp*y(1)
        s(1)  = temp
       y(2)  = amk + gennor(0.,1.)*sqrt(vk)
c
c       Generate y(3),...,y(n+iq)
c
       do k = 3, n + iq
          dk1  = real(k) - one
          dk1d = dk1 - d
c
c       Update the phi(j) using the recursion formula on W498
c
          do j = 1, k-2
            dj   = dk1 - real(j)
            s(j) = s(j)*(dk1*(dj-d)/(dk1d*dj))
          end do

                 temp   = d / dk1d
          s(k-1) = temp
c
c       Update vk
c
         vk = vk * (one-(temp*temp))
c
c       Form amk
c
         amk = zero
         do j = 1, k-1
           amk = amk + s(j)*y(k-j)
          end do
c
c       Generate y(k)
c
         y(k) = amk + gennor(0.,1.)*sqrt(vk)

       end do
c
c       We now have an ARIMA (0,d,0) realisation of length n+iq in
c       y(k),k=1,n+iq. We now run this through an inverse ARMA(p,q)
c       filter to get the final output in x(k),k=1,n.
c

       do k = 1, n

         sum = zero

          do i = 1, ip
           if (k .le. i) go to 10
           sum = sum + ar(i)*s(k-i)
          end do

10        continue

          do j = 1, iq
           sum = sum-ma(j)*y(k+iq-j)
          end do

         s(k) = sum + y(k+iq)

        end do

        if (rmu .ne. zero) then
          do i = 1, n
            s(i) = s(i) + rmu
          end do
        end if

       return
       end


	PROGRAM WAVELETEST
C
	REAL REALP(100),IMAGP(100)
	DATA TWOPI /6.28318531/
C
C	GENERATE A WAVELET
C
	NUMBER = 50
	OMEGA = TWOPI
	GAMMA = 2.*(OMEGA/5.336)**2
	print*,'w,gamma',omega,gamma
	DT = .1
	CALL WVLTGEN(OMEGA,GAMMA,NUMBER,DT,REALP,IMAGP)
	DO N = 1,NUMBER+1
	  PRINT*,N,OMEGA*N*DT,REALP(N),IMAGP(N)
	  WRITE(33,*) N,OMEGA*N*DT,REALP(N),IMAGP(N)
	ENDDO
C
C	GENERATE SINE WAVES FOR TESTING
C
	STOP
	END
	SUBROUTINE WVLTGEN(OMEGA,GAMMA,NUMBER,DT,REALP,IMAGP)
C
C	GENERATES REAL AND IMAGINARY PARTS OF A MORLET WAVELET.  I USE
C		THE NOTATION OF TEOLIS "COMPUTATIONAL SIGNAL PROCESSING
C		WITH WAVELETS, EXCEPT THAT HIS GAMMAb IS MY GAMMA AND
C		HIS GAMMAc IS MY OMEGA
C	HERE DT IS THE TIME BETWEEN SAMPLES, AND NUMBER IS THE TOTAL
C	NUMBER OF POINTS (TRUNCATION),  NUMBER IS TURNED INTO THE
C		NEXT LARGEST ODD NUMBER
C
	REAL REALP(100),IMAGP(100)
	DATA TWOPI /6.28318531/
C
	NO = 2*(NUMBER/2) + 1
	N2 =  (NO-1)/2
	N1 = -N2
	DO N = N1,N2
	  GAUSSF = EXP(-(N*DT)**2/GAMMA)/SQRT(.5*TWOPI*GAMMA)
	  ARG = OMEGA*N*DT
	  REALP(N-N1+1) = GAUSSF*COS(ARG)
	  IMAGP(N-N1+1) = GAUSSF*SIN(ARG)
	ENDDO
	RETURN
	END


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 2015 Adrian Martinez Vargas                            %
!                                                                      %
! This software may be modified and distributed under the terms        %
! of the MIT license.  See the LICENSE.txt file for details.           %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!                                                                      %
! Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
! Junior University.  All rights reserved.                             %
!                                                                      %
! The programs in GSLIB are distributed in the hope that they will be  %
! useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
! responsibility to anyone for the consequences of using them or for   %
! whether they serve any particular purpose or work at all, unless he  %
! says so in writing.  Everyone is granted permission to copy, modify  %
! and redistribute the programs in GSLIB, but only under the condition %
! that this notice and the above copyright notice remain intact.       %
!                                                                      %
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
! The functions and subroutines below were modified from the
! version 2.0 of the gslib code written in fortran 77
!
! The objective is to add functionality to GSLIB and to link
! this code with python using f2py. It uses f90 code convention.
! The arrays are dynamic and externally declared (from python)
!
! the code was converted from Fortran 77 to Fortran 90 using F2F.pl
!
! for more information please refer to:
! - gslib77 source code: http://www.statios.com/software/gslib77_ls.tar.gz
! - GSLIB: Geostatistical Software Library and User's Guide. Second edition
!   by Clayton V. Deutsch, Andre G. Journel, 1997.
! - F2PY Users Guide: http://docs.scipy.org/doc/numpy-dev/f2py/
! - F2F https://bitbucket.org/lemonlab/f2f
!-----------------------------------------------------------------------

subroutine gauinv(p,xp,ierr)
    !-----------------------------------------------------------------------

    ! Computes the inverse of the standard normal cumulative distribution
    ! function with a numerical approximation from : Statistical Computing,
    ! by W.J. Kennedy, Jr. and James E. Gentle, 1980, p. 95.

    ! INPUT/OUTPUT:

    !   p    = double precision cumulative probability value: dble(psingle)
    !   xp   = G^-1 (p) in single precision
    !   ierr = 1 - then error situation (p out of range), 0 - OK

    !-----------------------------------------------------------------------
    real :: xp
    real*8 :: p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,y,pp,lim,p
    save   p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,lim

    ! Coefficients of approximation:

    data lim/1.0e-10/
    data p0/-0.322232431088/,p1/-1.0/,p2/-0.342242088547/, &
    p3/-0.0204231210245/,p4/-0.0000453642210148/
    data q0/0.0993484626060/,q1/0.588581570495/,q2/0.531103462366/, &
    q3/0.103537752850/,q4/0.0038560700634/

    ! Check for an error situation:

    ierr = 1
    if(p < lim) then
        xp = -1.0e10
        return
    end if
    if(p > (1.0-lim)) then
        xp =  1.0e10
        return
    end if
    ierr = 0

    ! Get k for an error situation:

    pp   = p
    if(p > 0.5) pp = 1 - pp
    xp   = 0.0
    if(p == 0.5) return

    ! Approximate the function:

    y  = dsqrt(dlog(1.0/(pp*pp)))
    xp = real( y + ((((y*p4+p3)*y+p2)*y+p1)*y+p0) / &
    ((((y*q4+q3)*y+q2)*y+q1)*y+q0) )
    if(real(p) == real(pp)) xp = -xp

    ! Return with G^-1(p):

    return
end subroutine gauinv

subroutine dgauinv(p,xp,ierr)
    !-----------------------------------------------------------------------

    ! Computes the inverse of the standard normal cumulative distribution
    ! function with a numerical approximation from : Statistical Computing,
    ! by W.J. Kennedy, Jr. and James E. Gentle, 1980, p. 95.

    ! INPUT/OUTPUT:

    !   p    = double precision cumulative probability value: dble(psingle)
    !   xp   = G^-1 (p) in single precision
    !   ierr = 1 - then error situation (p out of range), 0 - OK

    !-----------------------------------------------------------------------
    real*8:: xp
    real*8 :: p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,y,pp,lim,p
    save   p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,lim

    ! Coefficients of approximation:

    data lim/1.0e-10/
    data p0/-0.322232431088/,p1/-1.0/,p2/-0.342242088547/, &
    p3/-0.0204231210245/,p4/-0.0000453642210148/
    data q0/0.0993484626060/,q1/0.588581570495/,q2/0.531103462366/, &
    q3/0.103537752850/,q4/0.0038560700634/

    ! Check for an error situation:

    ierr = 1
    if(p < lim) then
        xp = -1.0e10
        return
    end if
    if(p > (1.0-lim)) then
        xp =  1.0e10
        return
    end if
    ierr = 0

    ! Get k for an error situation:

    pp   = p
    if(p > 0.5) pp = 1 - pp
    xp   = 0.0
    if(p == 0.5) return

    ! Approximate the function:

    y  = dsqrt(dlog(1.0/(pp*pp)))
    xp = real( y + ((((y*p4+p3)*y+p2)*y+p1)*y+p0) / &
    ((((y*q4+q3)*y+q2)*y+q1)*y+q0) )
    if(real(p) == real(pp)) xp = -xp

    ! Return with G^-1(p):

    return
end subroutine dgauinv


! { dg-do compile }
! { dg-options "-floop-nest-optimize -fcheck=bounds -O1" }

SUBROUTINE PD2VAL(RES,NDERIV,TG1,TG2,C0)
    INTEGER, PARAMETER :: dp=8
    REAL(KIND=dp), INTENT(OUT)  :: res(*)
    REAL(KIND=dp), INTENT(IN)   :: TG1, TG2, C0(105,*)
    REAL(KIND=dp)               :: T1(0:13), T2(0:13)
 DO K=1,NDERIV+1
  RES(K)=RES(K)+DOT_PRODUCT(T1(0:7),C0(70:77,K))*T2(6)
  RES(K)=RES(K)+DOT_PRODUCT(T1(0:4),C0(91:95,K))*T2(9)
  RES(K)=RES(K)+DOT_PRODUCT(T1(0:3),C0(96:99,K))*T2(10)
 ENDDO
END SUBROUTINE PD2VAL


module rand_mod
  implicit none

contains

function rand5()
  integer :: rand5
  real :: r

  call random_number(r)
  rand5 = 5*r + 1
end function

function rand7()
  integer :: rand7

  do
    rand7 = 5*rand5() + rand5() - 6
    if (rand7 < 21) then
      rand7 = rand7 / 3 + 1
      return
    end if
  end do
end function
end module

program Randtest
  use rand_mod
  implicit none

  integer, parameter :: samples = 1000000

  call distcheck(rand7, samples, 0.005)
  write(*,*)
  call distcheck(rand7, samples, 0.001)

end program


subroutine SHSCouplingMatrixCap(kij, galpha, galpha_order, lmax, nmax, &
                                exitstatus)
!------------------------------------------------------------------------------
!
!   SHSCouplingMatrixCap returns the spherical harmonic coupling matrix that
!   relates the expectation of the function expressed in a subset of the best-
!   localized spherical-cap Slepian functions to the expectation of the global
!   power spectrum (assumed to be stationary). The Slepian functions are
!   determined by a call to `SHReturnTapers`, and each row of galpha contains
!   the (lmax+1) spherical harmonic coefficients for the single angular order
!   as given in galpha_order.
!
!   The relationship between the global and localized power spectra is given by
!
!       < S_{\tilde{f}}(l) > = \sum_{l'=0}^lmax K_{ll'} S_{f}(l')
!
!   where S_{\tilde{f}} is the expectation of the power spectrum at degree l of
!   the function expressed in Slepian functions, S_{f}(l') is the expectation
!   of the global power spectrum, and < ... > is the expectation operator.
!   The coupling matrix is given explicitly by
!
!   K_{ll'} = \frac{1}{2l'+1} Sum_{m=-mmax}^mmax
!            ( Sum_{alpha=1}^nmax g_{l'm}(alpha) g_{lm}(alpha) )**2
!
!   where mmax is min(l, lp).
!
!   Calling Parameters
!
!       IN
!           galpha         Matrix of dimension (LMAX+1, nmax) containing the
!                          spherical harmonic coefficients of the spherical-cap
!                          Slepian functions, obtained from a call to
!                          SHReturnTapers, where the functions are ordered from
!                          best to worst concentrated.
!           galpha_order   An array of dimension kmax containing the real
!                          angular order of the functions in galpha, as
!                          obtained from SHReturnTapers.
!           lmax           Maximum spherical harmonic degree of the Slepian
!                          functions.
!           nmax           Maximum number of Slepian coefficients used to
!                          construct the function.
!
!       OUT
!           kij            Spherical harmonic coupling matrix of dimension
!                          ((LMAX+1)**2, nmax).
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(out) :: kij(:,:)
    real(dp), intent(in) :: galpha(:,:)
    integer, intent(in) :: galpha_order(:), lmax, nmax
    integer, intent(out), optional :: exitstatus
    integer :: l, lp, m, alpha
    real(dp) :: temp

    if (present(exitstatus)) exitstatus = 0

    if (size(kij(:,1)) < (lmax+1) .or. size(kij(1,:)) < (lmax+1)) then
        print*, "Error --- SHSCouplingMatrixCap"
        print*, "KIJ must be dimensioned as (LMAX+1, LMAX+1)."
        print*, "LMAX = ", lmax
        print*, "Dimension of KIJ = ", size(kij(:,1)), size(kij(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(galpha(:,1)) < (lmax+1) .or. &
            size(galpha(1,:)) < nmax) then
        print*, "Error --- SHSCouplingMatrixCap"
        print*, "GALPHA must be dimensioned as (LMAX+1, NMAX )."
        print*, "LMAX = ", lmax
        print*, "NMAX = ", nmax
        print*, "Input array is dimensioned as ", size(galpha(:,1)), &
                size(galpha(1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(galpha_order) < nmax) then
        print*, "Error ---  SHSCouplingMatrixCap"
        print*, "GALPHA_ORDER must be dimensioned as (KMAX) where NMAX is ", &
                nmax
        print*, "Input array is dimensioned ", size(galpha_order)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    kij = 0.0_dp

    ! Calculate k(l, lp) * (2lp +1 ), which is symmetric
    do l = 0, lmax

        do lp = l, lmax, 1

            do m = -l, l, 1

                temp = 0.0_dp
                do alpha = 1, nmax, 1

                    if (galpha_order(alpha) /= m) cycle

                    temp = temp + galpha(lp+1, alpha) * galpha(l+1, alpha)

                end do

                kij(l+1, lp+1) = kij(l+1, lp+1) + temp**2

            end do

        end do

    end do

    ! Fill lower half of matrix
    do l = 1, lmax, 1

        do lp=0, l-1, 1

            kij(l+1, lp+1) = kij(lp+1, l+1)

        end do

    end do

    ! Multiply by 1/(2lp+1)
    do lp = 0, lmax

        kij(1:lmax+1, lp+1) = kij(1:lmax+1, lp+1) / dble(2*lp+1)

    end do

end subroutine SHSCouplingMatrixCap


*DECK CQRSL
      SUBROUTINE CQRSL (X, LDX, N, K, QRAUX, Y, QY, QTY, B, RSD, XB,
     +   JOB, INFO)
C***BEGIN PROLOGUE  CQRSL
C***PURPOSE  Apply the output of CQRDC to compute coordinate transfor-
C            mations, projections, and least squares solutions.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D9, D2C1
C***TYPE      COMPLEX (SQRSL-S, DQRSL-D, CQRSL-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, ORTHOGONAL TRIANGULAR,
C             SOLVE
C***AUTHOR  Stewart, G. W., (U. of Maryland)
C***DESCRIPTION
C
C     CQRSL applies the output of CQRDC to compute coordinate
C     transformations, projections, and least squares solutions.
C     For K .LE. MIN(N,P), let XK be the matrix
C
C            XK = (X(JVPT(1)),X(JVPT(2)), ... ,X(JVPT(K)))
C
C     formed from columns JVPT(1), ... ,JVPT(K) of the original
C     N x P matrix X that was input to CQRDC (if no pivoting was
C     done, XK consists of the first K columns of X in their
C     original order).  CQRDC produces a factored unitary matrix Q
C     and an upper triangular matrix R such that
C
C              XK = Q * (R)
C                       (0)
C
C     This information is contained in coded form in the arrays
C     X and QRAUX.
C
C     On Entry
C
C        X      COMPLEX(LDX,P).
C               X contains the output of CQRDC.
C
C        LDX    INTEGER.
C               LDX is the leading dimension of the array X.
C
C        N      INTEGER.
C               N is the number of rows of the matrix XK.  It must
C               have the same value as N in CQRDC.
C
C        K      INTEGER.
C               K is the number of columns of the matrix XK.  K
C               must not be greater than (N,P), where P is the
C               same as in the calling sequence to CQRDC.
C
C        QRAUX  COMPLEX(P).
C               QRAUX contains the auxiliary output from CQRDC.
C
C        Y      COMPLEX(N)
C               Y contains an N-vector that is to be manipulated
C               by CQRSL.
C
C        JOB    INTEGER.
C               JOB specifies what is to be computed.  JOB has
C               the decimal expansion ABCDE, with the following
C               meaning.
C
C                    If A .NE. 0, compute QY.
C                    If B,C,D, or E .NE. 0, compute QTY.
C                    If C .NE. 0, compute B.
C                    If D .NE. 0, compute RSD .
C                    If E .NE. 0, compute  XB.
C
C               Note that a request to compute B, RSD, or XB
C               automatically triggers the computation of QTY, for
C               which an array must be provided in the calling
C               sequence.
C
C     On Return
C
C        QY     COMPLEX(N).
C               QY contains Q*Y, if its computation has been
C               requested.
C
C        QTY    COMPLEX(N).
C               QTY contains CTRANS(Q)*Y, if its computation has
C               been requested.  Here CTRANS(Q) is the conjugate
C               transpose of the matrix Q.
C
C        B      COMPLEX(K)
C               B contains the solution of the least squares problem
C
C                    minimize NORM2(Y - XK*B),
C
C               if its computation has been requested.  (Note that
C               if pivoting was requested in CQRDC, the J-th
C               component of B will be associated with column JVPT(J)
C               of the original matrix X that was input into CQRDC.)
C
C        RSD    COMPLEX(N).
C               RSD contains the least squares residual Y - XK*B,
C               if its computation has been requested.  RSD is
C               also the orthogonal projection of Y onto the
C               orthogonal complement of the column space of XK.
C
C        XB     COMPLEX(N).
C               XB contains the least squares approximation XK*B,
C               if its computation has been requested.  XB is also
C               the orthogonal projection of Y onto the column space
C               of X.
C
C        INFO   INTEGER.
C               INFO is zero unless the computation of B has
C               been requested and R is exactly singular.  In
C               this case, INFO is the index of the first zero
C               diagonal element of R and B is left unaltered.
C
C     The parameters QY, QTY, B, RSD, and XB are not referenced
C     if their computation is not requested and in this case
C     can be replaced by dummy variables in the calling program.
C     To save storage, the user may in some cases use the same
C     array for different parameters in the calling sequence.  A
C     frequently occurring example is when one wishes to compute
C     any of B, RSD, or XB and does not need Y or QTY.  In this
C     case one may identify Y, QTY, and one of B, RSD, or XB, while
C     providing separate arrays for anything else that is to be
C     computed.  Thus the calling sequence
C
C          CALL CQRSL(X,LDX,N,K,QRAUX,Y,DUM,Y,B,Y,DUM,110,INFO)
C
C     will result in the computation of B and RSD, with RSD
C     overwriting Y.  More generally, each item in the following
C     list contains groups of permissible identifications for
C     a single calling sequence.
C
C          1. (Y,QTY,B) (RSD) (XB) (QY)
C
C          2. (Y,QTY,RSD) (B) (XB) (QY)
C
C          3. (Y,QTY,XB) (B) (RSD) (QY)
C
C          4. (Y,QY) (QTY,B) (RSD) (XB)
C
C          5. (Y,QY) (QTY,RSD) (B) (XB)
C
C          6. (Y,QY) (QTY,XB) (B) (RSD)
C
C     In any group the value returned in the array allocated to
C     the group corresponds to the last member of the group.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CCOPY, CDOTC
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CQRSL
      INTEGER LDX,N,K,JOB,INFO
      COMPLEX X(LDX,*),QRAUX(*),Y(*),QY(*),QTY(*),B(*),RSD(*),XB(*)
C
      INTEGER I,J,JJ,JU,KP1
      COMPLEX CDOTC,T,TEMP
      LOGICAL CB,CQY,CQTY,CR,CXB
      COMPLEX ZDUM
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C***FIRST EXECUTABLE STATEMENT  CQRSL
C
C     SET INFO FLAG.
C
      INFO = 0
C
C     DETERMINE WHAT IS TO BE COMPUTED.
C
      CQY = JOB/10000 .NE. 0
      CQTY = MOD(JOB,10000) .NE. 0
      CB = MOD(JOB,1000)/100 .NE. 0
      CR = MOD(JOB,100)/10 .NE. 0
      CXB = MOD(JOB,10) .NE. 0
      JU = MIN(K,N-1)
C
C     SPECIAL ACTION WHEN N=1.
C
      IF (JU .NE. 0) GO TO 40
         IF (CQY) QY(1) = Y(1)
         IF (CQTY) QTY(1) = Y(1)
         IF (CXB) XB(1) = Y(1)
         IF (.NOT.CB) GO TO 30
            IF (CABS1(X(1,1)) .NE. 0.0E0) GO TO 10
               INFO = 1
            GO TO 20
   10       CONTINUE
               B(1) = Y(1)/X(1,1)
   20       CONTINUE
   30    CONTINUE
         IF (CR) RSD(1) = (0.0E0,0.0E0)
      GO TO 250
   40 CONTINUE
C
C        SET UP TO COMPUTE QY OR QTY.
C
         IF (CQY) CALL CCOPY(N,Y,1,QY,1)
         IF (CQTY) CALL CCOPY(N,Y,1,QTY,1)
         IF (.NOT.CQY) GO TO 70
C
C           COMPUTE QY.
C
            DO 60 JJ = 1, JU
               J = JU - JJ + 1
               IF (CABS1(QRAUX(J)) .EQ. 0.0E0) GO TO 50
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  T = -CDOTC(N-J+1,X(J,J),1,QY(J),1)/X(J,J)
                  CALL CAXPY(N-J+1,T,X(J,J),1,QY(J),1)
                  X(J,J) = TEMP
   50          CONTINUE
   60       CONTINUE
   70    CONTINUE
         IF (.NOT.CQTY) GO TO 100
C
C           COMPUTE CTRANS(Q)*Y.
C
            DO 90 J = 1, JU
               IF (CABS1(QRAUX(J)) .EQ. 0.0E0) GO TO 80
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  T = -CDOTC(N-J+1,X(J,J),1,QTY(J),1)/X(J,J)
                  CALL CAXPY(N-J+1,T,X(J,J),1,QTY(J),1)
                  X(J,J) = TEMP
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE
C
C        SET UP TO COMPUTE B, RSD, OR XB.
C
         IF (CB) CALL CCOPY(K,QTY,1,B,1)
         KP1 = K + 1
         IF (CXB) CALL CCOPY(K,QTY,1,XB,1)
         IF (CR .AND. K .LT. N) CALL CCOPY(N-K,QTY(KP1),1,RSD(KP1),1)
         IF (.NOT.CXB .OR. KP1 .GT. N) GO TO 120
            DO 110 I = KP1, N
               XB(I) = (0.0E0,0.0E0)
  110       CONTINUE
  120    CONTINUE
         IF (.NOT.CR) GO TO 140
            DO 130 I = 1, K
               RSD(I) = (0.0E0,0.0E0)
  130       CONTINUE
  140    CONTINUE
         IF (.NOT.CB) GO TO 190
C
C           COMPUTE B.
C
            DO 170 JJ = 1, K
               J = K - JJ + 1
               IF (CABS1(X(J,J)) .NE. 0.0E0) GO TO 150
                  INFO = J
                  GO TO 180
  150          CONTINUE
               B(J) = B(J)/X(J,J)
               IF (J .EQ. 1) GO TO 160
                  T = -B(J)
                  CALL CAXPY(J-1,T,X(1,J),1,B,1)
  160          CONTINUE
  170       CONTINUE
  180       CONTINUE
  190    CONTINUE
         IF (.NOT.CR .AND. .NOT.CXB) GO TO 240
C
C           COMPUTE RSD OR XB AS REQUIRED.
C
            DO 230 JJ = 1, JU
               J = JU - JJ + 1
               IF (CABS1(QRAUX(J)) .EQ. 0.0E0) GO TO 220
                  TEMP = X(J,J)
                  X(J,J) = QRAUX(J)
                  IF (.NOT.CR) GO TO 200
                     T = -CDOTC(N-J+1,X(J,J),1,RSD(J),1)/X(J,J)
                     CALL CAXPY(N-J+1,T,X(J,J),1,RSD(J),1)
  200             CONTINUE
                  IF (.NOT.CXB) GO TO 210
                     T = -CDOTC(N-J+1,X(J,J),1,XB(J),1)/X(J,J)
                     CALL CAXPY(N-J+1,T,X(J,J),1,XB(J),1)
  210             CONTINUE
                  X(J,J) = TEMP
  220          CONTINUE
  230       CONTINUE
  240    CONTINUE
  250 CONTINUE
      RETURN
      END


subroutine clawpack46_limiter(maxm,meqn,mwaves,mbc,mx, &
           wave,s,mthlim)

    !! # Apply a limiter to the waves.
    !! # The limiter is computed by comparing the 2-norm of each wave with
    !! # the projection of the wave from the interface to the left or
    !! # right onto the current wave.  For a linear system this would
    !! # correspond to comparing the norms of the two waves.  For a
    !! # nonlinear problem the eigenvectors are not colinear and so the
    !! # projection is needed to provide more limiting in the case where the
    !! # neighboring wave has large norm but points in a different direction
    !! # in phase space.
    !!
    !! # The specific limiter used in each family is determined by the
    !! # value of the corresponding element of the array mthlim, as used in
    !! # the function philim.
    !! # Note that a different limiter may be used in each wave family.
    !!
    !! # dotl and dotr denote the inner product of wave with the wave to
    !! # the left or right.  The norm of the projections onto the wave are then
    !! # given by dotl/wnorm2 and dotr/wnorm2, where wnorm2 is the 2-norm
    !! # of wave.

    implicit none

    integer :: maxm, meqn, mwaves, mbc, mx

    integer :: mthlim(mwaves)
    double precision :: wave(meqn,mwaves,1-mbc:maxm+mbc)
    double precision :: s(mwaves,1-mbc:maxm+mbc)

    integer :: mw,i, m
    double precision :: dotr, wnorm2, dotl, wlimitr
    double precision :: philim

    wave_loop : do mw = 1,mwaves
        if (mthlim(mw) .eq. 0) then
            cycle
        endif
        dotr = 0.d0
        i_loop : do  i = 0, mx+1
            wnorm2 = 0.d0
            dotl = dotr
            dotr = 0.d0
            do m = 1,meqn
                wnorm2 = wnorm2 + wave(m,mw,i)**2
                dotr = dotr + wave(m,mw,i)*wave(m,mw,i+1)
            enddo

            if (i .gt. 0 .and. wnorm2 .ne. 0) then
                if (s(mw,i) .gt. 0.d0) then
                    wlimitr = philim(wnorm2, dotl, mthlim(mw))
                else
                    wlimitr = philim(wnorm2, dotr, mthlim(mw))
                endif

                do m = 1,meqn
                    wave(m,mw,i) = wlimitr * wave(m,mw,i)
                end do
            endif
        end do i_loop
    end do wave_loop

    return
end subroutine  clawpack46_limiter


! =====================================================
subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! =====================================================

! HLLE solver for the Euler equations.
! Same as rpn2_euler_hlle except that
! this solver takes into account internal reflecting boundaries (walls) within the domain,
! making it possible to solve problems like flow over a step.
! The aux array contains the geometry: where it is equal to zero, a solid object exists.
! The fluid domain is the region where aux is equal to one.

! waves: 2
! equations: 4

! Conserved quantities:
!       1 density
!       2 x-momentum
!       3 y-momentum
!       4 energy

    implicit none

    integer, intent(in) :: ixy, maxm, meqn, mwaves, maux, mbc, mx
    double precision, dimension(meqn,1-mbc:maxm+mbc), intent(inout) :: ql, qr
    double precision, dimension(maux,1-mbc:maxm+mbc), intent(in) :: auxl, auxr
    double precision, dimension(meqn, mwaves, 1-mbc:maxm+mbc), intent(out) :: wave
    double precision, dimension(mwaves, 1-mbc:maxm+mbc), intent(out) :: s
    double precision, dimension(meqn, 1-mbc:maxm+mbc), intent(out) :: amdq, apdq

    double precision :: u_l, u_r, c_l, c_r, u_hat, c_hat, v_l, v_r, v_hat
    double precision :: p_l, p_r, H_l, H_r, rhsqrt_l, rhsqrt_r
    double precision :: rhsq2, H_hat, gamma, gamma1, E_l, E_r
    double precision :: rho_m, rhou_m, rhov_m, E_m, s1, s2
    integer :: rho, mu, mv, E
    integer :: i, m, mw

    common /cparam/  gamma

    gamma1 = gamma - 1.d0

!     # set mu to point to  the component of the system that corresponds
!     # to momentum in the direction of this slice, mv to the orthogonal
!     # momentum:
!

    rho = 1
    E = 4
    if (ixy.eq.1) then
        mu = 2
        mv = 3
    else
        mu = 3
        mv = 2
    endif

    do i=2-mbc,mx+mbc

        ! First handle boundaries
        if( (auxr(1,i-1) .eq. 0.d0) .and. (auxl(1,i) .eq. 1.d0) ) then
            ! Reflecting boundary to left
            qr(1,i-1) = ql(1,i)
            qr(mu,i-1) = -ql(mu,i)
            qr(mv,i-1) = ql(mv,i)
            qr(4,i-1) = ql(4,i)
         else if( (auxl(1,i) .eq. 0.d0) .and. (auxr(1,i-1) .eq. 1.d0) ) then
            ! Reflecting boundary to right
            ql(1,i) = qr(1,i-1)
            ql(mu,i) = -qr(mu,i-1)
            ql(mv,i) = qr(mv,i-1)
            ql(4,i) = qr(4,i-1)
        ! We ought to check here if aux is zero on both sides.
        end if

        ! Velocity
        u_l = qr(mu,i-1) / qr(rho,i-1)
        u_r = ql(mu,i  ) / ql(rho,i  )
        v_l = qr(mv,i-1) / qr(rho,i-1)
        v_r = ql(mv,i  ) / ql(rho,i  )
        ! Pressure
        p_l = gamma1 * (qr(E,i-1) - qr(rho,i-1)*(u_l**2+v_l**2)/2.d0)
        p_r = gamma1 * (ql(E,i  ) - ql(rho,i  )*(u_r**2+v_r**2)/2.d0)
        ! Enthalpy
        H_l = (qr(E,i-1) + p_l) / qr(rho,i-1)
        H_r = (ql(E,i  ) + p_l) / ql(rho,i  )
        ! Sound speed
        c_l = dsqrt(gamma1*H_l-u_l**2/2.)
        c_r = dsqrt(gamma1*H_r-u_r**2/2.)

        E_l = qr(E,i-1)
        E_r = ql(E,i  )

        rhsqrt_l = dsqrt(qr(rho,i-1))
        rhsqrt_r = dsqrt(ql(rho,i))
        rhsq2 = rhsqrt_l + rhsqrt_r
        u_hat = (qr(mu,i-1)/rhsqrt_l + ql(mu,i)/rhsqrt_r) / rhsq2
        v_hat = (qr(mv,i-1)/rhsqrt_l + ql(mv,i)/rhsqrt_r) / rhsq2
        H_hat = (((qr(E,i-1)+p_l)/rhsqrt_l + (ql(E,i)+p_r)/rhsqrt_r)) / rhsq2
        c_hat = dsqrt(gamma1*(H_hat - 0.5d0*(u_hat**2+v_hat**2)))

        ! Speeds of non-shear waves
        s1 = min(u_l - c_l, u_hat - c_hat)
        s2 = max(u_r + c_r, u_hat + c_hat)

        ! "middle" state
        rho_m = (ql(mu,i) - qr(mu,i-1) - s2*ql(rho,i) + s1*qr(rho,i-1))/(s1-s2)
        rhou_m = (ql(rho,i)*u_r**2 - qr(rho,i-1)*u_l**2 + p_r - p_l - s2*ql(mu,i) + s1*qr(mu,i-1))/(s1-s2)
        rhov_m = (ql(mv,i)*u_r - qr(mv,i-1)*u_l - s2*ql(mv,i) + s1*qr(mv,i-1))/(s1-s2)
        E_m = ( u_r*(E_r+p_r) - u_l*(E_l+p_l) -s2*E_r + s1*E_l)/(s1-s2)

        wave(rho,1,i) = rho_m - qr(rho,i-1)
        wave(mu,1,i) = rhou_m - qr(mu,i-1)
        wave(mv,1,i) = rhov_m - qr(mv,i-1)
        wave(E,1,i) = E_m - qr(E,i-1)
        s(1,i) = s1

        wave(rho,2,i) = ql(rho,i) - rho_m
        wave(mu,2,i) = ql(mu,i) - rhou_m
        wave(mv,2,i) = ql(mv,i) - rhov_m
        wave(E,2,i) = ql(E,i) - E_m
        s(2,i) = s2
    end do

    do m=1,meqn
        do i=2-mbc, mx+mbc
            amdq(m,i) = 0.d0
            apdq(m,i) = 0.d0
            do mw=1,mwaves
                if (s(mw,i) .lt. 0.d0) then
                    amdq(m,i) = amdq(m,i) + s(mw,i)*wave(m,mw,i)
                 else
                   apdq(m,i) = apdq(m,i) + s(mw,i)*wave(m,mw,i)
                 endif
            end do
        end do
    end do

end subroutine rpn2


module constants
use types, only: dp
implicit none
private
public pi, e_, i_

! Constants contain more digits than double precision, so that
! they are rounded correctly. Single letter constants contain underscore so
! that they do not clash with user variables ("e" and "i" are frequently used as
! loop variables)
real(dp), parameter :: pi    = 3.1415926535897932384626433832795_dp
real(dp), parameter :: e_    = 2.7182818284590452353602874713527_dp
complex(dp), parameter :: i_ = (0, 1)

end module


program test_linalg_x
    use forlab_linalg, only: operator(.x.)
    use forlab_io, only: disp
    real, dimension(:, :), allocatable :: x_sp, y_sp

    allocate(x_sp(2,2), y_sp(2,2))

    x_sp = 1.
    y_sp = 2.

    call disp(x_sp.x.y_sp, 'x .x. y SP✨:')
end program test_linalg_x


C << MAIN PROGRAM>>
      IMPLICIT double precision (A-H,O-Z)
C *** Step1 input data ***
      write(6,*) 'input init value x1 and x2='
      read(5,*) x1, x2
      write(6,*) 'criteria of convergence epsilon='
      read(5,*) e
C *** Step 2 calculate bisection method ***
 100  x=(x1+x2)/2.0
      if(f(x1)*f(x).lt.0) then
          x2=x
      else
          x1=x
      end if

      if(abs(x1-x2).ge.e) then
          goto 100
      end if
C *** Step 3 output result
      write(6,200) 'answer = ',x
 200  format(1h,a6,f10.6)
      stop
      end

c << define nonlinear equation >>
      double precision function f(x)
c      x : value
      implicit double precision (A-H,O-Z)
      f=x**3-1
      return
      end


program MakeMag
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This program will read in a set of magnetic spherical harmonic coefficients
!	and will expand these into gridded raster ascii files corresponding
!	to the phi, theta, radial and total field. The field is calculated
!	on a speroid with radius r and flattening f.
!
!	The included spherical harmonic file FSU_mars90.sh is the martian magnetic
!	field model of Cain et al., 2003.
!
!	Dependencies:	SHRead
!			MakeMagGrid2D
!
!	Written by Mark Wieczorek, February 2004
!
!	Copyright (c) 2005, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use SHTOOLS

	implicit none
	integer, parameter ::	maxdeg = 100, gridmax = 1
	character*80 ::		infile, radf, thetaf, phif, totalf
	real*8 ::		glm(2,maxdeg+1, maxdeg+1), header(4), interval, r0, r, &
				rad(181*gridmax, 361*gridmax), phi(181*gridmax, 361*gridmax), &
				theta(181*gridmax, 361*gridmax), total(181*gridmax, 361*gridmax), &
				f, mpr, z, timein, timeout
	integer ::		lmax, nlong, nlat, i, j

	f = 1.0d0/169.864881d0	! Mars flattening = (R_eq - R_p)/R_eq
	mpr = 3389.508d3	! Mean radius of mars
	z = 145.d3		! mean altitude to calculate field at.

	infile = "../ExampleDataFiles/FSU_mars90.sh"

	call SHRead(infile, glm, lmax, header=header(1:4), skip=1)
	r0 = header(1)*1.d3
	print*, "R0 (km) = ", r0/1.d3
	print*, "Lmax of file = ", lmax

	r = mpr + z
	print*, "R (km) = ", r/1.d3

	print*, "Interval for gridded data (degrees) > "
	read(*,*) interval

	if (interval < gridmax) then
		print*, gridmax, interval
		stop
	endif

	radf = "radial_145f.dat"
	thetaf = "theta_145f.dat"
	phif = "phi_145f.dat"
	totalf = "total_145f.dat"

	open(12,file=radf)
	open(13,file=phif)
	open(14,file=thetaf)
	open(15,file=totalf)

	call cpu_time(timein)

	call MakeMagGrid2D(rad, phi, theta, total, glm, r0, r, f, lmax, interval, nlat, nlong)

	call cpu_time(timeout)

	print*, "Elapsed time (sec) = ", timeout-timein

	print*, "Maximum and minimum intensity (nT) = ", maxval(total(1:nlat,1:nlong)), minval(total(1:nlat,1:nlong))

	print*, nlat, nlong

	! write(12,*) nlat, nlong
	! write(13,*) nlat, nlong
	! write(14,*) nlat, nlong
	! write(15,*) nlat, nlong

	do i=1, nlat
		do j=1, nlong
			write(12,*) rad(i,j)
			write(13,*) phi(i,j)
			write(14,*) theta(i,j)
			write(15,*) total(i,j)
		enddo
	enddo

	close(12)
	close(13)
	close(14)
	close(15)

end program


program test_sce

  use mo_kind,             only: i4, i8, dp
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_sce,              only: sce
  use mo_opt_functions,    only: ackley

  implicit none

  real(dp), dimension(:),   allocatable :: pini
  real(dp), dimension(:,:), allocatable :: prange
  real(dp), dimension(:),   allocatable :: opt
  logical,  dimension(:),   allocatable :: mask

  real(dp)                              :: bestf      ! best function value = history(-1) = ackley(opt)
  integer(i8)                           :: neval      ! number of function evaluations = size(history,1)
  real(dp), dimension(:),   allocatable :: history    ! best function value found after ith iteration

  integer(i4)   :: n, iPar
  logical       :: isgood
  logical       :: parallel

  ! Dimension of test function = number of parameters
  n = 30

  ! Allocation
  allocate(pini(n))
  allocate(prange(n,2))
  allocate(opt(n))
  allocate(mask(n))

  ! Initialization
  pini        =  0.5_dp
  opt         =  pini
  do iPar = 1, n
     prange(iPar,1) = -10.0_dp
     prange(iPar,2) =  10.0_dp
  end do
  mask(:) = .true.
  pini(:) = 0.5_dp
  parallel=.false.

  opt  = sce(ackley,       & ! Mandatory IN: Objective function
       pini,               & ! Mandatory IN: initial guess
       prange,             & ! Mandatory IN: range for each parameter (min, max)
       mymaxn=30000_i8,    & ! Optional  IN: maximal number of function evaluations
       mymaxit=.false.,    & ! Optional  IN: maximize (true) or minimize (false) objective
       mykstop=10_i4,      & ! Optional  IN: number of shuffling loops in which the criterion value must
       !                                     change by given percentage before optimiz. is terminated
       mypcento=0.0001_dp, & ! Optional  IN: percentage by which the criterion value must change in
       !                                     <kstop> number of shuffling loops
       mypeps=0.001_dp,    & ! Optional  IN: optimization is terminated if volume of complex has
       !                                     converged to given percentage of feasible space
       myseed=10987_i8,    & ! Optional  IN: seed of random number generator
       myngs=2_i4,         & ! Optional  IN: number of complexes in the initial population
       mynpg=2*n+1,        & ! Optional  IN: number of points in each complex
       mynps=n+1,          & ! Optional  IN: number of points in a sub-complex
       mynspl=2*n+1,       & ! Optional  IN: number of evolution steps allowed for each complex before
       !                                     complex shuffling
       mymings=2_i4,       & ! Optional  IN: minimum number of complexes required, if the number of
       !                                     complexes is allowed to reduce as the
       !                                     optimization proceeds
       myiniflg=1_i4,      & ! Optional  IN: flag on whether to include the initial point
       !                                     in population (1) or not (0)
       myprint=0_i4,       & ! Optional  IN: flag for controlling print-out
       !                                        0, print information on the best point of the population
       !                                        1, print information on every point of the population
       !                                        2, no printing
       mymask=mask,        & ! OPTIONAL  IN:
       myalpha=0.8_dp,     & ! Optional  IN: parameter for reflection  of points in complex
       mybeta=0.45_dp,     & ! Optional  IN: parameter for contraction of points in complex
       tmp_file='best_objective_make_check_test_file', & ! Optional IN: writes best objective after each evolution loop
       popul_file='population_make_check_test_file',   & ! Optional IN: writes whole population and respective objectives
       !                                !                                  for each evolution loop
       restart_file='restart_make_check_test_file',    & ! Optional IN: restart file name
       parallel=parallel,             & ! Optional IN: if .false. sce will not run in parallel (although compiled with OpenMP)
       !                                               if .true.  sce will run in parallel when compiled with OpenMP and
       !                                                          in single thread when not compiled with OpenMP
       bestf=bestf,        & ! Optional OUT: objective function value of best parameter set
       neval=neval,        & ! Optional OUT: number of function evaluations needed
       history=history     & ! Optional OUT: history(k) = best objective after k function evaluations
       )

  write(*,*) ''
  write(*,*) 'number of function evaluations: neval = ', neval
  write(*,*) 'best function value found:      bestf = ', ackley(opt)
  write(*,*) 'global minimal function value:  optf  = ', 0.0_dp
  write(*,*) ''

  if (parallel) then
     ! compiled without OpenMP
     isgood = .true.
     isgood = isgood .and. (neval .eq. 4455_i4)
     isgood = isgood .and. (nint(bestf*10000000_dp) .eq. 104439)

     ! compiled with OpenMP
     !$ isgood = .true.
     !$ write(*,*) 'mo_sce: It is not possible to check if sce runs properly with OpenMP.'

  else
     ! no matter if compiler with or without OpenMP
     isgood = .true.
     isgood = isgood .and. (neval .eq. 4455_i4)
     isgood = isgood .and. (nint(bestf*10000000_dp) .eq. 104439)
  end if

  if (isgood) then
     write(*,*) 'mo_sce ', color('o.k.', c_green)
  else
     write(*,*) 'mo_sce 1 ', color('failed!', c_red)
  endif

  ! Check restart
  opt = sce(ackley,       & ! Mandatory IN  : Objective function
       pini,               & ! Mandatory IN  : initial guess
       prange,             & ! Mandatory IN  : range for each parameter (min, max)
       restart=.true.,     & ! Do the restart
       restart_file='restart_make_check_test_file', & ! Optional IN: restart file name
       bestf=bestf,        & ! Optional  OUT : objective function value of best parameter set
       neval=neval,        & ! Optional  OUT : number of function evaluations needed
       history=history     & ! Optional  OUT : history(k) = best objective after k function evaluations
       )

  write(*,*) ''
  write(*,*) 'number of function evaluations: neval = ', neval
  write(*,*) 'best function value found:      bestf = ', ackley(opt)
  write(*,*) 'global minimal function value:  optf  = ', 0.0_dp
  write(*,*) ''

  if (parallel) then
     ! compiled without OpenMP
     isgood = .true.
     isgood = isgood .and. (neval .eq. 4455_i4)
     isgood = isgood .and. (nint(bestf*10000000_dp) .eq. 104439)
     ! compiled with OpenMP
     !$ isgood = .true.
     !$ write(*,*) 'mo_sce: It is not possible to check if sce runs properly with OpenMP.'
  else
     ! no matter if compiler with or without OpenMP
     isgood = .true.
     isgood = isgood .and. (neval .eq. 4455_i4)
     isgood = isgood .and. (nint(bestf*10000000_dp) .eq. 104439)
  end if

  if (isgood) then
     write(*,*) 'mo_sce restart ', color('o.k.', c_green)
  else
     write(*,*) 'mo_sce restart ', color('failed!', c_red)
  endif

end program test_sce


        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 = ((n1-1)*bind_length*3)/(2*PI)
                lattice = radis + (radis/2)*2
                total_high = (bind_length/2)*SQRT(3.0)*2
                total_cell = lattice*2
          angle = 360.0/n1

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

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

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

         a1 = radis - 1.3
         b1 = 0

         c1 = radis + 1.3
         d1 = 0

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

         x(1,3) = c1*MyCOS(360.0/(n1*3)) + d1*MySIN(360.0/(n1*3))
         y(1,3) = -c1*MySIN(360.0/(n1*3)) + d1*MyCOS(360.0/(n1*3))

         xatom(1,1,1) = x(1,1)
         yatom(1,1,1) = y(1,1)

         xatom(1,2,1) = x(1,2)
         yatom(1,2,1) = y(1,2)

         xatom(1,3,1) = x(1,3)
         yatom(1,3,1) = y(1,3)

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

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

                xatom(1,3,i) = xatom(1,3,i-1)*MyCOS(angle) &
                               - yatom(1,3,i-1)*MySIN(angle)
                yatom(1,3,i) = xatom(1,3,i-1)*MySIN(angle) &
                               + yatom(1,3,i-1)*MyCOS(angle)

        enddo

         a2 = radis
         b2 = 0

         c2 = radis - 1.3
         d2 = 0

         e2 = radis + 1.3
         f2 = 0

         x(2,1) = a2*MyCOS((360.0/(n1*6))*3) - b2*MySIN((360.0/(n1*6))*3)
         y(2,1) = a2*MySIN((360.0/(n1*6))*3) + b2*MyCOS((360.0/(n1*6))*3)

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

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

         xatom(2,1,1) = x(2,1)
         yatom(2,1,1) = y(2,1)

         xatom(2,2,1) = x(2,2)
         yatom(2,2,1) = y(2,2)

         xatom(2,3,1) = x(2,3)
         yatom(2,3,1) = y(2,3)

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

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

                xatom(2,3,i) = xatom(2,3,i-1)*MyCOS(angle) &
                               - yatom(2,3,i-1)*MySIN(angle)
                yatom(2,3,i) = xatom(2,3,i-1)*MySIN(angle) &
                               + yatom(2,3,i-1)*MyCOS(angle)

        enddo

         do i = 1, n1
        high(1,1,i) = 0
        high(1,2,i) = 0
        high(1,3,i) = 0

        high(2,1,i) = total_high/2
        high(2,2,i) = total_high/2
        high(2,3,i) = total_high/2

         enddo

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

        do i = 1, 2
        do j = 1, 3
        do k = 1, n1

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

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

        enddo
        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*2, 'atom2 =', n1*4

      do j = 1, 3
      do k = 1, n1

         write(24,100) fxatom(1,j,k), fyatom(1,j,k), fhigh(1,j,k)
         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 = (2*(bind_length/2)*SQRT(3.0)*(n1-1))/(2*PI)
                lattice = radis + (radis/2)*3
                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,3), y(2,3), xatom(2,3,n1), yatom(2,3,n1))
         allocate(high(2,3,n1))

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

        a1 = radis - 1.65982445
        b1 = 0

        c1 = radis + 1
        d1 = 0

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

        x(1,3) = c1*MyCOS((360.0/(n1*2))) - d1*MySIN(360.0/(n1*2))
        y(1,3) = c1*MySIN((360.0/(n1*2))) + d1*MyCOS(360.0/(n1*2))

         xatom(1,1,1) = x(1,1)
         yatom(1,1,1) = y(1,1)

         xatom(1,2,1) = x(1,2)
         yatom(1,2,1) = y(1,2)

         xatom(1,3,1) = x(1,3)
         yatom(1,3,1) = y(1,3)

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

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

                xatom(1,3,i) = xatom(1,3,i-1)*MyCOS(angle) &
                               - yatom(1,3,i-1)*MySIN(angle)
                yatom(1,3,i) = xatom(1,3,i-1)*MySIN(angle) &
                               + yatom(1,3,i-1)*MyCOS(angle)

        enddo

        a2 = radis
        b2 = 0

        x(2,2) = radis - 1.65982445
        y(2,2) = 0

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

        x(2,1) = a2*MyCOS((360.0/(n1*2))) - b2*MySIN(360.0/(n1*2))
        y(2,1) = a2*MySIN((360.0/(n1*2))) + b2*MyCOS(360.0/(n1*2))

         xatom(2,1,1) = x(2,1)
         yatom(2,1,1) = y(2,1)

         xatom(2,2,1) = x(2,2)
         yatom(2,2,1) = y(2,2)

         xatom(2,3,1) = x(2,3)
         yatom(2,3,1) = y(2,3)

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

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

                xatom(2,3,i) = xatom(2,3,i-1)*MyCOS(angle) &
                               - yatom(2,3,i-1)*MySIN(angle)
                yatom(2,3,i) = xatom(2,3,i-1)*MySIN(angle) &
                               + yatom(2,3,i-1)*MyCOS(angle)

        enddo

         do i = 1, n1
        high(1,1,i) = bind_length/2
        high(1,2,i) = 0
        high(1,3,i) = (bind_length/2)*2

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

         enddo

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

        do i = 1, 2
        do j = 1, 3
        do k = 1, n1

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

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

        enddo
        enddo
        enddo

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

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

      do j = 1, 3
      do k = 1, n1

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

        endif

        END PROGRAM  main