      SUBROUTINE DEMEAN(IN,IOUT,N,MEAN)
C     DEMEAN IS AN AP ROUTINE TO REMOVE THE MEAN VALUE OF A TRACE.  MEAN REMOVAL
C IS THE SAME AS REMOVING THE DC SHIFT OR DC BIAS.
C
C ARGUMENTS:
C  IN     - THE AP ADDRESS OF THE INPUT ARRAY (THE BIASED ARRAY).
C  IOUT   - THE AP ADDRESS OF THE OUTPUT ARRAY TO RECEIVE THE UNBIASED DATA.
C           (IOUT MAY BE THE SAME AS IN).
C  N      - THE NUMBER OF ELEMENTS IN THE IN ARRAY.
C  MEAN   - THE AP ADDRESS WHERE THE MEAN VALUE CAN BE STORED.
C
C
C  WRITTEN AND COPYRIGHTED BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, 27 OCTOBER 1981
C  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
C  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
C
      CALL MEANV(IN,1,MEAN,N)                                           ! /* FIND THE MEAN VALUE
      CALL VNEG(MEAN,1,MEAN,1,1)                                        ! /* NEGATE THE MEAN VALUE
      CALL VSADD(IN,1,MEAN,IOUT,1,N)                                    ! /* SUBTRACT THE MEAN (ADD THE NEGATIVE)
      CALL VNEG(MEAN,1,MEAN,1,1)                                        ! /* MAKE THE MEAN AS IT WAS
      RETURN
      END


      SUBROUTINE DIVP(XXXX,YYYY,ZZZZ,IERR)
C
C THIS SUBROUTINE PERFORMS DIVISION  OF COMPLEX NUMBERS:
C ZZZZ = XXXX/YYYY
C
C ON INPUT:
C
C XXXX  IS AN ARRAY OF LENGTH TWO REPRESENTING THE FIRST COMPLEX
C       NUMBER, WHERE XXXX(1) = REAL PART OF XXXX AND XXXX(2) =
C       IMAGINARY PART OF XXXX.
C
C YYYY  IS AN ARRAY OF LENGTH TWO REPRESENTING THE SECOND COMPLEX
C       NUMBER, WHERE YYYY(1) = REAL PART OF YYYY AND YYYY(2) =
C       IMAGINARY PART OF YYYY.
C
C ON OUTPUT:
C
C ZZZZ  IS AN ARRAY OF LENGTH TWO REPRESENTING THE RESULT OF
C       THE DIVISION, ZZZZ = XXXX/YYYY, WHERE ZZZZ(1) =
C       REAL PART OF ZZZZ AND ZZZZ(2) = IMAGINARY PART OF ZZZZ.
C
C IERR =
C  1   IF DIVISION WOULD HAVE CAUSED OVERFLOW.  IN THIS CASE, THE
C      APPROPRIATE PARTS OF ZZZZ ARE SET EQUAL TO THE LARGEST
C      FLOATING POINT NUMBER, AS GIVEN BY FUNCTION  D1MACH .
C
C  0   IF DIVISION DOES NOT CAUSE OVERFLOW.
C
C DECLARATION OF INPUT
      DOUBLE PRECISION XXXX,YYYY
      DIMENSION XXXX(2),YYYY(2)
C
C DECLARATION OF OUTPUT
      INTEGER IERR
      DOUBLE PRECISION ZZZZ
      DIMENSION ZZZZ(2)
C
C DECLARATION OF VARIABLES
      DOUBLE PRECISION DENOM,XNUM,D1MACH
C
      IERR = 0
      DENOM = YYYY(1)*YYYY(1) + YYYY(2)*YYYY(2)
      XNUM    =   XXXX(1)*YYYY(1) + XXXX(2)*YYYY(2)
      IF (ABS(DENOM) .GE. 1.0  .OR.  ( ABS(DENOM) .LT. 1.0   .AND.
     $ ABS(XNUM)/D1MACH(2) .LT. ABS(DENOM) ) ) THEN
            ZZZZ(1) = XNUM/DENOM
          ELSE
            ZZZZ(1) = D1MACH(2)
            IERR =1
          END IF
      XNUM    =   XXXX(2)*YYYY(1) - XXXX(1)*YYYY(2)
      IF (ABS(DENOM) .GE. 1.0  .OR.  ( ABS(DENOM) .LT. 1.0   .AND.
     $ ABS(XNUM)/D1MACH(2) .LT. ABS(DENOM) ) ) THEN
            ZZZZ(2) = XNUM/DENOM
          ELSE
            ZZZZ(2) = D1MACH(2)
            IERR =1
          END IF
      RETURN
      END


      subroutine cpl0 (x, pl0, lmaxp1)
      implicit double precision (a-h, o-z)

c-----------------------------------------------------------------------
c
c     cpl0:  Calculate associated legendre polynomials p_l0(x)
c            by recursion.
c            Adapted from aslgndr.
c
c     first written: (25 june 86) by j. j. rehr
c
c     version 1 (25 june 86) (aslgndr)
c     version 2 (March, 1992) siz
c
c-----------------------------------------------------------------------

      dimension pl0 (lmaxp1)

      lmax = lmaxp1-1

c     calculate legendre polynomials p_l0(x) up to l=lmax
      pl0(1) = 1
      pl0(2) = x
      do 10  il = 2, lmax
         l = il-1
         pl0(il+1) = ( (2*l+1)*x*pl0(il) - l*pl0(l) ) / il
   10 continue

      return
      end


Subroutine Initial
use Aero2DCOM
implicit none
integer i,j,ioerr
real(8),external:: interpl
real(8) Tni0
ca=1006.43
if(Tmptype=='fixed') then
  ka=0.00008*(Ta-Tf)+0.0244
else if(Tmptype=='flux') then
  ka=0.0244
end if
Ui=Vfar*cos(AoA*Pi/180)
Vi=Vfar*sin(AoA*Pi/180)
rhoi=Po*Ma/(R*Ta)
mui=mu0*(Ta/Ti)**1.5*(Ti+Si)/(Ta+Si)
Re=rhoi*Vfar*c/mui
Mach=Vfar/sqrt(gama*R*Ta/Ma)
if(Turmod=='sa') then
 Tni=1
 DO i=1,100
  Tni0=Tni
  Tni=Tni-((rhoi/mui)**3*Tni**4-tvr*(rhoi/mui)**2*Tni**3-mui*tvr*Cnu1**3/rhoi)/(4*(rhoi/mui)**3*Tni**3-&
  3*tvr*(rhoi/mui)**2*Tni**2)
  if(abs(Tni-Tni0)<1e-8) exit
 end DO
else if(Turmod=='ke') then
 Tki=1.5*(Vfar*Itur)**2
 Tei=rhoi*Cu*Tki**2/(mui*tvr)
else if(Turmod=='sst') then
 Tki=1.5*(Vfar*Itur)**2
 Twi=rhoi*Tki/(mui*tvr)
end if
if(Init=='Y') then
 open(unit=1,file=filename(9),form='unformatted',status='old')
  read(1,iostat=ioerr) U
  read(1,iostat=ioerr) U
  read(1,iostat=ioerr) U
  read(1,iostat=ioerr) V
  read(1,iostat=ioerr) P
  read(1,iostat=ioerr) T
  read(1,iostat=ioerr) rho
  if(Turmod=='sa') then
   read(1,iostat=ioerr) Tn
  else if(Turmod=='ke') then
   read(1,iostat=ioerr) Tk
   read(1,iostat=ioerr) Te
  else if(Turmod=='sst') then
   read(1,iostat=ioerr) Tk
   read(1,iostat=ioerr) Tw
  end if
 close(1)
 print *,'Read initial data completed!'
else if(Init=='N') then
 if(Stag=='N') then
  U=Ui
  V=Vi
  P=0
  T=Ta
 else if(Stag=='Y') then
  U=0.1
  V=0.1
  P=Po*(1+(gama-1)/2*Mach**2)**(gama/(gama-1))-Po
  T=Ta*(1+(gama-1)/2*Mach**2)
 end if
 U(:,Jc)=Ui
 U(1,:)=Ui
 U(Ic,:)=Ui
 V(:,Jc)=Vi
 V(1,:)=Vi
 V(Ic,:)=Vi
 P(:,Jc)=0
 P(1,:)=0
 P(Ic,:)=0
 T(:,Jc)=Ta
 T(1,:)=Ta
 T(Ic,:)=Ta
 rho=(Po+P)*Ma/(R*T)
 if(Turmod=='sa') then
  Tn=Tni
  Tn(:,Jc)=Tni
  Tn(1,:)=Tni
  Tn(Ic,:)=Tni
 else if(Turmod=='ke') then
  Tk=Tki
  Tk(:,Jc)=Tki
  Tk(1,:)=Tki
  Tk(Ic,:)=Tki
  Te=Tei
  Te(:,Jc)=Tei
  Te(1,:)=Tei
  Te(Ic,:)=Tei
 else if(Turmod=='sst') then
  Tk=Tki
  Tk(:,Jc)=Tki
  Tk(1,:)=Tki
  Tk(Ic,:)=Tki
  Tw=Twi
  Tw(:,Jc)=Twi
  Tw(1,:)=Twi
  Tw(Ic,:)=Twi
 end if
else if(Init=='A') then
 U(:,Jc)=Ui
 U(1,:)=Ui
 U(Ic,:)=Ui
 V(:,Jc)=Vi
 V(1,:)=Vi
 V(Ic,:)=Vi
 P(:,Jc)=0
 P(1,:)=0
 P(Ic,:)=0
 T(:,Jc)=Ta
 T(1,:)=Ta
 T(Ic,:)=Ta
 rho=(Po+P)*Ma/(R*T)
 if(Turmod=='sa') then
  Tn(:,Jc)=Tni
  Tn(1,:)=Tni
  Tn(Ic,:)=Tni
 else if(Turmod=='ke') then
  Tk(:,Jc)=Tki
  Tk(1,:)=Tki
  Tk(Ic,:)=Tki
  Te(:,Jc)=Tei
  Te(1,:)=Tei
  Te(Ic,:)=Tei
 else if(Turmod=='sst') then
  Tk(:,Jc)=Tki
  Tk(1,:)=Tki
  Tk(Ic,:)=Tki
  Tw(:,Jc)=Twi
  Tw(1,:)=Twi
  Tw(Ic,:)=Twi
 end if
end if
ks=ksi
if(Turmod=='inv') then
 mu=0
else
 mu=mu0*(T/Ti)**1.5*(Ti+Si)/(T+Si)
end if
Pr=mu*ca/ka
Pc=9.24*((Pr/Prt)**0.75-1)*(1+0.28*exp(-0.007*Pr/Prt))
dP=0
Call Derivatives('U')
Call Derivatives('V')
Call Derivatives('P')
if(Turmod=='sa'.and.Walltreat=='lr') then
 d=d+0.03*ksi
end if
Call Turvis
Un=U*Yga-V*Xga
Vn=V*Xgk-U*Ygk
DO j=1,Jc-1
  DO i=2,Ic
  Unk(i,j)=interpl(Un(i,j),Un(i-1,j),dk(i,j),dk(i-1,j))
  end DO
end DO
DO j=1,Jc
  DO i=2,Ic-1
  if(j==1.and.i>=Ib1.and.i<=Ib2) then
   Vna(i,j)=0
  else if(j==1) then
   Vna(i,j)=interpl(Vn(i,j),-Vn(Ic+1-i,j),da(i,j),da(Ic+1-i,j))
  else
   Vna(i,j)=interpl(Vn(i,j),Vn(i,j-1),da(i,j),da(i,j-1))
  end if
  end DO
end DO
U0=U
V0=V
T0=T
if(Turmod=='sa') then
 Tn0=Tn
else if(Turmod=='ke') then
 Tk0=Tk
 Te0=Te
else if(Turmod=='sst') then
 Tk0=Tk
 Tw0=Tw
end if
end Subroutine Initial


PROGRAM driver
  use srHNF_brute
  use symmetry, only: get_lattice_pointGroup
  use vector_matrix_utilities
  use num_types
  use utilities
  use io_utils
  use numerical_utilities

  implicit none

  integer :: i, sfound, nfound, status, j
  integer, allocatable :: srHNFs(:,:,:), isrHNFs(:,:,:), temp_storage(:,:,:)
  real(dp), pointer :: pg(:,:,:)
  real(dp), allocatable :: gens(:,:,:)

  integer nMin, nMax ! Numbers of various things
  integer k ! Number of colors/label types (i.e., binary, ternary, etc.)
  integer LatDim ! 2D or 3D parent lattice?
  integer nD ! Number of sites in the basis (i.e., number of points in the multilattice)
  real(dp), pointer :: d(:,:) => null()
  character(1) :: latTyp
  real(dp)  eps, tstart, tend
  real(dp) :: parLV(3,3), invLV(3,3), abgens(3,3)

  character(80) title, fname
  logical fullLab,concCheck
  integer, pointer :: cRange(:,:)
  integer, pointer :: label(:,:)
  integer, pointer :: digit(:)
  integer, pointer :: equivalencies(:)

  if (iargc()>=1) then
     call getarg(1,fname)
  else
     fname = "struct_enum.in"
  endif
  call read_input(title,LatDim,parLV,nD,d,k,equivalencies,nMin,nMax,eps&
       &,fullLab,label,digit,fname,cRange,concCheck) ! Read in parent lattice vectors, etc.

  ! lat = reshape((/1,0,0,0,1,0,0,0,1/),(/3,3/))
  ! lat = reshape((/0.5,0.5,0.0,0.5,0.0,0.5,0.0,0.5,0.5/),(/3,3/))
  ! lat = reshape((/0.5,0.5,-0.5,0.5,-0.5,0.5,-0.5,0.5,0.5/),(/3,3/))
  ! vol = 1000

  call cpu_time(tstart)
  ! Need to replace get_lattice_pointGroup with get space group
  call get_lattice_pointGroup(parLV,pg)
  call find_pg_gens(pg,gens,1e-10_dp)

  ! print *, "pg size", size(pg,3)
  ! print *, "lat vecs", parLV

  do i=1, size(gens,3)
     ! print *, "cbas gen", i
     ! do j=1,3
     !    print *, gens(j,:,i)
     ! end do
     print *, "latbas gen", i
     call matrix_inverse(parLV,invLV)
     abgens = matmul(invLV,matmul(gens(:,:,i),parLV))
     do j=1,3
        print *, abgens(j,:)
     end do
  end do

end PROGRAM driver


c
c      RGB VALUES FOR VISIBLE WAVELENGTHS   by Dan Bruton (astro@tamu.edu)
c
c      This program can be found at
c      http://www.physics.sfasu.edu/astro/color.html
c      and was last updated on February 20, 1996.
c
c      This program will create a ppm (portable pixmap) image of a spectrum.
c      The spectrum is generated using approximate RGB values for visible
c      wavelengths between 380 nm and 780 nm.
c      NetPBM's ppmtogif can be used to convert the ppm image
c      to a gif.  The red, green and blue values (RGB) are
c      assumed to vary linearly with wavelength (for GAMMA=1).
c      NetPBM Software: ftp://ftp.cs.ubc.ca/ftp/archive/netpbm/
c
       IMPLICIT REAL*8 (a-h,o-z)
       REAL*8 CV(500,500,3)
c
c      IMAGE INFO - WIDTH, HEIGHT, DEPTH, GAMMA
c
       M=400
       N=50
       MAX=255
       GAMMA=.80
c
c      WRITE OUTPUT TO PPM FILE
c
       OPEN(UNIT=20,FILE='temp.ppm',STATUS='UNKNOWN')
1      FORMAT(A10)
       WRITE(20,1) 'P3        '
       WRITE(20,1) '# temp.ppm'
       WRITE(20,*) M,N
       WRITE(20,*) MAX
       DO J=1,N
        DO I=1,M
c
c         WAVELENGTH = WL
c
            WL = 380. + REAL(I * 400. / M)

            IF ((WL.GE.380.).AND.(WL.LE.440.)) THEN
              R = -1.*(WL-440.)/(440.-380.)
              G = 0.
              B = 1.
            ENDIF
            IF ((WL.GE.440.).AND.(WL.LE.490.)) THEN
              R = 0.
              G = (WL-440.)/(490.-440.)
              B = 1.
            ENDIF
            IF ((WL.GE.490.).AND.(WL.LE.510.)) THEN
              R = 0.
              G = 1.
              B = -1.*(WL-510.)/(510.-490.)
            ENDIF
            IF ((WL.GE.510.).AND.(WL.LE.580.)) THEN
              R = (WL-510.)/(580.-510.)
              G = 1.
              B = 0.
            ENDIF
            IF ((WL.GE.580.).AND.(WL.LE.645.)) THEN
              R = 1.
              G = -1.*(WL-645.)/(645.-580.)
              B = 0.
            ENDIF
            IF ((WL.GE.645.).AND.(WL.LE.780.)) THEN
              R = 1.
              G = 0.
              B = 0.
            ENDIF
c
c      LET THE INTENSITY SSS FALL OFF NEAR THE VISION LIMITS
c
         IF (WL.GT.700.) THEN
            SSS=.3+.7* (780.-WL)/(780.-700.)
         ELSE IF (WL.LT.420.) THEN
            SSS=.3+.7*(WL-380.)/(420.-380.)
         ELSE
            SSS=1.
         ENDIF
c
c      GAMMA ADJUST AND WRITE IMAGE TO AN ARRAY
c
         CV(I,J,1)=(SSS*R)**GAMMA
         CV(I,J,2)=(SSS*G)**GAMMA
         CV(I,J,3)=(SSS*B)**GAMMA
        ENDDO
       ENDDO
c
c      WRITE IMAGE TO PPM FILE
c
       DO J=1,N
        DO I=1,M
           WL = 380. + REAL(I * 400. / M)
           IR=INT(MAX*CV(I,J,1))
           IG=INT(MAX*CV(I,J,2))
           IB=INT(MAX*CV(I,J,3))
c
c      ITYPE=1 - PLAIN SPECTUM
c      ITYPE=2 - MARK SPECTRUM AT 100 nm INTEVALS
c      ITYPE=3 - HYDROGEN BALMER EMISSION SPECTRA
c      ITYPE=4 - HYDROGEN BALMER ABSORPTION SPECTRA
c
         ITYPE=4
         IF (ITYPE.EQ.2) THEN
            DO K=400,700,100
              IF ((ABS(INT(WL)-K).LT.1).AND.(J.LE.20)) THEN
               IR=MAX
               IG=MAX
               IB=MAX
              ENDIF
            ENDDO
         ELSEIF (ITYPE.EQ.3) THEN
            IF ((ABS(WL-656.).GT.1.).and.(ABS(WL-486.).GT.1.).and.
     *          (ABS(WL-433.).GT.1.).and.(ABS(WL-410.).GT.1.)
     *           .AND.(ABS(WL-396.).GT.1.)) THEN
              IR = 0
              IG = 0
              IB = 0
            ENDIF
         ELSEIF (ITYPE.EQ.4) THEN
            IF ((ABS(WL-656.).LT.1.1).or.(ABS(WL-486.).LT.1.1).or.
     *          (ABS(WL-433.).LT.1.1).or.(ABS(WL-410.).LT.1.1)
     *           .or.(ABS(WL-396.).LT.1.1)) THEN
              IR = 0
              IG = 0
              IB = 0
            ENDIF
         ENDIF

         WRITE(20,*) IR, IG, IB
        ENDDO
       ENDDO
       STOP
       END