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

!--------------------------------------------------------------------------------------
!   This module contains code to perform a double integration using Gauss-Legendre formula
!   Contest Implementation of Higher Order Panel Methods version 1.0
!
!   @author yedtoss
!   @version 1.0
!--------------------------------------------------------------------------------------

!     VERSIONS: gaussm3
!   This is based on gaussm2 - but with major changes that WEIGHTS & ABSCISSAS are no longer common variables
!     They are obtained from gauleg as local variables. User must specify what order of integration (# Gaussian Pts)
!     Consequently, all Gaussian Quadrature routines are modified with CALL gauleg.

!
!     9/9/98 - All ALLOCATED variables (pointers & allocatables) have been deallocated except for
!       WEIGhts and ABSCissas

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! NOTES
! 1. This MODULE can be compiled on its own like header file.
!    Then a *.lib file is created. To use functions in module,
!     must have "USE module_name" statement.
! 2. FATAL -- Specification of assumed size may be done for last dimension only.
!        a(*,*) wrong      a(9,*) correct
! 3. But -- Specification of assumed shape can be done in ANY dimension
!        a(:,:)  O.K.
! 4. "Module" is different from "include". Non-module files which have functions
!    can be included when compiling main file by using "INCLUDE" inside the main
!    file.
! 5. Dummy arguments cannot be ALLOCATABLE. !!BUT!! Dummy arguments can have
!    assumed shapes such as a(:,:)
! 6. INTENT must be used with dummy argument only.
! 7. Array must not have both ALLOCATABLE and POINTER attributes, but
!    pointers can be ALLOCATED.
! 8. POINTER array (eg. ans) must be declared with a deferred shape specification
!    (see "Dynamic Arrays" in the Lahey Fortran 90 Language Reference).
!    ans(3,4)  wrong          ans(:,:) correct
! 9. When dummy arguments are pointers, their actual argument must be pointers
!    too; and vice versa.
! 10. Intrinsic function MAXLOC(find location of maximum element e.g. in a list)
!       returns an ARRAY.
! 11. Intrinsic function MATMUL for Matrix Multiplication can handle REAL of
!     selected_kind (eg. double precision)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!  1. Topics: Gaussian elimination solution of linear equations & Gaussian Qudrature!
!   2. The variables in this module are GLOBALLY COMMON to all PROGRAM UNITS that "use"s
! this module and all INTERNAL subprograms within this module. The common variables are the
! Gauss-Legendre abscissas and weights for the Gaussian Qudrature.
!   3. The user must first call "gauleg" from the main program to set up all the abscissas
! and weights.

module gaussm3

 USE COMMON_TYPE

                        ! Common Global variables within module !
    !implicit none
   INTEGER, parameter :: dbp = 1
!   PRIVATE
   REAL :: newv
  REAL   :: EPS, M_PI
   PARAMETER (EPS=3.0d-15)          !EPS is the relative precision
   PARAMETER (M_PI=3.141592654d0)      ! Pi value

!   PUBLIC :: newv, EPS, M_PI, n, xabsc, weig, dbp, qgss2d
!REAL :: newv, EPS, M_PI, n, xabsc, weig, dbp, qgss2d

   INTERFACE

   END INTERFACE

   CONTAINS
!* This module has the following INTERNAL FUNCTIONS:
!* gauleg, qgauss, qgss3d, qgss2d, gsselm, identity_matrix
!* This module has the following INTERNAL SUBROUTINES:
!* linear_solver
!* They can call on each other without first specifying their type
!* NO INTERFACE nor EXTERNAL is required since they are INTERNAL functions

!********************************************************************************
!* Calculation of GAUSS-LEGENDRE abscissas and weights for Gaussian Quadrature
!* integration of polynomial functions.
!*      For normalized lower and upper limits of integration -1.0 & 1.0, and
!* given n, this routine calculates, arrays xabsc(1:n) and  weig(1:n) of length n,
!* containing the abscissas and weights of the Gauss-Legendre n-point quadrature
!* formula.  For detailed explanations finding weights & abscissas, see
!* "Numerical Recipes in Fortran */
!********************************************************************************
    SUBROUTINE  gauleg(ngp, xabsc, weig)

      !implicit none
      INTEGER  i, j, m
     REAL   p1, p2, p3, pp, z, z1
      INTEGER, INTENT(IN) :: ngp            ! # of Gauss Points
     REAL , INTENT(OUT) :: xabsc(ngp), weig(ngp)

       m = (ngp + 1) / 2
!* Roots are symmetric in the interval - so only need to find half of them  */

       do i = 1, m              ! Loop over the desired roots */

            z = cos( M_PI * (i-0.25d0) / (ngp+0.5d0) )
!*   Starting with the above approximation to the ith root,
!*          we enter the main loop of refinement by NEWTON'S method   */
100         p1 = 1.0d0
            p2 = 0.0d0
!*  Loop up the recurrence relation to get the Legendre
!*  polynomial evaluated at z                 */

            do j = 1, ngp
            p3 = p2
            p2 = p1
            p1 = ((2.0d0*j-1.0d0) * z * p2 - (j-1.0d0)*p3) / j
            enddo

!* p1 is now the desired Legendre polynomial. We next compute pp,
!* its derivative, by a standard relation involving also p2, the
!* polynomial of one lower order.      */
            pp = ngp*(z*p1-p2)/(z*z-1.0d0)
            z1 = z
            z = z1 - p1/pp             ! Newton's Method  */

            if (abs(z-z1) .gt. EPS) GOTO  100

        xabsc(i) =  - z                     ! Roots will be bewteen -1.0 & 1.0 */
        xabsc(ngp+1-i) =  + z                   ! and symmetric about the origin  */
        weig(i) = 2.0d0/((1.0d0-z*z)*pp*pp) ! Compute the weight and its       */
        weig(ngp+1-i) = weig(i)               ! symmetric counterpart         */

      end do     ! i loop

   End subroutine gauleg

!**********************************************************************************
!*           Generic 2D Gaussian Quadraure Routines                               *
!**********************************************************************************
!* Use this function to calculate 2D integral by Gaussian Quadrature
!* Must supply boundary conditions x1,x2, y1(x), y2(x)
!* and the function to be integrated over f(x,y)
   RECURSIVE function qgss2d(origfn, xx1, xx2, yf1, yf2, ngp) RESULT(inth)
        !implicit none                               ! returns integral in inth
       REAL   inth, xx1, xx2
       REAL   xm, xl, xtmp
      INTEGER j
      INTEGER, INTENT(IN) :: ngp            ! # of Gauss Points
     REAL  :: xabsc(ngp), weig(ngp)

   interface
      real function origfn(xp,yp)   ! Original Function's Interface
        !implicit none
       REAL   xp, yp
        end function origfn
      real function yf1(x)
        !implicit none
       REAL   x
      end  function yf1
      real function yf2(x)
        !implicit none
       REAL    x
      end  function yf2
    end interface

      call gauleg(ngp, xabsc, weig)

        inth = 0.0d0
       xm = 0.5 * (xx2 + xx1)
    xl = 0.5 * (xx2 - xx1)

        do j = 1, ngp
           xtmp = xm + xl*xabsc(j)                ! Gauss-Legendre Abcissas
           inth = inth + weig(j) * qgssgy()
        END do

        inth = inth * xl;    !Scale the answer to the range of integration  */

    CONTAINS
    RECURSIVE function qgssgy() RESULT(intg)
            !implicit none                                ! returns integral in intg
           REAL   intg
           REAL   ym, yl, ytmp                ! all undeclared variables are
        INTEGER j                                    !   COOMON with HOST

            intg = 0.0d0
           ym = 0.5 * (yf2(xtmp) + yf1(xtmp))
            yl = 0.5 * (yf2(xtmp) - yf1(xtmp))

            do j = 1, ngp
               ytmp = ym + yl*xabsc(j)                ! Gauss-Legendre Abcissas
            intg = intg + weig(j) * origfn(xtmp,ytmp)
            END do

            intg = intg * yl;    !Scale the answer to the range of integration  */
    END function qgssgy

   END FUNCTION  qgss2d

!**********************************************************************************
!*           Generic 2D Gaussian Quadraure Routines                               *
!**********************************************************************************
!* Use this function to calculate 2D integral by Gaussian Quadrature
!* Must supply boundary conditions x1,x2, y1(x), y2(x)
!* and the function to be integrated over f(x,y)
   RECURSIVE function qgss2d_simple(origfn, xx1, xx2, yf1, yf2, ngp, param) RESULT(inth)
        !implicit none                               ! returns integral in inth
       REAL   xx1, xx2, yf1, yf2
       COMPLEX inth
       REAL   xm, xl, xtmp
      INTEGER j
      INTEGER, INTENT(IN) :: ngp            ! # of Gauss Points
     REAL  :: xabsc(ngp), weig(ngp)
      TYPE(ParamsCommonInf) :: param

   interface
        complex function origfn(xp,yp, param)  ! Original Function's Interface
         USE COMMON_TYPE
        !implicit none
        REAL , INTENT(IN) :: xp, yp
        TYPE(ParamsCommonInf) :: param
        end function origfn

    end interface

      call gauleg(ngp, xabsc, weig)

        inth = 0.0d0
       xm = 0.5 * (xx2 + xx1)
    xl = 0.5 * (xx2 - xx1)

        do j = 1, ngp
           xtmp = xm + xl*xabsc(j)                ! Gauss-Legendre Abcissas
           inth = inth + weig(j) * qgssgy()
        END do

        inth = inth * xl;    !Scale the answer to the range of integration  */

    CONTAINS
    RECURSIVE function qgssgy() RESULT(intg)
            !implicit none                                ! returns integral in intg
           COMPLEX   intg
           REAL   ym, yl, ytmp                ! all undeclared variables are
        INTEGER j                                    !   COOMON with HOST

            intg = cmplx(0.0, 0.0)
           ym = 0.5 * (yf2 + yf1)
            yl = 0.5 * (yf2 - yf1)

            do j = 1, ngp
               ytmp = ym + yl*xabsc(j)                ! Gauss-Legendre Abcissas
            intg = intg + weig(j) * origfn(xtmp,ytmp, param)
            END do
            intg = intg * yl;    !Scale the answer to the range of integration  */
    END function qgssgy

   END FUNCTION  qgss2d_simple

   end module gaussm3


! $UWHPSC/codes/lapack/random/randomsys2.f90

program randomsys2
    implicit none
    real(kind=8), dimension(:),allocatable :: x,b
    real(kind=8), dimension(:,:),allocatable :: a
    real(kind=8) :: err
    integer :: i, info, lda, ldb, nrhs, n
    integer, dimension(:), allocatable :: ipiv

    ! initialize random number generator seed
    ! if you remove this, the same numbers will be generated each
    ! time you run this code.
    call init_random_seed()

    print *, "Input n ... "
    read *, n

    allocate(a(n,n))
    allocate(b(n))
    allocate(x(n))
    allocate(ipiv(n))

    call random_number(a)
    call random_number(x)
    b = matmul(a,x) ! compute RHS

    nrhs = 1 ! number of right hand sides in b
    lda = n  ! leading dimension of a
    ldb = n  ! leading dimension of b

    call dgesv(n, nrhs, a, lda, ipiv, b, ldb, info)

    ! Note: the solution is returned in b
    ! and a has been changed.

    ! compare computed solution to original x:
    print *, "         x          computed       rel. error"
    do i=1,n
        err = abs(x(i)-b(i))/abs(x(i))
        print '(3d16.6)', x(i),b(i),err
        enddo

    deallocate(a,b,ipiv)

end program randomsys2


subroutine outnormal_2d(x_solid,edge_el,normal,nsd_solid,nen_solid,len)
! calculate the outward normal for the edge on the solid interface
integer nsd_solid ! dimension of solid
integer nen_solid ! number of nodes in solid element
real(8) x_solid(nen_solid,nsd_solid) ! coordinates of solid node in the element
integer edge_el(nen_solid) ! flag matrix that deside if the node is on the interface
real(8) normal(nsd_solid) ! output for outward normal
real(8) len ! length of the edge on the boundary
real(8) a(nsd_solid)
real(8) b(nsd_solid)
real(8) c(nsd_solid)
real(8) d(nsd_solid) ! check notes for definition
real(8) tmp(2,nsd_solid)
integer i
integer j
real(8) f(2,2)
real(8) invf(2,2)
real(8) p(2)
real(8) det
real(8) l
j=1
do i=1,nen_solid
	if (edge_el(i) .eq. 1) then ! nodes on the edge
		tmp(j,1:nsd_solid)=x_solid(i,1:nsd_solid)
		j=j+1
	end if

	if (edge_el(i) .eq. 0) then ! nodes not on the edge
		c(1:nsd_solid)=x_solid(i,1:nsd_solid)
	end if
end do
a(1:nsd_solid)=tmp(1,1:nsd_solid)
b(1:nsd_solid)=tmp(2,1:nsd_solid)

f(1,1)=b(2)-a(2)
f(1,2)=-(b(1)-a(1))
f(2,1)=b(1)-a(1)
f(2,2)=b(2)-a(2)

p(1)=a(1)*(b(2)-a(2))-a(2)*(b(1)-a(1))
p(2)=c(1)*(b(1)-a(1))+c(2)*(b(2)-a(2))

det=f(1,1)*f(2,2)-f(1,2)*f(2,1)

invf(1,1)=f(2,2)/det
invf(2,2)=f(1,1)/det
invf(1,2)=-f(1,2)/det
invf(2,1)=-f(2,1)/det

d(:)=0.0d0

do i=1,nsd_solid
	do j=1,nsd_solid
		d(i)=d(i)+invf(i,j)*p(j)
	end do
end do

normal(1:nsd_solid)=d(1:nsd_solid)-c(1:nsd_solid)
l=normal(1)**2+normal(2)**2
l=sqrt(l)
normal(1:nsd_solid)=normal(1:nsd_solid)/l

len=(a(1)-b(1))**2+(a(2)-b(2))**2
len=sqrt(len)

!write(*,*) 'normal inward', normal(:)
return
end subroutine outnormal_2d


MODULE Exponential_Integral

!   ALGORITHM 683, COLLECTED ALGORITHMS FROM ACM.
!   THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
!   VOL. 16, NO. 2, PP. 178-182.

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

! COMMON /qad/ fnm, gln, x, y, iflag
REAL (dp), SAVE  :: fnm, gln, x, y
INTEGER, SAVE    :: iflag
PRIVATE
PUBLIC  :: cexint, cexqad

CONTAINS

SUBROUTINE cexqad(z, n, kode, tol, cw, kerr)

!  CEXQAD COMPUTES EXPONENTIAL INTEGRALS E(N,Z) OF A COMPLEX (dp) ARGUMENT
!  Z BY QUADRATURE ON  (T**(N-1)*EXP(-T)/(Z+T))/(N-1)!  FROM T=0 TO
!  T=INFINITY.  KODE=1 RETURNS CW=E(N,Z) WHILE KODE=2 RETURNS
!  CW=E(N,Z)*CEXP(Z).  TOL IS THE REQUESTED RELATIVE ERROR AND KERR.NE.0 IS
!  AN ERROR FLAG INDICATING A PREMATURE TRUNCATION OF AN INTEGRAL IN CEXQAD.
!  THE QUADRATURE IS DONE AS TWO REAL INTEGRALS SINCE Z IS COMPLEX (dp).

COMPLEX (dp), INTENT(IN)   :: z
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: kode
REAL (dp), INTENT(IN)      :: tol
COMPLEX (dp), INTENT(OUT)  :: cw
INTEGER, INTENT(OUT)       :: kerr

! COMMON /qad/ fnm, gln, x, y, iflag
! EXTERNAL fqcex
REAL (dp)  :: a, ans, b, fn, gm, s1, s2, xtol
INTEGER    :: i, ierr

fn = n
fnm = fn - 1.0
gm = 1.0_dp
IF (n /= 1) THEN
  DO  i = 2, n
    gm = gm * (i-1)
  END DO
END IF
gln = LOG(gm)
kerr = 0
x = REAL(z)
y = AIMAG(z)
!-----------------------------------------------------------------------
!     REAL PART OF E(N,Z)
!-----------------------------------------------------------------------
iflag = 1
s1 = 0.0_dp
b = 0.0_dp
DO  i = 1, 100
  a = b
  b = b + 5.0_dp
  xtol = tol
  CALL gaus8(fqcex, a, b, xtol, ans, ierr)
  s1 = s1 + ans
  IF (ABS(ans) < ABS(s1)*tol) GO TO 30
END DO
kerr = 1
!-----------------------------------------------------------------------
!     IMAGINARY PART OF E(N,Z)
!-----------------------------------------------------------------------
30 iflag = 2
s2 = 0.0_dp
IF (y /= 0.0_dp) THEN
  b = 0.0_dp
  DO  i = 1, 100
    a = b
    b = b + 5.0_dp
    xtol = tol
    CALL gaus8(fqcex, a, b, xtol, ans, ierr)
    s2 = s2 + ans
    IF (ABS(ans) < ABS(s2)*tol) GO TO 50
  END DO
  kerr = 2
END IF

50 cw = CMPLX(s1, -s2, KIND=dp)
IF (kode == 1) cw = cw * EXP(-z)
RETURN
END SUBROUTINE cexqad

FUNCTION fqcex(t) RESULT(fn_val)

REAL (dp), INTENT(IN)  :: t
REAL (dp)              :: fn_val

! COMMON /qad/ fnm, gln, x, y, iflag

REAL (dp)  :: a, b

a = -t + fnm * LOG(t) - gln
a = EXP(a)
IF (iflag /= 2) THEN
  b = (x+t) / ((x+t)**2 + y**2)
ELSE
  b = y / ((x+t)**2 + y**2)
END IF
fn_val = a * b
RETURN
END FUNCTION fqcex

FUNCTION g8(fun, x, h) RESULT(fn_val)
! Replaces the statement function g8 which was part of GAUS8

REAL (dp), INTENT(IN)  :: x, h
REAL (dp)              :: fn_val

INTERFACE
  FUNCTION fun(x) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)  :: x
    REAL (dp)              :: fn_val
  END FUNCTION fun
END INTERFACE

REAL (dp), PARAMETER  :: x1 = 1.83434642495649805D-01, x2 = 5.25532409916328986D-01, &
                         x3 = 7.96666477413626740D-01, x4 = 9.60289856497536232D-01
REAL (dp), PARAMETER  :: w1 = 3.62683783378361983D-01, w2 = 3.13706645877887287D-01, &
                         w3 = 2.22381034453374471D-01, w4 = 1.01228536290376259D-01

fn_val = h * ((w1*(fun(x-x1*h) + fun(x+x1*h)) + w2*(fun(x-x2*h) +  &
         fun(x+x2*h))) + (w3*(fun(x-x3*h) + fun(x+x3*h)) + w4*(fun(x-x4*h) + &
         fun(x+x4*h))))

RETURN
END FUNCTION g8

SUBROUTINE gaus8(fun, a, b, ERR, ans, ierr)

!  WRITTEN BY R.E. JONES

!  ABSTRACT
!     GAUS8 INTEGRATES REAL FUNCTIONS OF ONE VARIABLE OVER FINITE INTERVALS
!     USING AN ADAPTIVE 8-POINT LEGENDRE-GAUSS ALGORITHM.
!     GAUS8 IS INTENDED PRIMARILY FOR HIGH ACCURACY INTEGRATION OR
!     INTEGRATION OF SMOOTH FUNCTIONS.

!     GAUS8 CALLS I1MACH, R1MACH, XERROR

!  DESCRIPTION OF ARGUMENTS

!     INPUT--
!     FUN - NAME OF EXTERNAL FUNCTION TO BE INTEGRATED.  THIS NAME MUST BE
!           IN AN EXTERNAL STATEMENT IN THE CALLING PROGRAM.
!           FUN MUST BE A FUNCTION OF ONE REAL ARGUMENT.  THE VALUE OF THE
!           ARGUMENT TO FUN IS THE VARIABLE OF INTEGRATION WHICH RANGES
!           FROM A TO B.
!     A   - LOWER LIMIT OF INTEGRAL
!     B   - UPPER LIMIT OF INTEGRAL (MAY BE LESS THAN A)
!     ERR - IS A REQUESTED PSEUDORELATIVE ERROR TOLERANCE.  NORMALLY PICK A
!           VALUE OF ABS(ERR) SO THAT STOL < ABS(ERR) <= 1.0E-3 WHERE STOL
!           IS THE DOUBLE PRECISION UNIT ROUNDOFF = EPSILON(0.0_dp).
!           ANS WILL NORMALLY HAVE NO MORE ERROR THAN ABS(ERR) TIMES THE
!           INTEGRAL OF THE ABSOLUTE VALUE OF FUN(X).
!           USUALLY, SMALLER VALUES FOR ERR YIELD MORE ACCURACY AND
!           REQUIRE MORE FUNCTION EVALUATIONS.

!           A NEGATIVE VALUE FOR ERR CAUSES AN ESTIMATE OF THE
!           ABSOLUTE ERROR IN ANS TO BE RETURNED IN ERR.  NOTE THAT
!           ERR MUST BE A VARIABLE (NOT A CONSTANT) IN THIS CASE.
!           NOTE ALSO THAT THE USER MUST RESET THE VALUE OF ERR
!           BEFORE MAKING ANY MORE CALLS THAT USE THE VARIABLE ERR.

!     OUTPUT--
!     ERR - WILL BE AN ESTIMATE OF THE ABSOLUTE ERROR IN ANS IF THE
!           INPUT VALUE OF ERR WAS NEGATIVE.  (ERR IS UNCHANGED IF
!           THE INPUT VALUE OF ERR WAS NONNEGATIVE.)  THE ESTIMATED
!           ERROR IS SOLELY FOR INFORMATION TO THE USER AND SHOULD
!           NOT BE USED AS A CORRECTION TO THE COMPUTED INTEGRAL.
!     ANS - COMPUTED VALUE OF INTEGRAL
!     IERR- A STATUS CODE
!         --NORMAL CODES
!            1 ANS MOST LIKELY MEETS REQUESTED ERROR TOLERANCE, OR A=B.
!           -1 A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL INTEGRATION.
!              ANS IS SET TO ZERO.
!         --ABNORMAL CODE
!            2 ANS PROBABLY DOES NOT MEET REQUESTED ERROR TOLERANCE.
!***END PROLOGUE

REAL (dp), INTENT(IN)      :: a
REAL (dp), INTENT(IN)      :: b
REAL (dp), INTENT(IN OUT)  :: ERR
REAL (dp), INTENT(OUT)     :: ans
INTEGER, INTENT(OUT)       :: ierr

! EXTERNAL fun
INTERFACE
  FUNCTION fun(x) RESULT(fn_val)
    IMPLICIT NONE
    INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(12, 60)
    REAL (dp), INTENT(IN)  :: x
    REAL (dp)              :: fn_val
  END FUNCTION fun
END INTERFACE

INTEGER    :: k, l, lmn, lmx, lr(30), mxl, nbits, nib, nlmx
REAL (dp)  :: aa(30), ae, anib, area, c, ce, ee, ef, eps, est, gl, glr,  &
              gr(30), hh(30), tol, vl(30), vr
INTEGER, PARAMETER    :: nlmn = 1, kmx = 5000, kml = 6
INTEGER, SAVE         :: icall = 0
REAL (dp), PARAMETER  :: sq2 = 1.41421356_dp

!     INITIALIZE

IF (icall /= 0) THEN
  WRITE(*, *) 'GAUS8- GAUS8 CALLED RECURSIVELY; NOT ALLOWED HERE'
  RETURN
END IF

icall = 1
k = DIGITS(0.0_dp)
anib = LOG10(DBLE(RADIX(0.0_dp))) * k / 0.30102000_dp
nbits = INT(anib)
nlmx = (nbits*5) / 8
ans = 0.0_dp
ierr = 1
ce = 0.0_dp
IF (a /= b) THEN
  lmx = nlmx
  lmn = nlmn
  IF (b /= 0.0_dp) THEN
    IF (SIGN(1.0_dp,b)*a > 0.0_dp) THEN
      c = ABS(1.0_dp-a/b)
      IF (c <= 0.1_dp) THEN
        IF (c <= 0.0_dp) GO TO 100
        anib = 0.5_dp - LOG(c) / 0.69314718_dp
        nib = anib
        lmx = MIN(nlmx, nbits-nib-7)
        IF (lmx < 1) GO TO 90
        lmn = MIN(lmn,lmx)
      END IF
    END IF
  END IF
  tol = MAX(ABS(ERR), 2.0_dp**(5-nbits)) / 2.0_dp
  IF (ERR == 0.0_dp) tol = SQRT(EPSILON(0.0_dp))
  eps = tol
  hh(1) = (b-a) / 4.0_dp
  aa(1) = a
  lr(1) = 1
  l = 1
  est = g8(fun, aa(l)+2.0_dp*hh(l), 2.0_dp*hh(l))
  k = 8
  area = ABS(est)
  ef = 0.5_dp
  mxl = 0

!     COMPUTE REFINED ESTIMATES, ESTIMATE THE ERROR, ETC.

  10   gl = g8(fun, aa(l)+hh(l), hh(l))
  gr(l) = g8(fun, aa(l)+3.0_dp*hh(l), hh(l))
  k = k + 16
  area = area + (ABS(gl) + ABS(gr(l)) - ABS(est))
!     IF (L < LMN) GO TO 11
  glr = gl + gr(l)
  ee = ABS(est-glr) * ef
  ae = MAX(eps*area, tol*ABS(glr))
  IF (ee-ae > 0.0) THEN
    GO TO 40
  ELSE
    GO TO 30
  END IF
  20 mxl = 1
  30 ce = ce + (est-glr)
  IF (lr(l) > 0) THEN
    GO TO 70
  ELSE
    GO TO 50
  END IF

!     CONSIDER THE LEFT HALF OF THIS LEVEL

  40 IF (k > kmx) lmx = kml
  IF (l >= lmx) GO TO 20
  l = l + 1
  eps = eps * 0.5_dp
  ef = ef / sq2
  hh(l) = hh(l-1) * 0.5_dp
  lr(l) = -1
  aa(l) = aa(l-1)
  est = gl
  GO TO 10

!     PROCEED TO RIGHT HALF AT THIS LEVEL

  50 vl(l) = glr
  60 est = gr(l-1)
  lr(l) = 1
  aa(l) = aa(l) + 4.0_dp * hh(l)
  GO TO 10

!     RETURN ONE LEVEL

  70 vr = glr
  80 IF (l > 1) THEN
    l = l - 1
    eps = eps * 2.0_dp
    ef = ef * sq2
    IF (lr(l) <= 0) THEN
      vl(l) = vl(l+1) + vr
      GO TO 60
    END IF
    vr = vl(l+1) + vr
    GO TO 80
  END IF

!      EXIT

  ans = vr
  IF (mxl == 0 .OR. ABS(ce) <= 2.0_dp*tol*area) GO TO 100
  ierr = 2
  WRITE(*, *) 'GAUS8- ANS IS PROBABLY INSUFFICIENTLY ACCURATE.'
  GO TO 100

  90 ierr = -1
  WRITE(*, *) 'GAUS8- THE FOLLOWING TEMPORARY DIAGNOSTIC WILL APPEAR ONLY ONCE.'
  WRITE(*, *) 'A AND B ARE TOO NEARLY EQUAL TO ALLOW NORMAL INTEGRATION.'
  WRITE(*, *) 'ANS IS SET TO ZERO, AND IERR=-1.'
END IF
100 icall = 0
IF (ERR < 0.0_dp) ERR = ce
RETURN
END SUBROUTINE gaus8

SUBROUTINE cexint(z, n, kode, tol, m, cy, ierr)
!***BEGIN PROLOGUE  CEXINT
!***DATE WRITTEN   870515   (YYMMDD)
!***REVISION DATE  870515   (YYMMDD)
!***CATEGORY NO.  B5E
!***KEYWORDS  EXPONENTIAL INTEGRALS, SINE INTEGRAL, COSINE INTEGRAL
!***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
!***PURPOSE  TO COMPUTE EXPONENTIAL INTEGRALS OF A COMPLEX (dp) ARGUMENT
!***DESCRIPTION

!   ON KODE=1, CEXINT COMPUTES AN M MEMBER SEQUENCE OF COMPLEX (dp)
!   EXPONENTIAL INTEGRALS CY(J)=E(N+J-1,Z), J=1,...,M, FOR
!   POSITIVE ORDERS N,...,N+M-1 AND COMPLEX (dp) Z IN THE CUT PLANE
!   -PI < ARG(Z) <= PI (N=1 AND Z=CMPLX(0.0,0.0) CANNOT HOLD AT
!   THE SAME TIME).  ON KODE=2, CEXINT COMPUTES SCALED FUNCTIONS

!                    CY(J)=E(N+J-1,Z)*CEXP(Z),      J=1,...,M,

!   WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND
!   RIGHT HALF PLANES.  DEFINITIONS AND NOTATION ARE FOUND IN THE
!   NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1).

!   INPUT
!     Z      - Z=CMPLX(X,Y), -PI < ARG(Z) <= PI
!     N      - INTEGER ORDER OF INITIAL E FUNCTION, N=1,2,...
!              (N=1 AND Z=CMPLX(0.0,0.0) IS AN ERROR)
!     KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
!              KODE= 1  RETURNS
!                       CY(J)=E(N+J-1,Z),          J=1,...,M
!                  = 2  RETURNS
!                       CY(J)=E(N+J-1,Z)*CEXP(Z),  J=1,...,M
!     TOL    - PRECISION (ACCURACY) DESIRED FOR THE SEQUENCE,
!              URND <= TOL <= 1.0E-3, WHERE URND IS LIMITED BY
!              URND = MAX(UNIT ROUNDOFF,1.0E-18) AND UNIT
!              ROUNDOFF = EPSILON(0.0_dp)
!     M      - NUMBER OF E FUNCTIONS IN THE SEQUENCE, M >= 1

!   OUTPUT
!     CY     - A COMPLEX (dp) VECTOR WHOSE FIRST M COMPONENTS CONTAIN
!              VALUES FOR THE SEQUENCE
!              CY(J)=E(N+J-1,Z)  OR
!              CY(J)=E(N+J-1,Z)*CEXP(Z), J=1,...,M
!              DEPENDING ON KODE.
!     IERR   - ERROR FLAG
!              IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
!              IERR=1, INPUT ERROR   - NO COMPUTATION
!              IERR=2, UNDERFLOW     - FIRST M COMPONENTS OF CY
!                      SET TO ZERO, CY(J)=CMPLX(0.0,0.0), J=1,M,
!                      REAL(Z) > 0.0 TOO LARGE ON KODE=1
!              IERR=3, OVERFLOW      - NO COMPUTATION,
!                      REAL(Z) < 0.0 TOO SMALL ON KODE=1
!              IERR=4, CABS(Z) OR N+M-1 LARGE - COMPUTATION DONE
!                      BUT LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION
!                      PRODUCE LESS THAN HALF OF MACHINE ACCURACY
!              IERR=5, CABS(Z) OR N+M-1 TOO LARGE - NO COMPUTATION BECAUSE
!                      OF COMPLETE LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION
!              IERR=6, ERROR         - NO COMPUTATION,
!                      ALGORITHM TERMINATION CONDITION NOT MET.
!                      SEE LONG DESCRIPTION ABOUT PARAMETER ICMAX.
!              IERR=7, ERROR         - NO COMPUTATION,
!                      DISCRIMINATION ERROR.  THIS CONDITION SHOULD NEVER OCCUR.

!***LONG DESCRIPTION

!   CEXINT USES A COMBINATION OF POWER SERIES AND BACKWARD RECURRENCE
!   DESCRIBED IN REF. 2 FOR THE COMPLEX (dp) Z PLANE EXCEPT FOR A STRIP
!   2*YB WIDE ABOUT THE NEGATIVE REAL AXIS, WHERE ANALYTIC CONTINUATION IS
!   CARRIED OUT BY LIMITED USE OF TAYLOR SERIES.
!   THE SWITCH FROM BACKWARD RECURRENCE TO TAYLOR SERIES IS NECESSARY BECAUSE
!   BACKWARD RECURRENCE IS SLOWLY CONVERGENT NEAR THE NEGATIVE REAL AXIS.
!   THE BOUNDARIES Y=-YB AND Y=YB WERE DETERMINED SO THAT BACKWARD RECURRENCE
!   WOULD CONVERGE EASILY WITH N AS LARGE AS 100 AND TOL AS SMALL AS 1.0D-18.
!   SUBROUTINE CEXENZ DOES THE BACKWARD RECURRENCE AND SUBROUTINE CACEXI DOES
!   THE ANALYTIC CONTINUATION.  TO START THE CONTINUATION, CACEXI CALLS CEXENZ
!   WITH ZB=CMPLX(X,YB).
!   IF CEXENZ RETURNS IERR=6, THEN YB IS INCREASED BY 0.5 UNTIL CEXENZ RETURNS
!   IERR=0 OR 10 TRIES, WHICHEVER COMES FIRST.
!   WHEN IERR=0, THEN THE ANALYTIC CONTINUATION PROCEEDS VERTICALLY DOWN FROM
!   ZB=CMPLX(X,YB) TO Z=CMPLX(X,Y), 0 <= Y < YB.
!   CONJUGATION IS USED FOR Y < 0.  YB INCREASES AS TOL DECREASES TO KEEP
!   CONVERGENCE RATES UP AND RECURRENCE DOWN.

!   PARAMETER ICDIM=250 ALLOCATES STORAGE FOR THE COEFFICIENTS OF THE BACKWARD
!   RECURRENCE ALGORITHM.  IF THE ALGORITHM TERMINATION CONDITION IS NOT MET
!   IN ICDIM STEPS, THEN RECURRENCE PROCEEDS WITH NO ADDITIONAL STORAGE UNTIL
!   THE TERMINATION CONDITION IS MET OR THE LIMIT ICMAX=2000 IS EXCEEDED.
!   THE PURPOSE OF STORAGE IS TO MAKE THE ALGORITHM MORE EFFICIENT.
!   THE TERMINATION CONDITION IS MET IN LESS THAN 250 STEPS OVER MOST OF
!   THE COMPLEX (dp) PLANE EXCLUDING THE STRIP ABS(Y) < YB, X < 0.
!   EXCEPTIONS TO THIS RULE ARE GENERATED NEAR STRIP BOUNDARIES WHEN N+M-1
!   AND ABS(Z) ARE LARGE AND NEARLY EQUAL.  IN THESE CASES, THE CONVERGENCE
!   IS VERY SLOW AND ADDITIONAL RECURRENCE (UP TO ICMAX) MUST BE USED.
!   ON THE OTHERHAND, THESE REGIONS OF SLOW CONVERGENCE ARE KEPT SMALL BY
!   ADJUSTING YB AS A FUNCTION OF TOL.  THESE REGIONS COULD BE ELIMINATED
!   ENTIRELY BY MAKING YB SUFFICIENTLY LARGE, BUT THE EXPENSE AND INSTABILITY
!   OF CONTINUATION BY TAYLOR SERIES NOT ONLY GOES UP, BUT THE COMPUTATIONAL
!   EXPENSE BECOMES EXCESSIVELY LARGE IN OTHER PARTS OF THE LEFT HALF PLANE
!   (Y < YB) WHERE THE BACKWARD RECURRENCE ALGORITHM WOULD CONVERGE RAPIDLY.

!   DERIVATIVES FOR SUCCESSIVE POWER SERIES ARE NOT COMPUTED BY EVALUATING
!   DERIVATIVES OF A PREVIOUS POWER SERIES.  BECAUSE OF THE RELATION

!     (1)           DE(N,Z)/DZ = - E(N-1,Z),

!   SUCCESSIVE DERIVATIVES AT Z ARE GIVEN BY LOWER ORDER FUNCTIONS AND CAN BE
!   COMPUTED IN A STABLE FASHION BY BACKWARD RECURRENCE USING (2) PROVIDED
!   THAT THE BEGINNING ORDER NUB IS SMALLER THAN THE ARGUMENT.
!   TO ACHIEVE THIS FOR ALL INTERMEDIATE VALUES ZZ BETWEEN ZB AND Z, WE TAKE
!   NUB=MINO(N+M-1,INT(CABS(Z)+0.5)).
!   TO START, E(NUB,ZB) IS EVALUATED BY THE BACKWARD RECURRENCE ALGORITHM OF
!   REF. 3.  TO CONTINUE THE FUNCTION FROM ZB TO Z VIA INTERMEDIATE VALUES ZZ,
!   DERIVATIVES OF E(NUB,ZB) ARE COMPUTED BY BACKWARD RECURRENCE ON (2).
!   THIS ALLOWS A STEP (NO LARGER THAN 0.5) TO ZZ FOR E(NUB,ZZ) USING THE
!   TAYLOR SERIES ABOUT ZB.  NOW, WE APPLY (2) AGAIN STARTING AT E(NUB,ZZ) FOR
!   THE DERIVATIVES AT ZZ AND TAKE ANOTHER STEP, ETC.  NOTICE THAT THE
!   STABILITY CONDITION FOR BACKWARD RECURRENCE, NUB <= ABS(Z) <= ABS(ZZ)
!   <= ABS(ZB), IS SATISFIED FOR ALL INTERMEDIATE VALUES ZZ.  THE FINAL
!   SEQUENCE FOR ORDERS N,...,N+M-1 IS GENERATED FROM (2) BY BACKWARD
!   RECURRENCE, FORWARD RECURRENCE OR BOTH ONCE E(NUB,Z) HAS BEEN COMPUTED.

!   RECURRENCE WITH THE RELATION

!      (2)     N*E(N+1,Z) + Z*E(N,Z) = CEXP(-Z)

!   IN A DIRECTION AWAY FROM THE INTEGER CLOSEST TO ABS(Z) IS STABLE.
!   FOR NEGATIVE ORDERS, THE RECURRENCE

!         E( 0,Z) = CEXP(-Z)/Z
!         E(-N,Z) = ( CEXP(-Z)+N*E(-N+1,Z) )/Z   ,N=1,2,...

!   IS NUMERICALLY STABLE FOR ALL Z.

!   THE (CAPITAL) SINE AND COSINE INTEGRALS CAN BE COMPUTED FROM

!           SI(Z) =  (E(1,I*Z)-E(1,-I*Z))/(2*I) + PI/2
!           CI(Z) = -(E(1,I*Z)+E(1,-I*Z))/2

!   IN -PI/2 < ARG(Z) <= PI/2, (I**2=-1), WHILE THE PRINCIPAL
!   VALUED EXPONENTIAL INTEGRAL EI(X) CAN BE COMPUTED FROM

!       EI( X) = -(E(1,-X+I*0)+E(1,-X-I*0))/2 = -REAL(E(1,-X))
!       EI(-X) = -REAL(E(1,X))

!   FOR X > 0.0 TO AN ACCURACY TOL.  IF Z = X > 0 THEN THE REAL SINE AND
!   COSINE INTEGRALS ARE GIVEN BY

!           SI(X) = AIMAG(E(1,I*X)) + PI/2
!           CI(X) = -REAL(E(1,I*X)) .

!   THE ANALYTIC CONTINUATION TO OTHER SHEETS CAN BE DONE BY THE RELATIONS

!   E(N,Z*CEXP(2*PI*M*I)) = E(N,Z) - 2*PI*M*I*(-Z)**(N-1)/(N-1)!

!   WHERE M=+1 OR M=-1 AND I**2=-1.

!***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND
!           I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF COMMERCE, 1955.

!         COMPUTATION OF EXPONENTIAL INTEGRALS OF COMPLEX (dp) ARGUMENT
!           BY D. E. AMOS, ACM TRANS. MATH. SOFTWARE

!         COMPUTATION OF EXPONENTIAL INTEGRALS BY D. E. AMOS, ACM TRANS.
!           MATH. SOFTWARE, VOL 6, NO. 3 SEPTEMBER 1980, PP. 365-377;
!           ALGORITHM 556, EXPONENTIAL INTEGRALS, PP. 420-428.

!         REMARK ON ALGORITHM 556
!           BY D. E. AMOS, ACM TRANS. MATH. SOFTWARE, VOL 9, NO. 4
!           DECEMBER 1983, P. 525.

!         UNIFORM ASYMPTOTIC EXPANSIONS FOR EXPONENTIAL INTEGRALS E(N,X)
!           AND BICKLEY FUNCTIONS KI(N,X) BY D. E. AMOS, ACM TRANS. MATH.
!           SOFTWARE, VOL 9, NO. 4, DECEMBER. 1983, PP. 467-479;
!           ALGORITHM 609, A PORTABLE FORTRAN SUBROUTINE FOR BICKLEY
!           FUNCTIONS KI(N,X), PP. 480-493.

!***ROUTINES CALLED  CACEXI,CEXENZ,I1MACH,R1MACH
!***END PROLOGUE  CEXINT

COMPLEX (dp), INTENT(IN)   :: z
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: kode
REAL (dp), INTENT(IN)      :: tol
INTEGER, INTENT(IN)        :: m
COMPLEX (dp), INTENT(OUT)  :: cy(m)
INTEGER, INTENT(OUT)       :: ierr

INTEGER      :: i, k, k1, k2
REAL (dp)    :: aa, alim, az, bb, ca(250), d, elim, fn, rbry, r1m5, urnd, x,  &
                y, yb, htol
COMPLEX (dp) :: cb(250)
!-----------------------------------------------------------------------
!     DIMENSION CA(ICDIM),CB(ICDIM)
!-----------------------------------------------------------------------
INTEGER, PARAMETER  :: icdim = 250

!***FIRST EXECUTABLE STATEMENT  CEXINT
ierr = 0
x = REAL(z, KIND=dp)
y = AIMAG(z)
IF (x == 0.0_dp .AND. y == 0.0_dp .AND. n == 1) ierr = 1
IF (n < 1) ierr = 1
IF (kode < 1 .OR. kode > 2) ierr = 1
IF (m < 1) ierr = 1
urnd = MAX(EPSILON(0.0_dp), 1.0E-18)
IF (tol < urnd .OR. tol > 1.0E-3) ierr = 1
IF (ierr /= 0) RETURN
IF (x /= 0.0_dp .OR. y /= 0.0_dp .OR. n <= 1) THEN
!-----------------------------------------------------------------------
!     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
!     URND IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
!     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
!     EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/URND    AND
!     EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*URND       ARE INTERVALS NEAR
!     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
!-----------------------------------------------------------------------
  k1 = MINEXPONENT(0.0_dp)
  k2 = MAXEXPONENT(0.0_dp)
  r1m5 = LOG10(DBLE(RADIX(0.0_dp)))
  k = MIN(ABS(k1),ABS(k2))
  elim = 2.303_dp * (k*r1m5 - 3.0_dp)
  k1 = DIGITS(0.0_dp) - 1
  aa = r1m5 * k1
  aa = aa * 2.303
  alim = elim + MAX(-aa, -41.45_dp)
  rbry = 2.0
  IF (urnd > 1.0E-8) rbry = 1.0_dp
!-----------------------------------------------------------------------
!     TEST VARIABLES FOR RANGE. ABS(Z) CANNOT BE LARGER THAN THE ARGUMENT
!     OF THE INT( ) FUNCTION.
!-----------------------------------------------------------------------
  az = ABS(z)
  fn = n+m-1
  aa = 0.5_dp / urnd
  bb = HUGE(0.0_dp) * 0.5_dp
  aa = MIN(aa,bb)
  IF (az > aa) GO TO 20
  IF (fn > aa) GO TO 20
  aa = SQRT(aa)
  IF (az > aa) ierr = 4
  IF (fn > aa) ierr = 4
  IF (x >= 0.0_dp) THEN
!-----------------------------------------------------------------------
!     BACKWARD RECURRENCE FOR THE RIGHT HALF PLANE, X >= 0.0E0
!-----------------------------------------------------------------------
    CALL cexenz(z, n, kode, m, cy, ierr, rbry, tol, elim, alim, icdim, ca, cb)
    RETURN
  END IF
  IF (az <= rbry) THEN
!-----------------------------------------------------------------------
!     POWER SERIES FOR ABS(Z) <= RBRY AND X < 0.0E0
!-----------------------------------------------------------------------
    CALL cexenz(z, n, kode, m, cy, ierr, rbry, tol, elim, alim, icdim, ca, cb)
    RETURN
  END IF
  d = -0.4342945_dp * LOG(tol)
  yb = 10.5_dp - 0.538460_dp * (18.0_dp-d)
  IF (ABS(y) >= yb) THEN
!-----------------------------------------------------------------------
!     BACKWARD RECURRENCE EXTERIOR TO THE STRIP ABS(Y) < YB, X < 0.0
!-----------------------------------------------------------------------
    htol = 0.125_dp * tol
    CALL cexenz(z, n, kode, m, cy, ierr, rbry, htol, elim, alim, icdim, ca, cb )
    RETURN
  END IF
!-----------------------------------------------------------------------
!     TAYLOR SERIES IN CACEXI FOR ANALYTIC CONTINUATION
!-----------------------------------------------------------------------
  CALL cacexi(z, n, kode, m, cy, ierr, yb, rbry, tol, elim, alim, icdim, ca, cb )
  RETURN
END IF
DO  i = 1, m
  cy(i) = 1.0_dp / (n+i-2)
END DO
RETURN

20 ierr = 5
RETURN
END SUBROUTINE cexint

SUBROUTINE cexenz(z, n, kode, m, cy, ierr, rbry, tol, elim, alim, icdim, ca, cb)
!***BEGIN PROLOGUE  CEXENZ
!***REFER TO  CEXINT

!   CEXENZ COMPUTES THE EXPONENTIAL INTEGRAL BY MEANS OF POWER SERIES AND A
!   BACKWARD RECURRENCE ALGORITHM FOR THE CONFLUENT HYPERGEOMETRIC
!   REPRESENTATION.

!***ROUTINES CALLED PSIXN
!***END PROLOGUE  CEXENZ

COMPLEX (dp), INTENT(IN)   :: z
INTEGER, INTENT(IN)        :: n
INTEGER, INTENT(IN)        :: kode
INTEGER, INTENT(IN)        :: m
COMPLEX (dp), INTENT(OUT)  :: cy(m)
INTEGER, INTENT(OUT)       :: ierr
REAL (dp), INTENT(IN)      :: rbry
REAL (dp), INTENT(IN)      :: tol
REAL (dp), INTENT(IN)      :: elim
REAL (dp), INTENT(IN)      :: alim
INTEGER, INTENT(IN)        :: icdim
REAL (dp), INTENT(OUT)     :: ca(icdim)
COMPLEX (dp), INTENT(OUT)  :: cb(icdim)

INTEGER       :: i, ic, icase, ict, ik, ind, iz, jset, k, kflag, kn, ks, ml, &
                 mu, nd, nm
REAL (dp)     :: aa, aam, aams, aem, ah, ak, ap1, at, az, bk, bt, dk, ERR, &
                 fc, fnm, rtola, tola, x, xtol, y, ck
COMPLEX (dp)  :: cp1, cp2, cpt, cat, cbt, cy1, cy2, cyy(2), cnorm, cs, cak, &
                 emz, caa, tz, fz, ct, scle, rscle

REAL (dp), PARAMETER     :: euler = -5.77215664901532861D-01
COMPLEX (dp), PARAMETER  :: czero = (0.0_dp, 0.0_dp), cone = (1.0_dp, 0.0_dp)
INTEGER, PARAMETER       :: icmax = 2000

ierr = 0
scle = cone
rscle = cone
x = REAL(z, KIND=dp)
y = AIMAG(z)
az = ABS(z)
IF (az <= rbry) THEN
!-----------------------------------------------------------------------
!     SERIES FOR E(N,Z) FOR ABS(Z) <= RBRY
!-----------------------------------------------------------------------
  iz = az + 0.5_dp
!-----------------------------------------------------------------------
!     ICASE=1 MEANS INTEGER CLOSEST TO ABS(Z) IS 2 AND N=1
!     ICASE=2 MEANS INTEGER CLOSEST TO ABS(Z) IS 0,1, OR 2 AND N >= 2
!-----------------------------------------------------------------------
  icase = 2
  IF (iz > n) icase = 1
  nm = n - icase + 1
  nd = nm + 1
  ind = 3 - icase
  mu = m - ind
  ml = 1
  ks = nd
  fnm = nm
  cs = czero
  xtol = 0.3333_dp * tol
  aam = 1.0_dp
  IF (nd /= 1) THEN
    aam = 1.0_dp / fnm
    cs = aam
  END IF
  caa = cone
  aa = 1.0_dp
  ak = 1.0_dp
!-----------------------------------------------------------------------
!     LIMIT INDEX I TO IK TO PREVENT UNDERFLOW ON SMALL VALUES OF Z
!-----------------------------------------------------------------------
  ik = 35
  IF (az < xtol*aam) ik = 1
  DO  i = 1, ik
    at = 1.0_dp / ak
    caa = -caa * z * at
    aa = aa * az * at
    IF (i /= nm) THEN
      cs = cs - caa / (ak-fnm)
    ELSE
      cs = cs + caa * (-LOG(z) + psixn(nd))
    END IF
    IF (aa <= xtol*ABS(cs)) EXIT
    ak = ak + 1.0_dp
  END DO

  IF (nd == 1) cs = cs + (-LOG(z) + euler)
  IF (kode == 2) cs = cs * EXP(z)
  cy(1) = cs
  ct = cs
  emz = cone
  IF (m /= 1) THEN
    cy(ind) = cs
    ak = ks
    IF (kode == 1) emz = EXP(-z)
    SELECT CASE ( icase )
      CASE (    1)
        GO TO 140
      CASE (    2)
        GO TO 160
    END SELECT
  END IF
  IF (icase == 2) RETURN
  IF (kode == 1) emz = EXP(-z)
  cy(1) = (emz-cs) / z
  RETURN
END IF
!-----------------------------------------------------------------------
!     BACKWARD RECURSIVE MILLER ALGORITHM FOR
!              E(N,Z)=EXP(-Z)*(Z**(N-1))*U(N,N,Z)
!     WITH RECURSION AWAY FROM N=INTEGER CLOSEST TO ABS(Z)
!     U(A,B,Z) IS THE SECOND CONFLUENT HYPERGEOMETRIC FUNCTION
!-----------------------------------------------------------------------
emz = cone
IF (kode /= 2) THEN
!-----------------------------------------------------------------------
!     SCALE NEAR EXPONENT EXTREMES ON KODE=1
!-----------------------------------------------------------------------
  IF (x >= 0.0_dp) THEN
    at = x + (n+m-1)
    ct = CMPLX(at, y, KIND=dp)
    aa = ABS(ct)
    at = x + LOG(aa)
    IF (at > elim) GO TO 30
    kflag = 1
  ELSE
    at = x
    IF (at < (-elim)) GO TO 180
    kflag = 2
  END IF
  IF (ABS(at) >= alim) THEN
    tola = EXP(alim-elim)
    rtola = 1.0_dp / tola
    IF (kflag /= 2) THEN
      scle  = rtola
      rscle = tola
    ELSE
      scle  = tola
      rscle = rtola
    END IF
    emz = scle
  END IF
  emz = emz * EXP(-z)
END IF
iz = az + 0.5_dp
kn = n + m - 1
IF (kn <= iz) GO TO 50
IF (n < iz .AND. iz < kn) GO TO 80
IF (n >= iz) GO TO 70
ierr = 7
RETURN

30 ierr = 2
cy(1:m) = czero
RETURN

50 icase = 1
ks = kn
ml = m - 1
mu = -1
ind = m
IF (kn > 1) GO TO 90

60 ks = 2
icase = 3
GO TO 90

70 icase = 2
ind = 1
ks = n
mu = m - 1
IF (n > 1) GO TO 90
IF (kn == 1) GO TO 60
iz = 2

80 icase = 1
ks = iz
ml = iz - n
ind = ml + 1
mu = kn - iz

90 ik = ks / 2
ah = ik
jset = 1 + ks - 2 * ik
!-----------------------------------------------------------------------
!     START COMPUTATION FOR
!              CYY(1) = C*U( A , A ,Z)    JSET=1
!              CYY(1) = C*U(A+1,A+1,Z)    JSET=2
!     FOR AN EVEN INTEGER A.
!-----------------------------------------------------------------------
ic = 0
aa = ah + ah
caa = aa
aam = aa - 1.0_dp
aams = aam * aam
tz = z + z
fz = tz + tz
ak = ah
xtol = tol
ct = aams + fz * ah
cak = z + caa
aem = (ak+1.0_dp) / xtol
aem = aem / ABS(cak)
bk = aa
ck = ah * ah
!-----------------------------------------------------------------------
!     FORWARD RECURSION FOR P(IC),P(IC+1) AND INDEX IC FOR BACKWARD
!     RECURSION
!-----------------------------------------------------------------------
cp1 = czero
cp2 = cone

100 ic = ic + 1
IF (ic <= icdim) THEN
  ak = ak + 1.0_dp
  ck = ck + 1.0_dp
  at = bk / (bk+ak+ck)
  bk = bk + ak + ak
  cat = at
  ca(ic) = at
  bt = 1.0_dp / (ak + 1.0_dp)
  cbt = (ak + ak + z) * bt
  cb(ic) = cbt
  cpt = cp2
  cp2 = cbt * cp2 - cat * cp1
  cp1 = cpt
  ct = ct + fz
  aem = aem * at
  bt = ABS(ct)
  ERR = aem / SQRT(bt)
  ap1 = ABS(cp1)
  IF (ERR*(ak+1.0_dp)/ap1 > ap1) GO TO 100
ELSE
!-----------------------------------------------------------------------
!     CONTINUE FORWARD RECURRENCE UNINDEXED WHEN IC EXCEEDS ICDIM
!-----------------------------------------------------------------------
  ic = ic - 1

  110 ic = ic + 1
  IF (ic > icmax) GO TO 190
  ak = ak + 1.0_dp
  ck = ck + 1.0_dp
  at = bk / (bk+ak+ck)
  bk = bk + ak + ak
  cat = at
  bt = 1.0_dp / (ak+1.0_dp)
  cbt = (ak+ak + z) * bt
  cpt = cp2
  cp2 = cbt * cp2 - cat * cp1
  cp1 = cpt
  ct = ct + fz
  aem = aem * at
  bt = ABS(ct)
  ERR = aem / SQRT(bt)
  ap1 = ABS(cp1)
  IF (ERR*(ak+1.0_dp)/ap1 > ap1) GO TO 110
END IF
fc = ic
at = ((fc+1.0_dp)/(ak+1.0_dp)) * ((ak+ah)/(ak+1.0_dp))
cat = at * SQRT(ct/(ct+fz))
cy2 = cat * (cp1/cp2)
cy1 = cone
!-----------------------------------------------------------------------
!     BACKWARD RECURRENCE FOR
!             CY1=             C*U( A ,A,Z)
!             CY2= C*(A/(1+A/2))*U(A+1,A,Z)
!-----------------------------------------------------------------------
IF (ic > icdim) THEN
!-----------------------------------------------------------------------
!     BACKWARD RECUR UNINDEXED WHEN IC EXCEEDS ICDIM
!-----------------------------------------------------------------------
  bt = aa + x

  120 ak = ah + fc
  bk = ak + 1.0_dp
  ck = aam + fc
  dk = bt + fc + fc
  at = (ak/fc) * (bk/ck)
  cbt = CMPLX(dk/bk, y/bk, KIND=dp)
  cpt = cy1
  cy1 = (cbt*cy1 - cy2) * at
  cy2 = cpt
  fc = fc - 1.0_dp
  ic = ic - 1
  IF (ic > icdim) GO TO 120
END IF
ict = ic
DO  k = 1, ict
  at = 1.0_dp / ca(ic)
  cpt = cy1
  cy1 = (cb(ic)*cy1 - cy2) * at
  cy2 = cpt
  ic = ic - 1
END DO
!-----------------------------------------------------------------------
!     THE CONTIGUOUS RELATION
!              Z*U(B,C+1,Z)=(C-B)*U(B,C,Z)+U(B-1,C,Z)
!     WITH  B=A+1 , C=A IS USED FOR
!             CYY(2) = C * U(A+1,A+1,Z)
!     Z IS INCORPORATED INTO THE NORMALIZING RELATION FOR CNORM.
!-----------------------------------------------------------------------
cpt = cy2 / cy1
cnorm = cone - cpt * (ah + 1.0_dp) / aa
cyy(1) = cone / (cnorm*caa+z)
cyy(2) = cnorm * cyy(1)
IF (icase /= 3) THEN
  ct = emz * cyy(jset)
  cy(ind) = ct * rscle
  cs = ct
  IF (m == 1) RETURN
  ak = ks
  SELECT CASE ( icase )
    CASE (    1)
      GO TO 140
    CASE (    2)
      GO TO 160
  END SELECT
END IF
!-----------------------------------------------------------------------
!     RECURSION SECTION  N*E(N+1,Z) + Z*E(N,Z)=EMZ
!-----------------------------------------------------------------------
ct = emz * (cone - cyy(1)) / z
cy(1) = ct * rscle
RETURN

140 caa = ak
tz = cone / z
k = ind - 1
DO  i = 1, ml
  caa = caa - cone
  ct = (emz-caa*ct) * tz
  cy(k) = ct * rscle
  k = k - 1
END DO
IF (mu <= 0) RETURN
ak = ks

160 k = ind
DO  i = 1, mu
  cs = (emz - z*cs) / ak
  cy(k+1) = cs * rscle
  ak = ak + 1.0_dp
  k = k + 1
END DO
RETURN

180 ierr = 3
RETURN

190 ierr = 6
RETURN
END SUBROUTINE cexenz

SUBROUTINE cacexi(z, nu, kode, n, y, ierr, yb, rbry, tol, elim, alim, icdim, &
                  ca, cb)
!***BEGIN PROLOGUE  CACEXI
!***REFER TO  CEXINT

!  CACEXI COMPUTES THE ANALYTIC CONTINUATION OF THE EXPONENTIAL INTEGRAL
!  FOR X < 0 AND -YB < Y < YB BY TAYLOR SERIES IN INCREMENTS OF HALF A UNIT.
!  THE CONTINUATION PROCEEDS VERTICALLY DOWN FROM ZB=CMPLX(X,YB) TO
!  Z=CMPLX(X,Y) FOR 0.0 <= Y < YB.  CONJUGATION IS USED FOR Y < 0.0E0.

!***ROUTINES CALLED  CEXENZ
!***END PROLOGUE  CACEXI

COMPLEX (dp), INTENT(IN)      :: z
INTEGER, INTENT(IN)           :: nu
INTEGER, INTENT(IN)           :: kode
INTEGER, INTENT(IN)           :: n
COMPLEX (dp), INTENT(OUT)     :: y(n)
INTEGER, INTENT(OUT)          :: ierr
REAL (dp), INTENT(IN OUT)     :: yb
REAL (dp), INTENT(IN OUT)     :: rbry
REAL (dp), INTENT(IN)         :: tol
REAL (dp), INTENT(IN)         :: elim
REAL (dp), INTENT(IN)         :: alim
INTEGER, INTENT(IN)           :: icdim
REAL (dp), INTENT(IN OUT)     :: ca(icdim)
COMPLEX (dp), INTENT(IN OUT)  :: cb(icdim)

INTEGER       :: i, iaz, il, is, iy, k, kb, kl, kmax, ks, kyb, nb, nflg, nub
REAL (dp)     :: az, del, fk, rtola, tola, yt,  &
                 zi, zid, zr, xtol, rzi, atrm, fj, rw, rq(64), asum, htol
COMPLEX (dp)  :: yy(1), cex, sum, trm, zz, zp(64), zt, scle,  &
                 rscle, trms, zw, cezt
COMPLEX (dp), PARAMETER  :: cone = (1.0_dp, 0.0_dp)

scle = cone
rscle = cone
zr = REAL(z, KIND=dp)
zi = AIMAG(z)
zid = zi
kyb = 0
IF (zi < 0.0_dp) zid = -zid
az = ABS(z)
iaz = az + 0.5_dp
!-----------------------------------------------------------------------
!     SET ORDER NUB=MIN(N+M-1,INT(ABS(Z)+0.5)), GENERATE REMAINDER
!     OF THE SEQUENCE AFTER THE COMPUTATION OF E(NUB,Z)
!-----------------------------------------------------------------------
IF (nu < iaz) THEN
  IF (nu+n-1 <= iaz) GO TO 10
  nub = iaz
  nb = 0
  nflg = 3
  kb = nub - nu + 1
  ks = kb + 1
  kl = n
  is = 1
  il = kb - 1
  GO TO 30
END IF
nub = MAX(iaz, 1)
nb = nu - nub
nflg = 1
kb = 1
ks = 2
kl = n
GO TO 30

10 nub = nu + n - 1
nb = 0
nflg = 2
is = 2
il = n
kb = n
GO TO 30
!-----------------------------------------------------------------------
!     SET PARAMETERS FOR ANALYTIC CONTINUATION FROM Y=YB INTO THE REGION
!     0 <= ZID < YB.
!-----------------------------------------------------------------------
20 yb = yb + 0.5_dp
kyb = kyb + 1
IF (kyb > 10) RETURN
ierr = 0

30 del = yb - zid
!-----------------------------------------------------------------------
!     MAKE DEL LARGE ENOUGH TO AVOID UNDERFLOW IN GENERATION OF POWERS
!-----------------------------------------------------------------------
IF (ABS(del) <= 1.0E-4) THEN
  yb = yb + 1.0E-4
  del = yb - zid
END IF
htol = 0.125_dp * tol
zz = CMPLX(zr, yb, KIND=dp)
CALL cexenz(zz, nub, 2, 1, yy, ierr, rbry, htol, elim, alim, icdim, ca, cb)
IF (ierr == 6) GO TO 20
!-----------------------------------------------------------------------
!     ANALYTIC CONTINUATION VIA TAYLOR SERIES FOR ORDER NUB
!-----------------------------------------------------------------------
iy = del + del
yt = del / (iy+1)
sum = yy(1)
htol = 0.25_dp * tol
trm = sum
cezt = CMPLX(COS(yt), -SIN(yt), KIND=dp)
zw = cone
zp(1) = cone
fk = 1.0_dp
fj = nub - 1
zt = cone / zz
!-----------------------------------------------------------------------
!     TERMS OF THE SERIES TRM=E(NUB-K,ZZ)*(YT**K)/K!,  K=0,1,... ARE
!     GENERATED BY BACKWARD RECURRENCE.  E IS SCALED BY CEXP(ZZ).
!-----------------------------------------------------------------------
DO  k = 2, 64
  rw = yt / fk
  zw = zw * CMPLX(0.0_dp, rw, KIND=dp)
  rw = fj * rw
  trm = (zw - CMPLX(0.0_dp, rw, KIND=dp)*trm) * zt
  sum = sum + trm
  zp(k) = zw
  rq(k) = rw
  asum = ABS(sum)
  atrm = ABS(trm)
  IF (atrm < htol*asum) GO TO 50
  fk = fk + 1.0_dp
  fj = fj - 1.0_dp
END DO
k = 64

50 kmax = k
sum = sum * cezt
IF (iy /= 0) THEN
  DO  i = 1, iy
    rzi = (iy-i+1) * yt + zid
    zz = CMPLX(zr, rzi, KIND=dp)
    zt = cone / zz
    trm = sum
    DO  k = 2, kmax
      trm = (zp(k) - CMPLX(0.0_dp, rq(k), KIND=dp)*trm) * zt
      sum = sum + trm
    END DO
    atrm = ABS(trm)
    asum = ABS(sum)
    xtol = htol * asum
    IF (atrm >= xtol) THEN
      IF (kmax < 64) THEN
        kmax = kmax + 1
        DO  k = kmax, 64
          rw = yt / fk
          zw = zw * CMPLX(0.0_dp, rw, KIND=dp)
          rw = fj * rw
          trm = (zw - CMPLX(0.0_dp, rw, KIND=dp)*trm) * zt
          sum = sum + trm
          zp(k) = zw
          rq(k) = rw
          atrm = ABS(trm)
          IF (atrm < xtol) GO TO 80
          fk = fk + 1.0_dp
          fj = fj - 1.0_dp
        END DO
        k = 64

        80 kmax = k
      END IF
    END IF
    sum = sum * cezt
  END DO
END IF
!-----------------------------------------------------------------------
!     FORM SEQUENCE UP OR DOWN FROM ORDER NUB
!-----------------------------------------------------------------------
IF (zi < 0.0_dp) sum = CONJG(sum)
cex = cone
!-----------------------------------------------------------------------
!     SCALE NEAR OVERFLOW LIMIT ON KODE=1
!-----------------------------------------------------------------------
IF (kode /= 2) THEN
  IF (ABS(zr) >= alim) THEN
    IF (ABS(zr) > elim) GO TO 130
    tola = EXP(alim-elim)
    rtola = 1.0_dp / tola
    scle = tola
    rscle = rtola
  END IF
  cex = scle * EXP(-z)
END IF
trm = sum * cex
y(kb) = trm * rscle
trms = trm
IF (n == 1 .AND. nflg /= 1) RETURN
IF (nflg /= 2) THEN
  fk = nub
  IF (nflg == 1 .AND. nb /= 0) THEN
    DO  k = 1, nb
      trm = (cex - z*trm) / fk
      fk = fk + 1.0_dp
    END DO
  END IF
  y(kb) = trm * rscle
  trms = trm
  IF (n == 1) RETURN
  DO  k = ks, kl
    trm = (cex - z*trm) / fk
    y(k) = trm * rscle
    fk = fk + 1.0_dp
  END DO
  IF (nflg == 1) RETURN
END IF
k = kb - 1
fk = nub - 1
zt = cone / z
DO  i = is, il
  trms = (cex - fk*trms) * zt
  y(k) = trms * rscle
  k = k - 1
  fk = fk - 1.0_dp
END DO
RETURN

130 ierr = 3
RETURN
END SUBROUTINE cacexi

FUNCTION psixn(n) RESULT(fn_val)
!***BEGIN PROLOGUE  PSIXN
!***REFER TO  EXINT,BSKIN

!  THIS SUBROUTINE RETURNS VALUES OF PSI(X)=DERIVATIVE OF LOG GAMMA(X),
!  X > 0.0 AT INTEGER ARGUMENTS.  A TABLE LOOK-UP IS PERFORMED FOR N <= 100,
!  AND THE ASYMPTOTIC EXPANSION IS EVALUATED FOR N > 100.

!***END PROLOGUE  PSIXN

INTEGER, INTENT(IN)  :: n
REAL (dp)            :: fn_val

INTEGER    :: k
REAL (dp)  :: ax, fn, rfn2, trm, s, wdtol
!-----------------------------------------------------------------------
!             PSIXN(N), N = 1,100
!-----------------------------------------------------------------------
REAL (dp), PARAMETER  :: c(100) = (/ -5.77215664901532861D-01,  &
  4.22784335098467139D-01, 9.22784335098467139D-01, 1.25611766843180047_dp, &
  1.50611766843180047_dp, 1.70611766843180047_dp, 1.87278433509846714_dp,  &
  2.01564147795561000_dp, 2.14064147795561000_dp, 2.25175258906672111_dp,  &
  2.35175258906672111_dp, 2.44266167997581202_dp, 2.52599501330914535_dp,  &
  2.60291809023222227_dp, 2.67434666166079370_dp, 2.74101332832746037_dp,  &
  2.80351332832746037_dp, 2.86233685773922507_dp, 2.91789241329478063_dp,  &
  2.97052399224214905_dp, 3.02052399224214905_dp, 3.06814303986119667_dp,  &
  3.11359758531574212_dp, 3.15707584618530734_dp, 3.19874251285197401_dp,  &
  3.23874251285197401_dp, 3.27720405131351247_dp, 3.31424108835054951_dp,  &
  3.34995537406483522_dp, 3.38443813268552488_dp, 3.41777146601885821_dp,  &
  3.45002953053498724_dp, 3.48127953053498724_dp, 3.51158256083801755_dp,  &
  3.54099432554389990_dp, 3.56956575411532847_dp, 3.59734353189310625_dp,  &
  3.62437055892013327_dp, 3.65068634839381748_dp, 3.67632737403484313_dp,  &
  3.70132737403484313_dp, 3.72571761793728215_dp, 3.74952714174680596_dp,  &
  3.77278295570029433_dp, 3.79551022842756706_dp, 3.81773245064978928_dp,  &
  3.83947158108457189_dp, 3.86074817682925274_dp, 3.88158151016258607_dp,  &
  3.90198967342789220_dp, 3.92198967342789220_dp, 3.94159751656514710_dp,  &
  3.96082828579591633_dp, 3.97969621032421822_dp, 3.99821472884273674_dp,  &
  4.01639654702455492_dp, 4.03425368988169777_dp, 4.05179754953082058_dp,  &
  4.06903892884116541_dp, 4.08598808138353829_dp, 4.10265474805020496_dp,  &
  4.11904819067315578_dp, 4.13517722293122029_dp, 4.15105023880423617_dp,  &
  4.16667523880423617_dp, 4.18205985418885155_dp, 4.19721136934036670_dp,  &
  4.21213674247469506_dp, 4.22684262482763624_dp, 4.24133537845082464_dp,  &
  4.25562109273653893_dp, 4.26970559977879245_dp, 4.28359448866768134_dp,  &
  4.29729311880466764_dp, 4.31080663231818115_dp, 4.32413996565151449_dp,  &
  4.33729786038835659_dp, 4.35028487337536958_dp, 4.36310538619588240_dp,  &
  4.37576361404398366_dp, 4.38826361404398366_dp, 4.40060929305632934_dp,  &
  4.41280441500754886_dp, 4.42485260777863319_dp, 4.43675736968339510_dp,  &
  4.44852207556574804_dp, 4.46014998254249223_dp, 4.47164423541605544_dp,  &
  4.48300787177969181_dp, 4.49424382683587158_dp, 4.50535493794698269_dp,  &
  4.51634394893599368_dp, 4.52721351415338499_dp, 4.53796620232542800_dp,  &
  4.54860450019776842_dp, 4.55913081598724211_dp, 4.56954748265390877_dp,  &
  4.57985676100442424_dp, 4.59006084263707730_dp, 4.60016185273808740_dp /)
!-----------------------------------------------------------------------
!             COEFFICIENTS OF ASYMPTOTIC EXPANSION
!-----------------------------------------------------------------------
REAL (dp), PARAMETER  :: b(6) =  &
  (/ 8.33333333333333333D-02, -8.33333333333333333D-03, 3.96825396825396825D-03,   &
    -4.16666666666666666D-03, 7.57575757575757576D-03, -2.10927960927960928D-02 /)

IF (n <= 100) THEN
  fn_val = c(n)
  RETURN
END IF
wdtol = MAX(EPSILON(0.0_dp), 1.0D-18)
fn = n
ax = 1.0_dp
s = -0.5_dp / fn
IF (ABS(s) > wdtol) THEN
  rfn2 = 1.0_dp / (fn*fn)
  DO  k = 1, 6
    ax = ax * rfn2
    trm = -b(k) * ax
    IF (ABS(trm) < wdtol) EXIT
    s = s + trm
  END DO
END IF

fn_val = s + LOG(fn)
RETURN
END FUNCTION psixn

END MODULE Exponential_Integral

PROGRAM cqccex

! Code converted using TO_F90 by Alan Miller
! Date: 2002-03-26  Time: 19:32:11

!  CQCCEX IS A QUICK CHECK PROGRAM TO COMPARE EXPONENTIAL INTEGRALS
!  E(N,Z) FROM SUBROUTINE CEXINT,

!            CALL CEXINT(Z,N,KODE,TOL,M,CY,IERR)

!  AGAINST EXPONENTIAL INTEGRALS FROM QUADRATURE SUBROUTINE CEXQAD,

!            CALL CEXQAD(Z,N,KODE,TOL,CQ,KERR).

!  Z VALUES ARE TAKEN FROM THE REGION -6.5.LE.X.LE.5.5,-6.LE.Y.LE.6.
!  ORDERS N RUN FROM 3 TO 11 AND THE NUMBER OF MEMBERS M IN THE
!  SEQUENCE E(N+K-1,Z), K=1,M RUNS FROM 1 TO 3. BOTH SCALING OPTIONS

!             CY(K) = E(N+K-1,Z)                K=1,M     KODE=1
!                     E(N+K-1,Z)*CEXP(Z)        K=1,M     KODE=2

!  ARE CHECKED AND THE REQUESTED ACCURACY TOL IS THE LARGER OF
!  UNIT ROUNDOFF AND 1.0E-7. RELATIVE ERRORS ERR1 AND ERR2 FOR THE
!  FIRST AND LAST MEMBERS OF THE SEQUENCE ARE COMPUTED AND COMPARED
!  AGAINST 100.0*TOL. IF A CHECK DOES NOT OCCUR, Z,ERR1,ERR2,N,M,KODE
!  AND ERROR FLAGS IERR FROM CEXINT, KERR1 FROM CEXQAD, AND KERR2
!  FROM CEXQAD ARE PRINTED. VALUES CY(1),CQ1 AND CY(N+M-1),CQ2 WHICH
!  WERE COMPARED IN ERR1 AND ERR2 ARE PRINTED NEXT. KERR1.NE.0 OR
!  KERR2.NE.0 INDICATE A PREMATURE TRUNCATION OF THE INTEGRAL EVAL-
!  UATION IN CEXQAD. THE SUFFIXES 1 AND 2 CORRESPOND TO EVALUATIONS
!  AT ORDERS N AND N+M-1 RESPECTIVELY.

!  CQCCEX CALLS CEXINT,CEXQAD AND LOWER LEVEL ROUTINES CEXENZ,CACEXI,
!  PSIXN,CEXQAD,GAUS8,FQCEX,I1MACH,R1MACH,XERROR,FDUMP

USE Exponential_Integral
IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

COMPLEX (dp)  :: z, cy(10), cq1, cq2
INTEGER       :: ierr, iprnt, ix, iy, kerr1, kerr2, kode, m, n, nb
REAL (dp)     :: err1, err2, tol, x, xtol, y

iprnt = 0
tol = MAX(1.0D-15, EPSILON(0.0_dp))
xtol = tol * 100.0_dp
WRITE(*, 5000)
WRITE(*, 5100)
DO  kode = 1, 2
  DO  m = 1, 3
    DO  n = 3, 11, 2
      DO  iy = 1, 13, 3
        y = iy - 7
        WRITE(*, 5200) kode, m, n, y
        DO  ix = 2, 14, 4
          x = -7.5_dp + (ix-1)
          IF (y /= 0.0_dp .OR. x > 0.0_dp) THEN
            z = CMPLX(x, y, KIND=dp)
            CALL cexint(z, n, kode, tol, m, cy, ierr)
            nb = n
            CALL cexqad(z, nb, kode, tol, cq1, kerr1)
            err1 = ABS(cy(1)-cq1) / ABS(cq1)
            nb = n + m - 1
            CALL cexqad(z, nb, kode, tol, cq2, kerr2)
            err2 = ABS(cy(m)-cq2) / ABS(cq2)
            IF (err1 >= xtol .OR. err2 >= xtol) THEN
              IF (iprnt /= 1) THEN
                iprnt = 1
                OPEN (7, FILE='CEXDAT7', STATUS='UNKNOWN')
                WRITE (7,5300)
              END IF
              WRITE (7,5400) z, err1, err2, n, m, kode, ierr, kerr1, kerr2
              WRITE (7,5400) cy(1), cq1
              WRITE (7,5400) cy(m), cq2
            END IF
          END IF
        END DO
      END DO
    END DO
  END DO
END DO
IF (iprnt == 0) THEN
  WRITE(*, 5500)
ELSE
  WRITE(*, 5600)
END IF
STOP

5000 FORMAT (' CEXINT VS QUADRATURE FOR PARAMETERS:'/)
5100 FORMAT ('  KODE   M     N       Y        -6.5.LE.X.LE.5.5')
5200 FORMAT (i5, i5, i5, g13.5)
5300 FORMAT (' Z,ERR1,ERR2,N,M,KODE,IERR,KERR1,KERR2')
5400 FORMAT (4g11.3, 6I5)
5500 FORMAT (/' QUICK CHECKS FOR CEXINT ARE OK.')
5600 FORMAT (/' SEE DATA FILE CEXDAT7 FOR ERRORS')
END PROGRAM cqccex


subroutine calculate_face_velocity_interp(u, v, uf, vf, p, p_uf, p_vf, s_uf, s_vf, ap, dx, dy, nx, ny, xi, xf)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi, xf
real(kind=dp), intent(in), dimension(nx,xi-1:xf+1):: u, v, ap, p
real(kind=dp), intent(in):: dx(nx), dy(ny)
real(kind=dp), intent(in), dimension(nx-1,xi-1:xf+1):: p_uf, s_uf
real(kind=dp), intent(in), dimension(nx,xi-1:xf+1):: p_vf, s_vf
real(kind=dp), intent(inout), dimension(nx-1,xi-1:xf+1):: uf
real(kind=dp), intent(inout), dimension(nx,xi-1:xf+1):: vf

!! Other local variables
real(kind=dp), dimension(nx-1, xi-1:xf+1):: auf_bar
real(kind=dp), dimension(nx, xi-1:xf+1):: avf_bar
real(kind=dp):: fe_area, fn_area
integer:: iu, ju, iv, jv

do ju=xi,xf
      do iu=2,nx-2

            fe_area = dx(iu+1)/(dx(iu+1)+dx(iu))
            auf_bar(iu,ju) = 1.0d0/(fe_area/ap(iu,ju) + (1.0d0-fe_area)/ap(iu+1,ju))

      end do

end do

do ju = xi,xf

    do iu = 2,nx-2

        uf(iu,ju) = 0.50d0*(u(iu,ju) + u(iu+1,ju)) + 1.0d0/auf_bar(iu,ju)*((p(iu,ju) - p(iu+1,ju))*dy(ju) + s_uf(iu,ju)) - 0.50d0*(1.0d0/ap(iu,ju)*(p_uf(iu-1,ju)-p_uf(iu,ju))*dy(ju) + 1.0d0/ap(iu+1,ju)*(p_uf(iu,ju)-p_uf(iu+1,ju))*dy(ju))
!        uf(iu,ju) = 0.50d0*(u(iu,ju) + u(iu+1,ju)) + 1.0d0/auf_bar(iu,ju)*((p(iu,ju) - p(iu+1,ju))*dy(ju)) - 0.50d0*(1.0d0/ap(iu,ju)*(p_uf(iu-1,ju)-p_uf(iu,ju))*dy(ju) + 1.0d0/ap(iu+1,ju)*(p_uf(iu,ju)-p_uf(iu+1,ju))*dy(ju))
!
    end do

end do

do jv = xi,xf

      do iv = 2,nx-1

            fn_area = dy(jv+1)/(dy(jv+1)+dy(jv))
            avf_bar(iv,jv) = 1.0d0/(fn_area/ap(iv,jv) + (1.0d0-fn_area)/ap(iv,jv+1))

      end do

end do

do jv = xi,xf

    do iv = 2,nx-1

        vf(iv,jv) = 0.50d0*(v(iv,jv) + v(iv,jv+1)) + 1.0d0/avf_bar(iv,jv)*((p(iv,jv) - p(iv,jv+1))*dx(iv) + s_vf(iv,jv)) - 0.50d0*(1.0d0/ap(iv,jv)*(p_vf(iv,jv-1)-p_vf(iv,jv))*dx(iv) + 1.0d0/ap(iv,jv+1)*(p_vf(iv,jv)-p_vf(iv,jv+1))*dx(iv))
!        vf(iv,jv) = 0.50d0*(v(iv,jv) + v(iv,jv+1)) + 1.0d0/avf_bar(iv,jv)*((p(iv,jv) - p(iv,jv+1))*dx(iv)) - 0.50d0*(1.0d0/ap(iv,jv)*(p_vf(iv,jv-1)-p_vf(iv,jv))*dx(iv) + 1.0d0/ap(iv,jv+1)*(p_vf(iv,jv)-p_vf(iv,jv+1))*dx(iv))

    end do

end do

if (xf .eq. ny-1) then

    do iv = 2,nx-1

        vf(iv,ny-1) = v(iv,ny)

    end do

end if

call exchange_data(uf, nx-1, xi, xf)
call exchange_data(vf, nx, xi, xf)

end subroutine


! Code by: Jostein Brandshoi

! ---------------------------------------------------------------------------------------------------------------
! Compile/run on Windows:
! > gfortran -o storm_surge.exe storm_surge.f90
! > storm_surge.exe <output_filename>
!
! Compile/run on Linux:
! > gfortran -o storm_surge storm_surge.f90
! > ./storm_surge <output_filename>
!
! Command line args:
!     output_filename : Give a filename (*.dat) to store numerical solutions
!
! Purpose of program:
!   Solve exercise k) (linear rotating (with wind stress and friction) shallow water
!   equations applied to a storm surge problem) on Problem Set 10 in GEF4510
!
! Equations:
!   dU/dt - fV = -gH_0 * dh/dx + (tau_sx - tau_bx) / rho_0
!   dV/dt + fU = (tau_sy - tau_by) / rho_0
!   dh/dt \ dU/dx = 0
!
! Scheme (FBTCS):
!   U(j, n+1) = U(j, n) + dt * f * V(j, n) - ((g * H_0 * dt) / dx) *&
!       (h(j + 1, n) - h(j, n)) + (dt / rho_0) * (tau_sx - tau_bx_coeff * U(j, n))
!
!   V(j, n+1) = V(j, n) - dt * f * U(j, n+1) + (dt / rho_0) * &
!       (tau_sy - tau_by_coeff * V(j, n))
!
!   h(j, n+1) = h(j, n) - (dt / dx) * (U(j, n+1) - U(j - 1, n+1))
! ---------------------------------------------------------------------------------------------------------------

PROGRAM advection_solver
    IMPLICIT NONE
    ! ------------------------------- VARIABLE DECLARATIONS -------------------------------
    double precision, parameter :: g = 10.0              ! Accelereation of gravity [m/s^2]
    double precision, parameter :: rho_0 = 1E+3          ! Uniform constant density [kg/m^3]
    double precision, parameter :: f = 1E-4              ! Coriolis parameter [s^(-1)]
    double precision, parameter :: R = 2.4E-3            ! Factor used in bottom stress [m/s]
    double precision, parameter :: H_0 = 300.0           ! Equillibrium height [m]
    double precision, parameter :: c_0 = dsqrt(g * H_0)  ! Phase speed [m/s]
    double precision, parameter :: L_R = c_0 / f         ! Rossby's deformation radius [m]
    double precision, parameter :: L = L_R * 10.0        ! Max distance from coast [m]
    double precision, parameter :: tau_sx = 0.0          ! Surface wind stress (x-dir) [Pa]
    double precision, parameter :: tau_sy = 0.1          ! Surface wind stress (y-dir) [Pa]
    double precision, parameter :: tau_bx_coeff = (rho_0 * R) / H_0  ! Bottom stress coeff (x-dir) [kg/m^3s]
    double precision, parameter :: tau_by_coeff = (rho_0 * R) / H_0  ! Bottom stress coeff (y-dir) [kg/m^3s]

    double precision, parameter :: C = 0.80              ! Courant number [c_0 * delta_t / delta_x] [m/s]
    double precision, parameter :: dx = L_R / 10.0       ! Distance between spatial gridpoints [m]
    double precision, parameter :: dt = C * dx / c_0     ! Time between temporal gridpoints [s]

    integer :: j, n                                      ! Counter variables (j: space, n: time)
    integer :: n_temp, n_curr = 1, n_next = 2            ! Indices to represent curr and next time
    integer, parameter :: j_max = idnint(L / dx) + 1     ! Total number of space points in domain
    integer, parameter :: n_max = 1000                   ! Some arbitrary upper bound for simulation time

    double precision, dimension(j_max, 2) :: U = 0.0     ! To store U at times n and n + 1 (also sets IC)
    double precision, dimension(j_max, 2) :: V = 0.0     ! To store V at times n and n + 1 (also sets IC)
    double precision, dimension(j_max, 2) :: h = H_0     ! To store h at times n and n + 1 (also sets IC)

    character(len = 32) :: output_filename               ! Variable to hold output filename for results
    integer, parameter :: unit_number = 10               ! Unit number for identifying output file
    ! -------------------------------------------------------------------------------------

    ! ---------- GETTING ARGS FROM CMD-LINE AND OPEN .DAT FILE FOR RESULT OUTPUT ----------
    CALL GET_COMMAND_ARGUMENT(1, output_filename)                ! Get cmd-line arg for output file
    open(unit = unit_number, file = output_filename, form = "formatted")  ! Open file that will store results
    ! -------------------------------------------------------------------------------------

    ! ---------------------------- USING FBTCS SCHEME AND BC'S ----------------------------
    do n = 0, n_max - 1         ! Loop, in time to compute all three variables U, V, h
        U(j_max, n_next) = 0.0  ! BC: No flow through coast
        h(1, n_next) = H_0      ! BC: Ekman solution at position far away from coast

        do j = 1, j_max - 1     ! Loop in space to compute U_j^(n+1)
            U(j, n_next) = U(j, n_curr) + dt * f * V(j, n_curr) - ((g * H_0 * dt) / dx) *&
                (h(j + 1, n_curr) - h(j, n_curr)) + (dt / rho_0) * (tau_sx - tau_bx_coeff * U(j, n_curr))
        end do

        do j = 1, j_max         ! Loop in space to compute V_j^(n+1)
            V(j, n_next) = V(j, n_curr) - dt * f * U(j, n_next) + (dt / rho_0) * &
                (tau_sy - tau_by_coeff * V(j, n_curr))
        end do

        do j = 2, j_max         ! Loop in space to compute h_j^(n+1)
            h(j, n_next) = h(j, n_curr) - (dt / dx) * (U(j, n_next) - U(j - 1, n_next))
        end do

        ! Write line-wise to file. Write only solution for half the domain (closest to coast) to file.
        write(unit = 10, fmt = "(157f20.14)") float(n), U(50:, n_curr), V(50:, n_curr), h(50:, n_curr)

        n_temp = n_next     ! Set help index to next time step column column
        n_next = n_curr     ! Set next time step index to current ime step column
        n_curr = n_temp     ! Set current time step index to next time step column
    end do
    ! -------------------------------------------------------------------------------------

    close(unit = unit_number)    ! Close file after writing

END PROGRAM advection_solver


C*****************************************************************
      FUNCTION F0(ARG)
C                                                                *
C     CALCULATES THE ERROR FUNCTION ACCORDING TO A RATIONAL      *
C     APPROXIMATION FROM M. ABRAMOWITZ AND I.A. STEGUN,          *
C     ABSOLUTE ERROR IS LESS THAN 1.5*10**(-7)                   *
C     CAN BE REPLACED BY A BUILT-IN FUNCTION ON SOME MACHINES    *
C                                                                *
C*****************************************************************
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION A(5)
      DATA P/0.3275911D0/
      DATA A/0.254829592D0,-0.284496736D0,1.421413741D0,
     $ -1.453152027D0,1.061405429D0/
      real*8 SARG
      real*8 ERF

      if (ARG.lt.1.0D-6) then
        F0=1.0D0-ARG/3.0D0
        return
      endif

      SARG = sqrt(ARG)
      T=1.0D0/(1.0D0+P*SARG)
      TN=T
      POLY=A(1)*TN
      DO 10 I=2,5
      TN=TN*T
      POLY=POLY+A(I)*TN
   10 CONTINUE
      ERF=1.0D0-POLY*DEXP(-ARG)

      F0 = 0.886226925452758014 / SARG * ERF
      RETURN
      END
C***************************************************************


!-----------------------------------------------------------------------
! Fortran GPU Tutorial: Reduction
! written by Viktor K. Decyk, UCLA
      module redux
      implicit none
!
      contains
!
      subroutine sum0(a,sa)
! simple 1d sum reduction of length nx
! sa = sum(a)
      implicit none
      real :: sa
      real, dimension(:) :: a
! local data
      integer :: j
!
      sa = 0.0
      do j = 1, size(a,1)
         sa = sa + a(j)
      enddo
!
      end subroutine
!
      subroutine sum1(a,sa,mx)
! 1d sum reductions, each of length mx
! sa = sum(a)
      implicit none
      integer :: mx
      real :: sa
      real, dimension(:) :: a
! local data
      integer :: j, js, jb, nx, nbx
      real :: t
! nx = size of a array
      nx = size(a,1)
! nbx = number of blocks
      nbx = (nx - 1)/mx + 1
!
      sa = 0.0
      do jb = 1, nbx
      t = 0.0
      do js = 1, min(mx,nx-mx*(jb-1))
         j = js + mx*(jb - 1)
         t = t + a(j)
      enddo
      sa = sa + t

      enddo
!
      end subroutine
!
      subroutine sum2(a,d,mx)
! segmented 1d sum reductions, each of length mx
! forall (j = 1:nbx); d(j) = sum(a(1+mx*(j-1):min(nx,mx*j))); end forall
      implicit none
      integer :: mx
      real, dimension(:) :: a, d
! local data
      integer :: j, js, jb, nx, nbx
      real :: t
! nx = size of a array
      nx = size(a,1)
! nbx = number of blocks
      nbx = (nx - 1)/mx + 1
!
      do jb = 1, nbx
      t = 0.0
      do js = 1, min(mx,nx-mx*(jb-1))
         j = js + mx*(jb - 1)
         t = t + a(j)
      enddo
      d(jb) = t
      enddo
!
      end subroutine
!
      end module


MODULE NRTYPE
	IMPLICIT NONE
 	!-----------------------------------------------------------
	INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
	INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
	INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
	INTEGER, PARAMETER :: SP = KIND(1.0)
	INTEGER, PARAMETER :: DP = KIND(1.0D0)
	INTEGER, PARAMETER :: SPC = KIND((1.0,1.0))
	INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
	INTEGER, PARAMETER :: LGT = KIND(.TRUE.)
	REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_SP
	REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_SP
	REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_SP
	REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_SP
	REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_SP
	REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_DP
	REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_DP
	REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_DP
	TYPE SPRS2_SP
		INTEGER(I4B) :: N,NELT
		REAL(SP), DIMENSION(:), POINTER :: VAL
		INTEGER(I4B), DIMENSION(:), POINTER :: IROW
		INTEGER(I4B), DIMENSION(:), POINTER :: JCOL
	END TYPE SPRS2_SP
	TYPE SPRS2_DP
		INTEGER(I4B) :: N,NELT
		REAL(DP), DIMENSION(:), POINTER :: VAL
		INTEGER(I4B), DIMENSION(:), POINTER :: IROW
		INTEGER(I4B), DIMENSION(:), POINTER :: JCOL
	END TYPE SPRS2_DP
	 !-----------------------------------------------------------
END MODULE NRTYPE


    PROGRAM Testo
     USE Integer_Complex_Arithmetic
     IMPLICIT NONE
     TYPE(INTCOMPLEX) :: var1, var2, ans

     var1 = 3
     PRINT*, "var1 = 3"
     CALL Put_INTCOMPLEX(var1)

     var1 = 5.99
     PRINT*, "var1 = 5.99"
     CALL Put_INTCOMPLEX(var1)

     var1 = 6.01
     PRINT*, "var1 = 6.01"
     CALL Put_INTCOMPLEX(var1)

     var1 = Setup_INTCOMPLEX(1,2)
     var2 = Setup_INTCOMPLEX(3,4)

     PRINT*, "(1,2)+(3,4)"
     ans = var1 + var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(1,2)-(3,4)"
     ans = var1 - var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(1,2)/(3,4)"
     ans = var1 / var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(3,4)/(3,4)"
     ans = var2 / var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(3,4)/(1,2)"
     ans = var2 / var1
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(1,2)*(3,4)"
     ans = var1 * var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(1,2)**3"
     ans = var1 ** 3
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "+(1,2)"
     ans = +var1
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "-(1,2)"
     ans = -var1
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "Type in the two INTCOMPLEX components"
     CALL Get_INTCOMPLEX(var1)
     PRINT*, "This is what was typed in"
     CALL Put_INTCOMPLEX(var1)

     PRINT*, "Your number/(3,4)"
     ans = var1 / var2
     CALL Put_INTCOMPLEX(ans)

! Intrinsics

     PRINT*, "REAL(3,4)"
     PRINT*, REAL(var2)
     PRINT*, "INT(3,4)"
     PRINT*, INT(var2)
     PRINT*, "AIMAG(3,4)"
     PRINT*, AIMAG(var2)
     PRINT*, "CONJG(3,4)"
     CALL Put_INTCOMPLEX(CONJG(var2))
     PRINT*, "ABS(3,4)"
     PRINT*, ABS(var2)

! REAL | INTEGER .OP. INTCOMPLEX

     PRINT*, "2+(3,4)"
     ans =  2 + var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "2-(3,4)"
     ans =  2 - var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "2*(3,4)"
     ans =  2 * var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "2/(3,4)"
     ans =  2 /var2
     CALL Put_INTCOMPLEX(ans)

     var1 = Setup_INTCOMPLEX(1,2)
     PRINT*, "4/(1,2)"
     ans =  4/var1
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "2.5+(3,4)"
     ans =  2.5 + var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "2.5-(3,4)"
     ans =  2.5 - var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "2.5*(3,4)"
     ans =  2 * var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "2.5/(3,4)"
     ans =  2.5 /var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "4.7/(1,2)"
     ans =  4.7/var1
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "-2.5+(3,4)"
     ans =  -2.5 + var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "-2.5-(3,4)"
     ans =  -2.5 - var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "-2.5*(3,4)"
     ans =  -2.5 * var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "-2.5/(3,4)"
     ans =  -2.5 /var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "-4.7/(1,2)"
     ans =  -4.7/var1
     CALL Put_INTCOMPLEX(ans)

! INTCOMPLEX .OP. INTEGER | REAL

     PRINT*, "(3,4)+2"
     ans =  var2 + 2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "3,4)-2"
     ans =  var2-2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(3,4) * 2"
     ans =  var2 * 2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(3,4)/2"
     ans =  var2/2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(1,2)/4"
     ans =  var1/4
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(3,4)+2.5"
     ans =  var2+2.5
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(3,4)-2.5"
     ans =  var2-2.5
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(3,4)*2.5"
     ans =   var2*2.5
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(3,4)/2.5"
     ans =  var2/2.5
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(1,2)/4.7"
     ans =  var1/4.7
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "-(3,4)-2.5"
     ans =   -var2-2.5
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "(3,4)*(-2.5)"
     ans =  var2*(-2.5)
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "0.99 * (3,4)"
     ans = 0.99 *var2
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "1.0 * (3,4)"
     ans = 1.0 *var2
     CALL Put_INTCOMPLEX(ans)

! Extended precision

     var1 = Setup_INTCOMPLEX(3_short_int,1_long_int)
     PRINT*, "var1 = Setup_INTCOMPLEX(3_short_int,1_long_int)"
     CALL Put_INTCOMPLEX(var1)

     var1 = Setup_INTCOMPLEX(3_short_int,1_short_int)
     PRINT*, "var1 = Setup_INTCOMPLEX(3_short_int,1_short_int)"
     CALL Put_INTCOMPLEX(var1)

     var1 = Setup_INTCOMPLEX(3_long_int,1_short_int)
     PRINT*, "var1 = Setup_INTCOMPLEX(3_long_int,1_short_int)"
     CALL Put_INTCOMPLEX(var1)

     PRINT*, "var1 = Setup_INTCOMPLEX(3_long_int,1_long_int)"
     var1 = Setup_INTCOMPLEX(3_long_int,1_long_int)
     CALL Put_INTCOMPLEX(var1)

     PRINT*, "200_short_int * Setup_INTCOMPLEX(3_long_int,1_long_int)"
     ans = 200_short_int * var1
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "Setup_INTCOMPLEX(3_long_int,1_long_int) - 20_short_int"
     ans = var1 - 20_short_int
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "Setup_INTCOMPLEX(3_long_int,1_long_int) ** 200_short_int"
     ans = var1 ** 6_short_int
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "var ** 6_long_int"
     ans = var1 ** 6_long_int
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "var1 = Setup_INTCOMPLEX(30000_long_int,10000_long_int)"
     var1 = Setup_INTCOMPLEX(30000_long_int,10000_long_int)
     CALL Put_INTCOMPLEX(var1)

     PRINT*, "400_long_int / Setup_INTCOMPLEX(30000_long_int,10000_long_int)"
     ans = 400_long_int / var1
     CALL Put_INTCOMPLEX(ans)

     PRINT*, "Setup_INTCOMPLEX(30000_long_int,10000_long_int) / 4000000"
     ans = var1 / 4000000_long_int
     CALL Put_INTCOMPLEX(ans)

    END PROGRAM Testo


PROGRAM pg124
!-------------------------------------------------------------------------
!     program 12.4 three dimensional transient analysis of heat conduction
!     equation using 8-node hexahedral elements; DEC, parallel pcg version
!     implicit; integration in time using 'theta' method
!-------------------------------------------------------------------------
!USE mpi_wrapper  !remove comment for serial compilation
 USE precision; USE global_variables; USE mp_interface; USE input
 USE output; USE loading; USE timing; USE maths; USE gather_scatter
 USE geometry; USE new_library; USE common_mod; USE geometry_mod
 IMPLICIT NONE
!neq,ntot are now global variables - not declared
 INTEGER, PARAMETER::ndim=3,nodof=1,nprops=5
 INTEGER::nod,nn,nr,nip,i,j,k,l,m,iters,limit,iel,nstep,npri,nres,it,prog, &
   nlen,node_end,node_start,nodes_pp,loaded_freedoms,fixed_freedoms,is,  &
   fixed_freedoms_pp,fixed_freedoms_start,loaded_freedoms_pp,np_types,   &
   loaded_freedoms_start,nels,ndof,npes_pp,meshgen,partitioner,tz
 REAL(iwp)::kx,ky,kz,det,theta,dtim,real_time,tol,alpha,beta,up,big,q,   &
   rho,cp,val0
 REAL(iwp),PARAMETER::zero=0.0_iwp,penalty=1.e20_iwp,t0=0.0_iwp
 CHARACTER(LEN=15)::element; CHARACTER(LEN=50)::argv,fname
 CHARACTER(LEN=6)::ch; LOGICAL::converged=.false.
 REAL(iwp),ALLOCATABLE::loads_pp(:),u_pp(:),p_pp(:),points(:,:),kay(:),&
   fun(:),jac(:,:),der(:,:),deriv(:,:),weights(:),d_pp(:),col(:,:),      &
   kc(:,:),pm(:,:),funny(:,:),storka_pp(:,:,:),row(:,:),prop(:,:),       &
   storkb_pp(:,:,:),x_pp(:),xnew_pp(:),pmul_pp(:,:),utemp_pp(:,:),       &
   diag_precon_pp(:),diag_precon_tmp(:,:),g_coord_pp(:,:,:),timest(:),   &
   ttr_pp(:),eld_pp(:,:),val(:,:),val_f(:),store_pp(:),r_pp(:),          &
   kcx(:,:),kcy(:,:),kcz(:,:),eld(:)
 INTEGER,ALLOCATABLE::rest(:,:),g_num_pp(:,:),g_g_pp(:,:),no(:),         &
   no_pp(:),no_f_pp(:),no_pp_temp(:),sense(:),node(:),etype_pp(:)

 INTEGER :: n_smplx
 INTEGER, ALLOCATABLE :: smplx(:,:)
 REAL(iwp):: ka
!--------------------------input and initialisation-----------------------
 ALLOCATE(timest(20)); timest=zero; timest(1)=elap_time()
 CALL find_pe_procs(numpe,npes); CALL getname(argv,nlen)
 CALL read_p124(argv,numpe,dtim,element,fixed_freedoms,limit,            &
   loaded_freedoms,meshgen,nels,nip,nn,nod,npri,nr,nres,nstep,           &
   partitioner,theta,tol,np_types,val0)
 CALL calc_nels_pp(argv,nels,npes,numpe,partitioner,nels_pp)
 ndof=nod*nodof; ntot=ndof
 ALLOCATE(g_num_pp(nod,nels_pp),g_coord_pp(nod,ndim,nels_pp),            &
   etype_pp(nels_pp),prop(nprops,np_types))
 g_num_pp=0; g_coord_pp=zero; etype_pp=0; prop=zero
 IF (nr>0) THEN; ALLOCATE(rest(nr,nodof+1)); rest=0; END IF
 CALL read_elements(argv,iel_start,nn,npes,numpe,etype_pp,g_num_pp)
 IF(meshgen==2) CALL abaqus2sg(element,g_num_pp)
 CALL read_g_coord_pp(argv,g_num_pp,nn,npes,numpe,g_coord_pp)
 IF (nr>0) CALL read_rest(argv,numpe,rest)
 CALL read_material(argv,prop,numpe,npes)
 ALLOCATE (points(nip,ndim),weights(nip),kay(ndim),fun(nod),        &
   jac(ndim,ndim),der(ndim,nod),deriv(ndim,nod),pm(ntot,ntot),           &
   kc(ntot,ntot),funny(1,nod),g_g_pp(ntot,nels_pp),                      &
   storka_pp(ntot,ntot,nels_pp),eld(ntot),col(ntot,1),row(1,ntot),       &
   utemp_pp(ntot,nels_pp),storkb_pp(ntot,ntot,nels_pp),                  &
   pmul_pp(ntot,nels_pp),kcx(ntot,ntot),kcy(ntot,ntot),kcz(ntot,ntot))
!----------  find the steering array and equations per process -----------
 timest(2)=elap_time(); g_g_pp=0; neq=0
 IF(nr>0) THEN; CALL rearrange_2(rest)
   elements_1: DO iel = 1, nels_pp
     CALL find_g4(g_num_pp(:,iel),g_g_pp(:,iel),rest)
   END DO elements_1
 ELSE
   g_g_pp=g_num_pp  !When nr = 0, g_num_pp and g_g_pp are identical
 END IF
 neq=MAXVAL(g_g_pp); neq=max_p(neq); CALL calc_neq_pp
 CALL calc_npes_pp(npes,npes_pp); CALL make_ggl(npes_pp,npes,g_g_pp)
 DO i=1,neq_pp;IF(nres==ieq_start+i-1)THEN;it=numpe;is=i;END IF;END DO
 IF(numpe==it)THEN
   OPEN(11,FILE=argv(1:nlen)//'.res',STATUS='REPLACE',ACTION='WRITE')
   WRITE(11,'(A,I5,A)')"This job ran on ", npes,"  processes"
   WRITE(11,'(A,3(I7,A))')"There are ",nn," nodes",nr,                   &
     " restrained and   ",neq," equations"
   WRITE(11,'(A,F10.4)')"Time after setup is ",elap_time()-timest(1)
 END IF
 ALLOCATE(loads_pp(neq_pp),diag_precon_pp(neq_pp),u_pp(neq_pp),          &
   d_pp(neq_pp),p_pp(neq_pp),x_pp(neq_pp),xnew_pp(neq_pp),r_pp(neq_pp))
 loads_pp=zero; diag_precon_pp=zero; u_pp=zero; r_pp=zero; d_pp=zero
 p_pp=zero; x_pp=zero; xnew_pp=zero
!-------------- element stiffness using DEC and storage ----------------
 storka_pp=zero; storkb_pp=zero;  dim_cmplx = 3;  dim_embbd = 3;  k=dim_cmplx+1
 ALLOCATE(num_pelm_pp(1)); num_pelm_pp(1)=nod;  extra_pelm=0;  glb_offset=0
 glb_num_elm = (/ nod, 19, 18, 6 /);  num_elm=glb_num_elm
 ALLOCATE(lcl_complex(k));
 ALLOCATE(lcl_complex(1)%centers(nod,dim_embbd),&
   lcl_complex(k)%orientation(6),lcl_complex(k)%node_indx(6,k))
 lcl_complex(k)%orientation=0;  indx_offset = 0
 elements_3: DO iel=1,nels_pp
    kc=zero; pm=zero;
    kay(1)=prop(1,etype_pp(iel)); kay(2)=prop(2,etype_pp(iel));
    kay(3)=prop(3,etype_pp(iel)); rho=prop(4,etype_pp(iel))
    cp=prop(5,etype_pp(iel))

   !- split elements into simplices
   CALL elm2smplx(num_elm(dim_cmplx+1),lcl_complex(dim_cmplx+1)%node_indx,&
      g_coord_pp(:,:,iel),element,nod)

   !- Recursively compute element (co-)boundaries
   DO k=dim_cmplx+1,2,-1; CALL calc_bndry_cobndry(k); END DO

   !- setup connectivity
   DO k=1,dim_cmplx+1
     lcl_complex(k)%lcl_node_indx = lcl_complex(k)%node_indx
   END DO

   !- calc circumcenter
   lcl_complex(1)%centers = g_coord_pp(:,:,iel)
   DO k=2,dim_cmplx+1; CALL calc_circumcenters(k); END DO

   !- calc primal edge and dual area and primal direction
   CALL calc_prml_unsgnd_vlm(2);  CALL calc_dual_vlm(1);  CALL calc_prml_dir()

   kcx=zero
   DO i=1,nod
     DO j=1,lcl_complex(1)%num_cobndry(i)
       k = lcl_complex(1)%cobndry(i)%indx(j)
       IF (ABS(lcl_complex(2)%dual_volume(k) / &
          max(lcl_complex(2)%prml_volume(k),small))<smalls) CYCLE
       m = lcl_complex(2)%bndry(k)%indx(1)
       IF (i==m) m = lcl_complex(2)%bndry(k)%indx(2)
       ka = DOT_PRODUCT(kay,abs(lcl_complex(2)%prml_dir(k,:)))
       kc(i,m) = kc(i,m) - ka*lcl_complex(2)%dual_volume(k) / &
          max(lcl_complex(2)%prml_volume(k),small)
       kc(i,i) = kc(i,i) + ka*lcl_complex(2)%dual_volume(k) / &
          max(lcl_complex(2)%prml_volume(k),small)
     END DO
     pm(i,i) = pm(i,i) + lcl_complex(1)%dual_volume(i)*rho*cp
   END DO
   storka_pp(:,:,iel)=pm+kc*theta*dtim
   storkb_pp(:,:,iel)=pm-kc*(1._iwp-theta)*dtim

   !- Deallocate variables
   DO k=1,dim_cmplx+1;
     IF (ALLOCATED(lcl_complex(k)%recv_indx))   DEALLOCATE(lcl_complex(k)%recv_indx)
     IF (ALLOCATED(lcl_complex(k)%num_bndry))   DEALLOCATE(lcl_complex(k)%num_bndry)
     IF (ALLOCATED(lcl_complex(k)%bndry))       DEALLOCATE(lcl_complex(k)%bndry)
     IF (ALLOCATED(lcl_complex(k)%num_cobndry)) DEALLOCATE(lcl_complex(k)%num_cobndry)
     IF (ALLOCATED(lcl_complex(k)%cobndry))     DEALLOCATE(lcl_complex(k)%cobndry)
     IF (ALLOCATED(lcl_complex(k)%node_indx))   DEALLOCATE(lcl_complex(k)%node_indx)
   END DO
 END DO elements_3
!------------------ build the diagonal preconditioner --------------------
 ALLOCATE(diag_precon_tmp(ntot,nels_pp)); diag_precon_tmp = zero
 elements_4: DO iel = 1,nels_pp
   DO k=1,ntot
     diag_precon_tmp(k,iel)=diag_precon_tmp(k,iel)+storka_pp(k,k,iel)
   END DO
 END DO elements_4; CALL scatter(diag_precon_pp,diag_precon_tmp)
 DEALLOCATE(diag_precon_tmp)
!------------- read in fixed freedoms and assign to equations ------------
 IF(fixed_freedoms > 0) THEN
   ALLOCATE(node(fixed_freedoms),no_pp_temp(fixed_freedoms),             &
     no(fixed_freedoms),sense(fixed_freedoms),val_f(fixed_freedoms))
   node=0; no=0; no_pp_temp=0; sense=0; val_f = zero
   CALL read_fixed(argv,numpe,node,sense,val_f)
   CALL find_no2(g_g_pp,g_num_pp,node,sense,no)
   CALL reindex(ieq_start,no,no_pp_temp,fixed_freedoms_pp,               &
     fixed_freedoms_start,neq_pp)
   ALLOCATE(no_f_pp(fixed_freedoms_pp),store_pp(fixed_freedoms_pp))
   no_f_pp=0; store_pp=zero; no_f_pp=no_pp_temp(1:fixed_freedoms_pp)
   DEALLOCATE(node,no,sense,no_pp_temp)
 END IF
 IF(fixed_freedoms==0) fixed_freedoms_pp=0
!-------------------------- invert preconditioner ------------------------
 IF(fixed_freedoms_pp > 0) THEN
   DO i=1,fixed_freedoms_pp; l=no_f_pp(i)-ieq_start+1
     diag_precon_pp(l)=diag_precon_pp(l)+penalty
     store_pp(i)=diag_precon_pp(l)
   END DO
 END IF; diag_precon_pp=1._iwp/diag_precon_pp
!--------------- read in loaded nodes and get starting r_pp --------------
 IF(loaded_freedoms>0) THEN
   ALLOCATE(node(loaded_freedoms),val(nodof,loaded_freedoms),            &
     no_pp_temp(loaded_freedoms)); val=zero; node=0; no_pp_temp=0
   CALL read_loads(argv,numpe,node,val)
   CALL reindex(ieq_start,node,no_pp_temp,loaded_freedoms_pp,            &
     loaded_freedoms_start,neq_pp); ALLOCATE(no_pp(loaded_freedoms_pp))
   no_pp=0; no_pp=no_pp_temp(1:loaded_freedoms_pp)
   DEALLOCATE(no_pp_temp,node)
 END IF
 IF(loaded_freedoms==0) loaded_freedoms_pp=0
!------------------------- start time stepping loop ----------------------
 CALL calc_nodes_pp(nn,npes,numpe,node_end,node_start,nodes_pp)
 ALLOCATE(ttr_pp(nodes_pp),eld_pp(ntot,nels_pp))
 ttr_pp=zero; eld_pp=zero
 IF(numpe==it)                                                           &
   WRITE(11,'(A)') "  Time       Temperature  Iterations "
 IF(numpe==1) THEN
   OPEN(13, file=argv(1:nlen)//'.npp', status='replace', action='write')
   WRITE(13,*) nn; WRITE(13,*) nstep/npri; WRITE(13,*) npes
 END IF
 timesteps: DO j=1,nstep
    real_time=j*dtim; timest(3)=elap_time(); loads_pp=zero
!---- apply loads (sources and/or sinks) supplied as a boundary value ----
    IF(loaded_freedoms_pp>0) THEN
      DO i=1,loaded_freedoms_pp; k=no_pp(i)-ieq_start+1
        loads_pp(k)=val(loaded_freedoms_start+i-1,1)*dtim
      END DO;  q=q+SUM_P(loads_pp)
    END IF
!- compute RHS of time stepping equation, using storkb_pp, add to loads --
    u_pp=zero; pmul_pp=zero; utemp_pp=zero
    IF(j/=1) THEN
      CALL gather(xnew_pp,pmul_pp)
      elements_2a: DO iel=1,nels_pp
        utemp_pp(:,iel)=MATMUL(storkb_pp(:,:,iel),pmul_pp(:,iel))
      END DO elements_2a; CALL scatter(u_pp,utemp_pp)
      IF(fixed_freedoms_pp>0) THEN
        DO i=1,fixed_freedoms_pp; l=no_f_pp(i)-ieq_start+1
          k=fixed_freedoms_start+i-1; u_pp(l)=store_pp(i)*val_f(k)
        END DO
      END IF; loads_pp=loads_pp+u_pp
    ELSE
!------------------------ set initial temperature ------------------------
      x_pp=val0; IF(numpe==it) WRITE(11,'(2e12.4)') 0.0_iwp, x_pp(is)
      IF(fixed_freedoms_pp>0) THEN
        DO i=1,fixed_freedoms_pp; l=no_f_pp(i)-ieq_start+1
          k=fixed_freedoms_start+i-1; x_pp(l)=val_f(k)
        END DO
      END IF
      CALL gather(x_pp,pmul_pp)
      elements_2c: DO iel=1,nels_pp
        utemp_pp(:,iel)=MATMUL(storka_pp(:,:,iel),pmul_pp(:,iel))
      END DO elements_2c; CALL scatter(u_pp,utemp_pp)
      loads_pp=loads_pp+u_pp; tz=0
!----------------------- output "results" at t=0 -------------------------
      IF(numpe==1)THEN; WRITE(ch,'(I6.6)') tz
        OPEN(12,file=argv(1:nlen)//".ensi.NDTTR-"//ch,status='replace',  &
          action='write')
        WRITE(12,'(A)')                                                  &
          "Alya Ensight Gold --- Scalar per-node variable file"
        WRITE(12,'(A/A/A)') "part", "    1","coordinates"
      END IF
      eld_pp=zero; ttr_pp=zero; CALL gather(x_pp(1:),eld_pp)
      CALL scatter_nodes(npes,nn,nels_pp,g_num_pp,nod,nodof,nodes_pp,    &
        node_start,node_end,eld_pp,ttr_pp,1)
      CALL dismsh_ensi_p(12,1,nodes_pp,npes,numpe,1,ttr_pp)
!     CALL dismsh_pb(12,1,nodes_pp,npes,numpe,1,ttr_pp)
    END IF
!----- when x=0. p and r are just loads but in general p=r=loads-A*x -----
    r_pp=zero; pmul_pp=zero; utemp_pp=zero; x_pp=zero
    CALL gather(x_pp,pmul_pp)
    elements_2b: DO iel=1,nels_pp
      utemp_pp(:,iel)=MATMUL(storka_pp(:,:,iel),pmul_pp(:,iel))
    END DO elements_2b; CALL scatter(r_pp,utemp_pp)
    IF(fixed_freedoms_pp>0) THEN
      DO i=1,fixed_freedoms_pp; l=no_f_pp(i)-ieq_start+1
        k=fixed_freedoms_start+i-1; r_pp(l)=store_pp(i)*val_f(k)
      END DO
    END IF
    r_pp=loads_pp-r_pp; d_pp=diag_precon_pp*r_pp; p_pp=d_pp; iters=0
!---------------- solve simultaneous equations by pcg --------------------
    iterations: DO
      iters=iters+1; u_pp=zero; pmul_pp=zero; utemp_pp=zero
      CALL gather(p_pp,pmul_pp)
      elements_6: DO iel=1,nels_pp
        utemp_pp(:,iel)=MATMUL(storka_pp(:,:,iel),pmul_pp(:,iel))
      END DO elements_6; CALL scatter(u_pp,utemp_pp)
      IF(fixed_freedoms_pp>0) THEN; DO i=1,fixed_freedoms_pp
          l=no_f_pp(i)-ieq_start+1; u_pp(l)=p_pp(l)*store_pp(i)
      END DO; END IF
      up=DOT_PRODUCT_P(r_pp,d_pp); alpha=up/DOT_PRODUCT_P(p_pp,u_pp)
      xnew_pp=x_pp+p_pp*alpha; r_pp=r_pp-u_pp*alpha
      d_pp=diag_precon_pp*r_pp; beta=DOT_PRODUCT_P(r_pp,d_pp)/up
      p_pp=d_pp+p_pp*beta; CALL checon_par(xnew_pp,tol,converged,x_pp)
      IF(converged.OR.iters==limit)EXIT
    END DO iterations; timest(4)=timest(4)+(elap_time()-timest(3))
    IF(j/npri*npri==j)THEN; timest(5)=elap_time()
      IF(numpe==1)THEN; WRITE(ch,'(I6.6)') j
        OPEN(12,file=argv(1:nlen)//".ensi.NDTTR-"//ch,status='replace',  &
          action='write')
        WRITE(12,'(A)')                                                  &
          "Alya Ensight Gold --- Scalar per-node variable file"
        WRITE(12,'(A/A/A)') "part", "    1","coordinates"
      END IF; eld_pp=zero; ttr_pp=zero; CALL gather(xnew_pp(1:),eld_pp)
      CALL scatter_nodes(npes,nn,nels_pp,g_num_pp,nod,nodof,nodes_pp,    &
        node_start,node_end,eld_pp,ttr_pp,1)
      CALL dismsh_ensi_p(12,1,nodes_pp,npes,numpe,1,ttr_pp)
!     CALL dismsh_pb(12,1,nodes_pp,npes,numpe,1,ttr_pp)
      IF(numpe==1) CLOSE(12)
      IF(numpe==it) WRITE(11,'(2E12.4,I10)') real_time,xnew_pp(is),iters
      timest(6)=timest(6)+(elap_time()-timest(5))
    END IF
  END DO timesteps
  IF(numpe==it) THEN
    WRITE(11,'(A,F10.4)') "The solution phase took ",timest(4)
    WRITE(11,'(A,F10.4)') "Writing the output took ",timest(6)
    WRITE(11,'(A,F10.4)') "This analysis took ",elap_time()-timest(1)
    CLOSE(11)
  END IF; CALL SHUTDOWN()
END PROGRAM pg124