      DOUBLE COMPLEX FUNCTION FTriEvenTop(shat)
      IMPLICIT NONE
      DOUBLE COMPLEX shat
      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc' ! include model parameter

      DOUBLE PRECISION MQ,MQ2,S,REPS
      DOUBLE COMPLEX CQ2,CA5,C0AB

      REPS=1D-15

      MQ = MDL_MT
      MQ2 = MQ**2
      S = shat/MQ2

      CQ2 = MQ2*DCMPLX(1.D0,-REPS)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/shat)
      C0AB = 0.5D0*CDLOG((CA5+1.D0)/(CA5-1.D0))**2/shat*MQ2
      C0AB = C0AB/MQ2

      FTriEvenTop = 2D0/S*(2D0+(4D0-S)*MQ2*C0AB)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FTriEvenBot(shat)
      IMPLICIT NONE
      DOUBLE COMPLEX shat
      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc' ! include model parameter

      DOUBLE PRECISION MQ,MQ2,S,REPS
      DOUBLE COMPLEX CQ2,CA5,C0AB

      REPS=1D-15

      MQ = MDL_MB
      MQ2 = MQ**2
      S = shat/MQ2

      CQ2 = MQ2*DCMPLX(1.D0,-REPS)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/shat)
      C0AB = 0.5D0*CDLOG((CA5+1.D0)/(CA5-1.D0))**2/shat*MQ2
      C0AB = C0AB/MQ2

      FTriEvenBot = 2D0/S*(2D0+(4D0-S)*MQ2*C0AB)

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FTriOddTop(shat)
      IMPLICIT NONE
      DOUBLE COMPLEX shat
      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc' ! include model parameter

      DOUBLE PRECISION MQ,MQ2,REPS
      DOUBLE COMPLEX CQ2,CA5,C0AB

      REPS=1D-15

      MQ = MDL_MT
      MQ2 = MQ**2

      CQ2 = MQ2*DCMPLX(1.D0,-REPS)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/shat)
      C0AB = 0.5D0*CDLOG((CA5+1.D0)/(CA5-1.D0))**2/shat*MQ2
      C0AB = C0AB/MQ2

      FTriOddTop = -2D0*MQ2*C0AB

      RETURN
      END

      DOUBLE COMPLEX FUNCTION FTriOddBot(shat)
      IMPLICIT NONE
      DOUBLE COMPLEX shat
      INCLUDE 'coupl.inc'
      INCLUDE 'input.inc' ! include model parameter

      DOUBLE PRECISION MQ,MQ2,REPS
      DOUBLE COMPLEX CQ2,CA5,C0AB

      REPS=1D-15

      MQ = MDL_MB
      MQ2 = MQ**2

      CQ2 = MQ2*DCMPLX(1.D0,-REPS)
      CA5 = CDSQRT(1.D0-4.D0*CQ2/shat)
      C0AB = 0.5D0*CDLOG((CA5+1.D0)/(CA5-1.D0))**2/shat*MQ2
      C0AB = C0AB/MQ2

      FTriOddBot = -2D0*MQ2*C0AB

      RETURN
      END


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYGBEH
C...Evaluates the Bethe-Heitler cross section for heavy flavour
C...production.
C...Adapted from SaSgam library, authors G.A. Schuler and T. Sjostrand.

      SUBROUTINE PYGBEH(KF,X,Q2,P2,PM2,XPBH)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Local data.
      DATA AEM2PI/0.0011614D0/

C...Reset output.
      XPBH=0D0
      SIGBH=0D0

C...Check kinematics limits.
      IF(X.GE.Q2/(4D0*PM2+Q2+P2)) RETURN
      W2=Q2*(1D0-X)/X-P2
      BETA2=1D0-4D0*PM2/W2
      IF(BETA2.LT.1D-10) RETURN
      BETA=SQRT(BETA2)
      RMQ=4D0*PM2/Q2

C...Simple case: P2 = 0.
      IF(P2.LT.1D-4) THEN
        IF(BETA.LT.0.99D0) THEN
          XBL=LOG((1D0+BETA)/(1D0-BETA))
        ELSE
          XBL=LOG((1D0+BETA)**2*W2/(4D0*PM2))
        ENDIF
        SIGBH=BETA*(8D0*X*(1D0-X)-1D0-RMQ*X*(1D0-X))+
     &  XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)

C...Complicated case: P2 > 0, based on approximation of
C...C.T. Hill and G.G. Ross, Nucl. Phys. B148 (1979) 373
      ELSE
        RPQ=1D0-4D0*X**2*P2/Q2
        IF(RPQ.GT.1D-10) THEN
          RPBE=SQRT(RPQ*BETA2)
          IF(RPBE.LT.0.99D0) THEN
            XBL=LOG((1D0+RPBE)/(1D0-RPBE))
            XBI=2D0*RPBE/(1D0-RPBE**2)
          ELSE
            RPBESN=4D0*PM2/W2+(4D0*X**2*P2/Q2)*BETA2
            XBL=LOG((1D0+RPBE)**2/RPBESN)
            XBI=2D0*RPBE/RPBESN
          ENDIF
          SIGBH=BETA*(6D0*X*(1D0-X)-1D0)+
     &    XBL*(X**2+(1D0-X)**2+RMQ*X*(1D0-3D0*X)-0.5D0*RMQ**2*X**2)+
     &    XBI*(2D0*X/Q2)*(PM2*X*(2D0-RMQ)-P2*X)
        ENDIF
      ENDIF

C...Multiply by charge-squared etc. to get parton distribution.
      CHSQ=1D0/9D0
      IF(ABS(KF).EQ.2.OR.ABS(KF).EQ.4) CHSQ=4D0/9D0
      XPBH=3D0*CHSQ*AEM2PI*X*SIGBH

      RETURN
      END


      SUBROUTINE SB06ND( N, M, KMAX, A, LDA, B, LDB, KSTAIR, U, LDU, F,
     $                   LDF, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct the minimum norm feedback matrix F to perform
C     "deadbeat control" on a (A,B)-pair of a state-space model (which
C     must be preliminarily reduced to upper "staircase" form using
C     SLICOT Library routine AB01OD) such that the matrix R = A + BFU'
C     is nilpotent.
C     (The transformation matrix U reduces R to upper Schur form with
C     zero blocks on its diagonal (of dimension KSTAIR(i)) and
C     therefore contains bases for the i-th controllable subspaces,
C     where i = 1,...,KMAX).
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The actual state dimension, i.e. the order of the
C             matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The actual input dimension.  M >= 0.
C
C     KMAX    (input) INTEGER
C             The number of "stairs" in the staircase form as produced
C             by SLICOT Library routine AB01OD.  0 <= KMAX <= N.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the transformed state-space matrix of the
C             (A,B)-pair with triangular stairs, as produced by SLICOT
C             Library routine AB01OD (with option STAGES = 'A').
C             On exit, the leading N-by-N part of this array contains
C             the matrix U'AU + U'BF.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the transformed triangular input matrix of the
C             (A,B)-pair as produced by SLICOT Library routine AB01OD
C             (with option STAGES = 'A').
C             On exit, the leading N-by-M part of this array contains
C             the matrix U'B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     KSTAIR  (input) INTEGER array, dimension (KMAX)
C             The leading KMAX elements of this array must contain the
C             dimensions of each "stair" as produced by SLICOT Library
C             routine AB01OD.
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
C             On entry, the leading N-by-N part of this array must
C             contain either a transformation matrix (e.g. from a
C             previous call to other SLICOT routine) or be initialised
C             as the identity matrix.
C             On exit, the leading N-by-N part of this array contains
C             the product of the input matrix U and the state-space
C             transformation matrix which reduces A + BFU' to real
C             Schur form.
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= MAX(1,N).
C
C     F       (output) DOUBLE PRECISION array, dimension (LDF,N)
C             The leading M-by-N part of this array contains the
C             deadbeat feedback matrix F.
C
C     LDF     INTEGER
C             The leading dimension of array F.  LDF >= MAX(1,M).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (2*N)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Starting from the (A,B)-pair in "staircase form" with "triangular"
C     stairs, dimensions KSTAIR(i+1) x KSTAIR(i), (described by the
C     vector KSTAIR):
C
C                    | B | A      *  . . .  *  |
C                    |  1|  11       .      .  |
C                    |   | A     A     .    .  |
C                    |   |  21    22     .  .  |
C                    |   |    .      .     .   |
C      [ B | A ]  =  |   |      .      .    *  |
C                    |   |        .      .     |
C                    | 0 |   0                 |
C                    |   |          A      A   |
C                    |   |           r,r-1  rr |
C
C     where the i-th diagonal block of A has dimension KSTAIR(i), for
C     i = 1,2,...,r, the feedback matrix F is constructed recursively in
C     r steps (where the number of "stairs" r is given by KMAX). In each
C     step a unitary state-space transformation U and a part of F are
C     updated in order to achieve the final form:
C
C                       | 0   A      *   . . .  *   |
C                       |      12      .        .   |
C                       |                .      .   |
C                       |     0    A       .    .   |
C                       |           23       .  .   |
C                       |         .      .          |
C     [ U'AU + U'BF ] = |           .      .    *   | .
C                       |             .      .      |
C                       |                           |
C                       |                     A     |
C                       |                      r-1,r|
C                       |                           |
C                       |                       0   |
C
C
C     REFERENCES
C
C     [1] Van Dooren, P.
C         Deadbeat control: a special inverse eigenvalue problem.
C         BIT, 24, pp. 681-699, 1984.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O((N + M) * N**2) operations and is mixed
C     numerical stable (see [1]).
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997.
C     Supersedes Release 2.0 routine SB06BD by M. Vanbegin, and
C     P. Van Dooren, Philips Research Laboratory, Brussels, Belgium.
C
C     REVISIONS
C
C     1997, December 10; 2003, September 27.
C
C     KEYWORDS
C
C     Canonical form, deadbeat control, eigenvalue assignment, feedback
C     control, orthogonal transformation, real Schur form, staircase
C     form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, KMAX, LDA, LDB, LDF, LDU, M, N
C     .. Array Arguments ..
      INTEGER           KSTAIR(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*), F(LDF,*), U(LDU,*)
C     .. Local Scalars ..
      INTEGER           J, J0, JCUR, JKCUR, JMKCUR, KCUR, KK, KMIN,
     $                  KSTEP, MKCUR, NCONT
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DLACPY, DLARFG, DLASET, DLATZM,
     $                  DTRSM, XERBLA
C     .. Executable Statements ..
C
      INFO = 0
C
C     Test the input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( KMAX.LT.0 .OR. KMAX.GT.N ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDU.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -12
      ELSE
         NCONT = 0
C
         DO 10 KK = 1, KMAX
            NCONT = NCONT + KSTAIR(KK)
   10    CONTINUE
C
         IF( NCONT.GT.N )
     $      INFO = -8
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB06ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. M.EQ.0 )
     $   RETURN
C
      DO 120 KMIN = 1, KMAX
         JCUR = NCONT
         KSTEP = KMAX - KMIN
C
C        Triangularize bottom part of A (if KSTEP > 0).
C
         DO 40 KK = KMAX, KMAX - KSTEP + 1, -1
            KCUR = KSTAIR(KK)
C
C           Construct Ukk and store in Fkk.
C
            DO 20 J = 1, KCUR
               JMKCUR = JCUR - KCUR
               CALL DCOPY( KCUR, A(JCUR,JMKCUR), LDA, F(1,JCUR), 1 )
               CALL DLARFG( KCUR+1, A(JCUR,JCUR), F(1,JCUR), 1,
     $                      DWORK(JCUR) )
               CALL DLASET( 'Full', 1, KCUR, ZERO, ZERO, A(JCUR,JMKCUR),
     $                      LDA )
C
C              Backmultiply A and U with Ukk.
C
               CALL DLATZM( 'Right', JCUR-1, KCUR+1, F(1,JCUR), 1,
     $                      DWORK(JCUR), A(1,JCUR), A(1,JMKCUR), LDA,
     $                      DWORK )
C
               CALL DLATZM( 'Right', N, KCUR+1, F(1,JCUR), 1,
     $                      DWORK(JCUR), U(1,JCUR), U(1,JMKCUR), LDU,
     $                      DWORK(N+1) )
               JCUR = JCUR - 1
   20       CONTINUE
C
   40    CONTINUE
C
C        Eliminate diagonal block Aii by feedback Fi.
C
         KCUR = KSTAIR(KMIN)
         J0 = JCUR - KCUR + 1
         MKCUR = M - KCUR + 1
C
C        Solve for Fi and add B x Fi to A.
C
         CALL DLACPY( 'Full', KCUR, KCUR, A(J0,J0), LDA, F(MKCUR,J0),
     $                LDF )
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', KCUR,
     $               KCUR, -ONE, B(J0,MKCUR), LDB, F(MKCUR,J0), LDF )
         IF ( J0.GT.1 )
     $      CALL DGEMM( 'No transpose', 'No transpose', J0-1, KCUR,
     $                  KCUR, ONE, B(1,MKCUR), LDB, F(MKCUR,J0), LDF,
     $                  ONE, A(1,J0), LDA )
         CALL DLASET( 'Full',   KCUR, KCUR, ZERO, ZERO, A(J0,J0), LDA )
         CALL DLASET( 'Full', M-KCUR, KCUR, ZERO, ZERO, F(1,J0), LDF )
C
         IF ( KSTEP.NE.0 ) THEN
            JKCUR = NCONT
C
C           Premultiply A with Ukk.
C
            DO 80 KK = KMAX, KMAX - KSTEP + 1, -1
               KCUR = KSTAIR(KK)
               JCUR = JKCUR - KCUR
C
               DO 60 J = 1, KCUR
                  CALL DLATZM( 'Left', KCUR+1, N-JCUR+1, F(1,JKCUR), 1,
     $                         DWORK(JKCUR), A(JKCUR,JCUR),
     $                         A(JCUR,JCUR), LDA, DWORK(N+1) )
                  JCUR = JCUR - 1
                  JKCUR = JKCUR - 1
   60          CONTINUE
C
   80       CONTINUE
C
C           Premultiply B with Ukk.
C
            JCUR  = JCUR + KCUR
            JKCUR = JCUR + KCUR
C
            DO 100 J = M, M - KCUR + 1, -1
               CALL DLATZM( 'Left', KCUR+1, M-J+1, F(1,JKCUR), 1,
     $                      DWORK(JKCUR), B(JKCUR,J), B(JCUR,J), LDB,
     $                      DWORK(N+1) )
               JCUR = JCUR - 1
               JKCUR = JKCUR - 1
  100       CONTINUE
C
         END IF
  120 CONTINUE
C
      IF ( NCONT.NE.N )
     $   CALL DLASET( 'Full', M, N-NCONT, ZERO, ZERO, F(1,NCONT+1),
     $                LDF )
C
      RETURN
C *** Last line of SB06ND ***
      END


      program test
      implicit none
      integer p1,p5,p6
      integer p1d,p5d,p6d
      integer i,j,jmax
      integer x,y,z
      p1d = 4
      p5d = 3
      p6d = 2
      i = 0
      do p1 = 1, p1d
        do p5 = 1, p5d
          do p6 = 1, p6d
            i = i + 1
            j = 1 + (p6-1) + (p5-1)*p6d + (p1-1)*p5d*p6d
            print*,'1:',i,j,p1,p5,p6
          enddo
        enddo
      enddo
      jmax = p1d*p5d*p6d
      i = 0
      do j = 1, jmax
        i = i + 1
        p6 = 1+mod(j-1,p6d)
        x  = 1+(j-p6)/p6d
        p5 = 1+mod(x-1,p5d)
        y  = 1+(x-p5)/p5d
        p1 = 1+mod(y-1,p1d)
        print*,'2:',i,j,p1,p5,p6
      enddo
      end program


!
!  Purpose:
!
!  Defines a class for 3-dimensional cartesian vector calculations
!
module type_Vector3D

    use spherepack_precision, only: &
        wp, & ! working precision
        ip ! integer precision

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: Vector3D
    public :: Vector3DPointer
    public :: assignment(=)
    public :: operator(*)

    ! Parameters confined to the module
    real(wp), parameter :: ZERO = 0.0_wp

    type, public :: Vector3D
        ! Type components
        real(wp), public :: x = ZERO
        real(wp), public :: y = ZERO
        real(wp), public :: z = ZERO
    contains
        ! Type-bound procedures
        procedure,          private  :: add_vectors
        procedure,          private  :: subtract_vectors
        procedure,          private  :: divide_vector_by_real
        procedure,          private  :: divide_vector_by_integer
        procedure,          private  :: get_dot_product
        procedure,          private  :: assign_vector_from_integer_array
        procedure,          private  :: assign_vector_from_real_array
        procedure, nopass,  private  :: assign_real_array_from_vector
        procedure,          private  :: copy_vector
        procedure,          private  :: multiply_vector_times_real
        procedure, nopass,  private  :: multiply_real_times_vector
        procedure,          private  :: multiply_vector_times_integer
        procedure, nopass,  private  :: multiply_integer_times_vector
        procedure,          private  :: get_cross_product
        procedure,          public   :: get_norm
        ! Generic type-bound procedures
        generic, public :: operator(.dot.) => get_dot_product
        generic, public :: operator(.cross.) => get_cross_product
        generic, public :: operator(+) => add_vectors
        generic, public :: operator(-) => subtract_vectors
        generic, public :: operator(/) => &
            divide_vector_by_real, &
            divide_vector_by_integer
    end type Vector3D

    type, public :: Vector3DPointer
        ! Type components
        type(Vector3D), pointer :: ptr => null()
    end type Vector3DPointer

    ! Interface for assignment operator
    interface assignment(=)
        module procedure assign_vector_from_integer_array
        module procedure assign_vector_from_real_array
        module procedure assign_real_array_from_vector
        module procedure copy_vector
    end interface

    ! Interface for multiplication operator
    interface operator(*)
        module procedure multiply_vector_times_real
        module procedure multiply_real_times_vector
        module procedure multiply_vector_times_integer
        module procedure multiply_integer_times_vector
        module procedure get_cross_product
    end interface

contains

    subroutine assign_vector_from_integer_array(self, array)

        ! Dummy arguments
        class(Vector3D),  intent(out) :: self
        integer(ip),      intent(in)  :: array(:)

        select type(self)
            type is (Vector3D)
            self%x = real(array(1), kind=wp)
            self%y = real(array(2), kind=wp)
            self%z = real(array(3), kind=wp)
        end select

    end subroutine assign_vector_from_integer_array

    subroutine assign_vector_from_real_array(self, array)

        ! Dummy arguments
        class(Vector3D), intent(out) :: self
        real(wp),        intent(in)  :: array(:)

        select type(self)
            type is (Vector3D)
            self%x = array(1)
            self%y = array(2)
            self%z = array(3)
        end select
    end subroutine assign_vector_from_real_array

    pure subroutine assign_real_array_from_vector(array, self)

        ! Dummy arguments
        real(wp),        intent(out) :: array(:)
        class(Vector3D), intent(in)  :: self

        select type(self)
            type is (Vector3D)
            array(1) = self%x
            array(2) = self%y
            array(3) = self%z
        end select

    end subroutine assign_real_array_from_vector

    subroutine copy_vector(self, other)

        ! Dummy arguments
        class(Vector3D), intent(out) :: self
        class(Vector3D), intent(in)  :: other

        self%x = other%x
        self%y = other%y
        self%z = other%z

    end subroutine copy_vector

    pure function add_vectors(self, other) &
        result (return_value)

        ! Dummy arguments
        class(Vector3D), intent(in) :: self
        class(Vector3D), intent(in) :: other
        type(Vector3D)              :: return_value

        return_value%x = self%x + other%x
        return_value%y = self%y + other%y
        return_value%z = self%z + other%z

    end function add_vectors

    pure function subtract_vectors(self, other) &
        result (return_value)

        ! Dummy arguments
        class(Vector3D), intent(in) :: self
        class(Vector3D), intent(in) :: other
        type(Vector3D)              :: return_value

        return_value%x = self%x - other%x
        return_value%y = self%y - other%y
        return_value%z = self%z - other%z

    end function subtract_vectors

    pure function multiply_vector_times_real(self, real_var) &
        result (return_value)

        ! Dummy arguments
        class(Vector3D), intent(in) :: self
        real(wp),        intent(in) :: real_var
        type(Vector3D)              :: return_value

        return_value%x = self%x * real_var
        return_value%y = self%y * real_var
        return_value%z = self%z * real_var

    end function multiply_vector_times_real

    pure function multiply_real_times_vector(real_var, other) &
        result (return_value)

        ! Dummy arguments
        real(wp),        intent(in) :: real_var
        class(Vector3D), intent(in) :: other
        type(Vector3D)              :: return_value

        return_value%x = real_var * other%x
        return_value%y = real_var * other%y
        return_value%z = real_var * other%z

    end function multiply_real_times_vector

    pure function multiply_vector_times_integer(self, int_var) &
        result (return_value)

        ! Dummy arguments
        class(Vector3D), intent(in) :: self
        integer(ip),     intent(in) :: int_var
        type(Vector3D)              :: return_value

        ! Local variables
        real(wp) :: real_var

        real_var = real(int_var, kind=wp)

        return_value%x = self%x * real_var
        return_value%y = self%y * real_var
        return_value%z = self%z * real_var

    end function multiply_vector_times_integer

    pure function multiply_integer_times_vector(int_var, other) &
        result (return_value)

        ! Dummy arguments
        integer(ip),     intent(in) :: int_var
        class(Vector3D), intent(in) :: other
        type(Vector3D)              :: return_value

        ! Local variables
        real(wp) :: real_var

        real_var = real(int_var, kind=wp)

        return_value%x = real_var * other%x
        return_value%y = real_var * other%y
        return_value%z = real_var * other%z

    end function multiply_integer_times_vector

    pure function divide_vector_by_real(self, real_var) &
        result (return_value)

        ! Dummy arguments
        class(Vector3D), intent(in) :: self
        real(wp),        intent(in) :: real_var
        type(Vector3D)              :: return_value

        return_value%x = self%x / real_var
        return_value%y = self%y / real_var
        return_value%z = self%z / real_var

    end function divide_vector_by_real

    pure function divide_vector_by_integer(self, int_var) &
        result (return_value)

        ! Dummy arguments
        class(Vector3D), intent(in) :: self
        integer(ip),     intent(in) :: int_var
        type(Vector3D)              :: return_value

        return_value%x = self%x / int_var
        return_value%y = self%y / int_var
        return_value%z = self%z / int_var

    end function divide_vector_by_integer

    pure function get_dot_product(self, other) &
        result (return_value)

        ! Dummy arguments
        real(wp)                    :: return_value
        class(Vector3D), intent(in) :: self
        class(Vector3D), intent(in) :: other

        associate (&
            a => [self%x, self%y, self%z], &
            b => [other%x, other%y, other%z] &
           )
            return_value = dot_product(a, b)
        end associate

    end function get_dot_product

    pure function get_cross_product(self, other) &
        result (return_value)

        ! Dummy arguments
        class(Vector3D), intent(in) :: self
        class(Vector3D), intent(in) :: other
        type(Vector3D)              :: return_value

        return_value%x = self%y * other%z - self%z * other%y
        return_value%y = self%z * other%x - self%x * other%z
        return_value%z = self%x * other%y - self%y * other%x

    end function get_cross_product

    pure function get_norm(self) &
        result (return_value)

        ! Dummy arguments
        class(Vector3D), intent(in) :: self
        real(wp)                    :: return_value

        associate (array => [self%x, self%y, self%z])
            return_value = norm2(array)
        end associate

    end function get_norm

end module type_Vector3D


PROGRAM Numeric_Inquiry

  ! ------------
  ! Module usage
  ! ------------

  USE Type_Kinds     , ONLY: Single, Double
  USE Message_Handler, ONLY: Program_Message

  ! -----------------------
  ! Disable implicit typing
  ! -----------------------

  IMPLICIT NONE

  ! ----------
  ! Parameters
  ! ----------

  CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'Numeric_Inquiry'
  CHARACTER(*), PARAMETER :: PROGRAM_VERSION_ID = &

  REAL(Single), PARAMETER :: SP_ONE = 1.0_Single
  REAL(Double), PARAMETER :: DP_ONE = 1.0_Double

  INTEGER, PARAMETER :: N_TEST_NUMBERS = 5
  REAL(Single), PARAMETER :: SP_TEST_NUMBER(N_TEST_NUMBERS) = &
    (/ 1.234567890123456e-16_Single, &
       1.234567890123456e-01_Single, &
       1.234567890123456e+01_Single, &
       1.234567890123456e+16_Single, &
       0.01_Single /)
  REAL(Double), PARAMETER :: DP_TEST_NUMBER(N_TEST_NUMBERS) = &
    (/ 1.234567890123456e-16_Double, &
       1.234567890123456e-01_Double, &
       1.234567890123456e+01_Double, &
       1.234567890123456e+16_Double, &
       0.01_Double /)

  ! ------------
  ! Derived type
  ! ------------

  TYPE :: SP_NI_type
    REAL(Single) :: Number
    INTEGER      :: Digits
    REAL(Single) :: Epsilon
    REAL(Single) :: Huge
    INTEGER      :: MaxExponent
    INTEGER      :: MinExponent
    INTEGER      :: Precision
    INTEGER      :: Radix
    INTEGER      :: Range
    REAL(Single) :: Tiny
    INTEGER      :: Exponent
    REAL(Single) :: Fraction
    REAL(Single) :: mNearest
    REAL(Single) :: pNearest
    REAL(Single) :: RRSpacing
    REAL(Single) :: Scale_x_0
    REAL(Single) :: Set_Exponent_x_0
    REAL(Single) :: Spacing
    REAL(Single) :: Epsilon_on_Spacing
    REAL(Single) :: Epsilon_Delta
  END TYPE SP_NI_type

  TYPE :: DP_NI_type
    REAL(Double) :: Number
    INTEGER      :: Digits
    REAL(Double) :: Epsilon
    REAL(Double) :: Huge
    INTEGER      :: MaxExponent
    INTEGER      :: MinExponent
    INTEGER      :: Precision
    INTEGER      :: Radix
    INTEGER      :: Range
    REAL(Double) :: Tiny
    INTEGER      :: Exponent
    REAL(Double) :: Fraction
    REAL(Double) :: mNearest
    REAL(Double) :: pNearest
    REAL(Double) :: RRSpacing
    REAL(Double) :: Scale_x_0
    REAL(Double) :: Set_Exponent_x_0
    REAL(Double) :: Spacing
    REAL(Double) :: Epsilon_on_Spacing
    REAL(Double) :: Epsilon_Delta
  END TYPE DP_NI_type

  ! ---------
  ! Variables
  ! ---------
  INTEGER :: i
  TYPE(SP_NI_type) :: SP_NI(N_TEST_NUMBERS)
  TYPE(DP_NI_type) :: DP_NI(N_TEST_NUMBERS)

  ! Program header
  CALL Program_Message( PROGRAM_NAME, &
                        'Program to display numeric inquiry intrinsic results.', &
                        '$Revision$' )

  ! Output data for single type
  WRITE( *, '( /5x, "Single kind type : ", i5 )' ) Single
  DO i = 1, N_TEST_NUMBERS
    SP_NI(i)%Number = SP_TEST_NUMBER(i)
    SP_NI(i)%Digits             = DIGITS(       SP_NI(i)%Number )
    SP_NI(i)%Epsilon            = EPSILON(      SP_NI(i)%Number )
    SP_NI(i)%Huge               = HUGE(         SP_NI(i)%Number )
    SP_NI(i)%MaxExponent        = MAXEXPONENT(  SP_NI(i)%Number )
    SP_NI(i)%MinExponent        = MINEXPONENT(  SP_NI(i)%Number )
    SP_NI(i)%Precision          = PRECISION(    SP_NI(i)%Number )
    SP_NI(i)%Radix              = RADIX(        SP_NI(i)%Number )
    SP_NI(i)%Range              = RANGE(        SP_NI(i)%Number )
    SP_NI(i)%Tiny               = TINY(         SP_NI(i)%Number )
    SP_NI(i)%Exponent           = EXPONENT(     SP_NI(i)%Number )
    SP_NI(i)%Fraction           = FRACTION(     SP_NI(i)%Number )
    SP_NI(i)%mNearest           = NEAREST(      SP_NI(i)%Number, -SP_NI(i)%Number )
    SP_NI(i)%pNearest           = NEAREST(      SP_NI(i)%Number,  SP_NI(i)%Number )
    SP_NI(i)%RRSpacing          = RRSPACING(    SP_NI(i)%Number )
    SP_NI(i)%Scale_x_0          = SCALE(        SP_NI(i)%Number, 0 )
    SP_NI(i)%Set_Exponent_x_0   = SET_EXPONENT( SP_NI(i)%Number, 0 )
    SP_NI(i)%Spacing            = SPACING(      SP_NI(i)%Number )
    SP_NI(i)%Epsilon_on_Spacing = SP_NI(i)%Epsilon / SP_NI(i)%Spacing
    SP_NI(i)%Epsilon_Delta      = SP_NI(i)%Epsilon * REAL(SP_NI(i)%Radix,Single)**(SP_NI(i)%Exponent-1)
  END DO

  WRITE( *, '( /2x, "Number            = ", 10(1x,es20.13) )' ) SP_NI%Number
  WRITE( *, '(  2x, "--------------------", 10(a)          )' ) RESHAPE( (/'---------------------'/), &
                                                                         (/ N_TEST_NUMBERS /), &
                                                                         (/'---------------------'/))
  WRITE( *, '(  2x, "DIGITS()          = ", 10(16x,i5)     )' ) SP_NI%Digits
  WRITE( *, '(  2x, "EPSILON()         = ", 10(1x,es20.13) )' ) SP_NI%Epsilon
  WRITE( *, '(  2x, "HUGE()            = ", 10(1x,es20.13) )' ) SP_NI%Huge
  WRITE( *, '(  2x, "MAXEXPONENT()     = ", 10(16x,i5)     )' ) SP_NI%MaxExponent
  WRITE( *, '(  2x, "MINEXPONENT()     = ", 10(16x,i5)     )' ) SP_NI%MinExponent
  WRITE( *, '(  2x, "PRECISION()       = ", 10(16x,i5)     )' ) SP_NI%Precision
  WRITE( *, '(  2x, "RADIX()           = ", 10(16x,i5)     )' ) SP_NI%Radix
  WRITE( *, '(  2x, "RANGE()           = ", 10(16x,i5)     )' ) SP_NI%Range
  WRITE( *, '(  2x, "TINY()            = ", 10(1x,es20.13) )' ) SP_NI%Tiny
  WRITE( *, '(  2x, "EXPONENT()        = ", 10(16x,i5)     )' ) SP_NI%Exponent
  WRITE( *, '(  2x, "FRACTION()        = ", 10(1x,es20.13) )' ) SP_NI%Fraction
  WRITE( *, '(  2x, "NEAREST(-)        = ", 10(1x,es20.13) )' ) SP_NI%mNearest
  WRITE( *, '(  2x, "NEAREST(+)        = ", 10(1x,es20.13) )' ) SP_NI%pNearest
  WRITE( *, '(  2x, "RRSPACING()       = ", 10(1x,es20.13) )' ) SP_NI%RRSpacing
  WRITE( *, '(  2x, "SCALE(x,0)        = ", 10(1x,es20.13) )' ) SP_NI%Scale_x_0
  WRITE( *, '(  2x, "SET_EXPONENT(x,0) = ", 10(1x,es20.13) )' ) SP_NI%Set_Exponent_x_0
  WRITE( *, '(  2x, "SPACING()         = ", 10(1x,es20.13) )' ) SP_NI%Spacing
  WRITE( *, '(  2x, "EPSILON/SPACING   = ", 10(1x,es20.13) )' ) SP_NI%Epsilon_on_Spacing
  WRITE( *, '(  2x, "EPSILON_DELTA     = ", 10(1x,es20.13) )' ) SP_NI%Epsilon_Delta

  ! Output data for double type
  WRITE( *, '(//5x, "Double kind type : ", i5 )' ) Double
  DO i = 1, N_TEST_NUMBERS
    DP_NI(i)%Number = DP_TEST_NUMBER(i)
    DP_NI(i)%Digits             = DIGITS(       DP_NI(i)%Number )
    DP_NI(i)%Epsilon            = EPSILON(      DP_NI(i)%Number )
    DP_NI(i)%Huge               = HUGE(         DP_NI(i)%Number )
    DP_NI(i)%MaxExponent        = MAXEXPONENT(  DP_NI(i)%Number )
    DP_NI(i)%MinExponent        = MINEXPONENT(  DP_NI(i)%Number )
    DP_NI(i)%Precision          = PRECISION(    DP_NI(i)%Number )
    DP_NI(i)%Radix              = RADIX(        DP_NI(i)%Number )
    DP_NI(i)%Range              = RANGE(        DP_NI(i)%Number )
    DP_NI(i)%Tiny               = TINY(         DP_NI(i)%Number )
    DP_NI(i)%Exponent           = EXPONENT(     DP_NI(i)%Number )
    DP_NI(i)%Fraction           = FRACTION(     DP_NI(i)%Number )
    DP_NI(i)%mNearest           = NEAREST(      DP_NI(i)%Number, -DP_NI(i)%Number )
    DP_NI(i)%pNearest           = NEAREST(      DP_NI(i)%Number,  DP_NI(i)%Number )
    DP_NI(i)%RRSpacing          = RRSPACING(    DP_NI(i)%Number )
    DP_NI(i)%Scale_x_0          = SCALE(        DP_NI(i)%Number, 0 )
    DP_NI(i)%Set_Exponent_x_0   = SET_EXPONENT( DP_NI(i)%Number, 0 )
    DP_NI(i)%Spacing            = SPACING(      DP_NI(i)%Number )
    DP_NI(i)%Epsilon_on_Spacing = DP_NI(i)%Epsilon / DP_NI(i)%Spacing
    DP_NI(i)%Epsilon_Delta      = DP_NI(i)%Epsilon * REAL(DP_NI(i)%Radix,Double)**(DP_NI(i)%Exponent-1)
  END DO
  WRITE( *, '( /2x, "Number            = ", 10(1x,es27.20) )' ) DP_NI%Number
  WRITE( *, '(  2x, "--------------------", 10(a)         )' ) RESHAPE( (/'----------------------------'/), &
                                                                        (/ N_TEST_NUMBERS /), &
                                                                        (/'----------------------------'/))
  WRITE( *, '(  2x, "DIGITS()          = ", 10(23x,i5)     )' ) DP_NI%Digits
  WRITE( *, '(  2x, "EPSILON()         = ", 10(1x,es27.20) )' ) DP_NI%Epsilon
  WRITE( *, '(  2x, "HUGE()            = ", 10(1x,es27.20) )' ) DP_NI%Huge
  WRITE( *, '(  2x, "MAXEXPONENT()     = ", 10(23x,i5)     )' ) DP_NI%MaxExponent
  WRITE( *, '(  2x, "MINEXPONENT()     = ", 10(23x,i5)     )' ) DP_NI%MinExponent
  WRITE( *, '(  2x, "PRECISION()       = ", 10(23x,i5)     )' ) DP_NI%Precision
  WRITE( *, '(  2x, "RADIX()           = ", 10(23x,i5)     )' ) DP_NI%Radix
  WRITE( *, '(  2x, "RANGE()           = ", 10(23x,i5)     )' ) DP_NI%Range
  WRITE( *, '(  2x, "TINY()            = ", 10(1x,es27.20) )' ) DP_NI%Tiny
  WRITE( *, '(  2x, "EXPONENT()        = ", 10(23x,i5)     )' ) DP_NI%Exponent
  WRITE( *, '(  2x, "FRACTION()        = ", 10(1x,es27.20) )' ) DP_NI%Fraction
  WRITE( *, '(  2x, "NEAREST(-)        = ", 10(1x,es27.20) )' ) DP_NI%mNearest
  WRITE( *, '(  2x, "NEAREST(+)        = ", 10(1x,es27.20) )' ) DP_NI%pNearest
  WRITE( *, '(  2x, "RRSPACING()       = ", 10(1x,es27.20) )' ) DP_NI%RRSpacing
  WRITE( *, '(  2x, "SCALE(x,0)        = ", 10(1x,es27.20) )' ) DP_NI%Scale_x_0
  WRITE( *, '(  2x, "SET_EXPONENT(x,0) = ", 10(1x,es27.20) )' ) DP_NI%Set_Exponent_x_0
  WRITE( *, '(  2x, "SPACING()         = ", 10(1x,es27.20) )' ) DP_NI%Spacing
  WRITE( *, '(  2x, "EPSILON/SPACING   = ", 10(1x,es27.20) )' ) DP_NI%Epsilon_on_Spacing
  WRITE( *, '(  2x, "EPSILON_DELTA     = ", 10(1x,es27.20) )' ) DP_NI%Epsilon_Delta

END PROGRAM Numeric_Inquiry

!-------------------------------------------------------------------------------
!                          -- MODIFICATION HISTORY --
!-------------------------------------------------------------------------------
!
!
! $Date: 2004/08/31 19:25:54 $
!
! $Revision$
!
! $Name:  $
!
! $State: Exp $
!
! $Log: Numeric_Inquiry.f90,v $
! Revision 1.3  2004/08/31 19:25:54  paulv
! - Altered code to report data separately for Single and Double kind types.
!
! Revision 1.2  2004/08/13 20:26:28  paulv
! - Fixed a bug using the NEAREST intrinsic.
!
! Revision 1.1  2003/07/03 21:40:13  paulv
! Initial checkin.
!
!


program leapyear
    implicit none
    integer :: year

    year = get_year()
    if (is_leapyear(year)) then
        print '(I0, A)', year, ' is a leap year'
    else
        print '(I0, A)', year, ' is not a leap year'
    end if

contains

    integer function get_year()
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        character(len=256) :: buffer

        if (command_argument_count() /= 1) then
            write (unit=error_unit, fmt='(A)') &
                'error: expecting a year as argument'
            stop 1
        end if
        call get_command_argument(1, buffer)
        read (buffer, '(I10)') get_year
    end function get_year

    logical function is_leapyear(year)
        implicit none
        integer, intent(in) :: year

        if (mod(year, 4) /= 0) then
            is_leapyear = .false.
        else if (mod(year, 100) == 0) then
            if (mod(year, 400) == 0) then
                is_leapyear = .true.
            else
                is_leapyear = .false.
            end if
        else
            is_leapyear = .true.
        end if
    end function is_leapyear

end program leapyear


module init_phi_module

  use multifab_module

  implicit none

  private

  public :: init_phi

contains

  subroutine init_phi(phi,dx,prob_lo)

    type(multifab) , intent(inout) :: phi
    real(kind=dp_t), intent(in   ) :: dx
    real(kind=dp_t), intent(in   ) :: prob_lo(phi%dim)

    ! local variables
    integer :: lo(phi%dim), hi(phi%dim)
    integer :: dm, ng, i

    real(kind=dp_t), pointer :: dp(:,:,:,:)

    ! set these here so we don't have to pass them into the subroutine
    dm = phi%dim
    ng = phi%ng

    do i=1,nfabs(phi)
       dp => dataptr(phi,i)
       lo = lwb(get_box(phi,i))
       hi = upb(get_box(phi,i))
       select case(dm)
       case (2)
          call init_phi_2d(dp(:,:,1,1), ng, lo, hi, prob_lo, dx)
       case (3)
          call init_phi_3d(dp(:,:,:,1), ng, lo, hi, prob_lo, dx)
       end select
    end do

    ! fill ghost cells
    ! this only fills periodic ghost cells and ghost cells for neighboring
    ! grids at the same level.  Physical boundary ghost cells are filled
    ! using multifab_physbc.  But this problem is periodic, so this
    ! call is sufficient.
    call multifab_fill_boundary(phi)

  end subroutine init_phi

  subroutine init_phi_2d(phi, ng, lo, hi, prob_lo, dx)

    integer          :: lo(2), hi(2), ng
    double precision :: phi(lo(1)-ng:,lo(2)-ng:)
    double precision :: prob_lo(2)
    double precision :: dx

    ! local varables
    integer          :: i,j
    double precision :: x,y,r2

    do j=lo(2),hi(2)
         y = prob_lo(2) + (dble(j)+0.5d0) * dx
         do i=lo(1),hi(1)
            x = prob_lo(1) + (dble(i)+0.5d0) * dx

            r2 = ((x-0.25d0)**2 + (y-0.25d0)**2) / 0.01d0
            phi(i,j) = 1.d0 + exp(-r2)

         end do
      end do

    end subroutine init_phi_2d

    subroutine init_phi_3d(phi, ng, lo, hi, prob_lo, dx)

    integer          :: lo(3), hi(3), ng
    double precision :: phi(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:)
    double precision :: prob_lo(3)
    double precision :: dx

    ! local varables
    integer          :: i,j,k
    double precision :: x,y,z,r2

    !$omp parallel do private(i,j,k,x,y,z,r2)
    do k=lo(3),hi(3)
       z = prob_lo(3) + (dble(k)+0.5d0) * dx
       do j=lo(2),hi(2)
          y = prob_lo(2) + (dble(j)+0.5d0) * dx
          do i=lo(1),hi(1)
             x = prob_lo(1) + (dble(i)+0.5d0) * dx

             r2 = ((x-0.25d0)**2 + (y-0.25d0)**2 + (z-0.25d0)**2) / 0.01d0
             phi(i,j,k) = 1.d0 + exp(-r2)

          end do
       end do
    end do
    !$omp end parallel do

  end subroutine init_phi_3d

end module init_phi_module


!!# MODULE: SUBROUTINE <SUB_prodQuadrature>
MODULE SUB_prodQuadrature
!!## PURPOSE
!! Return a product quadrature set on the unit
!! sphere (each polar angle (from z-axis) has the same set of
!! azimuthal angles (angles in xy-plane).

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!## EXTERNAL PARAMETERS
USE PAR_Constants_Rdp,ONLY: c_2                !!((02-A-PAR_Constants_Rdp.f90))

!!## EXTERNAL PROCEDURES
USE SUB_aQuadrature_GL                         !!((06-B-SUB_aQuadrature_GL.f90))
USE SUB_aQuadrature_AS                         !!((06-B-SUB_aQuadrature_AS.f90))
USE SUB_aQuadrature_U                          !!((06-B-SUB_aQuadrature_U.f90))

USE SUB_pQuadrature_dGL                        !!((06-B-SUB_pQuadrature_dGL.f90))
USE SUB_pQuadrature_GL                         !!((06-B-SUB_pQuadrature_GL.f90))
USE SUB_pQuadrature_AS                         !!((06-B-SUB_pQuadrature_AS.f90))

USE SUB_CLEAR                                  !!((04-A-SUB_CLEAR.f90))
USE FUN_Error                                  !!((04-A-FUN_Error.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## PROCEDURE LISTING
INTERFACE prodQuadrature
 MODULE PROCEDURE prodQuadrature_Rsp
 MODULE PROCEDURE prodQuadrature_Rdp
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: prodQuadrature

!!## MODULE PROCEDURES
CONTAINS

!!### PURE SUBROUTINE: prodQuadrature_Rsp
PURE SUBROUTINE prodQuadrature_Rsp( aQuadrature , aOrder , &
                                    pQuadrature , pOrder , &
                                    xa , xp , wa , wp , &
                                    errint , errmsg , &
                                    UniformZGeometry )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-SUB_prodQuadrature.f90.hdr"
!!--begin--
INCLUDE "07-B-SUB_prodQuadrature.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: prodQuadrature_Rdp
PURE SUBROUTINE prodQuadrature_Rdp( aQuadrature , aOrder , &
                                    pQuadrature , pOrder , &
                                    xa , xp , wa , wp , &
                                    errint , errmsg , &
                                    UniformZGeometry )
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "07-B-SUB_prodQuadrature.f90.hdr"
!!--begin--
INCLUDE "07-B-SUB_prodQuadrature.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


program driver
   use stats
   implicit none
   interface
      subroutine rdfile(x, y, n, fname)
         integer, intent(in) :: n
         real, dimension(n), intent(out) :: x, y
         character (len=*), intent(in) :: fname
      end subroutine rdfile
      subroutine wtfile(x, y, n, fname)
         integer, intent(in) :: n
         real, dimension(n), intent(in) :: x, y
         character (len=*), intent(in) :: fname
      end subroutine
      subroutine report(x, n)
         integer, intent(in) :: n
         real, dimension(n), intent(in) :: x
      end subroutine report
   end interface
   ! variable and array declarations
   integer, parameter :: N = 1000
   integer :: i
   real, dimension(N) :: x, y
   ! processing
   call srand(time())
   ! create and dump data sets
   call uniform(x, N)
   call uniform(y, N)
   call wtfile(x, y, N, 'uniform.dat')
   call randnorm(x, N)
   call randnorm(y, N)
   call mergesort(x, N)
   call mergesort(y, N)
   call wtfile(x, y, N, 'normal.dat')
   ! uniform tests
   call rdfile(x, y, N, 'uniform.dat')
   write (*,*) 'random uniform distributions'
   write (*,*) 'x'
   call report(x, N)
   write (*,*) 'y'
   call report(y, N)
   write (*,*) 'x y'
   write (*,*) 'covariance = ', covar(x, y, N)
   write (*,*) 'correlation coefficient = ', correlation_coefficient(x, y, N)
   ! randnorm tests
   call rdfile(x, y, N, 'normal.dat')
   write (*,*) 'random normal distributions'
   write (*,*) 'x'
   call report(x, N)
   write (*,*) 'y'
   call report(y, N)
   write (*,*) 'x y'
   write (*,*) 'covariance = ', covar(x, y, N)
   write (*,*) 'correlation coefficient = ', correlation_coefficient(x, y, N)
end program driver


!==========================================================================
elemental subroutine gsw_ct_first_derivatives (sa, pt, ct_sa, ct_pt)
!==========================================================================
!
!  Calculates the following two derivatives of Conservative Temperature
!  (1) CT_SA, the derivative with respect to Absolute Salinity at
!      constant potential temperature (with pr = 0 dbar), and
!   2) CT_pt, the derivative with respect to potential temperature
!      (the regular potential temperature which is referenced to 0 dbar)
!      at constant Absolute Salinity.
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  pt  =  potential temperature (ITS-90)                          [ deg C ]
!         (whose reference pressure is 0 dbar)
!
!  CT_SA  =  The derivative of Conservative Temperature with respect to
!            Absolute Salinity at constant potential temperature
!            (the regular potential temperature which has reference
!            sea pressure of 0 dbar).
!            The CT_SA output has units of:                     [ K/(g/kg)]
!  CT_pt  =  The derivative of Conservative Temperature with respect to
!            potential temperature (the regular one with pr = 0 dbar)
!            at constant SA. CT_pt is dimensionless.           [ unitless ]
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : gsw_cp0, gsw_sfac, gsw_t0

use gsw_mod_toolbox, only : gsw_gibbs_pt0_pt0

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, pt
real (r8), intent(out), optional :: ct_sa, ct_pt

real (r8) :: abs_pt, g_sa_mod, g_sa_t_mod, x, y_pt

abs_pt = gsw_t0 + pt

if (present(ct_pt)) ct_pt = -(abs_pt*gsw_gibbs_pt0_pt0(sa,pt))/gsw_cp0

if (.not. present(ct_sa)) return

!--------------------------------------------------------------------------

x = sqrt(gsw_sfac*sa)
y_pt = 0.025_r8*pt

g_sa_t_mod = 1187.3715515697959_r8 + &
        x*(-1480.222530425046_r8 + x*(2175.341332000392_r8 + x*(-980.14153344888_r8 + 220.542973797483_r8*x) + &
        y_pt*(-548.4580073635929_r8 + y_pt*(592.4012338275047_r8 + y_pt*(-274.2361238716608_r8 + 49.9394019139016_r8*y_pt)))) + &
        y_pt*(-258.3988055868252_r8 + y_pt*(-90.2046337756875_r8 + y_pt*10.50720794170734_r8))) + &
        y_pt*(3520.125411988816_r8  + y_pt*(-1351.605895580406_r8 + &
        y_pt*(731.4083582010072_r8  + y_pt*(-216.60324087531103_r8 + 25.56203650166196_r8*y_pt))))
g_sa_t_mod = 0.5_r8*gsw_sfac*0.025_r8*g_sa_t_mod

g_sa_mod = 8645.36753595126_r8 + &
        x*(-7296.43987145382_r8 + x*(8103.20462414788_r8 + &
        y_pt*(2175.341332000392_r8 + y_pt*(-274.2290036817964_r8 + &
        y_pt*(197.4670779425016_r8 + y_pt*(-68.5590309679152_r8 + 9.98788038278032_r8*y_pt)))) + &
        x*(-5458.34205214835_r8 - 980.14153344888_r8*y_pt + &
        x*(2247.60742726704_r8 - 340.1237483177863_r8*x + 220.542973797483_r8*y_pt))) + &
        y_pt*(-1480.222530425046_r8 + &
        y_pt*(-129.1994027934126_r8 + &
        y_pt*(-30.0682112585625_r8 + y_pt*(2.626801985426835_r8 ))))) + &
        y_pt*(1187.3715515697959_r8 + &
        y_pt*(1760.062705994408_r8 + y_pt*(-450.535298526802_r8 + &
        y_pt*(182.8520895502518_r8 + y_pt*(-43.3206481750622_r8 + 4.26033941694366_r8*y_pt)))))
g_sa_mod = 0.5_r8*gsw_sfac*g_sa_mod

ct_sa = (g_sa_mod - abs_pt*g_sa_t_mod)/gsw_cp0

return
end subroutine

!--------------------------------------------------------------------------


program mathinit

!   This program pre-computes data to be read by the mathtool program.  By
!   default, the parameter nquadopt is set below to 1, so that only data for
!   the tanh-sinh quadrature routine is generated.  Setting nquadopt to 2
!   generates data for two quadrature routines (tanh-sinh and error function).
!   Setting nquadopt to 3 generates data for all three quadrature routines
!   (tanh-sinh, error function and Gaussian).  Typical run times on a 2004-era
!   computer (assuming ndigmx1 = 1000, ndigmx2 = 2000 and nquadx = 10):
!     Tanh-sinh        2 minutes
!     Error function   10 minutes
!     Gaussian         100 minutes
!     Total            112 minutes

!   See the comments at the start of globdata.f regarding this program.
!   If the message "table space parameter is too small" appears when this
!   program is run, the value of nquadz in globdata.f must be increased --
!   typically change the "18" in "nquadz = 18 ** nquadx", the formula for
!   nquadz, to some higher value, such as 25.

!   David H Bailey    2004-07-01

use mpmodule
use globdata
integer i, nq3, nquadopt
parameter (nquadopt = 1)
real*8 second, tm0, tm1, tm2
type (mp_real) catalan, eulergamma, t1, t2
external catalan, eulergamma, second

call mpinit (ndigmx2)
ndebug = 2
write (6, *) 'mathinit: start'
tm0 = second ()

!   Generate several constants.

tm1 = second ()
open (11, file = 'const.dat', form = 'unformatted')
t1 = catalan ()
t2 = eulergamma ()
write (6, *) 'const complete'
write (11) t1, t2
rewind (11)
close (11)
write (6, *) 'file const.dat written'
tm2 = second ()
write (6, *) 'cpu time =', tm2 - tm1

call mpsetprec (ndigmx1)

if (nquadopt >= 1) then

!   Generate data for tanh-sinh quadrature.

  tm1 = second ()
  open (11, file = 'quadts.dat', form = 'unformatted')
  call initqts (nquadx, nquadz, nq3, quadwk, quadxk)
  write (6, *) 'initqts complete'
  write (11) nq3
  write (11) (quadwk(i), i = -1, nq3)
  write (11) (quadxk(i), i = -1, nq3)
  rewind (11)
  close (11)
  write (6, *) 'file quadts.dat written'
  tm2 = second ()
  write (6, *) 'cpu time =', tm2 - tm1
endif

if (nquadopt >= 2) then

!   Generate data for erf quadrature.

  tm1 = second ()
  open (11, file = 'quaderf.dat', form = 'unformatted')
  call initqerf (nquadx, nquadz, nq3, quadwk, quadxk)
  write (6, *) 'initqerf complete'
  write (11) nq3
  write (11) (quadwk(i), i = -1, nq3)
  write (11) (quadxk(i), i = -1, nq3)
  rewind (11)
  close (11)
  write (6, *) 'file quaderf.dat written'
  tm2 = second ()
  write (6, *) 'cpu time =', tm2 - tm1
endif

if (nquadopt >= 3) then

!   Generate data for Gaussian quadrature.

  tm1 = second ()
  open (11, file = 'quadgs.dat', form = 'unformatted')
  call initqgs (nquadx, nquadz, nq3, quadwk, quadxk)
  write (6, *) 'initqt complete'
  write (11) nq3
  write (11) (quadwk(i), i = -1, nq3)
  write (11) (quadxk(i), i = -1, nq3)
  rewind (11)
  close (11)
  write (6, *) 'file quadgs.dat written'
  tm2 = second ()
  write (6, *) 'cpu time =', tm2 - tm1
endif

write (6, *) 'total cpu time =', tm2 - tm0
stop
end

subroutine initqgs (nq1, nq2, nq3, wk, xk)

!   This subroutine initializes the quadrature arays xk and wk for Gaussian
!   quadrature.  It employs a Newton iteration scheme with a dynamic precision
!   level.  The argument nq2, which is the space allocated for wk and xk in
!   the calling program, should be at least 8 * 2^nq1 + 100, although a higher
!   value may be required, depending on precision level.  Monitor the space
!   figure given in the message below during initialization to be certain.
!   Modified for the Toolkit
!   David H Bailey    2004-05-27

use mpmodule
use globdata
implicit none
integer i, ierror, ik0, is, j, j1, k, n, nq1, nq2, nq3, nwp, nws
double precision pi
parameter (pi = 3.141592653589793238d0)
type (mp_real) eps, r, t1, t2, t3, t4, t5, wk(-1:nq2), xk(-1:nq2)
parameter (ik0 = 100)

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqgs: Gaussian quadrature initialization')
endif

call mpgetprecwords (nws)
eps = 2.d0 ** (-96)
wk(-1) = dble (nq1)
wk(0) = 0.d0
xk(0) = 0.d0
wk(1) = dble (nq1)
xk(1) = dble (ik0)
i = ik0

do j = 2, ik0
  wk(j) = 0.d0
  xk(j) = 0.d0
enddo

do k = 1, nq1
  if (ndebug >= 2) write (6, *) k, i, nq2
  n = 3 * 2 ** (k + 1)

  do j = 1, n / 2

!   Compute a double precision estimate of the root.

    is = 0
    nwp = 3
    call mpsetprecwords (nwp)
    r = cos ((pi * (j - 0.25d0)) / (n + 0.5d0))

!   Compute the j-th root of the n-degree Legendre polynomial using Newton's
!   iteration.

100 continue

    t1 = 1.d0
    t2 = 0.d0

    do j1 = 1, n
      t3 = t2
      t2 = t1
      t1 = ((2 * j1 - 1) * r * t2 - (j1 - 1) * t3) / j1
    enddo

    t4 = n * (r * t1 - t2) / (r ** 2  - 1.d0)
    t5 = r
    r = r - t1 / t4

!   Once convergence is achieved at nwp = 3, then start doubling (almost) the
!   working precision level at each iteration until full precision is reached.

    if (nwp == 3) then
      if (abs (r - t5) > eps) goto 100
      nwp = min (2 * nwp - 1, nws)
      call mpsetprecwords (nwp)
      goto 100
    elseif (nwp < nws) then
      nwp = min (2 * nwp - 1, nws)
      call mpsetprecwords (nwp)
      goto 100
    endif

    i = i + 1
    if (i > nq2) goto 110
    xk(i) = r
    t4 = n * (r * t1 - t2) / (r ** 2  - 1.d0)
    wk(i) = 2.d0 / ((1.d0 - r ** 2) * t4 ** 2)
    call mpgetpar ('mpier', ierror)
    if (ierror > 0) goto 120
  enddo

  xk(k+1) = i
enddo

xk(-1) = dble (i)
nq3 = i
if (ndebug >= 2) then
  write (6, 2) i
2 format ('initqerf: Table spaced used =',i8)
endif
goto 130

110 continue

nq3 = 0
write (6, 3) nq2
3 format ('initqgs: Table space parameter is too small; value =',i8)
nerror = 92
goto 130

120 continue

nerror = ierror + 100
write (6, 4) nerror
4 format ('initqgs: Error in quadrature initialization; code =',i5)

130 continue

call mpsetprecwords (nws)
return
end

subroutine initqerf (nq1, nq2, nq3, wk, xk)

!   This subroutine initializes the quadrature arays xk and wk using the
!   function x(t) = erf(t) = 1 - erfc(t).  The argument nq2 is the space
!   allocated for wk and xk in the calling program.  By default it is set to
!   12 * 2^nq1.  Increase nq2 if directed by a message produced below.
!   Upon completion, wk(-1) = nq1, and xk(-1) = n, the maximum space parameter
!   for these arrays.  In other words, the arrays occupy (wk(i), i = -1 to n)
!   and (xk(i), i = -1 to n), where n = xk(-1).  The array x_k contain 1 minus
!   the abscissas; the wk array are the weights at these abscissas.
!   Modified for the toolkit.

!   David H Bailey    2004-05-27

use mpmodule
use globdata
implicit none
integer i, ierror, iprint, j, k, k1, nq1, nq2, nq3
logical log1
real*8 h
parameter (iprint = 1000)
type (mp_real) eps2, p2, spi, t1, t2, t3, t4, t5, wk(-1:nq2), xk(-1:nq2)

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqerf: Error function quadrature initialization')
endif

eps2 = mpreal (10.d0) ** (-ndigmx2)
p2 = 0.5d0 * mppic
spi = 2.d0 / sqrt (mppic)
h = 0.5d0 ** (nq1 - 2)
wk(-1) = dble (nq1)

do k = 0, nq2
  if (ndebug >= 2 .and. mod (k, iprint) == 0) write (6, *) k, nq2
  t1 = dble (k) * h
  xk(k) = erfc (t1)
  wk(k) = spi * exp (- t1 ** 2)
  call mpgetpar ('mpier', ierror)
  if (ierror > 0) goto 120
  if (wk(k) < eps2) goto 100
enddo

nq3 = 0
write (6, 2) nq2
2 format ('initqerf: Table space parameter is too small; value =',i8)
nerror = 91
goto 130

100 continue

nq3 = k
xk(-1) = dble (k)
if (ndebug >= 2) then
  write (6, 3) k
3 format ('initqerf: Table spaced used =',i8)
endif
goto 130

120 continue

nerror = ierror + 100
write (6, 4) nerror
4 format ('initqerf: Error in quadrature initialization; code =',i5)

130  continue

return
end

subroutine initqts (nq1, nq2, nq3, wk, xk)

!   This subroutine initializes the quadrature arays xk and wk using the
!   function x(t) = tanh (pi/2*sinh(t)).  The argument nq2 is the space
!   allocated for wk and xk in the calling program.  By default it is set to
!   12 * 2^nq1.  Increase nq2 if directed by a message produced below.
!   Upon completion, wk(-1) = nq1, and xk(-1) = n, the maximum space parameter
!   for these arrays.  In other words, the arrays occupy (wk(i), i = -1 to n)
!   and (xk(i), i = -1 to n), where n = xk(-1).   The array x_k contain 1 minus
!   the abscissas; the wk array are the weights at these abscissas.
!   Modified for the toolkit.
!   David H Bailey    2004-05-27

use mpmodule
use globdata
implicit none
integer i, ierror, iprint, j, k, k1, nq1, nq2, nq3
logical log1
real*8 h
parameter (iprint = 1000)
type (mp_real) eps2, p2, spi, t1, t2, t3, t4, u1, u2, wk(-1:nq2), xk(-1:nq2)

if (ndebug >= 1) then
  write (6, 1)
1 format ('initqts: Tanh-sinh quadrature initialization')
endif

eps2 = mpreal (10.d0) ** (-ndigmx2)
p2 = 0.5d0 * mppic
h = 0.5d0 ** nq1
wk(-1) = dble (nq1)

do k = 0, nq2
  if (ndebug >= 2 .and. mod (k, iprint) == 0) write (6, *) k, nq2
  t1 = dble (k) * h

!   xk(k) = 1 - tanh (u1) = 1 /(e^u1 * cosh (u1))
!   wk(k) = u2 / cosh (u1)^2
!   where u1 = pi/2 * cosh (t1), u2 = pi/2 * sinh (t1)

  t2 = exp (t1)
  u1 = 0.5d0 * p2 * (t2 + 1.d0 / t2)
  u2 = 0.5d0 * p2 * (t2 - 1.d0 / t2)
  t3 = exp (u2)
  t4 = 0.5d0 * (t3 + 1.d0 / t3)
  xk(k) = 1.d0 / (t3 * t4)
  wk(k) = u1 / t4 ** 2
  call mpgetpar ('mpier', ierror)
  if (ierror > 0) goto 120
  if (wk(k) < eps2) goto 100
enddo

nq3 = 0
write (6, 2) nq2
2 format ('initqts: Table space parameter is too small; value =',i8)
nerror = 91
goto 130

100 continue

nq3 = k
xk(-1) = dble (k)
if (ndebug >= 2) then
  write (6, 3) k
3 format ('initqts: Table spaced used =',i8)
endif
goto 130

120 continue

nerror = ierror + 100
write (6, 4) nerror
4 format ('initqts: Error in quadrature initialization; code =',i5)

130  continue

return
end

function catalan ()
use mpmodule
use globdata
implicit none
integer k
real*8 dk
type (mp_real) catalan, c1, c2, c4, c8, r16, t1, t2, t3
type (mp_real) x1, x2, x3, x4, x5, x6, eps

c1 = 1.d0
c2 = 2.d0
c4 = 4.d0
c8 = 8.d0
r16 = 1.d0 / 16.d0
t1 = 0.d0
t2 = 1.d0
eps = mpreal (10.d0) ** (-ndigmx1-1)

do k = 0, 10000000
  dk = k
  t3 = t2 * (c8 / (8.d0 * dk + 1.d0) ** 2 + c8 / (8.d0 * dk + 2.d0) ** 2 &
       + c4 / (8.d0 * dk + 3.d0) ** 2 - c2 / (8.d0 * dk + 5.d0) ** 2 &
       - c2 / (8.d0 * dk + 6.d0) ** 2 - c1 / (8.d0 * dk + 7.d0) ** 2)
  t1 = t1 + t3
  t2 = r16 * t2
  if (t3 < eps) goto 100
enddo

write (6, *) 'catalan: error - contact author'

100 continue

catalan = 1.d0 / 8.d0 * mppic * mpl02 + 1.d0 / 16.d0 * t1
return
end

function eulergamma ()
use mpmodule
use globdata
implicit none
integer k, m, n
real*8 d1, dplog10q
type (mp_real) eulergamma, c1, t1, t2, t3, t4, t5
external dplog10q

n = log (ndigmx1 * log (10.d0)) / log (2.d0) + 1.d0
d1 = 2.d0 ** n
c1 = 1.d0
t1 = 0.d0
t3 = 1.d0 / d1
t4 = 1.d0
t5 = 1.d0

do m = 0, 1000000000
  t3 = d1 * t3
  t4 = (m + 1) * t4
  t5 = t5 + c1 / (m + 1)
  t2 = t3 / t4 * t5
  t1 = t1 + t2
  if (t2 < 1.d0) goto 100
enddo

write (6, *) 'eulergamma: error - contact author'

100 continue

t5 = d1
eulergamma = d1 / exp (t5) * t1 - n * mpl02 - 1.d0
return
end

function dplog10q (a)

!   For input MP value a, this routine returns a DP approximation to log10 (a).

use mpmodule
implicit none
integer ia
double precision da, dplog10q, t1
type (mp_real) a

call mpmdc (a%mpr, da, ia)
if (da .eq. 0.d0) then
  dplog10q = -9999.d0
else
  dplog10q = log10 (abs (da)) + ia * log10 (2.d0)
endif

100 continue
return
end


: fib ( n1 -- n2 )
    dup 2 < if
	   drop 1
    else
	   dup
	   1- recurse
	   swap 2 - recurse
	   +
    then ;

: main 38 fib drop ;


program MC_ex01_p04
    use mc_randoms
    implicit none
    real(rk)::a
    real(rk),allocatable::p_lcg(:,:),p_pm(:,:),p_mt(:,:)
    integer::i
    !Initialize
    call seed_lcg(int(15,ik))
    call seed_pm(int(7895,ik))
    call init_genrand64(int(431,ik))
    allocate(p_lcg(100,2),p_pm(100,2),p_mt(100,2))
    !100 points
    do i=1, 100
        p_lcg(i,1)=rand_lcg()
        p_lcg(i,2)=rand_lcg()
        p_pm(i,1)=rand_pm()
        p_pm(i,2)=rand_pm()
        p_mt(i,1)=genrand64_real3()
        p_mt(i,2)=genrand64_real3()
    end do
    !Adjust the interval
    p_lcg=p_lcg*2-1
    p_pm=p_pm*2-1
    p_mt=p_mt*2-1

    !Save the data
    !LCG
    open(1,action="write",file="data_lcg100.txt",status="replace")
    do i=1,100
        write(1,*) p_lcg(i,1), p_lcg(i,2)
    end do
    close(1)
    !PM
    open(1,action="write",file="data_pm100.txt",status="replace")
    do i=1,100
        write(1,*) p_pm(i,1), p_pm(i,2)
    end do
    close(1)
    !MT
    open(1,action="write",file="data_mt100.txt",status="replace")
    do i=1,100
        write(1,*) p_mt(i,1), p_mt(i,2)
    end do
    close(1)
    deallocate(p_lcg,p_pm,p_mt)

    !Data for 10000 points
    allocate(p_lcg(10000,2),p_pm(10000,2),p_mt(10000,2))
    !10000points
    do i=1, 10000
        p_lcg(i,1)=rand_lcg()
        p_lcg(i,2)=rand_lcg()
        p_pm(i,1)=rand_pm()
        p_pm(i,2)=rand_pm()
        p_mt(i,1)=genrand64_real3()
        p_mt(i,2)=genrand64_real3()
    end do
    !Adjust the interval
    p_lcg=p_lcg*2-1
    p_pm=p_pm*2-1
    p_mt=p_mt*2-1

    !Save the data
    !LCG
    open(1,action="write",file="data_lcg10000.txt",status="replace")
    do i=1,10000
        write(1,*) p_lcg(i,1), p_lcg(i,2)
    end do
    close(1)
    !PM
    open(1,action="write",file="data_pm10000.txt",status="replace")
    do i=1,10000
        write(1,*) p_pm(i,1), p_pm(i,2)
    end do
    close(1)
    !MT
    open(1,action="write",file="data_mt10000.txt",status="replace")
    do i=1,10000
        write(1,*) p_mt(i,1), p_mt(i,2)
    end do
    close(1)

    !Region [-0.01,0.01] Seed 1
    !LCG
    i=1
    do
        if(i>1000) exit
        a=rand_lcg()
        if(a<=0.01.and.a>=-0.01) then
            p_lcg(i,1)=a
            do
                a=rand_lcg()
                if(a<=0.01.and.a>=-0.01) then
                    p_lcg(i,2)=a
                    exit
                end if
            end do
            i=i+1
        end if
    end do

    !PM
    i=1
    do
        if(i>1000) exit
        a=rand_pm()
        if(a<=0.01.and.a>=-0.01) then
            p_pm(i,1)=a
            do
                a=rand_pm()
                if(a<=0.01.and.a>=-0.01) then
                    p_pm(i,2)=a
                    exit
                end if
            end do
            i=i+1
        end if
    end do

    !MT
    i=1
    do
        if(i>1000) exit
        a=genrand64_real3()
        if(a<=0.01.and.a>=-0.01) then
            p_mt(i,1)=a
            do
                a=genrand64_real3()
                if(a<=0.01.and.a>=-0.01) then
                    p_mt(i,2)=a
                    exit
                end if
            end do
            i=i+1
        end if
    end do

    !Save the data
    !LCG
    open(1,action="write",file="data_lcg_region1.txt",status="replace")
    do i=1,1000
        write(1,*) p_lcg(i,1), p_lcg(i,2)
    end do
    close(1)
    !PM
    open(1,action="write",file="data_pm_region1.txt",status="replace")
    do i=1,1000
        write(1,*) p_pm(i,1), p_pm(i,2)
    end do
    close(1)
    !MT
    open(1,action="write",file="data_mt_region1.txt",status="replace")
    do i=1,1000
        write(1,*) p_mt(i,1), p_mt(i,2)
    end do
    close(1)

    !Region [-0.01,0.01] Seed 2
    call seed_lcg(int(8239,ik))
    call seed_pm(int(46,ik))
    call init_genrand64(int(20010,ik))
    !LCG
    i=1
    do
        if(i>1000) exit
        a=rand_lcg()
        if(a<=0.01.and.a>=-0.01) then
            p_lcg(i,1)=a
            do
                a=rand_lcg()
                if(a<=0.01.and.a>=-0.01) then
                    p_lcg(i,2)=a
                    exit
                end if
            end do
            i=i+1
        end if
    end do

    !PM
    i=1
    do
        if(i>1000) exit
        a=rand_pm()
        if(a<=0.01.and.a>=-0.01) then
            p_pm(i,1)=a
            do
                a=rand_pm()
                if(a<=0.01.and.a>=-0.01) then
                    p_pm(i,2)=a
                    exit
                end if
            end do
            i=i+1
        end if
    end do

    !MT
    i=1
    do
        if(i>1000) exit
        a=genrand64_real3()
        if(a<=0.01.and.a>=-0.01) then
            p_mt(i,1)=a
            do
                a=genrand64_real3()
                if(a<=0.01.and.a>=-0.01) then
                    p_mt(i,2)=a
                    exit
                end if
            end do
            i=i+1
        end if
    end do

    !Save the data
    !LCG
    open(1,action="write",file="data_lcg_region2.txt",status="replace")
    do i=1,1000
        write(1,*) p_lcg(i,1), p_lcg(i,2)
    end do
    close(1)
    !PM
    open(1,action="write",file="data_pm_region2.txt",status="replace")
    do i=1,1000
        write(1,*) p_pm(i,1), p_pm(i,2)
    end do
    close(1)
    !MT
    open(1,action="write",file="data_mt_region2.txt",status="replace")
    do i=1,1000
        write(1,*) p_mt(i,1), p_mt(i,2)
    end do
    close(1)

end program MC_ex01_p04


      PROGRAM PRIMES1
C
C     PROGRAM TO PRINT THE FIRST N PRIMES
C
      READ(*,*)N
      I=1
      J=0
 10   I=I+1
      DO 20 K=2,I-1
      IF (I-I/K*K) 20,10,20
 20   CONTINUE
      WRITE(*,*)I
      J=J+1
      IF (J-N) 10,30,30
 30   CONTINUE
      END


           program demo_minloc
           implicit none
           integer,save :: ints(3,5)= reshape([&
              4, 10,  1,  7, 13, &
              9, 15,  6, 12,  3, &
             14,  5, 11,  2,  8  &
           ],shape(ints),order=[2,1])
           write(*,*) minloc(ints)
           write(*,*) minloc(ints,dim=1)
           write(*,*) minloc(ints,dim=2)
           ! where in each column is the smallest number .gt. 10 ?
           write(*,*) minloc(ints,dim=2,mask=ints.gt.10)
           ! a one-dimensional array with dim=1 explicitly listed returns a scalar
           write(*,*) minloc(pack(ints,.true.),dim=1) ! scalar
           end program demo_minloc


module nf_loss

  !! This module will eventually provide a collection of loss functions and
  !! their derivatives. For the time being it provides only the quadratic
  !! function.

  implicit none

  private
  public :: quadratic, quadratic_derivative

  interface

    pure module function quadratic(true, predicted) result(res)
      !! Quadratic loss function:
      !!
      !!   L  = (predicted - true)**2 / 2
      !!
      real, intent(in) :: true(:)
        !! True values, i.e. labels from training datasets
      real, intent(in) :: predicted(:)
        !! Values predicted by the network
      real :: res(size(true))
        !! Resulting loss values
    end function quadratic

    pure module function quadratic_derivative(true, predicted) result(res)
      !! First derivative of the quadratic loss function:
      !!
      !!   L' =  predicted - true
      !!
      real, intent(in) :: true(:)
        !! True values, i.e. labels from training datasets
      real, intent(in) :: predicted(:)
        !! Values predicted by the network
      real :: res(size(true))
        !! Resulting loss values
    end function quadratic_derivative

  end interface

end module nf_loss


! { dg-do compile }
!
! PR 41556: [OOP] Errors in applying operator/assignment to an abstract type
!
! Contributed by Damian Rouson <damian@rouson.net>

module abstract_algebra
  implicit none
  private
  public :: rescale
  public :: object

  type ,abstract :: object
  contains
    procedure(assign_interface) ,deferred :: assign
    procedure(product_interface) ,deferred :: product
    generic  :: assignment(=) => assign
    generic  :: operator(*) => product
  end type

  abstract interface
    function product_interface(lhs,rhs) result(product)
      import :: object
      class(object) ,intent(in)  :: lhs
      class(object) ,allocatable :: product
      real          ,intent(in)  :: rhs
    end function
    subroutine assign_interface(lhs,rhs)
      import :: object
      class(object) ,intent(inout) :: lhs
      class(object) ,intent(in)    :: rhs
    end subroutine
  end interface

contains

  subroutine rescale(operand,scale)
    class(object)    :: operand
    real ,intent(in) :: scale
    operand = operand*scale
    operand = operand%product(scale)
  end subroutine
end module


!   ZGGESX Example Program Text
!   Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!   For licence see
!     https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

    Module zggesx_example_mod

!     ZGGESX Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public :: selctg
!     .. Parameters ..
      Integer, Parameter, Public :: nb = 64, nin = 5, nout = 6
      Logical, Parameter, Public :: chkfac = .False., prcond = .False., &
        prmat = .False.
    Contains
      Function selctg(a, b)

!       Logical function selctg for use with ZGGESX (ZGGESX)
!       Returns the value .TRUE. if the absolute value of the eigenvalue
!       a/b < 6.0

!       .. Function Return Value ..
        Logical :: selctg
!       .. Scalar Arguments ..
        Complex (Kind=dp), Intent (In) :: a, b
!       .. Intrinsic Procedures ..
        Intrinsic :: abs
!       .. Executable Statements ..
        selctg = (abs(a)<6.0_dp*abs(b))
        Return
      End Function
    End Module
    Program zggesx_example

!     ZGGESX Example Main Program

!     .. Use Statements ..
      Use blas_interfaces, Only: zgemm
      Use zggesx_example_mod, Only: chkfac, nb, nin, nout, prcond, prmat, selctg
      Use lapack_example_aux, Only: nagf_sort_realvec_rank, nagf_blas_dpyth, &
        nagf_file_print_matrix_complex_gen_comp, &
        nagf_sort_cmplxvec_rank_rearrange
      Use lapack_interfaces, Only: zggesx, zlange
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Complex (Kind=dp) :: alph, bet
      Real (Kind=dp) :: abnorm, anorm, bnorm, eps, normd, norme, tol
      Integer :: i, ifail, info, lda, ldb, ldc, ldd, lde, ldvsl, ldvsr, &
        liwork, lwork, n, sdim
      Logical :: factor
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), alpha(:), b(:, :), beta(:), &
        c(:, :), d(:, :), e(:, :), vsl(:, :), vsr(:, :), work(:)
      Complex (Kind=dp) :: dummy(1)
      Real (Kind=dp) :: rconde(2), rcondv(2)
      Real (Kind=dp), Allocatable :: rwork(:)
      Integer :: idum(1)
      Integer, Allocatable :: iwork(:)
      Logical, Allocatable :: bwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, cmplx, epsilon, max, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZGGESX Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldc = n
      ldd = n
      lde = n
      ldvsl = n
      ldvsr = n
      Allocate (a(lda,n), alpha(n), b(ldb,n), beta(n), c(ldc,n), d(ldd,n), &
        e(lde,n), vsl(ldvsl,n), vsr(ldvsr,n), rwork(8*n), bwork(n))

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      liwork = -1
      Call zggesx('Vectors (left)', 'Vectors (right)', 'Sort', selctg, &
        'Both reciprocal condition numbers', n, a, lda, b, ldb, sdim, alpha, &
        beta, vsl, ldvsl, vsr, ldvsr, rconde, rcondv, dummy, lwork, rwork, &
        idum, liwork, bwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max(n*nb+n*n/2, nint(real(dummy(1))))
      liwork = max(n+2, idum(1))
      Allocate (work(lwork), iwork(liwork))

!     Read in the matrices A and B
      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

      If (chkfac) Then
!       Copy A and B into D and E respectively
        d(1:n, 1:n) = a(1:n, 1:n)
        e(1:n, 1:n) = b(1:n, 1:n)
      End If

!     Find the Frobenius norms of A and B
      anorm = zlange('Frobenius', n, n, a, lda, rwork)
      bnorm = zlange('Frobenius', n, n, b, ldb, rwork)

      If (prmat) Then
!       Print matrices A and B
!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, a, &
          lda, 'Bracketed', 'F8.4', 'Matrix A', 'Integer', rlabs, 'Integer', &
          clabs, 80, 0, ifail)
        Write (nout, *)
        Flush (nout)

        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, b, &
          ldb, 'Bracketed', 'F8.4', 'Matrix B', 'Integer', rlabs, 'Integer', &
          clabs, 80, 0, ifail)
        Write (nout, *)
        Flush (nout)
      End If

      factor = .True.
!     Find the generalized Schur form
      Call zggesx('Vectors (left)', 'Vectors (right)', 'Sort', selctg, &
        'Both reciprocal condition numbers', n, a, lda, b, ldb, sdim, alpha, &
        beta, vsl, ldvsl, vsr, ldvsr, rconde, rcondv, work, lwork, rwork, &
        iwork, liwork, bwork, info)

      If (info/=0 .And. info/=(n+2)) Then
        Write (nout, 100) 'Failure in ZGGESX. INFO =', info
        factor = .False.
      Else If (chkfac) Then
!       Compute A - Q*S*Z^H from the factorization of (A,B) and store in
!       matrix D
        alph = cmplx(1, kind=dp)
        bet = cmplx(0, kind=dp)
        Call zgemm('N', 'N', n, n, n, alph, vsl, ldvsl, a, lda, bet, c, ldc)
        alph = cmplx(-1, kind=dp)
        bet = cmplx(1, kind=dp)
        Call zgemm('N', 'C', n, n, n, alph, c, ldc, vsr, ldvsr, bet, d, ldd)

!       Compute B - Q*T*Z^H from the factorization of (A,B) and store in
!       matrix E
        alph = cmplx(1, kind=dp)
        bet = cmplx(0, kind=dp)
        Call zgemm('N', 'N', n, n, n, alph, vsl, ldvsl, b, ldb, bet, c, ldc)
        alph = cmplx(-1, kind=dp)
        bet = cmplx(1, kind=dp)
        Call zgemm('N', 'C', n, n, n, alph, c, ldc, vsr, ldvsr, bet, e, lde)

!       Find norms of matrices D and E and warn if either is too large
        normd = zlange('O', ldd, n, d, ldd, rwork)
        If (normd>epsilon(1.0E0_dp)**0.75_dp) Then
          Write (nout, *) 'Norm of A-(Q*S*Z^T) is much greater than 0.'
          factor = .False.
          Write (nout, *) 'Schur factorization has failed.'
        End If
        norme = zlange('O', lde, n, e, lde, rwork)
        If (norme>epsilon(1.0E0_dp)**0.75_dp) Then
          Write (nout, *) 'Norm of B-(Q*T*Z^T) is much greater than 0.'
          factor = .False.
        End If
      End If

      If (factor) Then
!       Print eigenvalue details
        Write (nout, 100) 'Number of eigenvalues for which SELCTG is true = ', &
          sdim, '(dimension of deflating subspaces)'

        Write (nout, *)
!       Print selected (finite) generalized eigenvalues
        Write (nout, *) 'Selected generalized eigenvalues'

!       Store absolute values of eigenvalues for ranking
        work(1:n) = alpha(1:n)/beta(1:n)
        rwork(1:n) = abs(work(1:n))

!       Rank eigenvalues
        ifail = 0
        Call nagf_sort_realvec_rank(rwork, 1, sdim, 'Descending', iwork, &
          ifail)

!       Sort eigenvalues in work(1:n)
        Call nagf_sort_cmplxvec_rank_rearrange(work, 1, sdim, iwork, ifail)
        Do i = 1, sdim
          Write (nout, 110) i, work(i)
        End Do

        If (info==(n+2)) Then
          Write (nout, 120) '*** Note that rounding errors mean ', &
            'that leading eigenvalues in the', &
            'generalized Schur form no longer satisfy SELCTG = .TRUE.'
          Write (nout, *)
        End If
        Flush (nout)

        If (prcond) Then
!         Compute the machine precision and sqrt(anorm**2+bnorm**2)
          eps = epsilon(1.0E0_dp)
          abnorm = nagf_blas_dpyth(anorm, bnorm)
          tol = eps*abnorm

!         Print out the reciprocal condition numbers and error bound for
!         selected eigenvalues
          Write (nout, *)
          Write (nout, 130) &
            'Reciprocal condition numbers for the average of the', &
            'selected eigenvalues and their asymptotic error bound', &
            'rcond-left = ', rconde(1), ', rcond-right = ', rconde(2), &
            ', error = ', tol/rconde(1)

          Write (nout, *)
          Write (nout, 130) &
            'Reciprocal condition numbers for the deflating subspaces', &
            'and their approximate asymptotic error bound', 'rcond-left = ', &
            rcondv(1), ', rcond-right = ', rcondv(2), ', error = ', &
            tol/rcondv(2)
        End If

      Else
        Write (nout, *) 'Schur factorization has failed.'
      End If

100   Format (1X, A, I4, /, 1X, A)
110   Format (1X, I2, 1X, '(', F6.2, ',', F6.2, ')')
120   Format (1X, 2A, /, 1X, A)
130   Format (1X, A, /, 1X, A, /, 1X, 3(A,1P,E8.1))
    End Program


#define XWORK (256)
#define YWORK (64)

module finiteDifference2d

    use cudafor

    implicit none

    integer,  parameter :: dp     = kind(1.d0)
    real(dp), parameter :: two_pi = 8.d0*atan(1.d0)
    !! factors

    integer  :: nGrid, numIterations, blockSize(2), itime
    real(dp) :: length, dl, dl_inv
    !! Input Parameters

    real(dp)           :: factors(5)
    real(dp), constant :: factors_d(5)

    real(dp), dimension(:, :), allocatable         :: u, du, du_exact
    real(dp), dimension(:, :), allocatable, device :: u_d, du_d

contains

    subroutine get_block_size()
        character(len=128) :: cmdArg
        call get_command_argument(1,cmdArg)
        read(cmdArg,*) blockSize(1)
        call get_command_argument(2,cmdArg)
        read(cmdArg,*) blockSize(2)
    end subroutine get_block_size

    subroutine box_init(filename)
        character(*), intent(in) :: filename
        namelist /box_nml/ nGrid, length, numIterations

        open(unit=10,file=filename,status='old')
        read(10,nml=box_nml)
        close(10)

        length = length*two_pi
        dl     = length/nGrid
        dl_inv = 1.d0/dl
    end subroutine box_init

    subroutine set_factors()
        factors   = dl_inv*(1.d0/12.d0)*[ 1, -8, 0, 8, -1 ]
        factors_d = factors
    end subroutine set_factors

    subroutine allocate_arrays()
        allocate(u(nGrid,nGrid))
        allocate(du(nGrid,nGrid))
        allocate(du_exact(nGrid,nGrid))

        allocate(u_d(nGrid,nGrid))
        allocate(du_d(nGrid,nGrid))
        u        = 0.d0
        du       = 0.d0
        du_exact = 0.d0
    end subroutine allocate_arrays

    subroutine allocate_arrays_padded()
        !! Padding around 2d arrays required for one of the algorithm.
        allocate(u(-1:nGrid+2,-1:nGrid+2))
        allocate(du(-1:nGrid+2,-1:nGrid+2))
        allocate(du_exact(-1:nGrid+2,-1:nGrid+2))

        allocate(u_d(-1:nGrid+2,-1:nGrid+2))
        allocate(du_d(-1:nGrid+2,-1:nGrid+2))
        u        = 0.d0
        du       = 0.d0
        du_exact = 0.d0
    end subroutine allocate_arrays_padded

    subroutine write_device_array()
        integer :: i,j
        u = u_d
        do j = -1, nGrid+2
            do i = -1, nGrid+2
                write(*,20,advance='no') u(i,j)
            enddo
            write(*,*)
        enddo
        20      format (1f10.4)
    end subroutine write_device_array

    subroutine cuda_check_stat(istat)
        !! Subroutine to check cuda errors.
        integer, intent(in) :: istat
        if (istat /= cudaSuccess) then
            write(*, "('Error Code:',i0,': ')") istat
            write(*,*) cudaGetErrorString(istat)
            stop
        end if
    end subroutine cuda_check_stat

    subroutine initial_condition()
        integer  :: i,j
        real(dp) :: x,y

        u(:,:)        = 0.d0
        du_exact(:,:) = 0.d0

        do j = 1,nGrid
            y = dl*(j-1)
            do i = 1,nGrid
                x = dl*(i-1)
                u(i,j)        = sin(x)+sin(y)
                du_exact(i,j) = cos(x)+cos(y)
            end do
        end do

        !! Copy to device
        u_d(:,:) = u(:,:)
        !! Set the device output to 0
        du_d(:,:) = 0.d0
    end subroutine initial_condition

    !! Implementations begin here.

    !! Implementation 00
    attributes(global) subroutine divergence_mod(nGrid)
        integer, value, intent(in) :: nGrid

        integer  :: i, j, l, xn(5),yn(5)
        real(dp) :: ux(5), uy(5)

        i = (blockIdx%x-1) * blockDim%x + threadIdx%x
        j = (blockIdx%y-1) * blockDim%y + threadIdx%y

        do l = -2, 2
            xn(l+3) = mod(i+l+nGrid-1,nGrid) + 1
            yn(l+3) = mod(j+l+nGrid-1,nGrid) + 1
        end do

        ux = u_d(xn,j)
        uy = u_d(i,yn)

        du_d(i,j) = (ux(1)+uy(1))*factors_d(1) + (ux(2)+uy(2))*factors_d(2) &
                  + (ux(3)+uy(3))*factors_d(3) + (ux(4)+uy(4))*factors_d(4) &
                  + (ux(5)+uy(5))*factors_d(5)
    end subroutine divergence_mod

    !! Implementation 01
    attributes(global) subroutine divergence_padding()
        integer  :: i, j
        real(dp) :: ux(5), uy(5)

        i = (blockIdx%x-1) * blockDim%x + threadIdx%x
        j = (blockIdx%y-1) * blockDim%y + threadIdx%y

        ux = u_d(i-2:i+2,j)
        uy = u_d(i,j-2:j+2)

        du_d(i,j) = (ux(1)+uy(1))*factors_d(1) + (ux(2)+uy(2))*factors_d(2) &
                  + (ux(3)+uy(3))*factors_d(3) + (ux(4)+uy(4))*factors_d(4) &
                  + (ux(5)+uy(5))*factors_d(5)
    end subroutine divergence_padding

    !! Helper functions for divergence_padding.
    subroutine copy_to_padding()
        !! Copy data to padding.
        type(dim3) :: blockSp, gridSp
        !! Copy first the contiguous x direction, cuda support mpi like copying,
        !! so we can just specify the start of read and write locations and total
        !! number of elements to use.
        call cuda_check_stat(cudaMemCpy(u_d(-1,-1),u_d(-1,nGrid-1), 2*nGrid + 8, &
            cudaMemcpyDeviceToDevice))
        call cuda_check_stat(cudaMemCpy(u_d(-1,nGrid+1),u_d(-1,1) , 2*nGrid + 8, &
            cudaMemcpyDeviceToDevice))

        !! Copy the non contiguous y direction
        blockSp = dim3(256,1,1)
        gridSp  = dim3(nGrid/blockSp%x,1,1)
        call copy_y_padding <<< gridSp,blockSp >>> (nGrid)
    end subroutine copy_to_padding

    attributes(global) subroutine copy_y_padding(nGrid)
        !! Need a kernel to copy non-contiguous y-data.
        integer, value, intent(in) :: nGrid
        integer :: i
        i = (blockIdx%x-1) * blockDim%x + threadIdx%x
        u_d(-1,i)   = u_d(nGrid-1,i)
        u_d(0,i)    = u_d(nGrid,i)
        u_d(nGrid+1,i) = u_d(1,i)
        u_d(nGrid+2,i) = u_d(2,i)
    end subroutine copy_y_padding

    !! Implementation 02
    attributes(global) subroutine divergence_shared(nGrid)
        !! Compute derivatives by bringing values to shared memory.

        integer, value, intent(in) :: nGrid

        integer          :: iG, jG, i, j
        real(dp), shared :: u_ds(-1:blockDim%x+2,-1:blockDim%y+2)
        !! Shared memory

        i  = threadIdx%x
        j  = threadIdx%y
        iG = (blockIdx%x-1) * blockDim%x + threadIdx%x
        jG = (blockIdx%y-1) * blockDim%y + threadIdx%y

        u_ds(i,j) = u_d(iG,jG)
        !! now we copy paddings properly
        if (i <= 2) then
            !! check if block is not on x edge, if yes gotta fetch from edges.
            if (blockIdx%x == 1) then
                u_ds(i-2, j)  = u_d(nGrid+i-2,jG)            !! Left padding
                u_ds(i+blockDim%x,j) = u_d(iG+blockDim%x,jG) !! Right padding
            else if (blockIdx%x == gridDim%x) then
                u_ds(i-2, j)  = u_d(iG-2,jG)                 !! Left padding
                u_ds(i+blockDim%x,j) = u_d(i,jG)             !! Right padding
            else
                u_ds(i-2, j)  = u_d(iG-2,jG)                 !! Left padding
                u_ds(i+blockDim%x,j) = u_d(iG+blockDim%x,jG) !! Right padding
            end if
        end if

        if (j <= 2) then
            if (blockIdx%y == 1) then
                u_ds(i, j-2)  = u_d(iG,nGrid+j-2)            !! Up padding
                u_ds(i,j+blockDim%y) = u_d(iG,jG+blockDim%y) !! Down padding
            else if (blockIdx%y == gridDim%y) then
                u_ds(i, j-2)  = u_d(iG,jG-2)                 !! Up padding
                u_ds(i,j + blockDim%y) = u_d(iG,j)           !! Down padding
            else
                u_ds(i, j-2)  = u_d(iG,jG-2)                 !! Up padding
                u_ds(i,j+blockDim%y) = u_d(iG,jG+blockDim%y) !! Down padding
            end if
        endif

        call syncthreads()

        du_d(iG,jG) = ( u_ds(i-2,j) + u_ds(i,j-2) )*factors_d(1) &
                    + ( u_ds(i-1,j) + u_ds(i,j-1) )*factors_d(2) &
                    + ( u_ds(i  ,j) + u_ds(i,j  ) )*factors_d(3) &
                    + ( u_ds(i+1,j) + u_ds(i,j+1) )*factors_d(4) &
                    + ( u_ds(i+2,j) + u_ds(i,j+2) )*factors_d(5)
    end subroutine divergence_shared

    !! Implementation 03
    attributes(global) subroutine divergence_sharedx_registery(nGrid)
        !! Compute using shared memory and registers.
        !! Load x-data to shared memory, load y-data in registers.

        integer, value, intent(in) :: nGrid

        integer          :: i, j, iG, jW, jB

        real(dp)         :: front(2), center, behind(2)
        !! Put y-stuff on registers
        real(dp), shared :: u_ds(-1:blockDim%x+2)
        !! Shared memory for x direction

        i = threadIdx%x
        j = threadIdx%y
        !! Local thread index
        iG = (blockIdx%x-1) * blockDim%x + threadIdx%x
        !! Global index, will be used to access u_d/write du_d
        jB = YWORK*((blockIdx%y-1) * blockDim%y + threadIdx%y-1) + 1
        !! Global Index on which threads are going to work

        if (blockIdx%y == 1) then
            behind = [u_d(iG,nGrid-1),u_d(iG,nGrid)]
        else
            behind = [u_d(iG,jB-2),u_d(iG,jB-1)]
        end if
        center = u_d(iG,jB)
        front  = [u_d(iG,jB+1),u_d(iG,jB+2)]
        !! Preload the y-stencil for first point.
        !! Need to take care of the behind elements for lower most block properly.
        !! center and front can be loaded because threads always start at lowest index.

        !! now we copy x-paddings properly
        !! check if block is not on x edge, if yes gotta fetch from edges.
        !! Having if conditions outside YWORK loop reduces computational time,
        !! but increases code size.
        if (blockIdx%x == 1) then
            do jW = 1, YWORK
                u_ds(i) = center
                if (i <= 2) then
                    u_ds(i-2)  = u_d(nGrid+i-2,jB)             !! Left padding
                    u_ds(i+blockDim%x) = u_d(iG+blockDim%x,jB) !! Right padding
                end if
                call syncthreads()
                du_d(iG,jB) = ( u_ds(i-2) + behind(1))*factors_d(1) &
                                  + ( u_ds(i-1) + behind(2))*factors_d(2) &
                                  + ( u_ds(i  ) + center   )*factors_d(3) &
                                  + ( u_ds(i+1) + front(1) )*factors_d(4) &
                                  + ( u_ds(i+2) + front(2) )*factors_d(5)

                behind(1) = behind(2)
                behind(2) = center
                center    = front(1)
                front(1)  = front(2)
                jB     = jB + 1
                if (blockIdx%y == gridDim%y) then
                    front(2)  = u_d(iG,mod(jB+nGrid+1,nGrid)+1)
                else
                    front(2)  = u_d(iG,jB+2)
                end if
                call syncthreads()
            end do
        else if (blockIdx%x == gridDim%x) then
            do jW = 1, YWORK
                u_ds(i) = center
                if (i <= 2) then
                    u_ds(i-2)  = u_d(iG-2,jB)       !! Left padding
                    u_ds(i+blockDim%x) = u_d(i,jB)  !! Right padding
                end if
                call syncthreads()
                du_d(iG,jB) = ( u_ds(i-2) + behind(1))*factors_d(1) &
                                  + ( u_ds(i-1) + behind(2))*factors_d(2) &
                                  + ( u_ds(i  ) + center   )*factors_d(3) &
                                  + ( u_ds(i+1) + front(1) )*factors_d(4) &
                                  + ( u_ds(i+2) + front(2) )*factors_d(5)

                behind(1) = behind(2)
                behind(2) = center
                center    = front(1)
                front(1)  = front(2)
                jB     = jB + 1
                if (blockIdx%y == gridDim%y) then
                    front(2)  = u_d(iG,mod(jB+nGrid+1,nGrid)+1)
                else
                    front(2)  = u_d(iG,jB+2)
                end if
                call syncthreads()
            end do
        else
            do jW = 1, YWORK
                u_ds(i) = center
                if (i <= 2) then
                    u_ds(i-2)  = u_d(iG-2,jB)                  !! Left padding
                    u_ds(i+blockDim%x) = u_d(iG+blockDim%x,jB) !! Right padding
                end if
                call syncthreads()
                du_d(iG,jB) = ( u_ds(i-2) + behind(1))*factors_d(1) &
                                  + ( u_ds(i-1) + behind(2))*factors_d(2) &
                                  + ( u_ds(i  ) + center   )*factors_d(3) &
                                  + ( u_ds(i+1) + front(1) )*factors_d(4) &
                                  + ( u_ds(i+2) + front(2) )*factors_d(5)

                behind(1) = behind(2)
                behind(2) = center
                center    = front(1)
                front(1)  = front(2)
                jB     = jB + 1
                if (blockIdx%y == gridDim%y) then
                    front(2)  = u_d(iG,mod(jB+nGrid+1,nGrid)+1)
                else
                    front(2)  = u_d(iG,jB+2)
                end if
                call syncthreads()
            end do
        end if
    end subroutine divergence_sharedx_registery

end module finiteDifference2d


!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
! TYPE  : MODULE
! NAME  : MatrixOperations
! OBJECT: TYPE(nummethod)
! USED  : @lapck
! DATE  : 2017-12-06
! AUTHOR: Hengyue Li
!--------------
! DESCRIPTION:
!            only method here in this module.  Therefore no Initialization will be needed.
! STANDARD:
!
!
!          [sub]  ED_Hermitian_matrix(UL,N,H,E):
!                 character::UL = “U” or “L”
!                 integer::N
!                 real(8)::E(n)
!                 INPUT/OUTPUT H, H can be real(8) or complex(8)
!
!          [sub]  ED_tridiagonal_real(N,A,B,H,E):
!                 input integer::N,  REAL(8)::A(N),B(N)
!                 OUTPUT real(8)::H(n,n) ,E(n)
!                 B(1) will not be used.
!
!          [sub] MatrixInverse(N,M)
!                integer::N
!                real*8/complex*16,intent(inout)::M(n,n)
!                calculate the inverse of the matrix M
!
!          [fun] get_determinant_of_Matrix(N,M)
!                integer::N
!                real*8/complex*16::M(N)
!                return real*8/complex*16, the determinant of matrix M(N)
!
!
!
!
!!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

module MatrixOperations
   implicit none

   type nummethod

    contains
       procedure,private,pass::ED_HERMIT_real8
       procedure,private,pass::ED_HERMIT_complex8
       generic::ED_Hermitian_matrix=>ED_HERMIT_real8,ED_HERMIT_complex8

       procedure,pass::ED_tridiagonal_real=>ED_tridiagonal_real_p

       procedure,pass::MatrixInverse_r
       procedure,pass::MatrixInverse_c
       generic::MatrixInverse=>MatrixInverse_r,MatrixInverse_c

       procedure,pass::get_determinant_of_Matrix_r
       procedure,pass::get_determinant_of_Matrix_c
       generic::get_determinant_of_Matrix=>get_determinant_of_Matrix_r,get_determinant_of_Matrix_c

   end type

private::ED_HERMIT_real8,ED_HERMIT_complex8
private::MatrixInverse_r,MatrixInverse_c
private::get_determinant_of_Matrix_c,get_determinant_of_Matrix_r

contains

    subroutine ED_HERMIT_real8(self,UL,n,H,E)
    !---------------------------------------------------------!
    !Calls the LAPACK diagonalization subroutine DSYEV        !
    !input:  h(n,n) = real symmetric matrix to be diagonalized!
    !            n  = size of a                               !
    !            UL="L"/"U" choosing lower or upper part of H.!
    !output: h(n,n) = orthonormal eigenvectors of a           !
    !        e(n) = eigenvalues of a in ascending order       !
    !---------------------------------------------------------!
        implicit NONE
        class(nummethod),intent(inout)::self
        character(1),INTENT(IN)::UL
        integer,intent(in)::n
        real(8),intent(inout)::h(n,n),e(n)
        !--------------------------------------
        INTEGER::N4,L,inf
        REAL(8)::WORK( n*(3+n/2)  )
        N4=INT(N,4)
        l=n4*(3+n4/2)
        call dsyev('V',UL,n4,H,n4,E,work,l,inf)
    endsubroutine

    subroutine ED_HERMIT_complex8(self,UL,n,H,E)
        implicit NONE
        class(nummethod),intent(inout)::self
        character(1),INTENT(IN)::UL
        integer,intent(in)::n
        complex(8),intent(inout)::h(n,n)
        real(8),intent(inout)::e(n)

        call LA_ziasym(UL,h,e,int(n,4))
    contains
             subroutine LA_ziasym(UL,a,eig,n)
             implicit none
             character(1),INTENT(IN)::UL
             integer n,l,inf
             COMPLEX(8)::a(n,n),work(n*(3+n/2))  ;REAL(8)::eig(n)   ;REAL(8),ALLOCATABLE::RWORK(:)

             l=n*(3+n/2)
             ALLOCATE(RWORK(max(1, 3*N-2)))
             call ZHEEV('V',UL,n,a,n,eig,work,l,RWORK,inf)
             DEALLOCATE(RWORK)
             end subroutine LA_ziasym
            !---------------------!
    endsubroutine

   subroutine ED_tridiagonal_real_p(self,N,A,B,H,E,ifo) ! B(1) will not be used.
        implicit NONE
        class(nummethod),intent(inout)::self
        integer,intent(in)::n
        real(8),intent(in)::a(n),b(n)
        real(8),intent(out)::h(n,n),e(n)
        integer,intent(out),optional::ifo
        !-------------------------------------
        real*8::bn_1(n-1)
        integer::LWORK,n4,LIWORK,INFO
        REAL*8,ALLOCATABLE::WORK(:)
        INTEGER,ALLOCATABLE::IWORK(:)
        n4 = int(n,4)
        E    = A
        bn_1 = b(2:n)
        LWORK  = 1 + 4*N4 + N4**2
        LIWORK = 3+5*N4
        INFO = 0
        ALLOCATE( IWORK(LIWORK)   ,WORK(LWORK))
        call DSTEVD( "V", N4, E, bn_1, H, max(1,N4), WORK, LWORK, IWORK, LIWORK, INFO )
       DEALLOCATE( IWORK ,WORK)
       if (present(ifo)) ifo = info

   end subroutine

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
   subroutine MatrixInverse_r(self,N,M)
     implicit NONE
     class(nummethod),intent(inout)::self
     INTEGER,intent(in)::N
     real*8,intent(inout)::M(N,N)
     !
     INTEGER::IPIV(N),INFO, LWORK
     real*8::WORK(N*32)
     integer::n4

     LWORK=-1
     CALL DGETRF(n , n , M, n , IPIV, INFO )
     CALL DGETRI( n, M, n, IPIV, WORK, N*32, INFO )
 ENDSUBROUTINE
   subroutine MatrixInverse_c(self,N,M)
     implicit NONE
     class(nummethod),intent(inout)::self
     INTEGER,intent(in)::N
     COMPLEX*16,intent(inout)::M(N,N)
     !
     INTEGER::IPIV(N),INFO, LWORK
     COMPLEX*16::WORK(N*32)
     integer::n4

     LWORK=-1
     CALL ZGETRF(n , n , M, n , IPIV, INFO )
     CALL ZGETRI( n, M, n, IPIV, WORK, N*32, INFO )
 ENDSUBROUTINE
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 function get_determinant_of_Matrix_c(self,N,M) result(R)
 IMPLICIT none
 class(nummethod),intent(inout)::self
 INTEGER,intent(in)::N
 COMPLEX*16,intent(in)::M(N,N)
 complex*16::R
 !--------------------------------------------------------
 COMPLEX*16::A(N,N)  ;INTEGER::IPIV(N),INFO ;INTEGER::JC
 A=M
 call ZGETRF( n,	n, A, n, IPIV, INFO )
 R=(1._8,0._8)
 DO JC=1,INT(N,4)
   R=R*A(JC,JC)
   IF (.NOT. JC.EQ.IPIV(JC)) R=(-1._8)*R
 ENDDO
 END function

 function get_determinant_of_Matrix_r(self,N,M) result(R)
 IMPLICIT none
 class(nummethod),intent(inout)::self
 INTEGER,intent(in)::N
 real*8,intent(in)::M(N,N)
 real*8::R
 !--------------------------------------------------------
 real*8::A(N,N)  ;INTEGER::IPIV(N),INFO ;INTEGER::JC
 A=M
 call DGETRF( n,	n, A, n, IPIV, INFO )
 R=1._8
 DO JC=1,INT(N,4)
   R=R*A(JC,JC)
   IF (.NOT. JC.EQ.IPIV(JC)) R=(-1._8)*R
 ENDDO
 END function
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

end module