      SUBROUTINE INITIAL
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!  set up for 2D lattices
!!!!  K.Travis 05/05/12 Univ. of Sheffield
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      USE header_file
      IMPLICIT NONE

      REAL(kind = double), DIMENSION(N) :: ATEMP,BTEMP
      REAL(kind = double) :: VX0,VY0,XLEN,XLEN2,YLEN,YLEN2
      REAL(kind = double) :: RA,RB,RXX,RYY,SPACING
      REAL(kind = double) :: XSUM,YSUM,PSQSUM,TSFAC,T0
      REAL(kind = double) :: FACT,VAR,R1,R2,RANDNUM
      INTEGER             :: IX,IY,I, J, NX, NY,MM,M,IA,IB,INTX,INTY

      NX = NINT(SQRT(DBLE(N)))   ! atoms along each row/column

      IF(LATTICE_TYPE == 1) THEN
        GAMMA = PI/2.0D0
        ALEN = SQRT(DBLE(N)/DENSITY)
        BLEN = ALEN
      ELSE IF (LATTICE_TYPE == 2) THEN
        GAMMA = PI/3.0D0
        SPACING = (1.0d0/SQRT(DENSITY))*SQRT(2.0d0)/(3.0d0**0.25d0)
        ALEN = SPACING*DBLE(NX)
        BLEN = ALEN
      END IF

      INTX = 0
      INTY = 0
      XYZ_FILE_STAT = 'REPLACE'

      CALL CELLVECT
      WRITE(*,*) 'Calculated spacing = ',SPACING
      WRITE(*,*) 'Calculated density = ',N/(EFC(1,1)*EFC(2,2))

      WRITE(*,*) 'Building lattice with NX = ',NX

!! create a regular unit spaced grid using fractional coords along unit cell vectors as basis
      M = 0
      DO IA = 0,NX-1
        DO IB = 0,NX-1
           M = M + 1
           ATEMP(M)  = (DBLE(IA) + 0.5D0)/DBLE(NX)
           BTEMP(M)  = (DBLE(IB) + 0.5D0)/DBLE(NX)
          END DO
        END DO
      WRITE(*,*) 'Successfully constructed a regular grid!'

!!  now need to change them to cartesian coordinates

     DO I = 1,N
       RA = ATEMP(I)
       RB = BTEMP(I)
       CALL FRACCART(RA,RB,RXX,RYY)
       X(I) = RXX
       Y(I) = RYY
     END DO

!!!  assign velocities from a maxwell-boltzmann distribution
      DO I = 1,N
        MASS(I) = 1.0D00   !! assumes unit mass (can easily relax this)
        R1 = RANDNUM(INTX,INTY)
        R2 = RANDNUM(INTX,INTY)
        VAR = TREQ/MASS(I)
        FACT = SQRT(-2.0D0*LOG(R1)*VAR)
        VX0 = FACT*COS(2.0D0*PI*R2)
        VY0 = FACT*SIN(2.0D0*PI*R2)
        PX(I) = MASS(I)*VX0
        PY(I) = MASS(I)*VY0
      END DO

!!!   zero the total linear momentum
      XSUM = 0.0D0
      YSUM = 0.0D0
      DO I = 1,N
        XSUM = XSUM + PX(I)
        YSUM = YSUM + PY(I)
      END DO
      WRITE(*,*) 'X-compt momentum at start = ',XSUM/N
      WRITE(*,*) 'Y-compt momentum at start = ',YSUM/N
      PSQSUM = 0.0d0
      DO I = 1,N
        PX(I) = PX(I) - XSUM/N
        PY(I) = PY(I) - YSUM/N
        PSQSUM = PSQSUM + (PX(I)**2 + PY(I)**2)/MASS(I)
      END DO
      IF(ITHERM == 0) THEN
        DEGFREE = 2.0D0*N - 2.0d0
      ELSE
        DEGFREE = 2.0D0*N - 3.0d0
      END IF
      T0 = PSQSUM/DEGFREE
      WRITE(*,*) 'INitial temperature = ',T0

!!!  rescale the temperature
      TSFAC = SQRT(TREQ/T0)
      DO I = 1,N
        PX(I) = PX(I)*TSFAC
        PY(I) = PY(I)*TSFAC
      END DO

      END SUBROUTINE

      FUNCTION RANDNUM(INTX,INTY)
      IMPLICIT NONE
      INTEGER, PARAMETER :: double = SELECTED_REAL_KIND(15,99)
      INTEGER :: I,J,INTX,INTY
      REAL(kind = double) :: RANDNUM
      I = 1029*INTX + 1731
      J = I + 1029*INTY + 507*INTX - 1731
      INTX = MOD(I,2048)
      J = J + (I - INTX)/2048
      INTY = MOD(J,2048)
      RANDNUM = (INTX + 2048*INTY)/4194304.0D00

      END FUNCTION


SUBROUTINE gcount(n, apply, ifault)

! Code converted using TO_F90 by Alan Miller
! Date: 2003-04-26  Time: 20:20:16

! ALGORITHM AS227  APPL. STATIST. (1987) VOL. 36, NO. 2, pp. 245-9.

! Generates all possible N-bit binary codes, and applies a users
! procedure for each code generated.

! Translated from Algol 60.

IMPLICIT NONE

INTEGER, INTENT(IN)   :: n
INTEGER, INTENT(OUT)  :: ifault

! EXTERNAL apply

INTERFACE
  SUBROUTINE apply(n, change, STATUS)
    IMPLICIT NONE
    INTEGER, INTENT(IN)  :: n, change
    LOGICAL, INTENT(IN)  :: STATUS(n)
  END SUBROUTINE apply
END INTERFACE

! Local variables

INTEGER  :: change, i, tpoint(n)
LOGICAL  :: STATUS(n)

IF (n < 1) THEN
  ifault = 1
  RETURN
END IF
ifault = 0

! Initialize and make first call to user's routine.

DO  i = 1, n
  STATUS(i) = .false.
  tpoint(i) = i + 1
END DO
CALL apply(n, n, STATUS)

! Generate a new code.   The user's routine is called twice each
! cycle; the first time the bit which changes is bit 1.

20 IF (STATUS(1)) THEN
  STATUS(1) = .false.
  change = tpoint(2)
ELSE
  STATUS(1) = .true.
  change = 2
END IF
CALL apply(n, 1, STATUS)

! Check if count exhausted.

IF (change > n) RETURN

IF (STATUS(change)) THEN
  STATUS(change) = .false.
  tpoint(change) = tpoint(change+1)
ELSE
  STATUS(change) = .true.
  tpoint(change) = change + 1
END IF
CALL apply(n, change, STATUS)

GO TO 20
END SUBROUTINE gcount

SUBROUTINE print_comb(n, change, STATUS)
IMPLICIT NONE
INTEGER, INTENT(IN)  :: n, change
LOGICAL, INTENT(IN)  :: STATUS(n)

WRITE(*, '(" ", 4L2)') STATUS
RETURN
END SUBROUTINE print_comb

PROGRAM t_as227
! A simple program to print out the combinations when n = 4.

IMPLICIT NONE

INTEGER  :: n = 4, ifault

INTERFACE
  SUBROUTINE gcount(n, apply, ifault)
    IMPLICIT NONE
    INTEGER, INTENT(IN)   :: n
    INTEGER, INTENT(OUT)  :: ifault
    INTERFACE
      SUBROUTINE apply(n, change, STATUS)
        IMPLICIT NONE
        INTEGER, INTENT(IN)  :: n, change
        LOGICAL, INTENT(IN)  :: STATUS(n)
      END SUBROUTINE apply
    END INTERFACE
  END SUBROUTINE gcount

  SUBROUTINE print_comb(n, change, STATUS)
    IMPLICIT NONE
    INTEGER, INTENT(IN)  :: n, change
    LOGICAL, INTENT(IN)  :: STATUS(n)
  END SUBROUTINE print_comb
END INTERFACE

CALL gcount(n, print_comb, ifault)

STOP
END PROGRAM t_as227


! **********************************************************************************
! *                           INTERPOLATION ROUTINES                               *
! *      --------------------------------------------------------------------      *
! *      Partial list of subroutines:                                              *
! *        Interp,  linterp,  spline,  splint,  dpchim,  dpchfe,  dchfev,  dpchst, *
! *        readinputInterp                                                         *
! **********************************************************************************
subroutine Interp (n, x, y, xpoint, ypoint)
!------------------------------------------------------------------------------------
! Given the pairs (x_1,y_1), (x_2,y_2),..., (x_n,y_n), the routine computes the     !
! value ypoint at xpoint using linear, spline or cubic Hermite interpolation.       !
!                                                                                !
! Input parameters:                                                                 !
! - n (integer)    - number of data points.                                         !
! - x (real array) - set of discrete points (abscissas).                            !
! - y (real array) - function values at discrete points.                            !
! - xpoint (real)  - evaluation point.                                              !
!                                                                                !
! Output parameters:                                                                !
! - ypoint (real) - value of the function at xpoint.                                !
!                                                                                !
! The parameter TypeInterp (specified in the group statement "Interpolation"        !
! from the input file "../INPUTFILES/Input.dat") provides the type of               !
! interpolation method.                                                             !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer   :: n
  real(O)   :: x(n), y(n), xpoint, ypoint
!
  integer       :: i
  real(O)       :: yd1, ydn
  character(20) :: TypeInterp
  logical       :: ascending
  real(O),allocatable :: x1(:), y1(:), yd(:)
!
  call readinputInterp ( TypeInterp )
  allocate (x1(n), y1(n))
  ascending = .true.
  do i = 1, n - 1
    if (x(i) > x(i+1)) then
      ascending = .false.
      exit
    end if
  end do
  do i = 1, n
    if (ascending) then
      x1(i) = x(i)
      y1(i) = y(i)
    else
      x1(i) = x(n-i+1)
      y1(i) = y(n-i+1)
    end if
  end do
  if (xpoint < x1(1) .and. xpoint > x1(n)) then
    print "(/,2x,'Error in subroutine Interp in file Interp.f90:')"
    print "(  2x, a)",                                                               &
   'the interpolation point does not belong to the set of discrete points;'
    stop
  end if
  if (TypeInterp(1:6) == 'LINEAR') then
    call linterp (x1, y1, n, xpoint, ypoint)
  else if (TypeInterp(1:6) == 'SPLINE') then
    allocate (yd(n))
    yd1 = 0._O
    ydn = 0._O
    call spline (x1, y1, n, yd1, ydn, yd)
    call splint (x1, y1, yd, n, xpoint, ypoint)
    deallocate (yd)
  else if (TypeInterp(1:7) == 'HERMITE') then
    allocate ( yd(n))
    call dpchim (n, x1, y1, yd)
    call dpchfe (n, x1, y1, yd, xpoint, ypoint)
    deallocate  (yd)
  end if
  deallocate  (x1, y1)
end subroutine Interp
! ************************************************************************************
subroutine readinputInterp ( TypeInterp )
  use parameters
  implicit none
  integer       :: ios
  character(20) :: TypeInterp
  character(80) :: string
  logical       :: XFindPar
!
  open (unit = iInput, file = FileInput, status = "old", position = "rewind")
  TypeInterp = 'LINEAR'
  string     = 'Interpolation'
  if (XFindPar (iInput, string)) then
    read (iInput, *, iostat = ios) TypeInterp
    if (ios /= 0) then
      print "(/,2x,'Error by reading the input variable TypeInterp;')"
      stop
    end if
  else
    print "(/,2x,'Group name Interpolation not found;')"
    stop
  end if
  call check_Interpolation (TypeInterp)
  close (unit = iInput)
end subroutine readinputInterp
! ************************************************************************************
! *                           LINEAR INTERPOLATION ROUTINE                           *
! ************************************************************************************
subroutine linterp (xa, ya, n, x, y)
  use parameters
  use derived_parameters
  implicit none
  integer  :: n
  real(O)  :: xa(n), ya(n), x, y
!
  integer  :: i,ix
  real(O)  :: xs, xd, csi, dx
  logical  :: found
!
  found = .false.
  do i = 1, n - 1
    xs = xa(i)
    xd = xa(i+1)
    dx = xd - xs
    if (abs(dx) < MachEps) then
      print "(/,2x,'Error in subroutine linterp in file Interp.f90:')"
      print "(  2x,'coincident knots;')"
      stop
    end if
    if (x >= xs .and. x < xd) then
      ix    = i
      csi   = (x - xs) / dx
      found = .true.
      exit
    end if
  end do
  if (found) then
    y = (1._O - csi) * ya(ix) + csi * ya(ix+1)
  else
    y = ya(n)
  end if
end subroutine linterp
! ************************************************************************************
! *         SPLINE INTERPOLATION ROUTINE - F90-VERSION FROM NUMERICAL RECIPES        *
! ************************************************************************************
subroutine spline (x, y, n, yp1, ypn, y2)
!-----------------------------------------------------------------------------------
! The routine computes the derivatives needed to determine a spline interpolant    !
! to given data.                                                                   !
!-----------------------------------------------------------------------------------
  use parameters
  use derived_parameters
  implicit none
  integer  :: n
  real(O)  :: x(n), y(n), yp1, ypn, y2(n)
!
  integer  :: i, k
  real(O)  :: sig, p, qn, un, dy, dx, dyp, dym, dxp, dxm
  real(O),allocatable :: u(:)
!
  allocate (u(n))
  if (yp1 > LargestSplineVal) then
    y2(1) = 0._O
    u (1) = 0._O
  else
    y2(1) = - 0.5_O
    dy    = y(2) - y(1)
    dx    = x(2) - x(1)
    if (abs(dx) < MachEps) then
      print "(/,2x,'Error in subroutine spline in file Interp.f90:')"
      print "(  2x,'coincident knots;')"
      stop
    end if
    u (1) = (3._O / dx ) * (dy / dx - yp1)
  end if
  do i = 2, n - 1
    sig   = (x(i) - x(i-1)) / (x(i+1) - x(i-1))
    p     = sig * y2(i-1) + 2._O
    y2(i) = (sig - 1._O) / p
    dyp   = y(i+1) - y(i)
    dym   = y(i) - y(i-1)
    dxp   = x(i+1) - x(i)
    dxm   = x(i) - x(i-1)
    dx    = x(i+1) - x(i-1)
    if (abs(dxp) < MachEps ) then
      print "(/,2x,'Error in subroutine spline in file Interp.f90:')"
      print "(  2x,'coincident knots;')"
      stop
    end if
    u(i)  = (6._O * (dyp / dxp - dym / dxm) / dx - sig * u(i-1)) / p
  end do
  if (ypn > LargestSplineVal) then
    qn = 0._O
    un = 0._O
  else
    qn = 0.5_O
    dy = y(n) - y(n-1)
    dx = x(n) - x(n-1)
    un = (3._O / dx) * (ypn - dy / dx)
  end if
  y2(n) = (un - qn * u(n-1)) / (qn * y2(n-1) + 1._O)
  do k = n - 1, 1, - 1
    y2(k) = y2(k) * y2(k+1) + u(k)
  end do
  deallocate (u)
end subroutine spline
! ***********************************************************************************
subroutine splint (xa, ya, y2a, n, x, y)
!------------------------------------------------------------------------------------
! The routine evaluates a spline interpolant at a point.                            !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer  :: n
  real(O)  :: xa(n), ya(n), y2a(n), x, y
!
  integer  :: klo, khi, k
  real(O)  :: h, a, b
  logical  :: more
!
  klo = 1
  khi = n
  more = .true.
  do while (more)
    k = (khi + klo) / 2
    if (xa(k) > x) then
      khi = k
    else
      klo = k
    end if
    if (khi - klo <= 1) more = .false.
  end do
  h = xa(khi) - xa(klo)
  a = (xa(khi) - x) / h
  b = (x - xa(klo)) / h
  y = a * ya(klo) + b * ya(khi) + ((a**3 - a) * y2a(klo) +                          &
     (b**3 - b) * y2a(khi)) * (h**2) / 6._O
end subroutine splint
! ************************************************************************************
! *           HERMITE INTERPOLATION ROUTINE - F90-VERSION FROM SLATEC LIBRARY        *
! ************************************************************************************
subroutine dpchim (n, x, f, d)
!-----------------------------------------------------------------------------------
! The routine computes the derivatives needed to determine a monotone piecewise    !
! cubic Hermite interpolant to given data.                                         !
!-----------------------------------------------------------------------------------
  use parameters
  implicit none
  integer  :: n
  real(O)  :: x(n), f(n), d(n)
!
  integer  :: i, nless1
  real(O)  :: del1, del2, dmax, dmin, drat1, drat2, h1, h2, hsum, hsumt3,           &
              w1, w2, dpchst
!
  if (n < 2) then
    print "(/,2x,'Error in subroutine dpchfe in file Interp.f90:')"
    print "(  2x,'number of data points less than two;')"
    stop
  end if
  nless1 = n - 1
  h1     = x(2) - x(1)
  del1   = (f(2) - f(1)) / h1
  if (nless1 > 1) then
    h2    =   x(3) - x(2)
    del2  =   (f(3) - f(2)) / h2
    hsum  =   h1 + h2
    w1    =   (h1 + hsum) / hsum
    w2    = - h1 / hsum
    d(1)  =   w1 * del1 + w2 * del2
    if (dpchst (d(1), del1) <= 0._O)  then
      d(1) = 0._O
    else if (dpchst (del1, del2) < 0._O)  then
      dmax = 3._O * del1
      if (abs(d(1)) > abs(dmax))  d(1) = dmax
    end if
    do i = 2, nless1
      if (i /= 2) then
        h1   = h2
        h2   = x(i+1) - x(i)
        hsum = h1 + h2
        del1 = del2
        del2 = (f(i+1) - f(i)) / h2
      end if
      d(i) = 0._O
      if (dpchst (del1, del2) > 0._O) then
        hsumt3 = hsum + hsum + hsum
        w1     = (hsum + h1) / hsumt3
        w2     = (hsum + h2) / hsumt3
        dmax   = max(abs(del1), abs(del2) )
        dmin   = min(abs(del1), abs(del2) )
        drat1  = del1 / dmax
        drat2  = del2 / dmax
        d(i)   = dmin / (w1 * drat1 + w2 * drat2)
      end if
    end do
    w1   = - h2 / hsum
    w2   =  (h2 + hsum) / hsum
    d(n) = w1 * del1 + w2 * del2
    if (dpchst (d(n), del2) <= 0._O)  then
      d(n) = 0._O
    else if (dpchst (del1, del2) < 0._O)  then
      dmax = 3._O * del2
      if (abs(d(n)) > abs(dmax)) d(n) = dmax
    end if
  else
    d(1) = del1
    d(n) = del1
  end if
end subroutine dpchim
!************************************************************************************
subroutine dpchfe (n, x, f, d, xe, fe)
!------------------------------------------------------------------------------------
! The routine evaluates a cubic polynomial given in Hermite form at a point.        !
!------------------------------------------------------------------------------------
  use parameters
  implicit none
  integer  :: n
  real(O)  :: x(n), f(n), d(n), xe, fe
!
  integer  :: i, ix
  real(O)  :: xs, xd, x1, x2, f1, f2, d1, d2
  logical  :: found
!
  found = .false.
  do i = 1, n - 1
    xs = x(i)
    xd = x(i+1)
    if (xe >= xs .and. xe < xd) then
      ix    = i
      found = .true.
      exit
    end if
  end do
  if (found) then
    x1 = x(ix)
    x2 = x(ix+1)
    f1 = f(ix)
    f2 = f(ix+1)
    d1 = d(ix)
    d2 = d(ix+1)
    call dchfev (x1, x2, f1, f2, d1, d2, xe, fe)
  else
    fe = f(n)
  end if
end subroutine dpchfe
! ***********************************************************************************
subroutine dchfev (x1, x2, f1, f2, d1, d2, xe, fe)
  use parameters
  use derived_parameters
  implicit none
  real(O)  :: x1, x2, f1, f2, d1, d2, xe, fe
!
  real(O)  :: c2, c3, del1, del2, delta, h, x
!
  h =   x2 - x1
  if (abs(h) < MachEps) then
    print "(/,2x,'Error in subroutine dchfev in file Interp.f90:')"
    print "(  2x,'coincident knots;')"
    stop
  end if
  delta   =   (f2 - f1) / h
  del1    =   (d1 - delta) / h
  del2    =   (d2 - delta) / h
  c2      = - (del1 + del1 + del2)
  c3      =   (del1 + del2) / h
  x       =   xe - x1
  fe      =   f1 + x * (d1 + x * (c2 + x * c3))
end subroutine dchfev
! ***********************************************************************************
function dpchst (arg1, arg2) result (func)
  use parameters
  implicit none
  real(O),intent(in) :: arg1, arg2
  real(O)            :: func
!
  func = 0._O
  if ((arg1 /= 0._O) .and. (arg2 /= 0._O)) then
    func = sign(1._O,arg1) * sign(1._O,arg2)
  end if
end function dpchst


module mod_diagnostics

  ! Provides various diagnostic functions.

  use mod_kinds, only: ik, rk

  implicit none

  private
  public :: ke, mean

  interface mean
    module procedure :: mean_1d, mean_2d
  end interface mean

contains

  pure elemental real(rk) function ke(u, v)
    ! Computes the kinetic energy as 1/2 (u^2 + v^2)
    real(rk), intent(in) :: u, v
    ke = 0.5_rk * sqrt(u**2 + v**2)
  end function ke

  pure real(rk) function mean_1d(x) result(mean)
    real(rk), intent(in) :: x(:)
    mean = sum(x) / size(x)
  end function mean_1d

  pure real(rk) function mean_2d(x) result(mean)
    real(rk), intent(in) :: x(:, :)
    mean = sum(x) / size(x)
  end function mean_2d

end module mod_diagnostics


program test_random

    use random_mod

    implicit none

    print*, "-------------------------------------"
    print*, "test_normal_to_cdf_conversion"
    call test_normal_to_cdf_conversion()

    print*, "-------------------------------------"
    print*, "test_box_muller_random(10000)"
    call test_box_muller_random(10000)
    print*, "-------------------------------------"
    print*, "test_box_muller_random(999)"
    call test_box_muller_random(9999)

    print*, "-------------------------------------"
    print*, "test_uniform_to_normal"
    call test_uniform_to_normal()

contains

    subroutine test_uniform_to_normal()

        implicit none
        integer, parameter :: ntest_values = 23

        ! hard coded expected CDF values for given normal value from scipy.stats.norm.cdf
        real :: normal_values(ntest_values) = [-5.50, -5.00, -4.50, -4.00, -3.50, -3.00, -2.50, -2.00, &
                                               -1.50, -1.00, -0.50, 0.000, 0.500,  1.00,  1.50,  2.00, &
                                                2.50,  3.00,  3.50,  4.00,  4.50,  5.00,  5.50]

        real :: cdf_values(ntest_values) = [0.000000019, 0.0000002, 0.0000033, 0.0000316, 0.0002326, &
                                              0.0013498, 0.0062096, 0.0227501, 0.0668072, 0.1586552, &
                                              0.3085375, 0.5000000, 0.6914624, 0.8413447, 0.9331927, &
                                              0.9772498, 0.9937903, 0.9986501, 0.9997673, 0.9999683, &
                                              0.9999966, 0.9999997, 0.9999999810]
        logical :: passing
        integer :: i
        real :: normal

        passing = .True.
        print*, "WARNING: Passing criteria may not be strict enough, errors can be up to 20%"

        ! iterate over all values to test, if expected value is more than 2e-3 away from the actual result it fails
        do i = 1, ntest_values
            normal = get_normal_from_cdf( cdf_values(i) )
            if ((abs(normal_values(i) - normal ) > 1e-2) .and. (abs(normal_values(i) - normal )/abs(normal_values(i)) > 2e-1)) then
                passing = .False.
                print*, ""
                print*, " Error = ",normal_values(i) - normal, (normal_values(i) - normal)/normal_values(i)
                print*, " Expected = ", normal_values(i)
                print*, " Got: ",normal, " for:",cdf_values(i)
            endif
        end do

        if (passing) then
            print*, " PASSED"
        else
            print*, " FAILED"
        endif
    end subroutine test_uniform_to_normal

    subroutine test_normal_to_cdf_conversion()

        implicit none
        integer, parameter :: ntest_values = 23

        ! hard coded expected CDF values for given normal value from scipy.stats.norm.cdf
        real :: normal_values(ntest_values) = [-5.50, -5.00, -4.50, -4.00, -3.50, -3.00, -2.50, -2.00, &
                                               -1.50, -1.00, -0.50, 0.000, 0.500,  1.00,  1.50,  2.00, &
                                                2.50,  3.00,  3.50,  4.00,  4.50,  5.00,  5.50]

        real :: cdf_values(ntest_values) = [0.000000019, 0.0000002, 0.0000033, 0.0000316, 0.0002326, &
                                              0.0013498, 0.0062096, 0.0227501, 0.0668072, 0.1586552, &
                                              0.3085375, 0.5000000, 0.6914624, 0.8413447, 0.9331927, &
                                              0.9772498, 0.9937903, 0.9986501, 0.9997673, 0.9999683, &
                                              0.9999966, 0.9999997, 0.9999999810]
        logical :: passing
        integer :: i

        passing = .True.

        ! iterate over all values to test, if expected value is more than 2e-3 away from the actual result it fails
        do i = 1, ntest_values
            if (abs(cdf_values(i) - normal_cdf( normal_values(i) ) ) > 2e-3) then
                passing = .False.
                print*, ""
                print*, " Error = ",cdf_values(i) - normal_cdf( normal_values(i))
                print*, " Expected = ", cdf_values(i)
                print*, " Got: ",normal_cdf( normal_values(i)), " for:",normal_values(i)
            endif
        end do

        if (passing) then
            print*, " PASSED"
        else
            print*, " FAILED"
        endif
    end subroutine test_normal_to_cdf_conversion

    subroutine test_box_muller_random(n_random_values)
        implicit none

        integer, intent(in) :: n_random_values

        real :: random_values(n_random_values)
        real :: sigma, mean
        integer :: i
        logical :: passing

        passing = .True.

        call box_muller_random(random_values)

        mean = sum(random_values) / size(random_values)
        if (abs(mean) > 1e-2) then
            print*, " Error failed computing mean: ",mean
            passing = .False.
        endif

        sigma = 0
        do i = 1, n_random_values
            sigma = sigma + (random_values(i) - mean)**2
        enddo
        sigma = sqrt(sigma / (n_random_values - 1))
        if (abs(sigma - 1) > 1e-1) then
            print*, " Error failed computing standard deviation: ", sigma
            passing = .False.
        endif

        if (minval(random_values) > (-3)) then
            print*, " Error failed computing minimum value: ", minval(random_values)
            passing = .False.
        endif

        if (maxval(random_values) < (3)) then
            print*, " Error failed computing maximum value: ", maxval(random_values)
            passing = .False.
        endif

        if (passing) then
            print*, " PASSED"
        else
            print*, " FAILED"
        endif
    end subroutine test_box_muller_random

end program test_random


subroutine set_coordinates(delx, dely, xt, yt, nx, ny)
use kind_parameters
implicit none

integer:: nx, ny
real(kind=dp), intent(out), dimension(nx):: xt
real(kind=dp), intent(out), dimension(ny):: yt
real(kind=dp), dimension(nx-1):: delx
real(kind=dp), dimension(ny-1):: dely
integer:: it, jt

! locate the t position in x direction

xt(1) = 0.0

do it = 2,nx

    xt(it) = xt(it-1) + delx(it-1)

end do

! locate the t position in y direction

yt(1) = 0.0

do jt = 2,ny

    yt(jt) = yt(jt-1) + dely(jt-1)

end do

end subroutine set_coordinates


PROGRAM boundaries_test

USE boundaries, only : periodic, InitializeBoundaries, FinalizeBoundaries

IMPLICIT NONE

DOUBLE PRECISION, PARAMETER :: pi = 3.1415926535897932_8 ! underscore indicates rounding to real(8) precision

DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: Q, Qall
DOUBLE PRECISION :: dx, dy, dz, x, y, z
INTEGER :: Nx, Ny, Nz, seed_size, i, j, k, clock
INTEGER, PARAMETER :: N_min = 25, N_max = 256
INTEGER, ALLOCATABLE, DIMENSION(:) :: seed
REAL random_real

CALL RANDOM_SEED(size = seed_size)
ALLOCATE(seed(seed_size))
CALL SYSTEM_CLOCK(count = clock)
seed = clock +  37 * (/ (i - 1, i = 1, seed_size) /)
CALL RANDOM_SEED(put = seed)
DEALLOCATE(seed)

! Create random integer values for Nx, Ny, Nz
CALL RANDOM_NUMBER(random_real)
Nx = N_min + FLOOR( (N_max+1-N_min)*random_real )
CALL RANDOM_NUMBER(random_real)
Ny = N_min + FLOOR( (N_max+1-N_min)*random_real )
CALL RANDOM_NUMBER(random_real)
Nz = N_min + FLOOR( (N_max+1-N_min)*random_real )

dx = 1.0/DBLE(Nx)
dy = 1.0/DBLE(Ny)
dz = 1.0/DBLE(Nz)
ALLOCATE(Q(   -2:Nx+3, -2:Ny+3, -2:Nz+3))
ALLOCATE(Qall(-2:Nx+3, -2:Ny+3, -2:Nz+3))

CALL InitializeBoundaries(Nx, Ny, Nz)

! Initialize Q with -100
Q = DBLE(-100)

! Fill inner values of Q
DO k=1,Nz
    DO j=1,Ny
        DO i=1,Nx

            x = 0.5*dx + DBLE(i - 1)*dx
            y = 0.5*dy + DBLE(j - 1)*dy
            z = 0.5*dz + DBLE(k - 1)*dz

            Q(i,j,k) = SIN(2.0*pi*x)*SIN(2.0*pi*y)*SIN(2.0*pi*z)
        END DO
    END DO
END DO

! Fill Qall, including correctly set halo values
! Fill inner values of Q
DO k=-2,Nz+3
    DO j=-2,Ny+3
        DO i=-2,Nx+3

            x = 0.5*dx + DBLE(i - 1)*dx
            y = 0.5*dy + DBLE(j - 1)*dy
            z = 0.5*dz + DBLE(k - 1)*dz

            Qall(i,j,k) = SIN(2.0*pi*x)*SIN(2.0*pi*y)*SIN(2.0*pi*z)
        END DO
    END DO
END DO

CALL periodic(Q)

IF (MAXVAL(ABS(Q(-2:0,1:Ny,1:Nz) - Qall(-2:0,1:Ny,1:Nz)))>1e-14) THEN
    WRITE(*,*) 'Mismatch between Q and Qall in i-ghostcells with indices -2,-1,0'
    STOP
ELSE IF (MAXVAL(ABS(Q(Nx+1:Nx+3,1:Ny,1:Nz) - Qall(Nx+1:Nx+3,1:Ny,1:Nz)))>1e-14) THEN
    WRITE(*,*) 'Mismatch between Q and Qall in i-ghostcells with indices Nx+1, Nx+2, Nx+3'
    STOP
ELSE IF (MAXVAL(ABS(Q(1:Nx,-2:0,1:Nz) - Qall(1:Nx,-2:0,1:Nz)))>1e-14) THEN
    WRITE(*,*) 'Mismatch between Q and Qall in j-ghostcells with indices -2,-1,0'
    STOP
ELSE IF (MAXVAL(ABS(Q(1:Nx,Ny+1:Ny+3,1:Nz) - Qall(1:Nx,Ny+1:Ny+3,1:Nz)))>1e-14) THEN
    WRITE(*,*) 'Mismatch between Q and Qall in j-ghostcells with indices Ny+1, Ny+2, Ny+3'
    STOP
ELSE IF (MAXVAL(ABS(Q(1:Nx,1:Ny,-2:0)-Qall(1:Nx,1:Ny,-2:0)))>1e-14) THEN
    WRITE(*,*) 'Mismatch between Q and Qall in k-ghostcells with indices -2,-1,0'
    STOP
ELSE IF (MAXVAL(ABS(Q(1:Nx,1:Ny,Nz+1:Nz+3)-Qall(1:Nx,1:Ny,Nz+1:Nz+3)))>1e-14) THEN
    WRITE(*,*) 'Mismatch between Q and Qall in k-ghostcells with indices Nz+1, Nz+2, Nz+3'
    STOP
END IF

IF (MAXVAL(ABS(Q(-2:0,1:Ny,1:Nz) - Q(Nx-2:Nx,1:Ny,1:Nz)))>1e-14) THEN
    WRITE(*,*) 'Mismatch in i-ghostcells with index -2,-1,0 and other side Q values'
    STOP
ELSE IF (MAXVAL(ABS(Q(Nx+1:Nx+3,1:Ny,1:Nz)-Q(1:3,1:Ny,1:Nz)))>1e-14) THEN
    WRITE(*,*) 'Mismatch in i-ghostcells with index Nx+1, Nx+2, Nx+3 and other side Q values'
    STOP
ELSE IF (MAXVAL(ABS(Q(1:Nx,-2:0,1:Nz)-Q(1:Nx,Ny-2:Ny,1:Nz)))>1e-14) THEN
    WRITE(*,*) 'Mismatch in j-ghostcells with index -2,-1,0 and other side Q values'
    STOP
ELSE IF (MAXVAL(ABS(Q(1:Nx,Ny+1:Ny+3,1:Nz)-Q(1:Nx,1:3,1:Nz)))>1e-14) THEN
    WRITE(*,*) 'Mismatch in j-ghostcells with index Nx+1, Nx+2, Nx+3 and other side Q values'
    STOP
ELSE IF (MAXVAL(ABS(Q(1:Nx,1:Ny,-2:0)-Q(1:Nx,1:Ny,Nz-2:Nz)))>1e-14) THEN
    WRITE(*,*) 'Mismatch in k-ghostcells with index -2,-1,0 and other side Q values'
    STOP
ELSE IF (MAXVAL(ABS(Q(1:Nx,1:Ny,Nz+1:Nz+3)-Q(1:Nx,1:Ny,1:3)))>1e-14) THEN
    WRITE(*,*) 'Mismatch in k-ghostcells with index Nx+1, Nx+2, Nx+3 and other side Q values'
    STOP
END IF

DEALLOCATE(Q)
DEALLOCATE(Qall)

PRINT*, '\x1B[32m[0] -- Successful: Ghost cell values generated by boundaries module match directly inserted values.\x1B[0m'

END PROGRAM boundaries_test


! { dg-do  run }
! Check that simplification of maxloc works
program main
  implicit none
  integer :: d
  real, dimension(2), parameter :: a = [1.0, 0.0]
  character(len=3), dimension(3), parameter :: c = [ "fgh", "asd", "jkl" ]
  integer, parameter :: b = maxloc(a,dim=1)
  integer, parameter :: b2 = maxloc(a,dim=1,mask=[.false.,.false.])
  integer, parameter :: b3 = maxloc(c,dim=1)
  integer, parameter :: b4 = maxloc(c,dim=1,mask=[c<"iii"])
  integer, parameter,dimension(2,2) :: i1 = reshape([4,5,3,2],shape(i1))
  integer, parameter, dimension(2) :: b5 = maxloc(i1)
  integer, parameter, dimension(2) :: b6 = maxloc(i1,mask=i1>7)
  integer, parameter, dimension(2) :: b7 = maxloc(i1, mask=i1<5)
  integer, parameter, dimension(2) :: b8 = maxloc(i1, mask=.true.)
  integer, parameter, dimension(2) :: b9 = maxloc(i1, mask=.false.)
  integer, parameter, dimension(2,3) :: i2 = &
       reshape([2, -1, -3, 4, -5, 6], shape(i2))
  integer, parameter, dimension(3) :: b10 = maxloc(i2, dim=1)
  integer, parameter, dimension(2) :: b11 = maxloc(i2, dim=2)
  integer, parameter, dimension(3) :: b12 = maxloc(i2,dim=1,mask=i2<0)
  integer, parameter, dimension(2) :: b13 = maxloc(i2,dim=2, mask=i2<-10)
  if (b /= 1) STOP 1
  if (b2 /= 0) STOP 2
  if (b3 /= 3) STOP 3
  if (b4 /= 1) STOP 4
  if (any(b5 /= [2,1])) STOP 5
  if (any(b6 /= [0, 0])) STOP 6
  if (any(b7 /= [1,1])) STOP 7
  if (any(b8 /= b5)) STOP 8
  if (any(b9 /= [0, 0])) STOP 9
  d = 1
  if (any(b10 /= maxloc(i2,dim=d))) STOP 10
  d = 2
  if (any(b11 /= maxloc(i2,dim=2))) STOP 11
  d = 1
  if (any(b12 /= maxloc(i2, dim=d,mask=i2<0))) STOP 12
  if (any(b13 /= 0)) STOP 13
end program main


      SUBROUTINE cntab2(nn,ni,nj,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy)
      INTEGER ni,nj,nn(ni,nj),MAXI,MAXJ
      REAL h,hx,hxgy,hy,hygx,uxgy,uxy,uygx,TINY
      PARAMETER (MAXI=100,MAXJ=100,TINY=1.e-30)
      INTEGER i,j
      REAL p,sum,sumi(MAXI),sumj(MAXJ)
      sum=0
      do 12 i=1,ni
        sumi(i)=0.0
        do 11 j=1,nj
          sumi(i)=sumi(i)+nn(i,j)
          sum=sum+nn(i,j)
11      continue
12    continue
      do 14 j=1,nj
        sumj(j)=0.
        do 13 i=1,ni
          sumj(j)=sumj(j)+nn(i,j)
13      continue
14    continue
      hx=0.
      do 15 i=1,ni
        if(sumi(i).ne.0.)then
          p=sumi(i)/sum
          hx=hx-p*log(p)
        endif
15    continue
      hy=0.
      do 16 j=1,nj
        if(sumj(j).ne.0.)then
          p=sumj(j)/sum
          hy=hy-p*log(p)
        endif
16    continue
      h=0.
      do 18 i=1,ni
        do 17 j=1,nj
          if(nn(i,j).ne.0)then
            p=nn(i,j)/sum
            h=h-p*log(p)
          endif
17      continue
18    continue
      hygx=h-hx
      hxgy=h-hy
      uygx=(hy-hygx)/(hy+TINY)
      uxgy=(hx-hxgy)/(hx+TINY)
      uxy=2.*(hx+hy-h)/(hx+hy+TINY)
      return
      END

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


!		This program uses the modified Cholesky decomposition
!		in lu to solve the equation lusolve = b.
function solve(lu,b)
implicit none

real(kind=8),intent(in)::lu(:,:)
real(kind=8),intent(in)::b(:)
real(kind=8)::solve(size(b))
integer:: row,col,n
n=size(b)
!	 Lower triangle.
solve(1) = b(1)
if(lu(1,1)<=0.0_8) solve(1) = 0.0_8
if(n>1)then
	do row=2,n
		if(lu(row,row)<=0.0_8) then
			solve(row)=0.0_8
		else
			solve(row)=b(row)-dot_product(lu(row,1:row-1),solve(1:row-1))
	 	end if
	 end do
!	 Upper triangle.
end if
if(lu(n,n)>0.0_8)then
 	solve(n) = solve(n)/lu(n,n)
else
 	solve(n) = 0.0_8
end if
if(n==1) return
do col=n,2,-1
	row=col-1
 	if(lu(row,row)<=0.0_8)then
 		solve(row) = 0.0_8
 	else
  		solve(row) = (solve(row)-dot_product(lu(row,col:n),solve(col:n)))/lu(row,row)
 	end if
end do
return
end function solve


use ArrayClass
use IOClass
implicit none

real(real64),allocatable :: t(:),Ft(:)
real(real64) :: tau
type(IO_) :: f

tau = 100.0d0
t = linspace([0.0d0,2.0d0*tau],10000)
Ft = t

! accel.
Ft(1   :5000) = 1.0d0
Ft(5001:6000)  = -10.0d0
Ft(6001:7000)  = 1.0d0
Ft(7001:8000)  = -3.0d0
Ft(8001:9000)  = 10.0d0
Ft(9001:10000) = -1.0d0

call f%plot(t,Ft)
! velocity
call f%plot(t, I_dx(t,Ft) )
! displacement
call f%plot(t, I_dx(t,I_dx(t,Ft)) )

end


                IMPLICIT NONE
                REAL::x,vel,F,m,H
                INTEGER::ixx
                INTEGER,PARAMETER::itime = 10000
		REAL,PARAMETER::xposeq = 0.0, val=1.000,delta=0.02

		x = 0.00
		vel  = 1
                F= -val*(x-xposeq)
                m=1.00
                ixx=0

                !write(16,*) ixx*delta,x
                !write(18,*) ixx*delta,vel
                H = 0.5 *(vel**2) + 0.5 * val *(x**2)
                !write(20,*) x,vel
                write(28,*) ixx*delta,H

		do ixx = 1, itime

		vel = vel + (0.5*(F/m)*delta)
                x=x + (vel*delta)
                F = -val*(x-xposeq)
                vel = vel + (0.5*(F/m)*delta)

		!write(16,*) ixx*delta,x
                !write(18,*) ixx*delta,vel
                H = 0.5 *(vel**2) + 0.5 * val *(x**2)
                !write(20,*) x,vel
                write(28,*) ixx*delta,H

		end do

		stop
		end


C SUBROUTINE MATINV.F
C
C SOURCE
C   BEVINGTON, PAGES 302-303.
C
C PURPOSE
C   INVERT A SYMMETRIC MATRIX AND CALCULATE ITS DETERMINANT
C
C USAGE
C   CALL MATINV (ARRAY, NORDER, DET)
C
C DESCRIPTION OF PARAMETERS
C   ARRAY  - INPUT MATRIX WHICH IS REPLACED BY ITS INVERSE
C   NORDER - DEGREE OF MATRIX (ORDER OF DETERMINANT)
C   DET    - DETERMINANT OF INPUT MATRIX
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C   NONE
C
C COMMENT
C   DIMENSION STATEMENT VALID FOR NORDER UP TO 10
C
	SUBROUTINE MATINV (ARRAY,NORDER,DET)
	DOUBLE PRECISION ARRAY,AMAX,SAVE
	DIMENSION ARRAY(10,10),IK(10),JK(10)
C
10	DET=1.
11	DO 100 K=1,NORDER
C
C FIND LARGEST ELEMENT ARRAY(I,J) IN REST OF MATRIX
C
	AMAX=0.
21	DO 30 I=K,NORDER
	DO 30 J=K,NORDER
23	IF (DABS(AMAX)-DABS(ARRAY(I,J))) 24,24,30
24	AMAX=ARRAY(I,J)
	IK(K)=I
	JK(K)=J
30	CONTINUE
C
C INTERCHANGE ROWS AND COLUMNS TO PUT AMAX IN ARRAY(K,K)
C
31	IF (AMAX) 41,32,41
32	DET=0.
	GOTO 140
41	I=IK(K)
	IF (I-K) 21,51,43
43	DO 50 J=1,NORDER
	SAVE=ARRAY(K,J)
	ARRAY(K,J)=ARRAY(I,J)
50	ARRAY(I,J)=-SAVE
51	J=JK(K)
	IF (J-K) 21,61,53
53	DO 60 I=1,NORDER
	SAVE=ARRAY(I,K)
	ARRAY(I,K)=ARRAY(I,J)
60	ARRAY(I,J)=-SAVE
C
C ACCUMULATE ELEMENTS OF INVERSE MATRIX
C
61	DO 70 I=1,NORDER
	IF (I-K) 63,70,63
63	ARRAY(I,K)=-ARRAY(I,K)/AMAX
70	CONTINUE
71	DO 80 I=1,NORDER
	DO 80 J=1,NORDER
	IF (I-K) 74,80,74
74	IF (J-K) 75,80,75
75	ARRAY(I,J)=ARRAY(I,J)+ARRAY(I,K)*ARRAY(K,J)
80	CONTINUE
81	DO 90 J=1,NORDER
	IF (J-K) 83,90,83
83	ARRAY(K,J)=ARRAY(K,J)/AMAX
90	CONTINUE
	ARRAY(K,K)=1./AMAX
100	DET=DET*AMAX
C
C RESTORE ORDERING OF MATRIX
C
101	DO 130 L=1,NORDER
	K=NORDER-L+1
	J=IK(K)
	IF (J-K) 111,111,105
105	DO 110 I=1,NORDER
	SAVE=ARRAY(I,K)
	ARRAY(I,K)=-ARRAY(I,J)
110	ARRAY(I,J)=SAVE
111	I=JK(K)
	IF (I-K) 130,130,113
113	DO 120 J=1,NORDER
	SAVE=ARRAY(K,J)
	ARRAY(K,J)=-ARRAY(I,J)
120	ARRAY(I,J)=SAVE
130	CONTINUE
140	RETURN
	END


program main
    use plantFEM
    implicit none

    real(real64),parameter :: duration=10.0d0
    integer(int32),parameter :: sampling = 4096
    type(Random_) :: random
    type(IO_) :: f,z
    type(Math_) :: Math
    integer(int32) :: i
    complex(complex64 ),allocatable :: wave(:),spectre(:)
    real(real64),allocatable :: omega(:), t(:)
    real(real64) :: dt,set_omega

    set_omega = (20.0d0/2.0d0/math%PI) ! 15.92356687898089

    print *, set_omega
    create_input_wave: block
        t    = linspace([0.0d0, duration], sampling)
        dt   = duration/dble(sampling)
        wave = zeros(4096)
        do i=1, size(wave)
            wave(i) = random%gauss(mu=0.0d0, sigma=1.0d0)
            wave(i) = sin( set_omega*t(i) )!+sin( 3.0d0*dt*dble(i) )!+random%gauss(mu=0.0d0, sigma=1.0d0)
        enddo
    end block create_input_wave

    show_input_wave: block
        call f%open("input_wave.txt")
        call f%write( t,real(wave) )
        call f%close()
        call f%plot(option="with lines")
    end block show_input_wave

    run_FFT: block
        omega   = linspace([0.0d0, dble(sampling)/duration*2.0d0*math%PI ], sampling)
        spectre = zeros(sampling)
        spectre =  FFT(wave)
        call z%open("spectre.txt")
        do i=1,size(spectre)/2
            call z%write(omega(i),abs( spectre(i)))
        enddo
        call z%close()
        call z%plot(option="with lines",logscale=true)
    end block run_FFT

end program main


        program Day9
            implicit none

c           locals
            double precision values(1024)
            double precision valid,sum,value
            double precision validate,weakness

            integer i,j,io,count,preamble

c           read input file
            count = 0
            open(1,FILE='input.txt',STATUS='OLD')
            do
                read(1,*,IOSTAT=io) value
                if (io.gt.0) then
                    write(*,*) 'Error'
                exit
            else if(io.lt.0) then
                exit
            else
                count = count+1
                values(count) = value
                endif
            enddo
            close(1)

c           preamble for `input.txt`
            preamble = 25

c           preamble for `test.txt`
c           preamble = 5

c           iterate over the values
            do i=preamble+1,count

c               check invalid
                valid = validate(values,values(i),i-preamble, i-1)
                if (valid.eq.0) then
                    write(*,*) 'Part 1'
                    write(*,*) 'Invalid: ',values(i)

                    write(*,*) 'Part 2'
                    sum = weakness(values,count,values(i))
                    write(*,*) 'Weakness: ',sum
                endif
            enddo
        end

c       validates the value by finding a matching sum in the
c       preamble values
        double precision function validate(values,value,sindex,eindex)
            implicit none

            double precision values(*),value,sum
            integer sindex,eindex,i,j

            validate = 0
            do i=sindex,eindex-1
                do j=i+1,eindex
                    sum=values(i) + values(j)
c                    write(*,*) i,j,values(i),values(j),sum
                    if(sum.eq.value) then
                        validate = 1
                        goto 200
                    endif
                enddo
            enddo
 200        continue
c           write(*,*) ''
            return
        end

c       finds the encryption weakness by returning the sum
c       of the minimum and maximum values in the preamble values
        double precision function weakness(values,count,value)
            implicit none

            double precision values(*),value,sum
            double precision minimum,maximum
            integer count,i,j

c           iterate over values
            weakness = -1
            do i=1,count-1
c               initial minimum, maximum, and sum
                minimum = values(i)
                maximum = values(j)
                sum = values(i)

c               build continguous range
                do j=i+1,count

c                   update minimum
                    if(values(j).lt.minimum) then
                        minimum = values(j)
                    endif

c                   update maximum
                    if(values(j).gt.maximum) then
                        maximum = values(j)
                    endif

c                   update sum
                    sum = sum+values(j)

c                   check sum
                    if(sum.eq.value) then
                        weakness = minimum + maximum
                        goto 300
                    else if(sum.gt.value) then
                        goto 325
                    endif
                enddo
 325            continue
            enddo
 300        continue
            return
        end


*DECK DBSKES
      SUBROUTINE DBSKES (XNU, X, NIN, BKE)
C***BEGIN PROLOGUE  DBSKES
C***PURPOSE  Compute a sequence of exponentially scaled modified Bessel
C            functions of the third kind of fractional order.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C10B3
C***TYPE      DOUBLE PRECISION (BESKES-S, DBSKES-D)
C***KEYWORDS  EXPONENTIALLY SCALED, FNLIB, FRACTIONAL ORDER,
C             MODIFIED BESSEL FUNCTION, SEQUENCE OF BESSEL FUNCTIONS,
C             SPECIAL FUNCTIONS, THIRD KIND
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DBSKES(XNU,X,NIN,BKE) computes a double precision sequence
C of exponentially scaled modified Bessel functions
C of the third kind of order XNU + I at X, where X .GT. 0,
C XNU lies in (-1,1), and I = 0, 1, ... , NIN - 1, if NIN is positive
C and I = 0, -1, ... , NIN + 1, if NIN is negative.  On return, the
C vector BKE(.) contains the results at X for order starting at XNU.
C XNU, X, and BKE are double precision.  NIN is integer.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  D1MACH, D9KNUS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890911  Removed unnecessary intrinsics.  (WRB)
C   890911  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C***END PROLOGUE  DBSKES
      DOUBLE PRECISION XNU, X, BKE(*), BKNU1, V, VINCR, VEND, ALNBIG,
     1  D1MACH, DIRECT
      SAVE ALNBIG
      DATA ALNBIG / 0.D0 /
C***FIRST EXECUTABLE STATEMENT  DBSKES
      IF (ALNBIG.EQ.0.D0) ALNBIG = LOG (D1MACH(2))
C
      V = ABS(XNU)
      N = ABS(NIN)
C
      IF (V .GE. 1.D0) CALL XERMSG ('SLATEC', 'DBSKES',
     +   'ABS(XNU) MUST BE LT 1', 2, 2)
      IF (X .LE. 0.D0) CALL XERMSG ('SLATEC', 'DBSKES', 'X IS LE 0', 3,
     +   2)
      IF (N .EQ. 0) CALL XERMSG ('SLATEC', 'DBSKES',
     +   'N THE NUMBER IN THE SEQUENCE IS 0', 4, 2)
C
      CALL D9KNUS (V, X, BKE(1), BKNU1, ISWTCH)
      IF (N.EQ.1) RETURN
C
      VINCR = SIGN (1.0, REAL(NIN))
      DIRECT = VINCR
      IF (XNU.NE.0.D0) DIRECT = VINCR*SIGN(1.D0, XNU)
      IF (ISWTCH .EQ. 1 .AND. DIRECT .GT. 0.) CALL XERMSG ('SLATEC',
     +   'DBSKES', 'X SO SMALL BESSEL K-SUB-XNU+1 OVERFLOWS', 5, 2)
      BKE(2) = BKNU1
C
      IF (DIRECT.LT.0.) CALL D9KNUS (ABS(XNU+VINCR), X, BKE(2), BKNU1,
     1  ISWTCH)
      IF (N.EQ.2) RETURN
C
      VEND = ABS (XNU+NIN) - 1.0D0
      IF ((VEND-.5D0)*LOG(VEND)+0.27D0-VEND*(LOG(X)-.694D0) .GT.
     +   ALNBIG) CALL XERMSG ('SLATEC', 'DBSKES',
     +      'X SO SMALL OR ABS(NU) SO BIG THAT BESSEL K-SUB-NU ' //
     +      'OVERFLOWS', 5, 2)
C
      V = XNU
      DO 10 I=3,N
        V = V + VINCR
        BKE(I) = 2.0D0*V*BKE(I-1)/X + BKE(I-2)
 10   CONTINUE
C
      RETURN
      END


*> \brief \b ZPFTRF
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ZPFTRF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE ZPFTRF( TRANSR, UPLO, N, A, INFO )
*
*       .. Scalar Arguments ..
*       CHARACTER          TRANSR, UPLO
*       INTEGER            N, INFO
*       ..
*       .. Array Arguments ..
*       COMPLEX*16         A( 0: * )
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> ZPFTRF computes the Cholesky factorization of a complex Hermitian
*> positive definite matrix A.
*>
*> The factorization has the form
*>    A = U**H * U,  if UPLO = 'U', or
*>    A = L  * L**H,  if UPLO = 'L',
*> where U is an upper triangular matrix and L is lower triangular.
*>
*> This is the block version of the algorithm, calling Level 3 BLAS.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] TRANSR
*> \verbatim
*>          TRANSR is CHARACTER*1
*>          = 'N':  The Normal TRANSR of RFP A is stored;
*>          = 'C':  The Conjugate-transpose TRANSR of RFP A is stored.
*> \endverbatim
*>
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          = 'U':  Upper triangle of RFP A is stored;
*>          = 'L':  Lower triangle of RFP A is stored.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX*16 array, dimension ( N*(N+1)/2 );
*>          On entry, the Hermitian matrix A in RFP format. RFP format is
*>          described by TRANSR, UPLO, and N as follows: If TRANSR = 'N'
*>          then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is
*>          (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'C' then RFP is
*>          the Conjugate-transpose of RFP A as defined when
*>          TRANSR = 'N'. The contents of RFP A are defined by UPLO as
*>          follows: If UPLO = 'U' the RFP A contains the nt elements of
*>          upper packed A. If UPLO = 'L' the RFP A contains the elements
*>          of lower packed A. The LDA of RFP A is (N+1)/2 when TRANSR =
*>          'C'. When TRANSR is 'N' the LDA is N+1 when N is even and N
*>          is odd. See the Note below for more details.
*>
*>          On exit, if INFO = 0, the factor U or L from the Cholesky
*>          factorization RFP A = U**H*U or RFP A = L*L**H.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0:  successful exit
*>          < 0:  if INFO = -i, the i-th argument had an illegal value
*>          > 0:  if INFO = i, the leading minor of order i is not
*>                positive definite, and the factorization could not be
*>                completed.
*>
*>  Further Notes on RFP Format:
*>  ============================
*>
*>  We first consider Standard Packed Format when N is even.
*>  We give an example where N = 6.
*>
*>     AP is Upper             AP is Lower
*>
*>   00 01 02 03 04 05       00
*>      11 12 13 14 15       10 11
*>         22 23 24 25       20 21 22
*>            33 34 35       30 31 32 33
*>               44 45       40 41 42 43 44
*>                  55       50 51 52 53 54 55
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
*>  conjugate-transpose of the first three columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
*>  conjugate-transpose of the last three columns of AP lower.
*>  To denote conjugate we place -- above the element. This covers the
*>  case N even and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>                                -- -- --
*>        03 04 05                33 43 53
*>                                   -- --
*>        13 14 15                00 44 54
*>                                      --
*>        23 24 25                10 11 55
*>
*>        33 34 35                20 21 22
*>        --
*>        00 44 45                30 31 32
*>        -- --
*>        01 11 55                40 41 42
*>        -- -- --
*>        02 12 22                50 51 52
*>
*>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
*>  transpose of RFP A above. One therefore gets:
*>
*>           RFP A                   RFP A
*>
*>     -- -- -- --                -- -- -- -- -- --
*>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
*>     -- -- -- -- --                -- -- -- -- --
*>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
*>     -- -- -- -- -- --                -- -- -- --
*>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
*>
*>  We next  consider Standard Packed Format when N is odd.
*>  We give an example where N = 5.
*>
*>     AP is Upper                 AP is Lower
*>
*>   00 01 02 03 04              00
*>      11 12 13 14              10 11
*>         22 23 24              20 21 22
*>            33 34              30 31 32 33
*>               44              40 41 42 43 44
*>
*>  Let TRANSR = 'N'. RFP holds AP as follows:
*>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
*>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
*>  conjugate-transpose of the first two   columns of AP upper.
*>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
*>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
*>  conjugate-transpose of the last two   columns of AP lower.
*>  To denote conjugate we place -- above the element. This covers the
*>  case N odd  and TRANSR = 'N'.
*>
*>         RFP A                   RFP A
*>
*>                                   -- --
*>        02 03 04                00 33 43
*>                                      --
*>        12 13 14                10 11 44
*>
*>        22 23 24                20 21 22
*>        --
*>        00 33 34                30 31 32
*>        -- --
*>        01 11 44                40 41 42
*>
*>  Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate-
*>  transpose of RFP A above. One therefore gets:
*>
*>           RFP A                   RFP A
*>
*>     -- -- --                   -- -- -- -- -- --
*>     02 12 22 00 01             00 10 20 30 40 50
*>     -- -- -- --                   -- -- -- -- --
*>     03 13 23 33 11             33 11 21 31 41 51
*>     -- -- -- -- --                   -- -- -- --
*>     04 14 24 34 44             43 44 22 32 42 52
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complex16OTHERcomputational
*
*  =====================================================================
      SUBROUTINE ZPFTRF( TRANSR, UPLO, N, A, INFO )
*
*  -- LAPACK computational routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          TRANSR, UPLO
      INTEGER            N, INFO
*     ..
*     .. Array Arguments ..
      COMPLEX*16         A( 0: * )
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE
      COMPLEX*16         CONE
      PARAMETER          ( ONE = 1.0D+0, CONE = ( 1.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            LOWER, NISODD, NORMALTRANSR
      INTEGER            N1, N2, K
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA, ZHERK, ZPOTRF, ZTRSM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MOD
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NORMALTRANSR = LSAME( TRANSR, 'N' )
      LOWER = LSAME( UPLO, 'L' )
      IF( .NOT.NORMALTRANSR .AND. .NOT.LSAME( TRANSR, 'C' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LOWER .AND. .NOT.LSAME( UPLO, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZPFTRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     If N is odd, set NISODD = .TRUE.
*     If N is even, set K = N/2 and NISODD = .FALSE.
*
      IF( MOD( N, 2 ).EQ.0 ) THEN
         K = N / 2
         NISODD = .FALSE.
      ELSE
         NISODD = .TRUE.
      END IF
*
*     Set N1 and N2 depending on LOWER
*
      IF( LOWER ) THEN
         N2 = N / 2
         N1 = N - N2
      ELSE
         N1 = N / 2
         N2 = N - N1
      END IF
*
*     start execution: there are eight cases
*
      IF( NISODD ) THEN
*
*        N is odd
*
         IF( NORMALTRANSR ) THEN
*
*           N is odd and TRANSR = 'N'
*
            IF( LOWER ) THEN
*
*             SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) )
*             T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0)
*             T1 -> a(0), T2 -> a(n), S -> a(n1)
*
               CALL ZPOTRF( 'L', N1, A( 0 ), N, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               CALL ZTRSM( 'R', 'L', 'C', 'N', N2, N1, CONE, A( 0 ), N,
     $                     A( N1 ), N )
               CALL ZHERK( 'U', 'N', N2, N1, -ONE, A( N1 ), N, ONE,
     $                     A( N ), N )
               CALL ZPOTRF( 'U', N2, A( N ), N, INFO )
               IF( INFO.GT.0 )
     $            INFO = INFO + N1
*
            ELSE
*
*             SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1)
*             T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0)
*             T1 -> a(n2), T2 -> a(n1), S -> a(0)
*
               CALL ZPOTRF( 'L', N1, A( N2 ), N, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               CALL ZTRSM( 'L', 'L', 'N', 'N', N1, N2, CONE, A( N2 ), N,
     $                     A( 0 ), N )
               CALL ZHERK( 'U', 'C', N2, N1, -ONE, A( 0 ), N, ONE,
     $                     A( N1 ), N )
               CALL ZPOTRF( 'U', N2, A( N1 ), N, INFO )
               IF( INFO.GT.0 )
     $            INFO = INFO + N1
*
            END IF
*
         ELSE
*
*           N is odd and TRANSR = 'C'
*
            IF( LOWER ) THEN
*
*              SRPA for LOWER, TRANSPOSE and N is odd
*              T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1)
*              T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1
*
               CALL ZPOTRF( 'U', N1, A( 0 ), N1, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               CALL ZTRSM( 'L', 'U', 'C', 'N', N1, N2, CONE, A( 0 ), N1,
     $                     A( N1*N1 ), N1 )
               CALL ZHERK( 'L', 'C', N2, N1, -ONE, A( N1*N1 ), N1, ONE,
     $                     A( 1 ), N1 )
               CALL ZPOTRF( 'L', N2, A( 1 ), N1, INFO )
               IF( INFO.GT.0 )
     $            INFO = INFO + N1
*
            ELSE
*
*              SRPA for UPPER, TRANSPOSE and N is odd
*              T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0)
*              T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2
*
               CALL ZPOTRF( 'U', N1, A( N2*N2 ), N2, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               CALL ZTRSM( 'R', 'U', 'N', 'N', N2, N1, CONE, A( N2*N2 ),
     $                     N2, A( 0 ), N2 )
               CALL ZHERK( 'L', 'N', N2, N1, -ONE, A( 0 ), N2, ONE,
     $                     A( N1*N2 ), N2 )
               CALL ZPOTRF( 'L', N2, A( N1*N2 ), N2, INFO )
               IF( INFO.GT.0 )
     $            INFO = INFO + N1
*
            END IF
*
         END IF
*
      ELSE
*
*        N is even
*
         IF( NORMALTRANSR ) THEN
*
*           N is even and TRANSR = 'N'
*
            IF( LOWER ) THEN
*
*              SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) )
*              T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0)
*              T1 -> a(1), T2 -> a(0), S -> a(k+1)
*
               CALL ZPOTRF( 'L', K, A( 1 ), N+1, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               CALL ZTRSM( 'R', 'L', 'C', 'N', K, K, CONE, A( 1 ), N+1,
     $                     A( K+1 ), N+1 )
               CALL ZHERK( 'U', 'N', K, K, -ONE, A( K+1 ), N+1, ONE,
     $                     A( 0 ), N+1 )
               CALL ZPOTRF( 'U', K, A( 0 ), N+1, INFO )
               IF( INFO.GT.0 )
     $            INFO = INFO + K
*
            ELSE
*
*              SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) )
*              T1 -> a(k+1,0) ,  T2 -> a(k,0),   S -> a(0,0)
*              T1 -> a(k+1), T2 -> a(k), S -> a(0)
*
               CALL ZPOTRF( 'L', K, A( K+1 ), N+1, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               CALL ZTRSM( 'L', 'L', 'N', 'N', K, K, CONE, A( K+1 ),
     $                     N+1, A( 0 ), N+1 )
               CALL ZHERK( 'U', 'C', K, K, -ONE, A( 0 ), N+1, ONE,
     $                     A( K ), N+1 )
               CALL ZPOTRF( 'U', K, A( K ), N+1, INFO )
               IF( INFO.GT.0 )
     $            INFO = INFO + K
*
            END IF
*
         ELSE
*
*           N is even and TRANSR = 'C'
*
            IF( LOWER ) THEN
*
*              SRPA for LOWER, TRANSPOSE and N is even (see paper)
*              T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1)
*              T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k
*
               CALL ZPOTRF( 'U', K, A( 0+K ), K, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               CALL ZTRSM( 'L', 'U', 'C', 'N', K, K, CONE, A( K ), N1,
     $                     A( K*( K+1 ) ), K )
               CALL ZHERK( 'L', 'C', K, K, -ONE, A( K*( K+1 ) ), K, ONE,
     $                     A( 0 ), K )
               CALL ZPOTRF( 'L', K, A( 0 ), K, INFO )
               IF( INFO.GT.0 )
     $            INFO = INFO + K
*
            ELSE
*
*              SRPA for UPPER, TRANSPOSE and N is even (see paper)
*              T1 -> B(0,k+1),     T2 -> B(0,k),   S -> B(0,0)
*              T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k
*
               CALL ZPOTRF( 'U', K, A( K*( K+1 ) ), K, INFO )
               IF( INFO.GT.0 )
     $            RETURN
               CALL ZTRSM( 'R', 'U', 'N', 'N', K, K, CONE,
     $                     A( K*( K+1 ) ), K, A( 0 ), K )
               CALL ZHERK( 'L', 'N', K, K, -ONE, A( 0 ), K, ONE,
     $                     A( K*K ), K )
               CALL ZPOTRF( 'L', K, A( K*K ), K, INFO )
               IF( INFO.GT.0 )
     $            INFO = INFO + K
*
            END IF
*
         END IF
*
      END IF
*
      RETURN
*
*     End of ZPFTRF
*
      END


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file testsshifte.f contains a test program illustrating the
c     use of subroutine sshifte (see documentation for sshifte)
c
c ... required files off spherepack3.0
c
c     hrfft.f, sshifte.f
c
c     The "offset" scalar field goff is set equal to exp(x+y+z) where
c     x,y,z are the cartesian coordinates restricted to the surface
c     of the unit sphere.  This is transferred to the "regular" grid
c     in greg.  greg is then compared with exp(x+y+z) on the regular grid.
c     Finally greg is transferred back to goff which is again compared
c     with exp(x+y+z).  The least squares error after each transformation
c     with sshifte is computed and printed.  Output from running the
c     program below on a 2.5 degree equally spaced regular and offset
c     grid is listed below.
c
c *** OUTPUT (from execution on 32 bit machine)
c
c           sshifte arguments
c           ioff =  0 nlon = 144 nlat =  72
c           lsave =   608 lwork = 21024
c           ier =  0
c           least squares error =  0.500E-06
c           sshifte arguments
c           ioff =  1 nlon = 144 nlat =  72
c           lsave =   608 lwork = 21024
c           ier =  0
c           least squares error =  0.666E-06
c
c *** END OF OUTPUT
c
      program testsshifte
      implicit none
      integer nnlon,nnlat,nnlatp1,nnlat2,llsave,llwork
      parameter(nnlon=144,nnlat=72)
      parameter (nnlatp1 = nnlat+1, nnlat2 = nnlat+nnlat)
      parameter (llsave=2*(2*nnlat+nnlon)+32)
c     for nnlon even
      parameter (llwork = 2*(nnlat+1)*nnlon)
c     for nnlon odd
c     parameter (llwork = nnlon*(5*nnlat+1))
      integer ioff,nlon,nlat,nlat2,j,i,lsave,lwork,ier
      real pi,dlat,dlon,dlat2,dlon2,lat,long,x,y,z,gexact,err2
      real goff(nnlon,nnlat),greg(nnlon,nnlatp1)
      real wsave(llsave),work(llwork)
c
c     set resolution, work space lengths, and grid increments
c
      nlat = nnlat
      nlon = nnlon
      lsave = llsave
      nlat2 = nnlat2
      lwork = llwork
      pi = 4.0*atan(1.0)
      dlat = pi/nlat
      dlon = (pi+pi)/nlon
      dlat2 = 0.5*dlat
      dlon2 = 0.5*dlon
c
c     set offset grid values in goff
c
      do j=1,nlon
	long = dlon2+(j-1)*dlon
	do i=1,nlat
	  lat = -0.5*pi + dlat2+(i-1)*dlat
	  x = cos(lat)*cos(long)
	  y = cos(lat)*sin(long)
	  z = sin(lat)
	  goff(j,i) = exp(x+y+z)
	end do
      end do
c
c    initialize wsav for offset to regular shift
c
      ioff = 0
      call sshifti(ioff,nlon,nlat,lsave,wsave,ier)
c
c     write input arguments to sshifte
c
      write(*,100) ioff,nlon,nlat,lsave,lwork
  100 format(' sshifte arguments',
     +/' ioff = ',i2, ' nlon = ',i3,' nlat = ',i3,
     +/' lsave = ',i5, ' lwork = ',i5)
c
c     shift offset to regular grid
c
      call sshifte(ioff,nlon,nlat,goff,greg,wsave,lsave,work,lwork,ier)

      write(*,200) ier
  200 format(' ier = ',i2)

      if (ier.eq.0) then
c
c     compute error in greg
c
      err2 = 0.0
      do j=1,nlon
	long = (j-1)*dlon
	do i=1,nlat+1
	  lat = -0.5*pi+(i-1)*dlat
	  x = cos(lat)*cos(long)
	  y = cos(lat)*sin(long)
	  z = sin(lat)
	  gexact = exp(x+y+z)
	  err2 = err2 + (greg(j,i)-gexact)**2
	end do
      end do
      err2 = sqrt(err2/(nlon*(nlat+1)))
      write(*,300) err2
  300 format(' least squares error = ', e10.3)
      end if
c    initialize wsav for regular to offset shift
c
      ioff = 1
      call sshifti(ioff,nlon,nlat,lsave,wsave,ier)
c
c     now transfer regular grid values in greg back to offset grid in goff
c
      do j=1,nlon
	do i=1,nlat
	  goff(j,i) = 0.0
	end do
      end do
      write(*,100) ioff,nlon,nlat,lsave,lwork
      call sshifte(ioff,nlon,nlat,goff,greg,wsave,lsave,work,lwork,ier)
      write(*,200) ier
      if (ier .eq. 0) then
c
c     compute error in goff by comparing with exp(x+y+z) on offset grid
c
      err2 = 0.0
      do j=1,nlon
	long = dlon2+(j-1)*dlon
	do i=1,nlat
	  lat = -0.5*pi+dlat2+(i-1)*dlat
	  x = cos(lat)*cos(long)
	  y = cos(lat)*sin(long)
	  z = sin(lat)
	  gexact = exp(x+y+z)
	  err2 = err2 + (goff(j,i)-gexact)**2
	end do
      end do
      err2 = sqrt(err2/(nlon*(nlat+1)))
      write(*,300) err2
      end if
      end


module search_bisec_mod
  implicit none
  save

 contains
      subroutine search_bisec(v,x,lower,upper)
!     -------------------------------------------------------------
!     given value v; search an (**ascending order**)  array x(n)
!     by bisection, returning the indices that bracket value v
!     -------------------------------------------------------------
      implicit none
      real*8, intent(in):: v, x(:)
      integer :: n,mid
      integer, intent(out)::lower,upper

      n=size(x)
      upper=n
      lower=1

      do while ((upper - lower) .gt. 1)
         mid= (upper + lower)/2
         if ( v .gt. x(mid)) then
            upper=upper
            lower=mid
         else
            upper=mid
            lower=lower
         endif
      enddo

      return
      end subroutine
!***********************************************************************
end module search_bisec_mod


module ccm_numz
! basic real types
    integer, parameter:: b8 = selected_real_kind(10)
contains
     function ccm_time()
        implicit none
        integer i
        integer :: ccm_start_time(8) = (/(-100,i=1,8)/)
        real(b8) :: ccm_time,tmp
        integer,parameter :: norm(13)=(/  &
               0, 2678400, 5097600, 7776000,10368000,13046400,&
        15638400,18316800,20995200,23587200,26265600,28857600,31536000/)
        integer,parameter :: leap(13)=(/  &
               0, 2678400, 5184000, 7862400,10454400,13132800,&
        15724800,18403200,21081600,23673600,26352000,28944000,31622400/)
        integer :: values(8),m,sec
        save
        call date_and_time(values=values)
        if(mod(values(1),4) .eq. 0)then
           m=leap(values(2))
        else
           m=norm(values(2))
        endif
        sec=((values(3)*24+values(5))*60+values(6))*60+values(7)
        tmp=real(m,b8)+real(sec,b8)+real(values(8),b8)/1000.0_b8
        !write(*,*)"vals ",values
        if(values(1) .ne. ccm_start_time(1))then
            if(mod(ccm_start_time(1),4) .eq. 0)then
                tmp=tmp+real(leap(13),b8)
            else
                tmp=tmp+real(norm(13),b8)
            endif
        endif
        ccm_time=tmp
    end function

subroutine invert (matrix,size)
	implicit none
	real(b8) matrix(:,:)
	integer size
	integer switch,k, jj, kp1, i, j, l, krow, irow,nmax
	parameter (nmax=1000)
	dimension switch(nmax,2)
	real(b8) pivot,temp
	do  k = 1,size
		jj = k
		if (k .ne. size) then
			kp1 = k + 1
			pivot = (matrix(k, k))
			do i = kp1,size
				temp = (matrix(i, k))
				if ( abs(pivot) .lt.  abs(temp)) then
					pivot = temp
					jj = i
				endif
			enddo
		endif
		switch(k, 1) = k
		switch(k, 2) = jj
		if (jj .ne. k) then
			do  j = 1 ,size
				temp = matrix(jj, j)
				matrix(jj, j) = matrix(k, j)
				matrix(k, j) = temp
			enddo
		endif
		do j = 1,size
			if (j .ne. k)matrix(k, j) = matrix(k, j) / matrix(k, k)
		enddo
		matrix(k, k) = 1.0_b8 / matrix(k, k)
		do  i = 1,size
			if (i.ne.k) then
				do  j = 1,size
					if(j.ne.k)matrix(i,j)=matrix(i,j)-matrix(k,j)*matrix(i,k)
				enddo
			endif
		enddo
		do i = 1, size
			if (i .ne. k)matrix(i, k) = -matrix(i, k) * matrix(k, k)
		enddo
	enddo
	do  l = 1,size
		k = size - l + 1
		krow = switch(k, 1)
		irow = switch(k, 2)
		if (krow .ne. irow) then
			do  i = 1,size
				temp = matrix(i, krow)
				matrix(i, krow) = matrix(i, irow)
				matrix(i, irow) = temp
			enddo
		endif
	enddo
end subroutine

subroutine mset(m,  n,  in)
	real(b8) :: m(:,:)
	integer n,in
	integer i,j
	do i=1,n
		do j=1,n
			if( i .eq. j)then
				m(i,j)=in
			else
				m(i,j)=i+j
			endif
		enddo
	enddo
end subroutine

function mcheck(m,  n,  in)
	real(b8) :: m(:,:)
	real(b8) mcheck,x
	integer n,in
	integer i,j
	x=0
	do i=1,n
		do j=1,n
			if( i .eq. j)then
				x=x+abs(m(i,j)-in)
			else
				x=x+abs(m(i,J)-(i+j))
			endif
		enddo
	enddo
	mcheck=x
end function
end module ccm_numz

program tover
	use ccm_numz
	real(b8),allocatable :: m1(:,:),m2(:,:),m3(:,:),m4(:,:)
	integer n
	real(b8) t0_start,t0_end
    real(b8) t1_start,t1_end,e1
    real(b8) t2_start,t2_end,e2
    real(b8) t3_start,t3_end,e3
    real(b8) t4_start,t4_end,e4
    real(b8) s1,t1

	n=750
	e1=1
	e2=1
	e3=1
	e4=1
	allocate(m1(n,n),m2(n,n),m3(n,n),m4(n,n))
	call mset(m1,n,1)
	call mset(m2,n,2)
	call mset(m3,n,3)
	call mset(m4,n,4)
	t0_start=ccm_time()
!*** parallel is required lest it runs in serial mode
!*** single is required lest you get 4 sets for each thread
!$omp parallel
!$omp single
!$omp task
	t1_start=ccm_time()
	s1=t1_start
	call invert(m1,n)
	call invert(m1,n)
	t1_end=ccm_time()
!	e1=mcheck(m1,n,1)
	t1_start=t1_start-t0_start
	t1=t1_start
	t1_end=t1_end-t0_start
!$omp end task

!$omp task
	t2_start=ccm_time()
	call invert(m2,n)
	call invert(m2,n)
!$omp end task
	t2_end=ccm_time()
!	e2=mcheck(m2,n,2)
	t2_start=t2_start-t0_start
	t2_end=t2_end-t0_start

!$omp task
	t3_start=ccm_time()
	call invert(m3,n)
	call invert(m3,n)
!$omp end task
	t3_end=ccm_time()
!	e3=mcheck(m3,n,3)
	t3_start=t3_start-t0_start
	t3_end=t3_end-t0_start

!$omp task
	t4_start=ccm_time()
	call invert(m4,n)
	call invert(m4,n)
!$omp end task
	t4_end=ccm_time()
!	e4=mcheck(m4,n,4)
	t4_start=t4_start-t0_start
	t4_end=t4_end-t0_start
!$omp end single
!$omp end parallel
 t0_end=ccm_time()
 t0_end=t0_end-t0_start
 write(*,1)1,t1_start,t1_end,e1
 write(*,1)2,t2_start,t2_end,e2
 write(*,1)3,t3_start,t3_end,e3
 write(*,1)4,t4_start,t4_end,e4
 write(*,2)t0_start,t0_end
1 format("section ",i4," start time= ",f20.10," end time= ",g15.5," error=",g15.5)
2 format("taskwait",4x," start time= ",f20.10," end time= ",g15.5)
 e1=mcheck(m1,n,1)
 e2=mcheck(m2,n,2)
 e3=mcheck(m3,n,3)
 e4=mcheck(m4,n,4)
 write(*,3)e1,e2,e3,e4
3 format("final errors ",4(1x,g15.5))
 write(*,*)s1,t1
 end program


C * KDELF        -   Calculate the increment of the deformation gradient for
C                   a given perturbation in (i,j), with epsilon
C
C * KPRINTER     -   Print out a matrix of any size
C
C * KMTMS     -   Multiply two matrices
C
C * KMATRIX2VECTOR     -   Convert a 3x3 matrix to a 6x1 vector
C
C * KDOTPROD           - Dot product of two vectors
C
C------------------------------------------------------------
      subroutine kdotprod(A, B, dotp, n)

      INCLUDE 'ABA_PARAM.INC'

      intent(in) :: A, B, n
      intent(out):: dotp

      dimension A(n), B(n)
      dotp = 0.0

      do i = 1,n
        dotp = dotp + A(i)*B(i)
      end do

      end subroutine kdotprod
C
C-------------------------------------------------------
C
C-------------------------------------------------------
C
      subroutine kmatrix2vector(XMAT, VEC, NSHR)

      INCLUDE 'ABA_PARAM.INC'

      intent(in) :: XMAT, NSHR
      intent(out):: VEC

      dimension xmat(3,3), vec(6)

        do i=1,3
            vec(i) = xmat(i,i);
        end do

        vec(4) = xmat(1,2);

        IF (NSHR==3) then
            vec(5) = xmat(1,3);
            vec(6) = xmat(2,3);
        END IF

      end subroutine kmatrix2vector
C
C-------------------------------------------------------
C
C-------------------------------------------------------
C
      SUBROUTINE KMTMS (M, N, L, A, KA, B, KB, C, KC)

      INCLUDE 'ABA_PARAM.INC'
C
      intent(in) :: M, N, L, A, KA, B, KB, KC
      intent(out):: C
C
C
C    PRODUCT OF REAL MATRICES
C
      DIMENSION A(KA,N), B(KB,L), C(KC,L)
      DOUBLE PRECISION W
C
C
      DO 30 J = 1,L
         DO 20 I = 1,M
            W = 0.D0
            DO 10 K = 1,N
               W = W + A(I,K) * B(K,J)
   10       CONTINUE
            C(I,J) = W
   20    CONTINUE
   30 CONTINUE
      RETURN
      END SUBROUTINE KMTMS
C
C-------------------------------------------------------
C
C-------------------------------------------------------
C
      subroutine kprinter(tens, m, n)

      INCLUDE 'ABA_PARAM.INC'

      intent(in):: tens, m, n

      dimension tens(m,n)

        write(6,*)
        do i = 1,m
        do j = 1,n
            write(6,'(e19.9)',advance='no'),tens(i,j)
        end do
        write(6,*)
        end do
        write(6,*)
      return
      end subroutine kprinter
C
C-------------------------------------------------------
C
C-------------------------------------------------------
C
      subroutine kdelF(m, n, DGRAD, eps, DF)

      INCLUDE 'ABA_PARAM.INC'

      intent (in) :: DGRAD, eps, m, n
      intent (out):: DF

C Input: the index's i & j; The current deformation gradient (DGRAD). The perturbation
C        increment (eps)
C
C Output: The perturbed increment DF
C
      dimension dyad1(3,3), dyad2(3,3), DGRAD(3,3), DF(3,3), DFp1(3,3)

c Zero the dyad matrices
c
      do i = 1,3
        do j = 1,3
            dyad1(i,j) = zero
            dyad2(i,j) = zero
        end do
      end do

c Place the 1's in the correct location
      dyad1(m,n) = 1.0;
c
      dyad2(n,m) = 1.0;
c
c      KMTMS (M, N, L, A, KA, B, KB, C, KC)
      call KMTMS(3, 3, 3, dyad1, 3, DGRAD, 3, DFp1, 3)
      DF = DFp1

      call KMTMS(3, 3, 3, dyad2, 3, DGRAD, 3, DFp1, 3)
      DF = DF + DFp1

      DF = 0.5*DF*eps

      end subroutine kdelF
C
C-------------------------------------------------------
C
C-------------------------------------------------------
C

Lesson C - fibre reinforced anistropic models/Abaqus/utilities.f


      SUBROUTINE cdfnbn(which,p,q,s,xn,pr,ompr,status,bound)
C**********************************************************************
C
C      SUBROUTINE CDFNBN ( WHICH, P,Q, S, XN, PR, STATUS, BOUND )
C               Cumulative Distribution Function
C               Negative BiNomial distribution
C
C
C                              Function
C
C
C     Calculates any one parameter of the negative binomial
C     distribution given values for the others.
C
C     The  cumulative  negative   binomial  distribution  returns  the
C     probability that there  will be  F or fewer failures before  the
C     XNth success in binomial trials each of which has probability of
C     success PR.
C
C     The individual term of the negative binomial is the probability of
C     S failures before XN successes and is
C          Choose( S, XN+S-1 ) * PR^(XN) * (1-PR)^S
C
C
C                              Arguments
C
C
C     WHICH --> Integer indicating which of the next four argument
C               values is to be calculated from the others.
C               Legal range: 1..4
C               iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR
C               iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR
C               iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR
C               iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN
C                    INTEGER WHICH
C
C     P <--> The cumulation from 0 to S of the  negative
C            binomial distribution.
C            Input range: [0,1].
C                    DOUBLE PRECISION P
C
C     Q <--> 1-P.
C            Input range: (0, 1].
C            P + Q = 1.0.
C                    DOUBLE PRECISION Q
C
C     S <--> The upper limit of cumulation of the binomial distribution.
C            There are F or fewer failures before the XNth success.
C            Input range: [0, +infinity).
C            Search range: [0, 1E300]
C                    DOUBLE PRECISION S
C
C     XN  <--> The number of successes.
C              Input range: [0, +infinity).
C              Search range: [0, 1E300]
C                    DOUBLE PRECISION XN
C
C     PR  <--> The probability of success in each binomial trial.
C              Input range: [0,1].
C              Search range: [0,1].
C                    DOUBLE PRECISION PR
C
C     OMPR  <--> 1-PR
C              Input range: [0,1].
C              Search range: [0,1]
C              PR + OMPR = 1.0
C                    DOUBLE PRECISION OMPR
C
C     STATUS <-- 0 if calculation completed correctly
C               -I if input parameter number I is out of range
C                1 if answer appears to be lower than lowest
C                  search bound
C                2 if answer appears to be higher than greatest
C                  search bound
C                3 if P + Q .ne. 1
C                4 if PR + OMPR .ne. 1
C                    INTEGER STATUS
C
C     BOUND <-- Undefined if STATUS is 0
C
C               Bound exceeded by parameter number I if STATUS
C               is negative.
C
C               Lower search bound if STATUS is 1.
C
C               Upper search bound if STATUS is 2.
C
C
C                              Method
C
C
C     Formula   26.5.26   of   Abramowitz  and  Stegun,  Handbook   of
C     Mathematical Functions (1966) is used  to  reduce calculation of
C     the cumulative distribution  function to that of  an  incomplete
C     beta.
C
C     Computation of other parameters involve a seach for a value that
C     produces  the desired  value  of P.   The search relies  on  the
C     monotinicity of P with the other parameter.
C
C
C**********************************************************************
C     .. Parameters ..
      DOUBLE PRECISION tol
      PARAMETER (tol=1.0D-13)
      DOUBLE PRECISION atol
      PARAMETER (atol=1.0D-50)
      DOUBLE PRECISION inf
      PARAMETER (inf=1.0D300)
      DOUBLE PRECISION one
      PARAMETER (one=1.0D0)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION bound,p,q,pr,ompr,s,xn
      INTEGER status,which
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION fx,xhi,xlo,pq,prompr,cum,ccum
      LOGICAL qhi,qleft,qporq
C     ..
C     .. External Functions ..
      DOUBLE PRECISION spmpar
      EXTERNAL spmpar
C     ..
C     .. External Subroutines ..
      EXTERNAL dinvr,dstinv,dstzr,dzror,cumnbn
C     ..
C     .. Executable Statements ..
C
C     Check arguments
C
      IF (.NOT. ((which.LT.1).OR. (which.GT.4))) GO TO 30
      IF (.NOT. (which.LT.1)) GO TO 10
      bound = 1.0D0
      GO TO 20

   10 bound = 4.0D0
   20 status = -1
      RETURN

   30 IF (which.EQ.1) GO TO 70
C
C     P
C
      IF (.NOT. ((p.LT.0.0D0).OR. (p.GT.1.0D0))) GO TO 60
      IF (.NOT. (p.LT.0.0D0)) GO TO 40
      bound = 0.0D0
      GO TO 50

   40 bound = 1.0D0
   50 status = -2
      RETURN

   60 CONTINUE
   70 IF (which.EQ.1) GO TO 110
C
C     Q
C
      IF (.NOT. ((q.LE.0.0D0).OR. (q.GT.1.0D0))) GO TO 100
      IF (.NOT. (q.LE.0.0D0)) GO TO 80
      bound = 0.0D0
      GO TO 90

   80 bound = 1.0D0
   90 status = -3
      RETURN

  100 CONTINUE
  110 IF (which.EQ.2) GO TO 130
C
C     S
C
      IF (.NOT. (s.LT.0.0D0)) GO TO 120
      bound = 0.0D0
      status = -4
      RETURN

  120 CONTINUE
  130 IF (which.EQ.3) GO TO 150
C
C     XN
C
      IF (.NOT. (xn.LT.0.0D0)) GO TO 140
      bound = 0.0D0
      status = -5
      RETURN

  140 CONTINUE
  150 IF (which.EQ.4) GO TO 190
C
C     PR
C
      IF (.NOT. ((pr.LT.0.0D0).OR. (pr.GT.1.0D0))) GO TO 180
      IF (.NOT. (pr.LT.0.0D0)) GO TO 160
      bound = 0.0D0
      GO TO 170

  160 bound = 1.0D0
  170 status = -6
      RETURN

  180 CONTINUE
  190 IF (which.EQ.4) GO TO 230
C
C     OMPR
C
      IF (.NOT. ((ompr.LT.0.0D0).OR. (ompr.GT.1.0D0))) GO TO 220
      IF (.NOT. (ompr.LT.0.0D0)) GO TO 200
      bound = 0.0D0
      GO TO 210

  200 bound = 1.0D0
  210 status = -7
      RETURN

  220 CONTINUE
  230 IF (which.EQ.1) GO TO 270
C
C     P + Q
C
      pq = p + q
      IF (.NOT. (abs(((pq)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 260
      IF (.NOT. (pq.LT.0.0D0)) GO TO 240
      bound = 0.0D0
      GO TO 250

  240 bound = 1.0D0
  250 status = 3
      RETURN

  260 CONTINUE
  270 IF (which.EQ.4) GO TO 310
C
C     PR + OMPR
C
      prompr = pr + ompr
      IF (.NOT. (abs(((prompr)-0.5D0)-0.5D0).GT.
     +    (3.0D0*spmpar(1)))) GO TO 300
      IF (.NOT. (prompr.LT.0.0D0)) GO TO 280
      bound = 0.0D0
      GO TO 290

  280 bound = 1.0D0
  290 status = 4
      RETURN

  300 CONTINUE
  310 IF (.NOT. (which.EQ.1)) qporq = p .LE. q
C
C     Select the minimum of P or Q
C
C
C     Calculate ANSWERS
C
      IF ((1).EQ. (which)) THEN
C
C     Calculating P
C
          CALL cumnbn(s,xn,pr,ompr,p,q)
          status = 0

      ELSE IF ((2).EQ. (which)) THEN
C
C     Calculating S
C
          s = 5.0D0
          CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,s,fx,qleft,qhi)
  320     IF (.NOT. (status.EQ.1)) GO TO 350
          CALL cumnbn(s,xn,pr,ompr,cum,ccum)
          IF (.NOT. (qporq)) GO TO 330
          fx = cum - p
          GO TO 340

  330     fx = ccum - q
  340     CALL dinvr(status,s,fx,qleft,qhi)
          GO TO 320

  350     IF (.NOT. (status.EQ.-1)) GO TO 380
          IF (.NOT. (qleft)) GO TO 360
          status = 1
          bound = 0.0D0
          GO TO 370

  360     status = 2
          bound = inf
  370     CONTINUE
  380     CONTINUE

      ELSE IF ((3).EQ. (which)) THEN
C
C     Calculating XN
C
          xn = 5.0D0
          CALL dstinv(0.0D0,inf,0.5D0,0.5D0,5.0D0,atol,tol)
          status = 0
          CALL dinvr(status,xn,fx,qleft,qhi)
  390     IF (.NOT. (status.EQ.1)) GO TO 420
          CALL cumnbn(s,xn,pr,ompr,cum,ccum)
          IF (.NOT. (qporq)) GO TO 400
          fx = cum - p
          GO TO 410

  400     fx = ccum - q
  410     CALL dinvr(status,xn,fx,qleft,qhi)
          GO TO 390

  420     IF (.NOT. (status.EQ.-1)) GO TO 450
          IF (.NOT. (qleft)) GO TO 430
          status = 1
          bound = 0.0D0
          GO TO 440

  430     status = 2
          bound = inf
  440     CONTINUE
  450     CONTINUE

      ELSE IF ((4).EQ. (which)) THEN
C
C     Calculating PR and OMPR
C
          CALL dstzr(0.0D0,1.0D0,atol,tol)
          IF (.NOT. (qporq)) GO TO 480
          status = 0
          CALL dzror(status,pr,fx,xlo,xhi,qleft,qhi)
          ompr = one - pr
  460     IF (.NOT. (status.EQ.1)) GO TO 470
          CALL cumnbn(s,xn,pr,ompr,cum,ccum)
          fx = cum - p
          CALL dzror(status,pr,fx,xlo,xhi,qleft,qhi)
          ompr = one - pr
          GO TO 460

  470     GO TO 510

  480     status = 0
          CALL dzror(status,ompr,fx,xlo,xhi,qleft,qhi)
          pr = one - ompr
  490     IF (.NOT. (status.EQ.1)) GO TO 500
          CALL cumnbn(s,xn,pr,ompr,cum,ccum)
          fx = ccum - q
          CALL dzror(status,ompr,fx,xlo,xhi,qleft,qhi)
          pr = one - ompr
          GO TO 490

  500     CONTINUE
  510     IF (.NOT. (status.EQ.-1)) GO TO 540
          IF (.NOT. (qleft)) GO TO 520
          status = 1
          bound = 0.0D0
          GO TO 530

  520     status = 2
          bound = 1.0D0
  530     CONTINUE
  540 END IF

      RETURN

      END


*DECK CGECO
      SUBROUTINE CGECO (A, LDA, N, IPVT, RCOND, Z)
C***BEGIN PROLOGUE  CGECO
C***PURPOSE  Factor a matrix using Gaussian elimination and estimate
C            the condition number of the matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2C1
C***TYPE      COMPLEX (SGECO-S, DGECO-D, CGECO-C)
C***KEYWORDS  CONDITION NUMBER, GENERAL MATRIX, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     CGECO factors a complex matrix by Gaussian elimination
C     and estimates the condition of the matrix.
C
C     If  RCOND  is not needed, CGEFA is slightly faster.
C     To solve  A*X = B , follow CGECO By CGESL.
C     To Compute  INVERSE(A)*C , follow CGECO by CGESL.
C     To compute  DETERMINANT(A) , follow CGECO by CGEDI.
C     To compute  INVERSE(A) , follow CGECO by CGEDI.
C
C     On Entry
C
C        A       COMPLEX(LDA, N)
C                the matrix to be factored.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix and the multipliers
C                which were used to obtain it.
C                The factorization can be written  A = L*U  where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        RCOND   REAL
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       COMPLEX(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
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, CDOTC, CGEFA, CSSCAL, SCASUM
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  CGECO
      INTEGER LDA,N,IPVT(*)
      COMPLEX A(LDA,*),Z(*)
      REAL RCOND
C
      COMPLEX CDOTC,EK,T,WK,WKM
      REAL ANORM,S,SCASUM,SM,YNORM
      INTEGER INFO,J,K,KB,KP1,L
      COMPLEX ZDUM,ZDUM1,ZDUM2,CSIGN1
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
      CSIGN1(ZDUM1,ZDUM2) = CABS1(ZDUM1)*(ZDUM2/CABS1(ZDUM2))
C
C     COMPUTE 1-NORM OF A
C
C***FIRST EXECUTABLE STATEMENT  CGECO
      ANORM = 0.0E0
      DO 10 J = 1, N
         ANORM = MAX(ANORM,SCASUM(N,A(1,J),1))
   10 CONTINUE
C
C     FACTOR
C
      CALL CGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  CTRANS(A)*Y = E .
C     CTRANS(A)  IS THE CONJUGATE TRANSPOSE OF A .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  CTRANS(U)*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE CTRANS(U)*W = E
C
      EK = (1.0E0,0.0E0)
      DO 20 J = 1, N
         Z(J) = (0.0E0,0.0E0)
   20 CONTINUE
      DO 100 K = 1, N
         IF (CABS1(Z(K)) .NE. 0.0E0) EK = CSIGN1(EK,-Z(K))
         IF (CABS1(EK-Z(K)) .LE. CABS1(A(K,K))) GO TO 30
            S = CABS1(A(K,K))/CABS1(EK-Z(K))
            CALL CSSCAL(N,S,Z,1)
            EK = CMPLX(S,0.0E0)*EK
   30    CONTINUE
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = CABS1(WK)
         SM = CABS1(WKM)
         IF (CABS1(A(K,K)) .EQ. 0.0E0) GO TO 40
            WK = WK/CONJG(A(K,K))
            WKM = WKM/CONJG(A(K,K))
         GO TO 50
   40    CONTINUE
            WK = (1.0E0,0.0E0)
            WKM = (1.0E0,0.0E0)
   50    CONTINUE
         KP1 = K + 1
         IF (KP1 .GT. N) GO TO 90
            DO 60 J = KP1, N
               SM = SM + CABS1(Z(J)+WKM*CONJG(A(K,J)))
               Z(J) = Z(J) + WK*CONJG(A(K,J))
               S = S + CABS1(Z(J))
   60       CONTINUE
            IF (S .GE. SM) GO TO 80
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*CONJG(A(K,J))
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
         Z(K) = WK
  100 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
C
C     SOLVE CTRANS(L)*Y = W
C
      DO 120 KB = 1, N
         K = N + 1 - KB
         IF (K .LT. N) Z(K) = Z(K) + CDOTC(N-K,A(K+1,K),1,Z(K+1),1)
         IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 110
            S = 1.0E0/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
  110    CONTINUE
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
C
      YNORM = 1.0E0
C
C     SOLVE L*V = Y
C
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL CAXPY(N-K,T,A(K+1,K),1,Z(K+1),1)
         IF (CABS1(Z(K)) .LE. 1.0E0) GO TO 130
            S = 1.0E0/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
            YNORM = S*YNORM
  130    CONTINUE
  140 CONTINUE
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE  U*Z = V
C
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (CABS1(Z(K)) .LE. CABS1(A(K,K))) GO TO 150
            S = CABS1(A(K,K))/CABS1(Z(K))
            CALL CSSCAL(N,S,Z,1)
            YNORM = S*YNORM
  150    CONTINUE
         IF (CABS1(A(K,K)) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
         IF (CABS1(A(K,K)) .EQ. 0.0E0) Z(K) = (1.0E0,0.0E0)
         T = -Z(K)
         CALL CAXPY(K-1,T,A(1,K),1,Z(1),1)
  160 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0E0/SCASUM(N,Z,1)
      CALL CSSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END


program tarefaa
    print *, "Digite o valor inteiro de N:"
    read (*,*) N

    ! Número de "Andarilhos" M
    M = 1000

    ! loop do passo
    do i = 1, N
        ! zera a soma
        soma = 0e0

        ! loop do andarilho
        do j = 1, M
            ! soma os passos de cada andarilho
            soma = soma + rand()**i
        end do

        ! Escreve a media no terminal
        write (*,'(A,I0,A,1F5.3)') "<x^",i,">: ", soma/M
    end do

end program tarefaa


MODULE date_sub

!      COLLECTED AND PUT TOGETHER JANUARY 1972, H. D. KNOBLE .
!      ORIGINAL REFERENCES ARE CITED IN EACH ROUTINE.

! Code converted using TO_F90 by Alan Miller
! Date: 1999-12-22  Time: 10:23:47

IMPLICIT NONE

CONTAINS

!        ARITHMETIC FUNCTIONS 'IZLR' AND 'IDAY' ARE TAKEN FROM REMARK ON
!        ALGORITHM 398, BY J. DOUGLAS ROBERTSON, CACM 15(10):918.

FUNCTION iday(yyyy, mm, dd) RESULT(ival)
!------IDAY IS A COMPANION TO CALEND; GIVEN A CALENDAR DATE, YYYY, MM,
!           DD, IDAY IS RETURNED AS THE DAY OF THE YEAR.
!           EXAMPLE: IDAY(1984, 4, 22) = 113

INTEGER, INTENT(IN) :: yyyy, mm, dd
INTEGER             :: ival

ival = 3055*(mm+2)/100 - (mm+10)/13*2 -91 + (1-(MOD(yyyy, 4)+3)/4 +  &
       (MOD(yyyy, 100) + 99)/100 - (MOD(yyyy, 400)+399)/400)*(mm+10)/13 + dd

RETURN
END FUNCTION iday

FUNCTION izlr(yyyy, mm, dd) RESULT(ival)
!------IZLR(YYYY, MM, DD) GIVES THE WEEKDAY NUMBER 0 = SUNDAY, 1 = MONDAY,
!      ... 6 = SATURDAY.  EXAMPLE: IZLR(1970, 1, 1) = 4 = THURSDAY

INTEGER, INTENT(IN) :: yyyy, mm, dd
INTEGER             :: ival

ival = MOD((13*(mm+10-(mm+10)/13*12)-1)/5 + dd + 77 + 5*(yyyy+(mm-14)/12 -  &
           (yyyy+(mm-14)/12)/100*100)/4 + (yyyy+(mm-14)/12)/400 -  &
           (yyyy+(mm-14)/12)/100*2, 7)

RETURN
END FUNCTION izlr

SUBROUTINE calend(yyyy, ddd, mm, dd)
!=============CALEND WHEN GIVEN A VALID YEAR, YYYY, AND DAY OF THE YEAR, DDD,
!             RETURNS THE MONTH, MM, AND DAY OF THE MONTH, DD.
!             SEE ACM ALGORITHM 398, TABLELESS DATE CONVERSION, BY
!             DICK STONE, CACM 13(10):621.

INTEGER, INTENT(IN)   :: yyyy
INTEGER, INTENT(IN)   :: ddd
INTEGER, INTENT(OUT)  :: mm
INTEGER, INTENT(OUT)  :: dd

INTEGER :: t

t = 0
IF(MOD(yyyy, 4) == 0) t = 1

!-----------THE FOLLOWING STATEMENT IS NECESSARY IF YYYY IS < 1900 OR > 2100.
IF(MOD(yyyy, 400) /= 0 .AND. MOD(yyyy, 100) == 0) t = 0

dd = ddd
IF(ddd > 59+t) dd = dd + 2 - t
mm = ((dd+91)*100)/3055
dd = (dd+91) - (mm*3055)/100
mm = mm - 2
!----------MM WILL BE CORRECT IFF DDD IS CORRECT FOR YYYY.
IF(mm >= 1 .AND. mm <= 12) RETURN
WRITE(*,1) ddd
1 FORMAT('0$$$CALEND: DAY OF THE YEAR INPUT =', i11,  ' IS OUT OF RANGE.')

STOP
END SUBROUTINE calend

SUBROUTINE cdate(jd, yyyy, mm, dd)
!=======GIVEN A JULIAN DAY NUMBER, NNNNNNNN, YYYY,MM,DD ARE RETURNED AS THE
!              CALENDAR DATE. JD = NNNNNNNN IS THE JULIAN DATE FROM AN EPOCH
!              IN THE VERY DISTANT PAST.  SEE CACM 1968 11(10):657,
!              LETTER TO THE EDITOR BY FLIEGEL AND VAN FLANDERN.
!    EXAMPLE CALL CDATE(2440588, YYYY, MM, DD) RETURNS 1970 1 1 .

INTEGER, INTENT(IN)   :: jd
INTEGER, INTENT(OUT)  :: yyyy
INTEGER, INTENT(OUT)  :: mm
INTEGER, INTENT(OUT)  :: dd

INTEGER :: l, n

l = jd + 68569
n = 4*l/146097
l = l - (146097*n + 3)/4
yyyy = 4000*(l+1)/1461001
l = l - 1461*yyyy/4 + 31
mm = 80*l/2447
dd = l - 2447*mm/80
l = mm/11
mm = mm + 2 - 12*l
yyyy = 100*(n-49) + yyyy + l
RETURN
END SUBROUTINE cdate

SUBROUTINE daysub(jd, yyyy, mm, dd, wd, ddd)
!========GIVEN JD, A JULIAN DAY # (SEE ASF JD), THIS ROUTINE CALCULATES DD,
!        THE DAY NUMBER OF THE MONTH; MM, THE MONTH NUMBER; YYYY THE YEAR;
!        WD THE WEEKDAY NUMBER, AND DDD THE DAY NUMBER OF THE YEAR.

!   EXAMPLE: CALL DAYSUB(2440588, YYYY, MM, DD, WD, DDD) YIELDS 1970 1 1 4 1.

INTEGER, INTENT(IN)   :: jd
INTEGER, INTENT(OUT)  :: yyyy
INTEGER, INTENT(OUT)  :: mm
INTEGER, INTENT(OUT)  :: dd
INTEGER, INTENT(OUT)  :: wd
INTEGER, INTENT(OUT)  :: ddd

CALL cdate(jd, yyyy, mm, dd)
wd = izlr(yyyy, mm, dd)
ddd = iday(yyyy, mm, dd)

RETURN
END SUBROUTINE daysub

FUNCTION jd(yyyy, mm, dd) RESULT(ival)

INTEGER, INTENT(IN)  :: yyyy
INTEGER, INTENT(IN)  :: mm
INTEGER, INTENT(IN)  :: dd
INTEGER              :: ival

!              DATE ROUTINE JD(YYYY, MM, DD) CONVERTS CALENDER DATE TO
!              JULIAN DATE.  SEE CACM 1968 11(10):657, LETTER TO THE
!              EDITOR BY HENRY F. FLIEGEL AND THOMAS C. VAN FLANDERN.
!    EXAMPLE JD(1970, 1, 1) = 2440588

ival = dd - 32075 + 1461*(yyyy+4800+(mm-14)/12)/4 +  &
       367*(mm-2-((mm-14)/12)*12)/12 - 3*((yyyy+4900+(mm-14)/12)/100)/4

RETURN
END FUNCTION jd

FUNCTION ndays(mm1, dd1, yyyy1, mm2, dd2, yyyy2) RESULT(ival)

INTEGER, INTENT(IN)  :: mm1
INTEGER, INTENT(IN)  :: dd1
INTEGER, INTENT(IN)  :: yyyy1
INTEGER, INTENT(IN)  :: mm2
INTEGER, INTENT(IN)  :: dd2
INTEGER, INTENT(IN)  :: yyyy2
INTEGER              :: ival

!==============NDAYS IS RETURNED AS THE NUMBER OF DAYS BETWEEN TWO
!              DATES; THAT IS  MM1/DD1/YYYY1 MINUS MM2/DD2/YYYY2,
!              WHERE DATEI AND DATEJ HAVE ELEMENTS MM, DD, YYYY.
!-------NDAYS WILL BE POSITIVE IFF DATE1 IS MORE RECENT THAN DATE2.

ival = jd(yyyy1, mm1, dd1) - jd(yyyy2, mm2, dd2)

RETURN
END FUNCTION ndays

SUBROUTINE date_stamp( string, want_day, short )
CHARACTER (LEN=*), INTENT(OUT)  :: string
LOGICAL, INTENT(IN), OPTIONAL   :: want_day, short

! Returns the current date as a character string
! e.g.
! want_day     short      string
! .TRUE.      .TRUE.      Thursday, 23 Dec 1999
! .TRUE.      .FALSE.     Thursday, 23 December 1999  <- default
! .FALSE.     .TRUE.      23 Dec 1999
! .FALSE.     .FALSE.     23 December 1999

INTEGER :: val(8), pos
LOGICAL :: want_d, sh
CHARACTER (LEN=9) :: day(0:6) = (/ 'Sunday   ', 'Monday   ', 'Tuesday  ',  &
                      'Wednesday', 'Thursday ', 'Friday   ', 'Saturday ' /)
CHARACTER (LEN=9) :: month(1:12) = (/ 'January  ', 'February ', 'March    ',  &
                         'April    ', 'May      ', 'June     ', 'July     ',  &
                         'August   ', 'September', 'October  ', 'November ',  &
                         'December ' /)

want_d = .TRUE.
IF (PRESENT(want_day)) want_d = want_day
sh = .FALSE.
IF (PRESENT(short)) sh = short

CALL DATE_AND_TIME(VALUES=val)

IF (want_d) THEN
  pos = izlr(val(1), val(2), val(3))
  string = TRIM( day(pos) ) // ','
  pos = LEN_TRIM( string ) + 2
ELSE
  pos = 1
  string = ' '
END IF

WRITE(string(pos:pos+1), '(i2)') val(3)
IF (sh) THEN
  string(pos+3:pos+5) = month(val(2))(1:3)
  pos = pos + 7
ELSE
  string(pos+3:) = month(val(2))
  pos = LEN_TRIM( string ) + 2
END IF

WRITE( string(pos:pos+3), '(i4)') val(1)

RETURN
END SUBROUTINE date_stamp

END MODULE date_sub

PROGRAM test_datesub

!======DATESUB.FOR with Sample Drivers.

USE date_sub
IMPLICIT NONE
INTEGER            :: yyyy, mm, dd, wd, ddd, mma, dda, ndiff, val(8)
CHARACTER (LEN=50) :: message

! Test date_stamp
message = ' date_stamp = '
CALL date_stamp( message(15:) )
WRITE(*, '(a)') message
message = ' date_stamp = '
CALL date_stamp( message(15:), want_day=.FALSE.)
WRITE(*, '(a)') message
message = ' date_stamp = '
CALL date_stamp( message(15:), short=.TRUE.)
WRITE(*, '(a)') message
message = ' date_stamp = '
CALL date_stamp( message(15:), want_day=.FALSE., short=.TRUE.)
WRITE(*, '(a)') message

!  Is this a leap year? I.e. is 12/31/yyyy the 366th day of the year?
CALL DATE_AND_TIME(VALUES=val)
yyyy = val(1)

IF(iday(yyyy, 12, 31) == 366) THEN
  WRITE(*,*) yyyy, ' is a Leap Year'
ELSE
  WRITE(*,*) yyyy, ' is not a Leap Year'
END IF

!  DAYSUB SHOULD RETURN: 1970, 1, 1, 4, 1
CALL daysub(jd(1970, 1, 1), yyyy, mm, dd, wd, ddd)
IF(yyyy /= 1970 .OR. mm /= 1 .OR. dd /= 1 .OR. wd /= 4 .OR. ddd /= 1) THEN
  WRITE(*,*) 'DAYSUB Failed; YYYY, MM, DD, WD, DDD = ', yyyy, mm, dd, wd, ddd
  STOP
END IF

!  DIFFERENCE BETWEEN TO SAME MONTHS AND DAYS OVER 1 LEAP YEAR IS 366.
ndiff = ndays(5, 22, 1984, 5, 22, 1983)
IF(ndiff /= 366) THEN
  WRITE(*,*) 'NDAYS FAILED; NDIFF = ', ndiff
ELSE
!  RECOVER MONTH AND DAY FROM YEAR AND DAY NUMBER.
  CALL calend(yyyy, ddd, mma, dda)
  IF(mma /= 1 .AND. dda /= 1) THEN
    WRITE(*,*) 'CALEND FAILED; MMA, DDA = ', mma, dda
  ELSE
    WRITE(*,*) '** DATE MANIPULATION SUBROUTINES SIMPLE TEST OK.'
  END IF
END IF

STOP
END PROGRAM test_datesub


      subroutine get_ALI(AL,ALI)
******************************************
cc     Written by Lin-Wang Wang, March 30, 2001.
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

******************************************

      real*8 AL(3,3),ALI(3,3)
      real*8 tmp(3)

      do i=1,3
         do j=1,3
            ALI(j,i)=AL(i,j)
         enddo
         tmp(i)=1
      enddo

      call gaussj(ALI,3,3,tmp,1,1)

*****************************************
*     *  \sum_i AL(i,j1)*ALI(i,j2)= \delta_j1,j2
*     *  2*pi*ALI(i,j) is the jth G vector unit in (i)x,y,z components
*****************************************
      return
      end


!
!
!
 FUNCTION COSDD(ALFA)
 implicit NONE
!
! --- Assuming that ALFA is given in DEGREES, it returns the COSINE of ALFA
!     ************************ GS and FC 11-02-2009 ***********************
!
 REAL*8,  PARAMETER :: PI=3.14159265358979323840D0
 REAL*8 COSDD, ALFA, ALFARAD
 ALFARAD=ALFA*PI/180D0
 COSDD=COS(ALFARAD)
 END FUNCTION COSDD
!
!
!