      SUBROUTINE SSTEGR2( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
     $                   M, W, Z, LDZ, NZC, ISUPPZ, WORK, LWORK, IWORK,
     $                   LIWORK, DOL, DOU, ZOFFSET, INFO )
*
*  -- ScaLAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver
*     July 4, 2010
*
*     .. Scalar Arguments ..
      CHARACTER          JOBZ, RANGE
      INTEGER            DOL, DOU, IL, INFO, IU,
     $                   LDZ, NZC, LIWORK, LWORK, M, N, ZOFFSET
      REAL             VL, VU

*     ..
*     .. Array Arguments ..
      INTEGER            ISUPPZ( * ), IWORK( * )
      REAL               D( * ), E( * ), W( * ), WORK( * )
      REAL               Z( LDZ, * )
*     ..
*
*  Purpose
*  =======
*
*  SSTEGR2 computes selected eigenvalues and, optionally, eigenvectors
*  of a real symmetric tridiagonal matrix T. It is invoked in the
*  ScaLAPACK MRRR driver PSSYEVR and the corresponding Hermitian
*  version either when only eigenvalues are to be computed, or when only
*  a single processor is used (the sequential-like case).
*
*  SSTEGR2 has been adapted from LAPACK's SSTEGR. Please note the
*  following crucial changes.
*
*  1. The calling sequence has two additional INTEGER parameters,
*     DOL and DOU, that should satisfy M>=DOU>=DOL>=1.
*     SSTEGR2  ONLY computes the eigenpairs
*     corresponding to eigenvalues DOL through DOU in W. (That is,
*     instead of computing the eigenpairs belonging to W(1)
*     through W(M), only the eigenvectors belonging to eigenvalues
*     W(DOL) through W(DOU) are computed. In this case, only the
*     eigenvalues DOL:DOU are guaranteed to be fully accurate.
*
*  2. M is NOT the number of eigenvalues specified by RANGE, but is
*     M = DOU - DOL + 1. This concerns the case where only eigenvalues
*     are computed, but on more than one processor. Thus, in this case
*     M refers to the number of eigenvalues computed on this processor.
*
*  3. The arrays W and Z might not contain all the wanted eigenpairs
*     locally, instead this information is distributed over other
*     processors.
*
*  Arguments
*  =========
*
*  JOBZ    (input) CHARACTER*1
*          = 'N':  Compute eigenvalues only;
*          = 'V':  Compute eigenvalues and eigenvectors.
*
*  RANGE   (input) CHARACTER*1
*          = 'A': all eigenvalues will be found.
*          = 'V': all eigenvalues in the half-open interval (VL,VU]
*                 will be found.
*          = 'I': the IL-th through IU-th eigenvalues will be found.
*
*  N       (input) INTEGER
*          The order of the matrix.  N >= 0.
*
*  D       (input/output) REAL array, dimension (N)
*          On entry, the N diagonal elements of the tridiagonal matrix
*          T. On exit, D is overwritten.
*
*  E       (input/output) REAL array, dimension (N)
*          On entry, the (N-1) subdiagonal elements of the tridiagonal
*          matrix T in elements 1 to N-1 of E. E(N) need not be set on
*          input, but is used internally as workspace.
*          On exit, E is overwritten.
*
*  VL      (input) REAL
*  VU      (input) REAL
*          If RANGE='V', the lower and upper bounds of the interval to
*          be searched for eigenvalues. VL < VU.
*          Not referenced if RANGE = 'A' or 'I'.
*
*  IL      (input) INTEGER
*  IU      (input) INTEGER
*          If RANGE='I', the indices (in ascending order) of the
*          smallest and largest eigenvalues to be returned.
*          1 <= IL <= IU <= N, if N > 0.
*          Not referenced if RANGE = 'A' or 'V'.
*
*  M       (output) INTEGER
*          Globally summed over all processors, M equals
*          the total number of eigenvalues found.  0 <= M <= N.
*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
*          The local output equals M = DOU - DOL + 1.
*
*  W       (output) REAL array, dimension (N)
*          The first M elements contain the selected eigenvalues in
*          ascending order. Note that immediately after exiting this
*          routine, only the eigenvalues from
*          position DOL:DOU are to reliable on this processor
*          because the eigenvalue computation is done in parallel.
*          Other processors will hold reliable information on other
*          parts of the W array. This information is communicated in
*          the ScaLAPACK driver.
*
*  Z       (output) REAL array, dimension (LDZ, max(1,M) )
*          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
*          contain some of the orthonormal eigenvectors of the matrix T
*          corresponding to the selected eigenvalues, with the i-th
*          column of Z holding the eigenvector associated with W(i).
*          If JOBZ = 'N', then Z is not referenced.
*          Note: the user must ensure that at least max(1,M) columns are
*          supplied in the array Z; if RANGE = 'V', the exact value of M
*          is not known in advance and can be computed with a workspace
*          query by setting NZC = -1, see below.
*
*  LDZ     (input) INTEGER
*          The leading dimension of the array Z.  LDZ >= 1, and if
*          JOBZ = 'V', then LDZ >= max(1,N).
*
*  NZC     (input) INTEGER
*          The number of eigenvectors to be held in the array Z.
*          If RANGE = 'A', then NZC >= max(1,N).
*          If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
*          If RANGE = 'I', then NZC >= IU-IL+1.
*          If NZC = -1, then a workspace query is assumed; the
*          routine calculates the number of columns of the array Z that
*          are needed to hold the eigenvectors.
*          This value is returned as the first entry of the Z array, and
*          no error message related to NZC is issued.
*
*  ISUPPZ  (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
*          The support of the eigenvectors in Z, i.e., the indices
*          indicating the nonzero elements in Z. The i-th computed eigenvector
*          is nonzero only in elements ISUPPZ( 2*i-1 ) through
*          ISUPPZ( 2*i ). This is relevant in the case when the matrix
*          is split. ISUPPZ is only set if N>2.
*
*  WORK    (workspace/output) REAL array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal
*          (and minimal) LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK. LWORK >= max(1,18*N)
*          if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued.
*
*  IWORK   (workspace/output) INTEGER array, dimension (LIWORK)
*          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
*
*  LIWORK  (input) INTEGER
*          The dimension of the array IWORK.  LIWORK >= max(1,10*N)
*          if the eigenvectors are desired, and LIWORK >= max(1,8*N)
*          if only the eigenvalues are to be computed.
*          If LIWORK = -1, then a workspace query is assumed; the
*          routine only calculates the optimal size of the IWORK array,
*          returns this value as the first entry of the IWORK array, and
*          no error message related to LIWORK is issued.
*
*  DOL     (input) INTEGER
*  DOU     (input) INTEGER
*          From the eigenvalues W(1:M), only eigenvectors
*          Z(:,DOL) to Z(:,DOU) are computed.
*          If DOL > 1, then Z(:,DOL-1-ZOFFSET) is used and overwritten.
*          If DOU < M, then Z(:,DOU+1-ZOFFSET) is used and overwritten.
*
*  ZOFFSET (input) INTEGER
*          Offset for storing the eigenpairs when Z is distributed
*          in 1D-cyclic fashion
*
*  INFO    (output) INTEGER
*          On exit, INFO
*          = 0:  successful exit
*          other:if INFO = -i, the i-th argument had an illegal value
*                if INFO = 10X, internal error in SLARRE2,
*                if INFO = 20X, internal error in SLARRV.
*                Here, the digit X = ABS( IINFO ) < 10, where IINFO is
*                the nonzero error code returned by SLARRE2 or
*                SLARRV, respectively.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE, FOUR, MINRGP
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0,
     $                     FOUR = 4.0E0,
     $                     MINRGP = 3.0E-3 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
      INTEGER            I, IIL, IINDBL, IINDW, IINDWK, IINFO, IINSPL,
     $                   IIU, INDE2, INDERR, INDGP, INDGRS, INDWRK,
     $                   ITMP, ITMP2, J, JJ, LIWMIN, LWMIN, NSPLIT,
     $                   NZCMIN
      REAL               BIGNUM, EPS, PIVMIN, RMAX, RMIN, RTOL1, RTOL2,
     $                   SAFMIN, SCALE, SMLNUM, THRESH, TMP, TNRM, WL,
     $                   WU
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SLAMCH, SLANST
      EXTERNAL           LSAME, SLAMCH, SLANST
*     ..
*     .. External Subroutines ..
      EXTERNAL           SCOPY, SLAE2, SLAEV2, SLARRC, SLARRE2,
     $                   SLARRV, SLASRT, SSCAL, SSWAP
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      WANTZ = LSAME( JOBZ, 'V' )
      ALLEIG = LSAME( RANGE, 'A' )
      VALEIG = LSAME( RANGE, 'V' )
      INDEIG = LSAME( RANGE, 'I' )
*
      LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
      ZQUERY = ( NZC.EQ.-1 )

*     SSTEGR2 needs WORK of size 6*N, IWORK of size 3*N.
*     In addition, SLARRE2 needs WORK of size 6*N, IWORK of size 5*N.
*     Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N.
      IF( WANTZ ) THEN
         LWMIN = 18*N
         LIWMIN = 10*N
      ELSE
*        need less workspace if only the eigenvalues are wanted
         LWMIN = 12*N
         LIWMIN = 8*N
      ENDIF

      WL = ZERO
      WU = ZERO
      IIL = 0
      IIU = 0

      IF( VALEIG ) THEN
*        We do not reference VL, VU in the cases RANGE = 'I','A'
*        The interval (WL, WU] contains all the wanted eigenvalues.
*        It is either given by the user or computed in SLARRE2.
         WL = VL
         WU = VU
      ELSEIF( INDEIG ) THEN
*        We do not reference IL, IU in the cases RANGE = 'V','A'
         IIL = IL
         IIU = IU
      ENDIF
*
      INFO = 0
      IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
         INFO = -7
      ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
         INFO = -8
      ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
         INFO = -9
      ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
         INFO = -13
      ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -17
      ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
         INFO = -19
      END IF
*
*     Get machine constants.
*
      SAFMIN = SLAMCH( 'Safe minimum' )
      EPS = SLAMCH( 'Precision' )
      SMLNUM = SAFMIN / EPS
      BIGNUM = ONE / SMLNUM
      RMIN = SQRT( SMLNUM )
      RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
*
      IF( INFO.EQ.0 ) THEN
         WORK( 1 ) = LWMIN
         IWORK( 1 ) = LIWMIN
*
         IF( WANTZ .AND. ALLEIG ) THEN
            NZCMIN = N
            IIL = 1
            IIU = N
         ELSE IF( WANTZ .AND. VALEIG ) THEN
            CALL SLARRC( 'T', N, VL, VU, D, E, SAFMIN,
     $                            NZCMIN, ITMP, ITMP2, INFO )
            IIL = ITMP+1
            IIU = ITMP2
         ELSE IF( WANTZ .AND. INDEIG ) THEN
            NZCMIN = IIU-IIL+1
         ELSE
*           WANTZ .EQ. FALSE.
            NZCMIN = 0
         ENDIF
         IF( ZQUERY .AND. INFO.EQ.0 ) THEN
            Z( 1,1 ) = NZCMIN
         ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
            INFO = -14
         END IF
      END IF

      IF ( WANTZ ) THEN
         IF ( DOL.LT.1 .OR. DOL.GT.NZCMIN ) THEN
            INFO = -20
         ENDIF
         IF ( DOU.LT.1 .OR. DOU.GT.NZCMIN .OR. DOU.LT.DOL) THEN
            INFO = -21
         ENDIF
      ENDIF

      IF( INFO.NE.0 ) THEN
*
C         Disable sequential error handler
C         for parallel case
C         CALL XERBLA( 'SSTEGR2', -INFO )
*
         RETURN
      ELSE IF( LQUERY .OR. ZQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      M = 0
      IF( N.EQ.0 )
     $   RETURN
*
      IF( N.EQ.1 ) THEN
         IF( ALLEIG .OR. INDEIG ) THEN
            M = 1
            W( 1 ) = D( 1 )
         ELSE
            IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
               M = 1
               W( 1 ) = D( 1 )
            END IF
         END IF
         IF( WANTZ )
     $      Z( 1, 1 ) = ONE
         RETURN
      END IF
*
      INDGRS = 1
      INDERR = 2*N + 1
      INDGP = 3*N + 1
      INDE2 = 5*N + 1
      INDWRK = 6*N + 1
*
      IINSPL = 1
      IINDBL = N + 1
      IINDW = 2*N + 1
      IINDWK = 3*N + 1
*
*     Scale matrix to allowable range, if necessary.
*
      SCALE = ONE
      TNRM = SLANST( 'M', N, D, E )
      IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
         SCALE = RMIN / TNRM
      ELSE IF( TNRM.GT.RMAX ) THEN
         SCALE = RMAX / TNRM
      END IF
      IF( SCALE.NE.ONE ) THEN
         CALL SSCAL( N, SCALE, D, 1 )
         CALL SSCAL( N-1, SCALE, E, 1 )
         TNRM = TNRM*SCALE
         IF( VALEIG ) THEN
*           If eigenvalues in interval have to be found,
*           scale (WL, WU] accordingly
            WL = WL*SCALE
            WU = WU*SCALE
         ENDIF
      END IF
*
*     Compute the desired eigenvalues of the tridiagonal after splitting
*     into smaller subblocks if the corresponding off-diagonal elements
*     are small
*     THRESH is the splitting parameter for SLARRE2
*     A negative THRESH forces the old splitting criterion based on the
*     size of the off-diagonal. A positive THRESH switches to splitting
*     which preserves relative accuracy.
*
      IINFO = -1
*     Set the splitting criterion
      IF (IINFO.EQ.0) THEN
         THRESH = EPS
      ELSE
         THRESH = -EPS
      ENDIF
*
*     Store the squares of the offdiagonal values of T
      DO 5 J = 1, N-1
         WORK( INDE2+J-1 ) = E(J)**2
 5    CONTINUE

*     Set the tolerance parameters for bisection
      IF( .NOT.WANTZ ) THEN
*        SLARRE2 computes the eigenvalues to full precision.
         RTOL1 = FOUR * EPS
         RTOL2 = FOUR * EPS
      ELSE
*        SLARRE2 computes the eigenvalues to less than full precision.
*        SLARRV will refine the eigenvalue approximations, and we can
*        need less accurate initial bisection in SLARRE2.
*        Note: these settings do only affect the subset case and SLARRE2
         RTOL1 = SQRT(EPS)
         RTOL2 = MAX( SQRT(EPS)*5.0E-3, FOUR * EPS )
      ENDIF
      CALL SLARRE2( RANGE, N, WL, WU, IIL, IIU, D, E,
     $             WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
     $             IWORK( IINSPL ), M, DOL, DOU,
     $             W, WORK( INDERR ),
     $             WORK( INDGP ), IWORK( IINDBL ),
     $             IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
     $             WORK( INDWRK ), IWORK( IINDWK ), IINFO )
      IF( IINFO.NE.0 ) THEN
         INFO = 100 + ABS( IINFO )
         RETURN
      END IF
*     Note that if RANGE .NE. 'V', SLARRE2 computes bounds on the desired
*     part of the spectrum. All desired eigenvalues are contained in
*     (WL,WU]

      IF( WANTZ ) THEN
*
*        Compute the desired eigenvectors corresponding to the computed
*        eigenvalues
*
         CALL SLARRV( N, WL, WU, D, E,
     $                PIVMIN, IWORK( IINSPL ), M,
     $                DOL, DOU, MINRGP, RTOL1, RTOL2,
     $                W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
     $                IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
     $                ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
         IF( IINFO.NE.0 ) THEN
            INFO = 200 + ABS( IINFO )
            RETURN
         END IF
      ELSE
*        SLARRE2 computes eigenvalues of the (shifted) root representation
*        SLARRV returns the eigenvalues of the unshifted matrix.
*        However, if the eigenvectors are not desired by the user, we need
*        to apply the corresponding shifts from SLARRE2 to obtain the
*        eigenvalues of the original matrix.
         DO 20 J = 1, M
            ITMP = IWORK( IINDBL+J-1 )
            W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
 20      CONTINUE
      END IF
*

*
*     If matrix was scaled, then rescale eigenvalues appropriately.
*
      IF( SCALE.NE.ONE ) THEN
         CALL SSCAL( M, ONE / SCALE, W, 1 )
      END IF
*
*     Correct M if needed
*
      IF ( WANTZ ) THEN
         IF( DOL.NE.1 .OR. DOU.NE.M ) THEN
            M = DOU - DOL +1
         ENDIF
      ENDIF
*
*     If eigenvalues are not in increasing order, then sort them,
*     possibly along with eigenvectors.
*
      IF( NSPLIT.GT.1 ) THEN
         IF( .NOT. WANTZ ) THEN
            CALL SLASRT( 'I', DOU - DOL +1, W(DOL), IINFO )
            IF( IINFO.NE.0 ) THEN
               INFO = 3
               RETURN
            END IF
         ELSE
            DO 60 J = DOL, DOU - 1
               I = 0
               TMP = W( J )
               DO 50 JJ = J + 1, M
                  IF( W( JJ ).LT.TMP ) THEN
                     I = JJ
                     TMP = W( JJ )
                  END IF
 50            CONTINUE
               IF( I.NE.0 ) THEN
                  W( I ) = W( J )
                  W( J ) = TMP
                  IF( WANTZ ) THEN
                     CALL SSWAP( N, Z( 1, I-ZOFFSET ),
     $                                 1, Z( 1, J-ZOFFSET ), 1 )
                     ITMP = ISUPPZ( 2*I-1 )
                     ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
                     ISUPPZ( 2*J-1 ) = ITMP
                     ITMP = ISUPPZ( 2*I )
                     ISUPPZ( 2*I ) = ISUPPZ( 2*J )
                     ISUPPZ( 2*J ) = ITMP
                  END IF
               END IF
 60         CONTINUE
         END IF
      ENDIF
*
      WORK( 1 ) = LWMIN
      IWORK( 1 ) = LIWMIN
      RETURN
*
*     End of SSTEGR2
*
      END


!===============================================================================
! One of Andy Nowacki's Fortran utility modules for dealing with seismic
! anisotropy and other problems.
!
! Andy Nowacki <andy.nowacki@bristol.ac.uk>
!
! See the file LICENCE for licence details.
!===============================================================================
program xyz2lonlat
!===============================================================================
!  Reads sets of x,y,z from stdin and writes out lon,lat,radius

   use spherical_geometry, only: cart2geog

   implicit none

   real(8) :: lon, lat, r, x, y, z, val, norm_rad
   character(len=250) :: arg
   integer :: iostat
   logical :: norm = .false., value = .false.

!  Check input arguments
   call get_args

   ! Get coordinates from stdin
   iostat = 0
   do while (iostat == 0)
      if (value) then
         read(*,*,iostat=iostat) x, y, z, val
      else
         read(*,*,iostat=iostat) x, y, z
      endif
      if (iostat < 0) exit
      if (iostat > 0) then
         write(0,'(a)') 'lonlat2xyz: problem reading coordinates from stdin.'
         stop 1
      endif
      call cart2geog(x, y, z, lat, lon, r, degrees=.true.)
      if (norm) r = r*norm_rad
      if (value) then
         write(*,*) lon, lat, r, val
      else
         write(*,*) lon, lat, r
      endif
   enddo

contains
   !===============================================================================
   subroutine get_args()
   !===============================================================================
      integer :: iarg, narg
      narg = command_argument_count()
      iarg = 1
      do while (iarg <= narg)
         call get_command_argument(iarg, arg)
         select case(arg)
            case('-n')
               norm = .true.
               call get_command_argument(iarg+1, arg)
               read(arg,*) norm_rad
               iarg = iarg + 2
            case('-v')
               value = .true.
               iarg = iarg + 1
            case('-h')
               call usage(.true.)
            case default
               call usage
         end select
      enddo
   end subroutine get_args
   !-------------------------------------------------------------------------------

   !===============================================================================
   subroutine usage(help)
   !===============================================================================
      logical, intent(in), optional :: help
      integer :: unit
      unit = 0
      if (present(help)) then
         if (help) unit = 6
      endif
      write(0,'(a)') &
         'Usage: xyz2lonlat (options) < [x] [y] [z] (value)', &
         'Reads cartesian coordinates from stdin and writes geographic to stdout.', &
         'Options:', &
         '   -n [norm] : Scale the points radius by <norm>', &
         '   -v        : Output the value in the third/fourth column'
      if (present(help)) then
         if (help) stop
      endif
      error stop
   end subroutine usage
   !-------------------------------------------------------------------------------

end program xyz2lonlat
!-------------------------------------------------------------------------------


 SUBROUTINE ZGBSV_F95( A, B, KL, IPIV, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => DP
    USE LA_AUXMOD, ONLY: ERINFO
    USE F77_LAPACK, ONLY: GBSV_F77 => LA_GBSV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    INTEGER, INTENT(IN), OPTIONAL :: KL
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL, TARGET :: IPIV(:)
    COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!      LA_GBSV computes the solution to a real or complex linear system
! of equations A*X = B, where A is a square band matrix and X and B are
! rectangular matrices or vectors. The LU decomposition with row
! interchanges is used to factor A as A = L*U , where L is a product of
! permutation and unit lower triangular matrices with kl subdiagonals,
! and U is upper triangular with kl + ku superdiagonals. The factored
! form of A is then used to solve the above system.
!
! =========
!
!       SUBROUTINE LA_GBSV( AB, B, KL=kl, IPIV=ipiv, INFO=info )
!             <type>(<wp>), INTENT(INOUT) :: AB(:,:), <rhs>
!             INTEGER, INTENT(IN), OPTIONAL :: KL
!             INTEGER, INTENT(OUT), OPTIONAL :: IPIV(:)
!             INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!             <type> ::= REAL | COMPLEX
!             <wp>   ::= KIND(1.0) | KIND(1.0D0)
!             <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! AB      (input/output) REAL or COMPLEX rectangular array, shape (:,:)
!         with size(AB,1) = 2*kl+ku+1 and size(AB,2) = n, where kl and ku
!         are, respectively, the numbers of subdiagonals and
!         superdiagonals in the band of A, and n is the order of A.
!         On entry, the matrix A in band storage. The (kl + ku + 1)
! 	  diagonals of A are stored in rows (kl + 1) to (2*kl + ku + 1)
! 	  of AB, so that the j-th column of A is stored in the j-th
! 	  column of AB as follows:
! 	  AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl)
! 	                                 1<=j<=n
!         The remaining elements in AB need not be set.
!         On exit, details of the factorization. U is an upper triangular
!         band matrix with (kl + ku + 1) diagonals. These are stored in
! 	  the first (kl + ku + 1) rows of AB. The multipliers that arise
!         during the factorization are stored in the remaining rows.
! B       (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(B,1) = n or shape (:) with size(B) = n.
!         On entry, the matrix B.
!         On exit, the solution matrix X.
! KL      Optional (input) INTEGER.
!         The number of subdiagonals in the band of A (KL = kl).
!         The number of superdiagonals in the band is given by
! 	  ku = size(AB,1) - 2 * kl - 1.
!         Default value: (size(AB,1)-1)/3.
! IPIV    Optional (output) INTEGER array, shape (:) with size(IPIV) = n.
!         The pivot indices that define the row interchanges; row i of the
!         matrix was interchanged with row IPIV(i).
! INFO    Optional (output) INTEGER
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: if INFO = i, U(i,i) = 0. The factorization has been
!         completed, but the factor U is singular, so the solution could
!         not be computed.
!         If INFO is not present and an error occurs, then the program
!         is terminated with an error message.
!----------------------------------------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GBSV'
!   .. LOCAL SCALARS ..
    INTEGER :: LINFO, ISTAT, ISTAT1, SIPIV, LDA, N, NRHS, LKL, KU
!   .. LOCAL POINTERS ..
    INTEGER, POINTER :: LPIV(:)
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; ISTAT = 0
    LDA = SIZE(A,1); N = SIZE(A,2); NRHS = SIZE(B,2)
    IF( PRESENT(KL) ) THEN; LKL = KL; ELSE; LKL = (LDA-1)/3; ENDIF
    IF( PRESENT(IPIV) )THEN; SIPIV = SIZE(IPIV); ELSE; SIPIV = N; ENDIF
!   .. TEST THE ARGUMENTS
    IF( LDA - 2*LKL -1 < 0 .OR. LDA < 0 .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B, 1 ) /= N .OR. NRHS < 0 ) THEN; LINFO = -2
    ELSE IF( LDA - 2*LKL -1 < 0 .OR. LKL < 0 ) THEN; LINFO = -3
    ELSE IF( SIPIV /= N )THEN; LINFO = -4
    ELSE IF ( N > 0 ) THEN
       IF( PRESENT(IPIV) )THEN; LPIV => IPIV; ELSE
           ALLOCATE( LPIV(N), STAT = ISTAT ); END IF
       IF ( ISTAT == 0 ) THEN
          KU = LDA -2*LKL -1
          CALL GBSV_F77( N, LKL, KU, NRHS, A, LDA, LPIV, B, N, LINFO )
       ELSE
          LINFO = -100
       END IF
       IF( .NOT.PRESENT(IPIV) )THEN
          DEALLOCATE(LPIV, STAT = ISTAT1 )
       END IF
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
 END SUBROUTINE ZGBSV_F95


    MODULE cdf_normal_mod
! ----------------------------------------------------------------------

!                              cdf_normal_mod
!                              *=*=*=*=*=*=*=

!  -  SUBROUTINE CDF_NORMAL(WHICH, CUM, CCUM, X, MEAN, SD, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CUM_NORMAL(X, MEAN, SD,  STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION CCUM_NORMAL(X, MEAN, SD, STATUS, CHECK_INPUT)
!  -  REAL (dpkind) FUNCTION INV_NORMAL(CUM, CCUM, MEAN, SD, STATUS,
!                                       CHECK_INPUT)

!                             The Distribution
!                             ================

!         The density of the normal distribution is proportional to:

!                                 (         2)
!                                 ( (X-MEAN) )
!                              exp(----------)
!                                 (       2  )
!                                 (   2 SD   )

!                                Arguments
!                                =========

!  - INTEGER, INTENT(IN) :: WHICH. Integer indicating which of the next
!    arguments is to be calculated.
!  Input Range: [ 1:4 ]
!     1.  CUM and CCUM
!     2.  X
!     3.  MEAN
!     4.  SD
!  - REAL (dpkind), OPTIONAL :: CUM. The CDF of the normal distribution.
!  Range: [ 10^-10:1-10^-10 ]
!  - REAL (dpkind), OPTIONAL :: CCUM. One minus the CDF of the normal
!    distribution.
!  Range: [ 10^-10:1-10^-10 ]
!  - REAL (dpkind) :: X. The upper limit of integration of the normal
!    density. The lower limit is -oo.
!  Range: [ -10^100:10^100 ]
!  - REAL (dpkind), OPTIONAL:: MEAN. The mean of the normal distribution.
!    If omitted, the value 0 is used.
!  Range: [ -10^100:10^100 ]
!  - REAL (dpkind), OPTIONAL:: SD. The standard deviation of the normal
!    distribution. If omitted, the value 1 is used.
!  Range: [ 10^-10:10^100 ]
!  - INTEGER, INTENT(OUT), OPTIONAL :: STATUS. Return code. Possible values:
!     -1 WHICH outside input range
!     -2 CUM outside range
!     -3 CCUM outside range
!     -4 X outside range
!     -5 MEAN outside range
!     -6 SD outside range
!      3 CUM + CCUM is not nearly one
!  - LOGICAL, INTENT(IN), OPTIONAL :: CHECK_INPUT. If PRESENT and .TRUE.
!    input argument values are not checked for validity.
! ----------------------------------------------------------------------
! .. Use Statements ..
      USE biomath_constants_mod
      USE biomath_mathlib_mod
      USE cdf_aux_mod
! ..
! .. Default Accessibility ..
      PRIVATE
! ..
! .. Public Statements ..
      PUBLIC :: ccum_normal, cdf_normal, cum_normal, inv_normal
! ..
    CONTAINS

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

      FUNCTION ccum_normal(x,mean,sd,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: ccum_normal
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: mean, sd
        REAL (dpkind) :: x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_normal(which=1,ccum=ccum_normal,x=x,mean=mean,sd=sd, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION ccum_normal

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

      SUBROUTINE cdf_normal(which,cum,ccum,x,mean,sd,status,check_input)
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum, mean, sd
        REAL (dpkind) :: x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        INTEGER, INTENT (IN) :: which
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
! .. Local Arrays ..
        REAL (dpkind) :: params(6)
! ..
! .. Local Scalars ..
        REAL (dpkind) :: local_ccum, local_cum, local_mean, local_sd, z
        LOGICAL :: has_status, local_check_input
! ..
! .. Intrinsic Functions ..
        INTRINSIC PRESENT
! ..
        has_status = PRESENT(status)

! status = 0 means NO error

        IF (has_status) THEN
          status = 0
        END IF

! Check presence of arguments and fix up

        CALL check_complements(cum,ccum,the_normal%name,'cum','ccum', &
          local_cum,local_ccum,set_values=which/=1,bad_status=3, &
          status=status)

        IF (has_status) THEN
          IF (status/=0) THEN
            RETURN
          END IF
        END IF

        IF (PRESENT(mean)) THEN
          local_mean = mean
        ELSE
          local_mean = zero
        END IF

        IF (PRESENT(sd)) THEN
          local_sd = sd
        ELSE
          local_sd = one
        END IF

        params(1) = local_cum
        params(2) = local_ccum
        params(3) = x
        params(4) = local_mean
        params(5) = local_sd

        IF (PRESENT(check_input)) THEN
          local_check_input = check_input
        ELSE
          local_check_input = .TRUE.
        END IF

!!! Check for consistency of which and answer

        IF (local_check_input) THEN

          IF (which==3 .AND. .NOT. PRESENT(mean)) CALL which_miss(which, &
            the_normal%name,'mean')

          IF (which==4 .AND. .NOT. PRESENT(sd)) CALL which_miss(which, &
            the_normal%name,'sd')

          CALL validate_parameters(the_normal,which,params,status)

          IF (has_status) THEN
            IF (status/=0) THEN
              RETURN
            END IF
          END IF

        END IF

! ++++++++++          ++++++++++          ++++++++++
! Compute the Answers
! ++++++++++          ++++++++++          ++++++++++

        SELECT CASE (which)
        CASE (1)
          z = (x-local_mean)/local_sd

          CALL local_cum_normal(z,local_cum,local_ccum)

          IF (PRESENT(cum)) cum = local_cum
          IF (PRESENT(ccum)) ccum = local_ccum

        CASE (2)
          z = local_inv_normal(local_cum,local_ccum)

          x = local_sd*z + local_mean

        CASE (3)
          z = local_inv_normal(local_cum,local_ccum)

          mean = x - local_sd*z

        CASE (4)
          z = local_inv_normal(local_cum,local_ccum)

          sd = (x-local_mean)/z
        END SELECT

      END SUBROUTINE cdf_normal

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

      FUNCTION cum_normal(x,mean,sd,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: cum_normal
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: mean, sd
        REAL (dpkind) :: x
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_normal(which=1,cum=cum_normal,x=x,mean=mean,sd=sd, &
          status=status,check_input=check_input)

        RETURN

      END FUNCTION cum_normal

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

      FUNCTION inv_normal(cum,ccum,mean,sd,status,check_input)
! .. Function Return Value ..
        REAL (dpkind) :: inv_normal
! ..
! .. Scalar Arguments ..
        REAL (dpkind), OPTIONAL :: ccum, cum, mean, sd
        INTEGER, OPTIONAL, INTENT (OUT) :: status
        LOGICAL, OPTIONAL, INTENT (IN) :: check_input
! ..
        CALL cdf_normal(which=2,cum=cum,ccum=ccum,x=inv_normal,mean=mean, &
          sd=sd,status=status,check_input=check_input)

        RETURN

      END FUNCTION inv_normal

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

      SUBROUTINE local_cum_normal(arg,result,ccum)
!----------------------------------------------------------------------

!                              Function

!     Computes the cumulative  of    the  normal   distribution,   i.e.,
!     the integral from -infinity to x of
!          (1/sqrt(2*pi)) exp(-u*u/2) du
!     X --> Upper limit of integration.
!                                        X is DOUBLE PRECISION
!     RESULT <-- Cumulative normal distribution.
!                                        RESULT is DOUBLE PRECISION
!     CCUM <-- Compliment of Cumulative normal distribution.
!                                        CCUM is DOUBLE PRECISION
!     Renaming of function ANORM from:
!     Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN
!     Package of Special Function Routines and Test Drivers"
!     acm Transactions on Mathematical Software. 19, 22-32.
!     with slight modifications to return ccum and to deal with
!     machine constants.
!----------------------------------------------------------------------
! Original Comments:
!------------------------------------------------------------------
! This function evaluates the normal distribution function:
!                              / x
!                     1       |       -t*t/2
!          P(x) = ----------- |      e       dt
!                 sqrt(2 pi)  |
!                             /-oo
!   The main computation evaluates near-minimax approximations
!   derived from those in "Rational Chebyshev approximations for
!   the error function" by W. J. Cody, Math. Comp., 1969, 631-637.
!   This transportable program uses rational functions that
!   theoretically approximate the normal distribution function to
!   at least 18 significant decimal digits.  The accuracy achieved
!   depends on the arithmetic system, the compiler, the intrinsic
!   functions, and proper selection of the machine-dependent
!   constants.
!*******************************************************************
!*******************************************************************
! Explanation of machine-dependent constants.
!   MIN   = smallest machine representable number.
!   EPS   = argument below which anorm(x) may be represented by
!           0.5  and above which  x*x  will not underflow.
!           A conservative value is the largest machine number X
!           such that   1.0 + X = 1.0   to machine precision.
!*******************************************************************
!*******************************************************************
! Error returns
!  The program returns  ANORM = 0     for  ARG .LE. XLOW.
! Intrinsic functions required are:
!     ABS, AINT, EXP
!  Author: W. J. Cody
!          Mathematics and Computer Science Division
!          Argonne National Laboratory
!          Argonne, IL 60439
!  Latest modification: March 15, 1992
!------------------------------------------------------------------
!------------------------------------------------------------------
!  Mathematical constants
!  SQRPI = 1 / sqrt(2*pi), ROOT32 = sqrt(32), and
!  THRSH is the argument for which anorm = 0.75.
!------------------------------------------------------------------
!------------------------------------------------------------------
!  Coefficients for approximation in first interval
!------------------------------------------------------------------
!------------------------------------------------------------------
!  Coefficients for approximation in second interval
!------------------------------------------------------------------
!------------------------------------------------------------------
!  Coefficients for approximation in third interval
!------------------------------------------------------------------
! .. Scalar Arguments ..
        REAL (dpkind) :: arg, ccum, result
! ..
! .. Local Scalars ..
        REAL (dpkind) :: del, eps, min, temp, x, xden, xnum, xsq, y
        INTEGER :: i
! ..
! .. Intrinsic Functions ..
        INTRINSIC ABS, AINT, EPSILON, EXP, TINY
! ..
! .. Parameters ..
        REAL (dpkind), PARAMETER :: a(5) = (/ &
          2.2352520354606839287E00_dpkind, &
          1.6102823106855587881E02_dpkind, &
          1.0676894854603709582E03_dpkind, &
          1.8154981253343561249E04_dpkind, &
          6.5682337918207449113E-2_dpkind/)
        REAL (dpkind), PARAMETER :: b(4) = (/ &
          4.7202581904688241870E01_dpkind, &
          9.7609855173777669322E02_dpkind, &
          1.0260932208618978205E04_dpkind, &
          4.5507789335026729956E04_dpkind/)
        REAL (dpkind), PARAMETER :: c(9) = (/ &
          3.9894151208813466764E-1_dpkind, &
          8.8831497943883759412E00_dpkind, &
          9.3506656132177855979E01_dpkind, &
          5.9727027639480026226E02_dpkind, &
          2.4945375852903726711E03_dpkind, &
          6.8481904505362823326E03_dpkind, &
          1.1602651437647350124E04_dpkind, &
          9.8427148383839780218E03_dpkind, &
          1.0765576773720192317E-8_dpkind/)
        REAL (dpkind), PARAMETER :: d(8) = (/ &
          2.2266688044328115691E01_dpkind, &
          2.3538790178262499861E02_dpkind, &
          1.5193775994075548050E03_dpkind, &
          6.4855582982667607550E03_dpkind, &
          1.8615571640885098091E04_dpkind, &
          3.4900952721145977266E04_dpkind, &
          3.8912003286093271411E04_dpkind, &
          1.9685429676859990727E04_dpkind/)
        REAL (dpkind), PARAMETER :: p(6) = (/ &
          2.1589853405795699E-1_dpkind, 1.274011611602473639E-1_dpkind, &
          2.2235277870649807E-2_dpkind, 1.421619193227893466E-3_dpkind, &
          2.9112874951168792E-5_dpkind, 2.307344176494017303E-2_dpkind/)
        REAL (dpkind), PARAMETER :: q(5) = (/ &
          1.28426009614491121E00_dpkind, 4.68238212480865118E-1_dpkind, &
          6.59881378689285515E-2_dpkind, 3.78239633202758244E-3_dpkind, &
          7.29751555083966205E-5_dpkind/)
        REAL (dpkind), PARAMETER :: root32 = 5.656854248E0_dpkind
        REAL (dpkind), PARAMETER :: sixten = 1.6_dpkind
        REAL (dpkind), PARAMETER :: sqrpi = &
          3.9894228040143267794E-1_dpkind
        REAL (dpkind), PARAMETER :: thrsh = 0.66291E0_dpkind
! ..
!------------------------------------------------------------------
!  Machine dependent constants
!------------------------------------------------------------------
!        eps = spmpar(1)*0.5E0_dpkind
        eps = EPSILON(one)*half
!        min = spmpar(2)
        min = TINY(one)
!------------------------------------------------------------------
        x = arg
        y = ABS(x)
        IF (y<=thrsh) THEN
!------------------------------------------------------------------
!  Evaluate  anorm  for  |X| <= 0.66291
!------------------------------------------------------------------
          xsq = zero
          IF (y>eps) xsq = x*x
          xnum = a(5)*xsq
          xden = xsq
          xnum = (xnum+a(1))*xsq
          xden = (xden+b(1))*xsq
          xnum = (xnum+a(2))*xsq
          xden = (xden+b(2))*xsq
          xnum = (xnum+a(3))*xsq
          xden = (xden+b(3))*xsq
          result = x*(xnum+a(4))/(xden+b(4))
          temp = result
          result = half + temp
          ccum = half - temp
!------------------------------------------------------------------
!  Evaluate  anorm  for 0.66291 <= |X| <= sqrt(32)
!------------------------------------------------------------------
        ELSE IF (y<=root32) THEN
          xnum = c(9)*y
          xden = y

          DO i = 1, 7
            xnum = (xnum+c(i))*y
            xden = (xden+d(i))*y
          END DO

          result = (xnum+c(8))/(xden+d(8))
          xsq = AINT(y*sixten)/sixten
          del = (y-xsq)*(y+xsq)
          result = EXP(-xsq*xsq*half)*EXP(-del*half)*result
          ccum = one - result

          IF (x>zero) THEN
            temp = result
            result = ccum
            ccum = temp
          END IF

!------------------------------------------------------------------
!  Evaluate  anorm  for |X| > sqrt(32)
!------------------------------------------------------------------
        ELSE
          result = zero
          xsq = one/(x*x)
          xnum = p(6)*xsq
          xden = xsq
          xnum = (xnum+p(1))*xsq
          xden = (xden+q(1))*xsq
          xnum = (xnum+p(2))*xsq
          xden = (xden+q(2))*xsq
          xnum = (xnum+p(3))*xsq
          xden = (xden+q(3))*xsq
          xnum = (xnum+p(4))*xsq
          xden = (xden+q(4))*xsq
          result = xsq*(xnum+p(5))/(xden+q(5))
          result = (sqrpi-result)/y
          xsq = AINT(x*sixten)/sixten
          del = (x-xsq)*(x+xsq)
          result = EXP(-xsq*xsq*half)*EXP(-del*half)*result
          ccum = one - result

          IF (x>zero) THEN
            temp = result
            result = ccum
            ccum = temp
          END IF

        END IF

        IF (result<min) result = zero
        IF (ccum<min) ccum = zero

      END SUBROUTINE local_cum_normal

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

      FUNCTION local_inv_normal(cum,ccum)
!----------------------------------------------------------------------
! ALGORITHM AS241  APPL. STATIST. (1988) VOL. 37, NO. 3
! Produces the normal deviate Z corresponding to a given lower
! tail area of P; Z is accurate to about 1 part in 10**16.
! cum is the desired area to the left of local_inv_normal
! ccum is the desired area to the right
! A higher level of code checks ranges on cum and ccum and assures
! that they sum to one.
! This ELF90-compatible version by Alan Miller - 20 August 1996
! N.B. The original algorithm is as a function; this is a subroutine
! Code modified  (but not in logic) by Barry W. Brown
! May,2001 for incorporation into dcdflib90.
! The code is again a function
!----------------------------------------------------------------------
! .. Parameters ..
        REAL (dpkind), PARAMETER :: a(8) = (/ &
          3.3871328727963666080E0_dpkind, 1.3314166789178437745E+2_dpkind &
          , 1.9715909503065514427E+3_dpkind, &
          1.3731693765509461125E+4_dpkind, &
          4.5921953931549871457E+4_dpkind, &
          6.7265770927008700853E+4_dpkind, &
          3.3430575583588128105E+4_dpkind, &
          2.5090809287301226727E+3_dpkind/)
        REAL (dpkind), PARAMETER :: b(8) = (/ 1.0_dpkind, &
          4.2313330701600911252E+1_dpkind, &
          6.8718700749205790830E+2_dpkind, &
          5.3941960214247511077E+3_dpkind, &
          2.1213794301586595867E+4_dpkind, &
          3.9307895800092710610E+4_dpkind, &
          2.8729085735721942674E+4_dpkind, &
          5.2264952788528545610E+3_dpkind/)
        REAL (dpkind), PARAMETER :: c(8) = (/ &
          1.42343711074968357734E0_dpkind, &
          4.63033784615654529590E0_dpkind, &
          5.76949722146069140550E0_dpkind, &
          3.64784832476320460504E0_dpkind, &
          1.27045825245236838258E0_dpkind, &
          2.41780725177450611770E-1_dpkind, &
          2.27238449892691845833E-2_dpkind, &
          7.74545014278341407640E-4_dpkind/)
        REAL (dpkind), PARAMETER :: d(8) = (/ 1.0_dpkind, &
          2.05319162663775882187E0_dpkind, &
          1.67638483018380384940E0_dpkind, &
          6.89767334985100004550E-1_dpkind, &
          1.48103976427480074590E-1_dpkind, &
          1.51986665636164571966E-2_dpkind, &
          5.47593808499534494600E-4_dpkind, &
          1.05075007164441684324E-9_dpkind/)
        REAL (dpkind), PARAMETER :: e(8) = (/ &
          6.65790464350110377720E0_dpkind, &
          5.46378491116411436990E0_dpkind, &
          1.78482653991729133580E0_dpkind, &
          2.96560571828504891230E-1_dpkind, &
          2.65321895265761230930E-2_dpkind, &
          1.24266094738807843860E-3_dpkind, &
          2.71155556874348757815E-5_dpkind, &
          2.01033439929228813265E-7_dpkind/)
        REAL (dpkind), PARAMETER :: f(8) = (/ 1.0_dpkind, &
          5.99832206555887937690E-1_dpkind, &
          1.36929880922735805310E-1_dpkind, &
          1.48753612908506148525E-2_dpkind, &
          7.86869131145613259100E-4_dpkind, &
          1.84631831751005468180E-5_dpkind, &
          1.42151175831644588870E-7_dpkind, &
          2.04426310338993978564E-15_dpkind/)
        REAL (dpkind), PARAMETER :: const1 = 0.180625E0_dpkind
        REAL (dpkind), PARAMETER :: const2 = 1.6E0_dpkind
        REAL (dpkind), PARAMETER :: split1 = 0.425E0_dpkind
        REAL (dpkind), PARAMETER :: split2 = 5.E0_dpkind
! ..
! .. Scalar Arguments ..
        REAL (dpkind), INTENT (IN) :: ccum, cum
! ..
! .. Local Scalars ..
        REAL (dpkind) :: p, q, r
! ..
! .. Function Return Value ..
        REAL (dpkind) :: local_inv_normal
! ..
! .. Intrinsic Functions ..
        INTRINSIC ABS, LOG, MIN, SQRT
! ..
        p = MIN(cum,ccum)

        IF (p==half) THEN
          local_inv_normal = zero

          RETURN
        END IF

        q = p - half

        IF (ABS(q)<=split1) THEN
          r = const1 - q*q
          local_inv_normal = q*evaluate_polynomial(a,r)/ &
            evaluate_polynomial(b,r)
        ELSE
          r = SQRT(-LOG(p))

          IF (r<=split2) THEN
            r = r - const2
            local_inv_normal = evaluate_polynomial(c,r)/ &
              evaluate_polynomial(d,r)
          ELSE
            r = r - split2
            local_inv_normal = evaluate_polynomial(e,r)/ &
              evaluate_polynomial(f,r)
          END IF

        END IF

        local_inv_normal = ABS(local_inv_normal)

        IF (cum<half) local_inv_normal = -local_inv_normal

        RETURN

      END FUNCTION local_inv_normal

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

    END MODULE cdf_normal_mod


!*****************************************************************************************
!>
!  Speed test for 1d-6d tensor product b-spline interpolation (object-oriented version).
!
!### Results
!  ![Plot of results](https://raw.githubusercontent.com/jacobwilliams/bspline-fortran/master/src/tests/results/speed_test_oo.png)

    program bspline_speed_test_oo

    use bspline_module
    use bspline_kinds_module, only: wp, ip
    use pyplot_module
    use, intrinsic :: iso_fortran_env

    implicit none

    integer(ip),parameter :: nx = 8_ip   !number of points
    integer(ip),parameter :: ny = 8_ip
    integer(ip),parameter :: nz = 8_ip
    integer(ip),parameter :: nq = 8_ip
    integer(ip),parameter :: nr = 8_ip
    integer(ip),parameter :: ns = 8_ip

    integer(ip),parameter :: kx = 4_ip    !order
    integer(ip),parameter :: ky = 4_ip
    integer(ip),parameter :: kz = 4_ip
    integer(ip),parameter :: kq = 4_ip
    integer(ip),parameter :: kr = 4_ip
    integer(ip),parameter :: ks = 4_ip

    integer(ip),parameter :: n_cases = nx*ny*nz*nq*nr*ns

    real(wp) :: x(nx),y(ny),z(nz),q(nq),r(nr),s(ns)
    real(wp) :: fcn_1d(nx)
    real(wp) :: fcn_2d(nx,ny)
    real(wp) :: fcn_3d(nx,ny,nz)
    real(wp) :: fcn_4d(nx,ny,nz,nq)
    real(wp) :: fcn_5d(nx,ny,nz,nq,nr)
    real(wp) :: fcn_6d(nx,ny,nz,nq,nr,ns)

    type(bspline_1d) :: s1
    type(bspline_2d) :: s2
    type(bspline_3d) :: s3
    type(bspline_4d) :: s4
    type(bspline_5d) :: s5
    type(bspline_6d) :: s6

    real(wp) :: val,sumval
    integer(ip)  :: i,j,k,l,m,n,idx,idy,idz,idq,idr,ids,iflag
    real :: tstart, tend
    type(pyplot) :: plt
    real(wp),dimension(6) :: cases_per_sec
    integer :: istat  !! pyplot-fortran status flag

    idx = 0_ip
    idy = 0_ip
    idz = 0_ip
    idq = 0_ip
    idr = 0_ip
    ids = 0_ip

    x = [ (real(i,wp), i=1,nx) ]
    y = [ (real(i,wp), i=1,ny) ]
    z = [ (real(i,wp), i=1,nz) ]
    q = [ (real(i,wp), i=1,nq) ]
    r = [ (real(i,wp), i=1,nr) ]
    s = [ (real(i,wp), i=1,ns) ]

    !evaluate the functions:

    do i=1,nx
        fcn_1d(i) = f1(x(i))
        do j=1,ny
            fcn_2d(i,j) = f2(x(i),y(j))
            do k=1,nz
                fcn_3d(i,j,k) = f3(x(i),y(j),z(k))
                do l=1,nq
                    fcn_4d(i,j,k,l) = f4(x(i),y(j),z(k),q(l))
                    do m=1,nr
                        fcn_5d(i,j,k,l,m) = f5(x(i),y(j),z(k),q(l),r(m))
                        do n=1,ns
                            fcn_6d(i,j,k,l,m,n) = f6(x(i),y(j),z(k),q(l),r(m),s(n))
                        end do
                    end do
                end do
            end do
        end do
    end do

    !initialize using the constructors:

    s1 = bspline_1d(x,fcn_1d,kx)                         ; if (.not. s1%status_ok()) error stop 'error initializing s1'
    s2 = bspline_2d(x,y,fcn_2d,kx,ky)                    ; if (.not. s1%status_ok()) error stop 'error initializing s2'
    s3 = bspline_3d(x,y,z,fcn_3d,kx,ky,kz)               ; if (.not. s1%status_ok()) error stop 'error initializing s3'
    s4 = bspline_4d(x,y,z,q,fcn_4d,kx,ky,kz,kq)          ; if (.not. s1%status_ok()) error stop 'error initializing s4'
    s5 = bspline_5d(x,y,z,q,r,fcn_5d,kx,ky,kz,kq,kr)     ; if (.not. s1%status_ok()) error stop 'error initializing s5'
    s6 = bspline_6d(x,y,z,q,r,s,fcn_6d,kx,ky,kz,kq,kr,ks); if (.not. s1%status_ok()) error stop 'error initializing s6'

    ! evaluate the interpolants:
    sumval = 0.0_wp
    call cpu_time(tstart)
    do i=1,nx
        do j=1,ny
           do k=1,nz
                do l=1,nq
                    do m=1,nr
                        do n=1,ns
                            call s1%evaluate(x(i),idx,val,iflag)
                            sumval = sumval + val
                        end do
                    end do
                end do
            end do
        end do
    end do
    call cpu_time(tend)
    write(*,*) ''
    write(*,*) '1D'
    write(*,*) 'result         :', sumval
    write(*,*) 'number of cases:', n_cases
    write(*,*) 'cases/sec      :', n_cases/(tend-tstart)
    cases_per_sec(1) = n_cases/(tend-tstart)

    sumval = 0.0_wp
    call cpu_time(tstart)
    do i=1,nx
        do j=1,ny
           do k=1,nz
                do l=1,nq
                    do m=1,nr
                        do n=1,ns
                           call s2%evaluate(x(i),y(j),idx,idy,val,iflag)
                           sumval = sumval + val
                       end do
                   end do
               end do
           end do
       end do
    end do
    call cpu_time(tend)
    write(*,*) ''
    write(*,*) '2D'
    write(*,*) 'result         :', sumval
    write(*,*) 'number of cases:', n_cases
    write(*,*) 'cases/sec      :', n_cases/(tend-tstart)
    cases_per_sec(2) = n_cases/(tend-tstart)

    sumval = 0.0_wp
    call cpu_time(tstart)
    do i=1,nx
        do j=1,ny
           do k=1,nz
                do l=1,nq
                    do m=1,nr
                        do n=1,ns
                            call s3%evaluate(x(i),y(j),z(k),idx,idy,idz,val,iflag)
                            sumval = sumval + val
                        end do
                    end do
                end do
            end do
        end do
    end do
    call cpu_time(tend)
    write(*,*) ''
    write(*,*) '3D'
    write(*,*) 'result         :', sumval
    write(*,*) 'number of cases:', n_cases
    write(*,*) 'cases/sec      :', n_cases/(tend-tstart)
    cases_per_sec(3) = n_cases/(tend-tstart)

    sumval = 0.0_wp
    call cpu_time(tstart)
    do i=1,nx
        do j=1,ny
           do k=1,nz
                do l=1,nq
                    do m=1,nr
                        do n=1,ns
                            call s4%evaluate(x(i),y(j),z(k),q(l),idx,idy,idz,idq,val,iflag)
                            sumval = sumval + val
                        end do
                    end do
                end do
            end do
        end do
    end do
    call cpu_time(tend)
    write(*,*) ''
    write(*,*) '4D'
    write(*,*) 'result         :', sumval
    write(*,*) 'number of cases:', n_cases
    write(*,*) 'cases/sec      :', n_cases/(tend-tstart)
    cases_per_sec(4) = n_cases/(tend-tstart)

    sumval = 0.0_wp
    call cpu_time(tstart)
    do i=1,nx
        do j=1,ny
           do k=1,nz
                do l=1,nq
                    do m=1,nr
                        do n=1,ns
                            call s5%evaluate(x(i),y(j),z(k),q(l),r(m),idx,idy,idz,idq,idr,val,iflag)
                            sumval = sumval + val
                        end do
                    end do
                end do
            end do
        end do
    end do
    call cpu_time(tend)
    write(*,*) ''
    write(*,*) '5D'
    write(*,*) 'result         :', sumval
    write(*,*) 'number of cases:', n_cases
    write(*,*) 'cases/sec      :', n_cases/(tend-tstart)
    cases_per_sec(5) = n_cases/(tend-tstart)

    sumval = 0.0_wp
    call cpu_time(tstart)
    do i=1,nx
        do j=1,ny
           do k=1,nz
                do l=1,nq
                    do m=1,nr
                        do n=1,ns
                            call s6%evaluate(x(i),y(j),z(k),q(l),r(m),s(n),idx,idy,idz,idq,idr,ids,val,iflag)
                            sumval = sumval + val
                        end do
                    end do
                end do
            end do
        end do
    end do
    call cpu_time(tend)
    write(*,*) ''
    write(*,*) '6D'
    write(*,*) 'result         :', sumval
    write(*,*) 'number of cases:', n_cases
    write(*,*) 'cases/sec      :', n_cases/(tend-tstart)
    cases_per_sec(6) = n_cases/(tend-tstart)

    !plot results in bar chart:
    call plt%initialize(grid=.false.,xlabel='Dimension',ylabel='Cases Per Second',&
                        title='Speed Test (Object-Oriented Interface)',legend=.false.,&
                        font_size = 20,&
                        axes_labelsize = 20,&
                        xtick_labelsize = 20,&
                        ytick_labelsize = 20)
    call plt%add_bar(x=real([1,2,3,4,5,6],real64),height=real(cases_per_sec,real64),&
                        label='Speed test runs',&
                        yscale='log',align='center',color='r',istat=istat)
    call plt%savefig('speed_test_oo.png',istat=istat)

    contains

        function f1(x) result(f) !! 1d test function
        implicit none
        real(wp),intent(in) :: x
        real(wp) :: f
        f = x**1.1_wp + x**1.2_wp + x**1.3_wp + x**1.4_wp + x**1.5_wp + x**1.6_wp
        end function f1

        function f2(x,y) result(f) !! 2d test function
        implicit none
        real(wp),intent(in) :: x,y
        real(wp) :: f
        f = x**1.1_wp + y**1.2_wp + x**1.3_wp + y**1.4_wp + x**1.5_wp + y**1.6_wp
        end function f2

        function f3 (x,y,z) result(f) !! 3d test function
        implicit none
        real(wp),intent(in) :: x,y,z
        real(wp) :: f
        f = x**1.1_wp + y**1.2_wp + z**1.3_wp + x**1.4_wp + y**1.5_wp + z**1.6_wp
        end function f3

        function f4 (x,y,z,q) result(f) !! 4d test function
        implicit none
        real(wp),intent(in) :: x,y,z,q
        real(wp) :: f
        f = x**1.1_wp + y**1.2_wp + z**1.3_wp + q**1.4_wp + x**1.5_wp + y**1.6_wp
        end function f4

        function f5 (x,y,z,q,r) result(f) !! 5d test function
        implicit none
        real(wp),intent(in) :: x,y,z,q,r
        real(wp) :: f
        f = x**1.1_wp + y**1.2_wp + z**1.3_wp + q**1.4_wp + r**1.5_wp + x**1.6_wp
        end function f5

        function f6 (x,y,z,q,r,s) result(f) !! 6d test function
        implicit none
        real(wp),intent(in) :: x,y,z,q,r,s
        real(wp) :: f
        f = x**1.1_wp + y**1.2_wp + z**1.3_wp + q**1.4_wp + r**1.5_wp + s**1.6_wp
        end function f6

    end program bspline_speed_test_oo


program pgm
integer :: a(3,3,3), i , j, k, c

c = 1
do i = 1, 3
do j = 1, 3
do k = 1, 3
 a(j,i,k) = c
 c = c + 1
enddo
enddo
enddo

do k = 1, 3
do j = 1, 3
do i = 1, 3
 if (a(k,j,i) <= a(i,j,k)) then
  print *, a(k,j,i)
 endif
enddo
enddo
enddo
end


subroutine compute_surface_tension(nx, ny, surfactant, surface_tension)
    implicit none
    double precision :: beta, kappa, delta, mu, right_film_height
    common /surfactant_config/ beta, kappa, delta, mu, right_film_height

    integer, intent(in) :: nx, ny
    double precision, dimension(nx, ny), intent(in) :: surfactant
    double precision, dimension(nx, ny), intent(out) :: surface_tension

    integer :: ix, iy

    do iy = 1, ny
        do ix = 1, nx
            ! surface_tension(ix, iy) = (1.d0 + mu * surfactant(ix, iy))**(-3)
            surface_tension(ix, iy) = 1.d0 - surfactant(ix, iy)
        end do
    end do
end subroutine compute_surface_tension

subroutine compute_surface_tension_d1(nx, ny, surfactant, surface_tension_d1)
    implicit none
    double precision :: beta, kappa, delta, mu, right_film_height
    common /surfactant_config/ beta, kappa, delta, mu, right_film_height

    integer, intent(in) :: nx, ny
    double precision, dimension(nx, ny), intent(in) :: surfactant
    double precision, dimension(nx, ny), intent(out) :: surface_tension_d1

    integer :: ix, iy

    do iy = 1, ny
        do ix = 1, nx
            ! surface_tension_d1(ix, iy) = -3.d0 * mu * (1.d0 + mu * surfactant(ix, iy))**(-4)
            surface_tension_d1(ix, iy) = -1.d0
        end do
    end do
end subroutine compute_surface_tension_d1


-- Recursive types: list.

NatList = Rec X. <nil: Unit, cons: { Nat, X }>;

-- Some built-in operators on lists from simpler parts:

-- A constant nil:
nil = <nil = unit> as NatList;

-- A constructor cons for adding an element to the front
-- of an existing list:
cons = lambda n: Nat. lambda l: NatList. <cons = { n, l }> as NatList;

-- An isnil operation and destructors hd and tl for extracting
-- the head and tail of a non-empty list (in terms of case):
isnil = lambda l: NatList. case l of
                             <nil = u> ==> true
                           | <cons = p> ==> false;

hd = lambda l: NatList. case l of
                          <nil = u> ==> 0
                        | <cons = p> ==> p.1;

tl = lambda l: NatList. case l of
                          <nil = u> ==> l
                        | <cons = p> ==> (p.2) as NatList;

-- Example:

plus = fix (lambda s: Nat -> Nat -> Nat.
              lambda x: Nat. lambda y: Nat.
                if iszero y
                then x
                else s (succ x) (pred y));

sumlist = fix (lambda s: NatList -> Nat. lambda l: NatList.
                 if isnil l then 0 else plus (hd l) (s (tl l)));

mylist = cons 2 (cons 3 (cons 5 nil));
sumlist mylist;


program MaxwellModel
    implicit none
    integer :: N, i, j, k, l, m,p
    real, allocatable :: G(:), tau(:), ni(:), kl(:), kd(:)
    real ::  ni0, produkt, vsota, dt
    real ::  t, e, e1, e2, e3, e4, e5, de,de1,de2,de3,de4,de5, sigma, napetost
    real :: k1e,k2e,k3e,k4e
    real :: k1e1,k2e1,k3e1,k4e1
    real :: k1e2,k2e2,k3e2,k4e2
    real :: k1e3,k2e3,k3e3,k4e3
    real :: k1e4,k2e4,k3e4,k4e4
    real :: k1e5,k2e5,k3e5,k4e5

    N = 6
    allocate(G(N))
    allocate(tau(N))
    allocate(ni(N))
    allocate(kl(N))
    allocate(kd(N))

    ni0 = 1.0
    dt = 0.01

    G = (/0.01,0.005,0.0005,1.0,3.0,0.00069/)
    tau = (/1.1,1.2,1.3,1.4,1.5,1.1/)
    ni = tau*G
    kl = 0.0
    kd = 0.0

    do i = 1, N
        kd(1) = kd(1) + G(i)*tau(i)
    end do

    do i = 1, N-1
        do j = i+1, N
            vsota = G(i)+G(j)
            produkt = tau(i)*tau(j)
            kd(2) = kd(2) + vsota*produkt
        end do
    end do

    do i = 1, N-2
        do j = i+1, N-2
            do k = j+1, N
                vsota = G(i)+G(j)+G(k)
                produkt = tau(i)*tau(j)*tau(k)
                kd(3) = kd(3) + vsota*produkt
            end do
        end do
    end do

    do i = 1, N-3
        do j = i+1, N-2
            do k = j+1, N-1
                do l = k+1, N
                    vsota = G(i)+G(j)+G(k)+G(l)
                    produkt = tau(i)*tau(j)*tau(k)*tau(l)
                    kd(4) = kd(4) + vsota*produkt
                end do
            end do
        end do
    end do

    do i = 1, N-4
        do j = i+1, N-3
            do k = j+1, N-2
                do l = k+1, N-1
                    do m = l+1, N
                        vsota = G(i)+G(j)+G(k)+G(l)+G(m)
                        produkt = tau(i)*tau(j)*tau(k)*tau(l)*tau(m)
                        kd(5) = kd(5) + vsota*produkt
                    end do
                end do
            end do
        end do
    end do

    do i = 1, N-5
        do j = i+1, N-4
            do k = j+1, N-3
                do l = k+1, N-2
                    do m = l+1, N-1
                        do p = m+1, N
                            vsota = G(i)+G(j)+G(k)+G(l)+G(m)+G(p)
                            produkt = tau(i)*tau(j)*tau(k)*tau(l)*tau(m)*tau(p)
                            kd(6) = kd(6) + vsota*produkt
                        end do
                    end do
                end do
            end do
        end do
    end do

    print*, "kd", kd

    t = 0.0

    sigma = napetost(t)
    e  = 0.0
    e1 = 0.0
    e2 = 0.0
    e3 = 0.0
    e4 = 0.0
    e5 = 0.0

    open(15, file="rungekutta.dat")
    write(15,*) t, sigma, e, e1, e2, e3, e4, e5

    do while (t <= 120.0)

        k1e  = dt* de(e1)
        k1e1 = dt*de1(e2)
        k1e2 = dt*de2(e3)
        k1e3 = dt*de3(e4)
        k1e4 = dt*de4(e5)
        k1e5 = dt*de5(kd,t,e1,e2,e3,e4,e5)

        k2e  = dt* de(e1+0.5*k1e1)
        k2e1 = dt*de1(e2+0.5*k1e2)
        k2e2 = dt*de2(e3+0.5*k1e3)
        k2e3 = dt*de3(e4+0.5*k1e4)
        k2e4 = dt*de4(e5+0.5*k1e5)
        k2e5 = dt*de5(kd,t+0.5*dt,e1+0.5*k1e1,e2+0.5*k1e2,e3+0.5*k1e3,e4+0.5*k1e4,e5+0.5*k1e5)

        k3e  = dt* de(e1+0.5*k2e1)
        k3e1 = dt*de1(e2+0.5*k2e2)
        k3e2 = dt*de2(e3+0.5*k2e3)
        k3e3 = dt*de3(e4+0.5*k2e4)
        k3e4 = dt*de4(e5+0.5*k2e5)
        k3e5 = dt*de5(kd,t+0.5*dt,e1+0.5*k2e1,e2+0.5*k2e2,e3+0.5*k2e3,e4+0.5*k2e4,e5+0.5*k2e5)

        k4e  = dt* de(e1+k3e1)
        k4e1 = dt*de1(e2+k3e2)
        k4e2 = dt*de2(e3+k3e3)
        k4e3 = dt*de3(e4+k3e4)
        k4e4 = dt*de4(e5+k3e5)
        k4e5 = dt*de5(kd,t+dt,e1+k3e1,e2+k3e2,e3+k3e3,e4+k3e4,e5+k3e5)

        e  = e +      (k1e+2.0*k2e+2.0*k3e+k4e)/6.0
        e1 = e1 + (k1e1+2.0*k2e1+2.0*k3e1+k4e1)/6.0
        e2 = e2 + (k1e2+2.0*k2e2+2.0*k3e2+k4e2)/6.0
        e3 = e3 + (k1e3+2.0*k2e3+2.0*k3e3+k4e3)/6.0
        e4 = e4 + (k1e4+2.0*k2e4+2.0*k3e4+k4e4)/6.0
        e5 = e5 + (k1e5+2.0*k2e5+2.0*k3e5+k4e5)/6.0
        sigma = napetost(t)
        t = t + dt

        write(15,*) t, sigma, e, e1, e2, e3, e4, e5

    end do

    close(15)

    end program MaxwellModel

    ! napetost sigma
    function napetost(t)
        implicit none
        real :: napetost, t

        if (t < 40.0) then
            napetost = 10.0
        else
            napetost = 0.0
        end if

    end function

    ! 1. odvod
    function de(e1)
        implicit none
        real :: de,e1
        de = e1
    end function

    ! 2. odvod
    function de1(e2)
        implicit none
        real :: de1,e2
        de1 = e2
    end function

    ! 3. odvod
    function de2(e3)
        implicit none
        real :: de2,e3
        de2 = e3
    end function

    ! 4. odvod
    function de3(e4)
        implicit none
        real :: de3,e4
        de3 = e4
    end function

    ! 5. odvod
    function de4(e5)
        implicit none
        real :: de4,e5
        de4 = e5
    end function

    ! 6. odvod
    function de5(kd,t,e1,e2,e3,e4,e5)
        implicit none
        real :: kd(6)
        real :: de5,napetost,e1,e2,e3,e4,e5, t
        de5 = (napetost(t)-kd(5)*e5-kd(4)*e4-kd(3)*e3-kd(2)*e2-kd(1)*e1)/kd(6)
    end function


function light(height, time, intensity) result(out)
  real(kind=8), dimension(:), intent(in) :: height
  real(kind=8), intent(in) :: time
  real(kind=8), dimension(:), allocatable :: intensity
  logical :: out
  integer :: i
  real, parameter :: Pi = 3.1415927
  out = .true.
  if (allocated(intensity)) then
     deallocate(intensity)
  end if
  allocate(intensity(size(height)))
  do i = 1, size(height)
     intensity(i) = 80.0 * (1.0 + SIN(2.0 * Pi * time / 365)) / (ABS(200.0 - height(i))**2)
  end do
end function light


! --------------------------------------------------------------------
!    FEM solution:
!    2階常微分方程式
!    (d/dx)**2 u =  α (B.C. u(0) = 0, du/dx(L) = 0)
!    note: 1次元トラス要素で近似
! --------------------------------------------------------------------
! --------------------------------------------------------------------
!   module: Difine parameters
! --------------------------------------------------------------------
!
module parameters
    implicit none

    integer, parameter :: n = 10 ! 要素数
    integer, parameter :: n1 = n + 1 ! 節点数
    integer, parameter :: n2 = n + 2 ! 列ベクトル用
    double precision, parameter :: alpha = - 1.d0 / 12.d0 ! ODEのパラメータ

end module

! --------------------------------------------------------------------
!    main Program
! --------------------------------------------------------------------
!
program FEM_dim1
    use parameters
    implicit none

    call calc
    stop

end program

! --------------------------------------------------------------------
!   Calculation
! --------------------------------------------------------------------
!
subroutine calc
    use parameters
    implicit none

    integer i, j

    double precision,dimension(n1, n2) :: k_e ! 要素剛性マトリックス
    double precision,dimension(n1, n2) :: a ! 拡大係数行列(全体剛性マトリックス)
    double precision,dimension(n1) :: u ! 節点変位ベクトル
    double precision,dimension(n1) :: ans_u ! 解答となる節点変位
    double precision,dimension(n1) :: b ! - b = F 要素に働く外力ベクトル

    double precision,dimension(n1) :: x ! 要素毎の座標
    double precision,dimension(n) :: l ! 要素の長さ
    double precision :: L_total ! 要素の合計(トラス全体の長さ)
    ! gauss
    integer row, diag
    double precision :: m, temp
    ! pivot
    ! integer row_max
    ! double precision :: a_max, a_temp(n1 + 1)

    ! 解ベクトルを定義
    ans_u = [0.d0, 1.625d0, 3.17d0, 4.625d0, 6.d0, 8.5d0, 10.67d0, 12.5d0, 14.d0, 16.d0, 16.67d0]
!---節点の情報入力
    x = [0, 1, 2, 3, 4, 6, 8, 10, 12, 16, 20] ! 節点の位置座標
    L_total = x(n1)
!---節点間の長さを算出
    do i = 1, n
        l(i) = x(i + 1) - x(i)
    end do
!---初期化
    do i = 1, n1
        do j = 1, n2
            a(i, j) = 0.d0
            k_e(i, j) = 0.d0
        end do
        b(i) = 0.d0
    end do
    b(1) = l(1)
    b(n1) = l(n)
!---全体剛性マトリックス Kの計算
    a(1, 1) = 1.d0 / l(1)
    a(n1, n1) = 1.d0 / l(n)
    a(1, n2) = - alpha * l(1) / 2
    a(n1, n2) = - alpha * l(n) / 2
    do i = 2, n
        ! 要素剛性マトリックス (次々に加えられないことが課題)
        k_e(i, i) = 1.d0 / l(i) + 1.d0 / l(i - 1)
        k_e(i, i + 1) = - 1.d0 / l(i)
        k_e(i + 1, i) = - 1.d0 / l(i)
        k_e(i + 1, i + 1) = 1.d0 / l(i)
        ! 外力ベクトル
        b(i) = alpha * ( l(i) + l(i - 1) ) / 2
        ! 外力ベクトルのマージ
        a(i, n2) = a(i, n2) - b(i)
    end do
    ! 要素剛性マトリックスのマージ
    a = a + k_e
!---Check matrix a
    ! do i = 1, n1
    !     write(*, "(12f6.2)") a(i, :)
    ! end do

!---境界条件処理
    call BC_procedure(a)
!---Check matrix a
    write (*, *) "before matrix a"
    do i = 1, n1
        write(*, "(12f6.2)") a(i, :)
    end do
!---連立一次方程式を解く
    ! call gauss(a)

!---上書きで試す
    ! a(1, 1:n1 + 1) = [2, 4, 6, 6]
    ! a(2, 1:n1 + 1) = [3, 8, 7, 15]
    ! a(3, 1:n1 + 1) = [5, 7, 21, 24]

    ! a(1, 1:n1 + 1) = [6, 5, 4, 8]
    ! a(2, 1:n1 + 1) = [12, 13, 10, 16]
    ! a(3, 1:n1 + 1) = [18, 21, 17, 27]

!---Initialize
    temp = 0.d0
!---Make upper matrix
    do diag = 1, n1 - 1
        ! call pivot(a, diag, n1)
! !-------Sorting
!         a_max = abs(a(diag, diag))
!         do row = diag + 1, n1
!             if ( abs(a(row, diag)) > a_max ) then
!                 row_max = row
!                 a_max = abs(a(row, diag))
!             end if
!         end do
! !-------Replace for a
!         a_temp = a(diag, :)
!         a(diag, :) = a(row_max, :)
!         a(row_max, :) = a_temp

!-------Make upper matrix
        do row = diag + 1, n1
            m = a(row, diag) / a(diag, diag)
            a(row, 1:n1 + 1) = a(row, 1:n1 + 1) - m * a(diag, 1:n1 + 1)
        end do
    end do
    ! Check matrix a
    write (*, *) "after Matrix a ="
    do row = 1, n1
        write (*, "(12f6.2)") a(row, :)
    end do
!---Backward solution
    u(n1) = a(n1, n1 + 1) / a(n1, n1)
    do diag = n1 - 1, 1, - 1
        temp = dot_product(a(diag, 1:n1), u(1:n1))
        u(diag) = (a(diag, n1 + 1) - temp) / a(diag, diag)
    end do
!---Output u
    write (*, *) "Diplacement u ="
    write (*, "(11f6.2)") u(:)
    write (*, *) "answer u ="
    write (*, "(11f6.2)") ans_u(:)
    return

end subroutine

! --------------------------------------------------------------------
!   Boundary Condition procedure (境界条件処理)
! --------------------------------------------------------------------
!
subroutine BC_procedure(a)
    use parameters
    implicit none

    integer j
    double precision,dimension(n1, n2) :: a

    a(1, 1) = 1

    do j = 2, n2
        a(1, j) = 0
    end do
    return

end subroutine

! ----------------------------------------------
!   拡大係数行列 version
!-----------------------------------------------
!
subroutine gauss(a)
    use parameters
    implicit none

    integer dim
    ! integer dim
    double precision :: a(n1, n1 + 1)
    double precision :: x(n1)
    ! double precision :: y(dim)
    ! local
    integer row, diag
    double precision :: m, temp

!---Initialize
    dim = n1
    x = 0.d0
    temp = 0.d0
!---Make upper matrix
    do diag = 1, dim - 1
        call pivot(a, diag, dim)
        do row = diag + 1, dim
            m = a(row, diag) / a(diag, diag)
            a(row, 1:dim + 1) = a(row, 1:dim + 1) - m * a(diag, 1:dim + 1)
        end do
    end do
    ! Check matrix a
    ! write (*, *) "a ="
    ! do row = 1, dim
    !     write (*, "(4f6.2)") a(row, :)
    ! end do
!---Backward solution
    x(dim) = a(dim, dim + 1) / a(dim, dim)
    do diag = dim - 1, 1, - 1
        temp = dot_product(a(diag, 1:dim), x(1:dim))
        x(diag) = (a(diag, dim + 1) - temp) / a(diag, diag)
    end do
    return

end subroutine

!-----------------------------------------------
!  部分ピボット選択
!-----------------------------------------------
!
subroutine pivot(a, diag, dim)
    implicit none

    integer dim, diag, row, row_max
    double precision :: a_max, a(dim, dim + 1), a_temp(dim + 1)
!---Sorting
    a_max = abs(a(diag, diag))
    do row = diag + 1, dim
        if ( abs(a(row, diag)) > a_max ) then
            row_max = row
            a_max = abs(a(row, diag))
        end if
    end do
!---Replace for a
    a_temp = a(diag, :)
    a(diag, :) = a(row_max, :)
    a(row_max, :) = a_temp
    return

end subroutine

!-----------------------------------------------
!  Otput
!-----------------------------------------------
!
subroutine output
    implicit none
    ! call BC_procedure
    ! open(10, file = "output.csv", status = "replace")
    ! do i = 1, n1
    !     write (10, "(12f6.3)") a(i, :)
    ! end do
    ! close(10)

    ! call gauss
    ! open(11, file = "output-u.csv", status = "replace")
    ! ! write (*, *) "x ="
    ! do i = 1, n
    !     write (11, *) "step", "u"
    !     write (11, "(3f6.2)") i, x(i)
    ! end do
    ! close (11)

end subroutine


    program demo_int
    use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64
    implicit none
    integer :: i = 42
    complex :: z = (-3.7, 1.0)
    real :: x=-10.5, y=10.5

       print *, int(x), int(y)

       print *, int(i)

       print *, int(z), int(z,8)
       ! elemental
       print *, int([-10.9,-10.5,-10.3,10.3,10.5,10.9])
       ! note int(3) truncates towards zero

       ! CAUTION:
       ! a number bigger than a default integer can represent
       ! produces an incorrect result and is not required to
       ! be detected by the program.
       x=real(huge(0))+1000.0
       print *, int(x),x
       ! using a larger kind
       print *, int(x,kind=int64),x

       print *, int(&
       & B"111111111111111111111111111111111111111111111111111111111111111",&
       & kind=int64)
       print *, int(O"777777777777777777777",kind=int64)
       print *, int(Z"7FFFFFFFFFFFFFFF",kind=int64)

       ! elemental
       print *
       print *,int([ &
       &  -2.7,  -2.5, -2.2, -2.0, -1.5, -1.0, -0.5, &
       &  0.0,   &
       &  +0.5,  +1.0, +1.5, +2.0, +2.2, +2.5, +2.7  ])

    end program demo_int


      PROGRAM LA_SGTSVX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements"
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GTSVX
!  .."Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, N, NRHS
      INTEGER, ALLOCATABLE :: IPIV(:)
      CHARACTER(LEN=1) :: TRANS
!  .. Local Arrays ..
      REAL(WP), ALLOCATABLE :: DL(:), D(:), DU(:), DLF(:), &
                DF(:), DUF(:), DU2(:), B(:,:),X(:,:)

!  .. "Executable Statements" ..
       WRITE (*,*) 'SGTSVX Example Program Results.'
       N = 6; NRHS = 3

       ALLOCATE(DL(N-1), DLF(N-1), D(N), DF(N), DU(N-1), DUF(N-1), &
                DU2(N-2), B(N,NRHS), X(N,NRHS), IPIV(N) )

       OPEN(UNIT=21,FILE='gtsv.ma',STATUS='UNKNOWN')
          DO I=1,N-1
          READ(21,'(F2.0)') DL(I)
          ENDDO
          DO I=1,N
          READ(21,'(F2.0)') D(I)
          ENDDO
          DO I=1,N-1
          READ(21,'(F2.0)') DU(I)
          ENDDO
       CLOSE(21)

       WRITE(*,*)'DU :'
       WRITE(*,"(8(I3,1X))") INT(DU(:));
       WRITE(*,*)'D :'
       WRITE(*,"(8(I3,1X))") INT(D(:));
       WRITE(*,*)'DL :'
       WRITE(*,"(8(I3,1X))") INT(DL(:))

       B = 0.0_WP
       DO I = 2, N-1; B(I,:) = DU(I-1) + D(I) + DL(I); ENDDO
       B(1,:) = D(1) + DL(1);B(N,:) = DU(N-1) + D(N)
       DO I = 1, NRHS; B(:,I) = B(:,I)*I; ENDDO
       WRITE(*,*)'B = '
       DO I=1,N; WRITE(*,"(8(F8.5,1X))") B(I,:)
       ENDDO

       WRITE(*,*) "CALL LA_GTSVX(DL, D, DU, B, X, DLF, DF, DUF, DU2, TRANS='T' )"
       TRANS='T'
       CALL LA_GTSVX(DL, D, DU, B, X, DLF, DF, DUF, DU2, IPIV, TRANS='T' )

       WRITE(*,*)'X = '
       DO I=1,N;WRITE(*,"(6(F8.5,1X))") X(I,:)
       ENDDO

       WRITE(*,*)'DLF on exit:'; WRITE(*,"(8(F8.5,1X))") DLF(:);
       WRITE(*,*)'DF on exit:';  WRITE(*,"(8(F8.5,1X))") DF(:);
       WRITE(*,*)'DUF on exit:'; WRITE(*,"(8(F8.5,1X))") DUF(:);
       WRITE(*,*)'DU2 on exit:'; WRITE(*,"(8(F8.5,1X))") DU2(:);
       WRITE(*,*)'IPIV on exit:';WRITE(*,"(8(I6,1X))") IPIV(:);

       DEALLOCATE(DL,DLF,D,DF,DU,DUF,DU2,B,X)

       END PROGRAM LA_SGTSVX_EXAMPLE


!
!     ------------------------------------------------------------------
!        S Y M M E Q   A N D  S Y M M S L
!     ------------------------------------------------------------------
!
!        This routine is a modification of the one in "Computer Methods
!     for Mathematical Computation" by Forsythe, Malcolm, and Moler
!     (Prentice Hall, 1975) to solve a singular system of equations.
!
      SUBROUTINE SYMMEQ(NDIM, N, A, X)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: NDIM
      INTEGER , INTENT(IN) :: N
      REAL(DOUBLE) , INTENT(INOUT) :: A(NDIM,*)
      REAL(DOUBLE) , INTENT(INOUT) :: X(*)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NM1, K, KP1, I, J
      REAL(DOUBLE) :: T
!-----------------------------------------------
!   E x t e r n a l   F u n c t i o n s
!-----------------------------------------------
!-----------------------------------------------
!
!
!     SOLVE A SYSTEM OF LINEAR EQUATIONS A*X = 0
!
!     INPUT..
!
!        NDIM = DECLARED ROW DIMENSION OF THE ARRAY CONTAINING  A.
!        N = ORDER OF THE MATRIX
!        A =  COEFFICIENT MATRIX
!        B = CONSTANT VECTOR
!
!     OUTPUT..
!
!        X = SOLUTION VECTOR with X(1) unchanged.
!
      NM1 = N - 1
!
!
!      L U FACTORIZATION WITHOUT PIVOTING
!
      DO K = N, 3, -1
         KP1 = K - 1
         T = A(K,K)
         IF (T == 0.0D0) CYCLE
!
!        COMPUTE MULTIPLIERS
!
         A(KP1:2:(-1),K) = -A(KP1:2:(-1),K)/T
!
!        INTERCHANGE AND ELIMINATE BY COLUMNS
!
         DO J = KP1, 2, -1
            T = A(K,J)
            IF (T == 0.0D0) CYCLE
            A(KP1:2:(-1),J) = A(KP1:2:(-1),J) + A(KP1:2:(-1),K)*T
         END DO
      END DO
!
!     At this point it is assumed that the LU factorization
!     has already been performed.
!
      ENTRY SYMMSL (NDIM, N, A, X)
!
      X(2:N) = -A(2:N,1)
      DO K = N, 3, -1
         T = X(K)
         IF (T == 0.0D0) CYCLE
         X(K-1:2:(-1)) = X(K-1:2:(-1)) + A(K-1:2:(-1),K)*T
      END DO
!
!     BACK SUBSTITUTION
!
      DO K = 2, N - 1
         IF (A(K,K) == 0.D0) THEN
            X(K) = 0.D0
         ELSE
            X(K) = X(K)/A(K,K)
         ENDIF
         T = -X(K)
         X(K+1:N) = X(K+1:N) + A(K+1:N,K)*T
      END DO
      X(N) = X(N)/A(N,N)
      RETURN
      END SUBROUTINE SYMMEQ


program main
    implicit none

    integer :: i

    interface
        function Marsaglia_generator(seed_1_, seed_2_)
            implicit none
            integer, parameter :: li = selected_int_kind(10)
            integer, parameter :: dp = selected_real_kind(8)

            integer(li), intent(in), optional :: seed_1_, seed_2_
            real(dp) :: Marsaglia_generator
        end function Marsaglia_generator
    end interface

    do i = 1, 100
        write(*,*) Marsaglia_generator()
    end do
end program main

function Marsaglia_generator(seed_1_, seed_2_)
    implicit none
    integer, parameter :: li = selected_int_kind(10)
    integer, parameter :: dp = selected_real_kind(8)

    integer(li), intent(in), optional :: seed_1_, seed_2_
    real(dp) :: Marsaglia_generator

    if (present(seed_1_)) then
        if (present(seed_2_)) then
            Marsaglia_generator = Lagged_Fibonacci_generator(seed_1_) - random_generator_2(seed_2_)
        else
            Marsaglia_generator = Lagged_Fibonacci_generator(seed_1_) - random_generator_2()
        end if
    else
        if (present(seed_2_)) then
            Marsaglia_generator = Lagged_Fibonacci_generator() - random_generator_2(seed_2_)
        else
            Marsaglia_generator = Lagged_Fibonacci_generator() - random_generator_2()
        end if
    end if
    if (Marsaglia_generator < 0) then
        Marsaglia_generator = Marsaglia_generator + 16777213 / dble(16777216)
    end if

    contains
        function Lagged_Fibonacci_generator(seed_)
            ! 第一个随机数产生器 - Fibonacci 延迟产生器
            implicit none
            integer, parameter :: li = selected_int_kind(10)
            integer, parameter :: dp = selected_real_kind(8)

            integer(li), intent(in), optional :: seed_
            real(dp) :: Lagged_Fibonacci_generator

            integer :: i
            real(dp), save :: x(98) = [(-1, i = 1, 98)]
            logical :: initialized = .false.

            if (present(seed_)) then
                x(1) = Congruential_16807(seed_)
                initialized = .false.
            else if (x(1) == -1.0d0) then
                do i = 1, 97
                    x(1) = Congruential_16807(1_li)
                end do
                initialized = .false.
            end if

            if (initialized) then
                x(1:97) = x(2:98)
            else
                do i = 2, 97
                    x(i) = Congruential_16807()
                end do
            end if
            x(98) = x(1) - x(65)
            if (x(98) < 0) then
                x(98) = x(98) + 1.d0
            end if
            Lagged_Fibonacci_generator = x(98)
        end function Lagged_Fibonacci_generator

        function random_generator_2(seed_)
            ! 第二个随机数发生器
            implicit none
            integer, parameter :: li = selected_int_kind(10)
            integer, parameter :: dp = selected_real_kind(8)

            integer(li), intent(in), optional :: seed_
            real(dp) :: random_generator_2

            real(dp), save :: last_random_number

            if (present(seed_)) then
                last_random_number = seed_
            end if
            random_generator_2 = last_random_number - 7654321 / dble(16777216)
            if (random_generator_2 < 0) then
                random_generator_2 = random_generator_2 + 16777213 / dble(16777216)
            end if
            last_random_number = random_generator_2
        end function random_generator_2

        function Congruential_16807(seed_)
            ! Schrage 方法 16807 产生器
            implicit none
            integer, parameter :: li = selected_int_kind(10)
            integer, parameter :: dp = selected_real_kind(8)

            integer(li), intent(in), optional :: seed_
            real(dp) :: Congruential_16807

            integer, parameter :: a = 7**5, m = 2**31 - 1
            integer, parameter :: q = 12773, r = 2836
            integer, save :: z

            if (present(seed_)) then
                z = seed_
            else if (z == -1) then
                z = 1
            end if
            z = a * mod(z, q) - r * (z / q)
            if (z < 0) then
                z = z + m
            end if
            Congruential_16807 = mod(z, m) / dble(m)
        end function Congruential_16807
end function Marsaglia_generator


      REAL FUNCTION slSEP (A1, B1, A2, B2)
*+
*     - - - -
*      S E P
*     - - - -
*
*  Angle between two points on a sphere.
*
*  (single precision)
*
*  Given:
*     A1,B1    r     spherical coordinates of one point
*     A2,B2    r     spherical coordinates of the other point
*
*  (The spherical coordinates are [RA,Dec], [Long,Lat] etc, in radians.)
*
*  The result is the angle, in radians, between the two points.  It
*  is always positive.
*
*  Called:  slDSEP
*
*  Last revision:   7 May 2000
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    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; either version 2 of the License, or
*    (at your option) any later version.
*
*    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 (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL A1,B1,A2,B2

      DOUBLE PRECISION slDSEP

*  Use double precision version.
      slSEP = REAL(slDSEP(DBLE(A1),DBLE(B1),DBLE(A2),DBLE(B2)))

      END


module m_constants
    implicit none

    double precision, parameter :: PI = acos(-1.0d0)
end module


SUBROUTINE potmp(PRESS,TEMP,S,RP,POTEMP)
!SOURCE: http://www.ncl.ucar.edu/Support/talk_archives/2011/att-1609/potmp.f
!
!     TITLE:
!     *****
!
!       POTMP  -- CALCULATE POTENTIAL TEMPERATURE FOR AN ARBITRARY
!                 REFERENCE PRESSURE
!
!     PURPOSE:
!     *******
!
!       TO CALCULATE POTENTIAL TEMPERATURE
!
!       REF: N.P. FOFONOFF
!            DEEP SEA RESEARCH
!            IN PRESS NOV 1976
!
!     PARAMETERS:
!     **********
!
!       PRESS  -> PRESSURE IN DECIBARS
!       TEMP   -> TEMPERATURE IN CELSIUS DEGREES
!       S      -> SALINITY PSS 78
!       RP     -> REFERENCE PRESSURE IN DECIBARS
!                 (0.0 FOR THE QUANTITY THETA)
!       POTEMP <- POTENTIAL TEMPERATURE (DEG C)
!
  REAL PRESS,TEMP,S,RP,POTEMP
!
!     VARIABLES:
!     *********
!
  INTEGER I,J,N
  REAL*4 DP,P,Q,R1,R2,R3,R4,R5,S1,T,X
!
!     CODE:
!     ****
!
  S1 = S-35.0
  P  = PRESS
  T  = TEMP

  DP = RP - P
  N  = IFIX(ABS(DP)/1000.) + 1
  DP = DP/FLOAT(N)

  outer : do 10 I=1,N
    inner : do 20 J=1,4

      R1 = ((-2.1687E-16*T+1.8676E-14)*T-4.6206E-13)*P
      R2 = (2.7759E-12*T-1.1351E-10)*S1
      R3 = ((-5.4481E-14*T+8.733E-12)*T-6.7795E-10)*T
      R4 = (R1+(R2+R3+1.8741E-8))*P+(-4.2393E-8*T+1.8932E-6)*S1
      R5 = R4+((6.6228E-10*T-6.836E-8)*T+8.5258E-6)*T+3.5803E-5

      X  = DP*R5

      GO TO (100,200,300,400),J

  100 CONTINUE
      T = T+.5*X
      Q = X
      P = P + .5*DP
      CYCLE inner

  200 CONTINUE
      T = T + .29298322*(X-Q)
      Q = .58578644*X + .121320344*Q
      CYCLE inner

  300 CONTINUE
      T = T + 1.707106781*(X-Q)
      Q = 3.414213562*X - 4.121320344*Q
      P = P + .5*DP
      CYCLE inner

  400 CONTINUE
      T = T + (X-2.0*Q)/6.0

    enddo inner
  enddo outer

      POTEMP = T
!
!       END POTMP
!

END SUBROUTINE potmp


        program main
!========================================================================
!------------------ Miller-Colbert DVR (grid DVR) in one dimension ------
!------------------ equidistant grid, arbitrary number of points --------
!------------------ gives eigenvalues and eigenvectors of H -------------
!------------------ symmetric double well is defined --------------------
!========================================================================
	implicit real*8(a-h,o-z)
	parameter(nx=4096,aw=14d0,bw=20d0,vbot=bw*bw/4d0/aw)
        REAL*8 x(nx),v(nx)
!========================================================================
        OPEN(15,FILE='INdvr',STATUS='OLD')
         READ(15,*) n1,xmin,xmax
         read(15,*) am
        close(15)
        write(*,*) 'GRID',n1,xmin,xmax
        write(*,*) 'MASS=',am
      pi=4d0*atan(1d0)

	open(55, file='wf_dat')
	open(54, file='pot'   )
	open(62, file='eigs'  )
      open(101,file='r'     )
      open(11,file='pes.dat')
!=======================================================================
!cccccccccccccccccccccccccc define the grid cccccccccccccccccccccccccccccc
        xn=xmax-xmin
        dx=xn/(n1-1)
        write(*,*) 'GRID SPACING=',dx
	write(*,*) 'x_init',x(1),xmin
	write(*,*) 'x_fin',x(n1),xmax
cccccccccccccccccccccccccc define the potential ccccccccccccccccccccccccc
	De = 0.176d0
      do 11 i=1,N1
         x(i)=xmin+dx*(i-1)
!	   if(x(i) .lt. 0.653594d0) then
!	     v(i)=0.1831104*x(i)**2-0.186772608d0*x(i)**3
!	   else
!	     v(i) = 0.026074d0
!	   endif
!	  v(i) = De*(1d0-exp(-1.02d0*x(i)))**2
C	  v(i) = x(i)**2/2d0-0.05d0*x(i)**3
c         read(11,*) a,v(i)
         v(i) = x(i)**2/2d0-0.01*x(i)**3

         write(54,*) x(i),v(i)
11      continue
        close(54)

!=======================================================================
!------------------- construct and diagonalize H -----------------------
        call ham_dvr(n1,pi,am,x,v)

        close(62)
        close(55)
        STOP
        END
!========================================================================
!========================================================================
        subroutine ham_dvr(n1,pi,am,x,v)
!------ construct the DVR Hamiltonian and solve the eigenvalue problem --
!========================================================================
        implicit real*8(a-h,o-z)
        parameter(nx=4096,lwork=nx*10)
        real*8 x(*),v(*),work(lwork),w(nx),ham(nx,nx),hsv(nx,nx),z(nx)
        real*8 r(n1),dr(n1),ddr(n1)
        a=x(1)
        b=x(n1)
        ba=pi*a/(b-a)
        dx=x(2)-x(1)
        an=0.5d0/am/dx/dx
        anf=pi/(b-a)**2/am
c----------------- construct the hamiltonian matrix --------------
        do 10 j=1,n1
         ham(j,j)=an*pi*pi/3d0+v(j)
         do 9 i=j+1,n1
          ham(i,j)=an*(-1d0)**(i-j)*2d0/(i-j)**2
          hsv(i,j)=ham(i,j)
          hsv(j,i)=ham(i,j)
9       continue
10      hsv(j,j)=ham(j,j)
        write(*,*) ham(1,1),ham(1,2),ham(2,1),ham(2,2)
        call dsyev('V','L',n1,ham,nx,w,work,lwork,info)
        write(*,*) 'INFO',info,work(1)
        eig=w(1)
        write(*,*) 'EIGENVALS',w(1),w(2),w(3)
!---------------------- check the eigenvector --------------------
!------ ham(j,k)/dsqrt(dx) is the eigenfunction in coord space ---
        dev=0d0
        write(*,*) 'NUMBER OF EIGENFUNCTIONS TO PRINT'
        read(*,*) ns
        do 30 j=1,n1
         write(62,*) j,w(j)
         write(55,1000) x(j),(ham(j,k)/dsqrt(dx),k=1,ns)

         z(j)=0d0
         do 31 i=1,n1
31        z(j)=z(j)+hsv(j,i)*ham(i,1)/eig
          dev=dev+abs(z(j)-ham(j,1))**2
30      continue

c     print out quantum potential
        do j=1,n1-1
          r(j) = (abs(ham(j+1,1))-abs(ham(j,1)))
     +                  /dx/abs(ham(j,1))
        enddo

        do j=1,n1-2
          dr(j) = (r(j+1)-r(j))/dx
        enddo

        do j=1,n1-3
          ddr(j) = (dr(j+1)-dr(j))/dx
          write(101,1000) x(j),r(j),dr(j),ddr(j)
        enddo

        write(*,*) 'EIGENVECTOR TEST',dev
c--------------------  construct the eigenvector ------------
        anv=0d0
        do 15 n=1,n1
15         anv=anv+abs(ham(n,1))**2
        write(*,*) 'VECTOR NORM=',anv
1000	  format(81(e14.7,1x))
        return
        end
!========================================================================


!*********************************************************
!>
! Integration Functions:
!
!  * Gauss-Legendre Integration:

module nfIntegration
  use nfConstants
  use nfSpecialFunctions
  implicit none

  real(dp) :: glx128(64), glw128(64)
  real(dp) :: glx512(256), glw512(256)
  real(dp) :: glx1024(512), glw1024(512)
  real(dp) :: g30k61_gx(15), g30k61_gw(15), g30k61_kx(31), g30k61_kw(31)

  type, public :: nfInt
    real(dp), public, allocatable :: glx(:), glw(:)
  contains
    procedure, public :: setGLNumPoints
    procedure, private :: setGLPoints
    procedure, private :: bisectionGLPoints
  end type nfInt

  type, private :: nfIntGLPoints
    real(dp), private, allocatable :: lower(:), upper(:)
  end type nfIntGLPoints

  public :: readGLParameters
  public :: gaussLegendre, gaussLegendreCmplx
  public :: readGKParameters

contains

  subroutine setGLNumPoints(this, numPoints)
    class(nfInt) :: this
    integer :: numPoints

    allocate(this%glx(numPoints))
    allocate(this%glw(numPoints))
    call setGLPoints(this)
  end subroutine setGLNumPoints

  subroutine setGLPoints(this)
    class(nfInt) :: this
    type(nfIntGLPoints) :: points
    integer :: i, numPoints
    real(dp) :: x, dx, value, valueOLD

    numPoints = size(this%glx,1)
    allocate(points%lower(numPoints))
    allocate(points%upper(numPoints))
    dx = 0.00001
    i = 1
    valueOLD = legendrePoly(numPoints, -1)
    x = -1.d0+dx
    do while(x.le.1.d0)
      value = legendrePoly(numPoints, x)
      if(value*valueOLD.lt.0.d0) then
        points%lower(i) = x-dx
        points%upper(i) = x
        i = i+1
      end if
      valueOLD = value
      x = x+dx
    end do
    call bisectionGLPoints(this, points)
    do i=1,numPoints
      this%glx(i) = (points%upper(i)+points%lower(i))/2.d0
      this%glw(i) = 2.d0*(1.d0-this%glx(i)**2.d0)/((numPoints+1.d0)*legendrePoly(numPoints+1,this%glx(i)))**2.d0
      print *, this%glx(i), this%glw(i)
    end do
  end subroutine setGLPoints

  subroutine bisectionGLPoints(this, points)
    class(nfInt) :: this
    type(nfIntGLPoints) :: points
    integer :: i, numPoints
    real(dp) :: x, value, eps

    eps = 1.d-10
    numPoints = size(this%glx,1)
    do i=1,numPoints
      do while(abs(points%upper(i)-points%lower(i)).gt.eps)
        x = (points%upper(i)+points%lower(i))/2.d0
        value = legendrePoly(numPoints, x)
        if(value.lt.0.d0) then
          if(mod(i,2).eq.0) then
            points%lower(i) = x
          else
            points%upper(i) = x
          end if
        else
          if(mod(i,2).eq.0) then
            points%upper(i) = x
          else
            points%lower(i) = x
          end if
        end if
      end do
    end do
  end subroutine bisectionGLPoints

  subroutine readGLParameters()
    implicit none
    integer :: i

    open(unit=1,file='data/gl128.dat',status='old')
    do i=1,64
      read(1,*) glx128(i), glw128(i)
    end do
    close(1)
    open(unit=1,file='data/gl512.dat',status='old')
    do i=1,256
      read(1,*) glx512(i), glw512(i)
    end do
    close(1)
    open(unit=1,file='data/gl1024.dat',status='old')
    do i=1,512
      read(1,*) glx1024(i), glw1024(i)
    end do
    close(1)
  end subroutine

  subroutine readGKParameters()
    implicit none
    integer :: i, numLines

    open(unit=1,file='data/g30k61.dat',status='old')
    read(1,*) numLines
    do i=1,numLines
      read(1,*) g30k61_gx(i), g30k61_gw(i)
    end do
    read(1,*) numLines
    do i=1,numLines
      read(1,*) g30k61_kx(i), g30k61_kw(i)
    end do
    close(1)
  end subroutine

  real(dp) function gaussLegendre(f,a,b,n,consts)
    implicit none
    integer :: i, n
    real(dp) :: consts(n), a, b, t0, dt, sumIntegral
    interface
      function f(n,c,x)
        integer, parameter :: dp = kind(0.d0)
        integer :: n
        real(dp) :: c(n), x, f
      end function f
    end interface

    t0 = (a+b)/2.d0
    dt = (b-a)/2.d0
    sumIntegral = 0.d0

    ! Using glx128 and glw128
    do i=64,1,-1
      sumIntegral = sumIntegral+glw128(i)*f(n,consts,t0-dt*glx128(i))
    end do
    do i=1,64
      sumIntegral = sumIntegral+glw128(i)*f(n,consts,t0+dt*glx128(i))
    end do

    ! Using glx512 and glw512
    ! do i=256,1,-1
    !   sumIntegral = sumIntegral+glw512(i)*f(n,consts,t0-dt*glx512(i))
    ! end do
    ! do i=1,256
    !    sumIntegral = sumIntegral+glw512(i)*f(n,consts,t0+dt*glx512(i))
    ! end do

    ! Using glx1024 and glw1024
    ! do i=512,1,-1
    !   sumIntegral = sumIntegral+glw1024(i)*f(n,consts,t0-dt*glx1024(i))
    ! end do
    ! do i=1,512
    !   sumIntegral = sumIntegral+glw1024(i)*f(n,consts,t0+dt*glx1024(i))
    ! end do
    gaussLegendre = sumIntegral*dt
  end function

  complex(dp) function gaussLegendreCmplx(f,a,b,n,consts)
    implicit none
    integer :: i, n
    real(dp) :: a, b, t0, dt, sumReal, sumCmplx
    complex(dp) :: consts(n)
    interface
      function f(n,c,x)
        integer, parameter :: dp = kind(0.d0)
        integer :: n
        real(dp) :: x
        complex(dp) :: c(n), f
      end function
    end interface

    t0 = (a+b)/2.d0
    dt = (b-a)/2.d0
    sumReal = 0.d0
    sumCmplx = 0.d0

    ! Using glx128 and glw128
    do i=64,1,-1
      sumReal = sumReal+glw128(i)*real(f(n,consts,t0-dt*glx128(i)))
      sumCmplx = sumCmplx+glw128(i)*aimag(f(n,consts,t0-dt*glx128(i)))
    end do
    do i=1,64
      sumReal = sumReal+glw128(i)*real(f(n,consts,t0+dt*glx128(i)))
      sumCmplx = sumCmplx+glw128(i)*aimag(f(n,consts,t0+dt*glx128(i)))
    end do

    ! Using glx512 and glw512
    ! do i=256,1,-1
    !   sumIntegral = sumIntegral+glw512(i)*f(n,consts,t0-dt*glx512(i))
    ! end do
    ! do i=1,256
    !    sumIntegral = sumIntegral+glw512(i)*f(n,consts,t0+dt*glx512(i))
    ! end do

    ! Using glx1024 and glw1024
    ! do i=512,1,-1
    !   sumIntegral = sumIntegral+glw1024(i)*f(n,consts,t0-dt*glx1024(i))
    ! end do
    ! do i=1,512
    !   sumIntegral = sumIntegral+glw1024(i)*f(n,consts,t0+dt*glx1024(i))
    ! end do
    gaussLegendreCmplx = cmplx(sumReal*dt,sumCmplx*dt,dp)
  end function

end module nfIntegration


      subroutine init_rphi(ctfm,ctfmp,Nx,amp,deltx,hx,x0,res)
      implicit none
      integer i
      integer Nx
      real*8 amp
      real*8 deltx
      real*8 hx
      real*8 x0
      real*8 ctfm(Nx)
      real*8 ctfmp(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=2, Nx-1, 1
      qb = amp * (ctfm(i) - 0.1D1 * x0) / deltx ** 2 * (ctfm(i - 1) - 0.
     #1D1 * ctfm(i + 1)) / hx * exp(-0.1D1 * (ctfm(i) - 0.1D1 * x0) ** 2
     # / deltx ** 2) / ctfmp(i)
      res(i)=qb
      end do
      END


Real Function ang(srt, iseed)
  Common /rndf77/nseed
  Save
  If ((srt>2.14) .And. (srt<=2.4)) Then
     b1s = 29.03 - 23.75*srt + 4.865*srt**2
     b2s = -30.33 + 25.53*srt - 5.301*srt**2
  End If
  If (srt>2.4) Then
     b1s = 0.06
     b2s = 0.4
  End If
  x = ranart(nseed)
  p = b1s/b2s
  q = (2.*x-1.)*(b1s+b2s)/b2s
  If ((-q/2.+sqrt((q/2.)**2+(p/3.)**3))>=0.) Then
     ang1 = (-q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
  Else
     ang1 = -(q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
  End If
  If ((-q/2.-sqrt((q/2.)**2+(p/3.)**3)>=0.)) Then
     ang2 = (-q/2.-sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
  Else
     ang2 = -(q/2.+sqrt((q/2.)**2+(p/3.)**3))**(1./3.)
  End If
  ang = ang1 + ang2
  Return
End Function ang