      DOUBLE PRECISION FUNCTION PHO_GRSF2(X,S,Alp,Bet,A,B,Ga,Gb,Gc,Gd,
     &   Ge,Gep)
      IMPLICIT NONE
      DOUBLE PRECISION A , Alp , B , Bet , Ga , Gb , Gc , Gd , Ge ,
     &                 Gep , S , X
      SAVE

      PHO_GRSF2 = (S*X**A*(Ga+Gb*SQRT(X)+Gc*X**B)
     &            +S**Alp*EXP(-Ge+SQRT(Gep*S**Bet*LOG(1.D0/X))))
     &            *(1.D0-X)**Gd

      END FUNCTION


      SUBROUTINE NF01BQ( COND, N, IPAR, LIPAR, R, LDR, IPVT, DIAG, QTB,
     $                   RANKS, X, TOL, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To determine a vector x which solves the system of linear
C     equations
C
C           J*x = b ,     D*x = 0 ,
C
C     in the least squares sense, where J is an m-by-n matrix,
C     D is an n-by-n diagonal matrix, and b is an m-vector. The matrix J
C     is the current Jacobian of a nonlinear least squares problem,
C     provided in a compressed form by SLICOT Library routine NF01BD.
C     It is assumed that a block QR factorization, with column pivoting,
C     of J is available, that is, J*P = Q*R, where P is a permutation
C     matrix, Q has orthogonal columns, and R is an upper triangular
C     matrix with diagonal elements of nonincreasing magnitude for each
C     block, as returned by SLICOT Library routine NF01BS. The routine
C     NF01BQ needs the upper triangle of R in compressed form, the
C     permutation matrix P, and the first n components of Q'*b
C     (' denotes the transpose). The system J*x = b, D*x = 0, is then
C     equivalent to
C
C           R*z = Q'*b ,  P'*D*P*z = 0 ,                             (1)
C
C     where x = P*z. If this system does not have full rank, then an
C     approximate least squares solution is obtained (see METHOD).
C     On output, NF01BQ also provides an upper triangular matrix S
C     such that
C
C           P'*(J'*J + D*D)*P = S'*S .
C
C     The system (1) is equivalent to S*z = c , where c contains the
C     first n components of the vector obtained by applying to
C     [ (Q'*b)'  0 ]' the transformations which triangularized
C     [ R'  P'*D*P ]', getting S.
C
C     The matrix R has the following structure
C
C         /   R_1    0    ..   0   |   L_1   \
C         |    0    R_2   ..   0   |   L_2   |
C         |    :     :    ..   :   |    :    | ,
C         |    0     0    ..  R_l  |   L_l   |
C         \    0     0    ..   0   |  R_l+1  /
C
C     where the submatrices R_k, k = 1:l, have the same order BSN,
C     and R_k, k = 1:l+1, are square and upper triangular. This matrix
C     is stored in the compressed form
C
C              /   R_1  |   L_1   \
C              |   R_2  |   L_2   |
C       Rc =   |    :   |    :    | ,
C              |   R_l  |   L_l   |
C              \    X   |  R_l+1  /
C
C     where the submatrix X is irrelevant. The matrix S has the same
C     structure as R, and its diagonal blocks are denoted by S_k,
C     k = 1:l+1.
C
C     If l <= 1, then the full upper triangle of the matrix R is stored.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COND    CHARACTER*1
C             Specifies whether the condition of the matrices S_k should
C             be estimated, as follows:
C             = 'E' :  use incremental condition estimation and store
C                      the numerical rank of S_k in the array entry
C                      RANKS(k), for k = 1:l+1;
C             = 'N' :  do not use condition estimation, but check the
C                      diagonal entries of S_k for zero values;
C             = 'U' :  use the ranks already stored in RANKS(1:l+1).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix R.  N = BN*BSN + ST >= 0.
C             (See parameter description below.)
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             The integer parameters describing the structure of the
C             matrix R, as follows:
C             IPAR(1) must contain ST, the number of columns of the
C                     submatrices L_k and the order of R_l+1.  ST >= 0.
C             IPAR(2) must contain BN, the number of blocks, l, in the
C                     block diagonal part of R.  BN >= 0.
C             IPAR(3) must contain BSM, the number of rows of the blocks
C                     R_k, k = 1:l.  BSM >= 0.
C             IPAR(4) must contain BSN, the number of columns of the
C                     blocks R_k, k = 1:l.  BSN >= 0.
C             BSM is not used by this routine, but assumed equal to BSN.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 4.
C
C     R       (input/output) DOUBLE PRECISION array, dimension (LDR, NC)
C             where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
C             On entry, the leading N-by-NC part of this array must
C             contain the (compressed) representation (Rc) of the upper
C             triangular matrix R. If BN > 1, the submatrix X in Rc is
C             not referenced. The zero strict lower triangles of R_k,
C             k = 1:l+1, need not be set. If BN <= 1 or BSN = 0, then
C             the full upper triangle of R must be stored.
C             On exit, the full upper triangles of R_k, k = 1:l+1, and
C             L_k, k = 1:l, are unaltered, and the strict lower
C             triangles of R_k, k = 1:l+1, contain the corresponding
C             strict upper triangles (transposed) of the upper
C             triangular matrix S.
C             If BN <= 1 or BSN = 0, then the transpose of the strict
C             upper triangle of S is stored in the strict lower triangle
C             of R.
C
C     LDR     INTEGER
C             The leading dimension of the array R.  LDR >= MAX(1,N).
C
C     IPVT    (input) INTEGER array, dimension (N)
C             This array must define the permutation matrix P such that
C             J*P = Q*R. Column j of P is column IPVT(j) of the identity
C             matrix.
C
C     DIAG    (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the diagonal elements of the
C             matrix D.
C
C     QTB     (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the first n elements of the
C             vector Q'*b.
C
C     RANKS   (input or output) INTEGER array, dimension (r), where
C             r = BN + 1,  if ST > 0, BSN > 0, and BN > 1;
C             r = BN,      if ST = 0 and BSN > 0;
C             r = 1,       if ST > 0 and ( BSN = 0 or BN <= 1 );
C             r = 0,       if ST = 0 and BSN = 0.
C             On entry, if COND = 'U' and N > 0, this array must contain
C             the numerical ranks of the submatrices S_k, k = 1:l(+1).
C             On exit, if COND = 'E' or 'N' and N > 0, this array
C             contains the numerical ranks of the submatrices S_k,
C             k = 1:l(+1), estimated according to the value of COND.
C
C     X       (output) DOUBLE PRECISION array, dimension (N)
C             This array contains the least squares solution of the
C             system J*x = b, D*x = 0.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             If COND = 'E', the tolerance to be used for finding the
C             ranks of the submatrices S_k. If the user sets TOL > 0,
C             then the given value of TOL is used as a lower bound for
C             the reciprocal condition number;  a (sub)matrix whose
C             estimated condition number is less than 1/TOL is
C             considered to be of full rank.  If the user sets TOL <= 0,
C             then an implicitly computed, default tolerance, defined by
C             TOLDEF = N*EPS,  is used instead, where EPS is the machine
C             precision (see LAPACK Library routine DLAMCH).
C             This parameter is not relevant if COND = 'U' or 'N'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, the first N elements of this array contain the
C             diagonal elements of the upper triangular matrix S, and
C             the next N elements contain the solution z.
C             If BN > 1 and BSN > 0, the elements 2*N+1 : 2*N+ST*(N-ST)
C             contain the submatrix (S(1:N-ST,N-ST+1:N))' of the
C             matrix S.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 2*N,              if BN <= 1 or  BSN = 0 and
C                                                        COND <> 'E';
C             LDWORK >= 4*N,              if BN <= 1 or  BSN = 0 and
C                                                        COND =  'E';
C             LDWORK >= ST*(N-ST) + 2*N,  if BN >  1 and BSN > 0 and
C                                                        COND <> 'E';
C             LDWORK >= ST*(N-ST) + 2*N + 2*MAX(BSN,ST),
C                                         if BN >  1 and BSN > 0 and
C                                                        COND = 'E'.
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
C     METHOD
C
C     Standard plane rotations are used to annihilate the elements of
C     the diagonal matrix D, updating the upper triangular matrix R
C     and the first n elements of the vector Q'*b. A basic least squares
C     solution is computed. The computations exploit the special
C     structure and storage scheme of the matrix R. If one or more of
C     the submatrices S_k, k = 1:l+1, is singular, then the computed
C     result is not the basic least squares solution for the whole
C     problem, but a concatenation of (least squares) solutions of the
C     individual subproblems involving R_k, k = 1:l+1 (with adapted
C     right hand sides).
C
C     REFERENCES
C
C     [1] More, J.J., Garbow, B.S, and Hillstrom, K.E.
C         User's Guide for MINPACK-1.
C         Applied Math. Division, Argonne National Laboratory, Argonne,
C         Illinois, Report ANL-80-74, 1980.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0(N*(BSN+ST)) operations and is backward
C     stable, if R is nonsingular.
C
C     FURTHER COMMENTS
C
C     This routine is a structure-exploiting, LAPACK-based modification
C     of QRSOLV from the MINPACK package [1], and with optional
C     condition estimation.
C     The option COND = 'U' is useful when dealing with several
C     right-hand side vectors.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Dec. 2001.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Linear system of equations, matrix operations, plane rotations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         COND
      INTEGER           INFO, LDR, LDWORK, LIPAR, N
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           IPAR(*), IPVT(*), RANKS(*)
      DOUBLE PRECISION  DIAG(*), DWORK(*), QTB(*), R(LDR,*), X(*)
C     .. Local Scalars ..
      DOUBLE PRECISION  QTBPJ
      INTEGER           BN, BSM, BSN, I, IB, IBSN, IS, ITC, ITR, J,
     $                  JW, K, KF, L, NC, NTHS, ST
      LOGICAL           ECOND
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DSWAP, MB02YD, MB04OW, NF01BR, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Check the scalar input parameters.
C
      ECOND = LSAME( COND, 'E' )
      INFO  = 0
      IF( .NOT.( ECOND .OR. LSAME( COND, 'N' ) .OR.
     $                      LSAME( COND, 'U' ) ) ) THEN
         INFO = -1
      ELSEIF( N.LT.0 ) THEN
         INFO = -2
      ELSEIF( LIPAR.LT.4 ) THEN
         INFO = -4
      ELSE
         ST   = IPAR(1)
         BN   = IPAR(2)
         BSM  = IPAR(3)
         BSN  = IPAR(4)
         NTHS = BN*BSN
         IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN
            INFO = -3
         ELSEIF ( N.NE.NTHS + ST ) THEN
            INFO = -2
         ELSEIF ( LDR.LT.MAX( 1, N ) ) THEN
            INFO = -6
         ELSE
            JW = 2*N
            IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN
               IF ( ECOND )
     $            JW = 4*N
            ELSE
               JW = ST*NTHS + JW
               IF ( ECOND )
     $            JW = 2*MAX( BSN, ST ) + JW
            END IF
            IF ( LDWORK.LT.JW )
     $         INFO = -14
         ENDIF
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'NF01BQ', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      IF ( BN.LE.1 .OR. BSN.EQ.0 ) THEN
C
C        Special case: R is an upper triangular matrix.
C        Workspace: 4*N, if COND =  'E';
C                   2*N, if COND <> 'E'.
C
         CALL MB02YD( COND, N, R, LDR, IPVT, DIAG, QTB, RANKS(1), X,
     $                TOL, DWORK, LDWORK, INFO )
         RETURN
      END IF
C
C     General case: BN > 1 and BSN > 0.
C     Copy R and Q'*b to preserve input and initialize S.
C     In particular, save the diagonal elements of R in X.
C
      IB = N  + 1
      IS = IB + N
      JW = IS + ST*NTHS
      I  = 1
      L  = IS
      NC = BSN + ST
      KF = NC
C
      DO 20 K = 1, BN
C
         DO 10 J = 1, BSN
            X(I) = R(I,J)
            CALL DCOPY( BSN-J+1, R(I,J), LDR, R(I,J), 1 )
            I = I + 1
   10    CONTINUE
C
   20 CONTINUE
C
C     DWORK(IS) contains a copy of [ L_1' ... L_l' ].
C     Workspace:  ST*(N-ST)+2*N;
C
      DO 30 J = BSN + 1, NC
         CALL DCOPY( NTHS, R(1,J), 1, DWORK(L), ST )
         X(I) = R(I,J)
         CALL DCOPY( NC-J+1, R(I,J), LDR, R(I,J), 1 )
         I = I + 1
         L = L + 1
   30 CONTINUE
C
      CALL DCOPY( N, QTB, 1, DWORK(IB), 1 )
      IF ( ST.GT.0 ) THEN
         ITR = NTHS + 1
         ITC = BSN  + 1
      ELSE
         ITR = 1
         ITC = 1
      END IF
      IBSN = 0
C
C     Eliminate the diagonal matrix D using Givens rotations.
C
      DO 50 J = 1, N
         IBSN = IBSN + 1
         I    = IBSN
C
C        Prepare the row of D to be eliminated, locating the
C        diagonal element using P from the QR factorization.
C
         L = IPVT(J)
         IF ( DIAG(L).NE.ZERO ) THEN
            QTBPJ = ZERO
            DWORK(J) = DIAG(L)
C
            DO 40 K = J + 1, MIN( J + KF - 1, N )
               DWORK(K) = ZERO
   40       CONTINUE
C
C           The transformations to eliminate the row of D modify only
C           a single element of Q'*b beyond the first n, which is
C           initially zero.
C
            IF ( J.LT.NTHS ) THEN
               CALL MB04OW( BSN-IBSN+1, ST, 1, R(J,IBSN), LDR,
     $                      R(ITR,ITC), LDR, DWORK(J), 1, DWORK(IB+J-1),
     $                      BSN, DWORK(IB+NTHS), ST, QTBPJ, 1 )
               IF ( IBSN.EQ.BSN )
     $            IBSN = 0
            ELSE IF ( J.EQ.NTHS ) THEN
               CALL MB04OW( 1, ST, 1, R(J,IBSN), LDR, R(ITR,ITC), LDR,
     $                      DWORK(J), 1, DWORK(IB+J-1), BSN,
     $                      DWORK(IB+NTHS), ST, QTBPJ, 1 )
               KF = ST
            ELSE
               CALL MB04OW( 0, N-J+1, 1, R(J,IBSN), LDR, R(J,IBSN), LDR,
     $                      DWORK(J), 1, DWORK(IB+J-1), 1,
     $                      DWORK(IB+J-1), ST, QTBPJ, 1 )
            END IF
         ELSE
            IF ( J.LT.NTHS ) THEN
               IF ( IBSN.EQ.BSN )
     $            IBSN = 0
               ELSE IF ( J.EQ.NTHS ) THEN
                  KF = ST
            END IF
         END IF
C
C        Store the diagonal element of S.
C
         DWORK(J) = R(J,I)
   50 CONTINUE
C
C     Solve the triangular system for z. If the system is singular,
C     then obtain an approximate least squares solution.
C     Additional workspace:   2*MAX(BSN,ST), if COND =  'E';
C                             0,             if COND <> 'E'.
C
      CALL NF01BR( COND, 'Upper', 'NoTranspose', N, IPAR, LIPAR, R, LDR,
     $             DWORK, DWORK(IS), 1, DWORK(IB), RANKS, TOL,
     $             DWORK(JW), LDWORK-JW+1, INFO )
      I = 1
C
C     Restore the diagonal elements of R from X and interchange
C     the upper and lower triangular parts of R.
C
      DO 70 K = 1, BN
C
         DO 60 J = 1, BSN
            R(I,J) = X(I)
            CALL DSWAP( BSN-J+1, R(I,J), LDR, R(I,J), 1 )
            I = I + 1
   60    CONTINUE
C
   70 CONTINUE
C
      DO 80 J = BSN + 1, NC
         CALL DSWAP( NTHS, R(1,J), 1, DWORK(IS), ST )
         R(I,J) = X(I)
         CALL DSWAP( NC-J+1, R(I,J), LDR, R(I,J), 1 )
         I  = I  + 1
         IS = IS + 1
   80 CONTINUE
C
C     Permute the components of z back to components of x.
C
      DO 90 J = 1, N
         L    = IPVT(J)
         X(L) = DWORK(N+J)
   90 CONTINUE
C
      RETURN
C
C *** Last line of NF01BQ ***
      END


      program P0218
c>> 1997-10-02 Krogh Generate plots for ch02-18.tex
      integer MAXPT
      real XA, XB, XSIZE, YMAX, YMIN, YSIZE
      parameter (MAXPT=151)
      parameter (XA = -4.0E0, XB = 4.0E0)
      parameter (YMIN = -8.E0, YMAX = 8.E0)
      parameter (XSIZE=3.2E0, YSIZE=2.5E0)
      real DX, OPT(5), X(MAXPT), Y(MAXPT)
      external SPSI
      real SPSI
      integer I
      character COPT*40
      real PLOUNI, PLOTXT, PLONY, PLOBOR, PLOYMX
      parameter (PLOUNI=1.E0, PLOTXT=14.E0, PLONY=2.E0, PLOBOR=4.E0,
     1   PLOYMX=9.E0 )
      data OPT / 0.E0, PLOYMX, YMIN, YMAX, 0.E0 /
      data COPT / 'F{pl02-18.tex}1(F12){\large $\psi(x)$}Q' /
c
      DX = (XB - XA) / MAXPT
      do 100 I = 1, MAXPT
         X(I) = XA + real(I) * DX
         Y(I) = SPSI(X(I))
  100 continue
  150 call SPLOT(XSIZE, YSIZE, X, MAXPT, Y, OPT, COPT)
      stop
      end


program random1dWalk

! allocate variables
implicit none

integer :: i, iTemp, iterN, j, k, N, t
integer :: nRun, runTotal

integer, dimension(2) :: r0, rCell, rSim
integer, allocatable :: iterateOrder(:), tRun(:)

real(8) :: L, v, xCOM, xCOMi
real(8) :: pLeft, pRight, r
real(8), allocatable :: x(:)

real(8) :: t0, tf

character(len=1024) :: filename
character(len=1024) :: format_string

call cpu_time(t0)

! initialize parameters, variables
open(unit=11,file='input.txt',status='old',action='read')
read(11,*)
read(11,*) runTotal
read(11,*) N
read(11,*) L
read(11,*) v

pLeft  = 0.5_8 - v
pRight = 0.5_8 + v

write(*,*) 'parameters:'
write(*,*) '      N =',N
write(*,*) '      L =',L
write(*,*) '      v =',v
write(*,*) '  pLeft =',pLeft
write(*,*) ' pRight =',pRight
write(*,*)

call init_random_seed()

do iterN = 10, N, 10

    allocate( x(iterN) )
    allocate( iterateOrder(iterN) )
    allocate( tRun(runTotal) )

    ! initialize arrays
    x(:) = 0.0_8
    tRun(:) = 0

    do i = 1, iterN
        iterateOrder(i) = i
    enddo

do nRun = 1, runTotal

    t = 0

    ! initial walker position
    do i = 1, iterN
        x(i) = real(i-1)
    enddo
    ! inital center of mass (COM) position
    xCOMi = 0.0_8
    xCOMi = sum(x) / real(iterN)
    xCOM  = xCOMi

    do while( (xCOM - xCOMi) < L )

        ! shuffle the order walker moves
        do i = iterN, 2, -1
            call random_number(r)
            k = 1 + floor( real(i) * r )
            iTemp = iterateOrder(i)
            iterateOrder(i) = iterateOrder(k)
            iterateOrder(k) = iTemp
        enddo

        do i = 1, iterN
            iTemp = iterateOrder(i)
            call random_number(r)
            if( r < pRight )then
                if( iTemp /= iterN .AND. iterN /= 1 )then
                    if( x(iTemp+1) /= (x(iTemp)+1.0_8) )then
                        x(iTemp) = x(iTemp) + 1.0_8
                    endif
                else
                    x(iTemp) = x(iTemp) + 1.0_8
                endif
            else
                if( iTemp /= 1 .AND. iterN /= 1 )then
                    if( x(iTemp-1) /= (x(iTemp)-1.0_8) )then
                        x(iTemp) = x(iTemp) - 1.0_8
                    endif
                else
                    x(iTemp) = x(iTemp) - 1.0_8
                endif
            endif
        enddo
        xCOM = sum(x) / real(iterN)

        t = t + 1
    enddo

    tRun(nRun) = t
enddo

! output data
! make filenames for output data
format_string = "(A6,I1,A4)"
write(filename,format_string) "tRun00", iterN, '.dat'
if( iterN >= 10 )then
    format_string = "(A5,I2,A4)"
    write(filename,format_string) "tRun0", iterN, '.dat'
endif
if( iterN >= 100)then
    format_string = "(A4,I3,A4)"
    write(filename,format_string) "tRun", iterN, '.dat'
endif

open(unit=21,file=filename,status='replace',action='write')

do i = 1, runTotal
    write(21,*) tRun(i)
enddo

deallocate( x )
deallocate( iterateOrder )
deallocate( tRun )

close(21)

enddo

call cpu_time(tf)

write(*,*) ' run time =',tf-t0
end program

! initialize RANDOM_SEED
subroutine init_random_seed()
    integer :: values(1:8), k
    integer, dimension(:), allocatable :: seed
    real(8) :: r

    call date_and_time(values=values)

    call random_seed(size=k)
    allocate(seed(1:k))
    seed(:) = values(8)
    call random_seed(put=seed)
end subroutine init_random_seed


c     Simplest fortran example of doing a 1D type 1 transform with FINUFFT,
c     a math test of one output, and how to change from default options.
c     Double-precision (see simple1d1f.f for single).
c     Legacy-style: f77, plus dynamic allocation & derived types from f90.

c     To compile (linux/GCC) from this directory, use eg (paste to one line):

c     gfortran -fopenmp -I../../include simple1d1.f -o simple1d1
c     ../../lib/libfinufft.so -lfftw3 -lfftw3_omp -lgomp -lstdc++

c     Alex Barnett and Libin Lu 5/28/20, fix ptrs 10/6/21

      program simple1d1
      implicit none

c     our fortran-header, always needed
      include 'finufft.fh'

c     note some inputs are int (int*4) but others BIGINT (int*8)
      integer ier,iflag
      integer*8 N,ktest,M,j,k,ktestindex,t1,t2,crate
      real*8, allocatable :: xj(:)
      real*8 err,tol,pi,fmax,t
      parameter (pi=3.141592653589793238462643383279502884197d0)
      complex*16, allocatable :: cj(:),fk(:)
      complex*16 fktest

c     this is how you create the options struct in fortran...
      type(nufft_opts) opts
c     or this is if you want default opts, make a null pointer...
      type(nufft_opts), pointer :: defopts => null()

c     how many nonuniform pts
      M = 2000000
c     how many modes
      N = 1000000

      allocate(fk(N))
      allocate(xj(M))
      allocate(cj(M))
      print *,''
      print *,'creating data then run simple interface, default opts...'
c     create some quasi-random NU pts in [-pi,pi], complex strengths
      do j = 1,M
         xj(j) = pi * dcos(pi*j/M)
         cj(j) = dcmplx( dsin((100d0*j)/M), dcos(1.0+(50d0*j)/M))
      enddo

      call system_clock(t1)
c     mandatory parameters to FINUFFT: sign of +-i in NUFFT
      iflag = 1
c     tolerance
      tol = 1d-9
c     Do transform: writes to fk (mode coeffs), and ier (status flag).
c     use default options:
      call finufft1d1(M,xj,cj,iflag,tol,N,fk,defopts,ier)
      call system_clock(t2,crate)
      t = (t2-t1)/float(crate)
      if (ier.eq.0) then
         print '("done in ",f6.3," sec, ",e10.2" NU pts/s")',t,M/t
      else
         print *,'failed! ier=',ier
      endif

c     math test: single output mode with given freq (not array index) k
      ktest = N/3
      fktest = dcmplx(0,0)
      do j=1,M
         fktest = fktest + cj(j) * dcmplx( dcos(ktest*xj(j)),
     $        dsin(iflag*ktest*xj(j)) )
      enddo
c     compute inf norm of fk coeffs for use in rel err
      fmax = 0
      do k=1,N
         fmax = max(fmax,cdabs(fk(k)))
      enddo
      ktestindex = ktest + N/2 + 1
      print '("rel err for mode k=",i10," is ",e10.2)',ktest,
     $     cdabs(fk(ktestindex)-fktest)/fmax

c     do another transform, but now first setting some options...
      print *,''
      print *, 'setting new options, rerun simple interface...'
      call finufft_default_opts(opts)
c     fields of derived type opts may be queried/set as usual...
      opts%debug = 2
      opts%upsampfac = 1.25d0
      print *,'first list our new set of opts values (cf nufft_opts.h):'
      print *,opts
      call system_clock(t1)
      call finufft1d1(M,xj,cj,iflag,tol,N,fk,opts,ier)
      call system_clock(t2,crate)
      t = (t2-t1)/float(crate)
      if (ier.eq.0) then
         print '("done in ",f6.3," sec, ",e10.2" NU pts/s")',t,M/t
      else
         print *,'failed! ier=',ier
      endif

      stop
      end


! { dg-do run }

module e_53_1_mod
  integer :: THRESHOLD = 20
contains
  integer recursive function fib (n) result (f)
    !$omp declare target
    integer :: n
    if (n <= 0) then
      f = 0
    else if (n == 1) then
      f = 1
    else
      f = fib (n - 1) + fib (n - 2)
    end if
  end function

  integer function fib_wrapper (n)
    integer :: x
    !$omp target map(to: n) map(from: x) if(n > THRESHOLD)
      x = fib (n)
    !$omp end target
    fib_wrapper = x
  end function
end module

program e_53_1
  use e_53_1_mod, only : fib, fib_wrapper
  if (fib (15) /= fib_wrapper (15)) call abort
  if (fib (25) /= fib_wrapper (25)) call abort
end program


submodule(forlab_stats) forlab_stats_var

    implicit none

contains

    module procedure var_1_sp
    integer :: opt_w

    opt_w = 0
    if (present(w)) opt_w = w
    select case (opt_w)
    case (0)
        var_1_sp = sum((x - mean(x))**2)/(size(x) - 1)
    case (1)
        var_1_sp = sum((x - mean(x))**2)/size(x)
    end select
    return
    end procedure var_1_sp

    module procedure var_2_sp
    integer :: opt_w, i, m, n

    opt_w = 0
    if (present(w)) opt_w = w
    m = size(A, 1)
    n = size(A, 2)
    if ((.not. present(dim)) .or. (dim == 1)) then
        allocate (var_2_sp(n))
        do i = 1, n
            var_2_sp(i) = var_1_sp(A(:, i), opt_w)
        end do
    elseif (dim == 2) then
        allocate (var_2_sp(m))
        do i = 1, m
            var_2_sp(i) = var_1_sp(A(i, :), opt_w)
        end do
    end if
    return
    end procedure var_2_sp
    module procedure var_1_dp
    integer :: opt_w

    opt_w = 0
    if (present(w)) opt_w = w
    select case (opt_w)
    case (0)
        var_1_dp = sum((x - mean(x))**2)/(size(x) - 1)
    case (1)
        var_1_dp = sum((x - mean(x))**2)/size(x)
    end select
    return
    end procedure var_1_dp

    module procedure var_2_dp
    integer :: opt_w, i, m, n

    opt_w = 0
    if (present(w)) opt_w = w
    m = size(A, 1)
    n = size(A, 2)
    if ((.not. present(dim)) .or. (dim == 1)) then
        allocate (var_2_dp(n))
        do i = 1, n
            var_2_dp(i) = var_1_dp(A(:, i), opt_w)
        end do
    elseif (dim == 2) then
        allocate (var_2_dp(m))
        do i = 1, m
            var_2_dp(i) = var_1_dp(A(i, :), opt_w)
        end do
    end if
    return
    end procedure var_2_dp
    module procedure std_1_sp
    integer :: opt_w

    opt_w = 0
    if (present(w)) opt_w = w
    std_1_sp = sqrt(var_1_sp(x, opt_w))
    return
    end procedure std_1_sp

    module procedure std_2_sp
    integer :: opt_w

    opt_w = 0
    if (present(w)) opt_w = w
    if (.not. present(dim)) then
        std_2_sp = sqrt(var_2_sp(A, opt_w))
    else
        std_2_sp = sqrt(var_2_sp(A, opt_w, dim))
    end if
    return
    end procedure std_2_sp
    module procedure std_1_dp
    integer :: opt_w

    opt_w = 0
    if (present(w)) opt_w = w
    std_1_dp = sqrt(var_1_dp(x, opt_w))
    return
    end procedure std_1_dp

    module procedure std_2_dp
    integer :: opt_w

    opt_w = 0
    if (present(w)) opt_w = w
    if (.not. present(dim)) then
        std_2_dp = sqrt(var_2_dp(A, opt_w))
    else
        std_2_dp = sqrt(var_2_dp(A, opt_w, dim))
    end if
    return
    end procedure std_2_dp

end submodule forlab_stats_var


! =================================================================================================
! This file is part of the CodeVault project. The project is licensed under Apache Version 2.0.
! CodeVault is part of the EU-project PRACE-4IP (WP7.3.C).
!
! Author(s):
!   Rafal Gandecki <rafal.gandecki@pwr.edu.pl>
!
! This example demonstrates the use of Fortran 90 with OpenMP for LU decomposition (Doolittle algorithm).
!
! See [http://www.openmp.org/] for the full OpenMP documentation.
!
! =================================================================================================

program lud_openmp

  integer, parameter :: n = 3000
  real, allocatable :: A(:)
  real, allocatable :: L(:)
  real, allocatable :: U(:)
  double precision :: t_config
  integer :: t1, t2, clock_rate, clock_max

  allocate(A(n*n))
  allocate(L(n*n))
  allocate(U(n*n))

  call fill_random(A, n, n)

  call system_clock (t1, clock_rate, clock_max )
  call lud_algorithm(A, L, U, n)
  call system_clock (t2, clock_rate, clock_max )
  t_config = real ( t2 - t1 ) / real ( clock_rate )
  print '("Time without OpenMp: ",f6.3," seconds.")', t_config

  call system_clock (t1, clock_rate, clock_max )
  call lud_openmp_algorithm(A, L, U, n)
  call system_clock (t2, clock_rate, clock_max )
  t_config = real ( t2 - t1 ) / real ( clock_rate )

  print '("Time with OpenMp: ",f6.3," seconds.")', t_config

  deallocate(A)
  deallocate(L)
  deallocate(U)

end program lud_openmp

subroutine fill_random(a, n, m)

  implicit none

  integer, intent(in) :: n, m
  real, dimension(n*m), intent(inout) :: a
  integer :: i, j
  do i=1, n
    do j=1, m
      a((i-1)*m+j) = rand()
    end do
  end do

end subroutine fill_random

subroutine lud_algorithm(A, L, U, n)

  integer, intent(in) :: n
  real, dimension(n*n), intent(in) :: A
  real, dimension(n*n), intent(inout) :: L
  real, dimension(n*n), intent(inout) :: U
  integer :: i, j, k

  do i=1, n
    do j=1, n
      if (j>i) then
        U((j-1)*n+i) = 0
      end if
      U((i-1)*n+j) = A((i-1)*n+j)
      do k=1, i-1
        U((i-1)*n+j) = U((i-1)*n+j) - (U((k-1)*n+j) * L((i-1)*n+k))
      end do
    end do
    do j=1, n
      if(i>j) then
        L((j-1)*n+i) = 0
      else if (j==i) then
        L((j-1)*n+i) = 1
      else
        L((j-1)*n+i) = A((j-1)*n+i) / U((i-1)*n+i)
        do k=1, i-1
          L((j-1)*n+i) = L((j-1)*n+i) - ((U((k-1)*n+i) * L((j-1)*n+k)) / U((i-1)*n+i))
        end do
      end if
    end do
  end do

end subroutine

subroutine lud_openmp_algorithm(A, L, U, n)

  integer, intent(in) :: n
  real, dimension(n*n), intent(in) :: A
  real, dimension(n*n), intent(inout) :: L
  real, dimension(n*n), intent(inout) :: U
  integer :: i, j, k

!$OMP PARALLEL DO DEFAULT (SHARED) PRIVATE(i,j,k)
  do i=1, n
    do j=1, n
      if (j>i) then
        U((j-1)*n+i) = 0
      end if
      U((i-1)*n+j) = A((i-1)*n+j)
      do k=1, i-1
        U((i-1)*n+j) = U((i-1)*n+j) - (U((k-1)*n+j) * L((i-1)*n+k))
      end do
    end do

    do j=1, n
      if(i>j) then
        L((j-1)*n+i) = 0
      else if (j==i) then
        L((j-1)*n+i) = 1
      else
        L((j-1)*n+i) = A((j-1)*n+i) / U((i-1)*n+i)
        do k=1, i-1
          L((j-1)*n+i) = L((j-1)*n+i) - ((U((k-1)*n+i) * L((j-1)*n+k)) / U((i-1)*n+i))
        end do
      end if
    end do
  end do

!$OMP END PARALLEL DO
end subroutine

subroutine print_array(a, n, m)
  implicit none

  integer, intent(in) :: n, m
  real, dimension(n*m), intent(in) :: a
  integer :: i, j
  do i=1, n
    do j=1, m
      print '(F8.4,$)', a((i-1)*m+j)
    end do
    print *, ''
  end do
end subroutine print_array


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
!cd  incompressible for ASME nozzles eq 4a 4b
!
!     author: Yannick Muller
!
      subroutine pk_cdi_noz(reynolds,cdi_noz)
!
      implicit none
!
      real*8 reynolds,cdi_noz,ln_reynolds,cdi_noz_lr,
     &     cdi_noz_hr,e,reynolds_cor
!
      if (reynolds.lt.40000d0) then
!
! formerly pk_cdi_noz_lr : for low Reynolds nsumber
!
         if (reynolds.eq.0d0) then
            reynolds_cor=1.d0
         else
            reynolds_cor=reynolds
         endif
         e=2.718281828459045d0
         ln_reynolds=log(reynolds_cor)/log(e)
!
         cdi_noz_lr=0.19436d0+0.152884d0*ln_reynolds
     &        -0.0097785d0*ln_reynolds**2d0+0.00020903d0
     &        *ln_reynolds**3d0
!
         cdi_noz=cdi_noz_lr
!
      elseif (reynolds.lt.50000d0) then
!
         if (reynolds.eq.0) then
            reynolds_cor=1
         else
            reynolds_cor=reynolds
         endif
!
         e=2.718281828459045d0
         ln_reynolds=log(reynolds_cor)/log(e)
!
         cdi_noz_lr=0.19436d0+0.152884d0*ln_reynolds
     &        -0.0097785d0*ln_reynolds**2+0.00020903d0
     &        *ln_reynolds**3d0
!
         cdi_noz_hr=0.9975d0-0.00653d0*dsqrt(1000000d0/50000d0)

!     linear interpolation in order to achieve continuity
!
         cdi_noz=cdi_noz_lr+(cdi_noz_hr-cdi_noz_lr)
     &        *(reynolds-40000d0)/(50000d0-40000d0)
      else
!
!     formerly pk_cdi_noz_hr for high Reynolds numbers
!
         cdi_noz=0.9975d0-0.00653d0*dsqrt(1000000d0/reynolds)
      endif

      return
      end


module EFIE_mpi
  use tools
  use meshread_mod
  use mpi
  implicit none

  real(8), parameter, private :: pi = 4d0 * atan(1d0)
  complex(8), parameter, private :: IU = (0d0, 1d0)

  private :: findIndices,param
  private :: intSauterSchwabIdentical
  private :: intSauterSchwabEdge
  private :: intSauterSchwabVertex
  private :: gather_MPImatrix, assemble_matrix
contains

  !----------------------------------------------------------------------------!
  !                                 SUBROUTINES
  !----------------------------------------------------------------------------!

!*****************************************************************************!
subroutine genEFIESauterSchwabMat_mpi(Z, msh, k, nNS, nSG)
  integer, intent(in) :: nNS ! number of quadrature points for non-singular integration
  integer, intent(in) :: nSG ! number of quadrature points for singular integration (Sauter-Schwab)

  complex(8),allocatable,intent(out) :: Z(:,:)

  complex(8),allocatable :: Z_bff(:,:,:), Z_gather(:,:,:)

  type(Mesh),intent(in) :: msh

  real(8),intent(in) :: k

  integer ::i,j,n,m,ii,jj,cnt,pos(3,2)

  integer :: nd_i(3),nd_j(3)

  integer :: edg_j(3),edg_i(3)

  integer :: opp_nod_j(3),opp_nod_i(3)

  real(8) :: p(3,3),q(3,3)

  real(8) :: A_j,A_i,len_j(3),len_i(3)

  real(8) :: f_i(3),f_j(3),df_i,df_j

  real(8) :: Rvec(3),R

  real(8) :: q_src_nod(3,3),p_src_nod(3,3)

  complex(8) :: G,intg(3,3)

  integer :: start, finish , ierr, id, N_procs

  real(8) :: qq(nNS,3),pp(nNS,3)

  real(8):: V(nNS,3),wei(nNS)

  integer:: n_triangle

  !-----------------------------------------------------------------------------!
  call gaussQuadratureTriangles(V,wei,nNS)

  ! for parallelization
  call divide_work(start,finish,msh%nbELm)

  ! allocate buffer matrix
  allocate(Z_bff(3, msh%nbEdg, finish-start+1))
  Z_bff = 0.0d0

  n_triangle = 0
  do j = start,finish ! loop over the elements
    n_triangle = n_triangle + 1
    nd_j      = msh%ELE_NODES(j,1:3)  ! node indices
    edg_j     = msh%ELE_EDGES(j,1:3)  ! edge indices
    opp_nod_j = msh%ELE_EDGES(j,4:6)  ! index of the node opposed to the edge
    len_j     = msh%EDG_LEN(edg_j)    ! length of the edges
    A_j       = msh%A(j)              ! area of the triangle

    q  = msh%POS(nd_j,1:3) ! coordinates of the triangular nodes
    q_src_nod  = msh%POS(abs(opp_nod_j),1:3)
    qq = matmul(V,q)

    do i = 1,msh%nbElm ! loop over the elements to compute inner integral

      nd_i      = msh%ELE_NODES(i,1:3) ! node indices
      edg_i     = msh%ELE_EDGES(i,1:3)  ! edge indices
      opp_nod_i = msh%ELE_EDGES(i,4:6)  ! index of the node opposed to the edge
      len_i     = msh%EDG_LEN(edg_i)
      A_i       = msh%A(i)

      p = msh%POS(nd_i,1:3) ! mesh nodes in i-th element
      p_src_nod = msh%POS(abs(opp_nod_i),1:3) ! mesh nodes in i-th element
      pp = matmul(V,p)

      call findIndices(cnt,pos,nd_j,nd_i)

      if (cnt==3) then

        call intSauterSchwabIdentical(intg,k,p,p_src_nod,len_i,A_i,opp_nod_i,nSG)
        !Z_bff(edg_j,edg_i) = Z_bff(edg_j,edg_i) + A_i*A_j*intg/pi
        Z_bff(:, edg_i, n_triangle) = Z_bff(:, edg_i, n_triangle) + A_i*A_j*intg/pi

      elseif (cnt==2) then

        call intSauterSchwabEdge(intg,k,pos,&
                                q,q_src_nod,len_j,A_j,opp_nod_j,&
                                p,p_src_nod,len_i,A_i,opp_nod_i,nSG)

        !Z_bff(edg_j,edg_i) = Z_bff(edg_j,edg_i) + A_i*A_j*intg/pi
        Z_bff(:, edg_i, n_triangle) = Z_bff(:, edg_i, n_triangle) + A_i*A_j*intg/pi

      elseif (cnt==1) then

        call intSauterSchwabVertex(intg,k,pos,&
                                q,q_src_nod,len_j,A_j,opp_nod_j,&
                                p,p_src_nod,len_i,A_i,opp_nod_i,nSG)

        !Z_bff(edg_j,edg_i) = Z_bff(edg_j,edg_i) + A_i*A_j*intg/pi
        Z_bff(:, edg_i, n_triangle) = Z_bff(:, edg_i, n_triangle) + A_i*A_j*intg/pi

      else
        do jj=1,nNS !quadrature exterior integration

          do ii=1,nNS !quadrature interior integration

            Rvec = qq(jj,:)-pp(ii,:)
            R    = sqrt(sum(Rvec*Rvec))
            G    = exp(iu*k*R)/R/(4.0d0*pi)

            do m=1,3 !basis functions exterior

              f_j  = sign(1,opp_nod_j(m))*len_j(m)*(q_src_nod(m,:)-qq(jj,:))/(2.0d0*A_j)
              df_j = -sign(1,opp_nod_j(m))*len_j(m)/A_j

              do n=1,3 !basis functions interior

                f_i  = sign(1,opp_nod_i(n))*len_i(n)*(p_src_nod(n,:)-pp(ii,:))/(2.0d0*A_i)
                df_i = -sign(1,opp_nod_i(n))*len_i(n)/A_i

                !Z_bff(edg_j(m),edg_i(n)) = Z_bff(edg_j(m),edg_i(n)) + &
                  !A_i*A_j*wei(ii)*wei(jj) * G*(sum(f_j*f_i)-df_j*df_i/k**2)
                Z_bff(m, edg_i(n), n_triangle) = Z_bff(m, edg_i(n), n_triangle) + &
                  A_i*A_j*wei(ii)*wei(jj) * G*(sum(f_j*f_i)-df_j*df_i/k**2)

              enddo
            enddo
          enddo
        enddo
      endif
    enddo
  enddo

  call mpi_comm_rank(MPI_comm_world,id,ierr)
  call mpi_comm_size(MPI_comm_world, N_procs, ierr)

  ! Gather matrix data into the root process
  call gather_MPImatrix(3, msh%nbEdg, msh%nbELm, id, N_procs, Z_bff, Z_gather)
  deallocate(Z_bff)

  ! Assemble system matrix in root process
  if (id==0) then
    call assemble_matrix(msh, Z_gather, Z)
    deallocate(Z_gather)
  end if
end subroutine genEFIESauterSchwabMat_mpi

! Subroutine to gather a 3D array of shape (size1, size2, size3)
! into the root process using MPI.
! Each process stores a subarray of shape (size1, size2, size3/N_procs)
subroutine gather_MPImatrix(size1, size2, size3, id, N_procs, Z_bff, Z_gather)
    integer, intent(in) :: size1, size2, size3
    integer, intent(in) :: id                        ! MPI id of each process
    integer, intent(in) :: N_procs                   ! MPI number of processes
    complex(8), intent(in) :: Z_bff(:,:,:)           ! Local matrix
    complex(8), allocatable, intent(out) :: Z_gather(:,:,:)  ! Full matrix

    integer :: i, ierr
    integer :: data_per_process, lWork
    integer :: rcounts(N_procs)          ! list of number of elements sent from each process
    integer :: displs(N_procs)           ! list of relative displacement between blocks of data

    if (id==0) then
        allocate(Z_gather(size1, size2, size3))
        Z_gather = 0d0

        lWork = size3 / N_procs
        data_per_process = size1 * size2 * lWork

        rcounts = data_per_process
        do i= 1, N_procs
            displs(i) = (i-1) * data_per_process
            if (i == N_procs) then
                rcounts(N_procs) = size1 * size2 * (size3 - (N_procs-1)*lWork)
            end if
        end do
    end if

    call mpi_gatherv(Z_bff, size(Z_bff), MPI_double_complex, Z_gather, rcounts, displs,  &
                     MPI_double_complex, 0, MPI_comm_world, ierr)
end subroutine gather_MPImatrix

! Subroutine to assemble the system matrix (Z)
! from previously gathered data (Z_gather)
subroutine assemble_matrix(msh, Z_gather, Z)
    type(Mesh), intent(in) :: msh
    complex(8), intent(in) :: Z_gather(:,:,:)
    complex(8), allocatable, intent(out) :: Z(:,:)
    integer :: j, edg_j(3)

    allocate(Z(msh%nbEdg, msh%nbEdg))
    Z = 0d0
    do j = 1, msh%nbELm                  ! loop over the elements
        edg_j = msh%ELE_EDGES(j, 1:3)    ! edge indices
        Z(edg_j, :) = Z(edg_j, :) + Z_gather(:, :, j)
    end do
end subroutine assemble_matrix

subroutine genEFIEPot_mpi(Epot, nEvl, xEvl, msh, k)

    complex(8), allocatable,intent(out) :: Epot(:,:,:)

    complex(8), allocatable :: E_bff(:,:,:), Epot_aux(:,:,:)

    integer,intent(in) :: nEvl

    real(8),intent(in) :: xEvl(nEvl,3)

    type(Mesh),intent(in) :: msh

    real(8),intent(in) :: k

    integer ::i,j,n,nd_i(3),edg_i(3),opp_nod_i(3)

    real(8) :: p(3,3),p_int(3,3),p_src_nod(3,3)

    real(8) :: n_i(3)

    real(8):: V(3,3)

    real(8) :: A_i,len_i(3)

    real(8) :: f_n(3,3),df_n

    real(8) :: Rvec(3,3),R(3),x(3)

    complex(8) :: G(3),Gp(3),gradG(3,3)

    integer :: start, finish , ierr, id, N_procs
    integer :: jEvl

    V(1,:) = (/ 2.0d0/3.0d0, 1.0d0/6.0d0, 1.0d0/6.0d0 /)
    V(2,:) = (/ 1.0d0/6.0d0, 2.0d0/3.0d0, 1.0d0/6.0d0 /)
    V(3,:) = (/ 1.0d0/6.0d0, 1.0d0/6.0d0, 2.0d0/3.0d0 /)

    call divide_work(start,finish,nEvl)

    allocate(E_bff(3, msh%nbEdg, finish-start+1))
    E_bff = 0.0d0

    jEvl = 0
    do j=start,finish !loop over the evaluation points
      jEvl = jEvl + 1
      x = xEvl(j,:) ! coordenates of the evaluation point

      !==== Computation of the surface integral ====!
      do i = 1,msh%nbElm ! loop over the triangles T_i

        nd_i      = msh%ELE_NODES(i,1:3) ! node indices
        edg_i     = msh%ELE_EDGES(i,1:3) ! edge indices
        opp_nod_i = msh%ELE_EDGES(i,4:6) ! index of the node opposed to the edge
        len_i     = msh%EDG_LEN(edg_i)   ! length of the edges of the triangle
        A_i       = msh%A(i)             ! area of the triangle
        n_i       = msh%NRM(i,:)         ! unit normal to the triangle

        p = msh%POS(nd_i,1:3)            ! mesh nodes in i-th element
        p_src_nod = msh%POS(abs(opp_nod_i),1:3) ! mesh nodes in i-th element
        p_int = matmul(V,p)              ! quadrature points to integrate
                                         ! over the triangle

        Rvec  = spread(x,1,3)-p_int      ! the rows of Rvec are x-p_int_j, j=1,2,3
        R     = sqrt(sum(Rvec*Rvec,2))   ! distance from the x to p_int_j, j=1,2,3
        G     = exp(iu*k*R)/R/(4.0d0*pi) ! Green function at Rvec
        Gp    = (iu*k-1.0d0/R)*G         ! Aux. variable to compute grad with respect to x
        gradG = Rvec*spread(Gp/R,2,3)    ! Grad. with respect to x

        do n=1,3 ! loop over edges of T_i
          f_n  = sign(1,opp_nod_i(n))*len_i(n)*(spread(p_src_nod(n,:),1,3)-p_int)/(2.0d0*A_i)
          df_n = -sign(1,opp_nod_i(n))*len_i(n)/A_i

          E_bff(:,edg_i(n),jEvl) = E_bff(:,edg_i(n),jEvl) + A_i/3.0d0 *  &
          (G(1)*f_n(1,:)+G(2)*f_n(2,:)+G(3)*f_n(3,:) + k**(-2)*df_n*sum(gradG,1))
        enddo
      enddo
    enddo

    call mpi_comm_rank(MPI_comm_world,id,ierr)
    call mpi_comm_size(MPI_comm_world, N_procs, ierr)

    ! Gather matrix data into the root process
    call gather_MPImatrix(3, msh%nbEdg, nEvl, id, N_procs, E_bff, Epot_aux)
    deallocate(E_bff)

    ! Transpose matrix just to be consistent
    ! with previous subroutines
    if (id==0) then
      allocate(Epot(nEvl, msh%nbEdg, 3))
      Epot(:, :, 1) = transpose(Epot_aux(1, :, :))
      Epot(:, :, 2) = transpose(Epot_aux(2, :, :))
      Epot(:, :, 3) = transpose(Epot_aux(3, :, :))
    end if

end subroutine genEFIEPot_mpi

!******************************************************************************!
function  param(u,v,p1,p2,p3) result(x)
  implicit none
  real(8),intent(in) :: u,v,p1(3),p2(3),p3(3)
  real(8) :: x(3)
  x =p1+u*(p2-p1)+v*(p3-p2)
end function  param
!******************************************************************************!
subroutine intSauterSchwabIdentical(intg,k,p,p_src,len_p,A,opp_nod,nQ)
  implicit none
  complex(8), parameter :: iu=(0.0d0,1.0d0)
  real(8),intent(in) :: k,p(3,3),p_src(3,3),len_p(3),A
  integer,intent(in) :: opp_nod(3),nQ
  complex(8),intent(out) :: intg(3,3)
  real(8) :: t(nq),w(nq)
  real(8) :: fO(3),fI(3),dfO,dfI
  real(8) :: x(3),y(3),x0(3),y0(3)
  integer :: n1,n2,n3,i,n,m,l
  real(8) :: eta1,eta2,eta3,xi,uO,vO,uI,vI
  complex(8) :: Ker(3,3)
  ! !-------------------------------------------------------------------------!

  call gaussQuadrature(t,w,nQ)

  w = 0.5d0*w
  t = 0.5d0*(1.0d0+t)

  intg = 0.0d0

  do n1=1,nQ ! eta1
      eta1 = t(n1)
      do n2=1,nQ !eta2
          eta2 = t(n2)
          do n3=1,nQ !eta3
              eta3 = t(n3)
              do i=1,nQ ! xi
                  xi = t(i)
                  do l=1,6
                    if (l==1) then
                      uO = 1.0d0
                      vO = (1.0d0-eta1+eta1*eta2)
                      uI = (1.0d0-eta1*eta2*eta3)
                      vI = (1.0d0-eta1)
                    elseif (l==2) then
                      uO = (1.0d0-eta1*eta2*eta2)
                      vO = (1.0d0-eta1)
                      uI = 1.0d0
                      vI = (1.0d0-eta1+eta1*eta2)
                    elseif (l==3) then
                      uO = 1.0d0
                      vO = eta1*(1.0d0-eta2+eta2*eta3)
                      uI = (1.0d0-eta1*eta2)
                      vI = eta1*(1.0d0-eta2)
                    elseif (l==4) then
                      uO = (1.0d0-eta1*eta2)
                      vO = eta1*(1.0d0-eta2)
                      uI = 1.0d0
                      vI = eta1*(1.0d0-eta2+eta2*eta3)
                    elseif (l==5) then
                      uO = (1.0d0-eta1*eta2*eta3)
                      vO = eta1*(1.0d0-eta2*eta3)
                      uI = 1.0d0
                      vI = eta1*(1.0d0-eta2)
                    elseif (l==6) then
                      uO = 1.0d0
                      vO = eta1*(1.0d0-eta2)
                      uI = (1.0d0-eta1*eta2*eta3)
                      vI = eta1*(1.0d0-eta2*eta3)
                    endif

                    x =  param(xi*uO,xi*vO,p(1,:),p(2,:),p(3,:))
                    y =  param(xi*uI,xi*vI,p(1,:),p(2,:),p(3,:))

                    x0 =  param(uO,vO,p(1,:),p(2,:),p(3,:))
                    y0 =  param(uI,vI,p(1,:),p(2,:),p(3,:))

                    do n=1,3
                      fO = sign(1,opp_nod(n))*len_p(n)*(p_src(n,:)-x)/(2.0d0*A)
                      dfO = -sign(1,opp_nod(n))*len_p(n)/A
                      do m=1,3
                        fI = sign(1,opp_nod(m))*len_p(m)*(p_src(m,:)-y)/(2.0d0*A)
                        dfI = -sign(1,opp_nod(m))*len_p(m)/A
                        Ker(n,m) = sum(fO*fI)-dfO*dfI/k**2
                      enddo
                    enddo

                    Ker = exp(iu*k*sqrt(sum((x-y)**2)))/sqrt(sum((x0-y0)**2))*Ker

                    intg = intg + eta1**2*eta2*w(n1)*w(n2)*w(n3)*w(i)*Ker*xi**2

                  enddo
              enddo
          enddo
      enddo
  enddo
  return
end subroutine intSauterSchwabIdentical
!******************************************************************************!
subroutine intSauterSchwabEdge(intg,k,pos,&
                        q,q_src,len_q,A_q,opp_nod_q,&
                        p,p_src,len_p,A_p,opp_nod_p,nQ)
  implicit none
  complex(8), parameter :: iu=(0.0d0,1.0d0)
  real(8),intent(in) :: q(3,3),p(3,3),q_src(3,3),p_src(3,3),k
  real(8),intent(in) :: A_q,A_p,len_q(3),len_p(3)
  integer,intent(in) :: pos(3,2),opp_nod_q(3),opp_nod_p(3),nQ
  complex(8),intent(out) :: intg(3,3)
  real(8) :: fO(3),fI(3),dfO,dfI
  real(8) :: x(3),y(3),x0(3),y0(3)
  integer :: n1,n2,n3,i,j,n,m,l
  real(8) :: eta1,eta2,eta3,xi,uO,vO,uI,vI
  complex(8) :: Ker(3,3)
  integer :: nd_q(3),nd_p(3)
  complex(8) :: intgAux(3,3)
  real(8) :: qAux(3,3),pAux(3,3),q_srcAux(3,3),p_srcAux(3,3)
  real(8) :: len_qAux(3),len_pAux(3)
  integer :: opp_nod_qAux(3),opp_nod_pAux(3)
  real(8) :: t(nq),w(nq)

  !-------------------------------------------------------------------------!
  call gaussQuadrature(t,w,nQ)

  w = 0.5d0*w
  t = 0.5d0*(1.0d0+t)

  ! find the common edge first:
  nd_q(1:2) = pos(1:2,1)
  nd_p(1:2) = pos(1:2,2)

  if ((nd_q(1).ne.1).and.(nd_q(2).ne.1)) nd_q(3)=1
  if ((nd_q(1).ne.2).and.(nd_q(2).ne.2)) nd_q(3)=2
  if ((nd_q(1).ne.3).and.(nd_q(2).ne.3)) nd_q(3)=3

  if ((nd_p(1).ne.1).and.(nd_p(2).ne.1)) nd_p(3)=1
  if ((nd_p(1).ne.2).and.(nd_p(2).ne.2)) nd_p(3)=2
  if ((nd_p(1).ne.3).and.(nd_p(2).ne.3)) nd_p(3)=3

  pAux =p(nd_p,:)
  qAux =q(nd_q,:)
  p_srcAux = p_src(nd_p,:)
  q_srcAux = q_src(nd_q,:)
  opp_nod_pAux =opp_nod_p(nd_p)
  opp_nod_qAux =opp_nod_q(nd_q)

  len_pAux = len_p(nd_p)
  len_qAux = len_q(nd_q)

  !---------------------------
  intgAux = 0.0d0

  do n1=1,nQ ! eta1
      eta1 = t(n1)
      do n2=1,nQ !eta2
          eta2 = t(n2)
          do n3=1,nQ !eta3
              eta3 = t(n3)
              do i=1,nQ ! xi
                  xi = t(i)
                  do l=1,5
                  !----------------------------------------------------------
                    if (l==1) then
                      uO = 1.0d0
                      vO = eta1*eta3
                      uI = (1.0d0-eta1*eta2)
                      vI = eta1*(1.0d0-eta2)
                    elseif (l==2) then
                      uO = 1.0d0
                      vO = eta1
                      uI = (1.0d0-eta1*eta2*eta3)
                      vI = eta1*eta2*(1.0d0-eta3)
                    elseif (l==3) then
                      uO = (1.0d0-eta1*eta2)
                      vO = eta1*(1.0d0-eta2)
                      uI = 1.0d0
                      vI = eta1*eta2*eta3
                    elseif (l==4) then
                      uO = (1.0d0-eta1*eta2*eta3)
                      vO = eta1*eta2*(1.0d0-eta3)
                      uI = 1.0d0
                      vI = eta1
                    elseif (l==5) then
                      uO = (1.0d0-eta1*eta2*eta3)
                      vO = eta1*(1.0d0-eta2*eta3)
                      uI = 1.0d0
                      vI = eta1*eta2
                    endif

                    x =  param(xi*uO,xi*vO,qAux(1,:),qAux(2,:),qAux(3,:))
                    y =  param(xi*uI,xi*vI,pAux(1,:),pAux(2,:),pAux(3,:))

                    x0 =  param(uO,vO,qAux(1,:),qAux(2,:),qAux(3,:))
                    y0 =  param(uI,vI,pAux(1,:),pAux(2,:),pAux(3,:))

                    do n=1,3

                      fO = sign(1,opp_nod_qAux(n))*len_qAux(n)*(q_srcAux(n,:)-x)/(2.0d0*A_q)
                      dfO = -sign(1,opp_nod_qAux(n))*len_qAux(n)/A_q

                      do m=1,3

                        fI = sign(1,opp_nod_pAux(m))*len_pAux(m)*(p_srcAux(m,:)-y)/(2.0d0*A_p)
                        dfI = -sign(1,opp_nod_pAux(m))*len_pAux(m)/A_p

                        Ker(n,m) = sum(fO*fI)-dfO*dfI/k**2

                      enddo

                    enddo

                    Ker = exp(iu*k*sqrt(sum((x-y)**2)))/sqrt(sum((x0-y0)**2))*Ker

                    if (l==1) then
                      intgAux = intgAux + w(n1)*w(n2)*w(n3)*w(i)*eta1**2*Ker*xi**2
                    else
                      intgAux = intgAux + w(n1)*w(n2)*w(n3)*w(i)*eta1**2*eta2*Ker*xi**2
                    endif
                  enddo
              enddo
          enddo
      enddo
  enddo

  do i=1,3
    do j=1,3
      intg(nd_q(i),nd_p(j)) = intgAux(i,j)
    enddo
  enddo

  return
end subroutine intSauterSchwabEdge

!******************************************************************************!
subroutine intSauterSchwabVertex(intg,k,pos,&
                        q,q_src,len_q,A_q,opp_nod_q,&
                        p,p_src,len_p,A_p,opp_nod_p,nQ)
  implicit none
  complex(8), parameter :: iu=(0.0d0,1.0d0)
  real(8),intent(in) :: q(3,3),p(3,3),q_src(3,3),p_src(3,3),k
  real(8),intent(in) :: A_q,A_p,len_q(3),len_p(3)
  integer,intent(in) :: pos(3,2),opp_nod_q(3),opp_nod_p(3),nQ
  complex(8),intent(out) :: intg(3,3)
  real(8) :: fO(3),fI(3),dfO,dfI
  real(8) :: x(3),y(3),x0(3),y0(3)
  integer :: n1,n2,n3,i,j,l0,m,n,l
  real(8) :: eta1,eta2,eta3,xi,uO,vO,uI,vI
  complex(8) :: Ker(3,3)
  integer :: nd_q(3),nd_p(3)
  complex(8) :: intgAux(3,3)

  real(8) :: qAux(3,3),pAux(3,3),q_srcAux(3,3),p_srcAux(3,3)
  real(8) :: len_qAux(3),len_pAux(3)
  integer :: opp_nod_qAux(3),opp_nod_pAux(3)
  real(8) :: t(nq),w(nq)

  !-------------------------------------------------------------------------!
  call gaussQuadrature(t,w,nQ)

  w = 0.5d0*w
  t = 0.5d0*(1.0d0+t)

  ! find the common edge first:
  !pos(1,1) in q is pos(1,2) in p
  nd_q(1) = pos(1,1)
  l0 = mod(nd_q(1)+1,3)
  if (l0==0) l0=3
  nd_q(2) = l0
  l0 = mod(nd_q(1)+2,3)
  if (l0==0) l0=3
  nd_q(3) = l0

  nd_p(1) = pos(1,2)
  l0 = mod(nd_p(1)+1,3)
  if (l0==0) l0=3
  nd_p(2) = l0
  l0= mod(nd_p(1)+2,3)
  if (l0==0) l0=3
  nd_p(3) = l0

  pAux =p(nd_p,:)
  qAux =q(nd_q,:)
  p_srcAux = p_src(nd_p,:)
  q_srcAux = q_src(nd_q,:)
  opp_nod_pAux =opp_nod_p(nd_p)
  opp_nod_qAux =opp_nod_q(nd_q)

  len_pAux = len_p(nd_p)
  len_qAux = len_q(nd_q)
  !---------------------------
  intgAux = 0.0d0

  do n1=1,nQ ! eta1
      eta1 = t(n1)
      do n2=1,nQ !eta2
          eta2 = t(n2)
          do n3=1,nQ !eta3
              eta3 = t(n3)
              do i=1,nQ ! xi
                xi = t(i)
                do l=1,2
                  if (l==1) then
                    uO = 1.0d0
                    vO = eta1
                    uI = eta2
                    vI = eta2*eta3
                  elseif (l==2) then
                    uO = eta2
                    vO = eta2*eta3
                    uI = 1.0d0
                    vI = eta1
                  endif

                  x =  param(xi*uO,xi*vO,qAux(1,:),qAux(2,:),qAux(3,:))
                  y =  param(xi*uI,xi*vI,pAux(1,:),pAux(2,:),pAux(3,:))

                  x0 =  param(uO,vO,qAux(1,:),qAux(2,:),qAux(3,:))
                  y0 =  param(uI,vI,pAux(1,:),pAux(2,:),pAux(3,:))

                  do n=1,3

                    fO = sign(1,opp_nod_qAux(n))*len_qAux(n)*(q_srcAux(n,:)-x)/(2.0d0*A_q)
                    dfO = -sign(1,opp_nod_qAux(n))*len_qAux(n)/A_q

                    do m=1,3

                      fI = sign(1,opp_nod_pAux(m))*len_pAux(m)*(p_srcAux(m,:)-y)/(2.0d0*A_p)
                      dfI = -sign(1,opp_nod_pAux(m))*len_pAux(m)/A_p

                      Ker(n,m) = sum(fO*fI)-dfO*dfI/k**2

                    enddo

                  enddo

                  Ker = exp(iu*k*sqrt(sum((x-y)**2)))/sqrt(sum((x0-y0)**2))*Ker

                  intgAux = intgAux + w(n1)*w(n2)*w(n3)*w(i)*eta2*Ker*xi**2

                enddo
              enddo
          enddo
      enddo
  enddo

  do i=1,3
    do j=1,3
      intg(nd_q(i),nd_p(j)) = intgAux(i,j)
    enddo
  enddo
  return
end subroutine intSauterSchwabVertex
!*****************************************************************************!
subroutine findIndices(cnt,pos,indOut,indIn)
  ! cnt: number of vertices in common
  ! pos: coincident vertices
  implicit none
  integer :: pos(:,:),n,indOut(:),indIn(:)
  integer :: i,j,cnt

  n = size(indOut)
  cnt = 0
  pos = 0
  do i=1,n
    do j=1,n
      if (indOut(i)==indIn(j)) then
        cnt = cnt + 1
        pos(cnt,1)=i
        pos(cnt,2)=j
      endif
    end do
  enddo
  return
end subroutine findIndices

end module


      SUBROUTINE SB01BD( DICO, N, M, NP, ALPHA, A, LDA, B, LDB, WR, WI,
     $                   NFP, NAP, NUP, F, LDF, Z, LDZ, TOL, DWORK,
     $                   LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To determine the state feedback matrix F for a given system (A,B)
C     such that the closed-loop state matrix A+B*F has specified
C     eigenvalues.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the original system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The dimension of the state vector, i.e. the order of the
C             matrix A, and also the number of rows of the matrix B and
C             the number of columns of the matrix F.  N >= 0.
C
C     M       (input) INTEGER
C             The dimension of input vector, i.e. the number of columns
C             of the matrix B and the number of rows of the matrix F.
C             M >= 0.
C
C     NP      (input) INTEGER
C             The number of given eigenvalues. At most N eigenvalues
C             can be assigned.  0 <= NP.
C
C     ALPHA   (input) DOUBLE PRECISION
C             Specifies the maximum admissible value, either for real
C             parts, if DICO = 'C', or for moduli, if DICO = 'D',
C             of the eigenvalues of A which will not be modified by
C             the eigenvalue assignment algorithm.
C             ALPHA >= 0 if DICO = 'D'.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Z'*(A+B*F)*Z in a real Schur form.
C             The leading NFP-by-NFP diagonal block of A corresponds
C             to the fixed (unmodified) eigenvalues having real parts
C             less than ALPHA, if DICO = 'C', or moduli less than ALPHA,
C             if DICO = 'D'. The trailing NUP-by-NUP diagonal block of A
C             corresponds to the uncontrollable eigenvalues detected by
C             the eigenvalue assignment algorithm. The elements under
C             the first subdiagonal are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             input/state matrix.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     WR,WI   (input/output) DOUBLE PRECISION array, dimension (NP)
C             On entry, these arrays must contain the real and imaginary
C             parts, respectively, of the desired eigenvalues of the
C             closed-loop system state-matrix A+B*F. The eigenvalues
C             can be unordered, except that complex conjugate pairs
C             must appear consecutively in these arrays.
C             On exit, if INFO = 0, the leading NAP elements of these
C             arrays contain the real and imaginary parts, respectively,
C             of the assigned eigenvalues. The trailing NP-NAP elements
C             contain the unassigned eigenvalues.
C
C     NFP     (output) INTEGER
C             The number of eigenvalues of A having real parts less than
C             ALPHA, if DICO = 'C', or moduli less than ALPHA, if
C             DICO = 'D'. These eigenvalues are not modified by the
C             eigenvalue assignment algorithm.
C
C     NAP     (output) INTEGER
C             The number of assigned eigenvalues. If INFO = 0 on exit,
C             then NAP = N-NFP-NUP.
C
C     NUP     (output) INTEGER
C             The number of uncontrollable eigenvalues detected by the
C             eigenvalue assignment algorithm (see METHOD).
C
C     F       (output) DOUBLE PRECISION array, dimension (LDF,N)
C             The leading M-by-N part of this array contains the state
C             feedback F, which assigns NAP closed-loop eigenvalues and
C             keeps unaltered N-NAP open-loop eigenvalues.
C
C     LDF     INTEGER
C             The leading dimension of array F.  LDF >= MAX(1,M).
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
C             The leading N-by-N part of this array contains the
C             orthogonal matrix Z which reduces the closed-loop
C             system state matrix A + B*F to upper real Schur form.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.  LDZ >= MAX(1,N).
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The absolute tolerance level below which the elements of A
C             or B are considered zero (used for controllability tests).
C             If the user sets TOL <= 0, then the default tolerance
C             TOL = N * EPS * max(NORM(A),NORM(B)) is used, where EPS is
C             the machine precision (see LAPACK Library routine DLAMCH)
C             and NORM(A) denotes the 1-norm of A.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of working array DWORK.
C             LDWORK >= MAX( 1,5*M,5*N,2*N+4*M ).
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = K:  K violations of the numerical stability condition
C                   NORM(F) <= 100*NORM(A)/NORM(B) occured during the
C                   assignment of eigenvalues.
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             = 1:  the reduction of A to a real Schur form failed;
C             = 2:  a failure was detected during the ordering of the
C                   real Schur form of A, or in the iterative process
C                   for reordering the eigenvalues of Z'*(A + B*F)*Z
C                   along the diagonal.
C             = 3:  the number of eigenvalues to be assigned is less
C                   than the number of possibly assignable eigenvalues;
C                   NAP eigenvalues have been properly assigned,
C                   but some assignable eigenvalues remain unmodified.
C             = 4:  an attempt is made to place a complex conjugate
C                   pair on the location of a real eigenvalue. This
C                   situation can only appear when N-NFP is odd,
C                   NP > N-NFP-NUP is even, and for the last real
C                   eigenvalue to be modified there exists no available
C                   real eigenvalue to be assigned. However, NAP
C                   eigenvalues have been already properly assigned.
C
C     METHOD
C
C     SB01BD is based on the factorization algorithm of [1].
C     Given the matrices A and B of dimensions N-by-N and N-by-M,
C     respectively, this subroutine constructs an M-by-N matrix F such
C     that A + BF has eigenvalues as follows.
C     Let NFP eigenvalues of A have real parts less than ALPHA, if
C     DICO = 'C', or moduli less then ALPHA, if DICO = 'D'. Then:
C     1) If the pair (A,B) is controllable, then A + B*F has
C        NAP = MIN(NP,N-NFP) eigenvalues assigned from those specified
C        by WR + j*WI and N-NAP unmodified eigenvalues;
C     2) If the pair (A,B) is uncontrollable, then the number of
C        assigned eigenvalues NAP satifies generally the condition
C        NAP <= MIN(NP,N-NFP).
C
C     At the beginning of the algorithm, F = 0 and the matrix A is
C     reduced to an ordered real Schur form by separating its spectrum
C     in two parts. The leading NFP-by-NFP part of the Schur form of
C     A corresponds to the eigenvalues which will not be modified.
C     These eigenvalues have real parts less than ALPHA, if
C     DICO = 'C', or moduli less than ALPHA, if DICO = 'D'.
C     The performed orthogonal transformations are accumulated in Z.
C     After this preliminary reduction, the algorithm proceeds
C     recursively.
C
C     Let F be the feedback matrix at the beginning of a typical step i.
C     At each step of the algorithm one real eigenvalue or two complex
C     conjugate eigenvalues are placed by a feedback Fi of rank 1 or
C     rank 2, respectively. Since the feedback Fi affects only the
C     last 1 or 2 columns of Z'*(A+B*F)*Z, the matrix Z'*(A+B*F+B*Fi)*Z
C     therefore remains in real Schur form. The assigned eigenvalue(s)
C     is (are) then moved to another diagonal position of the real
C     Schur form using reordering techniques and a new block is
C     transfered in the last diagonal position. The feedback matrix F
C     is updated as F <-- F + Fi. The eigenvalue(s) to be assigned at
C     each step is (are) chosen such that the norm of each Fi is
C     minimized.
C
C     If uncontrollable eigenvalues are encountered in the last diagonal
C     position of the real Schur matrix Z'*(A+B*F)*Z, the algorithm
C     deflates them at the bottom of the real Schur form and redefines
C     accordingly the position of the "last" block.
C
C     Note: Not all uncontrollable eigenvalues of the pair (A,B) are
C     necessarily detected by the eigenvalue assignment algorithm.
C     Undetected uncontrollable eigenvalues may exist if NFP > 0 and/or
C     NP < N-NFP.
C
C     REFERENCES
C
C     [1] Varga A.
C         A Schur method for pole assignment.
C         IEEE Trans. Autom. Control, Vol. AC-26, pp. 517-519, 1981.
C
C     NUMERICAL ASPECTS
C                                            3
C     The algorithm requires no more than 14N  floating point
C     operations. Although no proof of numerical stability is known,
C     the algorithm has always been observed to yield reliable
C     numerical results.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     February 1999. Based on the RASP routine SB01BD.
C
C     REVISIONS
C
C     March 30, 1999, V. Sima, Research Institute for Informatics,
C     Bucharest.
C     April 4, 1999. A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen.
C     May 18, 2003. A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen.
C     Feb. 15, 2004, V. Sima, Research Institute for Informatics,
C     Bucharest.
C     May 12, 2005. A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen.
C     Dec. 29, 2012, V. Sima, Research Institute for Informatics,
C     Bucharest.
C
C     KEYWORDS
C
C     Eigenvalues, eigenvalue assignment, feedback control,
C     pole placement, state-space model.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION HUNDR, ONE, TWO, ZERO
      PARAMETER        ( HUNDR = 1.0D2, ONE = 1.0D0, TWO = 2.0D0,
     $                   ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER        DICO
      INTEGER          INFO, IWARN, LDA, LDB, LDF, LDWORK, LDZ, M, N,
     $                 NAP, NFP, NP, NUP
      DOUBLE PRECISION ALPHA, TOL
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*),
     $                 WI(*), WR(*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL          CEIG, DISCR, SIMPLB
      INTEGER          I, IB, IB1, IERR, IPC, J, K, KFI, KG, KW, KWI,
     $                 KWR, NCUR, NCUR1, NL, NLOW, NMOVES, NPC, NPR,
     $                 NSUP, WRKOPT
      DOUBLE PRECISION ANORM, BNORM, C, P, RMAX, S, X, Y, TOLER, TOLERB
C     .. Local Arrays ..
      LOGICAL          BWORK(1)
      DOUBLE PRECISION A2(2,2)
C     .. External Functions ..
      LOGICAL          LSAME, SELECT
      DOUBLE PRECISION DLAMCH, DLANGE
      EXTERNAL         DLAMCH, DLANGE, LSAME, SELECT
C     .. External Subroutines ..
      EXTERNAL         DCOPY, DGEES, DGEMM, DLAEXC, DLASET, DROT,
     $                 DSWAP, MB03QD, MB03QY, SB01BX, SB01BY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        DBLE, INT, MAX
C     ..
C     .. Executable Statements ..
C
      DISCR = LSAME( DICO, 'D' )
      IWARN = 0
      INFO  = 0
C
C     Check the scalar input parameters.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( M.LT.0 ) THEN
         INFO = -3
      ELSE IF( NP.LT.0 ) THEN
         INFO = -4
      ELSE IF( DISCR .AND. ( ALPHA.LT.ZERO ) ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -16
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -18
      ELSE IF( LDWORK.LT.MAX( 1, 5*M, 5*N, 2*N + 4*M ) ) THEN
         INFO = -21
      END IF
      IF( INFO.NE.0 )THEN
C
C        Error return.
C
         CALL XERBLA( 'SB01BD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         NFP = 0
         NAP = 0
         NUP = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Compute the norms of A and B, and set default tolerances
C     if necessary.
C
      ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK )
      BNORM = DLANGE( '1-norm', N, M, B, LDB, DWORK )
      IF( TOL.LE.ZERO ) THEN
         X = DLAMCH( 'Epsilon' )
         TOLER  = DBLE( N ) * MAX( ANORM, BNORM ) * X
         TOLERB = DBLE( N ) * BNORM * X
      ELSE
         TOLER  = TOL
         TOLERB = TOL
      END IF
C
C     Allocate working storage.
C
      KWR = 1
      KWI = KWR + N
      KW  = KWI + N
C
C     Reduce A to real Schur form using an orthogonal similarity
C     transformation A <- Z'*A*Z and accumulate the transformation in Z.
C
C     Workspace:  need   5*N;
C                 prefer larger.
C
      CALL DGEES( 'Vectors', 'No ordering', SELECT, N, A, LDA, NCUR,
     $            DWORK(KWR), DWORK(KWI), Z, LDZ, DWORK(KW),
     $            LDWORK-KW+1, BWORK, INFO )
      WRKOPT = KW - 1 + INT( DWORK( KW ) )
      IF( INFO.NE.0 ) THEN
         INFO = 1
         RETURN
      END IF
C
C     Reduce A to an ordered real Schur form using an orthogonal
C     similarity transformation A <- Z'*A*Z and accumulate the
C     transformations in Z. The separation of the spectrum of A is
C     performed such that the leading NFP-by-NFP submatrix of A
C     corresponds to the "good" eigenvalues which will not be
C     modified. The bottom (N-NFP)-by-(N-NFP) diagonal block of A
C     corresponds to the "bad" eigenvalues to be modified.
C
C     Workspace needed:  N.
C
      CALL MB03QD( DICO, 'Stable', 'Update', N, 1, N, ALPHA,
     $             A, LDA, Z, LDZ, NFP, DWORK, INFO )
      IF( INFO.NE.0 )
     $   RETURN
C
C     Set F = 0.
C
      CALL DLASET( 'Full', M, N, ZERO, ZERO, F, LDF )
C
C     Return if B is negligible (uncontrollable system).
C
      IF( BNORM.LE.TOLERB ) THEN
         NAP = 0
         NUP = N
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Compute the bound for the numerical stability condition.
C
      RMAX = HUNDR * ANORM / BNORM
C
C     Perform eigenvalue assignment if there exist "bad" eigenvalues.
C
      NAP = 0
      NUP = 0
      IF( NFP.LT.N ) THEN
         KG  = 1
         KFI = KG  + 2*M
         KW  = KFI + 2*M
C
C        Set the limits for the bottom diagonal block.
C
         NLOW = NFP + 1
         NSUP = N
C
C        Separate and count real and complex eigenvalues to be assigned.
C
         NPR = 0
         DO 10 I = 1, NP
            IF( WI(I).EQ.ZERO ) THEN
               NPR = NPR + 1
               K = I - NPR
               IF( K.GT.0 ) THEN
                  S = WR(I)
                  DO 5 J = NPR + K - 1, NPR, -1
                     WR(J+1) = WR(J)
                     WI(J+1) = WI(J)
    5             CONTINUE
                  WR(NPR) = S
                  WI(NPR) = ZERO
               END IF
            END IF
   10    CONTINUE
         NPC = NP - NPR
C
C        The first NPR elements of WR and WI contain the real
C        eigenvalues, the last NPC elements contain the complex
C        eigenvalues. Set the pointer to complex eigenvalues.
C
         IPC = NPR + 1
C
C        Main loop for assigning one or two eigenvalues.
C
C        Terminate if all eigenvalues were assigned, or if there
C        are no more eigenvalues to be assigned, or if a non-fatal
C        error condition was set.
C
C        WHILE (NLOW <= NSUP and INFO = 0) DO
C
   20    IF( NLOW.LE.NSUP .AND. INFO.EQ.0 ) THEN
C
C           Determine the dimension of the last block.
C
            IB = 1
            IF( NLOW.LT.NSUP ) THEN
               IF( A(NSUP,NSUP-1).NE.ZERO ) IB = 2
            END IF
C
C           Compute G, the current last IB rows of Z'*B.
C
            NL = NSUP - IB + 1
            CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE,
     $                  Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG), IB )
C
C           Check the controllability for a simple block.
C
            IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) )
     $          .LE. TOLERB ) THEN
C
C              Deflate the uncontrollable block and resume the
C              main loop.
C
               NSUP = NSUP - IB
               NUP = NUP + IB
               GO TO 20
            END IF
C
C           Test for termination with INFO = 3.
C
            IF( NAP.EQ.NP ) THEN
               INFO = 3
C
C              Test for compatibility. Terminate if an attempt occurs
C              to place a complex conjugate pair on a 1x1 block.
C
            ELSE IF( IB.EQ.1 .AND. NPR.EQ.0 .AND. NLOW.EQ.NSUP ) THEN
               INFO = 4
            ELSE
C
C              Set the simple block flag.
C
               SIMPLB = .TRUE.
C
C              Form a 2-by-2 block if necessary from two 1-by-1 blocks.
C              Consider special case IB = 1, NPR = 1 and
C              NPR+NPC > NSUP-NLOW+1 to avoid incompatibility.
C
               IF( ( IB.EQ.1 .AND. NPR.EQ.0 ) .OR.
     $             ( IB.EQ.1 .AND. NPR.EQ.1 .AND. NSUP.GT.NLOW .AND.
     $               NPR+NPC.GT.NSUP-NLOW+1 ) ) THEN
                  IF( NSUP.GT.2 ) THEN
                     IF( A(NSUP-1,NSUP-2).NE.ZERO ) THEN
C
C                       Interchange with the adjacent 2x2 block.
C
C                       Workspace needed: N.
C
                        CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ, NSUP-2,
     $                               2, 1, DWORK(KW), INFO )
                        IF( INFO.NE.0 ) THEN
                           INFO = 2
                           RETURN
                        END IF
                     ELSE
C
C                       Form a non-simple block by extending the last
C                       block with a 1x1 block.
C
                        SIMPLB = .FALSE.
                     END IF
                  ELSE
                     SIMPLB = .FALSE.
                  END IF
                  IB = 2
                  NL = NSUP - IB + 1
C
C                 Compute G, the current last IB rows of Z'*B.
C
                  CALL DGEMM( 'Transpose', 'NoTranspose', IB, M, N, ONE,
     $                        Z(1,NL), LDZ, B, LDB, ZERO, DWORK(KG),
     $                        IB )
C
C                 Check the controllability for the current block.
C
                  IF( DLANGE( '1', IB, M, DWORK(KG), IB, DWORK(KW) )
     $               .LE.TOLERB ) THEN
C
C                    Deflate the uncontrollable block and resume the
C                    main loop.
C
                     NSUP = NSUP - IB
                     NUP = NUP + IB
                     GO TO 20
                  END IF
               END IF
C
               IF( NAP+IB.GT.NP ) THEN
C
C                 No sufficient eigenvalues to be assigned.
C
                  INFO = 3
               ELSE
                  IF( IB.EQ.1 ) THEN
C
C                    A 1-by-1 block.
C
C                    Assign the real eigenvalue nearest to A(NSUP,NSUP).
C
                     X = A(NSUP,NSUP)
                     CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P )
                     NPR  = NPR - 1
                     CEIG = .FALSE.
                  ELSE
C
C                    A 2-by-2 block.
C
                     IF( SIMPLB ) THEN
C
C                       Simple 2-by-2 block with complex eigenvalues.
C                       Compute the eigenvalues of the last block.
C
                        CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y, INFO )
                        IF( NPC.GT.1 ) THEN
                           CALL SB01BX( .FALSE., NPC, X, Y,
     $                                  WR(IPC), WI(IPC), S, P )
                           NPC  = NPC - 2
                           CEIG = .TRUE.
                        ELSE
C
C                          Choose the nearest two real eigenvalues.
C
                           CALL SB01BX( .TRUE., NPR, X, X, WR, X, S, P )
                           CALL SB01BX( .TRUE., NPR-1, X, X, WR, X,
     $                                  Y, P )
                           P = S * Y
                           S = S + Y
                           NPR = NPR - 2
                           CEIG = .FALSE.
                        END IF
                     ELSE
C
C                       Non-simple 2x2 block with real eigenvalues.
C                       Choose the nearest pair of complex eigenvalues.
C
                        X = ( A(NL,NL) + A(NSUP,NSUP) )/TWO
                        CALL SB01BX( .FALSE., NPC, X, ZERO, WR(IPC),
     $                               WI(IPC), S, P )
                        NPC = NPC - 2
                     END IF
                  END IF
C
C                 Form the IBxIB matrix A2 from the current diagonal
C                 block.
C
                  A2(1,1) = A(NL,NL)
                  IF( IB.GT.1 ) THEN
                     A2(1,2) = A(NL,NSUP)
                     A2(2,1) = A(NSUP,NL)
                     A2(2,2) = A(NSUP,NSUP)
                  END IF
C
C                 Determine the M-by-IB feedback matrix FI which
C                 assigns the chosen IB eigenvalues for the pair (A2,G).
C
C                 Workspace needed: 5*M.
C
                  CALL SB01BY( IB, M, S, P, A2, DWORK(KG), DWORK(KFI),
     $                         TOLER, DWORK(KW), IERR )
                  IF( IERR.NE.0 ) THEN
                     IF( IB.EQ.1 .OR. SIMPLB ) THEN
C
C                       The simple 1x1 block is uncontrollable.
C
                        NSUP = NSUP - IB
                        IF( CEIG ) THEN
                           NPC = NPC + IB
                        ELSE
                           NPR = NPR + IB
                        END IF
                        NUP  = NUP + IB
                     ELSE
C
C                       The non-simple 2x2 block is uncontrollable.
C                       Eliminate its uncontrollable part by using
C                       the information in elements FI(1,1) and F(1,2).
C
                        C = DWORK(KFI)
                        S = DWORK(KFI+IB)
C
C                       Apply the transformation to A and accumulate it
C                       in Z.
C
                        CALL DROT( N-NL+1, A(NL,NL), LDA,
     $                             A(NSUP,NL), LDA, C, S )
                        CALL DROT( N, A(1,NL), 1, A(1,NSUP), 1, C, S )
                        CALL DROT( N, Z(1,NL), 1, Z(1,NSUP), 1, C, S )
C
C                       Annihilate the subdiagonal element of the last
C                       block, redefine the upper limit for the bottom
C                       block and resume the main loop.
C
                        A(NSUP,NL) = ZERO
                        NSUP = NL
                        NUP  = NUP + 1
                        NPC  = NPC + 2
                     END IF
                  ELSE
C
C                    Successful assignment of IB eigenvalues.
C
C                    Update the feedback matrix F <-- F + [0 FI]*Z'.
C
                     CALL DGEMM( 'NoTranspose', 'Transpose', M, N,
     $                           IB, ONE, DWORK(KFI), M, Z(1,NL),
     $                           LDZ, ONE, F, LDF )
C
C                    Check for possible numerical instability.
C
                     IF( DLANGE( '1', M, IB, DWORK(KFI), M, DWORK(KW) )
     $                           .GT. RMAX ) IWARN = IWARN + 1
C
C                    Update the state matrix A <-- A + Z'*B*[0 FI].
C                    Workspace needed: 2*N+4*M.
C
                     CALL DGEMM( 'NoTranspose', 'NoTranspose', N, IB,
     $                           M, ONE, B, LDB, DWORK(KFI), M, ZERO,
     $                           DWORK(KW), N )
                     CALL DGEMM( 'Transpose', 'NoTranspose', NSUP,
     $                           IB, N, ONE, Z, LDZ, DWORK(KW), N,
     $                           ONE, A(1,NL), LDA )
C
C                    Try to split the 2x2 block.
C
                     IF( IB.EQ.2 )
     $                  CALL MB03QY( N, NL, A, LDA, Z, LDZ, X, Y,
     $                               INFO )
                     NAP = NAP + IB
                     IF( NLOW+IB.LE.NSUP ) THEN
C
C                       Move the last block(s) to the leading
C                       position(s) of the bottom block.
C
                        NCUR1 = NSUP - IB
                        NMOVES = 1
                        IF( IB.EQ.2 .AND. A(NSUP,NSUP-1).EQ.ZERO ) THEN
                           IB = 1
                           NMOVES = 2
                        END IF
C
C                       WHILE (NMOVES > 0) DO
   30                   IF( NMOVES.GT.0 ) THEN
                           NCUR = NCUR1
C
C                          WHILE (NCUR >= NLOW) DO
   40                      IF( NCUR.GE.NLOW ) THEN
C
C                             Loop for the last block positioning.
C
                              IB1 = 1
                              IF( NCUR.GT.NLOW ) THEN
                                 IF( A(NCUR,NCUR-1).NE.ZERO ) IB1 = 2
                              END IF
                              CALL DLAEXC( .TRUE., N, A, LDA, Z, LDZ,
     $                                     NCUR-IB1+1, IB1, IB,
     $                                     DWORK(KW), INFO )
                              IF( INFO.NE.0 ) THEN
                                 INFO = 2
                                 RETURN
                              END IF
                              NCUR = NCUR - IB1
                              GO TO 40
                           END IF
C
C                          END WHILE 40
C
                           NMOVES = NMOVES - 1
                           NCUR1 = NCUR1 + 1
                           NLOW = NLOW + IB
                           GO TO 30
                        END IF
C
C                       END WHILE 30
C
                     ELSE
                        NLOW = NLOW + IB
                     END IF
                  END IF
               END IF
            END IF
            IF( INFO.EQ.0 ) GO TO 20
C
C        END WHILE 20
C
         END IF
C
         WRKOPT = MAX( WRKOPT, 5*M, 2*N + 4*M )
      END IF
C
C     Annihilate the elements below the first subdiagonal of A.
C
      IF( N.GT.2)
     $   CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A(3,1), LDA )
      IF( NAP .GT. 0 ) THEN
C
C        Move the assigned eigenvalues in the first NAP positions of
C        WR and WI.
C
         K = IPC - NPR - 1
         IF( K.GT.0 ) THEN
            IF( K.LE.NPR ) THEN
               CALL DSWAP( K, WR(NPR+1), 1, WR, 1 )
            ELSE
               CALL DCOPY( K, WR(NPR+1), 1, DWORK, 1 )
               CALL DCOPY( NPR, WR, 1, DWORK(K+1), 1 )
               CALL DCOPY( K+NPR, DWORK, 1, WR, 1 )
            END IF
         END IF
         J = NAP - K
         IF( J.GT.0 ) THEN
            CALL DSWAP( J, WR(IPC+NPC), 1, WR(K+1), 1 )
            CALL DSWAP( J, WI(IPC+NPC), 1, WI(K+1), 1 )
         END IF
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of SB01BD ***
      END


*
*     ------------------------------------------------------------------
*         R M E
*     ------------------------------------------------------------------
*
*
      DOUBLE PRECISION FUNCTION RME(L,LP,K)
*
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
*
      COMMON/FACT/GAM(100)
*
*--- EVALUATES THE REDUCED MATRIX ELEMENT (L//C(K)//LP)  -  SEE FANO
*    AND RACAH, IRREDUCIBLE TENSORIAL SETS, CHAP. 14, P. 81
*
*
      IF (MIN0(L,LP) .EQ. 0) THEN
         RME = 1.D0
       ELSE IF ( K .EQ. 0) THEN
         RME = 2*L+1
         RME = DSQRT(RME)
       ELSE IF ( K .EQ. 1) THEN
         RME = MAX0(L,LP)
         RME = DSQRT(RME)
       ELSE
         I2G=L+LP+K
         IG=I2G/2
         IF (I2G - 2*IG .NE. 0) THEN
             RME = 0.D0
          ELSE
            I1=IG-L
            I2=IG-LP
            I3=IG-K
            QUSQRT=(2*L+1)*(2*LP+1)
            RME=DSQRT(QUSQRT)*DEXP((GAM(2*I1+1)+GAM(2*I2+1)+GAM(2*I3+1)-
     :        GAM(I2G+2))/2.D0 +GAM(IG+1)-GAM(I1+1)-GAM(I2+1)-GAM(I3+1))
         END IF
      END IF
      RETURN
      END


! precision_specs.f08
!
! Integer parameters for precision specification.
! This file contains single, double, and quad
! precision when available.

module precision_specs

    integer, parameter :: sp = kind(1.0)
    integer, parameter :: dp = selected_real_kind(2 * precision(1.0_sp))
    integer, parameter :: qp = selected_real_kind(2 * precision(1.0_dp))

end module precision_specs


program reshape_test
    implicit none
    integer, parameter :: nr_values = 12
    integer :: i
    integer, dimension(nr_values) :: values = [ (i, i=1, nr_values) ]
    integer, dimension(2, 5) :: too_small
    integer, dimension(3, 5) :: too_large

    too_small = reshape(values, shape(too_small))
    call print_matrix(too_small)

    too_large = reshape(values, shape(too_large), pad=[-1, -2])
    call print_matrix(too_large)

contains

    subroutine print_matrix(A)
        implicit none
        integer, dimension(:, :), intent(in) :: A
        integer :: i

        do i = 1, size(A, 1)
            print *, A(i, :)
        end do
    end subroutine print_matrix

end program reshape_test


program test_besselj
  use types, only: dp
  use constants, only: i_
  use utils, only: assert
  use special, only: besselj
  implicit none

  ! check a few value against the ones computed with SciPy:
  ! note we use a rather 'large' eps - SciPy computes some the values we compare
  ! to with CEPHES whereas we use AMOS

  integer :: i
  real(dp), parameter :: eps = 1d-13
  real(dp), parameter :: ordersReal(7) = [0.0_dp,  1.0_dp,  2.0_dp,  3.3_dp,  7.0_dp,  -1.5_dp,  -4.0_dp]
  real(dp),  parameter :: xReal(7) = [1.1_dp,  3.0_dp,  10.0_dp,  2.1_dp,  5.5_dp,  1.1_dp,  2.0_dp]
  real(dp),  parameter :: xImag(7) = [0.1_dp,  -0.3_dp,  2.5_dp,  -1.8_dp,  2.0_dp,  0.5_dp,  1.5_dp]
  real(dp), parameter :: correctResultsRealArg(7) = [0.71962201852751084_dp,  0.33905895852593654_dp, &
       0.25463031368512057_dp,   0.10198066675126187_dp,  0.086601225791612571_dp, -0.991692967169576_dp, 0.033995719807568_dp]
  complex(dp), parameter :: correctResultsComplexArg(7) = &
       & [(0.721080505182738_dp, -0.047148055544687_dp), &
       & (0.347065164074845_dp, 0.113385532812354_dp), &
       & (1.464459020326502_dp, -0.136902071794694_dp), &
       & (-0.099772866153918_dp, -0.296926484013360_dp), &
       & (-0.017883657462811_dp, 0.158730532048265_dp), &
       & (-0.829111259236468_dp, 0.394003201107883_dp), &
       (-0.060418553266548_dp, 0.071850227467280_dp)]

  ! test real argument with real order:
  do i = 1,7
     call assert(abs(besselj(ordersReal(i), xReal(i)) - correctResultsRealArg(i)) < eps)
  end do

  ! test real argument with integer order against the Fortran intrinsic functions:
  ! test those to machine precision
  call assert(abs(besselj(0, xReal(1)) - bessel_j0(xReal(1))) <= epsilon(1.0_dp))
  call assert(abs(besselj(1, xReal(2)) - bessel_j1(xReal(2))) <= epsilon(1.0_dp))
  do i = 2, 7
     call assert(abs(besselj(i, xReal(i)) - bessel_jn(i, xReal(i))) <= epsilon(1.0_dp))
  end do

  ! test complex data with real order:
  do i = 1,7
     call assert(abs(besselj(ordersReal(i), xReal(i)+i_*xImag(i)) - correctResultsComplexArg(i)) < eps)
  end do

end program test_besselj


program submatrices
    implicit none
    integer, dimension(3, 4) :: A
    integer :: i, j

    A = reshape([ (((i - 1)*size(A, 2) + j, j=1, size(A, 2)), i=1,size(A, 1)) ], &
                shape(A))
    print *, A(2, :)
    print *, A(:, 3)
    print '(A, I0)', 'rank = ', rank(A(2, :))
    print '(A, I0)', 'shape = ', shape(A(2, :))
end program submatrices


! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE STR_TENSOR_TRANSFORM ( STRESS_TENSOR, STRESS_CORD_SYS )

! Transforms an input stress or strain tensor in input local elem coord sys to an output coord sys whose actual coord sys ID is
! STRESS_CORD_SYS

! The 3x3 transform matrix Tse which transforms a unit vector in elem coords (Ue) to a unit vector in stress output coords (Us) is:

!                                                  Us = Tse*Ue                                                         (1)

! Tse can be written as the product of two transformation matrices Ts0 (transform vector in basic to output s coord sys) and
! the transpose of Te0 (which transforms a vector in basic coords to local elem coords).
! That is:

!                                                 Tse = Ts0*T0e = Ts0*Te0'                                             (2)
!  and its transpose is Tes:
!                                                 Tes = Te0*Ts0'                                                       (3)

! where Te0 is output in subr ELMGMi as array TE.  With (2), eqn (1) becomes:

!                                                  Us = (Ts0*Te0')*Ue                                                  (4)

! The 2nd order stress tensor in element local coords is a 3x3 matrix of the 9 (6 independent) stresses:

!                                                       | Sxx  Sxy  Sxz |
!                                                 See = | Syx  Syy  Syz |                                              (5)
!                                                 ~     | Szx  Szy  Szz |

! where Sij = Sji and, for example Sxx is the normal stress in the x direction, Sxy is the shear stress in the xy plane, etc.
! Matrix Tse is used to transform this 2nd order stress tensor from element coords to output coords (Soo) via the equation:

!                                                 Soo = Tse*See*Tse' = Tse'*See*Tes                                    (6)
!                                                 ~         ~              ~

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE CONSTANTS_1, ONLY           :  ZERO, ONE
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, NCORD
      USE IOUNT1, ONLY                :  ERR, F04, F06, WRT_LOG
      USE TIMDAT, ONLY                :  TSEC
      USE MODEL_STUF, ONLY            :  CORD, RCORD, TE
      USE SUBR_BEGEND_LEVELS, ONLY    :  STR_TENSOR_TRANSFORM_BEGEND

      USE STR_TENSOR_TRANSFORM_USE_IFs

      IMPLICIT NONE

      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'STR_TENSOR_TRANSFORM'

      INTEGER(LONG), INTENT(IN)       :: STRESS_CORD_SYS   ! Actual coord system ID for stress/strain/engr force output
      INTEGER(LONG)                   :: I,J               ! DO loop indices
      INTEGER(LONG)                   :: ICORD             ! Internal coord system ID for STRESS_CORD_SYS
      INTEGER(LONG)                   :: K                 ! Counter
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = STR_TENSOR_TRANSFORM_BEGEND

      REAL(DOUBLE), INTENT(INOUT)     :: STRESS_TENSOR(3,3)! 2D stress tensor (eqn 6 above)
      REAL(DOUBLE)                    :: DUM33(3,3)        ! Intermediate array used in calc outputs
      REAL(DOUBLE)                    :: TS0(3,3)          ! Transform matrix from basic coords to stress output coords
      REAL(DOUBLE)                    :: T0S(3,3)          ! TS0'
      REAL(DOUBLE)                    :: TES(3,3)          ! Transform matrix from local elem coords to stress output coords
      REAL(DOUBLE)                    :: TSE(3,3)          ! TEO'

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF

! **********************************************************************************************************************************
! Get transformation matrix TS0 from stress coord sys to basic if it exists

      IF (STRESS_CORD_SYS == 0) THEN                       ! STRESS_CORD_SYS was basic so set T0o to the identity matrix

         DO I=1,3
            DO J=1,3
               T0S(I,J) = ZERO
            ENDDO
            T0S(I,I) = ONE
         ENDDO

      ELSE                                                 ! Need to transform ES mat'l matrix to basic coords

         ICORD = 0
         DO I=1,NCORD                                      ! Get the internal coord system ID for STRESS_CORD_SYS
            IF (STRESS_CORD_SYS == CORD(I,2)) THEN
               ICORD = I
               EXIT
            ENDIF
         ENDDO

      ENDIF

      IF (ICORD > 0) THEN                                  ! STRESS_CORD_SYS was found so do transformation

         DO I=1,3                                          ! Get TO0 from RCORD array
            DO J=1,3
               K = 3 + 3*(I-1) + J
               TS0(I,J) = RCORD(ICORD,K)
               T0S(J,I) = TS0(I,J)
            ENDDO
         ENDDO

         CALL MATMULT_FFF ( TE , T0S  , 3, 3, 3, TES )     ! Calc TES then transform to get TSE
         DO I=1,3
            DO J=1,3
               TSE(I,J) = TES(J,I)
            ENDDO
         ENDDO
                                                           ! Transform input stress tensor from e coords to o coords
         CALL MATMULT_FFF (STRESS_TENSOR, TES, 3, 3, 3, DUM33 )
         CALL MATMULT_FFF (TSE, DUM33, 3, 3, 3, STRESS_TENSOR )

      ELSE                                                 ! STRESS_CORD_SYS was not found leave tensor in local elem system

         WRITE(F06,9101) STRESS_CORD_SYS

      ENDIF

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9002) SUBR_NAME,TSEC
 9002    FORMAT(1X,A,' END  ',F10.3)
      ENDIF

      RETURN

! **********************************************************************************************************************************
 9101 FORMAT(' *INFORMATION: COORD SYSTEM ',I8,' FOR STRESS TRANSFORMATION IS UNDEFINED. LOCAL ELEMENT COORD SYSTEM WILL BE USED')

! **********************************************************************************************************************************

      END SUBROUTINE STR_TENSOR_TRANSFORM