      SUBROUTINE SB03SX( TRANA, UPLO, LYAPUN, N, XANORM, T, LDT, U, LDU,
     $                   R, LDR, FERR, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To estimate a forward error bound for the solution X of a real
C     discrete-time Lyapunov matrix equation,
C
C            op(A)'*X*op(A) - X = C,
C
C     where op(A) = A or A' (A**T) and C is symmetric (C = C**T). The
C     matrix A, the right hand side C, and the solution X are N-by-N.
C     An absolute residual matrix, which takes into account the rounding
C     errors in forming it, is given in the array R.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     UPLO    CHARACTER*1
C             Specifies which part of the symmetric matrix R is to be
C             used, as follows:
C             = 'U':  Upper triangular part;
C             = 'L':  Lower triangular part.
C
C     LYAPUN  CHARACTER*1
C             Specifies whether or not the original Lyapunov equations
C             should be solved, as follows:
C             = 'O':  Solve the original Lyapunov equations, updating
C                     the right-hand sides and solutions with the
C                     matrix U, e.g., X <-- U'*X*U;
C             = 'R':  Solve reduced Lyapunov equations only, without
C                     updating the right-hand sides and solutions.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and R.  N >= 0.
C
C     XANORM  (input) DOUBLE PRECISION
C             The absolute (maximal) norm of the symmetric solution
C             matrix X of the Lyapunov equation.  XANORM >= 0.
C
C     T       (input) DOUBLE PRECISION array, dimension (LDT,N)
C             The leading N-by-N upper Hessenberg part of this array
C             must contain the upper quasi-triangular matrix T in Schur
C             canonical form from a Schur factorization of A.
C
C     LDT     INTEGER
C             The leading dimension of array T.  LDT >= MAX(1,N).
C
C     U       (input) DOUBLE PRECISION array, dimension (LDU,N)
C             The leading N-by-N part of this array must contain the
C             orthogonal matrix U from a real Schur factorization of A.
C             If LYAPUN = 'R', the array U is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of array U.
C             LDU >= 1,        if LYAPUN = 'R';
C             LDU >= MAX(1,N), if LYAPUN = 'O'.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the absolute residual matrix R, with
C             bounds on rounding errors added.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the absolute residual matrix R, with
C             bounds on rounding errors added.
C             On exit, the leading N-by-N part of this array contains
C             the symmetric absolute residual matrix R (with bounds on
C             rounding errors added), fully stored.
C
C     LDR     INTEGER
C             The leading dimension of array R.  LDR >= MAX(1,N).
C
C     FERR    (output) DOUBLE PRECISION
C             An estimated forward error bound for the solution X.
C             If XTRUE is the true solution, FERR bounds the magnitude
C             of the largest entry in (X - XTRUE) divided by the
C             magnitude of the largest entry in X.
C             If N = 0 or XANORM = 0, FERR is set to 0, without any
C             calculations.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 0,            if N = 0;
C             LDWORK >= MAX(3,2*N*N), if N > 0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = N+1:  if T has almost reciprocal eigenvalues; perturbed
C                   values were used to solve Lyapunov equations (but
C                   the matrix T is unchanged).
C
C     METHOD
C
C     The forward error bound is estimated using a practical error bound
C     similar to the one proposed in [1], based on the 1-norm estimator
C     in [2].
C
C     REFERENCES
C
C     [1] Higham, N.J.
C         Perturbation theory and backward error for AX-XB=C.
C         BIT, vol. 33, pp. 124-136, 1993.
C
C     [2] Higham, N.J.
C         FORTRAN codes for estimating the one-norm of a real or
C         complex matrix, with applications to condition estimation.
C         ACM Trans. Math. Softw., 14, pp. 381-396, 1988.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     FURTHER COMMENTS
C
C     The option LYAPUN = 'R' may occasionally produce slightly worse
C     or better estimates, and it is much faster than the option 'O'.
C     The routine can be also used as a final step in estimating a
C     forward error bound for the solution of a discrete-time algebraic
C     matrix Riccati equation.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Oct. 1998. Partly based on DDLSVX (and then SB03SD) by P. Petkov,
C     Tech. University of Sofia, March 1998 (and December 1998).
C
C     REVISIONS
C
C     February 6, 1999, V. Sima, Katholieke Univ. Leuven, Belgium.
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004,
C     May 2020.
C
C     KEYWORDS
C
C     Lyapunov equation, orthogonal transformation, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, HALF
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          LYAPUN, TRANA, UPLO
      INTEGER            INFO, LDR, LDT, LDU, LDWORK, N
      DOUBLE PRECISION   FERR, XANORM
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   DWORK( * ), R( LDR, * ), T( LDT, * ),
     $                   U( LDU, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            LOWER, NOTRNA, UPDATE
      CHARACTER          TRANAT, UPLOW
      INTEGER            I, IJ, INFO2, ITMP, J, KASE, NN
      DOUBLE PRECISION   EST, SCALE, TEMP
C     ..
C     .. Local Arrays ..
      INTEGER            ISAVE( 3 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLANSY
      EXTERNAL           DLANSY, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLACN2, DSCAL, MA02ED, MB01RU, SB03MX, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      NOTRNA = LSAME( TRANA,  'N' )
      UPDATE = LSAME( LYAPUN, 'O' )
C
      NN   = N*N
      INFO = 0
      IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR.
     $                       LSAME( TRANA, 'C' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
     $   THEN
         INFO = -2
      ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( XANORM.LT.ZERO ) THEN
         INFO = -5
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN
         INFO = -9
      ELSE IF( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDWORK.LT.0 .OR.
     $       ( LDWORK.LT.MAX( 3, 2*NN ) .AND. N.GT.0 ) ) THEN
         INFO = -15
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB03SX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      FERR = ZERO
      IF( N.EQ.0 .OR. XANORM.EQ.ZERO )
     $   RETURN
C
      ITMP = NN + 1
C
      IF( NOTRNA ) THEN
         TRANAT = 'T'
      ELSE
         TRANAT = 'N'
      END IF
C
C     Fill in the remaining triangle of the symmetric residual matrix.
C
      CALL MA02ED( UPLO, N, R, LDR )
C
      KASE = 0
C
C     REPEAT
   10 CONTINUE
      CALL DLACN2( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE, ISAVE )
      IF( KASE.NE.0 ) THEN
C
C        Select the triangular part of symmetric matrix to be used.
C
         IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) )
     $       .GE.
     $       DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) )
     $     ) THEN
            UPLOW = 'U'
            LOWER = .FALSE.
         ELSE
            UPLOW = 'L'
            LOWER = .TRUE.
         END IF
C
         IF( KASE.EQ.2 ) THEN
            IJ = 0
            IF( LOWER ) THEN
C
C              Scale the lower triangular part of symmetric matrix
C              by the residual matrix.
C
               DO 30 J = 1, N
                  DO 20 I = J, N
                     IJ = IJ + 1
                     DWORK( IJ ) = DWORK( IJ )*R( I, J )
   20             CONTINUE
                  IJ = IJ + J
   30          CONTINUE
            ELSE
C
C              Scale the upper triangular part of symmetric matrix
C              by the residual matrix.
C
               DO 50 J = 1, N
                  DO 40 I = 1, J
                     IJ = IJ + 1
                     DWORK( IJ ) = DWORK( IJ )*R( I, J )
   40             CONTINUE
                  IJ = IJ + N - J
   50          CONTINUE
            END IF
         END IF
C
         IF( UPDATE ) THEN
C
C           Transform the right-hand side: RHS := U'*RHS*U.
C
            CALL MB01RU( UPLOW, 'Transpose', N, N, ZERO, ONE, DWORK, N,
     $                   U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 )
            CALL DSCAL( N, HALF, DWORK, N+1 )
         END IF
         CALL MA02ED( UPLOW, N, DWORK, N )
C
         IF( KASE.EQ.2 ) THEN
C
C           Solve op(T)'*Y*op(T) - Y = scale*RHS.
C
            CALL SB03MX( TRANA, N, T, LDT, DWORK, N, SCALE,
     $                   DWORK( ITMP ), INFO2 )
         ELSE
C
C           Solve op(T)*W*op(T)' - W = scale*RHS.
C
            CALL SB03MX( TRANAT, N, T, LDT, DWORK, N, SCALE,
     $                   DWORK( ITMP ), INFO2 )
         END IF
C
         IF( INFO2.GT.0 )
     $      INFO = N + 1
C
         IF( UPDATE ) THEN
C
C           Transform back to obtain the solution: Z := U*Z*U', with
C           Z = Y or Z = W.
C
            CALL MB01RU( UPLOW, 'No transpose', N, N, ZERO, ONE, DWORK,
     $                   N, U, LDU, DWORK, N, DWORK( ITMP ), NN, INFO2 )
            CALL DSCAL( N, HALF, DWORK, N+1 )
         END IF
C
         IF( KASE.EQ.1 ) THEN
            IJ = 0
            IF( LOWER ) THEN
C
C              Scale the lower triangular part of symmetric matrix
C              by the residual matrix.
C
               DO 70 J = 1, N
                  DO 60 I = J, N
                     IJ = IJ + 1
                     DWORK( IJ ) = DWORK( IJ )*R( I, J )
   60             CONTINUE
                  IJ = IJ + J
   70          CONTINUE
            ELSE
C
C              Scale the upper triangular part of symmetric matrix
C              by the residual matrix.
C
               DO 90 J = 1, N
                  DO 80 I = 1, J
                     IJ = IJ + 1
                     DWORK( IJ ) = DWORK( IJ )*R( I, J )
   80             CONTINUE
                  IJ = IJ + N - J
   90          CONTINUE
            END IF
         END IF
C
C        Fill in the remaining triangle of the symmetric matrix.
C
         CALL MA02ED( UPLOW, N, DWORK, N )
         GO TO 10
      END IF
C
C     UNTIL KASE = 0
C
C     Compute the estimate of the relative error.
C
      TEMP = XANORM*SCALE
      IF( TEMP.GT.EST ) THEN
         FERR = EST / TEMP
      ELSE
         FERR = ONE
      END IF
C
      RETURN
C
C *** Last line of SB03SX ***
      END


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mninst : insert test program                       cc
cc      application : to find the sum of two periodic splines         cc
cc                 with different sets of knots                       cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real t1(30),c1(30),t2(30),c2(30),x(21),y(21),y1(21),y2(21)
      integer i,ier,iopt,ip,i1,i2,j,j1,j2,k,k1,m,nest,nk,n1,n1k1,n2,n2k1
      real ai,per
c  set up the points where the splines will be evaluated.
      m = 21
      do 10 i=1,m
        ai = i-1
        x(i) = ai*0.5e-01
  10  continue
c  set up the dimension information
      nest = 30
c  main loop for the different spline degrees.
      do 800 k=3,5,2
        k1 = k+1
        do 700 ip=1,2
c  if iopt = 1 the splines will be considered as periodic splines.
c  if iopt = 0 they will be considered as ordinary splines.
        iopt = 2-ip
        if(iopt.eq.0) write(6,900)
        if(iopt.ne.0) write(6,905)
        write(6,910) k
c  fetch the knots and b-spline coefficients of the first spline s1(x).
        n1 = 2*k1+5
        n1k1 = n1-k1
        t1(k1) = 0.
        t1(k1+1) = 0.2e0
        t1(k1+2) = 0.3e0
        t1(k1+3) = 0.4e0
        t1(k1+4) = 0.7e0
        t1(k1+5) = 0.9e0
        t1(k1+6) = 0.1e+01
        c1(1) = 0.1e+01
        c1(2) = 0.2e+01
        c1(3) =-0.1e+01
        c1(4) = 0.3e+01
        c1(5) = 0.3e+01
        c1(6) =-0.3e+01
c  fetch the knots and b-spline coefficients of the second spline s2(x).
        n2 = 2*k1+6
        n2k1 = n2-k1
        t2(k1) = 0.
        t2(k1+1) = 0.1e0
        t2(k1+2) = 0.2e0
        t2(k1+3) = 0.3e0
        t2(k1+4) = 0.4e0
        t2(k1+5) = 0.7e0
        t2(k1+6) = 0.8e0
        t2(k1+7) = 0.1e+01
        c2(1) = 0.2e+01
        c2(2) =-0.2e+01
        c2(3) = 0.1e+01
        c2(4) =-0.3e+01
        c2(5) = 0.4e+01
        c2(6) = 0.4e+01
        c2(7) = 0.4e+01
c  incorporate the boundary conditions for periodic splines.
        per = 0.1e+01
        nk = n1-k
        do 20 j=1,k
          i1 = nk+j
          i2 = nk-j
          j1 = k1+j
          j2 = k1-j
c  the boundary knots
          t1(i1) = t1(j1)+per
          t1(j2) = t1(i2)-per
          t2(i1+1) = t2(j1)+per
          t2(j2) = t2(i2+1)-per
c  the boundary coefficients
          c1(j+6) = c1(j)
          c2(j+7) = c2(j)
  20    continue
        if(iopt.ne.0) go to 100
c  if iopt=0 we insert k knots at the boundaries of the interval to
c  find the representation with coincident boundary knots
        do 40 j=1,k
          call insert(iopt,t1,n1,c1,k,0.1e+01,t1,n1,c1,nest,ier)
          n1 = n1-1
          call insert(iopt,t1,n1,c1,k,0.,t1,n1,c1,nest,ier)
          n1 = n1-1
          do 30 i=1,n1
            t1(i) = t1(i+1)
            c1(i) = c1(i+1)
  30      continue
  40    continue
        do 60 j=1,k
          call insert(iopt,t2,n2,c2,k,0.1e+01,t2,n2,c2,nest,ier)
          n2 = n2-1
          call insert(iopt,t2,n2,c2,k,0.,t2,n2,c2,nest,ier)
          n2 = n2-1
          do 50 i=1,n2
            t2(i) = t2(i+1)
            c2(i) = c2(i+1)
  50      continue
  60    continue
c  print knots and b-spline coefficients of the two splines.
 100    write(6,915)
        write(6,920) (t1(i),i=1,n1)
        write(6,925)
        write(6,930) (c1(i),i=1,n1k1)
        write(6,935)
        write(6,920) (t2(i),i=1,n2)
        write(6,940)
        write(6,930) (c2(i),i=1,n2k1)
c  evaluate the two splines
        call splev(t1,n1,c1,k,x,y1,m,ier)
        call splev(t2,n2,c2,k,x,y2,m,ier)
c  insert the knots of the second spline into those of the first one
        call insert(iopt,t1,n1,c1,k,0.1e0,t1,n1,c1,nest,ier)
        call insert(iopt,t1,n1,c1,k,0.8e0,t1,n1,c1,nest,ier)
c  insert the knots of the first spline into those of the second one
        call insert(iopt,t2,n2,c2,k,0.9e0,t2,n2,c2,nest,ier)
c  print the knots and coefficients of the splines in their new
c  representation
        n1k1 = n1-k1
        write(6,945)
        write(6,920) (t1(i),i=1,n1)
        write(6,925)
        write(6,930) (c1(i),i=1,n1k1)
        write(6,940)
        write(6,930) (c2(i),i=1,n1k1)
c  find the coefficients of the sum of the two splines.
        do 110 i=1,n1k1
          c1(i) = c1(i)+c2(i)
 110    continue
        write(6,950)
        write(6,930) (c1(i),i=1,n1k1)
c  evaluate this new spline and compare results
        call splev(t1,n1,c1,k,x,y,m,ier)
        write(6,955)
        do 200 i=1,m
          write(6,960) i,x(i),y1(i),y2(i),y(i)
 200    continue
 700  continue
 800  continue
      stop
c  format statements.
 900  format(41h0insertion algorithm for ordinary splines)
 905  format(41h0insertion algorithm for periodic splines)
 910  format(1x,25hdegree of the splines k =,i2)
 915  format(1x,30hposition of the knots of s1(x))
 920  format(5x,15f5.1)
 925  format(1x,30hb-spline coefficients of s1(x))
 930  format(5x,8f9.5)
 935  format(1x,30hposition of the knots of s2(x))
 940  format(1x,30hb-spline coefficients of s2(x))
 945  format(1x,37hposition of the knots after insertion)
 950  format(1x,33hb-spline coefficients of s1+s2(x))
 955  format(3h0 i,6x,1hx,7x,5hs1(x),7x,5hs2(x),6x,8hs1+s2(x))
 960  format(1x,i2,f8.2,3f12.5)
      end


      SUBROUTINE TUBODY(GRAVMU,RSTART,VSTART,TPROP,RSTOP,VSTOP,
     *             IERPNT,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  GIVEN A POSITION AND VELOCITY OF A S/C IN ELLIPTICAL/CIRCULAR ORBIT,
C  PROPAGATE IT TPROP SECONDS AND RETURN A NEW POSITION AND VELOCITY.
C
C  PROPAGATION IS TWO-BODY(IE-CENTRAL FORCE ONLY). NO NUMERICAL
C  INTEGRATION.
C
C
C  VAR    DIM  TYPE   I/O   DESCRIPTION
C  ---    ---  ----   ---   -----------
C
C  GRAVMU  1   R*8    I     GRAVITATIONAL COEFFICIENT OF THE CENTRAL
C                           BODY. IN THE SAME LENGTH AND TIME UNITS
C                           AS THE INPUT POSITION AND VELOCITY.
C                           EX- GRAVMU=398601.2 KM**3/SEC**2
C                               GRAVMU=19.90931 ERAD**3/HOUR**2
C
C  RSTART  3   R*8    I     THE INERTIAL POSITION VECTOR. UNITS ARE
C                           THE SAME AS IN GRAVMU.
C
C  VSTART  3   R*8    I     THE INERTIAL VELOCITY VECTOR. UNITS ARE
C                           THE SAME AS FOR GRAVMU.
C
C  TPROP   1   R*8    I     THE NUMBER OF SECONDS TO PROPAGATE THE
C                           INPUT CONDITIONS. POSITIVE MEANS GO
C                           FORWARD IN TIME, NEGATIVE MEANS BACKWARD.
C
C  RSTOP   3   R*8    O     THE INERTIAL POSITION VECTOR AFTER
C                           PROPAGATING. SAME UNITS AS RSTART.
C                           IN THE CALLING ROUTINE, RSTART AND RSTOP
C                           MAY BE THE SAME ARRAY.
C
C  VSTOP   3   R*8    O     THE INERTIAL VELOCITY VECTOR AFTER
C                           PROPAGATING. SAME UNITS AS VSTART.
C                           IN THE CALLING ROUTINE, VSTART AND VSTOP
C                           MAY BE THE SAME ARRAY.
C
C  IERPNT  1   I*4    I     FORTRAN UNIT NUMBER FOR ERROR MESSAGES.
C                           ONLY ELLIPTICAL/CIRCULAR ORBITS CAN BE
C                           PROPAGATED BY THIS ROUTINE. ERROR IF
C                           INPUT IS OTHERWISE.
C
C  IERR    1   I*4    O     ERROR RETURN FLAG.
C                           =0, NO ERROR. =1, ERROR.
C
C***********************************************************************
C
C  CODED BY C PETRUZZO. 9/81.
C  MODIFIED....... CJP. 12/84. MOD TO ALLOW RSTART AND RSTOP TO BE THE
C                              SAME ARRAY IN THE CALLER. DITTO FOR V'S.
C                              ALSO, CHECKS FOR ZERO PROPAGATION TIME.
C                  CJP. 11/86. MINOR COMMENT MOD IN PROLOGUE. NO CODE
C                              MOD.
C
C***********************************************************************
C
      REAL*8 RSTART(3),VSTART(3),RSTOP(3),VSTOP(3)
      REAL*8 KEPLER(6),RTEMP(3),VTEMP(3)
C
      IF(TPROP.NE.0.D0) THEN
C
        CALL TOKEPL(GRAVMU,RSTART,VSTART,KEPLER,DUM,DUM)
        DELM = TPROP / DSQRT(KEPLER(1)**3/GRAVMU)
        KEPLER(6) = EQVANG(KEPLER(6) + DELM)
        CALL TOCART(GRAVMU,KEPLER,0,RTEMP,VTEMP,IERPNT,IERR)
        IF(IERR.NE.0) IERR = 1
        RSTOP(1) = RTEMP(1)
        RSTOP(2) = RTEMP(2)
        RSTOP(3) = RTEMP(3)
        VSTOP(1) = VTEMP(1)
        VSTOP(2) = VTEMP(2)
        VSTOP(3) = VTEMP(3)
C
      ELSE
        RSTOP(1) = RSTART(1)
        RSTOP(2) = RSTART(2)
        RSTOP(3) = RSTART(3)
        VSTOP(1) = VSTART(1)
        VSTOP(2) = VSTART(2)
        VSTOP(3) = VSTART(3)
        END IF
C
      RETURN
      END


c=======================================================================
c
c     GENBET
c
c     General Beta distribution generator
c
c     Returns a single random deviate from the beta distribution with
c     parameters A and B.  The density of the beta is
c               x^(a-1) * (1-x)^(b-1) / B(a,b) for 0 < x < 1
c
c-----------------------------------------------------------------------
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION genbet(aa, bb)
c-----------------------------------------------------------------------
c
c     INPUT :
c      a : first parameter of the beta distribution (a>1.0E-37)   double
c      b : second parameter of the beta distribution (b>1.0E-37)  double
c
c     Method
c
c     R. C. H. Cheng
c     Generating Beta Variates with Nonintegral Shape Parameters
c     Communications of the ACM, 21:317-322  (1978) (Algorithms BB and BC)
c
c------------------------------------------------------------------------
c
c     parameters
c     close to the largest number that can be exponentiated
      DOUBLE PRECISION expmax
C     JJV changed this - 89 was too high, and LOG(1.0E38) = 87.49823
      PARAMETER (expmax=87.49823)
C     Close to the largest representable single precision number
      DOUBLE PRECISION infnty
      PARAMETER (infnty=1.0E38)
C     JJV added the parameter minlog
C     Close to the smallest number of which a LOG can be taken.
      DOUBLE PRECISION minlog
      PARAMETER (minlog=1.0E-37)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION aa,bb
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION a,alpha,b,beta,delta,gamma,k1,k2,olda,oldb,r,s,t,
     +     u1,u2,v,w,y,z
      LOGICAL qsame
C     ..
C     .. External Functions ..
      DOUBLE PRECISION ranf
      EXTERNAL ranf
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC exp,log,max,min,sqrt
C     ..
C     .. Save statement ..
C     JJV added a,b
      SAVE olda,oldb,alpha,beta,gamma,k1,k2,a,b
C     ..
C     .. Data statements ..
C     JJV changed these to ridiculous values
      DATA olda,oldb/-1.0E37,-1.0E37/
C     ..
C     .. Executable Statements ..
      qsame = (olda.EQ.aa) .AND. (oldb.EQ.bb)
      IF (qsame) GO TO 20
C     JJV added small minimum for small log problem in calc of W
C     in Rand.c
   10 olda = aa
      oldb = bb
   20 IF (.NOT. (min(aa,bb).GT.1.0)) GO TO 100
c
c     Alborithm BB
c
c     Initialize
c
      IF (qsame) GO TO 30
      a = min(aa,bb)
      b = max(aa,bb)
      alpha = a + b
      beta = sqrt((alpha-2.0)/ (2.0*a*b-alpha))
      gamma = a + 1.0/beta
   30 CONTINUE
   40 u1 = ranf()
C
C     Step 1
C
      u2 = ranf()
      v = beta*log(u1/ (1.0-u1))
C     JJV altered this
      IF (v.GT.expmax) GO TO 55
C     JJV added checker to see if a*exp(v) will overflow
C     JJV 50 _was_ w = a*exp(v); also note here a > 1.0
   50 w = exp(v)
      IF (w.GT.infnty/a) GO TO 55
      w = a*w
      GO TO 60
 55   w = infnty

   60 z = u1**2*u2
      r = gamma*v - 1.3862944
      s = a + r - w
C
C     Step 2
C
      IF ((s+2.609438).GE. (5.0*z)) GO TO 70
C
C     Step 3
C
      t = log(z)
      IF (s.GT.t) GO TO 70
C
C     Step 4
C
C     JJV added checker to see if log(alpha/(b+w)) will
C     JJV overflow.  If so, we count the log as -INF, and
C     JJV consequently evaluate conditional as true, i.e.
C     JJV the algorithm rejects the trial and starts over
C     JJV May not need this here since ALPHA > 2.0
      IF (alpha/(b+w).LT.minlog) GO TO 40

      IF ((r+alpha*log(alpha/ (b+w))).LT.t) GO TO 40
C
C     Step 5
C
   70 IF (.NOT. (aa.EQ.a)) GO TO 80
      genbet = w/ (b+w)
      GO TO 90

   80 genbet = b/ (b+w)
   90 GO TO 230

C     Algorithm BC

C
C     Initialize
C
  100 IF (qsame) GO TO 110
      a = max(aa,bb)
      b = min(aa,bb)
      alpha = a + b
      beta = 1.0/b
      delta = 1.0 + a - b
      k1 = delta* (0.0138889+0.0416667*b)/ (a*beta-0.777778)
      k2 = 0.25 + (0.5+0.25/delta)*b
  110 CONTINUE
  120 u1 = ranf()
C
C     Step 1
C
      u2 = ranf()
      IF (u1.GE.0.5) GO TO 130
C
C     Step 2
C
      y = u1*u2
      z = u1*y
      IF ((0.25*u2+z-y).GE.k1) GO TO 120
      GO TO 170
C
C     Step 3
C
  130 z = u1**2*u2
      IF (.NOT. (z.LE.0.25)) GO TO 160
      v = beta*log(u1/ (1.0-u1))

C     JJV instead of checking v > expmax at top, I will check
C     JJV if a < 1, then check the appropriate values

      IF (a.GT.1.0) GO TO 135
C     JJV A < 1 so it can help out if EXP(V) would overflow
      IF (v.GT.expmax) GO TO 132
      w = a*exp(v)
      GO TO 200
 132  w = v + log(a)
      IF (w.GT.expmax) GO TO 140
      w = exp(w)
      GO TO 200

C     JJV in this case A > 1
 135  IF (v.GT.expmax) GO TO 140
      w = exp(v)
      IF (w.GT.infnty/a) GO TO 140
      w = a*w
      GO TO 200
 140  w = infnty
      GO TO 200

  160 IF (z.GE.k2) GO TO 120
C
C     Step 4
C
C
C     Step 5
C
  170 v = beta*log(u1/ (1.0-u1))

C     JJV same kind of checking as above
      IF (a.GT.1.0) GO TO 175
C     JJV A < 1 so it can help out if EXP(V) would overflow
      IF (v.GT.expmax) GO TO 172
      w = a*exp(v)
      GO TO 190
 172  w = v + log(a)
      IF (w.GT.expmax) GO TO 180
      w = exp(w)
      GO TO 190

C     JJV in this case A > 1
 175  IF (v.GT.expmax) GO TO 180
      w = exp(v)
      IF (w.GT.infnty/a) GO TO 180
      w = a*w
      GO TO 190

  180 w = infnty

C     JJV here we also check to see if log overlows; if so, we treat it
C     JJV as -INF, which means condition is true, i.e. restart
  190 IF (alpha/(b+w).LT.minlog) GO TO 120
      IF ((alpha* (log(alpha/ (b+w))+v)-1.3862944).LT.log(z)) GO TO 120
C
C     Step 6
C
  200 IF (.NOT. (a.EQ.aa)) GO TO 210
      genbet = w/ (b+w)
      GO TO 220

  210 genbet = b/ (b+w)
  220 CONTINUE
  230 RETURN

      END


program transmission
    implicit none !Define Everything
    real :: a,K=9.0,lam=2.0,T,abs=100 !a = Incident Wave Vector; E = K^2; lam = \lambda; T = Transmission Amplitude; abs = Upper limit check for Transmission amplitude
    ! for which loop will terminate
    integer :: i =180,M,j,Mmax=20 ! Mmax = Maximum number of matrix multiplication.
    complex :: cs,ct,z,z1 !cs = Complex Resistance Amplitude; ct = complex inverse transmission amplitude, z = phase factor; z1 = complex conjugate of z

    CALL SYSTEM("touch gnuscript.gnu") !creating the files in advance to prevent any error
    CALL SYSTEM("touch data.dat")

    open(1,file="data.dat",status="old")!Opening file for writing data

    !!!!!!!!!!!!!!!! Main Program starts here !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    do j=1,10000
        K = Float(j)/1000.0

        do i = 1000, 5000
            cs = complex(0,-1*lam/K)
            ct = (1,0)-cs
            a = Float(i)/1000.0
            z = CExp(complex(0,K*a))
            z1 = CExp(complex(0,-1*K*a))
            do M = 1, Mmax
                ct = z1*ct*ct + z*(CAbs(cs))**2
                cs = cs*(z*(ct*complex(1,-1))+z1*ct)
                T = real(CAbs(ct))
                if ( T>abs) then !checking the value of transmission cofficient if more than abs then the solution is unbounded and exit the loop
                    ! write(1,*) K,a
                    exit
                end if
                if ( M==Mmax ) then
                    write(1,*) K,a
                end if
            end do
        end do
    end do

    !!!!!!!!!!!!!!! Main Program Ends Here !!!!!!!!!!!!!!!!!!!!!!!!!!

    close(1)

    !!!!!!!!!!!!!!! Gnuplot graphing starts here !!!!!!!!!!!!!!!!!!!!

    open(2,file="gnuscript.gnu",status="old") ! gnuscipt for plotting

    ! character :: filewrite = 'plot "data.dat" w p pt 7 ps 0.01 \n set xlabel "K" \n set ylabel "Incident wavevector a" \n set title "Plot of the bands using Kronig-Penney model"'
    ! ! filewrite = '

    write(2,*) "plot 'data.dat' w p pt 7 ps 0.01"
    write(2,*) "set xlabel 'K'"
    write(2,*) "set ylabel 'Incident wavevector a'"
    write(2,*) "set title 'Plot of the bands using Kronig-Penney model'"
    write(2,*) "pause 30" !To keep the interactive window
    close(2)

    CALL SYSTEM("gnuplot -persist gnuscript.gnu")
end program transmission

Quantum Transmission in Periodic Potential/QuantumTransmission.f95


!  Solve riemann shock tube problem for a general equation of state using
!  the method of Colella and Glaz.  Use a two shock approximation, and
!  linearly interpolation between the head and tail of a rarefaction to
!  treat rarefactions.
!
!  The Riemann problem for the Euler's equation produces 4 states,
!  separated by the three characteristics (u - cs, u, u + cs):
!
!
!        l_1      t    l_2       l_3
!         \       ^   .       /
!          \  *L  |   . *R   /
!           \     |  .     /
!            \    |  .    /
!        L    \   | .   /    R
!              \  | .  /
!               \ |. /
!                \|./
!       ----------+----------------> x
!
!       l_1 = u - cs   eigenvalue
!       l_2 = u        eigenvalue (contact)
!       l_3 = u + cs   eigenvalue
!
!       only density jumps across l_2
!
!  References:
!
!   CG:   Colella & Glaz 1985, JCP, 59, 264.
!
!   CW:   Colella & Woodward 1984, JCP, 54, 174.
!
!   Fry:  Fryxell et al. 2000, ApJS, 131, 273.
!
!   Toro: Toro 1999, ``Riemann Solvers and Numerical Methods for Fluid
!         Dynamcs: A Practical Introduction, 2nd Ed.'', Springer-Verlag
!

module riemann_module

  implicit none

contains

  subroutine riemann(gamma, &
                     rho_l, u_l, p_l_in, &
                     rho_r, u_r, p_r_in, &
                     F_dens, F_xmom, F_ener)

    implicit none

    integer :: n

    double precision, intent(in) :: gamma
    double precision, intent(in) :: rho_l, u_l, p_l_in
    double precision, intent(in) :: rho_r, u_r, p_r_in
    double precision :: F_dens, F_xmom, F_ener

    double precision :: riemann_tol
    integer :: nriem

    double precision :: scratch, scratch2
    double precision :: ustar_sgn

    double precision :: tau_l, p_l, c_l
    double precision :: tau_r, p_r, c_r

    double precision :: pstar, pstar1, pstar2
    double precision :: w_l, w_l1
    double precision :: w_r, w_r1

    double precision :: wes, westar
    double precision :: rhos, rhostr, us, ustar, ps

    double precision :: smlrho, smallp, smallu

    double precision :: ustar_l1, ustar_r1, ustar_l2, ustar_r2, delu1, delu2

    double precision :: rhoav, uav, pav

    double precision :: eps

    double precision :: pres_err
    logical :: has_converged

    double precision :: vs, vstar, ces, cestar, ws

    ! some parameters
    riemann_tol = 1.d-5
    nriem = 15

    eps = 1.d-8

    smlrho = 1.d-10
    smallp = 1.d-10
    smallu = 1.d-10

    ! specific volume
    tau_l = 1.d0/max(rho_l, smlrho)
    tau_r = 1.d0/max(rho_r, smlrho)

    p_l = max(smallp, p_l_in)
    p_r = max(smallp, p_r_in)

    c_l = sqrt(gamma*p_l*rho_l)
    c_r = sqrt(gamma*p_r*rho_r)

    ! construct first guess for secant iteration by assuming that the
    ! nonlinear wave speed is equal to the sound speed -- the resulting
    ! expression is the same as Toro, Eq. 9.28 in the Primitive Variable
    ! Riemann Solver (PVRS).  See also Fry Eq. 72.
    pstar1 = p_r - p_l - c_r*(u_r - u_l)
    pstar1 = p_l + pstar1*(c_l/(c_l + c_r))
    pstar1 = max(smallp, pstar1)

    ! calculate nonlinear wave speeds for the left and right moving
    ! waves based on the first guess for the pressure jump.  Again,
    ! there is a left and a right wave speed.  Compute this using CG
    ! Eq. 34.

    ! note -- we simplify a lot here, assuming constant gamma
    w_l1 = pstar1 + 0.5d0*(gamma - 1.0d0)*(pstar1 + p_l)
    w_l1 = sqrt(rho_l*abs(w_l1))

    w_r1 = pstar1 + 0.5d0*(gamma - 1.0d0)*(pstar1 + p_r)
    w_r1 = sqrt(rho_r*abs(w_r1))

    ! construct second guess for the pressure using the nonlinear wave
    ! speeds from the first guess.  This is basically the same thing we
    ! did to get pstar1, except now we are using the better wave speeds
    ! instead of the sound speed.
    pstar2 = p_r - p_l - w_r1*(u_r - u_l)
    pstar2 = p_l + pstar2*w_l1/(w_l1 + w_r1)
    pstar2 = max(smallp, pstar2)

    ! begin the secant iteration -- see CG Eq. 17 for details.  We will
    ! continue to interate for convergence until the error falls below
    ! tol (in which case, things are good), or we hit nriem iterations
    ! (in which case we have a problem, and we spit out an error).
    has_converged = .false.

    do n = 1, nriem

       ! new nonlinear wave speeds, using CG Eq. 34
       w_l = pstar2 + 0.5d0*(gamma  - 1.d0)*(pstar2 + p_l)
       w_l = sqrt(rho_l*abs(w_l))

       w_r = pstar2 + 0.5d0*(gamma - 1.d0)*(pstar2 + p_r)
       w_r = sqrt(rho_r*abs(w_r))

       ! compute the velocities in the "star" state -- using CG
       ! Eq. 18 -- ustar_l2 and ustar_r2 are the velocities they define
       ! there.  ustar_l1 and ustar_l2 seem to be the velocities at the
       ! last time, since pstar1 is the old 'star' pressure, and
       ! w_l1 is the old wave speed.
       ustar_l1 = u_l - (pstar1 - p_l)/w_l1
       ustar_r1 = u_r + (pstar1 - p_r)/w_r1
       ustar_l2 = u_l - (pstar2 - p_l)/w_l
       ustar_r2 = u_r + (pstar2 - p_r)/w_r

       delu1 = ustar_l1 - ustar_r1
       delu2 = ustar_l2 - ustar_r2

       scratch = delu2  - delu1

       if (abs(pstar2 - pstar1) <= smallp) scratch = 0.d0

       if (abs(scratch) < smallu) then
          delu2 = 0.d0
          scratch = 1.d0
       endif

       ! pressure at the "star" state -- using CG Eq. 18
       pstar = pstar2 - delu2*(pstar2 - pstar1)/scratch
       pstar = max(smallp, pstar)

       ! check for convergence of iteration
       pres_err = abs(pstar - pstar2)/pstar
       if (pres_err < riemann_tol) then
          has_converged = .true.
          exit
       endif

       ! reset variables for next iteration
       pstar1 = pstar2
       pstar2 = pstar

       w_l1 = w_l
       w_r1 = w_r

    enddo

    if (.not. has_converged) then

       print *, " "
       print *, "Nonconvergence in subroutine rieman!"
       print *, "Pressure error = ", pres_err
       print *, "pL = ", p_l, " pR = ", p_r
       print *, "uL = ", u_l, " uR = ", u_r
       print *, "cL = ", c_l, " c_r = ", c_r
       print *, "Terminating execution"
       stop

    endif

    ! end of secant iteration

    ! calculate fluid velocity for the "star" state -- this comes from
    ! the shock jump equations, Fry Eq. 68 and 69.  The ustar velocity
    ! can be computed using either the jump eq. for a left moving or
    ! right moving shock -- we use the average of the two.

    scratch = u_l - (pstar - p_l)/w_l
    scratch2 = u_r + (pstar - p_r)/w_r
    ustar = 0.5d0*(scratch + scratch2)

    ustar_sgn = sign(1.d0, ustar)

    ! decide which state is located at the zone iterface based on
    ! the values of the wave speeds.  This is just saying that if
    ! ustar > 0, then the state is U_L.  if ustar < 0, then the
    ! state on the axis is U_R.
    scratch = 0.5d00*(1.0d0 + ustar_sgn)
    scratch2 = 0.5d0*(1.0d0 - ustar_sgn)

    ps = p_l*scratch + p_r*scratch2
    us = u_l*scratch + u_r*scratch2
    vs = tau_l*scratch + tau_r*scratch2

    rhos = 1.0d0/vs
    rhos = max(smlrho, rhos)

    vs = 1.0d0/rhos
    ws = w_l*scratch + w_r*scratch2
    ces = sqrt(gamma*ps*vs)

    ! compute rhostar, using the shock jump condition (Fry Eq. 80)
    vstar = vs - (pstar - ps)/(ws*ws)
    rhostr = 1.0d0/ vstar
    cestar = sqrt(gamma*pstar*vstar)

    ! compute some factors, Fry Eq. 81 and 82
    wes = ces - ustar_sgn*us
    westar = cestar - ustar_sgn*ustar

    scratch = ws*vs - ustar_sgn*us

    if (pstar - ps >= 0.d0) then
       wes = scratch
       westar = scratch
    endif

    ! compute correct state for rarefaction fan by linear interpolation
    scratch = max(wes - westar, wes + westar)
    scratch = max(scratch, smallu)

    scratch = (wes + westar)/scratch

    scratch = 0.5d0*(1.0d0 + scratch)
    scratch2 = 1.0d0 - scratch

    rhoav = scratch*rhostr + scratch2*rhos
    uav = scratch*ustar + scratch2*us
    pav = scratch*pstar + scratch2*ps

    if (westar >= 0.0d0) then
       rhoav  = rhostr
       uav = ustar
       pav = pstar
    endif

    if (wes < 0.0d0) then
       rhoav = rhos
       uav = us
       pav = ps
    endif

    ! now compute the fluxes
    F_dens = rhoav*uav
    F_xmom = rhoav*uav*uav + pav
    F_ener = uav*(pav/(gamma - 1.0d0) + 0.5d0*rhoav*uav*uav + pav)

    return
  end subroutine riemann

end module riemann_module


SUBROUTINE slope_aspect(nrow, ncol, nrow_alloc, ncol_alloc, &
    dresx, dresy, spheroid, alat, is_utm, dem, &
    theta, phit, ierr)
! this program is used to calculate slope and aspect angles
! using Sobel filter
! note: the row and column of DEM data must be larger
! than the image (extra each line and column for the four sides.
! it is needed for sobel filter.

!   Inputs:
!       spheroid
!           1. Spheroid major axis
!           2. Inverse flattening
!           3. Eccentricity squared
!           4. Earth rotational angular velocity rad/sec

    integer*4, intent(in) :: nrow, ncol, nrow_alloc, ncol_alloc
    double precision, intent(in) :: dresx, dresy
    double precision, dimension(4), intent(in) :: spheroid
    double precision, dimension(ncol), intent(in) :: alat
    real, dimension(nrow, ncol), intent(in) :: dem
    real, dimension(nrow_alloc, ncol_alloc) :: theta, phit
    logical is_utm
    integer*4, intent(out) ::  ierr

!    real*8 dresx, dresy
!    real*8 spheroid(4)
!    real*8 alat(nrow) ! remember that row starts at 2
!    real*4 dem(nrow, ncol) !
!    real*4 theta(nrow_alloc, ncol_alloc) !
!    real*4 phit(nrow_alloc, ncol_alloc) !
!    logical is_utm
!    integer*4 nrow_alloc, ncol_alloc, nrow, ncol, row, col
!    integer*4 ierr

! internal variables
    real*8 dx, dy
    real*8 pi, pia, pib
    real*8 p, q
    integer istat
    integer*4 n_row, n_col, row, col

!f2py depend(nrow, ncol), dem
!f2py depend(nrow_alloc, ncol_alloc), theta, phit
!f2py depend(ncol), alat

!feff2py intent(in) dresx, dresy, spheroid, alat, dem, is_utm
!feff2py intent(inout) theta, phit
!feff2py intent(out) ierr
!feff2py integer intent(hide),depend(solar) :: nrow_alloc=shape(solar,0), ncol_alloc=shape(solar,1)
!feff2py integer intent(hide),depend(dem) :: nrow=shape(dem,0), ncol=shape(dem,1)

!---------------------------------------------------------------------
!   upper left coordinator for satellite image.
!   here we assume that Landsat and DEM have same spatial resolution
!   and coordinator. The information can be obtained from satellite
!   header file. DEM header should add an extra pixel.
    pi=4.0d0*atan(1.0d0)
    pia=pi/180.0d0
    pib=180.0d0/pi
    ierr = 0;
!   check that the arrays dimensions are correct (relatively)
    if(ncol_alloc .ne. (ncol-2)) then
        ierr = 10
        return
    endif

    if(nrow_alloc .ne. (nrow-2)) then
        ierr = 11
        return
    endif

    n_col = ncol-2
    n_row = nrow-2

!   calculate pixel size in meters
    if(is_utm) then
        dx = dresx
        dy = dresy
    endif
!-------------------------------------------------------------------
    do col=2,n_col+1
        if(.not. is_utm) then
            call geo2metres_pixel_size(alat(col), dresx, dresy, &
                                       spheroid, dx, dy, istat)
        endif

        do row=2,n_row+1
!            We are taking as input Transposed arrays, as such we need to
!            reorder the convolution window operator.
!            p = &
!                      (dble(dem(row-1, col+1))-dble(dem(row-1, col-1)) + &
!                2.0d0*(dble(dem(row  , col+1))-dble(dem(row  , col-1))) + &
!                       dble(dem(row+1, col+1))-dble(dem(row+1, col-1))) / (8.0d0*dx)
!            q = &
!                      (dble(dem(row-1, col-1))-dble(dem(row+1, col-1)) + &
!                2.0d0*(dble(dem(row-1, col  ))-dble(dem(row+1, col  ))) + &
!                       dble(dem(row-1, col+1))-dble(dem(row+1, col+1))) / (8.0d0*dy)
             p = &
                      ((dble(dem(row+1, col-1)) - dble(dem(row-1, col-1))) + &
                 2.0d0*(dble(dem(row+1, col)) - dble(dem(row-1, col))) + &
                       (dble(dem(row+1, col+1)) - dble(dem(row-1, col+1)))) / (8.0*dx)
             q = &
                      ((dble(dem(row-1, col-1)) - dble(dem(row-1, col+1))) + &
                 2.0d0*(dble(dem(row, col-1)) - dble(dem(row, col+1))) + &
                       (dble(dem(row+1, col-1)) - dble(dem(row+1, col+1)))) / (8.0*dy)
    !----------------------------------------------------------------
            theta(row-1, col-1) = sngl(atan(sqrt(p**2 + q**2)) * pib)
            phit(row-1, col-1) = sngl(atan2(-p, -q) * pib)
            if (phit(row-1, col-1) .le. -180.0) phit(row-1, col-1) = phit(row-1, col-1) + 360.0
            if (phit(row-1, col-1) .gt.  180.0) phit(row-1, col-1) = phit(row-1, col-1) - 360.0
        enddo
    enddo
    return
END SUBROUTINE slope_aspect


module mod_mkkn

	implicit none

contains

subroutine MKKN(ds,gf,cnorm,kfe,nbi,nbdeg,ks0,kt0)

	implicit none

	integer, intent(in) :: kfe, nbdeg, ks0, kt0
	real(8), intent(in) :: gf(kfe,16), cnorm

	integer, intent(out) :: nbi
	real(8), intent(inout) :: ds(kfe)

	integer :: is, it, lc, ix, iy, lls, llt, ld
	real(8) :: da

	nbi = 0

	do it = 1, kt0+nbdeg
		do is = 1, ks0+nbdeg

			da = 0.d0
			nbi = nbi + 1
			lc = 0

			do iy = 0, nbdeg

				llt = it - nbdeg +iy

				do ix = 0, nbdeg

					lls = is - nbdeg + ix
					lc = lc + 1

					if(llt < 1 .or. llt > kt0) cycle
					if(lls < 1 .or. lls > ks0) cycle

					ld = lls + (llt-1) * ks0
					da = da + gf(ld,lc)

				end do
			end do

			ds(nbi) = da * cnorm

		end do
	end do

return
end subroutine MKKN

end module mod_mkkn


      SUBROUTINE PRECES(TI,TF,X,Y,Z,MODE)
      IMPLICIT REAL*8(A,B,C,D,E,F,G,H,O,P,Q,R,S,T,U,V,W,X,Y,Z)

      ATAN3(X,Y)=DMOD((DATAN2(X,Y)+6.2831853071796D0),6.2831853071796D0)

      T0=(TI-2415020.313417D0)/36524.21988D0
      TT=(TF-TI)/36524.21988D0
      ZT=(.011171319D0+6.767999D-6*T0)*TT+1.4641D-6*TT*TT+ 8.68D-8*TT**3
      ZZ=                              ZT+3.8349D-6*TT*TT
      TH=(.009718973D0-4.135460D-6*T0)*TT-2.0653D-6*TT*TT-20.36D-8*TT**3

      IF(MODE.EQ.1)then
          X0=X
          Y0=Y
          Z0=Z

      else ! MODE .EQ. 2
          X0=DCOS(Y)*DCOS(X)
          Y0=DSIN(Y)*DCOS(X)
          Z0=DSIN(X)

      endif

      SINZT=SIN(ZT)
C     PRINT*,'X0,Y0,Z0',X0,Y0,Z0
      COSZT=COS(ZT)
      SINTH=SIN(TH)
      COSTH=COS(TH)
      SINZZ=SIN(ZZ)
      COSZZ=COS(ZZ)
      XX=-SINZT*SINZZ+COSZT*COSTH*COSZZ
      XY=-COSZT*SINZZ-SINZT*COSTH*COSZZ
      XZ=-SINTH*COSZZ
      YX= SINZT*COSZZ+COSZT*COSTH*SINZZ
      YY= COSZT*COSZZ-SINZT*COSTH*SINZZ
      YZ=-SINTH*SINZZ
      ZX= SINTH*COSZT
      ZY=-SINTH*SINZT
      ZZ= COSTH
      X   =XX*X0+XY*Y0+XZ*Z0
      Y   =YX*X0+YY*Y0+YZ*Z0
      ZDUM=ZX*X0+ZY*Y0+ZZ*Z0
C     PRINT*,'X,YDUM,ZDUM',X,YDUM,ZDUM

      IF(MODE.EQ.1)THEN
          Z=ZDUM
C         PRINT*,'PRECES - X,Y,Z',X,Y,Z

      ELSE ! MODE .EQ. 2
          Y=ATAN3(Y,X)
          X=ASIN(ZDUM)
C         PRINT*,'PRECES RA=',Y,' DEC = ',X

      ENDIF

      RETURN
      END


SUBROUTINE ENVCN
!======================================
! Environment CNi
!======================================
! Calculating the analytic CNi for a cluster with an interacting evnvironment.
! To use the Fermi formulation of the CNi use 2nd version of the subroutine, ENVCN2.
!======================================

   USE PARACLUSTER
   USE CLUSTER
   USE POTENTIAL
   USE ENFORCE
   USE DISTANCE
   USE ENVIRONMENT

   IMPLICIT NONE

   integer               :: i, j, env_mminusn_pwr
   real(8), dimension(3) :: env_rij0 ! 3 possible cases: atoms A-A, B-B, A-B
   REAL(8), DIMENSION(nsiz,nsiz)   :: env_dij, env_df_dx, env_df_dy, env_df_dz

   if (ipas.eq.1) write(*,*) 'cnum> first calculation of sigmoid function (CN)'

   !---------------------------------------------------
   env_mminusn_pwr = env_m_pwr - env_n_pwr

   ! Evaluating the values of rij0 parameter in dependence of atom pair kind
   env_rij0 = dist * env_rzero * dsqrt(2.d0)

   !---------------------------------------------------
   ! Calculating the analytic coordination number
   ! The sum of these s(i,j) is the analytic coord no.

   ! Default Case: (dij(j,i) .LE. 0.d0)
   env_s  = 1.d0
   ! Derivative of s
   env_dS = 0.d0

   DO i = 1, natom
      DO j = 1, natom
         ! Distance between atom i and atom j
         ! minus the ref distance for the couple of atoms
         env_dij(j,i) = pair_dist(j,i) - dist(pairkindmat(j,i))
      END DO
   END DO

   ! Elements on the diagonal
   DO i = 1, natom
      env_s(i,i) = 0.d0
   END DO

   ! Case (dij(j,i) .GT. 0.d0)
   DO i = 1, natom-1
      DO j = i+1, natom
         IF (env_dij(j,i) .GT. 0.d0) THEN
            env_ratio = env_dij(j,i)/env_rij0(pairkindmat(j,i))
            ! I need to rise to (X_pwr-1) for the derivative
            env_ratio_ton = env_ratio**(env_n_pwr-1)
            env_ratio_tom = env_ratio_ton*(env_ratio**(env_mminusn_pwr))

            ! Calculating some pieces of derivative
            env_rnp = env_n_pwr * env_ratio_ton
            env_rmp = env_m_pwr * env_ratio_tom

            ! Now ratio_ton becomes really ratio to n_pwr
            env_ratio_ton = env_ratio_ton * env_ratio

            ! Another piece of derivative
            env_num = env_rmp - env_rnp - env_mminusn_pwr*env_ratio_ton*env_ratio_tom
            ! same as:
            ! num = rmp - rnp + ( n_pwr - m_pwr )*ratio**(n_pwr + m_pwr - 1)

            ! Now ratio_tom becomes really ratio to m_pwr
            env_ratio_tom = env_ratio_tom * env_ratio

            ! The sum of these s(i,j) is the analytic coord no.
            env_s(j,i) = (1.d0-env_ratio_ton)/(1.d0-env_ratio_tom)  ! this is f(rij)
            env_s(i,j) = env_s(j,i)

            ! Derivative of s
            env_dS(j,i) = env_num/( env_rij0(pairkindmat(j,i))* (1.d0 - env_ratio_tom)**2)
            env_dS(i,j) = env_dS(j,i)
         END IF
      END DO ! on j
   END DO ! on i

   ! KR: Calculating the sum of s(i,j), which is CNatom(i), global.
   ! This is the coord num of any single atom i
   ! No problem because s(i,i) is always zero
   DO i = 1, natom
      env_cn(i) = SUM(env_s(:,i))
      WRITE(184,*) i, env_cn(i)
   END DO

   !-------------------------------------------------------------------------
   ! Calculating the sum on j of derivatives of s
   ! with respect to coordinates of every atoms
   DO i = 1, natom
      DO j = 1, natom
         IF (j .NE. i) THEN
            ! Calculating the derivative of coordination number with
            ! respect to distance between atoms i and j, multiplied for
            ! the derivative of distance between atoms i and j
            ! with respect to position of atom i
            env_comfactor  = env_dS(j,i)/ pair_dist(j,i)
            env_dS_dx(j,i) = env_comfactor * xyz_dist(1,j,i) ! order of indexes depends on the definition of xyz_dist
            env_dS_dy(j,i) = env_comfactor * xyz_dist(2,j,i) ! order of indexes depends on the definition of xyz_dist
            env_dS_dz(j,i) = env_comfactor * xyz_dist(3,j,i) ! order of indexes depends on the definition of xyz_dist
         ELSE
            env_dS_dx(j,i) = 0.d0
            env_dS_dy(j,i) = 0.d0
            env_dS_dz(j,i) = 0.d0
         END IF
      END DO
   END DO

   DO i = 1, natom
      env_dcn_dx(i) = 2.d0 * SUM(env_dS_dx(1:natom, i))
      env_dcn_dy(i) = 2.d0 * SUM(env_dS_dy(1:natom, i))
      env_dcn_dz(i) = 2.d0 * SUM(env_dS_dz(1:natom, i))
      write(204,*) i, env_dcn_dx(i), env_dcn_dy(i), env_dcn_dz(i)
   END DO

END SUBROUTINE envcn


      SUBROUTINE MB01OC( UPLO, TRANS, N, ALPHA, BETA, R, LDR, H, LDH, X,
     $                   LDX, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To perform one of the special symmetric rank 2k operations
C
C        R := alpha*R + beta*H*X + beta*X*H',
C     or
C        R := alpha*R + beta*H'*X + beta*X*H,
C
C     where alpha and beta are scalars, R and X are N-by-N symmetric
C     matrices, and H is an N-by-N upper Hessenberg matrix.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangles of the symmetric matrices R
C             and X are given as follows:
C             = 'U':  the upper triangular part is given;
C             = 'L':  the lower triangular part is given.
C
C     TRANS   CHARACTER*1
C             Specifies the operation to be performed as follows:
C             = 'N':         R := alpha*R + beta*H*X  + beta*X*H';
C             = 'T' or 'C':  R := alpha*R + beta*H'*X + beta*X*H.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices R, H, and X.  N >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             The scalar alpha. When alpha is zero then R need not be
C             set before entry, except when R is identified with X in
C             the call.
C
C     BETA    (input) DOUBLE PRECISION
C             The scalar beta. When beta is zero then H and X are not
C             referenced.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR,N)
C             On entry with UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix R.
C             On entry with UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix R.
C             In both cases, the other strictly triangular part is not
C             referenced.
C             On exit, the leading N-by-N upper triangular part (if
C             UPLO = 'U'), or lower triangular part (if UPLO = 'L'), of
C             this array contains the corresponding triangular part of
C             the computed matrix R.
C
C     LDR     INTEGER
C             The leading dimension of the array R.  LDR >= MAX(1,N).
C
C     H       (input) DOUBLE PRECISION array, dimension (LDH,N)
C             On entry, the leading N-by-N upper Hessenberg part of this
C             array must contain the upper Hessenberg matrix H.
C             The remaining part of this array is not referenced.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= MAX(1,N).
C
C     X       (input) DOUBLE PRECISION array, dimension (LDX,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular part of the symmetric matrix X and the strictly
C             lower triangular part of the array is not referenced.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular part of the symmetric matrix X and the strictly
C             upper triangular part of the array is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= MAX(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -k, the k-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix expression is efficiently evaluated taking the
C     structure into account, and using inline code and BLAS1 routines.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires approximately N**3/2 operations.
C
C     FURTHER COMMENTS
C
C     This routine acts as a specialization of BLAS Library routine
C     DSYR2K.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2019.
C
C     REVISIONS
C
C     V. Sima, Mar. 2019.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         TRANS, UPLO
      INTEGER           INFO, LDH, LDR, LDX, N
      DOUBLE PRECISION  ALPHA, BETA
C     .. Array Arguments ..
      DOUBLE PRECISION  H(LDH,*), R(LDR,*), X(LDX,*)
C     .. Local Scalars ..
      DOUBLE PRECISION  TEMP1, TEMP2
      INTEGER           I, J, L
      LOGICAL           LTRANS, LUPLO
C     .. Local Arrays ..
      DOUBLE PRECISION  TMP(1)
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DLASCL, DLASET, DSCAL, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO   = 0
      LUPLO  = LSAME( UPLO,  'U' )
      LTRANS = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF (      ( .NOT.LUPLO  ).AND.( .NOT.LSAME( UPLO,  'L' ) ) ) THEN
         INFO = -1
      ELSE IF ( ( .NOT.LTRANS ).AND.( .NOT.LSAME( TRANS, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF ( N.LT.0 ) THEN
         INFO = -3
      ELSE IF ( LDR.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF ( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF ( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -11
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01OC', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      IF ( BETA.EQ.ZERO ) THEN
         IF ( ALPHA.EQ.ZERO ) THEN
C
C           Special case alpha = 0.
C
            CALL DLASET( UPLO, N, N, ZERO, ZERO, R, LDR )
         ELSE
C
C           Special case beta = 0.
C
            IF ( ALPHA.NE.ONE )
     $         CALL DLASCL( UPLO, 0, 0, ONE, ALPHA, N, N, R, LDR, INFO )
         END IF
         RETURN
      END IF
C
C     General case: beta <> 0.
C     Compute R = alpha*R + beta*( op( H )*X + X*op( H )' ), exploiting
C     the structure, where op( H ) is H, if UPLO = 'U', and H', if
C     UPLO = 'L'.
C
      IF ( .NOT.LTRANS ) THEN
C
C        Form  R := alpha*R + beta*( H*X + X*H' ).
C
         IF ( LUPLO ) THEN
            DO 20 J = 1, N
               IF ( ALPHA.EQ.ZERO ) THEN
                  TMP(1) = ZERO
                  CALL DCOPY( J, TMP, 0, R(1,J), 1 )
               ELSE IF ( ALPHA.NE.ONE ) THEN
                  CALL DSCAL( J, ALPHA, R(1,J), 1 )
               END IF
               I = MAX( 1, J-1 )
               DO 10 L = 1, N
                  IF ( L.LE.J ) THEN
                     TEMP1 = X(L,J)
                  ELSE
                     TEMP1 = X(J,L)
                  END IF
                  IF ( TEMP1.NE.ZERO )
     $               CALL DAXPY( MIN( L+1, J ), BETA*TEMP1, H(1,L), 1,
     $                           R(1,J), 1 )
                  IF ( L.GE.I ) THEN
                     TEMP2 = H(J,L)
                     IF ( TEMP2.NE.ZERO ) THEN
                        TEMP2 = BETA*TEMP2
                        CALL DAXPY( I, TEMP2, X(1,L), 1, R(1,J), 1 )
                        IF ( J.GT.1 )
     $                     R(J,J) = R(J,J) + TEMP1*TEMP2
                     END IF
                  END IF
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40 J = 1, N
               IF ( ALPHA.EQ.ZERO ) THEN
                  TMP(1) = ZERO
                  CALL DCOPY( N-J+1, TMP, 0, R(J,J), 1 )
               ELSE IF ( ALPHA.NE.ONE ) THEN
                  CALL DSCAL( N-J+1, ALPHA, R(J,J), 1 )
               END IF
               DO 30 L = MAX( 1, J-1 ), N
                  I = MIN( L+1, N )
                  TEMP2 = BETA*H(J,L)
                  IF ( L.GE.J ) THEN
                     TEMP1 = BETA*X(L,J)
                  ELSE
                     TEMP1 = BETA*X(J,L)
                  END IF
                  CALL DAXPY( I-J+1, TEMP1, H(J,L), 1,   R(J,J), 1 )
                  CALL DAXPY( N-L+1, TEMP2, X(L,L), 1,   R(L,J), 1 )
                  IF ( L.GT.J )
     $              CALL DAXPY( L-J, TEMP2, X(L,J), LDX, R(J,J), 1 )
   30          CONTINUE
   40       CONTINUE
         END IF
      ELSE
C
C        Form  R := alpha*R + beta*( H'*X + X*H ).
C
         IF ( LUPLO ) THEN
            DO 70 J = 1, N
               IF ( ALPHA.EQ.ZERO ) THEN
                  TMP(1) = ZERO
                  CALL DCOPY( J, TMP, 0, R(1,J), 1 )
               ELSE IF ( ALPHA.NE.ONE ) THEN
                  CALL DSCAL( J, ALPHA, R(1,J), 1 )
               END IF
               DO 60 I = 1, J
                  DO 50 L = 1, MIN( J+1, N )
                     IF ( L.LE.J ) THEN
                        TEMP1 = X(L,J)
                        IF ( L.LE.I ) THEN
                           TEMP2 = X(L,I)
                        ELSE
                           TEMP2 = X(I,L)
                        END IF
                     ELSE
                        TEMP1 = X(J,L)
                        TEMP2 = X(I,L)
                     END IF
                     IF ( L.LE.MIN( I+1, N ) )
     $                  R(I,J) = R(I,J) + BETA*TEMP1*H(L,I)
                     R(I,J)    = R(I,J) + BETA*TEMP2*H(L,J)
   50             CONTINUE
   60          CONTINUE
   70       CONTINUE
         ELSE
            DO 100 J = 1, N
               IF ( ALPHA.EQ.ZERO ) THEN
                  TMP(1) = ZERO
                  CALL DCOPY( N-J+1, TMP, 0, R(J,J), 1 )
               ELSE IF ( ALPHA.NE.ONE ) THEN
                  CALL DSCAL( N-J+1, ALPHA, R(J,J), 1 )
               END IF
               DO 90 I = J, N
                  DO 80 L = 1, MIN( I+1, N )
                     IF ( L.GE.I ) THEN
                        TEMP1 = X(L,J)
                        TEMP2 = X(L,I)
                     ELSE
                        IF ( L.GE.J ) THEN
                           TEMP1 = X(L,J)
                        ELSE
                           TEMP1 = X(J,L)
                        END IF
                        TEMP2 = X(I,L)
                     END IF
                     R(I,J) = R(I,J) + BETA*TEMP1*H(L,I)
                     IF ( L.LE.MIN( J+1, N ) )
     $                  R(I,J) = R(I,J) + BETA*TEMP2*H(L,J)
   80             CONTINUE
   90          CONTINUE
  100       CONTINUE
         END IF
      END IF
C
      RETURN
C *** Last line of MB01OC ***
      END


FUNCTION int1(x2)

USE Atmosphere
USE BLParams
USE Precision
USE TNOConstants
USE Wavenumber
USE AirfoilParams

implicit none

REAL (kind=4):: alpha
REAL (kind=4):: alpha_gauss
REAL (kind=4):: Cfin
REAL (kind=4):: delta
REAL (kind=4):: dudx
REAL (kind=4):: int1
REAL (kind=4):: ke
REAL (kind=4):: k1_hat
REAL (kind=4):: k3_hat
REAL (kind=4):: kT
REAL (kind=4):: L
REAL (kind=4):: Nut
REAL (kind=4):: phi22
REAL (kind=4):: phim
REAL (kind=4):: ums
REAL (kind=4):: u_star
REAL (kind=4):: U
REAL (kind=4):: Uc
REAL (kind=4):: Uo
REAL (kind=4):: W
REAL (kind=4):: x2

REAL (kind=4), EXTERNAL :: gamma,dgamma

Uo=Mach*co

!constants from xfoil
if (ISSUCTION) then
    alpha = 0.45 ! = 0.3 pressure, = 0.45 suction
    Cfin = Cf(1)
    delta = d99(1)
else
    alpha = 0.30
    Cfin = Cf(2)
    delta = d99(2)
endif
if (Cfin .le. 0.) then
    write(*,*) 'Cf is less than zero, Cf = ',Cfin
    stop
endif
u_star = Uo*sqrt(Cfin/2.)

L = 0.085*delta/kappa*tanh(kappa*x2/(0.085*delta))

if (x2 .gt. delta)then
     U = Uo
     dudx = 0.
     int1 = 0.
     RETURN
else
     W = 1.-cos(pi*x2/delta);
     U = u_star*(1./kappa*log(u_star*x2/nu) +Cnuk+ (Uo/u_star-1./kappa*log(u_star*delta/nu)-Cnuk)*0.5*W)
     dudx = u_star*(1./(kappa*x2)+(Uo/u_star-1./kappa*log(u_star*delta/nu)-Cnuk)* &
            0.5*(pi/delta)*sin(pi*x2/delta))
endif

ke=sqrt(pi)/L*0.4213560764 !gamma(5./6.)/gamma(1./3.)
k1_hat = k1/ke
k3_hat = k3/ke

Nut = (L*kappa)**2.*abs(dudx)
!!kT = sqrt((Nut*dudx)**2./Cmu) ! implementation mistake corrected via emails to Pat Moriarty
kT = sqrt(Nut*(dudx)**2./Cmu) ! this is the correct one

ums = alpha*kT

Uc = 0.7*U
alpha_gauss = 0.05*Uc/L

phim = 1./(alpha_gauss*sqrt(pi))*exp(-((omega-Uc*k1)/alpha_gauss)**2.)

phi22 = 4./9./pi*1/ke**2.*(k1_hat**2.+k3_hat**2.)/(1.+k1_hat**2.+k3_hat**2.)**(7./3.)

int1 = L*ums*(dudx)**2*phi22*phim*exp(-2*abs(k)*x2)

RETURN

END FUNCTION int1


SUBROUTINE bee8(bee,coord,xi,eta,det)
!
! Analytical version of the bee matrix for an 8-node quad
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),xi,eta
 REAL(iwp),INTENT(OUT)::bee(:,:),det
 REAL::x1,x2,x3,x4,x5,x6,x7,x8,y1,y2,y3,y4,y5,y6,y7,y8,xi2,xi3,et2,et3,   &
   xi2et2,xi1et1,xi2et1,xi1et2,xy12,xy13,xy14,xy15,xy16,xy17,xy18,xy23,   &
   xy24,xy25,xy26,xy27,xy28,xy34,xy35,xy36,xy37,xy38,xy45,xy46,xy47,xy48, &
   xy56,xy57,xy58,xy67,xy68,xy78,xcu,xsq,xon,ecu,esq,eon,x2e2,x1e1,x2e1,  &
   x1e2,cons,bot,top,dn1dx,dn2dx,dn3dx,dn4dx,dn5dx,dn6dx,dn7dx,dn8dx,     &
   dn1dy,dn2dy,dn3dy,dn4dy,dn5dy,dn6dy,dn7dy,dn8dy,zero=0.0_iwp,          &
   one=1.0_iwp,two=2.0_iwp,d3=3.0_iwp,d4=4.0_iwp,d5=5.0_iwp,d6=6.0_iwp,   &
   d8=8.0_iwp,pt125=0.125_iwp
 x1=coord(1,1)
 x2=coord(2,1)
 x3=coord(3,1)
 x4=coord(4,1)
 x5=coord(5,1)
 x6=coord(6,1)
 x7=coord(7,1)
 x8=coord(8,1)
 y1=coord(1,2)
 y2=coord(2,2)
 y3=coord(3,2)
 y4=coord(4,2)
 y5=coord(5,2)
 y6=coord(6,2)
 y7=coord(7,2)
 y8=coord(8,2)
 xi2=xi*xi
 xi3=xi2*xi
 et2=eta*eta
 et3=et2*eta
 xi2et2=xi2*et2
 xi1et1=xi*eta
 xi2et1=xi2*eta
 xi1et2=xi*et2
 xy12=x1*y2-y1*x2
 xy13=x1*y3-y1*x3
 xy14=x1*y4-y1*x4
 xy15=x1*y5-y1*x5
 xy16=x1*y6-y1*x6
 xy17=x1*y7-y1*x7
 xy18=x1*y8-y1*x8
 xy23=x2*y3-y2*x3
 xy24=x2*y4-y2*x4
 xy25=x2*y5-y2*x5
 xy26=x2*y6-y2*x6
 xy27=x2*y7-y2*x7
 xy28=x2*y8-y2*x8
 xy34=x3*y4-y3*x4
 xy35=x3*y5-y3*x5
 xy36=x3*y6-y3*x6
 xy37=x3*y7-y3*x7
 xy38=x3*y8-y3*x8
 xy45=x4*y5-y4*x5
 xy46=x4*y6-y4*x6
 xy47=x4*y7-y4*x7
 xy48=x4*y8-y4*x8
 xy56=x5*y6-y5*x6
 xy57=x5*y7-y5*x7
 xy58=x5*y8-y5*x8
 xy67=x6*y7-y6*x7
 xy68=x6*y8-y6*x8
 xy78=x7*y8-y7*x8
 xcu=-d8*xy48+d4*(-xy14+xy38+xy47+xy58)+two*(xy13+xy15-xy37-xy57)
 xsq=two*(-xy13+xy14-xy17+xy18+xy24-xy28-xy34+xy35-xy38-xy45+xy46+xy47-   &
   xy57+xy58+xy68-xy78)+one*(-xy12+xy16-xy23-xy25+xy27-xy36-xy56-xy67)
 xon=d8*xy48+two*(xy14-xy18+xy34-xy38-xy45-xy47-xy58-xy78)+xy12-xy16+xy23-&
   xy25+xy27+xy36-xy56-xy67
 ecu=-d8*xy26+d4*(xy16+xy25+xy36+xy27)+two*(-xy15-xy17-xy35-xy37)
 esq=two*(-xy12+xy13-xy16+xy17-xy23+xy24+xy25-xy27-xy28-xy35+xy36+xy46-   &
   xy56+xy57-xy67+xy68)-xy14+xy18-xy34+xy38-xy45-xy47-xy58-xy78
 eon=d8*xy26+two*( xy12-xy16-xy23-xy25-xy27-xy36-xy56+xy67)+xy14-xy18-    &
   xy34+xy38-xy45+xy47-xy58+xy78
 x2e2=d6*(xy24-xy28+xy46+xy68)+d3*(-xy12+xy13-xy14+xy16-xy17+xy18-xy23-   &
   xy25+xy27-xy34+xy35-xy36+xy38-xy45-xy47-xy56+xy57-xy58-xy67-xy78)
 x1e1=d8*(-xy24-xy28+xy46-xy68)+d6*(-xy12+xy18+xy23+xy34-xy45-xy56+xy67+  &
   xy78)+two*(xy14-xy16+xy25+xy27-xy36+xy38-xy47+xy58)
 x2e1=d8*(xy24+xy28+xy46-xy68)+d5*( xy17-xy18-xy34+xy35-xy45+xy78)+d4*    &
   (xy12-xy16-xy23-xy25-xy27-xy36-xy56+xy67)+d3*(-xy14+xy15+xy37-xy38-    &
   xy47+xy58)
 x1e2=d8*(-xy24+xy28+xy46+xy68)+d5*(xy12-xy13+xy23+xy57-xy56-xy67)+d4*    &
   (xy14-xy18+xy34-xy38-xy45-xy47-xy58-xy78)+d3*(-xy15+xy16+xy25-xy27-    &
   xy36+xy37)
 cons= two*(-xy24+xy28-xy46-xy68)
!
 bot=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 bot=bot+xi2et2*x2e2+xi1et1*x1e1
 bot=bot+xi2et1*x2e1+xi1et2*x1e2+cons
!
 det=pt125*bot
!
 xcu=two*y3-d4*y4+two*y5
 xsq=-y2-two*y3+two*y4+y6-two*y7+two*y8
 xon=y2+two*y4 -y6-two*y8
 ecu=-two*y5+d4*y6-two*y7
 esq=-two*y2+two*y3-y4-two*y6+two*y7+y8
 eon=two*y2+y4-two*y6-y8
 x2e2=-d3*y2+d3*y3-d3*y4+d3*y6-d3*y7+d3*y8
 x1e1=-d6*y2+two*y4-two*y6+d6*y8
 x2e1=d4*y2-d3*y4+d3*y5-d4*y6+d5*y7-d5*y8
 x1e2=d5*y2-d5*y3+d4*y4-d3*y5+d3*y6-d4*y8
 cons=zero
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn1dx=top/bot
!
 xcu=zero
 xsq=y1-y3+two*y4-y5+y7-two*y8
 xon=-y1+y3-y5+y7
 ecu=d4*y5-d8*y6+d4*y7
 esq=two*y1-two*y3+two*y4+two*y5-two*y7-two*y8
 eon=-two*y1-two*y3-two*y5+d8*y6-two*y7
 x2e2= d3*y1-d3*y3+d6*y4-d3*y5+d3*y7-d6*y8
 x1e1= d6*y1+d6*y3-d8*y4+two*y5+two*y7-d8*y8
 x2e1=-d4*y1-d4*y3+d8*y4-d4*y5-d4*y7+d8*y8
 x1e2=-d5*y1+d5*y3-d8*y4+d3*y5-d3*y7+d8*y8
 cons=-two*y4+two*y8
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn2dx=top/bot
!
 xcu=-two*y1-two*y7+d4*y8
 xsq=two*y1+y2-two*y4+two*y5-y6-two*y8
 xon=-y2+two*y4+y6-two*y8
 ecu=-two*y5+d4*y6-two*y7
 esq=-two*y1+two*y2-y4-two*y5+two*y6+y8
 eon=two*y2-y4-two*y6+y8
 x2e2=-d3*y1+d3*y2-d3*y4+d3*y5-d3*y6+d3*y8
 x1e1=-d6*y2+d6*y4-two*y6+two*y8
 x2e1=+d4*y2-d5*y4+d5*y5-d4*y6+d3*y7-d3*y8
 x1e2=d5*y1-d5*y2+d4*y4-d3*y6+d3*y7-d4*y8
 cons=zero
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn3dx=top/bot
!
 xcu=d4*y1+d4*y7-d8*y8
 xsq=-two*y1-two*y2+two*y3-two*y5+two*y6+two*y7
 xon=-two*y1-two*y3-two*y5-two*y7+d8*y8
 ecu=zero
 esq=y1-two*y2+y3-y5+two*y6-y7
 eon=-y1+y3-y5+y7
 x2e2=d3*y1-d6*y2+d3*y3-d3*y5+d6*y6-d3*y7
 x1e1=-two*y1+d8*y2-d6*y3-d6*y5+d8*y6-two*y7
 x2e1=d3*y1-d8*y2+d5*y3-d5*y5+d8*y6-d3*y7
 x1e2=-d4*y1+d8*y2-d4*y3-d4*y5+d8*y6-d4*y7
 cons=two*y2-two*y6
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn4dx=top/bot
!
 xcu=-two*y1-two*y7+d4*y8
 xsq=y2-two*y3+two*y4-y6-two*y7+two*y8
 xon=y2 +two*y4-y6-two*y8
 ecu=two*y1-d4*y2+two*y3
 esq=-two*y2+two*y3+y4-two*y6+two*y7-y8
 eon=two*y2+y4-two*y6-y8
 x2e2=d3*y2-d3*y3+d3*y4-d3*y6+d3*y7-d3*y8
 x1e1=-two*y2+d6*y4-d6*y6+two*y8
 x2e1=-d3*y1+d4*y2-d5*y3+d5*y4-d4*y6+d3*y8
 x1e2=d3*y1-d3*y2+d4*y4-d5*y6+d5*y7-d4*y8
 cons=zero
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn5dx=top/bot
!
 xcu=zero
 xsq=-y1+y3-two*y4+y5-y7+two*y8
 xon=y1-y3+y5-y7
 ecu=-d4*y1+d8*y2-d4*y3
 esq=two*y1-two*y3-two*y4+two*y5-two*y7+two*y8
 eon=two*y1-d8*y2+two*y3+two*y5+two*y7
 x2e2=-d3*y1+d3*y3-d6*y4+d3*y5-d3*y7+d6*y8
 x1e1=two*y1+two*y3-d8*y4+d6*y5+d6*y7-d8*y8
 x2e1=d4*y1+d4*y3-d8*y4+d4*y5+d4*y7-d8*y8
 x1e2=-d3*y1+d3*y3-d8*y4+d5*y5-d5*y7+d8*y8
 cons=two*y4-two*y8
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn6dx=top/bot
!
 xcu=two*y3-d4*y4+two*y5
 xsq=two*y1-y2-two*y4+two*y5+y6-two*y8
 xon=-y2+two*y4+y6-two*y8
 ecu=two*y1-d4*y2+two*y3
 esq=-two*y1+two*y2+y4-two*y5+two*y6-y8
 eon=two*y2-y4-two*y6+y8
 x2e2=d3*y1-d3*y2+d3*y4-d3*y5+d3*y6-d3*y8
 x1e1=-two*y2+two*y4-d6*y6+d6*y8
 x2e1=-d5*y1+d4*y2-d3*y3+d3*y4-d4*y6+d5*y8
 x1e2=d3*y2-d3*y3+d4*y4-d5*y5+d5*y6-d4*y8
 cons=zero
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn7dx=top/bot
!
 xcu=-d4*y3+d8*y4-d4*y5
 xsq=-two*y1+two*y2+two*y3-two*y5-two*y6+two*y7
 xon=two*y1+two*y3-d8*y4+two*y5+two*y7
 ecu=zero
 esq=-y1+two*y2-y3+y5-two*y6+y7
 eon=y1-y3+y5-y7
 x2e2=-d3*y1+d6*y2-d3*y3+d3*y5-d6*y6+d3*y7
 x1e1=-d6*y1+d8*y2-two*y3-two*y5+d8*y6-d6*y7
 x2e1=d5*y1-d8*y2+d3*y3-d3*y5+d8*y6-d5*y7
 x1e2=d4*y1-d8*y2+d4*y3+d4*y5-d8*y6+d4*y7
 cons=-two*y2+two*y6
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn8dx=top/bot
!
 y1=-x1
 y2=-x2
 y3=-x3
 y4=-x4
 y5=-x5
 y6=-x6
 y7=-x7
 y8=-x8
!
 xcu=two*y3-d4*y4+two*y5
 xsq=-y2-two*y3+two*y4+y6-two*y7+two*y8
 xon=y2+two*y4-y6-two*y8
 ecu=-two*y5+d4*y6-two*y7
 esq=-two*y2+two*y3-y4-two*y6+two*y7+y8
 eon=two*y2+y4-two*y6-y8
 x2e2=-d3*y2+d3*y3-d3*y4 +d3*y6-d3*y7+d3*y8
 x1e1=-d6*y2+two*y4-two*y6+d6*y8
 x2e1=d4*y2-d3*y4+d3*y5-d4*y6+d5*y7-d5*y8
 x1e2=d5*y2-d5*y3+d4*y4-d3*y5+d3*y6-d4*y8
 cons=zero
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn1dy=top/bot
!
 xcu=zero
 xsq=y1-y3+two*y4-y5+y7-two*y8
 xon=-y1+y3-y5+y7
 ecu=d4*y5-d8*y6+d4*y7
 esq=two*y1-two*y3+two*y4+two*y5-two*y7-two*y8
 eon=-two*y1-two*y3-two*y5+d8*y6-two*y7
 x2e2=d3*y1-d3*y3+d6*y4-d3*y5+d3*y7-d6*y8
 x1e1=d6*y1+d6*y3-d8*y4+two*y5+two*y7-d8*y8
 x2e1=-d4*y1-d4*y3+d8*y4-d4*y5-d4*y7+d8*y8
 x1e2=-d5*y1+d5*y3-d8*y4+d3*y5-d3*y7+d8*y8
 cons=-two*y4+two*y8
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn2dy=top/bot
!
 xcu=-two*y1-two*y7+d4*y8
 xsq=two*y1+y2-two*y4+two*y5-y6-two*y8
 xon=-y2+two*y4+y6-two*y8
 ecu=-two*y5+d4*y6-two*y7
 esq=-two*y1+two*y2-y4-two*y5+two*y6+y8
 eon=two*y2-y4-two*y6+y8
 x2e2=-d3*y1+d3*y2-d3*y4+d3*y5-d3*y6+d3*y8
 x1e1=-d6*y2+d6*y4-two*y6+two*y8
 x2e1=d4*y2-d5*y4+d5*y5-d4*y6+d3*y7-d3*y8
 x1e2=d5*y1-d5*y2+d4*y4-d3*y6+d3*y7-d4*y8
 cons=zero
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn3dy=top/bot
!
 xcu=d4*y1+d4*y7-d8*y8
 xsq=-two*y1-two*y2+two*y3-two*y5+two*y6+two*y7
 xon=-two*y1-two*y3-two*y5-two*y7+d8*y8
 ecu=zero
 esq=y1-two*y2+y3-y5+two*y6-y7
 eon=-y1+y3-y5+y7
 x2e2=d3*y1-d6*y2+d3*y3-d3*y5+d6*y6-d3*y7
 x1e1=-two*y1+d8*y2-d6*y3-d6*y5+d8*y6-two*y7
 x2e1=d3*y1-d8*y2+d5*y3-d5*y5+d8*y6-d3*y7
 x1e2=-d4*y1+d8*y2-d4*y3-d4*y5+d8*y6-d4*y7
 cons=two*y2-two*y6
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn4dy=top/bot
!
 xcu=-two*y1-two*y7+d4*y8
 xsq=y2-two*y3+two*y4-y6-two*y7+two*y8
 xon=y2+two*y4-y6-two*y8
 ecu=two*y1-d4*y2+two*y3
 esq=-two*y2+two*y3+y4-two*y6+two*y7-y8
 eon=two*y2+y4-two*y6-y8
 x2e2=d3*y2-d3*y3+d3*y4-d3*y6+d3*y7-d3*y8
 x1e1=-two*y2+d6*y4-d6*y6+two*y8
 x2e1=-d3*y1+d4*y2-d5*y3+d5*y4-d4*y6 +d3*y8
 x1e2=d3*y1-d3*y2+d4*y4-d5*y6+d5*y7-d4*y8
 cons=zero
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn5dy=top/bot
!
 xcu=zero
 xsq=-y1+y3-two*y4+y5-y7+two*y8
 xon=y1-y3+y5-y7
 ecu=-d4*y1+d8*y2-d4*y3
 esq=two*y1-two*y3-two*y4+two*y5-two*y7+two*y8
 eon=two*y1-d8*y2+two*y3+two*y5+two*y7
 x2e2=-d3*y1+d3*y3-d6*y4+d3*y5-d3*y7+d6*y8
 x1e1=two*y1+two*y3-d8*y4+d6*y5+d6*y7-d8*y8
 x2e1=d4*y1+d4*y3-d8*y4+d4*y5+d4*y7-d8*y8
 x1e2=-d3*y1+d3*y3-d8*y4+d5*y5-d5*y7+d8*y8
 cons=two*y4-two*y8
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn6dy=top/bot
!
 xcu=two*y3-d4*y4+two*y5
 xsq=two*y1-y2-two*y4+two*y5+y6-two*y8
 xon=-y2+two*y4+y6-two*y8
 ecu=two*y1-d4*y2+two*y3
 esq=-two*y1+two*y2+y4-two*y5+two*y6-y8
 eon=two*y2-y4-two*y6+y8
 x2e2=d3*y1-d3*y2+d3*y4-d3*y5+d3*y6-d3*y8
 x1e1=-two*y2+two*y4-d6*y6+d6*y8
 x2e1=-d5*y1+d4*y2-d3*y3+d3*y4-d4*y6+d5*y8
 x1e2=d3*y2-d3*y3+d4*y4-d5*y5+d5*y6-d4*y8
 cons=zero
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn7dy=top/bot
!
 xcu=-d4*y3+d8*y4-d4*y5
 xsq=-two*y1+two*y2+two*y3-two*y5-two*y6+two*y7
 xon=two*y1+two*y3-d8*y4+two*y5+two*y7
 ecu=zero
 esq=-y1+two*y2-y3+y5-two*y6+y7
 eon=y1-y3+y5-y7
 x2e2=-d3*y1+d6*y2-d3*y3+d3*y5-d6*y6+d3*y7
 x1e1=-d6*y1+d8*y2-two*y3-two*y5+d8*y6-d6*y7
 x2e1=d5*y1-d8*y2+d3*y3-d3*y5+d8*y6-d5*y7
 x1e2=d4*y1-d8*y2+d4*y3+d4*y5-d8*y6+d4*y7
 cons=-two*y2+two*y6
!
 top=xi3*xcu+xi2*xsq+xi*xon+et3*ecu+et2*esq+eta*eon
 top=top+xi2et2*x2e2+xi1et1*x1e1
 top=top+xi2et1*x2e1+xi1et2*x1e2+cons
!
 dn8dy=top/bot
!
 bee=zero
 bee(1,1)=dn1dx
 bee(1,3)=dn2dx
 bee(1,5)=dn3dx
 bee(1,7)=dn4dx
 bee(1,9)=dn5dx
 bee(1,11)=dn6dx
 bee(1,13)=dn7dx
 bee(1,15)=dn8dx
 bee(2,2)=dn1dy
 bee(2,4)=dn2dy
 bee(2,6)=dn3dy
 bee(2,8)=dn4dy
 bee(2,10)=dn5dy
 bee(2,12)=dn6dy
 bee(2,14)=dn7dy
 bee(2,16)=dn8dy
 bee(3,1)=dn1dy
 bee(3,3)=dn2dy
 bee(3,5)=dn3dy
 bee(3,7)=dn4dy
 bee(3,9)=dn5dy
 bee(3,11)=dn6dy
 bee(3,13)=dn7dy
 bee(3,15)=dn8dy
 bee(3,2)=dn1dx
 bee(3,4)=dn2dx
 bee(3,6)=dn3dx
 bee(3,8)=dn4dx
 bee(3,10)=dn5dx
 bee(3,12)=dn6dx
 bee(3,14)=dn7dx
 bee(3,16)=dn8dx
 RETURN
END SUBROUTINE bee8


! ------------------------------------------------------------------------------
!
! test program for mo_spatialsimilarity
!
! author: Matthias Zink
!
! created: May 2015
!
! ------------------------------------------------------------------------------

program test
  !
  use mo_kind,              only: sp, dp
  use mo_ansi_colors,       only: color, c_red, c_green
  use mo_spatialsimilarity, only: PD, NNDV
  !
  implicit none
  !
  real(dp), dimension(3,3)  :: mat1, mat2 ! data arrays
  logical,  dimension(3,3)  :: masking    ! mask for excluding nodata values
  logical                   :: validity   ! number of valid cells
  logical                   :: isgood
  real(sp) :: stmp
  real(dp) :: dtmp
  !
  isgood = .true.
  !
  mat1 = reshape((/12.0_dp,  4.0_dp, 15.0_dp, 17.0_dp, 10.0_dp,  2.0_dp,  1.0_dp, 11.0_dp, 20.0_dp/),(/3,3/))
  mat2 = reshape((/ 7.0_dp, 12.0_dp,  5.0_dp,  9.0_dp, 11.0_dp, 13.0_dp, 12.0_dp, 11.0_dp,  7.0_dp/),(/3,3/))

  masking = .TRUE.
  ! sp without mask
  stmp = NNDV(real(mat1(:,:),sp), real(mat2(:,:),sp)              )
  isgood  = isgood .and. (nint(100000.0_sp * stmp) .EQ. 29815)
  stmp = PD(real(mat1(:,:),sp), real(mat2(:,:),sp), mask=masking)
  isgood  = isgood .and. (nint(100000.0_sp * stmp) .EQ.  8148)

  ! dp without mask
  dtmp = NNDV(mat1(:,:), mat2(:,:),               valid=validity)
  isgood  = isgood .and. (nint(100000.0_dp * dtmp) .EQ. 29815)
  isgood  = isgood .and. validity
  dtmp =   PD(mat1(:,:), mat2(:,:), mask=masking, valid=validity)
  isgood  = isgood .and. (nint(100000.0_dp * dtmp) .EQ.  8148)
  isgood  = isgood .and. validity

  masking = reshape((/.TRUE., .TRUE., .FALSE., .FALSE., .TRUE., .TRUE., .TRUE., .TRUE., .FALSE./),(/3,3/))
  ! sp with mask
  stmp = NNDV(real(mat1(:,:),sp), real(mat2(:,:),sp), mask=masking)
  isgood  = isgood .and. (nint(1000000.0_sp * stmp) .EQ. 300000)
  stmp =   PD(real(mat1(:,:),sp), real(mat2(:,:),sp), mask=masking)
  isgood  = isgood .and. (nint(1000000.0_sp * stmp) .EQ.  55556)

  ! dp with mask
  masking = reshape((/.TRUE., .TRUE., .FALSE., .FALSE., .TRUE., .TRUE., .TRUE., .TRUE., .FALSE./),(/3,3/))
  dtmp = NNDV(mat1(:,:), mat2(:,:), mask=masking, valid=validity)
  isgood  = isgood .and. (nint(1000000.0_dp * dtmp) .EQ. 300000)
  isgood  = isgood .and. validity
  dtmp =   PD(mat1(:,:), mat2(:,:), mask=masking, valid=validity)
  isgood  = isgood .and. (nint(1000000.0_dp * dtmp) .EQ.  55556)
  isgood  = isgood .and. validity

  ! entire mask .false. - check validity argument
  masking = .FALSE.
  dtmp = NNDV(mat1(:,:), mat2(:,:), valid=validity, mask=masking)
  isgood  = isgood .and. (nint(1000000.0_dp * dtmp) .EQ. 0)
  isgood  = isgood .and. ( .not. validity)
  dtmp =   PD(mat1(:,:), mat2(:,:), valid=validity, mask=masking)
  isgood  = isgood .and. (nint(1000000.0_dp * dtmp) .EQ. 0)
  isgood  = isgood .and. ( .not. validity)

  if (isgood) then
     write(*,*) 'mo_spatialsimilarity ', color('o.k.', c_green)
  else
     write(*,*) 'mo_spatialsimilarity ', color('failed', c_red)
  endif
  !
end program test


module index_reference
  use aux
  use hamiltonian_module, only : ndim
  implicit none
  private
  public :: index_, inverse_l, inverse_r

  contains

  subroutine index_(x,y)  ! x - left compound index --- y - right compound index
  ! this can also be done via a function written like below - however it is faster to do one loop since every index is used anyways
    integer, intent(out) :: x(ndim,ndim),y(ndim,ndim)  ! x = 1 ... ndim**2 = y ---- Polarization arrays have to be changed
    integer              :: cnt,i,j

    cnt=1

    do i=1,ndim
    do j=1,ndim
      x(i,j) = cnt ! 11, 12, 13, ..., 21, 22, 23, ...
      y(j,i) = cnt ! 11, 21, 31, ..., 12, 22, 32, ...
      cnt = cnt+1
    enddo
    enddo

  end subroutine index_

  integer function inverse_l(i) ! i -> L (from LL_) --- j -> L_ (from L_L)
    integer,intent(in) :: i
    inverse_l=(i-1)/ndim+1 ! integer division
    return
  end function inverse_l

  integer function inverse_r(i) ! i -> L_ (from LL_) --- j -> L (from L_L)
    integer,intent(in) :: i
    inverse_r=mod(i-1,ndim)+1
    return
  end function inverse_r

end module index_reference


    program demo_besj1
    use, intrinsic :: iso_fortran_env, only : real_kinds, &
     & real32, real64, real128
    implicit none
    real(kind=real64) :: x = 1.0_real64
       x = bessel_j1(x)
       write(*,*)x
    end program demo_besj1


!**********************************************************************
!     matmult.f90 - simple matrix multiply implementation
!************************************************************************
      module matrices
      integer, parameter :: wp = selected_real_kind(15)
      real(wp), allocatable :: A(:,:), B(:,:), C(:,:)   ! scratch arrays
      integer MSIZE
      parameter (MSIZE = 1000)
      contains
      subroutine allocate_matrices
        allocate( A(MSIZE,MSIZE))
        allocate( B(MSIZE,MSIZE), C(MSIZE,MSIZE) )
        return
      end subroutine allocate_matrices
      subroutine deallocate_matrices
        deallocate( A, B )  ! note that C is not included in this list.
        return
      end subroutine deallocate_matrices

      subroutine initialize

! first initialize the A matrix
        do i = 1,MSIZE
          do j = 1,MSIZE
            A(j,i) = i
          end do
        end do

! then initialize the B matrix
        do i = 1,MSIZE
          do j = 1,MSIZE
            B(j,i) = i
          end do
        end do
        A(MSIZE+10,MSIZE) = 100
        A(MSIZE,MSIZE+10) = 100

      end subroutine initialize

      subroutine multiply_matrices(answer, buffer)
        double precision buffer(MSIZE), answer(MSIZE)
        integer i, j
! multiply the row with the column

        do i = 1,MSIZE
          answer(i) = 0.0
          do j = 1,MSIZE
            answer(i) = answer(i) + buffer(j)*B(j,i)
          end do
        end do
      end subroutine multiply_matrices

      subroutine driver
      include "mpif.h"

! try changing this value to 2000 to get rid of transient effects
! at startup
      double precision buffer(MSIZE), answer(MSIZE)

      integer myid, master, maxpe, ierr, status(MPI_STATUS_SIZE)
      integer i, j, numsent, sender
      integer answertype, row, flag

      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, myid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, maxpe, ierr )
      print *, "Process ", myid, " of ", maxpe, " is active"

      master = 0
      matsize = MSIZE

      if ( myid .eq. master ) then
! master initializes and then dispatches
! initialize a and b
        call initialize
        numsent = 0

! send b to each other process
        do i = 1,matsize
          call MPI_BCAST(B(1,i), matsize, MPI_DOUBLE_PRECISION, master, &
             MPI_COMM_WORLD, ierr)
        end do

! send a row of a to each other process; tag with row number
        do i = 1,maxpe-1
          do j = 1,matsize
            buffer(j) = A(i,j)
          end do
          call MPI_SEND(buffer, matsize, MPI_DOUBLE_PRECISION, i,       &
             i, MPI_COMM_WORLD, ierr)
          numsent = numsent+1
        end do

        do i = 1,matsize
          call MPI_RECV(answer, matsize, MPI_DOUBLE_PRECISION,          &
           MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
          sender = status(MPI_SOURCE)
          answertype = status(MPI_TAG)
          do j = 1,matsize
            c(answertype,j) = answer(j)
          end do

          if (numsent .lt. matsize) then
            do j = 1,matsize
              buffer(j) = A(numsent+1,j)
            end do
            call MPI_SEND(buffer, matsize, MPI_DOUBLE_PRECISION, sender,&
              numsent+1, MPI_COMM_WORLD, ierr)
            numsent = numsent+1
          else
            call MPI_SEND(1.0, 1, MPI_DOUBLE_PRECISION, sender, 0,      &
                 MPI_COMM_WORLD, ierr)
          endif
        end do

! print out one element of the answer
        print *, "c(", matsize, ",", matsize, ") = ", c(matsize,matsize)
      else
! workers receive B, then compute rows of C until done message
        do i = 1,matsize
          call MPI_BCAST(B(1,i), matsize, MPI_DOUBLE_PRECISION, master, &
                 MPI_COMM_WORLD, ierr)
        end do
        flag = 1
        do while (flag .ne. 0)
          call MPI_RECV(buffer, matsize, MPI_DOUBLE_PRECISION, master,  &
            MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr)
          row = status(MPI_TAG)
          flag = row
          if (flag .ne. 0) then
! multiply the matrices here using C(i,j) += sum (A(i,k)* B(k,j))
            call multiply_matrices(answer, buffer)
            call MPI_SEND(answer, matsize, MPI_DOUBLE_PRECISION, master,&
               row, MPI_COMM_WORLD, ierr)
          endif
        end do
      endif

      call MPI_FINALIZE(ierr)
      end subroutine driver
      end module matrices

      program main
      use matrices
      call allocate_matrices
      call driver
      call deallocate_matrices
      end program main


program test_point_in_polygon
	use fplus_geo_tools

	! create a polygone
	real, dimension(5) :: polygonX = (/0.0,1.0,1.0,0.0,0.0/)
	real, dimension(5) :: polygonY = (/0.0,0.0,1.0,1.0,0.0/)

	! check if some points are inside or outside of the polygon
	print*, point_in_polygon(polygonX, polygonY, 0.5, 0.5)
	print*, point_in_polygon(polygonX, polygonY, 1.5, 0.5)
	print*, point_in_polygon(polygonX, polygonY, 0.9, 0.1)
	print*, point_in_polygon(polygonX, polygonY, -0.5, 0.1)

end program


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_unifact_qr
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the Schur factorization of
! a unitary upper hessenberg matrix that is stored as a product of
! N-1 Givens rotations and a complex diagonal matrix.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  VEC             LOGICAL
!                    .TRUE.: compute schurvectors
!                    .FALSE.: no schurvectors
!
!  ID              LOGICAL
!                    .TRUE.: initialize to Z to identity
!                    .FALSE.: assume Z is already initialized
!
!  N               INTEGER
!                    dimension of matrix
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for Givens rotations
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!                    on output contains the eigenvalues
!
!  M               INTEGER
!                    leading dimension of Z
!
! OUTPUT VARIABLES:
!
!  Z              COMPLEX(8) array of dimension (M,N)
!                   components of schurvectors
!                   if VEC = .FALSE. unused
!                   if VEC = .TRUE. and ID = .TRUE. initializes Z to I
!                   if VEC = .TRUE. and ID = .FALSE. assumes Z initialized
!
!  ITS            INTEGER array of dimension (N-1)
!                   contains the number of iterations per deflation
!
!  INFO           INTEGER
!                   INFO = 1 implies no convergence
!                   INFO = 0 implies successful computation
!                   INFO = -3 implies N is invalid
!                   INFO = -4 implies Q is invalid
!                   INFO = -5 implies D is invalid
!                   INFO = -6 implies M is invalid
!                   INFO = -7 implies Z is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_unifact_qr(VEC,ID,N,Q,D,M,Z,ITS,INFO)

  implicit none

  ! input variables
  logical, intent(in) :: VEC, ID
  integer, intent(in) :: N, M
  real(8), intent(inout) :: Q(3*(N-1)), D(2*N)
  integer, intent(inout) :: INFO, ITS(N-1)
  complex(8), intent(inout) :: Z(M,N)

  ! compute variables
  logical :: flg
  integer :: ii, kk
  integer :: STR, STP, ZERO, ITMAX, ITCNT

  ! initialize info
  INFO = 0

  ! check factorization
  call z_unifact_factorcheck(N,Q,D,INFO)
  if (INFO.NE.0) then
    INFO = INFO - 2
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"N, Q, or D is invalid",INFO,INFO)
    end if
    return
  end if

  ! check M
  if (VEC.AND.(M < 1)) then
    INFO = -6
    ! print error message in debug mode
    if (DEBUG) then
      call u_infocode_check(__FILE__,__LINE__,"M must be at least 1",INFO,INFO)
    end if
    return
  end if

  ! check Z
  if (VEC.AND..NOT.ID) then
    call z_2Darray_check(M,N,Z,flg)
    if (.NOT.flg) then
      INFO = -7
      ! print error message in debug mode
      if (DEBUG) then
        call u_infocode_check(__FILE__,__LINE__,"Z is invalid",INFO,INFO)
      end if
      return
    end if
  end if

  ! initialize storage
  ITS = 0

  if (VEC.AND.ID) then
    Z = cmplx(0d0,0d0,kind=8)
    do ii=1,min(M,N)
      Z(ii,ii) = cmplx(1d0,0d0,kind=8)
    end do
  end if

  ! initialize indices
  STR = 1
  STP = N-1
  ZERO = 0
  ITMAX = 20*N
  ITCNT = 0

  ! iteration loop
  do kk=1,ITMAX

    ! check for completion
    if(STP <= 0)then
      exit
    end if

    ! check for deflation
    call z_unifact_deflationcheck(STP-STR+2,Q((3*STR-2):(3*STP)) &
    ,D((2*STR-1):(2*STP+2)),ZERO)

    if (ZERO.GT.0) then
      ITS(STR+ZERO-1) = ITS(STR+ZERO-1) + ITCNT
      ITCNT = 0
    end if

    ! if 1x1 block remove and check again
    if(STP == (STR+ZERO-1))then
      ! update indices
      STP = STP - 1
      ZERO = 0
      STR = 1

    ! if greater than 1x1 chase a bulge
    else

      ! check ZERO
      if (ZERO.GT.0) then
        STR = STR+ZERO
      end if

      ! perform singleshift iteration
      call z_unifact_singlestep(VEC,STP-STR+2,Q((3*STR-2):(3*STP)),D((2*STR-1):(2*STP+2)) &
      ,M,Z(:,STR:(STP+1)),ITCNT)

      ! update indices
      ITCNT = ITCNT + 1

    end if

    ! if ITMAX hit
    if (kk == ITMAX) then
      INFO = 1
      ITS(STR+STP-1) = ITCNT
    end if

  end do

end subroutine z_unifact_qr


== Checks if all elements of given `array` meet the condition specified
== in the `predicate`.
==
== Returns: Boolean
==     True if the array is empty or condition is met by all elements,
==     false otherwise.
all (array, predicate) ->
    array = [] | (predicate (array[0]) & all (array[1...], predicate))

== Checks if any element of given `array` meets the condition specified
== in the `predicate`.
==
== Returns: Boolean
==     True if the condition is met by at least one element, false otherwise
==     or if the array is empty.
any (array, predicate) ->
    array != [] & predicate (array[0]) | any (array[1...], predicate)

== Checks if any element of given `array` meets the condition specified
== in the `predicate`.
==
== Returns: Boolean
==     True if the array is empty or condition is met by no elements, false
==     otherwise.
none (array, predicate) -> !any (array, predicate)

== Makes a new array out of all elements of given `array` that meet the
== condition specified in given `predicate`.
==
== Returns: Array
filter (array, predicate) {
    no elements << array = []
    appended << !no elements & predicate (array[0]) ? [array[0]] : []
} ->
    no elements ? [] : appended ~ filter (array[1...], predicate)

== Makes a new array out of all elements of given `array` transformed with
== given `process` function.
==
== Returns: Array
map (array, process) ->
    array = [] ? []
               : [process (array[0])] ~ map (array[1...], process)

== Makes a new array of `n` values generated by given `generator`.
==
== Returns: Array
generate (n, generator) ->
    n = 0 ? [] : [generator()] ~ generate (n - 1, generator)


SUBROUTINE PACKINGBANDMATRIX_C(N,A,KD,AB,INFO)

! brute force packing of a banded matrix

  IMPLICIT NONE
  INTEGER, INTENT(INOUT) :: INFO
  INTEGER, INTENT(IN)    :: N,KD
  COMPLEX*16, DIMENSION(N,N)    :: A
  COMPLEX*16, DIMENSION(KD+1,N) :: AB

  INTEGER i,j,N_,I_

  CALL PACKINGBANDMATRIX(N,A,KD,AB,INFO)

END SUBROUTINE PACKINGBANDMATRIX_C

SUBROUTINE LAPACK_FULLEIGENVALUESBAND_C(AB,Z,KD,N,W,INFO)
  !eigenvalues/vectors of banded matrix ab
!AB, inout, packed banded matrix
!Z, out,eigenvectors
!KD out, calcuated eigenvectors
!N, in,matrix dimension
!W, out, eigenvalues
!INFO,inout, error flag

  !H is COMPLEX*16 array, dimension (N, N)
  !  69 *>          On entry, the Hermitian matrix A.  If UPLO = 'U', the
  !  70 *>          leading N-by-N upper triangular part of A contains the
  !  71 *>          upper triangular part of the matrix A.  If UPLO = 'L',
  !  72 *>          the leading N-by-N lower triangular part of A contains
  !  73 *>          the lower triangular part of the matrix A.
  !  74 *>          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
  !  75 *>          orthonormal eigenvectors of the matrix A.
  !  76 *>          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
  !  77 *>          or the upper triangle (if UPLO='U') of A, including the
  !  78 *>          diagonal, is destroyed.
  !
  ! The eigenvector H(:,r) corresponds to the eigenvalue W_SPACE(r)
  !
  IMPLICIT NONE
  INTEGER,                                INTENT(IN)    :: N,KD
  COMPLEX*16,       DIMENSION(KD+1,N), INTENT(INOUT)    :: AB
  COMPLEX*16,       DIMENSION(N,N),       INTENT(INOUT) :: Z
  DOUBLE PRECISION, DIMENSION(N),         INTENT(INOUT) :: W
  INTEGER,                                INTENT(OUT)   :: INFO

  CALL LAPACK_FULLEIGENVALUESBAND(AB,Z,KD,N,W,INFO)

END SUBROUTINE LAPACK_FULLEIGENVALUESBAND_C

SUBROUTINE LAPACK_FULLEIGENVALUES_C(U_F,N,W_SPACE_,INFO)
!eigenvalues/vectors of matrix ab
!H, inout, packed banded matrix
! , out,eigenvectors
!N, in,matrix dimension
!W_space, out, eigenvalues
!INFO,inout, error flag

  !H is COMPLEX*16 array, dimension (N, N)
  !  69 *>          On entry, the Hermitian matrix A.  If UPLO = 'U', the
  !  70 *>          leading N-by-N upper triangular part of A contains the
  !  71 *>          upper triangular part of the matrix A.  If UPLO = 'L',
  !  72 *>          the leading N-by-N lower triangular part of A contains
  !  73 *>          the lower triangular part of the matrix A.
  !  74 *>          On exit, if JOBZ = 'V', then if INFO = 0, A contains the
  !  75 *>          orthonormal eigenvectors of the matrix A.
  !  76 *>          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
  !  77 *>          or the upper triangle (if UPLO='U') of A, including the
  !  78 *>          diagonal, is destroyed.
  !
  ! The eigenvector H(:,r) corresponds to the eigenvalue W_SPACE(r)
  !
  USE ARRAYS
  IMPLICIT NONE
  INTEGER,                          INTENT(IN)    :: N
  COMPLEX*16,       DIMENSION(N,N), INTENT(INOUT) :: U_F
  DOUBLE PRECISION, DIMENSION(N),   INTENT(INOUT) :: W_SPACE_
  INTEGER,                          INTENT(OUT)   :: INFO

  !ALLOCATE(H_FLOQUET(N,N))
  !H_FLOQUET = 1.0
  !write(*,*) H_FLOQUET(1,1)!,SIZE(H_FLOQUET,1),SIZE(W_SPACE_,1)
!  wRITE(*,*) H_FLOQUET
  CALL LAPACK_FULLEIGENVALUES(H_FLOQUET,N,W_SPACE_,INFO)
  U_F = H_FLOQUET
  DEALLOCATE(H_FLOQUET)

END SUBROUTINE LAPACK_FULLEIGENVALUES_C

SUBROUTINE LAPACK_SELECTEIGENVALUES_C(H,N,W_SPACE,L1,L2,Z,INFO)
!selected eigenvalues/vectors of hermitian matrix
!H, inout, packed banded matrix
! , out,eigenvectors
!N, in,matrix dimension
!W_space, out, eigenvalues
!L1 ordinal lowest eigenvalue
!L2 ordinal highest eigenvlaue
!Z : eigenvectors
!INFO,inout, error flag

  !USE FLOQUET
  IMPLICIT NONE
  INTEGER,                        INTENT(IN)    :: N,L1,L2
  COMPLEX*16, DIMENSION(:,:),     INTENT(INOUT) :: H
  COMPLEX*16, DIMENSION(:,:),     INTENT(OUT)   :: Z
  DOUBLE PRECISION, DIMENSION(:), INTENT(OUT)   :: W_SPACE
  INTEGER,                        INTENT(OUT)   :: INFO

  CALL LAPACK_SELECTEIGENVALUES(H,N,W_SPACE,L1,L2,Z,INFO)

END SUBROUTINE LAPACK_SELECTEIGENVALUES_C


module structureted_grid_implementation
  !! author: Damian Rouson
  !!
  !! Establish a coarray for distributing structured-grid vertex locations across images.
  !! Use collective subroutines to distribute the grid dimensions and calculate this image's load

   use assertion_interface, only : assert, assertions
   implicit none

   private
   public :: get_grid_resolution
   public :: allocate_my_partition
   public :: my_partition_size

   real, allocatable :: x(:,:,:,:)[:]
     !! structured-grid vertex locations
   integer, parameter :: space_dimension=3

contains

  function get_grid_resolution(file_name) result(n)
    character(len=*), intent(in) :: file_name
    integer :: n(space_dimension)

    integer nx, ny, nz
    namelist/grid_resolution/ nx, ny, nz

    associate(me=>this_image(),ni=>num_images())
      block
        integer file_unit, stat
        integer, parameter :: reader=1, success=0

        if (me==reader) then
          open(newunit=file_unit,file=file_name,status='old',iostat=stat)
          if (assertions) call assert(stat==success,"file opened successfully")

          read(unit=file_unit,nml=grid_resolution,iostat=stat)
          if (assertions) call assert(stat==success,"file read successfully")

          close(unit=file_unit,iostat=stat)
          if (assertions) call assert(stat==success,"file closed successfully")
        end if

        n=[nx,ny,nz]
        call co_broadcast(n,source_image=reader)
      end block
    end associate

  end function

  subroutine allocate_my_partition(n)
    integer, intent(in) :: n(:)

    ! Requires
    call assert(size(n)==space_dimension,"valid resolution")

    associate(num_yz_planes=>n(1),ni=>num_images(),ny=>n(2),nz=>n(3))
      if (assertions) call assert(mod(num_yz_planes,ni)==0,"evenly divisible planes")
      associate(my_num_planes=>num_yz_planes/ni)
        allocate(x(my_num_planes,ny,nz,space_dimension)[*])
      end associate
    end associate

  end subroutine

  pure function my_partition_size() result(partition_size)
    integer partition_size
    partition_size = size(x)
  end function

end module

program main
  !! author: Damian Rouson
  !!
  !! Establish a coarray for distributing structured-grid vertex locations across images.
  !! Use collective subroutines to distribute the grid dimensions and verify load distribution

   use assertion_interface, only : assert
   use structureted_grid_implementation, only : get_grid_resolution, allocate_my_partition, my_partition_size

   implicit none

   integer, allocatable :: nx(:)

   nx = get_grid_resolution('grid.nml')
   call assert( size(nx)==3 .and. all(nx>0),"acceptable 3D grid resolution")

   call allocate_my_partition(nx)

   block
     integer load
     integer, parameter :: space_dimension=3
     load = my_partition_size()
     call co_sum( load )
     call assert( load == product(nx)*space_dimension, "all points distributed")
   end block

   sync all
   block
     integer, parameter :: reader=1
     if (this_image()==reader) print *,"Test passed."
   end block

end program


program main
  use module_gauss_legendre_quadrature
  implicit none

  integer :: ng

  real(8),allocatable :: gz(:), we(:)

  ng=10

  allocate(gz(ng),we(ng))

  call assemble_gauss(ng,gz,we)
  write(*,*) ng
  write(*,*) gz
  write(*,*) we

  deallocate(gz,we)

end program main


! Simple test program for the timers module.
! Note, the first time I run the program after compiling is when the times seem
! to be the most consistent. Subsequent runs the times change quite a bit. The
! CPU is doing something funny here.

program test
  use mod_timers
  implicit none

  integer :: t_outer,t_inner,t_something

  call test_timers()

contains

  subroutine  something()
    implicit none
    integer :: i,j
    integer, parameter :: n = 1024
    real*8, allocatable :: A(:,:), C(:,:)

    allocate(A(n,n),C(n,n))

    C = 0.d0
    do j=1,n
       do i=1,n
          A(i,j) = 1.d0/(i + j)
       end do
       C(j,j) = 1.d0
    end do

    do i=1,2
       write (*,'(a,i0,a)') "inner iteration ", i, " ..."
       call start_timer(t_inner)
       C = matmul(C,A)
       call stop_timer(t_inner)
    end do
    write (123,*) C(1,1)
  end subroutine something

  subroutine test_timers()
    ! Not an automated test. Just some scratch code to try it out.
    ! It does include some manual timers using system_clock for comparison.
    implicit none

    integer(8) :: k

    call add_timer("outer", t_outer)
    call add_timer("something", t_something)
    call add_timer("inner_iteration", t_inner)

    call start_timer(t_outer)
    do k=1,10
       call start_timer(t_something)
       call something()
       call stop_timer(t_something)
    end do
    call stop_timer(t_outer)

    call print_all_timers_flat(6)
    write (6,*) ""
    call print_all_timers(6)
    call clear_timers()
  end subroutine test_timers

end program test