module poles

implicit none

contains

subroutine getpoles(p,q,res)
    IMPLICIT NONE
    complex(kind=16),intent(inout) :: p(:) !cofficients
    complex(kind=16),intent(inout) :: q(:),res(:) !pole position and residue
    ! help variables
    complex(kind=16),allocatable :: z(:) !zeros in pade
    complex(kind=16) :: c !pre factor
    integer :: M !nbr of coefficients

    if( sum(p) == cmplx(0q0,0q0,kind=16)) then
        write(*,*) "All coefficients are 0"
        q=0
        res=1
        return
    endif
    M=size(p)
    if(mod(M,2)==0) then
        allocate(z(M/2-1))  !M/2-1 roots in nominator
    else
        allocate(z((M-1)/2)) !(M-1)/2 roots in nominator
    endif
    call p_factorize(p,q,z,c) !calculate pole positons q and zero positions z
    call p_residues(z,q,c,res) !calculate residues res
    deallocate(z)
end subroutine

SUBROUTINE p_factorize(pq,qq,zq,cq)
!**********************************************************
!
!       p_factorize
!
!>      Gives the poles and zeros of Pade approximant
!             f(z)=C*(Product_i (z-z(i)))/(Product_i (z-q(i)))
!
!>   Input:   p(nom)  coefficients of pade approximant.
!                     Pade approximant has shape either
!
!>                   f(z)=(p(1)+p(2)z+...+p(r)z**(r-1))/
!                        (p(r+1)+...+p(2r)z**(r-1)+z**r)
!                    if nom is even or
!>                   f(z)=(p(1)+p(2)z+...+p(r)z**(r-1)+p(r+1)z**r)/
!                        (p(r+2)+...+p(2r+1)z**(r-1)+z**r)
!                    if nom is odd.
!
!>            nom  number of Matsubara points
!>            r    degree of denominator
!
!>    Output: z(1:r-1) or z(1:r) , zeros of approximant. 1:r-1 if nom is even, 1:r if nom is odd
!>            q(1:r)      poles of approximant
!>            C         constant of factorisation
!
!**********************************************************
    IMPLICIT NONE
    complex(kind=16),intent(in)   :: pq(:)
    complex(kind=16),intent(out)  :: qq(:),zq(:)
    COMPLEX(KIND=16),intent(out)  :: cq

    complex(KIND=8),allocatable   :: A(:,:),B(:,:)
    complex(kind=8),allocatable   :: p(:),q(:),z(:)
    !INTEGER,PARAMETER             :: re=1d0
    INTEGER                       :: nom,r
    !dummy
    INTEGER                      ::      i,j
    nom=size(pq) !nbr of Pade coeff
    if(mod(nom,2)==0) then
       r=nom/2
       cq = pq(r)
       allocate(z(r-1))
       allocate(A(r-1,r-1),B(r,r))
    else
       r=(nom-1)/2
       cq = pq(r+1)
       allocate(z(r))
       allocate(A(r,r),B(r,r))
    endif
    allocate(p(nom),q(r))
    p=pq !convert pade coeff from quad to double
    A = (0d0,0d0)
    B = (0d0,0d0)

    ! Computes Companion Matrix of nominator and denominator
    ! polynomial
    if (r .eq. 1) then
       write(*,11) p(2)
    11   format("No zeros, pole at z=",F8.4,1x,E12.5)
    else
       !construct companion matrix B (denominator)
       do j=1,r-1
          B(j+1,j)= 1d0
       enddo
       if(mod(nom,2)==0) then
          do i=1,r
             B(i,r)=-p(r+i)
          enddo
       else
          do i=1,r
             B(i,r)=-p(r+1+i)
          enddo
       endif
       !construct companion matrix A (nominator)
       if(mod(nom,2)==0) then
          do j=1,r-2
                A(j+1,j)= 1d0
          enddo
          if (p(r) .ne. 0) then
            do i=1,r-1
                A(i,r-1)=-p(i)/p(r)
            enddo
          else
            write(1,*) 'stop'
            stop
          end if
       else
          do j=1,r-1
             A(j+1,j)= 1d0
          enddo
          if (p(r+1) .ne. 0) then
            do i=1,r
                A(i,r)=-p(i)/p(r+1)
            enddo
          else
                write(1,*) 'Sigma0 is calculated to be zero, so probably better to run with even Pade coefficients'
                stop
          end if
       endif
       ! Finds eigenvalues of Companion Matrices
       call zgeevwrapper(A,z)  !r-1
       call zgeevwrapper(B,q)  !r

    end if

    !convert back to quad variables
    qq=q
    zq=z
    deallocate(q,z,p)
    deallocate(A,B)
END SUBROUTINE

SUBROUTINE p_residues(z,q,C,w)
    !*******************************************************************
    !
    !       p_residues
    !
    !>      Can be used after Pade approximation and factorisation of
    !>      Pade polynomials to calculate the residues of the approximant
    !
    !>      Input:  z(1:r-1) or z(1:r)  zeros of approximant. size depending on if even or odd number of Pade coefficients
    !>              q(r)    poles of approximant
    !>              C       constant factor
    !>              r       degree of denominator (half of nom)
    !
    !       Output: w(r)    residues of poles q(r)
    !
    !*******************************************************************
    IMPLICIT NONE
    COMPLEX(KIND=16),intent(in)       ::  z(:),q(:),C
    COMPLEX(KIND=16)                  ::  w(:)
    INTEGER                           ::  i,j,r !dummy
    r=size(q)
    w(:)=C
    !Calculate residues
    do j=1,r
        do i=1,j-1
            w(j)=w(j)*(q(j)-z(i))/(q(j)-q(i))
        enddo
        do i=j+1,r
            w(j)=w(j)*(q(j)-z(i-1))/(q(j)-q(i))
        enddo
        if(size(z,1)==r) then
            w(j)=w(j)*(q(j)-z(r))
        endif
    enddo
end subroutine

!
!>    diagonalizes a general complex(kind=8) matrix and
!!     returns the eigenvalues and eigenvectors
!!
! *******************************************************
subroutine zgeevwrapper(a,e)
    ! A wrapper around zgeev
    implicit none
    complex(KIND=8),intent(inout) :: a(:,:) !< input: Matrix, output: Eigenvectors
    complex(KIND=8),intent(out)   :: e(:)   !< Eigenvalues
    ! See lapack zgeev on netlib for more information
    integer                       :: lwork,info,er
    complex(KIND=8),allocatable   :: work(:)
    real(KIND=8),allocatable      :: rwork(:)
    real(KIND=8)                  :: rwtmp(1) !< dummy
    complex(KIND=8)               :: v1tmp(1),v2tmp(2),wtmp(1) !< dummy,dummy, used to get proper work
    integer :: n      !< size(a,1)
    n=size(a,1)
    lwork = -1
    call zgeev('N','N',n,a,n,e,v1tmp,1,v2tmp,1,wtmp,lwork,rwtmp,info)
    if (info .ne. 0) stop
    lwork = max(6*n,int(wtmp(1)))
    allocate(work(lwork),rwork(2*n),stat=er)
    if (er .ne. 0) stop
    call zgeev('N','N',n,a,n,e,v1tmp,1,v2tmp,1,work,lwork,rwork,info)
    if (info .ne. 0) stop
    deallocate(work,rwork)
end subroutine

end module


   module Precision
      implicit none

      integer, parameter :: dl = KIND(1.d0)
      integer, parameter :: sp = KIND(1.0)
   end module Precision

   module constants
       use precision
       implicit none

       real(dl), parameter :: const_pi = 3.1415926535897932384626433832795_dl
       real(dl), parameter :: const_twopi=2._dl*const_pi, const_fourpi=4._dl*const_pi
       real(dl), parameter :: const_sqrt6=2.4494897427831780981972840747059_dl
       real(dl), parameter :: c = 2.99792458e8_dl
       real(dl), parameter :: h_P = 6.62606896e-34_dl

       real(dl), parameter :: G=6.6738e-11_dl !data book 2012, last digit +/-8
       real(dl), parameter :: sigma_thomson = 6.6524616e-29_dl
       real(dl), parameter :: sigma_boltz = 5.6704e-8_dl
       real(dl), parameter :: k_B = 1.3806504e-23_dl
       real(dl), parameter :: elecV = 1.60217646e-19_dl

       real(dl), parameter :: m_p = 1.672621637e-27_dl ! 1.672623e-27_dl
       real(dl), parameter :: m_H = 1.673575e-27_dl !av. H atom
       real(dl), parameter :: m_e = 9.10938215e-31_dl
       real(dl), parameter :: mass_ratio_He_H = 3.9715_dl

       real(dl), parameter :: Gyr=3.1556926e16_dl
       real(dl), parameter :: Mpc = 3.085678e22_dl !seem to be different definitions of this?
       real(dl), parameter :: MPC_in_sec = Mpc/c ! Mpc/c = 1.029272d14 in SI units

       real(dl), parameter :: const_rhocrit=(8.0d0*const_pi*G*1.d3/(3.0d0*((1.d7/(MPC_in_sec*c*1.d2))**(2.0d0))))**(-1.0d0)
       real(dl), parameter :: barssc0= k_B / m_p / c**2
       real(dl), parameter :: kappa=8._dl*const_pi*G
       real(dl), parameter :: a_rad = 8._dl*const_pi**5*k_B**4/15/c**3/h_p**3
                !7.565914e-16_dl !radiation constant for u=aT^4

       real(dl), parameter :: mplanck = 2.435e18 ! the reduced planck mass in GeV
       real(dl), parameter :: Compton_CT = MPC_in_sec*(8.d0/3.d0)*(sigma_thomson/(m_e*c))*a_rad
        !Compton_CT is CT in Mpc units, (8./3.)*(sigma_T/(m_e*C))*a_R in Mpc
        !Used to get evolution of matter temperature

       !For 21cm
       real(dl), parameter :: f_21cm = 1420.40575e6_dl, l_21cm= c/f_21cm, T_21cm = h_P*f_21cm/k_B
       real(dl), parameter :: A10 = 2.869e-15, B10 = l_21cm**3/2/h_P/c*A10

       real(dl), parameter :: line21_const = 3*l_21cm**2*C*h_P/32/const_pi/k_B*A10 * Mpc_in_sec * 1000
        !1000 to get in MiliKelvin
       real(dl), parameter :: COBE_CMBTemp = 2.7255_dl !(Fixsen 2009) used as default value
       real(dl), parameter :: default_nnu = 3.046_dl

   end module constants

    module Errors
     implicit none

     integer :: global_error_flag=0
     character(LEN=1024) :: global_error_message = ''
     integer, parameter :: error_reionization=1
     integer, parameter :: error_recombination=2
     integer, parameter :: error_inital_power=3
     integer, parameter :: error_evolution=4
     integer, parameter :: error_unsupported_params=5

    contains

      subroutine GlobalError(message, id)
       character(LEN=*), intent(IN), optional :: message
       integer, intent(in), optional :: id

       if (present(message)) then
        global_error_message = message
       else
        global_error_message=''
       end if
       if (present(id)) then
         if (id==0) stop 'Error id must be non-zero'
         global_error_flag=id
       else
         global_error_flag=-1
       end if

      end subroutine GlobalError

    end module Errors


equal = fix (
    \eq:Nat->Nat->Bool m:Nat n:Nat.
        if iszero m
            then iszero n
        else if iszero n
            then false
        else
            eq (pred m) (pred n)
    );

c = ref 0;
incc = \x:Unit. (c := succ (!c); !c);
decc = \x:Unit. (c := pred (!c); !c);
o = {i = incc, d = decc};
!c;
{o.i (), o.i (), o.i (), o.d()};
!c;

d = ref c;
e = ref d;
h = ref e;
{h, !h, !(!h), !(!(!h))};

NatArray = Ref (Nat->Nat);
newarray = \_:(). ref (\n:Nat.0);
lookup = \a:NatArray. \n:Nat. (!a) n;
update = \a:NatArray. \m:Nat. \v:Nat.
    let oldf = !a in
    a := (λn:Nat. if equal m n then v else oldf n);

arr = newarray ();
updatedArr = (update arr 10 7; update arr 5 10;  !arr);
{updatedArr 3, updatedArr 5, updatedArr 10};


subroutine PreGLQ(x1, x2, n, zero, w, exitstatus)
!------------------------------------------------------------------------------
!
!   This routine will find the zeros and weights that are
!   used in Gauss-Legendre quadrature routines. (Based on routines
!   in Numerical Recipes).
!
!   Calling Parameters
!
!       IN
!           x1      Lower bound of integration.
!           x2      Upper bound of integration.
!           n       Number of points used in the quadrature. n points
!                   will integrate a polynomial of degree 2n-1 exactly.
!
!       OUT
!           zero    Array of n Gauss points, which correspond to the zeros
!                   of P(n,0).
!           w       Array of n weights used in the quadrature.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Note
!       1.  If EPS is less than what is defined, then the do
!           loop for finding the roots might never terminate for some
!           values of lmax. If the algorithm doesn't converge, consider
!           increasing itermax, or decreasing eps.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    real(dp), intent(in) :: x1, x2
    real(dp), intent(out) :: zero(:), w(:)
    integer(int32), intent(in) :: n
    integer(int32), intent(out), optional :: exitstatus
    integer(int32) :: i, j, m, iter
    integer(int32), parameter :: itermax = 1000
    real(dp), parameter :: eps=1.0e-15_dp
    real(dp) :: p1, p2, p3, pp, z, z1, xm, xu, pi

    if (present(exitstatus)) exitstatus = 0

    if (size(zero) < n) then
        print*, "Error --- PreGLQ"
        print*, "ZERO must be dimensioned as (N) where N is ", n
        print*, "Input array is dimensioned ", size(zero)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(w) < n) then
        print*, "Error --- PreGLQ"
        print*, "W must be dimensioned as (N) where N is ", n
        print*, "Input array is dimensioned ", size(w)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    pi = acos(-1.0_dp)

    zero = 0.0_dp
    w = 0.0_dp

!------------------------------------------------------------------------------
!
!   The roots are symmetric in the interval, so we only have to find half of
!   them. xm is the midpoint of integration, and xu is the scaling factor
!   between the interval of integration and that of the -1 to 1 interval for
!   the Gauss-Legendre interval.
!
!------------------------------------------------------------------------------
    m = (n+1) / 2
    xm = (x2 + x1) / 2.0_dp
    xu = (x2 - x1) / 2.0_dp

    !   Compute roots and weights
    do i = 1, m
        iter = 0
        ! Approximation for the ith root
        z=cos(pi * (i-0.25_dp) / (n+0.5_dp))

        ! Find the true value using Newton's method
        do
            iter = iter + 1

            p1 = 1.0_dp
            p2 = 0.0_dp

            ! Determine the Legendre polynomial evaluated at z (p1) using
            ! recurrence relationships.
            do j = 1, n
                p3 = p2
                p2 = p1
                p1 = (dble(2*j-1)*z*p2-dble(j-1)*p3) / dble(j)

            end do

            ! This is the derivative of the legendre polynomial using
            ! recurrence relationships.
            pp = dble(n) * (z * p1 - p2) / (z * z-1.0_dp)

            ! This is Newton's method here
            z1 = z
            z = z1-p1 / pp

            if (abs(z-z1) <= eps) exit

            if (iter >itermax) then
                print*, "Error --- PreGLQ"
                print*, "Root Finding of PreGLQ not converging."
                print*, "m , n = ", m, n
                if (present(exitstatus)) then
                    exitstatus = 5
                    return
                else
                    stop
                end if

            end if

        end do

        zero(i) = xm + xu * z
        zero(n+1-i) = xm - xu * z
        w(i) = 2.0_dp * xu / ((1.0_dp-z * z) * pp *pp)
        w(n+1-i) = w (i)

    end do

end subroutine PreGLQ

function NGLQ(degree)
!------------------------------------------------------------------------------
!
!   For a polynomial of order degree, this simple function
!   will determine how many gauss-legendre quadrature points
!   are needed in order to integrate the function exactly.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    integer(int32) :: NGLQ
    integer(int32), intent(in) :: degree

    if (degree < 0) then
        print*, "Error --- NGLQ"
        print*, "DEGREE must be greater or equal to zero"
        print*, "DEGREE = ", degree
        stop
    end if

    nglq = ceiling((degree+1.0_dp) / 2.0_dp)

end function NGLQ

function NGLQSH(degree)
!------------------------------------------------------------------------------
!
!   This function returns the number of gauss-legendre points that
!   are needed to exactly integrate a spherical harmonic field of
!   Lmax = degree.
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    integer(int32) :: NGLQSH
    integer(int32), intent(in) :: degree

    if (degree < 0) then
        print*, "Error --- NGLQSH"
        print*, "DEGREE must be greater or equal to zero"
        print*, "DEGREE = ", degree
        stop
    end if

    nglqsh = degree + 1

end function NGLQSH

function NGLQSHN(degree, n)
!------------------------------------------------------------------------------
!
!   This function returns the number of gauss-legendre points that
!   are needed to exactly integrate a spherical harmonic field of
!   Lmax = degree raised to the nth power. Here, the maximum degree
!   of the integrand is n*lmax + lmax, or (n+1)*lmax
!
!------------------------------------------------------------------------------
    use ftypes

    implicit none

    integer(int32) :: NGLQSHN
    integer(int32), intent(in) :: degree, n

    if (degree < 0) then
        print*, "Error --- NGLQSHN"
        print*, "DEGREE must be greater or equal to zero"
        print*, "DEGREE = ", degree
        stop
    end if

    nglqshn = ceiling(((n+1.0_dp)*degree + 1.0_dp)/2.0_dp)

end function NGLQSHN


program gen_graphite
   use graphite_mod

   !-------------------------------------------------------------
   ! Program to generate a graphite lattice with given
   ! lengths in the 1-, 2-, and 3- directions of the
   ! hexagonal coordinate system. The lattice is centerd
   ! at (0,0,0) in cartesian coordinates. The program outputs
   ! the generated coordinates in cartesian coordiantes.
   !-------------------------------------------------------------

   implicit none

   integer :: i, j, k, l, ipm, jpm, kpm, coordinate, atom, p, q
   integer :: n1, n2, n3 ! how many times to translate in
                              ! each direction. Will translate that many
                              ! times in both the plus and minus
                              ! directions
   real(kind=8), parameter :: d1 = 11.0d0 ! length in 1-direction in angst.
   real(kind=8), parameter :: d2 = 11.0d0 ! length in 2-direction in angst.
   real(kind=8), parameter :: d3 = 9.0d0 ! length in 3-direction in angst.
   real(kind=8), dimension(2), parameter :: pm = (/ 1.0d0, -1.0d0 /) ! plus
                                                                     ! or
                                                                     ! minus
   real(kind=8), dimension(3) :: center ! center of mass
   real(kind=8), dimension(3) :: e1, e2, e3 ! unit vectors of basis
   real(kind=8), dimension(3), parameter :: a = (/ 2.45d0, 2.45d0, 6.70d0 /)
                                            ! lattice constants of graphite
   real(kind=8), dimension(3) :: atom_coordinates
   real(kind=8), dimension(3,3) :: Pe ! transformation matrix for change of
                                      ! basis to cartesian coordinates
   real(kind=8), dimension(3,3) :: Peinv
   real(kind=8), dimension(4,3) :: unit_cell
   real(kind=8), dimension(3,4) :: transposed_unit_cell
   real(kind=8), allocatable, dimension(:,:) :: first_cell
   integer :: io, nlines
   character(len=12) :: read_char
   character(len=200) :: current_line

   ! Determine how many times you want to translate in each direction:
   ! (some large enough number of times)
   n1 = int( (d1/a(1))/2.0d0 + 3.0d0 )
   n2 = int( (d2/a(2))/2.0d0 + 3.0d0 )
   n3 = int( (d3/a(3))/2.0d0 + 3.0d0 )

   !------------------------------------------------------------
   ! Define the atoms of unit_cell, and redefine them so that
   ! the first cell is centered at (0,0,0) of the
   ! Cartesian coordinate system:
   !------------------------------------------------------------

   ! Independent (basis) points in graphite in hexagonal coordinates:
   unit_cell = transpose(reshape( (/ 0.0d0, 0.0d0, 0.0d0, 1.0d0/3.0d0, &
      1.0d0/3.0d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0, 2.0d0/3.0d0, 2.0d0/3.0d0, &
      0.5d0 /), shape(transposed_unit_cell) ))

   ! Scale the basis points by the lattice constant:
   do i = 1, size(unit_cell,1)
      do j = 1, size(unit_cell,2)
         unit_cell(i,j) = unit_cell(i,j)*a(j)
      end do
   end do

   write(*,*) 'unit_cell:'
   do i = 1, size(unit_cell,1)
      write(*,*) (unit_cell(i,j), j = 1, size(unit_cell,2))
   end do
   write(*,*)

   ! Define hxagonal/cartesian transformations:
   e1 = (/ 1.0d0, 0.5d0, 0.0d0 /) ! x-axis
   e2 = (/ 0.0d0, sqrt(3.0d0)/2.0d0, 0.0d0 /) ! y-axis
   e3 = (/ 0.0d0, 0.0d0, 1.0d0 /) ! z-axis

   ! Hexagonal -> cartesian transformation matrix:
   do i = 1, 3
      Pe(i,1) = e1(i)
      Pe(i,2) = e2(i)
      Pe(i,3) = e3(i)
   end do

   ! Cartesian -> hexagonal transformation matrix:
   call inverse_3_3(Pe,Peinv)
   write(*,*)
   write(*,*) 'Peinv:'
   do i = 1, size(Peinv,1)
      write(*,*) (Peinv(i,j), j = 1, size(Peinv,2))
   end do
   write(*,*)

   ! Write the first cell in cartesian coordinates:
   ! so that it may be converted to cartesian coordinates,
   ! and centered at (0,0,0):
   open (unit=7, file='first_cell', status='new', action='write')
   do i = 0,1
      do j = 0,1
         do k = 0,1
            ! for the plus directio:
            ipm = 1
            jpm = 1
            kpm = 1
            ! For each atom in the unit cell:
            do atom = 1, size(unit_cell,1)
               ! For each coordinate of that atom
               atom_coordinates(1) = unit_cell(atom,1) + &
                  a(1)*pm(ipm)*dble(i)
               atom_coordinates(2) = unit_cell(atom,2) + &
                  a(2)*pm(jpm)*dble(j)
               atom_coordinates(3) = unit_cell(atom,3) + &
                  a(3)*pm(kpm)*dble(k)
               ! If the coordinates of this atom are
               ! within the dimensions of the unit cell,
               ! then write them to the first_cell output file:
               if (atom_coordinates(1) <= a(1)+0.1) then
                  if (atom_coordinates(2) <= a(2)+0.1) then
                     if (atom_coordinates(3) <= a(3)+0.1) then
                        atom_coordinates = matmul(atom_coordinates,Pe)
                        write(7,*) (atom_coordinates(coordinate), &
                        coordinate = 1, 3)
                     end if
                  end if
               end if
            end do
         end do
      end do
   end do
   close(7)

   ! Read the first cell:
   open (unit=8, file='first_cell', status='old', action='read')
   ! count the number of lines in first_cell:
   nlines = 0
   do
      read(8,*,iostat=io) read_char
      if (io/=0) exit
      nlines = nlines + 1
      !write(*,*) nlines
   end do

   rewind(8)
   allocate(first_cell(nlines,3))
   write(*,*) "first_cell: "
   do p = 1, nlines
      read(8,*) first_cell(p,1), first_cell(p,2), first_cell(p,3)
      write(*,*) (first_cell(p,q), q = 1,3)
   end do
   close(8)

   ! Find center of mass of unit cell:
   do i = 1,3
      center(i) = 0.0d0
      do j = 1, size(first_cell,1)
         center(i) = center(i) + first_cell(j,i)
      end do
      center(i) = center(i) / dble(size(first_cell,1))
   end do
   write(*,*)
   write(*,*) "center:", center
   write(*,*)

   ! move center of mass to (0,0,0)
   do i = 1, size(first_cell,1)
      do j = 1, 3
         first_cell(i,j) = first_cell(i,j) - center(j)
      end do
   end do

   ! Write first_cell.xyz for viewing with molden
   open (unit=9, file='first_cell_moved.xyz', status='new', action='write')
   write(9,*) size(first_cell,1) + 1
   write(9,*) 'The first cell'
   write(9,*) "O", 0.0d0, 0.0d0, 0.0d0
   do i = 1, size(first_cell,1)
      write(9,*) "C", (first_cell(i,j), j = 1,3)
   end do
   close(9)

   ! Redefine unit cell as first_cell in hexagonal coordinates:
   do i = 1, 4
      do j = 1, 3
         unit_cell(i,j) = first_cell(i,j)
      end do
   end do
   unit_cell = matmul(unit_cell, Peinv)
   deallocate(first_cell)

   write(*,*)
   write(*,*) "unit_cell:"
   do i = 1, size(unit_cell,1)
      write(*,*) (unit_cell(i,j), j = 1, size(unit_cell,2))
   end do

   ! Write the .in file:
   open (unit=2, file='graphite.in', status='new', action='write')

   write(2,*) "O", 0.0d0, 0.0d0, 0.0d0

   write(*,*)
   write(*,*) "final coordinates:"
   ! For the number of times the unit cell has to be repliicated
   ! in the 1-direction
   do i = 0,n1
      ! For the number of times the unit cell has to be repliicated
      ! in the 2-direction
      do j = 0, n2
         ! For the number of times the unit cell has to be repliicated
         ! in the 3-direction
         do k = 0, n3
            ! for the plus and minus of x:
            do ipm = 1, 2
               ! for the plus and minus of y:
               do jpm = 1, 2
                  ! for the plus and minus of z:
                  do kpm = 1,2
                     if ( i == 0 ) then
                        if ( ipm == 2 ) then
                           cycle ! Do not repeat twice for +0 and -0
                        end if
                     end if
                     if ( j == 0 ) then
                        if ( jpm == 2 ) then
                           cycle
                        end if
                     end if
                     if ( k == 0 ) then
                        if ( kpm == 2 ) then
                           cycle
                        end if
                     end if
                     ! For each atom in the unit cell:
                     do atom = 1, size(unit_cell,1)
                        ! For each coordinate of that atom
                        atom_coordinates(1) = unit_cell(atom,1) + &
                           a(1)*pm(ipm)*dble(i)
                        atom_coordinates(2) = unit_cell(atom,2) + &
                           a(2)*pm(jpm)*dble(j)
                        atom_coordinates(3) = unit_cell(atom,3) + &
                           a(3)*pm(kpm)*dble(k)
                        atom_coordinates = matmul(atom_coordinates,Pe)
                        ! If the coordinates of this atom are
                        ! within the requested dimensions of the slab,
                        ! then write them to the output file:
                        if (dabs(atom_coordinates(1)) <= d1/2.0d0) then
                           if (dabs(atom_coordinates(2)) <= d2/2.0d0) then
                              if (dabs(atom_coordinates(3)) <= d3/2.0d0) then
                                 if (atom <=2) then
                                    write(2,'(A1,A4,3F15.9)') "N", "    ",&
                                       (atom_coordinates(coordinate), &
                                       coordinate = 1, 3)
                                 else if (atom > 2) then
                                    write(2,'(A1,A4,3F15.9)') "C", "    ",&
                                       (atom_coordinates(coordinate), &
                                       coordinate = 1, 3)
                                 end if
                                 write(*,*) i, j, k, (atom_coordinates(l), l = 1, 3)
                              end if
                           end if
                        end if
                     end do
                  end do
               end do
            end do
         end do
      end do
   end do

   close(2)

   ! Write a .xyz file:
   open (unit=3, file='graphite.in', status='old', action='read')

   ! count the number of lines in particle.in:
   nlines = 0
   do
      read(3,*,iostat=io) read_char
      if (io/=0) exit
      nlines = nlines + 1
   end do

   rewind(3)

   open (unit=4, file='graphite.xyz', status='new', action='write')

   write(4,*) nlines
   write(4,*) 'kflklv'
   do i = 1, nlines
      read(3,'(A100)') current_line
      write(4,*) trim(current_line)
   end do

   close(3)
   close(4)

end program gen_graphite


PROGRAM calc_simple
	IMPLICIT NONE

	INTEGER :: a, b
	CHARACTER :: op

	PRINT *, 'Ecrivez un entier a='
	READ *, a
	PRINT *, 'Ecrivez un entier b='
	READ *, b
	PRINT *, 'Ecrivez un opérateur op='
	READ *, op

	IF(op=='+')THEN
		PRINT *, 'résultat =', a+b
	ELSE IF(op=='-')THEN
		PRINT *, 'résultat =', a-b
	ELSE IF(op=='*')THEN
		PRINT *, 'résultat =', a*b
	ELSE IF(op==':')THEN
		IF(b/=0) THEN
			PRINT *, 'résultat =', a/b
		ELSE
			PRINT *,'Division par zéro'
		END IF
	ELSE
		PRINT *, 'Opérateur inconnu!'
	END IF
END PROGRAM calc_simple


  program conversion

! Dimitri Komatitsch, CNRS Marseille, France, July 2018
! Author: Sourangshu Ghosh
! see formulas 9.59 and 9.60 in the book of Dahlen and Tromp, 1998
! (in that book, P is called alpha and S is called beta).
! See also file formulas_to_convert_between_Qkappa_Qmu_and_Qp_Qs_in_3D_and_in_2D_plane_strain.pdf in this directory.

  implicit none

  integer :: iconversion_type
  integer :: idimension

  double precision :: Qkappa,Qmu,Qp,Qs,cp,cs
  double precision :: inverse_of_Qp,inverse_of_Qmu,inverse_of_Qkappa,COEFFICIENT

  print *,'1 = you want to perform the conversion in 3D'
  print *,'2 = you want to perform the conversion in 2D plane strain'
  read(*,*) idimension
  if (idimension < 1 .or. idimension > 2) stop 'error: incorrect value of idimension'
  if (idimension == 1) then
    COEFFICIENT = 4.d0 / 3.d0
  else
    COEFFICIENT = 1.d0
  endif
  print *

  print *,'1 = you want to convert from (Qp,Qs) to (QKappa,Qmu)'
  print *,'2 = you want to convert from (QKappa,Qmu) to (Qp,Qs)'
  read(*,*) iconversion_type
  if (iconversion_type < 1 .or. iconversion_type > 2) stop 'error: incorrect value of iconversion_type'
  print *

! get the input values from the user
  if (iconversion_type == 1) then
    print *,'enter Qp:'
    read(*,*) Qp
    print *,'enter Qs:'
    read(*,*) Qs
    print *
  else
    print *,'enter QKappa:'
    read(*,*) QKappa
    print *,'enter Qmu:'
    read(*,*) Qmu
    print *
  endif

! enter the cp and cs velocities of the medium, at the frequency at which you want this conversion to be performed
  print *,'enter the cp and cs velocities of the medium, at the frequency at which you want this conversion to be performed:'
  print *,'enter cp:'
  read(*,*) cp
  print *,'enter cs:'
  read(*,*) cs
  print *

  if (iconversion_type == 1) then

! Qmu is always the same as Qs
    Qmu = Qs

! for QKappa the formula is more complex
    inverse_of_Qp = 1.d0 / Qp
    inverse_of_Qmu = 1.d0 / Qmu

    inverse_of_Qkappa = (inverse_of_Qp - COEFFICIENT*(cs**2)/(cp**2) * inverse_of_Qmu) / (1.d0 - COEFFICIENT*(cs**2)/(cp**2))

    Qkappa = 1.d0/inverse_of_Qkappa

! print the result
    print *,'Qkappa = ',Qkappa
    print *,'Qmu = ',Qmu

  else ! if (iconversion_type == 2) then

! Qs is always the same as Qmu
    Qs = Qmu

! for Qp the formula is more complex
    inverse_of_Qp = (1.d0 - COEFFICIENT*(cs**2)/(cp**2))/Qkappa + COEFFICIENT*(cs**2)/(cp**2)/Qmu
    Qp = 1.d0/inverse_of_Qp

! print the result
    print *,'Qp = ',Qp
    print *,'Qs = ',Qs

  endif

  end program conversion


program bitpat
! shows how bit masks "Z" and octets "O" work in Fortran
! https://gcc.gnu.org/onlinedocs/gfortran/BOZ-literal-constants.html

use, intrinsic:: iso_fortran_env, only: int64

implicit none (type, external)

! note that if you want other than default elements of array, you must use e.g. int( , int64) on each element
! or use a DATA statement, as per
! https://groups.google.com/forum/#!topic/comp.lang.fortran/AFtpnBh6eLg

integer :: I(5)
integer, parameter :: J(5) = [  2**29      ,  2**22    , 2**15   , 2**8 , 2**1 ]

integer(int64), parameter :: hexa = int(z'80000000',int64)

integer(int64),parameter :: K = int(O"201004020100",int64)
!2**34+2**27+2**20+2**13+2**6

integer,parameter :: K1 = int(O'50147')
!! while it's allowed to put BOZ at end, standard is to put BOZ at front

!> need to put each in int() otherwise compilers like GCC 10 error
I = [int(O"4000000000"), int(O"20000000"), int(O"100000"), int(O"400"), int(O"2")]

print '(A,5I12)','exp',j

print '(A,5I12)','BOZ',i

if (any(i /= j)) error stop 'bit pattern mismatch'

if (i(1) /= 536870912) error stop 'bit pattern mismatch'

if (j(1) /= 536870912) error stop 'bit pattern mismatch'

if (k1 /= 20583) error stop 'bit pattern mismatch'

if (k /= 17315143744_int64) error stop 'bit pattern mismatch'

print *,'--------------'
print *,hexa

end program


!*****************************************************************************
! FILE: omp_dotprod_hybrid.f
! DESCRIPTION:
!   This simple program is the hybrid version of a dot product and the fourth
!   of four codes used to show the progression from a serial program to a
!   hybrid MPI/OpenMP program.  The relevant codes are:
!      - omp_dotprod_serial.f  - Serial version
!      - omp_dotprod_openmp.f  - OpenMP only version
!      - omp_dotprod_mpi.f     - MPI only version
!      - omp_dotprod_hybrid.f  - Hybrid MPI and OpenMP version
! SOURCE: Blaise Barney
! LAST REVISED:  06/02/17 Blaise Barney
!******************************************************************************

      program dotprod
      include 'mpif.h'

! Define length of dot product vectors and number of OpenMP threads
      integer VECLEN, NUMTHREADS
      parameter(VECLEN=100)
      parameter(NUMTHREADS=8)

      integer i, myid, tid, numprocs, threads, ierr, OMP_GET_THREAD_NUM,
     &        OMP_GET_NUM_THREADS
      real*8 a(VECLEN*NUMTHREADS), b(VECLEN*NUMTHREADS)
      real*8 mysum, allsum, sum, psum

! MPI Initialization
      call MPI_INIT (ierr)
      call MPI_COMM_SIZE (MPI_COMM_WORLD, numprocs,ierr)
      call MPI_COMM_RANK (MPI_COMM_WORLD, myid, ierr)

! Each MPI task uses OpenMP to perform the dot product, obtains its
! partial sum, and then calls MPI_Reduce to obtain the global sum.
      if (myid .eq. 0) then
        print *, 'Starting omp_dotprod_hybrid. Using',numprocs,
     &           ' tasks...'
      end if

! Initialize dot product vectors
      do i=1, VECLEN*NUMTHREADS
        a(i)=1.0
        b(i)=a(i)
      end do

! Perform the dot product in an OpenMP parallel region for loop with a sum reduction
! For illustration purposes:
!   - Explicitly sets number of threads
!   - Gets and prints number of threads used
!   - Each thread keeps track of its partial sum

! Initialize OpenMP reduction sum
      sum = 0.0

!$OMP PARALLEL PRIVATE(i,tid,psum) NUM_THREADS(NUMTHREADS)
      psum = 0.0
      tid = OMP_GET_THREAD_NUM()
      if (tid .eq. 0) then
        threads = OMP_GET_NUM_THREADS()
        print *,'Task',myid,' using',NUMTHREADS,' threads'
      end if

!$OMP DO REDUCTION(+:sum)
      do i=1, VECLEN*NUMTHREADS
        sum = sum + a(i) * b(i)
        psum = sum
      end do
!$OMP END DO
      print *, 'Task',myid,'thread',tid,' partial sum =',psum
!$OMP END PARALLEL

! Print this task's partial sum
      mysum = sum
      print *,'Task',myid,'partial sum =',mysum

! After the dot product, perform a summation of results on each node
      call MPI_REDUCE (mysum, allsum, 1, MPI_DOUBLE_PRECISION, MPI_SUM,
     &            0, MPI_COMM_WORLD, ierr);
      if (myid .eq. 0) then
        print *, 'Done. Hybrid version: global sum  =', allsum
      end if

      call MPI_FINALIZE(ierr)

      end


program ising
! Lisa Larrimore, lisal@sccs.swarthmore.edu
! 3 May 2002
! Physics 114 Final Project
! This program is adapted from the Ising Model program written in
! BASIC by Elaine Chandler that appears on p. 184 of David Chandler"s
! Introduction to Modern Statistical Mechanics.

 ! The input parameters for this program are in "ising.in", and they
 ! allow the size, length, and initial configuration of the simulation
 ! to be changed. See comments in file.

 ! This program has three output files:
 !
 ! "spin-array" Contains snapshots of the spin lattice at the end of
 ! each temperature run (or throughout the middle of the
 ! run, if only looking at one temperature). Can be
 ! visualized with the IDL program see_spins.pro
 !
 ! "magnetization" Contains four columns: each temperature, the
 ! average magnetization at that temp, the ave magnetizaion
 ! squared at that temp, and the susceptibility.
 !
 ! "energy" Contains four columns: each temperature, the
 ! average energy at that temp, the ave energy squared
 ! at that temp, and the heat capacity.
use iso_fortran_env
 implicit none

 ! Variable declarations:
 integer :: i, j, m, n, m2, n2 ! dummy integers
 integer, allocatable :: A(:,:) ! matrix containing spins
 integer :: nrows, ncols ! number of rows and cols of A
 real :: temp, beta ! temperature, inverse temperature
 integer :: ConfigType ! starting configuration type
 integer :: npass ! number of passes for MC algorithm
 integer :: ipass,paso ! the current pass number
 integer :: nequil ! number of equilibration steps
 integer :: trial_spin ! values of changed spin
 real :: high_temp ! starting temp for scan
 real :: low_temp ! final temp for scan
 real :: temp_interval ! interval between scan points
 integer :: nscans ! number of scans (each at diff T)
 integer :: iscan ! current scan number
 logical :: MovieOn ! set to .true. to make movie of 1 temp
 real :: deltaU ! change in energy between 2 configs
 !real :: deltaU1, deltaU ! energy changes for lattice gas
 real :: log_eta ! log of random number to compare to
 real(kind=4) :: magnetization ! magnetization of all spins in lattice
 real(kind=4) :: magnetization_ave ! cumulative average magnetization
 real(kind=4) :: magnetizationabs_ave ! cumulative average absolute magnetization
 real(kind=4) :: magnetization2_ave ! cumulative average of mag. squared
 real(kind=4) :: magnetization4_ave ! cumulative average of mag. squared
 real(kind=4) :: energy ! energy of all spins in lattice
 real(kind=4) :: energy_ave ! cumulative average of energy
 real(kind=4) :: energy2_ave ! cumulative average of energy squared
 real :: alpha(3,3) !alphaud value
 integer :: output_count ! # times things have been added to averages
 real :: invOutput_count,invDim

 print*, "________________MONTE CARLO 2D ISING MODEL________________"
 print*, "Monte Carlo Statistics for 2D Ising Model with"
 print*, " periodic boundary conditions."
 print*, "The critical temperature is approximately 2.3, as seen on"
 print*, " Chandler p. 123."

 ! Read in input parameters from file "ising.in"
 open(unit=11,file="cf.dat",status="old",action="read")
 read(11,*);read(11,*) nrows
 read(11,*);read(11,*) ncols
 read(11,*);read(11,*) npass
 read(11,*);read(11,*) nequil
 read(11,*);read(11,*) high_temp
 read(11,*);read(11,*) low_temp
 read(11,*);read(11,*) temp_interval
 read(11,*);read(11,*) alpha(1,3)
 read(11,*);read(11,*) ConfigType
 read(11,*);read(11,*) MovieOn
 close(11)
alpha (3,1) = alpha(1,3)
alpha (1,1) = 1
alpha (3,3) = 1

invDim = 1.0/real(nrows*ncols)
 ! Set the dimensions of the matrix of spin arrays. This program uses
 ! periodic boundary conditions, so the first two rows and columns are
 ! the same as the last two.
 allocate(A(nrows+2,ncols+2))

 ! Open output files:
 !open(unit=32,file="spin-array",status="replace",action="write")
 !write(32,*) nrows
 !write(32,*) ncols
 nscans = int((high_temp - low_temp)/temp_interval) + 1
 !if (MovieOn) then
 !write(32,*) 51
 !write(32,*) 1
 !else
 !write(32,*) nscans
 !write(32,*) 2
 !endif

 open(unit=33,file="magnetization",status="replace",action="write")
 write(33,*) "temp ave_magnetization ave_magnetization^2 ave_magnetization^4 susceptibility susceptibilityAbs cumulant"
 open(unit=34,file="energy",status="replace",action="write")
 write(34,*) "temp ave_energy ave_energy^2 C_v"

! Set up the initial spin configuration.
A(1,1) = 1
 do i = 1, nrows+1
 	A(i+1,1) = -A(i,1)
 end do
do j = 1, ncols+1
	A(:,j+1) = -A(:,j)
enddo

 scan_loop: do iscan = 1, nscans
 temp = high_temp - temp_interval*(iscan-1)
 print*, "Running program for T =", temp

 ! Initialize variables
 beta = 1.0/temp
 output_count = 0
 energy_ave = 0.0
 energy2_ave = 0.0
 magnetization_ave = 0.0
 magnetizationabs_ave = 0.0
 magnetization2_ave = 0.0
 magnetization4_ave = 0.0

!do i = 1, nrows + 2
!do j = 1, ncols + 2
!A(i,j) = 1
!end do
!end do

 ! Main loop containing Monte Carlo algorithm:
 MC_passes: do ipass = 0, npass

 ! If MovieOn is .true., write the spin array to an output every
 ! npass/50 steps.
 !if ((MovieOn) .and. (mod(ipass,npass/50) == 0)) then
 !do i = 2, nrows+1
 !do j = 2, ncols+1
 !write(32,*) A(i,j)
 !enddo
 !enddo
 !endif

 ! If ipass is greater than nequil (the number of equilibration steps),
 ! calculate the magnetization and energy:
 if (ipass > nequil) then
 output_count = output_count + 1
 magnetization = sum(A(2:nrows+1,2:nrows+1))!*invDim!/(ncols*nrows*1.0)
 magnetization_ave = magnetization_ave + magnetization
 magnetizationabs_ave = magnetizationabs_ave + abs(magnetization)
 magnetization2_ave = magnetization2_ave + magnetization*magnetization
 magnetization4_ave = magnetization4_ave + magnetization*magnetization*magnetization*magnetization
 energy = 0.0
 do i = 2, nrows + 1
 do j = 2, ncols + 1
 energy = energy - A(i,j)*(alpha(A(i,j)+2,A(i-1,j)+2)*A(i-1,j)+alpha(A(i,j)+2,A(i+1,j)+2)*A(i+1,j)+alpha(A(i,j)+2,A(i,j-1)+2)*A(i,j-1)+alpha(A(i,j)+2,A(i,j+1)+2)*A(i,j+1))
 !print *, 'InstE: ',A(m,n)*(alpha(A(m,n)+2,A(m-1,n)+2)*A(m-1,n)+alpha(A(m,n)+2,A(m+1,n)+2)*A(m+1,n)+alpha(A(m,n)+2,A(m,n-1)+2)*A(m,n-1)+alpha(A(m,n)+2,A(m,n+1)+2)*A(m,n+1)), 'Energia: ',energy
 enddo
 enddo
 ! Divide the energy by the total number of spins to get the ave
 ! energy per spin, and divide by 2 to account for double counting.
 energy = energy/real(2.0)!*invDim!(ncols*nrows*2.0)
 !print *, 'Energia: ',energy, 'Energia^2: ',energy**2
 energy_ave = energy_ave + energy
 energy2_ave = energy2_ave + energy*energy
 endif

	MCloop: do paso=0, nrows*ncols
		 ! Randomly choose a spin to change:
		 m = nint((nrows-1)*ran1(5) + 2) ! choose a random row
		 n = nint((ncols-1)*ran1(5) + 2) ! choose a random column
		 trial_spin = -A(m,n) ! trial spin value

		 ! Find change in energy (deltaU) due to trial move.
		 ! If exp(-beta*deltaU) > eta, where eta is random, accept move:
		 !deltaU = -trial_spin*(A(m-1,n)+A(m+1,n)+A(m,n-1)+A(m,n+1))*2
		  deltaU = -trial_spin* &
				( A(m+1,n)*alpha(trial_spin+2,A(m+1,n)+2) &
				+ A(m-1,n)*alpha(trial_spin+2,A(m-1,n)+2) &
			    + A(m,n+1)*alpha(trial_spin+2,A(m,n+1)+2) &
			    + A(m,n-1)*alpha(trial_spin+2,A(m,n-1)+2) ) &
				+ A(m,n)* &
				( A(m+1,n)*alpha(A(m,n)+2,A(m+1,n)+2) &
				+ A(m-1,n)*alpha(A(m,n)+2,A(m-1,n)+2) &
			    + A(m,n+1)*alpha(A(m,n)+2,A(m,n+1)+2) &
			    + A(m,n-1)*alpha(A(m,n)+2,A(m,n-1)+2) )
		!print *, 'DeltaU: ',deltaU
		 log_eta = dlog(ran1(5) + 1.0d-10) ! random number 0-1 (+ tiny offset)
		 if (-beta*deltaU > log_eta) then
		 A(m,n) = trial_spin
		 if (m == 2) A(nrows+2,n) = trial_spin
		 if (m == nrows+1) A(1,n) = trial_spin
		 if (n == 2) A(m,ncols+2) = trial_spin
		 if (n == ncols+1) A(m,1) = trial_spin
		 endif
 	enddo MCloop
 enddo MC_passes
 invOutput_count = 1.0/real(output_count)
 ! Write final spin array to output file
 !if (.not. MovieOn) then
 !do i = 2, nrows + 1
 !do j = 2, ncols + 1
 !write(32,*) A(i,j)
 !enddo
 !enddo
 !endif
 write(33,*) temp, abs(magnetization_ave*invOutput_count)*invDim, &
 magnetization2_ave*invOutput_count*invDim, magnetization4_ave*invOutput_count*invDim, &
 beta*(magnetization2_ave*invOutput_count - (magnetization_ave*magnetization_ave*invOutput_count*invOutput_count ))*invDim, &
 beta*(magnetization2_ave*invOutput_count - (magnetizationabs_ave*magnetizationabs_ave*invOutput_count*invOutput_count ))*invDim,&
 1.0 - ( (magnetization4_ave*invOutput_count) / (3 * (magnetization2_ave*invOutput_count) ** 2) )
 write(34,*) temp, energy_ave*invOutput_count*invDim, energy2_ave*invOutput_count*invDim, &
 (beta*beta)*(energy2_ave*invOutput_count - (energy_ave*energy_ave*invOutput_count*invOutput_count ))*invDim

 enddo scan_loop

 !close(32)
 close(33)
 close(34)

 print*, "Program ising.f90 complete!"
 print*, "Look at spin-array with IDL program see_spins.pro"

 contains

 !_______RANDOM NUMBER GENERATING FUNCTION______!

 double precision function ran1(idum)
 implicit none
 double precision :: r(97)
 integer, intent(IN) :: idum
 save
 integer, parameter :: M1=259200,IA1=7141,IC1=54773
 real, parameter :: RM1=1.0d0/M1
 integer, parameter :: M2=134456,IA2=8121,IC2=28411
 real, parameter :: RM2=1.0d0/M2
 integer, parameter :: M3=243000,IA3=4561,IC3=51349
 integer :: IX1, IX2, IX3, jjj
 integer :: iff=0
 if (idum < 0 .or. iff == 0) then
 iff = 1
 IX1 = mod(IC1-idum,M1)
 IX1 = mod(IA1*IX1+IC1,M1)
 IX2 = mod(IX1,M2)
 IX1 = mod(IA1*IX1+IC1,M1)
 IX3 = mod(IX1,M3)
 do jjj = 1,97
 IX1 = mod(IA1*IX1+IC1,M1)
 IX2 = mod(IA2*IX2+IC2,M2)
 r(jjj) = (dfloat(IX1)+dfloat(IX2)*RM2)*RM1
 end do
 end if
 IX1 = mod(IA1*IX1+IC1,M1)
 IX2 = mod(IA2*IX2+IC2,M2)
 IX3 = mod(IA3*IX3+IC3,M3)
 jjj = 1+(97*IX3)/M3
 if (jjj > 97 .or. jjj < 1)  read( *, * )
 ran1 = r(jjj)
 r(jjj) = (dfloat(IX1)+dfloat(IX2)*RM2)*RM1
 end function ran1

 end program ising

V6 Out-Of & On Equilibrium/Result Coexistance Phase/Files/Critical Temperature/Internet/ising.f95


! calc the P, SH, and SV radiation pattern, using
! aki and richards formulation.
! code modified by EJG, from an original
! code written by CHUNPENG ZHAO
! summer 2009
!
! input: strike, dip, rake ("fi,delta,lamda")
!        station theta (take-off angle) and az,
!        and desired radiation pattern
!
! output: amplitude

         character*2 radpat
         real fi,lamda,delta,amp_theo
         real itheta,jaz,azi,takeoff

! fi = strike, delta = dip, lamda = rake
! read strike dip rake
         READ(*,*)fi,delta,lamda
! read desired radpat
         READ(*,*)radpat
! read take off angle and azimuth to compute
! radiation for:
         READ(*,*)itheta,jaz

         deg2rad=3.1415926/180
         rad2deg=1/deg2rad
         fi=fi*deg2rad
         delta=delta*deg2rad
         lamda=lamda*deg2rad
         takeoff=itheta*deg2rad
         azi=jaz*deg2rad

         if ( radpat == "P " ) then
!        P radiation Pattern
              amp_theo=cos(lamda)*sin(delta)*(sin(takeoff)**2.)
     c        *sin(2.*(azi-fi))-cos(lamda)*cos(delta)*sin(2*takeoff)
     c        *cos(azi-fi)+sin(lamda)*sin(2.*delta)*(cos(takeoff)**2.
     c        -sin(takeoff)**2.*sin(azi-fi)**2.)+sin(lamda)
     c        *cos(2.*delta)*sin(2.*takeoff)*sin(azi-fi)
              proj=takeoff*rad2deg
              azi=azi*rad2deg
              if(abs(amp_theo) .lt. 0.0001) amp_theo=0.0
              write(*,*)amp_theo
         else if ( radpat == "SV" ) then
!        SV radiation Pattern
              amp_theo=sin(lamda)*cos(2.*delta)*cos(takeoff*2.)
     c        *sin(azi-fi)-cos(lamda)*cos(delta)*cos(2.*takeoff)
     c        *cos(azi-fi)+1./2.*cos(lamda)*sin(delta)
     c        *sin(takeoff*2)*sin(2.*(azi-fi))-1./2.*sin(lamda)
     c        *sin(2.*delta)*sin(2.*takeoff)*(1+sin(azi-fi)**2.)
              proj=takeoff*rad2deg
              azi=azi*rad2deg
              if(abs(amp_theo) .lt. 0.0001) amp_theo=0.0
              write(*,*)amp_theo
         else if ( radpat == "SH" ) then
!        SH radiation Pattern
              amp_theo=cos(lamda)*cos(delta)*cos(takeoff)
     c        *sin(azi-fi)+cos(lamda)*sin(delta)*sin(takeoff)
     c        *cos(2.*(azi-fi))+sin(lamda)*cos(2.*delta)*cos(takeoff)
     c        *cos(azi-fi)-1./2.*sin(lamda)*sin(2.*delta)
     c        *sin(takeoff)*sin(2.*(azi-fi))
              proj=takeoff*rad2deg
              azi=azi*rad2deg
              if(abs(amp_theo) .lt. 0.0001) amp_theo=0.0
              write(*,*)amp_theo
        end if
        end


! mpiexec -np 4 bin/Debug/WGFM_test2.exe
program matrices_test
    use meshread_mod
    use MFIEDuffy_functions
    use linalg_mod
    use spherePEC_mod
    use mpi
    use EFIE_RWG_matrices
    use CFIE_mod
    implicit none

    real(8), parameter :: pi = 4d0 * atan(1d0)
    complex(8), parameter :: IU = (0d0, 1d0)

    ! Variables
    type(Mesh) :: msh
    integer, parameter :: nNS = 6           ! number of quadrature points for EFIE

    complex(8), allocatable :: K1Mat(:, :)   ! MFIE K_1 operator
    complex(8), allocatable :: K2Mat(:, :)   ! MFIE K_2 operator
    complex(8), allocatable :: IMat(:, :)    ! MFIE identity operator
    complex(8), allocatable :: T1Mat(:, :)   ! EFIE T_1 operator
    complex(8), allocatable :: T2Mat(:, :)   ! EFIE T_2 operator

    complex(8), allocatable :: A1(:, :)
    complex(8), allocatable :: A2(:, :)
    complex(8), allocatable :: A3(:, :)
    complex(8), allocatable :: CFIEMat(:, :)
    integer :: n1, n2, n3, n4

    complex(8), allocatable :: Einc(:, :)
    complex(8), allocatable :: Hinc(:, :)
    complex(8), allocatable :: Etot(:, :)
    complex(8), allocatable :: Htot(:, :)
    complex(8), allocatable :: Eproj(:)
    complex(8), allocatable :: Hproj(:)
    complex(8), allocatable :: Jvec(:)
    complex(8), allocatable :: Mvec(:)
    complex(8), allocatable :: MJvec(:)

    ! MPI variables
    integer :: ierr, N_procs, id

    ! Parameters
    real(8), parameter :: ep0 = 1d0!1d0 / (35950207149.4727056d0 * PI)  ! vacuum permittivity [F/m]
    real(8), parameter :: mu0 = 1d0!PI * 4d-7                           ! vacuum permeability [H/m]

    real(8), parameter :: k = 0.1d0 * PI          ! free-space wavenumber [1/m]
    real(8), parameter :: ep1 = ep0             ! exterior permittivity [F/m]
    real(8), parameter :: mu1 = mu0             ! exterior permeability [H/m]
    real(8), parameter :: ep2 = ep0 * 7.8d0     ! interior permittivity [F/m]
    real(8), parameter :: mu2 = mu0 * 2.3d0     ! interior permeability [H/m]

    real(8), parameter :: w = k / sqrt(ep0 * mu0)   ! angular frequency [rad/s]
    real(8), parameter :: k1 = w * sqrt(ep1 * mu1)  ! exterior wavenumber [1/m]
    real(8), parameter :: k2 = w * sqrt(ep2 * mu2)  ! interior wavenumber [1/m]

    character(len=100) :: file_msh = 'meshes/convergence_sphere/sph0150.msh'  ! mesh sph0400

    ! Dipole parameters
    real(8) :: pol(3) = [1.0d0, 1.0d0, 1.0d0]      ! polarization vector
    real(8) :: src(3) = [-0.1d0, -0.1d0, -0.25d0]  ! location of dipole source

    ! Planewave parameters
    logical :: TE_mode = .false.   ! TE / TM mode
    real(8) :: beta = pi / 4d0     ! angle of incidence of planewave

    ! MPI init
    call mpi_init(ierr)
    call mpi_comm_size(MPI_COMM_WORLD, N_procs, ierr)
    call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
    print *, "Total processes:", N_procs, "Process id:", id

    ! Load mesh
    call load_gmsh(file_msh, msh)

    ! Compute MFIE matrices
    if (id == 0) print *, "MFIE"
    call genMFIESauterSchwabMat(K1Mat, msh, k1, IMat)
    call genMFIESauterSchwabMat(K2Mat, msh, k2)

    ! Compute EFIE matrices
    if (id == 0) print *, "EFIE"
    call genEFIESauterSchwabMat_RWG(T1Mat, msh, k1, nNS, nNS)
    call genEFIESauterSchwabMat_RWG(T2Mat, msh, k2, nNS, nNS)

    if (id == 0) then
        ! Compute submatrices
        allocate(A1(msh%nbEdg, msh%nbEdg))
        allocate(A2(msh%nbEdg, msh%nbEdg))
        allocate(A3(msh%nbEdg, msh%nbEdg))
        A1 = -mu2 * K2Mat + mu1 * K1Mat
        A2 = 1d0 / w * (k2**2 * T2Mat - k1**2 * T1Mat)
        A3 = ep2 * K2Mat - ep1 * K1Mat
        deallocate(K1Mat, K2Mat, T1Mat, T2Mat)

        ! Assemble N-Muller system matrix
        n1 = 1
        n2 = msh%nbEdg
        n3 = msh%nbEdg + 1
        n4 = 2 * msh%nbEdg
        allocate(CFIEMat(n4, n4))
        CFIEMat(n1:n2, n1:n2) = (ep2+ep1)/2d0*IMat + A3
        CFIEMat(n3:n4, n3:n4) = -(mu2+mu1)/2d0*IMat + A1
        CFIEMat(n1:n2, n3:n4) = A2
        CFIEMat(n3:n4, n1:n2) = A2
        deallocate(A1, A2, A3)

        ! Compute interior and exterior fields
        ! (E1 - E2) and (H1 - H2)
        allocate(Etot(msh%nbNod, 3))
        allocate(Htot(msh%nbNod, 3))
        Etot = 0d0
        Htot = 0d0

        call DipoleFieldsOnMesh(pol, src, k1, msh, Einc, Hinc)  ! magnetic dipole (exterior)
        Hinc = Hinc / (IU * w * mu0)        ! adjust constants
        Etot = Etot + Einc
        Htot = Htot + Hinc

        call planewave_on_mesh(beta, k2, msh, Einc, TE_mode, Hinc)  ! planewave (interior)
        Hinc = Hinc / (w * mu0)        ! adjust constants
        Etot = Etot - Einc
        Htot = Htot - Hinc

        ! Compute projections <f_m, nxE> and <f_m, nxH>
        allocate(Eproj(msh%nbEdg))
        allocate(Hproj(msh%nbEdg))
        Eproj = genRHSMFIE(Etot, msh)
        Hproj = genRHSMFIE(Htot, msh)

        ! Compute currents
        allocate(Jvec(msh%nbEdg))
        allocate(Mvec(msh%nbEdg))
        allocate(MJvec(2*msh%nbEdg))
        call linsolve(Jvec, IMat, Hproj, msh%nbEdg)
        call linsolve(Mvec, IMat, -Eproj, msh%nbEdg)
        MJvec(n1:n2) = Mvec
        MJvec(n3:n4) = Jvec

        ! print
        MJvec = abs(matmul(CFIEMat, MJvec))
        print *, dreal(MJvec)
        print *, maxval(dreal(MJvec))
    end if

    call MPI_Finalize(ierr)
end program


c Copyright (c) Dmitry Nagirner
c This code is distributed under the MIT license.
c ---------------------------------------------------------
c the following 20 subprograms calculates Bessel function J_mu(z)
c for arbitrary values of argument z>=0 and index mu>=0
c program calculates the Bessel function J_mu(z)
c by series, asymptotic and Cherry method
c djmuz chooses the suitable subprogram for given z and mu (z and dmu)
c djser calculates the function with series, djasp --- with asymptotics,
c djchr --- by Cherry method
c subroutines ph01ln, ph01tg, dartgm, darthm are auxilary for djchr
c dcheb0 calculates Bessel functions with expansions on Chebyshev polinomials
c di13ml, di13pl, dj13ml, dj13pl, dk13gs and yj12gs calculate Bessel
c functions with indices 1/3 and -1/3, dgam calculates gamma-function
c dj0, dj0l, yjog and yj1g calculate the Bessel function J_0(z)
c value of j_mu(z) can be obtained with the command a=djmuz(mu,z)

      function djmuz(dmu,z)
      implicit real*8(a-h,o-z)
      data zlw,zup,dmul,dmup /1d1,1d2,3.5d0,4.5d0/
      if((z.eq.0d0).or.(dmu.eq.0d0)) goto 100
      if((z.le.zlw).and.(dmu.le.zlw)) then
          djmuz=djser(dmu,z)
        else
          if((z.ge.zup).and.(dmu.le.dmul)) then
             djmuz=djasp(dmu,z)
           else
             if(z.le.zlw) dml=1d1
             if((z.gt.zlw).and.(z.le.12.5d0)) dml=dmup
             if(z.gt.12.5d0) dml=z-8d0
             if(dmu.ge.dml) then
                djmuz=djchr(dmu,z)
               else
                imu=idint(dml-dmu)+1
                dmn=dmu+1d0*imu
                djp1=djchr(dmn+1d0,z)
                djo=djchr(dmn,z)
                do nd=1,imu
                   djm1=-djp1+2d0*(dmn-1d0*(nd-1))/z*djo
                   djp1=djo
                   djo=djm1
                enddo
                djmuz=djo
             endif
             return
          endif
      endif
      return
  100 continue
      if(dmu.gt.0d0) then
         djmuz=0d0
        else
         djmuz=dj0(z)
      endif
      return
      end

c subprogram calculates the Bessel function J_mu(z) through series,
c J_mu(z)=(1/gamma(mu+1))(z/2)^mu
c sum_{n=0}^infty prod_{j=1}^n(-1)(z/2)^2/j(mu+j), 0<mu<=10, 0<=z<=5
      function djser(dmu,z)
      implicit real*8(a-h,o-z)
      data eps /1d-9/
      if(z.eq.0d0) djser=0d0
      if(z.eq.0d0) return
      zs=0.5d0*z
      nmu=idint(dmu)
      ddmu=dmu-nmu
      if(ddmu.eq.0d0) then
        zsmu=1d0
       else
        zsmu=zs**ddmu
      endif
        dgmu=dgam(1d0+dmu)
      if(nmu.eq.0) goto 30
      do 20 nn=1,nmu
         zsmu=zs*zsmu
   20 continue
   30 continue
      dan=1d3
      dmz=1d0
      dn=1d0
      zz=-zs*zs
      an=1d0
      do while (dan.gt.eps)
         an=an*zz/dn/(dmu+dn)
         dmz=dmz+an
         dan=dabs(an)
         dn=dn+1d0
      enddo
      djser=zsmu/dgmu*dmz
      return
      end

c subprogram calculates the Bessel function J_mu(z) through asymptotics,
c J_mu(z)=sqrt(2/pi z)[cos(z-pi mu/2-pi/4)sum_{n=0}^infty a_{2n}+
c sin(z-pi mu/2-pi/4)sum_{n=0}^infty a_{2n+1}]
c a_n=(-1)^{[n/2]}prod_{k=1}^n[mu^2-(2k-1)^2/4]/2zk
c  calculation for z>=10, mu=<10
      function djasp(dmu,z)
      implicit real*8(a-h,o-z)
      data eps /1d-9/
      data pis,pif /1.570796326794d0,0.7853981633974483d0/
      zt=0.5d0/z
      dsqz=dsqrt(zt/pif)
      dmu2=dmu*dmu
      zmu=z-pis*dmu-pif
      czm=dcos(zmu)
      szm=dsin(zmu)
      sume=0d0
      sumo=0d0
      dn=1d0
      an=1d0
      dann=1d3
      dan=1d0
  300 continue
      do while ((dan.gt.eps).and.(dan.lt.dann))
         sume=sume+an
         dno=dn-0.5d0
         an=zt/dn*(dmu2-dno*dno)*an
         sumo=sumo+an
         dn=dn+1d0
         dne=dn-0.5d0
         an=-an*zt/dn*(dmu2-dne*dne)
         dann=dan
         dan=dabs(an)
      enddo
      djasp=dsqz*(czm*sume-szm*sumo)
 2001 format(1x,6d12.5)
      end

c subprogram calculates the Bessel function J_mu(z) by Cherry method:
c          /K_{1/3}(nu*xi), v_{+}=arth(zeta)/zeta, 0=<zeta<1,
c J_mu(z)=|     xi=nu*phi(v), phi(v)=v+phi_1(v)/mu^2+phi_2/mu^4,
c          \J_{1/3}(nu*xi)+J_{-1/3}(nu*xi), v_{-}=arctg(zeta)/zeta, z>0.
c z=lambda*sqrt(1-zeta^2) for upper row, z=lambda*sqrt(1+zeta^2) for low
c nu^2/mu^2=1+c_1/mu^2+c_2/mu^4, lambda^2/mu^2=1+gamma_1/mu^2+gamma_2/mu
      function djchr(dmu,z)
      implicit real*8(a-h,o-z)
      data c1,c2 /0.43809523809523809d-01,-0.481826817173756d-02/
      data g1,g2 /0.285714285714d-01,-0.217017268445840d-02/
      data pif,pit /0.785398163397448d0,0.628318530717959d1/
      data pis /1.570796326794897d0/
      data c13,sq13 /0.333333333333333d0,0.577350269189626d0/
      dm2=dmu*dmu  ! mu^2
      dmr2=1d0/dm2 ! 1/mu^2
      dl2=dm2*(1d0+dmr2*(g1+g2*dmr2)) ! [1+(g_1+g_2/mu^2)/mu^2]/mu^2
      dlb=dsqrt(dl2) ! sqroot(dl2)
      dnu=dmu*dsqrt(1d0+dmr2*(c1+c2*dmr2)) ! mu sqroot(1+(c_1+c_2/mu^2)/mu^2)
      z2l2=z*z/dl2 ! z^2/dl2
      if(z2l2.gt.1d0) goto 200
      zet=dsqrt(1d0-z2l2)
      zet1=z2l2/(1d0+zet)
      call ph01ln(zet,zet1,v,phi10n,phi11n,phi20n,phi21n)
      phi=v+dmr2*(phi10n+phi20n*dmr2)
      phi1=1d0+dmr2*(phi11n+phi21n*dmr2)
      xi=dnu*phi
      if(xi.lt.6d0) then
          xi13=xi**c13
          wstar=(di13ml(xi)/xi13-di13pl(xi)*xi13)*sq13
        else
          wstar=dk13gs(xi)/dsqrt(pit*xi)*dexp(-xi)
      endif
      djchr=dsqrt(phi/zet/phi1)*wstar
      return
  200 continue
      zet=dsqrt(z2l2-1d0)
      call ph01tg(zet,v,phi10g,phi11g,phi20g,phi21g)
      phi=v+dmr2*(phi10g+phi20g*dmr2)
      phi1=1d0+dmr2*(phi11g+phi21g*dmr2)
      xi=dnu*phi
      if(xi.lt.6d0) then
          xi13=xi**c13
          dj13m=dj13ml(xi)
          dj13p=dj13pl(xi)
          wstar=(dj13ml(xi)/xi13+dj13pl(xi)*xi13)*sq13
        else
          call yj13gs(xi,yjr,yji)
          x=xi-pif
          wstar=(dcos(x)*yjr-dsin(x)*yji)/dsqrt(pis*xi)
      endif
      djchr=dsqrt(phi/zet/phi1)*wstar
      return
      end

c programm calculates functions phi_1(v) and phi_2(v) and their derivatives
c for v_{+}, 0=<z<1, phi_j=y^{5/2}*p_j(y),phi_j'=y*p_{j1}(y),y=zeta^2
      subroutine ph01ln(z,z1,v,phi10n,phi11n,phi20n,phi21n)
      implicit real*8(a-h,o-z)
      common /warh/ arthm(30)
      data c13 /0.3333333333333333d0/
      data zlim /0.9d0/

      data aa1 /-0.438095238095238d-02/ ! -23/5250
      data aa2 /-0.612244897959184d-02/ ! -3/490
      data aa3 /-0.416666666666667d-01/ ! -1/24
      data aa4 / 0.568181818181818d-01/ ! 5/88

      data ab10 / 0.131428571428571d-01/  ! 23/1750
      data ab11 /-0.457142857142857d-02/  ! 4/875
      data ab20 / 0.183673469387755d-01/  ! 9/490
      data ab21 /-0.596938775510204d-01/  ! -117/1960
      data ab30 / 0.125000000000000d+00/  ! 1/8
      data ab31 / 0.250000000000000d+00/  ! 1/4
      data ab40 /-0.170454545454545d+00/  ! -15/88

      data ad10 /-0.789051184492001d-02/ ! -5224793159/662161500000
      data ad11 /-0.451342199750363d-03/ ! -24905119/55180125000
      data ad12 / 0.625772395405049d-03/ ! 3139109/5016375000
      data ad20 /-0.740895804875397d-02/ ! -21804119/2942940000
      data ad21 /-0.692858162245917d-04/ ! -2124/30655625
      data ad22 / 0.642879569410182d-03/ ! 14333/22295000
      data ad30 /-0.810192056620628d-02/ ! -471629/58212000
      data ad31 / 0.627705627705628d-03/ ! 29/46200
      data ad32 / 0.154195011337869d-02/ ! 17/11025
      data ad40 /-0.104130591630592d-01/ ! -5773/554400
      data ad41 / 0.194444444444444d-02/ ! 7/3600
      data ad42 /-0.219223484848485d-01/ ! -463/21120
      data ad50 /-0.172390109890110d-01/ ! -251/14560
      data ad51 / 0.493303571428571d-01/ ! 221/4480
      data ad52 / 0.193526785714286d+00/ ! 867/4480
      data ad60 /-0.130729166666667d+00/ ! -251/1920
      data ad61 /-0.230208333333333d+00/ ! -221/960
      data ad62 /-0.345312500000000d+00/ ! -221/640
      data ad70 / 0.192248774509804d+00/ ! 1255/6528
      data ad71 / 0.169270833333333d+00/ ! 65/384

      data ae10 / 0.710146066042801d-01/ ! 5224793159/73573500000
      data ae11 / 0.430123547201098d-02/ ! 79114237/18393375000
      data ae12 /-0.419736981385961d-02/ ! -2339509/557375000
      data ae13 / 0.977285789040891d-03/ ! 204268/209015625
      data ae20 / 0.666806224387857d-01/ ! 65412357/980980000
      data ae21 / 0.636783624538727d-03/ ! 19521/30655625
      data ae22 /-0.381988215865767d-02/ ! -936807/245245000
      data ae23 / 0.262538685803992d-02/ ! 58533/22295000
      data ae30 / 0.729172850958565d-01/ ! 471629/6468000
      data ae31 /-0.609461966604824d-02/ ! -657/107800
      data ae32 /-0.337043908472480d-02/ ! -109/32340
      data ae33 /-0.819238945578231d-01/ ! -38537/470400
      data ae40 / 0.937175324675325d-01/ ! 5773/61600
      data ae41 /-0.225324675324675d-01/ ! -347/15400
      data ae42 / 0.182366071428571d+00/ ! 817/4480
      data ae43 / 0.120933441558442d+01/ ! 14899/12320
      data ae50 / 0.155151098901099d+00/ ! 2259/14560
      data ae51 /-0.464062500000000d+00/ ! -297/640
      data ae52 /-0.174174107142857d+01/ ! -7803/4480
      data ae53 /-0.375669642857143d+01/ ! -1683/448
      data ae60 / 0.117656250000000d+01/ ! 753/640
      data ae61 / 0.216562500000000d+01/ ! 693/320
      data ae62 / 0.310781250000000d+01/ ! 1989/640
      data ae63 / 0.414375000000000d+01/ ! 663/160
      data ae70 /-0.173023897058824d+01/ ! -3765/2176
      data ae71 /-0.159237132352941d+01/ ! -3465/2176
      data ae72 /-0.152343750000000d+01/ ! -195/128

      data aav1 /-0.219047619047619d-01/ ! -23d0/1050d0
      data aav2 /-0.694444444444445d-01/ ! -5d0/72d0
      data aaz1 / 0.208333333333333d+00/ ! 5d0/24d0
      data aaz2 /-0.125000000000000d+00/ ! -1d0/8d0
      data aaz3 /-0.142857142857143d-01/ ! -1d0/70d0

      data abv1 /-0.761904761904762d-02/ ! -4d0/525d0
      data abv2 / 0.694444444444445d-01/ ! 5d0/72d0
      data abz1 /-0.625000000000000d+00/ ! -5d0/8d0
      data abz2 / 0.750000000000000d+00/ ! 3d0/4d0
      data abz3 /-0.139285714285714d+00/ ! -39d0/280d0

      data adv1 / 0.312886197702524d-02/ ! 3139109d0/1003275000d0
      data adv2 / 0.152116402116402d-02/ ! 23d0/15120d0
      data adv3 /-0.992063492063492d-03/ ! -1d0/1008d0
      data adv4 /-0.868055555555556d-02/ ! -5d0/576d0
      data adv5 / 0.144675925925926d-01/ ! 25d0/1728d0
      data adv6 /-0.403485082304527d-01/ ! -1255d0/31104d0
      data adz1 / 0.150005232862376d-02/ ! 14333d0/9555000d0
      data adz2 / 0.462585034013606d-02/ ! 17d0/3675d0
      data adz3 /-0.803819444444445d-01/ ! -463d0/5760d0
      data adz4 / 0.838616071428571d+00/ ! 3757d0/4480d0
      data adz5 /-0.172656250000000d+01/ ! -221d0/128d0
      data adz6 / 0.959201388888889d+00/ ! 1105d0/1152d0

      data aev1 / 0.162880964840149d-02/ ! 204268d0/125409375d0
      data aev2 /-0.529100529100529d-03/ ! -1d0/1890d0
      data aev3 /-0.967261904761905d-02/ ! -13d0/1344d0
      data aev4 / 0.520833333333333d-01/ ! 5d0/96d0
      data aev5 /-0.434027777777778d-01/ ! -25d0/576d0
      data aev6 / 0.198412698412698d-02/ ! 1d0/504d0
      data aev7 / 0.173611111111111d-01/ ! 5d0/288d0
      data aev8 /-0.289351851851852d-01/ ! -25d0/864d0
      data aev9 / 0.121045524691358d+00/ ! 1255d0/10368d0
      data aez1 / 0.612590266875981d-02/ ! 19511d0/3185000d0
      data aez2 /-0.245771683673469d+00/ ! -38537d0/156800d0
      data aez3 / 0.443422619047619d+01/ ! 14899d0/3360d0
      data aez4 /-0.162790178571429d+02/ ! -7293d0/448d0
      data aez5 / 0.207187500000000d+02/ ! 663d0/32d0
      data aez6 /-0.863281250000000d+01/ ! -1105d0/128d0

      y=z*z
      if(z.gt.zlim) goto 100
      call darthm(z,z1,9)
      v0=arthm(2)
      v1=arthm(3)
      v2=arthm(4)
      v3=arthm(5)
      v4=arthm(6)
      v5=arthm(7)
      v6=arthm(8)
      v7=arthm(9)
      v=c13*y*z*v0
      v01=v0+1d0
      v02=v0*v0
      v03=v0*v02
      v04=v0*v03
      p10n=aa1*v01*v1+aa2*v2+aa3*v3+aa4*v4
      p11n=(ab10+ab11*v0)*v1+(ab20+ab21*v0)*v2+(ab30+ab31*v0)*v3+
     ,ab40*v01*v4
      p20n=(ad10+ad11*v0+ad12*v02*v01)*v1+
     ,(ad20+ad21*v0+ad22*v02)*v2+
     ,(ad30+ad31*v0+ad32*v02)*v3+
     ,(ad40+ad41*v0+ad42*v02)*v4+
     ,(ad50+ad51*v0+ad52*v02)*v5+
     ,(ad60+ad61*v0+ad62*v02)*v6+
     ,(ad70+ad71*v0*v01)*v7
      p21n=(ae10+ae11*v0+ae12*v02+ae13*v03)*v1+
     ,(ae20+ae21*v0+ae22*v02+ae23*v03)*v2+
     ,(ae30+ae31*v0+ae32*v02+ae33*v03)*v3+
     ,(ae40+ae41*v0+ae42*v02+ae43*v03)*v4+
     ,(ae50+ae51*v0+ae52*v02+ae53*v03)*v5+
     ,(ae60+ae61*v0+ae62*v02+ae63*v03)*v6+
     ,(ae70+ae71*v0+ae72*v02*v01)*v7
      y52=y*y*z
      phi10n=y52*p10n/v0
      phi11n=y*p11n/v02
      phi20n=y52*p20n/v03
      phi21n=y*p21n/v04
      return
  100 continue
      zr=1d0/z
      yr=zr*zr
      yr2=yr*yr
      yr3=yr*yr2
      zyr=zr*yr
      call darthm(z,z1,1)
      v=c13*z*y*arthm(2)
      vr=1d0/v
      vr2=vr*vr
      vr3=vr*vr2
      vr4=vr*vr3
      phi10n=aav1*v+aav2*vr+(aaz1*yr+aaz2+aaz3*y)*zr
      phi11n=abv1+abv2*vr2+((abz1*yr+abz2)*yr+abz3)*yr
      phi20n=adv1*v+adv2*vr+adv6*vr3+z*((adv3+yr*(adv4+yr*adv5))*vr2+
     ,(adz1+yr*(adz2+yr*(adz3+yr*(adz4+yr*(adz5+yr*adz6))))))
      phi21n=aev1+(aev2+yr*(aev3+yr*(aev4+yr*aev5)))*vr2+
     ,z*(aev6+yr*(aev7+yr*aev8))*vr3+aev9*vr4+
     ,yr*(aez1+yr*(aez2+yr*(aez3+yr*(aez4+yr*(aez5+yr*aez6)))))
      return
      end

c programm calculates functions phi_1(v) and phi_2(v) and their derivati
c for v_{-}, zeta>=0, phi_j=y^{5/2}*p_j(y), phi_j'=y*p_{j1}(y), y=zeta^2
      subroutine ph01tg(z,v,phi10g,phi11g,phi20g,phi21g)
      implicit real*8(a-h,o-z)
      common /warg/ artgm(30)
      data c13 /0.3333333333333333d0/
      data zlim /0.9d0/

      data aa1 / 0.438095238095238d-02/ ! 23/5250
      data aa2 / 0.612244897959184d-02/ ! 3/490
      data aa3 / 0.416666666666667d-01/ ! 1/24
      data aa4 /-0.568181818181818d-01/ ! -5/88

      data ab10 /-0.131428571428571d-01/  ! -23/1750
      data ab11 /0.457142857142857d-02/  ! 4/875
      data ab20 /-0.183673469387755d-01/  ! -9/490
      data ab21 / 0.596938775510204d-01/  ! 117/1960
      data ab30 /-0.125000000000000d+00/  ! -1/8
      data ab31 /-0.250000000000000d+00/  ! -1/4
      data ab40 / 0.170454545454545d+00/  ! 15/88

      data ad10 / 0.789051184492001d-02/ ! 5224793159/662161500000
      data ad11 / 0.451342199750363d-03/ ! 24905119/55180125000
      data ad12 /-0.625772395405049d-03/ ! -3139109/5016375000
      data ad20 /0.740895804875397d-02/ ! 21804119/2942940000
      data ad21 / 0.692858162245917d-04/ ! 2124/30655625
      data ad22 /-0.642879569410182d-03/ ! -14333/22295000
      data ad30 / 0.810192056620628d-02/ ! 471629/58212000
      data ad31 /-0.627705627705628d-03/ ! -29/46200
      data ad32 /-0.154195011337869d-02/ ! -17/11025
      data ad40 / 0.104130591630592d-01/ ! 5773/554400
      data ad41 /-0.194444444444444d-02/ ! -7/3600
      data ad42 / 0.219223484848485d-01/ ! 463/21120
      data ad50 / 0.172390109890110d-01/ ! 251/14560
      data ad51 /-0.493303571428571d-01/ ! -221/4480
      data ad52 /-0.193526785714286d+00/ ! -867/4480
      data ad60 / 0.130729166666667d+00/ ! 251/1920
      data ad61 / 0.230208333333333d+00/ ! 221/960
      data ad62 / 0.345312500000000d+00/ ! 221/640
      data ad70 /-0.192248774509804d+00/ ! -1255/6528
      data ad71 /-0.169270833333333d+00/ ! -65/384

      data ae10 /-0.710146066042801d-01/ ! -5224793159/73573500000
      data ae11 /-0.430123547201098d-02/ ! -79114237/18393375000
      data ae12 / 0.419736981385961d-02/ ! 2339509/557375000
      data ae13 /-0.977285789040891d-03/ ! -204268/209015625
      data ae20 /-0.666806224387857d-01/ ! -65412357/980980000
      data ae21 /-0.636783624538727d-03/ ! -19521/30655625
      data ae22 / 0.381988215865767d-02/ ! 936807/245245000
      data ae23 /-0.262538685803992d-02/ ! -58533/22295000
      data ae30 /-0.729172850958565d-01/ ! -471629/6468000
      data ae31 / 0.609461966604824d-02/ ! 657/107800
      data ae32 / 0.337043908472480d-02/ ! 109/32340
      data ae33 / 0.819238945578231d-01/ ! 38537/470400
      data ae40 /-0.937175324675325d-01/ ! -5773/61600
      data ae41 / 0.225324675324675d-01/ ! 347/15400
      data ae42 /-0.182366071428571d+00/ ! -817/4480
      data ae43 /-0.120933441558442d+01/ ! -14899/12320
      data ae50 /-0.155151098901099d+00/ ! -2259/14560
      data ae51 / 0.464062500000000d+00/ ! 297/640
      data ae52 / 0.174174107142857d+01/ ! 7803/4480
      data ae53 / 0.375669642857143d+01/ ! 1683/448
      data ae60 /-0.117656250000000d+01/ ! -753/640
      data ae61 /-0.216562500000000d+01/ ! -693/320
      data ae62 /-0.310781250000000d+01/ ! -1989/640
      data ae63 /-0.414375000000000d+01/ ! -663/160
      data ae70 / 0.173023897058824d+01/ ! 3765/2176
      data ae71 / 0.159237132352941d+01/ ! 3465/2176
      data ae72 / 0.152343750000000d+01/ ! 195/128

      data aav1 /-0.219047619047619d-01/ ! -23d0/1050d0
      data aav2 / 0.694444444444445d-01/ ! 5d0/72d0
      data aaz1 /-0.208333333333333d+00/ ! -5d0/24d0
      data aaz2 /-0.125000000000000d+00/ ! -1d0/8d0
      data aaz3 / 0.142857142857143d-01/ ! 1d0/70d0

      data abv1 /-0.761904761904762d-02/ ! -4d0/525d0
      data abv2 /-0.694444444444445d-01/ ! -5d0/72d0
      data abz1 / 0.625000000000000d+00/ ! 5d0/8d0
      data abz2 / 0.750000000000000d+00/ ! 3d0/4d0
      data abz3 / 0.139285714285714d+00/ ! 39d0/280d0

      data adv1 / 0.312886197702524d-02/ ! 3139109d0/1003275000d0
      data adv2 /-0.152116402116402d-02/ ! -23d0/15120d0
      data adv3 /-0.992063492063492d-03/ ! -1d0/1008d0
      data adv4 / 0.868055555555556d-02/ ! 5d0/576d0
      data adv5 / 0.144675925925926d-01/ ! 25d0/1728d0
      data adv6 /-0.403485082304527d-01/ ! -1255d0/31104d0
      data adz1 /-0.150005232862376d-02/ ! -14333d0/9555000d0
      data adz2 / 0.462585034013606d-02/ ! 17d0/3675d0
      data adz3 / 0.803819444444445d-01/ ! 463d0/5760d0
      data adz4 / 0.838616071428571d+00/ ! 3757d0/4480d0
      data adz5 / 0.172656250000000d+01/ ! 221d0/128d0
      data adz6 / 0.959201388888889d+00/ ! 1105d0/1152d0

      data aev1 / 0.162880964840149d-02/ ! 204268d0/125409375d0
      data aev2 / 0.529100529100529d-03/ ! 1d0/1890d0
      data aev3 /-0.967261904761905d-02/ ! -13d0/1344d0
      data aev4 /-0.520833333333333d-01/ ! -5d0/96d0
      data aev5 /-0.434027777777778d-01/ ! -25d0/576d0
      data aev6 / 0.198412698412698d-02/ ! 1d0/504d0
      data aev7 /-0.173611111111111d-01/ ! -5d0/288d0
      data aev8 /-0.289351851851852d-01/ ! -25d0/864d0
      data aev9 / 0.121045524691358d+00/ ! 1255d0/10368d0
      data aez1 /-0.612590266875981d-02/ ! -19511d0/3185000d0
      data aez2 /-0.245771683673469d+00/ ! -38537d0/156800d0
      data aez3 /-0.443422619047619d+01/ ! -14899d0/3360d0
      data aez4 /-0.162790178571429d+02/ ! -7293d0/448d0
      data aez5 /-0.207187500000000d+02/ ! -663d0/32d0
      data aez6 /-0.863281250000000d+01/ ! -1105d0/128d0

      y=z*z
      if(z.gt.zlim) goto 100
      call dartgm(z,9)
      v0=artgm(2)
      v1=artgm(3)
      v2=artgm(4)
      v3=artgm(5)
      v4=artgm(6)
      v5=artgm(7)
      v6=artgm(8)
      v7=artgm(9)
      v=c13*y*z*v0
      v01=v0+1d0
      v02=v0*v0
      v03=v0*v02
      v04=v0*v03
      p10g=aa1*v01*v1+aa2*v2+aa3*v3+aa4*v4
      p11g=(ab10+ab11*v0)*v1+(ab20+ab21*v0)*v2+(ab30+ab31*v0)*v3+
     ,ab40*v01*v4
      p20g=(ad10+ad11*v0+ad12*v02*v01)*v1+
     ,(ad20+ad21*v0+ad22*v02)*v2+
     ,(ad30+ad31*v0+ad32*v02)*v3+
     ,(ad40+ad41*v0+ad42*v02)*v4+
     ,(ad50+ad51*v0+ad52*v02)*v5+
     ,(ad60+ad61*v0+ad62*v02)*v6+
     ,(ad70+ad71*v0*v01)*v7
      p21g=(ae10+ae11*v0+ae12*v02+ae13*v03)*v1+
     ,(ae20+ae21*v0+ae22*v02+ae23*v03)*v2+
     ,(ae30+ae31*v0+ae32*v02+ae33*v03)*v3+
     ,(ae40+ae41*v0+ae42*v02+ae43*v03)*v4+
     ,(ae50+ae51*v0+ae52*v02+ae53*v03)*v5+
     ,(ae60+ae61*v0+ae62*v02+ae63*v03)*v6+
     ,(ae70+ae71*v0+ae72*v02*v01)*v7
      y52=y*y*z
      phi10g=y52*p10g/v0
      phi11g=y*p11g/v02
      phi20g=y52*p20g/v03
      phi21g=y*p21g/v04
      return
  100 continue
      zr=1d0/z
      yr=zr*zr
      yr2=yr*yr
      yr3=yr*yr2
      zyr=zr*yr
      call dartgm(z,1)
      v=c13*z*y*artgm(2)
      vr=1d0/v
      vr2=vr*vr
      vr3=vr*vr2
      vr4=vr*vr3
      vr5=vr*vr4
      phi10g=aav1*v+aav2*vr+(aaz1*yr+aaz2+aaz3*y)*zr
      phi11g=abv1+abv2*vr2+((abz1*yr+abz2)*yr+abz3)*yr
      phi20g=adv1*v+adv2*vr+adv6*vr3+z*((adv3+yr*(adv4+yr*adv5))*vr2+
     ,(adz1+yr*(adz2+yr*(adz3+yr*(adz4+yr*(adz5+yr*adz6))))))
      phi21g=aev1+(aev2+yr*(aev3+yr*(aev4+yr*aev5)))*vr2+
     ,z*(aev6+yr*(aev7+yr*aev8))*vr3+aev9*vr4+
     ,yr*(aez1+yr*(aez2+yr*(aez3+yr*(aez4+yr*(aez5+yr*aez6)))))
      return
      end

c programm calculates residuals of artg(x)/x series, v_0=artg(x)/x
c v_m(x)=sum_{n=0}^infty (-1)^n(2m+3)/(2m+2n+3)x^m
c v_m=1+(-1)^m(2m+3)/(2m+5)*x*v_{m+1}
c x>=0, x=x, artgm(m)=v_{m-1}
      subroutine dartgm(x,m)
      implicit real*8(a-h,o-z)
      common /warg/ artgm(30)
      data pis /1.570796326794897d0/
      data eps,zlim /1d-9,0.9d0/
      if(x.lt.0d0) goto 70
      mp1=m+1
      dmt=2d0*m+1d0
      if(x.gt.zlim) goto 40
      xs=-x*x
      vm=1d0
      dn=2d0
      xn=xs
      an=1d0
      do while (dabs(an).ge.eps)
         an=xn*dmt/(dmt+dn)
         vm=vm+an
         xn=xs*xn
         dn=dn+2d0
      enddo
      artgm(mp1)=vm
      if(m.eq.0) return
      do 20 mn=1,m
         mn1=mn-1
         dd=dmt-2d0*mn
         artgm(m-mn1)=1d0+xs*dd/(dd+2d0)*artgm(mp1-mn1)
   20 continue
      return
   40 continue
      xr=1d0/x
      if(x.le.1d0) then
          artgm(1)=datan(x)*xr
        else
          artgm(1)=(pis-datan(xr))*xr
      endif
      if(m.eq.0) return
      do 50 mn=1,m
         dmn=2d0*mn-1d0
         artgm(mn+1)=(1d0-artgm(mn))*(dmn+2d0)*xr*xr/dmn
   50 continue
      return
   70 continue
      write(6,2003) x
      return
 2003 format(1x,'negative x=',3x,d12.5)
      end

c programm calculates residuals of arth(x)/x series, v_0=arth(x)/x
c v_m(x)=sum_{n=0}^infty (2m+3)/(2m+2n+3)x^m
c v_m=1+(2m+3)/(2m+5)*x*v_{m+1}
c 0=<x<1, x=x,x1=1-x, arthm(m)=v_{m-1}
      subroutine darthm(x,x1,m)
      implicit real*8(a-h,o-z)
c      common /ww/ eps,zlim,ylim
      common /warh/ arthm(30)
      data eps,zlim /1d-9,0.9d0/
      if((x.lt.0d0).or.(x.ge.1d0)) goto 70
      mp1=m+1
      dmt=2d0*m+1d0
      if(x.gt.zlim) goto 40
      xs=x*x
      vm=1d0
      dn=2d0
      xn=xs
      an=1d0
      do while (an.ge.eps)
         an=xn*dmt/(dmt+dn)
         vm=vm+an
         xn=xs*xn
         dn=dn+2d0
      enddo
      arthm(mp1)=vm
      if(m.eq.0) return
      do 20 mn=1,m
         mn1=mn-1
         dnmt=2d0*mn
         dd=dmt-dnmt
         arthm(m-mn1)=1d0+xs*dd/(dd+2d0)*arthm(mp1-mn1)
   20 continue
      return
   40 continue
      xr=1d0/x
      arthm(1)=0.5d0*dlog((1d0+x)/x1)*xr
      if(m.eq.0) return
      do 50 mn=1,m
         dmn=2d0*mn-1d0
         arthm(mn+1)=(arthm(mn)-1d0)*(dmn+2d0)*xr*xr/dmn
   50 continue
      return
   70 continue
      write(6,2005) x
      return
 2005 format(1x,'must be 0=<x<1',3x,'x=',3x,d12.5)
      end

c subroutine di13ml(x) calculates for given argument x from [-8,8]
c the value of the Bessel function x^{1/3}I_{-1/3}(x) through its
c expansion on the Chebyshev polinomials of even order
c Luke, Special mathematical functions and their approximations,
c ``MIR'', Moscow, 1980, 608 pp., table 9.18, p. 373
      function di13ml(x)
      implicit real*8(a-h,o-z)
      dimension a(19)
      data nout /6/
      data a / 246.76446 77610 21950 14476d0,
     1         374.90419 63977 61772 38356d0,
     2         168.94690 54665 51934 32342d0,
     3          47.81292 47970 09021 28986d0,
     4           9.02594 18911 35278 81180d0,
     5           1.19852 10167 30412 23176d0,
     6           0.11697 76116 93126 92166d0,
     7           0.00869 83095 97421 34176d0,
     8           0.00050 74091 61720 07577d0,
     9           0.00002 37873 65337 43276d0,
     ,           0.00000 09143 62383 07318d0,
     1           0.00000 00293 09947 86363d0,
     2           0.00000 00007 94846 32582d0,
     3           0.00000 00000 18462 55797d0,
     4           0.00000 00000 00371 27729d0,
     5           0.00000 00000 00006 52493d0,
     6           0.10105d-15,0.139d-17,0.2d-19/
c
      w=x*0.125d0
      di13ml=dcheb0(a,w,18,2,nout)
      return
      end

c subroutine di13pl(x) calculates for given argument x from [-8,8]
c the value of the Bessel function x^{-1/3}I_{1/3}(x) through its
c expansion on the Chebyshev polinomials of even order
c Luke, Special mathematical functions and their approximations,
c ``MIR'', Moscow, 1980, 608 pp., table 9.18, p. 373
      function di13pl(x)
      implicit real*8(a-h,o-z)
      dimension a(18)
      data nout /6/
      data a / 65.17366 54884 16526 95482d0,
     1         95.23190 27040 92163 97860d0,
     2         39.59331 03435 21063 45067d0,
     3         10.20622 18597 97178 58861d0,
     4          1.75552 58978 34803 58155d0,
     5          0.21351 04236 00373 85749d0,
     6          0.01921 26868 62831 23642d0,
     7          0.00132 57975 71063 41284d0,
     8          0.00007 22075 54088 40446d0,
     9          0.00000 31776 13642 90919d0,
     ,          0.00000 01152 07184 65074d0,
     1          0.00000 00034 97935 67902d0,
     2          0.00000 00000 90183 77386d0,
     3          0.00000 00000 01998 07607d0,
     4          0.00000 00000 00038 43793d0,
     5          0.00000 00000 00000 64790d0,
     6          0.965d-17,0.13d-18/
c
      w=x*0.125d0
      di13pl=dcheb0(a,w,17,2,nout)
      return
      end

c subroutine dj13ml(x) calculates for given argument x from [-8,8]
c the value of the Bessel function x^{1/3}J_{-1/3}(x) through its
c expansion on the Chebyshev polinomials of even order
c Luke, Special mathematical functions and their approximations,
c ``MIR'', Moscow, 1980, 608 pp., table 9.12, p. 365
      function dj13ml(x)
      implicit real*8(a-h,o-z)
      dimension a(19)
      data nout /6/
      data a / 0.15921 18677 83189 60054d0,
     1         0.13935 64007 14896 26069d0,
     2         0.05406 07319 77580 98869d0,
     3        -0.49889 25940 08176 73779d0,
     4         0.27634 28099 41437 09958d0,
     5        -0.06962 17491 14124 72070d0,
     6         0.01050 51479 21580 21916d0,
     7        -0.00107 36049 94092 01433d0,
     8         0.00007 98632 63462 05385d0,
     9        -0.00000 45371 68415 38583d0,
     ,         0.00000 02038 09350 93453d0,
     1        -0.00000 00074 32215 74519d0,
     2         0.00000 00002 24648 92145d0,
     3        -0.00000 00000 05724 18891d0,
     4         0.00000 00000 00124 68853d0,
     5        -0.00000 00000 00002 34948d0,
     6         0.00000 00000 00000 03868d0,
     7        -0.56d-18,0.1d-19/
c
      w=x*0.125d0
      dj13ml=dcheb0(a,w,18,2,nout)
      return
      end

c subroutine dj13pl(x) calculates for given argument x from [-8,8]
c the value of the Bessel function x^{-1/3}J_{1/3}(x) through its
c expansion on the Chebyshev polinomials of even order
c Luke, Special mathematical functions and their approximations,
c ``MIR'', Moscow, 1980, 608 pp., table 9.12, p. 365
      function dj13pl(x)
      implicit real*8(a-h,o-z)
      dimension a(18)
      data nout /6/
      data a / 0.13437 97942 27756 44764d0,
     1        -0.11984 86974 10732 73261d0,
     2         0.28710 68687 28687 47721d0,
     3        -0.24251 07291 97801 31136d0,
     4         0.08569 82591 68484 14668d0,
     5        -0.01691 33949 03176 58537d0,
     6         0.00215 74934 76006 00765d0,
     7        -0.00019 38490 54788 73423d0,
     8         0.00001 29832 45927 14860d0,
     9        -0.00000 06748 56479 41628d0,
     ,         0.00000 00280 59239 71246d0,
     1        -0.00000 00009 55461 01654d0,
     2         0.00000 00000 27154 60828d0,
     3        -0.00000 00000 00654 22144d0,
     4         0.00000 00000 00013 53678d0,
     5        -0.00000 00000 00000 24324d0,
     6         0.00000 00000 00000 00383d0,
     7        -0.5d-19/
c
      w=x*0.125d0
      dj13pl=dcheb0(a,w,17,2,nout)
      return
      end

c subroutine dk13gs(x) calculates for given argument x>=5
c the value of the Bessel function exp(x)*sqrt(2*x/pi)K_{1/3}(x)
c through its expansion on the Chebyshev displased polinomials
c Luke, Special mathematical functions and their approximations,
c ``MIR'', Moscow, 1980, 608 pp., table 9.18, p. 374
      function dk13gs(x)
      implicit real*8(a-h,o-z)
      dimension d(21)
      data nout /6/
      data d / 0.99353 64122 76093 38920d0,
     1        -0.00631 44392 60798 63137d0,
     2         0.00014 30095 80961 13131d0,
     3        -0.00000 57870 60592 02472d0,
     4         0.00000 03265 50333 19976d0,
     5        -0.00000 00231 23231 95077d0,
     6         0.00000 00019 39555 14434d0,
     7        -0.00000 00001 85897 88507d0,
     8         0.00000 00000 19868 42439d0,
     9        -0.00000 00000 02326 78966d0,
     ,         0.00000 00000 00294 68313d0,
     1        -0.00000 00000 00039 95293d0,
     2         0.00000 00000 00005 75225d0,
     3        -0.00000 00000 00000 87375d0,
     4  0.13927d-15,-0.2319d-16,0.402d-17,-0.72d-18,
     8  0.13d-18,-0.3d-19,0.1d-19/
c
      w=5d0/x
      dk13gs=dcheb0(d,w,20,3,nout)
      return
      end

c subroutine yj13gs(x) calculates for given argument |x|>5
c the combinations of values of the Bessel functions
c namely the real yjr and imaginary yji parts of the complex sum
c (\pi x/2)^{1/2}[J_{1/3}(x)+i Y_{1/3}(x)]e^{-i(x-\pi/4-\pi\nu/2)}
c through their expansions on the Chebyshev even polinomials
c Luke, Special mathematical functions and their approximations,
c ``MIR'', Moscow, 1980, 608 pp., table 9.12, p. 365
      subroutine yj13gs(x,yjr,yji)
      implicit real*8(a-h,o-z)
      dimension br(22),bi(22)
      data nout /6/
      data br / 0.99946 50123 35293 52860d0,
     1         -0.00070 77638 36250 14260d0,
     2         -0.00016 87952 26919 56340d0,
     3          0.00000 43855 75455 07034d0,
     4          0.00000 03580 42553 40564d0,
     5         -0.00000 00464 10843 62258d0,
     6          0.00000 00007 21026 33596d0,
     7          0.00000 00004 73021 33710d0,
     8         -0.00000 00000 70556 54580d0,
     9          0.00000 00000 01600 09976d0,
     ,          0.00000 00000 01288 42696d0,
     1         -0.00000 00000 00282 67591d0,
     2          0.00000 00000 00021 03354d0,
     3          0.00000 00000 00004 44013d0,
     4         -0.00000 00000 00001 82827d0,
     5          0.00000 00000 00000 29922d0,
     6         -0.00000 00000 00000 00462d0,
     7         -0.1232d-16,0.398d-17,-0.63d-18,
     ,         -0.1d-19,0.4d-19/
      data bi /-0.00685 69474 27212 69534d0,
     1         -0.00681 43334 21755 53208d0,
     2          0.00005 01456 42019 67809d0,
     3          0.00000 71142 29548 86394d0,
     4         -0.00000 04367 92366 55846d0,
     5         -0.00000 00141 58283 43520d0,
     6          0.00000 00049 24417 94772d0,
     7         -0.00000 00003 454775 277630,
     8         -0.00000 00000 31070 98997d0,
     9          0.00000 00000 11008 31850d0,
     ,         -0.00000 00000 01162 71069d0,
     1         -0.00000 00000 00063 01191d0,
     2          0.00000 00000 00046 74357d0,
     3         -0.00000 00000 00008 46207d0,
     4          0.00000 00000 00000 37472d0,
     5          0.00000 00000 00000 23430d0,
     6         -0.00000 00000 00000 08025d0,
     7          0.1257d-16,0.9d-19,-0.68d-18,
     ,          0.22d-18,-0.4d-19 /
c
      w=5d0/x
      yjr=dcheb0(br,w,21,0,nout)
      yji=dcheb0(bi,w,21,0,nout)
      return
      end

c subprogram for calculation of gamma-function gamma(1+x) for real argum
c and gamma(m+x)=(m-1+x)(m-2+x)...(1+x)gamma(1+x)
      function dgam(xx)
      implicit real*8(a-h,o-z)
      dimension a(30)
      data xl,eps /3.2d0,1d-17/
      data a /1.00000 00000 00000 00000d0,
     1         0.57721 56649 01532 86061d0,
     2       -0.65587 80715 20253 88108d0,
     3       -0.04200 26350 34095 23553d0,
     4        0.16653 86113 82291 48950d0,
     5       -0.04219 77345 55544 33675d0,
     6       -0.00962 19715 27876 97356d0,
     7        0.00721 89432 46663 09954d0,
     8       -0.00116 51675 91859 06511d0,
     9       -0.00021 52416 74114 95097d0,
     ,        0.00012 80502 82388 11619d0,
     1       -0.00002 01348 54780 78824d0,
     2       -0.00000 12504 93482 14267d0,
     3        0.00000 11330 27231 98170d0,
     4       -0.00000 02056 33841 69776d0,
     5        0.00000 00061 16095 10448d0,
     6        0.00000 00050 02007 64447d0,
     7       -0.00000 00011 81274 57049d0,
     8        0.00000 00001 04342 67117d0,
     9        0.00000 00000 07782 26344d0,
     ,       -0.00000 00000 03696 80562d0,
     1        0.00000 00000 00510 03703d0,
     2       -0.20 58326d-13,-0.5 34812d-14,
     4        0.1 22678d-14,-0.11813d-15,
     6        0.119d-17,0.141d-17,
     8       -0.23d-18,0.2d-19/
c
      ddg=1d0
      dgam=0d0
      x=xx-1d0
      if(x.lt.xl) goto 300
      nxn=idint(x)
      x=x-nxn*1d0
      do nx=1,nxn
         ddg=ddg*(xx-nx*1d0)
      enddo
  300 continue
c      write(6,2000) nxn
c      write(6,2001) xx,x,ddg
      s=0d0
      xn=1d0
      do n=1,30
         sn=a(n)*xn
         s=s+sn
         if(dabs(sn).lt.eps) goto 330
         xn=x*xn
      enddo
  330 continue
      dgam=ddg/s
      return
 2000 format(1x,4i4)
 2001 format(1x,5d12.5)
      end

c subprogram calculates for given first n+1 elements of the vector a
c coefficients of the expansion on the Chebyshev polinomials and the
c argument x the following value:
c f(n,x)=sum_{k=0}^n a(k) T(l(key),x).
cHere the key
c  0  - subsequent integers,
c  1  -  odd numbers,
c  2  - even numbers,
c  3  - displased
c by using the Klenshoe summing algorithm
c nout --- the number of the canal of messages of the program
c Luke, Special mathematical functions and their approximations,
      function dcheb0(a,x,n,key,nout)
      implicit real*8 (a-h,o-z)
      dimension a(n)
      data c0,c2,c4 /0d0,2d0,4d0/
      data cmax /1d76/
c control of the maximal number of terms
      ier=0
      if(n) 3,5,7
c the reaction to negative number
    3 write(nout,1000)
      dcheb0=cmax
      ier=1
c control the key
    5 if((key.ge.0).and.(key.le.3)) goto 7
c reaction to the erroneous value of the key
      write(nout,1001)
      dcheb0=1d76
      ier=1
    7 if(ier.ne.0) return
      n1=n+1
      if(key.eq.0) z=c2*x
      if(key.eq.1) z=c4*x*x-c2
      if(key.eq.2) z=c4*x*x-c2
      if(key.eq.3) z=c4*x-c2
      b0=c0
      b1=c0
      do 10 i=1,n1
        k=n1-i
        b2=b1
        b1=b0
        b0=z*b1-b2+a(k+1)
   10 continue
      if(key.eq.0) dcheb0=b0-x*b1
      if(key.eq.1) dcheb0=x*(b0-b1)
      if(key.eq.2) dcheb0=b0-b1*z/c2
      if(key.eq.3) dcheb0=b0-b1*z/c2
      return
 1000 format(1x,'dcheb0: the third parameter is negative.')
 1001 format(1x,'dcheb0: erroneous value of the key')
      end

c subroutine calculates the function J_0(x) for given x
      function dj0(x)
      implicit real*8(a-h,o-z)
      data pif,pis /0.785398163397448d0,1.570796326794897d0/
      if(x.lt.6d0) then
          dj0=dj0l(x)
        else
          call yj0g(x,yjr0,yji0)
          xpi=x-pif
          dj0=(dcos(xpi)*yjr0-dsin(xpi)*yji0)/dsqrt(pis*x)
      endif
      return
      end

c subroutine dj0l(x) calculates for given argument x <-8=<x=<8
c the values of the Bessel function J_0(x)
c the real yjr and imaginary yji parts of the complex sum
c through its expansion on the Chebyshev even polinomials
c Luke, Special mathematical functions and their approximations,
c ``MIR'', Moscow, 1980, 608 pp., table 9.1, p. 344
      function dj0l(x)
      implicit real*8(a-h,o-z)
      dimension a(18)
      data nout /6/
      data a /   0.15772 79714 74890 11956d0,
     1          -0.00872 34423 52852 22129d0,
     2           0.26517 86132 03336 80987d0,
     3          -0.37009 49938 72649 77903d0,
     4           0.15806 71023 32097 26128d0,
     5          -0.03489 37694 11408 88516d0,
     6           0.00481 91800 69467 60450d0,
     7          -0.00046 06261 66206 27505d0,
     8           0.00003 24603 28821 00508d0,
     9          -0.00000 17619 46907 76215d0,
     ,           0.00000 00760 81635 92419d0,
     1          -0.00000 00026 79253 53056d0,
     2           0.00000 00000 78486 96314d0,
     3          -0.00000 00000 01943 83469d0,
     4           0.00000 00000 00041 25321d0,
     5          -0.00000 00000 00000 75885d0,
     6           0.1222d-16,-0.17d-18 /
c
      w=x*0.125d0
      dj0l=dcheb0(a,w,17,2,nout)
      return
      end

c the subprogram yj0g(x,dre0,dim0) calculates for the given argument x>=5
c the values of the Bessel function:
c dre0=Re([J_0(x) +i*Y_0(x)]*sqrt(pi*x/2)*exp(i*(pi/4-x))) and
c dim0=Im([J_0(x)+i*Y(0,x)]*sqrt(pi*x/2)exp(i*(pi/4-x)))
c through their expansions of the even Chebyshev polinomials
c Luke, Special mathematical functions and their approximations,
c ``MIR'', Moscow, 1980, 608 pp., table 9.1, p. 344
c if re and im are found then the functions J_0(x) and
c with the formulae
cJ_0(x)=sqrt(2/(pi*x))*[dre0*cos(pi/4-x)+dim0*sin( pi/4-x)],
cY_0(x)=sqrt\(2/(pi*x))*[dim0*cos(pi/4-x )-dre0 * sin( pi/4-x )].
      subroutine yj0g(x,dre0,dim0)
      implicit real*8(a-h,o-z)
      dimension dr(23),di(22)
      data nout /6/
      data dr/ 0.99898 80898 58965 15390d0,
     1        -0.00133 84285 49971 85578d0,
     2        -0.00031 87898 78061 89289d0,
     3         0.00000 85112 32210 65665d0,
     4         0.00000 06915 42349 13894d0,
     5        -0.00000 00907 70101 53734d0,
     6         0.00000 00014 54928 07929d0,
     7         0.00000 00009 26762 48672d0,
     8        -0.00000 00001 39166 19797d0,
     9         0.00000 00000 03237 97518d0,
     ,         0.00000 00000 02535 35729d0,
     1        -0.00000 00000 00559 09032d0,
     2         0.00000 00000 00041 91896d0,
     3         0.00000 00000 00008 73316d0,
     4        -0.00000 00000 00003 61861d0,
     5 0.59438d-15,-0.964d-17,-0.2436d-16,0.789d-17,
     9-0.125d-17,-0.2d-19,0.8d-19,-0.3d-19 /
      data di/-0.01233 15205 78544 14382d0,
     1        -0.01224 94962 81259 47486d0,
     2         0.00009 64941 84993 42287d0,
     3         0.00001 36555 70490 35682d0,
     4        -0.00000 08518 06644 42635d0,
     5        -0.00000 00272 44053 41355d0,
     6         0.00000 00096 46421 33771d0,
     7        -0.00000 00006 83347 51799d0,
     8        -0.00000 00000 60627 38000d0,
     9         0.00000 00000 21695 71634d0,
     ,        -0.00000 00000 02304 89890d0,
     1        -0.00000 00000 00122 55390d0,
     2         0.00000 00000 00092 31372d0,
     3        -0.00000 00000 00016 77838d0,
     4         0.00000 00000 00000 75375d0,
     5 0.46244d-15,-0.15906d-15, 0.2500d-16,0.15d-18,
     9-0.135d-17, 0.44d-18,-0.7d-19 /
      w=5d0/x
      dre0=dcheb0(dr,w,22,3,nout)
      dim0=dcheb0(di,w,21,3,nout)
      return
      end

c the subprogram yj1g(x,dre1,dim1) calculates for the given argument x>=5
c the values of the Bessel function:
c dre1=Re([J_1(x)+i Y_1(x)]sqrt(pi*x/2)exp(i(pi/4-x))) and
c dim1=Im([J_0(x)+i Y(0,x)]sqrt(pi*x/2)exp(i(pi/4-x)))
c through their expansions of the even Chebyshev polinomials
c Luke, Special mathematical functions and their approximations,
c ``MIR'', Moscow, 1980, 608 pp., table 9.2, p. 346
c if dre1 and dim1 are found then the functions J_1(x) and Y_1(x)
c can be calculated with the formulae
c J_1(x)=sqrt(2/(pi*x)) [dre1 cos(3 pi/4-x)+dim1*sin(3 pi/4-x)],
c Y_1(x)=sqrt\(2/(pi*x) [dim1*cos(3 pi/4-x)-dre1*sin(3 pi/4-x )].
      subroutine yj1g(x,dre1,dim1)
      implicit real*8(a-h,o-z)
      dimension dr(24),di(24)
      data nout /6/
      data dr/ 1.00170 22348 53820 99565d0,
     1         0.00225 55728 46561 17976d0,
     2         0.00054 32164 87508 01325d0,
     3        -0.00001 11794 61895 40836d0,
     4        -0.00000 09469 01382 39192d0,
     5         0.00000 01110 32677 12082d0,
     6        -0.00000 00012 94398 92684d0,
     7        -0.00000 00011 14905 94420d0,
     8         0.00000 00001 57637 23196d0,
     9        -0.00000 00000 02830 45747d0,
     ,        -0.00000 00000 02932 16857d0,
     1         0.00000 00000 00617 80854d0,
     2        -0.00000 00000 00043 16153d0,
     3        -0.00000 00000 00010 13289d0,
     4         0.00000 00000 00003 97343d0,
     5 -0.63161d-15, 0.575d-17, 0.2696d-16,-0.847d-17,
     9  0.130d-17, 0.3d-19,-0.9d-19, 0.3d-19,-0.1d-19 /
      data di/ 0.03726 17150 00537 65365d0,
     1         0.03714 53224 79807 68994d0,
     2        -0.00013 72632 38201 90679d0,
     3        -0.00001 98512 94687 59687d0,
     4         0.00000 10700 14057 38568d0,
     5         0.00000 00383 05261 71449d0,
     6        -0.00000 00116 28723 27663d0,
     7         0.00000 00007 59733 09244d0,
     8         0.00000 00000 75476 07460d0,
     9        -0.00000 00000 24752 78088d0,
     ,         0.00000 00000 02493 89256d0,
     1         0.00000 00000 00156 19784d0,
     2        -0.00000 00000 00103 38521d0,
     3         0.00000 00000 00018 12876d0,
     4        -0.00000 00000 00000 70876d0,
     5 -0.52042d-15, 0.17235d-15,-0.2625d-16,-0.38d-18,
     9  0.148d-17,-0.47d-18, 0.8d-19,0d0,-0.1d-19/
      w=5d0/x
      dre1=dcheb0(dr,w,23,3,nout)
      dim1=dcheb0(di,w,23,3,nout)
      return
      end


	FUNCTION FINT (X,Y1,Y2,Y3,X1,X2,X3)
	D1=X-X1
	D2=X-X2
	D3=X-X3
	D12=X1-X2
	D13=X1-X3
	D23=X2-X3
	FINT=Y1*D2*D3/(D12*D13)-Y2*D1*D3/(D12*D23)+Y3*D1*D2/(D13*D23)
	RETURN
	END