SUBROUTINE compute_lwa_and_barotropic_fluxes(nlon, nlat, kmax, jd, &
                          pv,uu,vv,pt,qref,uref,tref,&
                         a, om, dz, h, r, cp, prefactor, &
                         astar,astarbaro,ua1baro,ubaro,ua2baro,ep1baro,ep2baro,ep3baro,ep4)

    implicit none

    integer, intent(in) :: nlon, nlat, kmax, jd
    real, intent(in) :: pv(nlon,nlat,kmax),uu(nlon,nlat,kmax),vv(nlon,nlat,kmax), &
                        pt(nlon,nlat,kmax),qref(jd,kmax),uref(jd,kmax),tref(jd,kmax)
    real, intent(in) ::  a, om, dz, h, r, cp, prefactor
    real, intent(out) :: astar(nlon,jd,kmax),astarbaro(nlon,jd),ua1baro(nlon,jd),ubaro(nlon,jd),&
                         ua2baro(nlon,jd),ep1baro(nlon,jd),ep2baro(nlon,jd),ep3baro(nlon,jd),ep4(nlon,jd)
    ! === dummy variables ===
    integer :: i, j, jj, k
    real :: qe(nlon,nlat),ue(nlon,nlat)
    real :: ua1(nlon,jd,kmax)
    real :: ua2(nlon,jd,kmax),ep1(nlon,jd,kmax)
    real :: ep2(nlon,jd,kmax),ep3(nlon,jd,kmax)
    real :: tg(kmax)
    real :: aa, cor, dc, ep11, ep41, ep42, ep43, wt, zk, zz, dp, rkappa
    real :: cosphi(0:jd+1), sinphi(0:jd+1)
    real, parameter :: pi = acos(-1.)

    dp = pi/float(nlat-1)
    rkappa = r/cp

    ! cos and sin of latitude are often used in the following computations.
    ! Because the evaluation of trigonometric functions is computationally
    ! expensive, values are computed once here and stored for later.
    cosphi(0) = cos(0.) ! fill values for meridional
    sinphi(0) = sin(0.) !  heat flux computation
    do j=1,jd+1
        cosphi(j) = cos(dp*float(j-1))
        sinphi(j) = sin(dp*float(j-1))
    enddo

    ! **** hemispheric-mean potential temperature ****

    tg(:) = 0.              ! mean PT
    wt = 0.                 ! area weight
    do j = 1,jd             ! NH
        tg(:) = tg(:)+cosphi(j)*tref(j,:)
        wt = wt + cosphi(j)
    enddo
    tg(:) = tg(:)/wt       ! averaging

    ! **** wave activity and nonlinear zonal flux F2 ****

    do k = 2,kmax-1
        do i = 1,nlon
            do j = 1,jd-1            ! 13.5N and higher latitude
                astar(i,j,k) = 0.       ! LWA*cos(phi)
                ua2(i,j,k) = 0.         ! F2
                cor = 2.*om*sinphi(j)          !Coriolis parameter
                ! South of the current latitude
                do jj = 1,j-1
                    qe(i,jj) = pv(i,jj+jd-1,k)-qref(j,k)*cor   !qe; Q = qref*cor
                    ue(i,jj) = uu(i,jj+jd-1,k)-uref(j,k)       !ue
                    aa = a*dp*cosphi(jj)                       !length element
                    if(qe(i,jj).gt.0.) then                    !LWA*cos(phi) and F2
                        astar(i,j,k)=astar(i,j,k)+qe(i,jj)*aa
                        ua2(i,j,k) = ua2(i,j,k)+qe(i,jj)*ue(i,jj)*aa
                    endif
                enddo
                ! North of the current latitude
                do jj = j,jd
                    qe(i,jj) = pv(i,jj+jd-1,k)-qref(j,k)*cor   !qe; Q = qref*cor
                    ue(i,jj) = uu(i,jj+jd-1,k)-uref(j,k)       !ue
                    aa = a*dp*cosphi(jj)                       !length element
                    if(qe(i,jj).le.0.) then                    !LWA*cos(phi) and F2
                        astar(i,j,k)=astar(i,j,k)-qe(i,jj)*aa
                        ua2(i,j,k) = ua2(i,j,k)-qe(i,jj)*ue(i,jj)*aa
                    endif
                enddo

                !    *********  Other fluxes *********

                ua1(i,j,k) = uref(j,k)*astar(i,j,k)            !F1
                ep1(i,j,k) = -0.5*(uu(i,j+jd-1,k)-uref(j,k))**2  !F3a
                ep1(i,j,k) = ep1(i,j,k)+0.5*vv(i,j+jd-1,k)**2    !F3a+b
                ep11 = 0.5*(pt(i,j+jd-1,k)-tref(j,k))**2         !F3c
                zz = dz*float(k-1)
                ep11 = ep11*(r/h)*exp(-rkappa*zz/h)
                ep11 = ep11*2.*dz/(tg(k+1)-tg(k-1))
                ep1(i,j,k) = ep1(i,j,k)-ep11                   !F3
                ep1(i,j,k) = ep1(i,j,k)*cosphi(j) ! correct for cosine factor

                ! meridional eddy momentum flux one grid north and south
                ep2(i,j,k)=(uu(i,j+jd  ,k)-uref(j,k))*vv(i,j+jd  ,k)*cosphi(j+1)*cosphi(j+1)
                ep3(i,j,k)=(uu(i,j+jd-2,k)-uref(j,k))*vv(i,j+jd-2,k)*cosphi(j-1)*cosphi(j-1)

                ! low-level meridional eddy heat flux
                if(k.eq.2) then     ! (26) of SI-HN17
                    ep41 = 2.*om*sinphi(j)*cosphi(j)*dz/prefactor       ! prefactor
                    ep42 = exp(-dz/h)*vv(i,j+jd-1,2)*(pt(i,j+jd-1,2)-tref(j,2))
                    ep42 = ep42/(tg(3)-tg(1))
                    ep43 = vv(i,j+jd-1,1)*(pt(i,j+jd-1,1)-tref(j,1))
                    ep43 = 0.5*ep43/(tg(2)-tg(1))
                    ep4(i,j) = ep41*(ep42+ep43)   ! low-level heat flux
                endif
            enddo
        enddo
    enddo

    ! ******** Column average: (25) of SI-HN17 ********

    astarbaro(:,:) = 0.
    ubaro(:,:) = 0.
    ua1baro(:,:) = 0.
    ua2baro(:,:) = 0.
    ep1baro(:,:) = 0.
    ep2baro(:,:) = 0.
    ep3baro(:,:) = 0.
    dc = dz/prefactor

    do k = 2,kmax-1
        zk = dz*float(k-1)
        astarbaro(:,:) = astarbaro(:,:)+astar(:,:,k)*exp(-zk/h)*dc
        ua1baro(:,:) = ua1baro(:,:)+ua1(:,:,k)*exp(-zk/h)*dc
        ua2baro(:,:) = ua2baro(:,:)+ua2(:,:,k)*exp(-zk/h)*dc
        ep1baro(:,:) = ep1baro(:,:)+ep1(:,:,k)*exp(-zk/h)*dc
        ep2baro(:,:) = ep2baro(:,:)+ep2(:,:,k)*exp(-zk/h)*dc
        ep3baro(:,:) = ep3baro(:,:)+ep3(:,:,k)*exp(-zk/h)*dc
        do j = 1,jd  ! ### yet to be multiplied by cosine
            ubaro(:,j) = ubaro(:,j)+uu(:,j+jd-1,k)*exp(-zk/h)*dc
        enddo
    enddo

end subroutine


!--------------------------------------------------------------------------------------------------
! MODULE: sh_ldiab_mod
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date November, 2016
!
! DESCRIPTION:
!> @brief Surface hopping algorithm.
!--------------------------------------------------------------------------------------------------
module sh_ldiab_mod
    use global_defs
    implicit none

    private
    public :: sh_diabatic

contains

    !----------------------------------------------------------------------------------------------
    ! SUBROUTINE: SH_Diabatic
    !
    ! DESCRIPTION:
    !> @brief Fewest switches surface hopping in a locally diabatic basis.
    !> @details
    !! Propagates electronic wave function coefficients and determines hops for the SH method.
    !----------------------------------------------------------------------------------------------
    subroutine sh_diabatic(n, dt, qe1, qe2, cwf, tst, olp, fprob)
        use matrix_mod, only : diagonal_mat, &
                               mat_sy_exp
        use orthog_mod, only : orthog_lowdin
        use linalg_wrapper_mod, only : gemm, gemv
        integer, intent(in) :: n !< Number of states.
        real(dp), intent(in) :: dt !< Nuclear dynamics time step.
        real(dp), intent(in) :: olp(n, n) !< Overlap matrix for current step.
        real(dp), intent(in) :: qe1(n) !< Energies at t.
        real(dp), intent(in) :: qe2(n) !< Energies at t + dt.
        complex(dp), intent(inout) :: cwf(n) !< WF coefficients in the adiabatic basis.
        integer, intent(inout) :: tst !< Current state.
        real(dp), intent(out) :: fprob(n) !< Final probability for each state.
        real(dp) :: t(n, n) !< Orthogonalized overlap matrix.
        real(dp) :: w1(n, n) !< Work array 1.
        real(dp) :: w2(n, n) !< Work array 2.
        complex(dp) :: u(n, n) !< Transformation matrix.
        complex(dp) :: w3(n, n) !< Work array 3.
        complex(dp) :: w4(n, n) !< Work array 4.
        complex(dp) :: pwf(n) !< Previous WF coefficients.
        real(dp) :: b(n) !< Contributions of each state to change in population.
        real(dp) :: rnum !< Random number for surface hopping.
        real(dp) :: denom !< Denominator in calculation of b.
        real(dp), parameter :: thresh = 1.e-10_dp !< Threshold for denominator.
        real(dp) :: cprob !< Cumulative probability of hopping into any state.
        integer :: k, l

        t = olp
        pwf = cwf

        ! Orthogonalize overlap matrix.
        call orthog_lowdin(t)

        ! Generate Z matrix. (Approx. Hamiltonian at half step.)
        call gemm(t, diagonal_mat(qe2), w1)
        call gemm(w1, t, w2, transb='T') ! H(t+dt/2) = T.E(t+dt).Tt
        w2 = (diagonal_mat(qe1) + w2) * 0.5_dp ! Z = (E(0) + H(t+dt))/2

        ! Generate U matrix. (Transformation matrix.)
        w3 = mat_sy_exp(w2, cmplx(0.0_dp, -dt, kind=dp)) ! exp(-i * Z * dt)
        w4 = cmplx(t, 0.0_dp, dp) !< Convert T to complex matrix.
        call gemm(w4, w3, u, transa='T') ! u = T^t exp(-i * Z * dt)

        ! Calculate new wf coefficients.
        cwf = matmul(u, pwf) ! A(t0 + dt) = U A(t0)

        ! Calculate hopping probabilities.
        k = tst
        b = 0.0_dp
        denom = abs(cwf(k))**2 - real(u(k, k) * pwf(k) * conjg(cwf(k)))
        if (denom > thresh) then
            denom = (abs(cwf(k))**2 - abs(pwf(k))**2) / denom
            do l = 1, n
                if (l == k) cycle
                b(l) = - real(u(k, l) * pwf(l) * conjg(cwf(k))) * denom
            end do
        else
            ! If the denominator is close to zero, the property b(k, l) = - b(l, k) is used.
            do l = 1, n
                if (l == k) cycle
                denom = abs(cwf(l))**2 - real(u(l, l) * pwf(l) * conjg(cwf(l)))
                if (denom < thresh) cycle
                denom = (abs(cwf(l))**2 - abs(pwf(l))**2) / denom
                b(l) = real(u(l, k) * pwf(k) * conjg(cwf(l))) * denom
            end do
        end if
        b = b / abs(pwf(k))**2

        ! Determine if hop should occur.
        call random_number(rnum)
        cprob = 0.0_dp
        fprob = 0.0_dp
        hop: do l = 1, n
            if (l == k) cycle
            if (b(l) > 0.0_dp) then ! Not actual probability, can be negative.
                cprob = cprob + b(l)
                fprob(l) = fprob(l) + b(l)
                if (rnum < cprob) then
                    tst = l
                    exit hop
                end if
            end if
        end do hop
    end subroutine sh_diabatic

end module sh_ldiab_mod


module rotation_module
  ! co_latitude, rotation_radius, theta_in_rad, sin_theta and cos_theta
  ! are only important when wanting to rotate a plane-parallel patch
  ! which lives at an angle co_latitude from the rotation axis and at a
  ! distance rotation_radius from center().  mk_vel_force should
  ! calculate the rotational forcing terms for the points within the
  ! patch.
  !
  ! for spherical problems, the only important variable from
  ! init_rotation() is omega, the angular frequency - mk_vel_force will
  ! calculate the appropriate terms for a given coordinate
  !
  ! NOTE: it is currently unclear how to handle BC's with a
  ! plane-parallel patch and it is not advisable to utilize
  ! rotation for such problems.

  use meth_params_module, only: rotational_frequency, co_latitude
  use amrex_constants_module

  implicit none

  private

  public :: init_rotation

  double precision, save :: sin_theta, cos_theta, omega

contains

  subroutine init_rotation()

    double precision :: theta_in_rad

    theta_in_rad = M_PI * co_latitude / 180.d0

    sin_theta = sin(theta_in_rad)
    cos_theta = cos(theta_in_rad)

    omega = 2 * M_PI * rotational_frequency

  end subroutine init_rotation

end module rotation_module


C NCLFORTSTART
      SUBROUTINE CALCDBZ(DBZ,PRS,TMK,QVP,QRA,QSN,QGR,WEDIM,SNDIM,BTDIM,
     +                   SN0,IVARINT,ILIQSKIN)
c
c     This routine computes equivalent reflectivity factor (in dBZ) at
c     each model grid point.  In calculating Ze, the RIP algorithm makes
c     assumptions consistent with those made in an early version
c     (ca. 1996) of the bulk mixed-phase microphysical scheme in the MM5
c     model (i.e., the scheme known as "Resiner-2").  For each species:
c
c     1. Particles are assumed to be spheres of constant density.  The
c     densities of rain drops, snow particles, and graupel particles are
c     taken to be rho_r = rho_l = 1000 kg m^-3, rho_s = 100 kg m^-3, and
c     rho_g = 400 kg m^-3, respectively. (l refers to the density of
c     liquid water.)
c
c     2. The size distribution (in terms of the actual diameter of the
c     particles, rather than the melted diameter or the equivalent solid
c     ice sphere diameter) is assumed to follow an exponential
c     distribution of the form N(D) = N_0 * exp( lambda*D ).
c
c     3. If ivarint=0, the intercept parameters are assumed constant
c     (as in early Reisner-2), with values of 8x10^6, 2x10^7,
c    and 4x10^6 m^-4, for rain, snow, and graupel, respectively.
c    If ivarint=1, variable intercept parameters are used, as
c    calculated in Thompson, Rasmussen, and Manning (2004, Monthly
c    Weather Review, Vol. 132, No. 2, pp. 519-542.)
c
c     4. If iliqskin=1, frozen particles that are at a temperature above
c     freezing are assumed to scatter as a liquid particle.
c
c     More information on the derivation of simulated reflectivity in
c     RIP can be found in Stoelinga (2005, unpublished write-up).
c     Contact Mark Stoelinga (stoeling@atmos.washington.edu) for a copy.
c

c   Arguments
      INTEGER WEDIM,SNDIM,BTDIM
      INTEGER SN0,IVARINT,ILIQSKIN
      DOUBLE PRECISION DBZ(WEDIM,SNDIM,BTDIM)
      DOUBLE PRECISION PRS(WEDIM,SNDIM,BTDIM)
      DOUBLE PRECISION TMK(WEDIM,SNDIM,BTDIM)
      DOUBLE PRECISION QVP(WEDIM,SNDIM,BTDIM)
      DOUBLE PRECISION QRA(WEDIM,SNDIM,BTDIM)
      DOUBLE PRECISION QSN(WEDIM,SNDIM,BTDIM)
      DOUBLE PRECISION QGR(WEDIM,SNDIM,BTDIM)

C NCLEND

c   Local Variables
      INTEGER I,J,K
      DOUBLE PRECISION TEMP_C,VIRTUAL_T
      DOUBLE PRECISION GONV,RONV,SONV
      DOUBLE PRECISION FACTOR_G,FACTOR_R,FACTOR_S
      DOUBLE PRECISION FACTORB_G,FACTORB_R,FACTORB_S
      DOUBLE PRECISION RHOAIR,Z_E

c   Constants used to calculate variable intercepts
      DOUBLE PRECISION R1,RON,RON2,SON,GON
      DOUBLE PRECISION RON_MIN,RON_QR0,RON_DELQR0
      DOUBLE PRECISION RON_CONST1R,RON_CONST2R
c   Constant intercepts
      DOUBLE PRECISION RN0_R,RN0_S,RN0_G
c   Other constants
      DOUBLE PRECISION RHO_R,RHO_S,RHO_G
      DOUBLE PRECISION GAMMA_SEVEN,ALPHA
      DOUBLE PRECISION RHOWAT,CELKEL,PI,RD

c   Constants used to calculate variable intercepts
      R1 = 1.D-15
      RON = 8.D6
      RON2 = 1.D10
      SON = 2.D7
      GON = 5.D7
      RON_MIN = 8.D6
      RON_QR0 = 0.00010D0
      RON_DELQR0 = 0.25D0*RON_QR0
      RON_CONST1R = (RON2-RON_MIN)*0.5D0
      RON_CONST2R = (RON2+RON_MIN)*0.5D0

c   Constant intercepts
      RN0_R = 8.D6
      RN0_S = 2.D7
      RN0_G = 4.D6

c   Other constants
      GAMMA_SEVEN = 720.D0
      RHOWAT = 1000.D0
      RHO_R = RHOWAT
      RHO_S = 100.D0
      RHO_G = 400.D0
      ALPHA = 0.224D0
      CELKEL = 273.15D0
      PI = 3.141592653589793D0
      RD = 287.04D0

c   Force all Q arrays to be 0.0 or greater.
      DO K = 1,BTDIM
         DO J = 1,SNDIM
            DO I = 1,WEDIM
               IF (QVP(I,J,K).LT.0.0) THEN
                  QVP(I,J,K) = 0.0
               END IF
               IF (QRA(I,J,K).LT.0.0) THEN
                  QRA(I,J,K) = 0.0
               END IF
               IF (QSN(I,J,K).LT.0.0) THEN
                  QSN(I,J,K) = 0.0
               END IF
               IF (QGR(I,J,K).LT.0.0) THEN
                  QGR(I,J,K) = 0.0
               END IF
            END DO
         END DO
      END DO

c   Input pressure is Pa, but we need hPa in calculations

      IF (SN0.EQ.0) THEN
          DO K = 1,BTDIM
              DO J = 1,SNDIM
                  DO I = 1,WEDIM
                      IF (TMK(I,J,K).LT.CELKEL) THEN
                          QSN(I,J,K) = QRA(I,J,K)
                          QRA(I,J,K) = 0.D0
                      END IF
                  END DO
              END DO
          END DO
      END IF

      FACTOR_R = GAMMA_SEVEN*1.D18* (1.D0/ (PI*RHO_R))**1.75D0
      FACTOR_S = GAMMA_SEVEN*1.D18* (1.D0/ (PI*RHO_S))**1.75D0*
     +           (RHO_S/RHOWAT)**2*ALPHA
      FACTOR_G = GAMMA_SEVEN*1.D18* (1.D0/ (PI*RHO_G))**1.75D0*
     +           (RHO_G/RHOWAT)**2*ALPHA

      DO K = 1,BTDIM
          DO J = 1,SNDIM
              DO I = 1,WEDIM

                  VIRTUAL_T = TMK(I,J,K)* (0.622D0+QVP(I,J,K))/
     +                        (0.622D0* (1.D0+QVP(I,J,K)))
                  RHOAIR = PRS(I,J,K) / (RD*VIRTUAL_T)

c      Adjust factor for brightband, where snow or graupel particle
c      scatters like liquid water (alpha=1.0) because it is assumed to
c      have a liquid skin.

                  IF (ILIQSKIN.EQ.1 .AND. TMK(I,J,K).GT.CELKEL) THEN
                      FACTORB_S = FACTOR_S/ALPHA
                      FACTORB_G = FACTOR_G/ALPHA
                  ELSE
                      FACTORB_S = FACTOR_S
                      FACTORB_G = FACTOR_G
                  END IF

c      Calculate variable intercept parameters

                  IF (IVARINT.EQ.1) THEN

                      TEMP_C = DMIN1(-0.001D0,TMK(I,J,K)-CELKEL)
                      SONV = DMIN1(2.0D8,2.0D6*EXP(-0.12D0*TEMP_C))

                      GONV = GON
                      IF (QGR(I,J,K).GT.R1) THEN
                          GONV = 2.38D0* (PI*RHO_G/
     +                           (RHOAIR*QGR(I,J,K)))**0.92D0
                          GONV = MAX(1.D4,MIN(GONV,GON))
                      END IF

                      RONV = RON2
                      IF (QRA(I,J,K).GT.R1) THEN
                          RONV = RON_CONST1R*TANH((RON_QR0-QRA(I,J,K))/
     +                           RON_DELQR0) + RON_CONST2R
                      END IF

                  ELSE

                      RONV = RN0_R
                      SONV = RN0_S
                      GONV = RN0_G

                  END IF

c      Total equivalent reflectivity factor (z_e, in mm^6 m^-3) is
c      the sum of z_e for each hydrometeor species:

                  Z_E = FACTOR_R* (RHOAIR*QRA(I,J,K))**1.75D0/
     +                  RONV**.75D0 + FACTORB_S*
     +                  (RHOAIR*QSN(I,J,K))**1.75D0/SONV**.75D0 +
     +                  FACTORB_G* (RHOAIR*QGR(I,J,K))**1.75D0/
     +                  GONV**.75D0

c      Adjust small values of Z_e so that dBZ is no lower than -30
                  Z_E = MAX(Z_E,.001D0)

c      Convert to dBZ
                  DBZ(I,J,K) = 10.D0*LOG10(Z_E)

              END DO
          END DO
      END DO

      RETURN
      END


program demo_io_disp

    use forlab_io, only: disp
    use stdlib_io, only: open

    real(8) :: r(2, 3)
    complex :: c(2, 3), c_3d(2, 100, 20)
    integer :: i(2, 3)
    logical :: l(10, 10)

    r = 1.; c = 1.; c_3d = 2.; i = 1; l = .true.
    r(1, 1) = -1.e-11
    r(1, 2) = -1.e10
    c(2, 2) = (-1.e10, -1.e10)
    c_3d(1, 3, 1) = (1000, 0.001)
    c_3d(1, 3, 2) = (1.e4, 100.)

    call disp('string', header='disp(string):')
    call disp('It is a note.')
    call disp()
    call disp(r, header='disp(r):')
    call disp(r(1, :), header='disp(r(1,:))')
    call disp(c, header='disp(c):')
    call disp(i, header='disp(i):')
    call disp(l, header='disp(l):', brief=.true.)
    call disp(c_3d(:, :, 3), header='disp(c_3d(:,:,3)):', brief=.true.)
    call disp(c_3d(2, :, :), header='disp(c_3d(2,:,:)):', brief=.true.)

    j = open ("DP.txt", "w+")
    call disp(c_3d(1,:,:), header="test_disp_to_unit: ", unit=j)
    close (j)

end program demo_io_disp


****************************************************
*
* This is a program to do the triplet mapping for
* droplet inside the linear eddy domain.
*
*******************************************************

	subroutine drop_map(n,i1,m1,ncell
     1  ,flag,index,ibound1,ibound2)

	dimension index(ibound1:ibound2)
	integer j1,j2

c.
c. if this is not the 1st time enter this
c. subroutine, then it is not necessary to
c. set the I.C.s and B.C.s again, go to 1110
c.

	if (flag.eq.1.)goto 1110
c.
c. Do triplet mapping of droplet
c.
c. set I.C.s and B.C.s
c.
	do j=1,ncell
	index(j)=j
	index(j+ncell)=j
Cindex(j-ncell)=j
	end do

1110	continue
c.
c. Be careful not confused here, N is amount of
c. eddy grid points, I1-M1+1 is the 1st point
c. of triplet mapping (because that index(j)=j,
c. so I1 in LEM is equal I1-M1+1 in DROP_MAP.f
c. here. Similarily NN (last point of mapping)
c. is I1-M1+N. ALso think about if there is
c. difference of X(i) in LEM and DROP)
c.
	CALL TRIPLET1(N,I1-M1+1,index)
c write(*,*)N,I1-M1+1
c do j=1,ncell
c write(*,*)j,index(j)
c enddo

	NN=I1-M1+N

c
c check if index(j) is negative
c
	do j=I1-M1+1,I1-M1+N

        if (index(j).le.0)then
	write(*,*)n,I1
        write(*,*)'line 128 m',j,'index(m)',index(j)
        end if

	end do
c.
c. set the 1st point (j1)
c.
	j1=I1-M1+1
	j2=NN
Cwrite(95,*)'jk=',jk,N
Cdo i=j1,j2
Cwrite(95,*)i,index(i)
Cenddo

C
C return to index to the initial value
C

Cdo mp=j1,j2
Cj=mp
Cindex(j-ncell)=index(j)
Cend do

	if(j2.gt.ncell)then
  	do mp=j1,j2
	j=mp
     	index(j-ncell)=index(j)
        enddo
	else
         do mp=j1,j2
	 j=mp
     	 index(j+ncell)=index(j)
 	 enddo
	endif

        return

        end

*********************************************************
*
*       This is a subroutine to perform triplet mapping
*
*********************************************************

        SUBROUTINE TRIPLET1(KK,K1,A)
	parameter(ibound1=0,ibound2=50000)
        Dimension A(ibound1:ibound2),E(ibound1:ibound2)

c
c       kk is the grid number for the eddy, due to the triplet
c       mapping, M is the 1/3 eddy grid pts
c       the logic of triplet mapping can be described as following
c       example
c       initial scalar: 1,2,3,4,5,6,7,8,9
c       after mapping:/  1,4,7,8,5,2,3,6,9
c
        M=kk/3
        MA=(3*M-1)
        MB=3*M-2
        MC=3*M-3

c**************************************************
c
c       STEP1
c
c**************************************************

        DO K=K1,K1+M-1
        E(K)=A(3*M-MA+K1-1)
        MA=MA-3
        END DO

c********************************************************
c
c       STEP2 and STEP2.1 2nd segment and Block Inversion
c
c*********************************************************
        DO K=M+K1, 2*M+K1-1
        E(K)=A(3*M-MB+K1-1)
        MB=MB-3
        END DO
c
c       block inversion of the 2nd segment
c
        MB1=INT((M-1)/2)+(M+K1)
        MW=2*M+K1-1
        DO K=M+K1,MB1
        B1=E(K)
        E(K)=E(MW)

        E(MW)=B1
        MW=MW-1
        END DO

c**********************************************************
c
c       step3 3rd segment
c
c**********************************************************
        DO K=2*M+K1,3*M+K1-1
        E(K)=A(3*M-MC+K1-1)
        MC=MC-3
        END DO

        DO K=K1,KK+K1-1
        A(K)=E(K)
        END DO

        RETURN
        END


module orbital_mech
  use nrtype
  use ode, only : velocity_verlet

  type orb_par
    real(dp) :: a  ! Major semi-axis.
    real(dp) :: ea ! Eccentric anomaly.
    real(dp) :: ec ! Eccentricity.
    real(dp) :: ma ! Mean anomaly.
    real(dp) :: ta ! True anomaly.
    real(dp) :: dt ! Time step.
    real(dp) :: n  ! Mean angular motion := sqrt(mu/a**3)
    real(dp) :: r  ! Distance from the focus.
    real(dp) :: o(4) ! Orbital position and velocity.
    real(dp) :: x(6) ! Cartesian position and velocity.
    real(dp) :: eu(3)! Euler angles. eu(1) = Omega, eu(2) = i, eu(3) = omega
    real(dp) :: reu(6) ! Euler angles in the rotation matrix.
  end type orb_par

contains
  subroutine integrate_orbits(orbits, start, end, dt, rec)
    implicit none
    real(dp), intent(in) :: start, end, dt, rec
    type(orb_par), intent(inout) :: orbits(:)
    real(dp),dimension(6*size(orbits)) :: xi, xf ! initial orbital positions and velocities
    real(dp) :: t  ! time
    integer  :: i, nbod, n

    nbod = size(orbits)
    t    = start

    open(2, file = 'vectors.txt')
    read_init: do i = 1, nbod
      read(2,*) orbits(i) % x(1:3) ! Positions, X, Y, Z.
      read(2,*) orbits(i) % x(4:6) ! Velocities Vx, Vy, Vz.
    end do read_init
    close(2)

    n = 0
    ! Map orbital positions to a 1D array with 6n entries, where n = number of bodies.
    do i = 1, nbod
      ! xi(1:3*nbod) = x, y, z.
      xi(i+n:i+n+2) = orbits(i)%x(1:3)
      ! xi(3*nbod+1:6*nbod) = vx, vy, vz.
      xi(i+n+nbod*3:i+n+nbod*3+2) = orbits(i)%x(4:6)
      n = n + 2
    end do

    write(1,*) xi

    do while( t < end)
        call velocity_verlet(accel_solar_system,t,xi,xf,dt)
        t = t + dt
        if (mod(t, rec*dt) == 0.) write(1,*) xi
        xi = xf
    end do
  end subroutine integrate_orbits

  subroutine read_kep_el(filename, bodies, date_flag, kep_el)
    implicit none
    ! Reads Keplerian Elements.
    character(:), allocatable, intent(in) :: filename
    integer, intent(in)      :: bodies, date_flag
    real(dp), intent(out)    :: kep_el(:,:)
    integer                  :: open_status, close_status, i, j

    open(unit = 1, file = filename, status = 'old', iostat = open_status, action = 'read', position = 'rewind')
    if ( open_status /= 0 ) then
      print *, 'Could not open ',filename,' for reading.', &
      'unit = ', 1
      stop
    endif

    epoch: if (date_flag == 1) then
      read_file1: do i = 1, bodies
        read(1,*) kep_el(1:10,i)
        read(1,*) kep_el(11:20,i)
      end do read_file1
    else epoch
      do j = 1, 19
        read(1,*)
      end do
      read_file2: do i = 1, bodies
        read(1,*) kep_el(1:10,i)
        read(1,*) kep_el(11:20,i)
      end do read_file2
    end if epoch
    close(unit = 1)
  end subroutine read_kep_el

  subroutine kep_el_teph(kep_el, orbits, t_eph)
    implicit none
    ! Calculates the Keplerian Elements at a given Julian Epoch.
    real(dp), intent(inout)    :: kep_el(:,:)
    real(dp), intent(in)       :: t_eph ! Julian Ephemeris Date
    type(orb_par), intent(out) :: orbits(:)
    real(dp)                   :: t

    ! Calculating T for evolving orbital elements in time.
    t = (t_eph-2451545._dp)/36525._dp

    ! Evolve orbital elements in time.
    kep_el(1:6,:)   = kep_el(1:6,:)   + kep_el(7:12,:)  * t
    kep_el(13:16,:) = kep_el(13:16,:) + kep_el(17:20,:) * t

    ! Calculate orbital parameters.
    orbits % a     = kep_el(1,:)
    orbits % ec    = kep_el(2,:)
    orbits % eu(1) = kep_el(6,:) * pi/180._dp
    orbits % eu(2) = kep_el(3,:) * pi/180._dp
    orbits % eu(3) = (kep_el(5,:) - kep_el(6,:)) * pi/180._dp
    orbits % ma    = kep_el(4,:)  - kep_el(5,:)        &
    + kep_el(13,:)*t*t                 &
    + kep_el(14,:)*cos(kep_el(16,:)*t) &
    + kep_el(15,:)*sin(kep_el(16,:)*t)
    orbits % ma    = mod(orbits % ma, tau) - pi
  end subroutine kep_el_teph

  subroutine state_vec(orbits,nr_tol)
    implicit none
    ! Calculates position and velocity state vectors.
    type(orb_par), intent(inout)      :: orbits(:)
    real(dp), intent(in)              :: nr_tol
    real(dp), dimension(size(orbits)) :: c1, c2, cosea, eao2
    real(dp), parameter :: mu = 1.32712440018d9/1.49597870700_dp, secoday = 1._dp/86400._dp ! seconds
    integer :: i

    ! Solve Kepler's equation for all orbits to calculate the eccentric anomaly.
    call orb_new_rap(orbits,nr_tol)

    ! Calculate true anomaly.
    eao2  = orbits % ea * .5_dp
    cosea = cos( orbits % ea )
    orbits % ta = 2._dp * atan2( sqrt( 1 - orbits % ec )*cos( eao2 ), &
    sqrt(1 + orbits % ec) * sin( eao2 ) )

    ! Calculate distance from the focus.
    orbits % r = orbits % a * (1._dp - orbits % ec * cosea )
    ! Calculating orbital positions.
    ! Calculating x in orbital coordinates.
    orbits % o(1) = orbits % r * cos( orbits % ta )
    ! Calculating y in orbital coordiantes.
    orbits % o(2) = orbits % r * sin( orbits % ta )

    ! Calculating orbital velocities.
    c1 = sqrt( mu * orbits % a ) / orbits % r
    c2 = sqrt( 1 - orbits % ec * orbits % ec )
    ! Calculating dx/dea.
    orbits % o(3) = - c1 * sin( orbits % ea )*secoday
    ! Calculating dy/dea.
    orbits % o(4) = c1 * c2 * cosea*secoday

    ! Call the rotation matrix for the euler angles.
    call rotate_orb_cart(orbits)

    orb_to_cart: do i = 1, size(orbits)
      orbits(i) % x(1:3) = orbits(i) % o(1) * orbits(i) % reu(1:3) + orbits(i) % o(2) * orbits(i) % reu(4:6)
      orbits(i) % x(4:6) = orbits(i) % o(3) * orbits(i) % reu(1:3) + orbits(i) % o(4) * orbits(i) % reu(4:6)
    end do orb_to_cart
  end subroutine state_vec

  subroutine kepler_eqn(kepeq,dkepeq,orbits)
    implicit none
    type(orb_par), intent(in)                      :: orbits(:)
    real(dp), intent(out), dimension(size(orbits)) :: kepeq, dkepeq

    ! We need to know when this is zero. From here we obtain the eccentric anomaly.
    kepeq  = orbits % ea - orbits % ec * sin(orbits % ea) - orbits % ma
    dkepeq = 1 - orbits % ec * cos(orbits % ea)
  end subroutine kepler_eqn

  subroutine orb_new_rap(orbits,tol)
    implicit none
    type(orb_par), intent(inout)      :: orbits(:)
    real(dp), dimension(size(orbits)) :: kepeq, dkepeq
    real(dp), intent(in)              :: tol
    real(dp) :: ea_1(size(orbits))
    integer  :: obj

    obj  = size(orbits)
    ! Initial value of the eccentric anomaly is the mean anomaly.
    orbits % ea = orbits % ma
    new_rap: do
      ea_1 = orbits % ea
      call kepler_eqn(kepeq,dkepeq,orbits)
      orbits % ea = orbits % ea - kepeq/dkepeq
      if ( 0.5_dp * abs( sum(orbits % ea)/obj - sum(ea_1)/obj ) < tol) return
    end do new_rap
  end subroutine orb_new_rap

  subroutine rotate_orb_cart(orbits)
    implicit none
    type(orb_par), intent(inout) :: orbits(:)
    orbits % reu(1) =  cos(orbits % eu(1)) * cos(orbits % eu(3)) - sin(orbits % eu(1)) * cos(orbits % eu(2)) * sin(orbits % eu(3))
    orbits % reu(2) =  sin(orbits % eu(1)) * cos(orbits % eu(3)) + cos(orbits % eu(1)) * cos(orbits % eu(2)) * sin(orbits % eu(3))
    orbits % reu(3) =  sin(orbits % eu(2)) * sin(orbits % eu(3))
    orbits % reu(4) = -cos(orbits % eu(1)) * sin(orbits % eu(3)) - sin(orbits % eu(1)) * cos(orbits % eu(2)) * cos(orbits % eu(3))
    orbits % reu(6) =  sin(orbits % eu(2)) * sin(orbits % eu(1))
    orbits % reu(5) = -sin(orbits % eu(1)) * sin(orbits % eu(3)) + cos(orbits % eu(1)) * cos(orbits % eu(2)) * cos(orbits % eu(3))
  end subroutine rotate_orb_cart

  subroutine accel_solar_system(x,y,dydx)
    implicit none
    real(dp), intent(in)  :: x, y(:)
    real(dp), intent(out) :: dydx(:)
    real(dp), parameter   :: kmau   = 1.495978707E+8, &   ! km/Au
                             km3au3  = kmau*kmau*kmau, &  ! km^3/Au^3
                             sd  = 8.64E+4, &             ! s/d
                             s2d2 = sd*sd                 ! s^2/d^2
    real(dp), parameter, dimension(10) :: g = [1.3271244004193938E+11, 2.203209E+4, 3.2485863E+5, &
                                               3.9860044E+5, 4.28283E+4, 1.26686511E+8, 3.79312078E+7, &
                                               5.793966E+6, 6.835107E+6, 872.4]/km3au3*s2d2
    integer  :: i, j, m, n ! i and j are coutners. m and n are counters that increase by two
    real(dp) :: norm, vec(3)
    integer  :: nbod

    nbod = size(y)/6
    ! Initial acceleration is zero because we need to add the acceleration caused by all interactions.
    dydx = 0._dp

    ! M increases by two every iteration of the loop for the planets. This is due to mapping an n x 6 matrix to a vector with 6n entries, where n = # of bodies.
    n = 0
    loop_cel_bodies: do i = 1, nbod
      ! N inreases by two every iteration of the acceleration. This is due to mapping an n x 6 matrix to a vector with 6n entries, where n = # of bodies.
      m = 0
      loop_accel: do j = 1, nbod
        ! Check for self-interactions, and skip them. We need to add two to m because the potential energy difference between a celestial body and itself is zero, therefore the acceleration with respect to itself is zero.
        if (j == i) then
          m = m + 2
          cycle loop_accel
        end if
        ! Calculate the components of the direction vector.
        vec  =  y(j + m : j + 2 + m) - y(i + n: i + 2 + n)
        ! Calculate the norm of the direction vector.
        norm = sqrt( sum(vec*vec) )
        ! Cube the norm.
        norm = norm*norm*norm
        ! Calculate the the total acceleration for a celestial body.
        dydx(i + n: i + 2 + n) = g(j)*vec / norm + dydx(i + n: i + 2 + n)
        m = m + 2
      end do loop_accel
      n = n + 2
    end do loop_cel_bodies
  end subroutine accel_solar_system
end module orbital_mech


!       Retrieved from:
!       http://ergodic.ugr.es/cphys/UTILES/dranxor2new.f

	subroutine dranini(iseed0)
	implicit double precision(a-h,o-z)
    	parameter(ip=1279)
	parameter(np=14)
	parameter(nbit=31)
	parameter(m=2**np,np1=nbit-np,nn=2**np1-1,nn1=nn+1)
	integer ix(ip)
	dimension g(0:m)

	data c0,c1,c2/2.515517,0.802853,0.010328/
	data d1,d2,d3/1.432788,0.189269,0.001308/
c
	common /ixx/ ix
	common /icc/ ic
	common /gg/ g
c
	dseed=iseed0
    	do 200 i=1,ip
        ix(i)=0
        do 200 j=0,nbit-1
        if(randxx(dseed).lt.0.5) ix(i)=ibset(ix(i),j)
200	continue
	ic=0
c
	pi=4.0d0*datan(1.0d0)
	do 1 i=m/2,m
	p=1.0-real(i+1)/(m+2)
	t=sqrt(-2.0*log(p))
	x=t-(c0+t*(c1+c2*t))/(1.0+t*(d1+t*(d2+t*d3)))
	g(i)=x
	g(m-i)=-x
1	continue

	u2th=1.0-real(m+2)/m*sqrt(2.0/pi)*g(m)*exp(-g(m)*g(m)/2)
	u2th=nn1*sqrt(u2th)
	do 856 i=0,m
856	g(i)=g(i)/u2th

	return
	end

! 	subroutine dranread(iunit)
! 	implicit double precision(a-h,o-z)
!     	parameter(ip=1279)
! 	parameter(np=14)
! 	parameter(m=2**np)
!         integer ix(ip)
! 	dimension g(0:m)
!         common /ixx/ ix
!         common /icc/ ic
! 	common /gg/ g
! 	open(UNIT=iunit)
!         read (iunit,*) ic
!         read (iunit,*) (ix(i),i=1,ip)
! 	read (iunit,*) (g(i),i=0,m)
! 	close(iunit)
!         return
!         end
!
!         subroutine dranwrite(iunit)
! 	implicit double precision(a-h,o-z)
!     	parameter(ip=1279)
! 	parameter(np=14)
! 	parameter(m=2**np)
!         integer ix(ip)
! 	dimension g(0:m)
! 	common /ixx/ ix
! 	common /icc/ ic
! 	common /gg/ g
! 	open(UNIT=iunit)
!         write (iunit,*) ic
!         write (iunit,*) (ix(i),i=1,ip)
! 	write (iunit,*) (g(i),i=0,m)
! 	close(iunit)
!         return
!         end
!
! 	subroutine dranread2(iunit,cadena)
! 	implicit double precision(a-h,o-z)
! 	character*100 cadena
!     	parameter(ip=1279)
! 	parameter(np=14)
! 	parameter(m=2**np)
!         integer ix(ip)
! 	dimension g(0:m)
!         common /ixx/ ix
!         common /icc/ ic
! 	common /gg/ g
! 	open(UNIT=iunit,FILE=cadena)
!         read (iunit,*) ic
!         read (iunit,*) (ix(i),i=1,ip)
! 	read (iunit,*) (g(i),i=0,m)
! 	close(iunit)
!         return
!         end
!
!         subroutine dranwrite2(iunit,cadena)
! 	implicit double precision(a-h,o-z)
! 	character*100 cadena
!     	parameter(ip=1279)
! 	parameter(np=14)
! 	parameter(m=2**np)
!         integer ix(ip)
! 	dimension g(0:m)
! 	common /ixx/ ix
! 	common /icc/ ic
! 	common /gg/ g
! 	open(UNIT=iunit,FILE=cadena,STATUS="UNKNOWN")
!         write (iunit,*) ic
!         write (iunit,*) (ix(i),i=1,ip)
! 	write (iunit,*) (g(i),i=0,m)
! 	close(iunit)
!         return
!         end

	function idran(n)
	implicit double precision(a-h,o-z)
    	parameter(ip=1279)
	parameter(iq=418)
	parameter(is=ip-iq)
	integer ix(ip)
	common /ixx/ ix
	common /icc/ ic
	ic=ic+1
    	if(ic.gt.ip) ic=1
	if(ic.gt.iq) then
		ix(ic)=ieor(ix(ic),ix(ic-iq))
	else
        	ix(ic)=ieor(ix(ic),ix(ic+is))
    	endif
    	idran=ix(ic)
        if (n.gt.0) idran=mod(idran,n)+1
    	return
	end

	function dranu()
	implicit double precision(a-h,o-z)
    	parameter(ip=1279)
	parameter(iq=418)
	parameter(is=ip-iq)
    	parameter (rmax=2147483647.0)
	integer ix(ip)
	common /ixx/ ix
	common /icc/ ic
	ic=ic+1
    	if(ic.gt.ip) ic=1
	if(ic.gt.iq) then
		ix(ic)=ieor(ix(ic),ix(ic-iq))
	else
        	ix(ic)=ieor(ix(ic),ix(ic+is))
    	endif
    	dranu=real(ix(ic))/rmax
	return
	end

	function drang()
	implicit double precision(a-h,o-z)
    	parameter(ip=1279)
	parameter(iq=418)
	parameter(np=14)
	parameter(nbit=31)
	parameter(m=2**np,np1=nbit-np,nn=2**np1-1,nn1=nn+1)
	parameter(is=ip-iq)

	integer ix(ip)
	dimension g(0:m)

	common /ixx/ ix
	common /icc/ ic
	common /gg/ g

	ic=ic+1
    	if(ic.gt.ip) ic=1
	if(ic.gt.iq) then
		ix(ic)=ieor(ix(ic),ix(ic-iq))
	else
        	ix(ic)=ieor(ix(ic),ix(ic+is))
    	endif
	i=ishft(ix(ic),-np1)
	i2=iand(ix(ic),nn)
	drang=i2*g(i+1)+(nn1-i2)*g(i)
	return
	end

	subroutine dranbm(x1,x2)
	implicit double precision(a-h,o-z)
    	parameter(ip=1279)
	parameter(iq=418)
	parameter(is=ip-iq)
    	parameter (rmax=2147483647.0)
	integer ix(ip)
	common /ixx/ ix
	common /icc/ ic
	data pi2 /6.2831853072/
	ic=ic+1
    	if (ic.gt.ip) ic=1
	if(ic.gt.iq) then
		ix(ic)=ieor(ix(ic),ix(ic-iq))
	else
        	ix(ic)=ieor(ix(ic),ix(ic+is))
    	endif
	u=pi2*real(ix(ic))/rmax
	ic=ic+1
    	if(ic.gt.ip) ic=1
	if(ic.gt.iq) then
		ix(ic)=ieor(ix(ic),ix(ic-iq))
	else
        	ix(ic)=ieor(ix(ic),ix(ic+is))
    	endif
	v=(real(ix(ic))+0.5)/rmax
	v=sqrt(-2.0*log(v))
	x1=cos(u)*v
	x2=sin(u)*v
	return
	end

	subroutine drangv(u,n)
	implicit double precision(a-h,o-z)
	parameter(ip=1279)
	parameter(iq=418)
	parameter(np=14)
	parameter(nbit=31)
	parameter(m=2**np,np1=nbit-np,nn=2**np1-1,nn1=nn+1)
	parameter(is=ip-iq)
	dimension g(0:m)
	dimension u(n)
	dimension ix(ip)
	common /gg/ g
	common /ixx/ ix
	common /icc/ic

        n1=0
10      if (ic.lt.iq) then
          kmax=min(n-n1,iq-ic)
	  do 99 k=1,kmax
  	  ic=ic+1
	  ix(ic)=ieor(ix(ic),ix(ic+is))
	  i=ishft(ix(ic),-np1)
	  i2=iand(ix(ic),nn)
	  u(n1+k)=i2*g(i+1)+(nn1-i2)*g(i)
99        continue
        else
          kmax=min(n-n1,ip-ic)
	  do 98 k=1,kmax
	  ic=ic+1
	  ix(ic)=ieor(ix(ic),ix(ic-iq))
	  i=ishft(ix(ic),-np1)
	  i2=iand(ix(ic),nn)
	  u(n1+k)=i2*g(i+1)+(nn1-i2)*g(i)
98        enddo
        endif
        if(ic.ge.ip) ic=0
        n1=n1+kmax
        if (n1.lt.n) goto 10

	return
	end

	subroutine drangvv(iv,u,n)
	implicit double precision(a-h,o-z)
	parameter(ip=1279)
	parameter(iq=418)
	parameter(np=14)
	parameter(nbit=31)
	parameter(m=2**np,np1=nbit-np,nn=2**np1-1,nn1=nn+1)
	parameter(is=ip-iq)
        dimension iv(n+ip)
	dimension g(0:m)
	dimension u(n)
	dimension ix(ip)
	common /gg/ g
	common /ixx/ ix
	common /icc/ic

	do 10 i=ic+1,ip
10	iv(i-ic)=ix(i)
	do 20 i=1,ic
20	iv(ip-ic+i)=ix(i)

cCDEC$ INIT_DEP_FWD
	do 99 k=1,n
	ir=ieor(iv(k+is),iv(k))
	i=ishft(ir,-np1)
	i2=iand(ir,nn)
	u(k)=i2*g(i+1)+(nn1-i2)*g(i)
	iv(k+ip)=ir
99	continue

	do 11 i=ic+1,ip
11	ix(i)=iv(n+i-ic)
	do 21 i=1,ic
21	ix(i)=iv(n+ip-ic+i)

	return
	end

        function randxx(dseed)
        double precision a,c,xm,rm,dseed,randxx
        parameter (xm=2.d0**32,rm=1.d0/xm,a=69069.d0,c=1.d0)
        dseed=mod(dseed*a+c,xm)
        randxx=dseed*rm
        return
        end


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Tool_Yes_In_Poly(x,y,xpol,ypol,npol,Yes_INOUT)
C     check if a point inside a polygon
      integer i,j,npol
      double precision x,y,xpol(npol),ypol(npol)
      logical Yes_INOUT

      Yes_INOUT = .False.
      if((x.gt.maxval(xpol)) .or.
     &   (x.lt.minval(xpol)) .or.
     &   (y.gt.maxval(ypol)) .or.
     &   (y.lt.minval(ypol))) then
             Yes_INOUT = .False.
         goto 100

      else
          j = npol-1
          do i=1,npol-1
              if ( ((ypol(i).gt.y).neqv. (ypol(j).gt.y)) .and.
     &               (x .lt. (xpol(j)-xpol(i)) * (y-ypol(i))
     &                / (ypol(j)-ypol(i)) + xpol(i)) ) then
                  Yes_INOUT = .NOT. Yes_INOUT
              end if
              j = i
          end do
      end if

  100 continue

      return
      end SUBROUTINE Tool_Yes_In_Poly


!===============================================================================
! Copyright 2006-2019 Intel Corporation.
!
! This software and the related documents are Intel copyrighted  materials,  and
! your use of  them is  governed by the  express license  under which  they were
! provided to you (License).  Unless the License provides otherwise, you may not
! use, modify, copy, publish, distribute,  disclose or transmit this software or
! the related documents without Intel's prior written permission.
!
! This software and the related documents  are provided as  is,  with no express
! or implied  warranties,  other  than those  that are  expressly stated  in the
! License.
!===============================================================================

MODULE MKL_POISSON

USE MKL_DFTI

INTERFACE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!INTERFACES FOR 3D CASE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE D_INIT_HELMHOLTZ_3D(AX,BX,AY,BY,AZ,BZ,NX,NY,NZ,BCTYPE,Q,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER NX, NY, NZ, STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION AX,BX,AY,BY,AZ,BZ,Q
   CHARACTER(6) BCTYPE
   DOUBLE PRECISION DPAR(*)
END SUBROUTINE

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

SUBROUTINE D_COMMIT_HELMHOLTZ_3D(F,BD_AX,BD_BX,BD_AY,BD_BY,BD_AZ,BD_BZ,XHANDLE,YHANDLE,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION DPAR(*)
   DOUBLE PRECISION F(IPAR(11)+1,IPAR(12)+1,*)
   DOUBLE PRECISION BD_AX(IPAR(12)+1,*),BD_BX(IPAR(12)+1,*),BD_AY(IPAR(11)+1,*),BD_BY(IPAR(11)+1,*)
   DOUBLE PRECISION BD_AZ(IPAR(11)+1,*),BD_BZ(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: XHANDLE, YHANDLE
END SUBROUTINE

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

SUBROUTINE D_HELMHOLTZ_3D(F,BD_AX,BD_BX,BD_AY,BD_BY,BD_AZ,BD_BZ,XHANDLE,YHANDLE,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION F(IPAR(11)+1,IPAR(12)+1,*)
   DOUBLE PRECISION BD_AX(IPAR(12)+1,*),BD_BX(IPAR(12)+1,*),BD_AY(IPAR(11)+1,*),BD_BY(IPAR(11)+1,*)
   DOUBLE PRECISION BD_AZ(IPAR(11)+1,*),BD_BZ(IPAR(11)+1,*)
   DOUBLE PRECISION DPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: XHANDLE, YHANDLE
END SUBROUTINE

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

SUBROUTINE FREE_HELMHOLTZ_3D(XHANDLE,YHANDLE,IPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: XHANDLE, YHANDLE
END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!INTERFACES FOR 2D CASE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE D_INIT_HELMHOLTZ_2D(AX,BX,AY,BY,NX,NY,BCTYPE,Q,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER NX, NY, STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION AX,BX,AY,BY,Q
   CHARACTER(4) BCTYPE
   DOUBLE PRECISION DPAR(*)
END SUBROUTINE

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

SUBROUTINE D_COMMIT_HELMHOLTZ_2D(F,BD_AX,BD_BX,BD_AY,BD_BY,HANDLE,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION F(IPAR(11)+1,*)
   DOUBLE PRECISION BD_AX(*),BD_BX(*),BD_AY(*),BD_BY(*)
   DOUBLE PRECISION DPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE

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

SUBROUTINE D_HELMHOLTZ_2D(F,BD_AX,BD_BX,BD_AY,BD_BY,HANDLE,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION F(IPAR(11)+1,*)
   DOUBLE PRECISION BD_AX(*),BD_BX(*),BD_AY(*),BD_BY(*)
   DOUBLE PRECISION DPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE

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

SUBROUTINE FREE_HELMHOLTZ_2D(HANDLE,IPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE
!**********************************************************************
!***********************SINGLE*****************************************
!**********************************************************************
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!INTERFACES FOR 3D CASE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE S_INIT_HELMHOLTZ_3D(AX,BX,AY,BY,AZ,BZ,NX,NY,NZ,BCTYPE,Q,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER NX, NY, NZ, STAT
   INTEGER IPAR(*)
   REAL AX,BX,AY,BY,AZ,BZ,Q
   CHARACTER(6) BCTYPE
   REAL SPAR(*)
END SUBROUTINE

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

SUBROUTINE S_COMMIT_HELMHOLTZ_3D(F,BD_AX,BD_BX,BD_AY,BD_BY,BD_AZ,BD_BZ,XHANDLE,YHANDLE,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   REAL SPAR(*)
   REAL F(IPAR(11)+1,IPAR(12)+1,*)
   REAL BD_AX(IPAR(12)+1,*),BD_BX(IPAR(12)+1,*),BD_AY(IPAR(11)+1,*),BD_BY(IPAR(11)+1,*)
   REAL BD_AZ(IPAR(11)+1,*),BD_BZ(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: XHANDLE, YHANDLE
END SUBROUTINE

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

SUBROUTINE S_HELMHOLTZ_3D(F,BD_AX,BD_BX,BD_AY,BD_BY,BD_AZ,BD_BZ,XHANDLE,YHANDLE,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   REAL F(IPAR(11)+1,IPAR(12)+1,*)
   REAL BD_AX(IPAR(12)+1,*),BD_BX(IPAR(12)+1,*),BD_AY(IPAR(11)+1,*),BD_BY(IPAR(11)+1,*)
   REAL BD_AZ(IPAR(11)+1,*),BD_BZ(IPAR(11)+1,*)
   REAL SPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: XHANDLE, YHANDLE
END SUBROUTINE

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!INTERFACES FOR 2D CASE!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE S_INIT_HELMHOLTZ_2D(AX,BX,AY,BY,NX,NY,BCTYPE,Q,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER NX, NY, STAT
   INTEGER IPAR(*)
   REAL AX,BX,AY,BY,Q
   CHARACTER(4) BCTYPE
   REAL SPAR(*)
END SUBROUTINE

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

SUBROUTINE S_COMMIT_HELMHOLTZ_2D(F,BD_AX,BD_BX,BD_AY,BD_BY,HANDLE,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   REAL F(IPAR(11)+1,*)
   REAL BD_AX(*),BD_BX(*),BD_AY(*),BD_BY(*)
   REAL SPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE

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

SUBROUTINE S_HELMHOLTZ_2D(F,BD_AX,BD_BX,BD_AY,BD_BY,HANDLE,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   REAL F(IPAR(11)+1,*)
   REAL BD_AX(*),BD_BX(*),BD_AY(*),BD_BY(*)
   REAL SPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE

SUBROUTINE D_INIT_SPH_P(AX,BX,AY,BY,NX,NY,Q,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER NX, NY, STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION AX,BX,AY,BY,Q
   DOUBLE PRECISION DPAR(*)
END SUBROUTINE

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

SUBROUTINE D_COMMIT_SPH_P(F,HANDLE_S,HANDLE_C,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION DPAR(*)
   DOUBLE PRECISION F(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE_C, HANDLE_S
END SUBROUTINE

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

SUBROUTINE D_SPH_P(F,HANDLE_S,HANDLE_C,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION DPAR(*)
   DOUBLE PRECISION F(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE_C, HANDLE_S
END SUBROUTINE

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

SUBROUTINE FREE_SPH_P(HANDLE_S,HANDLE_C,IPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE_S, HANDLE_C
END SUBROUTINE

!---------------------------------------------------------------------
SUBROUTINE D_INIT_SPH_NP(AX,BX,AY,BY,NX,NY,Q,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER NX, NY, STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION AX,BX,AY,BY,Q
   DOUBLE PRECISION DPAR(*)
END SUBROUTINE

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

SUBROUTINE D_COMMIT_SPH_NP(F,HANDLE,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION DPAR(*)
   DOUBLE PRECISION F(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE

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

SUBROUTINE D_SPH_NP(F,HANDLE,IPAR,DPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   DOUBLE PRECISION DPAR(*)
   DOUBLE PRECISION F(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE

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

SUBROUTINE FREE_SPH_NP(HANDLE,IPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE

!======================================================================

SUBROUTINE S_INIT_SPH_P(AX,BX,AY,BY,NX,NY,Q,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER NX, NY, STAT
   INTEGER IPAR(*)
   REAL AX,BX,AY,BY,Q
   REAL SPAR(*)
END SUBROUTINE

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

SUBROUTINE S_COMMIT_SPH_P(F,HANDLE_S,HANDLE_C,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   REAL SPAR(*)
   REAL F(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE_C, HANDLE_S
END SUBROUTINE

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

SUBROUTINE S_SPH_P(F,HANDLE_S,HANDLE_C,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   REAL SPAR(*)
   REAL F(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE_C, HANDLE_S
END SUBROUTINE

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

SUBROUTINE S_INIT_SPH_NP(AX,BX,AY,BY,NX,NY,Q,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER NX, NY, STAT
   INTEGER IPAR(*)
   REAL AX,BX,AY,BY,Q
   REAL SPAR(*)
END SUBROUTINE

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

SUBROUTINE S_COMMIT_SPH_NP(F,HANDLE,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   REAL SPAR(*)
   REAL F(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE

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

SUBROUTINE S_SPH_NP(F,HANDLE,IPAR,SPAR,STAT)
   USE MKL_DFTI

   INTEGER STAT
   INTEGER IPAR(*)
   REAL SPAR(*)
   REAL F(IPAR(11)+1,*)
   TYPE(DFTI_DESCRIPTOR), POINTER :: HANDLE
END SUBROUTINE

END INTERFACE
END MODULE