      subroutine zbesig (x1r,x1i, alpha, kode, n, yr,yi, nz,wr,wi,ierr)
c     Author Serge Steer, Copyright INRIA, 2005
c     extends cbesi for the case where alpha is negative
      double precision alpha
      double precision x1r, x1i, yr(n), yi(n), wr(n),wi(n)
      integer kode,n,nz,ierr
c
      double precision a,pi,inf,xr, xi,a1
      integer ier1,ier2
      double precision dlamch

      data pi /3.14159265358979324D0/
      inf=dlamch('o')*2.0d0

      xr=x1r
      xi=x1i
      ier2=0
      if (xr.ne.xr.or.xi.ne.xi.or.alpha.ne.alpha) then
c     .  NaN case
         call dset(n,inf-inf,yr,1)
         call dset(n,inf-inf,yi,1)
         ierr=4
      elseif (alpha .ge. 0.0d0) then
         call zbesi(xr,xi,alpha,kode,n,yr,yi,nz,ierr)
         if (ierr.eq.2) then
            call dset(n,inf,yr,1)
            call dset(n,inf,yi,1)
         elseif(ierr.ge.4) then
            call dset(n,inf-inf,yr,1)
            call dset(n,inf-inf,yi,1)
         endif
      else if (alpha .eq. dint(alpha)) then
c     .  alpha <0 and integer,
c     .  transform to positive value of alpha
         if(alpha-1+n.ge.0) then
c     .     0 is between alpha and alpha+n
            a1=0.0d0
            nn=min(n,int(-alpha))
         else
            a1=-(alpha-1+n)
            nn=n
         endif
         call zbesi(xr,xi,a1,kode,n,wr,wi,nz,ierr)
         if (ierr.eq.2) then
            call dset(n,inf,yr,1)
            call dset(n,inf,yi,1)
         else
            if(n.gt.nn) then
c     .        0 is between alpha and alpha+n
               call dcopy(n-nn,wr,1,yr(nn+1),1)
               call dcopy(n-nn,wi,1,yi(nn+1),1)
               call dcopy(nn,wr(2),-1,yr,1)
               call dcopy(nn,wi(2),-1,yi,1)
            else
c     .        alpha and alpha+n are negative
               call dcopy(n,wr,-1,yr,1)
               call dcopy(n,wi,-1,yi,1)
            endif
         endif

      else if (xr .eq. 0.0d0.and.xi .eq.0.0d0) then
         call dset(n,-inf,yr,1)
         call dset(n,0.0d0,yi,1)
         ierr=2
      else
c     .  first alpha is negative non integer,
c     .  transform to positive value of alpha
         if(alpha-1.0d0+n.ge.0.0d0) then
c     .     0 is between alpha and alpha+n
            nn=int(-alpha)+1
         else
            nn=n
         endif
c     .  compute for negative value of alpha+k, transform problem for
c     .  a1:a1+(nn-1) with a1 positive  a1+k =abs(alpha+nn-k)
         a1=-(alpha-1.0d0+nn)

         call zbesi(xr,xi,a1,kode,n,wr,wi,nz1,ierr)
         call zbesk(xr,xi,a1,1,n,yr,yi,nz2,ier)
         ierr=max(ierr,ier)
         nz=max(nz1,nz2)
         if (ierr.eq.0) then
            a=(2.0d0/pi)*dsin(a1*pi)
            if (kode.eq.2) a=a*dexp(-abs(xr))
c     .     change sign to take into account that sin((a1+k)*pi)
C     .     changes sign with k
            if (nn.ge.2) then
               call dscal(nn/2,-1.0d0,yr(2),2)
               call dscal(nn/2,-1.0d0,yi(2),2)
            endif
            call daxpy(nn,a,yr,1,wr,1)
            call daxpy(nn,a,yi,1,wi,1)

         elseif (ierr.eq.2) then
            call dset(nn,inf,wr,1)
            call dset(nn,inf,wi,1)
         elseif(ierr.ge.4) then
            call dset(nn,inf-inf,wr,1)
            call dset(nn,inf-inf,wi,1)
         endif
c     .  store the result in the correct order
         call dcopy(nn,wr,-1,yr,1)
         call dcopy(nn,wi,-1,yi,1)
c     .  compute for positive value of alpha+k is any (note that x>0)
         if (n.gt.nn) then
            a1=1.0d0-a1
            call zbesi(xr,xi,a1,kode,n-nn,yr(nn+1),yi(nn+1),nz,ier)
            if (ier.eq.2) then
               call dset(n-nn,inf,yr(nn+1),1)
               call dset(n-nn,inf,yi(nn+1),1)
            elseif(ier.ge.4) then
               call dset(n-nn,inf-inf,yr(nn+1),1)
               call dset(n-nn,inf-inf,yi(nn+1),1)
            endif
            ierr=max(ierr,ier)
         endif
      endif
      end

      subroutine zbesiv (xr,xi,nx,alpha,na, kode,yr,yi,wr,wi,ierr)
c     Author Serge Steer, Copyright INRIA, 2005
c     compute besseli function for x and alpha given by vectors
c     w : working array of size 2*na (used only if nz>0 and alpha
C     contains negative
C     values
      double precision xr(nx),xi(nx),alpha(na),yr(*),yi(*),wr(*),wi(*)
      double precision e,dlamch,eps
      integer kode,nx,na,ier
      ierr=0
      eps=dlamch('p')
      if (na.lt.0) then
c     .  element wise case x and alpha are supposed to have the same
C     size
         do i=1,nx
            call  zbesig (xr(i), xi(i), alpha(i), kode, 1, yr(i),yi(i),
     $           nz,wr,wi,ier)
            ierr=max(ierr,ier)
         enddo
      elseif (na.eq.1) then
         do i=1,nx
            call  zbesig (xr(i), xi(i), alpha(1), kode, 1, yr(i),yi(i),
     $           nz,wr,wi,ier)
            ierr=max(ierr,ier)
         enddo
      else
c     .  compute besseli(x(i),y(j)), i=1,nx,j=1,na
         j0=1
 05      n=0
 10      n=n+1
         j=j0+n
         if (j.le.na.and.abs((1+alpha(j-1))-alpha(j)).le.eps) then
            goto 10
         endif

         do i=1,nx
            call zbesig (xr(i), xi(i), alpha(j0) ,kode, n, wr, wi, nz,
     $           wr(na+1),wi(na+1),ier)
            ierr=max(ierr,ier)
            call dcopy(n,wr,1,yr(i+(j0-1)*nx),nx)
            call dcopy(n,wi,1,yi(i+(j0-1)*nx),nx)
         enddo
         j0=j
         if (j0.le.na) goto 05
      endif
      end


subroutine nsf_InnerResiduals(a,rinsi,rprnsi)
   !This subroutine performs convergence checks for the fractional step NavierStokes
   use typre
   use Mod_NSFractionalStep
   use Mod_NavierStokes, only : zensi
   use MPI
   use def_parame
   implicit none
   class(NSFractionalStepProblem) :: a

    real(rp) :: rinsi,rprnsi

   integer(ip) :: ndime, npoinLocal

   call a%Mesh%GetNpoinLocal(npoinLocal)
   call a%Mesh%GetNdime(ndime)
   call vecresMPIHeterogeneous(2_ip,ndime,ndime,npoinLocal,1,1,ndime,a%unkno,a%veloc(1,1,1),rinsi,zensi,a%MPIcomm,a%MPIroot)
   rprnsi = 0.0_rp

end subroutine


! Lagrange particle tracking on one particle
! !INTERFACE:
!TODO: Needs to implement Ross & Sharples (2004)
SUBROUTINE LAGRANGE(nlev,zlev, nuh,w,zi,zp)
USE PARAM_MOD, only: dtdays, d_per_s
! dtdays: timestep in days
! d_per_s: how many seconds in one day
!
IMPLICIT NONE
!
! !INPUT PARAMETERS:
INTEGER, intent(in)                :: nlev          !Number of vertical grids
REAL,    intent(in)                :: zlev(0:nlev)  !Depth of vertical grids at w points
REAL,    intent(in)                :: nuh(0:nlev)   !Vertical diffusivity at w points
REAL,    intent(in)                :: w(0:nlev)     !Vertical advection at w points

! INPUT/OUTPUT PARAMETERS:
! the ith grid where the particle currently resides
INTEGER, intent(inout)             :: zi

! Z position of particles
REAL,    intent(inout)             :: zp
!
! !LOCAL VARIABLES:
INTEGER            :: i
REAL               :: rnd, rnd_var_inv, dt, step1, step2
REAL,parameter     :: visc_back=0.e-6,rnd_var=0.333333333
REAL               :: dz(nlev),dzn(nlev),step,zp_old
REAL               :: visc,rat,dt_inv,zloc
REAL               :: wint  !interpolated w
!EOP
!-----------------------------------------------------------------------
!BOC

dt = dtdays * d_per_s

!Judge whether the input is correct
IF (zp < zlev(0) .or. zp > zlev(nlev) .or. zi < 1 .or. zi > nlev) THEN
   write(6,*) "zp = ", zp
   write(6,*) "zi = ", zi
   stop "The particle out of the domain!"
ENDIF

dt_inv      = 1./dt
rnd_var_inv = 1./rnd_var

DO i = 1,nlev

   ! Depth of each grid
   dz(i) = zlev(i)-zlev(i-1)

   ! gradient of Kv
   dzn(i)= (nuh(i)-nuh(i-1))/dz(i)

END DO

!  local viscosity calculation
! correction suggested by Visser [1997]

rat  = (zp-zlev(zi-1))/dz(zi)
wint = rat*w(zi) +(1.-rat)*w(zi-1)  ! interpolate w

! The new position after dt/2
zloc = zp + 0.5*(dzn(zi)+wint)*dt

step = zloc - zp   ! The distance traveled

! First judge whether the particle jumps out of the domain
if (zloc > zlev(nlev)) then  !Reflective boundary at surface
   zloc = 2.*zlev(nlev) - zloc
   zi   = nlev
elseif (zloc < zlev(0)) then  !Open boundary at bottom, the particle got lost
   zp   = zloc
   zi   = -1
   return
endif

step = zloc-zp     ! The distance traveled

! The following is to find the index for the grid where the particle currently resides
do i = 1,nlev
   if (zlev(i) .gt. zloc .and. zlev(i-1) .le. zloc) then
       zi = i
       EXIT
   endif
end do   !End of diffusivity correction

rat  = (zloc-zlev(i-1))/dz(i)
visc = rat*nuh(i)+(1.-rat)*nuh(i-1)  ! interpolate Kv
wint = rat*w(i) +(1.-rat)*w(i-1)     ! interpolate w

IF (visc.lt.visc_back) visc=visc_back   !Kv background

zp_old = zp

CALL RANDOM_NUMBER(rnd)
rnd  = 2.d0*rnd - 1.d0
step1= SQRT(2d0 * rnd_var_inv * dt * visc)*rnd
step2= dt*(wint+dzn(i))
step = step1 + step2

zp = zp + step

! First judge whether the particle jumps out of the domain
IF (zp > zlev(nlev)) THEN
      zp = 2.*zlev(nlev) - zp   !Reflective boundary at surface
ELSEIF (zp < zlev(0)) THEN      ! Particle lost at bottom
      zi = -1
      return
ENDIF

!Compute new zi
do i=1,nlev
   if (zlev(i) .gt. zp .and. zlev(i-1) .le. zp) then
       zi = i
       EXIT
   endif
end do

return
END SUBROUTINE LAGRANGE


!-------------------------------------------------------------------------------
! Copyright (c) 2021, Whitman T. Dailey
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright notice, this
!    list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation
!    and/or other materials provided with the distribution.
! 3. Neither the name of the copyright holder nor the names of its
!    contributors may be used to endorse or promote products derived from
!    this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
! DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
! FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!-------------------------------------------------------------------------------
Module Isothermal_Atm

    Use Kinds, Only: dp
    Use Global, Only: R_star
    Use Global, Only: g0
    Implicit None
    Private
    Public :: T
    Public :: P
    Public :: rho
    Public :: M0

    Real(dp), Parameter :: T0 = 288.15_dp  ![K]
    Real(dp), Parameter :: P0 = 101325._dp  ![Pa]
    Real(dp), Parameter :: rho0 = 1225.0002517923321962_dp  ![g/m^3]
    Real(dp), Parameter :: M0 = 28.964425912034_dp  ![g/mol]  Average molecular weight of the ten most abundant species in air,
                                                    !         weighted by relative abundance, from US Std Atmosphere 1976
    Real(dp), Parameter :: neg_inv_scale_height = &  !Scale height of the atmosphere, inverted and negated for computational speed
                                                & -1000._dp * M0 * g0 / (R_star * T0)  ![1/km]

Contains

Function T(z)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: T  ![K] kinetic temperature at geometric altitude Z
    Real(dp), Intent(In) :: z ![km]

    T = T0
End Function T

Function IsoAtm_Exp(z) Result(I)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: I
    Real(dp), Intent(In) :: z

    I = Exp(z * neg_inv_scale_height)
End Function IsoAtm_Exp

Function P(z)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: P  ![Pa]
    Real(dp), Intent(In) :: z ![km]

    P = P0 * IsoAtm_Exp(z)
End Function P

Function rho(z)
    Use Kinds, Only: dp
    Implicit None
    Real(dp) :: rho  ![g/m^3]
    Real(dp), Intent(In) :: z ![km]

    rho = rho0 * IsoAtm_Exp(z)
End Function rho

End Module Isothermal_Atm


function fft(y) result(yh)
! FFT function
complex(kind=8), intent(in)  :: y(:)
integer(kind=8) :: plan_forward
complex(kind=8), allocatable :: yh(:)
allocate(yh(size(y)))
call dfftw_plan_dft_1d_ (plan_forward, size(y), y, yh, FFTW_FORWARD, FFTW_ESTIMATE)
call dfftw_execute(plan_forward)
end function fft


!-----------------------------------------------------------------------
!    Module:       numerical_module
!    Author:       S. W. Bruenn
!    Date:         8/16/02
!
!    Common numerical constants
!-----------------------------------------------------------------------

module numerical_module

USE kind_module

REAL(double), PARAMETER  :: zero      = 0.0d0
REAL(double), PARAMETER  :: half      = 0.5d0
REAL(double), PARAMETER  :: one       = 1.0d0
REAL(double), PARAMETER  :: epsilon   = 1.0d-100

REAL(double), PARAMETER  :: pi        = 3.1415926535897932385d0 ! pi

!-----------------------------------------------------------------------
!  Derived constants
!-----------------------------------------------------------------------

REAL(double), PARAMETER  :: pi2       = pi * pi
REAL(double), PARAMETER  :: twpi      = 2.d0 * pi
REAL(double), PARAMETER  :: frpi      = 4.d0 * pi
REAL(double), PARAMETER  :: third     = 1.d0/3.d0
REAL(double), PARAMETER  :: twothd    = 2.d0 * third
REAL(double), PARAMETER  :: fourthd   = 4.d0 * third
REAL(double), PARAMETER  :: frpith    = third * frpi
REAL(double), PARAMETER  :: sxtnpi    = 16.d0 * pi

!-----------------------------------------------------------------------
!  Equation of state coefficients
!
!   kfm : [ # nucleons g^{-1} ][ cm^{3}fm^{-3} ]
!-----------------------------------------------------------------------

REAL(double)             ::  log_e
REAL(double)             ::  ln_10

END module numerical_module


      COMPLEX*16 FUNCTION D040WZ(Qs,Ps,mw2,mz2)
      REAL*8 Qs,Ps,p2s,pi,TET
      COMPLEX*16 mz2,mw2,mt2,XSPENZ
      COMPLEX*16 adx,bdx,ddx,sddx,xdpl,xdmi,blx,sdlx,xlpl,xlmi,xrt1,xrt2
      PARAMETER (pi=3.1415926535897932D0)
      p2s=1d-12
      adx=Qs*(p2s-Ps+mw2)
      bdx=p2s*mz2+Ps*(Qs+mw2-mz2)
      ddx=(Ps*(Qs+mw2+mz2)-p2s*mz2)**2-4d0*mw2*mz2*Ps*(Qs+Ps-p2s)
      sddx=SQRT(ddx)
      xdpl=(-bdx+sddx)/2d0/adx
      xdmi=(-bdx-sddx)/2d0/adx
      xrt1=-mz2/(mw2-mz2+p2s)
      xrt2=-Ps/(mw2+p2s-Ps)
      blx=Qs+mw2-mz2
      sdlx=SQRT(blx**2+4d0*mz2*Qs)
      xlpl=(blx+sdlx)/2d0/Qs
      xlmi=(blx-sdlx)/2d0/Qs
*
      D040WZ=+1d0/sddx*(
     &  +2d0*CMPLX(0d0,1d0)*PI*(
     &  +TET(-DIMAG(sdlx/Qs))*TET(+DIMAG(sdlx)*DREAL(sdlx))
     &  -TET(+DIMAG(sdlx/Qs))*TET(-DIMAG(sdlx)*DREAL(sdlx)))
     &  *(LOG((1d0-xdpl)/(-xdpl))-LOG((1d0-xdmi)/(-xdmi)))
     & +LOG(xlpl-xdpl)*LOG((1d0-xdpl)/(-xdpl))
     & -XSPENZ((1d0-xdpl)/(xlpl-xdpl))
     & +XSPENZ((   -xdpl)/(xlpl-xdpl))
     & +LOG(-xlmi+xdpl)*LOG((1d0-xdpl)/(-xdpl))
     & -XSPENZ((1d0-xdpl)/(xlmi-xdpl))
     & +XSPENZ((   -xdpl)/(xlmi-xdpl))
     & -LOG(xlpl-xdmi)*LOG((1d0-xdmi)/(-xdmi))
     & +XSPENZ((1d0-xdmi)/(xlpl-xdmi))
     & -XSPENZ((   -xdmi)/(xlpl-xdmi))
     & -LOG(-xlmi+xdmi)*LOG((1d0-xdmi)/(-xdmi))
     & +XSPENZ((1d0-xdmi)/(xlmi-xdmi))
     & -XSPENZ((   -xdmi)/(xlmi-xdmi))
     & +LOG(Qs/mw2)*LOG((1d0-xdpl)/(-xdpl))
     & -LOG(Qs/mw2)*LOG((1d0-xdmi)/(-xdmi))
     & -LOG(xdpl)*LOG((1d0-xdpl)/(-xdpl))
     & +LOG(xdmi)*LOG((1d0-xdmi)/(-xdmi))
     & +XSPENZ((1d0-xdpl)/(-xdpl))
     & -XSPENZ((1d0-xdmi)/(-xdmi))
     & -LOG(mz2+(mw2-mz2+p2s)*xdpl)*LOG((1d0-xdpl)/(-xdpl))
     & +LOG(Ps+(mw2+p2s-Ps)*xdpl)*LOG((1d0-xdpl)/(-xdpl))
     & +LOG(mz2+(mw2-mz2+p2s)*xdmi)*LOG((1d0-xdmi)/(-xdmi))
     & -LOG(Ps+(mw2+p2s-Ps)*xdmi)*LOG((1d0-xdmi)/(-xdmi))
     & +XSPENZ((1d0-xdpl)/(xrt1-xdpl))
     & -XSPENZ((   -xdpl)/(xrt1-xdpl))
     & -XSPENZ((1d0-xdmi)/(xrt1-xdmi))
     & +XSPENZ((   -xdmi)/(xrt1-xdmi))
     & -XSPENZ((1d0-xdpl)/(xrt2-xdpl))
     & +XSPENZ((   -xdpl)/(xrt2-xdpl))
     & +XSPENZ((1d0-xdmi)/(xrt2-xdmi))
     & -XSPENZ((   -xdmi)/(xrt2-xdmi))
     &                )
      RETURN
      END


	FUNCTION BXPA(F)
C
C	THIS FUNCTION RETURNS THE GAIN OF THE WIND X SEARCH COIL,PREAMP AND
C	INPUT STAGE ON THE 212 BOARD.
C	THE FUNCTION ITSELF RETURNS THE MAGNITUDE OF THE GAIN, AND THE PHASE
C	AND THE COMPLEX GAIN ARE RETURNED IN A COMMON BLOCK
C
	COMMON /GAINBLK/ PHASE,CGAIN        		  ! PHASE IS IN RADIANS
	COMMON /COMPBLK/ CVAR(5)
C
	COMPLEX CGAIN,Y1,Z1,Y2,Z2
	DATA Q,T0,F0 / 1.47,XXX,1650./
	DATA R1,C10,R2,C1/ .952E-6, 49.9E3, 1.E6, 1.E-9/
	DATA TWOPI /6.2831853/
C
C
	W = TWOPI*F
C	OUTPUT OF SEARCH COIL PLUS PREAMP, VOLTS/nT
	CGAIN = CMPLX(1.,Q*(F/F0 - F0/F))
C	EFFECT OF INPUT ON 212 BOARD
	Y1 = CMPLX
	Y2 = CMPLX(1./R10,W*CINP)
	Z1 = 1./Y1
	Z2 = 1./Y2
	CGAIN = CGAIN*Z2/(Z1+Z2)
C	EFFECT OF OUTPUT RC
	WC16 = 1./(W*C16)
C	PRINT*,'W,Z1,WC16',W,Z1,WC16
C	PRINT*,'F,CGAIN,PHASE
	CGAIN = CGAIN*CMPLX(0.,-WC16)/CMPLX(R33,-WC16)
C
C	EFFECT OF INPUT BOARD
C
	WCC = W*CCOMP
	Z1 = CMPLX(0.,-1./WCC)
	Z2 = CMPLX(RCOMP,-1./WCC)
	Z3 = Z1/(Z1+Z2)
C*****************   effect of compensation
	CGAIN = CGAIN*Z3*Z3
C*************
C
	GNIP = AIMAG(CGAIN)
	GNRP = CGAIN
	PHASE = ATAN2(GNIP,GNRP)
	XPADC = CABS(CGAIN)
	RETURN
	END


      SUBROUTINE MFFTC6(C,FAC)
*
*   PURPOSE:
*       ELEMENTARY GENTLEMAN-SANDE RADIX 5 STEP APPLIED TO A VECTOR-OF
*       2-VECTORS-OF-COMPLEX C[IMS,NM [IVS,NV [IES,NE]]].
*       SEE REF.[1] FOR NOTATIONS.
*       THIS ROUTINE CAN BE USED ONLY BY ROUTINE MFFTDM, WHICH CONTROLS
*       ITS OPERATION THROUGH THE MFFTPA COMMON
*
*   DUMMY ARGUMENTS :
*
*   C   ARRAY BEING FOURIER  TRANSFORMED
*   FAC PHASE FACTORS, PREPARED BY MFFTP; NOT MODIFIED IN OUTPUT
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /MFFTPA/  IMS,IVS,IES,NM,NV,NE,MX,LX,MLIM,MSTEP,LLIM,LSTEP,
     $ NUSTEP,IVLIM,ILIM,MD2LIM,LD2LIM
      INTEGER NUSTEP
      DOUBLE COMPLEX C(0:NUSTEP-1,0:4),FAC(0:*)
      DOUBLE COMPLEX T1,T2,T3,T4,T5,F1,F2,F3,F4
      REAL *8 SIN72,RAD5D4,S36D72
      PARAMETER (
     $ SIN72 =  9.51056516295153572116439333E-1,
     $ RAD5D4 =  5.59016994374947424102293417E-1,
     $ S36D72 =  6.18033988749894848204586834E-1 )
*..  MU > 0
            MUF=LX
            DO 200 MU=MSTEP,MLIM,MSTEP
              F1=CONJG(FAC(MUF))
              F2=CONJG(FAC(MUF*2))
              F3=CONJG(FAC(MUF*3))
              F4=CONJG(FAC(MUF*4))
              DO 190 LAM=MU,MU+LLIM,LSTEP
                DO 180 IV=LAM,LAM+IVLIM,IVS
                DO 180 I=IV,IV+ILIM,IES
                  T1=C(I,1)+C(I,4)
                  T2=C(I,2)+C(I,3)
                  T3=(C(I,1)-C(I,4))*SIN72
                  T4=(C(I,2)-C(I,3))*SIN72
                  T5=T1+T2
                  T1=RAD5D4*(T1-T2)
                  T2=C(I,0)-0.25*T5
                  C(I,0)=C(I,0)+T5
                  T5=T2+T1
                  T2=T2-T1
                  T1=T3+S36D72*T4
                  T3=S36D72*T3-T4
                  C(I,1)=(T5-DCMPLX(-DIMAG(T1),DREAL(T1)))*F1
                  C(I,4)=(T5+DCMPLX(-DIMAG(T1),DREAL(T1)))*F4
                  C(I,2)=(T2-DCMPLX(-DIMAG(T3),DREAL(T3)))*F2
                  C(I,3)=(T2+DCMPLX(-DIMAG(T3),DREAL(T3)))*F3
  180           CONTINUE
  190         CONTINUE
              MUF=MUF+LX
200         CONTINUE
            DO 193 LAM=0,LLIM,LSTEP
              DO 183 IV=LAM,LAM+IVLIM,IVS
              DO 183 I=IV,IV+ILIM,IES
                T1=C(I,1)+C(I,4)
                T2=C(I,2)+C(I,3)
                T3=(C(I,1)-C(I,4))*SIN72
                T4=(C(I,2)-C(I,3))*SIN72
                T5=T1+T2
                T1=RAD5D4*(T1-T2)
                T2=C(I,0)-0.25*T5
                C(I,0)=C(I,0)+T5
                T5=T2+T1
                T2=T2-T1
                T1=T3+S36D72*T4
                T3=S36D72*T3-T4
                C(I,1)=T5-DCMPLX(-DIMAG(T1),DREAL(T1))
                C(I,4)=T5+DCMPLX(-DIMAG(T1),DREAL(T1))
                C(I,2)=T2-DCMPLX(-DIMAG(T3),DREAL(T3))
                C(I,3)=T2+DCMPLX(-DIMAG(T3),DREAL(T3))
183           CONTINUE
193         CONTINUE
      END


          program printkw
	  real c,wl,r2
	  integer iwl
	  c=0.1
	  do iwl=1,61
	  wl=0.40+.3*(iwl-1)/60
	  call morcasiwat(wl,C,R2)
	  enddo
	  stop
	  end

	        subroutine morcasiwat(wl,C,R2)
C Spectral diffuse attenuation coefficient of Case I Waters as Predicted
C by MOREL within the spectral range 400-700nm (1988, Journal of Geophysical
C Research, Vol.93, No C9, pp 10749-10768)
C
C input parameters:	wl wavelength (IN MICROMETERS)
C			C  pigment concentration
C output parameter:	R2  reflectance of water
C
C According Morel,1988, we use:
C
C Kd	spectral value of the attenuation coefficient for
C	 downwelling irradiance
C	 with: Kd=Kw+Xc*C**e
C Kw	spectral value of the diffuse attenuation coefficient
C	 for pure oceanic water
C Xc, e	spectral coefficients to compute the diffuse attenuation
C	 coefficient for pigment
C bb	total backscattering coefficient
C	 with: bb=0.5*bw+bbt*b
C bw	spectral value of the molecular scattering coefficient of water
C bbt,b	parameters to compute the scattering coefficients of pigments
C
C R2	reflectance of water below the surface
C	 with: R2=(0.33/u)*(bb/Kd)	where u is depending of R2
C
      real Kw,Kd
      real tKw(61),tXc(61),te(61),tbw(61)
      real wl,c,r2,xc,e,bw,bb,b,bbt,u1,r1,u2,err
      integer iwl

      data tKw/0.0209,0.0200,0.0196,0.0189,0.0183,
     & 0.0182,0.0171,0.0170,0.0168,0.0166,
     & 0.0168,0.0170,0.0173,0.0174,0.0175,
     & 0.0184,0.0194,0.0203,0.0217,0.0240,
     & 0.0271,0.0320,0.0384,0.0445,0.0490,
     & 0.0505,0.0518,0.0543,0.0568,0.0615,
     & 0.0640,0.0640,0.0717,0.0762,0.0807,
     & 0.0940,0.1070,0.1280,0.1570,0.2000,
     & 0.2530,0.2790,0.2960,0.3030,0.3100,
     & 0.3150,0.3200,0.3250,0.3300,0.3400,
     & 0.3500,0.3700,0.4050,0.4180,0.4300,
     & 0.4400,0.4500,0.4700,0.5000,0.5500,
     & 0.6500/
      data tXc/0.1100,0.1110,0.1125,0.1135,0.1126,
     & 0.1104,0.1078,0.1065,0.1041,0.0996,
     & 0.0971,0.0939,0.0896,0.0859,0.0823,
     & 0.0788,0.0746,0.0726,0.0690,0.0660,
     & 0.0636,0.0600,0.0578,0.0540,0.0498,
     & 0.0475,0.0467,0.0450,0.0440,0.0426,
     & 0.0410,0.0400,0.0390,0.0375,0.0360,
     & 0.0340,0.0330,0.0328,0.0325,0.0330,
     & 0.0340,0.0350,0.0360,0.0375,0.0385,
     & 0.0400,0.0420,0.0430,0.0440,0.0445,
     & 0.0450,0.0460,0.0475,0.0490,0.0515,
     & 0.0520,0.0505,0.0440,0.0390,0.0340,
     & 0.0300/
      data te/0.668,0.672,0.680,0.687,0.693,
     & 0.701,0.707,0.708,0.707,0.704,
     & 0.701,0.699,0.700,0.703,0.703,
     & 0.703,0.703,0.704,0.702,0.700,
     & 0.700,0.695,0.690,0.685,0.680,
     & 0.675,0.670,0.665,0.660,0.655,
     & 0.650,0.645,0.640,0.630,0.623,
     & 0.615,0.610,0.614,0.618,0.622,
     & 0.626,0.630,0.634,0.638,0.642,
     & 0.647,0.653,0.658,0.663,0.667,
     & 0.672,0.677,0.682,0.687,0.695,
     & 0.697,0.693,0.665,0.640,0.620,
     & 0.600/
      data tbw/0.0076,0.0072,0.0068,0.0064,0.0061,
     & 0.0058,0.0055,0.0052,0.0049,0.0047,
     & 0.0045,0.0043,0.0041,0.0039,0.0037,
     & 0.0036,0.0034,0.0033,0.0031,0.0030,
     & 0.0029,0.0027,0.0026,0.0025,0.0024,
     & 0.0023,0.0022,0.0022,0.0021,0.0020,
     & 0.0019,0.0018,0.0018,0.0017,0.0017,
     & 0.0016,0.0016,0.0015,0.0015,0.0014,
     & 0.0014,0.0013,0.0013,0.0012,0.0012,
     & 0.0011,0.0011,0.0010,0.0010,0.0010,
     & 0.0010,0.0009,0.0008,0.0008,0.0008,
     & 0.0007,0.0007,0.0007,0.0007,0.0007,
     & 0.0007/
      if (wl.lt.0.400.or.wl.gt.0.700)then
	R2=0.000
	goto 60
      endif

      iwl=1+nint((wl-0.400)/0.005)
      Kw=tKw(iwl)
      Xc=tXc(iwl)
      e=te(iwl)
      bw=tbw(iwl)
C
      if (abs(C).lt.0.0001)then
         bb=0.5*bw
         Kd=Kw
      else
         b=0.30*C**0.62
         bbt=0.002+0.02*(0.5-0.25*alog10(C))*0.550/wl
         bb=0.5*bw+bbt*b
         Kd=Kw+Xc*C**e
      endif

      u1=0.75
      R1=0.33*bb/u1/Kd

 50   u2=0.90*(1.-R1)/(1.+2.25*R1)
      R2=0.33*bb/u2/Kd
      err=abs((R2-R1)/R2)
      if (err.lt.0.0001)goto 60
      R1=R2
      goto 50
 60   write(6,*) wl,r2,kw,bw*0.5,xc
      return
      end


      DOUBLE PRECISION FUNCTION MB03NY( N, OMEGA, A, LDA, S, DWORK,
     $                                  LDWORK, CWORK, LCWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the smallest singular value of A - jwI.
C
C     FUNCTION VALUE
C
C     MB03NY  DOUBLE PRECISION
C             The smallest singular value of A - jwI (if INFO = 0).
C             If N = 0, the function value is set to zero.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the the matrix A.  N >= 0.
C
C     OMEGA   (input) DOUBLE PRECISION
C             The constant factor of A - jwI.
C
C     A       (input/workspace) DOUBLE PRECISION array, dimension
C             (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, if OMEGA = 0, the contents of this array are
C             destroyed. Otherwise, this array is unchanged.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     S       (output) DOUBLE PRECISION array, dimension (N)
C             The singular values of A - jwI in decreasing order.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= MAX( 1, 5*N ).
C             For optimum performance LDWORK should be larger.
C
C     CWORK   COMPLEX*16 array, dimension (LCWORK)
C             On exit, if INFO = 0 and OMEGA <> 0, CWORK(1) returns the
C             optimal value of LCWORK.
C             If OMEGA is zero, this array is not referenced.
C
C     LCWORK  INTEGER
C             The length of the array CWORK.
C             LCWORK >= 1,                 if OMEGA =  0;
C             LCWORK >= MAX( 1, N*N+3*N ), if OMEGA <> 0.
C             For optimum performance LCWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 2:  The SVD algorithm (in either LAPACK Library routine
C                   DGESVD or ZGESVD) fails to converge; this error is
C                   very rare.
C
C     METHOD
C
C     This procedure simply constructs the matrix A - jwI, and calls
C     ZGESVD if w is not zero, or DGESVD if w = 0.
C
C     FURTHER COMMENTS
C
C     This routine is not very efficient because it computes all
C     singular values, but it is very accurate. The routine is intended
C     to be called only from the SLICOT Library routine AB13FD.
C
C     CONTRIBUTOR
C
C     R. Byers, the routine SIGMIN (January, 1995).
C
C     REVISIONS
C
C     Release 4.0: V. Sima, Katholieke Univ. Leuven, Belgium, Dec. 1999.
C
C     REVISIONS
C
C     Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest.
C     Apr. 2002, V. Sima.
C
C     KEYWORDS
C
C     singular values.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION       ZERO, ONE
      PARAMETER              ( ZERO = 0.0D0, ONE = 1.0D0 )
      COMPLEX*16             CONE, RTMONE
      PARAMETER              ( CONE   = ( 1.0D0, 0.0D0 ),
     $                         RTMONE = ( 0.0D0, 1.0D0 ) )
C     .. Scalar Arguments ..
      INTEGER                INFO, LCWORK, LDA, LDWORK, N
      DOUBLE PRECISION       OMEGA
C     .. Array Arguments ..
      DOUBLE PRECISION       A(LDA,*), DWORK(*), S(*)
      COMPLEX*16             CWORK(*)
C     .. Local Scalars ..
      INTEGER                I, IC, J
C     .. Local Arrays ..
      DOUBLE PRECISION       DUMMY(1,1)
      COMPLEX*16             ZDUMMY(1,1)
C     .. External Subroutines ..
      EXTERNAL               DGESVD, XERBLA, ZGESVD
C     .. Intrinsic Functions ..
      INTRINSIC              DBLE, MAX
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDWORK.LT.MAX( 1, 5*N ) ) THEN
         INFO = -7
      ELSE IF( LCWORK.LT.1 .OR. ( OMEGA.NE.ZERO .AND.
     $         LCWORK.LT.N*N + 3*N ) ) THEN
         INFO = -9
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB03NY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         MB03NY   = ZERO
         DWORK(1) = ONE
         IF ( OMEGA.NE.ZERO )
     $      CWORK(1) = CONE
         RETURN
      END IF
C
      IF ( OMEGA.EQ.ZERO ) THEN
C
C        OMEGA = 0 allows real SVD.
C
         CALL DGESVD( 'No vectors', 'No vectors', N, N, A, N, S, DUMMY,
     $                1, DUMMY, 1, DWORK, LDWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            INFO = 2
            RETURN
         END IF
      ELSE
C
C        General case, that is complex SVD.
C
         IC = 1
         DO 20 J = 1, N
            DO 10 I = 1, N
               CWORK(IC) = A(I,J)
               IC = IC + 1
   10       CONTINUE
            CWORK((J-1)*N+J) = CWORK((J-1)*N+J) - OMEGA * RTMONE
   20    CONTINUE
         CALL ZGESVD( 'No vectors', 'No vectors', N, N, CWORK, N, S,
     $                ZDUMMY, 1, ZDUMMY, 1, CWORK(N*N+1), LCWORK-N*N,
     $                DWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            INFO = 2
            RETURN
         END IF
         CWORK(1) = CWORK(N*N+1) + DBLE( N*N ) * CONE
         DWORK(1) = DBLE( 5*N )
      END IF
C
      MB03NY = S(N)
C
C *** Last line of MB03NY ***
      END


Real Function ptor(srt)
  Parameter (pimass=0.140, arho=0.77)
  Common /ppb1/ene, factr2(6), fsum, ppinnb, s, wtot
  Common /ppmm/pprr, ppee, pppe, rpre, xopoe, rree
  Save
  s2 = srt**2
  ptor = 9*(s2-4*arho**2)/(s2-4*pimass**2)*rtop(srt)
  Return
End Function ptor


        subroutine AsIqGradV (y,       x,       shp,
     &                   shgl,    ien,
     &                   qres )
c
c----------------------------------------------------------------------
c
c This routine computes and assembles the data corresponding to the
c interior elements for the global reconstruction of the diffusive
c flux vector.
c
c input:
c     y     (numnp,ndof)        : Y variables
c     x     (numnp,nsd)         : nodal coordinates
c     shp   (nen,nintg)         : element shape-functions
c     shgl  (nsd,nen,nintg)     : element local shape-function gradients
c     ien   (npro)              : nodal connectivity array
c
c output:
c     qres  (numnp,nsd,nsd)  : residual vector for diffusive flux
c
c----------------------------------------------------------------------
c
        include "common.h"
c
        dimension y(nshg,ndof),               x(numnp,nsd),
     &            shp(nshl,ngauss),         shgl(nsd,nshl,ngauss),
     &            ien(npro,nshl),
     &            qres(nshg,nsdsq)
c
        dimension yl(npro,nshl,ndof),          xl(npro,nenl,nsd),
     &            ql(npro,nshl,nsdsq)
c
        dimension sgn(npro,nshl)
c
c.... create the matrix of mode signs for the hierarchic basis
c     functions.
c
        do i=1,nshl
           where ( ien(:,i) < 0 )
              sgn(:,i) = -one
           elsewhere
              sgn(:,i) = one
           endwhere
        enddo

c
c.... gather the variables
c

        call localy(y,      yl,     ien,    ndof,   'gather  ')
        call localx (x,      xl,     ien,    nsd,    'gather  ')
c
c.... get the element residuals
c
        ql     = zero

        call e3qGradV  (yl,         shp,      shgl,
     &             xl,         ql,
     &             sgn  )

c
c.... assemble the diffusive flux residual
c
        call local (qres,   ql,  ien,  nsdsq,  'scatter ')
c
c.... end
c
        return
        end


!-*- mode: compilation; default-directory: "/tmp/" -*-
!Compilation started at Fri Jun  7 23:39:20
!
!a=./f && make $a && $a
!gfortran -std=f2008 -Wall -fopenmp -ffree-form -fall-intrinsics -fimplicit-none f.f08 -o f
!   3   4   5
!   5  12  13
!   6   8  10
!   8  15  17
!   9  12  15
!  12  16  20
!
!Compilation finished at Fri Jun  7 23:39:20

program list_comprehension
  integer, parameter :: n = 20
  integer, parameter :: m = n*(n+1)/2
  integer :: i, j
  complex, dimension(m) :: a
  real, dimension(m) :: b
  logical, dimension(m) :: c
  integer, dimension(3, m) :: d
  a = [ ( ( cmplx(i,j), i=j,n), j=1,n) ] ! list comprehension, implicit do loop
  b = abs(a)
  c = (b .eq. int(b)) .and. (b .le. n)
  i = sum(merge(1,0,c))
  d(2,:i) = int(real(pack(a, c))) ! list comprehensions: array
  d(1,:i) = int(imag(pack(a, c))) ! assignments and operations.
  d(3,:i) = int(pack(b,c))
  print '(3i4)',d(:,:i)
end program list_comprehension


!!Generate all derivative structures of a parent structure
!!Gus L. W. Hart BYU July 2007
MODULE derivative_structure_generator
use utilities
use io_utils
use num_types
use enumeration_types
use labeling_related
use combinatorics
use symmetry
use compare_structures
use rational_mathematics
use numerical_utilities
use vector_matrix_utilities, only: determinant, matrix_inverse
use sorting
use wrapper, only: write_matrices

implicit none
private
public get_all_HNFs, remove_duplicate_lattices, get_SNF, get_all_2D_HNFs,&
     &  gen_multilattice_derivatives, find_permutation_of_group,&
     get_dvector_permutations, get_rotation_perms_lists, do_rotperms_form_groups,&
     & mixed_radix_counter

CONTAINS

  !!This routine builds a concentration table with numerators
  !!and denominators for the given cell size subject to the
  !!concentration constraints specified in cTable. GH Apr 2011 --
  !!extended the routine for multilattices
  !!<parameter name="vol" regular="true">Current size of cells in the
  !!enumeration loops.</parameter>
  !!<parameter name="nD" regular="true">Number of
  !!d-vectors.</parameter>
  !!<parameter name="concTable" regular="true">Table of desired
  !!concentration ranges</parameter>
  !!<parameter name="cList" regular="true">List of fractions that are
  !!within the ranges.</parameter>
  !!<parameter name="eps" regular="true">Finite precision
  !!tolerance.</parameter>
  SUBROUTINE get_list_at_this_size(vol,nD,concTable,cList,eps)
    integer, intent(in) :: vol, nD
    integer, intent(in) :: concTable(:,:)
    integer, pointer    :: cList(:,:) ! INTENT(OUT):
    real(dp), intent(in):: eps

    integer volTable(size(concTable,1),size(concTable,2))
    integer i, denom, minv, maxv

    do i = 1, size(concTable,1) ! Loop over the rows in the
                                ! table. There are k rows (number of
                                ! "colors")
       denom = concTable(i,3) ! Cell size of input concentration ranges
       minv = minval(concTable(i,1:2)); maxv = maxval(concTable(i,1:2))
       ! Use floor on the bottom of the range and ceiling at the top
       ! so that the resulting integers must necessarily straddle the
       ! desired concentration range. Concentrations outside the range
       ! will be eliminated by get_concentration_list
       volTable(i,1:2) = (/ floor(real(minv,dp)/denom*vol*nD), ceiling(real(maxv,dp)/denom*vol*nD) /)
       volTable(i,3) = vol*nD ! Set the denominator  of the fractions listed
       ! in the volume table to be the current size of unit cells (i.e.,
       ! the volume) being enumerated.
    enddo

    call get_concentration_list(concTable,volTable,cList,eps)

  END SUBROUTINE get_list_at_this_size

  !!This routine takes the concentration "table" from lat.in
  !!or struct_enum.in and generates a list of concentration vectors
  !!that are consistent with the ranges in the input file.
  !!<parameter name="concTable" regular="true">concentration ranges
  !!specified in the input (original)</parameter>
  !!<parameter name="volTable" regular="true">concentration ranges
  !!specified for current unit cell sizes.</parameter>
  !!<parameter name="cList">List of concentration vectors that are
  !!within the ranges.</parameter>
  !!<parameter name="eps" regular="true">Finite precision
  !!tolerance.</parameter>
  SUBROUTINE get_concentration_list(concTable,volTable,cList,eps)
    integer, intent(in) :: concTable(:,:)
    integer, intent(in) :: volTable(:,:)
    integer, pointer    :: cList(:,:)
    real(dp), intent(in):: eps

    integer j, k, i, n, cc
    integer, dimension(size(volTable,1)) :: digCnt, digit
    integer, allocatable :: label(:,:), a(:)
    real(dp), dimension(size(volTable,1)) :: minv, maxv, conc

    ! open(98,file="debug_conc_check.out",position="append")
    ! write(98,'(" Original concentration ranges:")')
    ! do i = 1, size(concTable,1)
    !    write(98,'(90(i4,1x))') concTable(i,:)
    ! enddo
    ! write(98,'(/," Numbers for given cell size:")')
    ! do i = 1, size(volTable,1)
    !    write(98,'(90(i4,1x))') volTable(i,:)
    ! enddo

    ! Imagine an odometer with n wheels, each which has a sequence of
    ! labels (the allowed labels for that atomic site). We'll turn the
    ! wheels on this odometer and keep a list of those reading that
    ! are consistent with (don't violate) the concentration
    ! restrictions.
    n = volTable(1,3) ! Total number of slots in the labeling
    digit = volTable(:,2) - volTable(:,1) + 1 ! Number of "labels" on
    ! each "wheel" of the odometer
    digCnt = 1 ! Start each wheel of the odometer at the first position
    k = size(volTable,1) ! Number of labels, i.e., number of wheels on
    ! the odometer (i.e, the number of atom types)
    allocate(cList(product(digit),k))
    allocate(a(k))  ! The reading on the "odometer"

    ! Define a table that stores the possible labels for each wheel
    allocate(label(size(volTable,1),maxval(digit)))
    label = -1 ! Ends of the rows in this ragged list Paint the labels
    ! on the wheels (leave -1 for wheels that have more positions than
    ! valid labels for that site)
    do j = 1, k
       label(j,:) = (/(i,i=volTable(j,1),volTable(j,2))/)
       minv(j) = real(minval((/concTable(j,1),concTable(j,2)/)),dp)/concTable(j,3)
       maxv(j) = real(maxval((/concTable(j,1),concTable(j,2)/)),dp)/concTable(j,3)
    enddo
    ! Initialize the reading, "a", to the beginning
    forall(j=1:k);a(j)=label(j,1);endforall

    cc = 0 ! number of valid concentrations
    do
       !write(98,'(10(i1,1x))') a
       if (sum(a)==n) then ! This "reading" is a valid partition, i.e., cell size is correct
          conc = a/real(n,dp)
          if (.not. ( any(conc<minv-eps) .or. any(conc>maxv+eps) )) then
             cc = cc + 1 ! Keep track of the number of valid concentration vectors
             cList(cc,:) = a ! Store this in the list
          endif
       endif
       j = k  ! Start at the right end of the digit list, j is the digit pointer
       do
          if (digCnt(j) /= digit(j)) exit ! Is this wheel ready to roll over? No then exit
          a(j) = label(j,1) ! Reset this wheel to the first label
          digCnt(j) = 1     ! Reset the counter for this wheel
          j = j - 1         ! Look to the next wheel to the left
          if (j < 1) exit   ! If the whole odometer is ready to roll over the we are done
       enddo
       if (j < 1) exit ! All the numbers have been visited
       digCnt(j) = digCnt(j) + 1 ! Advance this wheel
       a(j) = label(j,digCnt(j)) ! Put the appropriate label in the j-th spot
    enddo
    cList => ralloc(cList,cc,k) ! Reallocate the list to be the proper size
    ! write(98,'(/," Number of discrete partitions: ",i5)') size(cList,1)
    ! write(98,'(/," generated list:")')
    ! do i = 1, size(cList,1)
    !    write(98,'(10(i4,1x))') cList(i,:)
    ! enddo
    ! close(98)

  END SUBROUTINE get_concentration_list

  !!Just a test routine for expanding the code to treat
  !!different label sets on different sites. This is just a counter of
  !!mixed radix form.
  !!<parameter name="labels" regular="true">Second index is the digit
  !!#, first is the label #.</parameter>
  !!<parameter name="digit" regular="true">List of the upper bound of
  !!each digit.</parameter>
  SUBROUTINE mixed_radix_counter(labels,digit)
    integer labels(:,:)
    integer digit(:)
    integer a(size(digit)), counter(size(digit)) ! The odometer; ordinal counter for each digit
    integer i,ic,j,n,ilab, quot
    integer nUq ! number of unique numbers possible in this mixed radix system
    integer multiplier(size(digit)), digIdx(size(digit)), temp(1), b(size(digit)), idx

    n = size(digit) ! Number of sites
    counter = 1

    ! Find the total number of numbers that the mixed radix system can represent
    nUq = product(digit) !;print *," Number of mixed-radix numbers",nUq

    multiplier = 0; multiplier(n)=1
    do i = n-1,1,-1
       multiplier(i) = digit(i+1)*multiplier(i+1)
    enddo
    write(*,'("Multiplier: ",20i6)') multiplier

    a = labels(1,:)
    write(*,'("Starting value: ",10i2)') a
    print *," Number of digits",n
    counter(n) = 0; ic = 0
    do; ic = ic + 1
       if(ic > nUq + 1) stop "Fail safe triggered. Wrong number of iterations in mixed-radix counterem"
       j = n ! Reset the digit index; start with j = the last place in the number
       do !;print *, "inner loop"
          if (counter(j) /= digit(j)) exit ! The digit isn't ready to
          ! roll over, so exit and advance it
          counter(j) = 1     ! Roll back j-th digit to the beginning
          j = j - 1          ! Move to the next (on the left) digit
          if (j < 1) exit    ! Leftmost digit updated, we've finished all the numbers
       enddo
       if (j < 1) exit  ! We're done counting, exit
       counter(j) = counter(j) + 1
       forall(i=1:n); a(i) = labels(counter(i),i);endforall
       do i=1,n; temp = minloc(labels(:,i),a(i)==labels(:,i)) - 1; digIdx(i) = temp(1) ;enddo
       idx = sum(digIdx*multiplier)
       idx = sum((counter-1)*multiplier)
       write(*,'(i6,":",2x,10i2)',advance="no") ic,counter
       write(*,'(i10,1x)',advance="no") idx
       write(*,'(3x,10i2)',advance="no") a
       write(*,'(3x,10i2)',advance="no") digIdx
       do ilab = 1, n ! Loop over each place (digit) in the labeling
          quot = idx/multiplier(ilab) ! divide the index by next highest multiplier
          b(ilab) = labels(quot+1,ilab) ! store the quotient (indexed to labels)
          idx = idx - quot*multiplier(ilab) ! find the remainder
       enddo
       write(*,'(3x,10i2)') b
    enddo
  END SUBROUTINE mixed_radix_counter

  !!This function checks that every "product" of two
  !!permutations in a list is still in the list. That is that every
  !!list forms a group. For finite groups, this is a sufficient
  !!condition.
  !!<parameter name="rpl" regular="true">The reduced (unique) set of
  !!rotation permutations lists for a given index</parameter>
  FUNCTION do_rotperms_form_groups(rpl)
    logical do_rotperms_form_groups
    type(RotPermList) :: rpl(:)

    integer nL, iL, iP, jP, nP, kP, ng
    logical exists
    integer, allocatable :: testperm(:)

    nL = size(rpl) ! Number of lists
    ng = size(rpl(1)%perm,2) ! Number of elements in each permutations
    allocate(testperm(ng))

    do_rotperms_form_groups = .true.
    lists: do iL = 1, nL ! Check each list in the set
       nP = size(rpl(iL)%perm,1) ! Number of permutations in this list
       write(11,'(3x)',advance="no")
       do iP = 1, nP; write(11,'(i3)',advance="no") iP; enddo; write(11,*) ! Make
       ! the column headings
       perms:   do iP = 1, nP
          write(11,'(i3)',advance="no") iP   ! Write the row heading
          !do jP = 1, nP; write(11,'(3x)',advance='no');enddo ! skip to the column
          do jP = 1, nP ! Now loop over all products for the iP'th permutation
             exists = .false.
             ! Is the product of perm_i x perm_j in the set?  Permute
             ! the elements of the iP'th permutation according to the
             ! jP'th permutation
             testperm = rpl(iL)%perm(iP,rpl(iL)%perm(jP,:))
             do kP = 1, nP
                if (all(testperm==rpl(iL)%perm(kp,:))) then
                   exists = .true.
                   write(11,'(i3)',advance="no") kP
                   exit
                endif
             enddo
             if (.not. exists) then

                write(11,'(/,"The set of permutations doesn''t form a group")')
                write(11,'("failed at ",2i3)')  jP, iP
                write(11,'("testperm ",20i2,/)') testperm
                write(11,'("permlist ",8i2)') transpose(rpl(iL)%perm)
                !write(*,'(20i2,/)') testperm
                print *
                !do itest = 1,nP
                !   write(*,'(20i2)') rpl(iL)%perm(itest,:)
                !enddo
                do_rotperms_form_groups = .false.
                !exit lists
                exit perms
             endif
          enddo
          write(11,*)
       enddo perms
       if (exists)write(11,*) iL,"The permutations form a group"
       if(.not. exists) write(11,*) iL,"failed"
    enddo lists ! Loop over lists
    !if(exists) then; do_rotperms_form_groups = .true.
    !else; do_rotperms_form_groups = .false.
    !endif
  ENDFUNCTION do_rotperms_form_groups

  !!This routine takes a list of permutation lists and
  !!identifies those that are idential. The output, RPLindx, is an
  !!index that groups the lists that match. The lists themselves are
  !!assumed to be in "alphabetical" order so that they can be quickly
  !!compared. I don't think it's necessary to explicitly treat lists
  !!corresponding to different SNFs separately---if the permutations
  !!lists happen to be identical (is this possible?) then the
  !!labelings list will also be, so it's not necessary to create a
  !!separate list or index for them.
  !!<parameter name="RPLists" regular="true"></parameter>
  !!<parameter name="rdRPList" regular="true"></parameter>
  !!<parameter name="RPLindx" regular="true"></parameter>
  SUBROUTINE organize_rotperm_lists(RPList,rdRPList,RPLindx)
    type(RotPermList), intent(in) :: RPList(:)
    type(RotPermList), pointer :: rdRPList(:) ! output
    integer, pointer :: RPLindx(:) ! output

    integer iL, jL, nL, status,  cnt, nP
    type(RotPermList), allocatable :: tList(:)
    logical unique

    nL = size(RPlist) ! Number of lists (including duplicates)
    allocate(tList(nL),RPLindx(nL),STAT=status)
    if(status/=0) stop "Allocation failed in organize_rotperm_lists: tList, RPLindx"

    cnt = 0
    do iL = 1, nL ! Loop over each loop in the list
       unique = .true.
       do jL = 1, cnt ! Loop over the number of unique lists found so far
          ! if the two lists aren't the same length, then they definitely aren't identical
          if (size(RPList(iL)%perm,1)/=size(tList(jL)%perm,1)) cycle
          if (all(RPList(iL)%perm==tList(jL)%perm)) then ! they're
          !identical. Tag it and go to next
             unique = .false.
             exit
          endif
       enddo
       if (unique) then ! store this list in the master list
          cnt = cnt + 1 ! number of unique lists found so far
          nP = size(RPList(iL)%perm,1) ! Number of perms in this list
          allocate(tList(cnt)%perm(nP,size(RPList(iL)%perm,2)))
          tList(cnt)%nL = nP ! store number and perms in a temporary
          tList(cnt)%perm = RPlist(iL)%perm ! array
       endif
       ! Store the label for this unique list in the output index
       RPLindx(iL) = jL
    enddo
    ! Now copy the reduced list to the output variable
    allocate(rdRPList(cnt))
    do iL=1,cnt
       nL = size(tList(iL)%perm,1)
       allocate(rdRPList(iL)%perm(nl,size(tList(iL)%perm,2)));
       rdRPList(iL)%nL = nL
       rdRPList(iL)%perm = tList(iL)%perm
    enddo
  ENDSUBROUTINE organize_rotperm_lists

  !!This routine applies the symmetry operations of the
  !!parent lattice to the interior points (i.e., the d-set) to see
  !!which ones are equivalent. Labelings of the lattice points that
  !!are contain permutations only of labels on equivalant sites are
  !!physically equivalent and therefore redundant. We use these
  !!permutations to eliminate those duplicate labelings.
  !!<parameter name="pLV" regular="true">Lattice vectors of the
  !!primary lattice (parent lattice).</parameter>
  !!<parameter name="pd">d-vectors defining the multilattice (primary
  !!lattice only).</parameter>
  !!<parameter name="dRPList" regular="true">Output. A list
  !!permutations effected by the Ops.</parameter>
  !!<parameter name="Latdim" regular="true">2 or 3 dimensional
  !!case?</parameter>
  !!<parameter name="eps" regular="true">Finite precision
  !!tolerance.</parameter>
  SUBROUTINE get_dvector_permutations(pLV,pd,dRPList,LatDim,eps)
    real(dp) :: pLV(3,3)
    real(dp), pointer :: pd(:,:)
    type(RotPermList), intent(out) :: dRPList
    integer, intent(in) :: LatDim
    real(dp), intent(in) :: eps

    integer nD, iD, nOp, iOp, status
    integer, pointer :: aTyp(:), tList(:,:)
    real(dp) :: rd(size(pd,1),size(pd,2)), tRD(size(pd,1),size(pd,2))
    real(dp) :: inv_pLV(3,3) ! Inverse of the pLV matrix
    real(dp), pointer:: rot(:,:,:), shift(:,:), tv(:,:,:)
    logical err
    character(80) name
    nD = size(pd,2)
    allocate(aTyp(nD),STAT=status)
    if(status/=0)stop "Allocation failed in get_dvector_permutations: aTyp"

    aTyp = 1
    call get_spaceGroup(pLV,aTyp,pd,rot,shift,.false.,eps)

    !call write_lattice_symmetry_ops(rot,shift)
    if(latDim==2) call rm_3D_operations(pLV,rot,shift,eps)
    !call write_lattice_symmetry_ops(rot,shift,"2D")
    nOp = size(rot,3)
    allocate(tList(nOp,nD),tv(3,nD,nOp),STAT=status)
    if(status/=0)stop "Allocation failed in get_dvector_permutations: tList"
    allocate(dRPList%perm(nOp,nD),dRPList%v(3,nD,nOp),STAT=status)
    if(status/=0)stop "Allocation failed in get_dvector_permutations: dRPList"

    call matrix_inverse(pLV,inv_pLV,err)
    if (err) stop "Bad parent lattice vectors in input to get_dvector_permutations"

    dRPList%nL = nOp  ! Number of operations that fix the parent
    !lattice (but may permute the d-vectors)

    do iOp = 1, nOp ! Try each operation in turn and see how the
                    ! d-vectors are permuted for each
       rd = matmul(rot(:,:,iOp),pd)+spread(shift(:,iOp),2,nD) ! Rotate each d and add the shift
       tRD = rd
       do iD = 1, nD
          call bring_into_cell(rd(:,iD),inv_pLV,pLV,eps)
       enddo

       ! The v vector is the vector that must be added (it's a lattice
       ! vector) to move a rotated d-vector back into the parent cell.
       dRPList%v(:,:,iOp) = rd(:,:) - tRD(:,:)
       call map_dvector_permutation(rd,pd,dRPList%perm(iOp,:),eps)
    enddo
    ! name = "debug_dvec_rots.out"
    ! call write_rotperms_list(dRPList,name)

    ! I don't think we should reduce this list to a unique one. Some
    ! rotations that don't permute the d's could still permute the
    ! g's. So we have to keep all the d permutations, even if they
    ! look redundant here.

  ENDSUBROUTINE get_dvector_permutations

  !!For each HNF, we have a list of the operations (rotations
  !!+ shifts, if present) that leave the superlattice fixed. Given
  !!this set of fixing operations, make a list of the permutations on
  !!the d-vectors (interior points of the multilattice) effected by
  !!the rotations. Then sort the HNFs into blocks that have the same
  !!rotation permutations.
  !!<parameter name="A" regular="true">Lattice vectors of the primary
  !!lattice (parent lattice).</parameter>
  !!<parameter name="HNF" regular="true">List of HNF
  !!matrices.</parameter>
  !!<parameter name="L" regular="true">List of left
  !!transforms.</parameter>
  !!<parameter name="SNF" regular="true">List of SNF
  !!matrices.</parameter>
  !!<parameter name="Op" regular="true">A list of symmetry ops (rots
  !!and shifts) for the parent multilattice</parameter>
  !!<parameter name="RPList" regular="true">A list of lists of
  !!permutations effected by the Ops.</parameter>
  !!<parameter name="dperms" regular="true"></parameter>
  !!<parameter name="eps" regular="true">Finite precision
  !!tolerance.</parameter>
  SUBROUTINE get_rotation_perms_lists(A,HNF,L,SNF,Op,RPlist,dperms,eps)
    real(dp), intent(in) :: A(3,3)
    integer, intent(in), dimension(:,:,:) :: HNF, L, SNF
    type(OpList), intent(in) :: Op(:)
    type(RotPermList) :: RPlist(:)
    type(RotPermList), intent(in) :: dperms
    real(dp), intent(in) :: eps
    type(RotPermList) :: rperms, tperms
    integer, pointer :: g(:,:) => null()
    integer, allocatable :: gp(:,:), dgp(:,:) ! G prime; the "rotated"
    ! group, (d',g') "rotated" table
    integer, allocatable :: tg(:,:), perm(:), ident(:,:), identT(:,:) ! translated
    ! group, translation permutation of the group members
    integer iH, nH, diag(3), iD, nD, iOp, nOp, n, ig, it, status, im, jm
    real(dp), dimension(3,3) :: Ainv, T, Tinv
    logical err
    real(dp), allocatable :: rgp(:,:)
    logical, allocatable :: skip(:)
    integer OpIndxInSuperCellList, RowInDxGTable

    ! open(19,file="debug_get_rotation_perms_lists.out")

    ! Number of HNFs (superlattices); Index of the superlattices;
    ! Number of d-vectors in d set
    nH = size(HNF,3); n = determinant(HNF(:,:,1)); nD = size(RPList(1)%v,2)
    allocate(gp(3,n), dgp(nD,n), rgp(3,n),skip(n),STAT=status)
    if(status/=0) stop "Allocation failed in get_rotation_perm_lists: gp, dgp, rgp, skip"
    allocate(tg(3,n),perm(n),ident(nD,n),identT(n,nD),STAT=status)
    if(status/=0) stop "Allocation failed in get_rotation_perm_lists: tg, perm, ident"
    allocate(tperms%perm(n,n*nD))
    identT = reshape((/(ig,ig=1,n*nD)/),(/n,nD/))  ! we could combine
    ! those two lines, but gfortran
    ident  = transpose(identT)                     ! does some strange things then.
    forall(iH = 1:nH); RPlist(iH)%nL=0; end forall ! initialize the number in each list

    ! Make the group member list for the first SNF
    diag = (/SNF(1,1,1),SNF(2,2,1),SNF(3,3,1)/)
    call make_member_list(diag,g)
    call matrix_inverse(A,Ainv,err)
    if(err) stop "Invalid parent lattice vectors in get_rotation_perm_lists"

    do iH = 1,nH ! loop over each superlattice unless the SNF is
   ! different than the previous (they should be sorted into blocks)
   ! don't bother making the group again. Just use the same one.
       if(iH > 1) then; if(.not. all(SNF(:,:,ih)==SNF(:,:,ih-1))) then
          diag = (/SNF(1,1,ih),SNF(2,2,ih),SNF(3,3,ih)/)
          call make_member_list(diag,g)
       endif; endif
       ! Make the transform matrices for taking the g's and rotating them
       Tinv = matmul(L(:,:,iH),Ainv); call matrix_inverse(Tinv, T, err)
       if (err) stop "Bad inverse for transformation matrix: get_rotation_perm_lists"

       nOp = size(Op(iH)%rot,3);
       if (associated(rperms%perm)) deallocate(rperms%perm)
       !print *,nop,nd,n;stop
       allocate(rperms%perm(nOp,nD*n),STAT=status)
       if (status/=0) stop "Allocation failed in get_rotation_perm_lists: rperms%perm"
       do iOp = 1, nOp ! For each rotation, find the permutation
          dgp = 0 ! Initialize the (d,g) table
          do iD = 1, nD ! Loop over each row in the (d,g) table
             ! LA^-1(v_i+(RAL^-1)G)
             rgp = matmul(Tinv,(-spread(RPList(iH)%v(:,iD,iOp),2,n)+matmul(matmul(Op(iH)%rot(:,:,iOp),T),g)))
             if (.not. equal(rgp,nint(rgp),eps)) stop "Transform left big fractional parts"
             gp = nint(rgp) ! Move the rotated group into an integer array
             gp = modulo(gp,spread(diag,2,n)) ! Mod by each entry of
             ! the SNF to bring into group Now that the rotated group
             ! is known, find the mapping of the elements between the
             ! original group and the permuted group. This is the
             ! permutation.
             skip = .false. ! This is just for efficiency
             do im = 1, n
                do jm = 1, n
                   if (skip(jm)) cycle ! Skip elements whose mapping is already known
                   if (all(gp(:,jm)==g(:,im))) then ! these elements
                   ! map to each other The list of operations that fix
                   ! the superlattice are a subset of those that fix
                   ! the parent lattice. RotIndx stores the indicies
                   ! of the parent lattice operations in a list with
                   ! as many entries as supercell fixing operations.

                   ! dperms%perm stores a list of d-vector
                   ! permutations, one permutation (an nD list) for
                   ! each operation in the parent lattice symmetries
                      OpIndxInSuperCellList = RPList(iH)%RotIndx(iOp)
                      RowInDxGTable = dperms%perm(OpIndxInSuperCellList,iD)
                      dgp(RowInDxGTable,im) = jm+(iD-1)*n
                      skip(jm) = .true.
                      exit
                   endif
                enddo ! jm
             enddo ! im
          enddo ! loop over d-vectors (each row in the table)
          if (any(dgp==0)) stop "(d,g)-->(d',g') mapping failed in get_rotation_perm_lists"

          ! Now we have the (d',g') table for this rotation. Now
          ! record the permutation
          rperms%perm(iOp,:) = reshape(transpose(dgp),(/nD*n/)) ! store
          ! permutation in the "long form"
          rperms%nL = nOp
          !write(*,'(i2,1x,20i2)')iOp,rperms%perm(iOp,:)
          !write(*,'("nL",1x,20i2)')rperms%nL
       enddo ! loop over rotations

       ! nomenclature:
       ! N+t = rotation (N) + fractional translation (t)  (me bethinks....)
       !   r = lattice translation

       ! Now that we have the permutations that are effected by N+t
       ! type of rotations (for each N in the point group), we need to
       ! compose them with the permutations effected by lattice
       ! translations, (parent) lattice translations contained inside the
       ! supercell (N+t+r, in Rod's nomenclature). Only when we have these
       ! two lists, and compose them, do we have a guarantee that the
       ! resulting list is actually a group. For efficiency, we reduce the
       ! N+t list (remove duplicates). Rod claims that the compositions
       ! (with the translations) will not have duplicates.
       if (size(rperms%perm,1) > 1) &
            call sort_permutations_list(rperms%perm)
       ! The rotations permutations list is now in "alphabetical"
       ! order and contains no duplicates

       ! To get the permutations effected by the r's, we don't need
       ! the r's. We can merely take the member list, the group, and
       ! add each element of the group to the group itself and see
       ! what permutation happens. (This part is somewhat redundant
       ! with make_translation_group in labeling_related module.)
       do ig = 1,n ! The number of r's inside the superlattice (the
                   ! translation perms) is the same as the index n
          tg = g(:,:)+spread(g(:,ig),2,n) ! Add the element to the group
          tg = modulo(tg,spread(diag,2,n)) ! mod by the SNF entries to
          ! bring it back to the "primitive" representation
          call find_permutation_of_group(g,tg,perm)
          tperms%perm(ig,:) = reshape(transpose(ident(:,perm)),(/n*nD/))
       enddo

       RPlist(iH)%nL = size(rperms%perm,1)*n
       allocate(RPlist(iH)%perm(RPlist(iH)%nL,n*nD)) ! nL rows and n*nD columns in the list
       do it = 1,n ! Loop over translation perms (r type)
          do iOp = 1,size(rperms%perm,1) ! Loop over unique rotation
             ! perms (N+t type) Form the permutation effected by
             ! composing the iOp-th one with the it-th one
             RPlist(iH)%perm((iOp-1)*n+it,:) = tperms%perm(it,(rperms%perm(iOp,:)))
             ! ^--- Having gotten both the rotations and the
         ! translation in the sections above (sort_permutations_list
         ! etc...), the "operators" of the rotation (one of them is
         ! R_i) and the translations (one of them is T_j) are now
         ! "scrambled", i.e., (T_j) o (R_i).  Since the *first*
         ! Rotation R_1 = Id, the *first* entries in the
         ! RPlist(iH)%perm are equivalent to pure translations only.
         ! The following entries are a combination of both.
          enddo
       enddo
    enddo ! loop over iH (superlattices)
    ! close(19)
  ENDSUBROUTINE get_rotation_perms_lists

  !!
  !!<parameter name="g" regular="true">Unpermuted groups.</parameter>
  !!<parameter name="gp" regular="true">Permuted groups.</parameter>
  !!<parameter name="perm" regular="true">Permutation of gp.</parameter>
  SUBROUTINE find_permutation_of_group(g,gp,perm)
    integer, intent(in), dimension(:,:) :: g, gp
    integer, intent(out) :: perm(:)

    integer n ! number of elements in the group (index of the superlattice)
    logical skip(size(g,2))
    integer im, jm

    n = size(g,2); perm = 0
    skip = .false. ! This is just for efficiency
    do im = 1, n
       do jm = 1, n
          if (skip(jm)) cycle ! This is just for efficiency
          if (all(gp(:,jm)==g(:,im))) then
             perm(im) = jm
             skip(jm) = .true.
             exit ! don't keep looking if you already found the match
          endif
       enddo ! jm
    enddo ! im
    !write (*,'(30i3)') perm
    if (any(perm==0)) stop "mapping failed in find_permutation_of_group"
  ENDSUBROUTINE find_permutation_of_group

  !!
  !!<parameter name="rd" regular="true">Rotated d's</parameter>
  !!<parameter name="d" regular="true">Original d.</parameter>
  !!<parameter name="RP" regular="true">Permutation of the quotient
  !!group effected by the rotation.</parameter>
  !!<parameter name="eps" regular="true">Finite precision tolerance.</parameter>
  SUBROUTINE map_dvector_permutation(rd,d,RP,eps)
    real(dp), dimension(:,:) :: rd, d ! (both input)
    integer :: RP(:) !(output)
    real(dp), intent(in) :: eps

    integer iD, jD, nD
    logical found(size(RP))

    RP = 0; found = .false.
    nD = size(rd,2) ! # of d-vectors

    do iD = 1, nD
       do jD = 1, nD
          if(found(jD)) cycle
          if(equal(rd(:,iD),d(:,jD),eps)) then
             RP(iD)=jD
             found(jD) = .true.
             exit
          endif
       enddo
    enddo
    if(any(RP==0)) then; print *, "d-vector didn't permute in map_dvector_permutation";
       print *,"This usually means that the d-set from the input structure and the d-set"
       print *,"from the struct_enum.out have a different origin or don't live in the same"
       print *,"unit cell. This probably isn't your fault---the code should overcome this."
       write(*,'(200(i2,1x))') RP
    stop;endif
  ENDSUBROUTINE map_dvector_permutation

  !!Finds all the possible diagonals of the HNF matrices of a
  !!given size
  !!<parameter name="detS" regular="true">Cell size, i.e., determinant
  !!of S matrix.</parameter>
  !!<parameter name="diagonals">All possible diagonals.</parameter>
  SUBROUTINE get_HNF_diagonals(detS, diagonals)
    integer, intent(in) :: detS
    integer, pointer :: diagonals(:,:)

    integer i, j, id, quotient, status
    integer :: tempDiag(3,detS*3)

    id = 0 ! Number of diagonals found
    do i = 1,detS ! Loop over possible first factors
       if (.not. mod(detS,i)==0) cycle
       quotient = detS/i
       do j = 1,quotient  ! Loop over possible second/third factors
          if (.not. mod(quotient,j)==0) cycle
          id = id + 1
          tempDiag(:,id) = (/i, j, quotient/j /) ! Construct the factor triplet
       enddo
    enddo
    allocate(diagonals(3,id),STAT=status)
    if(status/=0) stop "Allocation failed in get_HNF_diagonals, module deriv..."
    diagonals = tempDiag(:,1:id)
  END SUBROUTINE get_HNF_diagonals

  !!This subroutine generates all the unique HNF matrices of
  !!a given determinant. (See Santoro and Mighell 1972
  !!Acta. Cryst.)
  !!<parameter name="volume" regular="true"></parameter>
  !!<parameter name="hnf"></parameter>
  SUBROUTINE get_all_HNFs(volume,hnf)
    integer, intent(in) :: volume
    integer, pointer:: hnf(:,:,:)

    integer, pointer    :: d(:,:) => null()
    integer             :: i, j, k, l    ! Loop counters
    integer             :: N, Nhnf, ihnf ! # of triplets, # of HNF matrices, HNF counter
    integer status
    call get_HNF_diagonals(volume,d)
    N = size(d,2)

    ! Count the total number of HNF matrices for given determinant (volume)
    Nhnf = 0
    do i = 1,N
       Nhnf = Nhnf + d(2,i)*d(3,i)**2
    enddo

    allocate(hnf(3,3,Nhnf),STAT=status)
    if(status/=0) stop "Failed to allocate memory in get_all_HNFs"
    ihnf = 0
    do i = 1,N ! Loop over the permutations of the diagonal elements of the HFNs
       do j = 0,d(2,i)-1  ! Look over possible values of row 2, element 1
          do k = 0,d(3,i)-1  ! Ditto for row 3, element 1
             do l = 0,d(3,i)-1  ! Ditto for row 3, element 2
                ihnf = ihnf+1 ! Count the HNFs and construct the next one
                hnf(:,:,ihnf) = reshape((/ d(1,i),      j,     k,        &
                     0, d(2,i),     l,        &
                     0,      0, d(3,i)  /), (/3,3/))
       enddo;enddo;enddo  ! End loops over values for off-diagonal elements
    enddo ! End loop over all unique triplets of target determinant (volume)

    if (ihnf /= Nhnf) stop "HNF: not all the matrices were generated...(bug!)"
  END SUBROUTINE get_all_HNFs

  !!Find all the SNFs of a group of HNFs. A and B are the
  !!transformation matrices. F is a list of the *unique*
  !!SNFs. SNF_label indicates which of the unique SNFs corresponds to
  !!each HNF. The transformations, SNFs, and labels are ordered on
  !!output into blocks of identical SNFs.
  !!<parameter name="HNF">List of HNFs.</parameter>
  !!<parameter name="A"></parameter>
  !!<parameter name="SNF"></parameter>
  !!<parameter name="B"></parameter>
  !!<parameter name="RPList">List of rotation permutations for each HNF.</parameter>
  !!<parameter name="F"></parameter>
  !!<parameter name="SNF_label"></parameter>
  !!<parameter name="fixing_op" regular="true">List of operations that
  !!fix each HNF.</parameter>
  SUBROUTINE get_SNF(HNF,A,SNF,B,RPList,F,SNF_label,fixing_op)
    integer, pointer :: HNF(:,:,:), SNF_label(:) ! HNF is an input list
    integer, pointer, dimension(:,:,:) :: A, SNF, B, F ! All these are output lists
    type(opList) :: fixing_op(:)
    type(RotPermList) :: RPList(:)

    integer :: indx(size(HNF,3))
    integer ihnf, nHNF, nfound, ifound, status, ic, jc, i
    logical duplicate
    integer, allocatable, dimension(:,:,:) :: tF

    nHNF = size(HNF,3)
    nfound = 0
    allocate(A(3,3,nHNF),B(3,3,nHNF),SNF(3,3,nHNF),tF(3,3,nHNF),SNF_label(nHNF),STAT=status)
    if(status/=0) stop "Failed to allocate memory in get_SNF"

    do ihnf = 1, nHNF ! Loop over each HNF in the list
       call SmithNormalForm(HNF(:,:,ihnf),A(:,:,ihnf),SNF(:,:,ihnf),B(:,:,ihnf))
       duplicate = .false.
       do ifound = 1,nfound ! Check to see if this SNF is unique or a duplicate.
          if (all(SNF(:,:,ihnf)==tF(:,:,ifound))) then
             duplicate = .true.; SNF_label(ihnf) = ifound; exit; endif
       enddo
       if (.not. duplicate) then ! store this SNF in the unique list
          nfound = nfound + 1
          tF(:,:,nfound) = SNF(:,:,ihnf)
          SNF_label(ihnf) = nfound
       endif
    enddo

    ! We have all the SNFs now, as well as the transformations. But
    ! they are not in any kind of order. Rearrange the
    ! transformations, labels, and HNFs so that they are in blocks of
    ! matching SNFs
    ic = 1; jc = 0
    do ifound = 1, nfound
       jc = count(SNF_label==ifound) ! How many HNFs have this SNF?
       indx(ic:ic+jc-1) = pack((/(i,i=1,nHNF)/),SNF_label==ifound) ! Get
       ! the index of each matching case
       ic = ic + jc ! Compute the offset where the index is stored
    enddo

    ! Use the computed order index, indx, to reorder the A, B, and SNF matrices
    HNF = HNF(1:3,1:3,indx)
    SNF = SNF(1:3,1:3,indx)
    A = A(1:3,1:3,indx)
    B = B(1:3,1:3,indx)
    SNF_label = SNF_label(indx) ! Reorder the labels for which SNF each HNF is
    fixing_op = fixing_op(indx)
    RPList = RPList(indx) ! Reorders the permutations lists

    ! Fail safe trigger and storage of unique SNFs
    if (ic/=nHNF+1) stop "SNF sort in get_SNF didn't work"
    !if (associated(F)) deallocate(F). This is unnecessary because F
    !should only be allocated here and it only happens once in each
    !call to gen_multilattice_derivatives
    allocate(F(3,3,nfound),STAT=status)
    if(status/=0) stop "Failed to allocate memory in get_SNF for array F"
    F = tF(:,:,1:nfound)

  ENDSUBROUTINE get_SNF

  !!Takes a bunch of HNF matrices and a parent lattice and
  !!removes those that are rotationally equivalent (under the
  !!rotations of the parent lattice). Also returns all the unique
  !!derivative _lattices_ for this parent. Also returns a list of
  !!rotations that fix each superlattice.
  !!<parameter name="hnf">HNF matrices.</parameter>
  !!<parameter name="LatDim" regular="true">Is the parent lattice 2D
  !!or 3D?</parameter>
  !!<parameter name="parent_lattice" regular="true">Parent
  !!lattice.</parameter>
  !!<parameter name="d"></parameter>
  !!<parameter name="dperms" regular="true"></parameter>
  !!<parameter name="uq_hnf">List of symmetrically distinct
  !!HNFs.</parameter>
  !!<parameter name="fixing_op" regular="true">List of operations that
  !!fix each HNF.</parameter>
  !!<parameter name="RPList"></parameter>
  !!<parameter name="latts"></parameter>
  !!<parameter name="degeneracy_list" regular="true"></parameter>
  !!<parameter name="eps" regular="true">Finite precision tolerance.</parameter>
  SUBROUTINE remove_duplicate_lattices(hnf,LatDim,parent_lattice,d,dperms,uq_hnf,fixing_op,RPList,latts,degeneracy_list,eps)
    integer, pointer :: hnf(:,:,:) ! (input)
    integer :: LatDim
    real(dp), intent(in) :: parent_lattice(3,3) ! parent lattice (input)
    integer, pointer     :: degeneracy_list(:)
    integer, pointer :: uq_hnf(:,:,:) ! (output)
    type(opList), pointer :: fixing_op(:)
    real(dp),intent(in):: eps ! finite precision (input)
    real(dp), pointer :: d(:,:)
    type(RotPermList), intent(in) :: dperms
    type(RotPermList), pointer :: RPList(:)
    real(dp), pointer :: latts(:,:,:)
    !integer, intent(in)  :: label(:,:), digit(:)

    real(dp), pointer:: sgrots(:,:,:), sgshift(:,:)
    real(dp), dimension(3,3) :: test_latticei, test_latticej
    integer i, Nhnf, iuq, irot, j, nRot, Nq, status, nD
    integer, allocatable :: temp_hnf(:,:,:)
    logical duplicate
    integer, pointer :: aTyp(:)

    nD = size(d,2)
    allocate(aTyp(nD),STAT=status)
    if(status/=0)stop "Allocation failed in remove_duplicate_lattices: aTyp"

    aTyp = 1
    ! Let the code apply all the symmetries and then eliminate invalid
    !  labelings (the counter won't generate any but they may appear
    !  after the symmetry has been applied to a legal one). In other
    !  words, don't try and restrict the set of symmetries (at this
    !  point) but the set of labels that can be applied to any
    !  particular site.  call
    !  get_spaceGroup_atomTypes(label,digit,aTyp)
    call get_spaceGroup(parent_lattice,aTyp,d,sgrots,sgshift,.false.,eps)
    nRot = size(sgrots,3)
    Nhnf = size(hnf,3)
    allocate(temp_hnf(3,3,Nhnf),STAT=status)

    if(status/=0) stop "Failed to allocate memory in remove_duplicate_lattices: temp_hnf"
    temp_hnf = hnf
    call write_lattice_symmetry_ops(sgrots,sgshift)

    ! for the 2D case, eliminate the "3D" operations.

    if (LatDim==2) then
       call rm_3d_operations(parent_lattice,sgrots,sgshift,eps)
       nRot = size(sgrots,3)
       call write_lattice_symmetry_ops(sgrots,sgshift,"2D")
    endif
    ! For each HNF in the list, see if it is a derivative lattice of a
    ! preceding HNF in the list. If so, don't include it in the list
    ! of unique ones.
    iuq = 1
    do i = 2,Nhnf  ! Loop over each matrix in the original list
       duplicate = .false.
       do j = 1,iuq! Loop over the known unique matrices (in the updated list)
          do irot = 1, nRot! The duplicates will always be rotated from
             ! the original (otherwise necessarily unique)
             test_latticei = matmul(sgrots(:,:,irot),matmul(parent_lattice,hnf(:,:,i)))
             test_latticej = matmul(parent_lattice,temp_hnf(:,:,j))

             if (is_equiv_lattice(test_latticei,test_latticej,eps)) then
                duplicate = .true.;exit;endif
          enddo
       enddo
       if (.not. duplicate) then ! No duplicate found---add this to the unique list
          iuq = iuq+1
          temp_hnf(:,:,iuq) = hnf(:,:,i)
       endif

    enddo

    allocate(uq_hnf(3,3,iuq),latts(3,3,iuq),RPList(iuq),STAT=status)
    if(status/=0) stop "Failed to allocate uq_hnf/latts in remove_duplicate_lattices: uq_hnf"
    uq_hnf = temp_hnf(:,:,:iuq)
    Nq = iuq
    forall (i=1:Nq); latts(:,:,i) = matmul(parent_lattice,uq_hnf(:,:,i));end forall
    ! Now loop through the list of unique superlattices and record
    ! which of the parent lattice symmetry operations leave the
    ! superlattice unchanged. These operations, while they leave the
    ! superlattice unchanged can permute the labels inside. Thus, this
    ! is another source of duplicates.
    allocate(fixing_op(Nq),STAT=status)
    if(status/=0) stop "Allocation of fixing_op failed in remove_duplicate_lattices"

    allocate(degeneracy_list(Nq) )
    degeneracy_list = 0
    do iuq = 1, Nq  ! Loop over each unique HNF Determine which
       ! operations in the sym ops of the parent lattice leave the
       ! superlattice fixed. These operations may permute the labeling
       ! so we need them when finding duplicate labelings
       call get_sLV_fixing_operations(uq_hnf(:,:,iuq),parent_lattice,nD,sgrots,sgshift,&
        dperms,fixing_op(iuq),RPList(iuq),degeneracy_list(iuq),eps)
    enddo
    degeneracy_list = degeneracy_list + 1
  END SUBROUTINE remove_duplicate_lattices

  !!
  !!<parameter name="HNF" regular="true"></parameter>
  !!<parameter name="pLV" regular="true"></parameter>
  !!<parameter name="nD" regular="true"></parameter>
  !!<parameter name="rot" regular="true"></parameter>
  !!<parameter name="shift" regular="true"></parameter>
  !!<parameter name="dPerm" regular="true"></parameter>
  !!<parameter name="fixOp" regular="true">Stores the operations that
  !!leave sLV fixed.</parameter>
  !!<parameter name="rotPerm" regular="true"></parameter>
  !!<parameter name="degeneracy" regular="true"></parameter>
  !!<parameter name="eps" regular="true">Finite precision tolerance.</parameter>
  SUBROUTINE get_sLV_fixing_operations(HNF,pLV,nD,rot,shift,dPerm,fixOp,rotPerm,degeneracy,eps)
    integer, intent(in)       :: HNF(:,:), nD
    real(dp), intent(in)      :: pLV(:,:), rot(:,:,:), shift(:,:)
    type(opList)              :: fixOp
    real(dp), intent(in)      :: eps
    type(RotPermList)         :: rotPerm
    type(RotPermList), intent(in):: dPerm

    integer :: degeneracy
    integer i, ic, iRot, nRot, status, iDegen, cDegen
    type(opList)               :: tmpOp
    real(dp), dimension(3,3)   :: thisRot, origLat, rotLat
    real(dp), allocatable      :: tv(:,:,:), degen_lattices(:,:,:)
    integer, allocatable       :: tIndex(:)
    logical :: inList

    nRot = size(rot,3)
    allocate(tv(3,nD,nRot),tIndex(nRot),STAT=status); if(status/=0) stop "tv didn't allocate"
    allocate(tmpOp%rot(3,3,nRot),tmpOp%shift(3,nRot))

    allocate(degen_lattices(3,3,nRot) )
    degen_lattices = 0
    cDegen = 0
    ic = 0 ! Counter for the fixing operations
    tv = 0; tIndex = 0 ! temp variables
    do iRot = 1,nRot  ! Loop over each rotation
       thisRot = rot(:,:,iRot) ! Store the rotation
       origLat = matmul(pLV,HNF)  ! Compute the superlattice
       rotLat = matmul(thisRot,origLat)          ! Compute the rotated superlattice
       if (is_equiv_lattice(rotLat,origLat,eps)) then ! this operation
       ! fixes the lattice and should be recorded
          ic = ic + 1
          tmpOp%rot(:,:,ic) = thisRot
          tmpOp%shift(:,ic) = shift(:,iRot)
          tv(:,:,ic) = dPerm%v(:,:,iRot)
          tIndex(ic) = iRot
          ! Added by LN from here
       else
          inList = .false.
          do iDegen = 1, cDegen
             if (is_equiv_lattice(degen_lattices(:,:,iDegen),rotLat,eps) ) then
                inList = .true.
                exit
             end if
          end do

          if (.not. inList) then
             cDegen = cDegen + 1
             degen_lattices(:,:,cDegen) = rotLat
          end if
       endif
       ! End of LN additions for degeneracy
    enddo ! Now we know which rotations fix the lattice and how many
          ! there are so store them
    degeneracy = cDegen
    do i=1,ic; allocate(fixOp%rot(3,3,ic),fixOp%shift(3,ic),STAT=status)
       if(status/=0) stop "Allocation of fixing_op(iuq) failed, module deriv..."; enddo
    ! Allocate the storage for them
    fixOp%rot =   tmpOp%rot(:,:,1:ic) ! Stuff the rotations into the permanent array
    fixOp%shift = tmpOp%shift(:,1:ic) ! Stuff the shifts into the permanent array
    allocate(rotPerm%v(3,nD,ic),rotPerm%RotIndx(ic),STAT=status)
    if (status/=0) stop "Allocation of RPList failed in remove_duplicate_lattices"
    rotPerm%v = tv(:,:,1:ic)
    rotPerm%RotIndx = tIndex(1:ic)

  END SUBROUTINE get_sLV_fixing_operations

  !!This subroutine generates all the unique HNF matrices of
  !!a given determinant (See Santoro and Mighell 1972 Acta. Cryst.)
  !!but for a quasi-2D case
  !!<parameter name="volume" regular="true"></parameter>
  !!<parameter name="hnf" ></parameter>
  SUBROUTINE get_all_2D_HNFs(volume,hnf)
    integer, intent(in) :: volume
    integer, pointer:: hnf(:,:,:)

    integer, pointer    :: d(:,:) => null()
    integer             :: i, j    ! Loop counters
    integer             :: N, Nhnf, ihnf ! # of triplets, # of HNF matrices, HNF counter
    integer status
    call get_HNF_2D_diagonals(volume,d)
    N = size(d,2)

    ! Count the total number of HNF matrices for given determinant (volume)
    Nhnf = 0
    do i = 1,N
       Nhnf = Nhnf + d(3,i)
    enddo

    allocate(hnf(3,3,Nhnf),STAT=status)
    if(status/=0) stop "Failed to allocate memory in get_all_2D_HNFs"
    ihnf = 0
    do i = 1,N ! Loop over the permutations of the diagonal elements of the HFNs
       do j = 0,d(3,i)-1  ! Look over possible values of row 2, element 1
          ihnf = ihnf+1 ! Count the HNFs and construct the next one
          hnf(:,:,ihnf) = reshape((/ d(1,i),      0,     0,        &
               0, d(2,i),     j,        &
               0,      0, d(3,i)  /), (/3,3/))
       enddo  ! End loops over values for off-diagonal elements
    enddo ! End loop over all unique triplets of target determinant (volume)
    if (ihnf /= Nhnf) stop "HNF: not all the matrices were generated...(bug!)"
  END SUBROUTINE get_all_2D_HNFs

  !!Finds all the possible diagonals of the HNF matrices of a
  !!given size.
  !!<parameter name="detS" regular="true">Cell size, i.e., determinant
  !!of S matrix.</parameter>
  !!<parameter name="diagonals">All possible diagonals.</parameter>
  SUBROUTINE get_HNF_2D_diagonals(detS, diagonals)
    integer, intent(in) :: detS
    integer, pointer :: diagonals(:,:)

    integer i, id, quotient, status
    integer :: tempDiag(3,detS*3)

    id = 0 ! Number of diagonals found
    do i = 1,detS ! Loop over possible first factors
       if (.not. mod(detS,i)==0) cycle
       quotient = detS/i
       id = id + 1
       tempDiag(:,id) = (/1, i, quotient /) ! Construct the factor triplet
    enddo
    allocate(diagonals(3,id),STAT=status)
    if(status/=0) stop "Allocation of diagonals fails in get_HNF_2D_diagonals, module deriv..."
    diagonals = tempDiag(:,1:id)
  END SUBROUTINE get_HNF_2D_diagonals

  ![TODO] Add line enumerations for proteins etc.
  !!This procedure generates derivative superstructures from
  !!multilattices.
  !!<comments> This is more general and should therefore work on
  !! "mono"-lattices, as the original routine did. The algorithm
  !! implemented here has been slightly reordered from the original
  !! routine discussed in the first paper (Hart and Forcade 2008).
  !! </comments>
  !!<revision date="Oct 2010" author="GH">This routine has long since
  !!replaced the original.</revision>
  !!<revision date="Oct 2010" author="GH">Added the ability to
  !!enumerate for a fixed concentration (EnumIII).</revision>
  !!<parameter name="title" regular="true">A string to identify the
  !!run, echoed in the output file.</parameter>
  !!<parameter name="parLV" regular="true">The parent lattice
  !!vectors.</parameter>
  !!<parameter name="nDFull" regular="true">The number of d-vectors in
  !!the full d-set @CREF[param.dFull].</parameter>
  !!<parameter name="dFull">A list of all the d-vectors including
  !!those with no configurational degrees of freedom.</parameter>
  !!<parameter name="k" regular="true">The number of different kind of
  !!atoms that can be placed on a site (a.k.a. colors).</parameter>
  !!<parameter name="nMin" regular="true">The lower bound on the range
  !!of cell sizes to enumerate over.</parameter>
  !!<parameter name="nMax" regular="true">The upper bound on the range
  !!of cell sizes to enumerate over.</parameter>
  !!<parameter name="pLatTyp" choices="S,B" regular="true"> The parent
  !! lattice type. Possible choices are S = "Surface", B = "Bulk".
  !! </parameter>
  !!<parameter name="eps" regular="true">Tolerance for the finite
  !!difference calculations.</parameter>
  !!<parameter name="full" regular="true"> The full setting returns
  !! all possible combinations of colors at sites even if they are
  !! crystallographically equivalent. Partial (i.e. .false.) removes
  !! combinations of colors where a crystallographically equivalent
  !! site already exists (even though the energy may be
  !! different..</parameter>
  !!<parameter name="labelFull">A list of the labels (index 1) allowed
  !!on each site (index 2).</parameter>
  !!<parameter name="digitFull">A list of the *number* of labels on
  !!each site </parameter>
  !!<parameter name="equivalencies">A listing of sites that need to
  !!have the same color.</parameter>
  !!<parameter name="conc_check" regular="true">Specifies whether the
  !! enumeration should be done in a restricted concentration
  !! range. The restricted range is specified in
  !! @CREF[param.cRange]</parameter>
  !!<parameter name="cRange"> A restricted concentration
  !!  range for the enumeration. If any concentrations are restricted,
  !!  ranges must be specified for ALL colors (atom types) in the
  !!  enumeration. <dimension>Rows specify range
  !!  fractions. Row 1: Numerator (START); Row 2: Numerator (END); Row
  !!  3: Denominator.</dimension> <dimension>Columns specify colors
  !!  for range limitations.</dimension> </parameter>
  SUBROUTINE gen_multilattice_derivatives(title, parLV, nDFull, dFull, k, nMin, nMax, pLatTyp, eps, full,&
       & labelFull,digitFull,equivalencies, conc_check,cRange)
    integer, intent(in) :: k, nMin, nMax, nDFull
    integer             :: nD
    !Had to change character to 80 from 10 to match the definition in io_utils.read_input
    character(80), intent(in) :: title
    real(dp), intent(in) :: parLV(3,3), eps
    real(dp), pointer :: dFull(:,:), d(:,:)
    character(1), intent(in) :: pLatTyp
    logical, intent(in) :: full
    integer, intent(inout) :: labelFull(:,:) !
    integer, intent(inout) :: digitFull(:)   !
    integer, allocatable    :: label(:,:), digit(:)
    integer, intent(in) :: equivalencies(:)
    logical, intent(in) :: conc_check
    integer, optional,intent(in)   :: cRange(:,:)

    integer iD, i, ivol, LatDim, Scnt, Tcnt, iBlock, HNFcnt, status, iC
    integer, pointer, dimension(:,:,:) :: HNF => null(),SNF => null(), L => null(), R => null()
    integer, pointer :: SNF_labels(:) =>null(), uqSNF(:,:,:) => null()
    integer, pointer, dimension(:,:,:) :: rdHNF =>null()
    real(dp) tstart, tend!, removetime, organizetime, writetime,hnftime,snftime, permtime
    real(dp), allocatable :: tempD(:,:) ! Temporary list of the d-vectors
    real(dp)              :: inv_parLV(3,3) ! Parent lattice inverse matrix
    type(opList), pointer :: fixOp(:)  ! Symmetry operations that leave a multilattice unchanged
    type(RotPermList), pointer :: RPList(:) ! Master list of the rotation permutation lists
    type(RotPermList), pointer :: rdRPList(:) ! Master list of the *unique* rotation
    ! permutation lists
    type(RotPermList) :: ParRPList ! Just the list for the parent lattice
    integer, pointer ::  RPLindx(:) => null() ! Index showing which list of rotation
    !permutations corresponds to which HNF
    real(dp), pointer :: uqlatts(:,:,:) => null()
    character, pointer :: lm(:) ! labeling markers (use to generate the labelings
    !when writing results)
    character(80) filename ! String to pass filenames into output writing routines
    character(80) formatstring
    logical fixed_cells ! This is set to true if we are giving a list of cells from a file
    !instead of generating them all
    integer, pointer :: iRange(:,:) ! Rows: List of the number of atoms of each type
    !("color vector"). Cols: sweep over concentration range.
    logical err
    integer, pointer :: hnf_degen(:), lab_degen(:)

    ! Divide the dset into members that are enumerated and those that are not
    nD = count( (/(i,i=1,nDFull)/)==equivalencies)
    allocate(d(3,nD), label(size(labelFull,1),nD), digit(nD),tempD(3,nD))

    nD = 0
    do iD=1,nDFull
       if (iD==equivalencies(iD)) then ! this dset member is a unique point
          nD=nD+1
          d(:,nD)     = dFull(:,iD)
          label(:,nD) = labelFull(:,iD)
          digit(nD)   = digitFull(iD)
       else ! this dset member is equivalent (concerning the
            ! enumeration!) to a different point.  => Force the label
            ! and digit arrays to be equal for equivalent sites
          labelFull(:,iD) = labelFull(:,equivalencies(iD))
          digitFull(iD)   = digitFull(equivalencies(iD))
       endif
    enddo

    ! Are we going to use a set of fixed cells? Or loop over all possible cells?
    fixed_cells = .false.
    open(43,file="fixed_cells.in",status="old",iostat=status)
    if(status==0) then
       ! write(*,'(A)') "---------------------------------------------------------------------------------------------"
       ! write(*,'("Generating permutations for fixed cells. index n=",i2," to ",i2)') nMin, nMax
       ! write(*,'("Be aware: non-primitive structures (super-periodic configurations) are included",/,&
       !      &"in the final list in this mode.")')
       fixed_cells=.true.
    endif
    close(43)

    ! write(*,'(A)') "---------------------------------------------------------------------------------------------"
    ! write(*,'("Calculating derivative structures for index n=",i2," to ",i2)') nMin, nMax
    ! if (conc_check) then
       ! write(*,'(A)') "Including only structures of which the concentration &
       !      &of each atom is in the range:"
       ! do i = 1, k
       !    write(formatstring,'(A,i1,A,i1,A,i1,A,i1,A)') '("Type:",i2,": ",&
       !         &i',int(log10(real(cRange(i,1))+1))+1,&
       !         &',"/",i',int(log10(real(cRange(i,3))+1))+1,',"--",i'&
       !         &,int(log10(real(cRange(i,2))+1))+1,',"/",i'&
       !         &,int(log10(real(cRange(i,3))+1))+1,')'
       !    write(*,formatstring) i,cRange(i,1),cRange(i,3),cRange(i,2),cRange(i,3)
       ! enddo
    ! endif

    ! write(*,'("Volume",7x,"CPU",8x,"#HNFs",2x,"#SNFs",&
    !      &4x,"#reduced",4x,"% dups",6x,"volTot",6x,"RunTot")')

    ! Set up the output file and write the lattice information
    ! open(14,file="struct_enum.out")
    !Write the fortpy version information for the file.
    ! write(14, *) '# <fortpy version="3" revision="247"></fortpy>'
    ! write(14,'(a10)') title
    if (pLatTyp=='S'.or.pLatTyp=="s") then; write(14,'(a4)') "surf"
    elseif (pLatTyp=='B'.or.pLatTyp=="b") then; write(14,'(a4)') "bulk"
    else; print *,"pLatTyp:",pLatTyp
    stop '"pLatTyp" not defined in gen_multilattice_derivs in enumlib'; endif

    ! do i = 1,3
    !    write(14,'(3(g15.8,1x),3x,"# a",i1," parent lattice vector")') parLV(:,i),i
    ! enddo
    ! write(14, '(i5," # Number of points in the multilattice")') nDFull
    ! do iD = 1,nDFull
    !    ! Print out the dset points and their possible labels
    !    ! (1) setup the format for output
    !    formatstring='(3(g15.8,1x),3x,"# d",i2.2," d-vector, labels: "'
    !    do i=1,digitFull(iD); if (i>1) formatstring=trim(formatstring)//',"/"'; formatstring=trim(formatstring)//',i1'; enddo
    !    formatstring=trim(formatstring)//")"
    !    ! (2) print the data
    !    write(14,formatstring) dFull(:,iD),iD, labelFull(1:digitFull(iD),iD)
    ! enddo
    ! write(14,'(i2,"-nary case")') k
    ! write(14,'(2i4," # Starting and ending cell sizes for search")') nMin, nMax
    ! write(14,'(g15.8," # Epsilon (finite precision parameter)")') eps
    ! write(14,'(A)') "Concentration check:"
    ! write(14,'(L5)') conc_check
    ! if (conc_check) then
    !    write(14,'(A)') "Including only structures of which the concentration &
    !         &  of each atom is in the range:"
    !    do i = 1, k
    !       write(14,'("Type ",i1,": ",i4,"/",i4," -- ",i4,"/",i4)') i,cRange(i,1),cRange(i,3),cRange(i,2),cRange(i,3)
    !    enddo
    ! endif
    ! if (full) then; write(14,'("full list of labelings (including incomplete labelings) is used")')
    ! else; write(14,'("partial list of labelings (complete labelings only) is used")'); endif
    ! write(14,'("Equivalency list:" ,40(I2,1x))') equivalencies(:)

    ! !write(14,'("Symmetry of the primary lattice is of order ",i2)')

    ! write(14,'("start",3x,"#tot",6x,"HNF",5x,"Hdegn",3x,"labdegn",3x,"Totdegn",3x,"#size",1x,"idx",4x,"pg",4x,"SNF",13x,"HNF",17x,"Left transform",26x,"labeling")')

    ! Check for 2D or 3D request
    if (pLatTyp=='s' .or. pLatTyp=='S') then; LatDim = 2
       if (.not. equal((/parLV(1,2),parLV(1,3)/),(/0._dp,0._dp/),eps)) &
            stop 'For "surf" setting, first component of second and third vectors &
            & must be zero'
    else if(pLatTyp=='b' .or. pLatTyp=='B') then; LatDim = 3
    else; stop 'Specify "surf" or "bulk" in call to "generate_derivative_structures"';endif

    ! The permutations of the interior points (d-vectors)
    ! under symmetry operations of the parent multilattice
    ! are used later on. Generate them here
    tempD = d ! Make a temporary copy of the d-set members
    call matrix_inverse(parLV,inv_parLV,err); if(err) stop "Inverse failed for d-mapping"
    do iD = 1, nD
       call bring_into_cell(d(:,iD),inv_parLV,parLV,eps)
       if(.not. equal(d(:,iD),tempD(:,iD),eps)) then
          write(*,'("Original d-set member was not inside the unit cell. It has been remapped.")')
          write(*,'("Original:",3(f7.3,1x))') tempD(:,iD)
          write(*,'("Remapped:",3(f7.3,1x))') d(:,iD)
       endif
    enddo
    call get_dvector_permutations(parLV,d,ParRPList,LatDim,eps)

    ! This part generates all the derivative structures. Results are
    ! written to unit 14.
    Tcnt = 0 ! Keep track of the total number of structures generated
    HNFcnt = 0 ! Keep track of the total number of
    ! symmetrically-inequivalent HNFs in the output
    do ivol = nMin, nMax
       if (conc_check) then
          call get_list_at_this_size(ivol,nD,cRange,iRange,eps)
          if (size(iRange,1)==0) cycle
       endif
       call cpu_time(tstart)
       if (fixed_cells) then
          call read_in_cells_from_file(ivol,HNF,parLV,eps)
          if(size(HNF,3)==0) cycle
       else
          if (LatDim==3) then !<<< 2D ? or 3D? >>
             call get_all_HNFs(ivol,HNF)    ! 3D
          else
             call get_all_2D_HNFs(ivol,HNF) ! 2D
          endif
       endif

       !call cpu_time(HNFtime) Many of the superlattices will be
       ! symmetrically equivalent so we use the symmetry of the parent
       ! multilattice to reduce the list to those that are
       ! symmetrically distinct.
       call remove_duplicate_lattices(HNF,LatDim,parLV,d,ParRPList,rdHNF,fixOp,RPList,uqlatts,hnf_degen,eps)
       !call cpu_time(Removetime) Superlattices with the same SNF will
       ! have the same list of translation permutations of the
       ! labelings. So they can all be done at once if we find the
       ! SNF. rdHNF is the reduced list.
       call get_SNF(rdHNF,L,SNF,R,RPList,uqSNF,SNF_labels,fixOp)
       ! call cpu_time(SNFtime) Each HNF will have a certain number of
       ! rotations that leave the superlattice fixed, called
       ! fixOp. These operations will effect a permutation on the
       ! (d,g) table. Since many of the HNFs will have an identical
       ! list of rotation permutations, it'll be efficient to reduce
       ! the labelings for all such HNFs just once. So we need to
       ! generate the list for each HNF and then sort the HNFs into
       ! blocks with matching permutation lists. And we'll go ahead
       ! and include the translation permutations as well so that each
       ! list in rdRPList contains all possible permutations that
       ! identify duplicate labelings.
       call get_rotation_perms_lists(parLV,rdHNF,L,SNF,fixOp,RPList,ParRPList,eps)
       !call cpu_time(permtime)
       call organize_rotperm_lists(RPList,rdRPList,RPLindx)
       !call cpu_time(organizetime) This next if statement makes the
       ! run-time horrible (N^3 scaling) if enabled. (only used for
       ! checking once.)
       Scnt = 0 ! Keep track of the number of structures at this size

       call write_matrices(rdHNF, SNF, L, RPLindx, rdRPList, ivol)
       !cycle
       ! do iBlock = 1, maxval(RPLindx)
       !    !call cpu_time(blockstart)
       !    !filename = "debug_temp_perms.out"
       !    !call write_rotperms_list(rdRPList(iBlock), filename)

       !    if (conc_check) then
       !       do iC = 1, size(iRange,1) ! loop over each concentration in the range
       !          write(*,'("HNF: ",6(i2,1x))') (RDhnf(i,:,iBlock),i=1,3)
       !          ! call generate_permutation_labelings_new(ivol, nD, rdRPList(iBlock)%perm, iRange(iC,:), fixed_cells)
       !          call generate_permutation_labelings(k,ivol,nD,rdRPList(iBlock)%perm,&
       !               lm,iRange(iC,:),labelFull,digitFull,lab_degen,fixed_cells)
       !          ! call generate_disjoint_permutation_labelings(k,ivol,nD&
       !          !     &,rdRPList(iBlock)%perm,lm,iRange(iC,:),labelFull,digitFull,2)
       !           call write_labelings(k,ivol,nD,label,digit,iBlock,rdHNF,SNF,L,fixOp,Tcnt,Scnt,HNFcnt&
       !               &,RPLindx,lm,equivalencies,hnf_degen,lab_degen,iRange(iC,:))
       !       enddo
       !    else
       !       call generate_unique_labelings(k,ivol,nD,rdRPList(iBlock)%perm,&
       !            full,lm,label,digit,lab_degen,fixed_cells)
       !       ! Now that we have the labeling marker, we can write the output.
       !       call write_labelings(k,ivol,nD,label,digit,iBlock,rdHNF,SNF,L,fixOp,Tcnt,Scnt,HNFcnt,RPLindx,lm,equivalencies,hnf_degen,lab_degen)
       !       !call cpu_time(endwrite)
       !    endif
       ! enddo! iBlock
       ! !call cpu_time(writetime)
       ! call cpu_time(tend)
       ! write(*,'(i4,1x,f14.4,1x,i8,3x,i3,3x,i7,7x,f7.4,i12,i12)')ivol,tend-tstart,size(HNF,3),&
       !      size(uqSNF,3),size(rdHNF,3),1-size(rdHNF,3)/real(size(HNF,3)),Scnt, Tcnt
    enddo ! loop over cell sizes (ivol)
    ! close(14)
    ! write(*,'(A)') "---------------------------------------------------------------------------------------------"

  ENDSUBROUTINE gen_multilattice_derivatives

END MODULE derivative_structure_generator