      subroutine gen6(r,q,wt6,*)
      implicit none
      include 'constants.f'
      include 'mxdim.f'
      include 'debug.f'
      include 'phasemin.f'
      include 'process.f'
      include 'masses.f'
      include 'jetcuts.f'
      include 'x1x2.f'
      include 'energy.f'
      integer nu
      double precision r(mxdim)
      double precision wt6,q(mxpart,4)
      double precision p1(4),p2(4),p3(4),p4(4),p5(4),p6(4),p7(4),p8(4)
      double precision y,pswt,xjac,tau,vs,vsqmax,vsqmin,
     & s34,rtshat,ymax,yave

      wt6=0d0

      if (((case .eq. 'HWW2jt') .or. (case .eq. 'HZZ2jt'))
     &  .and. (hmass .lt. 201d0)) then
c--- Higgs production with WW or ZZ decay, small Higgs width
c--- (small error induced if zerowidth false, of order (hwidth/hmass))
        vsqmax=1d0/(hmass*(hmass+4d0*ptjetmin))
        vsqmin=1d0/sqrts**2
        xmin=vsqmin/vsqmax
        vs=(vsqmax-vsqmin)*r(9)+vsqmin
        s34=1d0/vs
        rtshat=dsqrt(s34)
        ymax=dlog(sqrts/rtshat)
        yave=ymax*(two*r(10)-1d0)
        xx(1)=rtshat/sqrts*exp(+yave)
        xx(2)=rtshat/sqrts*exp(-yave)
        xjac=(vsqmax-vsqmin)*s34**2/sqrts**2*two*ymax
      else
c--- generic process
        tau=dexp(dlog(taumin)*r(9))
        y=0.5d0*dlog(tau)*(1d0-2d0*r(10))
        xx(1)=dsqrt(tau)*dexp(+y)
        xx(2)=dsqrt(tau)*dexp(-y)
        xjac=dlog(taumin)*tau*dlog(tau)
      endif

c--- phase space volume only checked for x1=x2=1
      if ((case .eq. 'vlchwg') .or. (case .eq. 'vlchwh')) then
        xx(1)=1d0
        xx(2)=1d0
        xjac=1d0
      endif

c---if x's out of normal range alternative return
      if   ((xx(1) .gt. 1d0)
     & .or. (xx(2) .gt. 1d0)
     & .or. (xx(1) .lt. xmin)
     & .or. (xx(2) .lt. xmin)) return 1

      p1(4)=-xx(1)*sqrts*half
      p1(1)=zip
      p1(2)=zip
      p1(3)=-xx(1)*sqrts*half

      p2(4)=-xx(2)*sqrts*half
      p2(1)=zip
      p2(2)=zip
      p2(3)=+xx(2)*sqrts*half

      if     ((case .eq. 'W_twdk') .or. (case .eq. 'Wtbwdk')
     .   .or. (case .eq. 'W_cwdk') .or. (case .eq. 'vlchwh')) then
c--- W+t process, radiation in production
        call phase6a(r,p1,p2,p3,p4,p5,p6,p7,p8,pswt,*999)
      elseif ((case .eq. 'Wtdkay') .or. (case .eq. 'vlchwg')) then
c--- W+t process, radiation in decay
        call phase6b(r,p1,p2,p3,p4,p5,p6,p7,p8,pswt,*999)
      else
c--- generic case
        call phase6(r,p1,p2,p3,p4,p5,p6,p7,p8,pswt,*999)
      endif

      do nu=1,4
        q(1,nu)=p1(nu)
        q(2,nu)=p2(nu)
        q(3,nu)=p3(nu)
        q(4,nu)=p4(nu)
        q(5,nu)=p5(nu)
        q(6,nu)=p6(nu)
        q(7,nu)=p7(nu)
        q(8,nu)=p8(nu)
      enddo

      wt6=xjac*pswt

      if (debug) write(6,*) 'wt6 in gen6',wt6

      return

 999  q(:,:)=0d0
      return 1

      end


!-----------------------------------------------------------------------
!        FDTDの共通変数
!-----------------------------------------------------------------------
      module fdtd_variable
!解析領域
      integer,parameter::nxx=200,nyy=200,nzz=200   !解析領域分割数
      integer,parameter::nstep=300                !計算ステップ数
      real,parameter::dx=0.005,dy=0.005,dz=0.005   !セルサイズ
      real::dt,t                                   !時間ステップ,時間
!全計算領域
      integer,parameter::nx=nxx,ny=nyy,nz=nzz
!電界，磁界の配列，係数の配列
      real::ex(0:nx,0:ny,0:nz),ey(0:nx,0:ny,0:nz),ez(0:nx,0:ny,0:nz)
      real::hx(0:nx,0:ny,0:nz),hy(0:nx,0:ny,0:nz),hz(0:nx,0:ny,0:nz)
      real::aex(0:nx,0:ny,0:nz),aey(0:nx,0:ny,0:nz),aez(0:nx,0:ny,0:nz)
      real::bexy(0:nx,0:ny,0:nz),bexz(0:nx,0:ny,0:nz)
      real::beyx(0:nx,0:ny,0:nz),beyz(0:nx,0:ny,0:nz)
      real::bezx(0:nx,0:ny,0:nz),bezy(0:nx,0:ny,0:nz)
      real::amx(0:nx,0:ny,0:nz),amy(0:nx,0:ny,0:nz),amz(0:nx,0:ny,0:nz)
      real::bmxy(0:nx,0:ny,0:nz),bmxz(0:nx,0:ny,0:nz)
      real::bmyx(0:nx,0:ny,0:nz),bmyz(0:nx,0:ny,0:nz)
      real::bmzx(0:nx,0:ny,0:nz),bmzy(0:nx,0:ny,0:nz)
!媒質定数の配列と背景媒質定数
      real::epsd(-1:nx,-1:ny,-1:nz),sgmed(-1:nx,-1:ny,-1:nz)
      real::mud(-1:nx,-1:ny,-1:nz), sgmmd(-1:nx,-1:ny,-1:nz)
      real,parameter::epsbk=1.0,mubk=1.0,sigebk=0.0,sigmbk=0.0 !背景媒質
!散乱体
      integer,parameter::ic=nx/2, jc=ny/2, kc=nz/2    !散乱直方体の中心
      integer,parameter::lx2=20, ly2=20, lz2=20       !(直方体の寸法）/2
      real,parameter::epsr=5.0                        !直方体の比誘電率
!励振パルス
      real,parameter::duration=0.1e-9,t0=4.0*duration   !パルス幅，ピーク時刻
      integer,parameter::ifed=ic-lx2-20, jfed=jc, kfed=kc   !給電位置
!励振の種類
      integer::lfeed,lsoft,lhard
      parameter(lsoft=1,lhard=2)
      parameter(lfeed=lhard)
      real::befed                                       !ソフト給電の係数
      real,parameter::dl=0.001                          !ハード給電の間隙
!定数
      real,parameter::eps0=8.854188e-12,mu0=1.256637e-6 !真空の誘電率，透磁率
      real,parameter::c=2.9979246e8                     !光速
      end module fdtd_variable
!-----------------------------------------------------------------------
!       メインプログラム
!-----------------------------------------------------------------------
      program fdtd_3d
      use fdtd_variable

      call setup()                    !FDTDの初期設定

      t=dt
      do n=1,nstep                    !繰り返し計算
         write(*,*)'Time step:',n
         call e_cal                   !電界の計算
         call feed()                  !電流源の励振
         t=t+0.5*dt                   !時間の更新
         call h_cal                   !磁界の計算
         t=t+0.5*dt                   !時間の更新
         call out_emf(n)              !計算結果の出力
      end do
      end program fdtd_3d
!-----------------------------------------------------------------------
!       計算結果の出力
!-----------------------------------------------------------------------
      subroutine out_emf(n)
      use fdtd_variable
      integer,parameter::io=ic-lx2-40, jo=ny/2, ko=nz/2    !観測点

!出力空間の設定
      is=lpml
      ie=nx-lpml
      js=lpml
      je=ny-lpml
      k=nz/2

      if(n == 1) open(02,file='eztm.txt')
      write(02,111)t,ez(io,jo,ko)                   !観測点の過渡電界

      if(n==160)then
         open(03,file="ez160h.txt")
         do j=js,je
            do i=is,ie
               write(03,222)i-lpml,j-lpml,ez(i,j,k) !電界の空間分布
            end do
         end do
         close(03)
      end if

      if(n == nstep) close(02)
  111 format(2e18.9)
  222 format(2i5,e15.6)

      end subroutine out_emf

!-----------------------------------------------------------------------
!       励振波源
!-----------------------------------------------------------------------
      subroutine feed()
      use fdtd_variable
      real::iz

      ez(ifed,jfed,kfed)=exp(-((t-t0)/duration)**2)/dl   !ハード給電

      end subroutine feed
!-----------------------------------------------------------------------
!     FDTDの初期設定：
!-----------------------------------------------------------------------
      subroutine setup()
      use fdtd_variable
      real::mu
      integer::i,j,k

!時間ステップ
      dt=0.99999/(c*sqrt(1.0/(dx*dx)+1.0/(dy*dy)+1.0/(dz*dz)))
!背景媒質
      do k=-1,nz
         do j=-1,ny
            do i=-1,nx
               epsd(i,j,k)=epsbk
               mud(i,j,k)=mubk
               sgmed(i,j,k)=sigebk
               sgmmd(i,j,k)=sigmbk
            end do
         end do
      end do

!散乱直方体の媒質定数（背景媒質に上書き）
      call epsmu()

!波源の位置における係数
      eps=0.25*(epsd(ifed,jfed,kfed)+epsd(ifed-1,jfed,kfed)
     &          +epsd(ifed,jfed-1,kfed)+epsd(ifed-1,jfed-1,kfed))*eps0
      befed=dt/eps

!係数の計算
      do k=0,nz
        do j=0,ny
          do i=0,nx
            eps=0.25*(epsd(i,j,k)+epsd(i,j-1,k)
     &            +epsd(i,j,k-1)+epsd(i,j-1,k-1))*eps0
            sgm=0.25*(sgmed(i,j,k)+sgmed(i,j-1,k)
     &            +sgmed(i,j,k-1)+sgmed(i,j-1,k-1))
            a=0.5*sgm*dt/eps
            aex(i,j,k)=(1.0-a)/(1.0+a)
            bexy(i,j,k)=dt/eps/(1.0+a)/dy
            bexz(i,j,k)=dt/eps/(1.0+a)/dz

            eps=0.25*(epsd(i,j,k)+epsd(i-1,j,k)
     &            +epsd(i,j,k-1)+epsd(i-1,j,k-1))*eps0
            sgm=0.25*(sgmed(i,j,k)+sgmed(i-1,j,k)
     &            +sgmed(i,j,k-1)+sgmed(i-1,j,k-1))
            a=0.5*sgm*dt/eps
            aey(i,j,k)=(1.0-a)/(1.0+a)
            beyx(i,j,k)=dt/eps/(1.0+a)/dx
            beyz(i,j,k)=dt/eps/(1.0+a)/dz

            eps=0.25*(epsd(i,j,k)+epsd(i-1,j,k)
     &            +epsd(i,j-1,k)+epsd(i-1,j-1,k))*eps0
            sgm=0.25*(sgmed(i,j,k)+sgmed(i-1,j,k)
     &            +sgmed(i,j-1,k)+sgmed(i-1,j-1,k))
            a=0.5*sgm*dt/eps
            aez(i,j,k)=(1.0-a)/(1.0+a)
            bezx(i,j,k)=dt/eps/(1.0+a)/dx
            bezy(i,j,k)=dt/eps/(1.0+a)/dy

            mu=0.5*(mud(i,j,k)+mud(i-1,j,k))*mu0
            sgmm=0.5*(sgmmd(i,j,k)+sgmmd(i-1,j,k))
            a=0.5*sgmm*dt/mu
            amx(i,j,k)=(1.0-a)/(1.0+a)
            bmxy(i,j,k)=dt/mu/(1.0+a)/dy
            bmxz(i,j,k)=dt/mu/(1.0+a)/dz

            mu=0.5*(mud(i,j,k)+mud(i,j-1,k))*mu0
            sgmm=0.5*(sgmmd(i,j,k)+sgmmd(i,j-1,k))
            a=0.5*sgmm*dt/mu
            amy(i,j,k)=(1.0-a)/(1.0+a)
            bmyz(i,j,k)=dt/mu/(1.0+a)/dz
            bmyx(i,j,k)=dt/mu/(1.0+a)/dx

            mu=0.5*(mud(i,j,k)+mud(i,j,k-1))*mu0
            sgmm=0.5*(sgmmd(i,j,k)+sgmmd(i,j,k-1))
            a=0.5*sgmm*dt/mu
            amz(i,j,k)=(1.0-a)/(1.0+a)
            bmzx(i,j,k)=dt/mu/(1.0+a)/dx
            bmzy(i,j,k)=dt/mu/(1.0+a)/dy
          end do
        end do
      end do
      end subroutine setup

!-----------------------------------------------------------------------
!　　直方体の媒質定数
!-----------------------------------------------------------------------
      subroutine epsmu()
      use fdtd_variable

      do k=kc-lz2, kc+lz2-1
         do j=jc-ly2, jc+ly2-1
            do i=ic-lx2, ic+lx2-1
               epsd(i,j,k)=epsr
               mud(i,j,k)=1.0
               sgmed(i,j,k)=0.0
               sgmmd(i,j,k)=0.0
            end do
         end do
      end do
      end subroutine epsmu

!-----------------------------------------------------------------------
!     電界の計算
!-----------------------------------------------------------------------
      subroutine e_cal()
      use fdtd_variable
      integer::i,j,k
!Ex
      do k=1,nz-1
         do j=1,ny-1
            do i=0,nx-1
               ex(i,j,k)=aex(i,j,k)*ex(i,j,k)+bexy(i,j,k)*(hz(i,j,k)
     &             -hz(i,j-1,k))-bexz(i,j,k)*(hy(i,j,k)-hy(i,j,k-1))
            end do
         end do
      end do
!Ey
      do k=1,nz-1
         do j=0,ny-1
            do i=1,nx-1
               ey(i,j,k)=aey(i,j,k)*ey(i,j,k)+beyz(i,j,k)*(hx(i,j,k)
     &             -hx(i,j,k-1))-beyx(i,j,k)*(hz(i,j,k)-hz(i-1,j,k))
            end do
         end do
      end do
!Ez
      do k=0,nz-1
         do j=1,ny-1
            do i=1,nx-1
               ez(i,j,k)=aez(i,j,k)*ez(i,j,k)+bezx(i,j,k)*(hy(i,j,k)
     &             -hy(i-1,j,k))-bezy(i,j,k)*(hx(i,j,k)-hx(i,j-1,k))
            end do
         end do
      end do
      end subroutine e_cal
!-----------------------------------------------------------------------
!     磁界の計算
!-----------------------------------------------------------------------
      subroutine h_cal()
      use fdtd_variable
      integer::i,j,k
!Hx
      do k=0,nz-1
         do j=0,ny-1
            do i=1,nx-1
               hx(i,j,k)=amx(i,j,k)*hx(i,j,k)-bmxy(i,j,k)*(ez(i,j+1,k)
     &                   -ez(i,j,k))+bmxz(i,j,k)*(ey(i,j,k+1)-ey(i,j,k))
            end do
         end do
      end do
!Hy
      do k=0,nz-1
         do j=1,ny-1
            do i=0,nx-1
               hy(i,j,k)=amy(i,j,k)*hy(i,j,k)-bmyz(i,j,k)*(ex(i,j,k+1)
     &                   -ex(i,j,k))+bmyx(i,j,k)*(ez(i+1,j,k)-ez(i,j,k))
            end do
         end do
      end do
!Hz
      do k=1,nz-1
         do j=0,ny-1
            do i=0,nx-1
               hz(i,j,k)=amz(i,j,k)*hz(i,j,k)-bmzx(i,j,k)*(ey(i+1,j,k)
     &                   -ey(i,j,k))+bmzy(i,j,k)*(ex(i,j+1,k)-ex(i,j,k))
            end do
         end do
      end do
      end subroutine h_cal


       SUBROUTINE W3FA06 (P,T,RH,T5,TLI)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FA06         CALCULATION OF THE LIFTED INDEX
C   AUTHOR: HOWCROFT,J.      ORG: W/NMC342   DATE: 78-07-01
C
C ABSTRACT: GIVEN THE PRESSURE,TEMPERATURE AND RELATIVE HUMIDITY OF
C   AN AIR PARCEL AT SOME POINT IN THE ATMOSPHERE, CALCULATE THE
C   LIFTED INDEX OF THE PARCEL. LIFTED INDEX IS DEFINED AS THE
C   TEMPERATURE DIFFERENCE BETWEEN THE OBSERVED 500MB TEMPERATURE AND
C   THE SUPPOSED TEMPERATURE THAT THE PARCEL WOULD OBTAIN IF IT WERE
C   LIFTED DRY-ADIABATICALLY TO SATURATION AND THEN MOVED MOIST
C   ADIABATICALLY TO THE 500MB LEVEL.
C
C PROGRAM HISTORY LOG:
C   78-07-01  J.HOWCROFT
C   89-01-24  R.E.JONES   CHANGE TO MICROSOFT FORTRAN 4.10
C   90-06-08  R.E.JONES   CHANGE TO SUN FORTRAN 1.3
C   91-03-29  R.E.JONES   CONVERT TO SiliconGraphics FORTRAN
C   93-03-29  R.E.JONES   ADD SAVE STATEMENT
C   95-09-25  R.E.JONES   PUT IN W3 LIBRARY ON CRAY
C
C USAGE: CALL W3FA06(P,T,RH,T5,TLI)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     P      ARG LIST   PARCEL PRESSURE IN MILLIBARS
C     T      ARG LIST   PARCEL TEMPERATAURE IN DEGREES CELSIUS
C     RH     ARG LIST   PARCEL RELATIVE HUMIDITY IN PERCENT
C     T5     ARG LIST   TEMPERATURE AT THE 500MB LEVEL IN DEG. CELSIUS
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     TLI    ARG LIST  LIFTED INDEX IN DEGREES CELSIUS
C                      TLI = 9.9999  ITERATION DIVERGES;
C                      RETURN TO USER PROGRAM
C
C   SUBPROGRAMS CALLED:
C     NAMES                                                   LIBRARY
C     ------------------------------------------------------- --------
C     EXP    ABS    SIGN                                      SYSLIB
C     W3FA01                                                  W3LIB
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY C916/256, J916/2048
C
C$$$
C
       SAVE
C
       DATA            EPS   /0.5/
       DATA            KOUT  /  6/
C
  300  FORMAT ('  *** ITERATION NOT CONVERGING IN W3FA06 ***')
  350  FORMAT ('      INPUT PARAMS ARE:',4F15.8,/
     1         '      CALCULATIONS ARE',7E15.8)
C
       POTEMP(T,P) = (T+273.16)*((1000./P)**0.2857)
C
       EEP(T,P,ES) = EXP((596.73-0.601*T)*((0.622*ES)/(P-ES))
     1                / (0.24*(T+273.16)))
C
       UNPOT(TE,P) = (((P/1000.)**0.2857)*TE)-273.16
C
       VAPRES(T)   = 6.11*EXP(17.2694*T/(T+237.3))
C
       CALL W3FA01 (P,T,RH,TD,PLCL,TLCL)
       IF (PLCL .GT. 500.)  GO TO 30
       IF (PLCL .LT. 500.)  GO TO 20
         TLI = T5 - TLCL
         GO TO 80
   20  CONTINUE
C        LCL IS ABOVE THE 500MB LVL
         TLI = T5 - UNPOT((POTEMP(TLCL,PLCL)),500.)
         GO TO 80
   30  CONTINUE
C        USE STACKPOLE ALGORITHM (JAM VOL 6/1967 PP 464-7) TO FIND TGES
C        SO THAT (TGES,500) IS ON SAME MOIST ADIABAT AS (TLCL,PLCL).
         ES     = VAPRES(TLCL)
         THD    = POTEMP(TLCL,(PLCL-ES))
         THETA  = THD * EEP(TLCL,PLCL,ES)
C          THETA IS THE PSEUDO-EQUIV POTENTIAL TEMP THRU (PLCL,TLCL).
C      NOW FIND TEMP WHERE THETA INTERSECTS 500MB SFC.
C          INITIALIZE FOR STACKPOLIAN ITERATION
         TGES = T5
         DTT  = 10.
         PIIN = 1./(0.5**0.2857)
         A    = 0.
         ISTP = 0
C          START ITERATION.
   40  CONTINUE
         ISTP = ISTP + 1
         IF (ISTP .GT. 200)  GO TO 50
         SVA = VAPRES(TGES)
         AX  = A
         A   = (TGES+273.16)*PIIN * EEP(TGES,500.,SVA) - THETA
         IF (ABS(A) .LT. EPS)  GO TO 70
         DTT = DTT * 0.5
         IF (A*AX.LT.0.0)  DTT = -DTT
         TP   = TGES + DTT
         SVA  = VAPRES(TP)
         AP   = (TP+273.16)*PIIN * EEP(TP,500.,SVA) - THETA
         IF (ABS(AP) .LT. EPS)  GO TO 60
C          FIND NEXT ESTIMATE, DTT IS ADJUSTMENT FROM OLD TO NEW TGES.
           DTT  = A*DTT/(A-AP)
           IF (ABS(DTT).LT.0.01)  DTT = SIGN(0.01,DTT)
           TGES = TGES + DTT
           IF (TGES .GT. 50)  TGES = 50.
           GO TO 40
C
   50  CONTINUE
C        DISASTER SECTION
         WRITE (KOUT,300)
         WRITE (KOUT,350) P,T,RH,T5,THETA,AX,A,AP,TGES,TP,SVA
           TLI = 9.9999
           GO TO 80
   60  CONTINUE
         TGES = TP
   70  CONTINUE
         TLI  = T5 - TGES
   80  CONTINUE
       RETURN
       END


 SUBROUTINE corr20_a (visc,t,lb3,ethm,gausv,is,np,curve,props, &
                      propv,gm,km,stres,pstr,dtime,ierr)

   !
   ! plastic correction algorithm for UPDATED LAGRANGIAN FORMULATION (actual configuration)
   ! linear strain triangle (based on GARCIA GARINO thesis)
   !
   USE mat_dba, ONLY : inte_cr
   IMPLICIT NONE
   LOGICAL, INTENT(IN) :: visc     ! TRUE if viscoplastic analysis
   REAL (kind=8), INTENT(IN) :: dtime,    & !time step size
                                t(2,2),   & !in-plane Deformation gradient
                                lb3,      & !Lambda in out of plane direction
                                ethm,     & !thermal strain trace * 2
                                props(5), & !plastic properties (hardening)
                                propv(3), & !viscoplastic properties
                                gm,km       !elastic properties (km = 3K)
   INTEGER(kind=4), INTENT(IN) :: is,       & !isotropic hardening model
                                  np          !number of points defining curve (is = 5)
   REAL (kind=8), INTENT(IN OUT) :: gausv(6), & !Internal variables
                                    stres(4)    !Kirchhoff stresses
   REAL (kind=8), INTENT(OUT)    :: pstr(5)     !plastic strain tensor
   INTEGER(kind=4), INTENT(OUT)  :: ierr     !error flag
   REAL (kind=8), POINTER :: curve(:,:)     !(3,np) yield stress curve

   ! local variables
   INTEGER (kind=4) :: i
   REAL (kind=8)    :: efps0,reps0,se,devs(4),pres,trac,be(4),bo(4),fi(5), &
                       an(4),de,m2,m3,ftria,yield,aprim
   REAL (kind=8), PARAMETER :: toler = 1d-4,             &
                               r23 = 0.816496580927726d0

   INTERFACE
     INCLUDE 'visco20.h'
   END INTERFACE

   efps0 = gausv(6) !initial (old) Equivalent Plastic Strain
   reps0 = gausv(5) !initial (old) equivalent plastic strain rate (viscoplastic  only)
   !     setup initial yield FUNCTION radius
   IF( is == 5 ) THEN        !for points defined yield value
     i = 1   !begin at first interval
     yield = inte_cr (curve,np,efps0,i)    !s_y
     aprim = curve(3,i)                    !A'
   ELSE
     CALL isoha14(is,yield,aprim,efps0,props(1),props(2),props(3),props(4))  !compute s_y and A'
   END IF
   m2 = gm*2d0      !2*Mu to compute stresses
   m3 = gm*3d0      !3*Mu to use as auxiliar

   !inverse relative deformation gradient
   fi(1:2) = t(:,1)
   fi(3:4) = t(:,2)
   fi(  5) = lb3
   !compute elastic trial Finger tensor  (f^-T * b_old * f^-1)
   bo    = gausv(1:4)   !previous elastic Finger tensor
   be(1) = (fi(1)*bo(1)+fi(2)*bo(3))*fi(1) + (fi(1)*bo(3)+fi(2)*bo(2))*fi(2)
   be(2) = (fi(3)*bo(1)+fi(4)*bo(3))*fi(3) + (fi(3)*bo(3)+fi(4)*bo(2))*fi(4)
   be(3) = (fi(1)*bo(1)+fi(2)*bo(3))*fi(3) + (fi(1)*bo(3)+fi(2)*bo(2))*fi(4)
   be(4) =  fi(5)*bo(4)*fi(5)
   !elastic predictor state
   trac    = (be(1)+be(2)+be(4))/3d0 !Finger tensor trace / 3d0
   pres    =  km*(1d0-trac-ethm)/2d0 !p = 3 K * 1/3 tr(e_almansi)
   devs(1) = be(1)-trac  !deviatoric Finger tensor
   devs(2) = be(2)-trac  !
   devs(3) = be(3)       !
   devs(4) = be(4)-trac  !
   devs    = -gm*devs      !deviatoric Kirchhoff stresses
   de = 0d0                !initializes consistency parameter
   se = SQRT(devs(1)*devs(1)+devs(2)*devs(2)+devs(4)*devs(4)+ & !vMstress
         2d0*devs(3)*devs(3))                                   !
   ftria = se - r23*yield    !f_trial
   IF( ftria/se > toler )THEN  !plastic
     !radial return (no iteration) in terms of A' at eps old
     de = 1.5d0*ftria/(aprim+m3) !increment in eps
     IF( visc ) & !iteration to convergence in viscoplastic
       CALL visco20(se,m2,is,np,curve,props,propv,gausv(5:6),dtime,de,ierr)
       !de = (1d0/m2)*mises / (1d0 + (1d0/m3)*(aprim+propv(1)/dtime))
   END IF
   ! Updates internal variables
   IF( de > 0d0 ) THEN
     an   = devs / se        !plastic flow direction tensor
     devs = devs - m2*de*an  !dev Kirchhoff stress
     be   = be + 2d0*de*an   !elastic Finger tensor
     gausv(6) = efps0 + r23*de !efective plast strain
     IF( visc ) gausv(5) = r23*de / dtime !effective plast strain rate
   END IF
   !update internal variables
   gausv(1:4) = be(1:4)
   !Actualized Kirchhoff stress tensor
   stres(1) = pres + devs(1)  !tau(1,1)
   stres(2) = pres + devs(2)  !tau(2,2)
   stres(3) =        devs(3)  !tau(1,2) = tau(2,1)
   stres(4) = pres + devs(4)  !tau(3,3)

   pstr(1:4) = -de*an        !plastic deviatoric strain tensor
   pstr(5)   = pres/(km/3d0) !elastic strain trace
 END SUBROUTINE corr20_a


  !! Merge all the local data
  CALL MergeMatrixLocalBlocks(this, LMAT)

  ALLOCATE(column_sigma_contribution(LMAT%columns))
  column_sigma_contribution = 0
  DO outer_counter = 1, LMAT%columns
     DO inner_counter = LMAT%outer_index(outer_counter), &
          & LMAT%outer_index(outer_counter+1)-1
        column_sigma_contribution(outer_counter) = &
             & column_sigma_contribution(outer_counter) + &
             & ABS(LMAT%values(inner_counter+1))
     END DO
  END DO
  CALL MPI_Allreduce(MPI_IN_PLACE,column_sigma_contribution,&
       & LMAT%columns,MPINTREAL,MPI_SUM, &
       & this%process_grid%column_comm, ierr)
  CALL MPI_Allreduce(MAXVAL(column_sigma_contribution),sigma_value,1, &
       & MPINTREAL,MPI_MAX, this%process_grid%row_comm, ierr)
  sigma_value = 1.0d+0/(sigma_value**2)

  DEALLOCATE(column_sigma_contribution)
  CALL DestructMatrix(LMAT)


! eos_hs.f90
! Equation of State for hard sphere potential
PROGRAM eos_hs

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! This program uses the function derived by H Hansen-Goos, J Chem Phys, 16, 164506 (2016)
  ! which is claimed to be an excellent fit to simulation data over the whole fluid density range
  ! That paper also gives references to previous approximate equations of state (such as the
  ! venerable Carnahan-Starling equation).

  USE, INTRINSIC :: iso_fortran_env, ONLY : input_unit, output_unit, error_unit, iostat_end, iostat_eor

  IMPLICIT NONE

  REAL            :: density, p, z, eta
  INTEGER         :: ioerr
  REAL, PARAMETER :: pi = 4.0*ATAN(1.0)

  ! The coefficients appear in Table I of Hansen-Goos (2016)
  REAL,                 PARAMETER :: a = 8.0
  REAL, DIMENSION(0:7), PARAMETER :: b = [ 9.0,     -19.0,      47.0/3.0, -2.635232, &
       &                                  -1.265575,  0.041212, 0.248245, -0.096495 ]

  NAMELIST /nml/ density

  ! Set sensible default values
  density = 0.75

  READ ( unit=input_unit, nml=nml, iostat=ioerr )
  IF ( ioerr /= 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'Error reading namelist nml from standard input', ioerr
     IF ( ioerr == iostat_eor ) WRITE ( unit=error_unit, fmt='(a)') 'End of record'
     IF ( ioerr == iostat_end ) WRITE ( unit=error_unit, fmt='(a)') 'End of file'
     STOP 'Error in eos_hs'
  END IF

  eta = pi * density / 6.0 ! Packing fraction
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Density rho',          density
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Packing fraction eta', eta

  ! Equation (6) of Hansen-Goos (2016)
  z = a * LOG ( 1.0-eta ) / eta
  z = z + polynomial ( b, eta ) / ( 1.0 - eta ) ** 3 ! Compressibility factor P/(rho*kT)
  p = z * density                                    ! Pressure P / kT
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Pressure P',                            p
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Compressibility factor Z = P/(rho*kT)', z

CONTAINS

  FUNCTION polynomial ( c, x ) RESULT ( f )
    REAL, DIMENSION(:), INTENT(in) :: c ! coefficients of x**0, x**1, x**2 etc
    REAL,               INTENT(in) :: x ! argument
    REAL                           :: f ! result

    INTEGER :: i

    f = 0.0
    DO i = SIZE(c), 1, -1
       f = f * x + c(i)
    END DO

  END FUNCTION polynomial

END PROGRAM eos_hs


!------------------------------------------------------------------------------!
    MODULE kinds
!------------------------------------------------------------------------------!
      INTEGER, PARAMETER :: DP = selected_real_kind(14,200)
    END MODULE kinds


! Read the input binary-image
! Remove the improper solid points for the intended method of simulation
! Export the binary-image formatted output file
! Scale up and export the scale-up binary-image
! Scale keep the ratio of cell (area) while the 1st version keep the ratio of node
Program D2Qn_image_processing_2
implicit none
!=======================================================================
!       Physical space configurations
!=======================================================================
integer, parameter :: Ny=1500
integer, parameter :: Nx=3000

integer, parameter :: ghostLayer=1 !number of ghost layer at each boundary
integer, parameter :: Nxmin=1-ghostLayer,Nxmax=Nx+ghostLayer
integer, parameter :: Nymin=1-ghostLayer,Nymax=Ny+ghostLayer
integer, parameter :: Nxtotal=Nxmax-Nxmin+1
integer, parameter :: Nytotal=Nymax-Nymin+1
integer, parameter :: Ntotal=Nxtotal*Nytotal

integer, parameter:: fluid = 0, solid = 1, inlet = 30, outlet = 31, ghost=4
integer, parameter:: wallNE = 20, wallN = 21, wallNW = 22, wallW = 23
integer, parameter:: wallSW = 24, wallS = 25, wallSE = 26, wallE = 27
integer, DIMENSION(:,:), ALLOCATABLE :: array2D,array2D_2x,array2D_3x,array2D_4x
integer, DIMENSION(:), ALLOCATABLE :: image

integer :: i,j,k    !index variable for physical space
integer :: l,m,n  !index variable for molecular velocity space
integer :: mod_x,mod_y
integer	:: icount,icount2

character(LEN=30)::input_name,output_name

ALLOCATE(array2D(Nx,Ny))
ALLOCATE(image(Ntotal))
ALLOCATE(array2D_2x((Nx-1)*2+1,(Ny-1)*2+1))
ALLOCATE(array2D_3x((Nx-1)*3+1,(Ny-1)*3+1))
ALLOCATE(array2D_4x((Nx-1)*4+1,(Ny-1)*4+1))

!=======================================================================
!           Read from tomography file
!=======================================================================
input_name='var2circle.dat'
output_name='Processed_'//TRIM(ADJUSTL(input_name))
Open(200,file=input_name,status='OLD')
	Do j=1,Ny
		read(200, *) (array2D(i,j), i=1,Nx)
	Enddo
Close(200)

icount=0
Do j=1, Ny
	Do i=1,Nx
		If (array2D(i,j)==0) then
			array2D(i,j)=fluid
			icount=icount+1
		End if
		If (array2D(i,j)==1) then
			array2D(i,j)=solid
		End if
		l=(i+ghostLayer)+(j+ghostLayer-1)*Nxtotal
		image(l)= array2D(i,j)
	Enddo
Enddo
open(10,file='Test.dat', STATUS='REPLACE')
	Write(10,*) 'Porosity of the original binary image (node-base): ', Dble(icount)/Nx/Ny

icount=0
	 Do j=1,(Ny-1)
		Do i=1, (Nx-1)
			If ((array2D(i,j)==fluid).OR.(array2D(i+1,j)==fluid).OR.&
			& (array2D(i,j+1)==fluid).OR.(array2D(i+1,j+1)==fluid)) then
 				icount=icount+1
			Endif
		Enddo
	 Enddo
Write(10,*) 'Porosity of the original binary image (cell-base): ', Dble(icount)/((Nx-1))/((Ny-1))
Write(10,*)
!=======================================================================
!       Remove improper solid nodes
!	No 1-layer thin of fluid in the pore
!	No 1-layer thin of solid (include the diagonal)in the rock
!=======================================================================
!------------------------------------------------------------------------
!           Fill ghosts layer by ghost
!------------------------------------------------------------------------
Do j=Nymin,Nymax
    Do i=Nxmin,Nxmax
        If ((i<1).OR.(i>Nx).OR.(j<1).OR.(j>Ny)) then
            l=(i+ghostLayer)+(j+ghostLayer-1)*Nxtotal
            image(l) = ghost
        End if
    Enddo
Enddo
!------------------------------------------------------------------------
!           Drill to obtain at least two layer of fluid in pore
!			Convert 1-layer thin of solid to fluid
!------------------------------------------------------------------------
Do j=1,Ny
    Do i=1,Nx
		l=(i+ghostLayer)+(j+ghostLayer-1)*Nxtotal

        If (image(l)==solid) then
			If(((image(l-1)/=solid).AND.(image(l+1)/=solid)).OR.((image(l-Nxtotal)/=solid).AND.(image(l+Nxtotal)/=solid))) then
				image(l)=fluid
            End if
        End if

        If (image(l)==fluid) then
			If(((image(l-1)/=fluid).AND.(image(l+1)/=fluid)).OR.((image(l-Nxtotal)/=fluid).AND.(image(l+Nxtotal)/=fluid))) then
				If (j==Ny) then
					If (i==Nx) then
						image(l-1)=fluid
						image(l-Nxtotal)=fluid
						image(l-1-Nxtotal)=fluid
					else
						image(l+1)=fluid
						image(l-Nxtotal)=fluid
						image(l+1-Nxtotal)=fluid
					End	If
				else
					If (i==Nx) then
						image(l-1)=fluid
						image(l+Nxtotal)=fluid
						image(l-1+Nxtotal)=fluid
					else
						image(l+1)=fluid
						image(l+Nxtotal)=fluid
						image(l+1+Nxtotal)=fluid
					End	If
				End if
            End if
        End if

		If((image(l)==solid).AND.(image(l+1+Nxtotal)==solid).AND.(image(l-1-Nxtotal)==solid) &
		& .AND.(image(l-1+Nxtotal)==fluid).AND.(image(l+1-Nxtotal)==fluid)) then
			image(l)=fluid
			image(l-1)=fluid
			image(l+1)=fluid
			image(l-Nxtotal)=fluid
			image(l+Nxtotal)=fluid
		End If

		If((image(l)==solid).AND.(image(l-1+Nxtotal)==solid).AND.(image(l+1-Nxtotal)==solid) &
		& .AND.(image(l-1-Nxtotal)==fluid).AND.(image(l+1+Nxtotal)==fluid)) then
			image(l)=fluid
			image(l-1)=fluid
			image(l+1)=fluid
			image(l-Nxtotal)=fluid
			image(l+Nxtotal)=fluid
		End If

    Enddo
Enddo

Do j=1,Ny
    Do i=1,Nx
		l=(i+ghostLayer)+(j+ghostLayer-1)*Nxtotal

        If (image(l)==solid) then
			If(((image(l-1)/=solid).AND.(image(l+1)/=solid)).OR.((image(l-Nxtotal)/=solid).AND.(image(l+Nxtotal)/=solid))) then
				image(l)=fluid
            End if
        End if

        If (image(l)==fluid) then
			If(((image(l-1)/=fluid).AND.(image(l+1)/=fluid)).OR.((image(l-Nxtotal)/=fluid).AND.(image(l+Nxtotal)/=fluid))) then
				If (j==Ny) then
					If (i==Nx) then
						image(l-1)=fluid
						image(l-Nxtotal)=fluid
						image(l-1-Nxtotal)=fluid
					else
						image(l+1)=fluid
						image(l-Nxtotal)=fluid
						image(l+1-Nxtotal)=fluid
					End	If
				else
					If (i==Nx) then
						image(l-1)=fluid
						image(l+Nxtotal)=fluid
						image(l-1+Nxtotal)=fluid
					else
						image(l+1)=fluid
						image(l+Nxtotal)=fluid
						image(l+1+Nxtotal)=fluid
					End	If
				End if
            End if
        End if

		If((image(l)==solid).AND.(image(l+1+Nxtotal)==solid).AND.(image(l-1-Nxtotal)==solid) &
		& .AND.(image(l-1+Nxtotal)==fluid).AND.(image(l+1-Nxtotal)==fluid)) then
			image(l)=fluid
			image(l-1)=fluid
			image(l+1)=fluid
			image(l-Nxtotal)=fluid
			image(l+Nxtotal)=fluid
		End If

		If((image(l)==solid).AND.(image(l-1+Nxtotal)==solid).AND.(image(l+1-Nxtotal)==solid) &
		& .AND.(image(l-1-Nxtotal)==fluid).AND.(image(l+1+Nxtotal)==fluid)) then
			image(l)=fluid
			image(l-1)=fluid
			image(l+1)=fluid
			image(l-Nxtotal)=fluid
			image(l+Nxtotal)=fluid
		End If

    Enddo
Enddo

Do j=1,Ny
    Do i=1,Nx
		l=(i+ghostLayer)+(j+ghostLayer-1)*Nxtotal

        If (image(l)==solid) then
			If(((image(l-1)/=solid).AND.(image(l+1)/=solid)).OR.((image(l-Nxtotal)/=solid).AND.(image(l+Nxtotal)/=solid))) then
				image(l)=fluid
            End if
        End if

        If (image(l)==fluid) then
			If(((image(l-1)/=fluid).AND.(image(l+1)/=fluid)).OR.((image(l-Nxtotal)/=fluid).AND.(image(l+Nxtotal)/=fluid))) then
				If (j==Ny) then
					If (i==Nx) then
						image(l-1)=fluid
						image(l-Nxtotal)=fluid
						image(l-1-Nxtotal)=fluid
					else
						image(l+1)=fluid
						image(l-Nxtotal)=fluid
						image(l+1-Nxtotal)=fluid
					End	If
				else
					If (i==Nx) then
						image(l-1)=fluid
						image(l+Nxtotal)=fluid
						image(l-1+Nxtotal)=fluid
					else
						image(l+1)=fluid
						image(l+Nxtotal)=fluid
						image(l+1+Nxtotal)=fluid
					End	If
				End if
            End if
        End if

		If((image(l)==solid).AND.(image(l+1+Nxtotal)==solid).AND.(image(l-1-Nxtotal)==solid) &
		& .AND.(image(l-1+Nxtotal)==fluid).AND.(image(l+1-Nxtotal)==fluid)) then
			image(l)=fluid
			image(l-1)=fluid
			image(l+1)=fluid
			image(l-Nxtotal)=fluid
			image(l+Nxtotal)=fluid
		End If

		If((image(l)==solid).AND.(image(l-1+Nxtotal)==solid).AND.(image(l+1-Nxtotal)==solid) &
		& .AND.(image(l-1-Nxtotal)==fluid).AND.(image(l+1+Nxtotal)==fluid)) then
			image(l)=fluid
			image(l-1)=fluid
			image(l+1)=fluid
			image(l-Nxtotal)=fluid
			image(l+Nxtotal)=fluid
		End If

    Enddo
Enddo

Do j=1,Ny
    Do i=1,Nx
		l=(i+ghostLayer)+(j+ghostLayer-1)*Nxtotal

        If (image(l)==solid) then
			If(((image(l-1)/=solid).AND.(image(l+1)/=solid)).OR.((image(l-Nxtotal)/=solid).AND.(image(l+Nxtotal)/=solid))) then
				image(l)=fluid
            End if
        End if

        If (image(l)==fluid) then
			If(((image(l-1)/=fluid).AND.(image(l+1)/=fluid)).OR.((image(l-Nxtotal)/=fluid).AND.(image(l+Nxtotal)/=fluid))) then
				If (j==Ny) then
					If (i==Nx) then
						image(l-1)=fluid
						image(l-Nxtotal)=fluid
						image(l-1-Nxtotal)=fluid
					else
						image(l+1)=fluid
						image(l-Nxtotal)=fluid
						image(l+1-Nxtotal)=fluid
					End	If
				else
					If (i==Nx) then
						image(l-1)=fluid
						image(l+Nxtotal)=fluid
						image(l-1+Nxtotal)=fluid
					else
						image(l+1)=fluid
						image(l+Nxtotal)=fluid
						image(l+1+Nxtotal)=fluid
					End	If
				End if
            End if
        End if

		If((image(l)==solid).AND.(image(l+1+Nxtotal)==solid).AND.(image(l-1-Nxtotal)==solid) &
		& .AND.(image(l-1+Nxtotal)==fluid).AND.(image(l+1-Nxtotal)==fluid)) then
			image(l)=fluid
			image(l-1)=fluid
			image(l+1)=fluid
			image(l-Nxtotal)=fluid
			image(l+Nxtotal)=fluid
		End If

		If((image(l)==solid).AND.(image(l-1+Nxtotal)==solid).AND.(image(l+1-Nxtotal)==solid) &
		& .AND.(image(l-1-Nxtotal)==fluid).AND.(image(l+1+Nxtotal)==fluid)) then
			image(l)=fluid
			image(l-1)=fluid
			image(l+1)=fluid
			image(l-Nxtotal)=fluid
			image(l+Nxtotal)=fluid
		End If

    Enddo
Enddo
!=======================================================================
!    Print out the binary image
!=======================================================================
!------------------------------------------------------------------------
!           Map of solid part
!------------------------------------------------------------------------
    open(11,file='Map.dat',STATUS="REPLACE")
        write(11,*) 'Map'
        Do j=Nymax,Nymin,-1
			Do i=Nxmin,Nxmax
				l=(i+ghostLayer)+(j+ghostLayer-1)*Nxtotal
				if (image(l)==fluid) then
					write(11,"(A)",Advance='no') "   "
				else
					write(11,"(I2,A)",Advance='no') image(l)," "
				end if
			End do
			write(11,*)
        Enddo
    close(11)
!------------------------------------------------------------------------
!           Binary image
!------------------------------------------------------------------------
icount=0
Do j=1, Ny
	Do i=1,Nx
		l=(i+ghostLayer)+(j+ghostLayer-1)*Nxtotal
		If (image(l)==fluid) then
			array2D(i,j)=0
			icount=icount+1
		End if
		If (image(l)==solid) then
			array2D(i,j)=1
		End if
	Enddo
Enddo
Write(10,*) 'Number-of-node base: '
Write(10,*) 'Porosity of the processed 1x binary image: ', Dble(icount)/Nx/Ny

! Open(200,file=output_name,status='New')
	! Do j=1,Ny
		! write(200, *) (array2D(i,j), i=1,Nx)
	! Enddo
! Close(200)

 Open(200,file=output_name,STATUS="REPLACE")
	 Do j=1,Ny
		Do i=1, Nx
			write(200, "(I2)",Advance='no') array2D(i,j)
		Enddo
		write(200,*)
	 Enddo
 Close(200)
!=======================================================================
!   Scale-up by 2 times the binary image
!=======================================================================
array2D_2x=ghost
!------------------------------------------------------------------------
!           1x-based image
!------------------------------------------------------------------------
	 Do j=1,Ny
		Do i=1, Nx
			array2D_2x(1+(i-1)*2,1+(j-1)*2)=array2D(i,j)
		Enddo
	 Enddo
!------------------------------------------------------------------------
!           Filled points between based points
!------------------------------------------------------------------------
icount=0
	 Do j=1,(Ny-1)*2+1
		Do i=1, (Nx-1)*2+1
			l=1+(i-1)/2
			m=1+(j-1)/2
			mod_x=mod(i-1,2)
			mod_y=mod(j-1,2)
			If ((mod_x/=0).AND.(mod_y==0)) then
				If ((array2D(l,m)==solid).AND.(array2D(l+1,m)==solid)) then
					array2D_2x(i,j)=solid
				else
					array2D_2x(i,j)=fluid
				end if
			End if

			If ((mod_x==0).AND.(mod_y/=0)) then
				If ((array2D(l,m)==solid).AND.(array2D(l,m+1)==solid)) then
					array2D_2x(i,j)=solid
				else
					array2D_2x(i,j)=fluid
				end if
			End if

			If ((mod_x/=0).AND.(mod_y/=0).AND.(mod_x==mod_y)) then
				If (((array2D(l,m)==solid).AND.(array2D(l+1,m+1)==solid))&
				&.AND.& !1st and 2nd version switch by AND/OR
				& ((array2D(l,m+1)==solid).AND.(array2D(l+1,m)==solid))) then
					array2D_2x(i,j)=solid
				else
					array2D_2x(i,j)=fluid
				end if
			End if

			If (array2D_2x(i,j)==fluid) icount=icount+1
		Enddo
	 Enddo

Write(10,*) 'Porosity of the processed 2x binary image: ', Dble(icount)/((Nx-1)*2+1)/((Ny-1)*2+1)
!------------------------------------------------------------------------
!           Map of solid part
!------------------------------------------------------------------------
    open(11,file='Map_2x.dat',STATUS="REPLACE")
        write(11,*) 'Map'
        Do j=(Ny-1)*2+1,1,-1
			Do i=1,(Nx-1)*2+1
				if (array2D_2x(i,j)==fluid) then
					write(11,"(A)",Advance='no') "   "
				else
					write(11,"(I2,A)",Advance='no') array2D_2x(i,j)," "
				end if
			End do
			write(11,*)
        Enddo
    close(11)
!------------------------------------------------------------------------
!           Binary image
!------------------------------------------------------------------------
output_name='Processed_2x_'//TRIM(ADJUSTL(input_name))
	Open(200,file=output_name,STATUS="REPLACE")
		Do j=1,(Ny-1)*2+1
			Do i=1, (Nx-1)*2+1
				write(200, "(I2)",Advance='no') array2D_2x(i,j)
			Enddo
			write(200,*)
		Enddo
	Close(200)
!=======================================================================
!   Scale-up by 3 times the binary image
!=======================================================================
array2D_3x=ghost
!------------------------------------------------------------------------
!           1x-based image
!------------------------------------------------------------------------
	 Do j=1,Ny
		Do i=1, Nx
			array2D_3x(1+(i-1)*3,1+(j-1)*3)=array2D(i,j)
		Enddo
	 Enddo
!------------------------------------------------------------------------
!           Filled points between based points
!------------------------------------------------------------------------
icount=0
	 ! Do j=1,(Ny-1)*3+1
		! Do i=1, (Nx-1)*3+1
			! l=1+(i-1)/3
			! m=1+(j-1)/3
			! mod_x=mod(i-1,3)
			! mod_y=mod(j-1,3)
			! If ((mod_x/=0).AND.(mod_y==0)) then
				! If ((array2D(l,m)==solid).AND.(array2D(l+1,m)==solid)) then
					! array2D_3x(i,j)=solid
				! else
					! array2D_3x(i,j)=fluid
				! end if
			! End if

			! If ((mod_x==0).AND.(mod_y/=0)) then
				! If ((array2D(l,m)==solid).AND.(array2D(l,m+1)==solid)) then
					! array2D_3x(i,j)=solid
				! else
					! array2D_3x(i,j)=fluid
				! end if
			! End if

			! If ((mod_x/=0).AND.(mod_y/=0).AND.(mod_x==mod_y)) then
				! If ((array2D(l,m)==solid).AND.(array2D(l+1,m+1)==solid)) then
					! array2D_3x(i,j)=solid
				! end if
			! End if
			! If ((mod_x/=0).AND.(mod_y/=0).AND.((mod_x+mod_y)==3)) then
				! If ((array2D(l+1,m)==solid).AND.(array2D(l,m+1)==solid)) then
					! array2D_3x(i,j)=solid
				! end if
			! End if

		! Enddo
	 ! Enddo

	 ! Do j=1,(Ny-1)*3+1
		! Do i=1, (Nx-1)*3+1
			! l=1+(i-1)/3
			! m=1+(j-1)/3
			! mod_x=mod(i-1,3)
			! mod_y=mod(j-1,3)

			! If ((mod_x/=0).AND.(mod_y/=0).AND.(mod_x/=mod_y).AND.((mod_x+mod_y)/=3)) then
				! icount2=0
				! If (array2D_3x(i-1,j)==solid) icount2=icount2+1
				! If (array2D_3x(i+1,j)==solid) icount2=icount2+1
				! If (array2D_3x(i,j-1)==solid) icount2=icount2+1
				! If (array2D_3x(i,j+1)==solid) icount2=icount2+1
				! If (icount2>2) array2D_3x(i,j)=solid
			! End if

		! Enddo
	 ! Enddo

	 ! Do j=1,(Ny-1)*3+1
		! Do i=1, (Nx-1)*3+1
			! l=1+(i-1)/3
			! m=1+(j-1)/3
			! mod_x=mod(i-1,3)
			! mod_y=mod(j-1,3)

			! If (array2D_3x(i,j)==ghost) then
				! If ((array2D_3x(i-1,j)/=fluid).AND.(array2D_3x(i+1,j)/=fluid)&
				! &.OR.&
				! &(array2D_3x(i,j-1)/=fluid).AND.(array2D_3x(i,j+1)/=fluid)) then
					! array2D_3x(i,j)=solid
				! else
					! array2D_3x(i,j)=fluid
				! Endif
			! End if

			! If (array2D_3x(i,j)==fluid) icount=icount+1
		! Enddo
	 ! Enddo

	 Do j=1,(Ny-1)*3+1
		Do i=1, (Nx-1)*3+1
			l=1+(i-1)/3
			m=1+(j-1)/3
			mod_x=mod(i-1,3)
			mod_y=mod(j-1,3)
			If ((mod_x/=0).AND.(mod_y==0)) then
				If ((array2D(l,m)==solid).AND.(array2D(l+1,m)==solid)) then
					array2D_3x(i,j)=solid
				else
					array2D_3x(i,j)=fluid
				end if
			End if

			If ((mod_x==0).AND.(mod_y/=0)) then
				If ((array2D(l,m)==solid).AND.(array2D(l,m+1)==solid)) then
					array2D_3x(i,j)=solid
				else
					array2D_3x(i,j)=fluid
				end if
			End if

			If ((mod_x/=0).AND.(mod_y/=0)) then
				If (((array2D(l,m)==solid).AND.(array2D(l+1,m+1)==solid))&
				&.AND.&
				& ((array2D(l,m+1)==solid).AND.(array2D(l+1,m)==solid))) then
					array2D_3x(i,j)=solid
				else
					array2D_3x(i,j)=fluid
				end if
			End if

			If (array2D_3x(i,j)==fluid) icount=icount+1
		Enddo
	 Enddo

Write(10,*) 'Porosity of the processed 3x binary image: ', Dble(icount)/((Nx-1)*3+1)/((Ny-1)*3+1)
!------------------------------------------------------------------------
!           Map of solid part
!------------------------------------------------------------------------
    open(11,file='Map_3x.dat',STATUS="REPLACE")
        write(11,*) 'Map'
        Do j=(Ny-1)*3+1,1,-1
			Do i=1,(Nx-1)*3+1
				if (array2D_3x(i,j)==fluid) then
					write(11,"(A)",Advance='no') "   "
				else
					write(11,"(I2,A)",Advance='no') array2D_3x(i,j)," "
				end if
			End do
			write(11,*)
        Enddo
    close(11)
!------------------------------------------------------------------------
!           Binary image
!------------------------------------------------------------------------
output_name='Processed_3x_'//TRIM(ADJUSTL(input_name))
	Open(200,file=output_name,STATUS="REPLACE")
		Do j=1,(Ny-1)*3+1
			Do i=1, (Nx-1)*3+1
				write(200, "(I2)",Advance='no') array2D_3x(i,j)
			Enddo
			write(200,*)
		Enddo
	Close(200)
!=======================================================================
!   Scale-up by 4 times the binary image
!=======================================================================
array2D_4x=ghost
!------------------------------------------------------------------------
!           1x-based image
!------------------------------------------------------------------------
	 Do j=1,Ny
		Do i=1, Nx
			array2D_4x(1+(i-1)*4,1+(j-1)*4)=array2D(i,j)
		Enddo
	 Enddo
!------------------------------------------------------------------------
!           Filled points between based points
!------------------------------------------------------------------------
icount=0
	 ! Do j=1,(Ny-1)*4+1
		! Do i=1, (Nx-1)*4+1
			! l=1+(i-1)/4
			! m=1+(j-1)/4
			! mod_x=mod(i-1,4)
			! mod_y=mod(j-1,4)
			! If ((mod_x/=0).AND.(mod_y==0)) then
				! If ((array2D(l,m)==solid).AND.(array2D(l+1,m)==solid)) then
					! array2D_4x(i,j)=solid
				! else
					! array2D_4x(i,j)=fluid
				! end if
			! End if

			! If ((mod_x==0).AND.(mod_y/=0)) then
				! If ((array2D(l,m)==solid).AND.(array2D(l,m+1)==solid)) then
					! array2D_4x(i,j)=solid
				! else
					! array2D_4x(i,j)=fluid
				! end if
			! End if

			! If ((mod_x/=0).AND.(mod_y/=0).AND.(mod_x==mod_y)) then
				! If ((array2D(l,m)==solid).AND.(array2D(l+1,m+1)==solid)) then
					! array2D_4x(i,j)=solid
				! end if
			! End if
			! If ((mod_x/=0).AND.(mod_y/=0).AND.((mod_x+mod_y)==4)) then
				! If ((array2D(l+1,m)==solid).AND.(array2D(l,m+1)==solid)) then
					! array2D_4x(i,j)=solid
				! end if
			! End if

		! Enddo
	 ! Enddo

	 ! Do j=1,(Ny-1)*4+1
		! Do i=1, (Nx-1)*4+1
			! l=1+(i-1)/4
			! m=1+(j-1)/4
			! mod_x=mod(i-1,4)
			! mod_y=mod(j-1,4)

			! If ((mod_x/=0).AND.(mod_y/=0).AND.(mod_x/=mod_y).AND.((mod_x+mod_y)/=4)) then
				! icount2=0
				! If (array2D_4x(i-1,j)==solid) icount2=icount2+1
				! If (array2D_4x(i+1,j)==solid) icount2=icount2+1
				! If (array2D_4x(i,j-1)==solid) icount2=icount2+1
				! If (array2D_4x(i,j+1)==solid) icount2=icount2+1
				! If (icount2>2) array2D_4x(i,j)=solid
			! End if

		! Enddo
	 ! Enddo

	 ! Do j=1,(Ny-1)*4+1
		! Do i=1, (Nx-1)*4+1
			! l=1+(i-1)/4
			! m=1+(j-1)/4
			! mod_x=mod(i-1,4)
			! mod_y=mod(j-1,4)

			! If (array2D_4x(i,j)==ghost) then
				! If ((array2D_4x(i-1,j)/=fluid).AND.(array2D_4x(i+1,j)/=fluid)&
				! &.AND.&  !1st and 2nd version switch by AND/OR
				! &(array2D_4x(i,j-1)/=fluid).AND.(array2D_4x(i,j+1)/=fluid)) then
					! array2D_4x(i,j)=solid
				! else
					! array2D_4x(i,j)=fluid
				! Endif
			! End if

			! If (array2D_4x(i,j)==fluid) icount=icount+1
		! Enddo
	 ! Enddo

	 Do j=1,(Ny-1)*4+1
		Do i=1, (Nx-1)*4+1
			l=1+(i-1)/4
			m=1+(j-1)/4
			mod_x=mod(i-1,4)
			mod_y=mod(j-1,4)
			If ((mod_x/=0).AND.(mod_y==0)) then
				If ((array2D(l,m)==solid).AND.(array2D(l+1,m)==solid)) then
					array2D_4x(i,j)=solid
				else
					array2D_4x(i,j)=fluid
				end if
			End if

			If ((mod_x==0).AND.(mod_y/=0)) then
				If ((array2D(l,m)==solid).AND.(array2D(l,m+1)==solid)) then
					array2D_4x(i,j)=solid
				else
					array2D_4x(i,j)=fluid
				end if
			End if

			If ((mod_x/=0).AND.(mod_y/=0)) then
				If (((array2D(l,m)==solid).AND.(array2D(l+1,m+1)==solid))&
				&.AND.&
				& ((array2D(l,m+1)==solid).AND.(array2D(l+1,m)==solid))) then
					array2D_4x(i,j)=solid
				else
					array2D_4x(i,j)=fluid
				end if
			End if

			If (array2D_4x(i,j)==fluid) icount=icount+1
		Enddo
	 Enddo

Write(10,*) 'Porosity of the processed 4x binary image: ', Dble(icount)/((Nx-1)*4+1)/((Ny-1)*4+1)
!------------------------------------------------------------------------
!           Map of solid part
!------------------------------------------------------------------------
    open(11,file='Map_4x.dat',STATUS="REPLACE")
        write(11,*) 'Map'
        Do j=(Ny-1)*4+1,1,-1
			Do i=1,(Nx-1)*4+1
				if (array2D_4x(i,j)==fluid) then
					write(11,"(A)",Advance='no') "   "
				else
					write(11,"(I2,A)",Advance='no') array2D_4x(i,j)," "
				end if
			End do
			write(11,*)
        Enddo
    close(11)
!------------------------------------------------------------------------
!           Binary image
!------------------------------------------------------------------------
output_name='Processed_4x_'//TRIM(ADJUSTL(input_name))
	Open(200,file=output_name,STATUS="REPLACE")
		Do j=1,(Ny-1)*4+1
			Do i=1, (Nx-1)*4+1
				write(200, "(I2)",Advance='no') array2D_4x(i,j)
			Enddo
			write(200,*)
		Enddo
	Close(200)

!=======================================================================
!   Porosity of the binary image
!=======================================================================
Write(10,*)
Write(10,*) 'Number-of-cell base: '

icount=0
	 Do j=1,(Ny-1)
		Do i=1, (Nx-1)
			If ((array2D(i,j)==fluid).OR.(array2D(i+1,j)==fluid).OR.&
			& (array2D(i,j+1)==fluid).OR.(array2D(i+1,j+1)==fluid)) then
 				icount=icount+1
			Endif
		Enddo
	 Enddo
Write(10,*) 'Porosity of the processed 1x binary image: ', Dble(icount)/((Nx-1))/((Ny-1))

icount=0
	 Do j=1,(Ny-1)*2
		Do i=1, (Nx-1)*2
			If ((array2D_2x(i,j)==fluid).OR.(array2D_2x(i+1,j)==fluid).OR.&
			& (array2D_2x(i,j+1)==fluid).OR.(array2D_2x(i+1,j+1)==fluid)) then
 				icount=icount+1
			Endif
		Enddo
	 Enddo
Write(10,*) 'Porosity of the processed 2x binary image: ', Dble(icount)/((Nx-1)*2)/((Ny-1)*2)

icount=0
	 Do j=1,(Ny-1)*3
		Do i=1, (Nx-1)*3
			If ((array2D_3x(i,j)==fluid).OR.(array2D_3x(i+1,j)==fluid).OR.&
			& (array2D_3x(i,j+1)==fluid).OR.(array2D_3x(i+1,j+1)==fluid)) then
 				icount=icount+1
			Endif
		Enddo
	 Enddo
Write(10,*) 'Porosity of the processed 3x binary image: ', Dble(icount)/((Nx-1)*3)/((Ny-1)*3)

icount=0
	 Do j=1,(Ny-1)*4
		Do i=1, (Nx-1)*4
			If ((array2D_4x(i,j)==fluid).OR.(array2D_4x(i+1,j)==fluid).OR.&
			& (array2D_4x(i,j+1)==fluid).OR.(array2D_4x(i+1,j+1)==fluid)) then
 				icount=icount+1
			Endif
		Enddo
	 Enddo
Write(10,*) 'Porosity of the processed 4x binary image: ', Dble(icount)/((Nx-1)*4)/((Ny-1)*4)

	close (10)

DEALLOCATE(array2D,array2D_2x,array2D_3x,array2D_4x)
End Program D2Qn_image_processing_2


!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE)
!
! PURPOSE:
!
!
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_MOD_GET_RANKS

    USE XMDF

    USE MR_KINDS

    IMPLICIT NONE

    PRIVATE

    PUBLIC :: MR_GET_RANKS
    PUBLIC :: MR_GET_NK
    PUBLIC :: MR_GET_NKS

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

  CONTAINS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_GET_RANKS( MESH_IN_XMDF_ID , NND , NEM , NI , NJ , ERROR , ERRMSG )

    IMPLICIT NONE

    INTEGER            , INTENT(IN ) :: MESH_IN_XMDF_ID

    INTEGER(NDID_KIND) , INTENT(OUT) :: NND
    INTEGER(EMID_KIND) , INTENT(OUT) :: NEM
    INTEGER(EMID_KIND) , INTENT(OUT) :: NI , NJ

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    REAL   (CARD_KIND)               :: CTMP1 , CTMP2

    ERRMSG = ""

  ! GET FROM MESH NND AND NEM
    CALL XF_GET_NUMBER_OF_NODES( MESH_IN_XMDF_ID , NND , ERROR )
    IF( ERROR < 0 ) THEN
      ERRMSG = "Error in getting the number of nodes from mesh"
      RETURN
    END IF
    CALL XF_GET_NUMBER_OF_ELEMENTS( MESH_IN_XMDF_ID , NEM , ERROR )
    IF( ERROR < 0 ) THEN
      ERRMSG = "Error in getting the number of elements from mesh"
      RETURN
    END IF

  ! CALCULATE NI AND NJ
    CTMP1 = 0.25*(NND-1) - NEM
    CTMP2 = SQRT( CTMP1*CTMP1 - NEM )
  ! ASSUME NI IS ALWAYS GREATER THAN OR EQUAL TO NJ
    NI = NINT( CTMP1 + CTMP2 )
    NJ = NINT( CTMP1 - CTMP2 )

  ! CHECK CONSISTENCY
    IF( NND /= ((2*NI+1)*(2*NJ+1)) .AND. NEM /= (NI*NJ) ) THEN
      ERROR = - 1
      ERRMSG = "Inconsistent both number of nodes (NND) and number of elements (NEM) gotten from mesh"
      RETURN
    ELSE IF( NND /= ((2*NI+1)*(2*NJ+1)) ) THEN
      ERROR = - 1
      ERRMSG = "Inconsistent number of nodes (NND) gotten from mesh"
      RETURN
    ELSE IF( NEM /= (NI*NJ) ) THEN
      ERROR = - 1
      ERRMSG = "Inconsistent number of elements (NEM) gotten from mesh"
      RETURN
    END IF

  END SUBROUTINE MR_GET_RANKS

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_GET_NK( MULTI_DSETS_ID , NK , ERROR , ERRMSG )

    IMPLICIT NONE

    INTEGER            , INTENT(IN ) :: MULTI_DSETS_ID

    INTEGER                          :: PROP_ID , GROUP_ID

    INTEGER(KKID_KIND) , INTENT(OUT) :: NK
    INTEGER                          :: NK_ARRAY(1:1)

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    INTEGER                          :: ERROR_DUMMY

    ERRMSG = ""

    CALL XF_OPEN_PROPERTY_GROUP( MULTI_DSETS_ID , PROP_ID , ERROR )
    IF( ERROR < 0 ) THEN
      ERRMSG = "Error in opening /PROPERTIES"
    ELSE

      CALL XF_OPEN_GROUP( PROP_ID , "By Layers" , GROUP_ID , ERROR )
      IF( ERROR < 0 ) THEN
        ERRMSG = "Error in opening /PROPERTIES/By Layers"
      ELSE

        !BLOCK

          CALL XF_READ_PROPERTY_INT( GROUP_ID , "Num Layers" , 1 , NK_ARRAY , ERROR )
          IF( ERROR < 0 ) THEN
            ERRMSG = "Error in getting the number of layers from /PROPERTIES/By Layers"
          ELSE
            NK = NK_ARRAY(1)
          END IF

        !END BLOCK

        CALL XF_CLOSE_GROUP( GROUP_ID , ERROR_DUMMY )
        IF( ERROR_DUMMY < 0 .AND. ERROR >= 0 ) THEN
          ERROR = ERROR_DUMMY
          ERRMSG = "Error in closing /PROPERTIES/By Layers"
        END IF

      END IF

      CALL XF_CLOSE_GROUP( PROP_ID , ERROR_DUMMY )
      IF( ERROR_DUMMY < 0 .AND. ERROR >= 0 ) THEN
        ERROR = ERROR_DUMMY
        ERRMSG = "Error in closing /PROPERTIES"
      END IF

    END IF
    IF( ERROR < 0 ) THEN
      ERRMSG = TRIM(ERRMSG)//" in multiple datasets"
      RETURN
    END IF

  END SUBROUTINE MR_GET_NK

!***********************************************************************************************************************************
! UNIT:
!
!  (SUBROUTINE)
!
! PURPOSE:
!
!
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  SUBROUTINE MR_GET_NKS( MULTI_DSETS_ID , NKS , ERROR , ERRMSG )

    IMPLICIT NONE

    INTEGER            , INTENT(IN ) :: MULTI_DSETS_ID

    INTEGER                          :: PROP_ID , GROUP_ID

    INTEGER(KSID_KIND) , INTENT(OUT) :: NKS
    INTEGER                          :: NKS_ARRAY(1:1)

    INTEGER            , INTENT(OUT) :: ERROR
    CHARACTER(   *   ) , INTENT(OUT) :: ERRMSG

    INTEGER                          :: ERROR_DUMMY

    ERRMSG = ""

    CALL XF_OPEN_PROPERTY_GROUP( MULTI_DSETS_ID , PROP_ID , ERROR )
    IF( ERROR < 0 ) THEN
      ERRMSG = "Error in opening /PROPERTIES"
    ELSE

      CALL XF_OPEN_GROUP( PROP_ID , "By Sediment Sizes" , GROUP_ID , ERROR )
      IF( ERROR < 0 ) THEN
        ERRMSG = "Error in opening /PROPERTIES/By Sediment Sizes"
      ELSE

        !BLOCK

          CALL XF_READ_PROPERTY_INT( GROUP_ID , "Num Sediment Sizes" , 1 , NKS_ARRAY , ERROR )
          IF( ERROR < 0 ) THEN
            ERRMSG = "Error in getting the number of sediment sizes from /PROPERTIES/By Sediment Sizes"
          ELSE
            NKS = NKS_ARRAY(1)
          END IF

        !END BLOCK

        CALL XF_CLOSE_GROUP( GROUP_ID , ERROR_DUMMY )
        IF( ERROR_DUMMY < 0 .AND. ERROR >= 0 ) THEN
          ERROR = ERROR_DUMMY
          ERRMSG = "Error in closing /PROPERTIES/By Sediment Sizes"
        END IF

      END IF

      CALL XF_CLOSE_GROUP( PROP_ID , ERROR_DUMMY )
      IF( ERROR_DUMMY < 0 .AND. ERROR >= 0 ) THEN
        ERROR = ERROR_DUMMY
        ERRMSG = "Error in closing /PROPERTIES"
      END IF

    END IF
    IF( ERROR < 0 ) THEN
      ERRMSG = TRIM(ERRMSG)//" in multiple datasets"
      RETURN
    END IF

  END SUBROUTINE MR_GET_NKS

  END MODULE MR_MOD_GET_RANKS


module test_sorting

    use, intrinsic :: iso_fortran_env, only: compiler_version, error_unit
    use stdlib_kinds, only: int32, int64, dp, sp
    use stdlib_sorting
    use stdlib_string_type, only: string_type, assignment(=), operator(>), &
        operator(<), write(formatted)
    use testdrive, only: new_unittest, unittest_type, error_type, check

    implicit none

    integer(int32), parameter :: test_power = 16
    integer(int32), parameter :: char_set_size = 16
    integer(int32), parameter :: test_size = 2_int32**test_power
    integer(int32), parameter :: char_size = char_set_size**4
    integer(int32), parameter :: string_size = char_set_size**3
    integer(int32), parameter :: block_size = test_size/6
    integer, parameter        :: repeat = 1

    integer(int32) ::             &
        blocks(0:test_size-1),    &
        decrease(0:test_size-1),  &
        identical(0:test_size-1), &
        increase(0:test_size-1),  &
        rand0(0:test_size-1),     &
        rand1(0:test_size-1),     &
        rand2(0:test_size-1),     &
        rand3(0:test_size-1),     &
        rand10(0:test_size-1)
    character(len=4) ::               &
        char_decrease(0:char_size-1), &
        char_increase(0:char_size-1), &
        char_rand(0:char_size-1)
    type(string_type) ::                  &
        string_decrease(0:string_size-1), &
        string_increase(0:string_size-1), &
        string_rand(0:string_size-1)

    integer(int32)          :: dummy(0:test_size-1)
    character(len=4)        :: char_dummy(0:char_size-1)
    type(string_type)       :: string_dummy(0:string_size-1)
    integer(int_size)       :: index(0:max(test_size, char_size, string_size)-1)
    integer(int32)          :: work(0:test_size/2-1)
    character(len=4)        :: char_work(0:char_size/2-1)
    type(string_type)       :: string_work(0:string_size/2-1)
    integer(int_size)       :: iwork(0:max(test_size, char_size, &
                                     string_size)/2-1)
    integer                 :: count, i, index1, index2, j, k, l, temp
    real(sp)                :: arand, brand
    character(*), parameter :: filename = 'test_sorting.txt'
    integer                 :: lun
    character(len=4)        :: char_temp
    type(string_type)       :: string_temp
    logical                 :: ltest, ldummy

contains

    !> Collect all exported unit tests
    subroutine collect_sorting(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest('int_ord_sorts', test_int_ord_sorts), &
            new_unittest('char_ord_sorts', test_char_ord_sorts), &
            new_unittest('string_ord_sorts', test_string_ord_sorts), &
            new_unittest('int_sorts', test_int_sorts), &
            new_unittest('char_sorts', test_char_sorts), &
            new_unittest('string_sorts', test_string_sorts), &
            new_unittest('int_sort_indexes', test_int_sort_indexes), &
            new_unittest('char_sort_indexes', test_char_sort_indexes), &
            new_unittest('string_sort_indexes', test_string_sort_indexes) &
        ]

    end subroutine collect_sorting

    subroutine initialize_tests()

        ! Create the test arrays
        identical(:) = 10
        do i=0, test_size-1
            increase(i) = i
            decrease(i) = test_size - 1 - i
            call random_number( arand )
            rand0(i) = int( floor( 4 * arand * test_size ), kind=int32 )
            rand1(i) = int( floor( arand * test_size / 4 ), kind=int32 )
        end do
        blocks(:) = increase(:)
        blocks(0:block_size-1) = increase(4*block_size:5*block_size-1)
        blocks(block_size:2*block_size-1) = increase(0:block_size-1)
        blocks(2*block_size:3*block_size-1) = increase(2*block_size:3*block_size-1)
        blocks(3*block_size:4*block_size-1) = increase(block_size:2*block_size-1)
        blocks(4*block_size:5*block_size-1) = increase(3*block_size:4*block_size-1)
        rand2(:) = increase(:)
        do i=0, test_size-1
            call random_number( arand )
            index1 = int( floor( arand * test_size ), kind=int32 )
            temp = rand2(i)
            rand2(i) = rand2(index1)
            rand2(index1) = temp
        end do
        rand3(:) = increase(:)
        do i=0, 2
            call random_number( arand )
            call random_number( brand )
            index1 = int( floor( arand * test_size ), kind=int32 )
            index2 = int( floor( brand * test_size ), kind=int32 )
            temp = rand3(index1)
            rand3(index1) = rand3(index2)
            rand3(index2) = temp
        end do
        rand10(:) = increase(:)
        do i=test_size-10, test_size-1
            call random_number( arand )
            rand10(i) = int( floor( arand * test_size ), kind=int32 )
        end do

        count = 0
        do i=0, char_set_size-1
            do j=0, char_set_size-1
                do k=0, char_set_size-1
                    do l=0, char_set_size-1
                        char_increase(count) = achar(97+i) // achar(97+j) // &
                            achar(97+k) // achar(97+l)
                        count = count + 1
                    end do
                end do
            end do
        end do

        do i=0, char_size-1
            char_decrease(char_size-1-i) = char_increase(i)
        end do

        char_rand(:) = char_increase(:)
        do i=0, char_size-1
            call random_number( arand )
            index1 = int( floor( arand * char_size ), kind=int32 )
            char_temp = char_rand(i)
            char_rand(i) = char_rand(index1)
            char_rand(index1) = char_temp
        end do

        count = 0
        do i=0, char_set_size-1
            do j=0, char_set_size-1
                do k=0, char_set_size-1
                    string_increase(count) = achar(97+i) // achar(97+j) // &
                        achar(97+k)
                    count = count + 1
                end do
            end do
        end do

        do i=0, string_size-1
            string_decrease(string_size - 1 - i) = char_increase(i)
        end do

        string_rand(:) = string_increase(:)
        do i=0, string_size-1
            call random_number( arand )
            index1 = int( floor( arand * string_size ), kind=int32 )
            string_temp = string_rand(i)
            string_rand(i) = string_rand(index1)
            string_rand(index1) = string_temp
        end do

        ! Create and intialize file to report the results of the sortings
        open( newunit=lun, file=filename, access='sequential', action='write', &
            form='formatted', status='replace' )
        write( lun, '(a)' ) trim(compiler_version())
        write( lun, * )
        write( lun, '("|    Type     | Elements |    Array Name   |    Method ' // &
            '  |  Time (s) |")' )
        write( lun, '("|-------------|----------|-----------------|-----------' // &
            '--|-----------|")' )

    end subroutine initialize_tests

    subroutine test_int_ord_sorts(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer(int64)       :: i
        integer, allocatable :: d1(:)
        logical              :: ltest

        call test_int_ord_sort( blocks, "Blocks", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_ord_sort( decrease, "Decreasing", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_ord_sort( identical, "Identical", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_ord_sort( increase, "Increasing", ltest )
        call check(error, ltest)

        if (allocated(error)) return
        call test_int_ord_sort( rand1, "Random dense", ltest )
        call check(error, ltest)

        if (allocated(error)) return
        call test_int_ord_sort( rand2, "Random order", ltest )
        call check(error, ltest)

        if (allocated(error)) return
        call test_int_ord_sort( rand0, "Random sparse", ltest )
        call check(error, ltest)

        if (allocated(error)) return
        call test_int_ord_sort( rand3, "Random 3", ltest )
        call check(error, ltest)

        if (allocated(error)) return
        call test_int_ord_sort( rand10, "Random 10", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        !triggered an issue in insertion_sort
        d1 = [10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20]
        call ord_sort( d1 )
        call verify_sort( d1, ltest, i )
        call check(error, ltest)

    end subroutine test_int_ord_sorts

    subroutine test_int_ord_sort( a, a_name, ltest )
        integer(int32), intent(in) :: a(:)
        character(*), intent(in)   :: a_name
        logical, intent(out)       :: ltest

        integer(int64) :: t0, t1, tdiff
        real(dp)       :: rate
        integer(int64) :: i
        logical :: valid

        ltest = .true.

        tdiff = 0
        do i = 1, repeat
            dummy = a
            call system_clock( t0, rate )
            call ord_sort( dummy, work )
            call system_clock( t1, rate )
            tdiff = tdiff + t1 - t0
        end do
        tdiff = tdiff/repeat

        call verify_sort( dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "ORD_SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
        end if
        write( lun, '("|     Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
            'a12, " |",  F10.6, " |" )' ) &
            test_size, a_name, "Ord_Sort", tdiff/rate

        !reverse
        dummy = a
        call ord_sort( dummy, work, reverse = .true.)
        call verify_reverse_sort( dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
                "."
            write(*,*) 'i = ', i
            write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
        end if

        dummy = a
        call ord_sort( dummy, reverse = .true.)
        call verify_reverse_sort( dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "reverse ORD_SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
        end if

    end subroutine test_int_ord_sort

    subroutine test_char_ord_sorts(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        logical :: ltest

        call test_char_ord_sort( char_decrease, "Char. Decrease", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_char_ord_sort( char_increase, "Char. Increase", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_char_ord_sort( char_rand, "Char. Random", ltest )
        call check(error, ltest)

    end subroutine test_char_ord_sorts

    subroutine test_char_ord_sort( a, a_name, ltest )
        character(len=4), intent(in) :: a(0:)
        character(*), intent(in) :: a_name
        logical, intent(out) :: ltest

        integer(int64) :: t0, t1, tdiff
        real(dp)       :: rate
        integer(int64) :: i
        logical        :: valid

        ltest = .true.

        tdiff = 0
        do i = 1, repeat
            char_dummy = a
            call system_clock( t0, rate )
            call ord_sort( char_dummy, char_work )
            call system_clock( t1, rate )
            tdiff = tdiff + t1 - t0
        end do
        tdiff = tdiff/repeat

        call verify_char_sort( char_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "ORD_SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
        end if
        write( lun, '("|   Character |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
            'a12, " |",  F10.6, " |" )' ) &
            char_size, a_name, "Ord_Sort", tdiff/rate

        !reverse
        char_dummy = a
        call ord_sort( char_dummy, char_work, reverse = .true. )

        call verify_char_reverse_sort( char_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
                "."
            write(*,*) 'i = ', i
            write(*,'(a, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
        end if

        char_dummy = a
        call ord_sort( char_dummy, reverse = .true. )

        call verify_char_reverse_sort( char_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
                "."
            write(*,*) 'i = ', i
            write(*,'(a, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
        end if

    end subroutine test_char_ord_sort

    subroutine test_string_ord_sorts(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        logical:: ltest

        call test_string_ord_sort( string_decrease, "String Decrease", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_string_ord_sort( string_increase, "String Increase", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_string_ord_sort( string_rand, "String Random" , ltest)
        call check(error, ltest)

    end subroutine test_string_ord_sorts

    subroutine test_string_ord_sort( a, a_name, ltest )
        type(string_type), intent(in) :: a(0:)
        character(*), intent(in)      :: a_name
        logical, intent(out)          :: ltest

        integer(int64) :: t0, t1, tdiff
        real(dp)       :: rate
        integer(int64) :: i
        logical        :: valid

        ltest = .true.

        tdiff = 0
        do i = 1, repeat
            string_dummy = a
            call system_clock( t0, rate )
            call ord_sort( string_dummy, string_work )
            call system_clock( t1, rate )
            tdiff = tdiff + t1 - t0
        end do
        tdiff = tdiff/repeat

        call verify_string_sort( string_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "ORD_SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a, 2(1x,a))') 'string_dummy(i-1:i) = ', &
                string_dummy(i-1:i)
        end if
        write( lun, '("| String_type |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
            'a12, " |",  F10.6, " |" )' ) &
            string_size, a_name, "Ord_Sort", tdiff/rate

        !reverse
        string_dummy = a
        call ord_sort( string_dummy, string_work, reverse = .true. )

        call verify_string_reverse_sort( string_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "reverse + work ORD_SORT did not sort " // a_name // &
                "."
            write(*,*) 'i = ', i
            write(*,'(a, 2(1x,a))') 'string_dummy(i-1:i) = ', &
                string_dummy(i-1:i)
        end if

        string_dummy = a
        call ord_sort( string_dummy, reverse = .true. )

        call verify_string_reverse_sort( string_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "reverse ORD_SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a, 2(1x,a))') 'string_dummy(i-1:i) = ', &
                string_dummy(i-1:i)
        end if

    end subroutine test_string_ord_sort

    subroutine test_int_sorts(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer(int64)       :: i
        integer, allocatable :: d1(:)
        logical              :: ltest

        call test_int_sort( blocks, "Blocks", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort( decrease, "Decreasing", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort( identical, "Identical", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort( increase, "Increasing", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort( rand1, "Random dense", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort( rand2, "Random order", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort( rand0, "Random sparse", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort( rand3, "Random 3", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort( rand10, "Random 10", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        !triggered an issue in  insertion
        d1 = [10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20]
        call sort( d1 )
        call verify_sort( d1, ltest, i )
        call check(error, ltest)

    end subroutine test_int_sorts

    subroutine test_int_sort( a, a_name, ltest )
        integer(int32), intent(in) :: a(:)
        character(*), intent(in)   :: a_name
        logical, intent(out) :: ltest

        integer(int64) :: t0, t1, tdiff
        real(dp)       :: rate
        integer(int64) :: i
        logical        :: valid

        ltest = .true.

        tdiff = 0
        do i = 1, repeat
            dummy = a
            call system_clock( t0, rate )
            call sort( dummy )
            call system_clock( t1, rate )
            tdiff = tdiff + t1 - t0
        end do
        tdiff = tdiff/repeat

        call verify_sort( dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
        end if
        write( lun, '("|     Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
            'a12, " |",  F10.6, " |" )' ) &
            test_size, a_name, "Sort", tdiff/rate

        ! reverse
        dummy = a
        call sort( dummy, .true.)
        call verify_reverse_sort(dummy, valid, i)
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "reverse SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a12, 2i7)') 'dummy(i-1:i) = ', dummy(i-1:i)
        end if

    end subroutine test_int_sort

    subroutine test_char_sorts(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        logical :: ltest

        call test_char_sort( char_decrease, "Char. Decrease", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_char_sort( char_increase, "Char. Increase", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_char_sort( char_rand, "Char. Random", ltest )
        call check(error, ltest)

    end subroutine test_char_sorts

    subroutine test_char_sort( a, a_name, ltest )
        character(len=4), intent(in) :: a(0:)
        character(*), intent(in) :: a_name
        logical, intent(out) :: ltest

        integer(int64) :: t0, t1, tdiff
        real(dp)       :: rate
        integer(int64) :: i
        logical        :: valid

        ltest = .true.

        tdiff = 0
        do i = 1, repeat
            char_dummy = a
            call system_clock( t0, rate )
            call sort( char_dummy )
            call system_clock( t1, rate )
            tdiff = tdiff + t1 - t0
        end do
        tdiff = tdiff/repeat

        call verify_char_sort( char_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a17, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
        end if
        write( lun, '("|   Character |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
            'a12, " |",  F10.6, " |" )' ) &
            char_size, a_name, "Sort", tdiff/rate

        !reverse
        char_dummy = a
        call sort( char_dummy, .true.)
        call verify_char_reverse_sort( char_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "reverse SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a17, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
        end if

    end subroutine test_char_sort

    subroutine test_string_sorts(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        logical :: ltest

        call test_string_sort( string_decrease, "String Decrease", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_string_sort( string_increase, "String Increase", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_string_sort( string_rand, "String Random", ltest )
        call check(error, ltest)

    end subroutine test_string_sorts

    subroutine test_string_sort( a, a_name, ltest )
        type(string_type), intent(in) :: a(0:)
        character(*), intent(in) :: a_name
        logical, intent(out) :: ltest

        integer(int64) :: t0, t1, tdiff
        real(dp)       :: rate
        integer(int64) :: i
        logical        :: valid

        ltest = .true.

        tdiff = 0
        do i = 1, repeat
            string_dummy = a
            call system_clock( t0, rate )
            call sort( string_dummy )
            call system_clock( t1, rate )
            tdiff = tdiff + t1 - t0
        end do
        tdiff = tdiff/repeat

        call verify_string_sort( string_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a17, 2(1x,a4))') 'string_dummy(i-1:i) = ', &
                string_dummy(i-1:i)
        end if
        write( lun, '("| String_type |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
            'a12, " |",  F10.6, " |" )' ) &
            string_size, a_name, "Sort", tdiff/rate

        ! reverse
        string_dummy = a
        call sort( string_dummy, .true.)
        call verify_string_reverse_sort(string_dummy, valid, i)
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "reverse SORT did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a17, 2(1x,a4))') 'string_dummy(i-1:i) = ', &
                string_dummy(i-1:i)
        end if

    end subroutine test_string_sort

    subroutine test_int_sort_indexes(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        integer(int64)              :: i
        integer(int32), allocatable :: d1(:)
        integer(int64), allocatable :: index(:)
        logical                     :: ltest

        call test_int_sort_index( blocks, "Blocks", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort_index( decrease, "Decreasing", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort_index( identical, "Identical", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort_index( increase, "Increasing", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort_index( rand1, "Random dense", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort_index( rand2, "Random order", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort_index( rand0, "Random sparse", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort_index( rand3, "Random 3", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_int_sort_index( rand10, "Random 10", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        d1 = [10, 2, -3, -4, 6, -6, 7, -8, 9, 0, 1, 20]
        allocate( index(size(d1)) )
        call sort_index( d1, index )
        call verify_sort( d1, ltest, i )
        call check(error, ltest)

    end subroutine test_int_sort_indexes

    subroutine test_int_sort_index( a, a_name, ltest )
        integer(int32), intent(inout) :: a(:)
        character(*), intent(in)      :: a_name
        logical, intent(out)          :: ltest

        integer(int64)                 :: t0, t1, tdiff
        real(dp)                       :: rate
        integer(int64)                 :: i
        logical                        :: valid

        ltest = .true.

        tdiff = 0
        do i = 1, repeat
            dummy = a
            call system_clock( t0, rate )
            call sort_index( dummy, index, work, iwork )
            call system_clock( t1, rate )
            tdiff = tdiff + t1 - t0
        end do
        tdiff = tdiff/repeat

        dummy = a(index(0:size(a)-1))
        call verify_sort( dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "SORT_INDEX did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a18, 2i7)') 'a(index(i-1:i)) = ', a(index(i-1:i))
        end if
        write( lun, '("|     Integer |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
            'a12, " |",  F10.6, " |" )' ) &
            test_size, a_name, "Sort_Index", tdiff/rate

        dummy = a
        call sort_index( dummy, index, work, iwork, reverse=.true. )
        dummy = a(index(size(a)-1))
        call verify_reverse_sort( dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "SORT_INDEX did not reverse sort " // &
                a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a18, 2i7)') 'a(index(i-1:i)) = ', a(index(i-1:i))
        end if

    end subroutine test_int_sort_index

    subroutine test_char_sort_indexes(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        logical :: ltest

        call test_char_sort_index( char_decrease, "Char. Decrease", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_char_sort_index( char_increase, "Char. Increase", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_char_sort_index( char_rand, "Char. Random", ltest )
        call check(error, ltest)

    end subroutine test_char_sort_indexes

    subroutine test_char_sort_index( a, a_name, ltest )
        character(len=4), intent(in) :: a(0:)
        character(*), intent(in) :: a_name
        logical, intent(out)     :: ltest

        integer(int64) :: t0, t1, tdiff
        real(dp)       :: rate
        integer(int64) :: i
        logical        :: valid

        ltest = .true.

        tdiff = 0
        do i = 1, repeat
            char_dummy = a
            call system_clock( t0, rate )

            call sort_index( char_dummy, index, char_work, iwork )

            call system_clock( t1, rate )

            tdiff = tdiff + t1 - t0
        end do
        tdiff = tdiff/repeat

        call verify_char_sort( char_dummy, valid, i )

        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "SORT_INDEX did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a17, 2(1x,a4))') 'char_dummy(i-1:i) = ', char_dummy(i-1:i)
        end if
        write( lun, '("|   Character |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
            'a12, " |",  F10.6, " |" )' ) &
            char_size, a_name, "Sort_Index", tdiff/rate

    end subroutine test_char_sort_index

    subroutine test_string_sort_indexes(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error
        logical :: ltest

        call test_string_sort_index( string_decrease, "String Decrease", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_string_sort_index( string_increase, "String Increase", ltest )
        call check(error, ltest)
        if (allocated(error)) return

        call test_string_sort_index( string_rand, "String Random", ltest )
        call check(error, ltest)

    end subroutine test_string_sort_indexes

    subroutine test_string_sort_index( a, a_name, ltest )
        type(string_type), intent(in) :: a(0:)
        character(*), intent(in) :: a_name
        logical, intent(out) :: ltest

        integer(int64) :: t0, t1, tdiff
        real(dp)       :: rate
        integer(int64) :: i
        logical        :: valid

        ltest = .true.

        tdiff = 0
        do i = 1, repeat
            string_dummy = a
            call system_clock( t0, rate )
            call sort_index( string_dummy, index, string_work, iwork )
            call system_clock( t1, rate )
            tdiff = tdiff + t1 - t0
        end do
        tdiff = tdiff/repeat

        call verify_string_sort( string_dummy, valid, i )
        ltest = (ltest .and. valid)
        if ( .not. valid ) then
            write( *, * ) "SORT_INDEX did not sort " // a_name // "."
            write(*,*) 'i = ', i
            write(*,'(a17, 2(1x,a4))') 'string_dummy(i-1:i) = ', &
                string_dummy(i-1:i)
        end if
        write( lun, '("| String_type |", 1x, i7, 2x, "|", 1x, a15, " |", ' // &
            'a12, " |",  F10.6, " |" )' ) &
            string_size, a_name, "Sort_Index", tdiff/rate

    end subroutine test_string_sort_index

    subroutine verify_sort( a, valid, i )
        integer(int32), intent(in) :: a(0:)
        logical, intent(out) :: valid
        integer(int64), intent(out) :: i

        integer(int64) :: n

        n = size( a, kind=int64 )
        valid = .false.
        do i=1, n-1
            if ( a(i-1) > a(i) ) return
        end do
        valid = .true.

    end subroutine verify_sort

    subroutine verify_string_sort( a, valid, i )
        type(string_type), intent(in) :: a(0:)
        logical, intent(out) :: valid
        integer(int64), intent(out) :: i

        integer(int64) :: n

        n = size( a, kind=int64 )
        valid = .false.
        do i=1, n-1
            if ( a(i-1) > a(i) ) return
        end do
        valid = .true.

    end subroutine verify_string_sort

    subroutine verify_char_sort( a, valid, i )
        character(len=4), intent(in) :: a(0:)
        logical, intent(out) :: valid
        integer(int64), intent(out) :: i

        integer(int64) :: n

        n = size( a, kind=int64 )
        valid = .false.
        do i=1, n-1
            if ( a(i-1) > a(i) ) return
        end do
        valid = .true.

    end subroutine verify_char_sort

    subroutine verify_char_reverse_sort( a, valid, i )
        character(len=4), intent(in) :: a(0:)
        logical, intent(out) :: valid
        integer(int64), intent(out) :: i

        integer(int64) :: n

        n = size( a, kind=int64 )
        valid = .false.
        do i=1, n-1
            if ( a(i-1) < a(i) ) return
        end do
        valid = .true.

    end subroutine verify_char_reverse_sort

    subroutine verify_reverse_sort( a, valid, i )
        integer(int32), intent(in) :: a(0:)
        logical, intent(out) :: valid
        integer(int64), intent(out) :: i

        integer(int64) :: n

        n = size( a, kind=int64 )
        valid = .false.
        do i=1, n-1
            if ( a(i-1) < a(i) ) return
        end do
        valid = .true.

    end subroutine verify_reverse_sort

    subroutine verify_string_reverse_sort( a, valid, i )
        type(string_type), intent(in) :: a(0:)
        logical, intent(out) :: valid
        integer(int64), intent(out) :: i

        integer(int64) :: n

        n = size( a, kind=int64 )
        valid = .false.
        do i=1, n-1
            if ( a(i-1) < a(i) ) return
        end do
        valid = .true.

    end subroutine verify_string_reverse_sort

end module test_sorting

program tester
    use, intrinsic :: iso_fortran_env, only: compiler_version, error_unit
    use testdrive, only: new_testsuite, run_testsuite, testsuite_type
    use test_sorting, only: initialize_tests, collect_sorting

    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    call initialize_tests()

    stat = 0

    testsuites = [ &
        new_testsuite("sorting", collect_sorting) &
        ]

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if

end program tester


program compare
integer :: a, b
read(*,*) a, b

if (a < b) then
  write(*, *) a, ' is less than ', b
else if (a == b) then
  write(*, *) a, ' is equal to ', b
else if (a > b) then
  write(*, *) a, ' is greater than ', b
end if

end program compare


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_xcxal
   use m_juDFT
!-----------------------------------------------------------------------
!     Called in case of icorr=0 : nonspin-polarized exchange-correlation
!       potential with the X-alpha method

!     We caclulate  V_x = alpha V_{x,Slater}  where alpha = 2/3
!     i.e. the output corresponds to the Gaspar result for the
!     local approximation to the Hartree-Fock method.

!     krla=1: Relativistic correction of exchange energy and potential
!             related to Dirac kinetic energy, according to:
!             A.H. MacDonald and S.H. Vosko, J. Phys. C12, 2977 (1979)

!     be careful: calculation in rydberg!

!     vxcxal   calculates the XC-potential and
!     excxal   calculates the XC-energy

!     based on a subroutine by S. Bluegel;   r.pentcheva 22.01.96
!-----------------------------------------------------------------------

   USE m_constants, ONLY : pi_const
   USE m_relcor
   IMPLICIT NONE

   REAL, PARAMETER, PRIVATE :: one = 1.0 , three = 3.0 , four = 4.0
   REAL, PARAMETER, PRIVATE :: thrd = one/three , d_15 = 1.e-15
   REAL, PARAMETER, PRIVATE :: cvx = 1.221774115422  ! 2 * ( 3/(2*pi) )^(2/3)

CONTAINS
!************************************************************************
   SUBROUTINE vxcxal( &
      krla,jspins, &
      mgrid,ngrid,rh, &
      vx,vxc)
!************************************************************************

!     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: jspins
      INTEGER, INTENT (IN) :: krla        !  switch for rel. corr.
      INTEGER, INTENT (IN) :: mgrid,ngrid !  mesh points

!     .. Array Arguments ..
      REAL, INTENT (IN)  :: rh(mgrid,jspins)      ! charge density
      REAL, INTENT (OUT) :: vx (mgrid,jspins)
      REAL, INTENT (OUT) :: vxc(mgrid,jspins)     ! xc potential

!     .. Local Arrays ..
      REAL, ALLOCATABLE :: psi(:)       ! relativistic exchange potential corr.

      REAL ::  rs, rho, thfpi
      INTEGER :: ir

!-----s Intrinsic Functions
      INTRINSIC alog,max

      thfpi  = three / ( four * pi_const )

!-----> evaluate relativistic corrections for exchange

      ALLOCATE ( psi(ngrid) )
      CALL relcor( &
         mgrid,ngrid,jspins,krla, .TRUE. ,rh, &
         psi)

      DO ir = 1,ngrid
         IF (jspins == 1) THEN
            rho = max(d_15,rh(ir,1))
         ELSE
            rho = max(d_15,rh(ir,1)) + max(d_15,rh(ir,jspins))
         ENDIF
         rs = (thfpi/rho)**thrd
         ! exc:  exchange energy = -0.9163306/rs
         vxc(ir,1) = - psi(ir)*cvx/rs  ! paramagnetic exchange potential = 4/3 exc

         vx (ir,1) = - psi(ir)*cvx/rs

      ENDDO
      IF ( jspins == 2 ) THEN        ! spinpolarized calculation
         DO ir = 1,ngrid
            vxc(ir,jspins) = vxc(ir,1)

            vx(ir,jspins)  = vx(ir,1)
         ENDDO
      ENDIF

      DEALLOCATE (psi)
      RETURN

   END SUBROUTINE vxcxal
!***********************************************************************
   SUBROUTINE excxal( &
      iofile,krla,jspins, &
      mgrid,ngrid,rh, &
      exc)
!***********************************************************************

!     .. Scalar Arguments ..
      INTEGER, INTENT (IN) :: krla, jspins
      INTEGER, INTENT (IN) :: iofile      !  file number for read and write
      INTEGER, INTENT (IN) :: mgrid,ngrid !  mesh points

!     .. Array Arguments ..
      REAL, INTENT (IN)  :: rh(mgrid,jspins)      ! charge density
      REAL, INTENT (OUT) :: exc(mgrid)            ! xc energy

!     .. Local Scalars ..
      REAL :: cex
      REAL ::  rs, rho, thfpi
      INTEGER :: ir

!     .. Local Arrays ..
      REAL, ALLOCATABLE :: phi(:)       ! relativistic exchange energy correct.

!-----> Intrinsic Functions
      INTRINSIC alog,max

      cex = three * cvx / four
      thfpi  = three / ( four * pi_const )

      ALLOCATE ( phi(ngrid) )
      CALL relcor( &
         mgrid,ngrid,jspins,krla, .FALSE. ,rh, &
         phi)

      DO ir = 1,ngrid
         IF (jspins == 1) THEN
            rho = max(d_15,rh(ir,1))
         ELSE
            rho = max(d_15,rh(ir,1)) + max(d_15,rh(ir,jspins))
         ENDIF
         rs = (thfpi/rho)**thrd
         ! exc:  exchange energy = -0.9163306/rs
         exc(ir)     = - phi(ir)*cex / rs
      ENDDO
      IF ( jspins == 2 ) WRITE (iofile,*) &
         'WARNING: X-alpha XC & spin-polarized calculation'
      IF ( jspins > 2 ) THEN
         WRITE (iofile,'('' or error in jspins, jspins ='',i2)') jspins
         CALL juDFT_error("excxal",calledby="xcxal")
      END IF

      DEALLOCATE (phi)
      RETURN

   END SUBROUTINE excxal
END MODULE m_xcxal


      SUBROUTINE mglin(u,n,ncycle)
      INTEGER n,ncycle,NPRE,NPOST,NG,MEMLEN
      DOUBLE PRECISION u(n,n)
      PARAMETER (NG=5,MEMLEN=13*2**(2*NG)/3+14*2**NG+8*NG-100/3)
      PARAMETER (NPRE=1,NPOST=1)
CU    USES addint,copy,fill0,interp,maloc,relax,resid,rstrct,slvsml
      INTEGER j,jcycle,jj,jpost,jpre,mem,nf,ngrid,nn,ires(NG),irho(NG),
     *irhs(NG),iu(NG),maloc
      DOUBLE PRECISION z
      COMMON /memory/ z(MEMLEN),mem
      mem=0
      nn=n/2+1
      ngrid=NG-1
      irho(ngrid)=maloc(nn**2)
      call rstrct(z(irho(ngrid)),u,nn)
1     if (nn.gt.3) then
        nn=nn/2+1
        ngrid=ngrid-1
        irho(ngrid)=maloc(nn**2)
        call rstrct(z(irho(ngrid)),z(irho(ngrid+1)),nn)
      goto 1
      endif
      nn=3
      iu(1)=maloc(nn**2)
      irhs(1)=maloc(nn**2)
      call slvsml(z(iu(1)),z(irho(1)))
      ngrid=NG
      do 16 j=2,ngrid
        nn=2*nn-1
        iu(j)=maloc(nn**2)
        irhs(j)=maloc(nn**2)
        ires(j)=maloc(nn**2)
        call interp(z(iu(j)),z(iu(j-1)),nn)
        if (j.ne.ngrid) then
          call copy(z(irhs(j)),z(irho(j)),nn)
        else
          call copy(z(irhs(j)),u,nn)
        endif
        do 15 jcycle=1,ncycle
            nf=nn
            do 12 jj=j,2,-1
          do 11 jpre=1,NPRE
              call relax(z(iu(jj)),z(irhs(jj)),nf)
11        continue
          call resid(z(ires(jj)),z(iu(jj)),z(irhs(jj)),nf)
          nf=nf/2+1
          call rstrct(z(irhs(jj-1)),z(ires(jj)),nf)
          call fill0(z(iu(jj-1)),nf)
12          continue
            call slvsml(z(iu(1)),z(irhs(1)))
            nf=3
            do 14 jj=2,j
          nf=2*nf-1
          call addint(z(iu(jj)),z(iu(jj-1)),z(ires(jj)),nf)
          do 13 jpost=1,NPOST
              call relax(z(iu(jj)),z(irhs(jj)),nf)
13        continue
14          continue
15      continue
16    continue
      call copy(u,z(iu(ngrid)),n)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/mglin.for