submodule (Prng_Class) sm_rngNormal
  !! Generate random number from a normal distribution.

  ! Original Version
  ! Author: Alan Miller
  ! The base functions were originally inside http://www.netlib.org/random/random.f90.

  ! Updated version:
  ! Version 2.00, 11 November 2016
  ! Increased precision to double
  !
  ! Updated again
  ! Added overloaded operations for single number, nD arrays
  !     Author: Leon Foks

implicit none

contains

  !====================================================================!
  module procedure rngNormal_d1_Prng!(this, res, mean, std)
    !! Overloaded Type bound procedure Prng%rngNormal()
  !====================================================================!
  ! Adapted from the following Fortran 77 code
  !      ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM.
  !      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
  !      VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435.

  !  The function random_normal() returns a normally distributed pseudo-random
  !  number with zero mean and unit variance.

  !  The algorithm uses the ratio of uniforms method of A.J. Kinderman
  !  and J.F. Monahan augmented with quadratic bounding curves.
  !     Generate P = (u,v) uniform in rectangle enclosing acceptance region
  !====================================================================!
!  class(Prng), intent(inout) :: this
!  real(r64), intent(inout) :: res
!  real(r64), intent(in), optional :: mean,std
  ! Local variables
  real(r64), parameter :: s = 0.449871d0
  real(r64), parameter :: t = -0.386595d0
  real(r64), parameter :: a = 0.196d0
  real(r64), parameter :: b = 0.25472d0
  real(r64) :: q
  real(r64), parameter :: r1 = 0.27597d0
  real(r64), parameter :: r2 = 0.27846d0
  real(r64) :: u
  real(r64) :: v
  real(r64) :: x
  real(r64) :: y

  do
    call this%rngUniform(u, 0.d0, 1.d0)
    call this%rngUniform(v, 0.d0, 1.d0)
    v = 1.7156d0 * (v - 0.5d0)

    ! Evaluate the quadratic form
    x = u - s
    y = dabs(v) - t
    q = x**2d0 + y*(a*y - b*x)

    ! Accept P if inside inner ellipse
    if (q < r1) exit
    ! Reject P if outside outer ellipse
    if (q > r2) cycle
    ! Reject P if outside acceptance region
    if (v**2.d0 < -4.d0*log(u)*u**2.d0) exit
  enddo

  ! Return ratio of P's coordinates as the normal deviate
  res = v/u
  if (present(std)) then
    if (.not. present(mean)) call eMsg('rngNormal : Need both mean and standard deviation')
    res = (std*res) + mean
  end if
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure rngNormal_d1D_Prng!(this, res, mean,std)
    !! Overloaded Type bound procedure Prng%rngNormal()
  !====================================================================!
!  class(Prng), intent(inout) :: this
!  real(r64), intent(inout) :: res
!  real(r64),optional :: mean,std
  integer(i32) :: i,N
  N=size(res)
  do i=1,N
    call rngNormal_d1_Prng(this, res(i), mean, std)
  end do
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure rngNormal_d2D_Prng!(this, res, mean,std)
    !! Overloaded Type bound procedure Prng%rngNormal()
  !====================================================================!
!  class(Prng), intent(inout) :: this
!  real(r64), intent(inout) :: res
!  real(r64),optional :: mean,std
  integer(i32) :: i,iSub(2)
  integer(i32) :: n,nSub(2)
  nSub = shape(res)
  n=size(res)
  do i=1,n
    iSub = ind2sub(i,nSub)
    call rngNormal_d1_Prng(this, res(iSub(1),iSub(2)), mean, std)
  enddo
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure rngNormal_d3D_Prng!(this, res, mean,std)
    !! Overloaded Type bound procedure Prng%rngNormal()
  !====================================================================!
!  class(Prng), intent(inout) :: this
!  real(r64), intent(inout) :: res
!  real(r64),optional :: mean,std
  integer(i32) :: i,iSub(3)
  integer(i32) :: n,nSub(3)
  nSub = shape(res)
  n=size(res)
  do i=1,n
    iSub = ind2sub(i,nSub)
    call rngNormal_d1_Prng(this, res(iSub(1),iSub(2),iSub(3)), mean, std)
  enddo
  end procedure
  !====================================================================!

end submodule


*> \brief  DGTSV computes the solution to system of linear equations A * X = B for GT matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGTSV + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, LDB, N, NRHS
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGTSV  solves the equation
*>
*>    A*X = B,
*>
*> where A is an n by n tridiagonal matrix, by Gaussian elimination with
*> partial pivoting.
*>
*> Note that the equation  A**T*X = B  may be solved by interchanging the
*> order of the arguments DU and DL.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The order of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] NRHS
*> \verbatim
*>          NRHS is INTEGER
*>          The number of right hand sides, i.e., the number of columns
*>          of the matrix B.  NRHS >= 0.
*> \endverbatim
*>
*> \param[in,out] DL
*> \verbatim
*>          DL is DOUBLE PRECISION array, dimension (N-1)
*>          On entry, DL must contain the (n-1) sub-diagonal elements of
*>          A.
*>
*>          On exit, DL is overwritten by the (n-2) elements of the
*>          second super-diagonal of the upper triangular matrix U from
*>          the LU factorization of A, in DL(1), ..., DL(n-2).
*> \endverbatim
*>
*> \param[in,out] D
*> \verbatim
*>          D is DOUBLE PRECISION array, dimension (N)
*>          On entry, D must contain the diagonal elements of A.
*>
*>          On exit, D is overwritten by the n diagonal elements of U.
*> \endverbatim
*>
*> \param[in,out] DU
*> \verbatim
*>          DU is DOUBLE PRECISION array, dimension (N-1)
*>          On entry, DU must contain the (n-1) super-diagonal elements
*>          of A.
*>
*>          On exit, DU is overwritten by the (n-1) elements of the first
*>          super-diagonal of U.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB,NRHS)
*>          On entry, the N by NRHS matrix of right hand side matrix B.
*>          On exit, if INFO = 0, the N by NRHS solution matrix X.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of the array B.  LDB >= max(1,N).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*>          > 0: if INFO = i, U(i,i) is exactly zero, and the solution
*>               has not been computed.  The factorization has not been
*>               completed unless i = N.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup doubleGTsolve
*
*  =====================================================================
      SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
*
*  -- LAPACK driver routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   B( LDB, * ), D( * ), DL( * ), DU( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   FACT, TEMP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGTSV ', -INFO )
         RETURN
      END IF
*
      IF( N.EQ.0 )
     $   RETURN
*
      IF( NRHS.EQ.1 ) THEN
         DO 10 I = 1, N - 2
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
*              No row interchange required
*
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
               ELSE
                  INFO = I
                  RETURN
               END IF
               DL( I ) = ZERO
            ELSE
*
*              Interchange rows I and I+1
*
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DL( I ) = DU( I+1 )
               DU( I+1 ) = -FACT*DL( I )
               DU( I ) = TEMP
               TEMP = B( I, 1 )
               B( I, 1 ) = B( I+1, 1 )
               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
            END IF
   10    CONTINUE
         IF( N.GT.1 ) THEN
            I = N - 1
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
               ELSE
                  INFO = I
                  RETURN
               END IF
            ELSE
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DU( I ) = TEMP
               TEMP = B( I, 1 )
               B( I, 1 ) = B( I+1, 1 )
               B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
            END IF
         END IF
         IF( D( N ).EQ.ZERO ) THEN
            INFO = N
            RETURN
         END IF
      ELSE
         DO 40 I = 1, N - 2
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
*
*              No row interchange required
*
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  DO 20 J = 1, NRHS
                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
   20             CONTINUE
               ELSE
                  INFO = I
                  RETURN
               END IF
               DL( I ) = ZERO
            ELSE
*
*              Interchange rows I and I+1
*
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DL( I ) = DU( I+1 )
               DU( I+1 ) = -FACT*DL( I )
               DU( I ) = TEMP
               DO 30 J = 1, NRHS
                  TEMP = B( I, J )
                  B( I, J ) = B( I+1, J )
                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
   30          CONTINUE
            END IF
   40    CONTINUE
         IF( N.GT.1 ) THEN
            I = N - 1
            IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
               IF( D( I ).NE.ZERO ) THEN
                  FACT = DL( I ) / D( I )
                  D( I+1 ) = D( I+1 ) - FACT*DU( I )
                  DO 50 J = 1, NRHS
                     B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
   50             CONTINUE
               ELSE
                  INFO = I
                  RETURN
               END IF
            ELSE
               FACT = D( I ) / DL( I )
               D( I ) = DL( I )
               TEMP = D( I+1 )
               D( I+1 ) = DU( I ) - FACT*TEMP
               DU( I ) = TEMP
               DO 60 J = 1, NRHS
                  TEMP = B( I, J )
                  B( I, J ) = B( I+1, J )
                  B( I+1, J ) = TEMP - FACT*B( I+1, J )
   60          CONTINUE
            END IF
         END IF
         IF( D( N ).EQ.ZERO ) THEN
            INFO = N
            RETURN
         END IF
      END IF
*
*     Back solve with the matrix U from the factorization.
*
      IF( NRHS.LE.2 ) THEN
         J = 1
   70    CONTINUE
         B( N, J ) = B( N, J ) / D( N )
         IF( N.GT.1 )
     $      B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
         DO 80 I = N - 2, 1, -1
            B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
     $                  B( I+2, J ) ) / D( I )
   80    CONTINUE
         IF( J.LT.NRHS ) THEN
            J = J + 1
            GO TO 70
         END IF
      ELSE
         DO 100 J = 1, NRHS
            B( N, J ) = B( N, J ) / D( N )
            IF( N.GT.1 )
     $         B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
     $                       D( N-1 )
            DO 90 I = N - 2, 1, -1
               B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
     $                     B( I+2, J ) ) / D( I )
   90       CONTINUE
  100    CONTINUE
      END IF
*
      RETURN
*
*     End of DGTSV
*
      END


    MODULE random_standard_normal_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_standard_normal()
!**********************************************************************C
!                                                                      C
!                                                                      C
!     (STANDARD-)  N O R M A L  DISTRIBUTION                           C
!                                                                      C
!                                                                      C
!**********************************************************************C
!**********************************************************************C
!                                                                      C
!     FOR DETAILS SEE:                                                 C
!                                                                      C
!               AHRENS, J.H. AND DIETER, U.                            C
!               EXTENSIONS OF FORSYTHE'S METHOD FOR RANDOM             C
!               SAMPLING FROM THE NORMAL DISTRIBUTION.                 C
!               MATH. COMPUT., 27,124 (OCT. 1973), 927 - 937.          C
!                                                                      C
!     ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM 'FL'  C
!     (M=5) IN THE ABOVE PAPER     (SLIGHTLY MODIFIED IMPLEMENTATION)  C
!                                                                      C
!     Modified by Barry W. Brown, Feb 3, 1988 to use                   C
!     RANDOM_STANDARD_UNIFORM instead of                               C
!     SUNIF.  The argument IR thus goes away.                          C
!                                                                      C
!**********************************************************************C
!     THE DEFINITIONS OF THE CONSTANTS A(K), D(K), T(K) AND
!     H(K) ARE ACCORDING TO THE ABOVEMENTIONED ARTICLE
! .. Use Statements ..
        USE random_standard_uniform_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Local Scalars ..
        REAL :: aa, s, tt, u, ustar, w, y
        INTEGER :: i
! ..
! .. Intrinsic Functions ..
        INTRINSIC FLOAT, INT, MIN
! ..
! .. Function Return Value ..
        REAL :: random_standard_normal
! ..
! .. Parameters ..
        REAL, PARAMETER :: a(32) = (/ 0.0, 0.3917609E-1, 0.7841241E-1, &
          0.1177699, 0.1573107, 0.1970991, 0.2372021, 0.2776904, &
          0.3186394, 0.3601299, 0.4022501, 0.4450965, 0.4887764, &
          0.5334097, 0.5791322, 0.6260990, 0.6744898, 0.7245144, &
          0.7764218, 0.8305109, 0.8871466, 0.9467818, 1.009990, 1.077516, &
          1.150349, 1.229859, 1.318011, 1.417797, 1.534121, 1.675940, &
          1.862732, 2.153875/)
        REAL, PARAMETER :: d(31) = (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.2636843, &
          0.2425085, 0.2255674, 0.2116342, 0.1999243, 0.1899108, &
          0.1812252, 0.1736014, 0.1668419, 0.1607967, 0.1553497, &
          0.1504094, 0.1459026, 0.1417700, 0.1379632, 0.1344418, &
          0.1311722, 0.1281260, 0.1252791, 0.1226109, 0.1201036, &
          0.1177417, 0.1155119, 0.1134023, 0.1114027, 0.1095039/)
        REAL, PARAMETER :: h(31) = (/ 0.3920617E-1, 0.3932705E-1, &
          0.3950999E-1, 0.3975703E-1, 0.4007093E-1, 0.4045533E-1, &
          0.4091481E-1, 0.4145507E-1, 0.4208311E-1, 0.4280748E-1, &
          0.4363863E-1, 0.4458932E-1, 0.4567523E-1, 0.4691571E-1, &
          0.4833487E-1, 0.4996298E-1, 0.5183859E-1, 0.5401138E-1, &
          0.5654656E-1, 0.5953130E-1, 0.6308489E-1, 0.6737503E-1, &
          0.7264544E-1, 0.7926471E-1, 0.8781922E-1, 0.9930398E-1, &
          0.1155599, 0.1404344, 0.1836142, 0.2790016, 0.7010474/)
        REAL, PARAMETER :: t(31) = (/ 0.7673828E-3, 0.2306870E-2, &
          0.3860618E-2, 0.5438454E-2, 0.7050699E-2, 0.8708396E-2, &
          0.1042357E-1, 0.1220953E-1, 0.1408125E-1, 0.1605579E-1, &
          0.1815290E-1, 0.2039573E-1, 0.2281177E-1, 0.2543407E-1, &
          0.2830296E-1, 0.3146822E-1, 0.3499233E-1, 0.3895483E-1, &
          0.4345878E-1, 0.4864035E-1, 0.5468334E-1, 0.6184222E-1, &
          0.7047983E-1, 0.8113195E-1, 0.9462444E-1, 0.1123001, 0.1364980, &
          0.1716886, 0.2276241, 0.3304980, 0.5847031/)
! ..
! .. Executable Statements ..

        u = random_standard_uniform()
        s = 0.0
        IF (u>0.5) s = 1.0
        u = u + u - s
        u = 32.0*u
        i = MIN(INT(u),31)
        IF (i==0) GO TO 50

!                                START CENTER

        ustar = u - FLOAT(i)
        aa = a(i)
10      IF (ustar<=t(i)) GO TO 20
        w = (ustar-t(i))*h(i)
        CALL set_value
        RETURN

!                                CENTER CONTINUED

20      u = random_standard_uniform()
        w = u*(a(i+1)-aa)
        tt = (0.5*w+aa)*w
        GO TO 40

30      tt = u
        ustar = random_standard_uniform()
40      IF (ustar>tt) THEN
          CALL set_value
          RETURN
        END IF
        u = random_standard_uniform()
        IF (ustar>=u) GO TO 30
        ustar = random_standard_uniform()
        GO TO 10

!                                START TAIL

50      i = 6
        aa = a(32)
        GO TO 70

60      aa = aa + d(i)
        i = i + 1
70      u = u + u
        IF (u<1.0) GO TO 60
        u = u - 1.0
80      w = u*d(i)
        tt = (0.5*w+aa)*w
        GO TO 100

90      tt = u
100     ustar = random_standard_uniform()
        IF (ustar>tt) THEN
          CALL set_value
          RETURN
        END IF
        u = random_standard_uniform()
        IF (ustar>=u) GO TO 90
        u = random_standard_uniform()
        GO TO 80

      CONTAINS

!.....................................................................

        SUBROUTINE set_value
! .. Implicit None Statement ..
          IMPLICIT NONE
! ..
! .. Executable Statements ..

!                                EXIT   (BOTH CASES)
          y = aa + w
          random_standard_normal = y
          IF (s==1.0) random_standard_normal = -y
          RETURN

        END SUBROUTINE set_value

!.....................................................................

      END FUNCTION random_standard_normal

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

    END MODULE random_standard_normal_mod


c     program DRSEVVUN
c>> 1996-05-28 DRSEVVUN  Krogh Added external statement.
c>> 1994-10-19 DRSEVVUN  Krogh  Changes to use M77CON
c>> 1994-09-22 DRSEVVUN  CLL
c>> 1992-04-23 CLL
c>> 1992-03-04 DRSEVVUN  Krogh Initial version.
c     Demonstrate unsymmetric eigenvalue/eigenvector subroutine SEVVUN.
c     ------------------------------------------------------------------
c--S replaces "?": DR?EVVUN, ?EVVUN, ?VECP, ?MATP, ?DOT
c     ------------------------------------------------------------------
      integer I, J, LDA, N
      parameter (LDA = 3)
      integer IFLAG(LDA)
      real             A(LDA,LDA), VR(LDA), VI(LDA), VEC(LDA, LDA)
      real             WORK(LDA), ASAV(LDA, LDA), D(LDA, LDA), ANORM
      external SDOT
      real             SDOT
      data (A(1,I), I=1,3) /  8.0e0, -1.0e0, -5.0e0 /
      data (A(2,I), I=1,3) / -4.0e0,  4.0e0, -2.0e0 /
      data (A(3,I), I=1,3) / 18.0e0, -5.0e0, -7.0e0 /
      data ANORM / 30.0e0 /
      data N / LDA /
c     ------------------------------------------------------------------
      print*,'DRSEVVUN..  Demo driver for SEVVUN.'
c
c     First copy A() to ASAV() for later residual check.
c
         do 20 J = 1, N
            do 10 I = 1, N
               ASAV(I, J) = A(I, J)
   10       continue
   20    continue

         call SEVVUN(A(1, 1), LDA, N, VR, VI, VEC, IFLAG, WORK)

         print '(a, I2)',' IFLAG(1) =',IFLAG(1)
         if (IFLAG(1) .le. 2) then
            call SVECP(VR, N, ' Real part of the eigenvalues')
            call SVECP(VI, N, ' Imaginary part of the eigenvalues')
            call SMATP(VEC, LDA, N, N,
     *         '0 Eigenvectors as columns or pairs of columns')
c
c           As a check compute D = (ASAV*VEC - VEC*EVAL) / ANORM.
c           Expect D to be close to the machine precision.
c
            do 50 J = 1, N
               if (VI(J) .eq. 0.0e0) then
c                 Compute residual for a real eigenvalue and eigenvector
                  do 30 I = 1, N
                     D(I, J) = (SDOT(N, ASAV(I,1), LDA, VEC(1,J), 1) -
     *                  VEC(I,J) * VR(J)) / ANORM
   30             continue
               else if (VI(J) .gt. 0.0e0) then
                  do 40 I = 1, N
                     D(I, J) = (SDOT(N,ASAV(I,1),LDA,VEC(1,J),1) -
     *                  VEC(I,J)*VR(J)+VEC(I,J+1)*VI(J))/ANORM
                     D(I, J+1) = (SDOT(N,ASAV(I,1),LDA,VEC(1,J+1),1) -
     *                  VEC(I,J)*VI(J)-VEC(I,J+1)*VR(J))/ANORM
   40             continue
               end if
   50       continue
            call SMATP(D, LDA, N, N,
     *      '0 Packed residual matrix D = (A*EVEC - EVEC*EVAL) / ANORM')
         else
            print'(/a)', ' Failure in SEVVUN. '
         end if
      stop
      end


	FUNCTION PR_TMKC  ( tmpk )
C************************************************************************
C* PR_TMKC								*
C*									*
C* This function computes TMPC from TMPK.  The following equation is	*
C* used:								*
C*									*
C*                   TMPC = TMPK - TMCK					*
C*									*
C* REAL PR_TMKC  ( TMPK )						*
C*									*
C* Input parameters:							*
C*	TMPK		REAL		Temperature in Kelvin		*
C*									*
C* Output parameters:							*
C*	PR_TMKC		REAL		Temperature in Celsius		*
C**									*
C* Log:									*
C* I. Graffman/CSC	 8/83	Original source code			*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 8/88	Modified documentation			*
C* G. Krueger/EAI        4/96   Replaced C->K constant with TMCK	*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( tmpk ) )  THEN
	    PR_TMKC = RMISSD
	  ELSE
	    PR_TMKC = tmpk - TMCK
	END IF
C*
	RETURN
	END


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran Subroutines and Programs           *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
submodule(scalar_synthesis_routines) scalar_synthesis_gaussian_grid

contains

    ! Purpose:
    !
    ! This subroutine performs the spherical harmonic synthesis on
    ! a gaussian grid using the coefficients in array(s) a, b and returns
    ! the results in array(s) g.  the legendre polynomials are computed
    ! as needed in this version.
    !
    !     subroutine shsgc(nlat, nlon, isym, nt, g, idg, jdg, a, b, mdab, ndab, &
    !                      wshsgc, ierror)
    !
    !     subroutine shsgc performs the spherical harmonic synthesis
    !     on the arrays a and b and stores the result in the array g.
    !     the synthesis is performed on an equally spaced longitude grid
    !     and a gaussian colatitude grid.  the associated legendre functions
    !     are recomputed rather than stored as they are in subroutine
    !     shsgs.  the synthesis is described below at output parameter
    !     g.
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are compu
    !            in radians in theta(1), ..., theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid poi
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     isym   = 0  no symmetries exist about the equator. the synthesis
    !                 is performed on the entire sphere.  i.e. on the
    !                 array g(i, j) for i=1, ..., nlat and j=1, ..., nlon.
    !                 (see description of g below)
    !
    !            = 1  g is antisymmetric about the equator. the synthesis
    !                 is performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !
    !            = 2  g is symmetric about the equator. the synthesis is
    !                 performed on the northern hemisphere only.  i.e.
    !                 if nlat is odd the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., (nlat + 1)/2 and j=1, ..., nlon.
    !                 if nlat is even the synthesis is performed on the
    !                 array g(i, j) for i=1, ..., nlat/2 and j=1, ..., nlon.
    !
    !     nt     the number of syntheses.  in the program that calls shsgc,
    !            the arrays g, a and b can be three dimensional in which
    !            case multiple synthesis will be performed.  the third
    !            index is the synthesis index which assumes the values
    !            k=1, ..., nt.  for a single synthesis set nt=1. the
    !            discription of the remaining parameters is simplified
    !            by assuming that nt=1 or that the arrays g, a and b
    !            have only two dimensions.
    !
    !     idg    the first dimension of the array g as it appears in the
    !            program that calls shsgc. if isym equals zero then idg
    !            must be at least nlat.  if isym is nonzero then idg must
    !            be at least nlat/2 if nlat is even or at least (nlat + 1)/2
    !            if nlat is odd.
    !
    !     jdg    the second dimension of the array g as it appears in the
    !            program that calls shsgc. jdg must be at least nlon.
    !
    !     mdab   the first dimension of the arrays a and b as it appears
    !            in the program that calls shsgc. mdab must be at least
    !            min((nlon+2)/2, nlat) if nlon is even or at least
    !            min((nlon + 1)/2, nlat) if nlon is odd
    !
    !     ndab   the second dimension of the arrays a and b as it appears
    !            in the program that calls shsgc. ndab must be at least nlat
    !
    !     a, b    two or three dimensional arrays (see the input parameter
    !            nt) that contain the coefficients in the spherical harmonic
    !            expansion of g(i, j) given below at the definition of the
    !            output parameter g.  a(m, n) and b(m, n) are defined for
    !            indices m=1, ..., mmax and n=m, ..., nlat where mmax is the
    !            maximum (plus one) longitudinal wave number given by
    !            mmax = min(nlat, (nlon+2)/2) if nlon is even or
    !            mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     wshsgc an array which must be initialized by subroutine shsgci.
    !            once initialized, wshsgc can be used repeatedly by shsgc
    !            as long as nlat and nlon remain unchanged.  wshsgc must
    !            not be altered between calls of shsgc.
    !
    !     lshsgc the dimension of the array wshsgc as it appears in the
    !            program that calls shsgc. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsgc must be at least
    !
    !               nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
    !
    !     output parameters
    !
    !     g      a two or three dimensional array (see input parameter nt)
    !            that contains the discrete function which is synthesized.
    !            g(i, j) contains the value of the function at the gaussian
    !            colatitude point theta(i) and longitude point
    !            phi(j) = (j-1)*2*pi/nlon. the index ranges are defined
    !            above at the input parameter isym.  for isym=0, g(i, j)
    !            is given by the the equations listed below.  symmetric
    !            versions are used when isym is greater than zero.
    !
    !     the normalized associated legendre functions are given by
    !
    !     pbar(m, n, theta) = sqrt((2*n+1)*factorial(n-m)/(2*factorial(n+m)))
    !                       *sin(theta)**m/(2**n*factorial(n)) times the
    !                       (n+m)th derivative of (x**2-1)**n with respect
    !                       to x=cos(theta)
    !
    !
    !     define the maximum (plus one) longitudinal wave number
    !     as   mmax = min(nlat, (nlon+2)/2) if nlon is even or
    !          mmax = min(nlat, (nlon + 1)/2) if nlon is odd.
    !
    !     then g(i, j) = the sum from n=0 to n=nlat-1 of
    !
    !                   .5*pbar(0, n, theta(i))*a(1, n+1)
    !
    !              plus the sum from m=1 to m=mmax-1 of
    !
    !                   the sum from n=m to n=nlat-1 of
    !
    !              pbar(m, n, theta(i))*(a(m+1, n+1)*cos(m*phi(j))
    !                                    -b(m+1, n+1)*sin(m*phi(j)))
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of isym
    !            = 4  error in the specification of nt
    !            = 5  error in the specification of idg
    !            = 6  error in the specification of jdg
    !            = 7  error in the specification of mdab
    !            = 8  error in the specification of ndab
    !            = 9  error in the specification of lshsgc
    !
    module subroutine shsgc(nlat, nlon, mode, nt, g, idg, jdg, a, b, mdab, ndab, &
        wshsgc, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        integer(ip), intent(in)  :: mode
        integer(ip), intent(in)  :: nt
        real(wp),    intent(out) :: g(idg, jdg, nt)
        integer(ip), intent(in)  :: idg
        integer(ip), intent(in)  :: jdg
        real(wp),    intent(in)  :: a(mdab, ndab, nt)
        real(wp),    intent(in)  :: b(mdab, ndab, nt)
        integer(ip), intent(in)  :: mdab
        integer(ip), intent(in)  :: ndab
        real(wp),    intent(in)  :: wshsgc(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip)             :: mtrunc, lat, late
        integer(ip)             :: required_wavetable_size
        type(SpherepackUtility) :: util

        ! Check input arguments
        required_wavetable_size = util%get_lshsgc(nlat, nlon)

        call util%check_scalar_transform_inputs(mode, idg, jdg, &
            mdab, ndab, nlat, nlon, nt, required_wavetable_size, &
            wshsgc, ierror)

        ! Check error flag
        if (ierror /= 0) return

        ! Set limit for m in a(m, n), b(m, n) computation
        mtrunc = min((nlon+2)/2, nlat)

        ! Set gaussian point nearest equator pointer
        late = (nlat+mod(nlat, 2))/2

        ! Set number of grid points for analysis/synthesis
        select case (mode)
            case (0)
                lat = nlat
            case default
                lat = late
        end select

        block
            integer(ip) :: ifft

            ! Starting address  fft values
            ifft = nlat+2*nlat*late+3*(mtrunc*(mtrunc-1)/2+(nlat-mtrunc)*(mtrunc-1))+1

            call shsgc_lower_utility_routine(nlat, nlon, mtrunc, lat, mode, g, idg, &
                jdg, nt, a, b, mdab, ndab, wshsgc, wshsgc(ifft:), late)
        end block

    end subroutine shsgc

    ! Purpose:
    !
    ! This subroutine must be called before calling shsgc with
    ! fixed nlat, nlon. it precomputes quantites such as the gaussian
    ! points and weights, m=0, m=1 legendre polynomials, recursion
    ! recursion coefficients.
    !
    !     subroutine shsgci(nlat, nlon, wshsgc, ierror)
    !
    !     subroutine shsgci initializes the array wshsgc which can then
    !     be used repeatedly by subroutines shsgc. it precomputes
    !     and stores in wshsgc quantities such as gaussian weights,
    !     legendre polynomial coefficients, and fft trigonometric tables.
    !
    !     input parameters
    !
    !     nlat   the number of points in the gaussian colatitude grid on the
    !            full sphere. these lie in the interval (0, pi) and are compu
    !            in radians in theta(1), ..., theta(nlat) by subroutine compute_gaussian_latitudes_and_weights.
    !            if nlat is odd the equator will be included as the grid poi
    !            theta((nlat + 1)/2).  if nlat is even the equator will be
    !            excluded as a grid point and will lie half way between
    !            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
    !            note: on the half sphere, the number of grid points in the
    !            colatitudinal direction is nlat/2 if nlat is even or
    !            (nlat + 1)/2 if nlat is odd.
    !
    !     nlon   the number of distinct londitude points.  nlon determines
    !            the grid increment in longitude as 2*pi/nlon. for example
    !            nlon = 72 for a five degree grid. nlon must be greater
    !            than or equal to 4. the efficiency of the computation is
    !            improved when nlon is a product of small prime numbers.
    !
    !     wshsgc an array which must be initialized by subroutine shsgci.
    !            once initialized, wshsgc can be used repeatedly by shsgc
    !            as long as nlat and nlon remain unchanged.  wshsgc must
    !            not be altered between calls of shsgc.
    !
    !     lshsgc the dimension of the array wshsgc as it appears in the
    !            program that calls shsgc. define
    !
    !               l1 = min(nlat, (nlon+2)/2) if nlon is even or
    !               l1 = min(nlat, (nlon + 1)/2) if nlon is odd
    !
    !            and
    !
    !               l2 = nlat/2        if nlat is even or
    !               l2 = (nlat + 1)/2    if nlat is odd
    !
    !            then lshsgc must be at least
    !
    !                  nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15
    !
    !     output parameter
    !
    !     wshsgc an array which must be initialized before calling shsgc.
    !            once initialized, wshsgc can be used repeatedly by shsgc
    !            as long as nlat and nlon remain unchanged.  wshsgc must not
    !            altered between calls of shsgc.
    !
    !     ierror = 0  no errors
    !            = 1  error in the specification of nlat
    !            = 2  error in the specification of nlon
    !            = 3  error in the specification of lshsgc
    !            = 5  failure in compute_gaussian_latitudes_and_weights to compute gaussian points
    !                 (due to failure in eigenvalue routine)
    !
    !
    module subroutine shsgci(nlat, nlon, wshsgc, ierror)

        ! Dummy arguments
        integer(ip), intent(in)  :: nlat
        integer(ip), intent(in)  :: nlon
        real(wp),    intent(out) :: wshsgc(:)
        integer(ip), intent(out) :: ierror

        ! Local variables
        integer(ip) :: i1
        integer(ip) :: i2
        integer(ip) :: i3
        integer(ip) :: i4
        integer(ip) :: i5
        integer(ip) :: i6
        integer(ip) :: i7
        integer(ip) :: idth
        integer(ip) :: idwts
        integer(ip) :: iw
        integer(ip) :: ntrunc
        integer(ip) :: l1
        integer(ip) :: l2
        integer(ip) :: late, ldwork

        associate (lshsgc => size(wshsgc))

            ! Set triangular truncation limit for spherical harmonic basis
            ntrunc = min((nlon+2)/2, nlat)

            ! Set equator or nearest point (if excluded) pointer
            late = (nlat+mod(nlat, 2))/2
            l1 = ntrunc
            l2 = late

            ! Check calling arguments
            if (nlat < 3) then
                ierror = 1
            else if (nlon < 4) then
                ierror = 2
            else if (lshsgc < nlat*(2*l2+3*l1-2)+3*l1*(1-l1)/2+nlon+15) then
                ierror = 3
            else
                ierror = 0
            end if

            ! Check error flag
            if (ierror /= 0) return

            ! Set index pointers
            i1 = 1
            i2 = i1+nlat
            i3 = i2+nlat*late
            i4 = i3+nlat*late
            i5 = i4+ntrunc*(ntrunc-1)/2 +(nlat-ntrunc)*(ntrunc-1)
            i6 = i5+ntrunc*(ntrunc-1)/2 +(nlat-ntrunc)*(ntrunc-1)
            i7 = i6+ntrunc*(ntrunc-1)/2 +(nlat-ntrunc)*(ntrunc-1)

            ! Set indices in temp work for real gaussian wts and pts
            idth = 1
            idwts = idth + nlat
            iw = idwts + nlat

            ! Set required workspace size
            ldwork = nlat * (nlat + 4)

            block
                real(wp) :: dwork(ldwork)
                call shsgci_lower_utility_routine(nlat, nlon, ntrunc, late, wshsgc(i1:), &
                    wshsgc(i2:), wshsgc(i3:), wshsgc(i4:), wshsgc(i5:), wshsgc(i6:), &
                    wshsgc(i7:), dwork(idth:), dwork(idwts:), dwork(iw:), ierror)
            end block

            ! Check error flag from lower utility routine
            if (ierror /= 0) ierror = 5
        end associate

    end subroutine shsgci

    subroutine shsgc_lower_utility_routine(nlat, nlon, l, lat, mode, gs, idg, jdg, &
        nt, a, b, mdab, ndab, w, wfft, late)

        ! Dummy arguments
        real(wp) :: a(mdab, ndab, nt), b(mdab, ndab, nt)
        real(wp) :: gs(idg, jdg, nt)
        real(wp) :: w(:), wfft(:)
        integer(ip) :: i
        integer(ip) :: idg
        integer(ip) :: is

        integer(ip) :: jdg
        integer(ip) :: k
        integer(ip) :: km
        integer(ip) :: l
        integer(ip) :: lat
        integer(ip) :: late
        integer(ip) :: lm1
        integer(ip) :: lp1
        integer(ip) :: m
        integer(ip) :: mdab
        integer(ip) :: meo
        integer(ip) :: mode
        integer(ip) :: mp1
        integer(ip) :: mp2
        integer(ip) :: ms
        integer(ip) :: ndab
        integer(ip) :: nl2
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: np1
        integer(ip) :: ns
        integer(ip) :: nt
        real(wp) :: t1
        real(wp) :: t2
        real(wp) :: t3
        real(wp) :: t4
        type(SpherepackUtility) :: util

        !     reconstruct fourier coefficients in g on gaussian grid
        !     using coefficients in a, b
        !     set m+1 limit for b coefficient calculation

        block
            real(wp) :: pmn(nlat, late, 3), g(lat, nlon, nt)

            if (nlon == 2*l-2) then
                lm1 = l-1
            else
                lm1 = l
            end if

            ! Initialize to zero
            g = ZERO

            select case (mode)
                case (0)
                    ! Set first column in g
                    m = 0

                    ! Compute pmn for all i and n=m, ..., l-1
                    call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)

                    do k=1, nt
                        !     n even
                        do np1=1, nlat, 2
                            do i=1, late
                                g(i, 1, k) = g(i, 1, k)+a(1, np1, k)*pmn(np1, i, km)
                            end do
                        end do
                        !     n odd
                        nl2 = nlat/2
                        do np1=2, nlat, 2
                            do i=1, nl2
                                is = nlat-i+1
                                g(is, 1, k) = g(is, 1, k)+a(1, np1, k)*pmn(np1, i, km)
                            end do
                        end do
                        !     restore m=0 coefficents (reverse implicit even/odd reduction)
                        do i=1, nl2
                            is = nlat-i+1
                            t1 = g(i, 1, k)
                            t3 = g(is, 1, k)
                            g(i, 1, k) = t1+t3
                            g(is, 1, k) = t1-t3
                        end do
                    end do

                    ! Sweep  columns of g for which b is available
                    do mp1=2, lm1
                        m = mp1-1
                        mp2 = m+2
                        !     compute pmn for all i and n=m, ..., l-1
                        call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
                        do k=1, nt
                            !     for n-m even store (g(i, p, k)+g(nlat-i+1, p, k))/2 in g(i, p, k) p=2*m,
                            !     for i=1, ..., late
                            do np1=mp1, nlat, 2
                                do i=1, late
                                    g(i, 2*m, k) = g(i, 2*m, k)+a(mp1, np1, k)*pmn(np1, i, km)
                                    g(i, 2*m+1, k) = g(i, 2*m+1, k)+b(mp1, np1, k)*pmn(np1, i, km)
                                end do
                            end do
                            !     for n-m odd store g(i, p, k)-g(nlat-i+1, p, k) in g(nlat-i+1, p, k)
                            !     for i=1, ..., nlat/2 (p=2*m, p=2*m+1)
                            do np1=mp2, nlat, 2
                                do i=1, nl2
                                    is = nlat-i+1
                                    g(is, 2*m, k) = g(is, 2*m, k)+a(mp1, np1, k)*pmn(np1, i, km)
                                    g(is, 2*m+1, k) = g(is, 2*m+1, k)+b(mp1, np1, k)*pmn(np1, i, km)
                                end do
                            end do
                            !     now set fourier coefficients using even-odd reduction above
                            do i=1, nl2
                                is = nlat-i+1
                                t1 = g(i, 2*m, k)
                                t2 = g(i, 2*m+1, k)
                                t3 = g(is, 2*m, k)
                                t4 = g(is, 2*m+1, k)
                                g(i, 2*m, k) = t1+t3
                                g(i, 2*m+1, k) = t2+t4
                                g(is, 2*m, k) = t1-t3
                                g(is, 2*m+1, k) = t2-t4
                            end do
                        end do
                    end do
                    !     set last column (using a only)
                    if (nlon== l+l-2) then
                        m = l-1
                        call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
                        do k=1, nt
                            !     n-m even
                            do np1=l, nlat, 2
                                do i=1, late
                                    g(i, nlon, k) = g(i, nlon, k)+TWO*a(l, np1, k)*pmn(np1, i, km)
                                end do
                            end do
                            lp1 = l+1
                            !     n-m odd
                            do np1=lp1, nlat, 2
                                do i=1, nl2
                                    is = nlat-i+1
                                    g(is, nlon, k) = g(is, nlon, k)+TWO*a(l, np1, k)*pmn(np1, i, km)
                                end do
                            end do
                            do i=1, nl2
                                is = nlat-i+1
                                t1 = g(i, nlon, k)
                                t3 = g(is, nlon, k)
                                g(i, nlon, k)= t1+t3
                                g(is, nlon, k)= t1-t3
                            end do
                        end do
                    end if
                case default
                    !     half sphere
                    !     set first column in g
                    m = 0
                    meo = 1
                    if (mode == 1) meo = 2
                    ms = m+meo
                    !     compute pmn for all i and n=m, ..., l-1
                    call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
                    do k=1, nt
                        do np1=ms, nlat, 2
                            do i=1, late
                                g(i, 1, k) = g(i, 1, k)+a(1, np1, k)*pmn(np1, i, km)
                            end do
                        end do
                    end do
                    !     sweep interior columns of g
                    do mp1=2, lm1
                        m = mp1-1
                        ms = m+meo
                        !     compute pmn for all i and n=m, ..., l-1
                        call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)
                        do k=1, nt
                            do np1=ms, nlat, 2
                                do i=1, late
                                    g(i, 2*m, k) = g(i, 2*m, k)+a(mp1, np1, k)*pmn(np1, i, km)
                                    g(i, 2*m+1, k) = g(i, 2*m+1, k)+b(mp1, np1, k)*pmn(np1, i, km)
                                end do
                            end do
                        end do
                    end do
                    if (nlon==l+l-2) then
                        !     set last column
                        m = l-1
                        call util%compute_legendre_polys_for_gaussian_grids(mode, l, nlat, m, w, pmn, km)

                        select case (mode)
                            case (1)
                                ns = l+1
                            case default
                                ns = l
                        end select

                        do k=1, nt
                            do i=1, late
                                do np1=ns, nlat, 2
                                    g(i, nlon, k) = g(i, nlon, k) + TWO * a(l, np1, k) * pmn(np1, i, km)
                                end do
                            end do
                        end do
                    end if
            end select

            ! Do inverse fourier transform
            do k=1, nt
                call util%hfft%backward(lat, nlon, g(:, :, k), lat, wfft)
            end do

            !  scale output in gs
            gs(1:lat, 1:nlon, :) = HALF * g(1:lat, 1:nlon, :)
        end block

    end subroutine shsgc_lower_utility_routine

    subroutine shsgci_lower_utility_routine(nlat, nlon, l, late, wts, p0n, p1n, abel, bbel, cbel, &
        wfft, dtheta, dwts, work, ier)

        real(wp) :: abel
        real(wp) :: bbel
        real(wp) :: cbel
        integer(ip) :: i
        integer(ip) :: ier
        integer(ip) :: imn

        integer(ip) :: l
        integer(ip) :: late
        integer(ip) :: lw
        integer(ip) :: m
        integer(ip) :: mlim
        integer(ip) :: n
        integer(ip) :: nlat
        integer(ip) :: nlon
        integer(ip) :: np1
        real(wp) :: p0n
        real(wp) :: p1n
        real(wp) :: wfft
        real(wp) :: wts
        dimension wts(nlat), p0n(nlat, late), p1n(nlat, late), abel(*), bbel(*), &
            cbel(*), wfft(*)
        real(wp) :: pb, dtheta(nlat), dwts(nlat), work(*)
        type(SpherepackUtility) :: util

        !     compute the nlat  gaussian points and weights, the
        !     m=0, 1 legendre polys for gaussian points and all n,
        !     and the legendre recursion coefficients
        !     define index function used in storing
        !     arrays for recursion coefficients (functions of (m, n))
        !     the index function indx(m, n) is defined so that
        !     the pairs (m, n) map to [1, 2, ..., indx(l-1, l-1)] with no
        !     "holes" as m varies from 2 to n and n varies from 2 to l-1.
        !     (m=0, 1 are set from p0n, p1n for all n)
        !     define for 2<=n<=l-1
        !indx(m, n) = (n-1)*(n-2)/2+m-1
        !     define index function for l<=n<=nlat
        !imndx(m, n) = l*(l-1)/2+(n-l-1)*(l-1)+m-1
        !     preset quantites for fourier transform
        call util%hfft%initialize(nlon, wfft)
        !     compute real gaussian points and weights
        !     lw = 4*nlat*(nlat + 1)+2
        lw = nlat*(nlat+2)
        call compute_gaussian_latitudes_and_weights(nlat, dtheta, dwts, ier)
        if (ier/=0) return
        !     store gaussian weights single precision to save computation
        !     in inner loops in analysis
        wts = dwts
        !     initialize p0n, p1n using real dnlfk, dnlft
        p0n = ZERO
        p1n = ZERO

        !     compute m=n=0 legendre polynomials for all theta(i)
        np1 = 1
        n = 0
        m = 0
        call util%compute_fourier_coefficients(m, n, work)
        do i=1, late
            call util%compute_legendre_polys_from_fourier_coeff(m, n, dtheta(i), work, pb)
            p0n(1, i) = pb
        end do
        !     compute p0n, p1n for all theta(i) when n>0
        do np1=2, nlat
            n = np1-1
            m = 0
            call util%compute_fourier_coefficients(m, n, work)
            do i=1, late
                call util%compute_legendre_polys_from_fourier_coeff(m, n, dtheta(i), work, pb)
                p0n(np1, i) = pb
            end do
            !     compute m=1 legendre polynomials for all n and theta(i)
            m = 1
            call util%compute_fourier_coefficients(m, n, work)
            do i=1, late
                call util%compute_legendre_polys_from_fourier_coeff(m, n, dtheta(i), work, pb)
                p1n(np1, i) = pb
            end do
        end do
        !     compute and store swarztrauber recursion coefficients
        !     for 2<=m<=n and 2<=n<=nlat in abel, bbel, cbel
        do n=2, nlat
            mlim = min(n, l)
            do m=2, mlim

                if (n >= l) then
                    imn = l*(l-1)/2+(n-l-1)*(l-1)+m-1
                else
                    imn = (n-1)*(n-2)/2+m-1
                end if

                abel(imn)=sqrt(real((2*n+1)*(m+n-2)*(m+n-3))/ &
                    real(((2*n-3)*(m+n-1)*(m+n))))
                bbel(imn)=sqrt(real((2*n+1)*(n-m-1)*(n-m))/ &
                    real(((2*n-3)*(m+n-1)*(m+n))))
                cbel(imn)=sqrt(real((n-m+1)*(n-m+2))/ &
                    real(((n+m-1)*(n+m))))
            end do
        end do

    end subroutine shsgci_lower_utility_routine

end submodule scalar_synthesis_gaussian_grid


!
!     file thwscrt.f90
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 2005 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                         Fishpack                              *
!     *                                                               *
!     *                      A Package of Fortran                     *
!     *                                                               *
!     *                Subroutines and Example Programs               *
!     *                                                               *
!     *               for Modeling Geophysical Processes              *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *        John Adams, Paul Swarztrauber and Roland Sweet         *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
program test_hwscrt

    use fishpack

    ! Explicit typing only
    implicit none

    ! Dictionary
    integer(ip), parameter   :: M = 40, N = 80
    integer(ip), parameter   :: MP1 = M + 1, NP1 = N + 1
    integer(ip), parameter   :: IDIMF = M + 5
    integer(ip)              :: mbdcnd, nbdcnd, i, j, ierror
    real(wp)                 :: f(IDIMF, NP1), x(MP1)
    real(wp), dimension(NP1) :: bdb, y
    real(wp), dimension(1)   :: bda, bdc, bdd
    real(wp)                 :: a, b, c, d, elmbda, pertrb
    real(wp), parameter      :: PI2 = PI**2
    real(wp), parameter      :: ZERO = 0.0_wp, ONE = 1.0_wp
    real(wp), parameter      :: TWO = 2.0_wp, THREE = 3.0_wp, FOUR = 4.0_wp

    ! Set domain
    a = ZERO
    b = TWO
    c = -ONE
    d = THREE

    ! Set boundary conditions
    mbdcnd = 2
    nbdcnd = 0

    ! Set helmholtz constant
    elmbda = -FOUR

    ! Generate and store grid points for the purpose of computing
    ! boundary data and the right side of the helmholtz equation.
    do i = 1, MP1
        x(i) = TWO * real(i - 1, kind=wp)/M
    end do

    do j = 1, NP1
        y(j) = -ONE + FOUR * real(j - 1, kind=wp)/N
    end do

    ! Generate boundary data.
    ! In our example, bda, bdc, and bdd are 1-dimensional dummy variables.
    bdb = FOUR * cos((y + ONE) * HALF_PI)

    ! Generate right side of equation.
    f = ZERO
    do j = 1, NP1
        do i = 2, MP1
            f(i, j) = (TWO - (FOUR + PI2/4)*(x(i)**2)) * cos((y(j) + ONE)*HALF_PI)
        end do
    end do

    ! Solve 2D Helmholtz in cartesian coordinates on a centered grid
    call hwscrt(a, b, M, mbdcnd, bda, bdb, c, d, N, nbdcnd, bdc, bdd, &
        elmbda, f, IDIMF, pertrb, ierror)

    ! Compute discretization error. The exact solution is
    !
    ! u(x, y) = (x**2) * cos((y+1)*(pi/2))
    block
        real(wp), parameter :: KNOWN_ERROR = 0.536508246868017e-3_wp
        real(wp) :: discretization_error
        real(wp) :: exact_solution(MP1, NP1)

        do j = 1, NP1
            do i = 1, MP1
                exact_solution(i,j) = (x(i)**2) * cos((y(j)+ONE) * HALF_PI)
            end do
        end do

        ! Set discretization error
        discretization_error = maxval(abs(exact_solution - f(:MP1,:NP1)))

        call check_output('hwscrt', ierror, KNOWN_ERROR, discretization_error)
    end block

end program test_hwscrt


      SUBROUTINE DCOSSINFT2D(Y,n1_max,N1,n2,wrk)
!
! This routine is the same as DCOSFT2D except that in the second
! direction a SINFT is performed.
!
      IMPLICIT NONE
      INTEGER n1_max, n1, n2
      REAL*8  Y(N1_max,n2), wrk(n2)
      INTEGER j, k

      DO k=1,n2
         CALL dcosft(y(1,k),n1-1)
      END DO
      DO j=1,n1
         DO k=1,n2
            wrk(k)=y(j,k)
         END DO
         CALL dsinft(wrk,n2-1)
         DO k=1,n2
            y(j,k)=wrk(k)
         END DO
      END DO

      RETURN
      END SUBROUTINE DCOSSINFT2D


SUBROUTINE LUfact(a,n,ndim,b,epsilon,work,ipiv,returnCode)

   ! -------------------------------------------------------------------------
   ! NAME:   LUfact
   ! PARENT: Solve
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Called from subroutine 'Solve'. Solve systems of linear algebraic
   !         equations by LU factorization method.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   USE PrecTypes
   IMPLICIT NONE

   INTEGER, INTENT(IN) :: n,ndim
   INTEGER, INTENT(INOUT) :: ipiv(*)
   REAL(dp), INTENT(INOUT) :: epsilon
   REAL(dp), INTENT(INOUT) :: a(ndim,*),b(*),work(*)
   REAL(dp) :: ABSa, wk, aa, ba, minusb, wmax
   INTEGER, INTENT(OUT) :: returnCode
   INTEGER :: i, ii, j, k, kk, ir, iir

   ! Checking the arguments
   IF (ndim < n) THEN

      ! Error of the input argument
      WRITE(*,'("(LUfact) Invalid argument.",/,"n=",I5, /,"ndim =",I5)') n,ndim
      returnCode = 3
      RETURN

   ELSE IF (ndim >= n) THEN
      IF (n < 1) THEN
         ! Error of the input argument
         WRITE(6,10) n,ndim
         10 FORMAT('(LUfact) Invalid argument.',/,'n=',I5, /,'ndim =',I5)
         returnCode = 3
         RETURN

      ELSE IF (n == 1) THEN

         ! When the matrix size is one
         IF (a(1,1) == 0.0_dp) THEN
            ! Matrix singular case
            WRITE(*,'("(LUfact) Matrix is singular.")')
            returnCode = 1
            RETURN
         ELSE
            returnCode = 0
            b(1) = b(1)/a(1,1)
            ipiv(1) = 1
            RETURN
         END IF

      ELSE ! if n > 1
         IF (epsilon < 0.0_dp) epsilon = 1.0D-14
      END IF
   END IF

   ! 初期化
   DO i=1,n
      work(i) = ABS(a(i,1))
      ipiv(i) = i
   END DO

   ! Finding the maximum component of each row
   DO j=2,n
      DO i=1,n
         ABSa = ABS(a(i,j))
         wk = work(i)
         IF (wk < ABSa) work(i) = ABSa
      END DO
   END DO

   DO i=1,n
      wk = work(i)
      IF ( wk == 0.0_dp) THEN
         WRITE(*,'("(LUfact) Matrix is singular.")')
         returnCode = 1
         RETURN
      ELSE
         work(i) = 1.0_dp/work(i)
      END IF
   END DO

   ! Starting the LU-decomposition
   DO k=1,n
      IF (k /= 1) THEN

         DO j=1,k-1
            ir = ipiv(j)
            aa = - a(ir,k) * a(ir,j)
            a(ir,k) = - aa
            DO ii=j+1,n
               i = ipiv(ii)
               a(i,k) = a(i,k) + a(i,j)*aa
            END DO
         END DO
      END IF

      ! Finding the maximum component of the k-th column
      wmax = 0.0_dp
      DO ii=k,n
         i = ipiv(ii)
         wk = ABS(a(i,k))*work(i)
         IF (wmax < wk) THEN
            iir = ii
            wmax = wk
         END IF
      END DO

   ! Checking if the matrix is singular or not
      IF (wmax <= epsilon) THEN
         IF (wmax == 0.0_dp) THEN
            WRITE(*,'("(LUfact) Matrix is singular.")')
            returnCode = 1
         ELSE
            WRITE(*,'("(LUfac) Matrix became singular at the factorizing step :", I5)') k
            returnCode = 2
         END IF
         RETURN
      END IF

      ir = ipiv(iir)
      ipiv(iir) = ipiv(k)
      ipiv(k) = ir
      a(ir,k) = 1.0_dp/a(ir,k)
   END DO

   IF (n < 1) THEN
      WRITE(*,'("(LUfact) Invalid argument.",/,"n=",I5, /,"ndim =",I5)') n,ndim
      returnCode = 3
      RETURN
   ELSE IF (n == 1) THEN
      ! When the matrix size is one
      IF (a(1,1) == 0.0_dp) THEN
         ! Matrix singular case
         WRITE(*,'("(LUfact) Matrix is singular.")')
         returnCode = 1
         RETURN
      ELSE
         returnCode = 0
         b(1) = b(1)/a(1,1)
         ipiv(1) = 1
         RETURN
      END IF
   else ! if n > 1

      ! Forward substitution
      DO k=1,n-1
         ir = ipiv(k)
         ba = -b(ir)*a(ir,k)
         b(ir) = -ba
         DO ii=k+1,n
            i = ipiv(ii)
            b(i) = a(i,k)*ba+b(i)
         END DO
      END DO
      b(i) = b(i)*a(i,n)

      ! Backward substitution
      DO kk=2,n
         k = n-kk+2
         minusb = -b(i)
         DO ii=1,k-1
            i = ipiv(ii)
            b(i) = a(i,k)*minusb+b(i)
         END DO
      END DO
      DO k=1,n
         work(k) = b(k)
      END DO
      DO k=1,n
         i = ipiv(k)
         b(k) = work(i)
      END DO
      returnCode = 0

   END IF

   RETURN

END SUBROUTINE LUfact


*----------------------------------------------------------------------*
      subroutine dmdiagm(ndim,mat,diag,right,inverted)
*----------------------------------------------------------------------*
*     performs multiplication of a matrix with a diagonal matrix
*     right    : multiply diagonal matrix from right (T) or left (F)
*     inverted : use diag^-1 (T) or just diag (F)
*
*     matthias, dec 2010
*----------------------------------------------------------------------*
      implicit none

      include 'stdunit.h'

      integer, parameter ::
     &     ntest = 00
      real(8), parameter ::
     &     thresh = 1d-7 ! because in current use we have the
                         ! square root of diagonal elements on diag
      integer, intent(in) ::
     &     ndim
      real(8), intent(inout) ::
     &     mat(ndim,ndim)
      real(8), intent(in) ::
     &     diag(ndim)
      logical, intent(in) ::
     &     right, inverted

      integer ::
     &     idx

      if (ndim.eq.0) return

      if (ntest.ge.100) then
        write(lulog,'(x,a)') '---------------'
        write(lulog,'(x,a)') 'dmdiagm at work'
        write(lulog,'(x,a)') '---------------'
        write(lulog,*) 'input matrix:'
        call wrtmat2(mat,ndim,ndim,ndim,ndim)
        write(lulog,*) 'normalization vector:'
        call wrtmat2(diag,1,ndim,1,ndim)
      end if

      if (inverted) then
        if (right) then
          do idx = 1, ndim
            if (diag(idx).lt.thresh) then
c              mat(1:ndim,idx) = 0d0
              cycle
            end if
            mat(1:ndim,idx) = mat(1:ndim,idx)/diag(idx)
          end do
        else
          do idx = 1, ndim
            if (diag(idx).lt.thresh) then
c              mat(idx,1:ndim) = 0d0
              cycle
            end if
            mat(idx,1:ndim) = mat(idx,1:ndim)/diag(idx)
          end do
        end if
      else
        if (right) then
          do idx = 1, ndim
            if (diag(idx).lt.thresh) cycle ! debug
            mat(1:ndim,idx) = mat(1:ndim,idx)*diag(idx)
          end do
        else
          do idx = 1, ndim
            if (diag(idx).lt.thresh) cycle ! debug
            mat(idx,1:ndim) = mat(idx,1:ndim)*diag(idx)
          end do
        end if
      end if

      if (ntest.ge.100) then
        write(lulog,*) 'output matrix:'
        call wrtmat2(mat,ndim,ndim,ndim,ndim)
      end if

      return
      end


! { dg-do compile }
!
! PR 39861/39864
!
! Test cases provided by Dominique d'Humieres <dominiq@lps.ens.fr>
! and Michael Richmond <michael.a.richmond@nasa.gov>.

module vector_calculus
  intrinsic :: dot_product, sqrt

contains

  function len(r)
    real, dimension(:), intent(in) :: r
    real :: len
    len = sqrt(dot_product(r,r))
  end function len

  FUNCTION next_state()
    INTRINSIC :: RESHAPE
    INTEGER, PARAMETER :: trantb(1,1) = RESHAPE((/1,2/), shape=(/1,1/))
    next_state = trantb(1, 1)
  END FUNCTION next_state

end module vector_calculus


SUBROUTINE beamdis(loads,nf,ratmax,interp,nels,ell,argv,nlen,ips)
!
! This subroutine produces a PostScript output file "*.dis" displaying
! the deformed 1-D finite element mesh.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::loads(0:),ratmax,ell(:)
 INTEGER,INTENT(IN)::ips,nf(:,:),nels,interp,nlen
 REAL(iwp)::width,height,scale=72,sxy,xo,yo,x,y,dismag,vmax
 REAL(iwp)::xmin,xmax,ymin,ymax,xnow,dmax,zero=0.0_iwp,pt5=0.5_iwp,       &
   opt5=1.5_iwp,fpt5=5.5_iwp,d8=8.0_iwp,ept5=8.5_iwp,d11=11.0_iwp,        &
   one=1.0_iwp,two=2.0_iwp,thr=3.0_iwp,                                   &
   localx,globalx,na,nb,nc,nd,ll,wold,wnew
 INTEGER::i,j,nn
 CHARACTER(LEN=15)::argv
 REAL(iwp),ALLOCATABLE::xcoord(:)
 OPEN(ips,FILE=argv(1:nlen)//'.dis')
!
 nn=nels+1
 ALLOCATE(xcoord(nn))

 xmin=zero
 xmax=zero
 xnow=zero
 ymin=zero
 ymax=zero

 xcoord(1)=xnow

 DO i=2,nn
   xnow=xnow+ell(i-1)
   xcoord(i)=xnow
 END DO

 xmax=xcoord(nn)

 DO i=1,nn
    IF(loads(nf(1,i))<ymin)ymin=loads(nf(1,i))
    IF(loads(nf(1,i))>ymax)ymax=loads(nf(1,i))
 END DO

 width=xmax-xmin
 height=ymax-ymin
 dmax=ratmax*width
 IF(height>width)dmax=ratmax*height
!
 vmax=zero
 DO i=1,nn
     IF(ABS(loads(nf(1,i)))>vmax)vmax=ABS(loads(nf(1,i)))
 END DO
 dismag=dmax/vmax
!
 ymin=zero
 ymax=zero

 DO i=1,nn
   IF(dismag*loads(nf(1,i))<ymin)                            &
     ymin=dismag*loads(nf(1,i))
   IF(dismag*loads(nf(1,i))>ymax)                            &
     ymax=dismag*loads(nf(1,i))
!
   IF(loads(nf(1,i))<ymin)ymin=loads(nf(1,i))
   IF(loads(nf(1,i))>ymax)ymax=loads(nf(1,i))
 END DO
!
 width =xmax-xmin
 height=ymax-ymin
!
!                       allow 1.5" margin minimum on each side of figure
!
!                       portrait mode
!
 IF(height.GE.d11/ept5*width)THEN
!
!                       height governs the scale
!
   sxy=scale*d8/height
   xo=scale*pt5*(ept5-d8*width/height)
   yo=scale*opt5
 ELSE
!
!                       width governs the scale
!
   sxy=scale*fpt5/width
   xo=scale*opt5
   yo=scale*pt5*(d11-fpt5*height/width)
 END IF
!
!
!                       start PostScript output
!
 WRITE(ips,'(a)')'%!PS-Adobe-1.0'
 WRITE(ips,'(a)')'%%DocumentFonts: none'
 WRITE(ips,'(a)')'%%Pages: 1'
 WRITE(ips,'(a)')'%%EndComments'
 WRITE(ips,'(a)')'/m {moveto} def'
 WRITE(ips,'(a)')'/l {lineto} def'
 WRITE(ips,'(a)')'/s {stroke} def'
 WRITE(ips,'(a)')'/c {closepath} def'
 WRITE(ips,'(a)')'%%EndProlog'
 WRITE(ips,'(a)')'%%Page: 0 1'
 WRITE(ips,'(a)')'gsave'
!
!                       draw the deformed mesh
!
 WRITE(ips,'(2f9.2,a)') xo, yo, ' translate'
 WRITE(ips,'(f9.2,a)') 0.5, ' setlinewidth'

 wnew=loads(nf(1,1))

 DO i=1,nels
    DO j=1,interp

    wold=wnew
    localx=j*ell(i)/interp
    globalx=localx+xcoord(i)
    ll=ell(i)
    na=(one/(ll**3))*(ll**3-thr*ll*localx**2+two*localx**3)
    nb=(one/(ll**2))*(localx*ll**2-two*ll*localx**2+localx**3)
    nc=(one/(ll**3))*(thr*ll*localx**2-two*localx**3)
    nd=(one/(ll**2))*(localx**3-ll*localx**2)
    wnew=na*loads(nf(1,i))+nb*loads(nf(2,i))+nc*loads(nf(1,1+i))+nd*loads(nf(2,i+1))

    x=sxy*((globalx-ell(i)/interp)-xmin)
    y=sxy*(dismag*wold-ymin)
    WRITE(ips,'(2f9.2,a)') x, y,' m'
    x=sxy*(globalx-xmin)
    y=sxy*(dismag*wnew-ymin)
    WRITE(ips,'(2f9.2,a)') x, y,' l'
    WRITE(ips,'(a)')'c s'

    END DO

 END DO
!
 WRITE(ips,'(a)')'grestore'
 WRITE(ips,'(a)')'showpage'
 CLOSE(ips)
!
RETURN
END SUBROUTINE beamdis


program well
use special, only: spherical_bessel_jn_zeros
use dftatom
implicit none

! Atomic number:
integer, parameter :: Z = 0
! Mesh parameters:
real(dp), parameter :: r_min = 1e-8_dp, r_max = 10, a = 6.2e7_dp
integer, parameter :: NN = 6000

real(dp), parameter :: c = 137.03599907_dp, eps = 1e-10_dp
integer :: n, n2, l, relat, converged, relat_max, k, kappa
real(dp) :: r(NN+1), u(size(r)), Ein, E, E_exact_nonrel, error, P(size(r)), &
    Q(size(r))
real(dp) :: Rp(NN+1)
real(dp) :: Emin_init, Emax_init
real(dp), allocatable :: zeros(:, :)
real(dp) :: E_exact(7, -7:7) ! E_exact(n, kappa)

E_exact = 0
E_exact(7, -7) = 0.5525904113_dp
E_exact(6:7, -6) = [ &
 0.4376510015_dp, &
 0.8406357081_dp &
]
E_exact(5:7, -5) = [ &
 0.3347685757_dp, &
 0.6850117637_dp, &
 1.1309235187_dp &
]
E_exact(4:7, -4) = [ &
 0.2441543810_dp, &
 0.5425739559_dp, &
 0.9381557573_dp, &
 1.4319901885_dp &
]
E_exact(3:7, -3) = [ &
 0.1660865751_dp, &
 0.4135916009_dp, &
 0.7592590218_dp, &
 1.2034759695_dp, &
 1.7463192010_dp &
]
E_exact(2:7, -2) = [ &
 0.1009533714_dp, &
 0.2983952090_dp, &
 0.5944899358_dp, &
 0.9892629990_dp, &
 1.4827135257_dp, &
 2.0748352993_dp &
]
E_exact(1:7, -1) = [ &
 0.0493479580_dp, &
 0.1973910436_dp, &
 0.4441269495_dp, &
 0.7895517628_dp, &
 1.2336600278_dp, &
 1.7764447596_dp, &
 2.4178974112_dp &
]
E_exact(2:7, 1) = [ &
 0.1009533712_dp, &
 0.2983952108_dp, &
 0.5944899397_dp, &
 0.9892630035_dp, &
 1.4827135323_dp, &
 2.0748353048_dp &
]
E_exact(3:7, 2) = [ &
 0.1660865751_dp, &
 0.4135916010_dp, &
 0.7592590218_dp, &
 1.2034759695_dp, &
 1.7463192010_dp &
]
E_exact(4:7, 3) = [ &
 0.2441543811_dp, &
 0.5425739559_dp, &
 0.9381557573_dp, &
 1.4319901885_dp &
]
E_exact(5:7, 4) = [ &
 0.3347685757_dp, &
 0.6850117636_dp, &
 1.1309235187_dp &
]
E_exact(6:7, 5) = [ &
 0.4376510015_dp, &
 0.8406357081_dp &
]
E_exact(7, 6) = 0.5525904113_dp

r = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
u = 0

allocate(zeros(10, 0:7))
zeros = spherical_bessel_jn_zeros(7, 10, 1e-13_dp)
print *, "Relativistic infinite spherical potential well"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print *, " n  l  k kappa        E             E_exact     Error      E_exact_nonrel"
print *
do n = 1, 7
    do l = 0, n-1
        if (l == 0) then
            relat_max = 2
        else
            relat_max = 3
        end if
        do relat = 2, relat_max
            E_exact_nonrel = (zeros(n-l, l) / r_max)**2 / 2
            k = relat - 2
            if (k == 0) then
                kappa = -l - 1
            else
                kappa = l
            end if
            Ein = -100
            Emin_init = 0
            Emax_init = 100
            if (kappa > 0) then
                n2 = n + 1
            else
                n2 = n
            end if
            call solve_radial_eigenproblem(n2, l, Ein, eps, 100, R, Rp, u, &
                Z, c, relat, .false., Emin_init, Emax_init, converged, E, P, Q)
            error = abs(E - E_exact(n, kappa))
            if (converged /= 0) call stop_error("Not converged")
            print "(I3, I3, I3, I3, F17.8, F17.8, ES10.2, F17.8)", n, l, k, &
                kappa, E, E_exact(n, kappa), error, E_exact_nonrel
            if (error > 1e-6_dp) call stop_error("Error is higher than 1e-6")
        end do
    end do
end do
end program


! Created by EverLookNeverSee@GitHub on 4/19/20.
! This program finds factorial of n

program factorial
    implicit none
    ! defining user input variable
    integer :: n
    ! defining counter and temporary factorial variables
    integer :: temp = 1, i
1   print *, "Enter a positive integer value:"
    read *, n
    if (n < 1) then
        print *, "You should enter a positive integer value!"
        goto 1
    end if
    do i = 1, n
        temp = temp * i
    end do
    print *, temp
end program factorial


module lapack_module
  use aux
  implicit none
  private
  public inverse_matrix

  interface inverse_matrix
    module procedure inverse_matrix_d, inverse_matrix_z
  end interface inverse_matrix

  contains

  subroutine inverse_matrix_z(M)
    implicit none
    complex(dp), intent(inout) :: M(:,:)
    integer                    :: ndim,ierr,lwork
    integer, allocatable       :: ipiv(:)
    complex(dp), allocatable   :: work(:)
    complex(dp)                :: work_query(1)

    ndim = size(M,1)
    allocate(ipiv(ndim))
    call zgetrf(ndim,ndim,M,ndim,ipiv,ierr)
    if (ierr .ne. 0) then
      write(*,*)"ERROR in ZGETRF", ierr ; stop
    end if
    call zgetri(ndim,M,ndim,ipiv,work_query,-1,ierr) ! query for optimal work space
    if (ierr .ne. 0) then
      write(*,*)"ERROR in ZGETRI at workspace query", ierr ; stop
    endif
    lwork = work_query(1)
    allocate(work(lwork))
    call zgetri(ndim,M,ndim,ipiv,work,lwork,ierr)
    if (ierr .ne. 0) then
      write(*,*)"ERROR in ZGETRI", ierr ; stop
    endif
    deallocate(ipiv,work)
  end subroutine inverse_matrix_z

  subroutine inverse_matrix_d(M)
    implicit none
    real(dp), intent (inout) :: M(:,:)
    integer                  :: ndim,ierr,lwork
    integer, allocatable     :: ipiv(:)
    real(dp), allocatable    :: work(:)
    real(dp)                 :: work_query(1)

    ndim = size(M,1)
    allocate(ipiv(ndim))
    call dgetrf(ndim,ndim,M,ndim,ipiv,ierr)
    if(ierr .ne. 0) then
      write(*,*)"ERROR in DGETRF", ierr ; stop
    end if
    call dgetri(ndim,M,ndim,ipiv,work_query,-1,ierr) ! query for optimal work space
    if (ierr .ne. 0) then
      write(*,*)"ERROR in DGETRI at workspace query", ierr ; stop
    endif
    lwork = work_query(1)
    allocate(work(lwork))
    call dgetri(ndim,M,ndim,ipiv,work,lwork,ierr)
    if(ierr .ne. 0) then
      write(*,*)"ERROR in DGETRI", ierr ; stop
    end if
    deallocate(ipiv,work)
  end subroutine inverse_matrix_d

end module lapack_module


c       this file contains the following user-callable routines:
c
c
c       routine idzr_aid computes the SVD, to a specified rank,
c       of an arbitrary matrix. This routine is randomized.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idzr_asvd(m,n,a,krank,w,u,v,s,ier)
c
c       constructs a rank-krank SVD  u diag(s) v^*  approximating a,
c       where u is an m x krank matrix whose columns are orthonormal,
c       v is an n x krank matrix whose columns are orthonormal,
c       and diag(s) is a diagonal krank x krank matrix whose entries
c       are all nonnegative. This routine uses a randomized algorithm.
c
c       input:
c       m -- number of rows in a
c       n -- number of columns in a
c       a -- matrix to be decomposed; the present routine does not
c            alter a
c       krank -- rank of the SVD being constructed
c       w -- initialization array that routine idzr_aidi
c            has constructed (for use in the present routine,
c            w must be at least
c            (2*krank+22)*m+(6*krank+21)*n+8*krank**2+10*krank+90
c            complex*16 elements long)
c
c       output:
c       u -- matrix of orthonormal left singular vectors of a
c       v -- matrix of orthonormal right singular vectors of a
c       s -- array of singular values of a
c       ier -- 0 when the routine terminates successfully;
c              nonzero otherwise
c
c       _N.B._: The algorithm used by this routine is randomized.
c
        implicit none
        integer m,n,krank,lw,ilist,llist,iproj,lproj,icol,lcol,
     1          iwork,lwork,iwinit,lwinit,ier
        real*8 s(krank)
        complex*16 a(m,n),u(m,krank),v(n,krank),
     1             w((2*krank+22)*m+(6*krank+21)*n+8*krank**2
     2              +10*krank+90)
c
c
c       Allocate memory in w.
c
        lw = 0
c
        iwinit = lw+1
        lwinit = (2*krank+17)*n+21*m+80
        lw = lw+lwinit
c
        ilist = lw+1
        llist = n
        lw = lw+llist
c
        iproj = lw+1
        lproj = krank*(n-krank)
        lw = lw+lproj
c
        icol = lw+1
        lcol = m*krank
        lw = lw+lcol
c
        iwork = lw+1
        lwork = (krank+1)*(m+3*n+10)+9*krank**2
        lw = lw+lwork
c
c
        call idzr_asvd0(m,n,a,krank,w(iwinit),u,v,s,ier,
     1                  w(ilist),w(iproj),w(icol),w(iwork))
c
c
        return
        end
c
c
c
c
        subroutine idzr_asvd0(m,n,a,krank,winit,u,v,s,ier,
     1                        list,proj,col,work)
c
c       routine idzr_asvd serves as a memory wrapper
c       for the present routine (please see routine idzr_asvd
c       for further documentation).
c
        implicit none
        integer m,n,krank,list(n),ier
        real*8 s(krank)
        complex*16 a(m,n),u(m,krank),v(n,krank),
     1             proj(krank,n-krank),col(m*krank),
     2             winit((2*krank+17)*n+21*m+80),
     3             work((krank+1)*(m+3*n+10)+9*krank**2)
c
c
c       ID a.
c
        call idzr_aid(m,n,a,krank,winit,list,proj)
c
c
c       Collect together the columns of a indexed by list into col.
c
        call idz_copycols(m,n,a,krank,list,col)
c
c
c       Convert the ID to an SVD.
c
        call idz_id2svd(m,krank,col,n,list,proj,u,v,s,ier,work)
c
c
        return
        end


C Test for bug in reg-stack handling conditional moves.
C Reported by Tim Prince <tprince@computer.org>
C
C { dg-do run { target { { i?86-*-* x86_64-*-* } && ia32 } } }
C { dg-options "-ffast-math -march=pentiumpro" }

      double precision function foo(x, y)
         implicit none
         double precision x, y
         double precision a, b, c, d
         if (x /= y) then
             if (x * y >= 0) then
                 a = abs(x)
                 b = abs(y)
                 c = max(a, b)
                 d = min(a, b)
                 foo = 1 - d/c
             else
                 foo = 1
             end if
         else
             foo = 0
         end if
      end

      program test
      implicit none

      integer ntests
      parameter (ntests=7)
      double precision tolerance
      parameter (tolerance=1.0D-6)

C Each column is a pair of values to feed to foo,
C and its expected return value.
      double precision a(ntests), b(ntests), x(ntests)
      data a /1, -23, -1,   1,   9,  10,  -9/
      data b /1, -23, 12, -12,  10,   9, -10/
      data x /0,   0,  1,   1, 0.1, 0.1, 0.1/

      double precision foo
      double precision result
      integer i

      do i = 1, ntests
         result = foo(a(i), b(i))
         if (abs(result - x(i)) > tolerance) then
           print *, i, a(i), b(i), x(i), result
           call abort
         end if
      end do
      end


! { dg-do compile }
! { dg-require-effective-target fortran_large_real }
!
subroutine test_large
  integer, parameter :: wp = selected_real_kind (precision (0.0_8) + 1)
  complex(wp), parameter :: i = (0._wp, 1._wp)
  complex(wp) :: c(12)
  integer :: m, N

  N = 12
  c = (/(exp(i*m),m=1,N)/)
  print *, c(1)
end


!> 用于计算具有坐标 (x) 的粒子所在的排序网格的单元格的坐标 (xgcell) 的子例程。
!>   subroutine to calculate the coordinates (xgcell) of the cell of
!>   the sorting  grid, in which the particle with coordinates (x) lies.
subroutine grid_geom(i, x, ngridx, maxgridx, mingridx, dgeomx, xgcell)

    use sph_kind, only: rk
    use parameter
    implicit none

    !> 粒子序号
    !> index of particle
    integer, intent(in) :: i
    !> 粒子的坐标
    !> coordinates of particle
    real(rk), intent(in) :: x(dim)
    !> 分割网格的个数
    !> number of sorting grid cells in x, y, z-direction
    integer, intent(in) :: ngridx(dim)
    !> 分割网格的最大坐标
    !> maximum x-, y- and z-coordinate of grid range
    real(rk), intent(in) :: maxgridx(dim)
    !> 分割网格的最小坐标
    !> minimum x-, y- and z-coordinate of grid range
    real(rk), intent(in) :: mingridx(dim)
    !> 分割网格的坐标增量
    !> x-, y- and z-expansion of grid range
    real(rk), intent(in) :: dgeomx(dim)
    !> 分割网格的坐标
    !> x-, y- and z-coordinte of sorting grid cell
    real(rk), intent(out) :: xgcell(dim)

    integer :: d

    do d = 1, 3
        xgcell(d) = 1
    end do

    do d = 1, dim
        if ((x(d) > maxgridx(d)) .or. (x(d) < mingridx(d))) then
            print *, ' >>> error <<< : particle out of range'
            print *, '    particle position: x(', i, d, ') = ', x(d)
            print *, '    range: [xmin,xmax](', d, ') =                               [', mingridx(d), ',', maxgridx(d), ']'
            stop
        else
            xgcell(d) = int(real(ngridx(d))/dgeomx(d)*(x(d) - mingridx(d)) + 1._rk)
        end if
    end do

end subroutine grid_geom


!Joshua Dorrington 22/03/18 - University of Oxford

!This module handles random number generation for stochastic runs
module utils
	use, intrinsic :: iso_fortran_env
	use params
	implicit none
	private
	public time_seed, white_noise, red_noise

	contains
		!lifted wholesale from Sam Hatfield's Lorenz63-4D Var model
		!seeds random numbers
		subroutine time_seed()
            		integer :: i, n, clock
            		integer, allocatable :: seed(:)

            		call random_seed(size = n)
            		allocate(seed(n))

            		call system_clock(count=clock)

            		seed = clock + 37 * (/ (i - 1, i = 1, n) /)
            		call random_seed(put = seed)

            		deallocate(seed)
		end subroutine

		!generates (n X dims) array of gaussian random numbers using Box Muller
		subroutine white_noise(rand_arr,mean,std,n)
			real(dp) :: rand_arr(:,:)
			real(dp), intent(in) :: mean, std
			integer , intent(in):: n
			real(dp) :: rand1(n,dims), rand2(n,dims),u(n,dims),v(n,dims)

			!random univariates
			call random_number(rand1)
			call random_number(rand2)

			!Box-Muller
			u = sqrt(-2._dp * log(rand1))
           		v =   cos(8._dp*ATAN(1._dp) * rand2)
			rand_arr = mean + (std * u * v)
		end subroutine

		!generates (n X dims) array of red noise with lag 1 correlation r
		subroutine red_noise(rand_arr, mean,std,n)
			real(dp) :: rand_arr(:,:), white_arr(n,dims)
			real(dp), intent(in) :: mean, std
			integer , intent(in):: n
			integer :: i
			real(dp) :: k
			k=sqrt(1-r*r)
			call white_noise(white_arr,mean,std,n)
			rand_arr(1,:)=white_arr(1,:)
			do i=1, n-1
				rand_arr(i+1,:)=r*rand_arr(i,:) + k*white_arr(i+1,:)
			end do
		end subroutine

end module utils


MODULE PE2D_TYPE
 USE IEEE_ARITHMETIC
 IMPLICIT NONE
 !-----------------------------------------------------------
 INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9)
 INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4)
 INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2)
 INTEGER, PARAMETER :: SP = KIND(1.0)
 INTEGER, PARAMETER :: DP = KIND(1.0D0)
 INTEGER, PARAMETER :: SPC = KIND((1.0,1.0))
 INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0))
 INTEGER, PARAMETER :: LGT = KIND(.TRUE.)
 REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_SP
 REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_SP
 REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_SP
 REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_SP
 REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_SP
 REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_DP
 REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_DP
 REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_DP
 COMPLEX(DPC), PARAMETER :: IM=COMPLEX(0.0_DP,1.0_DP)
 !US = Unstructured Sparse
 TYPE US
  INTEGER(I4B) :: N, NELT
  REAL(DP), DIMENSION(:), ALLOCATABLE :: VAL
  INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: IROW
  INTEGER(I4B), DIMENSION(:), ALLOCATABLE :: JCOL
 END TYPE US
 !-----------------------------------------------------------
END MODULE PE2D_TYPE


module shadow_globaldefinitions

!
! global assignments for shadow3
!
    use, intrinsic :: ISO_C_BINDING
    implicit none

!
! Numeric variable types (precision)
!
    integer, parameter, public :: ski = C_INT
    integer, parameter, public :: skr = C_DOUBLE
    integer, parameter, public :: skc = C_CHAR
    integer, parameter, public :: skx = C_DOUBLE_COMPLEX
    integer, parameter, public :: sklen = 1024

!

!!----
!!---- OS: Integer variable 1: Windows, 2: Mac, 3: Linux, 4:Sun
!!---- OS_DS: ASCII code of directory separator character
!!

   integer(kind=ski), parameter :: OS = 3
   character(len=1),  parameter :: OS_DS = "/"

!
! mathematical and physical constants
!
    real(kind=skr), parameter :: pi     = 3.141592653589793238462643D0
    real(kind=skr), parameter :: twopi  = 6.283185307179586467925287D0
    real(kind=skr), parameter :: pihalf = 1.570796326794896619231322D0
    real(kind=skr), parameter :: todeg  =57.295779513082320876798155D0
    real(kind=skr), parameter :: torad  = 0.017453292519943295769237D0

    ! introduced physical constants in globaldefinitions:  srio@esrf.eu 20160527 - NIST CODATA 2014
    real(kind=skr),parameter :: codata_c                     = 2.99792458D8      !speed of light, m/s
    real(kind=skr),parameter :: codata_rm                    = 9.10938356D-31    !electron rest mass  kg
    real(kind=skr),parameter :: codata_e                     = 1.6021766208D-19  !electron charge, C
    real(kind=skr),parameter :: codata_h                     = 6.626070040D-34   !Planck's constant   joules*sec
    real(kind=skr),parameter :: codata_mee                   = 0.5109989461D0      ! electrom Mass equivalent in MeV
    real(kind=skr),parameter :: codata_electric_permittivity = 8.854187817D-12   ! electric constant epsilon0
    ! conversion Angstrom <-> eV for particles with no mass
    ! codata_h*codata_c/codata_e*1d10
    real(kind=skr), parameter :: toangs = 12398.419739640718D0    ! 12398.4192920042

    real(kind=skr), parameter :: tocm =   12398.419739640718D-8 ! 12398.4192920042D-8

    ! for debugging purposes, set this to 1 to get a verbose output
    integer(kind=ski), public :: shadow3_verbose = 0

    ! length units: note that this will be overwritten by source and oe DUMMY variable
    !  using m: user_units_to_cm=100, using cm: user_units_to_cm=1, usning mm: user_units_to_cm=0.1
    !  default is cm
    real(kind=skr), public :: user_units_to_cm = 1.0D0

end module shadow_globaldefinitions


      integer function ibico(n,k)
*     binomial coefficient n over k

      implicit none

      integer, intent(in) ::
     &     n, k
      integer ::
     &     l, nmkp1
      integer, external ::
     &     ifac

      if (k.lt.0.or.n.lt.k)
     &   call quit(1,'ibico','k<0 or n<k')

      if (k.gt.n/2) then
        nmkp1 = k+1 !use (n over k) = (n over (n-k))
      else
        nmkp1 = n-k+1
      end if

      ibico = 1
      do l = nmkp1, n
        ibico = ibico*l
      end do
      ibico = ibico/ifac(n-nmkp1+1)

      return
      end