      SUBROUTINE KICK2(I)
*
*
*       Velocity kick for Roche WD, NS & BH stars.
*       ------------------------------------------
*
      INCLUDE 'common6.h'
*
*
*       Randomize orbital phase and set disruption velocity in routine KICK.
      KSPAIR = KVEC(I)
      JPAIR = -KSPAIR
      KSTAR(I) = -KSTAR(I)
      CALL KSAPO(JPAIR)
*
*       Update the physical variables for termination.
      CALL RESOLV(KSPAIR,2)
*
*       Specify new single star location and terminate regularization.
      I = I + 2*(NPAIRS - KSPAIR)
      IPHASE = 2
      JCOMP = 0
      CALL KSTERM
*
*       Implement kick velocity for single component (mass loss in ROCHE).
      KW = KSTAR(I)
      CALL KICK(I,1,KW,0.0D0)
*
*       Copy block-step time to prevent SMALL STEP problem (19/3/12).
      TIME = TBLOCK
*
*       Re-initialize the KS regularization.
      ICOMP = IFIRST
      JCOMP = IFIRST + 1
      IPHASE = 1
      CALL KSREG
*
*       Check neighbour step reduction to compensate for velocity increase.
      NNB = ILIST(1)
      DO 10 L = 2,NNB+1
          J = ILIST(L)
          IF (T0(J) + 0.5*STEP(J).GT.TIME) THEN
              STEP(J) = 0.5*STEP(J)
              TNEW(J) = T0(J) + STEP(J)
          END IF
   10 CONTINUE
*
*       Specify negative index for new particle sequence.
      IPHASE = -1
*
      RETURN
*
      END


! This file is part of DASH.
! SPDX-Identifier: MIT
!
! Copyright 2003 Cambridge Crystallographic Data Centre
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!
!*****************************************************************************
!
      SUBROUTINE RR_VALCHI(CHIVAL)

      USE ATMVAR
      USE ZMVAR
      USE PO_VAR
      USE VARIABLES
      USE REFVAR
      USE RRVAR

      IMPLICIT NONE

      REAL,    INTENT (  OUT) :: CHIVAL

      INCLUDE 'params.inc'
      INCLUDE 'Lattice.inc'

      INTEGER         KKOR
      REAL                  WTIJ
      INTEGER                             IKKOR,         JKKOR
      COMMON /CHISTO/ KKOR, WTIJ(MCHIHS), IKKOR(MCHIHS), JKKOR(MCHIHS)

      INTEGER         NATOM
      REAL                   X
      INTEGER                          KX
      REAL                                        AMULT,      TF
      INTEGER         KTF
      REAL                      SITE
      INTEGER                              KSITE,      ISGEN
      REAL            SDX,        SDTF,      SDSITE
      INTEGER                                             KOM17
      COMMON /POSNS / NATOM, X(3,MaxAtm_3), KX(3,MaxAtm_3), AMULT(MaxAtm_3), TF(MaxAtm_3),  &
     &                KTF(MaxAtm_3), SITE(MaxAtm_3), KSITE(MaxAtm_3), ISGEN(3,MaxAtm_3),    &
     &                SDX(3,MaxAtm_3), SDTF(MaxAtm_3), SDSITE(MaxAtm_3), KOM17

      LOGICAL           LOG_HYDROGENS
      COMMON /HYDROGEN/ LOG_HYDROGENS

      INTEGER           TotNumOfAtoms, NumOfHydrogens, NumOfNonHydrogens, OrderedAtm
      COMMON  /ORDRATM/ TotNumOfAtoms, NumOfHydrogens, NumOfNonHydrogens, OrderedAtm(1:MaxAtm_3)

      INTEGER         NStPar
      COMMON /pextra/ NStPar

      REAL, EXTERNAL :: FFCALC_001, FFCALC_002, FFCALC_039, FFCALC_040, FFCALC_044, FFCALC_050, &
                        FFCALC_052, FFCALC_057, FFCALC_058, FFCALC_061, FFCALC_062, FFCALC_064, FFCALC_065
      REAL, EXTERNAL :: FFCALC_066, FFCALC_067, FFCALC_069, FFCALC_112, FFCALC_115, FFCALC_116, &
                        FFCALC_143, FFCALC_164, FFCALC_176, FFCALC_212, FFCALC_266, FFCALC_269
      REAL, EXTERNAL :: FFCALC_284, FFCALC_290, FFCALC_292, FFCALC_298, FFCALC_304, FFCALC_356, &
                        FFCALC_360, FFCALC_362, FFCALC_365, FFCALC_369, FFCALC_391, FFCALC_430
      REAL, EXTERNAL :: FFCALC_431, FFCALC_432, FFCALC_433, FFCALC_434, FFCALC_435, FFCALC_449, &
                        FFCALC_451, FFCALC_462, FFCALC_468, FFCALC_469, FFCALC_471, FFCALC_481, &
                        FFCALC_483, FFCALC_485, FFCALC_DEFAULT
      REAL    SUM1, SUM2, RESCL, DELI, DELJ, CHIADD
      INTEGER iR, iK, II, JJ

      CALL PRECFC
      IF (LOG_HYDROGENS) THEN
        NATOM = TotNumOfAtoms
      ELSE
        NATOM = NumOfNonHydrogens
      ENDIF
! Update the global isotropic temperature factors if needed.
      IF (RR_ioptITF .EQ. 1) THEN
        CALL CreateFobITF
      ENDIF
      SELECT CASE (NumberSGTable)
        CASE (1)             ! P1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_001(IR)
          ENDDO
        CASE (2)             ! P-1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_002(IR)
          ENDDO
        CASE (39)            ! P 1 21 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_039(IR)
          ENDDO
        CASE (40)             ! C 1 2 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_040(IR)
          ENDDO
        CASE (44)             ! P 1 c 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_044(IR)
          ENDDO
        CASE (50)            ! C 1 c 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_050(IR)
          ENDDO
        CASE (52)            ! I 1 a 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_052(IR)
          ENDDO
        CASE (57)            ! P 1 21/m 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_057(IR)
          ENDDO
        CASE (58)            ! C 1 2/m 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_058(IR)
          ENDDO
        CASE (61)            ! P 1 2/c 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_061(IR)
          ENDDO
        CASE (62)            ! P 1 2/n 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_062(IR)
          ENDDO
        CASE (64)            ! P 1 21/c 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_064(IR)
          ENDDO
        CASE (65)            ! P 1 21/n 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_065(IR)
          ENDDO
        CASE (66)            ! P 1 21/a 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_066(IR)
          ENDDO
        CASE (67)            ! C 1 2/c 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_067(IR)
          ENDDO
        CASE (69)            ! I 1 2/a 1
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_069(IR)
          ENDDO
        CASE (112)           ! P 21 21 2
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_112(IR)
          ENDDO
        CASE (115)           ! P 21 21 21
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_115(IR)
          ENDDO
        CASE (116)           ! C 2 2 21
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_116(IR)
          ENDDO
        CASE (143)           ! P c a 21
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_143(IR)
          ENDDO
        CASE (164)           ! P n a 21
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_164(IR)
          ENDDO
        CASE (176)            ! C m c 21
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_176(IR)
          ENDDO
        CASE (212)            ! F d d 2
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_212(IR)
          ENDDO
        CASE (266)            ! P c c n
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_266(IR)
          ENDDO
        CASE (269)            ! P b c m
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_269(IR)
          ENDDO
        CASE (284)           ! P b c n
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_284(IR)
          ENDDO
        CASE (290)           ! P b c a
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_290(IR)
          ENDDO
        CASE (292)           ! P n m a
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_292(IR)
          ENDDO
        CASE (298)           ! C m c m
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_298(IR)
          ENDDO
        CASE (304)           ! C m c a
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_304(IR)
          ENDDO
        CASE (356)           ! I -4
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_356(IR)
          ENDDO
        CASE (360)           ! P 4/n (origin choice 2)
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_360(IR)
          ENDDO
        CASE (362)           ! P 42/n (origin choice 2)
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_362(IR)
          ENDDO
        CASE (365)           ! I 41/a (origin choice 2)
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_365(IR)
          ENDDO
        CASE (369)           ! P 41 21 2
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_369(IR)
          ENDDO
        CASE (391)           ! P -4 21 c
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_391(IR)
          ENDDO
  ! Obscure from here on in !
        CASE (430)           ! P3
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_430(IR)
          ENDDO
        CASE (431)           ! P31
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_431(IR)
          ENDDO
        CASE (432)           ! P32
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_432(IR)
          ENDDO
        CASE (433)           ! R3 hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_433(IR)
          ENDDO
        CASE (434)           ! P-3
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_434(IR)
          ENDDO
        CASE (435)           ! R-3 hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_435(IR)
          ENDDO
        CASE (449)           ! P-31m hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_449(IR)
          ENDDO
        CASE (451)           ! P-3m1 hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_451(IR)
          ENDDO
        CASE (462)           ! P6 hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_462(IR)
          ENDDO
        CASE(468)           ! P-6 hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_468(IR)
          ENDDO
        CASE (469)           ! P6/m hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_469(IR)
          ENDDO
        CASE (471)           ! P622 hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_471(IR)
          ENDDO
        CASE (481)           ! P-6m2 hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_481(IR)
          ENDDO
        CASE (483)           ! P-62m hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_483(IR)
          ENDDO
        CASE (485)           ! P6/mmm hexagonal axes
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_485(IR)
          ENDDO
        CASE DEFAULT
          DO IR = 1, NumOfRef
            AICALC(IR) = FFCALC_DEFAULT(IR)
          ENDDO
      END SELECT
      NATOM = TotNumOfAtoms
! recalculate the preferred orientation correction factors.
! Fill Preferred Orientation part
      IF (PrefParExists .AND. RR_ioptPO .EQ. 1) CALL PO_PRECFC(RR_PO)
! AICALC(1:NumOfRef) now contains the structural part of the calculated intensities
! XICALC(1:NumOfRef) now contains the preferred orientation part of the calculated intensities
! If we are using preferred orientation: correct for it.
! If not: use the calculated intensities as is
      IF (PrefParExists) THEN
        DO iR = 1, NumOfRef
          BICALC(iR) = XICALC(iR) * AICALC(iR)
        ENDDO
      ELSE
        DO iR = 1, NumOfRef
          BICALC(iR) = AICALC(iR)
        ENDDO
      ENDIF
! BICALC(1:NumOfRef) now contains the calculated intensities corrected for preferred orientation
      SUM1 = 0.0
      SUM2 = 0.0
      DO IK = 1, KKOR
        II = IKKOR(IK)
        JJ = JKKOR(IK)
        SUM1 = SUM1 + BICALC(II)*WTIJ(IK)*AIOBS(JJ) + BICALC(JJ)*WTIJ(IK)*AIOBS(II)
        SUM2 = SUM2 + BICALC(II)*WTIJ(IK)*BICALC(JJ)
      ENDDO
      RESCL = 0.5*SUM1/SUM2
      CHIVAL = 0.0
      DO IK = 1, KKOR
        II = IKKOR(IK)
        JJ = JKKOR(IK)
        DELI = AIOBS(II) - RESCL*BICALC(II)
        DELJ = AIOBS(JJ) - RESCL*BICALC(JJ)
        CHIADD = DELI*WTIJ(IK)*DELJ
        CHIVAL = CHIVAL + CHIADD
      ENDDO
      CHIVAL = CHIVAL/FLOAT(NumOfRef-2)

      END SUBROUTINE RR_VALCHI
!
!*****************************************************************************
!
      REAL FUNCTION RR_FCN(N,P)

      USE RRVAR

      IMPLICIT NONE

      INTEGER N
      REAL P(*)

      INTEGER i
      REAL snglh

      DO I = 1, RR_MVAR
        RR_Params(i) = P(i)
      ENDDO
      CALL Params2RRVAR
      CALL RR_makefrac
      CALL RR_valchi(snglh)
      RR_FCN = snglh

      END FUNCTION RR_FCN
!
!*****************************************************************************
!
      SUBROUTINE RR_SIMOPT(X,DX,N,TheChiSqd)
!
! Purpose
!     A SIMPLEX-based routine which optimises the values of the N
! parameters pertaining to the components of the vector X
!
! Parameters
!   ARGUMENT  TYPE  I/O  DIMENSION  DESCRIPTION
!    N        I*4    I       -      No. of parameters to be optimised.
!    X        R*4    I       N      Initial guess.
!    X        R*4    O       N      The optimal answer.
!    DX       R*4    I       N      Initial step-lengths for X.
!
! Other Requirements
!     The user must provide a FUNCTION RR_FCN(N,X) which evalutes
! Chi-squared (un-normalised) given the vector X(N).
!
! History
!     D. S. Sivia    9 Feb 1995  Initial release.
!
      IMPLICIT NONE

  !    INCLUDE 'params.inc'

      REAL, INTENT (  OUT) :: TheChiSqd

      INTEGER     RR_MVAR
      PARAMETER ( RR_MVAR = 200 )
      INTEGER     MAXITR
      PARAMETER ( MAXITR = RR_MVAR )
      REAL X(*), DX(*)
      REAL V((RR_MVAR+1)*MAXITR), EX(3*RR_MVAR), C(RR_MVAR+1)
      INTEGER IR(RR_MVAR+1) ! Maximum index I could find: N+1. Maximum value for N should be RR_MVAR
                         ! IR seems to hold a sorted list of pointers into C
      INTEGER N, ITER
      REAL CHI, CHIMIN, ZERO
      REAL, EXTERNAL :: RR_FCN

      CALL VCOPY(X,V,N)
      CHIMIN = RR_FCN(N,V)
      ZERO = 0.0
      ITER = 0
    1 ITER = ITER + 1
      IF (ITER.GT.MAXITR) THEN
        CALL DebugErrorMessage('ITER.GT.MAXITR in RR_SIMOPT')
        GOTO 999
      ENDIF
      CALL RRSIMPLEX(V,N,DX,EX,C,IR,N*1000)
      CALL VCOPY(EX,V,N)
      CHI = RR_FCN(N,V)
! Convergence criterion
      IF (CHI .GT. CHIMIN) THEN
        CALL DebugErrorMessage('CHI .GT. CHIMIN in RR_SIMOPT')
        GOTO 1
      ENDIF
      IF ((1.0-CHI/CHIMIN) .GT. 0.000001) THEN
        CHIMIN = CHI
        GOTO 1
      ENDIF
  999 CALL VCOPY(V,X,N)
      TheChiSqd = CHI

      END SUBROUTINE RR_SIMOPT
!
!*****************************************************************************
!
      SUBROUTINE RRSIMPLEX(V,N,D,EX,C,IR,MX)

      REAL V(N,*), EX(N,*), C(*), D(*)
      INTEGER IR(*)
      LOGICAL SLOW
      DATA ALPHA, BETA, GAMA/1.0, 0.5, 2.0/

      SLOW = .FALSE.
      N3 = 3*N
      CAIM = 0.0
      C(1) = RR_FCN(N,V(1,1))
      CALL RRSIMP0(V,D,C,IR,N)
      CMIN = C(IR(N+1))
      ITER = 0
      NOLUCK = 0
      IRSTRT = 0
   10 ITER = ITER + 1
      NOLUCK = NOLUCK + 1
      IF (ITER.GE.MX .OR. NOLUCK.GT.100) THEN
        CALL SSORT(C,IR,N)
        CALL VCOPY(V(1,IR(N+1)),EX,N)
        IF (ITER.LT.250) THEN
          NOLUCK = 0
          DO ID = 1, N
!O            D(ID) = D(ID)/10.0
            D(ID) = D(ID)/2.0
          ENDDO
          CALL VCOPY(EX,V,N)
          C(1) = RR_FCN(N,V(1,1))
          CALL RRSIMP0(V,DSMALL,C,IR,N)
          CMIN = C(IR(N+1))
        ELSE
          RETURN
        ENDIF
      ENDIF
      CALL VRFILL(EX,0.,N3)
      CALL XCENT(V,EX(1,3),IR(1),N)
      CALL XZERO(V(1,IR(1)),EX,EX(1,3),N,ALPHA)
      C0 = RR_FCN(N,EX)
      CL = C(IR(N+1))
      CH = C(IR(1))
      CS = C(IR(2))
      IF (C0.LT.CL) THEN
        CALL RREXPAND(CL,EX,EX(1,2),EX(1,3),N,C0,GAMA)
      ELSEIF (C0.GT.CS) THEN
        CALL RRCONTRACT(CH,CS,C0,C00,EX,EX(1,2),EX(1,3),V(1,IR(1)),BETA,N)
        IF (C00.LT.CH .AND. C00.LT.C0) THEN
          CALL VCOPY(EX(1,2),EX,N)
          C0 = C00
        ELSE
          CALL RRCONT2(IR(N+1),V,C,N,IR)
          IRSTRT = IRSTRT + 1
          IF (C(IR(N+1)).LT.CMIN) CMIN = C(IR(N+1))
          IF (IRSTRT.GE.5) THEN
            NOLUCK = 0
            CALL SSORT(C,IR,N)
            CALL VCOPY(V(1,IR(N+1)),EX,N)
            RETURN
          ENDIF
        ENDIF
      ENDIF
      CALL VCOPY(EX,V(1,IR(1)),N)
      C(IR(1)) = C0
      CALL SSORT(C,IR,N)
      IF (C(IR(N+1)).LT.CMIN) THEN
        DROP = (CMIN-C(IR(N+1)))/CMIN
        IF (ABS(DROP).LT.1.0E-4) SLOW = .TRUE.
        NOLUCK = 0
        CMIN = C(IR(N+1))
      ENDIF
      IF (CMIN.GT.CAIM .AND. .NOT.SLOW) GOTO 10
      CALL VCOPY(V(1,IR(N+1)),EX,N)

      END SUBROUTINE RRSIMPLEX
!
!*****************************************************************************
!
      SUBROUTINE RRSIMP0(V,D,C,IR,N)

      REAL V(N,*), C(*), D(*)
      INTEGER IR(*)

      DO I = 2, N + 1
        CALL VCOPY(V,V(1,I),N)
        V(I-1,I) = V(I-1,I) + D(I-1)
        C(I) = RR_FCN(N,V(1,I))
      ENDDO
      CALL SSORT(C,IR,N)

      END SUBROUTINE RRSIMP0
!
!*****************************************************************************
!
      SUBROUTINE RREXPAND(CL,X0,X00,XC,N,C0,G)

      REAL X0(*), X00(*), XC(*)

      DO I = 1, N
        X00(I) = G*(X0(I)-XC(I)) + XC(I)
      ENDDO
      C00 = RR_FCN(N,X00)
      IF (C00.LT.CL) THEN
        CALL VCOPY(X00,X0,N)
        C0 = C00
      ENDIF

      END SUBROUTINE RREXPAND
!
!*****************************************************************************
!
      SUBROUTINE RRCONTRACT(CH,CS,C0,C00,X0,X00,XC,XH,B,N)

      REAL X0(*), X00(*), XC(*), XH(*)

      IF (C0.LT.CH) THEN
        DO I = 1, N
          X00(I) = B*(X0(I)-XC(I)) + XC(I)
        ENDDO
      ELSE
        DO I = 1, N
          X00(I) = B*(XH(I)-XC(I)) + XC(I)
        ENDDO
      ENDIF
      C00 = RR_FCN(N,X00)

      END SUBROUTINE RRCONTRACT
!
!*****************************************************************************
!
      SUBROUTINE RRCONT2(K,V,C,N,IR)

      REAL V(N,*), C(*)
      INTEGER IR(*)

      DO J = 1, N + 1
        IF (J.EQ.K) GOTO 20
        DO I = 1, N
          V(I,J) = 0.5*(V(I,J)+V(I,K))
          C(J) = RR_FCN(N,V(1,J))
        ENDDO
   20 ENDDO
      CALL SSORT(C,IR,N)

      END SUBROUTINE RRCONT2
!
!*****************************************************************************
!


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!      subroutine trproj: drives projection of hessian out of the
!        space of translational and rotational motions:
!        first get xyz c.m.; second get transl. and rot. projection matrix
!
!      part of QMDFF
!
subroutine trproj(natoms,nat3,xyz,hess,ldebug)

logical,intent(in)::ldebug
integer,intent(in)::natoms,nat3
real(kind=8),dimension(3,natoms)::xyz
real(kind=8),dimension(nat3*(nat3+1)/2)::hess
integer::i
real(kind=8)::xm,ym,zm
real(kind=8),dimension(3,natoms)::xyzucm

xyzucm(:,:) = xyz(:,:)

xm = 0.0d0
ym = 0.0d0
zm = 0.0d0
!
!     move cartesian coordinates
!
do i=1,natoms
   xm = xm + xyzucm(1,i)
   ym = ym + xyzucm(2,i)
   zm = zm + xyzucm(3,i)
end do

xm = xm/natoms
ym = ym/natoms
zm = zm/natoms

do i=1,natoms
   xyzucm(1,i) = xyzucm(1,i) - xm
   xyzucm(2,i) = xyzucm(2,i) - ym
   xyzucm(3,i) = xyzucm(3,i) - zm
end do
!
!     get translational and rotational projection matrix
!
call gtrprojm(natoms,nat3,xyzucm,hess,ldebug)

return
end subroutine trproj


C      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C      VOL. 17, NO. 2, PP. 218-232.  JUNE, 1991.
CC+------------------------------------------------------------------+CC
CC+                                                                  +CC
CC+                LAWRENCE LIVERMORE NATIONAL LABORATORY            +CC
CC+                                                                  +CC
CC+        MATHEMATICS AND STATISTICS DIVISION SOFTWARE LIBRARY      +CC
CC+                                                                  +CC
CC+------------------------------------------------------------------+CC
CC+                                                                  +CC
CC+  THE SLATEC MATHEMATICAL PROGRAM LIBRARY IS ISSUED BY            +CC
CC+  THE FOLLOWING:                                                  +CC
CC+                                                                  +CC
CC+       AIR FORCE WEAPONS LABORATORY, ALBUQUERQUE                  +CC
CC+       LAWRENCE LIVERMORE NATIONAL LABORATORY, LIVERMORE          +CC
CC+       LOS ALAMOS NATIONAL SCIENTIFIC LABORATORY, LOS ALAMOS      +CC
CC+       NATIONAL BUREAU OF STANDARDS, WASHINGTON                   +CC
CC+       OAK RIDGE NATIONAL LABORATORY, OAK RIDGE                   +CC
CC+       SANDIA NATIONAL LABORATORIES, ALBUQUERQUE                  +CC
CC+       SANDIA NATIONAL LABORATORIES, LIVERMORE                    +CC
CC+                                                                  +CC
CC+  PLEASE REFER QUESTIONS REGARDING THIS SOFTWARE TO THE           +CC
CC+  MSD CONSULTING OFFICE, EXTENSION 3-2976.                        +CC
CC+                                                                  +CC
CC+                                                                  +CC
CC+              * * * * * N O T I C E * * * * *                     +CC
CC+                                                                  +CC
CC+  THIS MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK SPONSORED      +CC
CC+  BY THE UNITED STATES GOVERNMENT.  NEITHER THE UNITED            +CC
CC+  STATES GOVERNMENT, NOR THE DEPARTMENT OF DEFENSE, NOR           +CC
CC+  ANY OF THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESSED           +CC
CC+  OR IMPLIED, OR ASSUMES ANY LEGAL LIABILITY OR                   +CC
CC+  RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR               +CC
CC+  USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT,              +CC
CC+  OR PROCESS DISCLOSED, OR REPRESENTS ITS USE WOULD NOT           +CC
CC+  INFRINGE UPON PRIVATELY OWNED RIGHTS.                           +CC
CC+                                                                  +CC
CC+------------------------------------------------------------------+CC
*DECK DQPSRT
      SUBROUTINE DQPSRT(LIMIT,LAST,MAXERR,ERMAX,ELIST,IORD,NRMAX)
C***BEGIN PROLOGUE  DQPSRT
C***REFER TO  DQAGE,DQAGIE,DQAGPE,DQAWSE
C***ROUTINES CALLED  (NONE)
C***REVISION DATE  810101   (YYMMDD)
C***KEYWORDS  SEQUENTIAL SORTING
C***AUTHOR  PIESSENS, ROBERT, APPLIED MATH. AND PROGR. DIV. -
C             K. U. LEUVEN
C           DE DONCKER, ELISE, APPLIED MATH. AND PROGR. DIV. -
C             K. U. LEUVEN
C***PURPOSE  THIS ROUTINE MAINTAINS THE DESCENDING ORDERING IN THE
C            LIST OF THE LOCAL ERROR ESTIMATED RESULTING FROM THE
C            INTERVAL SUBDIVISION PROCESS. AT EACH CALL TWO ERROR
C            ESTIMATES ARE INSERTED USING THE SEQUENTIAL SEARCH
C            METHOD, TOP-DOWN FOR THE LARGEST ERROR ESTIMATE AND
C            BOTTOM-UP FOR THE SMALLEST ERROR ESTIMATE.
C***DESCRIPTION
C
C           ORDERING ROUTINE
C           STANDARD FORTRAN SUBROUTINE
C           DOUBLE PRECISION VERSION
C
C           PARAMETERS (MEANING AT OUTPUT)
C              LIMIT  - INTEGER
C                       MAXIMUM NUMBER OF ERROR ESTIMATES THE LIST
C                       CAN CONTAIN
C
C              LAST   - INTEGER
C                       NUMBER OF ERROR ESTIMATES CURRENTLY IN THE LIST
C
C              MAXERR - INTEGER
C                       MAXERR POINTS TO THE NRMAX-TH LARGEST ERROR
C                       ESTIMATE CURRENTLY IN THE LIST
C
C              ERMAX  - DOUBLE PRECISION
C                       NRMAX-TH LARGEST ERROR ESTIMATE
C                       ERMAX = ELIST(MAXERR)
C
C              ELIST  - DOUBLE PRECISION
C                       VECTOR OF DIMENSION LAST CONTAINING
C                       THE ERROR ESTIMATES
C
C              IORD   - INTEGER
C                       VECTOR OF DIMENSION LAST, THE FIRST K ELEMENTS
C                       OF WHICH CONTAIN POINTERS TO THE ERROR
C                       ESTIMATES, SUCH THAT
C                       ELIST(IORD(1)),...,  ELIST(IORD(K))
C                       FORM A DECREASING SEQUENCE, WITH
C                       K = LAST IF LAST.LE.(LIMIT/2+2), AND
C                       K = LIMIT+1-LAST OTHERWISE
C
C              NRMAX  - INTEGER
C                       MAXERR = IORD(NRMAX)
C***END PROLOGUE  DQPSRT
C
      DOUBLE PRECISION ELIST,ERMAX,ERRMAX,ERRMIN
      INTEGER I,IBEG,IDO,IORD,ISUCC,J,JBND,JUPBN,K,LAST,LIMIT,MAXERR,
     1  NRMAX
      DIMENSION ELIST(LAST),IORD(LAST)
C
C           CHECK WHETHER THE LIST CONTAINS MORE THAN
C           TWO ERROR ESTIMATES.
C
C***FIRST EXECUTABLE STATEMENT  DQPSRT
      IF(LAST.GT.2) GO TO 10
      IORD(1) = 1
      IORD(2) = 2
      GO TO 90
C
C           THIS PART OF THE ROUTINE IS ONLY EXECUTED IF, DUE TO A
C           DIFFICULT INTEGRAND, SUBDIVISION INCREASED THE ERROR
C           ESTIMATE. IN THE NORMAL CASE THE INSERT PROCEDURE SHOULD
C           START AFTER THE NRMAX-TH LARGEST ERROR ESTIMATE.
C
   10 ERRMAX = ELIST(MAXERR)
      IF(NRMAX.EQ.1) GO TO 30
      IDO = NRMAX-1
      DO 20 I = 1,IDO
        ISUCC = IORD(NRMAX-1)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.LE.ELIST(ISUCC)) GO TO 30
        IORD(NRMAX) = ISUCC
        NRMAX = NRMAX-1
   20    CONTINUE
C
C           COMPUTE THE NUMBER OF ELEMENTS IN THE LIST TO BE MAINTAINED
C           IN DESCENDING ORDER. THIS NUMBER DEPENDS ON THE NUMBER OF
C           SUBDIVISIONS STILL ALLOWED.
C
   30 JUPBN = LAST
      IF(LAST.GT.(LIMIT/2+2)) JUPBN = LIMIT+3-LAST
      ERRMIN = ELIST(LAST)
C
C           INSERT ERRMAX BY TRAVERSING THE LIST TOP-DOWN,
C           STARTING COMPARISON FROM THE ELEMENT ELIST(IORD(NRMAX+1)).
C
      JBND = JUPBN-1
      IBEG = NRMAX+1
      IF(IBEG.GT.JBND) GO TO 50
      DO 40 I=IBEG,JBND
        ISUCC = IORD(I)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMAX.GE.ELIST(ISUCC)) GO TO 60
        IORD(I-1) = ISUCC
   40 CONTINUE
   50 IORD(JBND) = MAXERR
      IORD(JUPBN) = LAST
      GO TO 90
C
C           INSERT ERRMIN BY TRAVERSING THE LIST BOTTOM-UP.
C
   60 IORD(I-1) = MAXERR
      K = JBND
      DO 70 J=I,JBND
        ISUCC = IORD(K)
C ***JUMP OUT OF DO-LOOP
        IF(ERRMIN.LT.ELIST(ISUCC)) GO TO 80
        IORD(K+1) = ISUCC
        K = K-1
   70 CONTINUE
      IORD(I) = LAST
      GO TO 90
   80 IORD(K+1) = LAST
C
C           SET MAXERR AND ERMAX.
C
   90 MAXERR = IORD(NRMAX)
      ERMAX = ELIST(MAXERR)
      RETURN
      END
*DECK DQELG
      SUBROUTINE DQELG(N,EPSTAB,RESULT,ABSERR,RES3LA,NRES)
C***BEGIN PROLOGUE  DQELG
C***REFER TO  DQAGIE,DQAGOE,DQAGPE,DQAGSE
C***ROUTINES CALLED  D1MACH
C***REVISION DATE  830518   (YYMMDD)
C***KEYWORDS  CONVERGENCE ACCELERATION,EPSILON ALGORITHM,EXTRAPOLATION
C***AUTHOR  PIESSENS, ROBERT, APPLIED MATH. AND PROGR. DIV. -
C             K. U. LEUVEN
C           DE DONCKER, ELISE, APPLIED MATH. AND PROGR. DIV. -
C             K. U. LEUVEN
C***PURPOSE  THE ROUTINE DETERMINES THE LIMIT OF A GIVEN SEQUENCE OF
C            APPROXIMATIONS, BY MEANS OF THE EPSILON ALGORITHM OF
C            P.WYNN. AN ESTIMATE OF THE ABSOLUTE ERROR IS ALSO GIVEN.
C            THE CONDENSED EPSILON TABLE IS COMPUTED. ONLY THOSE
C            ELEMENTS NEEDED FOR THE COMPUTATION OF THE NEXT DIAGONAL
C            ARE PRESERVED.
C***DESCRIPTION
C
C           EPSILON ALGORITHM
C           STANDARD FORTRAN SUBROUTINE
C           DOUBLE PRECISION VERSION
C
C           PARAMETERS
C              N      - INTEGER
C                       EPSTAB(N) CONTAINS THE NEW ELEMENT IN THE
C                       FIRST COLUMN OF THE EPSILON TABLE.
C
C              EPSTAB - DOUBLE PRECISION
C                       VECTOR OF DIMENSION 52 CONTAINING THE ELEMENTS
C                       OF THE TWO LOWER DIAGONALS OF THE TRIANGULAR
C                       EPSILON TABLE. THE ELEMENTS ARE NUMBERED
C                       STARTING AT THE RIGHT-HAND CORNER OF THE
C                       TRIANGLE.
C
C              RESULT - DOUBLE PRECISION
C                       RESULTING APPROXIMATION TO THE INTEGRAL
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE ABSOLUTE ERROR COMPUTED FROM
C                       RESULT AND THE 3 PREVIOUS RESULTS
C
C              RES3LA - DOUBLE PRECISION
C                       VECTOR OF DIMENSION 3 CONTAINING THE LAST 3
C                       RESULTS
C
C              NRES   - INTEGER
C                       NUMBER OF CALLS TO THE ROUTINE
C                       (SHOULD BE ZERO AT FIRST CALL)
C***END PROLOGUE  DQELG
C
      DOUBLE PRECISION ABSERR,DABS,DELTA1,DELTA2,DELTA3,DMAX1,D1MACH,
     1  EPMACH,EPSINF,EPSTAB,ERROR,ERR1,ERR2,ERR3,E0,E1,E1ABS,E2,E3,
     2  OFLOW,RES,RESULT,RES3LA,SS,TOL1,TOL2,TOL3
      INTEGER I,IB,IB2,IE,INDX,K1,K2,K3,LIMEXP,N,NEWELM,NRES,NUM
      DIMENSION EPSTAB(52),RES3LA(3)
C
C           LIST OF MAJOR VARIABLES
C           -----------------------
C
C           E0     - THE 4 ELEMENTS ON WHICH THE COMPUTATION OF A NEW
C           E1       ELEMENT IN THE EPSILON TABLE IS BASED
C           E2
C           E3                 E0
C                        E3    E1    NEW
C                              E2
C           NEWELM - NUMBER OF ELEMENTS TO BE COMPUTED IN THE NEW
C                    DIAGONAL
C           ERROR  - ERROR = ABS(E1-E0)+ABS(E2-E1)+ABS(NEW-E2)
C           RESULT - THE ELEMENT IN THE NEW DIAGONAL WITH LEAST VALUE
C                    OF ERROR
C
C           MACHINE DEPENDENT CONSTANTS
C           ---------------------------
C
C           EPMACH IS THE LARGEST RELATIVE SPACING.
C           OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C           LIMEXP IS THE MAXIMUM NUMBER OF ELEMENTS THE EPSILON
C           TABLE CAN CONTAIN. IF THIS NUMBER IS REACHED, THE UPPER
C           DIAGONAL OF THE EPSILON TABLE IS DELETED.
C
C***FIRST EXECUTABLE STATEMENT  DQELG
      EPMACH = D1MACH(4)
      OFLOW = D1MACH(2)
      NRES = NRES+1
      ABSERR = OFLOW
      RESULT = EPSTAB(N)
      IF(N.LT.3) GO TO 100
      LIMEXP = 50
      EPSTAB(N+2) = EPSTAB(N)
      NEWELM = (N-1)/2
      EPSTAB(N) = OFLOW
      NUM = N
      K1 = N
      DO 40 I = 1,NEWELM
        K2 = K1-1
        K3 = K1-2
        RES = EPSTAB(K1+2)
        E0 = EPSTAB(K3)
        E1 = EPSTAB(K2)
        E2 = RES
        E1ABS = DABS(E1)
        DELTA2 = E2-E1
        ERR2 = DABS(DELTA2)
        TOL2 = DMAX1(DABS(E2),E1ABS)*EPMACH
        DELTA3 = E1-E0
        ERR3 = DABS(DELTA3)
        TOL3 = DMAX1(E1ABS,DABS(E0))*EPMACH
        IF(ERR2.GT.TOL2.OR.ERR3.GT.TOL3) GO TO 10
C
C           IF E0, E1 AND E2 ARE EQUAL TO WITHIN MACHINE
C           ACCURACY, CONVERGENCE IS ASSUMED.
C           RESULT = E2
C           ABSERR = ABS(E1-E0)+ABS(E2-E1)
C
        RESULT = RES
        ABSERR = ERR2+ERR3
C ***JUMP OUT OF DO-LOOP
        GO TO 100
   10   E3 = EPSTAB(K1)
        EPSTAB(K1) = E1
        DELTA1 = E1-E3
        ERR1 = DABS(DELTA1)
        TOL1 = DMAX1(E1ABS,DABS(E3))*EPMACH
C
C           IF TWO ELEMENTS ARE VERY CLOSE TO EACH OTHER, OMIT
C           A PART OF THE TABLE BY ADJUSTING THE VALUE OF N
C
        IF(ERR1.LE.TOL1.OR.ERR2.LE.TOL2.OR.ERR3.LE.TOL3) GO TO 20
        SS = 0.1D+01/DELTA1+0.1D+01/DELTA2-0.1D+01/DELTA3
        EPSINF = DABS(SS*E1)
C
C           TEST TO DETECT IRREGULAR BEHAVIOUR IN THE TABLE, AND
C           EVENTUALLY OMIT A PART OF THE TABLE ADJUSTING THE VALUE
C           OF N.
C
        IF(EPSINF.GT.0.1D-03) GO TO 30
   20   N = I+I-1
C ***JUMP OUT OF DO-LOOP
        GO TO 50
C
C           COMPUTE A NEW ELEMENT AND EVENTUALLY ADJUST
C           THE VALUE OF RESULT.
C
   30   RES = E1+0.1D+01/SS
        EPSTAB(K1) = RES
        K1 = K1-2
        ERROR = ERR2+DABS(RES-E2)+ERR3
        IF(ERROR.GT.ABSERR) GO TO 40
        ABSERR = ERROR
        RESULT = RES
   40 CONTINUE
C
C           SHIFT THE TABLE.
C
   50 IF(N.EQ.LIMEXP) N = 2*(LIMEXP/2)-1
      IB = 1
      IF((NUM/2)*2.EQ.NUM) IB = 2
      IE = NEWELM+1
      DO 60 I=1,IE
        IB2 = IB+2
        EPSTAB(IB) = EPSTAB(IB2)
        IB = IB2
   60 CONTINUE
      IF(NUM.EQ.N) GO TO 80
      INDX = NUM-N+1
      DO 70 I = 1,N
        EPSTAB(I)= EPSTAB(INDX)
        INDX = INDX+1
   70 CONTINUE
   80 IF(NRES.GE.4) GO TO 90
      RES3LA(NRES) = RESULT
      ABSERR = OFLOW
      GO TO 100
C
C           COMPUTE ERROR ESTIMATE
C
   90 ABSERR = DABS(RESULT-RES3LA(3))+DABS(RESULT-RES3LA(2))
     1  +DABS(RESULT-RES3LA(1))
      RES3LA(1) = RES3LA(2)
      RES3LA(2) = RES3LA(3)
      RES3LA(3) = RESULT
  100 ABSERR = DMAX1(ABSERR,0.5D+01*EPMACH*DABS(RESULT))
      RETURN
      END
*DECK DQXGS
      SUBROUTINE DQXGS(F,A,B,EPSABS,EPSREL,RESULT,ABSERR,IER,
     1   LIMIT,LENIW,LENW,LAST,IWORK,WORK)
C
C            THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL  I = INTEGRAL OF F OVER (A,B),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                     IER = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF LIMIT
C                             (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT. HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE. IT IS PRESUMED THAT
C                             THE REQUESTED TOLERANCE CANNOT BE
C                             ACHIEVED, AND THAT THE RETURNED RESULT IS
C                             THE BEST WHICH CAN BE OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID, BECAUSE
C                             (EPSABS.LE.0 AND
C                              EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28)
C                             OR LIMIT.LT.1 OR LENW.LT.LIMIT*46 OR
C                                LENIW .LT. LIMIT*3
C                             RESULT, ABSERR, LAST ARE SET TO
C                             ZERO.EXCEPT WHEN LIMIT OR LENW OR LENIW
C                             IS INVALID, IWORK(1), WORK(LIMIT*2+1) AND
C                             WORK(LIMIT*3+1) ARE SET TO ZERO, WORK(1)
C                             IS SET TO A AND WORK(LIMIT+1) TO B.
C
C         DIMENSIONING PARAMETERS
C            LIMIT - INTEGER
C                    LIMIT DETERMINES THE MAXIMUM NUMBER OF SUBINTERVALS
C                    IN THE PARTITION OF THE GIVEN INTEGRATION INTERVAL
C                    (A,B), LIMIT.GE.1.
C                    IF LIMIT.LT.1, THE ROUTINE WILL END WITH IER = 6.
C
C            LENW  - INTEGER
C                    DIMENSIONING PARAMETER FOR WORK
C                    LENW MUST BE AT LEAST LIMIT*46
C                    IF LENW.LT.LIMIT*46, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LENIW - INTEGER
C                    DIMENSIONING PARAMETER FOR IWORK
C                    LENIW MUST BE AT LEAST LIMIT*3
C                    IF LENW.LT.LIMIT*3, THE ROUTINE WILL END
C                    WITH IER = 6.
C
C            LAST  - INTEGER
C                    ON RETURN, LAST EQUALS THE NUMBER OF SUBINTERVALS
C                    PRODUCED IN THE SUBDIVISION PROCESS, DETERMINES THE
C                    NUMBER OF SIGNIFICANT ELEMENTS ACTUALLY IN THE WORK
C                    ARRAYS.
C
C         WORK ARRAYS
C            IWORK - INTEGER
C                    VECTOR OF DIMENSION AT LEAST 3*LIMIT, THE FIRST K
C                    ELEMENTS OF WHICH CONTAIN POINTERS
C                    TO THE ERROR ESTIMATES OVER THE SUBINTERVALS
C                    SUCH THAT WORK(LIMIT*3+IWORK(1)),... ,
C                    WORK(LIMIT*3+IWORK(K)) FORM A DECREASING
C                    SEQUENCE, WITH K = LAST IF LAST.LE.(LIMIT/2+2),
C                    AND K = LIMIT+1-LAST OTHERWISE
C
C            WORK  - DOUBLE PRECISION
C                    VECTOR OF DIMENSION AT LEAST LENW
C                    ON RETURN
C                    WORK(1), ..., WORK(LAST) CONTAIN THE LEFT
C                     END-POINTS OF THE SUBINTERVALS IN THE
C                     PARTITION OF (A,B),
C                    WORK(LIMIT+1), ..., WORK(LIMIT+LAST) CONTAIN
C                     THE RIGHT END-POINTS,
C                    WORK(LIMIT*2+1), ..., WORK(LIMIT*2+LAST) CONTAIN
C                     THE INTEGRAL APPROXIMATIONS OVER THE SUBINTERVALS,
C                    WORK(LIMIT*3+1), ..., WORK(LIMIT*3+LAST)
C                     CONTAIN THE ERROR ESTIMATES.
C                    WORK(LIMIT*4+1), ... IS THE AREA RESERVED TO STORE
C                     FUNCTIONAL VALUES.
C***ROUTINES CALLED  DQXGSE,XERROR
C
C THE CALL TO XERROR HAS BEEN COMMENTED TO GET A STAND ALONE ROUTINE
C IT CAN BE ADAPTED TO FIT THE LOCAL ERROR HANDLING PROCEDURES
C
      DOUBLE PRECISION A,ABSERR,B,EPSABS,EPSREL,F,RESULT,WORK
      INTEGER IER,IWORK,LAST,LENIW,LENW,LIMIT,LVL,L1,L2,L3,L4,L5
C
      DIMENSION IWORK(LENIW),WORK(LENW)
C
      EXTERNAL F
C
C         CHECK VALIDITY OF LIMIT,LENIW AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  DQXGS
      IER = 6
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      IF(LIMIT.LT.1.OR.LENIW.LT.LIMIT*3.OR.LENW.LT.LIMIT*46) GO TO 10
C
C         PREPARE CALL FOR DQXGSE.
C
      L1 = LIMIT+1
      L2 = LIMIT+L1
      L3 = LIMIT+L2
      L4 = LIMIT+L3
      L5 = 21*LIMIT+L3
C
      CALL DQXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *  IER,WORK(1),WORK(L1),WORK(L2),WORK(L3),IWORK,LAST,
     *  WORK(L4),WORK(L5),IWORK(L1),IWORK(L2))
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
C
C THE CALL TO XERROR HAS BEEN COMMENTED TO GET A STAND ALONE ROUTINE
C IT CAN BE ADAPTED TO FIT THE LOCAL ERROR HANDLING PROCEDURES
C
C     IF(IER.NE.0)CALL XERROR('ABNORMAL RETURN FROM DQXGS  ',28,IER,LVL)
      RETURN
      END
*DECK DQXGSE
      SUBROUTINE DQXGSE(F,A,B,EPSABS,EPSREL,LIMIT,RESULT,ABSERR,
     *   IER,ALIST,BLIST,RLIST,ELIST,IORD,LAST,VALP,VALN,LP,LN)
C
C            THE ROUTINE CALCULATES AN APPROXIMATION RESULT TO A GIVEN
C            DEFINITE INTEGRAL I = INTEGRAL OF F OVER (A,B),
C            HOPEFULLY SATISFYING FOLLOWING CLAIM FOR ACCURACY
C            ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)).
C
C        PARAMETERS
C         ON ENTRY
C            F      - DOUBLE PRECISION
C                     FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                     FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                     DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C            A      - DOUBLE PRECISION
C                     LOWER LIMIT OF INTEGRATION
C
C            B      - DOUBLE PRECISION
C                     UPPER LIMIT OF INTEGRATION
C
C            EPSABS - DOUBLE PRECISION
C                     ABSOLUTE ACCURACY REQUESTED
C            EPSREL - DOUBLE PRECISION
C                     RELATIVE ACCURACY REQUESTED
C                     IF  EPSABS.LE.0
C                     AND EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28),
C                     THE ROUTINE WILL END WITH IER = 6.
C
C            LIMIT  - INTEGER
C                     GIVES AN UPPERBOUND ON THE NUMBER OF SUBINTERVALS
C                     IN THE PARTITION OF (A,B)
C
C         ON RETURN
C            RESULT - DOUBLE PRECISION
C                     APPROXIMATION TO THE INTEGRAL
C
C            ABSERR - DOUBLE PRECISION
C                     ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                     WHICH SHOULD EQUAL OR EXCEED ABS(I-RESULT)
C
C            IER    - INTEGER
C                     IER = 0 NORMAL AND RELIABLE TERMINATION OF THE
C                             ROUTINE. IT IS ASSUMED THAT THE REQUESTED
C                             ACCURACY HAS BEEN ACHIEVED.
C                     IER.GT.0 ABNORMAL TERMINATION OF THE ROUTINE
C                             THE ESTIMATES FOR INTEGRAL AND ERROR ARE
C                             LESS RELIABLE. IT IS ASSUMED THAT THE
C                             REQUESTED ACCURACY HAS NOT BEEN ACHIEVED.
C            ERROR MESSAGES
C                         = 1 MAXIMUM NUMBER OF SUBDIVISIONS ALLOWED
C                             HAS BEEN ACHIEVED. ONE CAN ALLOW MORE SUB-
C                             DIVISIONS BY INCREASING THE VALUE OF LIMIT
C                             (AND TAKING THE ACCORDING DIMENSION
C                             ADJUSTMENTS INTO ACCOUNT). HOWEVER, IF
C                             THIS YIELDS NO IMPROVEMENT IT IS ADVISED
C                             TO ANALYZE THE INTEGRAND IN ORDER TO
C                             DETERMINE THE INTEGRATION DIFFICULTIES. IF
C                             THE POSITION OF A LOCAL DIFFICULTY CAN BE
C                             DETERMINED (E.G. SINGULARITY,
C                             DISCONTINUITY WITHIN THE INTERVAL) ONE
C                             WILL PROBABLY GAIN FROM SPLITTING UP THE
C                             INTERVAL AT THIS POINT AND CALLING THE
C                             INTEGRATOR ON THE SUBRANGES. IF POSSIBLE,
C                             AN APPROPRIATE SPECIAL-PURPOSE INTEGRATOR
C                             SHOULD BE USED, WHICH IS DESIGNED FOR
C                             HANDLING THE TYPE OF DIFFICULTY INVOLVED.
C                         = 2 THE OCCURRENCE OF ROUNDOFF ERROR IS DETEC-
C                             TED, WHICH PREVENTS THE REQUESTED
C                             TOLERANCE FROM BEING ACHIEVED.
C                             THE ERROR MAY BE UNDER-ESTIMATED.
C                         = 3 EXTREMELY BAD INTEGRAND BEHAVIOUR
C                             OCCURS AT SOME POINTS OF THE INTEGRATION
C                             INTERVAL.
C                         = 4 THE ALGORITHM DOES NOT CONVERGE.
C                             ROUNDOFF ERROR IS DETECTED IN THE
C                             EXTRAPOLATION TABLE.
C                             IT IS PRESUMED THAT THE REQUESTED
C                             TOLERANCE CANNOT BE ACHIEVED, AND THAT THE
C                             RETURNED RESULT IS THE BEST WHICH CAN BE
C                             OBTAINED.
C                         = 5 THE INTEGRAL IS PROBABLY DIVERGENT, OR
C                             SLOWLY CONVERGENT. IT MUST BE NOTED THAT
C                             DIVERGENCE CAN OCCUR WITH ANY OTHER VALUE
C                             OF IER.
C                         = 6 THE INPUT IS INVALID, BECAUSE
C                             EPSABS.LE.0 AND
C                             EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28).
C                             RESULT, ABSERR, LAST, RLIST(1),
C                             IORD(1) AND ELIST(1) ARE SET TO ZERO.
C                             ALIST(1) AND BLIST(1) ARE SET TO A AND B
C                             RESPECTIVELY.
C
C            ALIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE LEFT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE
C                     GIVEN INTEGRATION RANGE (A,B)
C
C            BLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE RIGHT END POINTS
C                     OF THE SUBINTERVALS IN THE PARTITION OF THE GIVEN
C                     INTEGRATION RANGE (A,B)
C
C            RLIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE INTEGRAL
C                     APPROXIMATIONS ON THE SUBINTERVALS
C
C            ELIST  - DOUBLE PRECISION
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST
C                      LAST  ELEMENTS OF WHICH ARE THE MODULI OF THE
C                     ABSOLUTE ERROR ESTIMATES ON THE SUBINTERVALS
C
C            IORD   - INTEGER
C                     VECTOR OF DIMENSION AT LEAST LIMIT, THE FIRST K
C                     ELEMENTS OF WHICH ARE POINTERS TO THE
C                     ERROR ESTIMATES OVER THE SUBINTERVALS,
C                     SUCH THAT ELIST(IORD(1)), ..., ELIST(IORD(K))
C                     FORM A DECREASING SEQUENCE, WITH K = LAST
C                     IF LAST.LE.(LIMIT/2+2), AND K = LIMIT+1-LAST
C                     OTHERWISE
C
C            LAST   - INTEGER
C                     NUMBER OF SUBINTERVALS ACTUALLY PRODUCED IN THE
C                     SUBDIVISION PROCESS
C
C            VALP   - DOUBLE PRECISION
C            VALN     ARRAYS OF DIMENSION AT LEAST (21,LIMIT) USED TO
C                     SAVE THE FUNCTIONAL VALUES
C
C            LP     - INTEGER
C            LN       VECTORS OF DIMENSION AT LEAST LIMIT, USED TO
C                     STORE THE ACTUAL NUMBER OF FUNCTIONAL VALUES
C                     SAVED IN THE CORRESPONDING COLUMN
C                     OF VALP,VALN
C
C***ROUTINES CALLED  F,D1MACH,DQELG,DQXLQM,DQPSRT,DQXRRD,DQXCPY
C
      DOUBLE PRECISION A,ABSEPS,ABSERR,ALIST,AREA,AREA1,AREA12,AREA2,A1,
     *  A2,B,BLIST,B1,B2,CORREC,DABS,DEFABS,DEFAB1,DEFAB2,D1MACH,DMAX1,
     *  DRES,ELIST,EPMACH,EPSABS,EPSREL,ERLARG,ERLAST,ERRBND,ERRMAX,
     *  ERROR1,ERROR2,ERRO12,ERRSUM,ERTEST,F,OFLOW,RESABS,RESEPS,RESULT,
     *  RES3LA,RLIST,RLIST2,SMALL,UFLOW,
     *  VALP,VALN,VP1,VP2,VN1,VN2
      INTEGER ID,IER,IERRO,IORD,IROFF1,IROFF2,IROFF3,JUPBND,K,KSGN,
     *  KTMIN,LAST,LIMIT,MAXERR,NRES,NRMAX,NUMRL2,
     *  LP,LN,LP1,LP2,LN1,LN2
      LOGICAL EXTRAP,NOEXT
      DIMENSION ALIST(LIMIT),BLIST(LIMIT),ELIST(LIMIT),IORD(LIMIT),
     * RES3LA(3),RLIST(LIMIT),RLIST2(52),
     * VALP(21,LIMIT),VALN(21,LIMIT),LP(LIMIT),LN(LIMIT),
     * VP1(21),VP2(21),VN1(21),VN2(21)
      EXTERNAL F
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C          EPMACH IS THE LARGEST RELATIVE SPACING.
C          UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C          OFLOW IS THE LARGEST POSITIVE MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT  DQXGSE
      EPMACH = D1MACH(4)
C
C            TEST ON VALIDITY OF PARAMETERS
C            ------------------------------
      IER = 0
      LAST = 0
      RESULT = 0.0D+00
      ABSERR = 0.0D+00
      ALIST(1) = A
      BLIST(1) = B
      RLIST(1) = 0.0D+00
      ELIST(1) = 0.0D+00
      IF(EPSABS.LE.0.0D+00.AND.EPSREL.LT.DMAX1(0.5D+02*EPMACH,0.5D-28))
     *   IER = 6
      IF(IER.EQ.6) GO TO 999
C
C           FIRST APPROXIMATION TO THE INTEGRAL
C           -----------------------------------
C
      UFLOW = D1MACH(1)
      OFLOW = D1MACH(2)
      IERRO = 0
      LP(1)=1
      LN(1)=1
      VALP(1,1)=F((A+B)*0.5D0)
      VALN(1,1)=VALP(1,1)
      CALL DQXLQM(F,A,B,RESULT,ABSERR,DEFABS,RESABS,
     *           VALP(1,1),VALN(1,1),LP(1),LN(1), 2  )
C
C           TEST ON ACCURACY.
C
      DRES = DABS(RESULT)
      ERRBND = DMAX1(EPSABS,EPSREL*DRES)
      LAST = 1
      RLIST(1) = RESULT
      ELIST(1) = ABSERR
      IORD(1) = 1
      IF(ABSERR.LE.1.0D+02*EPMACH*DEFABS.AND.ABSERR.GT.ERRBND) IER = 2
      IF(LIMIT.EQ.1) IER = 1
      IF(IER.NE.0.OR.(ABSERR.LE.ERRBND.AND.ABSERR.NE.RESABS).OR.
     *  ABSERR.EQ.0.0D+00) GO TO 999
C
C           INITIALIZATION
C           --------------
C
      RLIST2(1) = RESULT
      ERRMAX = ABSERR
      MAXERR = 1
      AREA = RESULT
      ERRSUM = ABSERR
      ABSERR = OFLOW
      NRMAX = 1
      NRES = 0
      NUMRL2 = 2
      KTMIN = 0
      EXTRAP = .FALSE.
      NOEXT = .FALSE.
      IROFF1 = 0
      IROFF2 = 0
      IROFF3 = 0
      KSGN = -1
      IF(DRES.GE.(0.1D+01-0.5D+02*EPMACH)*DEFABS) KSGN = 1
C
C           MAIN DO-LOOP
C           ------------
C
      DO 90 LAST = 2,LIMIT
C
C           BISECT THE SUBINTERVAL WITH THE NRMAX-TH LARGEST ERROR
C           ESTIMATE.
C
        A1 = ALIST(MAXERR)
        B1 = 0.5D+00*(ALIST(MAXERR)+BLIST(MAXERR))
        A2 = B1
        B2 = BLIST(MAXERR)
        ERLAST = ERRMAX
        CALL DQXRRD(F,VALN(1,MAXERR),LN(MAXERR),B1,A1,VN1,VP1,LN1,LP1)
        CALL DQXLQM(F,A1,B1,AREA1,ERROR1,RESABS,DEFAB1,VP1,VN1,LP1,LN1,
     *              2)
        CALL DQXRRD(F,VALP(1,MAXERR),LP(MAXERR),A2,B2,VP2,VN2,LP2,LN2)
        CALL DQXLQM(F,A2,B2,AREA2,ERROR2,RESABS,DEFAB2,VP2,VN2,LP2,LN2,
     *              2)
C
C           IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL
C           AND ERROR AND TEST FOR ACCURACY.
C
        AREA12 = AREA1+AREA2
        ERRO12 = ERROR1+ERROR2
        ERRSUM = ERRSUM+ERRO12-ERRMAX
        AREA = AREA+AREA12-RLIST(MAXERR)
        IF(DEFAB1.EQ.ERROR1.OR.DEFAB2.EQ.ERROR2) GO TO 15
        IF(DABS(RLIST(MAXERR)-AREA12).GT.0.1D-04*DABS(AREA12)
     *  .OR.ERRO12.LT.0.99D+00*ERRMAX) GO TO 10
        IF(EXTRAP) IROFF2 = IROFF2+1
        IF(.NOT.EXTRAP) IROFF1 = IROFF1+1
   10   IF(LAST.GT.10.AND.ERRO12.GT.ERRMAX) IROFF3 = IROFF3+1
   15   RLIST(MAXERR) = AREA1
        RLIST(LAST) = AREA2
        ERRBND = DMAX1(EPSABS,EPSREL*DABS(AREA))
C
C           TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG.
C
        IF(IROFF1+IROFF2.GE.10.OR.IROFF3.GE.20) IER = 2
        IF(IROFF2.GE.5) IERRO = 3
C
C           SET ERROR FLAG IN THE CASE THAT THE NUMBER OF SUBINTERVALS
C           EQUALS LIMIT.
C
        IF(LAST.EQ.LIMIT) IER = 1
C
C           SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR
C           AT A POINT OF THE INTEGRATION RANGE.
C
        IF(DMAX1(DABS(A1),DABS(B2)).LE.(0.1D+01+0.1D+03*EPMACH)*
     *  (DABS(A2)+0.1D+04*UFLOW)) IER = 4
C
C           APPEND THE NEWLY-CREATED INTERVALS TO THE LIST.
C
        IF(ERROR2.GT.ERROR1) GO TO 20
        ALIST(LAST) = A2
        BLIST(MAXERR) = B1
        BLIST(LAST) = B2
        ELIST(MAXERR) = ERROR1
        ELIST(LAST) = ERROR2
        CALL DQXCPY(VALP(1,MAXERR),VP1,LP1)
        LP(MAXERR)=LP1
        CALL DQXCPY(VALN(1,MAXERR),VN1,LN1)
        LN(MAXERR)=LN1
        CALL DQXCPY(VALP(1,LAST),VP2,LP2)
        LP(LAST)=LP2
        CALL DQXCPY(VALN(1,LAST),VN2,LN2)
        LN(LAST)=LN2
        GO TO 30
   20   ALIST(MAXERR) = A2
        ALIST(LAST) = A1
        BLIST(LAST) = B1
        RLIST(MAXERR) = AREA2
        RLIST(LAST) = AREA1
        ELIST(MAXERR) = ERROR2
        ELIST(LAST) = ERROR1
        CALL DQXCPY(VALP(1,MAXERR),VP2,LP2)
        LP(MAXERR)=LP2
        CALL DQXCPY(VALN(1,MAXERR),VN2,LN2)
        LN(MAXERR)=LN2
        CALL DQXCPY(VALP(1,LAST),VP1,LP1)
        LP(LAST)=LP1
        CALL DQXCPY(VALN(1,LAST),VN1,LN1)
        LN(LAST)=LN1
C
C           CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING
C           IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL
C           WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT).
C
   30   CALL DQPSRT(LIMIT,LAST,MAXERR,ERRMAX,ELIST,IORD,NRMAX)
C ***JUMP OUT OF DO-LOOP
        IF(ERRSUM.LE.ERRBND) GO TO 115
C ***JUMP OUT OF DO-LOOP
        IF(IER.NE.0) GO TO 100
        IF(LAST.EQ.2) GO TO 80
        IF(NOEXT) GO TO 90
        ERLARG = ERLARG-ERLAST
        IF(DABS(B1-A1).GT.SMALL) ERLARG = ERLARG+ERRO12
        IF(EXTRAP) GO TO 40
C
C           TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE
C           SMALLEST INTERVAL.
C
        IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
        EXTRAP = .TRUE.
        NRMAX = 2
C
C           THE BOUND 0.3*ERTEST HAS BEEN INTRODUCED TO PERFORM A
C           MORE CAUTIOUS EXTRAPOLATION THAN IN THE ORIGINAL DQAGSE
C           ROUTINE
C
   40   IF(IERRO.EQ.3.OR.ERLARG.LE.0.3D0*ERTEST) GO TO 60
C
C           THE SMALLEST INTERVAL HAS THE LARGEST ERROR.
C           BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE
C           LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION.
C
        ID = NRMAX
        JUPBND = LAST
        IF(LAST.GT.(2+LIMIT/2)) JUPBND = LIMIT+3-LAST
        DO 50 K = ID,JUPBND
          MAXERR = IORD(NRMAX)
          ERRMAX = ELIST(MAXERR)
C ***JUMP OUT OF DO-LOOP
          IF(DABS(BLIST(MAXERR)-ALIST(MAXERR)).GT.SMALL) GO TO 90
          NRMAX = NRMAX+1
   50   CONTINUE
C
C           PERFORM EXTRAPOLATION.
C
   60   NUMRL2 = NUMRL2+1
        RLIST2(NUMRL2) = AREA
        CALL DQELG(NUMRL2,RLIST2,RESEPS,ABSEPS,RES3LA,NRES)
        KTMIN = KTMIN+1
        IF(KTMIN.GT.5.AND.ABSERR.LT.0.1D-02*ERRSUM) IER = 5
        IF(ABSEPS.GE.ABSERR) GO TO 70
        KTMIN = 0
        ABSERR = ABSEPS
        RESULT = RESEPS
        CORREC = ERLARG
        ERTEST = DMAX1(EPSABS,EPSREL*DABS(RESEPS))
C ***JUMP OUT OF DO-LOOP
        IF(ABSERR.LE.ERTEST) GO TO 100
C
C           PREPARE BISECTION OF THE SMALLEST INTERVAL.
C
   70   IF(NUMRL2.EQ.1) NOEXT = .TRUE.
        IF(IER.EQ.5) GO TO 100
        MAXERR = IORD(1)
        ERRMAX = ELIST(MAXERR)
        NRMAX = 1
        EXTRAP = .FALSE.
        SMALL = SMALL*0.5D+00
        ERLARG = ERRSUM
        GO TO 90
   80   SMALL = DABS(B-A)*0.375D+00
        ERLARG = ERRSUM
        ERTEST = ERRBND
        RLIST2(2) = AREA
   90 CONTINUE
C
C           SET FINAL RESULT AND ERROR ESTIMATE.
C           ------------------------------------
C
  100 IF(ABSERR.EQ.OFLOW) GO TO 115
      IF(IER+IERRO.EQ.0) GO TO 110
      IF(IERRO.EQ.3) ABSERR = ABSERR+CORREC
      IF(IER.EQ.0) IER = 3
      IF(RESULT.NE.0.0D+00.AND.AREA.NE.0.0D+00) GO TO 105
      IF(ABSERR.GT.ERRSUM) GO TO 115
      IF(AREA.EQ.0.0D+00) GO TO 130
      GO TO 110
  105 IF(ABSERR/DABS(RESULT).GT.ERRSUM/DABS(AREA)) GO TO 115
C
C           TEST ON DIVERGENCE.
C
  110 IF(KSGN.EQ.(-1).AND.DMAX1(DABS(RESULT),DABS(AREA)).LE.
     * DEFABS*0.1D-01) GO TO 130
      IF(0.1D-01.GT.(RESULT/AREA).OR.(RESULT/AREA).GT.0.1D+03
     * .OR.ERRSUM.GT.DABS(AREA)) IER = 6
      GO TO 130
C
C           COMPUTE GLOBAL INTEGRAL SUM.
C
  115 RESULT = 0.0D+00
      DO 120 K = 1,LAST
         RESULT = RESULT+RLIST(K)
  120 CONTINUE
      ABSERR = ERRSUM
  130 IF(IER.GT.2) IER = IER-1
  999 RETURN
      END
*DECK DQXLQM
      SUBROUTINE DQXLQM(F,A,B,RESULT,ABSERR,RESABS,RESASC,VR,VS,LR,LS,
     *                  KEY)
C
C            TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
C                           ESTIMATE
C                       J = INTEGRAL OF ABS(F) OVER (A,B)
C
C           PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              A      - DOUBLE PRECISION
C                       LOWER LIMIT OF INTEGRATION
C
C              B      - DOUBLE PRECISION
C                       UPPER LIMIT OF INTEGRATION
C
C              VR     - DOUBLE PRECISION
C                       VECTOR OF LENGTH LR CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              VS     - DOUBLE PRECISION
C                       VECTOR OF LENGTH LS CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              LR     - INTEGER
C              LS       NUMBER OF ELEMENTS IN
C                       VR,VS RESPECTIVELY
C
C            KEY    - INTEGER
C                     KEY FOR CHOICE OF LOCAL INTEGRATION RULE
C                     RMS FORMULAS ARE USED WITH
C                      13 - 19               POINTS IF KEY.LT.1,
C                      13 - 19 - (27)        POINTS IF KEY = 1,
C                      13 - 19 - (27) - (41) POINTS IF KEY = 2,
C                           19 -  27  - (41) POINTS IF KEY = 3,
C                                 27  -  41  POINTS IF KEY.GT.3.
C
C                         (RULES) USED IF THE FUNCTION APPEARS
C                         ENOUGH REGULAR
C
C            ON RETURN
C              RESULT - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL I
C
C              ABSERR - DOUBLE PRECISION
C                       ESTIMATE OF THE MODULUS OF THE ABSOLUTE ERROR,
C                       WHICH SHOULD NOT EXCEED ABS(I-RESULT)
C
C              RESABS - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL J
C
C              RESASC - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL OF ABS(F-I/(B-A))
C                       OVER (A,B)
C
C              VR     - DOUBLE PRECISION
C                       VECTOR OF LENGTH LR CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              VS     - DOUBLE PRECISION
C                       VECTOR OF LENGTH LS CONTAINING THE
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              LR     - INTEGER
C              LS       NUMBER OF ELEMENTS IN
C                       VR,VS RESPECTIVELY
C
C***ROUTINES CALLED  D1MACH,DQXRUL
C
      DOUBLE PRECISION F,A,B,RESULT,ABSERR,RESABS,RESASC,
     *          D1MACH,EPMACH,RESG,RESK,UFLOW,ERROLD,VR(21),VS(21)
      INTEGER K,K0,K1,K2,KEY,KEY1,LR,LS
      EXTERNAL F
C
C            MACHINE DEPENDENT CONSTANTS
C            ---------------------------
C
C          EPMACH IS THE LARGEST RELATIVE SPACING.
C          UFLOW IS THE SMALLEST POSITIVE MAGNITUDE.
C          ERROLD IS THE LARGEST MAGNITUDE.
C
C***FIRST EXECUTABLE STATEMENT DQXLQM
      EPMACH = D1MACH(4)
      UFLOW  = D1MACH(1)
      ERROLD = D1MACH(2)
C
      KEY1 = MAX(KEY ,  0)
      KEY1 = MIN(KEY1,  4)
      K0   = MAX(KEY1-2,0)
      K1   = K0+1
      K2   = MIN(KEY1+1,3)
C
      CALL DQXRUL(F,A,B,RESG,RESABS,RESASC,K0,K1,VR,VS,LR,LS)
      DO 99 K=K1,K2
        CALL DQXRUL(F,A,B,RESK,RESABS,RESASC,K,K1,VR,VS,LR,LS)
        RESULT=RESK
        ABSERR = DABS((RESK-RESG))
        IF(RESASC.NE.0.0D+00.AND.ABSERR.NE.0.0D+00)
     *  ABSERR = RESASC*DMIN1(1.D0,(200D0*ABSERR/RESASC)**1.5D+00)
        IF(RESABS.GT.UFLOW/(10D0*EPMACH)) ABSERR = DMAX1
     *  ((EPMACH*10D0)*RESABS,ABSERR)
        RESG=RESK
        IF(ABSERR.GT.ERROLD*0.16)GOTO 3000
        IF(ABSERR.LT.1000*EPMACH*RESABS)GOTO 3000
        ERROLD=ABSERR
99    CONTINUE
3000  CONTINUE
      RETURN
      END
*DECK DQXRUL
      SUBROUTINE DQXRUL(F,XL,XU,Y,YA,YM,KE,K1,FV1,FV2,L1,L2)
C
C            TO COMPUTE I = INTEGRAL OF F OVER (A,B), WITH ERROR
C                           ESTIMATE
C            AND CONDITIONALLY COMPUTE
C                       J = INTEGRAL OF ABS(F) OVER (A,B)
C                       BY USING AN  RMS RULE
C           PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              XL     - DOUBLE PRECISION
C                       LOWER LIMIT OF INTEGRATION
C
C              XU     - DOUBLE PRECISION
C                       UPPER LIMIT OF INTEGRATION
C
C
C              KE     - INTEGER
C                     KEY FOR CHOICE OF LOCAL INTEGRATION RULE
C                     AN RMS RULE IS USED WITH
C                         13      POINTS IF KE  = 2,
C                         19      POINTS IF KE  = 3,
C                         27      POINTS IF KE  = 4,
C                         42      POINTS IF KE  = 5
C
C              K1     INTEGER
C                     VALUE OF KEY FOR WHICH THE ADDITIONAL ESTIMATES
C                     YA, YM ARE TO BE COMPUTED
C
C              FV1    - DOUBLE PRECISION
C                       VECTOR CONTAINING L1
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              FV2    - DOUBLE PRECISION
C                       VECTOR CONTAINING L2
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              L1     - INTEGER
C              L2       NUMBER OF ELEMENTS IN FV1,FV2  RESPECTIVELY
C
C            ON RETURN
C              Y      - DOUBLE PRECISION
C                       APPROXIMATION TO THE INTEGRAL I
C                       RESULT IS COMPUTED BY APPLYING THE
C                       REQUESTED RMS RULE
C
C              YA     - DOUBLE PRECISION
C                       IF KEY = K1  APPROXIMATION TO THE INTEGRAL J
C                       ELSE UNCHANGED
C
C              YM     - DOUBLE PRECISION
C                       IF KEY = K1  APPROXIMATION TO THE INTEGRAL OF
C                                      ABS(F-I/(XU-XL)   OVER (XL,XU)
C                       ELSE UNCHANGED
C
C              FV1    - DOUBLE PRECISION
C                       VECTOR L1 CONTAINING L1
C                       SAVED  FUNCTIONAL VALUES OF POSITIVE ABSCISSAS
C
C              FV2    - DOUBLE PRECISION
C                       VECTOR CONTAINING L2
C                       SAVED  FUNCTIONAL VALUES OF NEGATIVE ABSCISSAS
C
C              L1     - INTEGER
C              L2       NUMBER OF ELEMENTS IN FV1,FV2  RESPECTIVELY
C
C***ROUTINES CALLED  F
C
      DOUBLE PRECISION F,XL,XU,LDL,Y,YA,YM,Y2,XX(41),WW(52),
     *                 FV1(21),FV2(21),AA,BB,C
      EXTERNAL F
      INTEGER ISTART(4),LEN(4),KE,K1,L1,L2,K,IS,KS,I
      SAVE ISTART,LEN,XX,WW
      DATA ISTART/0, 7, 17, 31/,LEN/7, 10, 14, 21/
      DATA XX(  1)/.0                       /
      DATA XX(  2)/.25000000000000000000D+00/
      DATA XX(  3)/.50000000000000000000D+00/
      DATA XX(  4)/.75000000000000000000D+00/
      DATA XX(  5)/.87500000000000000000D+00/
      DATA XX(  6)/.93750000000000000000D+00/
      DATA XX(  7)/.10000000000000000000D+01/
      DATA XX(  8)/.37500000000000000000D+00/
      DATA XX(  9)/.62500000000000000000D+00/
      DATA XX( 10)/.96875000000000000000D+00/
      DATA XX( 11)/.12500000000000000000D+00/
      DATA XX( 12)/.68750000000000000000D+00/
      DATA XX( 13)/.81250000000000000000D+00/
      DATA XX( 14)/.98437500000000000000D+00/
      DATA XX( 15)/.18750000000000000000D+00/
      DATA XX( 16)/.31250000000000000000D+00/
      DATA XX( 17)/.43750000000000000000D+00/
      DATA XX( 18)/.56250000000000000000D+00/
      DATA XX( 19)/.84375000000000000000D+00/
      DATA XX( 20)/.90625000000000000000D+00/
      DATA XX( 21)/.99218750000000000000D+00/
C   NUMBER OF NODES 13
      DATA WW(1)/1.303262173284849021810473057638590518409112513421D-1/
      DATA WW(2)/2.390632866847646220320329836544615917290026806242D-1/
      DATA WW(3)/2.630626354774670227333506083741355715758124943143D-1/
      DATA WW(4)/2.186819313830574175167853094864355208948886875898D-1/
      DATA WW(5)/2.757897646642836865859601197607471574336674206700D-2/
      DATA WW(6)/1.055750100538458443365034879086669791305550493830D-1/
      DATA WW(7)/1.571194260595182254168429283636656908546309467968D-2/
C   NUMBER OF NODES 19
      DATA WW(8)/1.298751627936015783241173611320651866834051160074D-1/
      DATA WW(9)/2.249996826462523640447834514709508786970828213187D-1/
      DATA WW(15)/5.542699233295875168406783695143646338274805359780D-2/
      DATA WW(10)/1.680415725925575286319046726692683040162290325505D-1/
      DATA WW(16)/9.986735247403367525720377847755415293097913496236D-2/
      DATA WW(11)/1.415567675701225879892811622832845252125600939627D-1/
      DATA WW(12)/1.006482260551160175038684459742336605269707889822D-1/
      DATA WW(13)/2.510604860724282479058338820428989444699235030871D-2/
      DATA WW(17)/4.507523056810492466415880450799432587809828791196D-2/
      DATA WW(14)/9.402964360009747110031098328922608224934320397592D-3/
C   NUMBER OF NODES 27
      DATA WW(18)/6.300942249647773931746170540321811473310938661469D-2/
      DATA WW(28)/1.239572396231834242194189674243818619042280816640D-1/
      DATA WW(19)/1.261383225537664703012999637242003647020326905948D-1/
      DATA WW(25)/1.235837891364555000245004813294817451524633100256D-1/
      DATA WW(20)/1.273864433581028272878709981850307363453523117880D-1/
      DATA WW(26)/1.148933497158144016800199601785309838604146040215D-1/
      DATA WW(29)/2.501306413750310579525950767549691151739047969345D-2/
      DATA WW(21)/8.576500414311820514214087864326799153427368592787D-2/
      DATA WW(30)/4.915957918146130094258849161350510503556792927578D-2/
      DATA WW(22)/7.102884842310253397447305465997026228407227220665D-2/
      DATA WW(23)/5.026383572857942403759829860675892897279675661654D-2/
      DATA WW(27)/1.252575774226122633391477702593585307254527198070D-2/
      DATA WW(31)/2.259167374956474713302030584548274729936249753832D-2/
      DATA WW(24)/4.683670010609093810432609684738393586390722052124D-3/
C   NUMBER OF NODES 41
      DATA WW(32)/6.362762978782724559269342300509058175967124446839D-2/
      DATA WW(42)/1.187141856692283347609436153545356484256869129472D-1/
      DATA WW(46)/1.533126874056586959338368742803997744815413565014D-2/
      DATA WW(33)/9.950065827346794643193261975720606296171462239514D-2/
      DATA WW(47)/3.527159369750123100455704702965541866345781113903D-2/
      DATA WW(39)/8.140326425945938045967829319725797511040878579808D-2/
      DATA WW(48)/5.000556431653955124212795201196389006184693561679D-2/
      DATA WW(34)/7.048220002718565366098742295389607994441704889441D-2/
      DATA WW(49)/5.744164831179720106340717579281831675999717767532D-2/
      DATA WW(40)/6.583213447600552906273539578430361199084485578379D-2/
      DATA WW(43)/5.999947605385971985589674757013565610751028128731D-2/
      DATA WW(35)/6.512297339398335645872697307762912795346716454337D-2/
      DATA WW(44)/5.500937980198041736910257988346101839062581489820D-2/
      DATA WW(50)/1.598823797283813438301248206397233634639162043386D-2/
      DATA WW(36)/3.998229150313659724790527138690215186863915308702D-2/
      DATA WW(51)/2.635660410220884993472478832884065450876913559421D-2/
      DATA WW(37)/3.456512257080287509832054272964315588028252136044D-2/
      DATA WW(41)/2.592913726450792546064232192976262988065252032902D-2/
      DATA WW(45)/5.264422421764655969760271538981443718440340270116D-3/
      DATA WW(52)/1.196003937945541091670106760660561117114584656319D-2/
      DATA WW(38)/2.212167975884114432760321569298651047876071264944D-3/
C
C***FIRST EXECUTABLE STATEMENT DQXRUL
      K=KE+1
      IS=ISTART(K)
      KS=LEN(K)
      LDL= XU-XL
      BB= LDL*0.5D0
      AA= XL+BB
      Y =0.D0
      DO 100 I=1,KS
         IF(I.GT.L1.OR.I.GT.L2)   C=BB*XX(I)
         IF(I.GT.L1)              FV1(I)=F(AA+C)
         IF(I.GT.L2)              FV2(I)=F(AA-C)
         Y=Y+(FV1(I)+FV2(I))*WW(IS+I)
100   CONTINUE
      Y2=Y
      Y=Y*BB
      IF(L1.LT.KS)L1=KS
      IF(L2.LT.KS)L2=KS
      IF(KE.NE.K1)RETURN
      YA=0.D0
      DO 25 I=1,KS
        YA=YA+(DABS(FV1(I))+DABS(FV2(I)))*WW(IS+I)
  25  CONTINUE
      Y2=Y2*0.5D0
      YM=0.D0
      YA=YA*DABS(BB)
      DO 27 I=1,KS
        YM=YM+(DABS(FV1(I)-Y2)+DABS(FV2(I)-Y2))*WW(IS+I)
   27 CONTINUE
      YM=YM*DABS(BB)
      RETURN
      END
*DECK DQXRRD
      SUBROUTINE DQXRRD(F,Z,LZ,XL,XU,R,S,LR,LS)
C
C            TO REORDER THE COMPUTED FUNCTIONAL VALUES BEFORE
C            THE BISECTION OF AN INTERVAL
C           PARAMETERS
C            ON ENTRY
C              F      - DOUBLE PRECISION
C                       FUNCTION SUBPROGRAM DEFINING THE INTEGRAND
C                       FUNCTION F(X). THE ACTUAL NAME FOR F NEEDS TO BE
C                       DECLARED E X T E R N A L IN THE DRIVER PROGRAM.
C
C              XL     - DOUBLE PRECISION
C                       LOWER LIMIT OF INTERVAL
C
C              XU     - DOUBLE PRECISION
C                       UPPER LIMIT OF INTERVAL
C
C              Z      - DOUBLE PRECISION
C                       VECTOR CONTAINING LZ
C                       SAVED  FUNCTIONAL VALUES
C
C              LZ     - INTEGER
C                       NUMBER OF ELEMENTS IN LZ
C
C
C            ON RETURN
C              R      - DOUBLE PRECISION
C              S        VECTORS CONTAINING LR, LS
C                       SAVED  FUNCTIONAL VALUES FOR THE NEW INTERVALS
C
C              LR     - INTEGER
C              LS       NUMBER OF ELEMENTES IN R,S RESPECTIVELY
C
C***ROUTINES CALLED  F
C
      DOUBLE PRECISION F,R,S,Z,XU,XL,DLEN,CENTR
      INTEGER LR,LS,LZ
      DIMENSION R(21),S(21),Z(21)
C***FIRST EXECUTABLE STATEMENT DQXRRD
      DLEN= (XU-XL)*0.5D0
      CENTR= XL+DLEN
      R(1)=  Z(3)
      R(2)=  Z(9)
      R(3)=  Z(4)
      R(4)=  Z(5)
      R(5)=  Z(6)
      R(6)=  Z(10)
      R(7)=  Z(7)
      S(1)=  Z(3)
      S(2)=  Z(8)
      S(3)=  Z(2)
      S(7)=  Z(1)
      IF(LZ.GT.11)GOTO 2
      R(8)=  F(CENTR+DLEN*0.37500000D0)
      R(9)=  F(CENTR+DLEN*0.62500000D0)
      R(10)=  F(CENTR+DLEN*0.96875000D0)
      LR=  10
      IF(LZ.NE.11)S(4)=  F(CENTR-DLEN*0.75000000D0)
      IF(LZ.EQ.11)S(4)=  Z(11)
      S(5)=  F(CENTR-DLEN*0.87500000D0)
      S(6)=  F(CENTR-DLEN*0.93750000D0)
      S(8)=  F(CENTR-DLEN*0.37500000D0)
      S(9)=  F(CENTR-DLEN*0.62500000D0)
      S(10)=  F(CENTR-DLEN*0.96875000D0)
      LS=  10
      GOTO 3000
2     R(8)= Z(12)
      R(9)= Z(13)
      R(10)= Z(14)
      LR=  10
      S(4)= Z(11)
      S(5)= F(CENTR-DLEN*0.87500000D0)
      S(6)= F(CENTR-DLEN*0.93750000D0)
      IF(LZ.GT.14)GOTO3
      S(8)= F(CENTR-DLEN*0.37500000D0)
      S(9)= F(CENTR-DLEN*0.62500000D0)
      S(10)= F(CENTR-DLEN*0.96875000D0)
      LS=  10
      GOTO 3000
3     R(11)= Z(18)
      R(12)= Z(19)
      R(13)= Z(20)
      R(14)= Z(21)
      LR=  14
      S(8)= Z(16)
      S(9)= Z(15)
      S(10)= F(CENTR-DLEN*0.96875000D0)
      S(11)= Z(17)
      LS=  11
3000  RETURN
      END
*DECK DQXCPY
      SUBROUTINE DQXCPY(A,B,L)
C
C  TO COPY THE DOUBLE PRECISION VECTOR B OF LENGTH L   I N T O
C          THE DOUBLE PRECISION VECTOR A OF LENGTH L
C
C***REMARK  THIS ROUTINE CAN BE IMPROVED, BY CODING IT IN THE
C           ASSEMBLER LANGUAGE OF THE USED MACHINE
C***ROUTINES CALLED  (NONE)
C
      INTEGER L,I
      DOUBLE PRECISION A(L),B(L)
C***FIRST EXECUTABLE STATEMENT DQXCPY
      DO 1 I=1,L
        A(I)=B(I)
1     CONTINUE
      RETURN
      END
C
C ======================================================================
C     D1MACH can be used to obtain machine-dependent parameters
C     for the local machine environment.  It is a function
C     subprogram with one (input) argument, and can be called
C     as follows, for example
C
C          D = D1MACH(I)
C
C     where I=1,...,5.  The (output) value of D above is
C     determined by the (input) value of I.  The results for
C     various values of I are discussed below.
C
C  Double-precision machine constants
C  D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude.
C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
C  D1MACH( 3) = B**(-T), the smallest relative spacing.
C  D1MACH( 4) = B**(1-T), the largest relative spacing.
C  D1MACH( 5) = LOG10(B)
C ======================================================================
C
      DOUBLE PRECISION FUNCTION D1MACH(I)
      INTEGER I
C
C The constants below are for IEEE standard machines (e.g. PCs)
C Michele Cappellari, April 2000
C
      DOUBLE PRECISION DMACH(5)
      DATA DMACH(1) / 2.225073858507202D-308 /
      DATA DMACH(2) / 1.797693134862315D+308 /
      DATA DMACH(3) / 1.110223024625157D-016 /
      DATA DMACH(4) / 2.220446049250313D-016 /
      DATA DMACH(5) / 3.010299956639812D-001 /

      D1MACH = DMACH(I)
      RETURN
C
      END
C ======================================================================