C     ALGORITHM 584, COLLECTED ALGORITHMS FROM ACM.
C     ALGORITHM APPEARED IN ACM-TRANS. MATH. SOFTWARE, VOL.8, NO. 2,
C     JUN., 1982, P. 210. Author: D.P. Laurie
C     PROGRAM KONYN(OUTPUT,TAPE6=OUTPUT)
      SUBROUTINE CUBTRI(F, T, EPS, MCALLS, ANS, ERR, NCALLS, W, NW,
     * IDATA, RDATA, IER)
c
c     changed on June 6th 2011 in order to allow parallelization:
c     the common statements were commented with cparallel, the data
C     statements were converted.
C
C       ADAPTIVE CUBATURE OVER A TRIANGLE
C
C       PARAMETERS
C          F     - USER SUPPLIED EXTERNAL FUNCTION OF THE FORM
C                  F(X,Y,IDATA,RDATA)
C                  WHERE X AND Y ARE THE CARTESIAN COORDINATES OF A
C                  POINT IN THE PLANE, AND IDATA AND RDATA ARE INTEGER
C                  AND REAL*8 VECTORS IN WHICH DATA MAY BE PASSED.
C          T     - ARRAY OF DIMENSION (2,3) WHERE T(1,J) AND T(2,J)
C                  ARE THE X AND Y COORDINATES OF THE J-TH VERTEX OF
C                  THE GIVEN TRIANGLE (INPUT)
C          EPS   - REQUIRED TOLERANCE (INPUT).  IF THE COMPUTED
C                  INTEGRAL IS BETWEEN-1 AND 1, AN ABSOLUTE ERROR
C                  TEST IS USED, ELSE A RELATIVE ERROR TEST IS USED.
C          MCALLS- MAXIMUM PERMITTED NUMBER OF CALLS TO F (INPUT)
C          ANS   - ESTIMATE FOR THE VALUE OF THE INTEGRAL OF F OVER
C                  THE GIVEN TRIANGLE (OUTPUT)
C          ERR   - ESTIMATED ABSOLUTE ERROR IN ANS (OUTPUT)
C          NCALLS- ACTUAL NUMBER OF CALLS TO F (OUTPUT).  THIS
C                  PARAMETER MUST BE INITIALIZED TO 0 ON THE FIRST
C                  CALL TO CUBTRI FOR A GIVEN INTEGRAL (INPUT)
C          W     - WORK SPACE.  MAY NOT BE DESTROYED BETWEEN CALLS TO
C                  CUBTRI IF RESTARTING IS INTENDED
C          NW    - LENGTH OF WORK SPACE (INPUT).
C                  IF NW .GE. 3*(19+3*MCALLS)/38, TERMINATION DUE TO
C                  FULL WORK SPACE WILL NOT OCCUR.
C          IER   - TERMINATION INDICATOR (OUTPUT)
C                  IER=0   NORMAL TERMINATION, TOLERANCE SATISFIED
C                  IER=1   MAXIMUM NUMBER OF CALLS REACHED
C                  IER=2   WORK SPACE FULL
C                  IER=3   FURTHER SUBDIVISION OF TRIANGLES IMPOSSIBLE
C                  IER=4   NO FURTHER IMPROVEMENT IN ACCURACY IS
C                        POSSIBLE DUE TO ROUNDING ERRORS IN FUNCTION
C                        VALUES
C                  IER=5   NO FURTHER IMPROVEMENT IN ACCURACY IS
C                        POSSIBLE BECAUSE SUBDIVISION DOES NOT
C                        CHANGE THE ESTIMATED INTEGRAL. MACHINE
C                        ACCURACY HAS PROBABLY BEEN REACHED BUT
C                        THE ERROR ESTIMATE IS NOT SHARP ENOUGH.
C
C       CUBTRI IS DESIGNED TO BE CALLED REPEATEDLY WITHOUT WASTING
C       EARLIER WORK.  THE PARAMETER NCALLS IS USED TO INDICATE TO
C       CUBTRI AT WHAT POINT TO RESTART, AND MUST BE RE-INITIALIZED
C       TO 0 WHEN A NEW INTEGRAL IS TO BE COMPUTED.  AT LEAST ONE OF
C       THE PARAMETERS EPS, MCALLS AND NW MUST BE CHANGED BETWEEN
C       CALLS TO CUBTRI, ACCORDING TO THE RETURNED VALUE OF IER. NONE
C       OF THE OTHER PARAMETERS MAY BE CHANGED IF RESTARTING IS DONE.
C       IF IER=3 IS ENCOUNTERED, THERE PROBABLY IS A SINGULARITY
C       SOMEWHERE IN THE REGION.  THE ERROR MESSAGE INDICATES THAT
C       FURTHER SUBDIVISION IS IMPOSSIBLE BECAUSE THE VERTICES OF THE
C       SMALLER TRIANGLES PRODUCED WILL BEGIN TO COALESCE TO THE
C       PRECISION OF THE COMPUTER.  THIS SITUATION CAN USUALLY BE
C       RELIEVED BY SPECIFYING THE REGION IN SUCH A WAY THAT THE
C       SINGULARITY IS LOCATED AT THE THIRD VERTEX OF THE TRIANGLE.
C       IF IER=4 IS ENCOUNTERED, THE VALUE OF THE INTEGRAL CANNOT BE
C       IMPROVED ANY FURTHER. THE ONLY EXCEPTION TO THIS OCCURS WHEN A
C       FUNCTION WITH HIGHLY IRREGULAR BEHAVIOUR IS INTEGRATED (E.G.
C       FUNCTIONS WITH JUMP DISCONTINUITIES OR VERY HIGHLY OSCILLATORY
C       FUNCTIONS). IN SUCH A CASE THE USER CAN DISABLE THE ROUNDING
C       ERROR TEST BY REMOVING THE IF STATEMENT SHORTLY AFTER STATEMENT
C       NUMBER 70.
C
      implicit none
      EXTERNAL F,rnderr
      INTEGER IDATA(1), IER, MCALLS, NCALLS, NW,jkp,i,j,k,l,maxc,maxk,
     &  mw,nfe
      REAL*8 ALFA, ANS, ANSKP, AREA, EPS, ERR, ERRMAX, H, Q1, Q2, R1,R2,
     * RDATA(1), D(2,4), S(4), T(2,3), VEC(2,3), W(6,NW), X(2),zero,
     & point5,one,rnderr
C       ACTUAL DIMENSION OF W IS (6,NW/6)
C
      REAL*8 TANS, TERR, DZERO
cparallel      COMMON /CUBSTA/ TANS, TERR
C       THIS COMMON IS REQUIRED TO PRESERVE TANS AND TERR BETWEEN CALLS
C       AND TO SAVE VARIABLES IN FUNCTION RNDERR
      nfe=19
      s=(/1.d0,1.d0,1.d0,-1.d0/)
      d=reshape((/0.0d0,0.0d0,0.0d0,1.0d0,1.0d0,0.0d0,1.0d0,1.0d0/),
     &  (/2,4/))
      zero=0.d0
      one=1.d0
      dzero=0.d0
      point5=.5d0
cparallel      DATA NFE /19/, S(1), S(2), S(3), S(4) /3*1E0,-1E0/, D(1,1),
cparallel     * D(2,1) /0.0,0.0/, D(1,2), D(2,2) /0.0,1.0/, D(1,3), D(2,3)
cparallel     * /1.0,0.0/, D(1,4), D(2,4) /1.0,1.0/
C       NFE IS THE NUMBER OF FUNCTION EVALUATIONS PER CALL TO CUBRUL.
cparallel      DATA ZERO /0.E0/, ONE /1.E0/, DZERO /0.D0/, POINT5 /.5E0/
C
C      CALCULATE DIRECTION VECTORS, AREA AND MAXIMUM NUMBER
C      OF SUBDIVISIONS THAT MAY BE PERFORMED
      DO 20 I=1,2
        VEC(I,3) = T(I,3)
        DO 10 J=1,2
          VEC(I,J) = T(I,J) - T(I,3)
   10   CONTINUE
   20 CONTINUE
      MAXC = (MCALLS/NFE+3)/4
      IER = 1
      MAXK = MIN0(MAXC,(NW/6+2)/3)
      IF (MAXC.GT.MAXK) IER = 2
      AREA = ABS(VEC(1,1)*VEC(2,2)-VEC(1,2)*VEC(2,1))*POINT5
      K = (NCALLS/NFE+3)/4
      MW = 3*(K-1) + 1
      IF (NCALLS.GT.0) GO TO 30
C
C       TEST FOR TRIVIAL CASES
      TANS = DZERO
      TERR = DZERO
      IF (AREA.EQ.ZERO) GO TO 90
      IF (MCALLS.LT.NFE) GO TO 100
      IF (NW.LT.6) GO TO 110
C
C       INITIALIZE DATA LIST
      K = 1
      MW = 1
      W(1,1) = ZERO
      W(2,1) = ZERO
      W(3,1) = ONE
      CALL CUBRUL(F, VEC, W(1,1), IDATA, RDATA)
      TANS = W(5,1)
      TERR = W(6,1)
      NCALLS = NFE
C
C       TEST TERMINATION CRITERIA
   30 ANS = TANS
      ERR = TERR
      IF (ERR.LT.DMAX1(ONE,ABS(ANS))*EPS) GO TO 90
      IF (K.EQ.MAXK) GO TO 120
C
C       FIND TRIANGLE WITH LARGEST ERROR
      ERRMAX = ZERO
      DO 40 I=1,MW
        IF (W(6,I).LE.ERRMAX) GO TO 40
        ERRMAX = W(6,I)
        J = I
   40 CONTINUE
C
C       SUBDIVIDE TRIANGLE INTO FOUR SUBTRIANGLES AND UPDATE DATA LIST
      DO 50 I=1,2
        X(I) = W(I,J)
   50 CONTINUE
      H = W(3,J)*POINT5
      IF (RNDERR(X(1),H,X(1),H).NE.ZERO) GO TO 130
      IF (RNDERR(X(2),H,X(2),H).NE.ZERO) GO TO 130
      ANSKP = (TANS)
      TANS = TANS - (W(5,J))
      TERR = TERR - (W(6,J))
      R1 = W(4,J)
      R2 = W(5,J)
      JKP = J
      Q1 = ZERO
      Q2 = ZERO
      DO 70 I=1,4
        DO 60 L=1,2
          W(L,J) = X(L) + H*D(L,I)
   60   CONTINUE
        W(3,J) = H*S(I)
        CALL CUBRUL(F, VEC, W(1,J), IDATA, RDATA)
        Q2 = Q2 + W(5,J)
        Q1 = Q1 + W(4,J)
        J = MW + I
   70 CONTINUE
      ALFA = 1E15
      IF (Q2.NE.R2) ALFA = ABS((Q1-R1)/(Q2-R2)-ONE)
      J = JKP
      DO 80 I=1,4
        W(6,J) = W(6,J)/ALFA
        TANS = TANS + W(5,J)
        TERR = TERR + W(6,J)
        J = MW + I
   80 CONTINUE
      MW = MW + 3
      NCALLS = NCALLS + 4*NFE
      K = K + 1
C
C       IF ANSWER IS UNCHANGED, IT CANNOT BE IMPROVED
      IF (ANSKP.EQ.(TANS)) GO TO 150
C
C       REMOVE THIS IF STATEMENT TO DISABLE ROUNDING ERROR TEST
      IF (K.GT.3 .AND. ABS(Q2-R2).GT.ABS(Q1-R1)) GO TO 140
      GO TO 30
C
C       EXITS FROM SUBROUTINE
   90 IER = 0
      GO TO 120
  100 IER = 1
      GO TO 120
  110 IER = 2
  120 ANS = TANS
      ERR = TERR
      RETURN
  130 IER = 3
      GO TO 120
  140 IER = 4
      GO TO 120
  150 IER = 5
      GO TO 120
      END
      real*8 FUNCTION RNDERR(X, A, Y, B)
C       THIS FUNCTION COMPUTES THE ROUNDING ERROR COMMITTED WHEN THE
C       SUM X+A IS FORMED.  IN THE CALLING PROGRAM, Y MUST BE THE SAME
C       AS X AND B MUST BE THE SAME AS A.  THEY ARE DECLARED AS
C       DISTINCT VARIABLES IN THIS FUNCTION, AND THE INTERMEDIATE
C       VARIABLES S AND T ARE PUT INTO COMMON, IN ORDER TO DEFEND
C       AGAINST THE WELL-MEANING ACTIONS OF SOME OFFICIOUS OPTIMIZING
C       FORTRAN COMPILERS.
      implicit none
      real*8 x,a,y,b,s,t
cparallel      COMMON /CUBATB/ S, T
      S = X + A
      T = S - Y
      RNDERR = T - B
      RETURN
      END
      SUBROUTINE CUBRUL(F, VEC, P, IDATA, RDATA)
C
C       BASIC CUBATURE RULE PAIR OVER A TRIANGLE
C
C       PARAMETERS
C         F  - EXTERNAL FUNCTION - SEE COMMENTS TO CUBTRI
C         VEC- MATRIX OF BASE VECTORS AND ORIGIN (INPUT)
C         P  - TRIANGLE DESCRIPTION VECTOR OF DIMENSION 6
C               P(1) - TRANSFORMED X COORDINATE OF ORIGIN VERTEX(INPUT)
C               P(2) - TRANSFORMED Y COORDINATE OF ORIGIN VERTEX(INPUT)
C               P(3) - DISTANCE OF OTHER VERTICES IN THE DIRECTIONS
C                     OF THE BASE VECTORS (INPUT)
C               P(4) - LESS ACCURATE ESTIMATED INTEGRAL (OUTPUT)
C               P(5) - MORE ACCURATE ESTIMATED INTEGRAL (OUTPUT)
C               P(6) - ABS(P(5)-P(4))   (OUTPUT)
C
C       CUBRUL EVALUATES A LINEAR COMBINATION OF BASIC INTEGRATION
C       RULES HAVING D3 SYMMETRY.  THE AREAL*8 COORDINATES PERTAINING TO
C       THE J-TH RULE ARE STORED IN W(I,J),I=1,2,3.  THE CORRESPONDING
C       WEIGHTS ARE W(4,J) AND W(5,J), WITH W(5,J) BELONGING TO THE
C       MORE ACCURATE FORMULA.  IF W(1,J).EQ.W(2,J), THE INTEGRATION
C       POINT IS THE CENTROID, ELSE IF W(2,J).EQ.W(3,J), THE EVALUATION
C       POINTS ARE ON THE MEDIANS.  IN BOTH CASES ADVANTAGE IS TAKEN OF
C       SYMMETRY TO AVOID REPEATING FUNCTION EVALUATIONS.
C
C       THE FOLLOWING REAL*8 VARIABLES ARE USED TO AVOID
C       UNNECESSARY ROUNDING ERRORS IN FLOATING POINT ADDITION.
C       THEY MAY BE DECLARED SINGLE PRECISION IF REAL*8 IS
C       NOT AVAILABLE AND FULL ACCURACY IS NOT NEEDED.
      implicit none
      REAL*8 A1, A2, S, SN, DZERO, DONE, DTHREE, DSIX,f,
     &  point5,x,y
      REAL*8 AREA, ORIGIN(2), P(6), RDATA(1), TVEC(2,3), VEC(2,3),W(5,6)
      INTEGER IDATA(1),nquad,i,j,k
C
C       W CONTAINS POINTS AND WEIGHTS OF THE INTEGRATION FORMULAE
C       NQUAD - NUMBER OF BASIC RULES USED
C
C       THIS PARTICULAR RULE IS THE 19 POINT EXTENSION (DEGREE 8) OF
C       THE FAMILIAR 7 POINT RULE (DEGREE 5).
C
C     SIGMA=SQRT(7)
C     PHI=SQRT(15)
C     W(1,1),W(2,1),W(3,1) = 1/3
C     W(4,1) = 9/40
C     W(5,1) = 7137/62720 - 45*SIGMA/1568
C     W(1,2) = 3/7 + 2*PHI/21
C     W(2,2),W(3,2) = 2/7 - PHI/21
C     W(4,2) = 31/80 - PHI/400
C     W(5,2) = - 9301697/4695040 - 13517313*PHI/23475200
C            + 764885*SIGMA/939008 + 198763*PHI*SIGMA/939008
C     W(*,3) = W(*,2) WITH PHI REPLACED BY -PHI
C     W(1,5) = 4/9 + PHI/9 + SIGMA/9 - SIGMA*PHI/45
C     W(2,5),W(3,5) = 5/18 - PHI/18 - SIGMA/18 + SIGMA*PHI/90
C     W(4,5) = 0
C     W(5,5) = 102791225/59157504 + 23876225*PHI/59157504
C            - 34500875*SIGMA/59157504 - 9914825*PHI*SIGMA/59157504
C     W(*,4) = W(*,5) WITH PHI REPLACED BY -PHI
C     W(1,6) = 4/9 + SIGMA/9
C     W(2,6) = W(2,4)
C     W(3,6) = W(2,5)
C     W(4,6) = 0
C     W(5,6) = 11075/8064 - 125*SIGMA/288
C
      nquad=6
      w=reshape((/.3333333333333333333333333d0,
     & .3333333333333333333333333d0,.3333333333333333333333333d0,.225d0,
     & .3786109120031468330830822d-1,.7974269853530873223980253d0,
     & .1012865073234563388009874d0,.1012865073234563388009874d0,
     & .3778175416344814577870518d0,
     & .1128612762395489164329420d0,.5971587178976982045911758d-1,
     & .4701420641051150897704412d0,.4701420641051150897704412d0,
     & .3971824583655185422129482d0,
     & .2350720567323520126663380d0,.5357953464498992646629509d0,
     & .2321023267750503676685246d0,.2321023267750503676685246d0,
     & 0.d0,.3488144389708976891842461d0,
     & .9410382782311208665596304d0,
     & .2948086088443956672018481d-1,.2948086088443956672018481d-1,
     & 0.d0,.4033280212549620569433320d-1,.7384168123405100656112906d0,
     & .2321023267750503676685246d0,.2948086088443956672018481d-1,
     & 0.d0,.2250583347313904927138324d0/),(/5,6/))
cparallel
cparallel      DATA NQUAD /6/, W(1,1), W(2,1), W(3,1)/3*.33333333333333333333333
cparallel     * 33E0/, W(4,1), W(5,1) /.225E0,.3786109120031468330830822E-1/,
cparallel     * W(1,2), W(2,2), W(3,2) /.7974269853530873223980253E0,2*
cparallel     * .1012865073234563388009874E0/, W(4,2), W(5,2)
cparallel     * /.3778175416344814577870518E0,.1128612762395489164329420E0/,
cparallel     * W(1,3), W(2,3), W(3,3) /.5971587178976982045911758E-1,2*
cparallel     * .4701420641051150897704412E0/, W(4,3), W(5,3)
cparallel     * /.3971824583655185422129482E0,.2350720567323520126663380E0/
cparallel      DATA W(1,4), W(2,4), W(3,4) /.5357953464498992646629509E0,2*
cparallel     * .2321023267750503676685246E0/, W(4,4), W(5,4)
cparallel     * /0.E0,.3488144389708976891842461E0/, W(1,5), W(2,5), W(3,5)
cparallel     * /.9410382782311208665596304E0,2*.2948086088443956672018481E-1/,
cparallel     * W(4,5), W(5,5) /0.E0,.4033280212549620569433320E-1/, W(1,6),
cparallel     * W(2,6), W(3,6) /.7384168123405100656112906E0,
cparallel     * .2321023267750503676685246E0,.2948086088443956672018481E-1/,
cparallel     * W(4,6), W(5,6) /0.E0,.2250583347313904927138324E0/
cparallel
C
      dzero=0.d0
      done=1.d0
      dthree=3.d0
      dsix=6.d0
      point5=.5d0
cparallel      DATA DZERO /0.D0/, DONE /1.D0/, DTHREE /3.D0/, DSIX /6.D0/,
cparallel     * POINT5 /.5E0/
C
C       SCALE BASE VECTORS AND OBTAIN AREA
      DO 20 I=1,2
        ORIGIN(I) = VEC(I,3) + P(1)*VEC(I,1) + P(2)*VEC(I,2)
        DO 10 J=1,2
          TVEC(I,J) = P(3)*VEC(I,J)
   10   CONTINUE
   20 CONTINUE
      AREA = POINT5*ABS(TVEC(1,1)*TVEC(2,2)-TVEC(1,2)*TVEC(2,1))
      A1 = DZERO
      A2 = DZERO
C
C       COMPUTE ESTIMATES FOR INTEGRAL AND ERROR
      DO 40 K=1,NQUAD
        X = ORIGIN(1) + W(1,K)*TVEC(1,1) + W(2,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(1,K)*TVEC(2,1) + W(2,K)*TVEC(2,2)
        S = (F(X,Y,IDATA,RDATA))
        SN = DONE
        IF (W(1,K).EQ.W(2,K)) GO TO 30
        X = ORIGIN(1) + W(2,K)*TVEC(1,1) + W(1,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(2,K)*TVEC(2,1) + W(1,K)*TVEC(2,2)
        S = S + (F(X,Y,IDATA,RDATA))
        X = ORIGIN(1) + W(2,K)*TVEC(1,1) + W(3,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(2,K)*TVEC(2,1) + W(3,K)*TVEC(2,2)
        S = S + (F(X,Y,IDATA,RDATA))
        SN = DTHREE
        IF (W(2,K).EQ.W(3,K)) GO TO 30
        X = ORIGIN(1) + W(1,K)*TVEC(1,1) + W(3,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(1,K)*TVEC(2,1) + W(3,K)*TVEC(2,2)
        S = S + (F(X,Y,IDATA,RDATA))
        X = ORIGIN(1) + W(3,K)*TVEC(1,1) + W(1,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(3,K)*TVEC(2,1) + W(1,K)*TVEC(2,2)
        S = S + (F(X,Y,IDATA,RDATA))
        X = ORIGIN(1) + W(3,K)*TVEC(1,1) + W(2,K)*TVEC(1,2)
        Y = ORIGIN(2) + W(3,K)*TVEC(2,1) + W(2,K)*TVEC(2,2)
        S = S + (F(X,Y,IDATA,RDATA))
        SN = DSIX
   30   S = S/SN
        A1 = A1 + W(4,K)*S
        A2 = A2 + W(5,K)*S
   40 CONTINUE
      P(4) = (A1)*AREA
      P(5) = (A2)*AREA
      P(6) = ABS(P(5)-P(4))
      RETURN
      END


SUBROUTINE DSYEVD_F95( A, W, JOBZ, UPLO, INFO )
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: ERINFO, LSAME
   USE F77_LAPACK, ONLY: SYEVD_F77 => LA_SYEVD, ILAENV_F77 => ILAENV
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. CHARACTER ARGUMENTS ..
   CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOBZ, UPLO
!  .. SCALAR ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(INOUT) :: A(:,:)
   REAL(WP), INTENT(OUT) :: W(:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!      LA_SYEV and LA_SYEVD compute all eigenvalues and, optionally, all
! eigenvectors of a real symmetric matrix A.
!      LA_HEEV and LA_HEEVD compute all eigenvalues and, optionally, all
! eigenvectors of a complex Hermitian matrix A.
!      LA_SYEVD and LA_HEEVD use a divide and conquer algorithm. If
! eigenvectors are desired, they can be much faster than LA_SYEV and
! LA_HEEV for large matrices but use more workspace.
!
! =========
!
!       SUBROUTINE LA_SYEV / LA_HEEV / LA_SYEVD / LA_HEEVD( A, W, &
!                       JOBZ=jobz, UPLO=uplo, INFO=info )
!           <type>(<wp>), INTENT(INOUT) :: A(:,:)
!           REAL(<wp>), INTENT(OUT) :: W(:)
!           CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: JOBZ, UPLO
!           INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!           <type> ::= REAL | COMPLEX
!           <wp> ::= KIND(1.0) | KIND(1.0D0)
!
!
! Arguments
! =========
!
! A      (input/output) REAL or COMPLEX square array, shape (:,:).
!        On entry, the matrix A.
!        If UPLO = 'U', the upper triangular part of A contains the upper
!        triangular part of the matrix A. If UPLO = 'L', the lower
!        triangular part of A contains the lower triangular part of the
!        matrix A.
!        On exit:
!        If JOBZ = 'V', then the columns of A contain the orthonormal
!        eigenvectors of the matrix A in the order of the eigenvalues.
!        If JOBZ = 'N', then the upper triangle (if UPLO = 'U') or the
!        lower triangle (if UPLO = 'L') of A, including the diagonal, is
!        destroyed.
! W      (output) REAL array, shape (:) with size(W) = size(A,1).
!        The eigenvalues in ascending order.
! JOBZ   Optional (input) CHARACTER(LEN=1).
!        = 'N': Computes eigenvalues only;
!        = 'V': Computes eigenvalues and eigenvectors.
!        Default value: 'N'.
! UPLO   Optional (input) CHARACTER(LEN=1).
!        = 'U': Upper triangle of A is stored;
!        = 'L': Lower triangle of A is stored.
!        Default value: 'U'.
! INFO   Optional (output) INTEGER.
!        = 0: successful exit.
!        < 0: if INFO = -i, the i-th argument had an illegal value
!        > 0: if INFO = i, then i off-diagonal elements of an
!        intermediate tridiagonal form did not converge to zero.
!        If INFO is not present and an error occurs, then the program is
!        terminated with an error message.
!-----------------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_SYEVD'
   CHARACTER(LEN=6), PARAMETER :: BSNAME = 'DSYTRD'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LJOBZ, LUPLO
   INTEGER :: N, LINFO, LD, ISTAT, ISTAT1, LIWORK, LMWORK, LWORK, NB
!  .. LOCAL ARRAYS ..
   REAL(WP), POINTER :: WORK(:)
   INTEGER, POINTER :: IWORK(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MAX, PRESENT
!  .. EXECUTABLE STATEMENTS ..
   N = SIZE( A, 1 ); LINFO = 0; LD = MAX(1,N); ISTAT = 0
   IF( PRESENT(JOBZ) ) THEN
      LJOBZ = JOBZ
   ELSE
      LJOBZ = 'N'
   END IF
   IF( PRESENT(UPLO) ) THEN
      LUPLO = UPLO
   ELSE
      LUPLO = 'U'
   END IF
!  .. TEST THE ARGUMENTS
   IF( SIZE( A, 2 ) /= N .OR. N < 0 )THEN
      LINFO = -1
   ELSE IF( SIZE( W ) /= N )THEN
      LINFO = -2
   ELSE IF( .NOT.LSAME(LJOBZ,'N') .AND. .NOT.LSAME(LJOBZ,'V') )THEN
      LINFO = -3
   ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN
      LINFO = -4
   ELSE IF( N > 0 )THEN
!  .. DETERMINE THE WORKSPACE
      IF( LSAME(LJOBZ,'V') )THEN
         LMWORK = 1+6*N+2*N**2
         LIWORK = 3+5*N
      ELSE
         LMWORK = 2*N+1
         LIWORK = 1
      END IF
      NB = ILAENV_F77( 1, BSNAME, LUPLO, N, -1, -1, -1 )
      IF( NB <= 1 .OR. NB >= N )THEN
         NB = 1
      END IF
      LWORK = MAX( LMWORK, (NB+2)*N )
      ALLOCATE(WORK(LWORK), IWORK(LIWORK), STAT=ISTAT)
      IF( ISTAT /= 0 )THEN
         DEALLOCATE(WORK, IWORK, STAT=ISTAT1)
         LWORK = LMWORK
         ALLOCATE(WORK(LWORK), IWORK(LIWORK), STAT=ISTAT)
         IF( ISTAT /= 0 ) THEN
            LINFO = - 100
         ELSE
            CALL ERINFO( -200, SRNAME, LINFO )
         ENDIF
      ENDIF
!
      IF( LINFO == 0 )THEN
!        .. CALL LAPACK77 ROUTINE
         CALL SYEVD_F77( LJOBZ, LUPLO, N, A, LD, W, WORK, LWORK, &
                         IWORK, LIWORK,  LINFO )
      ENDIF
      DEALLOCATE(WORK, IWORK, STAT=ISTAT1)
   ENDIF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE DSYEVD_F95


program IcosTrianglesTest
!******************************************************************************
!	Peter A. Bosler
!	Department of Mathematics
!	University of Michigan
!	pbosler@umich.edu
!
!******************************************************************************
!
!	This program is a unit test for a basic cubed sphere sphere, no time integration.
!
!	Bosler, P.A., "Particle Methods for Geophysical Flow on the Sphere," PhD Thesis; the University of Michigan, 2013.
!

!----------------
use NumberKindsModule
use LoggerModule
use SphereMeshModule
use ParticlesModule
use EdgesModule
use PanelsModule
use VTKOutputModule
use AdvectionModule

implicit none

type(SphereMesh) :: sphere
integer(kint) :: panelKind, initNest, AMR, nTracer, problemKind
type(Particles), pointer :: sphereParticles
type(Edges), pointer :: sphereEdges
type(Panels), pointer :: spherePanels

type(VTKSource) :: vtkOut
character(len=56) :: testVTKfile

type(Logger) :: exeLog
character(len=56) :: logString

integer(kint) :: j

!
!	set mesh parameters
!
	initNest = 5
	panelKind = 3
	AMR = 0
	nTracer = 1
	problemKind = ADVECTION_SOLVER
	call New(exeLog,DEBUG_LOGGING_LEVEL)

!
!	Build a mesh
!
	call New(sphere,panelKind,initNest,AMR,nTracer,problemKind)
	sphereParticles => sphere%particles
	sphereEdges => sphere%edges
	spherePanels => sphere%panels
	write(logString,'(A,I4,A)') 'Mesh at initNest = ',initNest,' returned : '
	call LogStats(sphere,exeLog,trim(logString))
	call LogMessage(exeLog,TRACE_LOGGING_LEVEL,'Surf. area should be = ',4.0_kreal*PI*EARTH_RADIUS*EARTH_RADIUS)
	write(6,'(A,F24.15)') "surf area error = ",abs(4.0_kreal*PI*EARTH_RADIUS*EARTH_RADIUS - sum(spherePanels%area))

!
!	Define VTKOutput
!
	write(testVTKFile,'(A,I1,A)') 'icosTriMesh',initNest,'.vtk'
	call New(vtkOut,sphere,testVTKFile,'test1')
	call vtkOutput(vtkOut,sphere)
	call LogMessage(exeLog,TRACE_LOGGING_LEVEL,'VTKOutput : ',' done.')

!
!	clean up
!
	call Delete(vtkOut)
	call Delete(sphere)
	call Delete(exeLog)

end program


program testquicksort
	integer lst(10)
	lst = (/ 10, 9, 8, 7, 6, 5, 4, 3, 2, 1 /)
	call quicksort(lst, 1, 10)
	call show(lst)
end program testquicksort

recursive subroutine quicksort(lst, start, end_)
	integer lst(10)
	integer start, end_
	integer pivot, i, tmp
	if (start .lt. end_) then
		pivot = start
		do i = start+1, end_
			if (lst(i) .le. lst(start)) then
				pivot = pivot + 1
				tmp = lst(pivot)
				lst(pivot) = lst(i)
				lst(i) = tmp
			end if
		end do
		tmp = lst(pivot)
		lst(pivot) = lst(start)
		lst(start) = tmp

		call quicksort(lst, start, pivot)
		call quicksort(lst, pivot+1, end_)
	end if
end

subroutine show(lst)
	integer lst(10)
	integer x
	do x = 1, 10
		print 100, lst(x)
	end do

100 format (i0)
end


program defectLoc
    use hdf5 !use the hdf5 dataset
!program that will:
!1. read in hd5 grid representing spin angles of xy model
!2. find and label all defects
!3. output this as another hdf5
!this is a seperate program (though I may make it a module). It would
!be more efficient to calculate this during run time to cut down on IO
!but, I think it is more valuable to have this seperate, so we can run it
! over and over again on the same data set.
implicit none

character(100) :: buffer
real(8), allocatable, dimension(:,:) :: grid, dgrid
real(8),parameter :: pi = 4*atan(1.0_8),  deltime=0.1

real(8) :: windingn, avedelphi, dcount, deltar, dvar

integer :: ii, i,j,t, N, NFiles

!hdf parameters

!character(len=8), parameter :: filename = "dsetf.h5" ! file name
character(100) :: datafileName
character(100) :: datasetFileName
character(100) :: dset_name

integer(hid_t) :: file_id, file_idout  ! file identifier
integer(hid_t) :: dset_id, dset_idout    ! dataset identifier
integer(hid_t) :: dspace_id, dspace_idout! dataspace identifier

integer(hsize_t), dimension(2) :: dims ! dataset dimensions

integer     ::   rank = 2                        ! dataset rank

integer     ::   error ! error flag
type(h5o_info_t), target :: infobuf
INTEGER(HSIZE_T), DIMENSION(2) :: data_dims
character(256), allocatable, dimension(:) :: dsetNames

call getarg(1,buffer)
read(buffer,"(A100)") datafileName

call getarg(2, buffer)
read (buffer, "(A100)") datasetFileName

call getarg(3,buffer)
read(buffer,*) N
data_dims(1) = N
data_dims(2) = N

call getarg(4, buffer)
read(buffer, *) NFiles

allocate(dsetNames(NFiles))
open(unit = 99, file = datasetFileName, status = 'old', action='read')
do i = 1, NFiles
    read(99,*) dsetNames(i)
    write(*,*) dsetNames(i)
enddo
!initialize file to output defect grids using hd5 format
!  ! initialize fortran interface.
!  !
call h5open_f(error)
!
!  !
!  ! create a new file using default properties.
!  !
  call h5fcreate_f('defectGrid.h5', h5f_acc_trunc_f, file_idout, error)
!

allocate(grid(N,N))
allocate(dgrid(N,N))
grid = -1
dgrid = 0
call h5open_f(error)
write(*,*) 'reading in'
!CALL h5dopen_f(datafileName, dsetname, dset_id, error)
write(*,*) dsetNames(10)
!open the hdf5 file
CALL h5fopen_f(datafileName, H5F_ACC_RDWR_F, file_id, error)
write(*,*) 'file open'
do ii = 1, NFiles
    write(*,*) trim(dsetNames(ii))

!iteratre through all the datasets
CALL h5dopen_f(file_id, dsetNames(ii), dset_id, error)

CALL h5dread_f(dset_id, H5T_NATIVE_double, grid, data_dims, error)
CALL h5dclose_f(dset_id, error)

!!hdf handling
!
!dims = (/n,n/)
!  !

!
        do i=1,n
            do j=1,n
!!            write(1,'(f10.5)',advance="no") acos(cos(grid(i,j)))
!!            measuredt = (hamxy(i,j,grid(i,j),kappa,mu))/n/n+measuredt
            windingn=(windn(grid(i,modulo(j-2,n)+1)-grid(i,j)))+&
                &(windn(grid(modulo(i,n)+1,modulo(j-2,n)+1)-grid(i,modulo(j-2,n)+1)))+&
                &(windn(grid(modulo(i,n)+1,j)-grid(modulo(i,n)+1,modulo(j-2,n)+1)))+&
                &(windn(grid(i,j)-grid(modulo(i,n)+1,j)))
            if (windingn .ge. 1) then
                dgrid(i,j) =1
            else if (-1*windingn .ge. 1) then
                dgrid(i,j)=-1
            else
                dgrid(i,j)=0
            endif
!!           write(3,'(f10.5)',advance="no") dgrid(i,j)
            enddo
!!            write(1,*)
!!            write(3,*)
        enddo
  !
  ! create the dataspace.
  !
  call h5screate_simple_f(rank, data_dims, dspace_idout, error)

  !
  ! create the dataset with default properties.
  !
  call h5dcreate_f(file_idout, dsetNames(ii), h5t_native_double, dspace_idout, &
       dset_idout, error)

  ! write the data
  call h5dwrite_f(dset_idout, h5t_native_integer, dgrid, dims, error)
  !
  ! end access to the dataset and release resources used by it.
  !
  call h5dclose_f(dset_idout, error)

  !
  ! terminate access to the data space.
  !
  call h5sclose_f(dspace_idout, error)
  enddo

call h5fclose_f(file_idout, error)
CALL h5fclose_f(file_id, error)

  !
  ! close fortran interface.
  !
call h5close_f(error)

write(*,*) 'finished langin'
deallocate(dgrid)
deallocate(grid)
contains

    function xi(grid,beta,n)
        integer :: n
        real(8), dimension(n,n) :: grid
        real(8) :: beta, xi
        xi = sum(grid**2)/n**2
    end function xi

    function hamxy(i,j,theta,kappa,mu)
        integer :: i,j,ii,jj
        real(8):: theta
        real(8) :: kappa,hamxy,mu
        real(8), dimension(3) :: x,y
        !write(*,*) 'hamxy', i,j
        x =(/ grid(modulo(i-2,n)+1,j),theta,grid(modulo(i,n)+1,j)/)
        y =(/ grid(i,modulo(j-2,n)+1),theta,grid(i,modulo(j,n)+1)/)
        hamxy = -kappa*(cos(x(2)-x(1))+cos(x(2)-x(3))+cos(y(2)-y(1))+cos(y(2)-y(3)))-mu*cos( (theta-45/2/pi) )
    end function hamxy

    function angledist(theta1,theta2)
        real(8) :: d1,d2,angledist,theta1,theta2
        angledist = acos(cos(theta1-theta2))
        end function angledist

    function windn(angle)
        real(8) :: angle, windn
        windn = (angle-asin(sin(angle))) / (pi)
        end function windn

function remove_dups(input)
  integer :: input(100)       ! the input
  integer :: remove_dups(size(input))  ! the output
  integer :: k                   ! the number of unique elements
  integer :: i, j

  k = 1
  remove_dups(1) = input(1)
  outer: do i=2,size(input)
     do j=1,k
        if (remove_dups(j) == input(i)) then
           ! found a match so start looking again
           cycle outer
        end if
     end do
     ! no match found so add it to the output
     k = k + 1
     remove_dups(k) = input(i)
  end do outer
  end function remove_dups
    function unique(input)
     !   find "indices", the list of unique numbers in "list"
     integer( kind = 4 ) :: kx, input(100)
     integer( kind = 4 ),allocatable :: unique(:)
     logical :: mask(100)
     mask(1)=.true.
     do kx=100,2,-1
       mask(kx)= .not.(any(input(:kx-1)==input(kx)))
     end do
     unique=pack([(kx,kx=1,100)],mask)
    end function unique
end program defectLoc


      REAL*8 FUNCTION CONST(INDEX)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE RETURNS VARIOUS CONSTANT VALUES AS INDICATED BY THE
C INDEX INPUT TO IT. IT ALSO HAS AN ENTRY POINT, CONST1, THAT ALLOWS
C CONSTANT VALUES TO BE REDEFINED.
C
C
C USAGE: THIS ROUTINE IS AN ALTERNATE WAY TO DEFINE CONSTANTS IN A
C        LARGE PROGRAM WITHOUT HARD CODING THEM OR USING COMMON BLOCKS.
C        A ROUTINE CAN CALL THIS ONE TO SET INTERNAL VARIABLES WHEN AN
C        INITIALIZATION FLAG INDICATES THAT THE ROUTINE HAS NOT SET ITS
C        CONSTANTS.
C
C      EXAMPLES:
C
C      1.  IN THE CALLING PROGRAM, WE WANT TO SET THE EARTH GRAVITATION
C          CONSTANT. IN THE CALLING PROGRAM, WE CODE
C
C                  EARTHMU = CONST(56)
C
C      2.  IN THE CALLING PROGRAM WE WANT TO REDEFINE THE EARTH
C          GRAVITATION CONSTANT SO THAT SUBSEQUENT CALLS TO CONST WILL
C          RETURN THE REPLACEMENT VALUE. WE RESET IT BY
C
C                  CALL CONST1(56,398602.D0)
C
C          SUBSEQUENT STATEMENTS  XX=CONST(56) RESULT IN XX BEING SET TO
C          398602.D0
C
C
C VARIABLE DIM TYPE I/O DESCRIPTION
C -------- --- ---- --- -----------
C
C INDEX     1  I*4   I  THE INDEX DESCRIBING THE QUANTITY INVOLVED.
C
C                       ASSIGNMENTS ARE:
C
C                        1 PI
C                        2 PI/2
C                        3 2*PI
C                        4 DEGREES PER RADIAN(=57.29.....)
C                        5 KILOMETERS PER NAUTICAL MILE
C                        6 KILOMETERS PER INTERNATIONAL FOOT
C                        7 KILOMETERS PER LIGHT YEAR
C                        8 NEWTONS PER POUND(FORCE)
C                        9-50 NO USED
C                       51 EARTH RADIUS FOR GRAVITY COMPUTATIONS. IN KM.
C                       52 EARTH RADIUS FOR SCALING LENGTHS FROM
C                          KM TO EARTH RADII. IN KM.
C                       53 EARTH RADIUS AT THE EQUATOR. IN KM.
C                       54 SUN RADIUS. IN KM.
C                       55 LUNAR RADIUS(MEAN). IN KM.
C                       56 EARTH GRAVITATIONAL PARAMETER. KM**3/SEC**2.
C                       57 SUN GRAVITATIONAL PARAMETER. KM**3/SEC**2.
C                       58 MOON GRAVITATIONAL PARAMETER. KM**3/SEC**2.
C                       59 EARTH FLATTENING COEFFICIENT
C                       60 ASTRONOMICAL UNIT FOR ANALYTIC EPHEMERIS
C                          COMPUTATIONS. IN KM.
C                       61-63 GSFC LOCATION(APPROX).  LAT, LONG, HGT.
C                          IN RADIANS AND KM.
C                       64 ROTATION RATE OF THE EARTH. NON-PRECESSING
C                          FRAME. IN RADIANS/SEC.
C                       65 ROTATION RATE OF THE EARTH. PRECESSING
C                          FRAME. IN RADIANS/SEC.
C                       66 VELOCITY OF LIGHT IN A VACUUM. IN KM/SEC.
C
C                       67-100 NOT USED.
C
C CONST     1  R*8   O  THE VALUE ASSIGNED TO THIS FUNCTION SUBROUTINE.
C
C VALUE     1  R*8   I  THE VALUE TO BE ASSIGNED TO THE PARAMETER
C                       IDENTIFIED BY INDEX. USED FOR ENTRY POINT CONST1
C
C***********************************************************************
C
C  SOURCES :
C
C     1. SHUTTLE OPERATIONAL DATA BOOK.
C        VOLUME 1, SHUTTLE SYSTEMS PERFORMANCE AND CONSTRAINTS DATA
C        JSC 08934, VOL 1, REVISION C AND UPDATES AS OF 10/3/83.
C     2. EXPLANATORY SUPPLEMENT TO THE EPHEMERIS. 1974 REPRINT OF 1961
C        EDITION. GSFC LIBIRARY NUMBER QB8.U5, E96.
C     3. NASA SP-7012: THE INTERNATIONAL SYSTEM OF UNITS. (1964)
C
C**********************************************************************
C
C  BY C PETRUZZO, 11/83.
C    MODIFIED....  CJP 4/85. ADDED CONSTANT NUMBER 8.
C
C**********************************************************************
C
      PARAMETER NCONSTS = 100
      REAL*8 CONSVAL(NCONSTS)/ NCONSTS*-999.D0 /
C
      INTEGER INIT/1/
C
      KEY = 1
      GO TO 10
C
C
      ENTRY CONST1(INDEX,VALUE)
      KEY = 2
C
   10 CONTINUE
C
      IF(INIT.NE.1) GO TO 500
C
C***********************************************************************
C
C
C ********************
C *                  *
C *  INITIALIZATION  *
C *                  *
C ********************
C
      INIT=0
C
C   PI
C
      PI = DACOS(-1.D0)
      CONSVAL(1) = PI
C
C   PI/2
C
      CONSVAL(2) = PI/2.D0
C
C   2*PI
C
      CONSVAL(3) = PI+PI
C
C   DEGREES PER RADIAN
C
      DEGRAD = 180.D0/PI
      CONSVAL(4) = DEGRAD
C
C   NUMBER OF KM PER NAUTICAL MILE
C
      CONSVAL(5) = 1.852D0  ! JSC 08934, VOL I, P 8.5-1
C
C   NUMBER OF KM PER INTERNATIONAL FOOT
C
      CONSVAL(6) = 0.3048D-3    ! JSC 08934, VOL I, P 8.5-1
C
C   NUMBER OF KM PER LIGHT YEAR
C
      SECCENT = 36525.D0 * 86400.D0
      VLIGHT = 299792.5D0 ! JSC 08934, VOL I, P 8.1-4
      CONSVAL(7) = VLIGHT * SECCENT
C
C   NEWTONS PER POUND(FORCE)
C
      CONSVAL(8) = 4.4482216152605D0  ! NASA SP-7012
C
C
C
C
C   EARTH RADIUS FOR GRAVITATION COMPUTATIONS. IN KM.
C
      CONSVAL(51) = 6378.160D0  ! JSC 08934, VOL I, P 8.1-3
C
C   EARTH RADIUS FOR SCALING LENGTHS FROM KM TO EARTH RADII. IN KM.
C
      CONSVAL(52) = 6378.165D0 ! JSC 08934, VOL I, P 8.5-1
C
C   EARTH RADIUS AT THE EQUATOR. IN KM.
C
      CONSVAL(53) = 6378.166D0  ! JSC 08934, VOL I, P 8.4-1
C
C   SUN RADIUS. IN KM.
C
      CONSVAL(54) = 696000.D0   ! EPHEMERIS SUPPLEMENT, P 489
C
C   LUNAR RADIUS(MEAN). IN KM.
C
      CONSVAL(55) = 1738.090D0   ! JSC 08934, VOL I, P 8.1-3
C
C   EARTH GRAVITATIONAL PARAMETER. IN KM**3/SEC**2.
C
      CONSVAL(56) = 398601.2D0 ! JSC 08934, VOL I, P 8.1-3
C
C   SUN GRAVITATIONAL PARAMETER. IN KM**3/SEC**2.
C
      CONSVAL(57) = 1.32712499D11  ! JSC 08934, VOL I, P 8.1-4
C
C   MOON GRAVITATIONAL PARAMETER. IN KM**3/SEC**2.
C
      CONSVAL(58) = 4902.78D0      ! JSC 08934, VOL I, P 8.1-4
C
C   EARTH FLATTENING COEFFICIENT
C
      CONSVAL(59) = 1.D0 / 298.3D0   ! JSC 08934, VOL I, P 8.4-1
C
C   ASTRONOMICAL UNIT FOR ANALYTIC EPHEMERIS COMPUTATIONS. IN KM.
C
      CONSVAL(60) = 149.6D6  ! EPHEMERIS SUPPLEMENT, P 498
C
C   GSFC LOCATION(APPROX). IN RADIANS AND KM.
C
      CONSVAL(61) =  39.D0/DEGRAD   ! LAT.  FROM APOLLO-ERA STDN DATA.
      CONSVAL(62) = 283.D0/DEGRAD   ! LONG.
      CONSVAL(63) = 0.D0            ! HGT.
C
C   ROTATION RATE OF THE EARTH. IN RADIANS/SEC.
C
      CONSVAL(64) = ERTROT(0.D0,0)   ! RELATIVE TO NON-PRECESSING FRAME
      CONSVAL(65) = ERTROT(0.D0,1)   ! RELATIVE TO PRECESSING FRAME
C
C   VELOCITY OF LIGHT IN A VACUUM. IN KM/SEC.
C
      CONSVAL(66) = VLIGHT
C
C
C***********************************************************************
C
C
  500 CONTINUE
C
C
C ERROR CHECK:
      IF(INDEX.LT.1 .OR. INDEX.GT.NCONSTS) THEN
        STOP ' ERROR END FROM CONST. BAD INDEX VALUE.'
        END IF
C
C
      IF(KEY.EQ.1) THEN
C
C       *************************************
C       *  RETURN A CONSTANT TO THE CALLER  *
C       *************************************
C
        CONST = CONSVAL(INDEX)
        END IF
C
C
      IF(KEY.EQ.2) THEN
C
C       *************************
C       *  REDEFINE A CONSTANT  *
C       *************************
C
        CONSVAL(INDEX) = VALUE
        END IF
C
C
      RETURN
      END


       subroutine dinfo1(n,iout,a,ja,ia,valued,
     *		          title,key,type,ao,jao,iao)
	implicit real*8 (a-h,o-z)
        real*8 a(*),ao(*)
        integer ja(*),ia(n+1),jao(*),iao(n+1),nzdiag
        character title*72,key*8,type*3
        logical valued
c----------------------------------------------------------------------c
c  SPARSKIT:  ELEMENTARY INFORMATION ROUTINE.                          c
c----------------------------------------------------------------------c
c info1 obtains a number of statistics on a sparse matrix and writes   c
c it into the output unit iout. The matrix is assumed                  c
c to be stored in the compressed sparse COLUMN format sparse a, ja, ia c
c----------------------------------------------------------------------c
c Modified Nov 1, 1989. 1) Assumes A is stored in column
c format. 2) Takes symmetry into account, i.e., handles Harwell-Boeing
c            matrices correctly.
c          ***  (Because of the recent modification the words row and
c            column may be mixed-up at occasions... to be checked...
c
c bug-fix July 25: 'upper' 'lower' mixed up in formats 108-107.
c
c On entry :
c-----------
c n	= integer. column dimension of matrix
c iout  = integer. unit number where the information it to be output.
c a	= real array containing the nonzero elements of the matrix
c	  the elements are stored by columns in order
c	  (i.e. column i comes before column i+1, but the elements
c         within each column can be disordered).
c ja	= integer array containing the row indices of elements in a
c ia	= integer array containing of length n+1 containing the
c         pointers to the beginning of the columns in arrays a and ja.
c	  It is assumed that ia(*) = 1 and ia(n+1) = nzz+1.
c
c valued= logical equal to .true. if values are provided and .false.
c         if only the pattern of the matrix is provided. (in that
c         case a(*) and ao(*) are dummy arrays.
c
c title = a 72-character title describing the matrix
c         NOTE: The first character in title is ignored (it is often
c         a one).
c
c key   = an 8-character key for the matrix
c type  = a 3-character string to describe the type of the matrix.
c         see harwell/Boeing documentation for more details on the
c         above three parameters.
c
c on return
c----------
c 1) elementary statistics on the matrix is written on output unit
c    iout. See below for detailed explanation of typical output.
c 2) the entries of a, ja, ia are sorted.
c
c----------
c
c ao	= real*8 array of length nnz used as work array.
c jao	= integer work array of length max(2*n+1,nnz)
c iao   = integer work array of length n+1
c
c Note  : title, key, type are the same paramaters as those
c         used for Harwell-Bowing matrices.
c
c-----------------------------------------------------------------------
c Output description:
c--------------------
c *** The following info needs to be updated.
c
c + A header containing the Title, key, type of the matrix and, if values
c   are not provided a message to that effect.
c    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c    * SYMMETRIC STRUCTURE MEDIEVAL RUSSIAN TOWNS
c    *                    Key = RUSSIANT , Type = SSA
c    * No values provided - Information of pattern only
c    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c +  dimension n, number of nonzero elements nnz, average number of
c    nonzero elements per column, standard deviation for this average.
c +  if the matrix is upper or lower triangular a message to that effect
c    is printed. Also the number of nonzeros in the strict upper
c    (lower) parts and the main diagonal are printed.
c +  weight of longest column. This is the largest number of nonzero
c    elements in a column encountered. Similarly for weight of
c    largest/smallest row.
c +  lower dandwidth as defined by
c          ml = max ( i-j, / all  a(i,j).ne. 0 )
c +  upper bandwidth as defined by
c          mu = max ( j-i, / all  a(i,j).ne. 0 )
c    NOTE that ml or mu can be negative. ml .lt. 0 would mean
c    that A is confined to the strict upper part above the diagonal
c    number -ml. Similarly for mu.
c
c +  maximun bandwidth as defined by
c    Max (  Max [ j ; a(i,j) .ne. 0 ] - Min [ j ; a(i,j) .ne. 0 ] )
c     i
c +  average bandwidth = average over all columns of the widths each column.
c
c +  If there are zero columns /or rows a message is printed
c    giving the number of such columns/rows.
c
c +  matching elements in A and transp(A) :this counts the number of
c    positions (i,j) such that if a(i,j) .ne. 0 then a(j,i) .ne. 0.
c    if this number is equal to nnz then the matrix is symmetric.
c +  Relative symmetry match : this is the ratio of the previous integer
c    over nnz. If this ratio is equal to one then the matrix has a
c    symmetric structure.
c
c +  average distance of a given element from the diagonal, standard dev.
c    the distance of a(i,j) is defined as iabs(j-i).
c
c +  Frobenius norm of A
c    Frobenius norm of 0.5*(A + transp(A))
c    Frobenius norm of 0.5*(A - transp(A))
c    these numbers provide information on the degree of symmetry
c    of the matrix. If the norm of the nonsymmetric part is
c    zero then the matrix is symmetric.
c
c + 90% of matrix is in the band of width k, means that
c   by moving away and in a symmetric manner from the main
c   diagonal you would have to include exactly k diagonals
c   (k is always odd), in order to include 90% of the nonzero
c   elements of A.  The same thing is then for 80%.
c
c + The total number of nonvoid diagonals, i.e., among the
c   2n-1 diagonals of the matrix which have at least one nonxero
c   element.
c
c +  Most important diagonals. The code selects a number of k
c    (k .le. 10) diagonals that are the most important ones, i.e.
c    that have the largest number of nonzero elements. Any diagonal
c    that has fewer than 1% of the nonzero elements of A is dropped.
c    the numbers printed are the offsets with respect to the
c    main diagonal, going from left tp right.
c    Thus 0 means the main diagonal -1 means the subdiagonal, and
c    +10 means the 10th upper diagonal.
c +  The accumulated percentages in the next line represent the
c    percentage of the nonzero elements represented by the diagonals
c    up the current one put together.
c    Thus:
c    *  The 10 most important diagonals are (offsets)    :             *
c    *     0     1     2    24    21     4    23    22    20    19     *
c    *  The accumulated percentages they represent are   :             *
c    *  40.4  68.1  77.7  80.9  84.0  86.2  87.2  88.3  89.4  90.4     *
c    *-----------------------------------------------------------------*
c    shows the offsets of the most important  diagonals and
c    40.4 represent ratio of the number of nonzero elements in the
c    diagonal zero (main diagonal) over the total number of nonzero
c    elements. the second number indicates that the diagonal 0 and the
c    diagonal 1 together hold 68.1% of the matrix, etc..
c
c +  Block structure:
c    if the matrix has a block structure then the block size is found
c    and printed. Otherwise the info1 will say that the matrix
c    does not have a block structure. Note that block struture has
c    a very specific meaning here. the matrix has a block structure
c    if it consists of square blocks that are dense. even if there
c    are zero elements in the blocks  they should be represented
c    otherwise it would be possible to determine the block size.
c
c-----------------------------------------------------------------------
	real*8 dcount(20),amx
	integer ioff(20)
	character*61 tmpst
	logical sym
c-----------------------------------------------------------------------
	data ipar1 /1/
	write (iout,99)
        write (iout,97) title(2:72), key, type
 97     format(2x,' * ',a71,' *'/,
     *         2x,' *',20x,'Key = ',a8,' , Type = ',a3,25x,' *')
	if (.not. valued) write (iout,98)
 98    format(2x,' * No values provided - Information on pattern only',
     *   23x,' *')
c---------------------------------------------------------------------
	nnz = ia(n+1)-ia(1)
	sym = ((type(2:2) .eq. 'S') .or. (type(2:2) .eq. 'Z')
     *    .or. (type(2:2) .eq. 's') .or. (type(2:2) .eq. 'z'))
c
        write (iout, 99)
        write(iout, 100) n, nnz
	job = 0
	if (valued) job = 1
	ipos = 1
        call csrcsc(n, job, ipos, a, ja, ia, ao, jao, iao)
        call csrcsc(n, job, ipos, ao, jao, iao, a, ja, ia)
c-------------------------------------------------------------------
c computing max bandwith, max number of nonzero elements per column
c min nonzero elements per column/row, row/column diagonal dominance
c occurences, average distance of an element from diagonal, number of
c elemnts in lower and upper parts, ...
c------------------------------------------------------------------
c    jao will be modified later, so we call skyline here
          call skyline(n,sym,ja,ia,jao,iao,nsky)
          call nonz_lud(n,ja,ia,nlower, nupper, ndiag)
          call avnz_col(n,ja,ia,iao, ndiag, av, st)
c------ write out info ----------------------------------------------
	  if (sym)  nupper = nlower
          write(iout, 101) av, st
          if (nlower .eq. 0 ) write(iout, 105)
 1        if (nupper .eq. 0) write(iout, 106)
          write(iout, 107) nlower
          write(iout, 108) nupper
          write(iout, 109) ndiag
c
          call nonz(n,sym, ja, ia, iao, nzmaxc, nzminc,
     *                  nzmaxr, nzminr, nzcol, nzrow)
          write(iout, 1020) nzmaxc, nzminc
c
	  if (.not. sym) write(iout, 1021) nzmaxr, nzminr
c
	  if (nzcol .ne. 0) write(iout,116) nzcol
	  if (nzrow .ne. 0) write(iout,115) nzrow
c
          call diag_domi(n,sym,valued,a, ja,ia,ao, jao, iao,
     *                           ddomc, ddomr)
c-----------------------------------------------------------------------
c symmetry and near symmetry - Frobenius  norms
c-----------------------------------------------------------------------
          call frobnorm(n,sym,a,ja,ia,Fnorm)
          call ansym(n,sym,a,ja,ia,ao,jao,iao,imatch,av,fas,fan)
          call distaij(n,nnz,sym,ja,ia,dist, std)
          amx = 0.0d0
          do 40 k=1, nnz
            amx = max(amx, abs(a(k)) )
 40       continue
          write (iout,103) imatch, av, dist, std
          write(iout,96)
          if (valued) then
             write(iout,104) Fnorm, fas, fan, amx, ddomr, ddomc
             write (iout,96)
          endif
c-----------------------------------------------------------------------
c--------------------bandedness- main diagonals ----------------------- -
c-----------------------------------------------------------------------
	n2 = n+n-1
	do 8 i=1, n2
             jao(i) = 0
 8        continue
          do 9 i=1, n
             k1 = ia(i)
             k2 = ia(i+1) -1
             do 91 k=k1, k2
                j = ja(k)
                jao(n+i-j) = jao(n+i-j) +1
 91          continue
 9        continue
c
          call bandwidth(n,ja, ia, ml, mu, iband, bndav)
c
c     write bandwidth information .
c
          write(iout,117)  ml, mu, iband, bndav
c
          write(iout,1175) nsky
c
c         call percentage_matrix(n,nnz,ja,ia,jao,90,jb2)
c         call percentage_matrix(n,nnz,ja,ia,jao,80,jb1)
          nrow = n
          ncol = n
          call distdiag(nrow,ncol,ja,ia,jao)
          call bandpart(n,ja,ia,jao,90,jb2)
          call bandpart(n,ja,ia,jao,80,jb1)
          write (iout,112) 2*jb2+1, 2*jb1+1
c-----------------------------------------------------------------
          nzdiag = 0
          n2 = n+n-1
          do 42 i=1, n2
             if (jao(i) .ne. 0) nzdiag=nzdiag+1
 42       continue
          call n_imp_diag(n,nnz,jao,ipar1, ndiag,ioff,dcount)
          write (iout,118) nzdiag
          write (tmpst,'(10i6)') (ioff(j),j=1,ndiag)
          write (iout,110) ndiag,tmpst
          write (tmpst,'(10f6.1)')(dcount(j), j=1,ndiag)
          write (iout,111) tmpst
          write (iout, 96)
c     jump to next page -- optional //
c     write (iout,'(1h1)')
c-----------------------------------------------------------------------
c     determine block size if matrix is a block matrix..
c-----------------------------------------------------------------------
          call blkfnd(n, ja, ia, nblk)
          if (nblk .le. 1) then
             write(iout,113)
          else
             write(iout,114) nblk
          endif
          write (iout,96)
c
c---------- done. Next define all the formats --------------------------
c
 99    format (2x,38(2h *))
 96    format (6x,' *',65(1h-),'*')
c-----------------------------------------------------------------------
 100   format(
     * 6x,' *  Dimension N                                      = ',
     * i10,'  *'/
     * 6x,' *  Number of nonzero elements                       = ',
     * i10,'  *')
 101   format(
     * 6x,' *  Average number of nonzero elements/Column        = ',
     * f10.4,'  *'/
     * 6x,' *  Standard deviation for above average             = ',
     * f10.4,'  *')
c-----------------------------------------------------------------------
 1020       format(
     * 6x,' *  Weight of longest column                         = ',
     * i10,'  *'/
     * 6x,' *  Weight of shortest column                        = ',
     * i10,'  *')
 1021       format(
     * 6x,' *  Weight of longest row                            = ',
     * i10,'  *'/
     * 6x,' *  Weight of shortest row                           = ',
     * i10,'  *')
 117        format(
     * 6x,' *  Lower bandwidth  (max: i-j, a(i,j) .ne. 0)       = ',
     * i10,'  *'/
     * 6x,' *  Upper bandwidth  (max: j-i, a(i,j) .ne. 0)       = ',
     * i10,'  *'/
     * 6x,' *  Maximum Bandwidth                                = ',
     * i10,'  *'/
     * 6x,' *  Average Bandwidth                                = ',
     * e10.3,'  *')
 1175       format(
     * 6x,' *  Number of nonzeros in skyline storage            = ',
     * i10,'  *')
 103   format(
     * 6x,' *  Matching elements in symmetry                    = ',
     * i10,'  *'/
     * 6x,' *  Relative Symmetry Match (symmetry=1)             = ',
     * f10.4,'  *'/
     * 6x,' *  Average distance of a(i,j)  from diag.           = ',
     * e10.3,'  *'/
     * 6x,' *  Standard deviation for above average             = ',
     * e10.3,'  *')
 104   format(
     * 6x,' *  Frobenius norm of A                              = ',
     * e10.3,'  *'/
     * 6x,' *  Frobenius norm of symmetric part                 = ',
     * e10.3,'  *'/
     * 6x,' *  Frobenius norm of nonsymmetric part              = ',
     * e10.3,'  *'/
     * 6x,' *  Maximum element in A                             = ',
     * e10.3,'  *'/
     * 6x,' *  Percentage of weakly diagonally dominant rows    = ',
     * e10.3,'  *'/
     * 6x,' *  Percentage of weakly diagonally dominant columns = ',
     * e10.3,'  *')
 105        format(
     * 6x,' *  The matrix is lower triangular ...       ',21x,' *')
 106        format(
     * 6x,' *  The matrix is upper triangular ...       ',21x,' *')
 107        format(
     * 6x,' *  Nonzero elements in strict lower part            = ',
     * i10,'  *')
 108       format(
     * 6x,' *  Nonzero elements in strict upper part            = ',
     * i10,'  *')
 109       format(
     * 6x,' *  Nonzero elements in main diagonal                = ',
     * i10,'  *')
 110   format(6x,' *  The ', i2, ' most important',
     *	   ' diagonals are (offsets)    : ',10x,'  *',/,
     * 6x,' *',a61,3x,' *')
 111   format(6x,' *  The accumulated percentages they represent are ',
     * '  : ', 10x,'  *',/,
     * 6x,' *',a61,3x,' *')
c 111	format(
c     * 6x,' *  They constitute the following % of A             = ',
c     * f8.1,' %  *')
 112	format(
     * 6x,' *  90% of matrix is in the band of width            = ',
     * i10,'  *',/,
     * 6x,' *  80% of matrix is in the band of width            = ',
     * i10,'  *')
 113 	format(
     * 6x,' *  The matrix does not have a block structure ',19x,
     *    ' *')
 114 	format(
     * 6x,' *  Block structure found with block size            = ',
     * i10,'  *')
 115 	format(
     * 6x,' *  There are zero rows. Number of such rows         = ',
     * i10,'  *')
 116 	format(
     * 6x,' *  There are zero columns. Number of such columns   = ',
     * i10,'  *')
 118 	format(
     * 6x,' *  The total number of nonvoid diagonals is         = ',
     * i10,'  *')
c-------------------------- end of dinfo --------------------------
        return
        end


C Copyright (C) 2000, International Business Machines
C Corporation and others.  All Rights Reserved.
       SUBROUTINE MTERMS(KAPPA , B   , H, LAFLA , POLY ,
     *                   PNTINT, NIND, N, NEQCON, LPOLY, LPTINT)

*
*  ***********************************************************************
*  THIS SUBROUTINE COMPUTES THE TERMS OF THE QUADRATIC
*  INTERPOLATING POLYNOMIAL
*                     T         T
*      M(X)= KAPPA + G X + 0.5*X H X
*
*  USING FINITE DIFFERENCES, FOUND IN 'FG'
*
*  PARAMETERS:
*
*   N      (INPUT)  DIMENTION OF THE PROBLEM
*
*   NIND   (INPUT)  NUMBER OF INTERPOLATION POINTS
*
*   PNTINT (INPUT)  LIST OF  'NIND' DATA POINTS. THE I-TH POINT OCCUPIES
*                   POSITIONS ( I - 1 ) * N + 1 TO I * N.
*   POLY   (INPUT)  THE ARRAY CONTAINING COEFFICIENTS OF NEWTON FUNDAMENTAL
*                   POLYNOMIALS (AS COMPUTED BY 'NBUILD')
*   LAFLA  (INPUT)  THE ARRAY OF FINITE DIFFERENCES
*
*   NEQCON (INPUT)  NUMBER OF LINEARLY INDEP. EQUALITY CONSTRAINTS
*
*   KAPPA  (OUTPUT) THE CONSTANT TERM OF THE INTERPOLATION MODEL.
*
*   G      (OUTPUT) VECTOR OF THE LINEAR TERMS OF THE  INTERPOLATION MODEL.
*
*   H      (OUTPUT) MATRIX OF QUADRATIC TERMS OF THE  INTERPOLATION MODEL.
*
*  **************************************************************************
*

      DOUBLE PRECISION KAPPA, B(N), H(N,N), LAFLA(NIND),
     +                 POLY(LPOLY), PNTINT(LPTINT)

      INTEGER          NIND,N, LPOLY, LPTINT, NEQCON

C
C  LOCAL VARIABLES
C

      INTEGER          NP1, DD, NDD, NINDM1, NDMNP1,
     +                 I, J, K, KK, KM, JJ

       NP1    = N + 1
       DD     = (NP1)*(N+2)/2
       NDD    = DD-NP1
       NINDM1 = NIND  - 1
       NDMNP1 = NINDM1 - N

C
C  SET THE COEFFICIENT OF THE INTERPOLATION TO ZERO
C

       CALL RZRMAT(H, N, N)
       CALL RZRVEC(B, N)
C
C  COMPUTE THE CONSTANT TERM
C

C
C  INITIALIZE USING CONSTANT BLOCK
C
       KAPPA=LAFLA(1)*POLY(1)

C
C  UPDATE USING THE FINITE DIFFERENCES CORRESPONDING TO LINEAR BLOCK
C

       K=MIN(N-NEQCON,NINDM1)
       DO 10 J=1,K
         KAPPA = KAPPA + LAFLA(J+1)*POLY(2 + NP1*(J-1))
 10    CONTINUE

       IF (NIND.GT.NP1) THEN
C
C  UPDATE USING THE FINITE DIFF. CORRESPONDING TO QUADRATIC BLOCK
C
         K=MIN(NDD,NDMNP1)
         DO 20 J=1,K
           KAPPA = KAPPA + LAFLA(J+NP1)*POLY(2 + NP1*N + DD*(J-1))
 20      CONTINUE
       ENDIF

       DO 40 I = 1,N
C
C  COMPUTE DEGREE ONE TERMS
C
         IF (NIND.GT.1) THEN

C
C  UPDATE USING LINEAR BLOCK
C
           K=MIN(N-NEQCON,NINDM1)
           DO 50 J = 1,K
             B(I) = B(I) + LAFLA(J+1)*POLY(I + 2 + NP1*(J-1))
 50        CONTINUE
         ENDIF

         IF (NIND .GT.NP1) THEN
C
C  UPDATE USING QUADRATIC BLOCK
C
           K=MIN(NDD,NDMNP1)
           DO 60 J = 1,K
             B(I) = B(I) + LAFLA(J+NP1)*POLY(I + NP1*N + 2 + DD*(J-1))
 60        CONTINUE
         ENDIF

 40    CONTINUE

C
C  COMPUTE QUADRATIC TERMS USING QUADRATIC BLOCK
C

       IF (NIND.GT.NP1) THEN

C
C  POINTER TO FIRST QUADRATIC  BLOCK IN  'POLY'
C

         JJ = NP1*NP1 + 2

C
C  LOOP OVER THE NUMBER OF SECOND DEGREE POLYNOMIALS
C

         KM=MIN(NDD,NDMNP1)
         DO 80 J = 1,KM
           K=1
           DO 90 I = 1,N
C
C  UPDATE DIAGONAL ELEMENT
C
             H(I,I) = H(I,I) + 2.0D0*LAFLA(J+NP1)*
     +                         POLY(JJ+K-1+DD*(J-1))
             K=K+1
C
C  UPDATE OFF-DIAGONAL ELEMENTS
C
             DO 91 KK = I+1,N
               H(I,KK) = H(I,KK) + LAFLA(J+NP1)*POLY(JJ+K-1+DD*(J-1))
               H(KK,I) = H(I,KK)
               K=K+1
 91          CONTINUE
 90        CONTINUE
 80      CONTINUE
       ENDIF

       RETURN
       END


      function diskdens(r,z,psi)

      include 'commonblocks'
      real psi

c the truncation factor is derived assuming that the azimuthal velocity dist
c is gaussian with dispersion sigma_R * 2 omega/kappa, as per epicycle theory.

      if( idiskflag .eq. 0 ) then
         diskdens = 0
         return
      endif
      if( abs(z/zdisk) .gt. 30.) goto 99
      erfarg=(r-outdisk)/1.4142136/drtrunc
      if (erfarg.gt.4.) goto 99
      if (erfarg.lt.-4) then
         trunfac=1
      else
         trunfac=0.5*erfc(erfarg)
      endif

      if (z.eq.0.) then
         con=1
      elseif ( ihaloflag .eq. 0 .and. ibulgeflag .eq. 0 ) then
c only doing a disk potential
         con = exp(-abs(z/zdisk))
         con = (2.0*con/(1.0 + con*con))**2
      else
c     make disk vertically isothermal; normalize density so that
c     at height 3*zdisk the vertical density drop is that of a sech^2.
         psizh=pot(r,3*zdisk)
         psi00=pot(r,0.)
         dpsizh = psi00 - psizh
         dpsi   = psi00 - psi
         coeff = 0.0
         if( abs(dpsizh) .gt. 0.0) then
            coeff = dpsi/dpsizh
         endif
         if( coeff .gt. 16. .or. coeff .lt. 0.0 ) then
            con = 0.0
         else
            con = 0.009866**coeff
         endif
      endif
      diskdens = diskconst*exp(-r/rdisk)*con*trunfac
      return
 99   diskdens=0.0
      return
      end


subroutine flatten

! Flaten looks for signs of strong shocks and sets the variable flat
! between 0.0 (smooth flow) and 1.0 (strong shock).
! Simplified method of C&W: eqn. A.1 and A.2.
!-----------------------------------------------------------------------

! GLOBALS
use global
use sweeps

IMPLICIT NONE

! LOCALS
INTEGER :: n
REAL(kind=8), DIMENSION(maxsweep) :: steep
REAL(kind=8) :: delp1, delp2, shock, temp1, temp2, old_flat
                                    ! use the numbers below for more aggresive flattening
REAL(kind=8), PARAMETER :: omega1 = 0.75    ! 0.5
REAL(kind=8), PARAMETER :: omega2 = 5.0     ! 10.0
REAL(kind=8), PARAMETER :: epsilon = 0.33   ! 1.00

!--------------------------------------------------------------------------
! Look for presence of a shock using pressure gradient and sign of
! velocity jump:  shock = 1 if there is a shock in the zone, else shock = 0
! Compute steepness parameter based on steepness of pressure jump IF
! there is a shock.

do n = nmin-4, nmax+4
  delp1 = p(n+1) - p(n-1)
  delp2 = p(n+2) - p(n-2)
  if(abs(delp2) < small) delp2 = small
  shock = abs(delp1)/min(p(n+1),p(n-1))-epsilon
  shock = max(0.0,shock)
  if(shock > 0.0) shock = 1.0
  if(u(n-1) < u(n+1)) shock = 0.0
  temp1 = ( delp1 / delp2 - omega1 ) * omega2
  steep(n) = shock * max( 0., temp1 )
enddo

! Set phony boundary conditions for the steepness parameter

steep(nmin-5) = steep(nmin-4)
steep(nmax+5) = steep(nmax+4)

! Set flatening coefficient based on the steepness in nieghboring zones

flat = 0.0
do n = nmin-4, nmax+4
  temp2   = max( steep(n-1), steep(n), steep(n+1) )
  flat(n) = max( 0.0, min( 0.5, temp2 ) )
enddo

! flat(n) should be set to old_flat if no shock in this direction

do n = nmin-3, nmax+3
  old_flat = f(n) - int(f(n))
  if (flat(n) > 0.0) then
    flat(n) = max(flat(n),old_flat)
    f(n)    = max(flat(n) + (2.0*ndim-3.0), 0.0)   ! f(n)=0 for 1D, 1.f for 2D, 3.f for 3D
   else
    f(n)    = max(0.0, f(n) - 1.0)
    flat(n) = old_flat
  endif
enddo

return
end


module QUATUTIL
  ! utilities for dealing with quaternions
  ! and other representations of rotation
  ! including euler angles, rotation matrices, and alpha + gamma and z-axis-vector representations

  implicit none
  LOGICAL :: TESTQUAT = .FALSE.
  real(dp), PARAMETER :: PI = 3.141592653589793D0
  ! when z1^2 + z2^2 goes below tiny when working with alpha + gamma & zvec coordinates
  ! use the v->0 approximation
  real(dp), PARAMETER :: NZTinY = 1D-14

  ! definition of a quaternion class
  TYPE QUATERNION
     real(dp) :: W, X, Y, Z
  END TYPE QUATERNION

  inTERFACE OPERATOR (*)
     module PROCEDURE QPRODUCT
  END inTERFACE

  inTERFACE OPERATOR (/)
     module PROCEDURE QDIVIDE
  END inTERFACE

contains
  subroutine QUAT2SCREW(QUAT,TRANS,HELCRD)
    ! convert from a rotation + translation to screw coordinates
    ! (equivalently to overall helix coordinates)
    ! returns height, angle, radius, orientation of
    ! canonical system relative to helix system (3 euler angles)
    TYPE(QUATERNION), intent(in) :: QUAT
    real(dp), intent(in) :: TRANS(3)
    real(dp), intent(out) :: HELCRD(6)
    real(dp) :: THETA, AX(3), TP(3), ST2, CT2, AXT3, A, B, G, NP, NTP

    ! angle-axis representation from quaternion
    THETA = 2*ACOS(QUAT%W)

    if (THETA == 0D0) then ! translation only
       HELCRD(1) = SQRT(doT_PRODUCT(TRANS,TRANS))
       HELCRD(2) = 0D0
       HELCRD(3) = 0D0
       HELCRD(4:6) = (/0D0,0D0,0D0/)
       RETURN
    ENDif

    ! angle of rotation around screw axis
    HELCRD(2) = THETA

    AX = (/QUAT%X,QUAT%Y,QUAT%Z/);
    ST2 = Sin(THETA/2)
    AX = AX/ST2; ! normalize the axis

    ! shift along screw axis
    HELCRD(1) = doT_PRODUCT(TRANS,AX)

    ! translation in plane perpendicular to axis
    TP = TRANS - HELCRD(1)*AX
    NTP = SQRT(doT_PRODUCT(TP,TP))

    ! radius of screw
    NP = NTP/(2*ST2)
    HELCRD(3) = NP

    ! cross-product of AX x TP
    AXT3 = AX(1)*TP(2) - AX(2)*TP(1)

    ! euler angles of screw axis coord system relative to canonical
    A = atan2(AX(1),-AX(2))
    B = ACOS(AX(3))
    CT2 = QUAT%W/ST2
    G = ATAN2(-TP(3)-CT2*AXT3,-AXT3 + CT2*TP(3))

    ! euler angles of canonical system relative to screw axis
    HELCRD(4:6) = (/PI-G,B,PI-A/)
  END subroutine QUAT2SCREW

  subroutine COORDS2QUAT(AG,ZVEC,Q)
    ! convert from an alpha + gamma angle and a vector along the z axis
    ! to a normalized quaternion
    ! note: this doesn't work if beta = pi
    implicit none
    real(dp), intent(in) :: AG, ZVEC(3)
    TYPE(QUATERNION) :: Q
    real(dp) :: NZ, ZAX(3), ALPHA,BETA,GAMMA

    NZ = SQRT(doT_PRODUCT(ZVEC,ZVEC))
    ZAX = ZVEC/NZ

    NZ = ZAX(1)**2 + ZAX(2)**2

    if (NZ == 0) then
       CALL EULER2QUAT((/AG,0D0,0D0/),Q)
    else
       ALPHA = ATAN2(ZAX(1),-ZAX(2)); GAMMA = AG-ALPHA
       BETA = ACOS(ZAX(3))
       CALL EULER2QUAT((/ALPHA,BETA,GAMMA/),Q)
    ENDif

  END subroutine COORDS2QUAT

  subroutine COORDS2ROTMAT(AG,ZVEC,MAT,DMATAG,DMATZ)
    ! convert from coordinates that include the alpha + gamma euler angle
    ! and a non-normalized vector along the Z axis in canonical reference system
    ! to a rotation matrix
    ! if DMATAG and DMATZ are provided, also get derivatives of all the matrix
    ! components wrt the coordinates

    implicit none
    real(dp), intent(in) :: AG, ZVEC(3)
    real(dp), intent(out) :: MAT(3,3)
    real(dp), intent(out), OPTIONAL :: DMATAG(3,3), DMATZ(3,3,3)
    real(dp) :: NZTOT2, NZTOT, NZ, Z1, Z2, Z3
    real(dp) :: Z11,Z22,Z12,Z13,Z23,CAG,SAG
    real(dp) :: DXDZ(3,3),DYDZ(3,3)

    if ((PRESENT(DMATAG).AND..NOT.PRESENT(DMATZ)).OR.&
         & (.NOT.PRESENT(DMATAG).AND.PRESENT(DMATZ))) then
       PRinT*, 'ERROR in COORDS2ROTMAT: neither or both of DMATAG and DMATZ must be provided'
       stop 1
    ENDif

    MAT = 0D0

    ! normalize the zaxis
    NZTOT2 = doT_PRODUCT(ZVEC,ZVEC); NZTOT = SQRT(NZTOT2)
    MAT(:,3) = ZVEC/NZTOT
    Z1 = MAT(1,3); Z2 = MAT(2,3);
    Z11 = Z1*Z1; Z22 = Z2*Z2;
    NZ = Z11 + Z22;
    Z3 = MAT(3,3)
    Z12 = Z1*Z2; Z23 = Z2*Z3; Z13 = Z1*Z3

    ! if (Z3 < -1D0 + SQRT(NZTinY)) then
    !    PRinT*, 'ERROR in COORDS2ROTMAT: have hit gimbal lock with Z axis pointing downward. Not set up to deal with this yet.'
    !    STOP 1
    ! ENDif

    CAG = COS(AG); SAG = Sin(AG)

    !if (TESTQUAT) PRinT*, 'TESTX1', NZ, NZTinY
    if (NZ < NZTinY) then
       if (ZVEC(3) < 0) then
          PRinT*, 'PROBLEM in COORDS2ROTMAT: some z-vector falls along the &
               & negative z axis. This causes gimbal lock. &
               & If working with a single nucleosome you may be able to &
               & avoid this by rotating the entire structure slightly, or &
               & by using RANDSTART to start the linker beads in different positions.'
          stop 1
       endif
       MAT(1,1) = CAG - (Z12*SAG + Z11*CAG)/2
       !if (testquat) print*, 'testx2:', mat(1,1)
       MAT(2,1) = SAG - (Z22*SAG + Z12*CAG)/2

       MAT(1,2) = -SAG + (Z11*SAG-Z12*CAG)/2
       MAT(2,2) = CAG-(Z22*CAG-Z12*SAG)/2
    else
       MAT(1,1) = (Z22*CAG-Z12*SAG + Z3*(Z12*SAG + Z11*CAG))/NZ
       MAT(2,1) = (-Z12*CAG + Z11*SAG + Z3*(Z22*SAG + Z12*CAG))/NZ

       MAT(1,2) = -(Z22*SAG + Z12*CAG + Z3*(-Z12*CAG + Z11*SAG))/NZ
       !if (testquat) print*, 'testx2:', mat(1,2)
       MAT(2,2) = (Z12*SAG + Z11*CAG + Z3*(Z22*CAG-Z12*SAG))/NZ
    ENDif
    MAT(3,1) = -Z2*SAG-Z1*CAG
    MAT(3,2) = -CAG*Z2 + SAG*Z1

    if (PRESENT(DMATZ)) then
       DMATZ = 0D0

       ! derivative of normalized z axis wrt ZVEC coordinates (transposed)
       DMATZ(:,3,1) = -ZVEC(1)*MAT(:,3)/NZTOT2 + (/1D0/NZTOT,0D0,0D0/)
       DMATZ(:,3,2) = -ZVEC(2)*MAT(:,3)/NZTOT2 + (/0D0,1D0/NZTOT,0D0/)
       DMATZ(:,3,3) = -ZVEC(3)*MAT(:,3)/NZTOT2 + (/0D0,0D0,1D0/NZTOT/)

       if (NZ < NZTinY) then

          DXDZ(1,1) = -Z2*SAG/2-Z1*CAG
          DXDZ(1,2) = -Z1*SAG/2
          DXDZ(2,1) = -Z2*CAG/2
          DXDZ(2,2) = -Z2*SAG-Z1*CAG/2
          DXDZ(:,3) = 0D0

          DYDZ(1,1) = Z1*SAG - Z2*CAG/2
          DYDZ(1,2) = -Z1*CAG/2
          DYDZ(2,1) = Z2*SAG/2
          DYDZ(2,2) = -Z2*CAG + Z1*SAG/2
          DYDZ(:,3) = 0D0
       else
          ! derivative wrt normalized z axis
          DXDZ(1,1) = (-Z2*SAG + Z23*SAG + 2*Z13*CAG-2*Z1*MAT(1,1))/NZ
          DXDZ(1,2) = (2*Z2*CAG-Z1*SAG + Z13*SAG-2*Z2*MAT(1,1))/NZ
          DXDZ(1,3) = (Z12*SAG + Z11*CAG)/NZ

          DXDZ(2,1) = (-Z2*CAG + 2*Z1*SAG + Z23*CAG - 2*MAT(2,1)*Z1)/NZ
          DXDZ(2,2) = (-Z1*CAG + 2*Z23*SAG + Z13*CAG-2*MAT(2,1)*Z2)/NZ
          DXDZ(2,3) = (Z22*SAG + Z12*CAG)/NZ

          DYDZ(1,1) = (-Z2*CAG + Z23*CAG-2*Z13*SAG-2*Z1*MAT(1,2))/NZ
          DYDZ(1,2) = (-2*Z2*SAG-Z1*CAG + Z13*CAG-2*Z2*MAT(1,2))/NZ
          DYDZ(1,3) = (Z12*CAG-Z11*SAG)/NZ

          DYDZ(2,1) = (Z2*SAG + 2*Z1*CAG-Z23*SAG-2*Z1*MAT(2,2))/NZ
          DYDZ(2,2) = (Z1*SAG + 2*Z23*CAG-Z13*SAG-2*Z2*MAT(2,2))/NZ
          DYDZ(2,3) = (Z22*CAG-Z12*SAG)/NZ
       ENDif
       DXDZ(3,:) = (/-CAG,-SAG,0D0/)
       DYDZ(3,:) = (/SAG,-CAG,0D0/)

       ! derivatives of new axes

       CALL DGEMM('N','N',3,3,3,1D0,DXDZ,3,DMATZ(:,3,:),3,0D0,DMATZ(:,1,:),3)
       CALL DGEMM('N','N',3,3,3,1D0,DYDZ,3,DMATZ(:,3,:),3,0D0,DMATZ(:,2,:),3)

       !CALL DGEMV('N',3,3,1D0,DZ,3,DMATZTMP(2,1,:),1,0D0,DMATZ(2,1,:),1)
       !DMATZ(2,1,:) = DXDZ
    ENDif

    if (PRESENT(DMATAG)) then
       DMATAG = 0D0

       if (NZ < NZTinY) then
          DMATAG(1,1) = -SAG-(Z12*CAG-Z11*SAG)/2
          DMATAG(2,1) = CAG-(Z22*CAG-Z12*SAG)/2

          DMATAG(1,2) = -CAG + (Z11*CAG + Z12*SAG)/2
          DMATAG(2,2) = -SAG + (Z22*SAG + Z12*CAG)/2
       else
          DMATAG(1,1) = (-Z22*SAG-Z1*Z2*CAG + Z1*Z23*CAG-Z3*Z11*SAG)/NZ
          DMATAG(2,1) = (Z12*SAG + Z11*CAG + Z3*Z22*CAG-Z1*Z23*SAG)/NZ

          DMATAG(1,2) = (-Z22*CAG + Z12*SAG-Z1*Z23*SAG-Z3*Z11*CAG)/NZ
          DMATAG(2,2) = (Z12*CAG-Z11*SAG-Z22*Z3*SAG-Z1*Z23*CAG)/NZ
       ENDif
       DMATAG(3,1) = -Z2*CAG + Z1*SAG ! dX3/dA
       DMATAG(3,2) = SAG*Z2 + CAG*Z1! dY3/dA
    ENDif
  END subroutine COORDS2ROTMAT

  ! ----------------- STUFF inVOLVinG TREATinG QUATERNIONS AS 4-VECTORS -----
  FUNCTION QUAT2QV(Q)
    ! convert a quaternion object to a 4-vector
    implicit none
    real(dp) :: QUAT2QV(4)
    TYPE(QUATERNION), intent(in) :: Q

    QUAT2QV = (/Q%W,Q%X,Q%Y,Q%Z/)
  END FUNCTION QUAT2QV

  subroutine ROTQV(THETA,AX,QV,DT)
    ! get the quaternion corresponding to rotation around axis AX by angle THETA
    ! as a 4-vector (in QV); optionally, also get the derivative wrt theta
    ! WARNinG: AX assumed to be normalized; does not check for this!

    implicit none
    real(dp), intent(in) :: THETA, AX(3)
    real(dp), intent(out) :: QV(4)
    real(dp), intent(out), OPTIONAL :: DT(4)
    real(dp) :: CT, ST

    CT = COS(THETA/2); ST = Sin(THETA/2);
    QV(1) = CT
    QV(2:4) = ST*AX

    if (PRESENT(DT)) then
       DT(1) = -ST/2
       DT(2:4) = CT/2*AX
    ENDif

  END subroutine ROTQV

  subroutine QVPTMULT(Q,PT,QP,DQ,DPT)
    ! multiply a quaternion by a point in 3-space
    ! returns the result in QP
    ! optionally, returns derivatives wrt the quaternion components in dQ
    ! or wrt point components in DPT
    ! WARNinG: no normalization happens here
    ! WARNinG: this is  a pretty inefficient way to do things; should fix at some point without resorting to rotation matrices
    implicit none
    real(dp), intent(in) :: Q(4),PT(3)
    real(dp), intent(out) :: QP(3)
    real(dp), intent(out), OPTIONAL :: DQ(3,4),DPT(3,3)
    real(dp) :: QN, QinV(4),QTMP(4),QTMP2(4)
    real(dp) :: MAT(3,3),DMAT(3,3,4)
    integer :: I,J
    TYPE(QUATERNION) :: QUAT

    QN = doT_PRODUCT(Q,Q)
    QUAT%W = Q(1); QUAT%X = Q(2); QUAT%Y = Q(3); QUAT%Z = Q(4)
    if (PRESENT(DQ)) then
       CALL QUAT2ROTMAT(QUAT,MAT,dMAT)
    else
       CALL QUAT2ROTMAT(QUAT,MAT)
    ENDif
    do I = 1,3
       QP(I) = doT_PRODUCT(MAT(I,:),PT)
       if (PRESENT(DQ)) then
          do J = 1,4
             DQ(I,J) = doT_PRODUCT(dMAT(I,:,J),PT)
          ENDdo
       ENDif
    ENDdo

    QP = QP/QN
    if (PRESENT(DQ)) then
       do I = 1,3
          do J = 1,4
             DQ(I,J) = (DQ(I,J) - 2*Q(J)*QP(I))/QN
          ENDdo
       ENDdo
    ENDif

    if (PRESENT(DPT)) then
       DPT =MAT/QN
    END if
  END subroutine QVPTMULT

  ! ----------------- STUFF inVOLVinG QUATERNION OBJECTS -------------------

  TYPE(QUATERNION) FUNCTION RHQinTERP(Q1,Q2,F)
    ! interpolate from one quaternion to another always in a right-handed sense
    ! (relative to the Q1 z-axis)
    ! F should be between 0 and 1
    TYPE(QUATERNION) :: Q1, Q2
    real(dp) :: F
    real(dp) :: ANG, AX(3), DIR
    TYPE(QUATERNION) :: QREL

    ! relative quaternion for Q2 relative to Q1
    QREL = inVQUAT(Q1)*Q2

    ! angle of rotation
    ANG = ACOS(QREL%W)*2

    ! axis of rotation
    AX = (/QREL%X,QREL%Y,QREL%Z/); AX = AX/SQRT(doT_PRODUCT(AX,AX))

    DIR = doT_PRODUCT(AX,QUAT2PT(Q1*PTQUAT((/0D0,0D0,1D0/))/Q1))

    print*, 'testx2:', dir, ang, ax

    if (DIR < 0) then
       ! rotation axis points away from quaternion axis, so flip it
       ANG = -ANG
       AX = -AX
    ENDif

    QREL = ROTQUAT(ANG*F,AX)

    RHQinTERP = Q1*QREL
  END FUNCTION RHQinTERP

  TYPE(QUATERNION) FUNCTION QSLERP(Q1,Q2,F)
    ! Sphreical linear interpolation between two quaternions
    ! F should be between 0 and 1
    TYPE(QUATERNION), intent(in) :: Q1, Q2
    real(dp), intent(in) :: F
    real(dp) :: QV1(4), QV2(4), ANG, QVANS(4)

    QV1 = (/Q1%W,Q1%X,Q1%Y,Q1%Z/)
    QV2 = (/Q2%W, Q2%X, Q2%Y, Q2%Z/)

    ! angle between them
    ANG = ACOS(doT_PRODUCT(QV1,QV2))

    QVANS = Sin((1-F)*ANG)/Sin(ANG)*QV1 + Sin(F*ANG)/Sin(ANG)*QV2

    QSLERP%W = QVANS(1); QSLERP%X = QVANS(2); QSLERP%Y = QVANS(3); QSLERP%Z = QVANS(4);
  END FUNCTION QSLERP

  subroutine QUAT2ROTMAT(Q,MAT,DMAT)
    ! convert a quaternion object to a rotation matrix and optionally return derivatives
    ! NOTE: no normalization
    implicit none
    TYPE(QUATERNION) :: Q
    real(dp), intent(out) :: MAT(3,3)
    real(dp), intent(out), OPTIONAL :: DMAT(3,3,4)
    real(dp) :: A,B,C,D,AA,BB,CC,DD,AB,AC,AD,BC,BD,CD

    A = Q%W; B = Q%X; C = Q%Y; D = Q%Z
    AA = A*A; BB = B*B; CC = C*C; DD = D*D
    AB = 2*A*B; AC = 2*A*C; AD = 2*A*D
    BC = 2*B*C; BD = 2*B*D
    CD = 2*C*D

    MAT(1,:) = (/AA + BB-CC-DD,BC-AD,AC + BD/)
    MAT(2,:) = (/AD + BC,AA-BB + CC-DD,CD-AB/)
    MAT(3,:) = (/BD-AC,AB + CD,AA-BB-CC + DD/)

    if (PRESENT(DMAT)) then
       dMAT(1,:,1) = (/A,-D,C/)
       dMAT(1,:,2) = (/B,C,D/)
       dMAT(1,:,3) = (/-C,B,A/)
       dMAT(1,:,4) = (/-D,-A,B/)
       dMAT(2,:,1) = (/D,A,-B/)
       dMAT(2,:,2) = (/C,-B,-A/)
       dMAT(2,:,3) = (/B,C,D/)
       dMAT(2,:,4) = (/A,-D,C/)
       dMAT(3,:,1) = (/-C,B,A/)
       dMAT(3,:,2) = (/D,A,-B/)
       dMAT(3,:,3) = (/-A,D,-C/)
       dMAT(3,:,4) = (/B,C,D/)
       dMAT = dMAT*2
    ENDif
  END subroutine QUAT2ROTMAT

  TYPE(QUATERNION) FUNCTION ROTMAT2QUAT(R)
    ! convert from a rotation matrix to a quaternion object
    ! following Deibel, 2006 (but with the rotation matrix transposed)
    ! R(3,:) has the z axis after rotation is applied, etc.
    ! assumes R is orthonormal
    implicit none
    real(dp) :: R(3,3)
    real(dp) :: R11, R22,R33, TMP

    R11 = R(1,1); R22 = R(2,2); R33 = R(3,3)

    if (R22 >= -R33.AND.R11 >= -R22.AND.R11 >= -R33) then
       TMP = SQRT(1 + R11 + R22 + R33)
       ROTMAT2QUAT%W = TMP/2
       ROTMAT2QUAT%X = (R(2,3)-R(3,2))/(TMP*2)
       ROTMAT2QUAT%Y = (R(3,1)-R(1,3))/(TMP*2)
       ROTMAT2QUAT%Z = (R(1,2)-R(2,1))/(TMP*2)
       !PRinT*, 'TESTX1Q'
    elseif (R22 <= -R33.AND.R11 > R22.AND.R11 > R33) then
       TMP = SQRT(1 + R11-R22-R33)
       ROTMAT2QUAT%W = (R(2,3)-R(3,2))/(TMP*2)
       ROTMAT2QUAT%X = TMP/2
       ROTMAT2QUAT%Y = (R(1,2) + R(2,1))/(TMP*2)
       ROTMAT2QUAT%Z = (R(3,1) + R(1,3))/(TMP*2)
       !PRinT*, 'TESTX2Q'
    elseif (R22 > R33.AND.R11 < R22.AND.R11 <= -R33) then
       TMP = SQRT(1-R11 + R22-R33)
       ROTMAT2QUAT%W = (R(3,1)-R(1,3))/(TMP*2)
       ROTMAT2QUAT%X = (R(1,2) + R(2,1))/(TMP*2)
       ROTMAT2QUAT%Y = TMP/2
       ROTMAT2QUAT%Z = (R(2,3) + R(3,2))/(TMP*2)
       !PRinT*, 'TESTX3Q'
    elseif (R22 < R33.AND.R11 <= -R22.AND.R11 < R33) then
       TMP = SQRT(1D0-R11-R22 + R33)
       ROTMAT2QUAT%W = (R(1,2)-R(2,1))/(TMP*2)
       ROTMAT2QUAT%X = (R(3,1) + R(1,3))/(TMP*2)
       ROTMAT2QUAT%Y = (R(2,3) + R(3,2))/(TMP*2)
       ROTMAT2QUAT%Z = TMP/2
       !PRinT*, 'TESTX4Q'
    else
       PRinT*, 'ERROR in ROTMAT2QUAT: bad rotation matrix'
       PRinT*, R(:,1)
       PRinT*, R(:,2)
       PRinT*, R(:,3)
       STOP 1
       ROTMAT2QUAT%W = 0; ROTMAT2QUAT%X = 0; ROTMAT2QUAT%Y = 0; ROTMAT2QUAT%Z = 0
    ENDif
  END FUNCTION ROTMAT2QUAT

  subroutine EULER2QUAT(EUL,Q,DERV,GETDERV)
    ! convert from Euler angles (z-x-z convention) to a quaternion
    ! if GETDERV is true, also get the derivatives of the quaternion components
    ! with respect to the euler angles (4 rows by 3 columns)
    ! WARNinG: since the quaternion representation has more parameters, switching from quaternion
    ! to euler and back again will not always give the exact same quaternion, though it
    ! will give an equivalent one (eg: may invert all components)

    real(dp), intent(in) :: EUL(3)
    TYPE(QUATERNION), intent(out) :: Q
    real(dp), intent(out),OPTIONAL :: DERV(4,3)
    LOGICAL, intent(in),OPTIONAL :: GETDERV
    real(dp) :: CA,SA,CB,SB,CG,SG,ALPHA,GAMMA,BETA
    LOGICAL :: FLIPBETA

    BETA = ANGLE2PI(EUL(2))
    FLIPBETA = BETA > PI
    ALPHA = EUL(1); GAMMA = EUL(3)
    if (BETA > PI) then
       BETA = 2*PI-BETA
       GAMMA = GAMMA + PI
       ALPHA = ALPHA + PI
    ENDif

    ALPHA = ANGLE2PI(ALPHA)
    GAMMA = ANGLE2PI(GAMMA)
    !if (QUATTEST) then
    !   PRinT*, 'TESTXE:', EUL
    !   PRinT*, 'A,B,G:',ALPHA,BETA,GAMMA
    !ENDif

    CA = COS(ALPHA/2); SA = Sin(ALPHA/2)
    CB = COS(BETA/2); SB = Sin(BETA/2)
    CG = COS(GAMMA/2); SG = Sin(GAMMA/2)

    Q%W = CG*CB*CA - SG*CB*SA
    Q%X = SG*SB*SA + CG*SB*CA
    Q%Y = CG*SB*SA - SG*SB*CA
    Q%Z = CG*CB*SA + SG*CB*CA

    if (PRESENT(DERV)) then
       if (GETDERV) then
          DERV(1,:) = 0.5D0*(/-CG*CB*SA - SG*CB*CA, -CG*SB*CA + SG*SB*SA, -SG*CB*CA - CG*CB*SA/)
          DERV(2,:) = 0.5D0*(/SG*SB*CA - CG*SB*SA, SG*CB*SA + CG*CB*CA, CG*SB*SA - SG*SB*CA /)
          DERV(3,:) = 0.5D0*(/CG*SB*CA + SG*SB*SA, CG*CB*SA - SG*CB*CA, -SG*SB*SA - CG*SB*CA/)
          DERV(4,:) = 0.5D0*(/CG*CB*CA - SG*CB*SA, -CG*SB*SA - SG*SB*CA, -SG*CB*SA + CG*CB*CA/)
       ENDif
       if (FLIPBETA) then
          DERV(:,2) = -DERV(:,2)
       ENDif
    ENDif

  END subroutine EULER2QUAT

  subroutine QUAT2EULER(Q,EUL)
    ! get the Euler angles (z-x-z convention) corresponding to a unit quaternion
    ! NOTE: the quaternion must already be normalized
    ! currently can't handle gimbal lock
    TYPE(QUATERNION), intent(in) :: Q
    real(dp), intent(out) :: EUL(3)
    real(dp) :: DUMMY

    EUL(2) = 1 - 2*(Q%X**2 + Q%Y**2)
    if (EUL(2) > 1) then
       EUL(2) = 0D0
    elseif (EUL(2) < -1) then
       EUL(2) = PI
    else
       EUL(2) = ACOS(EUL(2))
    ENDif

    ! deal with the gimbal lock issues
    if (EUL(2) <= EPSILON(0D0)) then
       EUL(3) = ATAN2(2*(Q%X*Q%Y + Q%W*Q%Z), 1 - 2*(Q%Y**2 + Q%Z**2))
       if (EUL(3) < 0) EUL(3) = 2*PI + EUL(3)
       EUL(1) = 0D0
       RETURN
    elseif (EUL(2) >= PI-EPSILON(0D0)) then
       EUL(3) = ATAN2(-2*(Q%X*Q%Y + Q%W*Q%Z), 1 - 2*(Q%Y**2 + Q%Z**2))
       if (EUL(3) < 0) EUL(3) = 2*PI + EUL(3)
       EUL(1) = 0D0
       RETURN
    ENDif

    DUMMY = Q%W*Q%X-Q%Y*Q%Z

    EUL(1) = ATAN2(Q%W*Q%Y + Q%X*Q%Z, DUMMY)
    if (EUL(1) < 0) EUL(1) = 2*PI + EUL(1)

    DUMMY = Q%W*Q%X + Q%Y*Q%Z

    EUL(3) = ATAN2(Q%X*Q%Z-Q%W*Q%Y,DUMMY)
    if (EUL(3) < 0) EUL(3) = 2*PI + EUL(3)

  END subroutine QUAT2EULER

  FUNCTION QUAT2PT(Q)
    ! get the point corresponding to a quaternion
    TYPE(QUATERNION) :: Q
    real(dp) :: QUAT2PT(3)

    QUAT2PT = (/Q%X,Q%Y,Q%Z/)
  END FUNCTION QUAT2PT

  TYPE(QUATERNION) FUNCTION ROTQUAT(THETA,AX)
    ! get the quaternion corresponding to rotation around unit axis AX
    ! by an angle theta
    real(dp) :: THETA, AX(3)
    real(dp) :: T2, ST2

    if (ABS(SUM(AX**2)-1D0) > EPSILON(1d0)*10) then
       print*, 'ERROR in ROTQUAT: Axis does not have unit norm'
       STOP 1
    ENDif

    T2 = THETA/2; ST2 = Sin(THETA/2)
    ROTQUAT%W = COS(T2)
    ROTQUAT%X = ST2*AX(1); ROTQUAT%Y = ST2*AX(2); ROTQUAT%Z = ST2*AX(3)
  END FUNCTION ROTQUAT

  TYPE(QUATERNION) FUNCTION PTQUAT(P)
    ! turn a 3d point into a quaternion
    real(dp) :: P(3)

    PTQUAT%W = 0D0; PTQUAT%X = P(1); PTQUAT%Y = P(2); PTQUAT%Z = P(3)
  END FUNCTION PTQUAT

  TYPE(QUATERNION) FUNCTION inVQUAT(Q)
    ! get the inverse of a quaternion
    implicit none
    TYPE(QUATERNION), intent(in) :: Q
    real(dp) :: QN

    QN = Q%W**2 + Q%X**2 + Q%Y**2 + Q%Z**2
    inVQUAT%W = Q%W/QN; inVQUAT%X = -Q%X/QN; inVQUAT%Y = -Q%Y/QN; inVQUAT%Z = -Q%Z/QN

  END FUNCTION inVQUAT

  TYPE(QUATERNION) FUNCTION QDIVIDE(P,Q)
    ! multiply P by inverse of Q(in that order)
    implicit none
    TYPE(QUATERNION), intent(in) :: P,Q
    TYPE(QUATERNION) :: QinV
    real(dp) :: QN

    ! inverse of the 2nd quaternion
    QN = Q%W**2 + Q%X**2 + Q%Y**2 + Q%Z**2
    QinV%W = Q%W/QN; QinV%X = -Q%X/QN; QinV%Y = -Q%Y/QN; QinV%Z = -Q%Z/QN

    QDIVIDE = P*QinV
  END FUNCTION QDIVIDE

  TYPE(QUATERNION) FUNCTION QPRODUCT(P,Q)
    ! quaternion multiplication
    implicit none
    TYPE(QUATERNION), intent(in) :: P, Q

    QPRODUCT%W = P%W*Q%W - P%X*Q%X - P%Y*Q%Y - P%Z*Q%Z
    QPRODUCT%X = P%W*Q%X + P%X*Q%W + P%Y*Q%Z - P%Z*Q%Y
    QPRODUCT%Y = P%W*Q%Y - P%X*Q%Z + P%Y*Q%W + P%Z*Q%X
    QPRODUCT%Z = P%W*Q%Z + P%X*Q%Y - P%Y*Q%X + P%Z*Q%W

  END FUNCTION QPRODUCT

  ! --------- general angle and euler angle stuff -------------
  subroutine ROTANGAX(ANG,AX,inVEC,outVEC,CALCROTMAT,ROTMAT)
    ! rotate a 3D vector by angle ANG around axis AX
    ! if CALCROTMAT is true, recalculate the rotation matrix
    ! otherwise use the provided one
    implicit none
    real(dp), intent(in) :: ANG, AX(3), inVEC(3)
    real(dp), intent(out) :: outVEC(3)
    real(dp), intent(inout) :: ROTMAT(3,3)
    LOGICAL, intent(in)  :: CALCROTMAT
    real(dp) :: CT,ST,CT1
    integer :: I

    if (CALCROTMAT) then
       CT = COS(ANG); ST = Sin(ANG)
       CT1 = 1-CT
       ROTMAT(1,:) = (/CT + AX(1)**2*CT1, AX(1)*AX(2)*CT1-AX(3)*ST, AX(1)*AX(3)*CT1 + AX(2)*ST/)
       ROTMAT(2,:) = (/AX(2)*AX(1)*CT1 + AX(3)*ST,CT + AX(2)**2*CT1,AX(2)*AX(3)*CT1-AX(1)*ST/)
       ROTMAT(3,:) = (/AX(3)*AX(1)*CT1-AX(2)*ST,AX(3)*AX(2)*CT1 + AX(1)*ST, CT + AX(3)**2*CT1/)
    ENDif

    do I = 1,3
       outVEC(I) = doT_PRODUCT(ROTMAT(I,:),inVEC)
    ENDdo
  END subroutine ROTANGAX

  subroutine EUL2ROTMAT(EUL,ROTMAT,DMAT)
    ! get the rotation matrix corresponding to various euler angles
    ! and the appropriate derivatives if DMAT is present
    implicit none
    real(dp), intent(in) :: EUL(3)
    real(dp), intent(out) :: ROTMAT(3,3)
    real(dp), intent(out), OPTIONAL :: DMAT(3,3,3)
    real(dp) :: CA,SA,CB,SB,CG,SG

    CA = COS(EUL(1)); SA = Sin(EUL(1))
    CB = COS(EUL(2)); SB = Sin(EUL(2))
    CG = COS(EUL(3)); SG = Sin(EUL(3))

    ROTMAT(1,:) = (/CA*CG-SA*CB*SG, -CA*SG-SA*CB*CG, SB*SA/)
    ROTMAT(2,:) = (/SA*CG + CA*CB*SG,-SA*SG + CA*CB*CG,-SB*CA/)
    ROTMAT(3,:) = (/SB*SG,SB*CG,CB/)

    if (PRESENT(DMAT)) then
       dMAT(1,:,1) = (/-SA*CG-CA*CB*SG,SA*SG-CA*CB*CG,SB*CA/)
       dMAT(2,:,1) = (/CA*CG-SA*CB*SG,-CA*SG-SA*CB*CG,SB*SA/)
       dMAT(3,:,1) = 0D0

       dMAT(1,:,2) = (/SA*SB*SG,SA*SB*CG,CB*SA/)
       dMAT(2,:,2) = (/-CA*SB*SG,-CA*SB*CG,-CB*CA/)
       dMAT(3,:,2) = (/CB*SG,CB*CG,-SB/)

       dMAT(1,:,3) = (/-CA*SG-SA*CB*CG,-CA*CG + SA*CB*SG,0D0/)
       dMAT(2,:,3) = (/-SA*SG + CA*CB*CG,-SA*CG-CA*CB*SG,0D0/)
       dMAT(3,:,3) = (/SB*CG,-SB*SG,0D0/)
    ENDif
  END subroutine EUL2ROTMAT

  subroutine GETANGLE(IJ,KJ,CST,dCTdIJ,dCTdKJ)
    ! get the angle between three points (I-J-K)
    ! and, optionally, the derivative of that angle
    ! actually this returns the COSinE of the angle and its derivative
    ! IJ = I-J; KJ = K-J
    implicit none
    real(dp), intent(in) :: IJ(3),KJ(3)
    real(dp), intent(out) :: CST
    real(dp), intent(out), OPTIONAL :: dCTdIJ(3), dCTdKJ(3)

    real(dp) :: DXI, DYI, DZI, DXJ, DYJ, DZJ
    real(dp) :: RI2, RJ2, RI, RJ, RIR, RJR
    real(dp) :: DXIR,DYIR, DZIR,DXJR,DYJR,DZJR

    DXI = IJ(1); DYI = IJ(2); DZI = IJ(3)
    DXJ = KJ(1); DYJ = KJ(2); DZJ = KJ(3)

    RI2 = DXI*DXI + DYI*DYI + DZI*DZI
    RJ2 = DXJ*DXJ + DYJ*DYJ + DZJ*DZJ
    RI = SQRT(RI2)
    RJ = SQRT(RJ2)
    RIR = 1/RI
    RJR = 1/RJ
    DXIR = DXI*RIR
    DYIR = DYI*RIR
    DZIR = DZI*RIR
    DXJR = DXJ*RJR
    DYJR = DYJ*RJR
    DZJR = DZJ*RJR
    CST = DXIR*DXJR + DYIR*DYJR + DZIR*DZJR
    if (PRESENT(DCTDIJ)) then
       dCTdIJ(1) = -(DXIR*CST-DXJR)*RIR
       dCTdIJ(2) = -(DYIR*CST-DYJR)*RIR
       dCTdIJ(3) = -(DZIR*CST-DZJR)*RIR
    ENDif
    if (PRESENT(DCTDKJ)) then
       dCTdKJ(1) = -(DXJR*CST-DXIR)*RJR
       dCTdKJ(2) = -(DYJR*CST-DYIR)*RJR
       dCTdKJ(3) = -(DZJR*CST-DZIR)*RJR
    ENDif

  END subroutine GETANGLE

  subroutine GETDIHEDRAL(IJ,JK,LK, PHI, dPdIJ, dPdJK, dPdLK)
    ! dihedral angle for 4 atoms I, J, K, L bound in order
    ! IJ = I-J; JK = J-K; LK = L-K
    ! find the dihedral torsion angle; return it in PHI
    ! Also return all derivatives: dP/dIJx, dP/dIJy, dP/dIJz in triplet dPdIJ
    ! same with dPdJK, dPdLK
    implicit none
    real(dp), intent(in) ::  IJ(3), JK(3), LK(3)
    real(dp), intent(out) :: PHI
    real(dp), intent(out), OPTIONAL :: dPdIJ(3), dPdJK(3), dPdLK(3)
    real(dp) :: DPDJ(3),DPDI(3),DPDK(3),DPDL(3)
    real(dp) :: FX, FY, FZ, GX, GY, GZ, HX, HY, HZ
    real(dp) :: AX, AY, AZ, BX, BY, Bz
    real(dp) :: RF, RG, RH, RF2, RG2, RH2, RFR, RGR, RHR
    real(dp) :: CSTTWO, SNTTWO2, CSTTHREE, SNTTHREE2, SNTTWO2R, SNTTHREE2R
    real(dp) :: RA2, RB2, RA2R, RB2R, RABR, CP
    real(dp) :: MYTX, MYTY, MYTZ, MYSCALAR
    real(dp) :: DUMMY, DUMMY2
    real(dp) :: B1(3), B2(3), B3(3), B12(3), B23(3)
    LOGICAL :: NOCOOR = .FALSE.

    FX = IJ(1)
    FY = IJ(2)
    FZ = IJ(3)
    GX = JK(1)
    GY = JK(2)
    GZ = JK(3)
    HX = LK(1)
    HY = LK(2)
    HZ = LK(3)
    ! A = F x G, B = H x G
    AX = FY*GZ-FZ*GY
    AY = FZ*GX-FX*GZ
    AZ = FX*GY-FY*GX
    BX = HY*GZ-HZ*GY
    BY = HZ*GX-HX*GZ
    BZ = HX*GY-HY*GX
    ! RG = |G|, RGR = 1/|G|
    RG2 = GX*GX + GY*GY + GZ*GZ
    RG = SQRT(RG2)
    RGR = 1/RG
    ! dae for use in evaluating B-matrix
    RF2 = FX*FX + FY*FY + FZ*FZ
    RF = SQRT(RF2)
    RFR = 1/RF
    RH2 = HX*HX + HY*HY + HZ*HZ
    RH = SQRT(RH2)
    RHR = 1/RH

    CSTTWO = -(FX*GX + FY*GY + FZ*GZ)*RFR*RGR
    SNTTWO2 = 1-CSTTWO*CSTTWO
    SNTTWO2R = 1/SNTTWO2
    CSTTHREE = (HX*GX + HY*GY + HZ*GZ)*RHR*RGR
    SNTTHREE2 = 1-CSTTHREE*CSTTHREE
    SNTTHREE2R = 1/SNTTHREE2

    RA2 = AX*AX + AY*AY + AZ*AZ
    RB2 = BX*BX + BY*BY + BZ*BZ
    RA2R = 1/RA2
    RB2R = 1/RB2
    RABR = SQRT(RA2R*RB2R)

    PHI =  ATAN2(-RG*(FX*BX + FY*BY + FZ*BZ),AX*BX + AY*BY + AZ*BZ)

    if (PRESENT(DPDIJ).OR.PRESENT(DPDJK).OR.PRESENT(DPDLK)) then
       DUMMY = RFR*RFR*RGR*SNTTWO2R
       dPdI = (/-AX*DUMMY, -AY*DUMMY, -AZ*DUMMY/)
       DUMMY = RFR*RFR*RGR*RGR*SNTTWO2R*(RG-RF*CSTTWO)
       DUMMY2 = RHR*RGR*RGR*SNTTHREE2R*CSTTHREE
       dPdJ = (/AX*DUMMY-BX*DUMMY2, AY*DUMMY-BY*DUMMY2, AZ*DUMMY-BZ*DUMMY2/)
       DUMMY = RHR*RHR*RGR*SNTTHREE2R
       dPdL = (/BX*DUMMY,BY*DUMMY,BZ*DUMMY/)
    ENDif
    if (PRESENT(DPDIJ)) DPDIJ = DPDI
    if (PRESENT(DPDLK)) DPDLK = DPDL
    if (PRESENT(DPDJK)) DPDJK = DPDI + DPDJ

  END subroutine GETDIHEDRAL

  real(dp) FUNCTION ANGLE0(ANGLE)
    ! convert an angle to one between +/- pi
    ! (so keeping it as close as possible to zero)
    implicit none
    real(dp) :: ANGLE

    ANGLE0 = ANGLE2PI(ANGLE)
    if (ANGLE0 > PI) then
       ANGLE0 = ANGLE0 - 2*PI
    ENDif
  END FUNCTION ANGLE0

  real(dp) FUNCTION ANGLE2PI(ANGLE)
    ! convert an angle to one between 0 and 2pi by adding or subtracting multiples of 2pi
    implicit none
    real(dp) :: ANGLE
    integer :: N2PI

    N2PI = inT(ANGLE/(2*PI))
    if (ANGLE < 0) then
       ANGLE2PI = ANGLE + (-N2PI + 1)*2*PI
    else
       ANGLE2PI = ANGLE - N2PI*2*PI
    ENDif
  END FUNCTION ANGLE2PI

END module QUATUTIL


! Marsaglia & Tsang generator for random normals & random exponentials.
! Translated from C by Alan Miller (amiller@bigpond.net.au)

! Marsaglia, G. & Tsang, W.W. (2000) `The ziggurat method for generating
! random variables', J. Statist. Software, v5(8).

! This is an electronic journal which can be downloaded from:
! http://www.jstatsoft.org/v05/i08

! N.B. It is assumed that all integers are 32-bit.
! N.B. The value of M2 has been halved to compensate for the lack of
!      unsigned integers in Fortran.

! Latest version - 1 January 2001
MODULE Ziggurat
   IMPLICIT NONE

   PRIVATE

   INTEGER,  PARAMETER  ::  DP=SELECTED_REAL_KIND( 12, 60 )
   REAL(DP), PARAMETER  ::  m1=2147483648.0_DP,   m2=2147483648.0_DP,      &
                            half=0.5_DP
   REAL(DP)             ::  dn=3.442619855899_DP, tn=3.442619855899_DP,    &
                            vn=0.00991256303526217_DP,                     &
                            q,                    de=7.697117470131487_DP, &
                            te=7.697117470131487_DP,                       &
                            ve=0.003949659822581572_DP
   INTEGER,  SAVE       ::  iz, jz, jsr=123456789, kn(0:127),              &
                            ke(0:255), hz
   REAL(DP), SAVE       ::  wn(0:127), fn(0:127), we(0:255), fe(0:255)
   LOGICAL,  SAVE       ::  initialized=.FALSE.

   PUBLIC  :: zigset, shr3, uni, rnor, rexp

CONTAINS

SUBROUTINE zigset( jsrseed )

   INTEGER, INTENT(IN)  :: jsrseed

   INTEGER  :: i

   !  Set the seed
   jsr = jsrseed

   !  Tables for RNOR
   q = vn*EXP(half*dn*dn)
   kn(0) = (dn/q)*m1
   kn(1) = 0
   wn(0) = q/m1
   wn(127) = dn/m1
   fn(0) = 1.0_DP
   fn(127) = EXP( -half*dn*dn )
   DO  i = 126, 1, -1
      dn = SQRT( -2.0_DP * LOG( vn/dn + EXP( -half*dn*dn ) ) )
      kn(i+1) = (dn/tn)*m1
      tn = dn
      fn(i) = EXP(-half*dn*dn)
      wn(i) = dn/m1
   END DO

   !  Tables for REXP
   q = ve*EXP( de )
   ke(0) = (de/q)*m2
   ke(1) = 0
   we(0) = q/m2
   we(255) = de/m2
   fe(0) = 1.0_DP
   fe(255) = EXP( -de )
   DO  i = 254, 1, -1
      de = -LOG( ve/de + EXP( -de ) )
      ke(i+1) = m2 * (de/te)
      te = de
      fe(i) = EXP( -de )
      we(i) = de/m2
   END DO
   initialized = .TRUE.
   RETURN
END SUBROUTINE zigset

!  Generate random 32-bit integers
FUNCTION shr3( ) RESULT( ival )
   INTEGER  ::  ival

   jz = jsr
   jsr = IEOR( jsr, ISHFT( jsr,  13 ) )
   jsr = IEOR( jsr, ISHFT( jsr, -17 ) )
   jsr = IEOR( jsr, ISHFT( jsr,   5 ) )
   ival = jz + jsr
   RETURN
END FUNCTION shr3

!  Generate uniformly distributed random numbers
FUNCTION uni( ) RESULT( fn_val )
   REAL(DP)  ::  fn_val

   fn_val = half + 0.2328306e-9_DP * shr3( )
   RETURN
END FUNCTION uni

!  Generate random normals
FUNCTION rnor( ) RESULT( fn_val )
   REAL(DP)             ::  fn_val

   REAL(DP), PARAMETER  ::  r = 3.442620_DP
   REAL(DP)             ::  x, y

   IF( .NOT. initialized ) CALL zigset( jsr )
   hz = shr3( )
   iz = IAND( hz, 127 )
   IF( ABS( hz ) < kn(iz) ) THEN
      fn_val = hz * wn(iz)
   ELSE
      DO
         IF( iz == 0 ) THEN
            DO
               x = -0.2904764_DP* LOG( uni( ) )
               y = -LOG( uni( ) )
               IF( y+y >= x*x ) EXIT
            END DO
            fn_val = r+x
            IF( hz <= 0 ) fn_val = -fn_val
            RETURN
         END IF
         x = hz * wn(iz)
         IF( fn(iz) + uni( )*(fn(iz-1)-fn(iz)) < EXP(-half*x*x) ) THEN
            fn_val = x
            RETURN
         END IF
         hz = shr3( )
         iz = IAND( hz, 127 )
         IF( ABS( hz ) < kn(iz) ) THEN
            fn_val = hz * wn(iz)
            RETURN
         END IF
      END DO
   END IF
   RETURN
END FUNCTION rnor

!  Generate random exponentials
FUNCTION rexp( ) RESULT( fn_val )
   REAL(DP)  ::  fn_val

   REAL(DP)  ::  x

   IF( .NOT. initialized ) CALL Zigset( jsr )
   jz = shr3( )
   iz = IAND( jz, 255 )
   IF( ABS( jz ) < ke(iz) ) THEN
      fn_val = ABS(jz) * we(iz)
      RETURN
   END IF
   DO
      IF( iz == 0 ) THEN
         fn_val = 7.69711 - LOG( uni( ) )
         RETURN
      END IF
      x = ABS( jz ) * we(iz)
      IF( fe(iz) + uni( )*(fe(iz-1) - fe(iz)) < EXP( -x ) ) THEN
         fn_val = x
         RETURN
      END IF
      jz = shr3( )
      iz = IAND( jz, 255 )
      IF( ABS( jz ) < ke(iz) ) THEN
         fn_val = ABS( jz ) * we(iz)
         RETURN
      END IF
   END DO
   RETURN
END FUNCTION rexp

END MODULE ziggurat

PROGRAM test_ziggurat
   USE Ziggurat
   IMPLICIT NONE

   INTEGER, PARAMETER  ::  DP = SELECTED_REAL_KIND(12, 60)
   REAL                ::  t1, t2
   REAL(DP)            ::  x, chisq, expctd
   INTEGER             ::  i, ten_million=10000000, freq(0:999), j

   !  Set the random number seed
   WRITE(*, '(a)', ADVANCE='NO') ' Enter a non-zero integer: '
   READ(*, *) i

   CALL zigset( i )

   !  First time the generation of uniform, normal & exponential generators
   CALL CPU_TIME( t1 )
   DO  i = 1, ten_million
      x = uni( )
   END DO
   CALL CPU_TIME( t2 )
   WRITE(*, '(a, i10, a, f9.2, a)') ' Time to generate ', ten_million,  &
                                    ' uniform random nos. = ', t2-t1, 'sec.'
   CALL CPU_TIME( t1 )
   DO  i = 1, ten_million
      x = rnor( )
   END DO
   CALL CPU_TIME( t2 )
   WRITE(*, '(a, i10, a, f9.2, a)') ' Time to generate ', ten_million,     &
                                    ' normal random nos. = ', t2-t1, 'sec.'

   CALL CPU_TIME( t1 )
   DO  i = 1, ten_million
      x = rexp( )
   END DO
   CALL CPU_TIME( t2 )
   WRITE(*, '(a, i10, a, f9.2, a)') ' Time to generate ', ten_million,     &
                                    ' exponential random nos. = ', t2-t1, 'sec.'
   WRITE(*, *)

   !  Now look at the distributions generated
   WRITE(*, *) 'Std. devn. of chi-squared with 999 d.of.f. = 44.70'
   WRITE(*, *) 'Values of chi-squared below should be within about 90. of 999.'

   freq = 0
   DO  i = 1, ten_million
      j = 1000 * uni( )
      freq(j) = freq(j) +1
   END DO
   chisq = 0.0_DP
   expctd = ten_million / 1000
   DO  j = 0, 999
      chisq = chisq + (freq(j) - expctd)**2 / expctd
   END DO
   WRITE(*, '(a, f9.2, a)') ' Uniform distribution, chi-squared = ', chisq,   &
                            ' with 999 deg. of freedom'
   freq = 0
   DO  i = 1, ten_million
      j = 1000 * alnorm( rnor( ), .FALSE. )
      freq(j) = freq(j) +1
   END DO
   chisq = 0.0_DP
   expctd = ten_million / 1000
   DO  j = 0, 999
      chisq = chisq + (freq(j) - expctd)**2 / expctd
   END DO
   WRITE(*, '(a, f9.2, a)') ' Normal distribution, chi-squared = ', chisq,  &
                            ' with 999 deg. of freedom'
   freq = 0
   DO  i = 1, ten_million
      j = 1000 * EXP( -rexp( ) )
      IF( j > 999  .OR.  j < 0 ) THEN
         WRITE(*, '(a, 2i10)') ' i, j = ', i, j
      ELSE
         freq(j) = freq(j) +1
      END IF
   END DO
   chisq = 0.0_DP
   expctd = ten_million / 1000
   DO  j = 0, 999
      chisq = chisq + (freq(j) - expctd)**2 / expctd
   END DO
   WRITE(*, '(a, f9.2, a)') ' Exponential distribution, chi-squared = ',      &
                            chisq, ' with 999 deg. of freedom'
   STOP

CONTAINS

!  Algorithm AS66 Applied Statistics (1973) vol.22, no.3

!  Evaluates the tail area of the standardised normal curve
!  from x to infinity if upper is .true. or
!  from minus infinity to x if upper is .false.

! ELF90-compatible version by Alan Miller
! Latest revision - 29 November 2001

FUNCTION alnorm( x, upper ) RESULT( fn_val )
   REAL(DP), INTENT(IN)   ::  x
   LOGICAL,   INTENT(IN)  ::  upper
   REAL(DP)               ::  fn_val

   !  Local variables
   REAL(DP), PARAMETER   ::  zero=0.0_DP, one=1.0_DP, half=0.5_DP, con=1.28_DP
   REAL(DP)              ::  z, y
   LOGICAL               ::  up

   !  Machine dependent constants
   REAL(DP), PARAMETER  ::  ltone = 7.0_DP, utzero = 18.66_DP
   REAL(DP), PARAMETER  ::  p = 0.398942280444_DP, q = 0.39990348504_DP,   &
                            r = 0.398942280385_DP, a1 = 5.75885480458_DP,  &
                            a2 = 2.62433121679_DP, a3 = 5.92885724438_DP,  &
                            b1 = -29.8213557807_DP, b2 = 48.6959930692_DP, &
                            c1 = -3.8052E-8_DP, c2 = 3.98064794E-4_DP,     &
                            c3 = -0.151679116635_DP, c4 = 4.8385912808_DP, &
                            c5 = 0.742380924027_DP, c6 = 3.99019417011_DP, &
                            d1 = 1.00000615302_DP, d2 = 1.98615381364_DP,  &
                            d3 = 5.29330324926_DP, d4 = -15.1508972451_DP, &
                            d5 = 30.789933034_DP

   up = upper
   z = x
   IF( z < zero ) THEN
      up = .NOT. up
      z = -z
   END IF
   IF( z <= ltone  .OR.  (up  .AND.  z <= utzero) ) THEN
      y = half*z*z
      IF( z > con ) THEN
         fn_val = r*EXP( -y )/(z+c1+d1/(z+c2+d2/(z+c3+d3/(z+c4+d4/(z+c5+d5/(z+c6))))))
      ELSE
         fn_val = half - z*(p-q*y/(y+a1+b1/(y+a2+b2/(y+a3))))
      END IF
   ELSE
      fn_val = zero
   END IF

   IF( .NOT. up ) fn_val = one - fn_val
   RETURN
END FUNCTION alnorm

END PROGRAM test_ziggurat