*DECK TRIDIB
      SUBROUTINE TRIDIB (N, EPS1, D, E, E2, LB, UB, M11, M, W, IND,
     +   IERR, RV4, RV5)
C***BEGIN PROLOGUE  TRIDIB
C***PURPOSE  Compute the eigenvalues of a symmetric tridiagonal matrix
C            in a given interval using Sturm sequencing.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4A5, D4C2A
C***TYPE      SINGLE PRECISION (TRIDIB-S)
C***KEYWORDS  EIGENVALUES OF A REAL SYMMETRIC MATRIX, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine is a translation of the ALGOL procedure BISECT,
C     NUM. MATH. 9, 386-393(1967) by Barth, Martin, and Wilkinson.
C     HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 249-256(1971).
C
C     This subroutine finds those eigenvalues of a TRIDIAGONAL
C     SYMMETRIC matrix between specified boundary indices,
C     using bisection.
C
C     On Input
C
C        N is the order of the matrix.  N is an INTEGER variable.
C
C        EPS1 is an absolute error tolerance for the computed eigen-
C          values.  If the input EPS1 is non-positive, it is reset for
C          each submatrix to a default value, namely, minus the product
C          of the relative machine precision and the 1-norm of the
C          submatrix.  EPS1 is a REAL variable.
C
C        D contains the diagonal elements of the symmetric tridiagonal
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the symmetric
C          tridiagonal matrix in its last N-1 positions.  E(1) is
C          arbitrary.  E is a one-dimensional REAL array, dimensioned
C          E(N).
C
C        E2 contains the squares of the corresponding elements of E.
C          E2(1) is arbitrary.  E2 is a one-dimensional REAL array,
C          dimensioned E2(N).
C
C        M11 specifies the lower boundary index for the set of desired
C          eigenvalues.  M11 is an INTEGER variable.
C
C        M specifies the number of eigenvalues desired.  The upper
C          boundary index M22 is then obtained as M22=M11+M-1.
C          M is an INTEGER variable.
C
C     On Output
C
C        EPS1 is unaltered unless it has been reset to its
C          (last) default value.
C
C        D and E are unaltered.
C
C        Elements of E2, corresponding to elements of E regarded
C          as negligible, have been replaced by zero causing the
C          matrix to split into a direct sum of submatrices.
C          E2(1) is also set to zero.
C
C        LB and UB define an interval containing exactly the desired
C          eigenvalues.  LB and UB are REAL variables.
C
C        W contains, in its first M positions, the eigenvalues
C          between indices M11 and M22 in ascending order.
C          W is a one-dimensional REAL array, dimensioned W(M).
C
C        IND contains in its first M positions the submatrix indices
C          associated with the corresponding eigenvalues in W --
C          1 for eigenvalues belonging to the first submatrix from
C          the top, 2 for those belonging to the second submatrix, etc.
C          IND is an one-dimensional INTEGER array, dimensioned IND(M).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          3*N+1      if multiple eigenvalues at index M11 make
C                     unique selection of LB impossible,
C          3*N+2      if multiple eigenvalues at index M22 make
C                     unique selection of UB impossible.
C
C        RV4 and RV5 are one-dimensional REAL arrays used for temporary
C          storage of the lower and upper bounds for the eigenvalues in
C          the bisection process.  RV4 and RV5 are dimensioned RV4(N)
C          and RV5(N).
C
C     Note that subroutine TQL1, IMTQL1, or TQLRAT is generally faster
C     than TRIDIB, if more than N/4 eigenvalues are to be found.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  R1MACH
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  TRIDIB
C
      INTEGER I,J,K,L,M,N,P,Q,R,S,II,M1,M2,M11,M22,TAG,IERR,ISTURM
      REAL D(*),E(*),E2(*),W(*),RV4(*),RV5(*)
      REAL U,V,LB,T1,T2,UB,XU,X0,X1,EPS1,MACHEP,S1,S2
      INTEGER IND(*)
      LOGICAL FIRST
C
      SAVE FIRST, MACHEP
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  TRIDIB
      IF (FIRST) THEN
         MACHEP = R1MACH(4)
      ENDIF
      FIRST = .FALSE.
C
      IERR = 0
      TAG = 0
      XU = D(1)
      X0 = D(1)
      U = 0.0E0
C     .......... LOOK FOR SMALL SUB-DIAGONAL ENTRIES AND DETERMINE AN
C                INTERVAL CONTAINING ALL THE EIGENVALUES ..........
      DO 40 I = 1, N
         X1 = U
         U = 0.0E0
         IF (I .NE. N) U = ABS(E(I+1))
         XU = MIN(D(I)-(X1+U),XU)
         X0 = MAX(D(I)+(X1+U),X0)
         IF (I .EQ. 1) GO TO 20
         S1 = ABS(D(I)) + ABS(D(I-1))
         S2 = S1 + ABS(E(I))
         IF (S2 .GT. S1) GO TO 40
   20    E2(I) = 0.0E0
   40 CONTINUE
C
      X1 = MAX(ABS(XU),ABS(X0)) * MACHEP * N
      XU = XU - X1
      T1 = XU
      X0 = X0 + X1
      T2 = X0
C     .......... DETERMINE AN INTERVAL CONTAINING EXACTLY
C                THE DESIRED EIGENVALUES ..........
      P = 1
      Q = N
      M1 = M11 - 1
      IF (M1 .EQ. 0) GO TO 75
      ISTURM = 1
   50 V = X1
      X1 = XU + (X0 - XU) * 0.5E0
      IF (X1 .EQ. V) GO TO 980
      GO TO 320
   60 IF (S - M1) 65, 73, 70
   65 XU = X1
      GO TO 50
   70 X0 = X1
      GO TO 50
   73 XU = X1
      T1 = X1
   75 M22 = M1 + M
      IF (M22 .EQ. N) GO TO 90
      X0 = T2
      ISTURM = 2
      GO TO 50
   80 IF (S - M22) 65, 85, 70
   85 T2 = X1
   90 Q = 0
      R = 0
C     .......... ESTABLISH AND PROCESS NEXT SUBMATRIX, REFINING
C                INTERVAL BY THE GERSCHGORIN BOUNDS ..........
  100 IF (R .EQ. M) GO TO 1001
      TAG = TAG + 1
      P = Q + 1
      XU = D(P)
      X0 = D(P)
      U = 0.0E0
C
      DO 120 Q = P, N
         X1 = U
         U = 0.0E0
         V = 0.0E0
         IF (Q .EQ. N) GO TO 110
         U = ABS(E(Q+1))
         V = E2(Q+1)
  110    XU = MIN(D(Q)-(X1+U),XU)
         X0 = MAX(D(Q)+(X1+U),X0)
         IF (V .EQ. 0.0E0) GO TO 140
  120 CONTINUE
C
  140 X1 = MAX(ABS(XU),ABS(X0)) * MACHEP
      IF (EPS1 .LE. 0.0E0) EPS1 = -X1
      IF (P .NE. Q) GO TO 180
C     .......... CHECK FOR ISOLATED ROOT WITHIN INTERVAL ..........
      IF (T1 .GT. D(P) .OR. D(P) .GE. T2) GO TO 940
      M1 = P
      M2 = P
      RV5(P) = D(P)
      GO TO 900
  180 X1 = X1 * (Q-P+1)
      LB = MAX(T1,XU-X1)
      UB = MIN(T2,X0+X1)
      X1 = LB
      ISTURM = 3
      GO TO 320
  200 M1 = S + 1
      X1 = UB
      ISTURM = 4
      GO TO 320
  220 M2 = S
      IF (M1 .GT. M2) GO TO 940
C     .......... FIND ROOTS BY BISECTION ..........
      X0 = UB
      ISTURM = 5
C
      DO 240 I = M1, M2
         RV5(I) = UB
         RV4(I) = LB
  240 CONTINUE
C     .......... LOOP FOR K-TH EIGENVALUE
C                FOR K=M2 STEP -1 UNTIL M1 DO --
C                (-DO- NOT USED TO LEGALIZE -COMPUTED GO TO-) ..........
      K = M2
  250    XU = LB
C     .......... FOR I=K STEP -1 UNTIL M1 DO -- ..........
         DO 260 II = M1, K
            I = M1 + K - II
            IF (XU .GE. RV4(I)) GO TO 260
            XU = RV4(I)
            GO TO 280
  260    CONTINUE
C
  280    IF (X0 .GT. RV5(K)) X0 = RV5(K)
C     .......... NEXT BISECTION STEP ..........
  300    X1 = (XU + X0) * 0.5E0
         S1 = ABS(XU) + ABS(X0) + ABS(EPS1)
         S2 = S1 + ABS(X0-XU)/2.0E0
         IF (S2 .EQ. S1) GO TO 420
C     .......... IN-LINE PROCEDURE FOR STURM SEQUENCE ..........
  320    S = P - 1
         U = 1.0E0
C
         DO 340 I = P, Q
            IF (U .NE. 0.0E0) GO TO 325
            V = ABS(E(I)) / MACHEP
            IF (E2(I) .EQ. 0.0E0) V = 0.0E0
            GO TO 330
  325       V = E2(I) / U
  330       U = D(I) - X1 - V
            IF (U .LT. 0.0E0) S = S + 1
  340    CONTINUE
C
         GO TO (60,80,200,220,360), ISTURM
C     .......... REFINE INTERVALS ..........
  360    IF (S .GE. K) GO TO 400
         XU = X1
         IF (S .GE. M1) GO TO 380
         RV4(M1) = X1
         GO TO 300
  380    RV4(S+1) = X1
         IF (RV5(S) .GT. X1) RV5(S) = X1
         GO TO 300
  400    X0 = X1
         GO TO 300
C     .......... K-TH EIGENVALUE FOUND ..........
  420    RV5(K) = X1
      K = K - 1
      IF (K .GE. M1) GO TO 250
C     .......... ORDER EIGENVALUES TAGGED WITH THEIR
C                SUBMATRIX ASSOCIATIONS ..........
  900 S = R
      R = R + M2 - M1 + 1
      J = 1
      K = M1
C
      DO 920 L = 1, R
         IF (J .GT. S) GO TO 910
         IF (K .GT. M2) GO TO 940
         IF (RV5(K) .GE. W(L)) GO TO 915
C
         DO 905 II = J, S
            I = L + S - II
            W(I+1) = W(I)
            IND(I+1) = IND(I)
  905    CONTINUE
C
  910    W(L) = RV5(K)
         IND(L) = TAG
         K = K + 1
         GO TO 920
  915    J = J + 1
  920 CONTINUE
C
  940 IF (Q .LT. N) GO TO 100
      GO TO 1001
C     .......... SET ERROR -- INTERVAL CANNOT BE FOUND CONTAINING
C                EXACTLY THE DESIRED EIGENVALUES ..........
  980 IERR = 3 * N + ISTURM
 1001 LB = T1
      UB = T2
      RETURN
      END


PROGRAM EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999

!  .. "Use Statements"
USE LA_PRECISION, ONLY: WP => dp
use f95_lapack, only: gbsv=>la_gbsv
!  .. "Implicit Statement" ..
IMPLICIT NONE
!  .. "Local Scalars" ..
INTEGER :: K, KL, KU, I, J, N, NRHS, INFO, u
!  .. "Local Arrays" ..
INTEGER, ALLOCATABLE :: IPIV(:)
REAL(WP), ALLOCATABLE :: AB(:,:), B(:,:)
character(1024) :: argv
!  .. "Executable Statements" ..
print *, 'SGBSV Example Program Results.'
N = 6; KL = 2; KU = 1; NRHS = 2
ALLOCATE ( AB(2*KL+KU+1,N), B(N,NRHS), IPIV(N))

call get_command_argument(1, argv)

OPEN(newunit=u,FILE=trim(argv)//'/gbsv.ma',STATUS='old')
DO I=KL+1,2*KL+KU+1
DO J=1,N
  READ(u,'(F2.0)') AB(I,J)
ENDDO
ENDDO
CLOSE(u)

print *, 'The matrix AB:'
DO I=1,N; WRITE(*,"(5(I3,1X,1X),I3,1X)") INT(AB(I,:));
ENDDO

DO I = 1, NRHS
DO J = 1, N
DO K = MAX(1,J-KL),MIN(J+KU,N); B(J,I) = AB(KL+KU+1+J-K,K)+B(J,I);
ENDDO
ENDDO
B(:,I) = B(:,I)*I;
ENDDO

print *, 'The RHS matrix B:'
DO I=1,N; WRITE(*,"(1(I3,1X),I3,1X)") INT(B(I,:)); ENDDO

CALL GBSV( AB, B, 2, IPIV, INFO )

print *,'AB on exit: '
DO I=1,2*KL+KU+1; WRITE(*,"(5(E12.6,1X),E12.6,1X)") AB(I,:); ENDDO
print *,'B on exit: '
DO I=1,N; WRITE(*,"(1(E12.6,1X),E12.6,1X)") B(I,:); ENDDO
print *,'IPIV on exit: ', IPIV

stop info

END PROGRAM


      SUBROUTINE predic(data,ndata,d,m,future,nfut)
      INTEGER ndata,nfut,m,MMAX
      REAL d(m),data(ndata),future(nfut)
      PARAMETER (MMAX=100)
      INTEGER j,k
      REAL discrp,sum,reg(MMAX)
      do 11 j=1,m
        reg(j)=data(ndata+1-j)
11    continue
      do 14 j=1,nfut
        discrp=0.
        sum=discrp
        do 12 k=1,m
          sum=sum+d(k)*reg(k)
12      continue
        do 13 k=m,2,-1
          reg(k)=reg(k-1)
13      continue
        reg(1)=sum
        future(j)=sum
14    continue
      return
      END

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


! { dg-do run }

module e_53_3_mod
  !$omp declare target (N, p, v1, v2)
  integer, parameter :: N = 1000
  real :: p(N), v1(N), v2(N)
end module

subroutine init (v1, v2, N)
  integer :: i, N
  real :: v1(N), v2(N)
  do i = 1, N
    v1(i) = i + 2.0
    v2(i) = i - 3.0
  end do
end subroutine

subroutine check (p, N)
  integer :: i, N
  real, parameter :: EPS = 0.00001
  real :: diff, p(N)
  do i = 1, N
    diff = p(i) - (i + 2.0) * (i - 3.0)
    if (diff > EPS .or. -diff > EPS) call abort
  end do
end subroutine

subroutine vec_mult ()
  use e_53_3_mod
  integer :: i
  call init (v1, v2, N);
  !$omp target update to(v1, v2)
  !$omp target
    !$omp parallel do
    do i = 1,N
      p(i) = v1(i) * v2(i)
    end do
  !$omp end target
  !$omp target update from (p)
  call check (p, N)
end subroutine

program e_53_3
  call vec_mult ()
end program


MODULE MinMax_Find_Utility

  USE Type_Kinds, ONLY: fp
  IMPLICIT NONE

  PRIVATE
  PUBLIC :: MinVal_Find
  PUBLIC :: MaxVal_Find
  PUBLIC :: MaxDiff_Find

  ! Public
  INTERFACE MinVal_Find
    MODULE PROCEDURE integer_MinVal_Find
    MODULE PROCEDURE real_MinVal_Find
  END INTERFACE MinVal_Find

  INTERFACE MaxVal_Find
    MODULE PROCEDURE integer_MaxVal_Find
    MODULE PROCEDURE real_MaxVal_Find
  END INTERFACE MaxVal_Find

  INTERFACE MaxDiff_Find
    MODULE PROCEDURE integer_MaxDiff_Find
    MODULE PROCEDURE real_MaxDiff_Find
  END INTERFACE MaxDiff_Find

  ! Private
  INTERFACE MinLoc_Find
    MODULE PROCEDURE integer_MinLoc_Find
    MODULE PROCEDURE real_MinLoc_Find
  END INTERFACE MinLoc_Find

  INTERFACE MaxLoc_Find
    MODULE PROCEDURE integer_MaxLoc_Find
    MODULE PROCEDURE real_MaxLoc_Find
  END INTERFACE MaxLoc_Find

CONTAINS

  FUNCTION integer_MinVal_Find(array) RESULT(minimum_value)
    INTEGER, INTENT(IN) :: array(:)
    INTEGER :: minimum_value
    INTEGER :: idx
    idx = MinLoc_Find(array)
    minimum_value = SIGN(array(idx),array(idx))
  END FUNCTION integer_MinVal_Find

  FUNCTION integer_MaxVal_Find(array) RESULT(maximum_value)
    INTEGER, INTENT(IN) :: array(:)
    INTEGER :: maximum_value
    INTEGER :: idx
    idx = MaxLoc_Find(array)
    maximum_value = SIGN(array(idx),array(idx))
  END FUNCTION integer_MaxVal_Find

  SUBROUTINE integer_MaxDiff_Find(x,y, xval,yval,diff)
    INTEGER, INTENT(IN) :: x(:), y(:)
    INTEGER :: xval, yval, diff
    INTEGER :: idx
    idx = MaxLoc_Find(x-y)
    xval = x(idx)
    yval = y(idx)
    diff = xval - yval
  END SUBROUTINE integer_MaxDiff_Find

  FUNCTION real_MinVal_Find(array) RESULT(minimum_value)
    REAL(fp), INTENT(IN) :: array(:)
    REAL(fp) :: minimum_value
    INTEGER :: idx
    idx = MinLoc_Find(array)
    minimum_value = SIGN(array(idx),array(idx))
  END FUNCTION real_MinVal_Find

  FUNCTION real_MaxVal_Find(array) RESULT(maximum_value)
    REAL(fp), INTENT(IN) :: array(:)
    REAL(fp) :: maximum_value
    INTEGER :: idx
    idx = MaxLoc_Find(array)
    maximum_value = SIGN(array(idx),array(idx))
  END FUNCTION real_MaxVal_Find

  SUBROUTINE real_MaxDiff_Find(x,y, xval,yval,diff)
    REAL(fp), INTENT(IN) :: x(:), y(:)
    REAL(fp) :: xval, yval, diff
    INTEGER :: idx
    idx = MaxLoc_Find(x-y)
    xval = x(idx)
    yval = y(idx)
    diff = xval - yval
  END SUBROUTINE real_MaxDiff_Find

! PRIVATE PROCEDURES

  FUNCTION integer_MinLoc_Find(array) RESULT(idx)
    INTEGER, INTENT(IN) :: array(:)
    INTEGER :: idx
    idx = MINLOC(ABS(array),DIM=1)
  END FUNCTION integer_MinLoc_Find

  FUNCTION integer_MaxLoc_Find(array) RESULT(idx)
    INTEGER, INTENT(IN) :: array(:)
    INTEGER :: idx
    idx = MAXLOC(ABS(array),DIM=1)
  END FUNCTION integer_MaxLoc_Find

  FUNCTION real_MinLoc_Find(array) RESULT(idx)
    REAL(fp), INTENT(IN) :: array(:)
    INTEGER :: idx
    idx = MINLOC(ABS(array),DIM=1)
  END FUNCTION real_MinLoc_Find

  FUNCTION real_MaxLoc_Find(array) RESULT(idx)
    REAL(fp), INTENT(IN) :: array(:)
    INTEGER :: idx
    idx = MAXLOC(ABS(array),DIM=1)
  END FUNCTION real_MaxLoc_Find

END MODULE MinMax_Find_Utility


! { dg-do  run }
! { dg-options "-O3 -finline-matmul-limit=10 -fdump-tree-optimized -fdump-tree-original" }
! PR 37131 - all calls to matmul should be optimized away with -O3
! and the high limit.
program main
  real, dimension(3,2) :: a
  real, dimension(2,4) :: b
  real, dimension(3,4) :: c
  real, dimension(3,4) :: cres
  real, dimension(:,:), allocatable :: calloc
  integer :: a1 = size(a,1), a2 = size(a,2)
  integer :: b1 = size(b,1), b2 = size(b,2)
  integer :: c1 = size(c,1), c2 = size(c,2)

  data a / 2.,  -3.,  5.,  -7., 11., -13./
  data b /17., -23., 29., -31., 37., -39., 41., -47./
  data cres /195., -304.,  384.,  275., -428.,  548.,  347., -540.,  692.,  411., -640.,  816./
  c = matmul(a,b)
  if (sum(c-cres)>1e-4) call abort

  calloc = matmul(a,b)
  if (sum(calloc-cres)>1e-4) call abort
  if (any([size(calloc,1), size(calloc,2)] /= [3,4])) call abort
  deallocate(calloc)

  allocate(calloc(4,4))
  calloc = matmul(a,b)
  if (sum(calloc-cres)>1e-4) call abort
  if (any([size(calloc,1), size(calloc,2)] /= [3,4])) call abort
  deallocate(calloc)

  allocate(calloc(3,3))
  calloc = matmul(a,b)
  if (sum(calloc-cres)>1e-4) call abort
  if (any([size(calloc,1), size(calloc,2)] /= [3,4])) call abort
  deallocate(calloc)

  block
    real :: aa(a1, a2), bb(b1, b2), cc(c1, c2)
    aa = a
    bb = b

    cc = matmul(aa,bb)
    if (sum(cc-cres)>1e-4) call abort
    calloc = matmul(aa,bb)
    if (sum(calloc-cres)>1e-4) call abort
    if (any([size(calloc,1), size(calloc,2)] /= [3,4])) call abort
    calloc = 42.
    deallocate(calloc)

    allocate(calloc(4,4))
    calloc = matmul(aa,bb)
    if (sum(calloc-cres)>1e-4) call abort
    if (any([size(calloc,1), size(calloc,2)] /= [3,4])) call abort
    deallocate(calloc)

    allocate(calloc(3,3))
    calloc = matmul(aa,bb)
    if (sum(calloc-cres)>1e-4) call abort
    if (any([size(calloc,1), size(calloc,2)] /= [3,4])) call abort
    deallocate(calloc)
  end block

end program main
! { dg-final { scan-tree-dump-times "_gfortran_matmul" 4 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } }


*> \brief \b SCHKTP
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
*                          NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
*                          IWORK, NOUT )
*
*       .. Scalar Arguments ..
*       LOGICAL            TSTERR
*       INTEGER            NMAX, NN, NNS, NOUT
*       REAL               THRESH
*       ..
*       .. Array Arguments ..
*       LOGICAL            DOTYPE( * )
*       INTEGER            IWORK( * ), NSVAL( * ), NVAL( * )
*       REAL               AINVP( * ), AP( * ), B( * ), RWORK( * ),
*      $                   WORK( * ), X( * ), XACT( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SCHKTP tests STPTRI, -TRS, -RFS, and -CON, and SLATPS
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] DOTYPE
*> \verbatim
*>          DOTYPE is LOGICAL array, dimension (NTYPES)
*>          The matrix types to be used for testing.  Matrices of type j
*>          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
*>          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
*> \endverbatim
*>
*> \param[in] NN
*> \verbatim
*>          NN is INTEGER
*>          The number of values of N contained in the vector NVAL.
*> \endverbatim
*>
*> \param[in] NVAL
*> \verbatim
*>          NVAL is INTEGER array, dimension (NN)
*>          The values of the matrix column dimension N.
*> \endverbatim
*>
*> \param[in] NNS
*> \verbatim
*>          NNS is INTEGER
*>          The number of values of NRHS contained in the vector NSVAL.
*> \endverbatim
*>
*> \param[in] NSVAL
*> \verbatim
*>          NSVAL is INTEGER array, dimension (NNS)
*>          The values of the number of right hand sides NRHS.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*>          THRESH is REAL
*>          The threshold value for the test ratios.  A result is
*>          included in the output file if RESULT >= THRESH.  To have
*>          every test ratio printed, use THRESH = 0.
*> \endverbatim
*>
*> \param[in] TSTERR
*> \verbatim
*>          TSTERR is LOGICAL
*>          Flag that indicates whether error exits are to be tested.
*> \endverbatim
*>
*> \param[in] NMAX
*> \verbatim
*>          NMAX is INTEGER
*>          The leading dimension of the work arrays.  NMAX >= the
*>          maximumm value of N in NVAL.
*> \endverbatim
*>
*> \param[out] AP
*> \verbatim
*>          AP is REAL array, dimension
*>                      (NMAX*(NMAX+1)/2)
*> \endverbatim
*>
*> \param[out] AINVP
*> \verbatim
*>          AINVP is REAL array, dimension
*>                      (NMAX*(NMAX+1)/2)
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*>          B is REAL array, dimension (NMAX*NSMAX)
*>          where NSMAX is the largest entry in NSVAL.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*>          X is REAL array, dimension (NMAX*NSMAX)
*> \endverbatim
*>
*> \param[out] XACT
*> \verbatim
*>          XACT is REAL array, dimension (NMAX*NSMAX)
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is REAL array, dimension
*>                      (NMAX*max(3,NSMAX))
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (NMAX)
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension
*>                      (max(NMAX,2*NSMAX))
*> \endverbatim
*>
*> \param[in] NOUT
*> \verbatim
*>          NOUT is INTEGER
*>          The unit number for output.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_lin
*
*  =====================================================================
      SUBROUTINE SCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
     $                   NMAX, AP, AINVP, B, X, XACT, WORK, RWORK,
     $                   IWORK, NOUT )
*
*  -- LAPACK test routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      LOGICAL            TSTERR
      INTEGER            NMAX, NN, NNS, NOUT
      REAL               THRESH
*     ..
*     .. Array Arguments ..
      LOGICAL            DOTYPE( * )
      INTEGER            IWORK( * ), NSVAL( * ), NVAL( * )
      REAL               AINVP( * ), AP( * ), B( * ), RWORK( * ),
     $                   WORK( * ), X( * ), XACT( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            NTYPE1, NTYPES
      PARAMETER          ( NTYPE1 = 10, NTYPES = 18 )
      INTEGER            NTESTS
      PARAMETER          ( NTESTS = 9 )
      INTEGER            NTRAN
      PARAMETER          ( NTRAN = 3 )
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          DIAG, NORM, TRANS, UPLO, XTYPE
      CHARACTER*3        PATH
      INTEGER            I, IDIAG, IMAT, IN, INFO, IRHS, ITRAN, IUPLO,
     $                   K, LAP, LDA, N, NERRS, NFAIL, NRHS, NRUN
      REAL               AINVNM, ANORM, RCOND, RCONDC, RCONDI, RCONDO,
     $                   SCALE
*     ..
*     .. Local Arrays ..
      CHARACTER          TRANSS( NTRAN ), UPLOS( 2 )
      INTEGER            ISEED( 4 ), ISEEDY( 4 )
      REAL               RESULT( NTESTS )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLANTP
      EXTERNAL           LSAME, SLANTP
*     ..
*     .. External Subroutines ..
      EXTERNAL           ALAERH, ALAHD, ALASUM, SCOPY, SERRTR, SGET04,
     $                   SLACPY, SLARHS, SLATPS, SLATTP, STPCON, STPRFS,
     $                   STPT01, STPT02, STPT03, STPT05, STPT06, STPTRI,
     $                   STPTRS
*     ..
*     .. Scalars in Common ..
      LOGICAL            LERR, OK
      CHARACTER*32       SRNAMT
      INTEGER            INFOT, IOUNIT
*     ..
*     .. Common blocks ..
      COMMON             / INFOC / INFOT, IOUNIT, OK, LERR
      COMMON             / SRNAMC / SRNAMT
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Data statements ..
      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
      DATA               UPLOS / 'U', 'L' / , TRANSS / 'N', 'T', 'C' /
*     ..
*     .. Executable Statements ..
*
*     Initialize constants and the random number seed.
*
      PATH( 1: 1 ) = 'Single precision'
      PATH( 2: 3 ) = 'TP'
      NRUN = 0
      NFAIL = 0
      NERRS = 0
      DO 10 I = 1, 4
         ISEED( I ) = ISEEDY( I )
   10 CONTINUE
*
*     Test the error exits
*
      IF( TSTERR )
     $   CALL SERRTR( PATH, NOUT )
      INFOT = 0
*
      DO 110 IN = 1, NN
*
*        Do for each value of N in NVAL
*
         N = NVAL( IN )
         LDA = MAX( 1, N )
         LAP = LDA*( LDA+1 ) / 2
         XTYPE = 'N'
*
         DO 70 IMAT = 1, NTYPE1
*
*           Do the tests only if DOTYPE( IMAT ) is true.
*
            IF( .NOT.DOTYPE( IMAT ) )
     $         GO TO 70
*
            DO 60 IUPLO = 1, 2
*
*              Do first for UPLO = 'U', then for UPLO = 'L'
*
               UPLO = UPLOS( IUPLO )
*
*              Call SLATTP to generate a triangular test matrix.
*
               SRNAMT = 'SLATTP'
               CALL SLATTP( IMAT, UPLO, 'No transpose', DIAG, ISEED, N,
     $                      AP, X, WORK, INFO )
*
*              Set IDIAG = 1 for non-unit matrices, 2 for unit.
*
               IF( LSAME( DIAG, 'N' ) ) THEN
                  IDIAG = 1
               ELSE
                  IDIAG = 2
               END IF
*
*+    TEST 1
*              Form the inverse of A.
*
               IF( N.GT.0 )
     $            CALL SCOPY( LAP, AP, 1, AINVP, 1 )
               SRNAMT = 'STPTRI'
               CALL STPTRI( UPLO, DIAG, N, AINVP, INFO )
*
*              Check error code from STPTRI.
*
               IF( INFO.NE.0 )
     $            CALL ALAERH( PATH, 'STPTRI', INFO, 0, UPLO // DIAG, N,
     $                         N, -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
*              Compute the infinity-norm condition number of A.
*
               ANORM = SLANTP( 'I', UPLO, DIAG, N, AP, RWORK )
               AINVNM = SLANTP( 'I', UPLO, DIAG, N, AINVP, RWORK )
               IF( ANORM.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
                  RCONDI = ONE
               ELSE
                  RCONDI = ( ONE / ANORM ) / AINVNM
               END IF
*
*              Compute the residual for the triangular matrix times its
*              inverse.  Also compute the 1-norm condition number of A.
*
               CALL STPT01( UPLO, DIAG, N, AP, AINVP, RCONDO, RWORK,
     $                      RESULT( 1 ) )
*
*              Print the test ratio if it is .GE. THRESH.
*
               IF( RESULT( 1 ).GE.THRESH ) THEN
                  IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $               CALL ALAHD( NOUT, PATH )
                  WRITE( NOUT, FMT = 9999 )UPLO, DIAG, N, IMAT, 1,
     $               RESULT( 1 )
                  NFAIL = NFAIL + 1
               END IF
               NRUN = NRUN + 1
*
               DO 40 IRHS = 1, NNS
                  NRHS = NSVAL( IRHS )
                  XTYPE = 'N'
*
                  DO 30 ITRAN = 1, NTRAN
*
*                 Do for op(A) = A, A**T, or A**H.
*
                     TRANS = TRANSS( ITRAN )
                     IF( ITRAN.EQ.1 ) THEN
                        NORM = 'O'
                        RCONDC = RCONDO
                     ELSE
                        NORM = 'I'
                        RCONDC = RCONDI
                     END IF
*
*+    TEST 2
*                 Solve and compute residual for op(A)*x = b.
*
                     SRNAMT = 'SLARHS'
                     CALL SLARHS( PATH, XTYPE, UPLO, TRANS, N, N, 0,
     $                            IDIAG, NRHS, AP, LAP, XACT, LDA, B,
     $                            LDA, ISEED, INFO )
                     XTYPE = 'C'
                     CALL SLACPY( 'Full', N, NRHS, B, LDA, X, LDA )
*
                     SRNAMT = 'STPTRS'
                     CALL STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, X,
     $                            LDA, INFO )
*
*                 Check error code from STPTRS.
*
                     IF( INFO.NE.0 )
     $                  CALL ALAERH( PATH, 'STPTRS', INFO, 0,
     $                               UPLO // TRANS // DIAG, N, N, -1,
     $                               -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
                     CALL STPT02( UPLO, TRANS, DIAG, N, NRHS, AP, X,
     $                            LDA, B, LDA, WORK, RESULT( 2 ) )
*
*+    TEST 3
*                 Check solution from generated exact solution.
*
                     CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
     $                            RESULT( 3 ) )
*
*+    TESTS 4, 5, and 6
*                 Use iterative refinement to improve the solution and
*                 compute error bounds.
*
                     SRNAMT = 'STPRFS'
                     CALL STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B,
     $                            LDA, X, LDA, RWORK, RWORK( NRHS+1 ),
     $                            WORK, IWORK, INFO )
*
*                 Check error code from STPRFS.
*
                     IF( INFO.NE.0 )
     $                  CALL ALAERH( PATH, 'STPRFS', INFO, 0,
     $                               UPLO // TRANS // DIAG, N, N, -1,
     $                               -1, NRHS, IMAT, NFAIL, NERRS,
     $                               NOUT )
*
                     CALL SGET04( N, NRHS, X, LDA, XACT, LDA, RCONDC,
     $                            RESULT( 4 ) )
                     CALL STPT05( UPLO, TRANS, DIAG, N, NRHS, AP, B,
     $                            LDA, X, LDA, XACT, LDA, RWORK,
     $                            RWORK( NRHS+1 ), RESULT( 5 ) )
*
*                    Print information about the tests that did not pass
*                    the threshold.
*
                     DO 20 K = 2, 6
                        IF( RESULT( K ).GE.THRESH ) THEN
                           IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                        CALL ALAHD( NOUT, PATH )
                           WRITE( NOUT, FMT = 9998 )UPLO, TRANS, DIAG,
     $                        N, NRHS, IMAT, K, RESULT( K )
                           NFAIL = NFAIL + 1
                        END IF
   20                CONTINUE
                     NRUN = NRUN + 5
   30             CONTINUE
   40          CONTINUE
*
*+    TEST 7
*                 Get an estimate of RCOND = 1/CNDNUM.
*
               DO 50 ITRAN = 1, 2
                  IF( ITRAN.EQ.1 ) THEN
                     NORM = 'O'
                     RCONDC = RCONDO
                  ELSE
                     NORM = 'I'
                     RCONDC = RCONDI
                  END IF
*
                  SRNAMT = 'STPCON'
                  CALL STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK,
     $                         IWORK, INFO )
*
*                 Check error code from STPCON.
*
                  IF( INFO.NE.0 )
     $               CALL ALAERH( PATH, 'STPCON', INFO, 0,
     $                            NORM // UPLO // DIAG, N, N, -1, -1,
     $                            -1, IMAT, NFAIL, NERRS, NOUT )
*
                  CALL STPT06( RCOND, RCONDC, UPLO, DIAG, N, AP, RWORK,
     $                         RESULT( 7 ) )
*
*                 Print the test ratio if it is .GE. THRESH.
*
                  IF( RESULT( 7 ).GE.THRESH ) THEN
                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                  CALL ALAHD( NOUT, PATH )
                     WRITE( NOUT, FMT = 9997 ) 'STPCON', NORM, UPLO,
     $                  DIAG, N, IMAT, 7, RESULT( 7 )
                     NFAIL = NFAIL + 1
                  END IF
                  NRUN = NRUN + 1
   50          CONTINUE
   60       CONTINUE
   70    CONTINUE
*
*        Use pathological test matrices to test SLATPS.
*
         DO 100 IMAT = NTYPE1 + 1, NTYPES
*
*           Do the tests only if DOTYPE( IMAT ) is true.
*
            IF( .NOT.DOTYPE( IMAT ) )
     $         GO TO 100
*
            DO 90 IUPLO = 1, 2
*
*              Do first for UPLO = 'U', then for UPLO = 'L'
*
               UPLO = UPLOS( IUPLO )
               DO 80 ITRAN = 1, NTRAN
*
*                 Do for op(A) = A, A**T, or A**H.
*
                  TRANS = TRANSS( ITRAN )
*
*                 Call SLATTP to generate a triangular test matrix.
*
                  SRNAMT = 'SLATTP'
                  CALL SLATTP( IMAT, UPLO, TRANS, DIAG, ISEED, N, AP, X,
     $                         WORK, INFO )
*
*+    TEST 8
*                 Solve the system op(A)*x = b.
*
                  SRNAMT = 'SLATPS'
                  CALL SCOPY( N, X, 1, B, 1 )
                  CALL SLATPS( UPLO, TRANS, DIAG, 'N', N, AP, B, SCALE,
     $                         RWORK, INFO )
*
*                 Check error code from SLATPS.
*
                  IF( INFO.NE.0 )
     $               CALL ALAERH( PATH, 'SLATPS', INFO, 0,
     $                            UPLO // TRANS // DIAG // 'N', N, N,
     $                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
                  CALL STPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
     $                         RWORK, ONE, B, LDA, X, LDA, WORK,
     $                         RESULT( 8 ) )
*
*+    TEST 9
*                 Solve op(A)*x = b again with NORMIN = 'Y'.
*
                  CALL SCOPY( N, X, 1, B( N+1 ), 1 )
                  CALL SLATPS( UPLO, TRANS, DIAG, 'Y', N, AP, B( N+1 ),
     $                         SCALE, RWORK, INFO )
*
*                 Check error code from SLATPS.
*
                  IF( INFO.NE.0 )
     $               CALL ALAERH( PATH, 'SLATPS', INFO, 0,
     $                            UPLO // TRANS // DIAG // 'Y', N, N,
     $                            -1, -1, -1, IMAT, NFAIL, NERRS, NOUT )
*
                  CALL STPT03( UPLO, TRANS, DIAG, N, 1, AP, SCALE,
     $                         RWORK, ONE, B( N+1 ), LDA, X, LDA, WORK,
     $                         RESULT( 9 ) )
*
*                 Print information about the tests that did not pass
*                 the threshold.
*
                  IF( RESULT( 8 ).GE.THRESH ) THEN
                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                  CALL ALAHD( NOUT, PATH )
                     WRITE( NOUT, FMT = 9996 )'SLATPS', UPLO, TRANS,
     $                  DIAG, 'N', N, IMAT, 8, RESULT( 8 )
                     NFAIL = NFAIL + 1
                  END IF
                  IF( RESULT( 9 ).GE.THRESH ) THEN
                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
     $                  CALL ALAHD( NOUT, PATH )
                     WRITE( NOUT, FMT = 9996 )'SLATPS', UPLO, TRANS,
     $                  DIAG, 'Y', N, IMAT, 9, RESULT( 9 )
                     NFAIL = NFAIL + 1
                  END IF
                  NRUN = NRUN + 2
   80          CONTINUE
   90       CONTINUE
  100    CONTINUE
  110 CONTINUE
*
*     Print a summary of the results.
*
      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
*
 9999 FORMAT( ' UPLO=''', A1, ''', DIAG=''', A1, ''', N=', I5,
     $      ', type ', I2, ', test(', I2, ')= ', G12.5 )
 9998 FORMAT( ' UPLO=''', A1, ''', TRANS=''', A1, ''', DIAG=''', A1,
     $      ''', N=', I5, ''', NRHS=', I5, ', type ', I2, ', test(',
     $      I2, ')= ', G12.5 )
 9997 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''',',
     $      I5, ', ... ), type ', I2, ', test(', I2, ')=', G12.5 )
 9996 FORMAT( 1X, A, '( ''', A1, ''', ''', A1, ''', ''', A1, ''', ''',
     $      A1, ''',', I5, ', ... ), type ', I2, ', test(', I2, ')=',
     $      G12.5 )
      RETURN
*
*     End of SCHKTP
*
      END


!  qdmod.f
!
!  This work was supported by the Director, Office of Science, Division
!  of Mathematical, Information, and Computational Sciences of the
!  U.S. Department of Energy under contract number DE-AC03-76SF00098.
!
!  Copyright (c) 2000-2008
!
!  Fortran-90 module file to use with quad-double numbers.
!
!  Yozo Hida
!  David H Bailey    2008-02-20

module qdmodule
  use ddmodule
  use qdext
  implicit none

  type qd_real
    sequence
    real*8 :: re(4)
  end type qd_real

  type qd_complex
    sequence
    real*8 :: cmp(8)
  end type qd_complex

  real*8 d_qd_eps
  parameter (d_qd_eps = 1.21543267145725d-63)

  type (qd_real) qd_one, qd_zero, qd_eps, qd_huge, qd_tiny
  parameter (qd_one = qd_real((/1.0d0, 0.0d0, 0.0d0, 0.0d0/)))
  parameter (qd_zero = qd_real((/0.0d0, 0.0d0, 0.0d0, 0.0d0/)))
  parameter (qd_eps = qd_real((/d_qd_eps, 0.0d0, 0.0d0, 0.0d0/)))
  parameter (qd_huge = qd_real((/ &
    1.79769313486231570815d+308, 9.97920154767359795037d+291, &
    5.53956966280111259858d+275, 3.07507889307840487279d+259/)))
  parameter (qd_tiny = qd_real((/3.25194908739046463067d-260, &
    0.0d0, 0.0d0, 0.0d0/)))

  interface assignment (=)
    module procedure assign_qd_str
    module procedure assign_qd
    module procedure assign_qd_d
    module procedure assign_d_qd
    module procedure assign_dd_qd
    module procedure assign_qd_dd
    module procedure assign_qd_i
    module procedure assign_i_qd
    module procedure assign_qdc
    module procedure assign_qdc_qd
    module procedure assign_qd_qdc
    module procedure assign_qdc_d
    module procedure assign_qdc_i
    module procedure assign_d_qdc
    module procedure assign_qdc_dc
    module procedure assign_dc_qdc
  end interface

  interface operator (+)
    module procedure add_qd
    module procedure add_qd_d
    module procedure add_d_qd
    module procedure add_qd_i
    module procedure add_i_qd
    module procedure add_qdc
    module procedure add_qdc_qd
    module procedure add_qd_qdc
    module procedure add_qdc_d
    module procedure add_d_qdc
  end interface

  interface operator (-)
    module procedure sub_qd
    module procedure sub_qd_d
    module procedure sub_d_qd
    module procedure neg_qd
    module procedure sub_qdc
    module procedure sub_qdc_qd
    module procedure sub_qd_qdc
    module procedure sub_qdc_d
    module procedure sub_d_qdc
    module procedure neg_qdc
  end interface

  interface operator (*)
    module procedure mul_qd
    module procedure mul_qd_d
    module procedure mul_d_qd
    module procedure mul_qd_i
    module procedure mul_i_qd
    module procedure mul_qdc
    module procedure mul_qdc_qd
    module procedure mul_qd_qdc
    module procedure mul_qdc_d
    module procedure mul_d_qdc
    module procedure mul_i_qdc
    module procedure mul_qdc_i
  end interface

  interface operator (/)
    module procedure div_qd
    module procedure div_qd_d
    module procedure div_d_qd
    module procedure div_qd_i
    module procedure div_i_qd
    module procedure div_qdc
    module procedure div_qdc_qd
    module procedure div_qd_qdc
    module procedure div_qdc_d
  end interface

  interface operator (**)
    module procedure pwr_qd
    module procedure pwr_qd_i
    module procedure pwr_d_qd
    module procedure pwr_qdc_i
  end interface

  interface qdreal
    module procedure to_qd_i
    module procedure to_qd_d
    module procedure to_qd_dd
    module procedure to_qd_qd
    module procedure to_qd_str
    module procedure to_qd_qdc
  end interface

  interface ddreal
    module procedure to_dd_qd
  end interface

  interface real
    module procedure to_d_qd
    module procedure to_qd_qdc
  end interface

  interface qdcomplex
    module procedure to_qdc_qd
    module procedure to_qdc_qd2
    module procedure to_qdc_d
    module procedure to_qdc_dc
  end interface

  interface int
    module procedure to_int_qd
  end interface

  interface sin
    module procedure qdsin
  end interface
  interface cos
    module procedure qdcos
  end interface
  interface tan
    module procedure qdtan
  end interface
  interface sincos
    module procedure qdsincos
  end interface

  interface asin
    module procedure qdasin
  end interface
  interface acos
    module procedure qdacos
  end interface
  interface atan
    module procedure qdatan
  end interface
  interface atan2
    module procedure qdatan2
  end interface

  interface exp
    module procedure qdexp
    module procedure qdcexp
  end interface
  interface log
    module procedure qdlog
    module procedure qdclog
  end interface
  interface log10
    module procedure qdlog10
  end interface

  interface sqrt
    module procedure qdsqrt
  end interface
  interface sqr
    module procedure qdsqr
  end interface
  interface nroot
    module procedure qdnroot
  end interface

  interface sinh
    module procedure qdsinh
  end interface
  interface cosh
    module procedure qdcosh
  end interface
  interface tanh
    module procedure qdtanh
  end interface
  interface sincosh
    module procedure qdsincosh
  end interface

  interface asinh
    module procedure qdasinh
  end interface
  interface acosh
    module procedure qdacosh
  end interface
  interface atanh
    module procedure qdatanh
  end interface

  interface aint
    module procedure qdaint
  end interface

  interface nint
    module procedure qdnint
  end interface

  interface anint
    module procedure qdanint
  end interface

  interface abs
    module procedure qdabs
    module procedure qdcabs
  end interface

  interface sign
    module procedure qdsign
    module procedure qdsign_dd_d
  end interface

  interface random_number
    module procedure qdrand
  end interface

  interface aimag
    module procedure qd_aimag
  end interface

  interface operator (==)
    module procedure eq_qd
    module procedure eq_qd_d
    module procedure eq_d_qd
    module procedure eq_qd_i
    module procedure eq_i_qd
    module procedure eq_qdc
    module procedure eq_qdc_qd
    module procedure eq_qd_qdc
  end interface

  interface operator (/=)
    module procedure ne_qd
    module procedure ne_qd_d
    module procedure ne_d_qd
    module procedure ne_qd_i
    module procedure ne_i_qd
    module procedure ne_qdc
    module procedure ne_qdc_qd
    module procedure ne_qd_qdc
  end interface

  interface operator (>)
    module procedure gt_qd
    module procedure gt_qd_d
    module procedure gt_d_qd
    module procedure gt_qd_i
    module procedure gt_i_qd
  end interface

  interface operator (<)
    module procedure lt_qd
    module procedure lt_qd_d
    module procedure lt_d_qd
    module procedure lt_qd_i
    module procedure lt_i_qd
  end interface

  interface operator (>=)
    module procedure ge_qd
    module procedure ge_qd_d
    module procedure ge_d_qd
    module procedure ge_qd_i
    module procedure ge_i_qd
  end interface

  interface operator (<=)
    module procedure le_qd
    module procedure le_qd_d
    module procedure le_d_qd
    module procedure le_qd_i
    module procedure le_i_qd
  end interface

  interface read_scalar
    module procedure qdinpq
    module procedure qdcinpq
  end interface

  interface write_scalar
    module procedure qdoutq
    module procedure qdcoutq
  end interface

  interface qdread
    module procedure qdinpq
  end interface

  interface qdwrite
    module procedure qdoutq
  end interface

  interface qdcread
    module procedure qdcinpq
  end interface

  interface qdcwrite
    module procedure qdcoutq
  end interface

  interface dble
    module procedure to_d_qd
    module procedure to_d_qdc
  end interface

  interface cmplx
    module procedure to_dc_qdc
  end interface

  interface conjg
    module procedure qdcconjg
  end interface

  interface min
    module procedure qdmin
    module procedure qdmin2
  end interface
  interface max
    module procedure qdmax
    module procedure qdmax2
  end interface
  interface mod
     module procedure qdmod
  end interface

  interface qdpi
    module procedure qd_pi
  end interface

  interface huge
    module procedure qdhuge
  end interface

  interface safe_huge
    module procedure qd_safe_huge
  end interface

  interface tiny
    module procedure qdtiny
  end interface

  interface epsilon
    module procedure qdepsilon
  end interface

  interface radix
    module procedure qd_radix
  end interface

  interface digits
    module procedure qd_digits
  end interface

  interface maxexponent
    module procedure qd_max_expn
  end interface

  interface minexponent
    module procedure qd_min_expn
  end interface

  interface precision
    module procedure qd_precision
  end interface

  interface range
    module procedure qd_range
  end interface

  interface nan
    module procedure qd_nan
  end interface

contains

! Assignments
  subroutine assign_qd_str(a, s)
    type (qd_real), intent(inout) :: a
    character (len=*), intent(in) :: s
    character*80 t
    t = s
    call qdinpc (t, a%re)
  end subroutine assign_qd_str

  elemental subroutine assign_qd (a, b)
    type (qd_real), intent(inout) :: a
    type (qd_real), intent(in) :: b
    a%re = b%re
  end subroutine assign_qd

  elemental subroutine assign_qd_d(a, d)
    type (qd_real), intent(inout) :: a
    real*8, intent(in) :: d
    a%re(1) = d
    a%re(2:4) = 0.0d0
  end subroutine assign_qd_d

  elemental subroutine assign_d_qd(d, a)
    real*8, intent(inout) :: d
    type (qd_real), intent(in) :: a
    d = a%re(1)
  end subroutine assign_d_qd

  elemental subroutine assign_qd_i(a, i)
    type (qd_real), intent(inout) :: a
    integer, intent(in) :: i
    a%re(1) = i
    a%re(2:4) = 0.0d0
  end subroutine assign_qd_i

  elemental subroutine assign_i_qd(i, a)
    integer, intent(inout) :: i
    type (qd_real), intent(in) :: a
    i = a%re(1)
  end subroutine assign_i_qd

  elemental subroutine assign_dd_qd(dd, qd)
    type (dd_real), intent(inout) :: dd
    type (qd_real), intent(in) :: qd
    dd%re(1:2) = qd%re(1:2)
  end subroutine assign_dd_qd

  elemental subroutine assign_qd_dd(qd, dd)
    type (qd_real), intent(inout) :: qd
    type (dd_real), intent(in) :: dd
    qd%re(1:2) = dd%re
    qd%re(3:4) = 0.d0
  end subroutine assign_qd_dd

  elemental subroutine assign_qdc (a, b)
    type (qd_complex), intent(inout) :: a
    type (qd_complex), intent(in) :: b
    a%cmp = b%cmp
  end subroutine assign_qdc

  elemental subroutine assign_qdc_qd (qdc, qd)
    type (qd_complex), intent (inout) :: qdc
    type (qd_real), intent(in) :: qd
    qdc%cmp(1:4) = qd%re
    qdc%cmp(5:8) = 0.d0
  end subroutine assign_qdc_qd

  elemental subroutine assign_qd_qdc (qd, qdc)
    type (qd_real), intent (inout) :: qd
    type (qd_complex), intent(in) :: qdc
    qd%re = qdc%cmp(1:4)
  end subroutine assign_qd_qdc

  elemental subroutine assign_qdc_d (qdc, d)
    type (qd_complex), intent (inout) :: qdc
    real*8, intent(in) :: d
    qdc%cmp(1) = d
    qdc%cmp(2:8) = 0.d0
  end subroutine assign_qdc_d

  elemental subroutine assign_qdc_i (qdc, i)
    type (qd_complex), intent (inout) :: qdc
    integer, intent(in) :: i
    qdc%cmp(1) = i
    qdc%cmp(2:8) = 0.d0
  end subroutine assign_qdc_i

  elemental subroutine assign_d_qdc (d, qdc)
    real*8, intent(inout) :: d
    type (qd_complex), intent (in) :: qdc
    d = qdc%cmp(1)
  end subroutine assign_d_qdc

  elemental subroutine assign_qdc_dc (qdc, dc)
    type (qd_complex), intent (inout) :: qdc
    complex (kind (0.d0)), intent (in) :: dc
    qdc%cmp(1) = dble (dc)
    qdc%cmp(2:4) = 0.d0
    qdc%cmp(5) = aimag (dc)
    qdc%cmp(6:8) = 0.d0
  end subroutine assign_qdc_dc

  elemental subroutine assign_dc_qdc (dc, qdc)
    complex (kind (0.D0)), intent (inout) :: dc
    type (qd_complex), intent (in) :: qdc
    dc = cmplx (qdc%cmp(1), qdc%cmp(5), kind (0.d0))
  end subroutine assign_dc_qdc

! Conversions

  elemental type (qd_real) function to_qd_i(ia)
    integer, intent(in) :: ia
    to_qd_i%re(1) = ia
    to_qd_i%re(2:4) = 0.d0
  end function to_qd_i

  elemental type (qd_real) function to_qd_d(d)
    real*8, intent(in) :: d
    to_qd_d%re(1) = d
    to_qd_d%re(2:4) = 0.0d0
  end function to_qd_d

  elemental real*8 function to_d_qd(qd)
    type (qd_real), intent(in) :: qd
    to_d_qd = qd%re(1)
  end function to_d_qd

  elemental integer function to_int_qd(a)
    type (qd_real), intent(in) :: a
    to_int_qd = a%re(1)
  end function to_int_qd

  elemental type (qd_real) function to_qd_dd (dd)
    type (dd_real), intent(in) :: dd
    to_qd_dd%re(1:2) = dd%re
    to_qd_dd%re(3:4) = 0.d0
  end function to_qd_dd

  elemental type (qd_real) function to_qd_qd (qd)
    type (qd_real), intent(in) :: qd
    to_qd_qd%re = qd%re
  end function to_qd_qd

  elemental type (dd_real) function to_dd_qd (qd)
    type (qd_real), intent(in) :: qd
    to_dd_qd%re = qd%re(1:2)
  end function to_dd_qd

  type (qd_real) function to_qd_str(s)
    character (len=*), intent(in) :: s
    character*80 t
    t = s
    call qdinpc (t, to_qd_str%re)
  end function to_qd_str

  elemental type (qd_real) function to_qd_qdc(qdc)
    type (qd_complex), intent(in) :: qdc
    to_qd_qdc%re = qdc%cmp(1:4)
  end function to_qd_qdc

  elemental type (qd_complex) function to_qdc_qd(qd)
    type (qd_real), intent(in) :: qd
    to_qdc_qd%cmp(1:4) = qd%re
    to_qdc_qd%cmp(5:8) = 0.d0
  end function to_qdc_qd

  elemental type (qd_complex) function to_qdc_qd2(x, y)
    type (qd_real), intent(in) :: x, y
    to_qdc_qd2%cmp(1:4) = x%re
    to_qdc_qd2%cmp(5:8) = y%re
  end function to_qdc_qd2

  elemental type (qd_complex) function to_qdc_d(d)
    real*8, intent(in) :: d
    to_qdc_d%cmp(1) = d
    to_qdc_d%cmp(2:8) = 0.d0
  end function to_qdc_d

  elemental complex (kind (0.D0)) function to_dc_qdc (qdc)
    type (qd_complex), intent (in) :: qdc
    to_dc_qdc = cmplx (qdc%cmp(1), qdc%cmp(5), kind (0.d0))
  end function to_dc_qdc

  elemental type (qd_complex) function to_qdc_dc (dc)
    complex (kind (0.d0)), intent(in) :: dc
    to_qdc_dc%cmp(1) = dble (dc)
    to_qdc_dc%cmp(2:4) = 0.d0
    to_qdc_dc%cmp(5) = aimag (dc)
    to_qdc_dc%cmp(6:8) = 0.d0
  end function to_qdc_dc

  elemental real*8 function to_d_qdc(qdc)
    type (qd_complex), intent(in) :: qdc
    to_d_qdc = qdc%cmp(1)
  end function to_d_qdc

!  Complex conjugation

  elemental type (qd_complex) function qdcconjg (qdc)
    type (qd_complex), intent(in) :: qdc
    qdcconjg%cmp(1:4) = qdc%cmp(1:4)
    qdcconjg%cmp(5:8) = -qdc%cmp(5:8)
  end function qdcconjg

! Additions
  elemental type (qd_real) function add_qd(a, b)
    type (qd_real), intent(in) :: a, b
    call f_qd_add(a%re, b%re, add_qd%re)
  end function add_qd

  elemental type (qd_real) function add_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    call f_qd_add_qd_d(a%re, b, add_qd_d%re)
  end function add_qd_d

  elemental type (qd_real) function add_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    add_d_qd = add_qd_d(b, a)
  end function add_d_qd

  elemental type (qd_real) function add_qd_i(a, b)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: b
    call f_qd_add_qd_d(a%re, dble(b), add_qd_i%re)
  end function add_qd_i

  elemental type (qd_real) function add_i_qd(a, b)
    integer, intent(in) :: a
    type (qd_real), intent(in) :: b
    add_i_qd = add_qd_i(b, a)
  end function add_i_qd

  elemental type (qd_complex) function add_qdc(a, b)
    type (qd_complex), intent(in) :: a, b
    call f_qd_add (a%cmp(1:4), b%cmp(1:4), add_qdc%cmp(1:4))
    call f_qd_add (a%cmp(5:8), b%cmp(5:8), add_qdc%cmp(5:8))
  end function add_qdc

  elemental type (qd_complex) function add_qdc_qd(a, b)
    type (qd_complex), intent(in) :: a
    type (qd_real), intent(in) :: b
    call f_qd_add (a%cmp(1:4), b%re, add_qdc_qd%cmp(1:4))
    add_qdc_qd%cmp(5:8) = a%cmp(5:8)
  end function add_qdc_qd

  elemental type (qd_complex) function add_qd_qdc(a, b)
    type (qd_real), intent(in) :: a
    type (qd_complex), intent(in) :: b
    add_qd_qdc = add_qdc_qd(b, a)
  end function add_qd_qdc

  elemental type (qd_complex) function add_qdc_d(a, b)
    type (qd_complex), intent(in) :: a
    real*8, intent(in) :: b
    type (qd_real) :: qdb
    qdb%re(1) = b
    qdb%re(2:4) = 0.d0
    call f_qd_add (a%cmp(1:4), qdb%re, add_qdc_d%cmp(1:4))
    add_qdc_d%cmp(5:8) = a%cmp(5:8)
  end function add_qdc_d

  elemental type (qd_complex) function add_d_qdc(a, b)
    real*8, intent(in) :: a
    type (qd_complex), intent(in) :: b
    add_d_qdc = add_qdc_d(b, a)
  end function add_d_qdc

! Subtractions
  elemental type (qd_real) function sub_qd(a, b)
    type (qd_real), intent(in) :: a, b
    call f_qd_sub(a%re, b%re, sub_qd%re)
  end function sub_qd

  elemental type (qd_real) function sub_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    call f_qd_sub_qd_d(a%re, b, sub_qd_d%re)
  end function sub_qd_d

  elemental type (qd_real) function sub_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    call f_qd_sub_d_qd(a, b%re, sub_d_qd%re)
  end function sub_d_qd

  elemental type (qd_complex) function sub_qdc(a, b)
    type (qd_complex), intent(in) :: a, b
    call f_qd_sub (a%cmp(1:4), b%cmp(1:4), sub_qdc%cmp(1:4))
    call f_qd_sub (a%cmp(5:8), b%cmp(5:8), sub_qdc%cmp(5:8))
  end function sub_qdc

  elemental type (qd_complex) function sub_qdc_qd(a, b)
    type (qd_complex), intent(in) :: a
    type (qd_real), intent(in) :: b
    call f_qd_sub (a%cmp(1:4), b%re(1:4), sub_qdc_qd%cmp(1:4))
    sub_qdc_qd%cmp(5:8) = a%cmp(5:8)
  end function sub_qdc_qd

  elemental type (qd_complex) function sub_qd_qdc(a, b)
    type (qd_real), intent(in) :: a
    type (qd_complex), intent(in) :: b
    call f_qd_sub (a%re(1:4), b%cmp(1:4), sub_qd_qdc%cmp(1:4))
    sub_qd_qdc%cmp(5:8) = - b%cmp(5:8)
  end function sub_qd_qdc

  elemental type (qd_complex) function sub_qdc_d(a, b)
    type (qd_complex), intent(in) :: a
    real*8, intent(in) :: b
    type (qd_real) qdb
    qdb%re(1) = b
    qdb%re(2:4) = 0.d0
    call f_qd_sub (a%cmp(1:4), qdb%re, sub_qdc_d%cmp(1:4))
    sub_qdc_d%cmp(5:8) = a%cmp(5:8)
  end function sub_qdc_d

  elemental type (qd_complex) function sub_d_qdc(a, b)
    real*8, intent(in) :: a
    type (qd_complex), intent(in) :: b
    type (qd_real) qda
    qda%re(1) = a
    qda%re(2:4) = 0.d0
    call f_qd_sub (qda%re, b%cmp(1:4), sub_d_qdc%cmp(1:4))
    sub_d_qdc%cmp(5:8) = - b%cmp(5:8)
  end function sub_d_qdc

! Unary Minus
  elemental type (qd_real) function neg_qd(a)
    type (qd_real), intent(in) :: a
    neg_qd%re = -a%re
  end function neg_qd

  elemental type (qd_complex) function neg_qdc(a)
    type (qd_complex), intent(in) :: a
    neg_qdc%cmp = -a%cmp
  end function neg_qdc

! Multiplications
  elemental type (qd_real) function mul_qd(a, b)
    type (qd_real), intent(in) :: a, b
    call f_qd_mul(a%re, b%re, mul_qd%re)
  end function mul_qd

  elemental type (qd_real) function mul_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    call f_qd_mul_qd_d(a%re, b, mul_qd_d%re)
  end function mul_qd_d

  elemental type (qd_real) function mul_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    call f_qd_mul_qd_d(b%re, a, mul_d_qd%re)
  end function mul_d_qd

  elemental type (qd_real) function mul_qd_i(a, b)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: b
    call f_qd_mul_qd_d(a%re, dble(b), mul_qd_i%re)
  end function mul_qd_i

  elemental type (qd_real) function mul_i_qd(a, b)
    integer, intent(in) :: a
    type (qd_real), intent(in) :: b
    call f_qd_mul_qd_d(b%re, dble(a), mul_i_qd%re)
  end function mul_i_qd

  elemental type (qd_complex) function mul_qdc(a, b)
    type (qd_complex), intent(in) :: a, b
    type (qd_real) t1, t2
    call f_qd_mul (a%cmp(1:4), b%cmp(1:4), t1%re)
    call f_qd_mul (a%cmp(5:8), b%cmp(5:8), t2%re)
    call f_qd_sub (t1%re, t2%re, mul_qdc%cmp(1:4))
    call f_qd_mul (a%cmp(1:4), b%cmp(5:8), t1%re)
    call f_qd_mul (a%cmp(5:8), b%cmp(1:4), t2%re)
    call f_qd_add (t1%re, t2%re, mul_qdc%cmp(5:8))
  end function mul_qdc

  elemental type (qd_complex) function mul_qdc_qd(a, b)
    type (qd_complex), intent(in) :: a
    type (qd_real), intent(in) :: b
    call f_qd_mul (a%cmp(1:4), b%re, mul_qdc_qd%cmp(1:4))
    call f_qd_mul (a%cmp(5:8), b%re, mul_qdc_qd%cmp(5:8))
  end function mul_qdc_qd

  elemental type (qd_complex) function mul_qd_qdc(a, b)
    type (qd_real), intent(in) :: a
    type (qd_complex), intent(in) :: b
    call f_qd_mul (a%re, b%cmp(1:4), mul_qd_qdc%cmp(1:4))
    call f_qd_mul (a%re, b%cmp(5:8), mul_qd_qdc%cmp(5:8))
  end function mul_qd_qdc

  elemental type (qd_complex) function mul_qdc_d(a, b)
    type (qd_complex), intent(in) :: a
    real*8, intent(in) :: b
    call f_qd_mul_qd_d (a%cmp(1:4), b, mul_qdc_d%cmp(1:4))
    call f_qd_mul_qd_d (a%cmp(5:8), b, mul_qdc_d%cmp(5:8))
  end function mul_qdc_d

  elemental type (qd_complex) function mul_d_qdc(a, b)
    real*8, intent(in) :: a
    type (qd_complex), intent(in) :: b
    call f_qd_mul_qd_d (b%cmp(1:4), a, mul_d_qdc%cmp(1:4))
    call f_qd_mul_qd_d (b%cmp(5:8), a, mul_d_qdc%cmp(5:8))
  end function mul_d_qdc

  elemental type (qd_complex) function mul_qdc_i(a, b)
    type (qd_complex), intent(in) :: a
    integer, intent(in) :: b
    call f_qd_mul_qd_d (a%cmp(1:4), dble(b), mul_qdc_i%cmp(1:4))
    call f_qd_mul_qd_d (a%cmp(5:8), dble(b), mul_qdc_i%cmp(5:8))
  end function mul_qdc_i

  elemental type (qd_complex) function mul_i_qdc(a, b)
    integer, intent(in) :: a
    type (qd_complex), intent(in) :: b
    call f_qd_mul_qd_d (b%cmp(1:4), dble(a), mul_i_qdc%cmp(1:4))
    call f_qd_mul_qd_d (b%cmp(5:8), dble(a), mul_i_qdc%cmp(5:8))
  end function mul_i_qdc

! Divisions
  elemental type (qd_real) function div_qd(a, b)
    type (qd_real), intent(in) :: a, b
    call f_qd_div(a%re, b%re, div_qd%re)
  end function div_qd

  elemental type (qd_real) function div_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    call f_qd_div_qd_d(a%re, b, div_qd_d%re)
  end function div_qd_d

  elemental type (qd_real) function div_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    call f_qd_div_d_qd(a, b%re, div_d_qd%re)
  end function div_d_qd

  elemental type (qd_real) function div_qd_i(a, b)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: b
    call f_qd_div_qd_d(a%re, dble(b), div_qd_i%re)
  end function div_qd_i

  elemental type (qd_real) function div_i_qd(a, b)
    integer, intent(in) :: a
    type (qd_real), intent(in) :: b
    call f_qd_div_d_qd(dble(a), b%re, div_i_qd%re)
  end function div_i_qd

  elemental type (qd_complex) function div_qdc(a, b)
    type (qd_complex), intent(in) :: a, b
    type (qd_real) t1, t2, t3, t4, t5
    call f_qd_mul (a%cmp(1:4), b%cmp(1:4), t1%re)
    call f_qd_mul (a%cmp(5:8), b%cmp(5:8), t2%re)
    call f_qd_add (t1%re, t2%re, t3%re)
    call f_qd_mul (a%cmp(1:4), b%cmp(5:8), t1%re)
    call f_qd_mul (a%cmp(5:8), b%cmp(1:4), t2%re)
    call f_qd_sub (t2%re, t1%re, t4%re)
    call f_qd_mul (b%cmp(1:4), b%cmp(1:4), t1%re)
    call f_qd_mul (b%cmp(5:8), b%cmp(5:8), t2%re)
    call f_qd_add (t1%re, t2%re, t5%re)
    call f_qd_div (t3%re, t5%re, div_qdc%cmp(1:4))
    call f_qd_div (t4%re, t5%re, div_qdc%cmp(5:8))
  end function div_qdc

  elemental type (qd_complex) function div_qdc_qd(a, b)
    type (qd_complex), intent(in) :: a
    type (qd_real), intent(in) :: b
    call f_qd_div (a%cmp(1:4), b%re, div_qdc_qd%cmp(1:4))
    call f_qd_div (a%cmp(5:8), b%re, div_qdc_qd%cmp(5:8))
  end function div_qdc_qd

  elemental type (qd_complex) function div_qd_qdc(a, b)
    type (qd_real), intent(in) :: a
    type (qd_complex), intent(in) :: b
    type (qd_real) t1, t2, t3, t4, t5
    call f_qd_mul (a%re, b%cmp(1:4), t1%re)
    call f_qd_mul (a%re, b%cmp(5:8), t2%re)
    t2%re = - t2%re
    call f_qd_mul (b%cmp(1:4), b%cmp(1:4), t3%re)
    call f_qd_mul (b%cmp(5:8), b%cmp(5:8), t4%re)
    call f_qd_add (t3%re, t4%re, t5%re)
    call f_qd_div (t1%re, t5%re, div_qd_qdc%cmp(1:4))
    call f_qd_div (t2%re, t5%re, div_qd_qdc%cmp(5:8))
  end function div_qd_qdc

  elemental type (qd_complex) function div_qdc_d(a,b)
    type (qd_complex), intent(in) :: a
    real*8, intent(in) :: b
    call f_qd_div_qd_d(a%cmp(1:4), b, div_qdc_d%cmp(1:4))
    call f_qd_div_qd_d(a%cmp(5:8), b, div_qdc_d%cmp(5:8))
  end function div_qdc_d

! Power
  elemental type (qd_real) function pwr_qd (a, b)
    type (qd_real), intent(in) :: a, b
    type (qd_real) q1, q2
    call f_qd_log(a%re, q1%re)
    call f_qd_mul(q1%re, b%re, q2%re)
    call f_qd_exp(q2%re, pwr_qd%re)
  end function pwr_qd

  elemental type (qd_real) function pwr_qd_i(a, n)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: n
    call f_qd_npwr(a%re, n, pwr_qd_i%re)
  end function pwr_qd_i

  elemental type (qd_real) function pwr_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    type (qd_real) q1, q2, q3
    q1%re(1) = a
    q1%re(2:4) = 0.d0
    call f_qd_log(q1%re, q2%re)
    call f_qd_mul(q2%re, b%re, q3%re)
    call f_qd_exp(q3%re, pwr_d_qd%re)
  end function pwr_d_qd

  elemental type (qd_complex) function pwr_qdc_i(a, n)
    type (qd_complex), intent(in) :: a
    integer, intent(in) :: n
    integer i2, j, n1
    type (qd_real) t1, t2, t3
    type (qd_complex) c1, c2

    intrinsic :: iabs, ishft

    if (n == 0) then
      if (all(a%cmp == 0.d0)) then
        !write (6, *) 'pwr_qdc_i: a = 0 and n = 0'
        call f_qd_nan(pwr_qdc_i%cmp(1:4))
        call f_qd_nan(pwr_qdc_i%cmp(5))
        return
      endif
      pwr_qdc_i%cmp(1) = 1.d0
      pwr_qdc_i%cmp(2:8) = 0.d0
      return
    endif
    n1 = iabs (n)
    i2 = ishft(1, n1-1)

    c1%cmp(1) = 1.d0
    c1%cmp(2:8) = 0.d0

110 continue

    if (n1 >= i2) then
      call f_qd_mul (a%cmp(1:4), c1%cmp(1:4), t1%re)
      call f_qd_mul (a%cmp(5:8), c1%cmp(5:8), t2%re)
      call f_qd_sub (t1%re, t2%re, c2%cmp(1:4))
      call f_qd_mul (a%cmp(1:4), c1%cmp(5:8), t1%re)
      call f_qd_mul (a%cmp(5:8), c1%cmp(1:4), t2%re)
      call f_qd_add (t1%re, t2%re, c2%cmp(5:8))
      c1%cmp = c2%cmp
      n1 = n1 - i2
    endif
    i2 = i2 / 2
    if (i2 >= 1) then
      call f_qd_mul (c1%cmp(1:4), c1%cmp(1:4), t1%re)
      call f_qd_mul (c1%cmp(5:8), c1%cmp(5:8), t2%re)
      call f_qd_sub (t1%re, t2%re, c2%cmp(1:4))
      call f_qd_mul (c1%cmp(1:4), c1%cmp(5:8), t1%re)
      c2%cmp(5:8) = 2.d0 * t1%re
      c1%cmp = c2%cmp
      goto 110
    endif

    if (n > 0) then
      pwr_qdc_i%cmp = c1%cmp
    else
      c1%cmp(5:8) = - c1%cmp(5:8)
      call f_qd_mul (c1%cmp(1:4), c1%cmp(1:4), t1%re)
      call f_qd_mul (c1%cmp(5:8), c1%cmp(5:8), t2%re)
      call f_qd_add (t1%re, t2%re, t3%re)
      call f_qd_div (c1%cmp(1:4), t3%re, pwr_qdc_i%cmp(1:4))
      call f_qd_div (c1%cmp(5:8), t3%re, pwr_qdc_i%cmp(5:8))
    endif

    return
  end function pwr_qdc_i

! Trigonometric Functions
  elemental type (qd_real) function qdsin(a)
    type (qd_real), intent(in) :: a
    call f_qd_sin(a%re, qdsin%re)
  end function qdsin

  elemental type (qd_real) function qdcos(a)
    type (qd_real), intent(in) :: a
    call f_qd_cos(a%re, qdcos%re)
  end function qdcos

  elemental type (qd_real) function qdtan(a)
    type (qd_real), intent(in) :: a
    call f_qd_tan(a%re, qdtan%re)
  end function qdtan

  elemental subroutine qdsincos(a, s, c)
    type (qd_real), intent(in) :: a
    type (qd_real), intent(out) :: s, c
    call f_qd_sincos(a%re, s%re, c%re)
  end subroutine qdsincos

! Inverse Trigonometric Functions
  elemental type (qd_real) function qdasin(a)
    type (qd_real), intent(in) :: a
    call f_qd_asin(a%re, qdasin%re)
  end function qdasin

  elemental type (qd_real) function qdacos(a)
    type (qd_real), intent(in) :: a
    call f_qd_acos(a%re, qdacos%re)
  end function qdacos

  elemental type (qd_real) function qdatan(a)
    type (qd_real), intent(in) :: a
    call f_qd_atan(a%re, qdatan%re)
  end function qdatan

  elemental type (qd_real) function qdatan2(a, b)
    type (qd_real), intent(in) :: a, b
    call f_qd_atan2(a%re, b%re, qdatan2%re)
  end function qdatan2

! Exponential and Logarithms
  elemental type (qd_real) function qdexp(a)
    type (qd_real), intent(in) :: a
    call f_qd_exp(a%re, qdexp%re)
  end function qdexp

  elemental type (qd_complex) function qdcexp (a)
    type (qd_complex), intent(in) :: a
    type (qd_real) t1, t2, t3
    call f_qd_exp (a%cmp(1:4), t1%re)
    call f_qd_sincos (a%cmp(5:8), t3%re, t2%re)
    call f_qd_mul (t1%re, t2%re, qdcexp%cmp(1:4))
    call f_qd_mul (t1%re, t3%re, qdcexp%cmp(5:8))
  end function qdcexp

  elemental type (qd_real) function qdlog(a)
    type (qd_real), intent(in) :: a
    call f_qd_log(a%re, qdlog%re)
  end function qdlog

  elemental type (qd_complex) function qdclog (a)
    type (qd_complex), intent(in) :: a
    type (qd_real) t1, t2, t3
    call f_qd_mul (a%cmp(1:4), a%cmp(1:4), t1%re)
    call f_qd_mul (a%cmp(5:8), a%cmp(5:8), t2%re)
    call f_qd_add (t1%re, t2%re, t3%re)
    call f_qd_log (t3%re, t1%re)
    qdclog%cmp(1:4) = 0.5d0 * t1%re
    call f_qd_atan2 (a%cmp(5:8), a%cmp(1:4), qdclog%cmp(5:8))
  end function qdclog

  elemental type (qd_real) function qdlog10(a)
    type (qd_real), intent(in) :: a
    call f_qd_log10(a%re, qdlog10%re)
  end function qdlog10

! SQRT, etc.
  elemental type (qd_real) function qdsqrt(a)
    type (qd_real), intent(in) :: a
    call f_qd_sqrt(a%re, qdsqrt%re)
  end function qdsqrt

  elemental type (qd_real) function qdsqr(a)
    type (qd_real), intent(in) :: a
    call f_qd_sqr(a%re, qdsqr%re)
  end function qdsqr

  elemental type (qd_real) function qdnroot(a, n)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: n
    call f_qd_nroot(a%re, n, qdnroot%re)
  end function qdnroot

! Hyperbolic Functions
  elemental type (qd_real) function qdsinh(a)
    type (qd_real), intent(in) :: a
    call f_qd_sinh(a%re, qdsinh%re)
  end function qdsinh

  elemental type (qd_real) function qdcosh(a)
    type (qd_real), intent(in) :: a
    call f_qd_cosh(a%re, qdcosh%re)
  end function qdcosh

  elemental type (qd_real) function qdtanh(a)
    type (qd_real), intent(in) :: a
    call f_qd_tanh(a%re, qdtanh%re)
  end function qdtanh

  elemental subroutine qdsincosh(a, s, c)
    type (qd_real), intent(in) :: a
    type (qd_real), intent(out) :: s, c
    call f_qd_sincosh(a%re, s%re, c%re)
  end subroutine qdsincosh

! Inverse Hyperbolic Functions
  elemental type (qd_real) function qdasinh(a)
    type (qd_real), intent(in) :: a
    call f_qd_asinh(a%re, qdasinh%re)
  end function qdasinh

  elemental type (qd_real) function qdacosh(a)
    type (qd_real), intent(in) :: a
    call f_qd_acosh(a%re, qdacosh%re)
  end function qdacosh

  elemental type (qd_real) function qdatanh(a)
    type (qd_real), intent(in) :: a
    call f_qd_atanh(a%re, qdatanh%re)
  end function qdatanh

! Rounding
  elemental type (qd_real) function qdaint(a)
    type (qd_real), intent(in) :: a
    call f_qd_aint(a%re, qdaint%re)
  end function qdaint

  elemental type (qd_real) function qdanint(a)
    type (qd_real), intent(in) :: a
    call f_qd_nint(a%re, qdanint%re)
  end function qdanint

  elemental integer function qdnint(a)
    type (qd_real), intent(in) :: a
    qdnint = to_int_qd(qdaint(a));
  end function qdnint

! Random Number Generator
  subroutine qdrand(harvest)
    type (qd_real), intent(out) :: harvest
    call f_qd_rand(harvest%re)
  end subroutine qdrand

! Equality
  elemental logical function eq_qd(a, b)
    type (qd_real), intent(in) :: a, b
    integer :: r
    call f_qd_comp(a%re, b%re, r)
    if (r == 0) then
      eq_qd = .true.
    else
      eq_qd = .false.
    end if
  end function eq_qd

  elemental logical function eq_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(a%re, b, r)
    if (r == 0) then
      eq_qd_d = .true.
    else
      eq_qd_d = .false.
    end if
  end function eq_qd_d

  elemental logical function eq_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(b%re, a, r)
    if (r == 0) then
      eq_d_qd = .true.
    else
      eq_d_qd = .false.
    end if
  end function eq_d_qd

  elemental logical function eq_qd_i(a, b)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: b
    eq_qd_i = eq_qd_d(a, dble(b))
  end function eq_qd_i

  elemental logical function eq_i_qd(a, b)
    integer, intent(in) :: a
    type (qd_real), intent(in) :: b
    eq_i_qd = eq_d_qd(dble(a), b)
  end function eq_i_qd

  elemental logical function eq_qdc (a, b)
    type (qd_complex), intent(in) :: a, b
    integer :: i1, i2
    call f_qd_comp (a%cmp(1:4), b%cmp(1:4), i1)
    call f_qd_comp (a%cmp(5:8), b%cmp(5:8), i2)
    if (i1 == 0 .and. i2 == 0) then
      eq_qdc = .true.
    else
      eq_qdc = .false.
    endif
  end function eq_qdc

  elemental logical function eq_qdc_qd (a, b)
    type (qd_complex), intent(in) :: a
    type (qd_real), intent(in) :: b
    integer :: i1
    call f_qd_comp (a%cmp(1:4), b%re, i1)
    if (i1 == 0 .and. all(a%cmp(5:8) == 0.d0)) then
      eq_qdc_qd = .true.
    else
      eq_qdc_qd = .false.
    endif
  end function eq_qdc_qd

  elemental logical function eq_qd_qdc (a, b)
    type (qd_real), intent(in) :: a
    type (qd_complex), intent(in) :: b
    integer :: i1
    call f_qd_comp (a%re, b%cmp(1:4), i1)
    if (i1 == 0 .and. all(b%cmp(5:8) == 0.d0)) then
      eq_qd_qdc = .true.
    else
      eq_qd_qdc = .false.
    endif
  end function eq_qd_qdc

! Non-Equality
  elemental logical function ne_qd(a, b)
    type (qd_real), intent(in) :: a, b
    integer :: r
    call f_qd_comp(a%re, b%re, r)
    if (r == 0) then
      ne_qd = .false.
    else
      ne_qd = .true.
    end if
  end function ne_qd

  elemental logical function ne_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(a%re, b, r)
    if (r == 0) then
      ne_qd_d = .false.
    else
      ne_qd_d = .true.
    end if
  end function ne_qd_d

  elemental logical function ne_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(b%re, a, r)
    if (r == 0) then
      ne_d_qd = .false.
    else
      ne_d_qd = .true.
    end if
  end function ne_d_qd

  elemental logical function ne_qd_i(a, b)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: b
    ne_qd_i = ne_qd_d(a, dble(b))
  end function ne_qd_i

  elemental logical function ne_i_qd(a, b)
    integer, intent(in) :: a
    type (qd_real), intent(in) :: b
    ne_i_qd = ne_d_qd(dble(a), b)
  end function ne_i_qd

  elemental logical function ne_qdc (a, b)
    type (qd_complex), intent(in) :: a, b
    integer :: i1, i2
    call f_qd_comp (a%cmp(1:4), b%cmp(1:4), i1)
    call f_qd_comp (a%cmp(5:8), b%cmp(5:8), i2)
    if (i1 /= 0 .or. i2 /= 0) then
      ne_qdc = .true.
    else
      ne_qdc = .false.
    endif
  end function ne_qdc

  elemental logical function ne_qdc_qd (a, b)
    type (qd_complex), intent(in) :: a
    type (qd_real), intent(in) :: b
    integer :: i1
    call f_qd_comp (a%cmp(1:4), b%re, i1)
    if (i1 /= 0 .or. any(a%cmp(5:8) /= 0.d0)) then
      ne_qdc_qd = .true.
    else
      ne_qdc_qd = .false.
    endif
  end function ne_qdc_qd

  elemental logical function ne_qd_qdc (a, b)
    type (qd_real), intent(in) :: a
    type (qd_complex), intent(in) :: b
    integer :: i1
    call f_qd_comp (a%re, b%cmp(1:4), i1)
    if (i1 /= 0 .or. any(b%cmp(5:8) /= 0.d0)) then
      ne_qd_qdc = .true.
    else
      ne_qd_qdc = .false.
    endif
  end function ne_qd_qdc

! Greater-Than
  elemental logical function gt_qd(a, b)
    type (qd_real), intent(in) :: a, b
    integer :: r
    call f_qd_comp(a%re, b%re, r)
    if (r == 1) then
      gt_qd = .true.
    else
      gt_qd = .false.
    end if
  end function gt_qd

  elemental logical function gt_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(a%re, b, r)
    if (r == 1) then
      gt_qd_d = .true.
    else
      gt_qd_d = .false.
    end if
  end function gt_qd_d

  elemental logical function gt_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(b%re, a, r)
    if (r == -1) then
      gt_d_qd = .true.
    else
      gt_d_qd = .false.
    end if
  end function gt_d_qd

  elemental logical function gt_qd_i(a, b)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: b
    gt_qd_i = gt_qd_d(a, dble(b))
  end function gt_qd_i

  elemental logical function gt_i_qd(a, b)
    integer, intent(in) :: a
    type (qd_real), intent(in) :: b
    gt_i_qd = gt_d_qd(dble(a), b)
  end function gt_i_qd

! Less-Than
  elemental logical function lt_qd(a, b)
    type (qd_real), intent(in) :: a, b
    integer :: r
    call f_qd_comp(a%re, b%re, r)
    if (r == -1) then
      lt_qd = .true.
    else
      lt_qd = .false.
    end if
  end function lt_qd

  elemental logical function lt_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(a%re, b, r)
    if (r == -1) then
      lt_qd_d = .true.
    else
      lt_qd_d = .false.
    end if
  end function lt_qd_d

  elemental logical function lt_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(b%re, a, r)
    if (r == 1) then
      lt_d_qd = .true.
    else
      lt_d_qd = .false.
    end if
  end function lt_d_qd

  elemental logical function lt_qd_i(a, b)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: b
    lt_qd_i = lt_qd_d(a, dble(b))
  end function lt_qd_i

  elemental logical function lt_i_qd(a, b)
    integer, intent(in) :: a
    type (qd_real), intent(in) :: b
    lt_i_qd = lt_d_qd(dble(a), b)
  end function lt_i_qd

! Greater-Than-Or-Equal-To
  elemental logical function ge_qd(a, b)
    type (qd_real), intent(in) :: a, b
    integer :: r
    call f_qd_comp(a%re, b%re, r)
    if (r >= 0) then
      ge_qd = .true.
    else
      ge_qd = .false.
    end if
  end function ge_qd

  elemental logical function ge_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(a%re, b, r)
    if (r >= 0) then
      ge_qd_d = .true.
    else
      ge_qd_d = .false.
    end if
  end function ge_qd_d

  elemental logical function ge_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(b%re, a, r)
    if (r <= 0) then
      ge_d_qd = .true.
    else
      ge_d_qd = .false.
    end if
  end function ge_d_qd

  elemental logical function ge_qd_i(a, b)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: b
    ge_qd_i = ge_qd_d(a, dble(b))
  end function ge_qd_i

  elemental logical function ge_i_qd(a, b)
    integer, intent(in) :: a
    type (qd_real), intent(in) :: b
    ge_i_qd = ge_d_qd(dble(a), b)
  end function ge_i_qd

! Less-Than-Or-Equal-To
  elemental logical function le_qd(a, b)
    type (qd_real), intent(in) :: a, b
    integer :: r
    call f_qd_comp(a%re, b%re, r)
    if (r <= 0) then
      le_qd = .true.
    else
      le_qd = .false.
    end if
  end function le_qd

  elemental logical function le_qd_d(a, b)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(a%re, b, r)
    if (r <= 0) then
      le_qd_d = .true.
    else
      le_qd_d = .false.
    end if
  end function le_qd_d

  elemental logical function le_d_qd(a, b)
    real*8, intent(in) :: a
    type (qd_real), intent(in) :: b
    integer :: r
    call f_qd_comp_qd_d(b%re, a, r)
    if (r >= 0) then
      le_d_qd = .true.
    else
      le_d_qd = .false.
    end if
  end function le_d_qd

  elemental logical function le_qd_i(a, b)
    type (qd_real), intent(in) :: a
    integer, intent(in) :: b
    le_qd_i = le_qd_d(a, dble(b))
  end function le_qd_i

  elemental logical function le_i_qd(a, b)
    integer, intent(in) :: a
    type (qd_real), intent(in) :: b
    le_i_qd = le_d_qd(dble(a), b)
  end function le_i_qd

! Absolute Value
  elemental type (qd_real) function qdabs(a)
    type (qd_real), intent(in) :: a
    call f_qd_abs(a%re, qdabs%re)
  end function qdabs

  elemental type (qd_real) function qdcabs (qdc)
    type (qd_complex), intent(in) :: qdc
    type (qd_real) t1, t2, t3
    call f_qd_mul (qdc%cmp(1:4), qdc%cmp(1:4), t1%re)
    call f_qd_mul (qdc%cmp(5:8), qdc%cmp(5:8), t2%re)
    call f_qd_add (t1%re, t2%re, t3%re)
    call f_qd_sqrt (t3%re, qdcabs%re)
  end function qdcabs

! Sign transfer
  elemental type (qd_real) function qdsign(a, b) result (c)
    type (qd_real), intent(in) :: a, b
    if (b%re(1) .gt. 0.0d0) then
      if (a%re(1) .gt. 0.0d0) then
        c%re = a%re
      else
        c%re = -a%re
      end if
    else
      if (a%re(1) .gt. 0.0d0) then
        c%re = -a%re
      else
        c%re = a%re
      end if
    endif
  end function qdsign

  elemental type (qd_real) function qdsign_dd_d(a, b) result (c)
    type (qd_real), intent(in) :: a
    real*8, intent(in) :: b
    if (b .gt. 0.0d0) then
      if (a%re(1) .gt. 0.0d0) then
        c%re = a%re
      else
        c%re = -a%re
      end if
    else
      if (a%re(1) .gt. 0.0d0) then
        c%re = -a%re
      else
        c%re = a%re
      end if
    endif
  end function qdsign_dd_d

! Input
  subroutine qdinpq(u, q1, q2, q3, q4, q5, q6, q7, q8, q9)
    integer, intent(in) :: u
    type (qd_real), intent(in) :: q1
    type (qd_real), intent(in), optional :: q2, q3, q4, q5, q6, q7, q8, q9

    call qdinp (u, q1%re)

    if (present(q2)) then
      call qdinp (u, q2%re)
    end if

    if (present(q3)) then
      call qdinp (u, q3%re)
    end if

    if (present(q4)) then
      call qdinp (u, q4%re)
    end if

    if (present(q5)) then
      call qdinp (u, q5%re)
    end if

    if (present(q6)) then
      call qdinp (u, q6%re)
    end if

    if (present(q7)) then
      call qdinp (u, q7%re)
    end if

    if (present(q8)) then
      call qdinp (u, q8%re)
    end if

    if (present(q9)) then
      call qdinp (u, q9%re)
    end if

  end subroutine qdinpq

  subroutine qdcinpq(u, q1, q2, q3, q4, q5, q6, q7, q8, q9)
    integer, intent(in) :: u
    type (qd_complex), intent(in) :: q1
    type (qd_complex), intent(in), optional :: q2, q3, q4, q5, q6, q7, q8, q9

    call qdinp (u, q1%cmp(1:4))
    call qdinp (u, q1%cmp(5:8))

    if (present(q2)) then
      call qdinp (u, q2%cmp(1:4))
      call qdinp (u, q2%cmp(5:8))
    end if

    if (present(q3)) then
      call qdinp (u, q3%cmp(1:4))
      call qdinp (u, q3%cmp(5:8))
    end if

    if (present(q4)) then
      call qdinp (u, q4%cmp(1:4))
      call qdinp (u, q4%cmp(5:8))
    end if

    if (present(q5)) then
      call qdinp (u, q5%cmp(1:4))
      call qdinp (u, q5%cmp(5:8))
    end if

    if (present(q6)) then
      call qdinp (u, q6%cmp(1:4))
      call qdinp (u, q6%cmp(5:8))
    end if

    if (present(q7)) then
      call qdinp (u, q7%cmp(1:4))
      call qdinp (u, q7%cmp(5:8))
    end if

    if (present(q8)) then
      call qdinp (u, q8%cmp(1:4))
      call qdinp (u, q8%cmp(5:8))
    end if

    if (present(q9)) then
      call qdinp (u, q9%cmp(1:4))
      call qdinp (u, q9%cmp(5:8))
    end if

  end subroutine qdcinpq

! Output
  subroutine qdoutq(u, q1, q2, q3, q4, q5, q6, q7, q8, q9)
    integer, intent(in) :: u
    type (qd_real), intent(in) :: q1
    type (qd_real), intent(in), optional :: q2, q3, q4, q5, q6, q7, q8, q9

    call qdout (u, q1%re)

    if (present(q2)) then
      call qdout (u, q2%re)
    end if

    if (present(q3)) then
      call qdout (u, q3%re)
    end if

    if (present(q4)) then
      call qdout (u, q4%re)
    end if

    if (present(q5)) then
      call qdout (u, q5%re)
    end if

    if (present(q6)) then
      call qdout (u, q6%re)
    end if

    if (present(q7)) then
      call qdout (u, q7%re)
    end if

    if (present(q8)) then
      call qdout (u, q8%re)
    end if

    if (present(q9)) then
      call qdout (u, q9%re)
    end if

  end subroutine qdoutq

  subroutine qdcoutq(u, q1, q2, q3, q4, q5, q6, q7, q8, q9)
    integer, intent(in) :: u
    type (qd_complex), intent(in) :: q1
    type (qd_complex), intent(in), optional :: q2, q3, q4, q5, q6, q7, q8, q9

    call qdout (u, q1%cmp(1:4))
    call qdout (u, q1%cmp(5:8))

    if (present(q2)) then
      call qdout (u, q2%cmp(1:4))
      call qdout (u, q2%cmp(5:8))
    end if

    if (present(q3)) then
      call qdout (u, q3%cmp(1:4))
      call qdout (u, q3%cmp(5:8))
    end if

    if (present(q4)) then
      call qdout (u, q4%cmp(1:4))
      call qdout (u, q4%cmp(5:8))
    end if

    if (present(q5)) then
      call qdout (u, q5%cmp(1:4))
      call qdout (u, q5%cmp(5:8))
    end if

    if (present(q6)) then
      call qdout (u, q6%cmp(1:4))
      call qdout (u, q6%cmp(5:8))
    end if

    if (present(q7)) then
      call qdout (u, q7%cmp(1:4))
      call qdout (u, q7%cmp(5:8))
    end if

    if (present(q8)) then
      call qdout (u, q8%cmp(1:4))
      call qdout (u, q8%cmp(5:8))
    end if

    if (present(q9)) then
      call qdout (u, q9%cmp(1:4))
      call qdout (u, q9%cmp(5:8))
    end if

  end subroutine qdcoutq

  elemental real*8 function qd_to_d(a)
    type (qd_real), intent(in) :: a
    qd_to_d = a%re(1)
  end function qd_to_d

  elemental type (qd_real) function qdmin2(a, b)
    type (qd_real), intent(in) :: a, b
    integer :: r
    call f_qd_comp(a%re, b%re, r)
    if (r == 1) then
      qdmin2 = b
    else
      qdmin2 = a
    end if
  end function qdmin2

  elemental type (qd_real) function qdmin(a1, a2, a3, a4, a5, a6, a7, a8, a9)
    type (qd_real), intent(in) :: a1, a2, a3
    type (qd_real), intent(in), optional :: a4, a5, a6, a7, a8, a9
    qdmin = qdmin2(qdmin2(a1, a2), a3)
    if (present(a4)) qdmin = qdmin2(qdmin, a4)
    if (present(a5)) qdmin = qdmin2(qdmin, a5)
    if (present(a6)) qdmin = qdmin2(qdmin, a6)
    if (present(a7)) qdmin = qdmin2(qdmin, a7)
    if (present(a8)) qdmin = qdmin2(qdmin, a8)
    if (present(a9)) qdmin = qdmin2(qdmin, a9)
  end function qdmin

  elemental type (qd_real) function qdmax2(a, b)
    type (qd_real), intent(in) :: a, b
    integer :: r
    call f_qd_comp(a%re, b%re, r)
    if (r == -1) then
      qdmax2 = b
    else
      qdmax2 = a
    end if
  end function qdmax2

  elemental type (qd_real) function qdmax(a1, a2, a3, a4, a5, a6, a7, a8, a9)
    type (qd_real), intent(in) :: a1, a2, a3
    type (qd_real), intent(in), optional :: a4, a5, a6, a7, a8, a9
    qdmax = qdmax2(qdmax2(a1, a2), a3)
    if (present(a4)) qdmax = qdmax2(qdmax, a4)
    if (present(a5)) qdmax = qdmax2(qdmax, a5)
    if (present(a6)) qdmax = qdmax2(qdmax, a6)
    if (present(a7)) qdmax = qdmax2(qdmax, a7)
    if (present(a8)) qdmax = qdmax2(qdmax, a8)
    if (present(a9)) qdmax = qdmax2(qdmax, a9)
  end function qdmax

  elemental type (qd_real) function qdmod (a, b)
    type (qd_real), intent(in) :: a, b
    type (qd_real) :: s1, s2
    call f_qd_div (a%re, b%re, s1%re)
    call f_qd_aint(s1%re, s2%re)
    call f_qd_mul (s2%re, b%re, s1%re)
    call f_qd_sub (a%re, s1%re, qdmod%re)
  end function qdmod

  pure type (qd_real) function qd_pi()
    call f_qd_pi(qd_pi%re)
  end function qd_pi

subroutine qdinp (iu, a)

!   This routine reads the DD number A from logical unit IU.  The input
!   value must be placed on a single line of not more than 80 characters.

implicit none
integer iu, ln
parameter (ln = 80)
character*80 cs
real*8 a(4)

read (iu, '(a)', end = 100) cs
call qdinpc (cs, a)
goto 110

100 write (6, 1)
1  format ('*** qdinp: End-of-file encountered.')
! call qdabrt
stop

110 return

end subroutine

subroutine qdinpc (a, b)

!   Converts the CHARACTER*80 array A into the DD number B.

implicit none
integer i, id, ie, inz, ip, is, k, ln, lnn, beg
parameter (ln = 80)
real*8 bi
character*80 a
character*1 ai
character*10 dig
character*16 ca
parameter (dig = '0123456789')
real*8 b(4), f(4), s0(4), s1(4), s2(4)

id = 0
ip = -1
is = 0
inz = 0
s1(1) = 0.d0
s1(2) = 0.d0
s1(3) = 0.d0
s1(4) = 0.d0

beg = 0
do i = 1, 80
  if (a(i:i) /= ' ') then
    beg = i
    goto 80
  end if
end do

goto 210
80 continue

do i = beg, 80
  if (a(i:i) == ' ') then
    lnn = i-1
    goto 90
  end if
enddo

lnn = 80
90 continue

!   Scan for digits, looking for the period also.

do i = beg, lnn
  ai = a(i:i)
  if (ai .eq. '.') then
    if (ip >= 0) goto 210
    ip = id
    inz = 1
  elseif (ai .eq. '+') then
    if (id .ne. 0 .or. ip >= 0 .or. is .ne. 0) goto 210
    is = 1
  elseif (ai .eq. '-') then
    if (id .ne. 0 .or. ip >= 0 .or. is .ne. 0) goto 210
    is = -1
  elseif (ai .eq. 'e' .or. ai .eq. 'E' .or. ai .eq. 'd' .or. ai .eq. 'D') then
    goto 100
  elseif (index (dig, ai) .eq. 0) then
    goto 210
  else
!    read (ai, '(f1.0)') bi
    bi = index (dig, ai) - 1
    if (inz > 0 .or. bi > 0.d0) then
      inz = 1
      id = id + 1
! call qdmuld (s1, 10.d0, s0)
      call f_qd_mul_qd_d (s1, 10.d0, s0)
      f(1) = bi
      f(2) = 0.d0
      f(3) = 0.d0
      f(4) = 0.d0
!    call qddqc (bi, f)
!    call qdadd (s0, f, s1)
      call f_qd_add (s0, f, s1)
    endif
  endif
enddo

100   continue
if (is .eq. -1) then
  s1(1) = - s1(1)
  s1(2) = - s1(2)
  s1(3) = - s1(3)
  s1(4) = - s1(4)
endif
k = i
if (ip == -1) ip = id
ie = 0
is = 0
ca = ' '

do i = k + 1, lnn
  ai = a(i:i)
  if (ai .eq. ' ') then
  elseif (ai .eq. '+') then
    if (ie .ne. 0 .or. is .ne. 0) goto 210
    is = 1
  elseif (ai .eq. '-') then
    if (ie .ne. 0 .or. is .ne. 0) goto 210
    is = -1
  elseif (index (dig, ai) .eq. 0) then
    goto 210
  else
    ie = ie + 1
    if (ie .gt. 3) goto 210
    ca(ie:ie) = ai
  endif
enddo

! read (ca, '(i4)') ie
ie = dddigin (ca, 4)
if (is .eq. -1) ie = - ie
ie = ie + ip - id
s0(1) = 10.d0
s0(2) = 0.d0
s0(3) = 0.d0
s0(4) = 0.d0
! call qdnpwr (s0, ie, s2)
call f_qd_npwr (s0, ie, s2)
! call qdmul (s1, s2, b)
call f_qd_mul (s1, s2, b)
goto 220

210  write (6, 1) a
1 format ('*** qdinpc: Syntax error in literal string: ', a)
! call qdabrt
stop

220  return

end subroutine

subroutine qdout (iu, a)

!   This routine writes the QD number A on logical unit iu using a standard
!   E format, with lines 72 characters long.

implicit none
integer iu, ln
parameter (ln = 72)
character cs(72)
real*8 a(4)

call qdoutc (a, cs)
write (iu, '  (72a)') cs

return
end subroutine

subroutine qdoutc (a, b)
  implicit none
  real*8 a(4)
  character b(72)

  b(1) = ' '
  b(2) = ' '
  call f_qd_swrite(a, 62, b(3), 70)
end subroutine

elemental type (qd_real) function qdhuge(a)
  type (qd_real), intent(in) :: a
  qdhuge = qd_huge
end function qdhuge

elemental type (qd_real) function qd_safe_huge(a)
  type (qd_real), intent(in) :: a
  qd_safe_huge = qd_real((/ &
    1.7976931080746007281d+308,  9.97920154767359795037d+291, &
    5.53956966280111259858d+275, 3.07507889307840487279d+259/))
end function qd_safe_huge

elemental type (qd_real) function qdtiny(a)
  type (qd_real), intent(in) :: a
  qdtiny = qd_tiny
end function qdtiny

elemental type (qd_real) function qdepsilon(a)
  type (qd_real), intent(in) :: a
  qdepsilon = qd_eps
end function qdepsilon

elemental integer function qd_radix(a)
  type (qd_real), intent(in) :: a
  qd_radix = 2
end function qd_radix

elemental integer function qd_digits(a)
  type (qd_real), intent(in) :: a
  qd_digits = 209
end function qd_digits

elemental integer function qd_max_expn(a)
  type (qd_real), intent(in) :: a
  qd_max_expn = 1023
end function qd_max_expn

elemental integer function qd_min_expn(a)
  type (qd_real), intent(in) :: a
  qd_min_expn = -863
end function qd_min_expn

elemental integer function qd_precision(a)
  type (qd_real), intent(in) :: a
  qd_precision = 62
end function qd_precision

elemental integer function qd_range(a)
  type (qd_real), intent(in) :: a
  qd_range = 259
end function qd_range

elemental type (qd_real) function qd_nan(a)
  type (qd_real), intent(in) :: a
  call f_qd_nan(qd_nan%re)
end function qd_nan

elemental type (qd_real) function qd_aimag(a)
  type (qd_complex), intent(in) :: a
  qd_aimag%re = a%cmp(5:8)
end function

end module qdmodule


!////////////////////////////////////////////////////////////////////////////////////////
!  This program solves the 1-D heat equation, with zero-temperature
!  boundary conditions, in parallel.
PROGRAM MAIN
    USE ISO_FORTRAN_ENV, ONLY : output_unit,real64
    USE MPI
    IMPLICIT NONE
    REAL*8, ALLOCATABLE :: var(:), wrk(:)
    INTEGER ::  nx,nt
    REAL( real64) :: ct_one, ct_two, ct_three
    REAL( real64) :: elapsed_time, loop_time, init_time
    INTEGER :: i,j,k,n, ierr

    !/////////////////////////////////////////
    ! These two variables are initialized in INIT_COMM below.
    INTEGER :: my_rank, ncpu  ! Rank of this process; total number of MPI processes
    INTEGER :: my_imin, my_imax ! the range of x-indices that this rank owns
    INTEGER :: my_numx, modcheck

    CALL cpu_time( time= ct_one)
    !////////////////////////////////////////////////////
    ! Set some default values for the problem parameters.
    nx = 4096   ! x-dimension of our 3-D array
    nt = 4096   ! number of time steps to integrate over

    !////////////////////////////////////////////////////
    ! Check to see if the user has overridden
    ! these defaults at the command line.
    ! Command line calling syntax:
    ! ./ex5.out -nx 256 -nt 100
    CALL grab_args(nx,nt)

    CALL INIT_COMM()

    IF (my_rank .eq. 0) THEN
        WRITE(output_unit,'(a)') ' ///////////////////////////'
        WRITE(output_unit,'(a)') '  1-D Diffusion Equation   '
        WRITE(output_unit,'(a)') '  --Problem Parameters-- '
        WRITE(output_unit,'(a,i0)')'   nx =', nx
        WRITE(output_unit,'(a,i0)')'   nt =', nt
        WRITE(output_unit,'(a,i0)')' ncpu =', ncpu
        WRITE(output_unit,'(a)') ' ///////////////////////////'
        WRITE(output_unit,'(a)') ' '
    ENDIF
    !/////////////////////////////////////////////////////
    ! Initialize var and the wrk array

    !NOTE: my_imin and my_imax should be modified based on my_rank!
    my_numx = nx/ncpu       ! The number of x-values local to this rank
    modcheck = MOD(nx,ncpu)
    IF (my_rank .lt. modcheck) my_numx = my_numx+1

    ! There are different ways to do this.  Here is one way...
    my_imin = 1 + my_rank*my_numx
    IF (modcheck .le. my_rank) my_imin = my_imin+modcheck

    my_imax = my_imin+my_numx-1

    DO i = 0, ncpu-1
        IF (i .eq. my_rank) THEN
            WRITE(6,*)'my_rank, my_imin, my_imax: ', my_rank, my_imin, my_imax, modcheck
        ENDIF
        CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
    ENDDO

    ALLOCATE(var(my_imin-1:my_imax+1))
    ALLOCATE(wrk(my_imin:my_imax))

    var(:)   = 0.0d0
    wrk(:)   = 0.0d0
    CALL INIT_ARR(var, 1.0d0, 2) ! single sine wave in x-direction

    !/////////////////////////////////////////////////////
    ! Evolve the system
    CALL cpu_time( time= ct_two)
    DO n = 1, nt

        IF (my_rank .eq. 0) THEN
            IF (MOD(n,100) .eq. 0) Write(output_unit,'(a,i5)')' Timestep: ',n
        ENDIF

        !* EDIT THIS FUNCTION to communicate ghost zones
        !  to left and right neighbor ranks.
        IF (ncpu .gt. 1) CALL GHOST_ZONE_COMM()

        CALL Laplacian()

    ENDDO

    !//////////////////////////////////////////
    ! Write out some timing information.
    !Write(output_unit,*) var(:)  !, var(nx-8)

    CALL cpu_time( time= ct_three)
    elapsed_time = ct_three-ct_one
    init_time = ct_two-ct_one
    loop_time = ct_three-ct_two
    IF (my_rank .eq. 0) THEN
        WRITE(output_unit,'(a)')' Complete!'
        WRITE(output_unit,'( a, ES14.4, a)')'         Elapsed time: ', elapsed_time, ' seconds.'
        WRITE(output_unit, fmt= '( a, ES14.4, a)') '  Initialization time: ', init_time, ' seconds.'
        WRITE(output_unit, fmt= '( a, ES14.4, a)') '            Loop time: ', loop_time, ' seconds.'
    ENDIF
    CALL MPI_FINALIZE(ierr)
CONTAINS

    SUBROUTINE GHOST_ZONE_COMM()
        IMPLICIT NONE
        INTEGER :: ierr, dest, source
        INTEGER :: rbtag=1, lbtag=2 ! MPI tags for the right/left boundary communication
        REAL*8  :: lbval, rbval ! left and right boundary values
        REAL*8  :: rtval, ltval ! buffer variables for receiving boundary values
        rbval = var(my_imax)
        lbval = var(my_imin)

        !////////////////////////////////////////////////////////
        ! First, we communicate the right boundary values
        ! We receive from the left and send to the right
        IF (my_rank .gt. 0) THEN  ! rank zero does not receive
            ! Receive from the left
            source = my_rank-1
            Call MPI_Recv(rtval, 1, MPI_DOUBLE_PRECISION, source, &
                rbtag, MPI_COMM_WORLD, MPI_STATUS_IGNORE,ierr)
            var(my_imin-1) = rtval
        ENDIF
        IF (my_rank .lt. (ncpu-1)) THEN ! highest rank does not send
            ! Send to the right
            dest = my_rank+1
            Call MPI_Send(rbval, 1, MPI_DOUBLE_PRECISION, dest,rbtag, &
                & MPI_COMM_WORLD,ierr)
        ENDIF

        !////////////////////////////////////////////////////////
        ! Next, we communicate the left boundary values
        ! We receive from the right and send to the left
        IF (my_rank .lt. (ncpu-1)) THEN ! highest rank does not receive
            ! Receive from the right
            source = my_rank+1
            Call MPI_Recv(ltval, 1, MPI_DOUBLE_PRECISION, source, &
                lbtag, MPI_COMM_WORLD, MPI_STATUS_IGNORE,ierr)
            var(my_imax+1) = ltval
        ENDIF
        IF (my_rank .gt. 0) THEN ! rank zero does not send
            ! Send to the left
            dest = my_rank-1
            Call MPI_Send(lbval, 1, MPI_DOUBLE_PRECISION, dest,lbtag, &
                & MPI_COMM_WORLD,ierr)
        ENDIF

    END SUBROUTINE GHOST_ZONE_COMM

    SUBROUTINE Laplacian()
        IMPLICIT NONE
        INTEGER :: imin,imax

        imin = max(my_imin,2)    ! Avoid the boundaries, which are held fixed at zero
        imax = min(my_imax,nx-1)

        DO i = imin, imax
            wrk(i) =  var(i-1) + var(i+1)
        ENDDO

        DO i = imin, imax
            var(i) = wrk(i)*0.5d0
        ENDDO

    END SUBROUTINE Laplacian

    SUBROUTINE grab_args(numx, numiter)
            IMPLICIT NONE

            INTEGER, INTENT(OUT)   :: numx
            INTEGER, INTENT(OUT)   :: numiter

            INTEGER :: n                    ! Number of command-line arguments
            INTEGER :: i
            CHARACTER(len=1024) :: argname  ! Argument key
            CHARACTER(len=1024) :: val      ! Argument value

            n = command_argument_count()
            DO i=1,n,2
                    CALL get_command_argument(i, argname)
                    CALL get_command_argument(i+1, val)
                    SELECT CASE(argname)
                            CASE('-nx')
                                    read(val, '(I8)') numx
                            CASE('-nt')
                                    read(val, '(I8)') numiter
                            CASE DEFAULT
                                    WRITE(output_unit,'(a)') ' '
                                    WRITE(output_unit,'(a)') &
                                    ' Unrecognized option: '// trim(argname)
                    END SELECT
            ENDDO

    END SUBROUTINE grab_args

    SUBROUTINE INIT_COMM()
        IMPLICIT NONE
        INTEGER :: ierr
        !Initialize MPI  (ierr is an error flag with nonzero value if there's a problem)
        Call MPI_INIT( ierr )
        IF (ierr .ne. 0) STOP 'Error intializing MPI'

        !Find number of MPI processes executing this program (ncpu)
        Call MPI_Comm_size(MPI_COMM_WORLD, ncpu,ierr)
        IF (ierr .ne. 0) STOP 'Error finding ncpu'

        !Find this process's rank (my_rank; unique numeric identifier for each MPI process)
        Call MPI_Comm_rank(MPI_COMM_WORLD, my_rank,ierr)
        IF (ierr .ne. 0) STOP 'Error finding my_rank'
        WRITE(output_unit,'(a,i0,a,i0,a)')'Rank ',my_rank,' of ', ncpu, ' is active.'

        CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)  ! Pause until all processes have initiated MPI

    END SUBROUTINE INIT_COMM

    SUBROUTINE INIT_ARR(arr, amp, orderx)
        IMPLICIT NONE
        REAL*8, INTENT(INOUT) :: arr(my_imin-1:) ! If we don't declare the lower bound as my_imin-1
        REAL*8, INTENT(IN) :: amp                ! arr will be assumed to have indexing starting at 1
        INTEGER, INTENT(IN) :: orderx
        REAL*8 :: sinkx
        REAL*8 :: kx
        REAL*8, PARAMETER :: pi = 3.1415926535897932384626433832795028841972d0
        INTEGER :: i,ni
        ni = size(arr)

        kx = orderx*(pi/(ni-1))

        DO i = my_imin, my_imax
            sinkx = sin(kx*(i-1))
            arr(i) = arr(i)+amp*sinkx
        ENDDO
        If (my_imin .eq. 1) arr(1) = 0
        If (my_imax .eq. ni) arr(ni) = 0

    END SUBROUTINE INIT_ARR
END PROGRAM MAIN


program main ! How to write a double precision constant
use iso_fortran_env, only: real64, real128
implicit none
integer, parameter :: dp = real64, qp = real128
real(kind=dp) :: pi  ! double precision
real(kind=qp) :: piq ! quadruple precision
pi =        3.14159265358979323846 ! single precision constant
print*,pi ! 3.1415927410125732 -- precision lost
pi =        3.14159265358979323846d0 ! double precision constant
print*,pi ! 3.1415926535897931 -- precision retained
pi = 3.14159265358979323846_dp ! double precision constant
print*,pi ! 3.1415926535897931 -- precision retained
! quadruple precision constant
piq =        3.1415926535897932384626433832795028841971_qp
print*,piq ! 3.14159265358979323846264338327950280
end program main