! Program to test intrinsic functions as actual arguments
!
! Please keep the content of this file in sync with gfortran.dg/specifics_1.f90
subroutine test_c(fn, val, res)
  complex fn
  complex val, res

  if (diff(fn(val),res)) call abort
contains
function diff(a,b)
  complex a,b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine

subroutine test_z(fn, val, res)
  double complex fn
  double complex val, res

  if (diff(fn(val),res)) call abort
contains
function diff(a,b)
  double complex a,b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine

subroutine test_cabs(fn, val, res)
  real fn, res
  complex val

  if (diff(fn(val),res)) call abort
contains
function diff(a,b)
  real a,b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine

subroutine test_cdabs(fn, val, res)
  double precision fn, res
  double complex val

  if (diff(fn(val),res)) call abort
contains
function diff(a,b)
  double precision a,b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine

subroutine test_r(fn, val, res)
  real fn
  real val, res

  if (diff(fn(val), res)) call abort
contains
function diff(a, b)
  real a, b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine

subroutine test_d(fn, val, res)
  double precision fn
  double precision val, res

  if (diff(fn(val), res)) call abort
contains
function diff(a, b)
  double precision a, b
  logical diff
  diff = (abs(a - b) .gt. 0.00001d0)
end function
end subroutine

subroutine test_r2(fn, val1, val2, res)
  real fn
  real val1, val2, res

  if (diff(fn(val1, val2), res)) call abort
contains
function diff(a, b)
  real a, b
  logical diff
  diff = (abs(a - b) .gt. 0.00001)
end function
end subroutine

subroutine test_d2(fn, val1, val2, res)
  double precision fn
  double precision val1, val2, res

  if (diff(fn(val1, val2), res)) call abort
contains
function diff(a, b)
  double precision a, b
  logical diff
  diff = (abs(a - b) .gt. 0.00001d0)
end function
end subroutine

subroutine test_dprod(fn)
  double precision fn
  if (abs (fn (2.0, 3.0) - 6d0) .gt. 0.00001) call abort
end subroutine

subroutine test_nint(fn,val,res)
  integer fn, res
  real val
  if (res .ne. fn(val)) call abort
end subroutine

subroutine test_idnint(fn,val,res)
  integer fn, res
  double precision val
  if (res .ne. fn(val)) call abort
end subroutine

subroutine test_idim(fn,val1,val2,res)
  integer fn, res, val1, val2
  if (res .ne. fn(val1,val2)) call abort
end subroutine

subroutine test_iabs(fn,val,res)
  integer fn, res, val
  if (res .ne. fn(val)) call abort
end subroutine

subroutine test_len(fn,val,res)
  integer fn, res
  character(len=*) val
  if (res .ne. fn(val)) call abort
end subroutine

subroutine test_index(fn,val1,val2,res)
  integer fn, res
  character(len=*) val1, val2
  if (fn(val1,val2) .ne. res) call abort
end subroutine

program specifics
  intrinsic abs
  intrinsic aint
  intrinsic anint
  intrinsic acos
  intrinsic acosh
  intrinsic asin
  intrinsic asinh
  intrinsic atan
  intrinsic atanh
  intrinsic cos
  intrinsic sin
  intrinsic tan
  intrinsic cosh
  intrinsic sinh
  intrinsic tanh
  intrinsic alog
  intrinsic alog10
  intrinsic exp
  intrinsic sign
  intrinsic isign
  intrinsic amod

  intrinsic dabs
  intrinsic dint
  intrinsic dnint
  intrinsic dacos
  intrinsic dacosh
  intrinsic dasin
  intrinsic dasinh
  intrinsic datan
  intrinsic datanh
  intrinsic dcos
  intrinsic dsin
  intrinsic dtan
  intrinsic dcosh
  intrinsic dsinh
  intrinsic dtanh
  intrinsic dlog
  intrinsic dlog10
  intrinsic dexp
  intrinsic dsign
  intrinsic dmod

  intrinsic conjg
  intrinsic ccos
  intrinsic cexp
  intrinsic clog
  intrinsic csin
  intrinsic csqrt

  intrinsic dconjg
  intrinsic cdcos
  intrinsic cdexp
  intrinsic cdlog
  intrinsic cdsin
  intrinsic cdsqrt
  intrinsic zcos
  intrinsic zexp
  intrinsic zlog
  intrinsic zsin
  intrinsic zsqrt

  intrinsic cabs
  intrinsic cdabs
  intrinsic zabs

  intrinsic dprod

  intrinsic nint
  intrinsic idnint
  intrinsic dim
  intrinsic ddim
  intrinsic idim
  intrinsic iabs
  intrinsic mod
  intrinsic len
  intrinsic index

  intrinsic aimag
  intrinsic dimag

  call test_r (abs, -1.0, abs(-1.0))
  call test_r (aint, 1.7, aint(1.7))
  call test_r (anint, 1.7, anint(1.7))
  call test_r (acos, 0.5, acos(0.5))
  call test_r (acosh, 1.5, acosh(1.5))
  call test_r (asin, 0.5, asin(0.5))
  call test_r (asinh, 0.5, asinh(0.5))
  call test_r (atan, 0.5, atan(0.5))
  call test_r (atanh, 0.5, atanh(0.5))
  call test_r (cos, 1.0, cos(1.0))
  call test_r (sin, 1.0, sin(1.0))
  call test_r (tan, 1.0, tan(1.0))
  call test_r (cosh, 1.0, cosh(1.0))
  call test_r (sinh, 1.0, sinh(1.0))
  call test_r (tanh, 1.0, tanh(1.0))
  call test_r (alog, 2.0, alog(2.0))
  call test_r (alog10, 2.0, alog10(2.0))
  call test_r (exp, 1.0, exp(1.0))
  call test_r2 (sign, 1.0, -2.0, sign(1.0, -2.0))
  call test_r2 (amod, 3.5, 2.0, amod(3.5, 2.0))

  call test_d (dabs, -1d0, abs(-1d0))
  call test_d (dint, 1.7d0, 1d0)
  call test_d (dnint, 1.7d0, 2d0)
  call test_d (dacos, 0.5d0, dacos(0.5d0))
  call test_d (dacosh, 1.5d0, dacosh(1.5d0))
  call test_d (dasin, 0.5d0, dasin(0.5d0))
  call test_d (dasinh, 0.5d0, dasinh(0.5d0))
  call test_d (datan, 0.5d0, datan(0.5d0))
  call test_d (datanh, 0.5d0, datanh(0.5d0))
  call test_d (dcos, 1d0, dcos(1d0))
  call test_d (dsin, 1d0, dsin(1d0))
  call test_d (dtan, 1d0, dtan(1d0))
  call test_d (dcosh, 1d0, dcosh(1d0))
  call test_d (dsinh, 1d0, dsinh(1d0))
  call test_d (dtanh, 1d0, dtanh(1d0))
  call test_d (dlog, 2d0, dlog(2d0))
  call test_d (dlog10, 2d0, dlog10(2d0))
  call test_d (dexp, 1d0, dexp(1d0))
  call test_d2 (dsign, 1d0, -2d0, sign(1d0, -2d0))
  call test_d2 (dmod, 3.5d0, 2d0, dmod(3.5d0, 2d0))

  call test_dprod (dprod)

  call test_c (conjg, (1.2,-4.), conjg((1.2,-4.)))
  call test_c (ccos, (1.2,-4.), ccos((1.2,-4.)))
  call test_c (cexp, (1.2,-4.), cexp((1.2,-4.)))
  call test_c (clog, (1.2,-4.), clog((1.2,-4.)))
  call test_c (csin, (1.2,-4.), csin((1.2,-4.)))
  call test_c (csqrt, (1.2,-4.), csqrt((1.2,-4.)))

  call test_z (dconjg, (1.2d0,-4.d0), dconjg((1.2d0,-4.d0)))
  call test_z (cdcos, (1.2d0,-4.d0), cdcos((1.2d0,-4.d0)))
  call test_z (zcos, (1.2d0,-4.d0), zcos((1.2d0,-4.d0)))
  call test_z (cdexp, (1.2d0,-4.d0), cdexp((1.2d0,-4.d0)))
  call test_z (zexp, (1.2d0,-4.d0), zexp((1.2d0,-4.d0)))
  call test_z (cdlog, (1.2d0,-4.d0), cdlog((1.2d0,-4.d0)))
  call test_z (zlog, (1.2d0,-4.d0), zlog((1.2d0,-4.d0)))
  call test_z (cdsin, (1.2d0,-4.d0), cdsin((1.2d0,-4.d0)))
  call test_z (zsin, (1.2d0,-4.d0), zsin((1.2d0,-4.d0)))
  call test_z (cdsqrt, (1.2d0,-4.d0), cdsqrt((1.2d0,-4.d0)))
  call test_z (zsqrt, (1.2d0,-4.d0), zsqrt((1.2d0,-4.d0)))

  call test_cabs (cabs, (1.2,-4.), cabs((1.2,-4.)))
  call test_cdabs (cdabs, (1.2d0,-4.d0), cdabs((1.2d0,-4.d0)))
  call test_cdabs (zabs, (1.2d0,-4.d0), zabs((1.2d0,-4.d0)))
  call test_cabs (aimag, (1.2,-4.), aimag((1.2,-4.)))
  call test_cdabs (dimag, (1.2d0,-4.d0), dimag((1.2d0,-4.d0)))

  call test_nint (nint, -1.2, nint(-1.2))
  call test_idnint (idnint, -1.2d0, idnint(-1.2d0))
  call test_idim (isign, -42, 17, isign(-42, 17))
  call test_idim (idim, -42, 17, idim(-42,17))
  call test_idim (idim, 42, 17, idim(42,17))
  call test_r2 (dim, 1.2, -4., dim(1.2, -4.))
  call test_d2 (ddim, 1.2d0, -4.d0, ddim(1.2d0, -4.d0))
  call test_iabs (iabs, -7, iabs(-7))
  call test_idim (mod, 5, 2, mod(5,2))
  call test_len (len, "foobar", len("foobar"))
  call test_index (index, "foobarfoobar", "bar", index("foobarfoobar","bar"))

end program


c     program DRSRANU
c>> 1996-05-28 DRSRANU Krogh Added external statement.
c>> 1994-10-19 DRSRANU  Krogh  Changes to use M77CON
c>> 1992-03-13 DRSRANU  CLL
c>> 1987-12-09 DRSRANU  Lawson  Initial Code.
c
c     Driver to demonstrate use of SRANU to generate random numbers
c     from the uniform distribution on [0.0, 1.0].
c     Program computes histogram for N numbers
c     ------------------------------------------------------------------
c--S replaces "?": DR?RANU, ?RANU, ?STAT1, ?STAT2
c     ------------------------------------------------------------------
      integer N, NCELLS
      parameter(N = 10000, NCELLS = 10+2)
      external SRANU
      real             SRANU, STATS(5), YTAB(1), Y1, Y2
      integer I, IHIST(NCELLS)
      data Y1, Y2 / 0.0E0, 1.0E0 /
c     ------------------------------------------------------------------
      STATS(1) = 0.0E0
      do 20 I = 1, N
c                          Get random number
         YTAB(1) = SRANU( )
c                          Accumulate statistics and histogram.
c
        call SSTAT1(YTAB(1), 1, STATS, IHIST, NCELLS, Y1, Y2)
  20  continue
c                          Print the statistics and histogram.
c
      write(*,'(13x,a//)') 'Uniform random numbers from SRANU'
      call SSTAT2(STATS, IHIST, NCELLS, Y1, Y2)
      stop
      end


!==============================================================================
program main

! Parallelisation of this loop
!
!      do i = 2, n
!         a(i) = a(i) + a(i - 1)
!      enddo
!
! with OpenMP (see the parallel region).
!
! Overhead: In the parallel version the total number of additions almost
! doubles.

  implicit none
  include 'omp_lib.h'

  integer, parameter :: n = 40
  integer :: a(n)
  integer :: i, i1, i2, i_thread, n_thread
  integer, allocatable :: psum(:)

  do i = 1, n
     a(i) = i
  enddo

  n_thread = omp_get_max_threads()

  allocate(psum(0:n_thread - 1))

  !$omp parallel private(i, i1, i2, i_thread)

  call get_omp_range(n, i1, i2, i_thread, psum)

  do i = i1 + 1, i2
     a(i) = a(i) + a(i - 1)
  enddo

  psum(i_thread) = a(i2)

  !$omp barrier

  if (i_thread == 0) then
     do i = 1, n_thread - 1
        psum(i) = psum(i) + psum(i - 1)
     enddo
  endif

  !$omp barrier

  if (i_thread > 0) then
     do i = i1, i2
        a(i) = a(i) + psum(i_thread - 1)
     enddo
  endif

  !$omp end parallel

  do i = 1, n
     write(6,*) a(i)
  enddo

end

!------------------------------------------------------------------------------
subroutine get_omp_range(n, i1, i2, i_thread)

  implicit none
  include 'omp_lib.h'

  integer, intent(in)  :: n
  integer, intent(out) :: i1, i2, i_thread

  integer :: n_thread, chunk, rest

  n_thread = omp_get_num_threads()
  i_thread = omp_get_thread_num()

  chunk = n / n_thread
  rest = mod(n, n_thread)

  if (i_thread < rest) then
     chunk = chunk + 1
     i1 = chunk * i_thread
  else
     i1 = chunk * i_thread + rest
  endif

  i1 = i1 + 1                    ! Fortran arrays begin with index 1
  i2 = i1 + chunk - 1

end

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


Module constants

    Implicit None

!   Handles
    Integer, Parameter :: stdin  = 5
    Integer, Parameter :: stdout = 6
    Integer, Parameter :: stderr = 0

!   Precision
    Integer,        Parameter :: KINDR = KIND(0d0)

    Real(KINDR),    Parameter :: ZERO        =  0.0e0_KINDR
    Real(KINDR),    Parameter :: ONE         =  1.0e0_KINDR
    Real(KINDR),    Parameter :: TWO         =  2.0e0_KINDR
    Real(KINDR),    Parameter :: THREE       =  3.0e0_KINDR
    Real(KINDR),    Parameter :: FOUR        =  4.0e0_KINDR
    Real(KINDR),    Parameter :: FIVE        =  5.0e0_KINDR
    Real(KINDR),    Parameter :: SIX         =  6.0e0_KINDR
    Real(KINDR),    Parameter :: SEVEN       =  7.0e0_KINDR
    Real(KINDR),    Parameter :: EIGHT       =  8.0e0_KINDR
    Real(KINDR),    Parameter :: NINE        =  9.0e0_KINDR
    Real(KINDR),    Parameter :: TEN         = 10.0e0_KINDR
    Real(KINDR),    Parameter :: ELEVEN      = 11.0e0_KINDR
    Real(KINDR),    Parameter :: TWELVE      = 12.0e0_KINDR
    Real(KINDR),    Parameter :: THIRTEEN    = 13.0e0_KINDR
    Real(KINDR),    Parameter :: FOURTEEN    = 14.0e0_KINDR
    Real(KINDR),    Parameter :: FIFTEEN     = 15.0e0_KINDR
    Real(KINDR),    Parameter :: SIXTEEN     = 16.0e0_KINDR
    Real(KINDR),    Parameter :: SEVENTEEN   = 17.0e0_KINDR
    Real(KINDR),    Parameter :: EIGHTEEN    = 18.0e0_KINDR
    Real(KINDR),    Parameter :: NINETEEN    = 19.0e0_KINDR
    Real(KINDR),    Parameter :: TWENTY      = 20.0e0_KINDR
    Real(KINDR),    Parameter :: TWENTYTWO   = 22.0e0_KINDR
    Real(KINDR),    Parameter :: TWENTYFOUR  = 24.0e0_KINDR
    Real(KINDR),    Parameter :: THIRTYTWO   = 32.0e0_KINDR
    Real(KINDR),    Parameter :: THIRTYSIX   = 36.0e0_KINDR
    Real(KINDR),    Parameter :: FORTYEIGHT  = 48.0e0_KINDR
    Real(KINDR),    Parameter :: SEVENTYTWO  = 72.0e0_KINDR
    Real(KINDR),    Parameter :: HUNDRED     =  1.0e2_KINDR
    Real(KINDR),    Parameter :: FOURTH      = 0.25e0_KINDR
    Real(KINDR),    Parameter :: HALF        =  0.5e0_KINDR
    Real(KINDR),    Parameter :: THREEFOURTH = 0.75e0_KINDR
    Real(KINDR),    Parameter :: THIRD       =  1.0e0_KINDR / 3.0e0_KINDR
    Real(KINDR),    Parameter :: TWOTHIRD    =  2.0e0_KINDR / 3.0e0_KINDR
    Real(KINDR),    Parameter :: SIXTH       =  1.0e0_KINDR / 6.0e0_KINDR
    Real(KINDR),    Parameter :: THREESECOND =  3.0e0_KINDR / 2.0e0_KINDR
    Real(KINDR),    Parameter :: FOURTHIRD   =  4.0e0_KINDR / 3.0e0_KINDR

    Real(KINDR),    Parameter :: PI            = 3.14159265358979323846_KINDR
    Real(KINDR),    Parameter :: SQRTPI        = 1.7724538509055159_KINDR
    Real(KINDR),    Parameter :: TWOINVPI      = TWO / PI
    Real(KINDR),    Parameter :: SQRTTWOINVPI  = 0.79788456080286541_KINDR
    Real(KINDR),    Parameter :: TWOINVSQRTPI  = TWO / SQRTPI

    Complex(KINDR), Parameter :: I_C       = CMPLX(ZERO,    ONE,  KINDR)
    Complex(KINDR), Parameter :: ZERO_C    = CMPLX(ZERO,    ZERO, KINDR)
    Complex(KINDR), Parameter :: ONE_C     = CMPLX(ONE,     ZERO, KINDR)
    Complex(KINDR), Parameter :: TWO_C     = CMPLX(TWO,     ZERO, KINDR)
    Complex(KINDR), Parameter :: THREE_C   = CMPLX(THREE,   ZERO, KINDR)
    Complex(KINDR), Parameter :: FOUR_C    = CMPLX(FOUR,    ZERO, KINDR)
    Complex(KINDR), Parameter :: FIVE_C    = CMPLX(FIVE,    ZERO, KINDR)
    Complex(KINDR), Parameter :: SIX_C     = CMPLX(SIX,     ZERO, KINDR)
    Complex(KINDR), Parameter :: HALF_C    = CMPLX(HALF,    ZERO, KINDR)
    Complex(KINDR), Parameter :: HUNDRED_C = CMPLX(HUNDRED, ZERO, KINDR)

End Module constants


*DECK XPSI
      REAL FUNCTION XPSI (A, IPSIK, IPSIX)
C***BEGIN PROLOGUE  XPSI
C***SUBSIDIARY
C***PURPOSE  To compute values of the Psi function for XLEGF.
C***LIBRARY   SLATEC
C***CATEGORY  C7C
C***TYPE      SINGLE PRECISION (XPSI-S, DXPSI-D)
C***KEYWORDS  PSI FUNCTION
C***AUTHOR  Smith, John M., (NBS and George Mason University)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   820728  DATE WRITTEN
C   890126  Revised to meet SLATEC CML recommendations.  (DWL and JMS)
C   901019  Revisions to prologue.  (DWL and WRB)
C   901106  Changed all specific intrinsics to generic.  (WRB)
C           Corrected order of sections in prologue and added TYPE
C           section.  (WRB)
C   920127  Revised PURPOSE section of prologue.  (DWL)
C***END PROLOGUE  XPSI
      REAL A,B,C,CNUM,CDENOM
      DIMENSION CNUM(12),CDENOM(12)
      SAVE CNUM, CDENOM
C
C        CNUM(I) AND CDENOM(I) ARE THE ( REDUCED ) NUMERATOR
C        AND 2*I*DENOMINATOR RESPECTIVELY OF THE 2*I TH BERNOULLI
C        NUMBER.
C
      DATA CNUM(1),CNUM(2),CNUM(3),CNUM(4),CNUM(5),CNUM(6),CNUM(7),
     1CNUM(8),CNUM(9),CNUM(10),CNUM(11),CNUM(12)
     2    / 1.,     -1.,    1.,     -1., 1.,
     3   -691.,  1.,     -3617., 43867., -174611., 77683.,
     4   -236364091./
      DATA CDENOM(1),CDENOM(2),CDENOM(3),CDENOM(4),CDENOM(5),CDENOM(6),
     1 CDENOM(7),CDENOM(8),CDENOM(9),CDENOM(10),CDENOM(11),CDENOM(12)
     2/12.,120.,   252.,   240.,132.,
     3  32760., 12.,  8160., 14364., 6600., 276., 65520./
C***FIRST EXECUTABLE STATEMENT  XPSI
      N=MAX(0,IPSIX-INT(A))
      B=N+A
      K1=IPSIK-1
C
C        SERIES EXPANSION FOR A .GT. IPSIX USING IPSIK-1 TERMS.
C
      C=0.
      DO 12 I=1,K1
      K=IPSIK-I
   12 C=(C+CNUM(K)/CDENOM(K))/B**2
      XPSI=LOG(B)-(C+.5/B)
      IF(N.EQ.0) GO TO 20
      B=0.
C
C        RECURRENCE FOR A .LE. IPSIX.
C
      DO 15 M=1,N
   15 B=B+1./(N-M+A)
      XPSI=XPSI-B
   20 RETURN
      END