!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_dimsmod.f90,v $:
! $Revision: 1.30 $
! $Author: jorissen $
! $Date: 2012/06/29 01:05:24 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module DimsMod
  ! This module contains dimensions for data arrays

! The file in which dimensions current to the calculation are saved :
  character*20, parameter :: dimFName = '.dimensions.dat'
! Set the following according to max. available memory on your system :
! The hardcoded limit on cluster size that can NEVER be exceeded :
  integer, parameter :: nclusxhardlimit = 3000
! The hardcoded upper limit on l-values that can NEVER be exceeded :
  integer, parameter :: lxhardlimit = 20
! The hardcoded upper limit on the number of potentials that can NEVER be exceeded :
  integer, parameter :: nphxhardlimit = 31
  private dimFName, lxhardlimit, nclusxhardlimit !! Meaning no other code can change these ...

  integer,parameter :: nclxtd = 100     ! Maximum number of atoms for tdlda module.
  integer,parameter :: nspx   = 1       ! Max number of spins: 1 for spin average; 2 for spin-dep
  integer,parameter :: natx   = 2500    ! Max number of atoms in problem for the pathfinder and ffsort
  integer,parameter :: nattx  = 2500   ! Max number of atoms in problem for the rdinp
  integer,parameter :: nphx   = 14      ! Max number of unique potentials (potph)
  integer,parameter :: ltot   = 24      ! Max number of ang mom (arrays 1:ltot+1)
  integer,parameter :: nrptx  = 1251    ! Loucks r grid used through overlap and in phase work arrays
  integer,parameter :: nex    = 500     ! Number of energy points genfmt, etc.
  integer,parameter :: lamtot = 15      ! Max number of distinct lambda's for genfmt 15 handles iord 2 and exact ss
  integer,parameter :: mtot   = 4       ! Vary mmax and nmax independently
  integer,parameter :: ntot   = 2 
  integer,parameter :: npatx  = 8       ! Max number of path atoms, used  in path finder, NOT in genfmt
  integer,parameter :: legtot = npatx+1 ! Matches path finder, used in GENFMT
  integer,parameter :: novrx  = 8       ! Max number of overlap shells (OVERLAP card)
  integer,parameter :: nheadx = 20+nphxhardlimit      ! Max number of header lines !KJ 7-09 added term to accomodate large systems in xsect.bin header
  integer,parameter :: MxPole = 1000    ! Max number of poles that can be used to model epsilon^-1 for HL multipole self energy
  integer,parameter :: nwordx = max(100,2+2*nphxhardlimit)     ! An infuriatingly stupid parameter that shows up in a few places. KJ added 7-09.  used to be 20 - must be at least 2*(1+nphx) for feff.bin header.
  integer,parameter :: novp = 40 ! For istprm, movrlp, ovp2mt - an atom list cutoff that should be high enough to include one atom of each potential type.  Added 2-2011 !KJ

! NON PARAMETER STATEMENTS
  integer :: nclusx    ! Maximum number of atoms for FMS.
  integer :: lx        ! Max orbital momentum for FMS module.

  ! OLD XPARAM.H MODULE
  integer,parameter :: natxx = natx
  integer,parameter :: nexx = nex
  integer,parameter :: nkmin = 1
  integer,parameter :: nphasx = nphx
  integer :: istatx

contains

  subroutine write_dimensions(nclusxuserlimit,lxuserlimit)
    implicit none
    ! Write dimension data to a file
	integer,intent(in) :: nclusxuserlimit,lxuserlimit
    integer :: ios  ! IO Status

!   3/ Apply hardcoded dimension limits
    if(nclusxuserlimit.gt.0) then
	   nclusx=min(nclusx,nclusxuserlimit)
	else
	   nclusx=min(nclusx,nclusxhardlimit)
	endif
    if(lxuserlimit.ge.0) then
	   lx=min(lx,lxuserlimit)
	else
       lx=min(lx,lxhardlimit)
	endif
    open(10,FILE=trim(dimFName),STATUS='unknown',FORM='formatted',IOSTAT=ios)
    call chopen(ios,trim(dimFName),'dimsmod')
    if (ios.ne.0) stop "Error writing dimensions.dat.  Quiting."
    
    write(10,*) nclusx,lx
    close(10)
  end subroutine write_dimensions


  subroutine init_dimensions
    implicit none
    ! Read dimensions from file
    integer :: ios  ! IO Status
    open(10,FILE=trim(dimFName),STATUS='old',FORM='formatted',IOSTAT=ios)
    call chopen(ios,trim(dimFName),'dimsmod')
    read(10,*) nclusx,lx
    close(10)
    ! OLD XPARAM DIMENSIONS
    istatx=(lx+1)**2*nclusx*nspx
  end subroutine init_dimensions


end module DimsMod

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_controls.f90,v $:
! $Revision: 1.7 $
! $Author: bmattern $
! $Date: 2012/02/09 18:04:57 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*****************************************************************************
!       CONTROL THE WAY FEFF WORKS
!*****************************************************************************
      module controls
!    Switch to 1 for real space, 0 for reciprocal space
      integer spacy
!    Read sprkkr-structure file
      integer sprkkrstruct
!    Read sprkkr-potential file
      integer sprkkrpot
!    Read sprkkr-klist file
      integer sprkkrklist
!    Switch between real and complex spherical harmonics for the KKR structure factors
!    F for real, T for complex
      logical,parameter :: cplxylm=.false.
!    Arrays are allocated via kprep
      logical allocated
!    Use spin/relativistic matrices or not (LM basis) :
      integer irel
!    Set verbosity of SPRKKR subroutines
      integer iprint
!    Set up k-mesh in ffmod3
      logical makekmeshnow
!    Use a core hole or not
      logical corehole
!    Strength of the core hole - 1 is normal, 0 is nohole
      real*8 cholestrength       ! multiply core hole t-matrix by this number.  Currently strongly suggested to stay away from it!
!    Use single precision in strbbdd
      logical,parameter :: singleprec=.false.
!    Use full potential (t-matrix) or muffin tin potential (phases)
      logical fullpot      
      logical gglu_save_slice !BAM 2/2012

        CONTAINS
        subroutine init_controls
        spacy=1  ! real space
        sprkkrstruct=0
        sprkkrpot=0
        sprkkrklist=0
        makekmeshnow=.false. !use k-mesh from file
        allocated=.false.  ! not yet been in kprep
        irel=1  ! work in LM-basis
        iprint=0
        corehole=.false. !no core hole
        cholestrength=dble(1)
        open(96,file='ini.inp',status='old',err=2341)
        read(96,*,err=2341,end=2341) sprkkrstruct,sprkkrpot,sprkkrklist
        close(96)
2341    continue
        fullpot=(sprkkrpot.eq.1)
        gglu_save_slice = .false. ! BAM - save slice of g with n=0 in gglu
        return	          	
        end subroutine init_controls

        end module controls

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_kklist.f90,v $:
! $Revision: 1.8 $
! $Author: jorissen $
! $Date: 2012/01/30 06:01:58 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*****************************************************************************
!       THE K-MESH TO SAMPLE THE BRILLOUIN ZONE
!*****************************************************************************
        module kklist
!    Number of k-points for the BZ mesh
      integer nkp
!    BZ mesh size, specified as nkx x nky x nkz
     integer nkx,nky,nkz
!    Use symmetry (1) or not (0) for this mesh
      integer usesym
!    Type of k-mesh
      integer ktype
	  ! ktype=1  :  regular mesh of nkp points for all modules
	  ! ktype=2  :  use nkp points for ldos/fms and nkp/5 points for pot  (significant time savings)
	  ! ktype=3  :  use nkp points for ldos/fms and nkp/5 points for pot (near edge) ; reduce nkp for all modules as we get away from near-edge
!    Rotation matrices for spherical harmonics
      !complex*16 drot(32,32,48,2)  !lx=3
      complex*16 drot(50,50,48,2)   !lx=4
        complex*16, allocatable :: mrot(:,:,:)
!    The k-mesh itself!
      real*8, allocatable :: bk(:,:)
!    Corresponding integration weights
      real*8, allocatable :: weight(:)
!    Sum of the integration weights
      real*8 sumweights
!    Correspondence between wien2k and sprkkr symmetry matrices
      integer symid(2,48)
!    Arrays that code for the relation between full and reduced k-mesh
      integer,allocatable :: intn(:),inti(:,:,:)
!    Which symmetries are actually used for the k-mes
      integer symact(48)
!    More arrays
      real*8,allocatable :: intw(:,:)


      CONTAINS
          subroutine init_kklist(n,nsym) !KJ 6-09
!            use struct,only: nsym !KJ 6-09
            implicit none
            integer,intent(in) :: n,nsym !KJ added nsym 6-09
            allocate(bk(3,n),weight(n))
            allocate(intn(n),inti(n,nsym,2),intw(n,nsym))
            intn=0
            inti=0
            intw=dble(0)
            symact=0
            bk=dble(0)
            weight=dble(0)
            sumweights=dble(0)
            symid=0
          end subroutine init_kklist

          subroutine destroy_kklist
		     if(allocated(bk)) deallocate(bk)
		     if(allocated(weight)) deallocate(weight)
		     if(allocated(inti)) deallocate(inti)
		     if(allocated(intn)) deallocate(intn)
		     if(allocated(intw)) deallocate(intw)
          end subroutine destroy_kklist

        end module kklist

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_strfacs.f90,v $:
! $Revision: 1.4 $
! $Author: jorissen $
! $Date: 2011/11/23 22:57:43 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*****************************************************************************
!       THE KKR STRUCTURE FACTORS
!*****************************************************************************
        module strfacs
!    Ewald parameter
      real*8 streta
!    R-space cutoff
      real*8 strrmax
!    K-space cutoff
      real*8 strgmax
!    Energy broadening
      real*8 eimag
!    Structure factor
        complex,allocatable :: gk(:,:,:)

      CONTAINS
          subroutine init_strfacs
           !streta=dble(0)
           !strrmax=dble(0)
           !strgmax=dble(0)
           eimag=dble(0)
!	   open(98,file='eimag.txt',err=1010)
!	   read(98,*,err=1010,end=1010) eimag
!	   close(98)
           return
1010       eimag=dble(0);return
          end subroutine init_strfacs
        subroutine init_gk(n,j)
           implicit none
           integer n,j
           allocate(gk(n,n,j))  !nkkrmax,nkkrmax,nemax,nktabmax)
           gk=cmplx(0,0)
          end subroutine init_gk
          subroutine exit_gk
           deallocate(gk)
          end subroutine exit_gk

        end module strfacs

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_struct.f90,v $:
! $Revision: 1.12 $
! $Author: jorissen $
! $Date: 2012/01/31 22:47:21 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*****************************************************************************
!       DEFINE THE UNIT CELL
!*****************************************************************************
      module struct

!    The space group
      integer sgroup  ! goes from 1 to 230
!    The H-M name of the space group
      character*8 sgroup_hm	  
!    The Bravais lattice
      character*3 latticename ! can be P,F,H,R,B,CXZ,CYZ
!    Similar to the above; here we only want to know whether we're in the "primitive" lattice or a "conventional" lattice	  
      character*1 lattice  ! allowed values :  P,F,I,B,C
!    The lattice constants
      real*8 alat(3),alfalat(3)
!    The lattice vectors
      real*8 a1(3),a2(3),a3(3)
!    The reciprocal lattice vectors
      real*8 b1(3),b2(3),b3(3)
!    Number of atoms
      integer nats
!    Number of potentials
      integer nph
!    Number of atoms per potential type
      integer,allocatable :: natom(:)
!    Index of representative atom for a potential type in the list of the atom positions of the unit cell
      integer,allocatable :: firstpos(:)	  
!    Positions of all atoms
      real*8, allocatable :: ppos(:,:)
!    Potential type of each position
      integer, allocatable :: ppot(:)
!    Position containing the absorber
      integer absorber
!    Angular expansion limit of potential
      integer,allocatable :: lpot(:)
!    Atom type for each potential
      character*2,allocatable :: label(:)
!    Atomic number z for each potential
      integer,allocatable :: izatom(:)	  
!    Number of spin states
      integer nsp
!    Volume of the unit cell :
      real*8 celvol
!    Volume of the reciprocal unit cell
      real*8 volbz
!    Symmetry operations of the crystal
      real*8 cryst_gr(3,4,48,2)
!     cryst_gr(:,:,:,2) : in lattice coordinates
!     cryst_gr(:,:,:,1) : in carthesian coordinates
!    Number of symmetry operations of the crystal
      integer nsym
!    The Bravais matrix, in units 2 pi / a_i
      real*8 bramat(3,3)
!    Real space basis matrix
      real*8 rbas(3,3)
!    Reciprocal space basis matrix
      real*8 gbas(3,3)
!    Is the real space basis orthogonal or not
      logical ortho

        CONTAINS

        subroutine init_struct(n)
        implicit none
        integer n


		if(allocated(ppos)) write(*,*) 'ppos is allocated'
		if(allocated(ppot)) write(*,*) 'ppot is allocated'
		if(allocated(lpot)) write(*,*) 'lpot is allocated'
		if(allocated(natom)) write(*,*) 'natom is allocated'

        allocate(ppos(3,n),ppot(n),lpot(0:n),natom(n),label(0:n),izatom(0:n),firstpos(n))
        ppos=dble(0)
        natom=0
        ppot=-1
        lpot=-1
		label(:)='     '
        if(absorber.lt.1.or.absorber.gt.n) absorber=1
        if( (latticename.ne.'P  '.and.latticename.ne.'F  '.and.latticename.ne.'I  '.and.latticename.ne.'CXZ'.and.latticename.ne.'CYZ'.and.latticename.ne.'H  ' &
		       .and.latticename.ne.'R'.and.latticename.ne.'B  '.and.latticename.ne.'CXY')  .or.  &
            (lattice.ne.'P'.and.lattice.ne.'F'.and.lattice.ne.'I'.and.lattice.ne.'C'.and.lattice.ne.'H'.and.lattice.ne.'R'.and.lattice.ne.'B')  ) then
		   call wlog('Setting unknown lattice type '//latticename//' '//lattice//'  to P.')
		   lattice='P'
		   latticename='P  '
		endif
        if(sgroup.lt.1.or.sgroup.gt.230) sgroup=1
        ortho=.false.
        gbas=dble(0)
        rbas=dble(0)
        bramat=dble(0)
        cryst_gr=dble(0)
        nsym=0

        end subroutine init_struct

        end module struct

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_inpmodules.f90,v $:
! $Revision: 1.61 $
! $Author: jorissen $
! $Date: 2012/10/23 20:08:40 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     This file written by Kevin Jorissen 7-09

!     THIS FILE REPLACES ALLINP.H AND MOST OF WRTALL.F90, INIALL.F90.


!     LAYOUT - PLEASE READ FIRST !!
!     Each module contains :
!      - a list of variables and parameters
!      - a module_write subroutine to write variables to a module.inp file
!      - a corresponding module_read subroutine
!      - a module_init subroutine to specify default values

!     Note to programmers : use of implicit none for each module MANDATORY
!     since a small mistake here could otherwise have very messy repercussions.

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     We're getting so many input parameters, some of them optional, that passing them through "rdmodxinp" subroutines is getting messy.
!     It also makes updating options difficult and messy.

!     FEFF is set up in the following way : each subprogram starts by reading a file containing all the settings that determines how it should run.
!     Hence, manipulation of this single file allows the user to tweak any subprogram.
!     However, obviously some variables control more than one subprogram.
!     Still they can belong to only one module!
!     To keep things manageable, such variables will either be put in the global_inp module ;
!     or in the module of the first subprogram (first w.r.t. normal program flow) that needs it.
!     All other modules will then have to call the first module with a "use module_x, only : var_x" statement.
!     The choice is sometimes a bit arbitrary.

!     Note that the only alternative would be to make the input files such that each variable occurs only once.
!     This would make the modules much cleaner, ie no use statements necessary.
!     However, it would then be less easy for the user to see which variables affect a particular subprogram he wants to run.
!     Also, changing the input file would then affect all subprograms needing that input file.
!     (This is already the case for quite a few input files, such as eels.inp, reciprocal.inp, global.inp, ...)


!     Ideally, in the future, defaults will be set as private parameters in each module's INIT subroutine.
!     Then, input files might not have to contain some optionals, and parameters could be defined free-format using XML.

!     Even more ideally, in a very distant future, each line will contain only one variable declaration
!     paired with a comment line describing its function ...



!     I REALLY THINK IT'S BEST TO KEEP ALL THESE MODULES IN ONE FILE ; or at least in a separate folder so they don't get mixed up
!     with everything else ...






!=======================================================================
!     GEOMETRY
!=======================================================================

      module geometry_inp
	    use dimsmod, only: nattx
		implicit none
	!c    atoms.dat
		integer  natt
		integer iphatx(nattx)
		double precision  ratx(3,nattx)

		contains

		subroutine geometry_write_atoms
			integer iat
                         double precision distance
			!c    atoms.dat to be read by ffsort, which will write smaller geom.dat file
			open (file='atoms.dat', unit=3, status='unknown')
			  write (3, 35) natt
		  35    format ('natx =  ', i7)
			  write (3, 10) '    x       y        z       iph  '
			  do iat = 1, natt
                               distance=dsqrt((ratx(1,iat)-ratx(1,1))**2+(ratx(2,iat)-ratx(2,1))**2+(ratx(3,iat)-ratx(3,1))**2) ! core hole should be in position 1 by now
				write(3,36) ratx(1,iat), ratx(2,iat), ratx(3,iat), iphatx(iat), distance
		  36      format( 3f13.5, i4, f13.5)
			  enddo
			close(3)
		  10  format(a)
		  20  format (20i4)
		  30  format (9f13.5)
		end subroutine geometry_write_atoms

		subroutine geometry_init
			natt = 0
			iphatx(:) = -1
			ratx(:,:) = 0.d0 !KJ added 7-09
		end subroutine geometry_init

      end module


!=======================================================================
!     ATOMS
!=======================================================================

	  module atoms_inp
	  ! The geom.dat file
	    use dimsmod,only: natx,nphx,nheadx
        implicit none
	    integer nat, nph, iatph(0:nphx), iphat(natx), ibounc(natx)
		! ibounc is currently set to 1 for all atoms in ffsort.  Path uses it.  Probably discontinued variable but ah well. !KJ
	    double precision  rat(3,natx)
		character(*),parameter,private :: filename='geom.dat'
!		iphat(natx)  -  given specific atom, which unique pot?
!		rat(3,natx)  -  cartesian coords of specific atom
!		iatph(0:nphx)  - given unique pot, which atom is model?
!                      (0 if none specified for this unique pot)

		contains

		subroutine atoms_read
	!		Read  geom.dat file
                       implicit none
		    character*512 slog
			character*80 head(nheadx)
			integer lhead(nheadx),j,j1,nhead
                        real*8 rdum1(3)
                        integer idum1,idum2
			open (file=filename, unit=3, status='old')
!			read header
			nhead = nheadx
			call rdhead (3, nhead, head, lhead)
			nat = 0
		    nph = 0
			iatph(:)=0
  50		continue
!KJ I switched up statements below so that code doesn't falsely abort when nat=natx.
!KJ			nat = nat+1
			if (nat .gt. natx)  then
              write(slog,'(a, 2i10)') ' nat, natx ', nat, natx
              call wlog(slog)
              stop 'Bad input'
			endif
                        read(3,*,end=60) j1,rdum1(1:3),idum1,idum2
			nat = nat+1
                        rat(1:3,nat)=rdum1(1:3)
                        iphat(nat)=idum1
                        ibounc(nat)=idum2
!KJ			read(3,*,end=60)  j1, (rat(j,nat),j=1,3), iphat(nat), ibounc(nat) !KJ j2  !KJ put ibounc back in for program PATH
			if (iphat(nat).gt.nph) nph = iphat(nat)
			if ( iatph(iphat(nat)).eq.0) iatph(iphat(nat)) = nat
			goto 50
  60		continue
!KJ			nat = nat-1
			close(3)
		end subroutine atoms_read

	  end module




!=======================================================================
!     GLOBAL
!=======================================================================

      module global_inp
        implicit none
	!	the variables evnorm, xivnorm, spvnorm and l2lp are exclusive to nrixs (feffq) calculations
	!	le2 has different meaning for feffq calculations
	!	xivec serves many different functions depending on spectroscopy : xas/eels/nrixs
		integer do_nrixs,lj,ldecmx !KJ 7-09 for feff8q
	!	configuration average data :
		integer nabs, iphabs
		real*8 rclabs
	!	global polarization data :
		integer ipol, ispin, le2, l2lp
		real*8 elpty, angks
		real*8 evec(3), xivec(3), spvec(3)
		complex*16 ptz(-1:1,-1:1)
		double precision evnorm, xivnorm, spvnorm
	!   moved here because I think it belongs here !KJ 7-09
		integer ispec
		character(*),parameter,private :: filename='global.inp'  !KJ used to be global.dat !!!
!       How many q-vectors:  (impulse transfer)		
		integer nq
!       Are we doing direction averaged impulse transfer?  (Note: this means q || e_z, which is not really averaging!)		
		logical qaverage
!       The list of q-vectors and their norm:		
		real*8,allocatable :: qs(:,:),qn(:)
!       Weights of q-vectors in the cross-section (probably calculated by another code):
        complex*16,allocatable :: qw(:)		
!       Are we doing q,q' crossterms in the NRIXS code?
        logical mixdff
!       If entering q, q' as length(q), length(q'), angle(q,q'), this is cosine(angle(q,q'))
        real*8,allocatable :: cosmdff(:,:)		
!       and this is norm(q')
        real*8 qqmdff
!       A rotation matrix for each q-vector  (containing cos(theta),sin(theta),cos(fi),sin(fi) for each q)
        real*8,allocatable :: qtrig(:,:)  !compare to Adam's code qtrig(iq,1)=qcst(iq); 2)=qsnt; 3)=qcsf; 4)=qsnf
!       Should the mdff program run? !11-2010
        integer imdff

		contains

		subroutine init_feffq
	!	called to calculate some variables for nrixs
			integer i
			evnorm=0.0d0
			xivnorm=0.0d0
			spvnorm=0.0d0
			do i=1,3
			   evnorm=evnorm+evec(i)*evec(i)
			   xivnorm=xivnorm+xivec(i)*xivec(i)
			   spvnorm=spvnorm+spvec(i)*spvec(i)
			end do
			spvnorm=sqrt(spvnorm)
			xivnorm=sqrt(xivnorm)
			evnorm=sqrt(evnorm)
		end subroutine init_feffq

		subroutine global_write(iniq)
			integer i
			logical,intent(in) :: iniq
			if(iniq) call init_feffq
			open (file=filename, unit=3, status='unknown')
			write (3, 10) ' nabs, iphabs - CFAVERAGE data'
			write (3, 45) nabs, iphabs, rclabs
		  45	  format ( 2i8, f13.5)
			write (3,10) ' ipol, ispin, le2, elpty, angks, l2lp, do_nrixs, ldecmx, lj' !KJ last 4 added for feff8q.  Note le2 new meaning in feff8q
			write (3, 50)  ipol, ispin, le2, elpty, angks, l2lp, do_nrixs, ldecmx, lj !KJ
		  50	  format ( 3i5, 2f12.4, 10i5)  !KJ
			write (3, 10) 'evec		  xivec 	   spvec'
			do 60 i = 1,3
			write (3,30) evec(i), xivec(i), spvec(i)
		  60	  continue
			write (3, 10) ' polarization tensor '
			do 70 i = -1, 1
				write(3,30) dble(ptz(-1,i)), dimag(ptz(-1,i)), dble(ptz(0,i)), dimag(ptz(0,i)),  dble(ptz(1,i)), dimag(ptz(1,i))
		  70	  continue
		!KJ for feff8q - was in different place in file in feff8q:
			write(3,10) 'evnorm, xivnorm, spvnorm - only used for nrixs'
			write (3,30) evnorm, xivnorm, spvnorm !KJ
		!KJ for a list of q-vectors (NRIXS) and MDFF calculation (NRIXS) - only relevant for NRIXS calculations  12-2010
			write(3,10) "nq,    imdff,   qaverage,   mixdff"
			   write(3,*) nq,imdff,qaverage,mixdff
			write(3,*) 'q-vectors : qx, qy, qz, q(norm), weight, qcosth, qsinth, qcosfi, qsinfi'
			if(nq.gt.0) then    !note that this is redundant with xivec if nq=1, but ah well.
			   do i=1,nq
			      write(3,30) qs(i,:),qn(i),qw(i),qtrig(i,1:4)
			   enddo
	        endif 
			if(mixdff) then
			   write(3,*) "   qqmdff,   cos<q,q'>"
			   write(3,*) qqmdff,cosmdff
		    endif
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (20f13.5)

		end subroutine global_write

		subroutine global_read
			real*8 aa1,bb1,aa2,bb2,aa3,bb3
			integer i
			open (file=filename, unit=3, status='old')
			read  (3,*)
			read  (3,*) nabs, iphabs, rclabs
			read  (3,*)
			read  (3,*)  ipol, ispin, le2, elpty, angks, l2lp, do_nrixs, ldecmx, lj
			read  (3,*)
			do i = 1,3
			  read  (3,*) evec(i), xivec(i), spvec(i)
			enddo
			read  (3,*)
			do i = -1, 1
			  read (3,*) aa1, bb1, aa2, bb2, aa3, bb3 !KJ changed names of dummies to avoid confusion with my WELL DEFINED arrays (f*cking "implicit" people !#$&%)
			  ptz(-1,i)= dcmplx(aa1,bb1)  !KJ changed cmplx to dcmplx to satisfy thorough compilers
			  ptz(0,i) = dcmplx(aa2,bb2)
			  ptz(1,i) = dcmplx(aa3,bb3)
			enddo
			read (3,*)
			read (3,*) evnorm, xivnorm, spvnorm !KJ
			if(do_nrixs .ne. 0) then !compatibility with (most) old files
		       read(3,*) 
			   read(3,*) nq,imdff,qaverage,mixdff
			   read(3,*)
			   call make_qlist(nq)
			   if(nq.gt.0) then    !note that this is redundant with xivec if nq=1, but ah well.
			      do i=1,nq
			         read(3,30) qs(i,:),qn(i),qw(i),qtrig(i,1:4)
			      enddo
	           endif  
			   if(mixdff) then
			      read(3,*) 
				  read(3,*) qqmdff,cosmdff
			   endif
	  30  format (20f13.5)
			endif
			close(3)
		end subroutine global_read
		
		subroutine make_qlist(n)
		    implicit none
			integer,intent(in) :: n
			allocate(qs(n,3),qn(n),qw(n),qtrig(n,4),cosmdff(n,n))
			qs(:,:)=0.d0
			qn(:)=0.d0
			qw(:)=1.d0
			qtrig(:,:)=0.d0
			qtrig(:,1)=1.d0
			qtrig(:,3)=1.d0 !corresponding to not rotating at all
			cosmdff(:,:)=1.d0
		    return
		end subroutine make_qlist

        subroutine make_qtrig
!          simple routine to get rotation angles; copied from mkptz      
           implicit none
           double precision rr,rsp
           integer iq
	       do iq=1,nq
              if (qn(iq).gt.0.0d0) then
                 rsp = qn(iq)
                 rr = qs(iq,1)**2 + qs(iq,2)**2
				 if (rr.eq. 0) then
					qtrig(iq,1) = - 1.d0
					qtrig(iq,2) = 0.d0
					qtrig(iq,3) = 1.d0
					qtrig(iq,4) = 0.d0
				elseif (qs(iq,3).lt.0) then !meaning forward scattering ??
!                  rotation is defined by angles theta and fi
				   rr = sqrt(rr)
				   qtrig(iq,1) = qs(iq,3) / rsp
				   qtrig(iq,2) = rr / rsp
				   qtrig(iq,3) = qs(iq,1) / rr
			       qtrig(iq,4) = qs(iq,2) / rr
				else 
                   qtrig(iq,1)=1.0d0
                   qtrig(iq,2)=0.0d0
                   qtrig(iq,3)=1.0d0 !surely this is a bug??  Shouldn't this be 1? !KJ 12-2011 changed 0->1 because produces NaN in genfmt otherwise
                   qtrig(iq,4)=0.0d0
				end if
              else
                 call wlog(' FATAL error: one of the q-vectors is zero')
                 call par_stop(' ') 
              endif
		   enddo !iq  
           return 
        end subroutine make_qtrig		

		subroutine global_init
			ispec = 0
			ldecmx=-1 ! initialize the number of decomposition channels - KJ 7-09 for feff8q
			nabs = 1
			iphabs = 0
			rclabs = 0.d0
			ipol = 0
			ispin = 0
			le2 = 0
			l2lp = 0
			elpty = 0.d0
			angks = 0.d0
			evec(:) = 0.d0
			xivec(:) = 0.d0
			spvec(:) = 0.d0
			ptz(:,:) = cmplx(0.d0,0.d0)
			evnorm=0.0d0
			xivnorm=0.0d0
			spvnorm=0.0d0
			do_nrixs=0 ! no nrixs calculation
			lj = -1
			nq=0
			qaverage=.true.
			imdff=0 !no mdff
			mixdff=.false. !no mdff in NRIXS
		!	cosmdff=1.d0  ! q || q'  => cos(0)=1     !KJ 11-2011 this is now an allocatable array.  Instruction fails on gfortran.
			qqmdff=-1.d0 ! leads to q=q' (norm only)
		end subroutine global_init


	end module 



!=======================================================================
!     RECIPROCAL
!=======================================================================

      module reciprocal_inp
	!     k-space variables :
		use controls  !KJ 8/06
		use struct, nphstr => nph
		use kklist,only: nkp,usesym,nkx,nky,nkz,ktype
        use strfacs,only: streta,strrmax,strgmax,init_strfacs
		implicit none
		integer icorehole
		real*8 streimag ! additional broadening for calculation KKR structure factors ; not recommended
		character(*),parameter,private :: filename='reciprocal.inp'

		contains

		subroutine reciprocal_write
		!KJ next file added 8/06
		    integer i
			open (file=filename, unit=3, status='unknown')
		!       in which space are we?
			write(3,10) 'spacy'
			write(3,20) spacy
			if(spacy.eq.0) then
			   write(3,10) 'lattice vectors  (in A, in Carthesian coordinates)'
			   write(3,30) a1
			   write(3,30) a2
			   write(3,30) a3
			   write(3,10) 'Volume scaling factor (A^3); eimag; core hole'
			   write(3,30) dble(-1),dble(0),dble(1)
			   write(3,10) 'lattice type  (P,I,F,R,B,CXY,CYZ,CXZ)'
			   write(3,10) latticename
			   write(3,10) '#atoms in unit cell ; position absorber ; corehole?'
			   write(3,20) nats,absorber,icorehole
			   write(3,10) '# k-points total/x/y/z ; ktype; use symmetry?'
			   write(3,*) nkp,nkx,nky,nkz,ktype,usesym  ! format line 20 limits integer to 4 positions - not enough for nkp!
			   write(3,10) 'ppos'
			   do i=1,nats
				  write(3,30) ppos(:,i)
			   enddo
			   write(3,10) 'ppot'
			    !KJ bugfix 5/2012: It's important not to use formatting when there are more atoms than fit on one line!!			   
			   write(3,*) ppot
			   write(3,10) 'streta,strgmax,strrmax'
			   write(3,30) streta,strgmax,strrmax
				endif
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (9f13.5)
		end subroutine reciprocal_write

		subroutine reciprocal_read(celvin)
		use struct, nphstr => nph
		integer i
		real*8,intent(out) :: celvin
        open (3,file=filename,status='unknown',err=167)
        read(3,*,end=167,err=167)
        read(3,*,end=167,err=167) spacy
        if(spacy.eq.0) then
             read(3,*) ; read(3,*) a1(:)
        	 read(3,*) a2(:)
        	 read(3,*) a3(:)
        	 read(3,*) ; read(3,*) celvin,streimag,cholestrength
        	 read(3,*) ; read(3,*) latticename
			 lattice=latticename(1:1)
             read(3,*) ; read(3,*) nats,absorber,icorehole
             read(3,*) ; read(3,*) nkp,nkx,nky,nkz,ktype,usesym
             read(3,*)
			 !Careful: the next statement used to be "if size(ppot).eq.0".  However, on ifort size(ppot)=0 but on gfortran it =1!!
			 !Hence the new instruction.
			 !I wish if(allocated(ppot)) would work here; I don't understand why it doesn't.
        	 if(size(ppot).lt.nats) call init_struct(nats) !KJ 7-09 bugfix call this only once ; I can't seem to use "allocated(ppos)" here?
	         do i=1,nats
	             read(3,*) ppos(:,i)
	         enddo
             read(3,*) ; read(3,*) ppot
             read(3,*) ; read(3,*) streta,strgmax,strrmax
			 if(icorehole.eq.1) then
				corehole=.true.
			 else
				corehole=.false.
			 endif
		endif
        return
167     spacy=1
        return
		end subroutine reciprocal_read

		subroutine reciprocal_init
			call init_controls
			call init_strfacs
			icorehole = 1  ! use core hole
			streimag = dble(0) ! no extra broadening for KKR struc factors
			cholestrength = dble(1) ! don't mess with core hole
		end subroutine reciprocal_init
        
	end module






!=======================================================================
!     POTENTIAL
!=======================================================================

      module potential_inp
		use dimsmod, only: nheadx, nphx, novrx
		use global_inp, only: ispec
		use atoms_inp, only : nph
		implicit none
		character(*),parameter,private :: filename='pot.inp'

		character*80 title(nheadx)
		integer mpot, ntitle, ihole, ipr1, iafolp, iunf,             &
			nmix, nohole, jumprm, inters, nscmt, icoul, lfms1, ixc
		integer iz(0:nphx)
!		iz(0:nphx)    - atomic number, input
		integer lmaxsc(0:nphx)
		real rfms1
		double precision gamach, rgrd, ca1, ecv, totvol
		double precision  xnatph(0:nphx), folp(0:nphx), spinph(0:nphx)
!		xnatph(0:nphx) - given unique pot, how many atoms are there
!                      of this type? (used for interstitial calc)
!		folp(0:nphx) -  overlap factor for rmt calculation
		double precision  xion(0:nphx)
!		xion(0:nphx)  - ionicity, input
		logical ExternalPot
	!     for OVERLAP option
	    logical StartFromFile
		! read potential from pot.bin file and start from there
		integer novr(0:nphx), iphovr(novrx,0:nphx), nnovr(novrx,0:nphx)
		double precision  rovr(novrx,0:nphx)
!		novr(0:nphx) -  number of overlap shells for unique pot
!		iphovr(novrx,0:nphx) -  unique pot for this overlap shell
!		nnovr(novrx,0:nphx) -   number of atoms in overlap shell
!		rovr(novrx,0:nphx)  -   r for overlap shell
		! Added by Fer
		! Used to correct the excitation energy for chemical shifts
		integer  ChSh_Type
		integer configtype !KJ 12-2010 : which method for choosing atomic configuration?
		double precision corval_emin  !KJ 12-2012 defines energy window for search for core-valence separation energy.

!       criteria for self-consistency
        real*8,parameter :: tolmu = 1.D-3  ! Fermi level (Ha)
        real*8,parameter :: tolq = 1.D-3   ! net charge on atom iph (e)
	    real*8,parameter :: tolqp = 2.D-4  ! partial charge (e.g. l=1) on atom iph (e)
	    real*8,parameter :: tolsum = 0.05  ! total valence charge in Norman sphere compared to formal valence charge


		contains

		subroutine potential_write
			integer ititle,ip,iph,iovr			
			open (file=filename, unit=3, status='unknown')
			  write(3,10) 'mpot, nph, ntitle, ihole, ipr1, iafolp, ixc,ispec'
			  write(3,20) mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec
			  write(3,10) 'nmix, nohole, jumprm, inters, nscmt, icoul, lfms1, iunf'
			  write(3,20)  nmix, nohole, jumprm, inters, nscmt, icoul, lfms1, iunf
			  do ititle = 1, ntitle
		         write(3,10) title(ititle)
			  enddo
			  write(3,10) 'gamach, rgrd, ca1, ecv, totvol, rfms1, corval_emin'
			  write(3,30)  gamach, rgrd, ca1, ecv, totvol, rfms1, corval_emin
			  write(3,10) ' iz, lmaxsc, xnatph, xion, folp'
		  120   format ( 2i5, 4f13.5)
			  do ip = 0, nph
		        write(3,120) iz(ip), lmaxsc(ip), xnatph(ip), xion(ip), folp(ip)
			  enddo
			  write(3,10) 'ExternalPot switch, StartFromFile switch'
			  write(3,*) ExternalPot,StartFromFile
		!       for OVERLAP option
			  write(3,10) 'OVERLAP option: novr(iph)'
			  write(3,20) ( novr(iph), iph=0,nph)
			  write(3,10) ' iphovr  nnovr rovr '
		  140   format ( 2i5, f13.5)
			  do iph = 0, nph
			  do iovr = 1, novr(iph)
		         write(3,140) iphovr(iovr, iph), nnovr(iovr,iph), rovr(iovr,iph)
			  enddo
	          enddo
		! Added by Fer
		! Correction of the excitation energy for chemical shifts
			  write(3,10) 'ChSh_Type:'
			  write(3,20) ChSh_Type
			  write(3,10) 'ConfigType:'
			  write(3,20) configtype 
		close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (9f13.5)
		end subroutine potential_write

		subroutine potential_read
			integer ititle,ip,iph,iovr	
			open (file=filename, unit=3, status='old')
			  read(3,*) ; read(3,*) mpot, nph, ntitle, ihole, ipr1, iafolp, ixc, ispec
			  read(3,*) ; read(3,*)  nmix, nohole, jumprm, inters, nscmt, icoul, lfms1, iunf
			  do ititle = 1, ntitle
		         read(3,*) title(ititle)
			  enddo
			  read(3,*) ; read(3,*)  gamach, rgrd, ca1, ecv, totvol, rfms1, corval_emin
			  read(3,*)
			  do ip = 0, nph
		        read(3,*) iz(ip), lmaxsc(ip), xnatph(ip), xion(ip), folp(ip)
			  enddo
			  read(3,*) ; read(3,*) ExternalPot, StartFromFile
			  read(3,*) ; read(3,*) (novr(iph), iph=0,nph)
			  read(3,*)
			  do iph = 0, nph
			  do iovr = 1, novr(iph)
		         read(3,*) iphovr(iovr, iph), nnovr(iovr,iph), rovr(iovr,iph)
			  enddo
	          enddo
			  read(3,*) ; read(3,*) ChSh_Type
			  read(3,*,end=55) ; read(3,*,end=55) configtype
			  55 continue
			close(3)
		end subroutine potential_read

		subroutine potential_init
			title(:) = ' '
			mpot = 1
			nph = 0
			ntitle = 0
			ihole = 1
			ipr1 = 0
			iafolp = 0
			iunf = 0
			nmix = 1
			nohole = -1
			jumprm = 0
			inters = 0
			nscmt = 0
			icoul = 0
			ixc = 0
			lfms1 = 0
			iz(:) = -1
			lmaxsc(:) = 0
			rfms1 = -1 * 1.e0
			ca1 = 0.d0
			ecv = -40*1.d0 
			rgrd = 0.05 * 1.d0
			totvol = 0.d0
			gamach = 0.d0 !initialized later by setgam
			xnatph(:) = 0.d0
			spinph(:) = 0.d0
			xion(:) = 0.d0
			folp(:) = 1.d0
		    ExternalPot = .false.
			StartFromFile = .false. !KJ added 12-10
			novr(:) = 0
			iphovr(:,:)=0 !KJ added 7-09
			nnovr(:,:)=0 !KJ
			rovr(:,:) = 0.d0 !KJ
			ChSh_Type = 0 !Fer : standard feff
			configtype=1 !KJ 12-2010 standard feff9
			corval_emin=-70.d0 ! eV
		end subroutine potential_init

	end module

!=======================================================================
!     LDOS
!=======================================================================

      module ldos_inp
	    use atoms_inp,only: nph
        use potential_inp,only: ixc, rgrd
		use global_inp,only: ispin
		use dimsmod,only : nphx
		implicit none
		character(*),parameter,private :: filename='ldos.inp'
		integer mldos, lfms2, minv, lmaxph(0:nphx)
		double precision emin, emax, eimag
		integer neldos
		real rdirec, toler1, toler2, rfms2
        logical save_g0, save_compton_info ! BAM 2/2012

		contains

		subroutine ldos_write
			integer iph
			open (file=filename, unit=3, status='unknown')
			  write(3,10) 'mldos, lfms2, ixc, ispin, minv, neldos'
			  write(3,20)  mldos, lfms2, ixc, ispin, minv, neldos
			  write(3,10) 'rfms2, emin, emax, eimag, rgrd'
			  write(3,30)  rfms2, emin, emax, eimag, rgrd
			  write(3,10) 'rdirec, toler1, toler2'
			  write(3,30)  rdirec, toler1, toler2
			  write(3,10) ' lmaxph(0:nph)'
			  write(3,20)  (lmaxph(iph),iph=0,nph)
			  write(3,10) 'save_g0? save_compton_info?'
			  write(3,*)  save_g0, save_compton_info
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (9f13.5)
		end subroutine ldos_write

		subroutine ldos_read
			integer iph
			open (file=filename, unit=3, status='old')
			  read(3,*) ; read(3,*)  mldos, lfms2, ixc, ispin, minv, neldos
			  read(3,*) ; read(3,*)  rfms2, emin, emax, eimag, rgrd
			  read(3,*) ; read(3,*)  rdirec, toler1, toler2
			  read(3,*) ; read(3,*)  (lmaxph(iph),iph=0,nph)
			  read(3,*) ; read(3,*)  save_g0, save_compton_info
			close(3)
		end subroutine ldos_read

		subroutine ldos_init
			mldos = 0
			lfms2 = 0
			minv = 0
			emax = 0.d0
			emin = 1000*1.d0
			eimag = -1*1.d0
			neldos = 101
			rfms2 = -1 * 1.e0
			rdirec = -1 * 1.e0
			toler1 = 1.d-3
			toler2 = 1.d-3
			lmaxph(:) = 0
            save_g0 = .false.
            save_compton_info = .false.
		end subroutine ldos_init

	end module



!=======================================================================
!     SCREEN
!=======================================================================

      module screen_inp
	    use atoms_inp,only: nph		
		implicit none
		
                TYPE ScreenInputVars
                   integer ner, nei, maxl, irrh, iend, lfxc, nrptx0
                   double precision emin, emax, eimax, ermin, rfms
                END TYPE ScreenInputVars
                
                character(*),parameter,private :: filename='screen.inp'
                TYPE(ScreenInputVars) ScreenI

		contains

		subroutine screen_write
		           open(unit=3,file=filename,status='unknown')
				   write(3,*) 'ner',ScreenI%ner
				   write(3,*) 'nei',ScreenI%nei
				   write(3,*) 'maxl',ScreenI%maxl
				   write(3,*) 'irrh',ScreenI%irrh
				   write(3,*) 'iend',ScreenI%iend
				   write(3,*) 'lfxc',ScreenI%lfxc
				   write(3,*) 'emin',ScreenI%emin
				   write(3,*) 'emax',ScreenI%emax
				   write(3,*) 'eimax',ScreenI%eimax
				   write(3,*) 'ermin',ScreenI%ermin
				   write(3,*) 'rfms',ScreenI%rfms
				   write(3,*) 'nrptx0',ScreenI%nrptx0
                   close(3)
				   return
		end subroutine screen_write

        subroutine screen_inp_parse(str,vars)
		   implicit none
		   character*3,intent(in) :: str
		   real*8,intent(in) ::  vars
				if (str .eq. 'ner') then
				   ScreenI%ner   = vars
				elseif (str .eq. 'nei') then
				   ScreenI%nei   = vars
				elseif (str .eq. 'max') then
				   ScreenI%maxl  = vars
				elseif (str .eq. 'irr') then
				   ScreenI%irrh  = vars
				elseif (str .eq. 'ien') then
				   ScreenI%iend  = vars
				elseif (str .eq. 'lfx') then
				   ScreenI%lfxc  = vars
				elseif (str .eq. 'emi') then
				   ScreenI%emin  = vars
				elseif (str .eq. 'ema') then
				   ScreenI%emax  = vars
				elseif (str .eq. 'eim') then
				   ScreenI%eimax = vars
				elseif (str .eq. 'erm') then
				   ScreenI%ermin = vars
				elseif (str .eq. 'rfm') then
				   ScreenI%rfms  = vars
				elseif (str .eq. 'nrp')then
				   ScreenI%nrptx0  = vars
				else 
				   call wlog("Unrecognized keyword submitted to screen.inp in SCREEN_INP_PARSE ; aborting.")
				   stop
                endif
				return
		end subroutine screen_inp_parse

        subroutine screen_inp_parse_and_write(str,vars)
		!KJ No longer used (1-2012).  Used in a previous version of feff.
		   implicit none
		   character*3,intent(in) :: str
		   real*8,intent(in) ::  vars
		        open(unit=3,file=filename,status='unknown',access='append')
				if (str .eq. 'ner') then
				   ScreenI%ner   = vars
				   write(3,*) 'ner',ScreenI%ner
				elseif (str .eq. 'nei') then
				   ScreenI%nei   = vars
				   write(3,*) 'nei',ScreenI%nei
				elseif (str .eq. 'max') then
				   ScreenI%maxl  = vars
				   write(3,*) 'maxl',ScreenI%maxl
				elseif (str .eq. 'irr') then
				   ScreenI%irrh  = vars
				   write(3,*) 'irrh',ScreenI%irrh
				elseif (str .eq. 'ien') then
				   ScreenI%iend  = vars
				   write(3,*) 'iend',ScreenI%iend
				elseif (str .eq. 'lfx') then
				   ScreenI%lfxc  = vars
				   write(3,*) 'lfxc',ScreenI%lfxc
				elseif (str .eq. 'emi') then
				   ScreenI%emin  = vars
				   write(3,*) 'emin',ScreenI%emin
				elseif (str .eq. 'ema') then
				   ScreenI%emax  = vars
				   write(3,*) 'emax',ScreenI%emax
				elseif (str .eq. 'eim') then
				   ScreenI%eimax = vars
				   write(3,*) 'eimax',ScreenI%eimax
				elseif (str .eq. 'erm') then
				   ScreenI%ermin = vars
				   write(3,*) 'ermin',ScreenI%ermin
				elseif (str .eq. 'rfm') then
				   ScreenI%rfms  = vars
				   write(3,*) 'rfms',ScreenI%rfms
				elseif (str .eq. 'nrp')then
				   ScreenI%nrptx0  = vars
				   write(3,*) 'nrptx0',ScreenI%nrptx0
				else 
				   call wlog("Unrecognized keyword submitted to screen.inp ; aborting.")
				   stop
                endif
				close(3)
				return
		end subroutine screen_inp_parse_and_write


		subroutine screen_read
		    ! Reads screen.inp.  This routine is set up a little different from its brothers in the other input modules.
			! This is to keep it compatible with situations where there either is no screen.inp file (in which case defaults are used for all variables),
			! and with situations where screen.inp contains only the variables for which non-default values are specified.
			! This is because I've only added mandatory screen.inp files being written by rdinp now 1-2012.  KJ
			integer i
			character*8 strs
			character*3 str
			double precision vars
			call screen_init  !KJ set defaults in case screen.inp doesn't exist!
			open (file=filename, unit=3, status='old', err=60)
!KJ			read (3,*)  !KJ 11-2011 removing header line from screen.inp because it is incompatible with screen_inp_and_parse above.
			do i = 1, 12
				read(3,*,end=60)  strs, vars
				str = strs(1:3)
				if (str .eq. 'ner') ScreenI%ner   = nint(vars)
				if (str .eq. 'nei') ScreenI%nei   = nint(vars)
				if (str .eq. 'max') ScreenI%maxl  = nint(vars)
				if (str .eq. 'irr') ScreenI%irrh  = nint(vars)
				if (str .eq. 'ien') ScreenI%iend  = nint(vars)
				if (str .eq. 'lfx') ScreenI%lfxc  = nint(vars)
				if (str .eq. 'emi') ScreenI%emin  = vars
				if (str .eq. 'ema') ScreenI%emax  = vars
				if (str .eq. 'eim') ScreenI%eimax = vars
				if (str .eq. 'erm') ScreenI%ermin = vars
				if (str .eq. 'rfm') ScreenI%rfms  = vars
				if (str .eq. 'nrp') ScreenI%nrptx0  = nint(vars)
			end do
		  60 continue
		  close(3)
                  return
		end subroutine screen_read

		subroutine screen_init
		  ScreenI%ner   = 40
		  ScreenI%nei   = 20
		  ScreenI%maxl  = 4
		  ScreenI%irrh  = 1
		  ScreenI%iend  = 0
		  ScreenI%emin  = -40.0d0 !KJ This and next 3 values are in eV ; converted to Ha at a later point in the code (screen/rdgeom.f90)
		  ScreenI%emax  = 0.0d0
		  ScreenI%eimax = 2.0d0
		  ScreenI%ermin = 0.001d0
		  ScreenI%lfxc  = 0
		  ScreenI%rfms  = 4.0d0
		  ScreenI%nrptx0 = 251
		end subroutine screen_init

	end module


!=======================================================================
!     OPCONS
!=======================================================================
      MODULE opcons_inp
        USE dimsmod
        LOGICAL run_opcons, print_eps
        REAL(8) NumDens(0:nphx)
		character(*),parameter,private :: filename='opcons.inp'		
        
        CONTAINS
           SUBROUTINE opcons_init
              run_opcons = .FALSE.
              print_eps  = .FALSE.
              NumDens(:) = -1.d0
           END SUBROUTINE opcons_init

           SUBROUTINE opcons_write
              INTEGER iph

              OPEN(FILE=filename,UNIT=8,STATUS='REPLACE')

              WRITE(8,'(A)') 'run_opcons'
              WRITE(8,*) run_opcons
              WRITE(8,'(A)') 'print_eps'
              WRITE(8,*) print_eps
              WRITE(8,'(A)') 'NumDens(0:nphx)'
              WRITE(8,*) NumDens(0:nphx)

              CLOSE(8)
           END SUBROUTINE opcons_write

           SUBROUTINE opcons_read
              INTEGER iph

              OPEN(FILE=filename,UNIT=8,STATUS='OLD')

              READ(8,*)
              READ(8,*) run_opcons
              READ(8,*)
              READ(8,*) print_eps
              READ(8,*)
              READ(8,*) NumDens(0:nphx)
           END SUBROUTINE opcons_read

      END MODULE opcons_inp
!=======================================================================
!     XSPH
!=======================================================================

      module xsph_inp
        use dimsmod
		use global_inp
		use potential_inp
		use ldos_inp
		implicit none
		character(*),parameter,private :: filename='xsph.inp'
		integer mphase, ipr2, ixc0, lreal, iPlsmn
		integer iGammaCH, iGrid, NPoles
		character*6  potlbl(0:nphx)
!		potlbl(0:nphx)    -   label for user convienence
		double precision xkstep, xkmax, vixan, vr0, vi0, Eps0, EGap
		integer izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis
!		!KJ for the energy grid card EGRID :
		integer iegrid,egrid3a
		real*8 egrid3b,egrid3c
		character*100 egridfile
                logical lopt

		contains

		subroutine xsph_write
			integer iph
			open (file=filename, unit=3, status='unknown')
		!     Josh - added flag for PLASMON card (iPlsmn = 0, 1, or 2)
			  write(3,10) 'mphase,ipr2,ixc,ixc0,ispec,lreal,lfms2,nph,l2lp,iPlsmn,NPoles,iGammaCH,iGrid'
			  write(3,20)  mphase,ipr2,ixc,ixc0,ispec,lreal,lfms2,nph,l2lp,   &
			 &        iPlsmn, NPoles, iGammaCH, iGrid
			  write(3,10) 'vr0, vi0'
			  write(3,30)  vr0, vi0
			  write(3,10) ' lmaxph(0:nph)'
			  write(3,20)  (lmaxph(iph),iph=0,nph)
			  write(3,10) ' potlbl(iph)'
			  write(3,170)  (potlbl(iph),iph=0,nph)
		  170   format (13a6)
			  write(3,10) 'rgrd, rfms2, gamach, xkstep, xkmax, vixan, Eps0, EGap'
			  write(3,30)  rgrd, rfms2, gamach, xkstep, xkmax, vixan, Eps0, EGap
			  write(3,30)  (spinph(iph),iph=0,nph)
			  write(3,20)  izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis
			! Commented out by Fer
			! The following lines are commented out because they are not being read
			! in rexsph (commented out by JK). This screws up anything that comes after
			! them in mod2.inp (for example, the ChSh parameters that I'm including.
			!!KJ next lines contain EGRID variables ; added 01-07
			!        write(3,10) 'iegrid,egrid3a,egrid3b,egrid3c'
			!          write(3,'(2i4,2f13.5)') iegrid,egrid3a,egrid3b,egrid3c !format statement is a mix of 20 and 30
			!          write(3,10) 'egridfile'
			!          write(3,10) egridfile
			!!KJ
			! Added by Fer
			! Correction of the excitation energy for chemical shifts
			  write(3,10) 'ChSh_Type:'
			  write(3,20) ChSh_Type
			!KJ 7-09 Next 2 lines for feff8q
			  write(3,'(a)') ' the number of decomposition channels ; only used for nrixs'
			  write(3,'(i5)') ldecmx
                          write(3,'(a)') 'lopt'
                          write(3,*) lopt
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (20f13.5)
		end subroutine xsph_write

		subroutine xsph_read
			integer iph
			open (file=filename, unit=3, status='old')
			  read(3,*) ; read(3,*)  mphase,ipr2,ixc,ixc0,ispec,lreal,lfms2,nph,l2lp,iPlsmn, NPoles, iGammaCH, iGrid
			  read(3,*) ; read(3,*)  vr0, vi0
			  read(3,*) ; read(3,*)  (lmaxph(iph),iph=0,nph)
			  read(3,*) ; read(3,'(13a6)')  (potlbl(iph),iph=0,nph)
			  read(3,*) ; read(3,*)  rgrd, rfms2, gamach, xkstep, xkmax, vixan, Eps0, EGap
			  read(3,*)  (spinph(iph),iph=0,nph)
			  read(3,*)  izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis
			!!KJ next lines contain EGRID variables ; added 01-07
			!          read(3,*) ; read(3,'(2i4,2f13.5)') iegrid,egrid3a,egrid3b,egrid3c !format statement is a mix of 20 and 30
			!          read(3,*) ; read(3,10) egridfile
			  read(3,*) ; read(3,*) ChSh_Type
			!KJ 7-09 Next 2 lines for feff8q
			  read(3,*) ; read(3,*) ldecmx
                        read(3,*) ; read(3,*) lopt
			close(3)
		end subroutine xsph_read

		subroutine xsph_init
                        lopt = .false.
			izstd = 0
			ifxc = 0
			ipmbse = 0
			itdlda = 0
			nonlocal = 0
			ibasis = 0
			potlbl(0:nphx) = ' '
			mphase = 1
			ipr2 = 0
			ixc0 = -1
			lreal = 0
			iPlsmn = 0 ! Josh Kas
                        NPoles = 100 ! JJK 3/9/2010
                        EGap = 0.d0 ! JJK 4/2010
			iGammaCH = 0
			iGrid = 0
			vr0 = 0.d0
			vi0 = 0.d0
			xkmax = 20*1.d0
			xkstep = 0.07*1.d0
			vixan = 0.d0
			iegrid=0 !KJ for EGRID card 1-07
			egridfile=' '
			egrid3a=0
			egrid3b=dble(0)
			egrid3c=dble(0)
		end subroutine xsph_init


      end module



!=======================================================================
!     FMS
!=======================================================================

      module fms_inp
        use ldos_inp
		use global_inp,only: ldecmx
		implicit none
		character(*),parameter,private :: filename='fms.inp'
		integer mfms, idwopt, ipr3 !ipr3 is currently dummy - not in fms.inp
		real rprec
		!KJ rprec seems to be bogus input, i.e. not used anywhere in entire FEFF90.  Set to 0 and kept here for compatibility.
		double precision   tk, thetad, sig2g

		contains

		subroutine fms_write
			implicit none
			integer iph
			open (file=filename, unit=3, status='unknown')
			  write(3,10) 'mfms, idwopt, minv'
			  write(3,20)  mfms, idwopt, minv
			  write(3,10) 'rfms2, rdirec, toler1, toler2'
			  write(3,30)  rfms2, rdirec, toler1, toler2
			  write(3,10) 'tk, thetad, sig2g'
			  write(3,30)  tk, thetad, sig2g
			  write(3,10) ' lmaxph(0:nph)'
			  write(3,20)  (lmaxph(iph),iph=0,nph)
			  !KJ 7-09 Next 2 lines for feff8q
			  write(3,'(a24)') ' the number of decomposition channels'
			  write(3,'(i5)') ldecmx
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (9f13.5)
		end subroutine fms_write

		subroutine fms_read
		    integer iph
			open (file=filename, unit=3, status='unknown')
			  read(3,*) ; read(3,*)  mfms, idwopt, minv
			  read(3,*) ; read(3,*)  rfms2, rdirec, toler1, toler2
			  read(3,*) ; read(3,*)  tk, thetad, sig2g
			  read(3,*) ; read(3,*)  (lmaxph(iph),iph=0,nph)
			  !KJ 7-09 Next line for feff8q
			  read(3,*) ; read(3,*) ldecmx
			close(3)
		end subroutine fms_read

		subroutine fms_init
			mfms = 1
			idwopt = -1
			sig2g = 0.d0
			thetad = 0.d0
			tk = 0.d0
			ipr3 = 0
			rprec = 0.e0
		end subroutine fms_init

	end module




!=======================================================================
!     PATHS
!=======================================================================

      module paths_inp
        use ldos_inp
		implicit none
		character(*),parameter,private :: filename='paths.inp'
		integer  mpath, ms, nncrit, nlegxx, ipr4, ica  !KJ added ica 6-06
		!KJ nncrit seems to be bogus input, i.e. not set in rdinp at all ; fully internal to PATH.  Set to 0 and kept here for compatibility.
		real critpw, pcritk, pcrith,  rmax

		contains

		subroutine paths_write
			implicit none
			open (file=filename, unit=3, status='unknown')
			  write(3,10) 'mpath, ms, nncrit, nlegxx, ipr4'
			  write(3,20)  mpath, ms, nncrit, nlegxx, ipr4
			  write(3,10) 'critpw, pcritk, pcrith,  rmax, rfms2'
			  write(3,30)  critpw, pcritk, pcrith,  rmax, rfms2
			  write(3,10) 'ica' !KJ 6-06
			  write(3,20)  ica  !KJ 6-06
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (9f13.5)
		end subroutine paths_write

		subroutine paths_read
			open (file=filename, unit=3, status='old')
			  read(3,*) ; read(3,*)  mpath, ms, nncrit, nlegxx, ipr4
			  read(3,*) ; read(3,*)  critpw, pcritk, pcrith,  rmax, rfms2
			  read(3,*) ; read(3,*)  ica  !KJ 6-06
			close(3)
		end subroutine paths_read

		subroutine paths_init
			mpath = 1
			ms = 0
			ipr4 = 0
			ica=-1 !KJ 6-06
			critpw = 2.5*1.e0
			pcritk = 0.e0
			pcrith = 0.e0
			rmax = -1 * 1.e0
			nlegxx = 10
			nncrit = 0
		end subroutine paths_init

	end module



!=======================================================================
!     GENFMT
!=======================================================================

      module genfmt_inp
		use global_inp
		implicit none
		character(*),parameter,private :: filename='genfmt.inp'
		integer  mfeff, ipr5, iorder
		logical  wnstar
		double precision critcw

		contains

		subroutine genfmt_write
			open (file=filename, unit=3, status='unknown')
			  write(3,10) 'mfeff, ipr5, iorder, critcw, wnstar'
			  write(3,180)  mfeff, ipr5, iorder, critcw, wnstar
		      180   format ( 2i4, i8, f13.5, L5)
			  !KJ 7-09 Next 2 lines for feff8q
			  write(3,'(a24)') ' the number of decomposition channels'
			  write(3,'(i5)') ldecmx
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (9f13.5)
		end subroutine genfmt_write

		subroutine genfmt_read
			open (file=filename, unit=3, status='old')
			  read(3,*) ; read(3,*)  mfeff, ipr5, iorder, critcw, wnstar
			  !KJ 7-09 Next line for feff8q
			  read(3,*) ; read(3,*) ldecmx
			close(3)
		end subroutine genfmt_read

		subroutine genfmt_init
			mfeff = 1
			ipr5 = 0
			iorder = 2
			wnstar = .false.
			critcw = 4*1.d0
		end subroutine genfmt_init

	end module



!=======================================================================
!     FF2X
!=======================================================================

      module ff2x_inp
		use global_inp
		use xsph_inp
		use fms_inp
		use genfmt_inp
		implicit none
		character(*),parameter,private :: filename='ff2x.inp'
		integer  mchi, ipr6, mbconv, absolu !KJ added absolu 3-06
		double precision  vrcorr, vicorr, s02, alphat, thetae
		

		contains

		subroutine ff2x_write
			integer i
			open (file=filename, unit=3, status='unknown')
			  write(3,10) 'mchi, ispec, idwopt, ipr6, mbconv, absolu, iGammaCH' !KJ added absolu 3-06
			  write(3,20)  mchi, ispec, idwopt, ipr6, mbconv, absolu, iGammaCH !KJ added absolu 3-06
			  write(3,10) 'vrcorr, vicorr, s02, critcw'
			  write(3,30)  vrcorr, vicorr, s02, critcw
			  write(3,10) 'tk, thetad, alphat, thetae, sig2g'
			  write(3,30)  tk, thetad, alphat, thetae, sig2g
			  !KJ 7-09 next 4 lines for feff8q
			  write(3,10) 'momentum transfer'
			  write(3, '(3f13.5)') (xivec(i),i=1,3)
			  write(3,'(a24)') ' the number of decomposition channels'
			  write(3,'(i5)') ldecmx
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (9f13.5)
		end subroutine ff2x_write

		subroutine ff2x_read
			integer i
			open (file=filename, unit=3, status='old')
			  read(3,*) ; read(3,*)  mchi, ispec, idwopt, ipr6, mbconv, absolu, iGammaCH !KJ added absolu 3-06
			  read(3,*) ; read(3,*)  vrcorr, vicorr, s02, critcw
			  read(3,*) ; read(3,*)  tk, thetad, alphat, thetae, sig2g
			  read(3,*) ; read(3, *) (xivec(i),i=1,3)
			  read(3,*) ; read(3,*) ldecmx
			close(3)
		end subroutine ff2x_read

		subroutine ff2x_init
			absolu=0  !KJ 3-06 for ABSOLUTE card
			mchi = 1
			ipr6 = 0
			mbconv = 0
			vicorr = 0.d0
			vrcorr = 0.d0
			s02 = 1.d0
			alphat = 0.d0
			thetae = 0.d0
		end subroutine ff2x_init

	end module


!=======================================================================
!     SFCONV
!=======================================================================

      module sfconv_inp
		use global_inp, only : ispec
		use ff2x_inp, only : ipr6
		implicit none
		character(*),parameter,private :: filename='sfconv.inp'
		integer  msfconv, ipse, ipsk
		double precision wsigk, cen
		character(12) cfname

		contains

		subroutine sfconv_write
		!c    sfconv.inp - Josh Kas
			open (file=filename, unit=3, status='unknown')
			  write(3,10) 'msfconv, ipse, ipsk'
			  write(3,20)  msfconv, ipse, ipsk
			  write(3,10) 'wsigk, cen'
			  write(3,30) wsigk, cen
			  write(3,10) 'ispec, ipr6'
			  write(3,20)  ispec, ipr6
			  write(3,10) 'cfname'
			  write(3,10) cfname
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (9f13.5)
		end subroutine sfconv_write

		subroutine sfconv_read
			open (file=filename, unit=3, status='old')
			read (3,*) ; read (3,*)  msfconv, ipse, ipsk
			read (3,*) ; read (3,*)  wsigk, cen
			read (3,*) ; read (3,*)  ispec, ipr6
			read (3,*) ; read (3,*)  cfname
			close(3)
		end subroutine sfconv_read

		subroutine sfconv_init
			msfconv = 0 ! Josh Kas
			ipse = 0
			ipsk = 0
			wsigk = 0.d0 ! Josh Kas
			cen = 0.d0 ! Josh Kas
			cfname = 'NULL'
		end subroutine sfconv_init

	end module



!=======================================================================
!     EELS
!=======================================================================

      module eels_inp
!		Beam direction in crystal frame of feff.inp (a.u.)
		use global_inp,only: xivec
		implicit none
		character(*),parameter,private :: filename='eels.inp'
!		Beam energy in eV :
		real*8 ebeam
!		Convergence semiangle in rad :
		real*8 aconv
!		Collection semiangle in rad :
		real*8 acoll
!		Integration mesh for q-vectors (radial/angular mesh size)
        integer nqr,nqf
!		Detector position ; angles in rad w.r.t. x and y directions
		real*8 thetax,thetay
!       what kind of q-mesh : uniform (U), logarithmic (L), or one dimensional logarithmic (1)
!       not currently in eels.inp/feff.inp
        character*1      qmodus
!		Parameter for logarithmic mesh - not currently in eels.inp/feff.inp
		real*8 th0
!		Make magic angle plot if magic=1
		integer        magic
!		Evaluate magic angle at this energy point
		real*8        emagic
!		Orientation sensitive?
		integer        aver
!		Do we have cross-terms?
		integer        cross
!		Do we do anything at all?
		integer        eels
!		How many spectra to combine
		integer ipmin,ipmax,ipstep ,nip
!		Where do we take input from :
		integer iinput           
!		Which column? - to be replaced by more advanced switch
		integer spcol
!       Relativistic calculation or not?  Converted into logical inside eels-module.
		integer relat

		contains

		subroutine eels_write
			open (file=filename, unit=3, status='unknown')
			  write(3,10) 'calculate ELNES?'
			  write(3,20) eels
			  write(3,10) 'average? relativistic? cross-terms? Which input?'
			  write(3,20) aver, relat, cross, iinput, spcol
			  write(3,10) 'polarizations to be used ; min step max'
			  write(3,20) ipmin,ipstep,ipmax
			  write(3,10) 'beam energy in eV'
			  write(3,30) ebeam
			  write(3,10) 'beam direction in arbitrary units'
			  write(3,30) xivec
			  write(3,10) 'collection and convergence semiangle in rad'
			  write(3,30) acoll,aconv
			  write(3,10) 'qmesh - radial and angular grid size'
			  write(3,20) nqr,nqf
			  write(3,10) 'detector positions - two angles in rad'
			  write(3,30) thetax,thetay
			  write(3,10) 'calculate magic angle if magic=1'
			  write(3,20) magic
			  write(3,10) 'energy for magic angle - eV above threshold'
			  write(3,30) emagic
			close(3)
		! standard formats for string, integers and real numbers
	  10  format(a)
	  20  format (20i4)
	  30  format (9f13.5)
		end subroutine eels_write

		subroutine eels_read
			open (file=filename, unit=3, status='old',err=100)
			read(3,*) ; read(3,*,end=100,err=100) eels
			read(3,*) ; read(3,*,err=209) aver, relat, cross, iinput,spcol ; goto 210
			209   iinput=1;spcol=4;relat=1;cross=1;aver=0  !restore defaults - this construction for older files.
			210 read(3,*) ; read(3,*) ipmin,ipstep,ipmax  !KJ this un-Kevin-like construction for older files ...
			nip=1+((ipmax-ipmin)/ipstep)
			read(3,*) ; read(3,*) ebeam
			read(3,*) ; read(3,*) xivec
			read(3,*) ; read(3,*) acoll,aconv
			read(3,*) ; read(3,*) nqr,nqf
			read(3,*) ; read(3,*) thetax,thetay
			read(3,*) ; read(3,*) magic
			read(3,*) ; read(3,*) emagic
			close(3)
			return
100			eels = 0  ; ipmin=1 ; ipmax=1 ; ipstep=1 ! no eels.inp -> don't do eels
            return
		end subroutine eels_read


        subroutine eels_init !default values for everything (except xivec)
		  ebeam=0.d0
		  aconv=0.d0
		  acoll=0.d0
		  nqr=0
		  nqf=0
		  magic=0
		  emagic=0.d0
		  eels=0
		  relat=1
		  cross=1
		  aver=0
		  thetax=0.d0
		  thetay=0.d0
		  ipmin=1
		  ipmax=1
		  nip=1
		  ipstep=1
          iinput=1  ! xmu.dat - files from ff2x
          spcol=4   ! xmu.dat - use spectrum mu(omega)
          qmodus='U'  !  U for uniform grid 
          th0=0.d0
		end subroutine eels_init

	end module



!=======================================================================
!     COMPTON
!=======================================================================


    module compton_inp
      implicit none
      character(*),parameter,private :: filename='compton.inp'

      ! spatial and momentum grid parameters
      integer :: ns, nphi, nz, nzp, npq
      real :: smax, phimax, zmax, zpmax, pqmax

      ! flags
      logical :: do_compton, do_rhozzp
      logical :: force_jzzp
	  integer run_compton_module

      ! apodization function type
      integer :: window
      real :: window_cutoff

      real :: temperature
      logical ::  set_chemical_potential
      real :: chemical_potential

      integer, parameter :: WINDOW_STEP = 0, WINDOW_HANNING = 1
    contains
      subroutine compton_write
	    if (do_compton .or. do_rhozzp) then
		   run_compton_module=1
		else
		   run_compton_module=0
		endif
        open (file=filename, unit=3, status='unknown')
		  write(3,10) 'run compton module?'
		  write(3,*)  run_compton_module 
          write(3,10) 'pqmax, npq'
          write(3,*) pqmax, npq
          write(3,10) 'ns, nphi, nz, nzp'
          write(3,20) ns, nphi, nz, nzp
          write(3,10) 'smax, phimax, zmax, zpmax'
          write(3,30) smax, phimax, zmax, zpmax
          write(3,10) 'jpq? rhozzp? force_recalc_jzzp?'
          write(3,*) do_compton, do_rhozzp, force_jzzp
          write(3,10) 'window_type (0=Step, 1=Hann), window_cutoff'
          write(3,*) window, window_cutoff
          write(3,10) 'temperature (in eV)'
          write(3,30) temperature
          write(3,10) 'set_chemical_potential? chemical_potential(eV)'
          write(3,*) set_chemical_potential, chemical_potential
        close(3)
		! standard formats for string, integers, real numbers
    10  format(a)
    20  format (20i4)
    30  format (9f13.5)
      end subroutine compton_write

      subroutine compton_read
        open (file=filename, unit=3, status='old',err=100)
		  read(3,*,end=100,err=100) ; read(3,*,end=100,err=100) run_compton_module
          read(3,*,end=100,err=100) ; read(3,*,end=100,err=100) pqmax, npq
          read(3,*,end=100,err=100) ; read(3,*,end=100,err=100) ns, nphi, nz, nzp
          read(3,*,end=100,err=100) ; read(3,*,end=100,err=100) smax, phimax, zmax, zpmax
          read(3,*,end=100,err=100) ; read(3,*,end=100,err=100) do_compton, do_rhozzp, force_jzzp
          read(3,*,end=100,err=100) ; read(3,*,end=100,err=100) window, window_cutoff
          read(3,*,end=100,err=100) ; read(3,*,end=100,err=100) temperature
          read(3,*,end=100,err=100) ; read(3,*,end=100,err=100) set_chemical_potential, chemical_potential
        close(3)
        return
        100			run_compton_module=0  ! no compton.inp -> don't do compton
        return
      end subroutine compton_read

      subroutine compton_init
        real, parameter :: pi  = 3.1415926535897932384626433832795
        ns   = 32
        nphi = 32
        nz   = 32
        nzp  = 144

        smax   = 0
        phimax = 2*pi
        zmax   = 0
        zpmax  = 10.0

        npq   = 1000
        pqmax = 5.0

        do_compton     = .false.
        do_rhozzp  = .false.
        force_jzzp = .false.
		run_compton_module=0

        window = WINDOW_HANNING
        window_cutoff = 0

        temperature = 0.0
        set_chemical_potential = .false.
        chemical_potential = 0
      end subroutine compton_init
    end module

! Kevin Jorissen 2012.  Purpose: to pass exit codes to  an external program, e.g. the JFEFF Java GUI which launches FEFF9 modules and must be able to figure out if they succeed before launching the next module.
! There is no really reliable way to set exit codes in Fortran (compiler/platform dependencies; exit codes are only included in very latest Fortran standards (2008? 2010?).
! Therefore, we copy the WIEN2k approach.  Set error file in working directory at program launch.  Wipe it on successful termination.  The GUI can then check for the presence of a non-zero-size file:
! If such a file exists, the program did not exit cleanly, signifying a crash.  This approach is robust and does not depend on any Fortran programming to catch runtime exceptiosn, memory allocation problems, ...
! The downside is that the file will not contain much useful information.  However any runtime information will still be printed to the screen.

! There is already some error handling code present in FEFF, introduced by Josh; presumably only used in a few of the routines he contributed?  In any case, it is not set up to output to file rather than stdout/err,
! and I don't want to mess with it.  The simple code below is good enough for me.

module errorfile

implicit none
character*11,private :: ErrorFileName='.feff.error'
integer,private :: lun = 77


contains

subroutine OpenErrorfileAtLaunch(ModuleName)
   ! Open the errorfile and set a default message.  Call at the start of a module.
   character*(*),intent(in) :: ModuleName
   character*500 :: ErrorMessage
   ErrorMessage='Starting FEFF9 module '//ModuleName//'.  If this message is still here after the module finishes running, it must have crashed.  The content of this file is wiped on successful termination.'
   call SetErrorfileMessage(ErrorMessage)
   return
end subroutine OpenErrorfileAtLaunch


subroutine WipeErrorfileAtFinish
  !Overwrite the error file with an empty, 0-byte file.  Call at the regular termination of a module.
  open(lun,file=ErrorFileName,status='replace',err=1000)
  close(lun)
  return
  1000 stop 'Unable to wipe errorfile in SetErrorfileMessage.  How ironic.'
end subroutine WipeErrorfileAtFinish



subroutine SetErrorfileMessage(ErrorMessage)
   !Write a user(programmer)-specified error message to the errorfile.  Useful for diagnostic purposes.
   character*(*),intent(in) :: ErrorMessage
   open(lun,file=ErrorFileName,status='unknown',err=1000)
   write(lun,*) ErrorMessage
   close(lun)
   return
   1000 stop 'Unable to open errorfile in SetErrorfileMessage'
end subroutine SetErrorfileMessage



end module errorfile

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_par.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      module par

	  implicit none
	  integer par_type, this_process, numprocs, my_rank
      logical master, worker, parallel_run
      real*8 wall_comm, time_comm

      end module


MODULE config 
! Contains information on which orbitals contain electrons.
! Used to be in routines getorb and IsOccupied in file getorb.f90
! Structure change to module 12-2010 by Kevin Jorissen to allow user input.
! Subroutines follow after long list of data.
      use potential_inp,only: nph,iz,configtype
      implicit none ! compiles with implicit none, but the "integer i" conflicts with calling routines ...

      integer, private :: i
      real*8, private :: iocc9(100,29), ival9(100,29), ispn9(100, 29) ! feff9 defaults
	  real*8, private :: iocc7(97,29),  ival7(97,29)                  ! feff7 defaults
      real*8, allocatable :: iocc(:,:), ival(:,:),     ispn(:,:)      ! final values after user input
      integer          :: nnum (29), kappa(29),inoble(7)
	  logical, private :: config_initialized=.false.
	  logical, private :: dump_to_file=.false.  !disabled because in its current state, does not reflect core hole or ionicity -> not so useful
	  character*2,private :: element(100)
	  

!     Table for each element has occupation of the various levels.
!     The order of the levels in each array is:

!     element  level     principal qn (nqn), kappa qn (nk)
!           1  1s        1  -1
!           2  2s        2  -1
!           3  2p1/2     2   1
!           4  2p3/2     2  -2
!           5  3s        3  -1
!           6  3p1/2     3   1
!           7  3p3/2     3  -2
!           8  3d3/2     3   2
!           9  3d5/2     3  -3
!          10  4s        4  -1
!          11  4p1/2     4   1
!          12  4p3/2     4  -2
!          13  4d3/2     4   2
!          14  4d5/2     4  -3
!          15  4f5/2     4   3
!          16  4f7/2     4  -4
!          17  5s        5  -1
!          18  5p1/2     5   1
!          19  5p3/2     5  -2
!          20  5d3/2     5   2
!          21  5d5/2     5  -3
!          22  5f5/2     5   3
!          23  5f7/2     5  -4
!          24  6s        6  -1
!          25  6p1/2     6   1
!          26  6p3/2     6  -2
!          27  6d3/2     6   2
!          28  6d5/2     6  -3
!          29  7s        7  -1

!     Feel free to change occupation numbers for element of interest.
!     ival(i) is necessary only for partly nonlocal exchange model.
!     iocc(i) and ival(i) can be fractional
!     But you have to keep the sum of iocc(i) equal to nuclear charge.
!     Also ival(i) should be equal to iocc(i) or zero. 
!     Otherwise you have to change subroutine getorb or contact authors  for help.


!     kappa quantum number for each orbital
!     k = - (j + 1/2)  if l = j - 1/2
!     k = + (j + 1/2)  if l = j + 1/2
      data kappa /-1,-1, 1,-2,-1,  1,-2, 2,-3,-1,  1,-2, 2,-3, 3,  -4,-1, 1,-2, 2, -3, 3,-4,-1, 1, -2, 2,-3,-1/

!     principal quantum number (energy eigenvalue)
      data nnum  /1,2,2,2,3,  3,3,3,3,4,  4,4,4,4,4,  4,5,5,5,5,  5,5,5,6,6,  6,6,6,7/

      data (element(i),i=1,100) /'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne','Na','Ng','Al','Si','P ','S ','Cl','Ar','K ','Ca', &
                                 'Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr','Rb','Sr','Y ','Zr', &
								 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn','Sb','Te','I ','Xe','Cs','Ba','La','Ce','Pr','Nd', &
						         'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu','Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg', &
						         'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th','Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm'/

!     number of states (/29) filled for a noble gas atom : He,Ne,Ar,Kr,Xe,Hg,Rn (1->6)
   	  data (inoble(i),i=1,7) /2, 10, 18, 36, 54, 80, 86/ 

!     occupation of each level for z = 1, 100
      data (iocc9( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9( 2,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9( 3,i),i=1,29)  /2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9( 3,i),i=1,29)  /0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9( 3,i),i=1,29)  /0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9( 4,i),i=1,29)  /2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9( 4,i),i=1,29)  /0,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9( 4,i),i=1,29)  /0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9( 5,i),i=1,29)  /2,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9( 5,i),i=1,29)  /0,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9( 5,i),i=1,29)  /0,0,1,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9( 6,i),i=1,29)  /2,1,2,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9( 6,i),i=1,29)  /0,1,2,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9( 6,i),i=1,29)  /0,0,1,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9( 7,i),i=1,29)  /2,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9( 7,i),i=1,29)  /0,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9( 7,i),i=1,29)  /0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9( 8,i),i=1,29)  /2,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9( 8,i),i=1,29)  /0,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9( 8,i),i=1,29)  /0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9( 9,i),i=1,29)  /2,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9( 9,i),i=1,29)  /0,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9( 9,i),i=1,29)  /0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(10,i),i=1,29)  /2,2,2,4,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(10,i),i=1,29)  /0,0,2,4,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(10,i),i=1,29)  /0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(11,i),i=1,29)  /2,2,2,4,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(11,i),i=1,29)  /0,0,2,4,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(11,i),i=1,29)  /0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(12,i),i=1,29)  /2,2,2,4,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(12,i),i=1,29)  /0,0,0,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(12,i),i=1,29)  /0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(13,i),i=1,29)  /2,2,2,4,2,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(13,i),i=1,29)  /0,0,0,0,2,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(13,i),i=1,29)  /0,0,0,0,0,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(14,i),i=1,29)  /2,2,2,4,2,  2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(14,i),i=1,29)  /0,0,0,0,2,  2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(14,i),i=1,29)  /0,0,0,0,0,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(15,i),i=1,29)  /2,2,2,4,2,  2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(15,i),i=1,29)  /0,0,0,0,2,  2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(15,i),i=1,29)  /0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(16,i),i=1,29)  /2,2,2,4,2,  2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(16,i),i=1,29)  /0,0,0,0,2,  2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(16,i),i=1,29)  /0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(17,i),i=1,29)  /2,2,2,4,2,  2,3,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(17,i),i=1,29)  /0,0,0,0,2,  2,3,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(17,i),i=1,29)  /0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(18,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(18,i),i=1,29)  /0,0,0,0,2,  2,4,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(18,i),i=1,29)  /0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(19,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(19,i),i=1,29)  /0,0,0,0,2,  2,4,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(19,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(20,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(20,i),i=1,29)  /0,0,0,0,0,  2,4,0,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(20,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(21,i),i=1,29)  /2,2,2,4,2,  2,4,1,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(21,i),i=1,29)  /0,0,0,0,0,  2,4,1,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(21,i),i=1,29)  /0,0,0,0,0,  0,0,1,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(22,i),i=1,29)  /2,2,2,4,2,  2,4,2,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(22,i),i=1,29)  /0,0,0,0,0,  2,4,2,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(22,i),i=1,29)  /0,0,0,0,0,  0,0,2,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(23,i),i=1,29)  /2,2,2,4,2,  2,4,3,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(23,i),i=1,29)  /0,0,0,0,0,  2,4,3,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(23,i),i=1,29)  /0,0,0,0,0,  0,0,3,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(24,i),i=1,29)  /2,2,2,4,2,  2,4,4,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(24,i),i=1,29)  /0,0,0,0,0,  2,4,4,0,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(24,i),i=1,29)  /0,0,0,0,0,  0,0,4,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(25,i),i=1,29)  /2,2,2,4,2,  2,4,4,1,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(25,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(25,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(26,i),i=1,29)  /2,2,2,4,2,  2,4,4,2,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(26,i),i=1,29)  /0,0,0,0,0,  0,0,4,2,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(26,i),i=1,29)  /0,0,0,0,0,  0,0,2,2,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(27,i),i=1,29)  /2,2,2,4,2,  2,4,4,3,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(27,i),i=1,29)  /0,0,0,0,0,  0,0,4,3,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(27,i),i=1,29)  /0,0,0,0,0,  0,0,0,3,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(28,i),i=1,29)  /2,2,2,4,2,  2,4,4,4,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(28,i),i=1,29)  /0,0,0,0,0,  0,0,4,4,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(28,i),i=1,29)  /0,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(29,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(29,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(29,i),i=1,29)  /0,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(30,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(30,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,1,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(30,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(31,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(31,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,2,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(31,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(32,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(32,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,2,  2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(32,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(33,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(33,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(33,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(34,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(34,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(34,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(35,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,3,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(35,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,3,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(35,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(36,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(36,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,4,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(36,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(37,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(37,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,4,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(37,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(38,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(38,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,0,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(38,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(39,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,1,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(39,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,1,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(39,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,1,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(40,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,2,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(40,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,2,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(40,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,2,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(41,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(41,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,4,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(41,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,3,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(42,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(42,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  2,4,4,1,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(42,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(43,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(43,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(43,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(44,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,3,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(44,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,3,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(44,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,2,2,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(45,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,4,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(45,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,4,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(45,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(46,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(46,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(46,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(47,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(47,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(47,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(48,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(48,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(48,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(49,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(49,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,  0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(49,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,1,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(50,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(50,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,  0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(50,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,1,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(51,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(51,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,  0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(51,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(52,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(52,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(52,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(53,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(53,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(53,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(54,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (ival9(54,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (ispn9(54,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(55,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,4,0,  0,0,0,1,0,  0,0,0,0/
      data (ival9(55,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,4,0,  0,0,0,1,0,  0,0,0,0/
      data (ispn9(55,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,  0,0,0,0/

      data (iocc9(56,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival9(56,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(56,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,  0,0,0,0/

      data (iocc9(57,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(57,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(57,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(58,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,1,  0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(58,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,  0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(58,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(59,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,2,  0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(59,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(59,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(60,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,3,  0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(60,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,3,  0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(60,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,3,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(61,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,4,  0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(61,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(61,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(62,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,5,  0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(62,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,5,  0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(62,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,5,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(63,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(63,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  0,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(63,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(64,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  1,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(64,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  1,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(64,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(65,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  2,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(65,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  2,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(65,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  2,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(66,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  3,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(66,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  3,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(66,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  3,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(67,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  4,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(67,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  4,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(67,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  4,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(68,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  5,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(68,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  5,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(68,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  3,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(69,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  6,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(69,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  6,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(69,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  2,0,0,0,0,  0,0,0,2,0,  0,0,0,0/

      data (iocc9(70,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  7,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(70,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  7,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(70,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(71,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival9(71,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  8,0,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(71,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(72,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,2,  0,0,0,2,0,  0,0,0,0/
      data (ival9(72,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  8,0,2,4,2,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(72,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(73,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,3,  0,0,0,2,0,  0,0,0,0/
      data (ival9(73,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  8,0,0,0,3,  0,0,0,2,0,  0,0,0,0/
      data (ispn9(73,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,3,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(74,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,3,  1,0,0,2,0,  0,0,0,0/
      data (ival9(74,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  8,0,0,0,3,  1,0,0,2,0,  0,0,0,0/
      data (ispn9(74,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  0,0,0,0,0,  0,0,0,0/

      data (iocc9(75,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  1,0,0,2,0,  0,0,0,0/
      data (ival9(75,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  1,0,0,2,0,  0,0,0,0/
      data (ispn9(75,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  1,0,0,0,0,  0,0,0,0/

      data (iocc9(76,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  2,0,0,2,0,  0,0,0,0/
      data (ival9(76,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  2,0,0,2,0,  0,0,0,0/
      data (ispn9(76,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  2,0,0,0,0,  0,0,0,0/

      data (iocc9(77,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  3,0,0,2,0,  0,0,0,0/
      data (ival9(77,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  3,0,0,2,0,  0,0,0,0/
      data (ispn9(77,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  3,0,0,0,0,  0,0,0,0/

      data (iocc9(78,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  5,0,0,1,0,  0,0,0,0/
      data (ival9(78,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  5,0,0,1,0,  0,0,0,0/
      data (ispn9(78,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  2,0,0,0,0,  0,0,0,0/

      data (iocc9(79,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,1,0,  0,0,0,0/
      data (ival9(79,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  6,0,0,1,0,  0,0,0,0/
      data (ispn9(79,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  1,0,0,0,0,  0,0,0,0/

      data (iocc9(80,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,0,  0,0,0,0/
      data (ival9(80,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  6,0,0,2,0,  0,0,0,0/
      data (ispn9(80,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,  0,0,0,0/

      data (iocc9(81,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,1,  0,0,0,0/
      data (ival9(81,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  6,0,0,2,1,  0,0,0,0/
      data (ispn9(81,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,  0,0,0,0/

      data (iocc9(82,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  0,0,0,0/
      data (ival9(82,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  6,0,0,2,2,  0,0,0,0/
      data (ispn9(82,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,  0,0,0,0/

      data (iocc9(83,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  1,0,0,0/
      data (ival9(83,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  6,0,0,2,2,  1,0,0,0/
      data (ispn9(83,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  1,0,0,0/

      data (iocc9(84,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  2,0,0,0/
      data (ival9(84,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  6,0,0,2,2,  2,0,0,0/
      data (ispn9(84,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  1,0,0,0/

      data (iocc9(85,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  3,0,0,0/
      data (ival9(85,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,2,  3,0,0,0/
      data (ispn9(85,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  1,0,0,0/

      data (iocc9(86,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,0,0,0/
      data (ival9(86,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,2,  4,0,0,0/
      data (ispn9(86,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  1,0,0,0/

      data (iocc9(87,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,0,0,1/
      data (ival9(87,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,2,  4,0,0,1/
      data (ispn9(87,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1/

      data (iocc9(88,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,0,0,2/
      data (ival9(88,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  4,0,0,2/
      data (ispn9(88,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1/

      data (iocc9(89,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,1,0,2/
      data (ival9(89,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  4,1,0,2/
      data (ispn9(89,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,1,0,0/

      data (iocc9(90,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,2,0,2/
      data (ival9(90,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  4,2,0,2/
      data (ispn9(90,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,0,0/

      data (iocc9(91,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,2,0,2,2,  4,1,0,2/
      data (ival9(91,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,0,0,2,  4,1,0,2/
      data (ispn9(91,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,0,0,0,  0,0,0,0/

      data (iocc9(92,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,3,0,2,2,  4,1,0,2/
      data (ival9(92,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,3,0,0,2,  4,1,0,2/
      data (ispn9(92,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,1.5,0,0,0,0,0,0,0/

      data (iocc9(93,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,4,0,2,2,  4,1,0,2/
      data (ival9(93,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,4,0,0,2,  4,1,0,2/
      data (ispn9(93,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,4,0,0,0,  0,0,0,0/

      data (iocc9(94,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,0,2,2,  4,0,0,2/
      data (ival9(94,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,0,0,2,  4,0,0,2/
      data (ispn9(94,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,5,0,0,0,  0,0,0,0/

      data (iocc9(95,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,1,2,2,  4,0,0,2/
      data (ival9(95,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,1,0,2,  4,0,0,2/
      data (ispn9(95,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,5,1,0,0,  0,0,0,0/

      data (iocc9(96,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,2,2,2,  4,0,0,2/
      data (ival9(96,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,2,0,2,  4,0,0,2/
      data (ispn9(96,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,5,2,0,0,  0,0,0,0/

      data (iocc9(97,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,3,2,2,  4,0,0,2/
      data (ival9(97,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,3,0,2,  4,0,0,2/
      data (ispn9(97,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,3,3,0,0,  0,0,0,0/

      data (iocc9(98,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,4,2,2,  4,0,0,2/
      data (ival9(98,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,4,0,2,  4,0,0,2/
      data (ispn9(98,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,1,4,0,0,  0,0,0,0/

      data (iocc9(99,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,5,2,2,  4,0,0,2/
      data (ival9(99,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,5,0,2,  4,0,0,2/
      data (ispn9(99,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,4,0,0,  0,0,0,0/

      data (iocc9(100,i),i=1,29) /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,6,2,2,  4,0,0,2/
      data (ival9(100,i),i=1,29) /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,6,0,2,  4,0,0,2/
      data (ispn9(100,i),i=1,29) /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,3,0,0,  0,0,0,0/

!     the old recipe of feff7 for z = 1, 97
      data (iocc7( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7( 1,i),i=1,29)  /1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7( 2,i),i=1,29)  /2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7( 3,i),i=1,29)  /2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7( 3,i),i=1,29)  /0,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7( 4,i),i=1,29)  /2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7( 4,i),i=1,29)  /0,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7( 5,i),i=1,29)  /2,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7( 5,i),i=1,29)  /0,2,1,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7( 6,i),i=1,29)  /2,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7( 6,i),i=1,29)  /0,2,2,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7( 7,i),i=1,29)  /2,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7( 7,i),i=1,29)  /0,2,2,1,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7( 8,i),i=1,29)  /2,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7( 8,i),i=1,29)  /0,2,2,2,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7( 9,i),i=1,29)  /2,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7( 9,i),i=1,29)  /0,2,2,3,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(10,i),i=1,29)  /2,2,2,4,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(10,i),i=1,29)  /0,2,2,4,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(11,i),i=1,29)  /2,2,2,4,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(11,i),i=1,29)  /0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(12,i),i=1,29)  /2,2,2,4,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(12,i),i=1,29)  /0,0,0,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(13,i),i=1,29)  /2,2,2,4,2,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(13,i),i=1,29)  /0,0,0,0,2,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(14,i),i=1,29)  /2,2,2,4,2,  2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(14,i),i=1,29)  /0,0,0,0,2,  2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(15,i),i=1,29)  /2,2,2,4,2,  2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(15,i),i=1,29)  /0,0,0,0,2,  2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(16,i),i=1,29)  /2,2,2,4,2,  2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(16,i),i=1,29)  /0,0,0,0,2,  2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(17,i),i=1,29)  /2,2,2,4,2,  2,3,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(17,i),i=1,29)  /0,0,0,0,2,  2,3,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(18,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(18,i),i=1,29)  /0,0,0,0,2,  2,4,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(19,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(19,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(20,i),i=1,29)  /2,2,2,4,2,  2,4,0,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(20,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(21,i),i=1,29)  /2,2,2,4,2,  2,4,1,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(21,i),i=1,29)  /0,0,0,0,0,  0,0,1,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(22,i),i=1,29)  /2,2,2,4,2,  2,4,2,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(22,i),i=1,29)  /0,0,0,0,0,  0,0,2,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(23,i),i=1,29)  /2,2,2,4,2,  2,4,3,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(23,i),i=1,29)  /0,0,0,0,0,  0,0,3,0,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(24,i),i=1,29)  /2,2,2,4,2,  2,4,4,1,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(24,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(25,i),i=1,29)  /2,2,2,4,2,  2,4,4,1,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(25,i),i=1,29)  /0,0,0,0,0,  0,0,4,1,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(26,i),i=1,29)  /2,2,2,4,2,  2,4,4,2,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(26,i),i=1,29)  /0,0,0,0,0,  0,0,4,2,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(27,i),i=1,29)  /2,2,2,4,2,  2,4,4,3,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(27,i),i=1,29)  /0,0,0,0,0,  0,0,4,3,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(28,i),i=1,29)  /2,2,2,4,2,  2,4,4,4,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(28,i),i=1,29)  /0,0,0,0,0,  0,0,4,4,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(29,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(29,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,1,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(30,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(30,i),i=1,29)  /0,0,0,0,0,  0,0,4,6,2,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(31,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(31,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  1,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(32,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(32,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(33,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(33,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,1,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(34,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(34,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,2,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(35,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,3,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(35,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,3,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(36,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(36,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,2,  2,4,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(37,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(37,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(38,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,0,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(38,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(39,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,1,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(39,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,1,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(40,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,2,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(40,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,2,0,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(41,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(41,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,0,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(42,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(42,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(43,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,1,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(43,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,1,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(44,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,3,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(44,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,3,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(45,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,4,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(45,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,4,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(46,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(46,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(47,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(47,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,  0,1,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(48,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(48,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,4,6,0,  0,2,0,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(49,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(49,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,1,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(50,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(50,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,0,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(51,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(51,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,1,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(52,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(52,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,2,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(53,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(53,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,3,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(54,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (ival7(54,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,2,4,0,  0,0,0,0,0,  0,0,0,0/
      data (iocc7(55,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,4,0,  0,0,0,1,0,  0,0,0,0/
      data (ival7(55,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1,0,  0,0,0,0/
      data (iocc7(56,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(56,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(57,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,0,  0,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival7(57,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(58,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,2,  0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(58,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(59,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,3,  0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(59,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,3,  0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(60,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,4,  0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(60,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(61,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,5,  0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(61,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,5,  0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(62,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  0,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(62,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  0,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(63,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  1,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(63,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  1,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(64,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  1,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival7(64,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  1,0,0,0,1,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(65,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  3,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(65,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  3,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(66,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  4,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(66,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  4,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(67,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  5,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(67,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  5,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(68,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  6,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(68,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  6,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(69,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  7,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(69,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  7,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(70,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,0,  0,0,0,2,0,  0,0,0,0/
      data (ival7(70,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,6,  8,0,0,0,0,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(71,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,1,  0,0,0,2,0,  0,0,0,0/
      data (ival7(71,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,1,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(72,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,2,  0,0,0,2,0,  0,0,0,0/
      data (ival7(72,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,2,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(73,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,3,  0,0,0,2,0,  0,0,0,0/
      data (ival7(73,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,3,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(74,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  0,0,0,2,0,  0,0,0,0/
      data (ival7(74,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  0,0,0,2,0,  0,0,0,0/
      data (iocc7(75,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  1,0,0,2,0,  0,0,0,0/
      data (ival7(75,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  1,0,0,2,0,  0,0,0,0/
      data (iocc7(76,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  2,0,0,2,0,  0,0,0,0/
      data (ival7(76,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  2,0,0,2,0,  0,0,0,0/
      data (iocc7(77,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  3,0,0,2,0,  0,0,0,0/
      data (ival7(77,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  3,0,0,2,0,  0,0,0,0/
      data (iocc7(78,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  5,0,0,1,0,  0,0,0,0/
      data (ival7(78,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  5,0,0,1,0,  0,0,0,0/
      data (iocc7(79,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,1,0,  0,0,0,0/
      data (ival7(79,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  6,0,0,1,0,  0,0,0,0/
      data (iocc7(80,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,0,  0,0,0,0/
      data (ival7(80,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,4,  6,0,0,2,0,  0,0,0,0/
      data (iocc7(81,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,1,  0,0,0,0/
      data (ival7(81,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,1,  0,0,0,0/
      data (iocc7(82,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  0,0,0,0/
      data (ival7(82,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,2,  0,0,0,0/
      data (iocc7(83,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  1,0,0,0/
      data (ival7(83,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,2,  1,0,0,0/
      data (iocc7(84,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  2,0,0,0/
      data (ival7(84,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,2,  2,0,0,0/
      data (iocc7(85,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  3,0,0,0/
      data (ival7(85,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,2,  3,0,0,0/
      data (iocc7(86,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,0,0,0/
      data (ival7(86,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2,2,  4,0,0,0/
      data (iocc7(87,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,0,0,1/
      data (ival7(87,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,1/
      data (iocc7(88,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,0,0,2/
      data (ival7(88,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,2/
      data (iocc7(89,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,1,0,2/
      data (ival7(89,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,1,0,2/
      data (iocc7(90,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,0,0,2,2,  4,2,0,2/
      data (ival7(90,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,0,2/
      data (iocc7(91,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,2,0,2,2,  4,1,0,2/
      data (ival7(91,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,2,0,0,0,  0,1,0,2/
      data (iocc7(92,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,3,0,2,2,  4,1,0,2/
      data (ival7(92,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,3,0,0,0,  0,1,0,2/
      data (iocc7(93,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,4,0,2,2,  4,1,0,2/
      data (ival7(93,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,4,0,0,0,  0,1,0,2/
      data (iocc7(94,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,0,2,2,  4,0,0,2/
      data (ival7(94,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,0,0,0,  0,0,0,2/
      data (iocc7(95,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,1,2,2,  4,0,0,2/
      data (ival7(95,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,1,0,0,  0,0,0,2/
      data (iocc7(96,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,2,2,2,  4,0,0,2/
      data (ival7(96,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,2,0,0,  0,0,0,2/
      data (iocc7(97,i),i=1,29)  /2,2,2,4,2,  2,4,4,6,2,  2,4,4,6,6,  8,2,2,4,4,  6,6,3,2,2,  4,0,0,2/
      data (ival7(97,i),i=1,29)  /0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,0,0,0,0,  0,6,3,0,0,  0,0,0,2/

CONTAINS

logical FUNCTION IsOccupied(i,ihole)
  integer,intent(in) :: i, ihole
  call InitConfig  ! This function can be called from outside at any moment!
  IsOccupied = iocc(i,ihole).ge.1
end function IsOccupied


real*8 FUNCTION F_Iocc(i,j,k)
integer,intent(in) :: i,j,k
real*8 o(29),v(29),s(29)
if(i.lt.1 .or. i.gt.100 .or. j.lt.1 .or. j.gt.29) call par_stop('Nonsense request in F_Iocc')
call GiveConfig(o,v,s,i,k)
F_Iocc=o(j)
return
end function F_Iocc


real*8 FUNCTION F_Ival(i,j,k)
integer,intent(in) :: i,j,k
real*8 o(29),v(29),s(29)
if(i.lt.1 .or. i.gt.100 .or. j.lt.1 .or. j.gt.29) call par_stop('Nonsense request in F_Ival')
call GiveConfig(o,v,s,i,k)
F_Ival=v(j)
return
end function F_Ival


real*8 FUNCTION F_Ispn(i,j,k)
integer,intent(in) :: i,j,k
real*8 o(29),v(29),s(29)
if(i.lt.1 .or. i.gt.100 .or. j.lt.1 .or. j.gt.29) call par_stop('Nonsense request in F_Ispn')
call GiveConfig(o,v,s,i,k)
F_Ispn=s(j)
return
end function F_Ispn


SUBROUTINE GiveConfig(occ,val,spn,i,k)
! return configuration for specific "Z"
! if requested element is not in feff.inp, use either feff9 or feff7 default
! if core hole atom is needed, use "-Z"
  integer,intent(in) :: i,k ! "i" to work by atomic number; "k" to work by potential index
  real*8,intent(out) :: occ(29),val(29),spn(29)
  logical test
  
  integer :: iph
  call InitConfig
  do iph=0,nph 
     if(k.ge.0 .and. k.le.nph) then
	    test= (iph.eq.k)
     else
	    test= (iz(iph).eq.i)
	 endif
     if(k.lt.0 .and. i.ge.0 .and. iph.eq.0) cycle
	 if(test) then
	    occ(:)=iocc(iph,:)
		val(:)=ival(iph,:)
		spn(:)=ispn(iph,:)
		return
	 endif
  enddo
  occ(:)=iocc9(i,:)
  val(:)=ival9(i,:)
  spn(:)=ispn9(i,:)
  if (configtype .eq. 7) then
     occ(:)=iocc7(i,:)
     val(:)=ival7(i,:)
     spn(:)=0
  endif
  return
end subroutine GiveConfig      


SUBROUTINE InitConfig
  !allocate arrays and populate them with feff defaults ; read user input if required.
  implicit none
  integer iph,i,j
  
  if(allocated(iocc)) return !means InitConfig already ran once, and that's enough!
  
  allocate(iocc(0:nph,29),ival(0:nph,29),ispn(0:nph,29))
  ispn(:,:)=0.d0
  ival(:,:)=0.d0
  iocc(:,:)=0.d0
  
  
  do iph=0,nph    !load feff9 defaults
     ispn(iph,:)=ispn9(iz(iph),:)
	 ival(iph,:)=ival9(iz(iph),:)
     iocc(iph,:)=iocc9(iz(iph),:)
  enddo
  
  if (configtype .eq. 7) then  !reload feff7 defaults
     call wlog('Electron configuration set to feff7 recipe.')
     do iph=0,nph    !load defaults
	    ival(iph,:)=ival7(iz(iph),:)
        iocc(iph,:)=iocc7(iz(iph),:)
		ispn(iph,:)=0
     enddo
  endif
  
  if(configtype .eq. 2) then
     call wlog('Electron configuration set by user.')
	 call ParseConfig(112) !process user input
  endif
  
  if(dump_to_file) call DumpConfig(112) !write results to file config.dat

return
end subroutine InitConfig


SUBROUTINE ParseConfig(iunit)
! Read a 'shorthand' line specifying the configuration, and make sense of it :-)
! A line may look like this :
!      4 Cr Ar 3d 4 0 4s 1 4p 1 s 1
! which means the Cr atom (z=34) of potential type (iph=4) in feff.inp (-this has to be consistent-)
! has the configuration of the Ar noble gas atom, plus 3d^4 4s^1 4p^1
! and the 4 d-electrons are all in 3d3/2 while 3d5/2 has occupation 0
! and there is spin "1" in the 4p state (in addition to whatever spin Ar may have in the orbitals below 3d).
! In another example,
!     -1 C 0  1s -2 2s 2 2p 1 1
! This means there has to be a C atom (z=6) of potential type (iph=1) in feff.inp.  The configuration specified 
! here, however, will be used for ALL C atoms (unless specific lines follow that change things again) because ip=-1<0.
! The configuration is not given using a noble gas atom ("0"); it is 1s^2 2s^2 2p^2, where the 2p electrons are divided
! between 2p1/2 and 2p3/2.  Moreover, 1s is considered a core state (negative occupation number) and 2s, 2p valence states insofar as ival is considered.
! (This does not override ecv later in the code, I believe.)
integer,intent(in) :: iunit
character*150 line
character*20 w(98),w0(100)
logical allip,outofrange
character*2 state,noblegas,name
integer i,n,z,zn,inoble,ist,iph,ip,nwords,jinit
real*8 io,ecount
! it is assumed that lun iunit is available.
!!     open(iunit,file='config.inp',form='formatted',status='old')
	 line='config.inp'
	 jinit=-1
57   continue
     allip=.false.	 
	 outofrange=.false.
	 call rdline(jinit,line)
	 if ( (line .eq. 'read_line_end') .or. (line .eq. 'read_line_error'))  goto 75	 
!!	 read(iunit,*,err=75,end=75) ip,name,line
	 nwords=100 !match the dimension of w(:)
	 ecount=0
	 call bwords(line,nwords,w0)
	 read(w0(1),*) ip !!ip=w0(1)
	 read(w0(2),*) name
!!	 name=w0(2)
	 w(1:98)=w0(3:100)
	 nwords=nwords-2
	 noblegas=w(1)  ! must be char*2 by definition
	 if(ip.lt.0) allip=.true.
	 ip=iabs(ip)
	 inoble=IsNoble(noblegas)
!	 if(inoble.lt.0) call par_stop('Invalid noble gas code in config.inp')
	 z=NameToZ(name)
	 if(inoble.gt.0) zn=NameToZ(noblegas)
	 if(z.le.0) call par_stop('Invalid element name in config.inp')
	 if(ip.gt.nph) outofrange=.true.
	 if (.not. outofrange) then
		 !initialize a potential type of feff.inp 
		 if(z.ne.iz(ip)) then
			call wlog('ERROR: Element name in config.inp does not match Z in feff.inp for some potential type.')
			call par_stop('Invalid element name in config.inp')
		 endif
		 n=0
		 !Now read and decypher noble gas notation ...
		 if(inoble.gt.0) then
		    if(configtype .ne. 7) then
			   ispn(ip,:)=ispn9(zn,:) ; iocc(ip,:)=iocc9(zn,:) ; ival(ip,:)=ival9(zn,:)
			else
			   ispn(ip,:)=0 ; iocc(ip,:)=iocc7(zn,:) ; ival(ip,:)=ival7(zn,:)
			endif
			ecount=zn
			n=1
		 endif
		 do while(n .lt. nwords)
			n=n+1
			read(w(n),'(a2)',err=975) state
			ist=ParseState(state)
			n=n+1
			read(w(n),*,err=975) io
			iocc(ip,ist)=abs(io)
			if(io.gt.0) ival(ip,ist)=abs(io)
			ecount=ecount+abs(io)
			if(w(n+1).eq.'s') then
				n=n+2
				read(w(n),*,err=975) ispn(ip,ist)
			endif
			if(ist.ne.1 .and. ist.ne.2 .and. ist.ne.5 .and. ist.ne.10 .and. ist.ne.17 .and. ist.ne.24 .and. ist.ne.29) then  !not an s-state
			   n=n+1
			   read(w(n),*,err=975) io
			   iocc(ip,ist+1)=abs(io)
			   if(io.gt.0) ival(ip,ist+1)=abs(io)
			   ecount=ecount+abs(io)
			   if(w(n+1).eq.'s') then
				  n=n+2
				  read(w(n),*,err=975) ispn(ip,ist+1)
			   endif
			endif
		 enddo
		 !done reading line "ip"; now see if we need to copy this info:
		 if(ecount.ne.z) call wlog(':WARNING : Number of electrons does not add up to atomic number Z in config.inp - ion?')
		 if(allip) then
			do iph=0,nph
			   if(iz(iph) .eq. z) then
				  iocc(iph,:)=iocc(ip,:)
				  ival(iph,:)=ival(ip,:)
				  ispn(iph,:)=ispn(ip,:)
			   endif
			enddo
		 endif
     else
		 !initialize an element not in feff.inp 
		 !Now read and decypher noble gas notation ...
		 n=0
		 if(inoble.gt.0) then
		    if(configtype .ne. 7) then
			   ispn9(z,:)=ispn9(zn,:) ; iocc9(z,:)=iocc9(zn,:) ; ival9(z,:)=ival9(zn,:)
			else
			   iocc7(z,:)=iocc7(zn,:) ; ival7(z,:)=ival7(zn,:)
			endif
			ecount=zn
			n=1
		 endif
		 do while(n .lt. nwords)
			n=n+1
			read(w(n),'(a2)',err=975) state
			ist=ParseState(state)
			n=n+1
			read(w(n),*,err=975) io
			if(configtype.ne.7) then
			   iocc9(z,ist)=abs(io)
			   if(io.gt.0) ival9(z,ist)=abs(io)
			else
			   iocc7(z,ist)=abs(io)
			   if(io.gt.0) ival7(z,ist)=abs(io)
			endif
			ecount=ecount+abs(io)
			if(w(n+1).eq.'s') then
			    if(configtype.eq.7) call par_stop('Error-rubbish input in config.inp')
				n=n+2
				read(w(n),*,err=975) ispn9(z,ist)
			endif
			if(ist.ne.1 .and. ist.ne.2 .and. ist.ne.5 .and. ist.ne.10 .and. ist.ne.17 .and. ist.ne.24 .and. ist.ne.29) then  !not an s-state
			   n=n+1
			   read(w(n),*,err=975) io
			   if(configtype.ne.7) then
			      iocc9(z,ist+1)=abs(io)
			      if(io.gt.0) ival9(z,ist+1)=abs(io)
			   else
			      iocc7(z,ist+1)=abs(io)
			      if(io.gt.0) ival7(z,ist+1)=abs(io)
			   endif			
			   ecount=ecount+abs(io)
			   if(w(n+1).eq.'s') then
			      if(configtype.eq.7) call par_stop('Error-rubbish input in config.inp')
				  n=n+2
				  read(w(n),*,err=975) ispn9(z,ist+1)
			   endif
			endif
		 enddo
		 !done reading line "ip"
		 if(ecount.ne.z) call wlog(':WARNING : Number of electrons does not add up to atomic number Z in config.inp - ion?')
     endif	 
	 goto 57 ! read the next line
	 
75   continue	 
	 close(iunit) 
	 return    
975  call par_stop('Corrupt file config.inp.')	 
     return
end subroutine ParseConfig


integer FUNCTION ParseState(s)
character*2,intent(in) :: s
if    (s.eq.'1s') then ; ParseState=1
elseif(s.eq.'2s') then ; ParseState=2
elseif(s.eq.'2p') then ; ParseState=3
elseif(s.eq.'3s') then ; ParseState=5
elseif(s.eq.'3p') then ; ParseState=6
elseif(s.eq.'3d') then ; ParseState=8
elseif(s.eq.'4s') then ; ParseState=10
elseif(s.eq.'4p') then ; ParseState=11
elseif(s.eq.'4d') then ; ParseState=13
elseif(s.eq.'4f') then ; ParseState=15
elseif(s.eq.'5s') then ; ParseState=17
elseif(s.eq.'5p') then ; ParseState=18
elseif(s.eq.'5d') then ; ParseState=20
elseif(s.eq.'5f') then ; ParseState=22
elseif(s.eq.'6s') then ; ParseState=24
elseif(s.eq.'6p') then ; ParseState=25
elseif(s.eq.'6d') then ; ParseState=27
elseif(s.eq.'7s') then ; ParseState=29
else                   ; ParseState=-1
endif
return
end function ParseState


SUBROUTINE DumpConfig(iunit)
! Write configuration to file (reflecting hardcoded templates and feff.inp CONFIG input)
integer,intent(in) :: iunit
integer iph
open(iunit,file='config.dat',form='formatted',status='unknown')
write(iunit,'(a)') '# Configuration of all atom types in feff.inp.'
write(iunit,'(a)') '# iph, z,name,  iocc/ival/ispn (i=1,29)'
do iph=0,nph
   write(iunit,'(i3,2x,i3,2x,a2,2x,29(f5.2,2x))') iph,iz(iph),element(iz(iph)),iocc(iph,:)
   write(iunit,'(14x,29(f5.2,2x))') ival(iph,:)
   write(iunit,'(14x,29(f5.2,2x))') ispn(iph,:)
enddo
close(iunit) 
return
end subroutine DumpConfig

SUBROUTINE DumpConfig2(iunit,iniocc,inival,nq,nk,no)
! Write configuration to file (meant to be called from outside the module, when ionicity and core hole/screening have been added for all atoms)
integer,intent(in) :: iunit
integer,intent(in) :: no(0:nph) !=norb
real*8,intent(in) ::  iniocc(30,0:nph),inival(30,0:nph)  !arrays represenging only occupied orbitals (i.e. xnel,xnval)  -- iz and nph are known already
real*8            ::  intocc(30,0:nph),intval(30,0:nph)  !arrays representing all orbitals, including empty ones
integer,intent(in) :: nq(30,0:nph),nk(30,0:nph)
integer iph,i,j,k
!write(*,*) 'DUMPCONFIG2*****************'
!write(*,*) 'nk',nk(:,1)
!write(*,*) 'nq',nq(:,1)
!write(*,*) 'xnel',iniocc(:,1)
!write(*,*) 'norb',no(1)
! Expand arrays of occupied states occupations to arrays of occupations for all orbitals
intocc=0.d0
intval=0.d0
do i=0,nph
do j=1,no(i)
   do k=1,29
      if (nnum(k).eq.nq(j,i) .and. kappa(k).eq.nk(j,i)) then
	     intocc(k,i)=iniocc(j,i)
		 intval(k,i)=inival(j,i)
      endif
   enddo
enddo
enddo

! Write to file
open(iunit,file='config.dat',form='formatted',status='unknown')
write(iunit,'(a)') '# Configuration of all atom types in feff.inp.'
write(iunit,'(a)') '# Atomic occupation numbers including core hole, screening, and ionicity (but no SCF).'
write(iunit,'(a)') '# iph, z,name,  iocc/ival/ispn (i=1,29)'
do iph=0,nph
   write(iunit,'(i3,2x,i3,2x,a2,2x,29(f5.2,2x))') iph,iz(iph),element(iz(iph)),intocc(1:29,iph)
   write(iunit,'(14x,29(f5.2,2x))') intval(1:29,iph)
!   write(iunit,'(14x,29(f5.2,2x))') ispn(iph,:)
enddo
close(iunit) 
return
end subroutine DumpConfig2


integer FUNCTION NameToZ(name)
character*2,intent(in) :: name
NameToZ=-1
do i=1,100
   if(element(i).eq.name) then 
      NameToZ=i
	  return
   endif
enddo
return
end function NameToZ


integer FUNCTION IsNoble(name)
character*2,intent(in) :: name 
if(NameToZ(name).eq.2) then
   IsNoble=1  ! He
elseif(NameToZ(name).eq.10) then
   IsNoble=2  ! Ne
elseif(NameToZ(name).eq.18) then
   IsNoble=3  ! Ar
elseif(NameToZ(name).eq.36) then
   IsNoble=4  ! Kr
elseif(NameToZ(name).eq.54) then
   IsNoble=5  ! Xe
elseif(NameToZ(name).eq.80) then
   IsNoble=5  ! Hg - not a noble gas, but used to specify configurations
elseif(NameToZ(name).eq.86) then
   IsNoble=6  ! Rn
elseif(name.eq.' 0'.or.name.eq.'0 ') then
   IsNoble=0  ! no noble gas basis - maybe for H??
else
   IsNoble=-1 ! not a noble gas
endif
return
end function IsNoble


end MODULE config


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_constants.f90,v $:
! $Revision: 1.3 $
! $Author: jorissen $
! $Date: 2010/12/16 18:30:30 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*************************************************************************
      module constants

      implicit none

      ! Symbolic names for kind types of 4-, 2-, and 1-byte integers:
      integer, parameter :: I4 = selected_int_kind(9)
      integer, parameter :: I2 = selected_int_kind(4)
      integer, parameter :: I1 = selected_int_kind(2)
      ! Symbolic names for kind types of single- and double-precision reals:
      integer, parameter :: SP  = kind(1.0)
      integer, parameter :: DP  = kind(1.0D0)
      ! Symbolic names for kind types of single- and double-precision complex:
      integer, parameter :: SZ  = kind((1.0,1.0))
      integer, parameter :: DZ  = kind((1.0D0,1.0D0))
      ! Symbolic name for kind type of default logical:
      integer, parameter :: LGT = kind(.true.)
      private i1,i2,i4,sp,dp,sz,dz,lgt

      real(dp), parameter :: pi2 = 6.283185307179586476925286766559_dp
      real(dp), parameter :: pi  = 3.1415926535897932384626433832795_dp
      real(dp), parameter :: one = 1.0_dp
      real(dp), parameter :: zero  = 0.0_dp
      real(dp), parameter :: third = 1.0_dp/3.0_dp
      real(dp), parameter :: raddeg = 180.0_dp/pi
!     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
      real(dp), parameter :: fa = 1.919158292677512811_dp
      complex(dz), parameter :: coni = (0.0_dp,1.0_dp)
      real(dp), parameter :: bohr = 0.529177249_dp
      real(dp), parameter :: ryd  = 13.605698_dp
      real(dp), parameter :: hart = 2.0_dp*ryd
      real(dp), parameter :: alpinv = 137.03598956_dp
      real(dp), parameter :: alphfs = 1.0_dp/alpinv

      ! from moduleseels.f 
      ! conversion from eV to Ry :
      real(dp), parameter :: ev2Ry = 1.0_dp/13.6058_dp
      !  h/2pi c in units eV a.u.
      real(dp), parameter :: hbarc_eV = 1973.2708_dp/0.529177_dp
	  real(dp), parameter :: hbarc_atomic = 137.04188_dp  ! i.e. in Ha, hence 27.2 times smaller than above
      ! electron rest mass times c^2 in au (ie, 1 * alfa * alfa), times eV/Ha (27.2)
      real(dp), parameter :: MeC2 =  511004.0_dp
      REAL(dp), parameter :: HOnSqrtTwoMe = 23.1761_dp
      ! Me c / hbar = 2.5896 10^12 m^(-1) = 137.04188 a.u.^(-1)
      real(dp), parameter :: MeCOnHbar = 137.04188_dp

      end module constants

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_errormod.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      MODULE ErrorMod
        IMPLICIT NONE
        INTEGER :: MxErrLines
        PARAMETER( MxErrLines = 5 )
        LOGICAL,PRIVATE :: FirstErrorCall = .TRUE.

        TYPE ErrorType
           ! ErrorName - name of errror
           CHARACTER(30)  ErrorName
           CHARACTER(150) Message(MxErrLines)
           CHARACTER(10)  Action
           LOGICAL        ErrorOccured
           INTEGER        NErrLines
        END TYPE ErrorType

        CHARACTER(300),PRIVATE :: ErrorMessage
        LOGICAL,PRIVATE :: MessageIsSet = .FALSE.

        INTERFACE Error
           MODULE PROCEDURE ErrorSM
           MODULE PROCEDURE ErrorMM
        END INTERFACE
      CONTAINS
        
        ! Set the message to report when an error occurs.
        SUBROUTINE SetErrorMessage(Message)
          CHARACTER*(*) Message
          
          ErrorMessage = Message
          MessageIsSet = .TRUE.
          
          RETURN 
        END SUBROUTINE SetErrorMessage
        
        
        ! Returns true if error message is set, false otherwise.
        FUNCTION ErrorMessageIsSet()
          LOGICAL ErrorMessageIsSet
          ErrorMessageIsSet = MessageIsSet
          RETURN
        END FUNCTION ErrorMessageIsSet


        ! Print ErrorMessage if Message is not supplied,
        ! otherwise, Message is printed. Then STOP.
        SUBROUTINE ErrorSM(Message,StopProgram)
          CHARACTER*(*),INTENT(IN),OPTIONAL :: Message
          LOGICAL,INTENT(IN),OPTIONAL :: StopProgram
          ! If this is the first call to Error, print buffer.
          IF(FirstErrorCall) THEN
             PRINT*
             PRINT '(A)', '************************************************************************************'
             PRINT '(A)', '************************************************************************************'
             FirstErrorCall = .FALSE.
          END IF

          IF(PRESENT(Message)) THEN         
             PRINT*, TRIM(Message)
          ELSE
             IF(MessageIsSet) THEN
                PRINT*, TRIM(ErrorMessage)
             ELSE
                PRINT*, 'Unknown Error'
             END IF
          END IF

          IF(PRESENT(StopProgram)) THEN
             IF(StopProgram) THEN
                PRINT '(A)', '************************************************************************************'
                PRINT '(A)', '************************************************************************************'
                PRINT*
             END IF
          ELSE
             PRINT '(A)', '************************************************************************************'
             PRINT '(A)', '************************************************************************************'
             PRINT*
             STOP
          END IF

        END SUBROUTINE ErrorSM

        SUBROUTINE ErrorMM(Messg,StopProgram)
          CHARACTER*(*),INTENT(IN) :: Messg(:)
          INTEGER iMessg, NMessg
          LOGICAL,OPTIONAL,INTENT(IN) :: StopProgram
          
          NMessg = SIZE(Messg)
          DO iMessg = 1, NMessg - 1
             IF(PRESENT(StopProgram)) THEN
                CALL ErrorSM(Messg(iMessg), StopProgram = StopProgram)
             ELSE
                CALL ErrorSM(Messg(iMessg), StopProgram = .FALSE.)
             END IF
          END DO

          CALL ErrorSM(Messg(NMessg), StopProgram = .TRUE.)

        END SUBROUTINE ErrorMM
        
        SUBROUTINE CheckError(ErrType)
          TYPE(ErrorType),INTENT(IN) :: ErrType
          LOGICAL StopOnError
          CHARACTER(10) Action
          INTEGER i1

          ! If the error did not occur, return
          IF(.not.ErrType%ErrorOccured) RETURN

          ! Set the action. Stop, warn, or do nothing.
          Action = ADJUSTL(ErrType%Action)
          CALL Upper(Action)
          IF(Action(1:4).eq.'STOP') THEN              
             StopOnError = .TRUE.
             CALL Error('ERROR:', StopProgram = .FALSE.)
          ELSEIF(Action(1:4).eq.'WARN') THEN
             StopOnError = .FALSE.
             CALL Error('WARNING:', StopProgram = .FALSE.)
          ELSE
             RETURN
          END IF

          ! Print the errror messages
          DO i1 = 1, ErrType%NErrLines
             CALL Error(ErrType%Message(i1), StopProgram = .FALSE.)
          END DO
          
          ! If Action = 'STOP' Stop.
          IF(StopOnError) STOP
        END SUBROUTINE CheckError


        SUBROUTINE CheckErrors(ErrorTypes)
          TYPE(ErrorType) ErrorTypes(:)
          INTEGER i1
          
          DO i1 = 1, SIZE(ErrorTypes)
             CALL CheckError(ErrorTypes(i1))
          END DO
        END SUBROUTINE CheckErrors


        ! Check Allocation.
        SUBROUTINE CheckAllocation(iErr,Message)
          INTEGER,INTENT(IN) :: iErr
          CHARACTER*(*),INTENT(IN) :: Message

          IF(iErr.ne.0) CALL Error(Message)

          RETURN
        END SUBROUTINE CheckAllocation

      END MODULE ErrorMod

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_iofiles.f90,v $:
! $Revision: 1.6 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MODULE IOFiles
  USE ErrorMod
  IMPLICIT NONE
  ! MaxLength - Maximum length of filename strings
  ! MaxSections - Maximum number of sections in a file
  INTEGER,PRIVATE :: MaxLength, MaxSections, NError
  PARAMETER( MaxLength = 300, MaxSections = 1000, NError = 2 )
  
  ! Default format strings for Integer, Real, Double, Complex, 
  ! Double Complex, and String
  CHARACTER(300) DefaultIFormat, DefaultRFormat, DefaultDFormat, &
       & DefaultCFormat, DefaultDCFormat, DefaultSFormat
  PARAMETER ( DefaultIFormat  = '(I10)' )
  PARAMETER ( DefaultRFormat  = '(E20.10)' )
  PARAMETER ( DefaultDFormat  = '(E20.10)' )
  PARAMETER ( DefaultCFormat  = '(1E20.10,1X,1E20.10)' )
  PARAMETER ( DefaultDCFormat = '(1E20.10,1X,1E20.10)' )
  PARAMETER ( DefaultSFormat  = '(A)' )
  
  ! Default file format is text
  CHARACTER(3) DefaultFileFormat
  PARAMETER ( DefaultFileFormat = 'TXT' )


  TYPE IOFile
     ! Filename - name of file.
     ! DataTypeLine - type description of the columns of data that will 
     ! be in a section. Section changes when data types change or user 
     ! specifies a new section.
     CHARACTER(300) FileName, DataTypeLine(MaxSections)
     ! Format strings for each type of data (Integer, Real, Double, 
     ! Complex, Complex*16, and String
     CHARACTER(100) IFormat, RFormat, DFormat, CFormat, DCFormat, SFormat
     ! Specify whether you want output to be ASCII ('txt') or packed 
     ! ascii ('pad'). Can add new formats later, i.e. 'xml' ...
     CHARACTER(5) FileFormat
     ! IOFileAction: READ, WRITE, READWRITE
     CHARACTER(9) IOFileAction
     ! NLines     - number of lines in a section
     ! TotLines   - total number of lines in file.
     ! NSections  - Number of sections (Write) or current section (Read).
     ! UnitNumber - unit number of the file.
     INTEGER NLines(MaxSections), TotLines, NSections, UnitNumber
     ! IsInitialized - this IOFile was initialized if true.
     ! ExistedOnOpen - file existed when we opened it if true.
     ! IsOpen        - file is open if true.
     ! EOF           - End of file has been reached (Read) if true.
     LOGICAL IsInitialized, ExistedOnOpen, IsOpen, EOF
     ! ReadError and WriteError define possible errors that could occur, and what action to take
     ! if each error does occur.
     TYPE(ErrorType) IOErrors(NError)
  END TYPE IOFile

  TYPE(IOFile),PRIVATE,SAVE :: FileStack(100)
  INTEGER,PRIVATE,Save :: NFiles = 0

  INTERFACE ASSIGNMENT(=)
     MODULE PROCEDURE CopyIOFile
  END INTERFACE

CONTAINS

  ! Set IOFile1 = IOFile2
  SUBROUTINE CopyIOFile(IOFile1, IOFile2)
    TYPE(IOFile),INTENT(OUT) :: IOFile1
    TYPE(IOFile),INTENT(IN)  :: IOFile2

    IOFile1%FileName = IOFile2%FileName
    IOFile1%DataTypeLine(:) = IOFile2%DataTypeLine(:) 

    IOFile1%IFormat  = IOFile2%IFormat
    IOFile1%RFormat  = IOFile2%RFormat
    IOFile1%DFormat  = IOFile2%DFormat
    IOFile1%CFormat  = IOFile2%CFormat
    IOFile1%DCFormat = IOFile2%DCFormat
    IOFile1%SFormat  = IOFile2%SFormat

    IOFile1%FileFormat = IOFile2%FileFormat

    IOFile1%IOFileAction = IOFile2%IOFileAction

    IOFile1%NLines(:) = IOFile2%NLines(:)
    IOFile1%TotLines = IOFile2%TotLines
    IOFile1%NSections = IOFile2%NSections
    IOFile1%UnitNumber = IOFile2%UnitNumber

    IOFile1%IsInitialized = IOFile2%IsInitialized
    IOFile1%ExistedOnOpen = IOFile2%ExistedOnOpen
    IOFile1%IsOpen = IOFile2%IsOpen
    IOFile1%EOF = IOFile2%EOF


  END SUBROUTINE COPYIOFILE

  ! Initialize IOFile IOF. FileName must be specified.
  ! All other arguments are optional.
  SUBROUTINE InitIOFile(IOF, FileName)
    TYPE(IOFile),INTENT(INOUT) :: IOF
    CHARACTER*(*),INTENT(IN) :: FileName
    ! Loop variables
    INTEGER i1
    ! Set FileName, NSections, NLines
    IOF%FileName  = FileName
    IOF%NSections = 0
    IOF%NLines(:) = 0
    IOF%TotLines  = 0
    IOF%NSections = 0
    IOF%DataTypeLine(:)='Unknown'
    IOF%IsInitialized = .TRUE.
    IOF%ExistedOnOpen = .FALSE.
    IOF%IFormat = DefaultIFormat
    IOF%RFormat = DefaultRFormat
    IOF%DFormat = DefaultDFormat
    IOF%CFormat = DefaultCFormat
    IOF%DCFormat = DefaultDCFormat
    IOF%SFormat = DefaultSFormat
    IOF%FileFormat = DefaultFileFormat
    IOF%EOF = .FALSE.

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Error definitions: Not set up yet.
    ! ArrayTooSmall - Error evaluates true if arrays passed to read routines are not big enough
    !                 to hold the data in the file.
    IOF%IOErrors(1)%ErrorName = 'ArrayTooSmall'
    IOF%IOErrors(1)%Message(1)    = 'Array too small to hold data in file ' // FileName // '.'
    IOF%IOErrors(1)%Action        = 'WARN' 
    IOF%IOErrors(1)%ErrorOccured  = .FALSE.
    IOF%IOErrors(1)%NErrLines     = 1

    ! ArrayTooLarge - Error evaluates true if arrays passed to read routines are larger than
    !                 the data in the file.
    IOF%IOErrors(2)%ErrorName = 'ArrayTooLarge'
    IOF%IOErrors(2)%Message(1)    = 'Array too large when compared to data in file ' // FileName // '.'
    IOF%IOErrors(2)%Action        = 'WARN' 
    IOF%IOErrors(2)%ErrorOccured  = .FALSE.
    IOF%IOErrors(2)%NErrLines     = 1

  END SUBROUTINE InitIOFile
    
  ! Add a file to the stack
  SUBROUTINE AddIOFile(FileName)
    CHARACTER*(*),INTENT(IN) :: FileName
    TYPE(IOFile) IOF

    ! If file exists, do nothing
    IF(IndexIOFile(FileName).ne.0) RETURN 

    ! initialize IOFile
    CALL InitIOFile(IOF, FileName)
    
    ! Add IOFile to stack.
    NFiles = NFiles + 1
    FileStack(NFiles) = IOF
    FileStack(NFiles)%IsInitialized = .TRUE.
  END SUBROUTINE AddIOFile

  ! Find the index of a file
  INTEGER FUNCTION IndexIOFile(FileName)
    CHARACTER*(*) FileName
    INTEGER i1
    IndexIOFile = 0
    DO i1 = 1, NFiles
       IF(TRIM(FileStack(i1)%FileName).eq.TRIM(FileName)) THEN
          IndexIOFile = i1
          RETURN
       END IF
    END DO
  END FUNCTION IndexIOFile


  ! Remove a file from the stack
  SUBROUTINE DeleteIOFile(FileName)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER(10) TmpStr

    ! Local variable index is index of file to delete
    INTEGER Index
    INTEGER i1
    
    TmpStr = TRIM(ADJUSTL(FileName))
    CALL Upper(TmpStr)
    
    IF(TmpStr(1:3).eq.'ALL') THEN       
       NFiles = 0
    ELSE
       Index = IndexIOFile(FileName)
       ! If file doesn't exist, do nothing
       IF(Index.eq.0) RETURN
       
       ! Shift remaining files left
       DO i1 = Index, NFiles - 1
          FileStack(i1) = FileStack(i1+1)
       END DO
       
       NFiles = NFiles - 1
    END IF
  END SUBROUTINE DeleteIOFile

  ! Set options for IOFile
  SUBROUTINE SetIOFileInfo(FileName,UnitNumber, DataTypeLine, IFormat, RFormat, &
       & DFormat, CFormat, DCFormat, SFormat, FileFormat, ExistedOnOpen, IsOpen, &
       & FileAction, NSections,EOF)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: DataTypeLine, IFormat, RFormat, DFormat, &
         & CFormat, DCFormat, SFormat, FileFormat, FileAction
    LOGICAL, INTENT(IN), OPTIONAL :: ExistedOnOpen, IsOpen, EOF
    INTEGER, INTENT(IN), OPTIONAL :: UnitNumber, NSections

    CHARACTER(1000) TmpStr
    INTEGER IOFIndex

    IOFIndex = IndexIOFile(FileName)
    IF(IOFIndex.eq.0) THEN
       CALL Error('Error in function: SetIOFileOptions', StopProgram = .FALSE.)
       CALL Error('File: ' // FileName // ' does not exist.')
    END IF

    ! If arguments are present, set them.
    IF(PRESENT(UnitNumber)) FileStack(IOFIndex)%UnitNumber = UnitNumber
    IF(PRESENT(NSections)) FileStack(IOFIndex)%NSections = NSections
    IF(PRESENT(DataTypeLine)) THEN
       IF(FileStack(IOFIndex)%NSections.gt.0) FileStack(IOFIndex)%DataTypeLine(FileStack(IOFIndex)%NSections) = DataTypeLine
    END IF
    IF(PRESENT(IFormat))  FileStack(IOFIndex)%IFormat  = IFormat
    IF(PRESENT(RFormat))  FileStack(IOFIndex)%RFormat  = RFormat
    IF(PRESENT(DFormat))  FileStack(IOFIndex)%DFormat  = DFormat
    IF(PRESENT(CFormat))  FileStack(IOFIndex)%CFormat  = CFormat
    IF(PRESENT(DCFormat)) FileStack(IOFIndex)%DCFormat = DCFormat
    IF(PRESENT(SFormat))  FileStack(IOFIndex)%SFormat  = SFormat
    IF(PRESENT(FileFormat)) THEN
       TmpStr = TRIM(ADJUSTL(FileFormat))
       CALL Upper(TmpStr)
       FileStack(IOFIndex)%FileFormat  = TRIM(TmpStr)
    END IF
    IF(PRESENT(ExistedOnOpen)) FileStack(IOFIndex)%ExistedOnOpen  = ExistedOnOpen
    IF(PRESENT(IsOpen)) FileStack(IOFIndex)%IsOpen  = IsOpen
    IF(PRESENT(FileAction)) THEN
       TmpStr = TRIM(ADJUSTL(FileAction))
       CALL Upper(TmpStr)
       FileStack(IOFIndex)%IOFileAction = TRIM(TmpStr)
    END IF
    IF(PRESENT(EOF)) FileStack(IOFIndex)%EOF = EOF
  END SUBROUTINE SetIOFileInfo

  SUBROUTINE GetIOFileInfo(FileName, UnitNumber, DataTypeLine, IFormat, RFormat, &
       & DFormat, CFormat, DCFormat, SFormat, FileFormat, ExistedOnOpen, IsOpen, &
       & FileAction, NSections, EOF)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: DataTypeLine, IFormat, RFormat, DFormat, &
         & CFormat, DCFormat, SFormat, FileFormat, FileAction
    LOGICAL, INTENT(OUT), OPTIONAL :: ExistedOnOpen, IsOpen, EOF
    INTEGER, INTENT(OUT), OPTIONAL :: UnitNumber, NSections

    INTEGER IOFIndex

    IOFIndex = IndexIOFile(FileName)

    IF(IOFIndex.eq.0) THEN
       CALL Error('Error in function: GetIOFileInfo', StopProgram = .FALSE.)
       CALL Error('File: ' // FileName // ' does not exist.')
    END IF

    ! If arguments are present, set them.
    IF(PRESENT(UnitNumber)) UnitNumber = FileStack(IOFIndex)%UnitNumber
    IF(PRESENT(DataTypeLine)) THEN
       IF(FileStack(IOFIndex)%NSections.gt.0) THEN
          DataTypeLine = FileStack(IOFIndex)%DataTypeLine(FileStack(IOFIndex)%NSections)
       END IF
    END IF
    IF(PRESENT(IFormat))  IFormat  = FileStack(IOFIndex)%IFormat
    IF(PRESENT(RFormat))  RFormat  = FileStack(IOFIndex)%RFormat
    IF(PRESENT(DFormat))  DFormat  = FileStack(IOFIndex)%DFormat
    IF(PRESENT(CFormat))  CFormat  = FileStack(IOFIndex)%CFormat
    IF(PRESENT(DCFormat)) DCFormat = FileStack(IOFIndex)%DCFormat
    IF(PRESENT(SFormat))  SFormat  = FileStack(IOFIndex)%SFormat 

    IF(PRESENT(FileFormat)) FileFormat = FileStack(IOFIndex)%FileFormat
    IF(PRESENT(ExistedOnOpen)) ExistedOnOpen = FileStack(IOFIndex)%ExistedOnOpen
    IF(PRESENT(IsOpen)) IsOpen = FileStack(IOFIndex)%IsOpen
    IF(PRESENT(NSections)) NSections = FileStack(IOFIndex)%NSections
    IF(PRESENT(EOF)) EOF = FileStack(IOFIndex)%EOF
    IF(PRESENT(FileAction)) FileAction = FileStack(IOFIndex)%IOFileAction
  END SUBROUTINE GetIOFileInfo
  
  SUBROUTINE PrintIOFileInfo(IOF)
    TYPE(IOFile) IOF
    INTEGER i1

    PRINT '(A)', 'Information for file ' // TRIM(IOF%FileName)
    PRINT *, 'File is initialized ?: ', IOF%IsInitialized
    PRINT*, 'File is open?: ', IOF%IsOpen
    PRINT*, 'Files existed on open ?: ', IOF%ExistedOnOpen
    PRINT*, 'Unit Number: ', IOF%UnitNumber
    PRINT*, 'End of file?: ', IOF%EOF
    PRINT '(2A)', 'IFormat: ', IOF%IFormat
    PRINT '(2A)', 'RFormat: ', IOF%RFormat
    PRINT '(2A)', 'DFormat: ', IOF%DFormat
    PRINT '(2A)', 'CFormat: ', IOF%CFormat
    PRINT '(2A)', 'DCFormat: ',IOF%DCFormat
    PRINT '(2A)', 'SFormat: ', IOF%SFormat
    PRINT '(2A)', 'FileFormat: ', IOF%FileFormat
    PRINT '(2A)', 'FileAction: ', IOF%IOFileAction
    PRINT '(A,I10)', 'Total number of Lines: ', IOF%TotLines
    PRINT '(A,I10)', 'Number of sections: ', IOF%NSections

    PRINT '(A)', 'Section information:'
    PRINT '(A)', 'Section  NLines  DataTypeLine'
    DO i1 = 1, IOF%NSections
       PRINT '(2I5,1X,A)', i1, IOF%NLines(i1), IOF%DataTypeLine(i1)
    END DO
  END SUBROUTINE PrintIOFileInfo
  
  SUBROUTINE PrintFileStackInfo
    INTEGER i1
    PRINT*, 'Number of files: ', NFiles
    DO i1 = 1, NFiles
       CALL PrintIOFileInfo(FileStack(i1))
    END DO
  END SUBROUTINE PrintFileStackInfo

  LOGICAL FUNCTION ReadingNewSection(FileName,NSections)
    CHARACTER*(*), INTENT(IN) :: FileName
    INTEGER,INTENT(IN) :: NSections
    INTEGER IOFIndex

    IOFIndex = IndexIOFile(FileName)

    IF(IOFIndex.eq.0) THEN
       CALL Error('Error in function IsNewSection. File: ' &
            & // FileName // ' does not exist.')
    ELSE
       
       IF(FileStack(IOFIndex)%NSections.eq.NSections+1) THEN
          ReadingNewSection = .TRUE.
       ELSE
          ReadingNewSection = .FALSE.
       END IF
    END IF
  END FUNCTION ReadingNewSection
    
  LOGICAL FUNCTION WritingNewSection(FileName,DataTypeLine)
    CHARACTER*(*), INTENT(IN) :: FileName, DataTypeLine
    INTEGER IOFIndex, NSections

!    write(*,*) 'filename,datatypeline',filename,datatypeline
!	write(*,*) 'filestack',filestack
    IOFIndex = IndexIOFile(FileName)
    IF(IOFIndex.eq.0) THEN
       CALL Error('Error in function IsNewSection. File: ' &
            & // FileName // ' does not exist.')
    ELSE
       NSections = FileStack(IOFIndex)%NSections
       IF(NSections.le.0) THEN
          WritingNewSection = .FALSE.
          RETURN
       END IF
       IF(TRIM(DataTypeLine).eq. &
            & TRIM(FileStack(IOFIndex)%DataTypeLine(NSections)).or.&
            & LEN_TRIM(DataTypeLine).eq.0) THEN
          WritingNewSection = .FALSE.
       ELSE
          WritingNewSection = .TRUE.
       END IF
    END IF
  END FUNCTION WritingNewSection

  SUBROUTINE GetFileStackInfo(NumberOfFiles, FileNames, UnitNumbers)
    INTEGER,INTENT(OUT) :: NumberOfFiles
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: FileNames(:)
    INTEGER,INTENT(OUT),OPTIONAL :: UnitNumbers(:)

    INTEGER i1

    IF(PRESENT(FileNames)) THEN
       ! Check the size of the array.
       IF(SIZE(FileNames).gt.NFiles) CALL Error('Array to hold file names passed to ' // &
            & 'GetFileStackInfo is not large enough.')
       
       DO i1 = 1, NFiles
          FileNames(i1) = FileStack(i1)%FileName
       END DO
    END IF

    IF(PRESENT(UnitNumbers)) THEN
       ! Check the size of the array.
       IF(SIZE(UnitNumbers).gt.NFiles) CALL Error('Array to hold file names passed to ' // &
            & 'GetFileStackInfo is not large enough.')
       
       DO i1 = 1, NFiles
          UnitNumbers(i1) = FileStack(i1)%UnitNumber
       END DO
    END IF
    NumberOfFiles = NFiles
  END SUBROUTINE GetFileStackInfo

! Find the index of an ioerror.
  INTEGER FUNCTION IndexIOError(Filename,ErrorName)
    CHARACTER*(*) FileName, ErrorName
    INTEGER IOFIndex, i1
    
    IOFIndex = IndexIOFile(FileName)
    ! If file doesn't exist, error
    IF(IOFIndex.eq.0) CALL Error('ERROR: IOFile does not exist for file ' // FileName // '.')

    DO i1 = 1, NError
       IF(TRIM(FileStack(IOFIndex)%IOErrors(i1)%ErrorName).eq.TRIM(ErrorName)) THEN
          IndexIOError = i1
          RETURN
       END IF
    END DO
  END FUNCTION IndexIOError

  SUBROUTINE SetIOErrorInfo(FileName, ErrorName, Message, Action, ErrorOccured)
    CHARACTER*(*),INTENT(IN) :: FileName, ErrorName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: Message(:), Action
    LOGICAL,INTENT(IN),OPTIONAL :: ErrorOccured
    INTEGER IOErrorIndex, IOFIndex, i1, NMessage, NErrLines

    IOFIndex = IndexIOFile(FileName)
    IOErrorIndex = IndexIOError(FileName,ErrorName)
    NErrLines = FileStack(IOFIndex)%IOErrors(IOErrorIndex)%NErrLines

    IF(PRESENT(Message)) THEN
       NMessage = MAX(SIZE(Message)+NErrLines,MxErrLines)
       DO i1 = NErrLines, NMessage
          FileStack(IOFIndex)%IOErrors(IOErrorIndex)%Message(i1) = Message(i1-NErrLines+1)
       END DO
    END IF
    FileStack(IOFIndex)%IOErrors(IOErrorIndex)%NErrLines = NMessage
    IF(PRESENT(Action))  FileStack(IOFIndex)%IOErrors(IOErrorIndex)%Action = Action
    IF(PRESENT(ErrorOccured)) FileStack(IOFIndex)%IOErrors(IOErrorIndex)%ErrorOccured = ErrorOccured
  END SUBROUTINE SetIOErrorInfo

SUBROUTINE GetIOErrorInfo(FileName, ErrorName, Message, Action, ErrorOccured, NErrLines)
    CHARACTER*(*),INTENT(IN) :: FileName, ErrorName
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Message(:), Action
    LOGICAL,INTENT(OUT),OPTIONAL :: ErrorOccured
    INTEGER,INTENT(OUT),OPTIONAL :: NErrLines
    INTEGER IOErrorIndex, IOFIndex, i1, NLines

    IOFIndex = IndexIOFile(FileName)
    IOErrorIndex = IndexIOError(FileName,ErrorName)
    NLines = FileStack(IOFIndex)%IOErrors(IOErrorIndex)%NErrLines

    IF(PRESENT(Message)) THEN
       DO i1 = 1, NLines
          Message(i1) = FileStack(IOFIndex)%IOErrors(IOErrorIndex)%Message(i1)
       END DO
    END IF

    IF(PRESENT(Action))  Action = FileStack(IOFIndex)%IOErrors(IOErrorIndex)%Action
    IF(PRESENT(ErrorOccured))  ErrorOccured = FileStack(IOFIndex)%IOErrors(IOErrorIndex)%ErrorOccured
    IF(PRESENT(NErrLines))  NErrLines = FileStack(IOFIndex)%IOErrors(IOErrorIndex)%NErrLines 
  END SUBROUTINE GetIOErrorInfo
END MODULE IOFiles

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_padio.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! PAD library:   Packed Ascii Data 
!   these routines contain code for handling packed-ascii-data  
!   (pad) arrays for writing printable character strings that 
!   represent real or complex scalars and arrays to a file.
!
! routines included in padlib are (dp==double precision):
!   wrpadd     write a dp array as pad character strings
!   wrpadx     write a dp complex array as pad character strings
!   rdpadr     read a pad character array as a real array
!   rdpadd     read a pad character array as a dp  array
!   rdpadc     read a pad character array as a complex array
!   rdpadx     read a pad character array as a dp complex array
!   pad        internal routine to convert dp number to pad string
!   unpad      internal routine to pad string to dp number
!
! routines not included, but required by padlib:
!     triml, istrln, wlog
!
!//////////////////////////////////////////////////////////////////////
! Copyright (c) 1997--2001 Matthew Newville, The University of Chicago
! Copyright (c) 1992--1996 Matthew Newville, University of Washington
!
! Permission to use and redistribute the source code or binary forms of
! this software and its documentation, with or without modification is
! hereby granted provided that the above notice of copyright, these
! terms of use, and the disclaimer of warranty below appear in the
! source code and documentation, and that none of the names of The
! University of Chicago, The University of Washington, or the authors
! appear in advertising or endorsement of works derived from this
! software without specific prior written permission from all parties.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
! SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
!//////////////////////////////////////////////////////////////////////
! License is applicable for routines below, until otherwise specified.
!
MODULE PADIO
  USE ErrorMod

  ! padlib.h -*-fortran-*-
  !  header of parameters for packed-ascii-data (pad) routines
  implicit none
  character,private :: cpadr, cpadi, cpadc
  integer,private ::  maxlen, ibase, ioff, ihuge, ibas2
  double precision,private :: ten, tenlog, huge, tiny, one, zero, base
  parameter(cpadr = '!', cpadc = '$', cpadi = '%')
  parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
  parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
  parameter(tenlog= 2.302585092994045684d0)
  parameter(huge = ten**ihuge, tiny = one/huge)
  parameter(base = ibase*one)

  INTERFACE WritePAD
     MODULE PROCEDURE wrpaddsc
     MODULE PROCEDURE wrpadrsc
     MODULE PROCEDURE wrpadxsc
     MODULE PROCEDURE wrpadcsc
     MODULE PROCEDURE wrpadisc
     MODULE PROCEDURE wrpadssc
  END INTERFACE

  INTERFACE ReadPAD
     MODULE PROCEDURE rdpaddsc
     MODULE PROCEDURE rdpadrsc
     MODULE PROCEDURE rdpadxsc
     MODULE PROCEDURE rdpadcsc
     MODULE PROCEDURE rdpadisc
     MODULE PROCEDURE rdpadssc
  END INTERFACE

CONTAINS

  subroutine wrpaddsc(strval, npack,val)
    !
    ! write a dp scalar to a file in packed-ascii-data format
    !
    ! inputs:  [ no outputs / no side effects ]
    !   iout   unit to write to (assumed open)
    !   npack  number of characters to use (determines precision)
    !   array  real array 
    ! notes:
    !   real number converted to packed-ascii-data string using pad

    integer    iout, npack, npts, mxl, js, i
    character*(*) :: strval
    character  str*128
    double precision val, xr
    js  = 0
    str = ' '
    mxl = maxlen - npack + 1

    js = js+npack
    xr = val
    call padx(xr, npack, str(js-npack+1:js))

    ! Trim trailing zeros.
!    DO i = js, 4, -1
!       IF(str(i:i).eq.'%') THEN
!          str(i:i) = ' '
!       ELSE
!          EXIT
!       END IF
!    END DO
    strval = str(1:js)
    js = 0
    
    return
100 format(a1,a)
  end subroutine wrpaddsc

!   subroutine wrpadd(iout,npack,array,npts)
!     !
!     ! write a dp array to a file in packed-ascii-data format
!     !
!     ! inputs:  [ no outputs / no side effects ]
!     !   iout   unit to write to (assumed open)
!     !   npack  number of characters to use (determines precision)
!     !   array  real array 
!     !   npts   number of array elements to read
!     ! notes:
!     !   real number converted to packed-ascii-data string using pad

!     integer    iout, npack, npts, mxl, js, i
!     character  str*128
!     double precision array(*), xr
!     js  = 0
!     str = ' '
!     mxl = maxlen - npack + 1
!     do i = 1, npts
!        js = js+npack
!        xr = array(i)
!        call padx(xr, npack, str(js-npack+1:js))
!        if ((js.ge.mxl).or.(i.eq.npts)) then
!           write(iout,100) cpadr, str(1:js)
!           js = 0
!        end if
!     end do
!     return
! 100 format(a1,a)
!   end subroutine wrpadd
  ! --padlib--
  subroutine wrpadxsc(strval,npack,val)
    ! write complex*16 scalar as pad string
    character*(*) strval
    integer    iout, npack, mxl, js, i
    complex*16 val
    character  str1*128, str2*128
    double precision xr, xi
    js = 0
    str1  = ' '
    str2 = ' '
    mxl  = maxlen - 2 * npack + 1
    js = js  + 2 * npack + 1
    xr = dble(val)
    xi = dimag(val)
    call padx(xr, npack, str1(1:npack))

    ! Trim trailing zeros.
!    DO i = js, 4, -1
!       IF(str1(i:i).eq.'%') str1(i:i) = ' '
!    END DO
    
    call padx(xi, npack, str2(1:npack))

    ! Trim trailing zeros.
!    DO i = js, 4, -1
!       IF(str2(i:i).eq.'%') str2(i:i) = ' '
!    END DO


    strval = TRIM(ADJUSTL(str1)) // ' ' // TRIM(ADJUSTL(str2))
    js = 0
    
    
    return
100 format(a1,a)
  end subroutine wrpadxsc

!   subroutine wrpadx(iout,npack,array,npts)
!     ! write complex*16 array as pad string

!     integer    iout, npack, npts, mxl, js, i
!     complex*16 array(npts)
!     character  str*128
!     double precision xr, xi
!     js = 0
!     str  = ' '
!     mxl  = maxlen - 2 * npack + 1
!     do i = 1, npts
!        js = js  + 2 * npack
!        xr = dble(array(i))
!        xi = dimag(array(i))
!        call padx(xr, npack, str(js-2*npack+1:js-npack))
!        call padx(xi, npack, str(js-npack+1:js))
!        if ((js.ge.mxl).or.(i.eq.npts)) then
!           write(iout,100) cpadc, str(1:js)
!           js = 0
!        end if
!     end do
!     return
! 100 format(a1,a)
!   end subroutine wrpadx
!   ! --padlib--

  subroutine wrpadrsc(strval,npack,val)
    !
    ! write a real array to a file in packed-ascii-data format
    !
    ! inputs:  [ no outputs / no side effects ]
    !   iout   unit to write to (assumed open)
    !   npack  number of characters to use (determines precision)
    !   array  real array 
    !   npts   number of array elements to read
    ! notes:
    !   real number converted to packed-ascii-data string using pad
    character*(*) strval
    integer    iout, npack, mxl, js, i
    character  str*128
    real    val
    double precision xr
    js  = 0
    str = ' '
    mxl = maxlen - npack + 1

    js = js+npack
    xr = dble(val)
    call padx(xr, npack, str(js-npack+1:js))

    ! Trim trailing zeros.
!    DO i = js, 4, -1
!       IF(str(i:i).eq.'%') str(i:i) = ' '
!    END DO

    strval = str(1:js)
    js = 0

    return
100 format(a1,a)
  end subroutine wrpadrsc

!   subroutine wrpadr(iout,npack,array,npts)
!     !
!     ! write a real array to a file in packed-ascii-data format
!     !
!     ! inputs:  [ no outputs / no side effects ]
!     !   iout   unit to write to (assumed open)
!     !   npack  number of characters to use (determines precision)
!     !   array  real array 
!     !   npts   number of array elements to read
!     ! notes:
!     !   real number converted to packed-ascii-data string using pad

!     integer    iout, npack, npts, mxl, js, i
!     character  str*128
!     real    array(npts)
!     double precision xr
!     js  = 0
!     str = ' '
!     mxl = maxlen - npack + 1
!     do i = 1, npts
!        js = js+npack
!        xr = dble(array(i))
!        call padx(xr, npack, str(js-npack+1:js))
!        if ((js.ge.mxl).or.(i.eq.npts)) then
!           write(iout,100) cpadr, str(1:js)
!           js = 0
!        end if
!     end do
!     return
! 100 format(a1,a)
!   end subroutine wrpadr

!   ! --padlib--
  subroutine wrpadcsc(strval,npack,val)
    ! write complex (*8) scalar as pad string
    character*(*) strval
    integer    iout, npack, mxl, js, i
    complex    val
    character  str1*128, str2*128
    double precision xr, xi
    js = 0
    str1  = ' '
    str2  = ' ' 
    mxl  = maxlen - 2 * npack + 1

    js = js  + 2 * npack + 1
    xr = dble(val)
    xi = aimag(val)
    call padx(xr, npack, str1(1:npack))
    ! Trim trailing zeros.
!    DO i = js, 4, -1
!       IF(str1(i:i).eq.'%') str1(i:i) = ' '
!    END DO

    call padx(xi, npack, str2(1:npack))
    ! Trim trailing zeros.
!    DO i = js, 4, -1
!       IF(str2(i:i).eq.'%') str2(i:i) = ' '
!    END DO

    strval = TRIM(ADJUSTL(str1)) // ' ' // TRIM(ADJUSTL(str2))
    js = 0
    
    return
100 format(a1,a)
  end subroutine wrpadcsc
  ! --padlib--
!   subroutine wrpadc(iout,npack,array,npts)
!     ! write complex (*8) array as pad string
!     integer    iout, npack, npts, mxl, js, i
!     complex    array(*)
!     character  str*128
!     double precision xr, xi
!     js = 0
!     str  = ' '
!     mxl  = maxlen - 2 * npack + 1
!     do i = 1, npts
!        js = js  + 2 * npack
!        xr = dble(array(i))
!        xi = aimag(array(i))
!        call padx(xr, npack, str(js-2*npack+1:js-npack))
!        call padx(xi, npack, str(js-npack+1:js))
!        if ((js.ge.mxl).or.(i.eq.npts)) then
!           write(iout,100) cpadc, str(1:js)
!           js = 0
!        end if
!     end do
!     return
! 100 format(a1,a)
!   end subroutine wrpadc
  ! --padlib--
  subroutine wrpadisc(strval,val)
    character*(*) strval
    integer iou, iabs, val, imin, n, irem, iend
    character sign
    
    strval = ' '

    ! Set the sign
    if(val.lt.0) then
       sign = '-'
    else
       sign = '+'
    end if
    iend = LEN(strval)
    iabs = ABS(val)
    n = 0

    do
       IF(iabs.le.75**(n+1)) THEN
          strval(iend-n:iend-n) = ACHAR(INT(iabs/75**n)+48)
          strval(iend-n-1:iend-n-1) = sign
          strval = TRIM(ADJUSTL(strval))
          EXIT
       ELSE
          irem = MOD(iabs,75**(n+1))
          strval(iend-n:iend-n) = ACHAR(INT(irem/75**n)+48)
          iabs = iabs - irem
       END IF
       n = n + 1
       IF(n.eq.100) CALL Error('Error in wrpadisc: integer too large.')
    end do
    
  end subroutine wrpadisc

!  subroutine wrpadi(iou,val,npts)
!    integer iou, val(:), npts, ipts
!    do ipts = 1, npts
!       call wrpadisc(iou,val(i))
!    end do
!  end subroutine wrpadi    

  subroutine wrpadssc(strval,val)    
    integer iou
    character*(*) val, strval

    ! This is a string. Just write it.
    strval = TRIM(ADJUSTL(val))
  end subroutine wrpadssc

!  subroutine wrpads(iou,val,npts)
!    integer iou, npts, ipts
!    character val(:)

!    do ipts = 1, npts
!       call wrpadssc(iou,val(ipts))
!    end do
!  end subroutine wrpads
    
  ! --padlib--
  subroutine rdpaddsc(str,npack,val)
    ! read dp scalar from packed-ascii-data file
    ! arguments:
    !   iou    unit to read from (assumed open)                   (in)
    !   npack  number of characters to use (determines precision) (in)
    !   val  double variable                                         (out)
    ! notes:
    !   packed-ascii-data string converted to real array using  unpad

    integer iou, npack, ndline, i, istrln, ipts, np
    double precision    val, tmp
    character  ctest, ccomp
    character*(*)  str
    external  istrln
    ccomp = cpadr
    ipts = 0
    call sclean(str)
    i = istrln(str)
    if (i.lt.0) go to 50
    call triml(str)
    np = i
    ndline = i/np
    if (ndline.le.0) go to 200
    tmp   = unpadx(str(1:np),np)
    val = tmp
50  continue 
    return
200 continue
    call error(' -- Read_PAD error:  bad data at line:',StopProgram = .FALSE.)
    i = istrln(str)
    call error(str(:i), StopProgram = .FALSE.)
    call error(' -- fatal error in reading PAD data file -- ')
  end subroutine rdpaddsc

!   subroutine rdpadd(iou,npack,array,npts)
!     ! read dparray from packed-ascii-data file
!     ! arguments:
!     !   iou    unit to read from (assumed open)                   (in)
!     !   npack  number of characters to use (determines precision) (in)
!     !   array  real array                                         (out)
!     !   npts   number of array elements to read / number read     (in/out)
!     ! notes:
!     !   packed-ascii-data string converted to real array using  unpad

!     integer iou, npack, npts, ndline, i, istrln, ipts
!     double precision    array(*), tmp
!     character  ctest, ccomp
!     character  str*128
!     external  istrln
!     ccomp = cpadr
!     ipts = 0
!     do
!        i = iread(iou, str)
!        if (i.lt.0) go to 50
!        call triml(str)
!        ctest  = str(1:1)
!        str    = str(2:)
!        ndline = i/npack
!        if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
!        do i = 1, ndline
!           ipts  = ipts + 1
!           tmp   = unpadx(str(1-npack+i*npack:i*npack),npack)
!           array(ipts) = tmp
!           if (ipts.ge.npts) go to 50
!        end do
!     end do
! 50  continue 
!     return
! 200 continue
!     call error(' -- Read_PAD error:  bad data at line:',StopProgram = .FALSE.)
!     i = istrln(str)
!     call error(str(:i), StopProgram = .FALSE.)
!     call error(' -- fatal error in reading PAD data file -- ')
!   end subroutine rdpadd

  ! --padlib--
  subroutine rdpadrsc(str,npack,val)
    ! read real array from packed-ascii-data file
    ! arguments:
    !   iou    unit to read from (assumed open)                   (in)
    !   npack  number of characters to use (determines precision) (in)
    !   array  real array                                         (out)
    !   npts   number of array elements to read / number read     (in/out)
    ! notes:
    !   packed-ascii-data string converted to real array using  unpad

    integer iou, npack, ndline, i, istrln, ipts, np
    real    val
    double precision tmp
    character  ctest, ccomp
    character*(*)  str
    external  istrln
    ccomp = cpadr
    ipts = 0
    call sclean(str)
    i = istrln(str)
    if (i.lt.0) go to 50
    call triml(str)
    np = i
    ndline = i/np
    if (ndline.le.0) go to 200
    
    tmp   = unpadx(str(1:np),np)
    val = real(tmp)

50  continue 
    return
200 continue
    call error(' -- Read_PAD error:  bad data at line:',StopProgram = .FALSE.)
    i = istrln(str)
    call error(str(:i),StopProgram = .FALSE.)
    call error(' -- fatal error in reading PAD data file -- ')
  end subroutine rdpadrsc

!   ! --padlib--
!   subroutine rdpadr(iou,npack,array,npts)
!     ! read real array from packed-ascii-data file
!     ! arguments:
!     !   iou    unit to read from (assumed open)                   (in)
!     !   npack  number of characters to use (determines precision) (in)
!     !   array  real array                                         (out)
!     !   npts   number of array elements to read / number read     (in/out)
!     ! notes:
!     !   packed-ascii-data string converted to real array using  unpad

!     integer iou, npack, npts, ndline, i, istrln, ipts
!     real    array(*)
!     double precision tmp
!     character  ctest, ccomp
!     character  str*128
!     external  istrln
!     ccomp = cpadr
!     ipts = 0
! 10  continue 
!     i = iread(iou, str)
!     if (i.lt.0) go to 50
!     call triml(str)
!     ctest  = str(1:1)
!     str    = str(2:)
!     ndline = i/npack
!     if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
!     do i = 1, ndline
!        ipts  = ipts + 1
!        tmp   = unpadx(str(1-npack+i*npack:i*npack),npack)
!        array(ipts) = real(tmp)
!        if (ipts.ge.npts) go to 50
!     end do
!     go to 10
! 50  continue 
!     return
! 200 continue
!     call error(' -- Read_PAD error:  bad data at line:',StopProgram = .FALSE.)
!     i = istrln(str)
!     call error(str(:i),StopProgram = .FALSE.)
!     call error(' -- fatal error in reading PAD data file -- ')
!   end subroutine rdpadr
  ! --padlib--
  subroutine rdpadcsc(str,npack,val)
    ! read complex array from packed-ascii-data file
    ! arguments:
    !   iou    unit to read from (assumed open)                  (in)
    !   npack  number of characters to use (determines precision)(in)
    !   array  complex array                                     (out)
    !   npts   number of array elements to read / number read    (in/out)
    ! notes:
    !   packed-ascii-data string converted to real array using  unpad

    integer iou, npack,npts, ndline, i, istrln, ipts, np
    double precision  tmpr, tmpi
    complex  val
    character  ctest, ccomp
    character*(*)  str
    external  istrln
    ccomp = cpadc
    ipts = 0
    np   = 2 * npack

    call sclean(str)
    i = istrln(str)
    if (i.lt.0) go to 50
    call triml(str)

    ndline = i / np
    if (ndline.le.0) go to 200
    
    tmpr = unpadx(str(1:npack),npack)
    tmpi = unpadx(str(npack+1:2*npack),npack)
    val = cmplx(tmpr, tmpi)
    
50  continue 
    return
200 continue
    call error(' -- Read_PAD error:  bad data at line:',StopProgram = .FALSE.)
    i = istrln(str)
    call error(str(:i),StopProgram = .FALSE.)
    call error(' -- fatal error in reading PAD data file -- ')
  end subroutine rdpadcsc

!   subroutine rdpadc(iou,npack,array,npts)
!     ! read complex array from packed-ascii-data file
!     ! arguments:
!     !   iou    unit to read from (assumed open)                  (in)
!     !   npack  number of characters to use (determines precision)(in)
!     !   array  complex array                                     (out)
!     !   npts   number of array elements to read / number read    (in/out)
!     ! notes:
!     !   packed-ascii-data string converted to real array using  unpad

!     integer iou, npack,npts, ndline, i, istrln, ipts, np
!     double precision  tmpr, tmpi
!     complex  array(*)
!     character  ctest, ccomp
!     character  str*128
!     external  istrln
!     ccomp = cpadc
!     ipts = 0
!     np   = 2 * npack
! 10  continue 
!     i = iread(iou, str)
!     if (i.lt.0) go to 50
!     call triml(str)
!     ctest  = str(1:1)
!     str    = str(2:)
!     ndline = i / np
!     if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
!     do i = 1, ndline
!        ipts = ipts + 1
!        tmpr = unpadx(str(1-np+i*np:-npack+i*np),npack)
!        tmpi = unpadx(str(1-npack+i*np:i*np),npack)
!        array(ipts) = cmplx(tmpr, tmpi)
!        if (ipts.ge.npts) go to 50
!     end do
!     go to 10
! 50  continue 
!     return
! 200 continue
!     call error(' -- Read_PAD error:  bad data at line:',StopProgram = .FALSE.)
!     i = istrln(str)
!     call error(str(:i),StopProgram = .FALSE.)
!     call error(' -- fatal error in reading PAD data file -- ')
!   end subroutine rdpadc
  subroutine rdpadxsc(str,npack,val)
    ! read complex*16 array from packed-ascii-data file
    ! arguments:
    !   iou    unit to read from (assumed open)                  (in)
    !   npack  number of characters to use (determines precision)(in)
    !   array  complex array                                     (out)
    !   npts   number of array elements to read / number read    (in/out)
    ! notes:
    !   packed-ascii-data string converted to real array using  unpad

    integer iou, npack,npts, ndline, i, istrln, ipts, np
    double precision  tmpr, tmpi
    complex*16  val
    character  ctest, ccomp
    character*(*)  str
    external  istrln
    ccomp = cpadc
    ipts = 0
    np   = 2 * npack

    call sclean(str)
    i = istrln(str)
    if (i.lt.0) go to 50
    call triml(str)

    ndline = i / np
    if (ndline.le.0) go to 200

    tmpr = unpadx(str(1:npack),npack)
    tmpi = unpadx(str(npack+1:2*npack),npack)
    val = cmplx(tmpr, tmpi)

50  continue 
    return
200 continue
    call error(' -- Read_PAD error:  bad data at line:',StopProgram = .FALSE.)
    i = istrln(str)
    call error(str(:i),StopProgram = .FALSE.)
    call error(' -- fatal error in reading PAD data file -- ')
  end subroutine rdpadxsc
!   subroutine rdpadx(iou,npack,array,npts)
!     ! read complex*16 array from packed-ascii-data file
!     ! arguments:
!     !   iou    unit to read from (assumed open)                  (in)
!     !   npack  number of characters to use (determines precision)(in)
!     !   array  complex array                                     (out)
!     !   npts   number of array elements to read / number read    (in/out)
!     ! notes:
!     !   packed-ascii-data string converted to real array using  unpad

!     integer iou, npack,npts, ndline, i, istrln, ipts, np
!     double precision  tmpr, tmpi
!     complex*16  array(*)
!     character  ctest, ccomp
!     character  str*128
!     external  istrln
!     ccomp = cpadc
!     ipts = 0
!     np   = 2 * npack
! 10  continue 
!     i = iread(iou, str)
!     if (i.lt.0) go to 50
!     call triml(str)
!     ctest  = str(1:1)
!     str    = str(2:)
!     ndline = i / np
!     if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
!     do i = 1, ndline
!        ipts = ipts + 1
!        tmpr = unpadx(str(1-np+i*np:-npack+i*np),npack)
!        tmpi = unpadx(str(1-npack+i*np:i*np),npack)
!        array(ipts) = cmplx(tmpr, tmpi)
!        if (ipts.ge.npts) go to 50
!     end do
!     go to 10
! 50  continue 
!     return
! 200 continue
!     call error(' -- Read_PAD error:  bad data at line:',StopProgram = .FALSE.)
!     i = istrln(str)
!     call error(str(:i),StopProgram = .FALSE.)
!     call error(' -- fatal error in reading PAD data file -- ')
!   end subroutine rdpadx

  subroutine rdpadisc(strval,val)
    integer iou, iabs, val, imin, n, irem, iend, ic, sign
    character*(*) strval
    character str*128
    character c

    iabs = 0
    str = TRIM(ADJUSTL(strval))
    iend = LEN_TRIM(str)
    IF(str(1:1).eq.'+') THEN
       sign = 1
    ELSE
       sign = -1
    END IF
    do n = iend, 2, -1
       c = str(n:n)
       ic = IACHAR(c) - 48
       iabs = iabs + ic*75**(iend - n)
    end do
    val = sign*iabs
  end subroutine rdpadisc

  subroutine rdpadssc(strval,val)
    character*(*) strval, val
    val = TRIM(ADJUSTL(strval))
  end subroutine rdpadssc
!   subroutine rdpadi(iou,val,npts)
!     integer iou, val(:), npts, ipts
!     do ipts = 1, npts
!        call rdpadisc(iou,val(ipts))
!     end do
!   end subroutine rdpadi
    
  ! --padlib--
  ! --padlib--
  subroutine padx(xreal,npack,str)
    !  convert dp number *xreal* to packed-ascii-data string *str*

    integer  iexp, itmp, isgn, i, npack, j
    double precision xreal, xwork, xsave,onem, tenth
    parameter (onem  =  0.99999999997d0)
    parameter (tenth =  0.099999999994d0)
    character str*(*)
    !
    str      = ' '
    xsave    = min(huge, max(-huge, xreal))
    isgn     = 1
    if (xsave.le.0) isgn = 0
    !
    xwork    = dabs( xsave )
    iexp     = 0
    if ((xwork.lt.huge).and.(xwork.gt.tiny))  then
       iexp  =   1 + int(log(xwork) / tenlog  )
    else if (xwork.ge.huge) then
       iexp  = ihuge
       xwork = one
    else if (xwork.le.tiny)  then
       xwork = zero
    end if
    ! force xwork between ~0.1 and ~1
    ! note: this causes a loss of precision, but 
    ! allows backward compatibility
    xwork    = xwork / (ten ** iexp)
20  continue
    if (xwork.ge.one) then
       xwork = xwork * 0.100000000000000d0
       iexp  = iexp + 1
    else if (xwork.le.tenth) then
       xwork = xwork * ten
       iexp  = iexp - 1
    endif
    if (xwork.ge.one) go to 20

    itmp     = int ( ibas2 * xwork ) 
    str(1:1) = char(iexp  + ioff + ibas2 )
    str(2:2) = char( 2 * itmp + isgn + ioff)
    xwork    = xwork * ibas2 - itmp
    if (npack.gt.2) then
       do i = 3, npack
          itmp     = int( base * xwork + 1.d-9)
          str(i:i) = char(itmp + ioff)
          xwork    = xwork * base - itmp
       end do
    end if
    if (xwork.ge.0.5d0) then
       i = itmp + ioff + 1
       if (i.le.126) then
          str(npack:npack)= char(i)
       else 
          j = ichar(str(npack-1:npack-1))
          if (j.lt.126) then
             str(npack-1:npack-1) = char(j+1)
             str(npack:npack)     = char(37)
          endif
       endif
    endif
    return
  end subroutine padx

    
  ! --padlib--
  double precision function unpadx(str,npack)
    !
    !  convert packed-ascii-data string *str* to dp number *unpad*

    double precision sum
    integer   iexp, itmp, isgn, i, npack
    character str*(*)
    unpadx = zero
    if (npack.le.2) return
    iexp  =     (ichar(str(1:1)) - ioff   ) - ibas2
    isgn  = mod (ichar(str(2:2)) - ioff, 2) * 2 - 1
    itmp  =     (ichar(str(2:2)) - ioff   ) / 2
    sum   = dble(itmp/(base*base))
    !       do 100 i = 3, npack
    !          sum = sum + dble(ichar(str(i:i)) - ioff) / base**i
    ! 100   continue
    do i = npack, 3, -1
       sum = sum + dble(ichar(str(i:i)) - ioff) / base**i
    end do
    unpadx = 2 * isgn * ibase * sum * (ten ** iexp)
    !c       print*, sum, iexp,unpad
    return
  end function unpadx
  ! --padlib--
  ! end of pad library
  ! ----------
!   integer function iread(lun,string)
!     !
!     ! generalized internal read:
!     !    read a string the next line of an opened file 
!     !    unit, returning the real length of string
!     ! 
!     ! inputs:   
!     !   lun     opened file unit number
!     ! outputs:
!     !   string  string read from file
!     ! returns:
!     !   iread   useful length of string, as found from 
!     !                  sending string to 'sclean' to 
!     !                  remove non-printable characters
!     !                   and then istrln  
!     !           or
!     !              -1   on 'end-of-file'
!     !              -2   on 'error'
!     !
!     ! copyright (c) 1999  Matthew Newville
!     implicit none
!     character*(*) string
!     integer    lun, istrln
!     external   istrln
!     string = ' '
! 10  format(a)
!     read(lun, 10, end = 40, err = 50) string
!     call sclean(string)
!     iread = istrln(string)
!     return
! 40  continue 
!     string = ' '
!     iread = -1
!     return
! 50  continue 
!     string = ' '
!     iread = -2
!     return
!   end function iread
  subroutine sclean(str) 
    !
    !  clean a string, especially for strings passed between 
    !  different file systems, or from C functions:
    !
    !   1. characters in the range char(0), or char(10)...char(15) 
    !      are interpreted as end-of-line characters, so that all
    !      remaining characters are explicitly blanked.
    !   2. all other characters below char(31) (including tab) are
    !      replaced by a single blank
    !
    !  this is mostly useful when getting a string generated by a C 
    !  function and for handling dos/unix/max line-endings.
    !
    ! copyright (c) 1999  Matthew Newville
    character*(*) str, blank*1
    parameter (blank = ' ')
    integer i,j,is
    do i = 1, len(str)
       is = ichar(str(i:i))
       if ((is.eq.0) .or. ((is.ge.10) .and. (is.le.15))) then
          do j= i, len(str)
             str(j:j) = blank
          end do
          return
       elseif (is.le.31)  then
          str(i:i)  = blank
       end if
    end do
    return
    ! end subroutine sclean
  end subroutine sclean
END MODULE PADIO

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_iomod.f90,v $:
! $Revision: 1.11 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MODULE IOMod
  USE ErrorMod
  USE IOFiles
  USE PADIO

  IMPLICIT NONE

  INTEGER,PRIVATE :: npadxDefault, npadrDefault, MaxStrLen, iFileTypeDefault
  PARAMETER(npadxDefault = 8, npadrDefault = 8, MaxStrLen = 80, iFileTypeDefault = 1)
  LOGICAL,PRIVATE,SAVE :: WriteDataDescription(100)
  CHARACTER(30),PRIVATE :: DefaultFileStatus, DefaultFilePosition, &
       & DefaultFileAction, DefaultCommentCharacters
  PARAMETER(DefaultFileStatus = 'UNKNOWN', DefaultFilePosition = 'REWIND')
  PARAMETER(DefaultFileAction = 'READWRITE', DefaultCommentCharacters = '#!cC')

  INTERFACE Write2D
     MODULE PROCEDURE WriteInt2D
     MODULE PROCEDURE WriteReal2D
     MODULE PROCEDURE WriteDouble2D
     MODULE PROCEDURE WriteComplex2D
     MODULE PROCEDURE WriteDComplex2D
     MODULE PROCEDURE WriteString2D
  END INTERFACE

  INTERFACE Read2D
     MODULE PROCEDURE ReadInt2D
     MODULE PROCEDURE ReadReal2D
     MODULE PROCEDURE ReadDouble2D
     MODULE PROCEDURE ReadComplex2D
     MODULE PROCEDURE ReadDComplex2D
     MODULE PROCEDURE ReadString2D
  END INTERFACE

CONTAINS

  ! OpenFl finds the first available unit and opens the file if it is not already open.
  ! In addition, a new IOFile is created and added to the FileStack. The FileStack holds 
  ! valuable information about the files that are open. See IOFiles.f90 for more info.
  ! If the file is already open, OpenFl does nothing.
  !
  ! FileName.
  ! FileName     - Name of file to open.
  ! FileStatus   - Optional: Can be any legal fortran 90 file status.
  !                Argument is passed directly to OPEN(iUnit, STATUS = FileStatus ...
  ! FilePosition - Optional: Can be any legal file position.
  !                Agument is passed directly to OPEN(iUnit, POSITION = FilePosition ...
  ! FileAction   - This can be 'READ', 'WRITE', or 'WREADWRITE'. Case insensitive.
  SUBROUTINE OpenFl(FileName, FileStatus, FilePosition, FileAction, ErrorMessage)
    CHARACTER*(*) FileName
    CHARACTER*(*),OPTIONAL :: FileStatus, FilePosition, FileAction, ErrorMessage(:)

    LOGICAL FileIsOpen
    INTEGER,SAVE :: iOpenUnit
    INTEGER IOError, iUnit
    LOGICAL :: UnitIsUsed, FileExists
    CHARACTER(300) messg, FStatus, FPosition, FAction

    FStatus   = DefaultFileStatus
    FPosition = DefaultFilePosition
    FAction   = DefaultFileAction

    IF(PRESENT(FileStatus)) FStatus = FileStatus
    IF(PRESENT(FilePosition)) FPosition = FilePosition
    IF(PRESENT(FileAction)) FAction = FileAction

    ! Is file already open?
    INQUIRE(FILE=FileName,OPENED=FileIsOpen,EXIST=FileExists)
    IF(FileIsOpen) THEN
       ! This file is already open. Do nothing.
       RETURN
    ELSE
       ! File was not open. Find first available unit.
       DO iOpenUnit = 5, 100
          INQUIRE(UNIT=iOpenUnit,OPENED=UnitIsUsed)
          IF(.not.UnitIsUsed) THEN
             iUnit = iOpenUnit
             EXIT
          END IF
       END DO

       ! Open file.
       OPEN(UNIT=iUnit,FILE=FileName,STATUS=FStatus,POSITION=FPosition,ACTION=FAction,IOSTAT=IOError)
       IF(IOError.ne.0) THEN
          ! OPEN passed back an error
          CALL Error('Error opening file: ' // FileName, StopProgram = .FALSE.)
          IF(PRESENT(ErrorMessage)) CALL Error(ErrorMessage, StopProgram = .FALSE.)
          WRITE(messg,'(A,i4)') 'OPEN returned error number ', IOError
          CALL Error(messg)
       END IF

       ! Create new IOFile
       CALL AddIOFile(FileName)

       ! Set file options 
       CALL SetIOFileInfo(FileName,ExistedOnOpen = FileExists, UnitNumber = iUnit,IsOpen = .TRUE., &
            & FileAction = FAction)
    END IF
  END SUBROUTINE OpenFl

  ! Subroutine CloseFl closes the file associated with FileName, and deletes the IOFile
  ! from the filestack. If FileName = 'ALL' (case insensitive), all open files are closed
  ! and deleted from the filestack.
  SUBROUTINE CloseFl(FileName)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER(10) FileAction, TmpStr
    INTEGER iUnit, iUnits(100), NFiles, i1

    TmpStr = TRIM(ADJUSTL(FileName))
    CALL Upper(TmpStr)

    IF(TmpStr.ne.'ALL') THEN
       CALL GetIOFileInfo(FileName,UnitNumber = iUnit)
       CLOSE(iUnit)
       CALL DeleteIOFile(FileName)
    ELSE
       CALL GetFileStackInfo(NFiles, UnitNumbers = iUnits)
       DO i1 = 1, NFiles
          CLOSE(iUnits(i1))
       END DO
       CALL DeleteIOFile(FileName)
    END IF
  END SUBROUTINE CloseFl


  ! Subroutine WriteData writes scalar data to the file filename.
  ! Up to 10 pieces of data can be written each specified by using
  ! the optional arguments Int1 - Int10, Real1 - Real10, etc.  
  ! Thus you can write all integer data, all real data, etc. or a mixture 
  ! of various types. The column that each data piece goes in is set by
  ! specifying the number of each type, for example, a call to write a
  ! real number followed by an integer is as follows:
  !
  ! CALL WriteData(FileName, Real1 = RealVar, Int2 = IntVar) 
  !
  ! To write a complex variable followed by a string variable then a real 
  ! variable,
  !
  ! CALL WriteData(FileName, Complex1 = ComplexVar, String2 = StringVar, Real3 = RealVar)
  !
  ! Assigning two variables to the same column will produce an error, i.e.
  !
  ! CALL WriteData(FileName, Complex1 = ComplexVar, Int1 = IntVar)
  !
  ! will produce an error since we are trying to write two variables to the first column.
  !
  ! WriteData will also write a section liine (beginning with #SN#) and a data type line
  ! (beginning with #DT#). New sections are started when the types or number of the data 
  ! arguments are changed, or the optional ForceNewSection argument is set to true.
  ! In addition, the user can specify an array of headers to be written above the data,
  ! as well as an array of column labels to describe the data. 
  !
  ! Arguments
  ! FileName - Name of file to write to. Note that if the file is already open for reading,
  !            you will get an error. Note that this is the only non-optional argument.
  !
  ! The following arguments give the data to be written to the file. Note that all of 
  ! these arguments are optional.
  ! Int1, Real1, ... String1    - Argument to go in the first column.
  ! Int2, Real2, ... String2    - Argument to go in the second column.
  ! .
  ! .
  ! .
  ! Int10, Real10, ... String10 - Argument to go in the tenth column.
  !
  ! Headers - Optional: Array of headers to be written out above the data. Note that
  !           this argument can be given without any data, and the headers will be written
  !           alone. Also, headers will only be written at the beginning of a section, so
  !           that the user can set headers and use WriteData in a loop, and the headers
  !           will only be written in the first call inside the loop.
  !
  ! ColumnLabels - Optional: Array of strings to describe the data being passed to 
  !                WriteData. These will be written directly above the data in a formatted
  !                manner. Note that column labels will not extend past the length of the 
  !                data in a particular column. Thus the length of each column label is 
  !                restricted by the formats which are used to write that data. The default 
  !                formats can be found in IOFiles.f90, and may be set for a particular 
  !                file by using the SetIOFileInfo subroutine.
  !
  ! WriteDataInHeader - When set to .TRUE. data will be written with #HD# inserted at the 
  !                     beginning of the line. This is usefull for files which contain
  !                     various information, including scalar information (which would be
  !                     written in the header) as well a set of arrays written in columns
  !                     which the user would like to be able to plot.
  !
  ! ForceNewSection - In the case where two sets of data have the same types. The user may
  !                   force a new section so that the section line, data type line,any 
  !                   headers, and the column labels will be written.
  SUBROUTINE WriteData(FileName,                                      &
       & Int1, Int2, Int3, Int4, Int5, Int6, Int7, Int8, Int9, Int10, &
       & Real1, Real2, Real3, Real4, Real5, Real6, Real7, Real8,      &
       & Real9, Real10,                                               &
       & Double1, Double2, Double3, Double4, Double5, Double6,        &
       & Double7, Double8, Double9, Double10,                         &
       & Complex1, Complex2, Complex3, Complex4, Complex5, Complex6,  &
       & Complex7, Complex8, Complex9, Complex10,                     &
       & DComplex1, DComplex2, DComplex3, DComplex4, DComplex5,       &
       & DComplex6, DComplex7, DComplex8, DComplex9, DComplex10,      &
       & String1, String2, String3, String4, String5, String6,        &
       & String7, String8, String9, String10,                         &
       & Headers, ColumnLabels, WriteDataInHeader, ForceNewSection,   &
       & FileType)
    ! Passed variables
    CHARACTER*(*), INTENT(IN) :: FileName
    INTEGER, INTENT(IN), OPTIONAL :: Int1, Int2, Int3, Int4, Int5,    &
         & Int6, Int7, Int8, Int9, Int10
    REAL, INTENT(IN), OPTIONAL :: Real1, Real2, Real3, Real4, Real5,  &
         & Real6, Real7, Real8, Real9, Real10
    DOUBLE PRECISION, INTENT(IN), OPTIONAL :: Double1, Double2,       &
         & Double3, Double4, Double5, Double6, Double7, Double8,      &
         & Double9, Double10
    COMPLEX, INTENT(IN), OPTIONAL :: Complex1, Complex2, Complex3,    &
         & Complex4, Complex5,                                        &
         & Complex6, Complex7, Complex8, Complex9, Complex10
    COMPLEX*16, INTENT(IN), OPTIONAL :: DComplex1, DComplex2,         &
         & DComplex3, DComplex4, DComplex5, DComplex6, DComplex7,     &
         & DComplex8, DComplex9, DComplex10
    CHARACTER*(*), INTENT(IN), OPTIONAL :: String1, String2, String3, &
         & String4, String5, String6, String7, String8, String9,      &
         & String10

    CHARACTER*(*),INTENT(IN),OPTIONAL :: Headers(:), ColumnLabels(:), &
         & FileType
    LOGICAL,INTENT(IN),OPTIONAL :: WriteDataInHeader, ForceNewSection

    ! Local variables
    ! NumArgs - Number of data arguments passed
    ! iUnit   - unit number associated with FileName
    ! NColumnLabels - will hold the size of the ColumnLabels array.
    INTEGER NumArgs, iUnit, NColumnLabels

    ! IsPresent  - If IsPresent(i) is true then the ith argument has already been defined.
    ! HeaderData - If true, write data in header format (beginning with #HD#).
    ! txt, pad  - These are here in anticipation of enabling various formats for output,
    !              including text, paded ascii to start, and possibly further formats 
    !              such as xml.
    ! NewSection - If true, force a new section.
    ! FlType     - 
    LOGICAL IsPresent(10), HeaderData, txt, pad, NewSection
    ! DataArray - Array of strings to hold the data. Data is first written to DataArray,
    !             then DataArray(1:NumArgs) is written to the file.
    CHARACTER(MaxStrLen) DataArray(10)
    ! DataTypeLine - The data type line lists the types of data that have been specified
    !                by the user to be written to file. This line will be written above
    !                the data, and above any column label line if present. The line 
    !                begins with #DT#
    CHARACTER(120) DataTypeLine
    ! IntFormat, RealFormat, ... StringFormat - These hold the format strings which will
    !                                           be used to write the data to the 
    !                                           character array DataArray and eventually
    !                                           to the file.
    !
    ! FileAction - String variable that holds the action associated with the IOFile
    !              specified by FileName.
    CHARACTER(20) IntFormat, RealFormat, DoubleFormat, ComplexFormat, &
         & DComplexFormat, StringFormat, FileAction
    ! ColumnLabelFormat - This will be used to hold the format string to write the
    !                     column labels if any.
    CHARACTER(80) ColumnLabelFormat
    ! CLFormats - This holds the separate formats for each column label. They will be
    !             combined to create ColumnLabelFormat
    CHARACTER(10) CLFormats(20)
    ! TmpStr - used when creating column label formats.
    CHARACTER(4) TmpStr, FlType

    ! NSection - number of the current section.
    INTEGER NSections

    ! Loop variables
    INTEGER i1

    ! Initialization
    HeaderData    = .FALSE.
    IsPresent(:)  = .FALSE.
    NumArgs       = 0
    txt           = .TRUE.
    pad           = .FALSE.
    DataTypeLine  = ''
    FlType = 'TXT'

    ! Set the type of file. Default is txt.
    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          txt = .TRUE.
          pad = .FALSE.
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          pad = .TRUE.
          txt = .FALSE.
       ELSE
          CALL Error('Error: Illegal file type passed to WriteData')
       END IF
    END IF

!KJ next section was commented out "!NS" but I activated it again 7-09
    IF(PRESENT(ForceNewSection)) THEN
       NewSection = ForceNewSection
    ELSE
       NewSection = .FALSE.
    END IF
!KJ

    IF(PRESENT(WriteDataInHeader)) HeaderData = WriteDataInHeader

    IF(PRESENT(ColumnLabels)) THEN
       NColumnLabels = 0
    ELSE
       NColumnLabels = -1
    END IF

    ! Open the file.
    CALL OpenFl(FileName, FileStatus = 'REPLACE', FileAction = 'WRITE')

    ! Get the formats for each data type.
    CALL GetIOFileInfo(FileName, IFormat = IntFormat, RFormat = RealFormat, &
         & DFormat = DoubleFormat, CFormat = ComplexFormat, &
         & DCFormat = DComplexFormat, SFormat = StringFormat, FileAction = FileAction)

    ! Check that this file was not already opened for READ.
    IF(TRIM(FileAction).eq.'READ') THEN 
       CALL Error('Error: file ' // FileName // &
            & ' was already opened for reading.', StopProgram = .FALSE.)
       CALL Error("Please use CALL CloseFl('" // FileName // "') before writing.")
    END IF
    
    ! The SetArgType(Arg,ColumnNumber) subroutines checks the presence of Arg. If Arg
    ! is present, the data is written to DataArray(ColumnNumber). Also, NumArgs is incremented,
    ! CLFormats(ColumnNumber) is set, and the data type is appended to DataTypeLine.
    ! In addition, various errors are checked.
    ! Find the 1st argument.
    IF(PRESENT(Int1)) CALL SetArgInt(Int1, 1)
    IF(PRESENT(Real1)) CALL SetArgReal(Real1, 1)
    IF(PRESENT(Double1)) CALL SetArgDouble(Double1, 1)
    IF(PRESENT(Complex1)) CALL SetArgComplex(Complex1, 1)
    IF(PRESENT(DComplex1)) CALL SetArgDComplex(DComplex1, 1)
    IF(PRESENT(String1)) CALL SetArgString(String1, 1)

    ! Find the 2nd argument.
    IF(PRESENT(Int2)) CALL SetArgInt(Int2, 2)
    IF(PRESENT(Real2)) CALL SetArgReal(Real2, 2)
    IF(PRESENT(Double2)) CALL SetArgDouble(Double2, 2)
    IF(PRESENT(Complex2)) CALL SetArgComplex(Complex2, 2)
    IF(PRESENT(DComplex2)) CALL SetArgDComplex(DComplex2, 2)
    IF(PRESENT(String2)) CALL SetArgString(String2, 2)

    ! Find the 3rd argument.
    IF(PRESENT(Int3)) CALL SetArgInt(Int3, 3)
    IF(PRESENT(Real3)) CALL SetArgReal(Real3, 3)
    IF(PRESENT(Double3)) CALL SetArgDouble(Double3, 3)
    IF(PRESENT(Complex3)) CALL SetArgComplex(Complex3, 3)
    IF(PRESENT(DComplex3)) CALL SetArgDComplex(DComplex3, 3)
    IF(PRESENT(String3)) CALL SetArgString(String3, 3)

    ! Find the 4th argument.
    IF(PRESENT(Int4)) CALL SetArgInt(Int4, 4)
    IF(PRESENT(Real4)) CALL SetArgReal(Real4, 4)
    IF(PRESENT(Double4)) CALL SetArgDouble(Double4, 4)
    IF(PRESENT(Complex4)) CALL SetArgComplex(Complex4, 4)
    IF(PRESENT(DComplex4)) CALL SetArgDComplex(DComplex4, 4)
    IF(PRESENT(String4)) CALL SetArgString(String4, 4)

    ! Find the 5th argument.
    IF(PRESENT(Int5)) CALL SetArgInt(Int5, 5)
    IF(PRESENT(Real5)) CALL SetArgReal(Real5, 5)
    IF(PRESENT(Double5)) CALL SetArgDouble(Double5, 5)
    IF(PRESENT(Complex5)) CALL SetArgComplex(Complex5, 5)
    IF(PRESENT(DComplex5)) CALL SetArgDComplex(DComplex5, 5)
    IF(PRESENT(String5)) CALL SetArgString(String5, 5)

    ! Find the 6th argument.
    IF(PRESENT(Int6)) CALL SetArgInt(Int6, 6)
    IF(PRESENT(Real6)) CALL SetArgReal(Real6, 6)
    IF(PRESENT(Double6)) CALL SetArgDouble(Double6, 6)
    IF(PRESENT(Complex6)) CALL SetArgComplex(Complex6, 6)
    IF(PRESENT(DComplex6)) CALL SetArgDComplex(DComplex6, 6)
    IF(PRESENT(String6)) CALL SetArgString(String6, 6)

    ! Find the 7th argument.
    IF(PRESENT(Int7)) CALL SetArgInt(Int7, 7)
    IF(PRESENT(Real7)) CALL SetArgReal(Real7, 7)
    IF(PRESENT(Double7)) CALL SetArgDouble(Double7, 7)
    IF(PRESENT(Complex7)) CALL SetArgComplex(Complex7, 7)
    IF(PRESENT(DComplex7)) CALL SetArgDComplex(DComplex7, 7)
    IF(PRESENT(String7)) CALL SetArgString(String7, 7)

    ! Find the 8th argument.
    IF(PRESENT(Int8)) CALL SetArgInt(Int8, 8)
    IF(PRESENT(Real8)) CALL SetArgReal(Real8, 8)
    IF(PRESENT(Double8)) CALL SetArgDouble(Double8, 8)
    IF(PRESENT(Complex8)) CALL SetArgComplex(Complex8, 8)
    IF(PRESENT(DComplex8)) CALL SetArgDComplex(DComplex8, 8)
    IF(PRESENT(String8)) CALL SetArgString(String8, 8)

    ! Find the 9th argument.
    IF(PRESENT(Int9)) CALL SetArgInt(Int9, 9)
    IF(PRESENT(Real9)) CALL SetArgReal(Real9, 9)
    IF(PRESENT(Double9)) CALL SetArgDouble(Double9, 9)
    IF(PRESENT(Complex9)) CALL SetArgComplex(Complex9, 9)
    IF(PRESENT(DComplex9)) CALL SetArgDComplex(DComplex9, 9)
    IF(PRESENT(String9)) CALL SetArgString(String9, 9)

    ! Find the 10th argument.
    IF(PRESENT(Int10)) CALL SetArgInt(Int10, 10)
    IF(PRESENT(Real10)) CALL SetArgReal(Real10, 10)
    IF(PRESENT(Double10)) CALL SetArgDouble(Double10, 10)
    IF(PRESENT(Complex10)) CALL SetArgComplex(Complex10, 10)
    IF(PRESENT(DComplex10)) CALL SetArgDComplex(DComplex10, 10)
    IF(PRESENT(String10)) CALL SetArgString(String10, 10)

    ! Get the unit number and section number.
    CALL GetIOFileInfo(FileName,UnitNumber = iUnit, NSections = NSections)

    ! If data type line is different that last, or user has forced a new section
    ! write a new section header and data type line. Also write any headers and
    ! column labels that have been specified.
    IF(WritingNewSection(FileName,DataTypeLine).or.NewSection) THEN

       NSections = NSections + 1

       WRITE(iUnit,'(A,I4)') '#SN#   Section: ', NSections
       WRITE(iUnit,'(A)') '#DF# This section written in ' // FlType // '.'
       WRITE(iUnit,'(A)') '#H#'

       ! Only write a data type line if it is not blank       
       IF(LEN_TRIM(DataTypeLine).ne.0) THEN
          WRITE(iUnit,'(A)') '#H# The following data types are written in this section.'
          WRITE(iUnit,'(2A)') '#DT# ', TRIM(DataTypeLine)
       END IF

       ! If headers are present, write them.
       IF(PRESENT(Headers)) THEN
          DO i1 = 1, SIZE(Headers)
             ! Write only non-blank, non-null headers.
             IF((LEN_TRIM(Headers(i1)).gt.0).and.(ICHAR(Headers(i1)).ne.0)) &
                  & WRITE(iUnit,'(2A)') '#H# ', TRIM(Headers(i1))
          END DO
       END IF

       ! If column labels are present, get the columnlable format and write them.
       IF(PRESENT(ColumnLabels)) THEN
          ColumnLabelFormat = '(A5, '
          DO i1 = 1, NColumnLabels - 1
             ColumnLabelFormat = TRIM(ColumnLabelFormat) // TRIM(CLFormats(i1)) // ', '
          END DO
          ColumnLabelFormat = TRIM(ColumnLabelFormat) // TRIM(CLFormats(NColumnLabels)) // ')'
          WRITE(iUnit,ColumnLabelFormat) '#CL# ', (TRIM(ColumnLabels(i1)) // ' ', i1 = 1, NColumnLabels)
       END IF

       ! Set the section number and data type line.
       CALL SetIOFileInfo(FileName, DataTypeLine = DataTypeLine, NSections = NSections)

    ELSEIF(PRESENT(Headers).and.(NumArgs.eq.0)) THEN
       ! If only headers are present, write the headers without changing the section number.
       DO i1 = 1, SIZE(Headers)
          ! Write only non-blank, non-null headers.
          IF((LEN_TRIM(Headers(i1)).gt.0).and.(ICHAR(Headers(i1)).ne.0)) &
               & WRITE(iUnit,'(2A)') '#H# ', TRIM(Headers(i1))
       END DO
       CALL SetIOFileInfo(FileName, DataTypeLine = DataTypeLine)
    END IF


    ! Write data line.
    IF(NumArgs.gt.0) THEN
       IF(HeaderData) THEN
          WRITE(iUnit, '(11A)') '#HD# ', (TRIM(DataArray(i1)) // ' ', i1 = 1, NumArgs)
       ELSE
          WRITE(iUnit, '(11A)') (TRIM(DataArray(i1)) // ' ', i1 = 1, NumArgs)
       END IF
    END IF
  CONTAINS

    ! The SetArgType(Arg,ColumnNumber) subroutines check the presence of Arg. If Arg
    ! is present, the data is written to DataArray(ColumnNumber). Also, NumArgs is incremented,
    ! CLFormats(ColumnNumber) is set, and the data type is appended to DataTypeLine.
    ! In addition, various errors are checked.

    SUBROUTINE SetArgInt(Arg, iArg)
      INTEGER,INTENT(IN) :: Arg
      INTEGER,INTENT(IN) :: iArg

      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'Int')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         WRITE(DataArray(iArg), IntFormat) Arg
      ELSEIF(pad) THEN
         CALL WritePAD(DataArray(iArg),Arg)
      END IF

      ! Set the columnlabel format string if ColumnLabels is passed.
      IF(PRESENT(ColumnLabels)) THEN
         IF(SIZE(ColumnLabels).gt.NColumnLabels) THEN
            NColumnLabels = NColumnLabels + 1
            IF((iArg.eq.1).and.txt) THEN
               WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(iArg)) - 4
            ELSE
               WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(iArg)) + 1
            END IF
            CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
         END IF
      END IF

    END SUBROUTINE SetArgInt

    SUBROUTINE SetArgReal( Arg, iArg)
      REAL,INTENT(IN) :: Arg
      INTEGER,INTENT(IN) :: iArg
      REAL TmpArg(2)
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'Real')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         WRITE(DataArray(iArg), RealFormat) Arg
      ELSEIF(pad) THEN
         TmpArg(1) = Arg
         CALL WritePAD(DataArray(iArg),npadrDefault,Arg)
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         IF(SIZE(ColumnLabels).gt.NColumnLabels) THEN
            NColumnLabels = NColumnLabels + 1
            IF((iArg.eq.1).and.txt) THEN
               WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(iArg)) - 4
            ELSE
               WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(iArg)) + 1
            END IF
            CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
         END IF
      END IF
    END SUBROUTINE SetArgReal

    SUBROUTINE SetArgDouble( Arg, iArg)
      DOUBLE PRECISION,INTENT(IN) :: Arg
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'Double')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         WRITE(DataArray(iArg), DoubleFormat) Arg
      ELSEIF(pad) THEN
         CALL WritePAD(DataArray(iArg),npadrDefault,Arg)
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         IF(SIZE(ColumnLabels).gt.NColumnLabels) THEN
            NColumnLabels = NColumnLabels + 1
            IF((iArg.eq.1).and.txt) THEN
               WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(iArg)) - 4
            ELSE
               WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(iArg)) + 1
            END IF
            CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
         END IF
      END IF
    END SUBROUTINE SetArgDouble

    SUBROUTINE SetArgComplex( Arg, iArg)
      COMPLEX,INTENT(IN) :: Arg
      INTEGER,INTENT(IN) :: iArg

      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'Complex')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         WRITE(DataArray(iArg), ComplexFormat) REAL(Arg), IMAG(Arg)
      ELSEIF(pad) THEN
         CALL WritePAD(DataArray(iArg),npadrDefault,Arg)
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         IF(SIZE(ColumnLabels).gt.NColumnLabels+1) THEN
            NColumnLabels = NColumnLabels + 2
            IF((iArg.eq.1).and.txt) THEN
               WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(iArg))/2) - 4
               CLFormats(NColumnLabels - 1) = 'A' // TRIM(ADJUSTL(TmpStr))
               WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(iArg))/2) + 1
               CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
            ELSE
               WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(iArg))/2) + 1
               CLFormats(NColumnLabels - 1) = 'A' // TRIM(ADJUSTL(TmpStr))
               CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
            END IF
         END IF
      END IF
    END SUBROUTINE SetArgComplex

    SUBROUTINE SetArgDComplex( Arg, iArg)
      COMPLEX*16,INTENT(IN) :: Arg
      INTEGER,INTENT(IN) :: iArg

      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'DComplex')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         WRITE(DataArray(iArg), DComplexFormat) DBLE(Arg), DIMAG(Arg)
      ELSEIF(pad) THEN
         CALL WritePAD(DataArray(iArg),npadrDefault,Arg)
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         IF(SIZE(ColumnLabels).gt.NColumnLabels+1) THEN
            NColumnLabels = NColumnLabels + 2
            IF((iArg.eq.1).and.txt) THEN
               WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(iArg))/2) - 4
               CLFormats(NColumnLabels - 1) = 'A' // TRIM(ADJUSTL(TmpStr))
               WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(iArg))/2) + 1
               CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
            ELSE
               WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(iArg))/2) + 1
               CLFormats(NColumnLabels - 1) = 'A' // TRIM(ADJUSTL(TmpStr))
               CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
            END IF
         END IF
      END IF
    END SUBROUTINE SetArgDComplex

    SUBROUTINE SetArgString( Arg, iArg)
      CHARACTER*(*),INTENT(IN) :: Arg
      CHARACTER(MaxStrLen) TmpStr
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'String')

      TmpStr = TRIM(ADJUSTL(Arg))
      IF(LEN_TRIM(Arg).gt.MaxStrLen) CALL Error('Warning: String argument is too long in WriteData. ' // &
           & 'Will be truncated.', StopProgram = .FALSE.)

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         WRITE(DataArray(iArg), StringFormat) TRIM(TmpStr)
      ELSEIF(pad) THEN
         CALL WritePAD(DataArray(iArg),TRIM(TmpStr))
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         IF(SIZE(ColumnLabels).gt.NColumnLabels) THEN
            NColumnLabels = NColumnLabels + 1
            IF((iArg.eq.1).and.txt) THEN
               WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(iArg)) - 4
            ELSE
               WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(iArg)) + 1
            END IF
            CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
         END IF
      END IF
    END SUBROUTINE SetArgString

    ! CheckForErrors checks for the following errors and stops if it finds one:
    ! 
    ! 1. 'Error in WriteData multiple arguments in place' - This error occurs 
    !    when the user has specified that two arguments should be written into
    !    one column, i.e. WriteData(FileName, Int1 = I, Real1 = R, ...)
    !
    ! 2. 'Too many arguments passed to WriteData. Max is 10.' - user has specified
    !    more than 10 aguments. This one is redundant, and error 1. should always 
    !    occur if this happens.
    !
    ! In addition, CheckForErrors appends the type to DataTypeLine
    SUBROUTINE CheckForErrors(iArg,DTL)
      INTEGER,INTENT(IN) :: iArg
      CHARACTER*(*) DTL
      CHARACTER(2) ArgNum
      INTEGER iAllocateError
      ArgNum=''
      WRITE(ArgNum,'(I2)') iArg

      IF(IsPresent(iArg)) THEN
         CALL Error('Error in WriteData multiple arguments in place ' // TRIM(ArgNum) // '.')
      END IF

      ! Set IsPresent(iArg)
      IsPresent(iArg) = .TRUE.

      ! Check that number of arguments is not too large. Redundant, but oh well.
      IF(NumArgs.ge.iArg) CALL Error('Too many arguments passed to WriteData. Max is 10.')
      NumArgs = NumArgs + 1

      ! Set data type line
      DataTypeLine = TRIM(DataTypeLine) // ' ' // TRIM(DTL)
    END SUBROUTINE CheckForErrors

  END SUBROUTINE WriteData


  ! SUBROUTINE ReadData reads scalar data from the file filename.
  ! Up to 10 pieces of data can be read, each specified by using
  ! the optional arguments Int1 - Int10, Real1 - Real10, etc.  
  ! Thus you can read all integer data, all real data, etc. or a mixture 
  ! of various types. The column that each data piece comes from is set by
  ! specifying the number of each type, for example, a call to read a
  ! real number followed by an integer is as follows:
  !
  ! CALL ReadData(FileName, Real1 = RealVar, Int2 = IntVar) 
  !
  ! To read a complex variable followed by a string variable then a real 
  ! variable,
  !
  ! CALL ReadData(FileName, Complex1 = ComplexVar, String2 = StringVar, Real3 = RealVar)
  !
  ! Assigning two variables to the same column will produce an error, i.e.
  !
  ! CALL ReadData(FileName, Complex1 = ComplexVar, Int1 = IntVar)
  !
  ! will produce an error since we are trying to write two variables to the first column.
  !
  ! ReadData will also read section lines (beginning with #SN#) if they exist and a data 
  ! type lines (beginning with #DT#) if they exist. If the arguments passed to the routine
  ! do not match with the data type line for the current section, or (in the case where no
  ! data type line is present) do not match with the types found in the file, an error will
  ! occur. In addition, the user can specify an array of headers to be read from above the data.
  ! These headers will include any column labels that are defined.
  !
  ! Arguments
  ! FileName - Name of file to read from. Note that if the file is already open for writing,
  !            you will get an error. Note that this is the only non-optional argument.
  !
  ! The following arguments give the data to be read from the file. Note that all of 
  ! these arguments are optional.
  ! Int1, Real1, ... String1    - Argument to come from the first column.
  ! Int2, Real2, ... String2    - Argument to come from second column.
  ! .
  ! .
  ! .
  ! Int10, Real10, ... String10 - Argument to come from the tenth column.
  !
  ! SectionNumber - data will be read from the section number supplied if any. If no section
  !                 number is supplied, data is read sequentially from the current section.
  !                 Note: If the section number supplied is equal to the current section 
  !                 number, data continues to be read sequentially from this section.
  !
  ! Headers - Optional: Array of headers to be read from above the data. Note that
  !           this argument can be given without any data, and the headers will be read
  !           alone. 
  !
  ! ReadDataFromHeader - When set to .TRUE., lines beginning with #HD# will be interpretted
  !                     as data. This is usefull for files which contain
  !                     various information, including scalar information (which would be
  !                     written in the header) as well a set of arrays written in columns
  !                     which the user would like to be able to plot.
  !
  ! CommentCharacters - String of characters, any of which, when found at the beginning of a line,
  !                     will cause the line to be interpreted as a header. The default is '#!cC*'
  !
  ! NewSection - If a new section is found and this argument is present, data will not be read,
  !              and the routine will return NewSection = .TRUE.
  !              This helps when reading an unknown number of data lines from a section. 
  SUBROUTINE ReadData(FileName,                                      &
       & Int1, Int2, Int3, Int4, Int5, Int6, Int7, Int8, Int9, Int10, &
       & Real1, Real2, Real3, Real4, Real5, Real6, Real7, Real8,      &
       & Real9, Real10,                                               &
       & Double1, Double2, Double3, Double4, Double5, Double6,        &
       & Double7, Double8, Double9, Double10,                         &
       & Complex1, Complex2, Complex3, Complex4, Complex5, Complex6,  &
       & Complex7, Complex8, Complex9, Complex10,                     &
       & DComplex1, DComplex2, DComplex3, DComplex4, DComplex5,       &
       & DComplex6, DComplex7, DComplex8, DComplex9, DComplex10,      &
       & String1, String2, String3, String4, String5, String6,        &
       & String7, String8, String9, String10,                         &
       & SectionNumber, Headers, ReadDataFromHeader, CommentCharacters, &
       & NewSection, FileType, ExpectNewSection, ErrorMessage)
    CHARACTER*(*), INTENT(IN) :: FileName
    CHARACTER*(*), INTENT(IN), OPTIONAL :: ErrorMessage(:)
    INTEGER, INTENT(OUT), OPTIONAL :: Int1, Int2, Int3, Int4, Int5,    &
         & Int6, Int7, Int8, Int9, Int10
    REAL, INTENT(OUT), OPTIONAL :: Real1, Real2, Real3, Real4, Real5,  &
         & Real6, Real7, Real8, Real9, Real10
    DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: Double1, Double2,       &
         & Double3, Double4, Double5, Double6, Double7, Double8,      &
         & Double9, Double10
    COMPLEX, INTENT(OUT), OPTIONAL :: Complex1, Complex2, Complex3,    &
         & Complex4, Complex5,                                        &
         & Complex6, Complex7, Complex8, Complex9, Complex10
    COMPLEX*16, INTENT(OUT), OPTIONAL :: DComplex1, DComplex2,         &
         & DComplex3, DComplex4, DComplex5, DComplex6, DComplex7,     &
         & DComplex8, DComplex9, DComplex10
    CHARACTER*(*), INTENT(OUT), OPTIONAL :: String1, String2, String3, &
         & String4, String5, String6, String7, String8, String9,      &
         & String10

    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Headers(:)
    CHARACTER*(*),INTENT(IN),OPTIONAL :: CommentCharacters, FileType
    LOGICAL,INTENT(IN),OPTIONAL :: ReadDataFromHeader, ExpectNewSection
    LOGICAL,INTENT(OUT),OPTIONAL :: NewSection
    INTEGER,INTENT(IN),OPTIONAL :: SectionNumber

    ! Local variables
    ! NumArgs - Number of data arguments passed
    ! iArg    - The current argument.
    ! iUnit   - unit number associated with FileName
    INTEGER NumArgs, iArg, iUnit
    ! IsPresent  - If IsPresent(i) is true then the ith argument has already been defined.
    ! HeaderData - If true, interpret lines beginning with #HD# as data.
    ! txt, pad  - These are here in anticipation of enabling various formats,
    !              including text, paded ascii to start, and possibly further formats 
    !              such as xml.
    ! NewSection - If a new section is found, return set to true and return without reading.
    LOGICAL IsPresent(10), HeaderData, txt, pad, ExpNewSect
    ! DataArray - Array of strings to hold the data. Data line is split into words contained 
    !             in DataArray, then the arguments are read from DataArray(iArg)
    CHARACTER(MaxStrLen) DataArray(10)
    ! DataTypeLine - The data type line lists the types of data that have been specified
    !                in the file on a line beginning with #DT#. The arguments specified by
    !                the user will be checked against the types defined in the file.
    CHARACTER(120) DataTypeLine
    ! DataTypes - Array of types. 'Int', 'Real', 'Double' ...
    CHARACTER(20) DataTypes(10)
    ! ! FileAction - String variable that holds the action associated with the IOFile
    !                specified by FileName.
    CHARACTER(80) Args(20), FileAction
    ! String of comment characters.
    CHARACTER(10) CmtChars, FlType
    ! String holding the current line.
    CHARACTER(1000) Line
    ! NSections  - number of current section.
    ! NDataTypes - number of data types specified on the data type line in the file.
    ! NFields - number of columns in the current line.
    ! iField - current column.
    INTEGER i1, NSections, NDataTypes, NFields, iField

    ! Initialization
    HeaderData   = .FALSE.
    IsPresent(:) = .FALSE.
    NumArgs      = 0
    txt          = .TRUE.
    pad         = .FALSE.
    DataTypeLine = ''
    DataTypes(:) = 'Unknown'
    NDataTypes = 0
    iField = 0
    FlType = 'TXT'
    ExpNewSect = .FALSE.

    IF(PRESENT(ExpectNewSection)) ExpNewSect = ExpectNewSection
    ! Set the type of file. Default is txt.
    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          txt = .TRUE.
          pad = .FALSE.
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          pad = .TRUE.
          txt = .FALSE.
       ELSE
          CALL Error('Error: Illegal file type passed to WriteData')
       END IF
    END IF

    IF(PRESENT(CommentCharacters)) THEN 
       CmtChars = CommentCharacters
    ELSE
       CmtChars = '#!cC*'
    END IF

    IF(PRESENT(ReadDataFromHeader)) HeaderData = ReadDataFromHeader

    ! Open the file.
    IF(PRESENT(ErrorMessage)) THEN
       CALL OpenFl(FileName, FileStatus = 'OLD', FileAction = 'READ', ErrorMessage = ErrorMessage)
    ELSE
       CALL OpenFl(FileName, FileStatus = 'OLD', FileAction = 'READ')
    END IF

    ! Get the unit number, the section number, and the fileaction (Read or Write).
    CALL GetIOFileInfo(FileName,UnitNumber = iUnit,NSections = NSections, FileAction = FileAction)    
    ! If this is the first call, set NSections to 1
    IF(NSections.eq.0) NSections = 1

    ! Check that the FileAction is 'READ' not 'WRITE'.
    IF(FileAction(1:5).eq.'WRITE') CALL Error('Error in ReadData. File ' // FileName // &
         & ' is already open for writing.')

    ! If section number has been supplied, and is not equal to the current section number
    ! read to the specified section. 
    IF(PRESENT(SectionNumber)) THEN
       IF(SectionNumber.ne.NSections) CALL ReadToSection(FileName,SectionNumber)
       NSections = SectionNumber
       ! If we have reached the end of the file, return.
       IF(EndOfFile(FileName)) RETURN
    END IF

    ! Read the headers, keeping them in Headers array if supplied. This will also update the
    ! DataTypeLine and section number if they are found.
    IF(PRESENT(Headers)) THEN
       CALL ReadHeaders(FileName,Line,CommentCharacters = CmtChars, Headers = Headers)
    ELSE
       CALL ReadHeaders(FileName,Line,CommentCharacters = CmtChars)
    END IF

    ! If end of file or end of section, return.
    IF(EndOfFile(FileName).or.ReadingNewSection(FileName,NSections)) THEN
       IF(.NOT.ExpNewSect) THEN
          IF(PRESENT(NewSection)) NewSection = .TRUE.
          RETURN
       END IF
    END IF

    ! Get the DataTypeLine
    CALL GetIOFileInfo(FileName, DataTypeLine = DataTypeLine, NSections = NSections)
    ! If the DataTypeLine is not defined in the file, ignore.
    IF(TRIM(ADJUSTL(DataTypeLine)).ne.'Unknown') THEN
       NDataTypes = 10
       CALL bwords(DataTypeLine,NDataTypes,DataTypes)
    END IF

    ! Read the Line.
    Line = TRIM(ADJUSTL(Line))

    ! If Line starts with #HD#, this is header data. Ignore #HD# and 
    ! break the rest of the line.
    IF(Line(1:4).eq.'#HD#') Line = Line(5:LEN(Line))
    NFields = 20
    CALL bwords2(Line,NFields, Args)


    ! Find the 1st argument.
    IF(PRESENT(Int1)) CALL GetArgInt(Int1, 1)
    IF(PRESENT(Real1)) CALL GetArgReal(Real1, 1)
    IF(PRESENT(Double1)) CALL GetArgDouble(Double1, 1)
    IF(PRESENT(Complex1)) CALL GetArgComplex(Complex1, 1)
    IF(PRESENT(DComplex1)) CALL GetArgDComplex(DComplex1, 1)
    IF(PRESENT(String1)) CALL GetArgString(String1, 1)

    ! The GetArgType(Arg,ColumnNumber) subroutines checks the presence of Arg. If Arg
    ! is present, the data is read into DataArray(ColumnNumber). Also
    ! iField is incremented.
    ! In addition, various errors are checked.
    ! Find the 2nd argument.
    IF(PRESENT(Int2)) CALL GetArgInt(Int2, 2)
    IF(PRESENT(Real2)) CALL GetArgReal(Real2, 2)
    IF(PRESENT(Double2)) CALL GetArgDouble(Double2, 2)
    IF(PRESENT(Complex2)) CALL GetArgComplex(Complex2, 2)
    IF(PRESENT(DComplex2)) CALL GetArgDComplex(DComplex2, 2)
    IF(PRESENT(String2)) CALL GetArgString(String2, 2)

    ! Find the 3rd argument.
    IF(PRESENT(Int3)) CALL GetArgInt(Int3, 3)
    IF(PRESENT(Real3)) CALL GetArgReal(Real3, 3)
    IF(PRESENT(Double3)) CALL GetArgDouble(Double3, 3)
    IF(PRESENT(Complex3)) CALL GetArgComplex(Complex3, 3)
    IF(PRESENT(DComplex3)) CALL GetArgDComplex(DComplex3, 3)
    IF(PRESENT(String3)) CALL GetArgString(String3, 3)

    ! Find the 4th argument.
    IF(PRESENT(Int4)) CALL GetArgInt(Int4, 4)
    IF(PRESENT(Real4)) CALL GetArgReal(Real4, 4)
    IF(PRESENT(Double4)) CALL GetArgDouble(Double4, 4)
    IF(PRESENT(Complex4)) CALL GetArgComplex(Complex4, 4)
    IF(PRESENT(DComplex4)) CALL GetArgDComplex(DComplex4, 4)
    IF(PRESENT(String4)) CALL GetArgString(String4, 4)

    ! Find the 5th argument.
    IF(PRESENT(Int5)) CALL GetArgInt(Int5, 5)
    IF(PRESENT(Real5)) CALL GetArgReal(Real5, 5)
    IF(PRESENT(Double5)) CALL GetArgDouble(Double5, 5)
    IF(PRESENT(Complex5)) CALL GetArgComplex(Complex5, 5)
    IF(PRESENT(DComplex5)) CALL GetArgDComplex(DComplex5, 5)
    IF(PRESENT(String5)) CALL GetArgString(String5, 5)

    ! Find the 6th argument.
    IF(PRESENT(Int6)) CALL GetArgInt(Int6, 6)
    IF(PRESENT(Real6)) CALL GetArgReal(Real6, 6)
    IF(PRESENT(Double6)) CALL GetArgDouble(Double6, 6)
    IF(PRESENT(Complex6)) CALL GetArgComplex(Complex6, 6)
    IF(PRESENT(DComplex6)) CALL GetArgDComplex(DComplex6, 6)
    IF(PRESENT(String6)) CALL GetArgString(String6, 6)

    ! Find the 7th argument.
    IF(PRESENT(Int7)) CALL GetArgInt(Int7, 7)
    IF(PRESENT(Real7)) CALL GetArgReal(Real7, 7)
    IF(PRESENT(Double7)) CALL GetArgDouble(Double7, 7)
    IF(PRESENT(Complex7)) CALL GetArgComplex(Complex7, 7)
    IF(PRESENT(DComplex7)) CALL GetArgDComplex(DComplex7, 7)
    IF(PRESENT(String7)) CALL GetArgString(String7, 7)

    ! Find the 8th argument.
    IF(PRESENT(Int8)) CALL GetArgInt(Int8, 8)
    IF(PRESENT(Real8)) CALL GetArgReal(Real8, 8)
    IF(PRESENT(Double8)) CALL GetArgDouble(Double8, 8)
    IF(PRESENT(Complex8)) CALL GetArgComplex(Complex8, 8)
    IF(PRESENT(DComplex8)) CALL GetArgDComplex(DComplex8, 8)
    IF(PRESENT(String8)) CALL GetArgString(String8, 8)

    ! Find the 9th argument.
    IF(PRESENT(Int9)) CALL GetArgInt(Int9, 9)
    IF(PRESENT(Real9)) CALL GetArgReal(Real9, 9)
    IF(PRESENT(Double9)) CALL GetArgDouble(Double9, 9)
    IF(PRESENT(Complex9)) CALL GetArgComplex(Complex9, 9)
    IF(PRESENT(DComplex9)) CALL GetArgDComplex(DComplex9, 9)
    IF(PRESENT(String9)) CALL GetArgString(String9, 9)

    ! Find the 10th argument.
    IF(PRESENT(Int10)) CALL GetArgInt(Int10, 10)
    IF(PRESENT(Real10)) CALL GetArgReal(Real10, 10)
    IF(PRESENT(Double10)) CALL GetArgDouble(Double10, 10)
    IF(PRESENT(Complex10)) CALL GetArgComplex(Complex10, 10)
    IF(PRESENT(DComplex10)) CALL GetArgDComplex(DComplex10, 10)
    IF(PRESENT(String10)) CALL GetArgString(String10, 10)

  CONTAINS

    ! The GetArgType(Arg,ColumnNumber) subroutines checks the presence of Arg. If Arg
    ! is present, the data is read into DataArray(ColumnNumber). Also
    ! iField is incremented.
    ! In addition, various errors are checked.    
    SUBROUTINE GetArgInt(Arg, iArg)
      INTEGER,INTENT(OUT) :: Arg
      INTEGER,INTENT(IN) :: iArg

      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'Int')

      ! Read the next argument
      iField = iField + 1
      IF(txt) THEN
         READ(Args(iField),*) Arg
      ELSEIF(pad) THEN
         CALL ReadPAD(Args(iField),Arg)
      END IF
    END SUBROUTINE GetArgInt

    SUBROUTINE GetArgReal( Arg, iArg)
      REAL,INTENT(OUT) :: Arg
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'Real')

      ! Read the next argument
      iField = iField + 1
      IF(txt) THEN
         READ(Args(iArg),*) Arg
      ELSEIF(pad) THEN
         CALL ReadPAD(Args(iField), npadrDefault, Arg)
      END IF
    END SUBROUTINE GetArgReal

    SUBROUTINE GetArgDouble( Arg, iArg)
      DOUBLE PRECISION,INTENT(OUT) :: Arg
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'Double')

      ! Read the next argument
      iField = iField + 1
      IF(txt) THEN
         READ(Args(iArg),*) Arg
      ELSEIF(pad) THEN
         CALL ReadPAD(Args(iField), npadxDefault, Arg)
      END IF
    END SUBROUTINE GetArgDouble

    SUBROUTINE GetArgComplex( Arg, iArg)
      COMPLEX,INTENT(OUT) :: Arg
      INTEGER,INTENT(IN) :: iArg
      REAL ReArg, ImArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'Complex')

      ! Read the next argument
      iField = iField + 1
      IF(txt) THEN
         READ(Args(iField),*) ReArg
      ELSEIF(pad) THEN
         CALL ReadPAD(Args(iField), npadrDefault, ReArg)
      END IF

      ! Check that the number of Fields in the data file is >= to iField. This was checked in
      ! CheckForErrors, but we need to check it again since we are reading again.
      IF(iField.ge.NFields) CALL Error('Too many arguments passed to ReadData when compared ' //&
           & 'number of fields in file ' // FileName)
      iField = iField + 1
      IF(txt) THEN
         READ(Args(iField),*) ImArg
      ELSEIF(pad) THEN
         CALL ReadPAD(Args(iField), npadrDefault, ImArg)
      END IF
      Arg = ReArg + (0.0, 1.0)*ImArg
    END SUBROUTINE GetArgComplex

    SUBROUTINE GetArgDComplex( Arg, iArg)
      COMPLEX*16,INTENT(OUT) :: Arg
      INTEGER,INTENT(IN) :: iArg

      DOUBLE PRECISION ReArg, ImArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'DComplex')

      ! Read the next argument
      iField = iField + 1
      IF(txt) THEN
         READ(Args(iField),*) ReArg
      ELSEIF(pad) THEN
         CALL ReadPAD(Args(iField), npadxDefault, ReArg)
      END IF

      ! Check that the number of Fields in the data file is >= to iField. This was checked in
      ! CheckForErrors, but we need to check it again since we are reading again.
      IF(iField.ge.NFields) CALL Error('Too many arguments passed to ReadData when compared ' //&
           & 'number of fields in file ' // FileName)
      iField = iField + 1
      IF(txt) THEN
         READ(Args(iField),*) ImArg
      ELSEIF(pad) THEN
         CALL ReadPAD(Args(iField), npadxDefault, ImArg)
      END IF
      Arg = ReArg + (0.d0, 1.d0)*ImArg
    END SUBROUTINE GetArgDComplex

    SUBROUTINE GetArgString( Arg, iArg)
      CHARACTER*(*),INTENT(OUT) :: Arg
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,'String')

      ! Read the next argument
      iField = iField + 1
      IF(txt) THEN
      READ(Args(iField),*) Arg
      ELSEIF(pad) THEN
         CALL ReadPAD(Args(iField),Arg)
      END IF
    END SUBROUTINE GetArgString

    ! CheckForErrors checks for the following errors and stops if it finds one:
    ! 
    ! 1. 'Error in ReadData multiple arguments in place' - This error occurs 
    !    when the user has specified that two arguments should be written into
    !    one column, i.e. WriteData(FileName, Int1 = I, Real1 = R, ...)
    !
    ! 2. 'Too many arguments passed to ReadData. Max is 10.' - user has specified
    !    more than 10 aguments. This one is redundant, and error 1. should always 
    !    occur if this happens.
    !
    ! 3. 'Too many arguments passed to ReadData when compared to
    !     number of fields in file FileName' - user has specified
    !     more (or different) arguments than are available in file.
    !
    ! 4. 'Error: Number of arguments passed to ReadData does not
    !     match that defined in the file FileName' - user has
    !     specified more arguments than are defined in the data type
    !     line in the file.  
    !
    ! 5.  'Error: Arguments passed to ReadData are of different type
    !      than those defined in the file FileName.' - user is trying
    !      to read different types than those defined by the data
    !      type line in the file.
    !
    ! In addition, CheckForError increments the number of arguments.
    SUBROUTINE CheckForErrors(iArg,DTL)
      INTEGER,INTENT(IN) :: iArg
      CHARACTER*(*) DTL
      CHARACTER(2) ArgNum
      INTEGER iAllocateError
      ArgNum=''
      WRITE(ArgNum,'(I2)') iArg

      IF(IsPresent(iArg)) THEN
         CALL Error('Error in ReadData multiple arguments in place ' // TRIM(ArgNum) // '.')
      END IF

      ! Set IsPresent(iArg)
      IsPresent(iArg) = .TRUE.

      ! Check that number of arguments is not too large. Redundant, but oh well.
      IF(NumArgs.ge.10) CALL Error('Too many arguments passed to ReadData. Max is 10.')
      NumArgs = NumArgs + 1

      ! Check that the number of Fields in the data file is >= to iField
      IF(iField.ge.NFields) CALL Error('Too many arguments passed to ReadData when compared ' //&
           & 'number of fields in file ' // FileName)

      ! If data types have been defined in this file, check for data type errors.
      IF(NDataTypes.gt.0) THEN
         ! Check that there are not more arguments than data types.
         IF(iArg.gt.NDataTypes) THEN
            CALL Error('Error: Number of arguments passed to ReadData does not match ' // &
                 & 'that defined in the file ' // FileName)
         END IF

         ! Check that this argument is compatible with the datatype described in DataTypeLine.
         IF( TRIM(ADJUSTL(DataTypes(iArg))).ne.TRIM(ADJUSTL(DTL)) ) THEN
            CALL Error('Error: Arguments passed to ReadData are of different type than those' // &
                 & ' defined in the file ' // FileName // '.')
         END IF
      END IF
    END SUBROUTINE CheckForErrors

  END SUBROUTINE ReadData


  ! SUBROUTINE ReadArrayData reads up to 10 arrays out of the file
  ! FileName. This routine is almost identical to ReadData except
  ! that the data arguments are arbitrary length arrays. See
  ! description of ReadData for more information. The following
  ! information gives differences to ReadData.
  ! 
  ! ReadArrayData will read multiple lines into the given arrays
  ! until it reaches the end of the section, or the end of the file.
  ! Each column of data in the file is interpreted as a single array.
  ! All arrays passed to the routine must be the same length. If the
  ! arrays are not long enough to hold the data specified in the
  ! section to be read, an error will occur.
  !
  ! It has one additional optional argument when compared to ReadData.
  ! NumElements - ReadArrayData will return the number of elements it
  ! read from the specified file.
  SUBROUTINE ReadArrayData(FileName,                                      &
       & Int1, Int2, Int3, Int4, Int5, Int6, Int7, Int8, Int9, Int10, &
       & Real1, Real2, Real3, Real4, Real5, Real6, Real7, Real8,      &
       & Real9, Real10,                                               &
       & Double1, Double2, Double3, Double4, Double5, Double6,        &
       & Double7, Double8, Double9, Double10,                         &
       & Complex1, Complex2, Complex3, Complex4, Complex5, Complex6,  &
       & Complex7, Complex8, Complex9, Complex10,                     &
       & DComplex1, DComplex2, DComplex3, DComplex4, DComplex5,       &
       & DComplex6, DComplex7, DComplex8, DComplex9, DComplex10,      &
       & String1, String2, String3, String4, String5, String6,        &
       & String7, String8, String9, String10,                         &
       & SectionNumber, Headers, ReadDataFromHeader, CommentCharacters, &
       & NewSection, NumElements, FileType, ExactLength)
    CHARACTER*(*), INTENT(IN) :: FileName
    INTEGER, INTENT(OUT), OPTIONAL :: Int1(:), Int2(:), Int3(:), Int4(:), Int5(:),    &
         & Int6(:), Int7(:), Int8(:), Int9(:), Int10(:)
    REAL, INTENT(OUT), OPTIONAL :: Real1(:), Real2(:), Real3(:), Real4(:), Real5(:),  &
         & Real6(:), Real7(:), Real8(:), Real9(:), Real10(:)
    DOUBLE PRECISION, INTENT(OUT), OPTIONAL :: Double1(:), Double2(:),       &
         & Double3(:), Double4(:), Double5(:), Double6(:), Double7(:), Double8(:),      &
         & Double9(:), Double10(:)
    COMPLEX, INTENT(OUT), OPTIONAL :: Complex1(:), Complex2(:), Complex3(:),    &
         & Complex4(:), Complex5(:),                                        &
         & Complex6(:), Complex7(:), Complex8(:), Complex9(:), Complex10(:)
    COMPLEX*16, INTENT(OUT), OPTIONAL :: DComplex1(:), DComplex2(:),         &
         & DComplex3(:), DComplex4(:), DComplex5(:), DComplex6(:), DComplex7(:),     &
         & DComplex8(:), DComplex9(:), DComplex10(:)
    CHARACTER*(*), INTENT(OUT), OPTIONAL :: String1(:), String2(:), String3(:), &
         & String4(:), String5(:), String6(:), String7(:), String8(:), String9(:),      &
         & String10(:)

    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Headers(:)
    CHARACTER*(*),INTENT(IN),OPTIONAL :: CommentCharacters, FileType
    LOGICAL,INTENT(IN),OPTIONAL :: ReadDataFromHeader, ExactLength
    LOGICAL,INTENT(OUT),OPTIONAL :: NewSection
    INTEGER,INTENT(IN),OPTIONAL :: SectionNumber
    INTEGER,INTENT(OUT),OPTIONAL :: NumElements

    INTEGER NumArgs, iArg, iUnit, NumData, NColumnLabels
    LOGICAL IsPresent(10), HeaderData, txt, pad, ExactLen
    CHARACTER(MaxStrLen),ALLOCATABLE :: DataArray(:,:)
    CHARACTER(120) DataTypeLine
    CHARACTER(20) DataTypes(10)
    CHARACTER(20) IntFormat, RealFormat, DoubleFormat, ComplexFormat, &
         & DComplexFormat, StringFormat, FileAction
    CHARACTER(80) Args(20)
    CHARACTER(10) CLFormats(30), CmtChars
    CHARACTER(1000) Line
    CHARACTER(10) TmpStr, FlType

    INTEGER i1, NSections, NDataTypes, NFields, iField, MaxData, iAllocateError

    ! Initialization
    TmpStr = ' '
    HeaderData   = .FALSE.
    IsPresent(:) = .FALSE.
    NumArgs      = 0
    txt          = .TRUE.
    pad          = .FALSE.
    DataTypeLine = ''
    DataTypes(:) = 'Unknown'
    CLFormats(:) = ''
    NColumnLabels = 0
    NDataTypes = 0
    iField = 0
    MaxData = 0
    FlType = 'TXT'
    ExactLen = .TRUE.

    IF(PRESENT(ExactLength)) ExactLen = ExactLength

    ! Set the type of file. Default is txt.
    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          txt = .TRUE.
          pad = .FALSE.
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          pad = .TRUE.
          txt = .FALSE.
       ELSE
          CALL Error('Error: Illegal file type passed to WriteData')
       END IF
    END IF

    IF(PRESENT(CommentCharacters)) THEN 
       CmtChars = CommentCharacters
    ELSE
       CmtChars = DefaultCommentCharacters
    END IF

    IF(PRESENT(ReadDataFromHeader)) HeaderData = ReadDataFromHeader

    ! Open the file.
    CALL OpenFl(FileName, FileStatus = 'OLD', FileAction = 'READ')

    ! Get the unit number, and the section number.
    CALL GetIOFileInfo(FileName,UnitNumber = iUnit,NSections = NSections, FileAction = FileAction)
    IF(NSections.eq.0) NSections = 1

    ! Check that the FileAction is read.
    IF(FileAction(1:5).eq.'WRITE') CALL Error('Error in ReadData. File ' // FileName // &
         & ' is already open for writing.')

    ! If section number has been supplied, read to that section. 
    IF(PRESENT(SectionNumber)) THEN
       IF(SectionNumber.ne.NSections) CALL ReadToSection(FileName,SectionNumber)
       NSections = SectionNumber
       IF(EndOfFile(FileName)) RETURN
    END IF

    ! Read the headers, keeping them in Headers if supplied. This will also update the
    ! DataTypeLine and section number if they are found.
    IF(PRESENT(Headers)) THEN
       CALL ReadHeaders(FileName,Line, CommentCharacters = CmtChars, Headers = Headers)
    ELSE
       CALL ReadHeaders(FileName,Line,CommentCharacters = CmtChars)
    END IF
    IF(EndOfFile(FileName)) RETURN

    ! Get the DataTypeLine
    CALL GetIOFileInfo(FileName, DataTypeLine = DataTypeLine, NSections = NSections)
    IF(TRIM(ADJUSTL(DataTypeLine)).ne.'Unknown') THEN
       NDataTypes = 10
       CALL bwords(DataTypeLine,NDataTypes,DataTypes)
    END IF

    ! Get the maximum number of data lines.
    CALL GetMaxData

    ! Allocate space for string data array.
    ALLOCATE(DataArray(MaxData,20), STAT = iAllocateError)
    CALL CheckAllocation(iAllocateError, 'Error: Failed to allocate space for DataArray' //&
         & ' in subroutine WriteArrayData.')
    ! Read all the lines in this section, and split them into words.
    ! ReadHeaders reads the line.

    DO i1 = 1, MaxData 
       NFields = 20
       ! Clean up the line.
       Line = ADJUSTL(Line)
       ! If this is header data, remove the #HD# marker.
       IF(Line(1:4).eq.'#HD#') Line = Line(5:LEN(Line))
       ! Split line into words and copy to DataArray.
       CALL bwords2(Line,NFields,Args)
       DO iField = 1, NFields
          DataArray(i1,iField) = Args(iField)
       END DO

       ! If we have reached the end of the section or the end of the 
       ! file, return.
       IF(EndOfFile(FileName).or.ReadingNewSection(FileName,NSections)) THEN
          IF(PRESENT(NewSection)) NewSection = .TRUE.
          EXIT
       ELSE
          NumData = i1
       END IF
       IF(i1.eq.MaxData) EXIT
       ! Read past any comments and output next line.
       CALL ReadHeaders(FileName,Line,CommentCharacters = CmtChars)
    END DO
    ! Check that the next line is not data. If it is. The arrays that were passed
    ! are not long enough to hold all of the data in the file. Error.
    IF(.not.ExactLen) THEN
       IF(NextLineIsData(FileName)) THEN
          WRITE(TmpStr,'(I4)') NSections
          CALL Error('Error: Arrays passed to ReadArrayData are not long enough to hold', StopProgram = .FALSE.)
          CALL Error('the data defined in section ' // TRIM(ADJUSTL(TmpStr)) // ' of ' // TRIM(FileName), StopProgram = .FALSE.)
       END IF
    END IF

    iField = 0
    ! Find the 1st argument and read all elements into DataArray
    IF(PRESENT(Int1)) CALL GetArrayArgInt(Int1, 1)
    IF(PRESENT(Real1)) CALL GetArrayArgReal(Real1, 1)
    IF(PRESENT(Double1)) CALL GetArrayArgDouble(Double1, 1)
    IF(PRESENT(Complex1)) CALL GetArrayArgComplex(Complex1, 1)
    IF(PRESENT(DComplex1)) CALL GetArrayArgDComplex(DComplex1, 1)
    IF(PRESENT(String1)) CALL GetArrayArgString(String1, 1)

    ! Find the 2nd argument.
    IF(PRESENT(Int2)) CALL GetArrayArgInt(Int2, 2)
    IF(PRESENT(Real2)) CALL GetArrayArgReal(Real2, 2)
    IF(PRESENT(Double2)) CALL GetArrayArgDouble(Double2, 2)
    IF(PRESENT(Complex2)) CALL GetArrayArgComplex(Complex2, 2)
    IF(PRESENT(DComplex2)) CALL GetArrayArgDComplex(DComplex2, 2)
    IF(PRESENT(String2)) CALL GetArrayArgString(String2, 2)

    ! Find the 3rd argument.
    IF(PRESENT(Int3)) CALL GetArrayArgInt(Int3, 3)
    IF(PRESENT(Real3)) CALL GetArrayArgReal(Real3, 3)
    IF(PRESENT(Double3)) CALL GetArrayArgDouble(Double3, 3)
    IF(PRESENT(Complex3)) CALL GetArrayArgComplex(Complex3, 3)
    IF(PRESENT(DComplex3)) CALL GetArrayArgDComplex(DComplex3, 3)
    IF(PRESENT(String3)) CALL GetArrayArgString(String3, 3)

    ! Find the 4th argument.
    IF(PRESENT(Int4)) CALL GetArrayArgInt(Int4, 4)
    IF(PRESENT(Real4)) CALL GetArrayArgReal(Real4, 4)
    IF(PRESENT(Double4)) CALL GetArrayArgDouble(Double4, 4)
    IF(PRESENT(Complex4)) CALL GetArrayArgComplex(Complex4, 4)
    IF(PRESENT(DComplex4)) CALL GetArrayArgDComplex(DComplex4, 4)
    IF(PRESENT(String4)) CALL GetArrayArgString(String4, 4)

    ! Find the 5th argument.
    IF(PRESENT(Int5)) CALL GetArrayArgInt(Int5, 5)
    IF(PRESENT(Real5)) CALL GetArrayArgReal(Real5, 5)
    IF(PRESENT(Double5)) CALL GetArrayArgDouble(Double5, 5)
    IF(PRESENT(Complex5)) CALL GetArrayArgComplex(Complex5, 5)
    IF(PRESENT(DComplex5)) CALL GetArrayArgDComplex(DComplex5, 5)
    IF(PRESENT(String5)) CALL GetArrayArgString(String5, 5)

    ! Find the 6th argument.
    IF(PRESENT(Int6)) CALL GetArrayArgInt(Int6, 6)
    IF(PRESENT(Real6)) CALL GetArrayArgReal(Real6, 6)
    IF(PRESENT(Double6)) CALL GetArrayArgDouble(Double6, 6)
    IF(PRESENT(Complex6)) CALL GetArrayArgComplex(Complex6, 6)
    IF(PRESENT(DComplex6)) CALL GetArrayArgDComplex(DComplex6, 6)
    IF(PRESENT(String6)) CALL GetArrayArgString(String6, 6)

    ! Find the 7th argument.
    IF(PRESENT(Int7)) CALL GetArrayArgInt(Int7, 7)
    IF(PRESENT(Real7)) CALL GetArrayArgReal(Real7, 7)
    IF(PRESENT(Double7)) CALL GetArrayArgDouble(Double7, 7)
    IF(PRESENT(Complex7)) CALL GetArrayArgComplex(Complex7, 7)
    IF(PRESENT(DComplex7)) CALL GetArrayArgDComplex(DComplex7, 7)
    IF(PRESENT(String7)) CALL GetArrayArgString(String7, 7)

    ! Find the 8th argument.
    IF(PRESENT(Int8)) CALL GetArrayArgInt(Int8, 8)
    IF(PRESENT(Real8)) CALL GetArrayArgReal(Real8, 8)
    IF(PRESENT(Double8)) CALL GetArrayArgDouble(Double8, 8)
    IF(PRESENT(Complex8)) CALL GetArrayArgComplex(Complex8, 8)
    IF(PRESENT(DComplex8)) CALL GetArrayArgDComplex(DComplex8, 8)
    IF(PRESENT(String8)) CALL GetArrayArgString(String8, 8)

    ! Find the 9th argument.
    IF(PRESENT(Int9)) CALL GetArrayArgInt(Int9, 9)
    IF(PRESENT(Real9)) CALL GetArrayArgReal(Real9, 9)
    IF(PRESENT(Double9)) CALL GetArrayArgDouble(Double9, 9)
    IF(PRESENT(Complex9)) CALL GetArrayArgComplex(Complex9, 9)
    IF(PRESENT(DComplex9)) CALL GetArrayArgDComplex(DComplex9, 9)
    IF(PRESENT(String9)) CALL GetArrayArgString(String9, 9)

    ! Find the 10th argument.
    IF(PRESENT(Int10)) CALL GetArrayArgInt(Int10, 10)
    IF(PRESENT(Real10)) CALL GetArrayArgReal(Real10, 10)
    IF(PRESENT(Double10)) CALL GetArrayArgDouble(Double10, 10)
    IF(PRESENT(Complex10)) CALL GetArrayArgComplex(Complex10, 10)
    IF(PRESENT(DComplex10)) CALL GetArrayArgDComplex(DComplex10, 10)
    IF(PRESENT(String10)) CALL GetArrayArgString(String10, 10)

    IF(PRESENT(NumElements)) NumElements = NumData
    DEALLOCATE(DataArray)
  CONTAINS

    SUBROUTINE GetArrayArgInt(Arg, iArg)
      INTEGER,INTENT(OUT) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg
      INTEGER iData

      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckArrayForErrors(iArg,'Int')

      IF(MaxData.ne.SIZE(Arg)) THEN
         CALL Error('Error in ReadArrayData: All arrays must be same size.')
      END IF
      ! Read the next column.
      iField = iField + 1
      IF(txt) THEN
         DO i1 = 1, NumData
            READ(DataArray(i1,iField),*) Arg(i1)
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL ReadPAD(DataArray(i1,iField),Arg(i1))
         END DO
      END IF
    END SUBROUTINE GetArrayArgInt

    SUBROUTINE GetArrayArgReal( Arg, iArg)
      REAL,INTENT(OUT) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckArrayForErrors(iArg,'Real')

      IF(MaxData.ne.SIZE(Arg)) THEN
         CALL Error('Error in writearray: All arrays must be same size.')
      END IF

      ! Read the next argument
      iField = iField + 1
      IF(txt) THEN
         DO i1 = 1, NumData
            READ(DataArray(i1,iField),*) Arg(i1)
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL ReadPAD(DataArray(i1, iField), npadrDefault, Arg(i1))
         END DO
      END IF
    END SUBROUTINE GetArrayArgReal

    SUBROUTINE GetArrayArgDouble( Arg, iArg)
      DOUBLE PRECISION,INTENT(OUT) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckArrayForErrors(iArg,'Double')

      IF(MaxData.ne.SIZE(Arg)) THEN
         CALL Error('Error in writearray: All arrays must be same size.')
      END IF

      ! Read the next argument
      iField = iField + 1
      IF(txt) THEN
         DO i1 = 1, NumData
            READ(DataArray(i1,iField),*) Arg(i1)
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL ReadPAD(DataArray(i1, iField), npadrDefault, Arg(i1))
         END DO
      END IF
    END SUBROUTINE GetArrayArgDouble

    SUBROUTINE GetArrayArgComplex( Arg, iArg)
      COMPLEX,INTENT(OUT) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg
      REAL ReArg, ImArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckArrayForErrors(iArg,'Complex')

      IF(MaxData.ne.SIZE(Arg)) THEN
         CALL Error('Error in writearray: All arrays must be same size.')
      END IF

      ! Read the next argument
      iField = iField + 1
      IF(iField.ge.NFields) CALL Error('Too many arguments passed to ReadData when compared ' //&
           & 'number of fields in file ' // FileName)
      iField = iField + 1
      IF(txt) THEN
         DO i1 = 1, NumData
            READ(DataArray(i1,iField-1),*) ReArg
            READ(DataArray(i1,iField),*) ImArg
            Arg(i1) = ReArg + (0.0,1.0)*ImArg
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL ReadPAD(DataArray(i1, iField-1), npadrDefault, ReArg)
            CALL ReadPAD(DataArray(i1, iField), npadrDefault, ImArg)
            Arg(i1) = ReArg + (0.0,1.0)*ImArg
         END DO
      END IF
    END SUBROUTINE GetArrayArgComplex

    SUBROUTINE GetArrayArgDComplex( Arg, iArg)
      COMPLEX*16,INTENT(OUT) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg

      DOUBLE PRECISION ReArg, ImArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckArrayForErrors(iArg,'DComplex')

      IF(MaxData.ne.SIZE(Arg)) THEN
         CALL Error('Error in writearray: All arrays must be same size.')
      END IF

      ! Read the next column
      iField = iField + 1
      IF(iField.ge.NFields) CALL Error('Too many arguments passed to ReadData when compared ' //&
           & 'number of fields in file ' // FileName)
      iField = iField + 1
      IF(txt) THEN
         DO i1 = 1, NumData
            READ(DataArray(i1,iField-1),*) ReArg
            READ(DataArray(i1,iField),*) ImArg
            Arg(i1) = ReArg + (0.0,1.0)*ImArg
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL ReadPAD(DataArray(i1, iField-1), npadxDefault, ReArg)
            CALL ReadPAD(DataArray(i1, iField), npadxDefault, ImArg)
            Arg(i1) = ReArg + (0.d0,1.d0)*ImArg
         END DO
      END IF
    END SUBROUTINE GetArrayArgDComplex

    SUBROUTINE GetArrayArgString( Arg, iArg)
      CHARACTER*(*),INTENT(OUT) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckArrayForErrors(iArg,'String')

      IF(MaxData.ne.SIZE(Arg)) THEN
         CALL Error('Error in writearray: All arrays must be same size.')
      END IF

      ! Read the next column
      iField = iField + 1
      IF(txt) THEN
         DO i1 = 1, NumData
            READ(DataArray(i1,iField),*) Arg(i1)
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL ReadPAD(DataArray(i1, iField),Arg(i1))
         END DO
      END IF
    END SUBROUTINE GetArrayArgString
      
    SUBROUTINE CheckArrayForErrors(iArg,DTL)
      INTEGER,INTENT(IN) :: iArg
      CHARACTER*(*) DTL
      CHARACTER(2) ArgNum
      INTEGER iAllocateError
      ArgNum=''
      WRITE(ArgNum,'(I2)') iArg

      IF(IsPresent(iArg)) THEN
         CALL Error('Error in ReadData: multiple arguments in place ' // TRIM(ArgNum) // '.')
      END IF

      ! Set IsPresent(iArg)
      IsPresent(iArg) = .TRUE.

      ! Check that number of arguments is not too large. Redundant, but oh well.
      IF(NumArgs.ge.10) CALL Error('Too many arguments passed to ReadData. Max is 10.')
      NumArgs = NumArgs + 1
      ! Check that the number of Fields in the data file is >= to iField
      IF(iField.ge.NFields) CALL Error('Too many arguments passed to ReadData when compared ' //&
           & 'number of fields in file ' // FileName)

      ! If data types have been defined in this file, check for data type errors.
      IF(DataTypes(1).ne.'Unknown') THEN
         ! Check that there are not more arguments than data types.
         IF(iArg.gt.NDataTypes) THEN
            CALL Error('Error: Number of arguments passed to ReadData does not match ' // &
                 & 'that defined in the file ' // FileName)
         END IF

         ! Check that this argument is compatible with the datatype described in DataTypeLine.
         IF( TRIM(ADJUSTL(DataTypes(iArg))).ne.TRIM(ADJUSTL(DTL)) ) THEN
            CALL Error('Error: Arguments passed to ReadData are of different type than those' // &
                 & ' defined in the file ' // FileName // '.')
         END IF
      END IF
    END SUBROUTINE CheckArrayForErrors

    SUBROUTINE GetMaxData
      ! Find the 1st argument.
      IF(PRESENT(Int1)) MaxData = SIZE(Int1)
      IF(PRESENT(Real1)) MaxData = SIZE(Real1)
      IF(PRESENT(Double1)) MaxData = SIZE(Double1)
      IF(PRESENT(Complex1)) MaxData =SIZE(Complex1)
      IF(PRESENT(DComplex1)) MaxData =SIZE(DComplex1)
      IF(PRESENT(String1)) MaxData = SIZE(String1)
    END SUBROUTINE GetMaxData

  END SUBROUTINE ReadArrayData

  ! Subroutine WriteArrayData writes scalar data to the file filename.
  ! Up to 10 arrays of data can be written each specified by using
  ! the optional arguments Int1 - Int10, Real1 - Real10, etc.  
  ! WriteArrayData is very similar to WriteData, except that the data
  ! arguments are arbitrary length arrays instead of scalar valued
  ! variables. All data arrays passed to the routine must be the same
  ! length.
  SUBROUTINE WriteArrayData(FileName,                                      &
       & Int1, Int2, Int3, Int4, Int5, Int6, Int7, Int8, Int9, Int10, &
       & Real1, Real2, Real3, Real4, Real5, Real6, Real7, Real8,      &
       & Real9, Real10,                                               &
       & Double1, Double2, Double3, Double4, Double5, Double6,        &
       & Double7, Double8, Double9, Double10,                         &
       & Complex1, Complex2, Complex3, Complex4, Complex5, Complex6,  &
       & Complex7, Complex8, Complex9, Complex10,                     &
       & DComplex1, DComplex2, DComplex3, DComplex4, DComplex5,       &
       & DComplex6, DComplex7, DComplex8, DComplex9, DComplex10,      &
       & String1, String2, String3, String4, String5, String6,        &
       & String7, String8, String9, String10,                         &
       & Headers, ColumnLabels, WriteDataInHeader, ForceNewSection,   &
       & FileType)
    CHARACTER*(*), INTENT(IN) :: FileName
    INTEGER, INTENT(IN), OPTIONAL :: Int1(:), Int2(:), Int3(:), Int4(:),  Int5(:),    &
         & Int6(:), Int7(:), Int8(:), Int9(:), Int10(:)
    REAL, INTENT(IN), OPTIONAL :: Real1(:), Real2(:), Real3(:), Real4(:), Real5(:),  &
         & Real6(:), Real7(:), Real8(:), Real9(:), Real10(:)
    DOUBLE PRECISION, INTENT(IN), OPTIONAL :: Double1(:), Double2(:),       &
         & Double3(:), Double4(:), Double5(:), Double6(:), Double7(:), Double8(:),      &
         & Double9(:), Double10(:)
    COMPLEX, INTENT(IN), OPTIONAL :: Complex1(:), Complex2(:), Complex3(:),    &
         & Complex4(:), Complex5(:),                                        &
         & Complex6(:), Complex7(:), Complex8(:), Complex9(:), Complex10(:)
    COMPLEX*16, INTENT(IN), OPTIONAL :: DComplex1(:), DComplex2(:),         &
         & DComplex3(:), DComplex4(:), DComplex5(:), DComplex6(:), DComplex7(:),     &
         & DComplex8(:), DComplex9(:), DComplex10(:)
    CHARACTER*(*), INTENT(IN), OPTIONAL :: String1(:), String2(:), String3(:), &
         & String4(:), String5(:), String6(:), String7(:), String8(:), String9(:),      &
         & String10(:)

    CHARACTER*(*),INTENT(IN),OPTIONAL :: Headers(:), ColumnLabels(:), FileType
    LOGICAL,INTENT(IN),OPTIONAL :: WriteDataInHeader, ForceNewSection

    INTEGER NumArgs, NumData, iUnit
    LOGICAL IsPresent(10), HeaderData, txt, pad, NewSection
    CHARACTER(80),ALLOCATABLE :: DataArray(:,:)
    CHARACTER(120) DataTypeLine
    CHARACTER(20) IntFormat, RealFormat, DoubleFormat, ComplexFormat, &
         & DComplexFormat, StringFormat, FileAction
    CHARACTER(80) ColumnLabelFormat
    CHARACTER(10) CLFormats(20)
    CHARACTER(4) TmpStr, FlType

    INTEGER i1, i2, NSections, NColumnLabels
    
    ! Initialization
    HeaderData   = .FALSE.
    IsPresent(:) = .FALSE.
    NumArgs      = 0
    txt          = .TRUE.
    pad         = .FALSE.
    DataTypeLine = ''
    CLFormats(:) = ''
    NColumnLabels = 0
    FlType = 'TXT'

    ! Set the type of file. Default is txt.
    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          txt = .TRUE.
          pad = .FALSE.
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          pad = .TRUE.
          txt = .FALSE.
       ELSE
          CALL Error('Error: Illegal file type passed to WriteData')
       END IF
    END IF

    IF(PRESENT(ForceNewSection)) THEN
       NewSection = ForceNewSection
    ELSE
       NewSection = .FALSE.
    END IF

    IF(PRESENT(WriteDataInHeader)) HeaderData = WriteDataInHeader

    ! Open the file.
    CALL OpenFl(FileName, FileStatus = 'REPLACE', FileAction = 'WRITE')

    ! Get the formats for each data type, and the FileAction.
    CALL GetIOFileInfo(FileName, IFormat = IntFormat, RFormat = RealFormat, &
         & DFormat = DoubleFormat, CFormat = ComplexFormat, &
         & DCFormat = DComplexFormat, SFormat = StringFormat, FileAction = FileAction)

    ! Check that this file was not already opened for READ.
    IF(TRIM(FileAction).eq.'READ') THEN 
       CALL Error('Error: file ' // FileName // &
            & ' was already opened for reading.', StopProgram = .FALSE.)
       CALL Error("Please use CALL CloseFl('" // FileName // "') before writing.")
    END IF

    ! Find the 1st argument.
    IF(PRESENT(Int1)) CALL SetArgInt(Int1, 1)
    IF(PRESENT(Real1)) CALL SetArgReal(Real1, 1)
    IF(PRESENT(Double1)) CALL SetArgDouble(Double1, 1)
    IF(PRESENT(Complex1)) CALL SetArgComplex(Complex1, 1)
    IF(PRESENT(DComplex1)) CALL SetArgDComplex(DComplex1, 1)
    IF(PRESENT(String1)) CALL SetArgString(String1, 1)

    ! Find the 2nd argument.
    IF(PRESENT(Int2)) CALL SetArgInt(Int2, 2)
    IF(PRESENT(Real2)) CALL SetArgReal(Real2, 2)
    IF(PRESENT(Double2)) CALL SetArgDouble(Double2, 2)
    IF(PRESENT(Complex2)) CALL SetArgComplex(Complex2, 2)
    IF(PRESENT(DComplex2)) CALL SetArgDComplex(DComplex2, 2)
    IF(PRESENT(String2)) CALL SetArgString(String2, 2)

    ! Find the 3rd argument.
    IF(PRESENT(Int3)) CALL SetArgInt(Int3, 3)
    IF(PRESENT(Real3)) CALL SetArgReal(Real3, 3)
    IF(PRESENT(Double3)) CALL SetArgDouble(Double3, 3)
    IF(PRESENT(Complex3)) CALL SetArgComplex(Complex3, 3)
    IF(PRESENT(DComplex3)) CALL SetArgDComplex(DComplex3, 3)
    IF(PRESENT(String3)) CALL SetArgString(String3, 3)

    ! Find the 4th argument.
    IF(PRESENT(Int4)) CALL SetArgInt(Int4, 4)
    IF(PRESENT(Real4)) CALL SetArgReal(Real4, 4)
    IF(PRESENT(Double4)) CALL SetArgDouble(Double4, 4)
    IF(PRESENT(Complex4)) CALL SetArgComplex(Complex4, 4)
    IF(PRESENT(DComplex4)) CALL SetArgDComplex(DComplex4, 4)
    IF(PRESENT(String4)) CALL SetArgString(String4, 4)

    ! Find the 5th argument.
    IF(PRESENT(Int5)) CALL SetArgInt(Int5, 5)
    IF(PRESENT(Real5)) CALL SetArgReal(Real5, 5)
    IF(PRESENT(Double5)) CALL SetArgDouble(Double5, 5)
    IF(PRESENT(Complex5)) CALL SetArgComplex(Complex5, 5)
    IF(PRESENT(DComplex5)) CALL SetArgDComplex(DComplex5, 5)
    IF(PRESENT(String5)) CALL SetArgString(String5, 5)

    ! Find the 6th argument.
    IF(PRESENT(Int6)) CALL SetArgInt(Int6, 6)
    IF(PRESENT(Real6)) CALL SetArgReal(Real6, 6)
    IF(PRESENT(Double6)) CALL SetArgDouble(Double6, 6)
    IF(PRESENT(Complex6)) CALL SetArgComplex(Complex6, 6)
    IF(PRESENT(DComplex6)) CALL SetArgDComplex(DComplex6, 6)
    IF(PRESENT(String6)) CALL SetArgString(String6, 6)

    ! Find the 7th argument.
    IF(PRESENT(Int7)) CALL SetArgInt(Int7, 7)
    IF(PRESENT(Real7)) CALL SetArgReal(Real7, 7)
    IF(PRESENT(Double7)) CALL SetArgDouble(Double7, 7)
    IF(PRESENT(Complex7)) CALL SetArgComplex(Complex7, 7)
    IF(PRESENT(DComplex7)) CALL SetArgDComplex(DComplex7, 7)
    IF(PRESENT(String7)) CALL SetArgString(String7, 7)

    ! Find the 8th argument.
    IF(PRESENT(Int8)) CALL SetArgInt(Int8, 8)
    IF(PRESENT(Real8)) CALL SetArgReal(Real8, 8)
    IF(PRESENT(Double8)) CALL SetArgDouble(Double8, 8)
    IF(PRESENT(Complex8)) CALL SetArgComplex(Complex8, 8)
    IF(PRESENT(DComplex8)) CALL SetArgDComplex(DComplex8, 8)
    IF(PRESENT(String8)) CALL SetArgString(String8, 8)

    ! Find the 9th argument.
    IF(PRESENT(Int9)) CALL SetArgInt(Int9, 9)
    IF(PRESENT(Real9)) CALL SetArgReal(Real9, 9)
    IF(PRESENT(Double9)) CALL SetArgDouble(Double9, 9)
    IF(PRESENT(Complex9)) CALL SetArgComplex(Complex9, 9)
    IF(PRESENT(DComplex9)) CALL SetArgDComplex(DComplex9, 9)
    IF(PRESENT(String9)) CALL SetArgString(String9, 9)

    ! Find the 10th argument.
    IF(PRESENT(Int10)) CALL SetArgInt(Int10, 10)
    IF(PRESENT(Real10)) CALL SetArgReal(Real10, 10)
    IF(PRESENT(Double10)) CALL SetArgDouble(Double10, 10)
    IF(PRESENT(Complex10)) CALL SetArgComplex(Complex10, 10)
    IF(PRESENT(DComplex10)) CALL SetArgDComplex(DComplex10, 10)
    IF(PRESENT(String10)) CALL SetArgString(String10, 10)

    ! Get the unit number
    CALL GetIOFileInfo(FileName,UnitNumber = iUnit,NSections = NSections)

    ! If data type line is different that last, write a new section header and 
    ! data type line.
    IF(WritingNewSection(FileName,DataTypeLine).or.NewSection) THEN
       NSections = NSections + 1

       WRITE(iUnit,'(A,I4)') '#SN#   Section: ', NSections
       WRITE(iUnit,'(A)') '#DF# This section written in ' // FlType // '.'
       WRITE(iUnit,'(A)') '#H#'

       WRITE(iUnit,'(A)') '#H# The following data types are written in this section.'
       WRITE(iUnit,'(2A)') '#DT# ', TRIM(DataTypeLine)
       CALL SetIOFileInfo(FileName,NSections = NSections, DataTypeLine = TRIM(DataTypeLine))

       ! If headers are present, write them
       IF(PRESENT(Headers)) THEN
          DO i1 = 1, SIZE(Headers)
             IF((LEN_TRIM(Headers(i1)).gt.0).and.(ICHAR(Headers(i1)(1:1)).ne.0)) &
                  & WRITE(iUnit,'(2A)') '#H# ', TRIM(Headers(i1))
          END DO
       END IF

       ! If column labels are present, get the columnlable format and write them.
       IF(PRESENT(ColumnLabels)) THEN
          ColumnLabelFormat = '(A5, '
          DO i1 = 1, NColumnLabels - 1
             ColumnLabelFormat = TRIM(ColumnLabelFormat) // TRIM(CLFormats(i1)) // ', '
          END DO
          ColumnLabelFormat = TRIM(ColumnLabelFormat) // TRIM(CLFormats(NColumnLabels)) // ')'
          WRITE(iUnit,ColumnLabelFormat) '#CL# ', (TRIM(ColumnLabels(i1)) // ' ', i1 = 1, NColumnLabels)
       END IF
       ! If only headers are present, don't update the section or write a data type line.
    ELSEIF(PRESENT(Headers).and.(NumArgs.eq.0)) THEN
       DO i1 = 1, SIZE(Headers)
          IF((LEN_TRIM(Headers(i1)).gt.0).and.(ICHAR(Headers(i1)(1:1)).ne.0)) &
               & WRITE(iUnit,'(2A)') '#H# ', TRIM(Headers(i1))
       END DO
    END IF

    ! Write data line.
    IF(HeaderData) THEN
       DO i1 = 1, NumData
          WRITE(iUnit, '(11A)') '#HD# ', (TRIM(DataArray(i1,i2)) // ' ', i2 = 1, NumArgs)
       END DO
    ELSE
       DO i1 = 1, NumData
          WRITE(iUnit, '(11A)') (TRIM(DataArray(i1,i2)) // ' ', i2 = 1, NumArgs)
       END DO
    END IF

    DEALLOCATE(DataArray)

  CONTAINS

    SUBROUTINE SetArgInt(Arg, iArg)
      INTEGER,INTENT(IN) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg

      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,SIZE(Arg),'Int')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         DO i1 = 1, NumData
            WRITE(DataArray(i1, iArg), IntFormat) Arg(i1)
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL WritePAD(DataArray(i1, iArg),Arg(i1))
         END DO
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         NColumnLabels = NColumnLabels + 1
         IF((iArg.eq.1).and.txt) THEN
            WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(1,iArg)) - 4
         ELSE
            WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(1,iArg)) + 1
         END IF
         CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
      END IF
    END SUBROUTINE SetArgInt

    SUBROUTINE SetArgReal( Arg, iArg)
      REAL,INTENT(IN) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,SIZE(Arg),'Real')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         DO i1 = 1, NumData
            WRITE(DataArray(i1, iArg), RealFormat) Arg(i1)
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL WritePAD(DataArray(i1, iArg), npadrDefault, Arg(i1))
         END DO
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         NColumnLabels = NColumnLabels + 1
         IF((iArg.eq.1).and.txt) THEN
            WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(1,iArg)) - 4
         ELSE
            WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(1,iArg)) + 1
         END IF
         CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
      END IF
    END SUBROUTINE SetArgReal

    SUBROUTINE SetArgDouble( Arg, iArg)
      DOUBLE PRECISION,INTENT(IN) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,SIZE(Arg),'Double')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         DO i1 = 1, NumData
            WRITE(DataArray(i1, iArg), DoubleFormat) Arg(i1)
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL WritePAD(DataArray(i1, iArg), npadxDefault, Arg(i1))
         END DO
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         NColumnLabels = NColumnLabels + 1
         IF((iArg.eq.1).and.txt) THEN
            WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(1,iArg)) - 4
         ELSE
            WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(1,iArg)) + 1
         END IF
         CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
      END IF
    END SUBROUTINE SetArgDouble

    SUBROUTINE SetArgComplex( Arg, iArg)
      COMPLEX,INTENT(IN) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,SIZE(Arg),'Complex')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         DO i1 = 1, NumData
            WRITE(DataArray(i1, iArg), ComplexFormat) REAL(Arg(i1)), IMAG(Arg(i1))
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL WritePAD(DataArray(i1, iArg), npadrDefault, Arg(i1))
         END DO
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         NColumnLabels = NColumnLabels + 2
         IF((iArg.eq.1).and.txt) THEN
            WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(1, iArg))/2) - 4
            CLFormats(NColumnLabels - 1) = 'A' // TRIM(ADJUSTL(TmpStr))
            WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(1, iArg))/2) + 1
            CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
         ELSE
            WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(1, iArg))/2) + 1
            CLFormats(NColumnLabels - 1) = 'A' // TRIM(ADJUSTL(TmpStr))
            CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
         END IF
      END IF
    END SUBROUTINE SetArgComplex

    SUBROUTINE SetArgDComplex( Arg, iArg)
      COMPLEX*16,INTENT(IN) :: Arg(:)
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,SIZE(Arg),'DComplex')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         DO i1 = 1, NumData
            WRITE(DataArray(i1, iArg), DComplexFormat) DBLE(Arg(i1)), DIMAG(Arg(i1))
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            CALL WritePAD(DataArray(i1, iArg), npadxDefault, Arg(i1))
         END DO
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         NColumnLabels = NColumnLabels + 2
         IF((iArg.eq.1).and.txt) THEN
            WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(1, iArg))/2) - 4
            CLFormats(NColumnLabels - 1) = 'A' // TRIM(ADJUSTL(TmpStr))
            WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(1, iArg))/2) + 1
            CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
         ELSE
            WRITE(TmpStr,'(I3)') INT(LEN_TRIM(DataArray(1, iArg))/2) + 1
            CLFormats(NColumnLabels - 1) = 'A' // TRIM(ADJUSTL(TmpStr))
            CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
         END IF
      END IF
    END SUBROUTINE SetArgDComplex

    SUBROUTINE SetArgString( Arg, iArg)
      CHARACTER*(*),INTENT(IN) :: Arg(:)
      CHARACTER(MaxStrLen) TmpStr
      INTEGER,INTENT(IN) :: iArg
      ! Check for errors, increment number of args,
      ! set numdata if this is the first argument, and write data to string
      ! array.
      CALL CheckForErrors(iArg,SIZE(Arg),'String')

      ! Write the data to the character array with the right format.
      ! For now fileformat is txt only.
      IF(txt) THEN
         DO i1 = 1, NumData
            ! Check that the string is not too long.
            TmpStr = TRIM(ADJUSTL(Arg(i1)))
            IF(LEN_TRIM(Arg(i1)).gt.MaxStrLen) CALL Error('Warning: String argument is too long in WriteArrayData. ' // &
                 & 'Will be truncated.' , StopProgram = .FALSE.)
            WRITE(DataArray(i1, iArg), StringFormat) TRIM(TmpStr)
         END DO
      ELSEIF(pad) THEN
         DO i1 = 1, NumData
            ! Check that the string is not too long.
            TmpStr = TRIM(ADJUSTL(Arg(i1)))
            IF(LEN_TRIM(Arg(i1)).gt.MaxStrLen) CALL Error('Warning: String argument is too long in WriteArrayData. ' // &
                 & 'Will be truncated.' , StopProgram = .FALSE.)

            CALL WritePAD(DataArray(i1,iArg),TRIM(TmpStr))
         END DO
      END IF

      ! Set the columnlabel format string
      IF(PRESENT(ColumnLabels)) THEN
         NColumnLabels = NColumnLabels + 1
         IF((iArg.eq.1).and.txt) THEN
            WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(1,iArg)) - 4
         ELSE
            WRITE(TmpStr,'(I3)') LEN_TRIM(DataArray(1,iArg)) + 1
         END IF
         CLFormats(NColumnLabels) = 'A' // TRIM(ADJUSTL(TmpStr))
      END IF
    END SUBROUTINE SetArgString

    SUBROUTINE CheckForErrors(iArg,ArgSize,DTL)
      INTEGER,INTENT(IN) :: iArg, ArgSize
      CHARACTER*(*) DTL
      CHARACTER(2) ArgNum
      INTEGER iAllocateError
      ArgNum=''
      WRITE(ArgNum,'(I2)') iArg

      IF(IsPresent(iArg)) THEN
         CALL Error('Error in WriteData multiple arguments in place ' // TRIM(ArgNum) // '.')
      END IF

      ! Set IsPresent(iArg)
      IsPresent(iArg) = .TRUE.

      ! Check that number of arguments is not too large. Redundant, but oh well.
      IF(NumArgs.ge.iArg) CALL Error('Too many arguments passed to WriteData. Max is 10.')
      NumArgs = NumArgs + 1

      ! If this is the first data argument, set the size of the arrays and allocate space, 
      ! otherwise check that this array is the same size as the first array.        
      IF(iArg.eq.1) THEN
         NumData = ArgSize
         ALLOCATE(DataArray(NumData,10), STAT = iAllocateError)
         CALL CheckAllocation(iAllocateError, 'Error: Failed to allocate space for DataArray' //&
              & ' in subroutine WriteArrayData.')
      ELSE
         IF(NumData.ne.ArgSize) THEN
            CALL Error('Error in writearray: All arrays must be same size.')
         END IF
      END IF

      ! Set data type line
      DataTypeLine = TRIM(DataTypeLine) // ' ' // TRIM(DTL)
    END SUBROUTINE CheckForErrors

  END SUBROUTINE WriteArrayData


  ! SUBROUTINE WriteInt2D writes a 2D integer array to file.
  SUBROUTINE WriteInt2D(FileName,IntArray,Headers, FileType, WriteDataInHeader)
    CHARACTER*(*),INTENT(IN) :: FileName
    INTEGER,INTENT(IN) :: IntArray(:,:)
    CHARACTER*(*),INTENT(IN),OPTIONAL :: Headers(:), FileType
    LOGICAL,INTENT(IN),OPTIONAL :: WriteDataInHeader

    INTEGER iUnit, N1, N2, i1, i2, iError, NSections, iFlType
    CHARACTER(100) IntFormat, DataStr
    CHARACTER(4) FlType
    LOGICAL HeaderData

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)
    
    HeaderData = .FALSE.
    IF(PRESENT(WriteDataInHeader)) HeaderData = WriteDataInHeader

    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          iFlType = ipad
       ELSE
          CALL Error('Illegal FileType passed to Write2D.')
       END IF
    END IF

    CALL OpenFl(FileName)
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, IFormat = IntFormat, &
         & NSections = NSections)

    N1 = SIZE(IntArray,1)
    N2 = SIZE(IntArray,2)

    ! Write the section number.
    WRITE(iUnit,'(A,I4)') '#SN#   Section: ', NSections + 1
    WRITE(iUnit,'(A)') '#DF# This section written in ' // FlType // '.'
    WRITE(iUnit,'(A)') '#H#'

    ! Write info about this array
    WRITE(iUnit,'(A,I4,I4)') '#DT# 2D integer array with sizes ', N1, N2
    WRITE(iUnit,'(A)') '#H# File is organized as follows:  Array(1,i)     Array(1,i+1)    Array(1,i+2)  . . .'
    WRITE(iUnit,'(A)') '#H#                                Array(2,i)'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'

    ! Write headers if they exist
    IF(PRESENT(Headers)) THEN
       CALL WriteData(FileName, Headers = Headers)
    END IF

    ! Write data to file.
    DO i1 = 1, N1
       ! If User has specified that data should be written in the header, do so
       IF(HeaderData.and.(iFlType.eq.itxt)) WRITE(iUnit, '(A)', ADVANCE = 'NO', IOSTAT = iError) '#HD# '
       DO i2 = 1, N2
          IF(iFlType.eq.itxt) THEN
             WRITE(iUnit,IntFormat, ADVANCE = 'NO',IOSTAT = iError) IntArray(i1,i2)
             IF(iError.ne.0) CALL Error('Error in WriteInt2D while trying to write to file: ' //&
                  & FileName)
          ELSEIF(iFlType.eq.ipad) THEN
             CALL WritePAD(DataStr,IntArray(i1,i2))
             WRITE(iUnit,'(A)', ADVANCE = 'NO',IOSTAT = iError) TRIM(DataStr) // ' '
          END IF
       END DO
       WRITE(iUnit,*, IOSTAT = iError)
    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)
  END SUBROUTINE WriteInt2D

  ! SUBROUTINE WriteReal2D writes a 2D integer array to file.
  SUBROUTINE WriteReal2D(FileName,RealArray,Headers,FileType,WriteDataInHeader)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: Headers(:), FileType
    REAL,INTENT(IN) :: RealArray(:,:)
    LOGICAL,INTENT(IN),OPTIONAL :: WriteDataInHeader

    INTEGER iUnit, N1, N2, i1, i2, iError, NSections, iFlType
    CHARACTER(100) RealFormat, IntFormat, DataStr
    CHARACTER(4) FlType
    LOGICAL HeaderData

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)

    HeaderData = .FALSE.
    IF(PRESENT(WriteDataInHeader)) HeaderData = WriteDataInHeader
    
    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          iFlType = ipad
       ELSE
          CALL Error('Illegal FileType passed to Write2D.')
       END IF
    END IF

    CALL OpenFl(FileName)
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, RFormat = RealFormat, &
         & NSections = NSections)

    N1 = SIZE(RealArray,1)
    N2 = SIZE(RealArray,2)

    ! Write the section number.
    WRITE(iUnit,'(A,I4)') '#SN#   Section: ', NSections + 1
    WRITE(iUnit,'(A)') '#DF# This section written in ' // FlType // '.'
    WRITE(iUnit,'(A)') '#H#'

    ! Write some other information
    WRITE(iUnit,'(A,I4,I4)') '#DT# 2D real array with sizes ', N1, N2
    WRITE(iUnit,'(A)') '#H# File is organized as follows:  Array(1,i)     Array(1,i+1)    Array(1,i+2)  . . .'
    WRITE(iUnit,'(A)') '#H#                                Array(2,i)'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'

    ! Write headers if they exist
    IF(PRESENT(Headers)) THEN
       CALL WriteData(FileName, Headers = Headers)
    END IF

    ! Write the data.
    DO i1 = 1, N1
       ! If User has specified that data should be written in the header, do so
       IF(HeaderData.and.(iFlType.eq.itxt)) WRITE(iUnit, '(A)', ADVANCE = 'NO', IOSTAT = iError) '#HD# '
       DO i2 = 1, N2
          IF(iFlType.eq.itxt) THEN
             WRITE(iUnit,RealFormat, ADVANCE = 'NO',IOSTAT = iError) RealArray(i1,i2)
             IF(iError.ne.0) CALL Error('Error in WriteReal2D while trying to write to file: ' //&
                  & FileName)
          ELSEIF(iFlType.eq.ipad) THEN
             CALL WritePAD(DataStr,npadrDefault,RealArray(i1,i2))
             WRITE(iUnit,'(A)', ADVANCE = 'NO',IOSTAT = iError) TRIM(DataStr) // ' '
             IF(iError.ne.0) CALL Error('Error in WriteReal2D while trying to write to file: ' //&
                  & FileName)
          END IF
       END DO
       WRITE(iUnit,*, IOSTAT = iError)
    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)
  END SUBROUTINE WriteReal2D

  ! SUBROUTINE WriteReal2D writes a 2D integer array to file.
  SUBROUTINE WriteDouble2D(FileName,DoubleArray,Headers,FileType,WriteDataInHeader)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: Headers(:), FileType
    DOUBLE PRECISION,INTENT(IN) :: DoubleArray(:,:)
    LOGICAL,INTENT(IN),OPTIONAL :: WriteDataInHeader

    INTEGER iUnit, N1, N2, i1, i2, iError, NSections, iFlType
    CHARACTER(100) DoubleFormat, IntFormat, DataStr
    CHARACTER(4) FlType
    LOGICAL HeaderData

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)

    HeaderData = .FALSE.
    IF(PRESENT(WriteDataInHeader)) HeaderData = WriteDataInHeader

    iFlType = 1
    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          iFlType = ipad
       ELSE
          CALL Error('Illegal FileType passed to Write2D.')
       END IF
    END IF

    CALL OpenFl(FileName)
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, DFormat = DoubleFormat, &
         & NSections = NSections)

    N1 = SIZE(DoubleArray,1)
    N2 = SIZE(DoubleArray,2)

    ! Write the section number.
    WRITE(iUnit,'(A,I4)') '#SN#   Section: ', NSections + 1
    WRITE(iUnit,'(A)') '#DF# This section written in ' // FlType // '.'
    WRITE(iUnit,'(A)') '#H#'

    ! Write some other information
    WRITE(iUnit,'(A,I4,I4)') '#DT# 2D double array with sizes ', N1, N2
    WRITE(iUnit,'(A)') '#H# File is organized as follows:  Array(1,i)     Array(1,i+1)    Array(1,i+2)  . . .'
    WRITE(iUnit,'(A)') '#H#                                Array(2,i)'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'

    ! Write headers if they exist
    IF(PRESENT(Headers)) THEN
       CALL WriteData(FileName, Headers = Headers)
    END IF

    ! Write the data.
    DO i1 = 1, N1
       ! If User has specified that data should be written in the header, do so
       IF(HeaderData.and.(iFlType.eq.itxt)) WRITE(iUnit, '(A)', ADVANCE = 'NO', IOSTAT = iError) '#HD# '
       DO i2 = 1, N2
          IF(iFlType.eq.itxt) THEN
             WRITE(iUnit,DoubleFormat,IOSTAT = iError, ADVANCE = 'NO') DoubleArray(i1,i2)
             IF(iError.ne.0) CALL Error('Error in WriteReal2D while trying to write to file: ' //&
                  & FileName)
          ELSEIF(iFlType.eq.ipad) THEN
             CALL WritePAD(DataStr,npadxDefault,DoubleArray(i1,i2))
             WRITE(iUnit,'(A)',IOSTAT = iError, ADVANCE = 'NO') TRIM(DataStr) // ' '
             IF(iError.ne.0) CALL Error('Error in WriteReal2D while trying to write to file: ' //&
                  & FileName)
          END IF
       END DO
       WRITE(iUnit,*)
    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)
  END SUBROUTINE WriteDouble2D

  ! SUBROUTINE WriteComplex2D writes a 2D integer array to file.
  SUBROUTINE WriteComplex2D(FileName,ComplexArray,Headers,FileType,WriteDataInHeader)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: Headers(:), FileType
    COMPLEX,INTENT(IN) :: ComplexArray(:,:)
    LOGICAL,INTENT(IN),OPTIONAL :: WriteDataInHeader

    INTEGER iUnit, N1, N2, i1, i2, iError, NSections, iFlType
    CHARACTER(100) ComplexFormat, IntFormat, DataStr
    CHARACTER(4) FlType
    LOGICAL HeaderData

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)

    HeaderData = .FALSE.
    IF(PRESENT(WriteDataInHeader)) HeaderData = WriteDataInHeader
    
    iFlType = itxt
    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          iFlType = ipad
       ELSE
          CALL Error('Illegal FileType passed to Write2D.')
       END IF
    END IF

    CALL OpenFl(FileName)
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, CFormat = ComplexFormat, &
         & NSections = NSections)

    N1 = SIZE(ComplexArray,1)
    N2 = SIZE(ComplexArray,2)
    ! Write the section number.
    WRITE(iUnit,'(A,I4)') '#SN#   Section: ', NSections + 1
    WRITE(iUnit,'(A)') '#DF# This section written in ' // FlType // '.'
    WRITE(iUnit,'(A)') '#H#'

    ! Write some other information
    WRITE(iUnit,'(A,I4,I4)') '#DT# 2D complex array with sizes ', N1, N2
    WRITE(iUnit,'(A)') '#H# File is organized as follows:  Array(1,i)     Array(1,i+1)    Array(1,i+2)  . . .'
    WRITE(iUnit,'(A)') '#H#                                Array(2,i)'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'

    ! Write headers if they exist
    IF(PRESENT(Headers)) THEN
       CALL WriteData(FileName, Headers = Headers)
    END IF

    ! Write the data.
    DO i1 = 1, N1
       ! If User has specified that data should be written in the header, do so
       IF(HeaderData.and.(iFlType.eq.itxt)) WRITE(iUnit, '(A)', ADVANCE = 'NO', IOSTAT = iError) '#HD# '
       DO i2 = 1, N2
          IF(iFlType.eq.itxt) THEN
             WRITE(iUnit,ComplexFormat, ADVANCE = 'NO',IOSTAT = iError) REAL(ComplexArray(i1,i2)),  &
                  & IMAG(ComplexArray(i1,i2))
             IF(iError.ne.0) CALL Error('Error in WriteComplex2D while trying to write to file: ' //&
                  & FileName)
          ELSEIF(iFlType.eq.ipad) THEN
             CALL WritePAD(DataStr,npadrDefault,ComplexArray(i1,i2))
             WRITE(iUnit,'(A)', ADVANCE = 'NO',IOSTAT = iError) TRIM(DataStr) // ' '
             IF(iError.ne.0) CALL Error('Error in WriteReal2D while trying to write to file: ' //&
                  & FileName)
          END IF
       END DO
       WRITE(iUnit,*, IOSTAT = iError)
    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)
  END SUBROUTINE WriteComplex2D

  ! SUBROUTINE WriteDComplex2D writes a 2D integer array to file.
  SUBROUTINE WriteDComplex2D(FileName,DComplexArray,Headers,FileType,WriteDataInHeader)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: Headers(:), FileType
    COMPLEX*16,INTENT(IN) :: DComplexArray(:,:)
    LOGICAL,INTENT(IN),OPTIONAL :: WriteDataInHeader

    INTEGER iUnit, N1, N2, i1, i2, iError, NSections, iFlType
    CHARACTER(100) DComplexFormat, DataStr
    CHARACTER(4) FlType
    LOGICAL HeaderData

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)

    HeaderData = .FALSE.
    IF(PRESENT(WriteDataInHeader)) HeaderData = WriteDataInHeader
    
    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          iFlType = ipad
       ELSE
          CALL Error('Illegal FileType passed to Write2D.')
       END IF
    END IF

    CALL OpenFl(FileName)
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, DCFormat = DComplexFormat, &
         & NSections = NSections)

    N1 = SIZE(DComplexArray,1)
    N2 = SIZE(DComplexArray,2)

    ! Write the section number.
    WRITE(iUnit,'(A,I4)') '#SN#   Section: ', NSections + 1
    WRITE(iUnit,'(A)') '#DF# This section written in ' // FlType // '.'
    WRITE(iUnit,'(A)') '#H#'

    ! Write some other information
    WRITE(iUnit,'(A,I4,I4)') '#DT# 2D double complex array with sizes ', N1, N2
    WRITE(iUnit,'(A,I4,I4)') '#DT# 2D complex array with sizes ', N1, N2
    WRITE(iUnit,'(A)') '#H# File is organized as follows:  Array(1,i)     Array(1,i+1)    Array(1,i+2)  . . .'
    WRITE(iUnit,'(A)') '#H#                                Array(2,i)'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'

    ! Write headers if they exist
    IF(PRESENT(Headers)) THEN
       CALL WriteData(FileName, Headers = Headers)
    END IF

    ! Write the data.
    DO i1 = 1, N1
       ! If User has specified that data should be written in the header, do so
       IF(HeaderData.and.(iFlType.eq.itxt)) WRITE(iUnit, '(A)', ADVANCE = 'NO', IOSTAT = iError) '#HD# '
       DO i2 = 1, N2
          IF(iFlType.eq.itxt) THEN
             WRITE(iUnit,DComplexFormat, ADVANCE = 'NO',IOSTAT = iError) DBLE(DComplexArray(i1,i2)),  &
                  & DIMAG(DComplexArray(i1,i2))
             IF(iError.ne.0) CALL Error('Error in WriteDComplex2D while trying to write to file: ' // &
                  & FileName)
          ELSEIF(iFlType.eq.ipad) THEN
             CALL WritePAD(DataStr,npadrDefault,DComplexArray(i1,i2))
             WRITE(iUnit,'(A)', ADVANCE = 'NO',IOSTAT = iError) TRIM(DataStr) // ' '
             IF(iError.ne.0) CALL Error('Error in WriteReal2D while trying to write to file: ' //&
                  & FileName)
          END IF
       END DO
       WRITE(iUnit,*, IOSTAT = iError)
    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)
  END SUBROUTINE WriteDComplex2D

  ! SUBROUTINE WriteString2D writes a 2D integer array to file.
  SUBROUTINE WriteString2D(FileName,StringArray,Headers,FileType,WriteDataInHeader)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: Headers(:), FileType
    CHARACTER*(*),INTENT(IN) :: StringArray(:,:)
    LOGICAL,INTENT(IN),OPTIONAL :: WriteDataInHeader

    INTEGER iUnit, N1, N2, i1, i2, iError, NSections
    CHARACTER(100) StringFormat
    CHARACTER(4) FlType
    INTEGER iFlType
    LOGICAL HeaderData

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)

    iFlType = 1
    HeaderData = .FALSE.
    IF(PRESENT(WriteDataInHeader)) HeaderData = WriteDataInHeader
    
    CALL OpenFl(FileName)
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, SFormat = StringFormat, &
         & NSections = NSections)

    N1 = SIZE(StringArray,1)
    N2 = SIZE(StringArray,2)

    ! Write the section number.
    WRITE(iUnit,'(A,I4)') '#SN#   Section: ', NSections + 1
    WRITE(iUnit,'(A)') '#H#'

    ! Write some other information
    WRITE(iUnit,'(A,I4,I4)') '#DT# 2D double complex array with sizes ', N1, N2
    WRITE(iUnit,'(A,I4,I4)') '#DT# 2D double complex array with sizes ', N1, N2
    WRITE(iUnit,'(A,I4,I4)') '#DT# 2D complex array with sizes ', N1, N2
    WRITE(iUnit,'(A)') '#H# File is organized as follows:  Array(1,i)     Array(1,i+1)    Array(1,i+2)  . . .'
    WRITE(iUnit,'(A)') '#H#                                Array(2,i)'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'
    WRITE(iUnit,'(A)') '#H#                                     .'

    ! Write headers if they exist
    IF(PRESENT(Headers)) THEN
       CALL WriteData(FileName, Headers = Headers)
    END IF

    ! Write the data.
    DO i1 = 1, N1
       ! If User has specified that data should be written in the header, do so
       IF(HeaderData.and.(iFlType.eq.itxt)) WRITE(iUnit, '(A)', ADVANCE = 'NO', IOSTAT = iError) '#HD# '
       DO i2 = 1, N2
          WRITE(iUnit,StringFormat, ADVANCE = 'NO',IOSTAT = iError) TRIM(ADJUSTL(StringArray(i1,i2)))
          IF(iError.ne.0) CALL Error('Error in WriteString2D while trying to write to file: ' //&
               & FileName)

          ! Write some space between elements
          WRITE(iUnit,'(A)', ADVANCE = 'NO') '  '
       END DO
       WRITE(iUnit,*, IOSTAT = iError)
    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)
  END SUBROUTINE WriteString2D

  ! SUBROUTINE ReadInt2D reads a 2D integer array from file.
  SUBROUTINE ReadInt2D(FileName,IntArray, N1, N2, SectionNumber, Headers, ReadDataFromHeader, &
       & FileType, CommentCharacters)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Input: 
    ! FileName          - name of file to read.
    ! FileType          - 'PAD' or 'TXT'
    ! CommentCharacters - string of characters, any of which can signify a header line. By default
    !                     'TXT' headers start with '#', '!', 'c', 'C', or '*'. When reading 'PAD' data
    !                     comment character is '#' only.
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: FileType, CommentCharacters
    INTEGER,INTENT(IN),OPTIONAL :: SectionNumber
    LOGICAL,INTENT(IN),OPTIONAL :: ReadDataFromHeader
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Output:
    ! Headers           - Read header lines into this variable.
    ! IntArray       - Holds data read from file.
    ! N1, N2            - Dimensions of the array as read from file.
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Headers(:)
    INTEGER,INTENT(OUT) :: IntArray(:,:)
    INTEGER,INTENT(OUT) :: N1, N2

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Local Variables:
    ! iUnit        - unit number of the file.
    ! iError       - error code passed back from read.
    ! NSections    - Current section of file.
    ! iFlType      - index of file type. (1 = txt, 2 = pad)
    ! NE1, NE2     - used to hold the dimensions of the array as read from file.
    ! Length       - Length of the current word.
    ! IntFormat - Format to use for double precision data.
    ! CmtChars     - Holds string of possible comment characters.
    ! DataTypeLine - Holds the type of data being read from file, if defined.
    ! DataStr      - Holds the current word as read from file.
    ! FlType       - Holds the file type ('TXT' or 'PAD').
    ! EOF/EOR      - True if end of file/record has been reached
    ! IsHead       - True if a comment character has been found at beginning of line.
    INTEGER iUnit, iError, NSections, iFlType, NE1, NE2, Length
    CHARACTER(100) IntFormat, CmtChars, DataTypeLine
    CHARACTER(40) DataStr
    CHARACTER(4) FlType
    LOGICAL EOF, EOR, IsHeader, HeaderData
 
    ! Loop Variables: 
    INTEGER i1, i2

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)
    
    ! Initialization
    NE1 = 0
    NE2 = 0
    
    HeaderData = .FALSE.
    IF(PRESENT(ReadDataFromHeader)) HeaderData = ReadDataFromHeader

    IF(PRESENT(SectionNumber)) THEN
       CALL ReadToSection(FileName, SectionNumber)
    END IF

    iFlType = iFileTypeDefault
    IF(PRESENT(CommentCharacters)) THEN 
       CmtChars = CommentCharacters
    ELSE
       CmtChars = DefaultCommentCharacters
    END IF

    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          ! If filetype is 'PAD' comment characters must be '#' only.
          iFlType = ipad
          CmtChars='#'
       ELSE
          CALL Error('Illegal FileType passed to Write2D.')
       END IF
    END IF
    ! End Initialization

    ! Open the file for reading.
    CALL OpenFl(FileName, FileAction = 'READ')

    ! Get some info about the file.
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, IFormat = IntFormat, &
         & NSections = NSections)

    ! Set the maximum size of the array to be read.
    N1 = SIZE(IntArray,1)
    N2 = SIZE(IntArray,2)

    ! Read headers and save if Headers has been passed.
    IF(PRESENT(Headers)) THEN
       CALL ReadHeaders(FileName, DataStr, CommentCharacters = CmtChars, Headers = Headers)
    ELSE
       CALL ReadHeaders(FileName, DataStr, CommentCharacters = CmtChars)
    END IF

    ! Backspace since ReadHeaders reads one line passed the last header.
    BACKSPACE(iUnit)

    ! Loop over dimensions of the array.
    DO i1 = 1, N1
       DO i2 = 1, N2

          ! Read the next word from the file and save in DataStr
          CALL ReadNextWord(iUnit,DataStr,Length,IsHeader,EOR,EOF,CmtChars)

          ! If end of file, set EOF and return.
          IF(EOF) THEN
             CALL SetIOFileInfo(FileName, EOF = EOF)
             RETURN
          END IF

          ! If this is a header line backspace and read headers.
          IF(IsHeader) THEN
             BACKSPACE(iUnit)
             CALL ReadHeaders(FileName, DataStr, CommentCharacters = CmtChars)
             
             ! Check if we are reading a new section. If so, return.
             IF(ReadingNewSection(FileName, NSections)) RETURN
          END IF

          ! If line is not blank, set the data array element.
          IF(Length.gt.0) THEN
             IF(iFlType.eq.itxt) THEN
                READ(DataStr(1:Length),FMT=*,IOSTAT = iError) IntArray(i1,i2)
                IF(iError.ne.0) CALL Error('Error in Read2D while trying to read from file: ' //&
                     & FileName)
             ELSEIF(iFlType.eq.ipad) THEN
                IF(Length.gt.0) CALL ReadPAD(DataStr(1:Length),IntArray(i1,i2))
             END IF

             ! Set dimension 2.
             NE2 = i2
          END IF

          ! If end of record reached, exit this loop.
          IF(EOR) EXIT

       END DO

       ! Advance to the next line.
       IF(.not.EOR) READ(iUnit,*,END=20)              

       ! Set dimension 1
       N1 = i1

    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)

    ! End of file reached.
20  CONTINUE
    CALL SetIOFileInfo(FileName, EOF = .TRUE.)
  END SUBROUTINE ReadInt2D


  ! SUBROUTINE ReadReal2D reads a 2D integer array from file.
  SUBROUTINE ReadReal2D(FileName,RealArray, N1, N2, SectionNumber, Headers, ReadDataFromHeader, &
       & FileType, CommentCharacters)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Input: 
    ! FileName          - name of file to read.
    ! FileType          - 'PAD' or 'TXT'
    ! CommentCharacters - string of characters, any of which can signify a header line. By default
    !                     'TXT' headers start with '#', '!', 'c', 'C', or '*'. When reading 'PAD' data
    !                     comment character is '#' only.
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: FileType, CommentCharacters
    INTEGER,INTENT(IN),OPTIONAL :: SectionNumber
    LOGICAL,INTENT(IN),OPTIONAL :: ReadDataFromHeader
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Output:
    ! Headers           - Read header lines into this variable.
    ! RealArray       - Holds data read from file.
    ! N1, N2            - Dimensions of the array as read from file.
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Headers(:)
    REAL,INTENT(OUT) :: RealArray(:,:)
    INTEGER,INTENT(OUT) :: N1, N2

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Local Variables:
    ! iUnit        - unit number of the file.
    ! iError       - error code passed back from read.
    ! NSections    - Current section of file.
    ! iFlType      - index of file type. (1 = txt, 2 = pad)
    ! NE1, NE2     - used to hold the dimensions of the array as read from file.
    ! Length       - Length of the current word.
    ! RealFormat - Format to use for double precision data.
    ! CmtChars     - Holds string of possible comment characters.
    ! DataTypeLine - Holds the type of data being read from file, if defined.
    ! DataStr      - Holds the current word as read from file.
    ! FlType       - Holds the file type ('TXT' or 'PAD').
    ! EOF/EOR      - True if end of file/record has been reached
    ! IsHead       - True if a comment character has been found at beginning of line.
    INTEGER iUnit, iError, NSections, iFlType, NE1, NE2, Length
    CHARACTER(100) RealFormat, CmtChars, DataTypeLine
    CHARACTER(40) DataStr
    CHARACTER(4) FlType
    LOGICAL EOF, EOR, IsHeader, HeaderData
 
    ! Loop Variables: 
    INTEGER i1, i2

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)
    
    ! Initialization
    NE1 = 0
    NE2 = 0

    HeaderData = .FALSE.
    IF(PRESENT(ReadDataFromHeader)) HeaderData = ReadDataFromHeader

    IF(PRESENT(SectionNumber)) THEN
       CALL ReadToSection(FileName, SectionNumber)
    END IF

    iFlType = iFileTypeDefault
    IF(PRESENT(CommentCharacters)) THEN 
       CmtChars = CommentCharacters
    ELSE
       CmtChars = DefaultCommentCharacters
    END IF

    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          ! If filetype is 'PAD' comment characters must be '#' only.
          iFlType = ipad
          CmtChars='#'
       ELSE
          CALL Error('Illegal FileType passed to Write2D.')
       END IF
    END IF
    ! End Initialization

    ! Open the file for reading.
    CALL OpenFl(FileName, FileAction = 'READ')

    ! Get some info about the file.
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, RFormat = RealFormat, &
         & NSections = NSections)

    ! Set the maximum size of the array to be read.
    N1 = SIZE(RealArray,1)
    N2 = SIZE(RealArray,2)

    ! Read headers and save if Headers has been passed.
    IF(PRESENT(Headers)) THEN
       CALL ReadHeaders(FileName, DataStr, CommentCharacters = CmtChars, Headers = Headers)
    ELSE
       CALL ReadHeaders(FileName, DataStr, CommentCharacters = CmtChars)
    END IF

    ! Backspace since ReadHeaders reads one line passed the last header.
    BACKSPACE(iUnit)

    ! Loop over dimensions of the array.
    DO i1 = 1, N1
       DO i2 = 1, N2

          ! Read the next word from the file and save in DataStr
          CALL ReadNextWord(iUnit,DataStr,Length,IsHeader,EOR,EOF,CmtChars)

          ! If end of file, set EOF and return.
          IF(EOF) THEN
             CALL SetIOFileInfo(FileName, EOF = EOF)
             RETURN
          END IF

          ! If this is a header line backspace and read headers.
          IF(IsHeader) THEN
             BACKSPACE(iUnit)
             CALL ReadHeaders(FileName, DataStr, CommentCharacters = CmtChars)
             
             ! Check if we are reading a new section. If so, return.
             IF(ReadingNewSection(FileName, NSections)) RETURN
          END IF

          ! If line is not blank, set the data array element.
          IF(Length.gt.0) THEN
             IF(iFlType.eq.itxt) THEN
                READ(DataStr(1:Length),FMT=*,IOSTAT = iError) RealArray(i1,i2)
                IF(iError.ne.0) CALL Error('Error in Read2D while trying to write to file: ' //&
                     & FileName)
             ELSEIF(iFlType.eq.ipad) THEN
                IF(Length.gt.0) CALL ReadPAD(DataStr(1:Length),npadrDefault,RealArray(i1,i2))
             END IF

             ! Set dimension 2.
             NE2 = i2
          END IF

          ! If end of record reached, exit this loop.
          IF(EOR) EXIT

       END DO

       ! Advance to the next line.
       IF(.not.EOR) READ(iUnit,*,END=20)              

       ! Set dimension 1
       N1 = i1

    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)

    ! End of file reached.
20  CONTINUE
    CALL SetIOFileInfo(FileName, EOF = .TRUE.)
  END SUBROUTINE ReadReal2D


  ! SUBROUTINE ReadDouble2D reads a 2D integer array from file.
  SUBROUTINE ReadDouble2D(FileName,DoubleArray, N1, N2, SectionNumber,  Headers, ReadDataFromHeader,&
       & FileType, CommentCharacters)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Input: 
    ! FileName          - name of file to read.
    ! FileType          - 'PAD' or 'TXT'
    ! CommentCharacters - string of characters, any of which can signify a header line. By default
    !                     'TXT' headers start with '#', '!', 'c', 'C', or '*'. When reading 'PAD' data
    !                     comment character is '#' only.
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: FileType, CommentCharacters
    INTEGER,INTENT(IN),OPTIONAL :: SectionNumber
    LOGICAL,INTENT(IN),OPTIONAL :: ReadDataFromHeader
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Output:
    ! Headers           - Read header lines into this variable.
    ! DoubleArray       - Holds data read from file.
    ! N1, N2            - Dimensions of the array as read from file.
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Headers(:)
    DOUBLE PRECISION,INTENT(OUT) :: DoubleArray(:,:)
    INTEGER,INTENT(OUT) :: N1, N2

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Local Variables:
    ! iUnit        - unit number of the file.
    ! iError       - error code passed back from read.
    ! NSections    - Current section of file.
    ! iFlType      - index of file type. (1 = txt, 2 = pad)
    ! NE1, NE2     - used to hold the dimensions of the array as read from file.
    ! Length       - Length of the current word.
    ! DoubleFormat - Format to use for double precision data.
    ! CmtChars     - Holds string of possible comment characters.
    ! DataTypeLine - Holds the type of data being read from file, if defined.
    ! DataStr      - Holds the current word as read from file.
    ! FlType       - Holds the file type ('TXT' or 'PAD').
    ! EOF/EOR      - True if end of file/record has been reached
    ! IsHead       - True if a comment character has been found at beginning of line.
    INTEGER iUnit, iError, NSections, iFlType, NE1, NE2, Length
    CHARACTER(100) DoubleFormat, CmtChars, DataTypeLine
    CHARACTER(40) DataStr
    CHARACTER(200) line
    CHARACTER(4) FlType
    LOGICAL EOF, EOR, IsHeader, HeaderData
 
    ! Loop Variables: 
    INTEGER i1, i2

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)
    
    ! Initialization
    NE1 = 0
    NE2 = 0

    HeaderData = .FALSE.
    IF(PRESENT(ReadDataFromHeader)) HeaderData = ReadDataFromHeader

    IF(PRESENT(SectionNumber)) THEN
       CALL ReadToSection(FileName, SectionNumber)
    END IF

    iFlType = iFileTypeDefault
    IF(PRESENT(CommentCharacters)) THEN 
       CmtChars = CommentCharacters
    ELSE
       CmtChars = DefaultCommentCharacters
    END IF

    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          ! If filetype is 'PAD' comment characters must be '#' only.
          iFlType = ipad
          CmtChars='#'
       ELSE
          CALL Error('Illegal FileType passed to Read2D.')
       END IF
    END IF
    ! End Initialization

    ! Open the file for reading.
    CALL OpenFl(FileName, FileAction = 'READ')

    ! Get some info about the file.
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, DFormat = DoubleFormat, &
         & NSections = NSections)

    ! Set the maximum size of the array to be read.
    N1 = SIZE(DoubleArray,1)
    N2 = SIZE(DoubleArray,2)

    ! Read headers and save if Headers has been passed.
    IF(PRESENT(Headers)) THEN
       CALL ReadHeaders(FileName, line, CommentCharacters = CmtChars, Headers = Headers)
    ELSE
       CALL ReadHeaders(FileName, line, CommentCharacters = CmtChars)
    END IF

    ! Backspace since ReadHeaders reads one line passed the last header.
    BACKSPACE(iUnit)

    ! Loop over dimensions of the array.
    DO i1 = 1, N1
       DO i2 = 1, N2

          ! Read the next word from the file and save in DataStr
          CALL ReadNextWord(iUnit,DataStr,Length,IsHeader,EOR,EOF,CmtChars)

          ! If end of file, set EOF and return.
          IF(EOF) THEN
!             CALL SetIOError('Array_Too_Small')
             CALL SetIOFileInfo(FileName, EOF = EOF)
             RETURN
          END IF
          
          ! If this is a header line backspace and read headers.
          IF(IsHeader) THEN
             BACKSPACE(iUnit)
             CALL ReadHeaders(FileName, line, CommentCharacters = CmtChars)
             
             ! Check if we are reading a new section. If so, return.
             IF(ReadingNewSection(FileName, NSections)) THEN
                RETURN
             ELSE
                ! Set Comment_Error to true. By default, this will produce a warning.
                CALL Error('Unexpected comment character found in file ' // FileName // '.')
                CALL Error(line)
             END IF
          END IF

          ! If line is not blank, set the data array element.
          IF(Length.gt.0) THEN
             IF(iFlType.eq.itxt) THEN
                READ(DataStr(1:Length),FMT=*,IOSTAT = iError) DoubleArray(i1,i2)
                IF(iError.ne.0) CALL Error('Error in Read2D while trying to write to file: ' //&
                     & FileName)
             ELSEIF(iFlType.eq.ipad) THEN
                IF(Length.gt.0) CALL ReadPAD(DataStr(1:Length),npadrDefault,DoubleArray(i1,i2))
             END IF

             ! Set dimension 2.
             NE2 = i2
          END IF

          ! If end of record reached, exit this loop.
          IF(EOR) EXIT

       END DO

       ! Advance to the next line if needed.
       IF(.not.EOR) READ(iUnit,*,END=20)              

       ! Set dimension 1
       N1 = i1

    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)

    RETURN
    ! End of file reached.
20  CONTINUE
    CALL SetIOFileInfo(FileName, EOF = .TRUE.)
  END SUBROUTINE ReadDouble2D


  ! SUBROUTINE ReadComplex2D reads a 2D integer array from file.
  SUBROUTINE ReadComplex2D(FileName,ComplexArray, N1, N2, SectionNumber, Headers, ReadDataFromHeader, &
       & FileType, CommentCharacters)
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Input: 
    ! FileName          - name of file to read.
    ! FileType          - 'PAD' or 'TXT'
    ! CommentCharacters - string of characters, any of which can signify a header line. By default
    !                     'TXT' headers start with '#', '!', 'c', 'C', or '*'. When reading 'PAD' data
    !                     comment character is '#' only.
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: FileType, CommentCharacters
    INTEGER,INTENT(IN),OPTIONAL :: SectionNumber
    LOGICAL,INTENT(IN),OPTIONAL :: ReadDataFromHeader
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Output:
    ! Headers           - Read header lines into this variable.
    ! ComplexArray       - Holds data read from file.
    ! N1, N2            - Dimensions of the array as read from file.
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Headers(:)
    COMPLEX,INTENT(OUT) :: ComplexArray(:,:)
    INTEGER,INTENT(OUT) :: N1, N2

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    ! Local Variables:
    ! iUnit        - unit number of the file.
    ! iError       - error code passed back from read.
    ! NSections    - Current section of file.
    ! iFlType      - index of file type. (1 = txt, 2 = pad)
    ! NE1, NE2     - used to hold the dimensions of the array as read from file.
    ! Length       - Length of the current word.
    ! ComplexFormat - Format to use for double precision data.
    ! CmtChars     - Holds string of possible comment characters.
    ! DataTypeLine - Holds the type of data being read from file, if defined.
    ! DataStr      - Holds the current word as read from file.
    ! FlType       - Holds the file type ('TXT' or 'PAD').
    ! EOF/EOR      - True if end of file/record has been reached
    ! IsHead       - True if a comment character has been found at beginning of line.
    REAL ReData, ImData
    INTEGER iUnit, iError, NSections, iFlType, NE1, NE2, ReLength, ImLength
    CHARACTER(100) ComplexFormat, CmtChars, DataTypeLine
    CHARACTER(40) ReDataStr, ImDataStr
    CHARACTER(4) FlType
    LOGICAL EOF, EOR, IsHeader, HeaderData
 
    ! Loop Variables: 
    INTEGER i1, i2

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)
    
    ! Initialization
    NE1 = 0
    NE2 = 0

    HeaderData = .FALSE.
    IF(PRESENT(ReadDataFromHeader)) HeaderData = ReadDataFromHeader

    IF(PRESENT(SectionNumber)) THEN
       CALL ReadToSection(FileName, SectionNumber)
    END IF

    iFlType = iFileTypeDefault
    IF(PRESENT(CommentCharacters)) THEN 
       CmtChars = CommentCharacters
    ELSE
       CmtChars = DefaultCommentCharacters
    END IF

    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          ! If filetype is 'PAD' comment characters must be '#' only.
          iFlType = ipad
          CmtChars='#'
       ELSE
          CALL Error('Illegal FileType passed to Write2D.')
       END IF
    END IF
    ! End Initialization

    ! Open the file for reading.
    CALL OpenFl(FileName, FileAction = 'READ')

    ! Get some info about the file.
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, CFormat = ComplexFormat, &
         & NSections = NSections)

    ! Set the maximum size of the array to be read.
    N1 = SIZE(ComplexArray,1)
    N2 = SIZE(ComplexArray,2)

    ! Read headers and save if Headers has been passed.
    IF(PRESENT(Headers)) THEN
       CALL ReadHeaders(FileName, ReDataStr, CommentCharacters = CmtChars, Headers = Headers)
    ELSE
       CALL ReadHeaders(FileName, ReDataStr, CommentCharacters = CmtChars)
    END IF

    ! Backspace since ReadHeaders reads one line passed the last header.
    BACKSPACE(iUnit)

    ! Loop over dimensions of the array.
    DO i1 = 1, N1
       DO i2 = 1, N2
          ! Read the next word from the file and save in ReDataStr
          CALL ReadNextWord(iUnit,ReDataStr,ReLength,IsHeader,EOR,EOF,CmtChars)
          IF(EOF.or.EOR) CALL Error('Error: Unexpected end of record while reading from ' // FileName // '.')
          ! Read the next word from the file and save in ImDataStr
          CALL ReadNextWord(iUnit,ImDataStr,ImLength,IsHeader,EOR,EOF,CmtChars)

          ! If end of file, set EOF and return.
          IF(EOF) THEN
             CALL SetIOFileInfo(FileName, EOF = EOF)
             RETURN
          END IF

          ! If this is a header line backspace and read headers.
          IF(IsHeader) THEN
             BACKSPACE(iUnit)
             CALL ReadHeaders(FileName, ReDataStr, CommentCharacters = CmtChars)
             
             ! Check if we are reading a new section. If so, return.
             IF(ReadingNewSection(FileName, NSections)) RETURN
          END IF

          ! If line is not blank, set the data array element.
          IF(iFlType.eq.itxt) THEN
             IF(ReLength.gt.0) THEN
                READ(ReDataStr(1:ReLength),FMT=*, iostat = iError) ReData
                IF(iError.ne.0) CALL Error('Error in Read2D while trying to read to file: ' //&
                     & FileName)
             END IF
             IF(ImLength.gt.0) THEN
                READ(ImDataStr(1:ImLength),FMT=*, iostat = iError) ImData
                IF(iError.ne.0) CALL Error('Error in Read2D while trying to read to file: ' //&
                     & FileName)
             ENDIF
          ELSEIF(iFlType.eq.ipad) THEN
             IF(ReLength.gt.0) CALL ReadPAD(ReDataStr(1:ReLength),npadrDefault,ReData)
             IF(ImLength.gt.0) CALL ReadPAD(ImDataStr(1:ImLength),npadrDefault,ImData)
          END IF

          ! Set the data array.
          ComplexArray(i1,i2) = ReData + (0.0,1.0)*ImData

          ! Set dimension 2.
          NE2 = i2
          
          ! If end of record reached, exit this loop.
          IF(EOR) EXIT

       END DO

       ! Advance to the next line.
       IF(.not.EOR) READ(iUnit,*,END=20)              

       ! Set dimension 1
       N1 = i1

    END DO

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)

    ! End of file reached.
20  CONTINUE
    CALL SetIOFileInfo(FileName, EOF = .TRUE.)
  END SUBROUTINE ReadComplex2D


  ! SUBROUTINE ReadInt2D reads a 2D integer array from file.
  SUBROUTINE ReadDComplex2D(FileName,DComplexArray, N1, N2, SectionNumber, Headers, ReadDataFromHeader, &
       & FileType, CommentCharacters)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Headers(:)
    CHARACTER*(*),INTENT(IN),OPTIONAL :: FileType, CommentCharacters
    COMPLEX*16,INTENT(OUT) :: DComplexArray(:,:)
    INTEGER,INTENT(OUT) :: N1, N2
    INTEGER,INTENT(IN),OPTIONAL :: SectionNumber
    LOGICAL,INTENT(IN),OPTIONAL :: ReadDataFromHeader

    INTEGER iUnit, i1, i2, iError, NSections, iFlType, NWords, NE1, NE2, Length
    CHARACTER(100) DComplexFormat, CmtChars, DataTypeLine
    CHARACTER(100) ReDataStr, ImDataStr
    CHARACTER(20) Words(20)
    CHARACTER(4) FlType
    LOGICAL EOF, EOR, IsHeader, HeaderData
    DOUBLE PRECISION ReArg, ImArg

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)
    
    NE1 = 0
    NE2 = 0

    HeaderData = .FALSE.
    IF(PRESENT(ReadDataFromHeader)) HeaderData = ReadDataFromHeader

    IF(PRESENT(SectionNumber)) THEN
       CALL ReadToSection(FileName, SectionNumber)
    END IF

    iFlType = iFileTypeDefault
    IF(PRESENT(CommentCharacters)) THEN 
       CmtChars = CommentCharacters
    ELSE
       CmtChars = DefaultCommentCharacters
    END IF

    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          iFlType = ipad
       ELSE
          CALL Error('Illegal FileType passed to Write2D.')
       END IF
    END IF

    CALL OpenFl(FileName, FileAction = 'READ')
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, DCFormat = DComplexFormat, &
         & NSections = NSections)

    N1 = SIZE(DComplexArray,1)
    N2 = SIZE(DComplexArray,2)

    ! Read headers and save if they exist
    IF(PRESENT(Headers)) THEN
       CALL ReadHeaders(FileName, ReDataStr, CommentCharacters = CmtChars, Headers = Headers)
    ELSE
       CALL ReadHeaders(FileName, ReDataStr, CommentCharacters = CmtChars)
    END IF
    BACKSPACE(iUnit)

    ! Read data from file.
    DO i1 = 1, N1
       DO i2 = 1, N2
          CALL ReadNextWord(iUnit,ReDataStr,Length,IsHeader,EOR,EOF,CmtChars)
          CALL ReadNextWord(iUnit,ImDataStr,Length,IsHeader,EOR,EOF,CmtChars)
          IF(EOF) EXIT
          ! If this is a header line backspace and read headers.
          IF(ReDataStr(1:1).eq.'#') THEN
             BACKSPACE(iUnit)
             CALL ReadHeaders(FileName, ReDataStr, CommentCharacters = CmtChars)
             IF(ReadingNewSection(FileName, NSections)) RETURN
          END IF
          IF((LEN_TRIM(ReDataStr).gt.0).and.(LEN_TRIM(ImDataStr).gt.0)) THEN
             IF(iFlType.eq.itxt) THEN
                READ(ReDataStr,FMT=*,IOSTAT = iError) ReArg
                READ(ImDataStr,*,IOSTAT = iError) ImArg
                IF(iError.ne.0) CALL Error('Error in Read2D while trying to read from file: ' //&
                     & FileName)
             ELSEIF(iFlType.eq.ipad) THEN
                CALL ReadPAD(ReDataStr,npadrDefault,ReArg)
                CALL ReadPAD(ImDataStr,npadrDefault,ImArg)
             END IF
             DComplexArray(i2,i1) = ReArg + (0.0,1.0)*ImArg
             NE1 = NE1 + 1
          END IF
          IF(EOR) EXIT
       END DO
       IF(EOF) EXIT
       NE2 = NE2 + 1
    END DO
    EOF = .FALSE.
5   CONTINUE

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)
  END SUBROUTINE ReadDComplex2D

  ! SUBROUTINE ReadInt2D reads a 2D integer array from file.
  SUBROUTINE ReadString2D(FileName, StringArray, N1, N2, SectionNumber, Headers, ReadDataFromHeader, &
       & FileType, CommentCharacters)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Headers(:)
    CHARACTER*(*),INTENT(IN),OPTIONAL :: FileType, CommentCharacters
    CHARACTER*(*),INTENT(OUT) :: StringArray(:,:)
    INTEGER,INTENT(OUT) :: N1, N2
    INTEGER,INTENT(IN),OPTIONAL :: SectionNumber
    LOGICAL,INTENT(IN),OPTIONAL :: ReadDataFromHeader

    INTEGER iUnit, i1, i2, iError, NSections, iFlType, NWords, NE1, NE2, Length
    CHARACTER(100) StringFormat, CmtChars, DataTypeLine
    CHARACTER(MaxStrLen) DataStr
    CHARACTER(20) Words(20)
    CHARACTER(4) FlType
    LOGICAL EOF, EOR, IsHeader, HeaderData

    ! Define file types.
    INTEGER itxt, ipad
    PARAMETER(itxt = 1, ipad = 2)
    
    NE1 = 0
    NE2 = 0

    HeaderData = .FALSE.
    IF(PRESENT(ReadDataFromHeader)) HeaderData = ReadDataFromHeader

    IF(PRESENT(SectionNumber)) THEN
       CALL ReadToSection(FileName, SectionNumber)
    END IF

    iFlType = iFileTypeDefault
    IF(PRESENT(CommentCharacters)) THEN 
       CmtChars = CommentCharacters
    ELSE
       CmtChars = DefaultCommentCharacters
    END IF

    IF(PRESENT(FileType)) THEN
       FlType = TRIM(ADJUSTL(FileType))
       CALL Upper(FlType)
       IF(TRIM(FlType).eq.'TXT') THEN
          iFlType = itxt
       ELSEIF(TRIM(FlType).eq.'PAD') THEN
          iFlType = ipad
       ELSE
          CALL Error('Illegal FileType passed to Read2D.')
       END IF
    END IF

    CALL OpenFl(FileName, FileAction = 'READ')
    CALL GetIOFileInfo(FileName, UnitNumber = iUnit, SFormat = StringFormat, &
         & NSections = NSections)

    N1 = SIZE(StringArray,1)
    N2 = SIZE(StringArray,2)

    ! Read headers and save if they exist
    IF(PRESENT(Headers)) THEN
       CALL ReadHeaders(FileName, DataStr, CommentCharacters = CmtChars, Headers = Headers)
    ELSE
       CALL ReadHeaders(FileName, DataStr, CommentCharacters = CmtChars)
    END IF
    BACKSPACE(iUnit)

    ! Read data to file.
    DO i1 = 1, N1
       DO i2 = 1, N2
          CALL ReadNextWord(iUnit,DataStr,Length,IsHeader,EOR,EOF,CmtChars)
          IF(EOF) EXIT
          ! If this is a header line backspace and read headers.
          IF(DataStr(1:1).eq.'#') THEN
             BACKSPACE(iUnit)
             CALL ReadHeaders(FileName, DataStr, CommentCharacters = CmtChars)
             IF(ReadingNewSection(FileName, NSections)) RETURN
          END IF
          IF(LEN_TRIM(DataStr).gt.0) THEN
             StringArray(i2,i1) = TRIM(ADJUSTL(DataStr))
             NE1 = NE1 + 1
          END IF
          IF(EOR) EXIT
       END DO
       IF(EOF) EXIT
       NE2 = NE2 + 1
    END DO
10  CONTINUE

    ! Increment the section number
    CALL SetIOFileInfo(FileName, NSections = NSections + 1)
  END SUBROUTINE ReadString2D

  ! Reads through the file FileName until it finds the section specified by
  ! SectionNumber. 
  SUBROUTINE ReadToSection(FileName,SectionNumber)
    CHARACTER*(*),INTENT(IN) :: FileName
    INTEGER,INTENT(IN) :: SectionNumber

    INTEGER iUnit, NSections, iError
    CHARACTER(10) ErrorNum
    CHARACTER(20) TmpStr
    CHARACTER(1000) Line

    ! Get the unit number.
    CALL GetIOFileInfo(FileName,UnitNumber = iUnit, NSections = NSections)

    ! Rewind to start of file
    REWIND(iUnit)

    ! Read until section.
    NSections = 0
    DO
       READ(iUnit,'(A)',IOSTAT = iError, END = 5) Line

       ! If error stop.          
       IF(iError.ne.0) THEN
          WRITE(ErrorNum,'(I5)') iError
          CALL Error('Error ocurred in ReadToSection', StopProgram = .FALSE.)
          CALL Error('while reading from file ' // TRIM(ADJUSTL(FileName)) // &
               & '.',StopProgram = .FALSE.)
          CALL Error('Error: ' // ErrorNum)
       END IF

       TmpStr = ADJUSTL(Line)
       IF(TmpStr(1:4).eq.'#SN#') NSections = NSections + 1
       IF(NSections.eq.SectionNumber) EXIT
    END DO

    ! Set the section number.
    CALL SetIOFileInfo(FileName, NSections = NSections)

    RETURN

5   CONTINUE ! End of file reached. Set EOF and return.
    CALL SetIOFileInfo(FileName, EOF = .TRUE.)

  END SUBROUTINE ReadToSection

  ! Reads lines until it finds one that is not a header. The next non
  !-header (non-blank) line will be passed back in Line.
  ! FileName - name of file to read from.
  ! Line - next data line
  ! CommentCharacters - string of characters, any of which will be
  ! interpreted as comment characters when found at the beginning of
  ! a line.
  ! Headers - optional: will store the headers found in Headers.
  SUBROUTINE ReadHeaders(FileName,Line,CommentCharacters,Headers)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(OUT) :: Line
    CHARACTER*(*),INTENT(IN),OPTIONAL :: CommentCharacters
    CHARACTER*(*),INTENT(OUT),OPTIONAL :: Headers(:)

    INTEGER iUnit, iError, NHead, MaxNHead, NSections
    CHARACTER(10) ErrorNum, CmtChars
    CHARACTER(200) TmpStr

    LOGICAL IsHead

    INTEGER i1

    ! Initialization
    IsHead = .TRUE.
    IF(PRESENT(Headers)) MaxNHead = SIZE(Headers)
    NHead = 0
    IF(PRESENT(CommentCharacters)) THEN
       CmtChars = CommentCharacters
    ELSE
       CmtChars = DefaultCommentCharacters
    END IF

    ! Get the unit number.
    CALL GetIOFileInfo(FileName,UnitNumber = iUnit, NSections = NSections)
    
    ! Read until next non-header line, saving header lines if Headers variable
    ! is provided.
    DO
       READ(iUnit,'(A)',IOSTAT = iError, END = 5) Line

       ! If error stop.          
       IF(iError.ne.0) THEN
          WRITE(ErrorNum,'(I5)') iError
          CALL Error('Error ocurred in ReadHeaders', StopProgram = .FALSE.)
          CALL Error('while reading from file ' // TRIM(ADJUSTL(FileName)) // &
               & '.',StopProgram = .FALSE.)
          CALL Error('Error: ' // ErrorNum)
       END IF

       TmpStr = TRIM(ADJUSTL(Line))

       ! First run through a few cases that look like headers but are not.
       IF(TmpStr(1:4).eq.'#SN#') THEN 
          ! New section has been reached. Increment section #
          CALL SetIOFileInfo(FileName,NSections = NSections + 1)
          NSections = NSections + 1

       ELSEIF(TmpStr(1:4).eq.'#DT#') THEN
          ! This is a data type line. Set DataTypeLine and continue.
          TmpStr = TRIM(ADJUSTL(Line(5:LEN(Line))))
          CALL SetIOFileInfo(FileName, DataTypeLine = TmpStr)

       ELSEIF(TmpStr(1:4).eq.'#DF#') THEN
          ! This is a data format line. Eventually add an automatic reader.
          CONTINUE

       ELSEIF(TmpStr(1:4).eq.'#HD#') THEN
          ! This is header data: return.
          IF(NSections.eq.0) NSections = 1
          CALL SetIOFileInfo(FileName, NSections = NSections)
          RETURN

       ELSEIF(LEN_TRIM(TmpStr).ne.0) THEN ! This is not a blank line, check for header line.
          ! Header lines are anything that start with any of the CommentCharacters
          ! if provided, otherwise they start with #, *, c, C, or ! 
          IsHead = .FALSE.
          DO i1 = 1, LEN_TRIM(CmtChars)
             IF(TmpStr(1:1).eq.CmtChars(i1:i1)) THEN
                ! if this is a header, set headers if specified
                IF(PRESENT(Headers)) THEN
                   NHead = NHead + 1
                   IF(MaxNHead.le.NHead) Headers(NHead) = TRIM(ADJUSTL(Line))
                END IF
                IsHead = .TRUE.
                EXIT
             END IF
          END DO

          ! If this line was not a header, backspace and return.
          IF(.not.IsHead) THEN
             IF(NSections.eq.0) NSections = 1
             CALL SetIOFileInfo(FileName, NSections = NSections)
             RETURN
          END IF
       END IF
    END DO

5   CONTINUE ! End of file reached. Set EOF for this file.
    CALL SetIOFileInfo(FileName, EOF = .TRUE.)
    
  END SUBROUTINE ReadHeaders

  ! Checks if the end of the file has been reached.
  LOGICAL FUNCTION EndOfFile(FileName)
    CHARACTER*(*) FileName

    CALL GetIOFileInfo(FileName, EOF = EndOfFile)
  END FUNCTION EndOfFile

  ! Checks if the next line is data (not a header), and backspaces.
  LOGICAL FUNCTION NextLineIsData(FileName, CommentCharacters)
    CHARACTER*(*),INTENT(IN) :: FileName
    CHARACTER*(*),INTENT(IN),OPTIONAL :: CommentCharacters

    INTEGER iUnit, iError, i1
    CHARACTER(1000) Line
    CHARACTER(20) TmpStr, CmtChars
    CHARACTER(5) ErrorNum
    LOGICAL IsHead, EOF

    NextLineIsData = .FALSE.
    IF(PRESENT(CommentCharacters)) THEN
       CmtChars = CommentCharacters
    ELSE
       CmtChars = DefaultCommentCharacters
    END IF

    ! Get the unit number.
    CALL GetIOFileInfo(FileName,UnitNumber = iUnit, EOF = EOF)
    
    ! If EOF, return false.
    IF(EOF) THEN
       NextLineIsData = .FALSE.
       RETURN
    END IF

    ! Read the next line.
    READ(iUnit,'(A)',IOSTAT = iError, END = 5) Line

    ! If error stop.          
    IF(iError.ne.0) THEN
       WRITE(ErrorNum,'(I5)') iError
       CALL Error('Error ocurred in NextLineIsData', StopProgram = .FALSE.)
       CALL Error('while reading from file ' // TRIM(ADJUSTL(FileName)) // &
            & '.',StopProgram = .FALSE.)
       CALL Error('Error: ' // ErrorNum)
    END IF

    TmpStr = TRIM(ADJUSTL(Line))

    ! First run through a few cases that look like headers but are not.
    IF(TmpStr(1:4).eq.'#SN#') THEN 
       NextLineIsData = .FALSE.
    ELSEIF(TmpStr(1:4).eq.'#DT#') THEN
       NextLineIsData = .FALSE.
    ELSEIF(TmpStr(1:4).eq.'#HD#') THEN
       ! Header Data 
       NextLineIsData = .TRUE.
    ELSEIF(TmpStr(1:4).eq.'#DF#') THEN
       NextLineIsData = .FALSE.
    ELSEIF(LEN_TRIM(TmpStr).ne.0) THEN ! This is not a blank line, check for header line.
       ! Header lines are anything that start with any of the CommentCharacters
       ! if provided, otherwise they start with #, *, c, C, or ! 
       IsHead = .FALSE.
       DO i1 = 1, LEN_TRIM(CmtChars)
          IF(TmpStr(1:1).eq.CmtChars(i1:i1)) THEN
             IsHead = .TRUE.
             EXIT
          END IF
       END DO

       ! If this line was not a header, backspace and return.
       IF(.not.IsHead) THEN          
          NextLineIsData = .TRUE.
       END IF
    END IF
5   CONTINUE
    BACKSPACE(iUnit)
    
  END FUNCTION NextLineIsData

  SUBROUTINE ReadNextWord(iUnit,Word,Length,IsHeader,EOR,EOF,CommentCharacters)
    INTEGER,INTENT(IN) :: iUnit
    CHARACTER,INTENT(IN) :: CommentCharacters
    INTEGER,INTENT(OUT) :: Length
    CHARACTER*(*),INTENT(OUT) :: Word
    LOGICAL,INTENT(OUT) :: EOR, EOF, IsHeader
    CHARACTER c
    CHARACTER(200) line
    INTEGER i1, clen

    EOR = .FALSE.
    EOF = .FALSE.
    IsHeader = .FALSE.
    Length = 0
    Word = ' '
    ! Read until we hit the first character. If we hit the end of the line, keep reading.
    DO
       READ(iUnit,'(A1)',ADVANCE = 'NO', EOR = 5, END = 10) c
       
       ! If c is not blank. Set Word(1:1) and exit
       clen = LEN_TRIM(c)
       IF(clen.gt.0) THEN
          Word(1:1) = c
          EXIT
       ENDIF          
    END DO

    ! Now check if this is a comment line.
    DO i1 = 1, LEN(CommentCharacters)
       IF(c.eq.CommentCharacters(i1:i1)) THEN
          IsHeader = .TRUE.
          READ(iUnit,*)
          RETURN
       END IF
    END DO

    Length = 1
    ! Now read until we hit a blank character.
    DO
       READ(iUnit,'(A)',ADVANCE = 'NO', EOR = 5, END = 10) c
       IF(LEN_TRIM(c).gt.0) THEN
          Word = TRIM(Word) // c
          Length = Length + 1
       ELSE
          EXIT
       END IF
    END DO
    RETURN
    
    ! End of record has been reached.
5   CONTINUE
    EOR = .TRUE.
    RETURN

    ! End of file has been reached.
10  CONTINUE
    EOF = .TRUE.
  END SUBROUTINE ReadNextWord
  
  ! Strips #HD# from the beginning of header data lines.
  SUBROUTINE StripHDLine(iUnit, IsHeader, EOR, EOF)
    INTEGER,INTENT(IN) :: iUnit
    INTEGER iError
    CHARACTER(4) HDString
    LOGICAL IsHeader, EOR, EOF

    EOR = .FALSE.
    EOF = .FALSE.
    IsHeader = .FALSE.

    READ(iUnit,'(A4)',ADVANCE = 'NO', EOR = 5, END = 10, IOSTAT = iError) HDString 
    CALL ReadError(iUnit = iUnit, Routine = 'StripHDLine', iError = iError)

    ! If HDString = #HD#, good, return
    IF(HDString.eq.'#HD#') THEN
       RETURN
    ELSEIF(TRIM(ADJUSTL(HDString(1:1))).eq.'#') THEN
       ! This is a header, but not data. 
       IsHeader = .TRUE.       
       RETURN
    ELSE
       ! This is not a header line or header data. Error
       CALL ReadError(iUnit = iUnit, Routine = 'StripHDLine')
    END IF

5   CONTINUE
    ! End of record found. Return
    EOR = .TRUE.
    RETURN

10  CONTINUE
    ! End of file found.
    EOF = .TRUE.
  END SUBROUTINE StripHDLine

  ! Handles read errors. Prints error number, file name, and calling routine.
  SUBROUTINE ReadError(FileName, iUnit, Routine, iError)
    CHARACTER*(*),INTENT(IN),OPTIONAL :: FileName, Routine
    INTEGER,INTENT(IN),OPTIONAL :: iUnit, iError
    CHARACTER(300) Messg(3), FlName, ErrorNum

    IF(PRESENT(FileName)) THEN
       FlName = FileName
    ELSEIF(PRESENT(iUnit)) THEN
       INQUIRE(UNIT = iUnit, NAME = FlName)
    ELSE
       CALL Error('ReadError called without either FileName or UnitNumber present.')
    END IF

    Messg(1) = 'READ ERROR:'

    IF(PRESENT(iError)) THEN
       WRITE(ErrorNum,*) iError
       Messg(1) = TRIM(Messg(1)) // ' ' // TRIM(ADJUSTL(ErrorNum))
    END IF

    Messg(2) = 'Read error occured while reading from file ' // TRIM(FlName) // '.'

    IF(PRESENT(Routine)) Messg(3) = 'This error occured inside the ' // TRIM(Routine) // ' routine.'

    CALL Error(Messg)

  END SUBROUTINE ReadError

  INTEGER Function NumberOfLines(FileName)
    CHARACTER*(*) FileName
    INTEGER iUnit, i1
    CHARACTER c
    CHARACTER(200) Line
    ! Find the number of lines that contain data
    CALL ReadHeaders(FileName,Line)
    CALL GetIOFileInfo(FileName,UnitNumber=iUnit)    
    BACKSPACE(iUnit)
    NumberOfLines = 0
    DO
       READ(iUnit,'(a)',END=10) c
       NumberOfLines = NumberOfLines + 1
    END DO
10  CONTINUE
    REWIND(iUnit)
  END Function NumberOfLines

END MODULE IOMod

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_kinds.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module m_Kinds

! Definition of the standard kinds used throughout the program

  integer, parameter :: i04 = selected_int_kind(4)
  integer, parameter :: i08 = selected_int_kind(8)
  integer, parameter :: i16 = selected_int_kind(16)

  integer, parameter :: r04 = selected_real_kind(4)
  integer, parameter :: r08 = selected_real_kind(8)
  integer, parameter :: r16 = selected_real_kind(16)

end module m_Kinds

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_mtdp.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module Mtdp

! Muffin-Tin density and potential

  use m_Kinds

  type :: Mtdp_Data_Type
    integer(kind=i08)                            :: nR
    integer(kind=i08)                            :: nAt
    integer(kind=i08), dimension(:), allocatable :: At_AN
    real(kind=r08), dimension(:,:), allocatable  :: At_XYZ
    real(kind=r08), dimension(:), allocatable    :: At_R
    integer(kind=i08), dimension(:), allocatable :: At_iR
    real(kind=r08), dimension(:,:), allocatable  :: At_Den
    real(kind=r08), dimension(:,:), allocatable  :: At_Pot
    integer(kind=i08)                            :: nESph
    real(kind=r08), dimension(:,:), allocatable  :: ESph_XYZ
    real(kind=r08), dimension(:), allocatable    :: ESph_R
    integer(kind=i08), dimension(:), allocatable :: ESph_iR
    real(kind=r08), dimension(:,:), allocatable  :: ESph_Den
    real(kind=r08), dimension(:,:), allocatable  :: ESph_Pot
    real(kind=r08)                               :: V_Int
    real(kind=r08)                               :: V_HOMO
    real(kind=r08)                               :: V_LUMO
  end type

  private
  public :: Mtdp_Data_Type
  public :: Write_Mtdp
  public :: Read_Mtdp

contains

  subroutine Write_Mtdp(Mtdp_Data)

    implicit none

    type(Mtdp_Data_Type), intent(in) :: Mtdp_Data

! Number of points in the radial grid
    write(6,fmt='(i12)') Mtdp_Data%nR

! Number of atoms
    write(6,fmt='(i12)') Mtdp_Data%nAt

! Atomic numbers
    write(6,fmt='(i12)') Mtdp_Data%At_AN

! Atomic coordinates
    write(6,fmt='(1p,e20.10)') Mtdp_Data%At_XYZ

! Muffin-Tin Radii
    write(6,fmt='(1p,e20.10)') Mtdp_Data%At_R

! Index of the radii on the radial grid
    write(6,fmt='(i12)') Mtdp_Data%At_iR

! Electron density inside each Muffin-Tin
    write(6,fmt='(1p,e20.10)') Mtdp_Data%At_Den

! Potential (H+XC) inside each Muffin-Tin
    write(6,fmt='(1p,e20.10)') Mtdp_Data%At_Pot

! Number of empty spheres
    write(6,fmt='(i12)') Mtdp_Data%nESph

! Coordinates of the empty sphere's centers
    write(6,fmt='(1p,e20.10)') Mtdp_Data%ESph_XYZ

! Empty sphere's radii
    write(6,fmt='(1p,e20.10)') Mtdp_Data%ESph_R

! Index of the empty sphere's radii on the radial grid
    write(6,fmt='(i12)') Mtdp_Data%ESph_iR

! Electron density inside each empty sphere
    write(6,fmt='(1p,e20.10)') Mtdp_Data%ESph_Den

! Potential (H+XC) inside each empty sphere
    write(6,fmt='(1p,e20.10)') Mtdp_Data%ESph_Pot

! Interstitial potential
    write(6,fmt='(1p,e20.10)') Mtdp_Data%V_Int

! HOMO energy
    write(6,fmt='(1p,e20.10)') Mtdp_Data%V_HOMO

! LUMO energy
    write(6,fmt='(1p,e20.10)') Mtdp_Data%V_LUMO

  end subroutine Write_Mtdp

  subroutine Read_Mtdp(iunit,Mtdp_Data)

    implicit none

    integer, intent(in) :: iunit
    type(Mtdp_Data_Type), intent(out) :: Mtdp_Data

! Number of points in the radial grid
    read(iunit,*) Mtdp_Data%nR

! Number of atoms
    read(iunit,*) Mtdp_Data%nAt

! Atomic numbers
    allocate(Mtdp_Data%At_AN(Mtdp_Data%nAt))
    read(iunit,*) Mtdp_Data%At_AN

! Atomic coordinates
    allocate(Mtdp_Data%At_XYZ(3,Mtdp_Data%nAt))
    read(iunit,*) Mtdp_Data%At_XYZ

! Muffin-Tin Radii
    allocate(Mtdp_Data%At_R(Mtdp_Data%nAt))
    read(iunit,*) Mtdp_Data%At_R

! Index of the radii on the radial grid
    allocate(Mtdp_Data%At_iR(Mtdp_Data%nAt))
    read(iunit,*) Mtdp_Data%At_iR

! Electron density inside each Muffin-Tin
    allocate(Mtdp_Data%At_Den(Mtdp_Data%nR,Mtdp_Data%nAt))
    read(iunit,*) Mtdp_Data%At_Den

! Potential (H+XC) inside each Muffin-Tin
    allocate(Mtdp_Data%At_Pot(Mtdp_Data%nR,Mtdp_Data%nAt))
    read(iunit,*) Mtdp_Data%At_Pot

! Number of empty spheres
    read(iunit,*) Mtdp_Data%nESph

! Coordinates of the empty sphere's centers
    allocate(Mtdp_Data%ESph_XYZ(3,Mtdp_Data%nESph))
    read(iunit,*) Mtdp_Data%ESph_XYZ

! Empty sphere's radii
    allocate(Mtdp_Data%ESph_R(Mtdp_Data%nESph))
    read(iunit,*) Mtdp_Data%ESph_R

! Index of the empty sphere's radii on the radial grid
    allocate(Mtdp_Data%ESph_iR(Mtdp_Data%nESph))
    read(iunit,*) Mtdp_Data%ESph_iR

! Electron density inside each empty sphere
    allocate(Mtdp_Data%ESph_Den(Mtdp_Data%nR,Mtdp_Data%nESph))
    read(iunit,*) Mtdp_Data%ESph_Den

! Potential (H+XC) inside each empty sphere
    allocate(Mtdp_Data%ESph_Pot(Mtdp_Data%nR,Mtdp_Data%nESph))
    read(iunit,*) Mtdp_Data%ESph_Pot

! Interstitial potential
    read(iunit,*) Mtdp_Data%V_Int

! HOMO energy
    read(iunit,*) Mtdp_Data%V_HOMO

! LUMO energy
    read(iunit,*) Mtdp_Data%V_LUMO

  end subroutine Read_Mtdp

end module Mtdp

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_atomicpotio.f90,v $:
! $Revision: 1.16 $
! $Author: jorissen $
! $Date: 2010/12/14 00:22:37 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MODULE AtomicPotIO
  USE ErrorMod
  USE IOMod
  IMPLICIT NONE
  
  CHARACTER(3),PRIVATE :: FileType
  !PARAMETER(FileType = 'PAD')
  PARAMETER(FileType = 'TXT')
  
  
  CONTAINS
    SUBROUTINE WriteAtomicPots(nph, iz, ihole, rho, dmag, rhoval, vcoul, dgc0, dpc0, dgc, dpc, &
           & adgc, adpc, erelax, emu, xnvmu, xnval, norb, eorb, drho, dvcoul, iphat,    &
           & rat, iatph, novr, iphovr, nnovr, rovr, nat, edens, edenvl, vclap, rnrm,    &
           & kappa, iorb, s02)
      
      ! Scalar data
      INTEGER,INTENT(IN) :: nph, nat, ihole
      DOUBLE PRECISION, INTENT(IN) :: emu, erelax, s02

      ! 1D data
      INTEGER,INTENT(IN) :: iz(:), norb(:), iphat(:), iatph(:), novr(:)
      DOUBLE PRECISION,INTENT(IN) :: dgc0(:), dpc0(:), drho(:), dvcoul(:), rnrm(:)

      ! 2D data
      INTEGER,INTENT(IN) :: iphovr(:,:), nnovr(:,:), kappa(:,:), iorb(:,:)
      DOUBLE PRECISION,INTENT(IN) :: rho(:,:), dmag(:,:), rhoval(:,:), vcoul(:,:), &
           & xnvmu(:,:), xnval(:,:), eorb(:,:), rat(:,:), rovr(:,:), edens(:,:),   &
           & edenvl(:,:), vclap(:,:)

      ! 3D data
      DOUBLE PRECISION,INTENT(IN) :: dgc(:,:,:), dpc(:,:,:), adgc(:,:,:), adpc(:,:,:)


         

      CHARACTER*80 Headers(20)
      CHARACTER*20 ColumnLabels(20)

      INTEGER iph

      ! Initialize stuff.
      Headers(:) = ' '
      ColumnLabels(:) = ' '

      ! Define some headers.
      Headers(1) = 'This file contains information about the free atom potentials.'
      Headers(2) = 'nat    - number of atoms.'
      Headers(3) = 'nph    - number of unique potentials'      
      Headers(3) = 'ihole  - hole index'      
      Headers(4) = 'erelax - relaxation energy for each occupied orbital.'
      Headers(5) = 'emu - edge energy for each occupied orbital.'
      Headers(6) = 's02 - many body amplitude reduction.'
      ColumnLabels(1) = 'nph'
      ColumnLabels(2) = 'nat'
      ColumnLabels(3) = 'ihole'
      ColumnLabels(4) = 'erelax'
      ColumnLabels(5) = 'emu'
      ColumnLabels(6) = 's02'
      ! Write headers along with the first line and columnlabels.
      ! Write scalar data.
      CALL WriteData('apot.bin', Int1 = nph, Int2 = nat, Int3 = ihole, Double4 = erelax, Double5 = emu, &
           & Double6 = s02, Headers = Headers, ColumnLabels = ColumnLabels, FileType = FileType, &
		   ForceNewSection = .TRUE. ) !KJ 7-09 added ForceNewSection bc otherwise doesn't work on my Windows pc
      Headers(:) = ' '
      ColumnLabels(:) = ' '

      ! Write iz, iatph, novr, rnrm.
      Headers(1) = 'iz(0:nphx)    - atomic number for each unique potential'
      Headers(2) = 'iatph(0:nphx) - given unique pot, which atom is model?'
      Headers(3) = 'novr(0:nphx)  - number of overlap shells for each unique pot'
      Headers(4) = 'rnrm(0:nphx)  - norman radius for each unique potential.'
      ColumnLabels(1) = 'iz'
      ColumnLabels(2) = 'iatph'
      ColumnLabels(3) = 'novr'
      ColumnLabels(4) = 'rnrm'
      CALL WriteArrayData('apot.bin', Int1 = iz, Int2 = iatph, Int3 = novr, Double4 = rnrm, &
           & Headers = Headers, ColumnLabels = ColumnLabels, FileType = FileType,           &
           & ForceNewSection = .TRUE.)
      Headers(:) = ' '
      ColumnLabels(:) = ' '

      ! Write norb
      Headers(1) = 'norb(0:nphx+1) - number of occupied orbitals for each unique potential'
      CALL WriteArrayData('apot.bin', Int1 = norb, Headers = Headers, &
           & FileType = FileType, ForceNewSection = .TRUE.)

      ! Write iphat
      Headers(1) = 'iphat(natx) - given specific atom, which unique pot?'
      CALL WriteArrayData('apot.bin', Int1 = iphat, Headers = Headers, &
           & FileType = FileType, ForceNewSection = .TRUE.)

      ! Write dgc0, dpc0, drho, and dvcoul
      Headers(1) = 'dgc0   - upper component of core hole orbital'
      Headers(2) = 'dpc0   - lower component of core hole orbital'
      Headers(3) = 'drho   - core hole density.'
      Headers(4) = 'dvcoul - core hole coulomb potential.'
      ColumnLabels(1) = 'dgc0'
      ColumnLabels(2) = 'dpc0'
      ColumnLabels(3) = 'drho'
      ColumnLabels(4) = 'dvcoul'
      CALL WriteArrayData('apot.bin', Double1 = dgc0, Double2 = dpc0, Double3 = drho, &
           & Double4 = dvcoul, Headers = Headers, ColumnLabels = ColumnLabels,          &
           & FileType = FileType, ForceNewSection = .TRUE.)
      Headers(:) = ' '
      ColumnLabels(:) = ' '

      ! Write iphovr.
      Headers(1) = 'iphovr(novrx,0:nphx) - unique pot for each overlap shell'
      CALL Write2D('apot.bin', iphovr, Headers = Headers, FileType = FileType)

      ! Write nnovr.
      Headers(1) = 'nnovr(novrx,0:nphx) - number of atoms in overlap shell'
      CALL Write2D('apot.bin', nnovr, Headers = Headers, FileType = FileType)

      ! Write rho.
      Headers(1) = 'rho(r,0:nphx+1) - atomic density for each unique potential'
      Headers(2) = '                  nph+1 holds final state potential for absorber'
      CALL Write2D('apot.bin', rho, Headers = Headers, FileType = FileType)
      Headers(:) = ' '

      ! Write dmag.
      Headers(1) = 'dmag(r,nph+1) - ?'
      CALL Write2D('apot.bin', dmag, Headers = Headers, FileType = FileType)

      ! Write rhoval.
      Headers(1) = 'rhoval(r,nph+1) - atomic valence density for each unique potential.'
      CALL Write2D('apot.bin', rhoval, Headers = Headers, FileType = FileType)

      ! Write vcoul.
      Headers(1) = 'vcoul(r,nph) - coulomb potential for each unique potential.'
      CALL Write2D('apot.bin', vcoul, Headers = Headers, FileType = FileType)

      ! Write xnvmu.
      Headers(1) = 'xnvmu(0:lx,0:nphx+1) - number of valence electron within norman sphere for each channel (?)'
      CALL Write2D('apot.bin', xnvmu, Headers = Headers, FileType = FileType)

      ! Write xnval.
      Headers(1) = 'xnval(30,nph) - occupation of each orbital.'
      CALL Write2D('apot.bin', xnval, Headers = Headers, FileType = FileType)

      ! Write eorb.
      Headers(1) = 'eorb(norb,iph)'
      CALL Write2D('apot.bin', eorb, Headers = Headers, FileType = FileType)

      ! Write rat.
      Headers(1) = 'rat(3,nat) - cartesian coordinates for each atom.'
      CALL Write2D('apot.bin', rat, Headers = Headers, FileType = FileType)

      ! Write rovr
      Headers(1) = 'rovr(novrx,0:nphx) - r for overlap shell'
      CALL Write2D('apot.bin', rovr, Headers = Headers, FileType = FileType)

      ! Write edens.
      Headers(1) = 'edens(r,0:nphx) - overlapped density for each unique potential.'
      CALL Write2D('apot.bin', edens, Headers = Headers, FileType = FileType)

      ! Write edenvl
      Headers(1) = 'edenvl(r,0:nphx) - overlapped density of valence electrons?'
      CALL Write2D('apot.bin', edenvl, Headers = Headers, FileType = FileType)


      ! Write vclap.
      Headers(1) = 'vclap(r,0:nphx) - overlapped coulomb potential.'
      CALL Write2D('apot.bin', vclap, Headers = Headers, FileType = FileType)

      ! Write kappa.
      Headers(1) = 'kappa(norb,0:nph) - quntum number kappa for each orbital and potential.'
      CALL Write2D('apot.bin', kappa, Headers = Headers, FileType = FileType)

      ! Write iorb.
      Headers(1) = 'iorb(-4:3,0:nphx+1) - last occupied orbital of a particular kappa or zero if none.'
      CALL Write2D('apot.bin', iorb, Headers = Headers, FileType = FileType)
      
      ! Write dgc.
      Headers(1) = 'dgc(r,30,nph) - upper component of each obital for each unique potential.'
      CALL WriteData('apot.bin',Headers = Headers)
      DO iph = 1, SIZE(dgc,3)
         IF(iph.eq.1) THEN
             Headers(1) = 'dgc(r,30,nph) - upper component of each obital for each unique potential.'
             Headers(2) = 'dgc(r,norb,' // ACHAR(iph+48) // ')'
          ELSEIF(iph.lt.10) THEN
             Headers(1) = 'dgc(r,norb,' // ACHAR(iph+48) // ')'
		  ELSEIF(iph.lt.100) THEN
             Headers(1) = 'dgc(r,norb,' // ACHAR((iph/10)+48) // ACHAR(mod(iph,10)+48) // ')'
		  ELSE
		     stop 'ERROR iph too large in WriteAtomicPots'
          END IF
         CALL Write2D('apot.bin', dgc(:,:,iph), Headers = Headers, FileType = FileType)
      END DO

      ! Write dpc.
      Headers(1) = 'dpc(r,30,nph) - lower component of each obital and unique potential.'
      CALL WriteData('apot.bin',Headers = Headers)
      DO iph = 1, SIZE(dpc,3)
         IF(iph.eq.1) THEN
            Headers(1) = 'dpc(r,30,nph) - lower component of each obital and unique potential.'
             Headers(2) = 'dpc(r,norb,' // ACHAR(iph+48) // ')'
          ELSEIF(iph.lt.10) THEN
             Headers(1) = 'dpc(r,norb,' // ACHAR(iph+48) // ')'
		  ELSEIF(iph.lt.100) THEN
             Headers(1) = 'dpc(r,norb,' // ACHAR((iph/10)+48) // ACHAR(mod(iph,10)+48) // ')'
		  ELSE
		     stop 'ERROR iph too large in WriteAtomicPots'
          END IF
         CALL Write2D('apot.bin', dpc(:,:,iph), Headers = Headers, FileType = FileType)
      END DO

      ! Write adgc.
      DO iph = 1, SIZE(adgc,3)
         IF(iph.eq.1) THEN
            Headers(1) = 'adgc(r,30,nph) - upper development coeficients for each obital and unique potential.'            
            WRITE(Headers(2),'(A,I10,A)') 'adgc(r,norb,', iph, ')'
         ELSE
            WRITE(Headers(1),'(A,I10,A)') 'adgc(r,norb,', iph, ')'
         END IF
         CALL Write2D('apot.bin', adgc(:,:,iph), Headers = Headers, FileType = FileType)
      END DO

      ! Write adpc.
      Headers(1) = 'adpc(r,30,nph) - lower development coeficients for each obital and unique potential.'
      CALL WriteData('apot.bin',Headers = Headers)
      DO iph = 1, SIZE(adpc,3)
         IF(iph.eq.1) THEN
             Headers(1) = 'adpc(r,30,nph) - lower development coeficients for each obital and unique potential.'
             WRITE(Headers(2),'(A,I10,A)') 'adpc(r,norb,', iph, ')'
          ELSE
             WRITE(Headers(1),'(A,I10,A)') 'adpc(r,norb,', iph, ')'
          END IF
         CALL Write2D('apot.bin', adpc(:,:,iph), Headers = Headers, FileType = FileType)
      END DO

      ! Close the file so that we can read it later.
      CALL CloseFl('apot.bin')
    END SUBROUTINE WriteAtomicPots


    SUBROUTINE ReadAtomicPots(nph, iz, ihole, rho, dmag, rhoval, vcoul, dgc0, dpc0, dgc, dpc, &
         & adgc, adpc, erelax, emu, xnvmu, xnval, norb, eorb, drho, dvcoul, iphat,     &
         & rat, iatph, novr, iphovr, nnovr, rovr, nat, edens, edenvl, vclap, rnrm,     &
         & kappa, iorb, s02)

      ! Scalar data
      INTEGER,INTENT(OUT),OPTIONAL :: nph, nat, ihole
      DOUBLE PRECISION,INTENT(OUT),OPTIONAL :: emu, erelax, s02

      ! 1D data
      INTEGER,INTENT(OUT),OPTIONAL :: iz(:), norb(:), iphat(:), iatph(:), novr(:)
      DOUBLE PRECISION,INTENT(OUT),OPTIONAL :: dgc0(:), dpc0(:), drho(:), dvcoul(:), rnrm(:)

      ! 2D data
      INTEGER,INTENT(OUT),OPTIONAL :: iphovr(:,:), nnovr(:,:), kappa(:,:), iorb(:,:)
      DOUBLE PRECISION,INTENT(OUT),OPTIONAL :: rho(:,:), dmag(:,:), rhoval(:,:), vcoul(:,:), &
           & xnvmu(:,:), xnval(:,:), eorb(:,:), rat(:,:), rovr(:,:), edens(:,:),   &
           & edenvl(:,:), vclap(:,:)

      ! 3D data
      DOUBLE PRECISION,INTENT(OUT),OPTIONAL :: dgc(:,:,:), dpc(:,:,:), adgc(:,:,:), adpc(:,:,:)

      INTEGER n1, n2, nSect, iError, iph

      ! Temp variables.
      INTEGER iTmp1, iTmp2, iTmp3
      INTEGER,ALLOCATABLE :: iTmpArray1(:), iTmpArray2(:), iTmpArray3(:)
      DOUBLE PRECISION DTmp1, DTmp2, DTmp3
      DOUBLE PRECISION,ALLOCATABLE :: DTmpArray1(:), DTmpArray2(:), DTmpArray3(:), DTmpArray4(:)

      NSect = 1
      ! Read nph, nat
      ! PRINT*, 'Read nph, nat'
      IF(PRESENT(nph).or.PRESENT(nat).or.PRESENT(ihole).or.PRESENT(emu).or.PRESENT(erelax)) THEN
         CALL ReadData('apot.bin', Int1 = iTmp1, Int2 = iTmp2, Int3 = iTmp3, Double4 = DTmp1, & 
              & Double5 = DTmp2 , Double6 = DTmp3, FileType = FileType, SectionNumber = NSect)
         IF(PRESENT(nph)) nph = iTmp1
         IF(PRESENT(nat)) nat = iTmp2
         IF(PRESENT(ihole)) ihole = iTmp3
         IF(PRESENT(erelax)) erelax = DTmp1
         IF(PRESENT(emu)) emu = DTmp2
         IF(PRESENT(s02)) s02 = DTmp3
      END IF

      NSect = NSect + 1
      IF(PRESENT(iz).or.PRESENT(iatph).or.PRESENT(novr).or.PRESENT(rnrm)) THEN
         ! Read iz, iatph, novr, rnrm.
         IF(PRESENT(iz)) THEN
            n1 = SIZE(iz)
         ELSEIF(PRESENT(iatph)) THEN
            n1 = SIZE(iatph)
         ELSEIF(PRESENT(novr)) THEN
            n1 = SIZE(novr)
         ELSEIF(PRESENT(rnrm)) THEN
            n1 = SIZE(rnrm)
         END IF

         ALLOCATE(iTmpArray1(n1),STAT = iError)
         CALL CheckAllocation(iError,'ERROR: Cannot allocate space for array iTmpArray1 in subroutine ReadAtomicPots.')
         ALLOCATE(iTmpArray2(n1),STAT = iError)
         CALL CheckAllocation(iError,'ERROR: Cannot allocate space for array iTmpArray2 in subroutine ReadAtomicPots.')
         ALLOCATE(iTmpArray3(n1),STAT = iError)
         CALL CheckAllocation(iError,'ERROR: Cannot allocate space for array iTmpArray3 in subroutine ReadAtomicPots.')
         ALLOCATE(DTmpArray1(n1),STAT = iError)
         CALL CheckAllocation(iError,'ERROR: Cannot allocate space for array DTmpArray1 in subroutine ReadAtomicPots.')
         CALL ReadArrayData('apot.bin', Int1 = iTmpArray1, Int2 = iTmpArray2, Int3 = iTmpArray3, Double4 = DTmpArray1, &
              & FileType = FileType, SectionNumber = NSect)
         IF(PRESENT(iz)) iz(:)    = iTmpArray1(:)
         IF(PRESENT(iatph)) iatph(:) = iTmpArray2(:)
         IF(PRESENT(novr)) novr(:)  = iTmpArray3(:)
         IF(PRESENT(rnrm)) rnrm(:)  = DTmpArray1(:)

         DEALLOCATE(iTmpArray1, iTmpArray2, iTmpArray3, DTmpArray1)
      END IF

      NSect = NSect + 1
      IF(PRESENT(norb)) THEN
         ! Read norb
         CALL ReadArrayData('apot.bin', Int1 = norb,  &
              & FileType = FileType, SectionNumber = NSect)
      END IF

      NSect = NSect + 1
      IF(PRESENT(iphat)) THEN
         ! Read iphat
         CALL ReadArrayData('apot.bin', Int1 = iphat,  &
              & FileType = FileType, SectionNumber = NSect)
      END IF

      NSect = NSect + 1
      IF(PRESENT(dgc0).or.PRESENT(dgc0).or.PRESENT(drho).or.PRESENT(dvcoul)) THEN
         ! Read dgc0, dpc0, drho, and dvcoul
         IF(PRESENT(dgc0)) THEN
            n1 = SIZE(dgc0)
         ELSEIF(PRESENT(dpc0)) THEN
            n1 = SIZE(dpc0)
         ELSEIF(PRESENT(drho)) THEN
            n1 = SIZE(drho)
         ELSEIF(PRESENT(dvcoul)) THEN
            n1 = SIZE(dvcoul)
         END IF

         ALLOCATE(DTmpArray1(n1),STAT = iError)
         CALL CheckAllocation(iError,'ERROR: Cannot allocate space for array iTmpArray1 in subroutine ReadAtomicPots.')
         ALLOCATE(DTmpArray2(n1),STAT = iError)
         CALL CheckAllocation(iError,'ERROR: Cannot allocate space for array iTmpArray2 in subroutine ReadAtomicPots.')
         ALLOCATE(DTmpArray3(n1),STAT = iError)
         CALL CheckAllocation(iError,'ERROR: Cannot allocate space for array iTmpArray3 in subroutine ReadAtomicPots.')
         ALLOCATE(DTmpArray4(n1),STAT = iError)
         CALL CheckAllocation(iError,'ERROR: Cannot allocate space for array DTmpArray1 in subroutine ReadAtomicPots.')

         CALL ReadArrayData('apot.bin', Double1 = DTmpArray1, Double2 = DTmpArray2, &
              & Double3 = DTmpArray3, Double4 = DTmpArray4, FileType = FileType, SectionNumber = NSect)
         IF(PRESENT(dgc0))   dgc0    = DTmpArray1
         IF(PRESENT(dpc0))   dpc0    = DTmpArray2
         IF(PRESENT(drho))   drho    = DTmpArray3
         IF(PRESENT(dvcoul)) dvcoul  = DTmpArray4

         DEALLOCATE(DTmpArray1, DTmpArray2, DTmpArray3, DTmpArray4)
      END IF

      NSect = NSect + 1
      IF(PRESENT(iphovr)) THEN
         ! Read iphovr.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', iphovr,  n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(nnovr)) THEN
         ! Read nnovr.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', nnovr,  n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(rho)) THEN
         ! Read rho.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', rho,  n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(dmag)) THEN
         ! Read dmag.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', dmag,  n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(rhoval)) THEN
         ! Read rhoval.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', rhoval, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(vcoul)) THEN
         ! Read vcoul.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', vcoul, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(xnvmu)) THEN
         ! Read xnvmu.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', xnvmu, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(xnval)) THEN
         ! Read xnval.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', xnval, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(eorb)) THEN
         ! Read eorb.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', eorb, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      ! PRINT*, 'Read rat'
      IF(PRESENT(rat)) THEN
         ! Read rat.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', rat, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(rovr)) THEN
         ! Read rovr
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', rovr, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(edens)) THEN
         ! Read edens.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', edens, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(edenvl)) THEN
         ! Read edenvl
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', edenvl, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(vclap)) THEN
         ! Read vclap.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', vclap, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(kappa)) THEN
         ! Read kappa.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', kappa, n1, n2, FileType = FileType)
      END IF

      NSect = NSect + 1
      IF(PRESENT(iorb)) THEN
         ! Read iorb.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         CALL Read2D('apot.bin', iorb, n1, n2, FileType = FileType)
      END IF
      
      NSect = NSect + 1
      IF(PRESENT(dgc)) THEN
         ! Read dgc.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         DO iph = 1, SIZE(dgc,3)
            CALL Read2D('apot.bin', dgc(:,:,iph), n1, n2, FileType = FileType)
         END DO
      END IF

      NSect = NSect + nph + 2
      IF(PRESENT(dpc)) THEN
         ! Read dpc.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         DO iph = 1, SIZE(dpc,3)
            CALL Read2D('apot.bin', dpc(:,:,iph), n1, n2, FileType = FileType)
         END DO
      END IF

      NSect = NSect + nph + 2
      IF(PRESENT(adgc)) THEN
         ! Read adgc.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         DO iph = 1, SIZE(adgc,3)
            CALL Read2D('apot.bin', adgc(:,:,iph), n1, n2, FileType = FileType)
         END DO
      END IF

      NSect = NSect + nph + 2
      IF(PRESENT(adpc)) THEN
         ! Read adpc.
         CALL ReadToSection('apot.bin',SectionNumber = NSect)
         DO iph = 1, SIZE(adpc,3)         
            CALL Read2D('apot.bin', adpc(:,:,iph), n1, n2, FileType = FileType)
         END DO
      END IF

      CALL CloseFl('apot.bin')
      ! PRINT*, 'Done reading information from atomic calculation.' 
    END SUBROUTINE ReadAtomicPots
    
        ! Hack for Fer's mt potentials
    SUBROUTINE WriteExternalPot(vtot, vint, edens, rhoint, rat, xmu, imt, rmt)
      DOUBLE PRECISION vtot(:,:), vint, edens(:,:), rhoint, rat(:,:), xmu, rmt(:), RadialGrid(251), xNElOut
      DOUBLE PRECISION,ALLOCATABLE :: ratTranspose(:,:)
      INTEGER nat, NRPts, i1, i2, imt(:), ncoord
      INTEGER,ALLOCATABLE :: iat(:)
      CHARACTER(30) FileName

      ncoord = 3
      FileName = 'extpot.aip'
      nat = 2
      ! Read number of atoms
      CALL WriteData(FileName, Int1 = nat, ForceNewSection = .TRUE.)

      ! Read atomic numbers
      ALLOCATE(iat(nat))
      iat(1) = 6
      iat(2) = 8
      CALL WriteArrayData(FileName, Int1 = iat, ForceNewSection = .TRUE.)
      
      ! Read coordinates
      ALLOCATE(ratTranspose(nat,3))
      DO i1 = 1, nat
         DO i2 = 1, 3
            ratTranspose(i1,i2) = rat(i2, i1)
         END DO
      END DO
      CALL Write2D(FileName, ratTranspose)

      ! Read number of radial points
      NRPts = 210
      CALL WriteData(FileName, Int1 = NRPts, ForceNewSection = .TRUE.)
      
      ! Read Interstitial potential
      CALL WriteData(FileName, Double1 = vint, ForceNewSection = .TRUE.)

      ! Read Fermi energy
      CALL WriteData(FileName, Double1 = xmu, ForceNewSection = .TRUE.)

      ! Read number of electrons outside muffin tins.
      xNElOut = 1
      CALL WriteData(FileName, Double1 = xNElOut, ForceNewSection = .TRUE.)

      ! Read muffin tin radii and jri.
      CALL WriteArrayData(FileName, Int1 = imt, Double2 = rmt, ForceNewSection = .TRUE.)
      
      ! Read radial grid, vtot, and edens
      DO i1 = 1, nat
         DO i2 = 1, NRPts
            CALL WriteData(FileName, Double1 = RadialGrid(i2), Double2 = vtot(i2,i1), Double3 = edens(i2,i1))
         END DO
      END DO

      CALL CloseFl(FileName)
    END SUBROUTINE WriteExternalPot


    ! Hack for Fer's mt potentials
    SUBROUTINE ReadExternalPot(vtot, vint, edens, rhoint, rat, xmu, imt, rmt)
      USE Mtdp
      USE IOFiles
      
      DOUBLE PRECISION vtot(:,:), vint, edens(:,:), rhoint, rat(:,:), xmu, rmt(:), RadialGrid(251), vTmp, xNElOut
      DOUBLE PRECISION :: rmt2(SIZE(rmt)), vtot2(SIZE(vtot,1),SIZE(vtot,2)), edens2(SIZE(edens,1),SIZE(edens,2)) 
      INTEGER nat, NRPts, i1, i2, imt(:), ncoord, iError, iSort(200), iunit
      INTEGER :: iz(SIZE(imt)), imt2(SIZE(imt))
      CHARACTER(30) PotFile, SortFile, mtdpFile
      TYPE(Mtdp_Data_Type) :: Mtdp_Data
      ncoord = 3
      PotFile  = 'extpot.aip'
      SortFile = 'sort.aip'
      mtdpFile = 'GeCl4.04.dft.mtdp'

      ! Read mtdp file.
      CALL OpenFl(mtdpFile,FileStatus='OLD',FileAction='READ')
      CALL GetIOFileInfo(mtdpFile, UnitNumber = iunit)
      CALL Read_Mtdp(iunit,Mtdp_Data)

      ! Number of points in the radial grid
      NRPts = Mtdp_Data%nR
      
      ! Number of atoms
      nat = Mtdp_Data%nAt
      
      ! For now atomic numbers are not needed.

      ! Atomic coordinates - ignore for now
!      rat(:,:) = Mtdp_Data%At_XYZ

      ! Muffin-Tin Radii
      rmt2(:nat) = Mtdp_Data%At_R(:)

      ! Index of the radii on the radial grid
      imt2(:nat) = Mtdp_Data%At_iR(:)

      ! Electron density inside each Muffin-Tin
      edens2(:,:nat) = Mtdp_Data%At_Den(:,:)

      ! Potential (H+XC) inside each Muffin-Tin
      vtot2(:,:nat) = Mtdp_Data%At_Pot(:,:)

      ! Empty spheres

      ! muffin tin radii
      rmt2(nat+1:Mtdp_Data%nESph+nat) = Mtdp_Data%ESph_R(:)
      
      ! muffin tin index
      imt2(nat+1:Mtdp_Data%nESph+nat) = Mtdp_Data%ESph_iR(:)

      ! Electron density inside each empty sphere
      edens2(:,nat+1:Mtdp_Data%nESph+nat) = Mtdp_Data%ESph_Den(:,:)

      ! Potential (H+XC) inside each empty sphere
      vtot2(:,nat+1:Mtdp_Data%nESph+nat) = Mtdp_Data%ESph_Pot(:,:)

      PRINT*, 'Old vint = ', vint
      ! Interstitial potential
      vint = Mtdp_Data%V_Int
      PRINT*, 'Enter vint: '
      READ*, vint    
    
      ! HOMO energy
      xmu = (Mtdp_Data%V_HOMO + Mtdp_Data%V_LUMO)/2.d0
!      xmu = Mtdp_Data%V_HOMO
      nat = nat + Mtdp_Data%nESph
      ! Read isort out of sort.aip. This tells which potentials go with which atoms in feff.
      iSort(:) = -1
      ! PRINT*, 'Reading iSort'
      CALL ReadArrayData(SortFile, Int1 = iSort)
      ! iSort(i1) is the unique potential given the i1th potential defined in the extpot.aip file.
      ! iSort can be zero, but arrays here are defined from 1, so we need to shift.
      DO i1 = 1, SIZE(iSort)
         iSort(i1) = iSort(i1) + 1
      END DO

      ! Fill vtot, edens, rmt, and imt with the proper values based on iSort
      DO i1 = 1, SIZE(iSort)
         IF(iSort(i1).gt.0) THEN
            ! Fill rmt and imt
            IF(iSort(i1).gt.nat) CALL Error('ERROR: Number of potentials defined '// &
              & 'in sort.aip is greater than number defined in extpot.aip.')
            rmt(iSort(i1)) = rmt2(i1)
            imt(iSort(i1)) = imt2(i1)
            
            ! Fill vtot and edens
            DO i2 = 1, NRPts
               vtot(i2,iSort(i1)) = vtot2(i2,i1)
               edens(i2,iSort(i1)) = edens2(i2,i1)
            END DO
         END IF         
      END DO
      
      ! If vint is too close to zero, reset it.
!      IF(vint.gt.-0.1d0) vint = -0.1d0
      DO i1 = 1, nat
         DO i2 = NRPts + 1, 251
            vtot(i2,i1) = vint
            edens(i2,i1) = rhoint
         END DO
      END DO

!      DO i1 = 1, 251
!         vtot(i2,nat+1) = vtot(NRPts,1)
!         edens(i2,nat+1) = edens(NRPts,1)
!      END DO

      CALL CloseFl(SortFile)
      CALL CloseFl(mtdpFile)
      ! PRINT*, 'Done reading external potential.'
    END SUBROUTINE ReadExternalPot

!     SUBROUTINE SplitMtDP(PotFiles,mtdpFile)
!       USE Mtdp
!       USE IOFiles
!       ! This subroutine reads an mtdp file and splits it into nph pot files.
!       ! Input is the array of potential file names.
!       CHARACTER PotFiles(:)

!       INTEGER iunit, iat
!       CHARACTER AtomLabel

!       CALL OpenFl(mtdpFile)
!       CALL GetIOFileInfo(UnitNumber = iunit)
!       CALL Read_Mtdp(iunit,Mtdp_Data)

!       DO iat = 1, Mtdp_Data%nAt
!          ! Number of points in the radial grid
!          Mtdp_Data%nR

!          CALL WriteData



    SUBROUTINE ReadExternalPotWien2k   ! (vtot, vint, edens, rhoint, rat, xmu, imt, rmt)

    END SUBROUTINE ReadExternalPotWien2k


      
END MODULE AtomicPotIO

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_controlkgen.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*****************************************************************************
!****************************************************************

!*****************************************************************
      module controlkgen

!    Do calculation of tetrahedra?
      logical, parameter :: dotets=.false.
!    Give lots of crazy output?
      logical, parameter :: verbose=.false.

        end module controlkgen

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_kgenwork.f90,v $:
! $Revision: 1.3 $
! $Author: jorissen $
! $Date: 2012/01/30 06:01:58 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      module kgenwork
!    Number of k-points asked for
      integer nka
!    Number of k-points in full mesh
      integer nkf
!    Number of k-points in irreducible mesh
      integer nki
!    Number of k-points in work arrays
      integer nkw
!    The mesh of k-points (full,irreducible,work)
      real*8,allocatable :: bkf(:,:),bki(:,:),bkw(:,:)
!    The mesh of k-points in sublattice units
      integer,allocatable :: bkwi(:,:)
!    A spare copy (different units ...)
      real*8,allocatable :: bki2(:,:)
!    The weights of k-points (full,irreducible,work)
      real*8,allocatable :: wf(:),wi(:),ww(:)
!    Correspondence of full to irr mesh
      integer,allocatable :: linkf(:),linkw(:)
!    Same correspondence - symmetry used
      integer,allocatable :: lsymf(:),lsymw(:)

        CONTAINS
          subroutine init_fullmesh(n)
            integer n
            allocate(bkf(3,n),wf(n),linkf(n),lsymf(n))
          end subroutine init_fullmesh

          subroutine init_irrmesh(n)
            integer n
            allocate(bki(3,n),wi(n))
            allocate(bki2(3,n))
          end subroutine init_irrmesh
        
          subroutine init_workmesh(n)
            integer n
            allocate(bkw(3,n),bkwi(3,n),ww(n),linkw(n),lsymw(n))
          end subroutine init_workmesh

          subroutine destroy_workmesh
            deallocate(bkw,bkwi,ww,linkw,lsymw)
          end subroutine destroy_workmesh

          subroutine destroy_meshes
            if(allocated(bkw)) deallocate(bkw)
            if(allocated(bkwi)) deallocate(bkwi)
            if(allocated(ww)) deallocate(ww)
            if(allocated(linkw)) deallocate(linkw)
            if(allocated(lsymw)) deallocate(lsymw)
            if(allocated(bki)) deallocate(bki)
            if(allocated(bki2)) deallocate(bki2)
            if(allocated(wi)) deallocate(wi)
            if(allocated(bkf)) deallocate(bkf)
            if(allocated(wf)) deallocate(wf)
            if(allocated(linkf)) deallocate(linkf)
            if(allocated(lsymf)) deallocate(lsymf)
          end subroutine destroy_meshes	


      end module kgenwork

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_tetrahedra.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      module tetrahedra

!    The number of tetrahedra
      integer ntet
!    The tetrahedra
      integer,allocatable :: itet(:,:)
!    Some work array
      integer,allocatable :: iy(:,:)
!    Some work array
      integer,allocatable :: ittfl(:)
!    Needed for dimensioning ittfl
        integer,parameter :: mwrit=101

      CONTAINS
          subroutine init_tetrahedra(n,m)
            integer n,m
        	allocate(itet(4,n*6),iy(4,6*m),ittfl(5*mwrit))
          end subroutine init_tetrahedra

          subroutine destroy_tetrahedra
           deallocate(itet,iy,ittfl)
          end subroutine destroy_tetrahedra

      end module tetrahedra

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_boundaries.f90,v $:
! $Revision: 1.10 $
! $Author: jorissen $
! $Date: 2012/04/03 22:39:49 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*****************************************************************************
!       DIMENSIONS FOR THE KKR STRUCTURE FACTOR ROUTINES
!*****************************************************************************
      module boundaries
      integer nlmax,nkmax,nkmmax,nkmpmax,nmuemax,nkkrmax
      integer nqmax
      integer NLLMMMAX,NQQPMAX,LGNT12,LLARR
	  integer NRDL,NG,NR ! The actualized values for NRDLMAX,NGRLMAX,NRDLMAX0 !KJ 2-2012

! summation limit >> setting up the structure constants
      integer,parameter :: J13MIN    = 113     
      integer,parameter :: J22MAX    = 100 !200 !120 !30  !Increase to 200 for energies up to E=40 Ry (series will peak at j=100)      
      integer,parameter :: NMARR     = 15 !12      
! store all non-0  gaunt coefficients:
!                 LGNT123 >=   100  for  l_max = 2
!                 LGNT123 >=   400  for  l_max = 3
!                 LGNT123 >=  1200  for  l_max = 4
!      integer,parameter :: LGNT123 =  1200    
      integer :: LGNT123 =  1200    
! G-vectors in reciprocal lattice
!      integer,parameter :: ngrlmax =  5000 !2000
      integer :: ngrlmax =  5000
! R-vectors in direct lattice
!      integer,parameter :: nrdlmax =  5000 !2000
      integer :: nrdlmax =  5000
! R-vectors in direct lattice -- initially
!      integer,parameter :: nrdlmax0=  10000 !5000
      integer :: nrdlmax0=  10000

!  FINALLY, these are MINE  (KJ) :
      integer maxl  ! maximal angular momentum index in the crystal
      integer msize ! size of most matrices in reciprocal space
      integer mls   ! size of matrices that do not depend on position


        CONTAINS
          subroutine init_boundaries(lin,nq)
            use controls,only : cplxylm
            implicit none
            integer,intent(in) :: lin,nq
! atom positions
            nqmax = nq
! gaunt coefficients:
		    if(lin.le.2) then
			   lgnt123=100
			elseif(lin.eq.3) then
			   lgnt123=400
			elseif(lin.ge.4) then
			   lgnt123=1200  !Will probably crash if lin>4 - but then so will much of the FEFF code ...
			endif
! angular momentum expansion of wave functions
            nlmax=lin+1
            nkmax=2*nlmax-1
            nkmmax=2*nlmax**2
            nkmpmax=2*nlmax**2+2*nlmax
            nmuemax=2*nlmax
            nkkrmax = nqmax * 2 * nlmax**2 
            if(cplxylm) then
               lgnt12=nlmax**4
            else   ! matrix is symmetric
             lgnt12=(nlmax**2*(nlmax**2+1)/2)
            endif
! inequivalent combination of lattice sites in structure constants matrix
            nqqpmax = nqmax*(nqmax-1)+1
            llarr=2*lin 
            nllmmmax=(2*lin+1)**2 

        end subroutine init_boundaries
        end module boundaries

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_energygrid.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*************************************************************************
      module energygrid
        complex*16,allocatable :: egrid(:)
        complex*16 emin,emax
        integer nene

        contains
           subroutine init_energygrid(n)
              implicit none
              integer n
              nene=n
              allocate(egrid(n))
              egrid=dcmplx(0,0)
           end subroutine init_energygrid
        end module energygrid

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_trafo.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      module trafo
      complex*16, allocatable :: crel(:,:),rrel(:,:),rc(:,:)
        real*8 mrotr(3,3,48)

      contains
           subroutine init_trafo(n)
             implicit none
             integer n
             allocate(crel(n,n),rrel(n,n),rc(n,n))
             crel=dcmplx(0,0)
             rrel=dcmplx(0,0)
             rc=dcmplx(0,0)
           end subroutine init_trafo
        end module trafo

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_wigner3j.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      module wigner3j
! Wigner 3j symbols needed to set up FEFF's t-matrix in routine fms2.

        real,allocatable :: t3jp(:,:,:),t3jm(:,:,:)

        contains
           subroutine init_wigner3j(l)
             implicit none
             integer,intent(in) :: l

             allocate(t3jp(0:l,-(l+1):(l+1),2),t3jm(0:l,-(l+1):(l+1),2))
! m-field is allowed to go up to l+1, in order to zero out m2=m1+1 contributions for m1=l
! in the setup of off-diagonal elements of the t-matrix in subr fms(2).
             t3jp=real(0)
             t3jm=real(0)
           end subroutine init_wigner3j
        end module wigner3j

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_workstrfacs.f90,v $:
! $Revision: 1.5 $
! $Author: jorissen $
! $Date: 2012/02/04 00:38:51 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*****************************************************************************
!       WORK ARRAYS FOR THE KKR STRUCTURE FACTORS
!*****************************************************************************
      module workstrfacs
! replaces COMMON /STRQQP/ , /STRLIM/ , /STRGNT/ , /CSRREL/ , /STRENE/
! plus variables nl,nlm,nkmq,ind0q
      COMPLEX*16,allocatable :: CIPWL(:),SRREL(:,:,:),IILERS(:,:,:)
        complex*16 edu
      REAL*8,allocatable :: gnt(:)
        real*8 GMAX,GMAXSQ,RMAX
      INTEGER,allocatable :: IGNT(:),IJQ(:,:),IRREL(:,:,:),             &
     &        NGNT(:),NIJQ(:),NRREL(:,:),SMAX(:),NKMQ(:),IND0Q(:)
      integer llmax,mmllmax,nmax,nqqp,nrtab,nl,nlm

      CONTAINS
          subroutine init_workstrfacs(nq)
            use boundaries
            implicit none
            integer nq
            allocate(CIPWL((2*NLMAX)**2),SRREL(2,2,NKMMAX),             &
     &      GNT(LGNT123),IGNT(LGNT123),IRREL(2,2,NKMMAX),NGNT(LGNT12),               &
     &        NRREL(2,NKMMAX),nkmq(nq),ind0q(nq)          &
     &        ) !,IILERS(0:LLARR,NRDLMAX,NQQPMAX)  )
          end subroutine init_workstrfacs
		  
          subroutine exit_workstrfacs
            implicit none
            deallocate(CIPWL,SRREL,GNT,IGNT,IJQ,IRREL,NGNT,NIJQ,        &
     &        NRREL,SMAX,nkmq,ind0q,IILERS)
          end subroutine exit_workstrfacs
		  
		  subroutine init_workstrfacs_b
		     use boundaries
			 if(nqqp.lt.1 .or. nrdl.lt.1) stop 'error calling init_workstrfacs_b too soon'
             allocate(IILERS(0:LLARR,NRDL,NQQP))
		  end subroutine init_workstrfacs_b

		  subroutine init_workstrfacs_c
		     use boundaries
			 if(nqqp.lt.1) stop 'error calling init_workstrfacs_c too soon'
             allocate(IJQ(NQQP,NQQP),NIJQ(NQQP),SMAX(NQQP))
		  end subroutine init_workstrfacs_c
          
        end module workstrfacs

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_workstrfacs2.f90,v $:
! $Revision: 1.9 $
! $Author: jorissen $
! $Date: 2012/03/27 22:46:31 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*****************************************************************************
!       MORE WORK ARRAYS FOR THE KKR STRUCTURE FACTORS
!*****************************************************************************

!KJ  Note: I'm generally a proponent of zeroeing everything explicitly.
! However, some of the arrays here are huge, and it takes time.
! So, I'm checking carefully whether it's really necessary given the way the code is currently (2-2012)
! and eliminating it where possible (i.e. where entire array is explicitly initialized before being used).

      module workstrfacs2
! replaces COMMON /STRACD/ , /STRCOM/ , /STRETA/ , /STRG/, /STRTSC/ , /STRHP/

      REAL*8 ALPHA0,ETA,ETA0
        real*8,allocatable :: BGX(:),BGY(:),BGZ(:),BRX(:),BRY(:),BRZ(:),&
     &       CQMLTAB(:,:),GGJLRS(:,:,:,:),HP(:),QJLTAB(:,:),            &
     &       QQPX(:),QQPY(:),QQPZ(:),QX(:),QY(:),QZ(:),T(:,:)
      COMPLEX*16 d300
        complex*16,allocatable :: D1TERM3(:),EXPGNQ(:,:),QQMLRS(:,:,:)
      INTEGER,allocatable :: G1(:),G2(:),G3(:),INDR(:,:),R1(:),R2(:),R3(:)
      integer g123max,r123max

      CONTAINS
          subroutine init_workstrfacs2
           use boundaries,only: llarr,nllmmmax,nqmax
           implicit none
           real*8, parameter :: rnul=0.d0
           complex*16,parameter :: cnul=(0.d0,0.d0)
		   ! Very small or "exactly the right size" allocations:
           allocate(BGX(3),BGY(3),BGZ(3),BRX(3),BRY(3),BRZ(3), QX(NQMAX),       &
             QY(NQMAX),QZ(NQMAX),QJLTAB(0:LLARR,0:LLARR),D1TERM3(0:LLARR),         &
             CQMLTAB(-LLARR:LLARR,0:LLARR),T(0:LLARR,0:LLARR), HP(NLLMMMAX)  )

           bgx=rnul;bgy=rnul;bgz=rnul;brx=rnul;bry=rnul;brz=rnul
           d300=cnul;d1term3=cnul;eta0=rnul
           !g1=0;g2=0;g3=0;r1=0;r2=0;r3=0;indr=0
           cqmltab=rnul;hp=rnul;qjltab=rnul;qx=rnul;qy=rnul;qz=rnul;t=rnul
          end subroutine init_workstrfacs2

          subroutine init_workstrfacs2_b(n)
		  integer,intent(in) :: n
           real*8, parameter :: rnul=0.d0
	       ! Allocations containing nqqpmax:
		   if(n.lt.1) stop 'error calling init_workstrfacs2_b too soon'
		   allocate(QQPX(n),QQPY(n),QQPZ(n))
!		   qqpx=rnul;qqpy=rnul;qqpz=rnul;
		  end subroutine init_workstrfacs2_b
		  
		  subroutine exit_workstrfacs2_b
		  deallocate(qqpx,qqpy,qqpz)
		  end subroutine exit_workstrfacs2_b
		  
		  
		  subroutine init_workstrfacs2_c(nr0,ndr,n) !for nrdlmax0,nrdlmax,nqqpmax
           use boundaries,only: nllmmmax,llarr,j22max
           implicit none
		   integer,intent(in) :: nr0,ndr,n
           real*8, parameter :: rnul=0.d0
           complex*16,parameter :: cnul=(0.d0,0.d0)
		   ! Allocations containing nrdlmax/nrdlmax0:  (very large)
			 if(n.lt.1.or.ndr.lt.1.or.nr0.lt.1) stop 'error calling init_workstrfacs2_c too soon'
		   allocate( GGJLRS(0:J22MAX,0:LLARR,ndr,N),QQMLRS(NLLMMMAX,ndr,N),INDR(nr0,N),R1(nr0),R2(nr0),R3(nr0))
!           qqmlrs=rnul;ggjlrs=rnul
           r1=0;r2=0;r3=0;indr=0  !these arrays are not fully initialized because smax(:) depends on iqqp
		   ! they are only used for the initialized fields - still, reason for caution.
          end subroutine init_workstrfacs2_c

		  subroutine init_workstrfacs2_d(ng,n)  ! for ngrlmax,nqqpmax
           implicit none
		   integer,intent(in):: ng,n
           complex*16,parameter :: cnul=(0.d0,0.d0)
		   ! Allocations containing ngrlmax:  (very large)
			 if(n.lt.1.or.ng.lt.1) stop 'error calling init_workstrfacs2_d too soon'
		   allocate( EXPGNQ(ng,N),G1(ng),G2(ng),G3(ng))
!           expgnq=cnul
!           g1=0;g2=0;g3=0
          end subroutine init_workstrfacs2_d
		  
          subroutine exit_workstrfacs2
           use boundaries
           implicit none
           deallocate(BGX,BGY,BGZ,BRX,BRY,BRZ,CQMLTAB,GGJLRS,HP,QJLTAB, &
     &       QQPX,QQPY,QQPZ,QX,QY,QZ,T,D1TERM3,EXPGNQ,QQMLRS,G1,G2,G3,  &
     &       INDR,R1,R2,R3)
          end subroutine exit_workstrfacs2


        end module workstrfacs2

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_workstrfacssimple.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      module workstrfacssimple
      
      REAL ETA
      real,allocatable :: BGX(:),BGY(:),BGZ(:),BRX(:),BRY(:),BRZ(:),    &
     &       QQPX(:),QQPY(:),QQPZ(:)
      COMPLEX d300
        complex,allocatable :: D1TERM3(:),EXPGNQ(:,:),QQMLRS(:,:,:)
      INTEGER,allocatable :: G1(:),G2(:),G3(:),R1(:),R2(:),R3(:)
      integer g123max,r123max
        complex edu
        real GMAXSQ
      INTEGER,allocatable :: SMAX(:)
      integer llmax,nmax,nqqp,nrtab,nl,nlm

      CONTAINS
          subroutine init_workstrfacssimple
           use boundaries
           use workstrfacs,only: smaxd=>smax,llmaxd=>llmax,             &
     & gmaxsqd=>gmaxsq,nmaxd=>nmax,nqqpd=>nqqp,                         &
     & nrtabd=>nrtab,nld=>nl,nlmd=>nlm	   
           use workstrfacs2,only: bgxd=>bgx,bgyd=>bgy,bgzd=>bgz,        &
     & brxd=>brx,bryd=>bry,brzd=>brz,qqpxd=>qqpx,                       &
     & qqpyd=>qqpy,qqpzd=>qqpz,g1d=>g1,g2d=>g2,g3d=>g3,                 &
     & r1d=>r1,r2d=>r2,r3d=>r3,g123maxd=>g123max,r123maxd=>r123max,     &
     & etad=>eta
           implicit none
           allocate(BGX(3),BGY(3),BGZ(3),BRX(3),BRY(3),BRZ(3),          &
     &       QQPX(NQQPMAX),QQPY(NQQPMAX),QQPZ(NQQPMAX),                 &
     &       D1TERM3(0:LLARR),EXPGNQ(NGRLMAX,NQQPMAX),                  &
     &       QQMLRS(NLLMMMAX,NRDLMAX,NQQPMAX),                          &
     &       G1(NGRLMAX),G2(NGRLMAX),G3(NGRLMAX),                       &
     &       R1(NRDLMAX0),R2(NRDLMAX0),R3(NRDLMAX0))
            allocate(SMAX(NQQPMAX))
! Copy only arrays that are fixed after initialization :	    	
            bgx=real(bgxd);bgy=real(bgyd);bgz=real(bgzd)
            brx=real(brxd);bry=real(bryd);brz=real(brzd)  
            qqpx=real(qqpxd);qqpy=real(qqpyd);qqpz=real(qqpzd)
            g1=g1d;g2=g2d;g3=g3d;r1=r1d;r2=r2d;r3=r3d
            g123max=g123maxd;r123max=r123maxd
            gmaxsq=real(gmaxsqd)
            eta=real(etad)
            smax=smaxd
            llmax=llmaxd;nmax=nmaxd;nqqp=nqqpd;nrtab=nrtabd
            nl=nld;nlm=nlmd

           end subroutine init_workstrfacssimple

          subroutine copy_workstrfacssimple
           use boundaries
           use workstrfacs,only: edud=>edu
           use workstrfacs2,only: d300d=>d300,d1term3d=>d1term3,        &
     & expgnqd=>expgnq,qqmlrsd=>qqmlrs
           implicit none
! Copy arrays that change for every energy	
            d300=cmplx(d300d)
            d1term3=cmplx(d1term3d)
            expgnq=cmplx(expgnqd)
            qqmlrs=cmplx(qqmlrsd)
            edu=cmplx(edud)
           end subroutine copy_workstrfacssimple
      
      end module workstrfacssimple


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: atomic.f90,v $:
! $Revision: 1.6 $
! $Author: jorissen $
! $Date: 2012/05/30 00:55:55 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
program atomic_pot

  !     calculate  el. density and potential given atomic positions for cluster atoms or other similar information
  !     calculation can vary in complexity: self-consistency (on/off), spin dependency (on/off), etc..
  !       coded by a.l. ankudinov 2000, for modular code structure
  !       modified by a.l. ankudinov 2001, for new i/o structure
  !       modified again K. Jorissen 2009

  !     INPUT files: pot.inp, geom.dat
  !     OUTPUT file: apot.bin
  use DimsMod
  use par
  use potential_inp,only: mpot
  use errorfile
  implicit none
  real*8 wall_start, wall_end
  integer ios

  call OpenErrorfileAtLaunch('atomic')	
  call par_begin
  call init_dimensions

  !     Initialize clock
  call seconds(wall_start)
  wall_comm = 0.0

  !     open the log file, unit 11.  See subroutine wlog.
  if (master) then
     open (unit=11, file='log1.dat', status='unknown', iostat=ios)
     call chopen (ios, 'log1.dat', 'feff')
  else
     par_type = 2
  endif

  !     INPUT: read data in pot.inp  and geom.dat files
  call reapot(.false.)  !KJ 1-2012 don't launch kprep since we won't need it -> saves 90% of runtime ...

  if (mpot .eq. 1)  then
     call wlog(' Calculating potentials ...')
     call AtomicPotentials
  endif

  !     OUTPUT: subroutine pot writes main output file pot.bin
  !     with information on potentials, necessary for other modules;
  !     additional output files can be obtained using PRINT card

  if (master) close (unit=11)

  !--   Time at end of run
  call seconds(wall_end)
  if (master .and. parallel_run) then
     write (6,*) 'total time    ', wall_end - wall_start
     write (6,*) 'communicate time', wall_comm
  endif

  call par_end

  call WipeErrorfileAtFinish
  stop
end program atomic_pot

  !       CONTROL mpot
  !       RGRID  rgrd
  !       TITLE title
  !        ntitle: number of title lines(default:0)
  !        title:  title lines(default:none)
  !       PRINT   ipr1:   print option (default:0)
  !       EXAFS, XANES, DANES, FPRIME, XES
  !        ispec: type of spectroscopy (default:0-EXAFS)
  !       NOHOLE: turn on/off core-hole potential
  !       HOLE  ihole: index of core-hole orbital
  !        gamach: core hole lifetime
  !       POTENTIALS card
  !        nph  - number of different potential types(default:1)
  !        iz - nicleus charge for each potential charge(default:none)
  !        lmaxsc - max orb momentum to calculate (default:3)
  !        xnatph - relative amount of atoms of each type (default:1)
  !       ION card
  !        xion - total initial charge for each potential type
  !               (iz + el.charge) which might be fractional (default:0)
  !       EXCHANGE card: ixc=2 for potential calculation
  !       JUMPRM: turn on potential jump removal at mt radius (default:0)
  !       AFOLP iafolp: turn on/off automatic overlap of muffintin spheres
  !       FOLP  folp: manual setting for overlapping muffin-tin spheres
  !       INTERSTITIAL inters (default:0)  totvol (default:0)
  !       SCF rfms1 lfms1 nscmt ca1 nmix ecv  icoul 
  !       OVERLAP geometry ( rarely used for EXAFS calculations only)

  !       ATOM card
  !         nat: number of atoms in a clsuter
  !         rat: x,y,z coordinates of all atoms
  !         iphat: which potential type correspond to each atom
  !         iatph: index of representative atom for each potential type

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: apot.f90,v $:
! $Revision: 1.22 $
! $Author: jorissen $
! $Date: 2012/09/11 22:52:14 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE AtomicPotentials !KJ 7-09 stuffed everything in modules !(nohole, nat, nph, ihole, iphat, rat, iatph, novr, iphovr, nnovr, rovr, xion, iunf, iz, ipr1)

  USE AtomicPotIO
  USE ErrorMod
  USE constants
  USE DimsMod
  USE par
  use config,only: IsOccupied, DumpConfig2
  use atoms_inp,only: nat,nph,iphat,iatph,rat
  use potential_inp,only: nohole, ihole, novr, iphovr, nnovr, rovr, xion, iunf, iz, ipr1
  !     Josh Kas - modified pot.f to calculate the atomic potentials separately from
  !                the scf loop. Note also that moveh has been removed.

  !     Cluster code -- multiple shell single scattering version of FEFF
  !     This program (or subroutine) calculates free atom potentials and
  !     saves the information in apot.bin
  !

  IMPLICIT NONE
  INTEGER, parameter :: NRPts = 251

  ! Input:
  ! iz(0:nphx) - atomic number, input
  ! nohole     - control over core-hole treatment
  ! nph        - number of unique pots
  ! ihole      - hole/edge code of absorbing atom
  ! iphat      - given specific atom, which unique pot?
  ! iunf       - freeze f-orbitals or not?
  ! ipr1       - print control
  ! nat        - number of atoms in problem.
  ! xion(0:nphx)  - ionicity, input
  !     rat(3,natx)  -  cartesian coords of specific atom
  !     iatph(0:nphx) - given unique pot, which atom is model?
  !                   (0 if none specified for this unique pot)
  !     novr(0:nphx)  - number of overlap shells for unique pot
  !     iphovr(novrx,0:nphx)  - unique pot for this overlap shell
  !     nnovr(novrx,0:nphx)  -  number of atoms in overlap shell
  !     rovr(novrx,0:nphx)   -  r for overlap shell

  ! Local varaibles:
  
  ! xionp         - temp variable to hole xion(iph)
  real*8 xionp

  !     overlapped density*4*pi
  real*8, allocatable :: edens(:,:), edenvl(:,:), vclap(:,:)

  !     ATOM output
  !     Note that ATOM output is dimensioned NRPts, all other r grid
  !     data is set to nrptx, currently 250
  !     rho(NRPts,0:nphx+1)     -   density*4*pi
  real*8, allocatable :: rho(:,:)
  !     rnrm - norman radius of each unique pot.
  real*8, allocatable :: rnrm(:), rnrmTmp(:)
  !     vcoul(NRPts,0:nphx+1)   -   coulomb potential
  real*8, allocatable :: vcoul(:,:)
  real*8 dr(NRPts), drho(NRPts), dvcoul(NRPts)

  !     need irregular solution for complex potential. fix later
  real*8 dgc0(NRPts), dpc0(NRPts)

  !     additioal data needed for relativistic version
  real*8, allocatable, dimension(:,:,:) :: dgc, dpc, adgc, adpc
  real*8, allocatable, dimension(:,:) :: rhoval,dmag, xnvmu, xnval, eorb,xnel !KJ 5-2012 added xnel througout to enable configuration output
  real*8 et, etinit, etfin, efrozn, erelax, emu, s02, hx, x0
  integer, allocatable :: kappa(:,:), iorb(:,:), norb(:), nqn(:,:)  !KJ 9-2012 added nqn

  CHARACTER*512 slog
  !     Josh use nhtmp to save nohole value
  integer nhtmp, nfree, i, ifree, ispinr, iph, itmp


10 format (4x, a, i5)

  ! Allocate local arrays:
  allocate(edens(NRPts,0:nphx), edenvl(NRPts,0:nphx),vclap(NRPts,0:nphx))
  allocate(rho(NRPts,0:nphx+1))
  allocate(rnrm(0:nphx), rnrmTmp(0:nphx))
  allocate(vcoul(NRPts,0:nphx+1))
  allocate(dgc(NRPts,30,0:nphx+1), dpc(NRPts,30,0:nphx+1))
  allocate(adgc(10,30,0:nphx+1), adpc(10,30,0:nphx+1), rhoval(NRPts,0:nphx+1))
  allocate(dmag(NRPts,0:nphx+1), xnvmu(0:lx,0:nphx+1))
  allocate(xnval(30,0:nphx+1), eorb(30,0:nphx+1), xnel(30,0:nphx+1))
  allocate(kappa(30,0:nphx+1), iorb(-4:3,0:nphx+1), norb(0:nphx+1),nqn(30,0:nphx+1))


  ! Initialize variables
  dgc(:,:,:) = 0.d0
  dpc(:,:,:) = 0.d0
  kappa(:,:) = 0
  nqn(:,:) = 0 !KJ
  edens(:,:) = 0.d0
  edenvl(:,:) = 0.d0
  vclap(:,:) = 0.d0
  rho(:,:) = 0.d0
  rnrm(:) = 0.d0
  rnrmTmp(:) = 0.d0
  adgc(:,:,:) = 0.d0
  adpc(:,:,:) = 0.d0
  rhoval(:,:) = 0.d0
  dmag(:,:) = 0.d0
  xnvmu(:,:) = 0.d0
  xnval(:,:) = 0.d0
  xnel(:,:) = 0.d0
  eorb(:,:) = 0.d0
  iorb(:,:) = 0
  norb(:) = 0
  vcoul(:,:) = 0.d0

  !     increase the length of hydrogen bonds for potential only
  call moveh (nat, iphat, iz, rat)

  !     Josh - for now if nohole=2 reset to 0 so that regular nohole
  !     potential is used
  nhtmp = nohole
  if (nohole.eq.2) nohole = 0
  !     Josh



  nfree = 1
  ! If any of the atoms are ionized, nfree = 2.
  do i=0,nph
     if (abs(xion(i)) .gt. 1.d-3) nfree = 2
  end do

  !     Free atom potentials and densities
  !     Final state is (usually) with a core hole, initial state is 
  !     w/o a corehole.
  !     NB wsatom is needed in SUMAX, if changed here, change it there

  !     do not save spinors
  !     Call twice if any of xion.neq.0 ( first time with xion=0 to set rnrm)

  do ifree = 1, nfree

     ispinr = 0
     ! Calculate for absorbing atom (iph = 0)
     iph = 0
     ! Calculate all edges up to ihole - 1
!      do itmp = 1, ihole - 1
!         ! Only calculate orbitals that contain at least one electron.
!         IF(IsOccupied(iz(0),itmp)) THEN
!            ! If user has specified NOHOLE, run and fill nph+1 elements of arrays
!            if (nohole.ge.0) then
!               xionp = xion(iph)               
!               if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
!               ! Run self-consistend dirac-fock atomic solver.
!               call scfdat ( ipr1, nph+1, nph, iz(0), itmp, xionp, iunf,    &
!                    &     vcoul(1,nph+1), rho(1,nph+1), dmag(1,nph+1), rhoval(1,nph+1),&
!                    &     ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,                    &
!                    &     s02, efrozn, et, xnvmu(0,nph+1),                             &
!                    &     xnval(1,nph+1), iorb(-4,nph+1), norb(nph+1),                 &
!                    &     eorb(1,nph+1), kappa(1,nph+1) )

!            ! Otherwise fill iph elements of arrays.
!            else
              
!               xionp = xion(iph)
!               if (nfree.eq.2 .and. ifree.eq.1) xionp = 0

!               ! Run self-consistent dirac-fock atomic solver.
!               call scfdat ( ipr1, iph, nph, iz(iph), itmp, xionp, iunf,    &
!                    &         vcoul(1,iph), rho(1,iph), dmag(1,iph), rhoval(1,iph),    &
!                    &         ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,                &
!                    &         s02, efrozn, et, xnvmu(0,iph),                           &
!                    &         xnval(1,iph), iorb(-4,iph), norb(iph),                   &
!                    &         eorb(1,iph), kappa(1,iph) )
!            endif
!            ! etfin is absorbing atom final state total energy, see nohole case below.
!            etfin(itmp) = et
!         END IF
!      end do
     ! Now calculate from 29 to ihole
!     do itmp = 29, ihole, -1
!KJ     IF(IsOccupied(iz(0),ihole)) THEN
     IF(IsOccupied(0,ihole)) THEN  !KJ 12-2010 
        if (nohole.ge.0) then
           xionp = xion(0)
           if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
           ! Run self-consistent dirac-fock atomic solver.
           call scfdat ( ipr1, nph+1, nph, iz(0), ihole, xionp, iunf,    &
                &     vcoul(1,nph+1), rho(1,nph+1), dmag(1,nph+1), rhoval(1,nph+1),&
                &     ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,                    &
                &     s02, efrozn, et, xnvmu(0,nph+1),                             &                           
                &     xnval(1,nph+1), xnel(1,nph+1), iorb(-4,nph+1), norb(nph+1),  &
                &     eorb(1,nph+1), kappa(1,nph+1), nqn(:,nph+1) )
        else
           xionp = xion(iph)
           if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
           ! Run self-consistent dirac-fock atomic solver.
           call scfdat ( ipr1, iph, nph, iz(iph), ihole, xionp, iunf,    &
                &         vcoul(1,iph), rho(1,iph), dmag(1,iph), rhoval(1,iph),    &
                &         ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,                &
                &         s02, efrozn, et, xnvmu(0,iph),                           &
                &         xnval(1,iph), xnel(1,iph), iorb(-4,iph), norb(iph),                   &
                &         eorb(1,iph), kappa(1,iph), nqn(:,iph) )
        endif
        ! etfin is absorbing atom final state total energy, see nohole case below.
        etfin = et
     ELSE
        WRITE(slog,'(I2)') ihole
        CALL Error('No electrons in initial state specified by ihole = ' // slog)
     END IF
!     end do
       
     ! Calculate for other potentials.
     do iph = 1, nph
        ! Calculate only if cell has an atom in it. Josh Kas
        IF(iz(iph).gt.0) THEN
           ! Write to log.
           write(slog,10) 'free atom potential and density for atom type', iph
           call wlog(slog)
           
           itmp = 0
           xionp = xion(iph)
           if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
           ! Run self-consistent dirac-fock atomic solver.
           call scfdat ( ipr1, iph, nph, iz(iph), itmp, xionp, iunf,    &
                &         vcoul(1,iph), rho(1,iph), dmag(1,iph), rhoval(1,iph),    &
                &         ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,                &
                &         s02, efrozn, et, xnvmu(0,iph),                           &
                &         xnval(1,iph), xnel(1,iph), iorb(-4,iph), norb(iph),                   &
                &         eorb(1,iph), kappa(1,iph), nqn(:,iph) )
        END IF
     end do ! End of loop over iph

     ! Now, run the absorbing atom again with no core hole.
     ! Write to log.
     write(slog,10) 'initial state energy'
     call wlog(slog)

     !     Save initial state energy and spinors for core hole orbital,
     !     do not save potentials, except for nohole.
     ispinr = ihole
     itmp = 0
     ! If user specified nohole, run with nohole and fill the iph = 0 element of
     ! arrays.
     if (nohole.ge.0) then
        iph = 0
        xionp = xion(iph)
        if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
        call scfdat ( ipr1, iph, nph, iz(iph), itmp, xionp, iunf,      &
             &         vcoul(1,iph), rho(1,iph), dmag(1,iph), rhoval(1,iph),    &
             &         ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,                &
             &         s02, efrozn, etinit, xnvmu(0,iph),                       &
             &         xnval(1,iph), xnel(1,iph), iorb(-4,iph), norb(iph),                   &
             &         eorb(1,iph), kappa(1,iph), nqn(:,iph) )

     ! Otherwise, run with nohole and fill the iph = nph+1 element of arrays.
     else        
        xionp = xion(0)
        if (nfree.eq.2 .and. ifree.eq.1) xionp = 0
        call scfdat ( ipr1, nph+1, nph, iz(0), itmp, xionp, iunf,      &
             &     vcoul(1,nph+1), rho(1,nph+1), dmag(1,nph+1), rhoval(1,nph+1),&
             &     ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc,                    &
             &     s02, efrozn, etinit, xnvmu(0,nph+1),                         &
             &     xnval(1,nph+1), xnel(1,nph+1), iorb(-4,nph+1), norb(nph+1),                 &
             &     eorb(1,nph+1), kappa(1,nph+1), nqn(:,nph+1) )
     endif

!KJ 5-2012.  Now that all calls to scfdat (->inmuat->getorb) are finished, output configuration information.
!            Moved this here so that it includes all core hole / screening / ionicity contributions.
     call DumpConfig2(112,xnel(:,0:nph),xnval(:,0:nph),nqn(:,0:nph),kappa(:,0:nph),norb(0:nph))

     !     testing new potential for the final state. ala
     hx = 0.05
     x0 = -8.8
     if (nohole.gt.0) then
        do i = 1,NRPts
           dr(i) = exp(x0+hx*(i-1))
        end do
        if (nohole.eq.1) then
           do i = 1,NRPts
              drho(i) = dgc0(i)**2 + dpc0(i)**2
           end do
        else
           do i = 1,NRPts
              drho(i)=dr(i)**2 * (rho(i,0)-rhoval(i,0)-rho(i,nph+1)+rhoval(i,nph+1))
           end do
        endif
        call potslw ( dvcoul, drho, dr, hx,NRPts)
        do i=1,NRPts
           !           drho(i) = drho(i)/ dr(i)**2
           !           use 1/2 of core-hole as in transition state
           drho(i) = drho(i)/2.0d0/ dr(i)**2
        end do
     else
        do i=1,NRPts
           drho(i) = 0
           dvcoul(i) = 0
        end do
     endif

     ! etinit is absorbing atom initial state (no hole)
     ! efrozn is ionization energy with frozen orbitals (koopman's theorem)
     ! etfin-etinit is ionization energy in adiabatic approximation
! Debug: Fer
!    print *, '-efrozn: ', -efrozn
!    print *, 'etinit: ', etinit
!    print *, 'etfin: ', etfin
     erelax = -efrozn - ( etfin - etinit)
     emu = etfin - etinit
! Debug: Fer
!    print *, ' emu 1: ', emu
        ! Josh - added check for low energy edges.
     IF(emu.le.0.d0) emu = -efrozn
! Debug: Fer
!    print *, ' emu 2: ', emu
     ! Find norman radius.
     ! Overlap potentials and densitites
     do iph = 0, nph
        write(slog,10)  'overlapped potential and density for unique potential', iph
        call wlog(slog)
        call ovrlp (iph, iphat, rat, iatph, novr, iphovr, nnovr, rovr, iz, nat, rho, dmag, rhoval, vcoul, edens, edenvl, vclap, rnrmTmp)
        if (iph.eq.0) emu = emu - vclap(1,0)+vcoul(1,0)
! Debug: Fer
!       print *, ' emu 3: ', emu
     end do
     
     if (ifree.eq.1) then
        ! Set the Norman radii if this is the atomic potential with no ionicity.
        rnrm(0:nph) = rnrmTmp(0:nph)
     endif

  end do ! End of loop over ifree

  CALL WriteAtomicPots(nph, iz(0:nph), ihole, rho, dmag(:,0:nph+1), rhoval, vcoul, dgc0,  &
       & dpc0, dgc(:,:,0:nph+1), dpc(:,:,0:nph+1), adgc(:,:,0:nph+1), adpc(:,:,0:nph+1), &
       & erelax, emu, xnvmu, xnval(:,0:nph+1), norb, eorb, drho, dvcoul, iphat,    &
       & rat, iatph(0:nph), novr(0:nph), iphovr, nnovr, rovr, nat, edens, &
       & edenvl, vclap,  rnrm(0:nph), kappa(:,0:nph+1), iorb(:,0:nph+1), s02)


  ! Deallocate local variables
  deallocate(edens, edenvl,vclap)
  deallocate(rho)
  deallocate(rnrm, rnrmTmp)
  deallocate(vcoul)
  deallocate(dgc, dpc)
  deallocate(adgc, adpc, rhoval)
  deallocate(dmag, xnvmu)
  deallocate(xnval, eorb)
  deallocate(kappa, iorb, norb)



END SUBROUTINE AtomicPotentials

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: chopen.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine chopen (ios, fname, mod)
!     Writes error msg and stops if error in ios flag from open
!     statement.  fname is filename, mod is module with failed open.
      character*(*) fname, mod
      character*512 slog
      external istrln

!     open successful
      if (ios .le. 0)  return

!     error opening file, tell user and die.
      i = istrln(fname)
      j = istrln(mod)
      write(slog,100)  fname(1:i), mod(1:j)
      call wlog(slog)

  100 format (' Error opening file, ', a,                               &
     &        ' in module ', a)

      call wlog(' Fatal error')
      call par_stop('CHOPEN')
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: wlog.f90,v $:
! $Revision: 1.4 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine wlog (string)
      use par
      character*(*) string
      integer istrln
      external istrln

!     This output routine is used to replace the PRINT statement
!     for output that "goes to the terminal", or to the log file.
!     If you use a window based system, you can modify this routine
!     to handle the running output elegantly.
!     Handle carriage control in the string you pass to wlog.
!
!     The log file is also written here, hard coded here.

!     The log file is unit 11.  The log file is opened in the
!     main program, program feff.

!     make sure not to write trailing blanks

   10 format (a)

!     Suppress output in sequential loops
      if (par_type .eq. 2) return

      il = istrln (string)
      if (il .eq. 0)  then
         print 10
         if (par_type .ne. 3) write(11,10)
      else
         print 10, string(1:il)
         if (par_type .ne. 3) write(11,10) string(1:il)
      endif
      return
      end
      subroutine lblank (string)
      character*(*) string
!     add a leading blank, useful for carriage control
      string = ' ' // string
      return
      end

!  **************************************************
!  Parallel feff8 routines
!  Jim Sims
!  **************************************************

      subroutine par_begin
!  **************************************************
!  Initializations for parallel version(s)
!  **************************************************

      use par

!-- So cvd or dbx can attach to a running process
!     call sleep(30) 

      numprocs = 1
      my_rank = 0
      this_process = my_rank

      par_type = 0
      parallel_run = .false.
!-- The following variable will be used for IO that should only be
!-- done in one process.
      master = (my_rank .eq. 0)

      worker = (.not. master)
      if (worker) par_type = 1

      return
      end

      subroutine par_stop (string)
!  **************************************************
!  Abnormal termination of the parallel session
!  **************************************************
      use par
!     For abnormal exits 
!     If open, close unit = 11
!     Go to the barrier that workers are sitting at
!     Then everyone will call par_end and stop
      logical is_open
      character*(*) string

      inquire(unit=11,opened=is_open)
      if (is_open) then
        call wlog(string)
        close(unit=11)
      else if (string .ne. ' ') then
        print *,string
        print *,'Abnormal termination on processor ',this_process
      endif

      stop ' '
      end

      subroutine par_end
!  **************************************************
!  Terminate the parallel session
!  **************************************************
      return
      end

      subroutine par_barrier
!  **************************************************
!  Calls mpi_barrier
!  **************************************************
      return
      end

      subroutine par_send_int(buf,count,dest,tag)
!  **************************************************
!  Call mpi_send for integer arrays
!  **************************************************
      integer count,dest,tag
      integer buf(*)
      return
      end

      subroutine par_send_int_scalar(buf,count,dest,tag)
!  **************************************************
!  Call mpi_send for integer arrays
!  **************************************************
      integer count,dest,tag
      integer buf
      return
      end


      subroutine par_send_cmplx(buf,count,dest,tag)
!  **************************************************
!  Call mpi_send for complex arrays
!  **************************************************
      integer count,dest,tag
      complex buf(*)
      return
      end

      subroutine par_send_real(buf,count,dest,tag)
!  **************************************************
!  Call mpi_send for real arrays
!  **************************************************
      integer count,dest,tag
      real buf(*)
      return
      end

      subroutine par_send_dc(buf,count,dest,tag)
!  **************************************************
!  Call mpi_send for double_complex arrays
!  **************************************************
      integer count,dest,tag
      complex*16 buf(*)
      return
      end

      subroutine par_recv_int(buf,count,source,tag)
!  **************************************************
!  Call mpi_recv for integer arrays
!  **************************************************
      integer count,source,tag
      integer buf(*)
      return
      end

      subroutine par_recv_int_scalar(buf,count,source,tag)
!  **************************************************
!  Call mpi_recv for integer arrays
!  **************************************************
      integer count,source,tag
      integer buf
      return
      end

      subroutine par_recv_cmplx(buf,count,source,tag)
!  **************************************************
!  Call mpi_recv for complex arrays
!  **************************************************
      integer count,source,tag
      complex buf(*)
      return
      end

      subroutine par_recv_real(buf,count,source,tag)
!  **************************************************
!  Call mpi_recv for real arrays
!  **************************************************
      integer count,source,tag
      real buf(*)
      return
      end

      subroutine par_recv_dc(buf,count,source,tag)
!  **************************************************
!  Call mpi_recv for double complex arrays
!  **************************************************
      integer count,source,tag
      complex*16 buf(*)
      return
      end

      subroutine par_bcast_int(buf,count,source)
!  **************************************************
!  Call mpi_bcast for integer arrays
!  **************************************************
      integer count,source
      integer buf(*)
      return
      end

      subroutine par_bcast_cmplx(buf,count,source)
!  **************************************************
!  Call mpi_bcast for complex arrays
!  **************************************************
      integer count,source
      complex buf(*)
      return
      end

      subroutine par_bcast_real(buf,count,source)
!  **************************************************
!  Call mpi_bcast for real arrays
!  **************************************************
      integer count,source
      real buf(*)
      return
      end

      subroutine par_bcast_dc(buf,count,source)
!  **************************************************
!  Call mpi_bcast for double_complex arrays
!  **************************************************
      integer count, source
      complex*16 buf(*)
      return
      end

      subroutine MPE_DECOMP1D( n, num_procs, myid, s, e )
!  ******************************************************
!  A routine for producing a decomposition of a 1-d 
!  array when given a number of processors.  It may 
!  be used in "direct" product decomposition.  The 
!  values returned assume a "global" domain in [1:n]
!  ******************************************************
!  MPE_Decomp1d - Compute a balanced decomposition of
!  a 1-D array
!  ******************************************************
!  Input Parameters:
!  n  - Length of the array
!  num_procs - Number of processors in decomposition
!  myid  - Rank of this processor in the decomposition 
!  (0 <= rank < size)
!  ******************************************************
!  Output Parameters:
!  s,e - Array my_particles are s:e, with the original 
!  array considered as 1:n.  
!  ******************************************************

      integer n, num_procs, myid, s, e
      integer nloc, deficit
 
      nloc  = n / num_procs
      s       = myid * nloc + 1
      deficit = mod(n,num_procs)
      s       = s + min(myid,deficit)
      if (myid .lt. deficit) then
        nloc = nloc + 1
      endif
      e = s + nloc - 1
      if (e .gt. n .or. myid .eq. num_procs-1) e = n

      return
      end

      SUBROUTINE SECONDS( W)
!  ***************************************************
!  SECONDS returns the wall clock times for a process
!  in seconds.
!  ***************************************************
 
      REAL*8      W

      W = 0.0

      RETURN
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: reapot.f90,v $:
! $Revision: 1.22 $
! $Author: jorissen $
! $Date: 2012/05/30 00:55:55 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine reapot(run_kpreppot) !KJ put everything in modules 7-09

!KJ for reciprocal space code :
        use DimsMod
        use controls
        use struct,nphkevin=>nph
        use kklist
        use strfacs
        use constants
		use potential_inp
		use atoms_inp
		use reciprocal_inp
        implicit none

!     Local stuff
      logical,intent(in) :: run_kpreppot
      character*32 s1, s2, s3
	  real*8 celvin !KJ scaling factor for volume of unit cell - hidden option
	  integer i,iat,istart,iend,ilen,iph,iovr
	  integer,external :: istrln


      call atoms_read !read geom.dat
      call potential_read !read pot.inp
	  
	  if(mpot.le.0) return  !KJ 2-2012

      !KJ Next section added for k-space calculations
      nphkevin=nph !KJ temp fix here - need to have same value in both modules!!
      call init_controls
      call reciprocal_read(celvin)  ! read reciprocal.inp
	  if (nohole.ge.0) corehole=.false. !KJ if NOHOLE 2, corehole needs to be used in fms but *not* in pot !!

      if(spacy.eq.0) then
		   !KJ next lines : initialize nsp in the struct module (old routines will use same value reinitialized by fmstot).
           nsp = 1
           !normally, I use :           if (abs(ispin).eq.1 ) nsp = nspx
           !however, this module does not read global.dat !!
           !therefore, temp fix :
           if(nspx.eq.2) call wlog('Using nsp=1 in mod1.  Please fix or complain to Kevin if you need nsp=2.')	   
           lpot(0:nph)= lmaxsc(0:nph)  ! copy lmaxsc into lpot
		  ! if (run_kpreppot) run_kpreppot = (nscmt.gt.0)  !Don't spend time on initialization if we don't need to do SCF
      endif

      makekmeshnow=.true.
      if(spacy.eq.0 .and. run_kpreppot )  then !KJ prepare the k-mesh
	     if(ktype.eq.2 .or. ktype.eq.3) then
		    !KJ 1-2012 potentials optionally run with k-mesh that's 5 times smaller than k-mesh for fms/ldos.
			! For practical reasons, not possible to specify x/y/z k-mesh.
		    nkp=nkp/5
			nkx=nkp
			nky=0
			nkz=0
		 endif
         a1=a1/bohr  ! lattice constants in bohr
         a2=a2/bohr
         a3=a3/bohr
         celvin=celvin/(bohr**3)
         call crystalstructure(celvin)

		 if(nscmt.gt.0) then  !If no SCF we don't need to set up structure constants - saves loads of time for large unit cells  KJ 2-2012
         if(makekmeshnow) then
            call kmesh
!            open(27,file='kvectors.txt')
!            do i=1,nkp
!                 write(27,'(i4,3f12.4)') i,bk(:,i)
!              enddo
!c           k-mesh in fractional units 0-1 for strfac
!	      do i=1,3
!	         bk(i,:)=bk(i,:) * alat(1) /(dble(2)*pi) ! I suspect alat(i) needs to be replaced by alat(1) !KJ fix later
!	      enddo

         else
!c          klist.inp  !KJ added 8/06
            open(3,file='klist.inp',form='formatted',status='old')
            read(3,*)
            read(3,*) nkp,usesym,ktype
            call init_kklist(nkp,nsym) !KJ 6-09
            read(3,*)
            do i=1,nkp
               read(3,*) bk(:,i),weight(i)
            enddo
            close(3)
!           k-mesh in fractional units 0-1 for strfac
            call wlog('assuming a klist.inp in Angstrom')
            call wlog('update these instructions !!')
            do i=1,3
               bk(i,:)=bk(i,:) * alat(i)/(dble(2)*pi) *bohr  !remove *bohr if klist.inp is in a.u.
            enddo
         endif

!KJ kprep called here in mod1 (not in mod2 and mod3) :
         if (run_kpreppot) call kpreppot   ! executed for "pot" but not for "atomic"
		 endif ! nscmt > 0 (i.e. do SCF)
      endif
! !KJ end my changes


!     transform to code units (bohrs and hartrees - atomic units)
      rfms1 = rfms1 / bohr
      gamach = gamach / hart
      ecv   = ecv   / hart
      totvol = totvol / bohr**3
      do 210 iat = 1, nat
      do 210 i = 1,3
        rat(i,iat) = rat (i, iat) / bohr
  210 continue
      do 220 iph = 0, nph
      do 220 iovr = 1, novr(iph)
         rovr(iovr,iph) = rovr(iovr,iph) / bohr
  220 continue

!     add lines to the title
      if (mpot.eq.1) then
         ntitle = ntitle + 1
         if (nat.gt.1) then
           if (rfms1.lt.0) rfms1 = 0
           if (nscmt.gt.0) then
             write(s1, 230) nscmt, rfms1*bohr, lfms1
  230        format(' POT  SCF', i4, f8.4, i4)
           else
             write(s1, 235) 
  235        format(' POT  Non-SCF' )
           endif
         else
           write(s1, 240) 
  240      format(' POT  used OVERLAP geometry,')
         endif
         if (nohole.eq.0) then
           write(s2, 310) 
  310      format(', NO core-hole,')
         elseif (nohole.eq.2) then
           write(s2, 315) 
  315      format(', screened core-hole,')
         else
           write(s2, 320) 
  320      format(', core-hole,')
         endif
         if (iafolp.lt.0) then
           write(s3, 330) folp(0)
  330      format(' FOLP (folp(0)=', f6.3, ')' )
         else
           write(s3, 340) folp(0)
  340      format(' AFOLP (folp(0)=', f6.3, ')' )
         endif
!        concatenate 3 strings into 1
         title(ntitle) = ' '
         ilen = istrln(s1)
         istart = 1
         iend = ilen
         title(ntitle)(istart:iend) = s1(1:ilen)
         ilen = istrln(s2)
         istart = iend + 1
         iend = iend + ilen
         title(ntitle)(istart:iend) = s2(1:ilen)
         ilen = istrln(s3)
         istart = iend + 1
         iend = iend + ilen
         title(ntitle)(istart:iend) = s3(1:ilen)
      endif

      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: potslw.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine potslw (dv,d,dr,dpas,np)
!
! coulomb potential uses a 4-point integration method
! dv=potential;  d=density;  dp=bloc de travail; dr=radial mesh
! dpas=exponential step;
! np=number of points
! **********************************************************************

      implicit double precision (a-h,o-z)
      dimension dv(251), d(251), dp(251), dr(251)

      das=dpas/24.0
      do 10 i=1,np
   10 dv(i)=d(i)*dr(i)
      dlo=exp(dpas)
      dlo2=dlo*dlo
      dp(2)=dr(1)*(d(2)-d(1)*dlo2)/(12.0*(dlo-1.0))
      dp(1)=dv(1)/3.0-dp(2)/dlo2
      dp(2)=dv(2)/3.0-dp(2)*dlo2
      j=np-1
      do 20 i=3,j
   20 dp(i)=dp(i-1)+das*(13.0*(dv(i)+dv(i-1))-(dv(i-2)+dv(i+1)))
      dp(np)=dp(j)
      dv(j)=dp(j)
      dv(np)=dp(j)
      do 30 i=3,j
      k=np+1-i
   30 dv(k)=dv(k+1)/dlo+das*(13.0*(dp(k+1)/dlo+dp(k))-(dp(k+2)/dlo2+dp  &
     & (k-1)*dlo))
      dv(1)=dv(3)/dlo2+dpas*(dp(1)+4.0*dp(2)/dlo+dp(3)/dlo2)/3.0
      do 40 i=1,np
   40 dv(i)=dv(i)/dr(i)
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: scfdat.f90,v $:
! $Revision: 1.8 $
! $Author: jorissen $
! $Date: 2012/09/11 22:52:14 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine scfdat ( ipr1, iph, nph, iz, ihole, xion, iunf, vcoul,  &
     &     srho, dmag, srhovl, ispinr, dgc0, dpc0, dgc, dpc, adgc, adpc, &
     &     s02, efrozn, eatom, xntot, xnval, xnel_out, indorb, norbp, eorb, kappa,nq2)   !KJ 5-2012 added xnel_out, nqn for output
  !     single configuration Dirac-Fock atom code
  !     Ankudinov, Zabinsky, Rehr, Comp.Phys. Comm. 98, p.359 (1996).
  !     which is modified Desclaux multi-configuration code.
  !     written by a.ankudinov 1996
  use DimsMod
  use par
  implicit double precision (a-h,o-z)
  !     save central atom dirac components, see comments below.
  dimension dgc0(251), dpc0(251)

integer nq2(30) !KJ

  real*8, intent(inout) :: dgc(251, 30, 0:nphx), dpc(251, 30, 0:nphx)
  real*8, intent(inout) :: adgc(10, 30, 0:nphx), adpc(10, 30, 0:nphx)

  real*8, intent(inout) :: xntot(0:lx)

  dimension xnval(30), eorb(30), kappa(30), xnel_out(30)
  dimension xmag(30)
  
  dimension vcoul(251)
  dimension srho(251), dmag(251), srhovl(251)
  !     temporary do not use core-valence separation
  dimension xnvalp(30), indorb(-4:3)
  logical open_16
  
  dimension ovpint(30, 30)
  character*30 fname
  !#mn:
  external dsordf

  ! muatco programm to calculate angular coefficients
  !        this programm uses cofcon cofdat dsordf ictime iowrdf
  !        lagdat messer nucdev ortdat potrdf soldir 
  common cg(251,30), cp(251,30), bg(10,30), bp(10,30), fl(30), fix(30), ibgp
  ! cg (cp) large (small) components
  ! bg (bp) development coefficients at the origin of large
  !    (small) component
  ! fl power of the first term of development limits.
  ! ibgp first dimension of the arrays bg and bp
  
  common/comdir/ cl, dz, gg(251), ag(10), gp(251), ap(10), bid(783)
  !  gg,gp are the output from soldir
  common/itescf/ testy, rap(2), teste, nz, norb, norbsc
  common/mulabk/ afgk
  common/inelma/ nem
  dimension afgk(30, 30, 0:3)
  common/messag/ dlabpr, numerr
  character*8 dprlab, dlabpr
  common/ratom1/ xnel(30), en(30), scc(30), scw(30), sce(30), nq(30), kap(30), nmax(30)
  common/scrhf1/ eps(435), nre(30), ipl
  common/snoyau/ dvn(251), anoy(10), nuc
  common/tabtes/ hx, dr(251), test1, test2, ndor, np, nes, method, idim
  data dprlab /'  scfdat'/
      
  ! if ipr1 > 3, print atomNN.dat
  if (ipr1 .ge. 3 .and. iph.le.nph)  then
     !        do not want to have extra file
     !        prepare file for atom output
     write(fname,14)  iph
14   format('atom', i2.2, '.dat')
     if (master) then
        open (unit=16, file=fname, status='unknown', iostat=ios)
        write (16,*)  ' free atom ', iph
     endif
     !        call chopen (ios, fname, 'atom')
     !        call head (16)
  endif
  
  !  initialize the data and test parameters
  jfail = 0
  ibgp = 10
  numerr = 0
  nz = iz
11 call inmuat (ihole, xion, iunf, xnval, iholep, xmag, indorb, iph,nq2) !KJ 12-2010 added iph
   
  
  idfock = 1
  !     idfock = 2
  !     idfock=1  --  pure Dirac-Fock.
  !     idfock=2  --  pure LDA
  !     idfock=5  --  exchange 5 model.
  !     idfock=6  --  exchange 6 model.
  if (idfock.eq.1) then 
     do 42 i=1,30
42      xnvalp(i) = 0.0d0
  elseif (idfock.eq.2) then
     do 44 i=1,30
44      xnvalp(i) = xnel(i)
  else
  !        use core-valence separation. also change vlda.f
     do 43 i=1,30
43      xnvalp(i) = xnval(i)
  endif

           !     iholep is the index for core hole orbital in all arrays
           !     ihole is just a code number for given core hole
           !     for 90% of atoms iholep=ihole
           ilast = 0

!   calculate initial orbitals using thomas-fermi model ido=1
!   option to read from cards(ido=2) destroyed
      ido = 1
      if (numerr .eq. 0) then
         a = -xion - 1
         call wfirdf (en, a, nq, kap, nmax, ido)
      endif

      niter = 30
! if niter is negative then schmidt orthogonalization procedure is used
!           niter =1000*n1+100*n2+n3
! n3 is the number of iterations per orbital
      j = 1
      ind = 1
      nter = 0
      do 41 i = 1, norb
 41   scw(i) = 0.
      test1 = testy / rap(1)
      test2 = testy / rap(2)
      netir = abs(niter) * norb
      if (ipr1 .ge. 5 .and. iph.le.nph .and. master)  then
         write(16,210) niter, teste, testy
  210    format (5x,'number of iterations',i4,//,                       &
     &        5x,'precision of the energies',1pe9.2,//,                 &
     &        23x,'wave functions  ',1pe9.2,/)
         write(16,220) idim, dr(1), hx
  220    format (' the integration is made on ', i3,                    &
     &        ' points-the first is equal to ' ,f7.4,/,                 &
     &        ' and the step-size pas = ',f7.4,/)
         write(16,230) test1, nes
  230    format ('matching of w.f. with precision', 1pe9.2,             &
     &        ' in ',i3,' attempts ',/)
         if (nuc .gt. 1)  write(16,250)
  250    format (1h0, 30x,'finite nucleus case used'/)
      endif
 
!     angular coefficients 
!     corrected for valence model. ala
      call muatco(xnvalp)
      if (numerr .ne. 0) go to 711

!     iteration over the number of cycles
 101  iort = 0
         nter = nter + 1
         if (niter .ge. 0) go to 105
!        orthogonalization by schmidt procedure
 104     call ortdat (j)
 105     method = 1
!        calculate lagrange parameters
         if (nre(j).gt.0 .and. ipl.ne.0) call lagdat (j,1)
!        calculate electron potential
         call potrdf (j)
!        add potential due to xc with valence electrons
         call vlda (j, xnval, srho, srhovl, dmag, ilast, idfock)
         e = en(j)
         np = idim
!        resolution of the dirac equation
         ifail = 0
         ainf = cg(nmax(j),j)
         call soldir (en(j), fl(j), bg(1,j), bp(1,j), ainf,             &
     &                nq(j), kap(j), nmax(j), ifail)
         if (ifail.ne.0 .and. jfail.eq.0) jfail = j
         if (jfail.eq.j .and. ifail.eq.0) jfail = 0
         if (numerr .eq. 0) go to 111
         if (iort.ne.0 .or. niter.lt.0) go to 711
         iort = 1
         go to 104

 111     sce(j) = abs ((e - en(j)) / en(j))
!        variation of the wave function using two iterations
         k = nmax(j)
         pr = 0.
         do 121 i = 1, k
            w = cg(i,j) - gg(i)
            if (abs(w) .le. abs(pr)) go to 115
            pr = w
            a = cg(i,j)
            b = gg(i)
 115        w = cp(i,j) - gp(i)
            if (abs(w) .le. abs(pr)) go to 121
            pr = w
            a = cp(i,j)
            b = gp(i)
 121     continue
!        write original Desclaux output on screen and into the logfile
!        write (slog,'(i4, i3, 2(1pe11.2), 2(1pd16.6), 4x, a, i2)')
!    1   nter, j, sce(j), pr, a, b, 'method', method
!        call wlog(slog)

!        acceleration of the convergence
         b = scc(j)
         call cofcon (a, b, pr, scw(j))
         scc(j) = b
         do 151 i = 1, k
            gg(i) = b * gg(i) + a * cg(i,j)
 151        gp(i) = b * gp(i) + a * cp(i,j)
         do 155 i = 1, ndor
            ag(i) = b * ag(i) + a * bg(i,j)
 155        ap(i) = b * ap(i) + a * bp(i,j)
!        normalization of the wave function
         a = dsordf (j, k, 0, 4, fl(j))
         a = sqrt(a)
         do 171 i = 1, np
            cg(i,j) = gg(i) / a
 171        cp(i,j) = gp(i) / a
         do 175 i = 1, ndor
            bg(i,j) = ag(i) / a
 175        bp(i,j) = ap(i) / a
!        determination of the next orbital to calculate
         if (nter.lt.norbsc .or. (ind.lt.0 .and. j.lt.norbsc)) then
            j = j + 1
            go to 451
         endif
            j = j + 1
         pr = 0.
         do 301 i = 1, norbsc
            w = abs (scw(i))
            if (w .gt. pr) then
               pr = w
               j = i
            endif
 301     continue
         if (j .gt. norbsc) j = 1
         if (pr .gt. testy) go to 421
         pr = 0.
         do 321 i = 1, norbsc
            w = abs (sce(i))
            if (w .gt. pr) then
               pr = w
               j = i
            endif
 321     continue
         if (pr .ge. teste) go to 421
         if (ind .lt. 0) go to 999
         ind = -1
         j = 1
         go to 451

 421     ind = 1
 451  if (nter .le. netir) go to 101
      numerr= 192011
! **** number of iterations exceeded the limit
      dlabpr = dprlab
 711  call messer
      call par_stop('SCFDAT-1')
 999  if (numerr .eq. 0) then
         if (jfail .ne. 0) then
            call par_stop(                                              &
     &    '  Failed to match lower component, results are meaningless')
!           stop
         endif
!        tabulation of the results
         if (ipr1 .ge. 5 .and. iph.le.nph)  call tabrat
         call etotal (16, kap, xnel, xnvalp, en, eatom)
         do 504 ix = 1,251 
 504       dmag(ix)=0.0d0 
         ilast = 1
         iorb = 0
!        use to test SIC
!         do 505 iorb = 1,norb
 505       call vlda (iorb, xnval, srho, srhovl, dmag, ilast, idfock)
         ecorr =2.0
         call somm(dr,dmag,dmag,hx, ecorr,0,idim)
         eatom = (eatom-ecorr/4.0) 

!        jcore = 1

!        prepare information for SCMT and core-valence separation
         norbp = norb
         do 499 i = 0,lx
  499    xntot(i)=0.0d0
         do 500 j = 1, norb
           eorb(j) = en(j) 
           kappa(j) = kap(j)
           i = kap(j)
           if (kap(j) .lt.0) i=-kap(j)-1
           if (i.le.lx) xntot(i)=xntot(i)+xnval(j)
  500    continue
! 500     if (xnel(j).gt.xnval(j) .and. nmax(j).gt.jcore) jcore=nmax(j)

!  get difference in spin-up and -down densities per spin 
!  the spin - polarizable orbitals are specified in subroutine getorb
!  The spin amplitude and directions are taken care of in subroutine ovrlp
!  and specified in feff.inp file
         spin = 0
         do 530 i = 1, idim
  530    dmag(i) = 0.0
         do 536 iorb = 1, norb
           spin = spin + xmag(iorb)
           do 535 i = 1, np
  535      dmag(i)= dmag(i)+ xmag(iorb)* (cg(i,iorb)**2 + cp(i,iorb)**2)
  536    continue
         if (spin.gt.0.d0) then
!          normalize dmag per  spin
           do 537 i = 1, np
  537      dmag(i) = dmag(i) / spin
         endif

!  return coulomb potential
!  fix later: can be replaced by potrdf
         call potslw (vcoul, srho, dr, hx, idim)
         do 510 i = 1, 251
  510      vcoul(i) = (vcoul(i) - nz / dr(i)) 

!        return srho as 4*pi*density instead of 4*pi*density*r**2
         do 560  i = 1, 251
            srho(i) = srho(i) / (dr(i)**2)
            dmag(i) = dmag(i) / (dr(i)**2)
            srhovl(i) = srhovl(i) / (dr(i)**2)
  560    continue

         if (ipr1 .ge. 3 .and. iph.le.nph)  close(unit=16)

         if (ispinr .ne. 0)  then
!        need kap(i) for central atom without core hole, all output of
!        getorb is dummy, except iholep and kap(i) which is put in nq(i)
            call getorb (iz, ispinr, xion, iunf, i, j, indorb, iholep, nre, nq, scw, sce, eps, iph) !KJ 2-2011 added iph
			nq2(1:30)=nq(1:30) !KJ 9-2012
            do 552  i = 1, nmax(iholep)
               dgc0(i) = cg(i,iholep)
               dpc0(i) = cp(i,iholep)
  552       continue
            do 553  i = nmax(iholep) + 1, 251
               dgc0(i) = 0.0d0
               dpc0(i) = 0.0d0
  553       continue
         endif

         do 590 j = 1, 30
            do 570 i = 1, nmax(j)
               dgc(i,j,iph) = cg(i,j)
               dpc(i,j,iph) = cp(i,j)
  570       continue
            do 575 i = nmax(j) + 1, 251
               dgc(i,j,iph) = 0.0d00
               dpc(i,j,iph) = 0.0d00
  575       continue
            do 580 i = 1, 10
               adgc(i,j,iph) = bg(i,j)
               adpc(i,j,iph) = bp(i,j)
  580       continue
  590    continue
      endif

!     calc. overlap integrals for the final and initial state orbitals
!     of the central atom
      if (iholep .gt. 0 .and. iholep.lt.30 .and. ihole.le.0) then
!        this logic is fulfilled only in the last call of scfdat
!        in subroutine pot ( ihole=0 and iholep=ispinr.neq.0)
         efrozn = en(iholep) 
         do 790 i = 1, norb
!          to handle special case when electron added to new orbital
           if (nq(i) .eq. kap(i)) then
              itr = 0
           elseif (nq(i+1) .eq. kap(i)) then
              itr = 1
           else
              call wlog                                                 &
     &        ('  If it is not la, gd or np, please, give us a call')
              call wlog('  s02 is overestimated')
              do 710 j = 1, i - 1
  710            ovpint(j,i) = 0.0
              ovpint(i,i) = 1.0
              goto 780
           endif
           i0 = i + itr
           iph1 = 0
           if (iph.eq.0) iph1 = nph + 1
           do 720 ir = 1, idim
             gg(ir) = dgc(ir, i0, iph1)
  720        gp(ir) = dpc(ir, i0, iph1)
           do 730 ir = 1, ndor
              ag(ir) = adgc(ir, i0, iph1)
  730         ap(ir) = adpc(ir, i0, iph1)
           do 770 j = 1, norb
             if (kap(i) .ne. kap(j)) go to 770
             ovpint(i,j) = dsordf ( j, j, 0, 3, fl(i))
  770      continue
  780      continue
  790    continue
         do 810 j=1,norb
             xnel(j) = xnel(j)-xnval(j)
 810     continue

!        need better control here. for now always print fpf0.dat
!        if (ipr1.ge.3) call  fpf0 ( iz, iholep, srho, dr, hx,
         call  fpf0 ( iz, iholep, srho, dr, hx,                         &
     &     dgc0, dpc0, dgc, dpc,                                        &
     &     eatom, xnel, norb, eorb, kappa)

         call s02at (iholep, norb, kap, xnel, ovpint, s02)
!        print*,'z=',iz, '   s02 calculated = ', s02
      endif
	  
	  xnel_out=xnel  !KJ 5-2012 for output

      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: moveh.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine moveh (nat, iphat, iz, rath)
!    Increase length of bonds with hydrogen atoms
!    Move Hydrogens for potentials. Otherwise MT geometry is screwed up.
        use DimsMod

      implicit double precision (a-h, o-z)

!     input is everything; output is modified  atomic coordinates (rath) 
!     nat is number of atoms in cluster
      dimension iphat(natx),  iz(0:nphx)
      dimension rath(3,natx)

      do 970 iat = 1, nat
        if (iz(iphat(iat)) .eq. 1) then
!         find the nearest atom A, units for rat are bohr.
          rah = 100
          ia = 0
          do i = 1,nat
              rattmp = dist(rath(1,iat), rath(1,i) )
              if (rattmp.lt. rah .and. i.ne. iat) then
                 ia = i
                 rah = rattmp
              endif
          enddo
          if (iz(iphat(ia)).eq.1) goto 970

!         set max distance as function of rah ( set by calculations
!         for H2O and GeH4)
          ratmax = rah + 4.d0/rah**2 

!        find shortest AB bond (neither A or B are H)
          rab = 10
          ib = 0
          do i = 1,nat
              rattmp = dist(rath(1,ia), rath(1,i))
              if (i.ne.ia .and. iz(iphat(i)).ne.1 .and.                 &
     &            rab.gt.rattmp) then
                 rab = rattmp
                 ib = i
              endif
          enddo
          if (rab.lt.ratmax) ratmax = 0.95*rab + 0.05*rah
          if (rah .gt. ratmax) goto 970

!         increase rah to ratmax and check that A is still closest to H
          ratmin = rah
  960     do i = 1,3
           rath(i,iat)=rath(i,ia)+ratmax/ratmin*(rath(i,iat)-rath(i,ia))
          enddo
          rbh = 10
          ib = 0
          do i = 1,nat
              rattmp = dist(rath(1,iat), rath(1,i))
              if (i.ne.iat .and. rbh.gt.rattmp) then
                 rbh = rattmp
                 ib = i
              endif
          enddo

          if (ia.ne.ib) then
             rab = dist(rath(1,ia),rath(1,ib))
             rattmp = ratmax*rab**2/(ratmax**2+rab**2-rbh**2)
             ratmin = ratmax
             ratmax = 0.95*rattmp +0.05*rah
             goto 960
          endif
        endif
  970 continue

      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: ovrlp.f90,v $:
! $Revision: 1.5 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine ovrlp (iph, iphat, rat, iatph, novr, iphovr,           &
     &                nnovr, rovr, iz, nat, rho, dmag,                  &
     &                rhoval, vcoul, edens, edenvl, vclap, rnrm)

!     Overlaps coulomb potentials and electron densities for current
!     unique potential
      use constants
      use DimsMod

      implicit double precision (a-h, o-z)


      dimension iphat(natx)
      dimension rat(3,natx)
      dimension iatph(0:nphx)
      dimension novr(0:nphx)
      dimension iphovr(novrx,0:nphx)
      dimension nnovr(novrx,0:nphx)
      dimension rovr(novrx,0:nphx)
      dimension iz(0:nphx)
      dimension rho(251,0:nphx+1), dmag(251,0:nphx+1)
      dimension vcoul(251,0:nphx+1), rhoval(251,0:nphx+1)
      dimension edens(251,0:nphx), edenvl(251,0:nphx)
      dimension vclap(251,0:nphx)
      dimension rnrm(0:nphx)
!#mn
       external dist

!     start with free atom values for current atom
      do 100  i = 1, 251
         vclap(i,iph) = vcoul(i,iph)
         edens(i,iph) = rho  (i,iph)
         
!c       investigate effect of central atom spin only
!        if (iph.ge.1) dmag(i,iph) = 0.0

         edenvl(i,iph) = rhoval  (i,iph)
  100 continue

      if (novr(iph) .gt. 0)  then
         do 104  iovr = 1, novr(iph)
            rnn  = rovr(iovr,iph)
            ann  = nnovr(iovr,iph)
            infr = iphovr(iovr,iph)
            call sumax (rnn, ann, vcoul(1,infr), vclap(1,iph))
            call sumax (rnn, ann, rho  (1,infr), edens(1,iph))
            call sumax (rnn, ann, rho  (1,infr), edenvl(1,iph))
  104    continue
      else
!        Do overlapping from geometry with model atom iat
         iat = iatph(iph)

!        overlap with all atoms within r overlap max (rlapx)
!        12 au = 6.35 ang  This number pulled out of a hat...
         rlapx = 12
!        inat is Index of Neighboring ATom
         do 110  inat = 1, nat
!           don't overlap atom with itself
            if (inat .eq. iat)  goto 110

!           if neighbor is too far away, don't overlap it
            rnn = dist (rat(1,inat), rat(1,iat))
            if (rnn .gt. rlapx)  goto 110

            infr = iphat(inat)
            call sumax (rnn, one, vcoul(1,infr), vclap(1,iph))
            call sumax (rnn, one, rho  (1,infr), edens(1,iph))
            call sumax (rnn, one, rho  (1,infr), edenvl(1,iph))
!ala        call sumax (rnn, one, rhoval(1,infr), edenvl(1,iph))
  110       continue
      endif

!     set norman radius
!     set norman radius
      IF(iz(iph).eq.0) THEN
         call frnrm (edens(1,iph), 1, rnrm(iph))
         PRINT '(A,I2,A,F20.10)', 'Norman radius for empty cell. iph = ', iph, ': ', rnrm(iph)
      ELSE
         call frnrm (edens(1,iph), iz(iph), rnrm(iph))
      END IF

!     remember ratio dmag/edens , not dmag itself
      do 200 i = 1,251
        if (edens(i,iph) .gt. 0.d0) then
          dmag(i,iph) = dmag(i,iph) / edens(i,iph)
        else
          dmag(i,iph) = 0.d0
        endif
 200  continue

      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: cofcon.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine cofcon (a,b,p,q)
!     acceleration of the convergence in the iterative process
!     b is the part of final iteration n is a function of the error (p)
!     (p) at iteration n and the error (q) at the iteration n-1.
!     if the product p*q is positive  b is increased by 0.1
!                        zero b is unchanged
!                        negative b is decreased by 0.1
!     b is between 0.1 and 0.9
!                a = 1. - b
!     ** at the end makes q=p
!
      implicit double precision (a-h,o-z)

      if (p*q)  11,31,21
 11   if (b .ge. 0.2) b = b - 0.1
      go to 31

 21   if (b .le. 0.8) b = b + 0.1

 31   a = 1.0 - b
      q=p
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: dsordf.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function dsordf (i,j,n,jnd,a)

         USE ErrorMod
!              * calculation of diff. integrals*
!        integration by simpson method of the   hg*(r**n)
!        hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j)  if jnd=1
!        hg=expression above multiplied by  dg  if jnd=-1
!        hg(l)=cg(l,i)*cp(l,j)                  if jnd=2
!        hg=expression above multiplied by  dg  if jnd=-2
!        hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j)      if jnd=3
!        hg(l)=dg(l)*dg(l)+dp(l)*dp(l)          if jnd=4
!        hg is constructed by calling program   if jnd>=5
!                  cg(l,i)  large component of the orbital i
!                  cp(l,j)  small component of the orbital j
!        a is such that dg,dp or hg following the case
!        behave at the origin as cte*r**a
!        the integration is made as far as dr(j) for jnd>3
!
!        the development limits at the origin (used for calculation
!        of integral from 0 to dr(1) ) of functions dg,dp and hg are
!        supposed to be in blocks ag,ap and chg respectively
!        this program uses  aprdev
!
      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),              &
     &         fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783)
      dimension hg(251),chg(10)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      dimension bgi(10),bgj(10),bpi(10),bpj(10)
      external aprdev

      ! construction of the array hg
      SELECT CASE(ABS(jnd))
         CASE(1) 

            max0= min(nmax(i),nmax(j))
            bgi(:) = bg(:,i)
            bgj(:) = bg(:,j)
            bpi(:) = bp(:,i)
            bpj(:) = bp(:,j)
            
            DO l=1,max0
               hg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j)
            END DO
         
            DO l=1,ndor
               chg(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l)
            END DO

            b=fl(i)+fl(j)

            IF(jnd.lt.0) THEN
               do l=1,max0
                  hg(l)=hg(l)*dg(l)
               end do
               
               do l=1,ndor
                  ap(l)=chg(l)
               end do
               
               b=b+a
               do l=1,ndor
                  chg(l)=aprdev(ap,ag,l)
               end do
            END IF

         CASE(2) ! hg(l)= cg(l,i)*cp(l,j)
            max0= min(nmax(i),nmax(j))
            bgi(:) = bg(:,i)
            bgj(:) = bg(:,j)
            bpi(:) = bp(:,i)
            bpj(:) = bp(:,j)

            do l=1,max0
               hg(l)=cg(l,i)*cp(l,j)
            end do
            
            do l=1,ndor
               chg(l)=aprdev(bgi,bpj,l)
            end do
         
            b=fl(i)+fl(j)

            IF(jnd.lt.0) THEN
               do l=1,max0
                  hg(l)=hg(l)*dg(l)
               end do
               
               do l=1,ndor
                  ap(l)=chg(l)
               end do
               
               b=b+a
               do l=1,ndor
                  chg(l)=aprdev(ap,ag,l)
               end do
            END IF

         CASE(3)
            max0= min(nmax(i),nmax(j))
            bgi(:) = bg(:,i)
            bgj(:) = bg(:,j)
            bpi(:) = bp(:,i)
            bpj(:) = bp(:,j)

            do l=1,max0
               hg(l)=dg(l)*cg(l,i)+dp(l)*cp(l,j)
            end do

            b=a+fl(i)
            do l=1,ndor
               chg(l)=aprdev(bgi,ag,l)+aprdev(bpj,ap,l)
            end do
         CASE(4)
            max0=j
            b=a

            do l=1,max0
               hg(l)=dg(l)*dg(l)+dp(l)*dp(l)
            end do
            
            b=b+b
            do l=1,ndor
               chg(l)=aprdev(ag,ag,l)+aprdev(ap,ap,l)
            end do

         CASE (5:)
            max0=j
            b=a

         CASE DEFAULT
            CALL Error('Illegal input to dsordf. jnl = ' // ACHAR(jnl), StopProgram = .FALSE.)
            CALL Error('jnl must be {-2, -1, 1, 2, 3, 4, 5, ...}')
      END SELECT

      dsordf=0.0d00
      io=n+1
      do l=1,max0
         hg(l)=hg(l)*(dr(l)**io)
      end do

      do l=2,max0,2
         dsordf=dsordf+hg(l)+hg(l)+hg(l+1)
      end do

      dsordf=hx*(dsordf+dsordf+hg(1)-hg(max0))/3.0d00

!        integral from 0 to dr(1)
      b=b+n

      do l=1,ndor
         b=b+1.0d00
         dsordf=dsordf+chg(l)*(dr(1)**b)/b
      end do
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: etotal.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine etotal (io, kap, xnel, xnval, en, eatom)
! combined from original subroutines tabfgk,tabbre,tabrat.
! io  label for output file atomNN.dat
! kap quantum number "kappa" 
! xnel occupation of  orbitals
! en one-electron energies
! fdrirk function calculating radial integrals rk
! akeato angular coefficient for integrals  fk, for the
! integrals fk(i;i) gives angular coefficients multiplied by 2
! bkeato angular coefficient for integrals  gk
! coul ener(1) direct coulomb interaction
! ech  ener(2) exchange coulomb interaction
!        * average value of the breit hamiltonian *
! fdrocc function of the orbitals' occupations.
! bkmrdf is a programm to calculate angular coefficients
! ema ener(3) magnetic energy
! ere ener(4) retardation term
!        this program uses akeato,bkeato
!        fdrocc fdrirk bkmrdf

      implicit double precision (a-h,o-z)
      parameter (ryd  = 13.605698d0)
      parameter (hart = 2*ryd)
      dimension kap(30),xnel(30),en(30), xnval(30)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      dimension mk(12),ener(4)
      dimension cer(17),mbi(9),mii(9),mjj(9)
      common/tabre/cmag(3),cret(3)
      common/inelma/nem
      common/print/iprint
      character*4 iner(4)
      logical io_open

      external akeato, bkeato, fdrirk, fdmocc
      data iner/'coul','ech.','mag.','ret.'/
 
      do 10 i = 1,4
 10   ener(i)=0.0d00
      iv=0
!       fk  integrales
      do 40 i=1,norb
         l= abs(kap(i))-1
         do 40 j=1,i
            a=1.0d00
            if (j.eq.i) a=a+a
            m= abs(kap(j))-1
            kmi=2* min(l,m)
            k=0
 20         iv=iv+1
            cer(iv)=fdrirk(i,i,j,j,k)
            ener(1) = ener(1) + cer(iv) * akeato(i,j,k) / a
            mk(iv)=k
            if (iv.lt.3) go to 30
            iv=0
 30         k=k+2
            if (k.le.kmi) go to 20
 40   continue
      iv=0
      if (norb.gt.1) then
!       gk  integrales
      do 70 i=2,norb
         a = 1.0d0
         if (xnval(i) .gt. 0.0d0) a=0.5d0
         i1=i-1
         do 70 j=1,i1
            if (xnval(j) .gt. 0.0d0) goto 70
            l= abs(kap(i))
            m= abs(kap(j))
            k= abs(l-m)
            if ((kap(i)*kap(j)).lt.0) k=k+1
            kmi=l+m-1
 50         iv=iv+1
            cer(iv)=fdrirk(i,j,i,j,k)
            ener(2) = ener(2) - cer(iv) * bkeato(i,j,k) * a
            mk(iv)=k
            if (iv.lt.3) go to 60 
            iv=0
 60         k=k+2
            if (k.le.kmi) go to 50 
 70   continue
      endif
!
      nem=1
!       direct  integrals
      ik=0
      do 140 j=1,norb
         jj=2* abs(kap(j))-1
         do 140 i=1,j
            ji=2* abs(kap(i))-1
            k=1
            kma= min(ji,jj)
 110        ik=ik+1
            mbi(ik)=k
            mii(ik)=i
            mjj(ik)=j
            cer(ik)=fdrirk(j,j,i,i,k)
            if (i.ne.j) go to 120
            call bkmrdf (j,j,k)
            ener(3) = ener(3) + (cmag(1) + cmag(2) + cmag(3)) *         &
     &                cer(ik) * fdmocc(j,j) / 2.0d00
 120        if (ik.lt.3) go to 130
            ik=0
 130        k=k+2
            if (k.le.kma) go to 110
 140  continue
      if (norb.gt.1) then
!       echange  integrals
      do 201 j=2,norb
         lj= abs(kap(j))
         na=-1
         if (kap(j).gt.0) go to 121
         na=-na
         lj=lj-1
 121     jp=j-1
         do 201 l=1,jp
            ll= abs(kap(l))
            nb=-1
            if (kap(l).gt.0) go to 131
            nb=-nb
            ll=ll-1
 131        b=fdmocc(j,l)
            nm1= abs(lj+na-ll)
            nmp1=ll+lj+nb
            nmm1=ll+lj+na
            np1= abs(ll+nb-lj)
            k= min(nm1,np1)
            kma=max(nmp1,nmm1)
            if (mod(k+ll+lj,2).eq.0) k=k+1
            nb= abs(kap(j))+ abs(kap(l))
 141        call bkmrdf (j,l,k)
            do 151 i=1,3
 151           cer(i)=0.0d00
            if (nb.le.k.and.kap(l).lt.0.and.kap(j).gt.0) go to 161
            cer(1)=fdrirk(l,j,l,j,k)
            cer(2)=fdrirk(0,0,j,l,k)
 161        if (nb.le.k.and.kap(l).gt.0.and.kap(j).lt.0) go to 171
            cer(3)=fdrirk(j,l,j,l,k)
            if (cer(2).ne.0.0d00) go to 171
            cer(2)=fdrirk(0,0,l,j,k)
 171        do 185 i = 1, 3
               ener(3) = ener(3) + cmag(i) * cer(i) * b
               ener(4) = ener(4) + cret(i) * cer(i) * b
 185        continue
            k=k+2
            if (k.le.kma) go to 141
 201  continue
      endif
 
!     total   energy
      eatom = - (ener(1) + ener(2)) + ener(3) + ener(4)
      do 212 j = 1, norb
 212     eatom = eatom + en(j) * xnel(j)
      inquire(unit=io,opened=io_open)
      if (iprint .ge. 5 .and. io_open)                                  &
     &  write (io, '(a,1pd18.7)') 'etot', eatom*hart
      do 215 i = 1, 4
        if (iprint.ge.5 .and. io_open)                                  &
     &    write(io, '(a4,1pd18.7)') iner(i), ener(i)*hart
 215  continue
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: fpf0.f90,v $:
! $Revision: 1.5 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine fpf0 ( iz, iholep, srho, dr, hx,                       &
     &     dgc0, dpc0, dgc, dpc,                                  &
     &     eatom, xnel, norb, eorb, kappa)
  !      everything is input. output is written in fpf0.dat
  !      to be read by ff2afs.f to get scattering amplitude

  use DimsMod
  use constants
  use par
  implicit none

  !     save central atom dirac components, see comments below.

  integer, intent(in) :: iz,iholep, norb
  real*8, intent(in)  :: eatom,hx
  real*8, intent(in), dimension(251) :: dgc0, dpc0, srho,dr
  real*8, intent(in), dimension(30)  :: xnel, eorb !, kappa
  real*8, intent(in), dimension(251, 30, 0:nphx) :: dgc, dpc
  integer,intent(in), dimension(30) :: kappa

  real*8, dimension(251) :: xpc, xqc

  logical open_16

  !     output arrays
  real*8, dimension(13) :: enosc, oscstr !, index
  integer, dimension(13) :: index

  ! Added to satisfy implicit none
  integer :: i,iorb,iq,jkap,kdif,kinit,np,nosc,ios
  real*8  :: xk0,xj0,xirf,twoj,xmult1,xmult2,dq,fpcorr

  if (master) then
     open (unit=16, file='fpf0.dat', status='unknown', iostat=ios)
     fpcorr =  -(iz/82.5)**2.37
     write (16,*)  ' atom Z = ', iz
     write (16,10)  eatom *alphfs**2 *5/3, fpcorr,                   &
          &        ' total energy part of fprime - 5/3*E_tot/mc**2'
10   format (2(1pe19.5), a)
     open_16 = .true.
  else
     open_16 = .false.
  endif

  !     get oscillator strengths
  do i=1,13
     oscstr(i)=0.d0
     enosc(i)=0.d0
  enddo
  enosc(1)= eorb(iholep)
  index(1)= iholep
  kinit = kappa(iholep)
  oscstr(1) = 2*abs(kinit)
  !     always will use first spot to represent initial state
  nosc=1
  np = 251

  do iorb =1, norb
     if (xnel(iorb) .gt.0.d0) then
        !         it is core orbital, check if it satisfies dipole selection
        jkap = kappa(iorb)
        if (jkap+kinit.eq.0 .or. abs(jkap-kinit).eq.1) then
           nosc = nosc+1
           !            calculate reduced dipole matrix element
           kdif= jkap-kinit
           if (abs(kdif).gt.1) kdif=0
           !            xirf = <i |p| f> relativistic version of dipole m.e.
           !            from Grant,Advan.Phys.,v.19,747(1970) eq. 6.30, using
           !            Messiah's "Q.M." appendices to reduce 9j,3j symbols
           !            to simple coefficients xmult1,2. ala 12.12.95
           twoj = 2.0d0*abs(kinit) - 1.0d0
           if (kdif.eq.-1 .and. kinit.gt.0) then
              xmult1 = 0.0d0
              xmult2 = sqrt(2.0d0 * (twoj+1)*(twoj-1)/twoj )
           elseif (kdif.eq.-1 .and. kinit.lt.0) then
              xmult1 = 0.0d0
              xmult2 = - sqrt(2.0d0 * (twoj+1)*(twoj+3)/(twoj+2) )
           elseif (kdif.eq. 0 .and. kinit.gt.0) then
              xmult1 = - sqrt( (twoj+1)*twoj/(twoj+2) )
              xmult2 = - sqrt( (twoj+1)*(twoj+2)/twoj )
           elseif (kdif.eq. 0 .and. kinit.lt.0) then
              xmult1 = sqrt( (twoj+1)*(twoj+2)/twoj )
              xmult2 = sqrt( (twoj+1)*twoj/(twoj+2) )
           elseif (kdif.eq. 1 .and. kinit.gt.0) then
              xmult1 = sqrt(2.0d0 * (twoj+1)*(twoj+3)/(twoj+2) )
              xmult2 = 0.0d0
           elseif (kdif.eq. 1 .and. kinit.lt.0) then
              xmult1 = - sqrt(2.0d0 * (twoj+1)*(twoj-1)/twoj )
              xmult2 = 0.0d0
           endif
           xk0 = abs(eorb(iorb)-eorb(iholep)) * alphfs
           do i = 1, np
              xj0 = sin(xk0*dr(i))/(xk0*dr(i))
              xpc(i) = (xmult1*dgc0(i)*dpc(i,iorb,0)+                 &
                   &            xmult2*dpc0(i)*dgc(i,iorb,0)) * xj0
              xqc(i) = 0.0d0
           enddo
           !            xirf=lfin+linit+2
           xirf=2
           call somm (dr, xpc, xqc, hx, xirf, 0, np)
           oscstr(nosc) = xirf**2/3.0d0 
           enosc(nosc) = eorb(iorb)
           index(nosc) = iorb
        endif
     endif
  enddo

  !     write down information about oscillators
  if(open_16) then
     write(16, *) nosc
     do i=1,nosc
        write(16,220) oscstr(i), enosc(i), index(i)
220     format ( f9.5, f12.3, i4)
     enddo
  endif

  !     calculate and write out f0(Q) on grid delq=0.5 Angstorm**(-1)
  dq=0.5*bohr 
  do iq = 1,81
     xk0 = dq*(iq-1)
     !        srho is 4*pi*density 
     do i = 1, np
        xj0 = 1.d0
        if(iq.gt.1) xj0 = sin(xk0*dr(i))/(xk0*dr(i))
        xpc(i) = srho(i) * (dr(i)**2) *xj0
        xqc(i) = 0.d0
     enddo
     xirf = 2.d0
     call somm (dr, xpc, xqc, hx, xirf, 0, np)
     if (open_16) write (16, 570) 0.5*(iq-1), xirf
570  format ( f5.1, 1x, f9.4)
  enddo

  if (open_16) close(unit=16)

  return
end subroutine fpf0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: inmuat.f90,v $:
! $Revision: 1.5 $
! $Author: jorissen $
! $Date: 2012/09/11 22:52:14 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine inmuat (ihole, xionin, iunf, xnval, iholep, xmag, iorb, iph, nq2)  !KJ 12-2010 added iph, nq2
      implicit double precision (a-h,o-z)
      dimension xnval(30), xmag(30), iorb(-4:3)
	  integer nq2(30)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
! the meaning of common variables is described below
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),nq(30),kap(30),nmax(30)
! en one-electron energies
! scc factors for acceleration of convergence
! scw precisions of wave functions
! sce precisions of one-electron energies
! nmax number of tabulation points for orbitals
      common/scrhf1/eps(435),nre(30),ipl
! eps non diagonal lagrange parameters
! nre distingue: - the shell is closed (nre <0)
!                  the shell is open (nre>0)
!                - the orbitals in the integral rk if abs(nre) > or =2
! ipl define the existence of lagrange parameters (ipl>0)
      common/snoyau/dvn(251),anoy(10),nuc
! dvn nuclear potential
! anoy development coefficients at the origin of nuclear potential
! this development is supposed to be written anoy(i)*r**(i-1)
! nuc index of nuclear radius (nuc=1 for point charge)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      data nucm/11/,nesn/50/,ideps/435/

      ndor=10

      ! testy precision for the wave functions
      testy=1.0d-05

      ! teste precision for the one-electron energies
      teste=5.0d-06

      ! rap tests of precision for soldir
      rap(1)=100.
      rap(2)=10.

      do i = 1, 30
         en(i) = 0.d0
         xmag(i) = 0
         xnval(i) = 0
      end do

!write(*,*) '*********** Calling getorb for :'
      call getorb (nz, ihole, xionin, iunf, norb, norbsc, iorb, iholep, nq, kap, xnel, xnval, xmag, iph)  !KJ 12-2010 added iph
	  nq2(:)=nq(:)
!      write(*,*) 'nz,ihole,xionin',nz,ihole,xionin
!	  write(*,*) 'iunf,norb,norbsc',iunf,norb,norbsc
!	  write(*,*) 'iorb',iorb
!	  write(*,*) 'iholep,nq',iholep,nq
!	  write(*,*) 'kap',kap
!	  write(*,*) 'xnel',xnel
!	  write(*,*) 'xnval',xnval
!	  write(*,*) 'xmag,iph',xmag,iph
!     stop
	  

      xk=0
      do i=1,norb
         xk=xk+xnel(i)
      end do
!write(*,*) 'norb,xnel',norb,xnel(1:norb)
!write(*,*) 'nz,xionin,xk',nz,xionin,xk
      if ( abs(nz-xionin-xk) .gt. 0.001) call par_stop('check number of electrons in getorb.f')

      norbsc=norb
! nz atomic number     noi ionicity (nz-number of electrons)
! norb number of orbitals
! xnel(i) number of electrons on orbital i.
! first norbsc orbitals will be determined selfconsistently,
! the rest of orbitals are orthogonolized if iorth is non null,
! and their energies are those on cards if iene is non null
! or otherwise are the values obtained from solving dirac equation
      nes=nesn
! nes number of attempts in program soldir
      nuc=nucm
! nuc number of points inside nucleus (11 by default)
      do 171 i=1,ideps
 171  eps(i)=0.0d00

      idim = 251
      if (mod(idim,2) .eq. 0) idim=idim-1

      ipl=0
! if ipl non null, it permits a repartition of tabulation points and certain precision tests.
      do 401 i=1,norb
         nre(i)=-1
         llq= abs(kap(i))
         l=llq+llq
         if (kap(i).lt.0) llq=llq-1
         if (llq.lt.0.or.llq.ge.nq(i).or.llq.gt.3) call par_stop('kappa out of range, check getorb.f')
         nmax(i)=idim
         scc(i)=0.3
         if (xnel(i) .lt. l)  nre(i)=1
         if (xnel(i) .lt. 0.5)  scc(i)=1.0
         do 385 j=1,i-1
            if (kap(j).ne.kap(i)) go to 385
            if (nre(j).gt.0.or.nre(i).gt.0) ipl=ipl+1
 385     continue
 401  continue
 999  return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: lagdat.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine lagdat (ia,iex)
!        * non diagonal lagrange parameteres *
! lagrange parameters involving orbital ia if ia is positive
! all lagrange parameters are calculated if ia is negative or zero
! contribution of the exchange terms is omitted if iex=0
!        this program uses akeato(bkeato) fdrirk multrk

      implicit double precision (a-h,o-z)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
      common/scrhf1/eps(435),nre(30),ipl
      dimension ni(2),nj(2)
!#mn
       external akeato, bkeato, fdrirk
 
      i1= max(ia,1)
      idep=1
      if (ia.gt.0) go to 15
 11   idep=i1+1
 15   ni(1)=i1
      nj(2)=i1
      ji1=2* abs(kap(i1))-1
      do 201 i2=idep,norbsc
         if (i2.eq.i1.or.kap(i2).ne.kap(i1)) go to 201
         if (nre(i1).lt.0.and.nre(i2).lt.0) go to 201
! the following line was included to handle the case of 1 electron in
! 2 s-shells.
! Probably need to use schmidt orthogonalization in this case
         if (xnel(i1).eq.xnel(i2)) go to 201
         ni(2)=i2
         nj(1)=i2
         d=0.0d00
         do 101 l=1,norbsc
            k=0
            jjl=2* abs(kap(l))-1
            kma= min(ji1,jjl)
 41         a=akeato(l,i1,k)/xnel(i1)
            b=a-akeato(l,i2,k)/xnel(i2)
            c=b
            if (a.ne.0.0d00) c=c/a
            if ( abs(c).lt.1.0d-07) go to 51
            d=d+b*fdrirk(l,l,i1,i2,k)
 51         k=k+2
            if (k.le.kma) go to 41
            if (iex.eq.0) go to 101
            kma=(ji1+jjl)/2
            k= abs(jjl-kma)
            if ((kap(i1)*kap(l)).lt.0) k=k+1
 61         a=bkeato(l,i2,k)/xnel(i2)
            b=a-bkeato(l,i1,k)/xnel(i1)
            c=b
            if (a.ne.0.0d00) c=c/a
            if ( abs(c).lt.1.0d-07) go to 71
            d=d+b*fdrirk(i1,l,i2,l,k)
 71         k=k+2
            if (k.le.kma) go to 61
 101     continue
         i= min(i1,i2)
         j= max(i1,i2)
         eps(i+((j-1)*(j-2))/2)=d/(xnel(i2)-xnel(i1))
 201  continue
      if (ia.gt.0) go to 999
      i1=i1+1
      if (i1.lt.norbsc) go to 11
 999  return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: messer.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine messer
!  prints error message on the output device
      implicit double precision (a-h,o-z)
      common/messag/dlabpr,numerr
      character*8 dlabpr
      character*512 slog
 
      ilig=numerr/1000
      ier=numerr-1000*ilig
      write(slog,'(a,i6,a,i6,a,a8)')  'error number ',ier,              &
     & ' detected on a line ',ilig,'in the program',dlabpr
      call wlog(slog)
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: muatco.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine muatco(xnval) 
!               * angular coefficients *
!        sous programmes utilises  cwig3j
!
      implicit double precision (a-h,o-z)
      dimension xnval(30)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/mulabk/afgk
      dimension afgk(30,30,0:3)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
!#mn
       external cwig3j

      do 511 i=1,30
      do 511 j=1,30
      do 511 k=0,3
 511  afgk(i,j,k)=0.0d00
 601  do 701 i=1,norb
         li= abs(kap(i))*2-1
         do 701 j=1,i
            lj= abs(kap(j))*2-1
            kmax=(li+lj)/2
            kmin= abs(li-lj)/2
            if ((kap(i)*kap(j)).lt.0) kmin=kmin+1
! calculate a_k(i,j)
            m=0
            if (j.eq.i .and. xnval(i).le.0.0d0) m=1
!           use to test SIC
!           if (j.eq.i) m=1

            afgk(j,i,0)=afgk(j,i,0)+xnel(i)*(xnel(j)-m)
            if (xnval(i).gt.0.0d0 .and. xnval(j).gt.0.0d0) goto 700
! calculate b_k(i,j)
            b=afgk(j,i,0)
            if (j.eq.i .and. xnval(i).le.0.0d0) then
               a=li
               b=-b*(a+1.0d00)/a
               kmin = kmin+2
            endif
            do 675 k = kmin, kmax,2
               afgk(i,j,k/2)=b*(cwig3j(li,k*2,lj,1,0,2)**2)
 675        continue

 700        continue
 701  continue
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: ortdat.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine ortdat (ia)
!        * orthogonalization by the schmidt procedure*
! the ia orbital is orthogonalized toa all orbitals of the same
! symmetry if ia is positive, otherwise all orbitals of the same
! symmetry are orthogonalized
!        this program uses dsordf
 
      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),              &
     &         fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783)
!  dg,ag,dp,ap are used to exchange data only with dsordf
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
!#mn
       external dsordf
 
      m=norb
      l= max(ia,1)
      if (ia.gt.0) go to 11
 5    m=l
      l=l+1
      if (l.gt.norb) go to 999
 11   do 15 i=1,idim
         dg(i)=0.0d00
 15      dp(i)=0.0d00
      maxl=nmax(l)
      do 21 i=1,maxl
         dg(i)=cg(i,l)
 21      dp(i)=cp(i,l)
      do 25 i=1,ndor
         ag(i)=bg(i,l)
 25      ap(i)=bp(i,l)
      do 51 j=1,m
         if (j.eq.l.or.kap(j).ne.kap(l)) go to 51
         max0=nmax(j)
         a=dsordf (j,j,0,3,fl(l))
         do 41 i=1,max0
            dg(i)=dg(i)-a*cg(i,j)
 41         dp(i)=dp(i)-a*cp(i,j)
         do 45 i=1,ndor
            ag(i)=ag(i)-a*bg(i,j)
 45         ap(i)=ap(i)-a*bp(i,j)
         maxl= max(maxl,max0)
 51   continue
      max0= maxl
      nmax(l)=max0
      a=dsordf (l,max0,0,4,fl(l))
      a= sqrt(a)
      do 71 i=1,max0
         cg(i,l)=dg(i)/a
 71      cp(i,l)=dp(i)/a
      do 75 i=1,ndor
         bg(i,l)=ag(i)/a
 75      bp(i,l)=ap(i)/a
      if (ia.le.0) go to 5
 999  return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: potrdf.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine potrdf (ia)
!        this programm uses akeato(bkeato),aprdev,multrk,yzkrdf
      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),              &
     &        fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),dv(251),av(10), &
     &              eg(251),ceg(10),ep(251),cep(10)
!     dg,dp to get data from yzkrdf, dv,eg,ep -output for soldir
      dimension at(251),bt(251)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
      common/scrhf1/eps(435),nre(30),ipl
      common/snoyau/dvn(251),anoy(10),nuc
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      dimension bgj(10),bpj(10)
!#mn
       external akeato, bkeato, aprdev
 
      do 9 i=1,ndor
         cep(i)=0.0d00
         ceg(i)=0.0d00
 9       av(i)=anoy(i)
      do 11 i=1,idim
         at(i)=0.0d00
         bt(i)=0.0d00
         ep(i)=0.0d00
         eg(i)=0.0d00
 11      dv(i)=0.0d00
 
!     coulomb terms
      jia=2* abs(kap(ia))-1
      k=0
 21   do 25 i=1,idim
 25   dg(i)=0.0d00
      do 31 i=1,ndor
 31   ag(i)=0.0d00
      max0=0
      do 51 j=1,norb
         do 33 i = 1,10
            bgj(i) = bg(i,j)
 33         bpj(i) = bp(i,j)
         m=2* abs(kap(j))-1
         if (k.gt.m) go to 51
         a=akeato(ia,j,k)/xnel(ia)
         if (a.eq.0.0d00) go to 51
         m=nmax(j)
         do 35 i=1,m
 35         dg(i)=dg(i)+a*(cg(i,j)*cg(i,j)+cp(i,j)*cp(i,j))
         n=2* abs(kap(j))-k
         l=ndor+2-n
         if (l.le.0) go to 51
!        quick fix of development coefficients
         a = a * fix(j)**2
         do 41 i=1,l
            m=n-2+i
 41         ag(m)=ag(m)+a*(aprdev(bgj,bgj,i)+                           &
     &            aprdev(bpj,bpj,i))
 51      max0= max(max0,nmax(j))
      call yzkrdf (0,max0,k)
      do 61 i=1,ndor
         l=k+i+3
         if (l.gt.ndor) go to 61
         av(l)=av(l)-ag(i)
 61   continue
      do 81 i=1,idim
 81   dv(i)=dv(i)+dg(i)
      k=k+2
      if (k.le.ndor) av(k)=av(k)+ap(1)
      if (k.lt.jia) go to 21
 
!     exchange terms
      if (method.eq.0) go to 411
      do 201 j=1,norb
         if (j-ia) 105,201,105
 105     max0=nmax(j)
         jj=2* abs(kap(j))-1
         kma=(jj+jia)/2
         k= abs(jj-kma)
         if ((kap(j)*kap(ia)).lt.0) k=k+1

 111     a=bkeato(j,ia,k)/xnel(ia)
         if (a.eq.0.0d00) go to 151
         call yzkrdf (j,ia,k)
         do 121 i=1,max0
            eg(i)=eg(i)+a*dg(i)*cg(i,j)
 121        ep(i)=ep(i)+a*dg(i)*cp(i,j)
         n=k+1+ abs(kap(j))- abs(kap(ia))
         if (n.gt.ndor) go to 141
         do 135 i=n,ndor
            ceg(i)=ceg(i)+bg(i+1-n,j)*a*ap(1) *fix(j)/fix(ia)
 135        cep(i)=cep(i)+bp(i+1-n,j)*a*ap(1) *fix(j)/fix(ia)
 141     i=2* abs(kap(j))+1
         if (i.gt.ndor) go to 151
         do 143 ix = 1,10
            bgj(ix) = bg(ix,j)
 143        bpj(ix) = bp(ix,j)
         do 145 n=i,ndor
            ceg(n)=ceg(n)-a*aprdev(ag,bgj,n+1-i) *fix(j)**2
 145        cep(n)=cep(n)-a*aprdev(ag,bpj,n+1-i) *fix(j)**2
 151     k=k+2
         if (k.le.kma) go to 111
 201  continue
 411  if (ipl.eq.0) go to 511
      do 481 j=1,norbsc
         if (kap(j).ne.kap(ia).or.j.eq.ia) go to 481
         if (nre(j).lt.0.and.nre(ia).lt.0) go to 481
         m= max(j,ia)
         i= min(j,ia)+((m-1)*(m-2))/2
         a=eps(i)*xnel(j)
         max0=nmax(j)
         do 461 i=1,max0
            at(i)=at(i)+a*cg(i,j)
 461        bt(i)=bt(i)+a*cp(i,j)
         do 471 i=1,ndor
            ceg(i)=ceg(i)+bg(i,j)*a
 471        cep(i)=cep(i)+bp(i,j)*a
 481  continue
 
! addition of nuclear potential and division of potentials and
!       their development limits by speed of light
 511  do 527 i=1,ndor
         av(i)=av(i)/cl
         cep(i)=cep(i)/cl
 527     ceg(i)=ceg(i)/cl
      do 531 i=1,idim
         dv(i)=(dv(i)/dr(i)+dvn(i))/cl
         ep(i)=(ep(i)+bt(i)*dr(i))/cl
 531     eg(i)=(eg(i)+at(i)*dr(i))/cl
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: s02at.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine s02at(ihole, norb, nk, xnel, ovpint, dval)
      implicit double precision (a-h,o-z)
      double precision  m1(7,7), m2(7,7)
      dimension nk(30), xnel(30), iorb(30), ovpint(30,30)
      external determ

      dval = 1.0
!     loop over possible kappa for existing atoms
      do 100 kap = -4,3

!        initialize matrices and other stuff
         do 10 i = 1,7
         do 10 j = 1,7
            m1(i,j) = 0
  10        m2(i,j) = 0
         do 20 i= 1,7
            iorb(i) = 0
            m1(i,i) = 1.0
  20        m2(i,i) = 1.0
!        morb - number of orbitals with quantum number kappa
         morb = 0
         nhole = 0

!        construct the largest possible matrix for given value of kappa.
         do 40 i = 1, norb
            if (nk(i) .eq. kap) then
               morb = morb + 1
               iorb(morb) = i
               do 50 j = 1, morb
!                 print overlap integrals
!                 print*, kap,' ', iorb(j),' ', iorb(morb), '
!    1                            ovp= ',ovpint(iorb(j), iorb(morb))
   50             m1(j,morb) = ovpint(iorb(j), iorb(morb))
               do 60 j = 1, morb - 1
   60             m1(morb,j) = m1(j,morb)
               
               if (ihole .eq. i) nhole = morb
            endif
   40    continue
         if (morb .eq. 0) goto 100
         dum1 = determ(m1, morb, 7)
         dum1 = dum1**2

         dum3 = determ(m1, morb-1, 7)
         dum3 = dum3**2
         xn = xnel(iorb(morb))
         nmax = 2*abs(kap)
         xnh = nmax - xn
         if (nhole .eq. 0) then 
            dval = dval * dum1**xn * dum3**xnh
         elseif (nhole .eq. morb) then
            dval = dval * dum1**(xn-1) * dum3**(xnh+1)
         else
            call elimin(m1,nhole,m2)
            dum2 = determ(m2,morb,7)
            dum2 = dum2**2
            dum4 = determ(m2,morb-1,7)
            dum4 = dum4**2
            dum5 = (dum4*dum1*xnh + dum2*dum3*xn)/nmax
            dval = dval * dum5 * dum1**(xn-1) * dum3**(xnh-1)
         endif

100   continue

      return
      end

      subroutine elimin(d1,n,d2)
      implicit double precision (a-h,o-z)
      dimension d1(7,7), d2(7,7)

      do 10 i = 1,7
      do 10 j = 1,7
         if (i .ne. n) then
            if (j .ne. n) then
               d2(i,j)=d1(i,j)
            else
               d2(i,j) = 0
            endif
         else
            if (j .ne. n) then
               d2(i,j) = 0
            else
               d2(i,j) = 1.0
            endif
         endif
   10 continue
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: soldir.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine soldir (en,fl,agi,api,ainf,nq,kap,max0,ifail)
!                  resolution of the dirac equation
!                   p' - kap*p/r = - ( en/cl-v )*g - eg/r
!                   g' + kap*g/r = ( 2*cl+en/cl-v )*p + ep/r
! at the origin v approximately is -z/(r*cl) due to the point nucleus
! en one-electron energy in atomic units and negative
! fl power of the first term in development at the origin
! agi (api) initial values of the first development coefficient
! at the origin of the large(small)component
! ainf initial value for the large component at the point dr(max0)
! nq principal quantum number     kap quantum number kappa
! max0 the last point of tabulation of the wave function
!        this programm uses intdir
 
      implicit double precision (a-h,o-z)
      common/comdir/cl,dz,gg(251),ag(10),gp(251),ap(10),dv(251),av(10), &
     &eg(251),ceg(10),ep(251),cep(10)
! gg,gp -output, dv,eg,ep - input
      dimension hg(251),agh(10),                                        &
     &hp(251),aph(10),bg(251),bgh(10),bp(251),bph(10)
!
! cl speed of light (approximately 137.037 in atomic units)
! dz nuclear charge
! gg (gp) large (small) component
! hg,hp,bg et bp working space
! dv direct potential (v)     eg and ep exchange potentials
! ag,ap,agh,aph,bgh,bph,av,ceg and cep are respectively the
! development coefficients for gg,gp,hg,hp,bg,bp,dv,eg et ep
!
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
!
! hx exponential step
! dr radial mesh
! test1 precision for the matching the small component if method=1
! test2 precision for the normalisation if method=2
! ndor number of terms for the developments at the origin
! np maximum number of the tabulation points
! nes maximum number of attempts to ajust the small component
! method at the initial time distinguish the homoginious (method=0)
!  from inhomoginious system. at the end is the index of method used.
! idim dimension of the block dr

      common/subdir/ell,fk,ccl,imm,nd,node,mat

! ell fk*(fk+1)/ccl     fk=kap     ccl=cl+cl
! imm a flag for the determination of matching point
! nd number of nodes found     node number of nodes to be found
! mat index of the matching point

      common/messag/dlabpr,numerr
      character*8 dprlab,dlabpr, drplab
! at the time of return numerr should be zero if integration is correct,
! otherwise numerr contains the number of instruction, which
! indicate the sourse and reason for abnornal return.
!     character*512 slog
      save

      data dprlab/'  soldir'/,drplab/'  intdir'/
      dlabpr=dprlab
      enav=1.0d00
      ainf= abs(ainf)
      ccl=cl+cl
      iex=method
      if (method.le.0) method=1
! notice that iex=0,1 and method=1,2 only below.
! this was used to simplify block structure of program. ala 11/22/94
      fk=kap
      if (av(1).lt.0.0d00.and.kap.gt.0) api=-agi*(fk+fl)/av(1)
      if (av(1).lt.0.0d00.and.kap.lt.0) api=-agi*av(1)/(fk-fl)
      ell=fk*(fk+1.0d00)/ccl
      node=nq- abs(kap)
      if (kap.lt.0) node=node+1
      emin=0.0
      do 91 i=1,np
         a=(ell/(dr(i)*dr(i))+dv(i))*cl
         if (a.lt.emin) emin=a
 91   continue
      if (emin .ge. 0.0) then
         numerr=75011
!       *potential is apparently positive
         return
      endif
      if (en.lt.emin) en=emin*0.9d00
      edep=en

 101  numerr=0
      test=test1
      if (method.gt.1) test=test2
      einf=1.0d00
      esup=emin
      en=edep
      ies=0
      nd=0
 105  jes=0
 106  modmat=0
      imm=0
      if ( abs((enav-en)/en).lt.1.0d-01) imm=1
      enav=en
 
!     integration of the inhomogenious system
 107  do 111 i=1,idim
         gg(i)=eg(i)
 111     gp(i)=ep(i)
      do 115 i=2,ndor
         ag(i)=ceg(i-1)
 115     ap(i)=cep(i-1)
      call intdir (gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0)
      if (numerr.ne.0) then
         dlabpr=drplab
         return
      endif
      if (iex.ne.0) go to 141
 
!     match large component for the homogenios system(method=0)
      a=ggmat/gg(mat)
      do 135 i=mat,max0
         gg(i)=a*gg(i)
 135     gp(i)=a*gp(i)
      j=mat
      go to 215
 
!     integration of the homogenios system
 141  do 151 i=1,idim
            hg(i)=0.0d00
 151     hp(i)=0.0d00
      do 155 i=1,ndor
         agh(i)=0.0d00
 155     aph(i)=0.0d00
      imm=1
      if (method.eq.1) imm=-1
      call intdir (hg,hp,agh,aph,hgmat,hpmat,en,fl,agi,api,ainf,max0)
 
!     match the large component for inhomogenious system(method=1)
      a=gg(mat)-ggmat
      if (method.lt.2) then
         b=-a/hg(mat)
      else
         b=gp(mat)-gpmat
         ah=hpmat*hg(mat)-hgmat*hp(mat)
         if (ah.eq.0.0d00) go to 263
         c=(b*hg(mat)-a*hp(mat))/ah
         b=(b*hgmat-a*hpmat)/ah
         do 165 i=1,ndor
            ag(i)=ag(i)+c*agh(i)
 165        ap(i)=ap(i)+c*aph(i)
         j=mat-1
         do 168 i=1,j
            gg(i)=gg(i)+c*hg(i)
 168        gp(i)=gp(i)+c*hp(i)
      endif
      do 173 i=mat,max0
         gg(i)=gg(i)+b*hg(i)
 173     gp(i)=gp(i)+b*hp(i)

      if (method.ge.2) then
!        integration of the system derived from disagreement in energy
         do 175 i=2,ndor
            bgh(i)=ag(i-1)/cl
 175        bph(i)=ap(i-1)/cl
         do 177 i=1,max0
            bg(i)=gg(i)*dr(i)/cl
 177        bp(i)=gp(i)*dr(i)/cl
         call intdir (bg,bp,bgh,bph,bgmat,bpmat,en,fl,agi,api,ainf,max0)
 
!        match both components for inhomogenious system (method=2)
         f=bg(mat)-bgmat
         g=bp(mat)-bpmat
         a=(g*hg(mat)-f*hp(mat))/ah
         g=(g*hgmat-f*hpmat)/ah
         do 181 i=1,j
            bg(i)=bg(i)+a*hg(i)
 181        bp(i)=bp(i)+a*hp(i)
         do 182 i=1,ndor
            bgh(i)=bgh(i)+a*agh(i)
 182        bph(i)=bph(i)+a*aph(i)
         do 183 i=mat,max0
            bg(i)=bg(i)+g*hg(i)
 183        bp(i)=bp(i)+g*hp(i)
!        calculate the norm 
         call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor,                  &
     &     gpmat,fl,max0,mat)
 
!        correction to the energy (method=2)
         do 186 i=1,max0
 186     hg(i)=(gg(i)*bg(i)+gp(i)*bp(i))*dr(i)
         ah=0.0d00
         c=0.0d00
         do 187 i=2,max0,2
 187     ah=ah+hg(i)+hg(i)+hg(i+1)
         ah=hx*(ah+ah+hg(1)-hg(max0))/3.0d00+hg(1)/(fl+fl+1.0d00)
         f=(1.0d00-b)/(ah+ah)
         c=1.0d00-b
         do 191 i=1,max0
            gg(i)=gg(i)+f*bg(i)
 191        gp(i)=gp(i)+f*bp(i)
         do 195 i=1,ndor
            ag(i)=ag(i)+f*bgh(i)
 195        ap(i)=ap(i)+f*bph(i)
      endif
 
!     search for the maximum of the modulus of large component
      a=0.0d00
      bgh(1)=b
      bph(1)=ah
      do 211 i=1,max0
         g=gg(i)*gg(i)
         if (g.le.a) go to 211
         a=g
         j=i
 211  continue
      if (j.gt.mat .and. modmat.eq.0) then
         modmat=1
         mat=j
         if (mod(mat,2).eq.0) mat=mat+1
         imm=1
         if (mat.lt.(max0-10)) go to 107

         mat=max0-12
         j=mat
         if (mod(mat,2).eq.0) mat=mat+1
!        write(slog,'(a,i4,a,i4)') ' warning  mat=',mat,' max0=',max0
!        call wlog(slog)
      endif
! this case can happen due to bad starting point in scf procedure.
! ignore this warning unless you are getting it at final norb calls
! of soldir
!  redirected by ala 11/21/94.
!     numerr=220021
! * impossible matching point
!     go to 899
 
! compute number of nodes
 215  nd=1
      j= max(j,mat)
      do 231 i=2,j
         if (gg(i-1).eq.0.0d00) go to 231
         if ((gg(i)/gg(i-1)).le.0.0d00) nd=nd+1
 231  continue

      if (nd-node) 251,305,261
 251  esup=en
      if (einf.lt.0.0d00) go to 271
      en=en*8.0d-01
      if ( abs(en).gt.test1) go to 285
      numerr=238031
!    *zero energy
      go to 899

 261  einf=en
      if (esup.gt.emin) go to 271
 263  en=en*1.2d00
      if (en.gt.emin) go to 285
      numerr=245041
!    *energy is lower than the minimum of apparent potential
      go to 899

 271  if ( abs(einf-esup).gt.test1) go to 281
      numerr=249051
!    *the upper and lower limits of energy are identical
      go to 899

 281  en=(einf+esup)/2.0d00

 285  jes=jes+1
      if (jes.le.nes) go to 106
 
! *number of attempts to find good number of nodes is over the limit
! this case can happen due to bad starting point in scf procedure.
! ignore this warning unless you  got it at final norb calls of soldir
!     call wlog('warning jes>nes')
      ifail=1
!    *redirected by ala 11/21/94.
!     numerr=255061
!     go to 899

!     calculation of the norm
 305  call norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor,                     &
     &     gpmat,fl,max0,mat)
      if (method.eq.1) then
!        correction to the energy (method=1)
         c=gpmat-gp(mat)
         f=gg(mat)*c*cl/b
         if (gpmat.ne.0.0d00) c=c/gpmat
      endif

      en=en+f
      g= abs(f/(en-f))
 371  if ((en.ge.0 .or. g.gt.2.0d-01) .or.                              &
     & (abs(c).gt.test .and. (en.lt.esup.or.en.gt.einf))) then
!        try smaller step in enrgy under above conditions
         f=f/2.0d00
         g=g/2.0d00
         en=en-f
         if (g.gt.test1) go to 371
         numerr=29071
!       *zero energy
         go to 899
      endif

      if ( abs(c).gt.test)  then
         ies=ies+1
         if (ies.le.nes) go to 105
         ifail=1
!        call wlog('warning: iteration stopped because ies=nes')
!     everything is fine unless you got this message on the latest stage
!     of selfconsistent process. just stopped trying to match lower
!     component, because number of trials exceeded limit.
!     lines below were commented out.  ala 11/18/94
      endif

!     numerr=298081
!    *number of attempts to match the lower component is over the limit
!     go to 899
 
!     divide by a square root of the norm, and test the sign of w.f.
      b= sqrt(b)
      c=b
      if ((ag(1)*agi).lt.0.0d00.or.(ap(1)*api).lt.0.0d00) c=-c
      do 711 i=1,ndor
         ag(i)=ag(i)/c
 711     ap(i)=ap(i)/c
      if ((gg(1)*agi).lt.0.0d00.or.(gp(1)*api).lt.0.0d00) b=-b
      do 721 i=1,max0
         gg(i)=gg(i)/b
 721     gp(i)=gp(i)/b
      if (max0.ge.np) return
      j=max0+1
      do 741 i=j,np
         gg(i)=0.0d00
 741     gp(i)=0.0d00
!     if everything o'k , exit is here.
      return

!     abnormal exit is here, if method.ne.1
 899  if (iex.eq.0 .or. method.eq.2) go to 999
      method=method+1
      go to 101

 999  return
      end

      subroutine norm(b,hp,dr,gg,gp,ag,ap,method,hx,ndor,               &
     & gpmat,fl,max0,mat)
!    calculate norm b. this part of original code was used twice,
!    causing difficult block structure. so it was rearranged into
!    separate subroutine. ala 
      implicit double precision (a-h, o-z)
      dimension hp(251),dr(251),gg(251),gp(251),ag(10),ap(10)

      b=0.0d00
      do 311 i=1,max0
 311  hp(i)=dr(i)*(gg(i)*gg(i)+gp(i)*gp(i))
      if (method.ne.1) go to 315
      hp(mat)=hp(mat)+dr(mat)*(gpmat**2-gp(mat)**2)/2.0d00
 315  do 321 i=2,max0,2
 321  b=b+hp(i)+hp(i)+hp(i+1)
      b=hx*(b+b+hp(1)-hp(max0))/3.0d00
      do 325 i=1,ndor
         g=fl+fl+i
         g=(dr(1)**g)/g
         do 325 j=1,i
 325     b=b+ag(j)*g*ag(i+1-j)+ap(j)*g*ap(i+1-j)
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: tabrat.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine tabrat
!      tabulation of the results
! do identifications of orbitals
! nmax number of tabulation points for wave function
!      this programm uses dsordf

      implicit double precision (a-h,o-z)
      parameter (zero = 0)
      parameter (ryd  = 13.605698d0)
      parameter (hart = 2*ryd)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
      character*2  titre(30)
      character*2  ttire(9)
      dimension at(8),mbi(8)
      logical open_16

      external dsordf
      data ttire /'s ', 'p*', 'p ', 'd*', 'd ', 'f*', 'f ','g*', 'g '/
 
      do 110 i=1,norb
         if (kap(i) .gt. 0) then
           j=2*kap(i)
         else
           j=-2*kap(i)-1
         endif
         titre(i)=ttire(j)
 110  continue

!     tabulation of number of points and of average values of
!                   r**n (n=6,4,2,1,-1,-2,-3)
      inquire(unit=16,opened=open_16)
      do 201 i=2,8
 201     mbi(i)=8-i-i/3-i/4+i/8
      if(open_16) then
        write(16,*)                                                     &
     &  'number of electrons nel and average values of r**n in a.u.'
        write(16,2061) (mbi(k),k=2,8)
 2061   format (5x,'nel     -E ','     n=',7(i2,8x))
      endif
      do 251 i=1,norb
         llq= abs(kap(i))-1
         j=8
         if (llq.le.0) j=7
         do 241 k=2,j
 241        at(k)=dsordf(i,i,mbi(k),1, zero)
 251     if (open_16)                                                   &
     &     write(16,2071) nq(i),titre(i),xnel(i),-en(i)*hart,           &
     &                  (at(k),k=2,j)
 2071 format(i1,a2,f6.3,8(1pe10.3))

!      overlap integrals
      if (norb.le.1) return
      if (open_16) write(16,321)
 321  format(10x,'overlap integrals')
      do 351 i=1,norb-1
         do 331 j=i+1,norb
            if (kap(j).ne.kap(i)) go to 331
            at(1)=dsordf(i,j,0,1, zero)
            if(open_16)                                                 &
     &        write(16,2091)  nq(i),titre(i),nq(j),titre(j),at(1)
 331     continue
 351  continue
 2091 format (4x,i3,a2,i3,a2,f14.7)
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: vlda.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine vlda(ia, xnval,srho, srhovl,vtrho, ilast, idfock)
!    this program calculates xc potential, using core-vlaence separation
!    discussed in ankuodinov's thesis.  
!    written by alexei ankoudinov. 11.07.96
      use constants
      implicit double precision (a-h,o-z)

      dimension xnval(30), srho (251), srhovl(251), vtrho(251)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),              &
     &        fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),dv(251),av(10), &
     &              eg(251),ceg(10),ep(251),cep(10)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
 
      do 10 i = 1,251
        srhovl(i) = 0.0d0
 10     srho(i) = 0.0d0
 
!  find total and valence densities. Remove self-interaction if SIC
      do 50 j = 1, norb
        a = xnel(j)
        b = xnval(j)
!      use to test SIC
!       if (j .eq. ia) a=a-1.0d0
!       if (j .eq. ia) b=b-1.0d0
      do 50 i = 1,nmax(j)
        srho(i) = srho(i) + a * (cg(i,j)**2+cp(i,j)**2)
 50     srhovl(i) = srhovl(i) + b * (cg(i,j)**2+cp(i,j)**2)

!  constract lda potential. Put your favorite model into vbh.f.
!  exch=5,6 correspond to 2 ways of core-valence separation of V_xc.
      do 90 i = 1,251
        rho = srho(i) / (dr(i)**2)
        if (idfock.eq.5) then
!          for exch=5 valence density*4*pi
           rhoc = srhovl(i) / (dr(i)**2)
        elseif (idfock.eq.6) then
!          for exch=6 core density*4*pi
           rhoc = (srho(i)-srhovl(i)) / (dr(i)**2)
        elseif (idfock.eq.1) then
           rhoc = 0.0d0
        elseif (idfock.eq.2) then
           rhoc = srho(i) / (dr(i)**2)
        else
            call par_stop(' undefined idfock in subroutine vlda')
        endif

        if (rho .gt. 0.0 ) then
           rs = (rho/3)**(-third)
           rsc =101.0
           if (rhoc .gt.0.0) rsc = (rhoc/3)**(-third)
           xm = 1.0d0
!          vbh and edp in Hartrees
           if (idfock.eq.5 .or. idfock.eq.2) then
!             for exch=5, 2
              call vbh(rsc, xm, vxcvl)
           elseif (idfock.eq.6) then
!             for exch=6
              call vbh(rs, xm, vvbh)
                 xf = fa/rs
              call edp(rsc,xf,vdh)
              vxcvl = vvbh - vdh
           elseif (idfock.eq.1) then
!          for pure Dirac-Fock
              vxcvl = 0.0d0
           endif

!   contribution to the total energy from V_xc:=\int d^3 r V_xc * rho/2
           if (ilast.gt.0) vtrho (i) = vtrho(i) +                       &
     &         vxcvl * srho(i)
!    1         vxcvl * xnel(ia)*(cg(i,ia)**2+cp(i,ia)**2)
!           use to test SIC

!  add to the total potential and correct it's development coefficients
           if (i.eq.1) av(2) = av(2) +vxcvl/cl
           dv(i) = dv(i) +vxcvl/cl
        endif
 90   continue
 999  continue

      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: wfirdf.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine wfirdf (en,ch,nq,kap,nmax,ido)
!     calculate initial orbiatls from integration of dirac equation
! cg (cp) large (small) radial components
! bg (bp) development coefficients at the origin of cg (cp)
! en one-electron energies 
! fl power of the first term of development at the origin
! ch ionicity (nuclear charge - number of electrons)
! nq principal quantum number
! kap quantum number "kappa"
! nmax number of tabulation points for the orbitals
! ibgp first dimension of the arrays bg and bp
!        this programmes utilises nucdev,dentfa,soldir et messer
 
      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),              &
     &         fl(30), fix(30), ibgp
      dimension en(30),nq(30),kap(30),nmax(30)
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),                &
     &dv(251),av(10),eg(251),ceg(10),ep(251),cep(10)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/inelma/nem
      common/messag/dlabpr,numerr
      character*8 dlabpr
      character*512 slog
      common/snoyau/dvn(251),anoy(10),nuc
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
!#mn
       external dentfa

      cl=1.370373d+02
!    speed of light in atomic units
      dz = nz
! make r-mesh and calculate nuclear potential
! hx exponential step
! dr1 first tabulation point multiplied by nz
      hx=5.0d-02
      dr1= nz*exp(-8.8)
      call nucdev (anoy,dr,dvn,dz,hx,nuc,idim,ndor,dr1)
! notice that here nuc=1, 
! unless you specify nuclear mass and thickness in nucdev.f

      a=(dz/cl)**2
      if (nuc.gt.1) a=0.0d00
      do 11 j=1,norb
         b=kap(j)*kap(j)-a
         fl(j)= sqrt(b)
!        quick fix of development coefficients. ala
 11      fix(j) = dr(1)**(fl(j)-abs(kap(j)))
! calculate potential from thomas-fermi model
      do 21 i=1,idim
 21   dv(i)=(dentfa(dr(i),dz,ch)+dvn(i))/cl
      if (numerr.ne.0) return
      do 51 i=1,idim
         eg(i)=0.0d00
 51      ep(i)=0.0d00
      do 61 i=1,ibgp
         ceg(i)=0.0d00
         cep(i)=0.0d00
 61      av(i)=anoy(i)/cl
      av(2)=av(2)+dentfa(dr(nuc),dz,ch)/cl
      test1=testy/rap(1)
      b=test1

! resolution of the dirac equation to get initial orbitals
      if (ido.ne.1) then
         call wlog('only option ido=1 left')
         ido = 1
      endif
!  here was a piece to read orbitals from cards
      do 281 j=1,norb
         bg(1,j)=1.0d00
         i=nq(j)- abs(kap(j))
         if (kap(j).lt.0) i=i-1
         if (mod(i,2).eq.0) bg(1,j)=-bg(1,j)
         if (kap(j).lt.0) go to 201
         bp(1,j)=bg(1,j)*cl*(kap(j)+fl(j))/dz
         if (nuc.gt.1) bg(1,j)=0.0d00
         go to 211

 201     bp(1,j)=bg(1,j)*dz/(cl*(kap(j)-fl(j)))
         if (nuc.gt.1) bp(1,j)=0.0d00
 211     np=idim
         en(j)=-dz*dz/nq(j)*nq(j)
         method=0
         ifail = 0
         call soldir                                                    &
     &     (en(j),fl(j),bg(1,j),bp(1,j),b,nq(j),kap(j),nmax(j),ifail)

         if (numerr.eq.0) go to 251
         call messer
         write(slog,'(a,2i3)')                                          &
     &   'soldir failed in wfirdf for orbital nq,kappa ',nq(j),kap(j)
         call wlog(slog)
         go to 281

 251     do 261 i=1,ibgp
            bg(i,j)=ag(i)
 261        bp(i,j)=ap(i)
         do 271 i=1,np
            cg(i,j)=dg(i)
 271        cp(i,j)=dp(i)
 281  continue
      nem=0
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: getorb.f90,v $:
! $Revision: 1.7 $
! $Author: jorissen $
! $Date: 2012/09/11 22:52:14 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine getorb (iz, ihole, xion, iunf, norb, norbco, iorb, iholep, nqn, nk, xnel, xnval, xmag, iph)  !KJ 12-2010 added iph
!     Gets orbital data for chosen element.  Input is:
!       iz - atomic number of desired element,
!       ihole - index of core-hole orbital
!       xion  - ionicity (usually zero)
!     other arguments are output.
!       norb - total number of orbitals
!       norbco - number of core orbitals
!       iorb - index of orbital for making projections (last occupied)
!       iholep - index of core hole orbital in compacted list
!       nqn - principal quantum number for each orbital
!       nk - quantum number kappa for each orbital
!       xnel - occupation for each orbital
!       xnval - valence occupation for each orbital
!       xmag - spin magnetization for each orbital
      use config,izdum=>iz  ! replaces old data statements
	  
	  ! KJ bugfix Sept 2012 : added initialization statement setting xnel,xmag,xnval to 0 since getorb is called many times ...  Yikes!
	  
	  implicit none
	  
      integer,intent(in)  :: iz, ihole, iph, iunf
	  real*8,intent(in)   :: xion
	  integer,intent(out) :: norb, norbco, iorb(-4:3), iholep, nqn(30), nk(30)
	  real*8,intent(out)  :: xnel(30), xnval(30), xmag(30)

!     Written by Steven Zabinsky, July 1989
!     modified (20 aug 1989)  table increased to at no 100
!     Recipe for final state configuration is changed. Valence electron occupations are added. ala 17.1.1996
!     Structure changed - using modules, allowing user input.  KJ 12.2010

      character*512 slog
	  integer ion,index,ilast,iscf,iion,i,index1,iscr,iphl
	  real*8 delion



!  How an ION is treated :
!  Say we have ION 1 0.6 in feff.inp, where potential "1" is for Fe (Z=26), i.e. we have a Fe^+0.6 atom
!  We need to remove 0.6 e charge from this Fe atom.
!  We will start from the default Z=25 configuration of Mn.  
!  Then, we will find the orbital for which the occupation differs between the default Mn and Fe occupations.
!  In this orbital, we will add 0.4 e.  (Unless there is a corehole and the screening electron would already fill all available
!  space in this orbital; in that case, we choose the highest orbital with any occupation; or, if that one too lacks sufficient space, the first empty orbital.)
!  The parameters used below will evaluate to (for a NOHOLE calculation) :
!  (iz=26; index=25; index1=26; xion=0.6; ion=1; delion=-0.4; iion=9 [3d]; ilast=11; iscr=9 )

!  If instead we had ION 1 -0.6, then we would start from the default Z=26 configuration for Fe.
!  We would find the highest orbital with sufficient occupation to remove 0.6 e.
!  And we'd just take them out :).


!     write(*,*) '########## START GETORB ##########'
!     write(*,*) 'iz,ihole,xion',iz,ihole,xion
!	  write(*,*) 'iunf,norb,norbco',iunf,norb,norbco
!	  write(*,*) 'iorb',iorb
!	  write(*,*) 'iholep,nqn',iholep,nqn
!	  write(*,*) 'nk',nk
!	  write(*,*) 'xnel',xnel
!	  write(*,*) 'xnval',xnval
!	  write(*,*) 'xmag,iph',xmag,iph
!	  write(*,*) '       ######'


      call InitConfig   !Initialize default electronic configurations, taking user input into account.
      if (iz .lt. 1  .or.  iz .gt. 100)  then
         write(slog,'(" Atomic number ",i5," not available.")')  iz
         call wlog(slog)
         call par_stop('GETORB-0')
      endif
!	  if (iph.eq.1) then
!	  write(*,*) "O configuration iocc:"
!	  write(*,'(100f7.2)') iocc(1,15:24)
!	  endif


! ###### The following section figures out which orbitals will accomodate the core hole, screening electron, and ionization :
!        (i.e., find iscr and iion)

      ion = nint(xion)
      delion=xion-ion  !we will subtract delion electrons from the base configuration Z=index
      index = iz - ion
      ilast = 0
      iscr = 0
      iion = 0
      iholep = ihole
	  if(index.eq.iz) then !KJ
	     iphl=iph  !=> use potential index to retrieve occupation numbers
	  else
	     iphl=-743 !negative number  => use modified (ionized) atomic number to retrieve atomic numbers
      endif


!     find last occupied orbital (ilast) and iion for delion.ge.0
!     (if delion<0, this produces nonsense, but it will be fixed below, once we know iscr.)
      do i=29,1,-1
         if (iion.eq.0  .and. f_iocc(index,i,iphl).gt.delion) iion=i
         if (ilast.eq.0 .and. f_iocc(index,i,iphl).gt.0) ilast=i
      enddo
!     write(*,*) 'iion,ilast',iion,ilast
      !check that the core hole orbital contains sufficient charge to create a hole:
      if (ihole.gt.0) then
         if ( f_iocc(index,ihole,iphl) .lt. 1 ) then
           call wlog(' Cannot remove an electron from this level')
           call par_stop('GETORB-1')
         endif
      endif
	  !even if we are also ionizing that same orbital:
      if (ihole.eq.iion .and. delion.gt.0) then   !KJ ilast->iion 5-2012; if delion<0 we will add electrons, so there's no need to worry here, but skip the test, since iion will be set to a nonsense value.
         if ( f_iocc(index,ihole,iphl)-delion.lt.1) then
           call wlog(' Cannot remove an electron from this level')
           call par_stop('GETORB-1')
        endif
      endif

!        the recipe for final state atomic configuration is changed from iz+1 prescription, since sometimes it changed occupation
!        numbers in more than two orbitals. This could be consistent only with s02=0.0. New recipe remedies this deficiency.

!     find where to put screening electron : put it in the orbital where the "Z+1" atom has its extra electron
      index1 = index + 1
      do i = 1, 29
         if (iscr.eq.0 .and. (f_iocc(index1,i,-1)-f_iocc(index,i,iphl)).gt.0.5) iscr=i  
      enddo

!     If core-hole orbital only has one electron, set iscr to ihole - Josh Kas
      if(ihole.gt.0) then
	     if (f_iocc(index,ihole,iphl).lt.1.5) iscr = ihole !KJ array bounds get exceeded here when ihole=0 - fixed!
	  endif
!     special case of hydrogen like ion
!     if (index.eq.1) iscr=2

!     find where to add or subtract charge delion (iion).
!     if (delion .ge. 0) then
!        removal of electron charge
!        iion is already found
      if (delion .lt. 0) then
!        addition of electron charge in the amount of -delion to the same orbital where we'd put the screening electron
         iion = iscr
!        except special cases where there's not enough space for the ionization charge
         if (ihole.ne.0 .and. f_iocc(index,iscr,iphl)+1-delion.gt.2*abs(kappa(iscr))) then
             iion = ilast
             if (ilast.eq.iscr .or. f_iocc(index,ilast,iphl)-delion.gt. 2*abs(kappa(ilast)) ) iion = ilast + 1
         endif
      endif

!      if (iph.eq.1)      write(*,*) 'iscr,iion,index,ihole,delion',iscr,iion,index,ihole,delion
!      write(*,*) 'f_iocc(index,i,iphl',(f_iocc(index,i,iphl),i=1,29)
! 	   write(*,*) 'v_ival(index,i,iphl',(f_ival(index,i,iphl),i=1,29)
	  
	  
! ######## Now we know everything.  Start filling up the occupation arrays.	 

! Note that xnel,xnval,xmag do not track all orbitals, but only the ones containing charge.  e.g. "2 2 4 1 0 0 0 2" --> "2 2 4 1 2" 
      norb = 0
      iorb(-4:3) = 0
	  xnel(:)=0.d0
	  xnval(:)=0.d0
	  xmag(:)=0.d0
      do i = 1, 29
         if (f_iocc(index,i,iphl).gt.0 .or. (i.eq.iscr .and. ihole.gt.0) .or. (i.eq.iion .and. f_iocc(index,i,iphl)-delion.gt.0) )  then
		     !the template has e here        !put the screening e here         !we put ionization charge here
            if (i.ne.ihole .or. f_iocc(index,i,iphl).ge.1) then
               norb = norb + 1
               nqn(norb) = nnum(i) !principal quantum number
               nk(norb)  = kappa(i) !relativistic quantum number
               xnel(norb) = f_iocc(index,i,iphl) !occupation of the template
               if (i.eq.ihole) then   !create the core hole
                  xnel(norb) = xnel(norb) - 1
                  iholep = norb
               endif
               if (i.eq.iscr .and. ihole.gt.0)  xnel(norb)=xnel(norb)+1  !add the screening electron
               xnval(norb)= f_ival(index,i,iphl) !valence occupation
               if ((kappa(i).eq.-4 .or. kappa(i).eq.3) .and. iunf.eq.0)  xnval(norb) = 0 !put f-electron in the core, i.e. "freeze" them
               xmag(norb) = f_ispn(index,i,iphl)
               iorb(nk(norb)) = i
               if (i.eq.ihole .and. xnval(norb).ge.1)   xnval(norb) = xnval(norb) - 1 !adjust valence occupation for core hole
               if (i.eq.iscr .and. ihole.gt.0) xnval(norb) = xnval(norb) + 1 !adjust valence occupation for screening electron
               if (i.eq.iion)  xnel(norb) = xnel(norb) - delion !adjust occupation for ionization  !KJ 5-2012 iscr-> iion bugfix
               if (i.eq.iion)  xnval(norb) = xnval(norb) - delion !adjust valence occupation for ionization
            endif
         endif
      enddo
      norbco = norb

!     check that all occupation numbers are within limits
      do i = 1, norb
         if ( xnel(i).lt.0 .or.  xnel(i).gt.2*abs(nk(i)) .or. xnval(i).lt.0 .or. xnval(i).gt.2*abs(nk(i)) ) then
            write (slog,55) i
   55       format(' error in getorb.f. Check occupation number for ',i3, '-th orbital. May be a problem with ionicity.')
            call wlog(slog)
            call par_stop('GETORB-99')
         endif
      enddo
	  
!	  if (iph.eq.1) write(*,'(100f7.2)') xnel(15:24)
!     if (iph.eq.1) stop

!	  write(*,*) '       ######'
!     write(*,*) 'iz,ihole,xion',iz,ihole,xion
!	  write(*,*) 'iunf,norb,norbco',iunf,norb,norbco
!	  write(*,*) 'iorb',iorb
!	  write(*,*) 'iholep,nqn',iholep,nqn
!	  write(*,*) 'nk',nk
!	  write(*,*) 'xnel',xnel
!	  write(*,*) 'xnval',xnval
!	  write(*,*) 'xmag,iph',xmag,iph
!	  write(*,*) '       ######'
!     write(*,*) '########## END GETORB ##########'

            
      return
      end  ! subroutine getorb


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: somm.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine somm (dr,dp,dq,dpas,da,m,np)
!
! integration by the method of simpson of (dp+dq)*dr**m from
! 0 to r=dr(np)
! dpas=exponential step;
! for r in the neighborhood of zero (dp+dq)=cte*r**da
! **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(np), dp(np), dq(np)
      mm=m+1
      d1=da+mm
      da=0.0
      db=0.0
      do 70 i=1,np
      dl=dr(i)**mm
      if (i.eq.1.or.i.eq.np) go to 10
      dl=dl+dl
      if ((i-2*(i/2)).eq.0) dl=dl+dl
   10 dc=dp(i)*dl
      if (dc) 20,40,30
   20 db=db+dc
      go to 40
   30 da=da+dc
   40 dc=dq(i)*dl
      if (dc) 50,70,60
   50 db=db+dc
      go to 70
   60 da=da+dc
   70 continue
      da = dpas * (da + db) / 3.0
      dc=exp(dpas)-1.0
      db=d1*(d1+1.0)*dc*exp((d1-1.0)*dpas)
      db=dr(1)*(dr(2)**m)/db
      dc=(dr(1)**mm)*(1.0+1.0/(dc*(d1+1.0)))/d1
      da=da+dc*(dp(1)+dq(1))-db*(dp(2)+dq(2))
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: aprdev.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function aprdev (a,b,l)
!     the result of this function is the coefficient for the term of 
!     power (l-1) for the product of two polynomes, whose coefficients
!     are in rows a and b 
 
      implicit double precision (a-h,o-z)
      dimension a(10),b(10)
 
      aprdev=0.0d00
      do 11 m=1,l
 11      aprdev=aprdev+a(m)*b(l+1-m)
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: akeato.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function akeato (i,j,k)
!     angular coefficient by the direct coulomb integral fk for orbitals
!     i and j
      implicit double precision (a-h,o-z)
      common/mulabk/afgk
      dimension afgk(30,30,0:3)
 
!     afgk angular coefficients by integrales fk and gk
!        coefficient of integral fk(i;j) is in  afgk(min,max)
!        and that of integral gk(i;j) is in  afgk(max,min)
!        max=max(i,j) min=min(i,j)
 
      if (i .le. j) then 
         akeato=afgk(i,j,k/2)
      else
         akeato=afgk(j,i,k/2)
      endif
      return
      end

      double precision function bkeato (i,j,k)
      implicit double precision (a-h,o-z)
      common/mulabk/afgk
      dimension afgk(30,30,0:3)
!     angular coefficient at the exchange coulomb integral gk
 
      bkeato=0.0d00
      if (i .lt. j) then
         bkeato=afgk(j,i,k/2)
      elseif (i.gt.j) then
         bkeato=afgk(i,j,k/2)
      endif
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: bkmrdf.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine bkmrdf (i,j,k)
!     angular coefficients for the breit term. i and j are the numbers
!     of orbitals and  k is the value of k in uk(1,2)
!        this programm uses cwig3j
!     coefficients for magnetic interaction  are in cmag
!     and those for retarded term are in cret
!     the order correspond to -1 0 and +1
 
      implicit double precision (a-h,o-z)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
      common/tabre/cmag(3),cret(3)
!#mn
       external cwig3j
 
      do 12 l=1,3
        cmag(l)=0.0d00
 12     cret(l)=0.0d00
      ji=2* abs(kap(i))-1
      jj=2* abs(kap(j))-1
      kam=kap(j)-kap(i)
      l=k-1
      do 51 m=1,3
         if (l.lt.0) go to 51
         a=cwig3j(ji,jj,l+l,-1,1,2)**2
         if (a.eq.0.0d00) go to 51
         c=l+l+1
         if (m-2) 14,16,17
 14      cm=(kam+k)**2
         cz=kam*kam-k*k
         cp=(k-kam)**2
         n=k
 15      l1=l+1
         am=(kam-l)*(kam+l1)/c
         az=(kam*kam+l*l1)/c
         ap=(l+kam)*(kam-l1)/c
         d=n*(k+k+1)
         go to 31

 16      d=k*(k+1)
         cm=(kap(i)+kap(j))**2
         cz=cm
         cp=cm
         go to 41

 17      cm=(kam-l)**2
         cz=kam*kam-l*l
         cp=(kam+l)**2
         n=l
         c=-c
         go to 15

 31      c= abs(c)*d
         if (c.ne.0.0d00) c=n/c
         cret(1)=cret(1)+a*(am-c*cm)
         cret(2)=cret(2)+(a+a)*(az-c*cz)
         cret(3)=cret(3)+a*(ap-c*cp)
 41      if (d.eq.0.0d00) go to 51
         a=a/d
         cmag(1)=cmag(1)+cm*a
         cmag(2)=cmag(2)+cz*(a+a)
         cmag(3)=cmag(3)+cp*a
 51      l=l+1
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: fdmocc.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function fdmocc (i,j)
!     product of the occupation numbers of the orbitals i and j

      implicit double precision (a-h,o-z)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
 
      if (j.eq.i) then
         fdmocc=xnel(i)*(xnel(j)-1)
         a=2* abs(kap(i))
         fdmocc=fdmocc*a/(a-1.0)
      else
         fdmocc=xnel(i)*xnel(j)
      endif
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: fdrirk.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function fdrirk (i,j,l,m,k)
!                       * calculate radial integrales rk *
!        rk = integral of f(r) * uk(r,s) * g(s)
! uk(r,s) = rinf**k / rsup**(k+1)    rinf=min(r,s)   rsup=max(r,s)
!        if nem=0  f(.)=cg(.,i)*cg(.,j)+cp(.,i)*cp(.,j)
!                  g(.)=cg(.,l)*cg(.,m)+cp(.,l)*cp(.,m)
!        if nem non zero f(.)=cg(.,i)*cp(.,j)
!                        g(.)=cg(.,l)*cp(.,m)
!                  cg (cp) large (small) componenents of the orbitales
! moreover if nem > or =0 the integration is made from 0 to infinity,
! and otherwise from 0 to r.
!        this programm uses yzkrdf and dsordf
 
      implicit double precision (a-h,o-z)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783)
! comdir is used just to exchange variables between dsordf,yzkrdf,fdrirk
      dimension hg(251)
      common/inelma/nem
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      save
 
      fdrirk=0.0d00
      if (i.le.0.or.j.le.0) go to 201
      call yzkrdf (i,j,k)
      nn= abs(kap(i))+ abs(kap(j))
      nn=max(nn-k,1)
      a=k+1
      do 21 n=1,ndor
 21   hg(n)=0.0d00
      do 31 n=1,ndor
         if (nn.gt.ndor) go to 31
         hg(nn)=-ag(n)
 31      nn=nn+1
      do 41 n=1,ndor
 41      ag(n)=hg(n)
      ag(1)=ag(1)+ap(1)

 201  if (l.le.0.or.m.le.0) return
      n=-1
      if (nem.ne.0) n=-2
      fdrirk=dsordf(l,m,-1,n,a)
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: cwig3j.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function cwig3j (j1,j2,j3,m1,m2,ient)
!     wigner 3j coefficient for integers  (ient=1)
!                         or semiintegers (ient=2)
!     other arguments should be multiplied by ient
 
      implicit double precision (a-h,o-z)
      integer,parameter :: idim = 58 !KJ 7-09 for NRIXS - used to be 58)
      character*512 slog
!     dimensions  modified for larger arguments by ala 12.12.94
      dimension al(idim+1),m(12)
      save ini, al
      data ini/1/
!     idim-1 is the largest argument of factorial to calculate

      m3=-m1-m2
      if (ini) 1,21,1
!        initialisation of the log's of the factorials
 1    ini=0
      al(1)=0.0d00
      do i=1,idim
         b=i
         al(i+1)=al(i)+ log(b)
      enddo
 21   cwig3j=0.0d00
      if (((ient-1)*(ient-2)).ne.0) go to 101
      ii=ient+ient
!        test triangular inequalities, parity and maximum values of m
      if (( abs(m1)+ abs(m2)).eq.0.and.mod(j1+j2+j3,ii).ne.0) go to 99
      m(1)=j1+j2-j3
      m(2)=j2+j3-j1
      m(3)=j3+j1-j2
      m(4)=j1+m1
      m(5)=j1-m1
      m(6)=j2+m2
      m(7)=j2-m2
      m(8)=j3+m3
      m(9)=j3-m3
      m(10)=j1+j2+j3+ient
      m(11)=j2-j3-m1
      m(12)=j1-j3+m2
      do 41 i=1,12
!	     write(*,*) 'i,m(i)',i,m(i)
!	     write(*,*) 'error1?'
         if (i.gt.10) go to 31
         if (m(i).lt.0) go to 99
!        write(*,*) 'error2?', mod(m(i),ient)
31       if (mod(m(i),ient).ne.0) go to 101
         m(i)=m(i)/ient
!		 write(*,*) 'error3?',idim
         if (m(i).gt.idim) go to 101
 41   continue

!        calculate 3j coefficient
      max0= max(m(11),m(12),0)+1
      min0= min(m(1),m(5),m(6))+1
      isig=1
      if (mod(max0-1,2).ne.0) isig=-isig
      c=-al(m(10)+1)
      do i=1,9
         c=c+al(m(i)+1)
      enddo
      c=c/2.0d00
      do i=max0,min0
         j=2-i
         b=al(i)+al(j+m(1))+al(j+m(5))+al(j+m(6))+al(i-m(11))+al(i-m(12))
         cwig3j=cwig3j+isig* exp(c-b)
         isig=-isig
      enddo
      if (mod(j1-j2-m3,ii).ne.0) cwig3j=-cwig3j
 99   return

 101  write(slog,'(a,6i5)') 'error in cwig3j ',j1,j2,j3,m1,m2,ient
      call wlog(slog)
      stop
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: yzkrdf.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine yzkrdf (i,j,k)
!       * calculate  function yk *
! yk = r * integral of f(s)*uk(r,s)
! uk(r,s) = rinf**k/rsup**(k+1)   rinf=min(r,s)   rsup=max(r,s)
! f(s)=cg(s,i)*cg(s,j)+cp(s,i)*cp(s,j)      if nem=0
! f(s)=cg(s,i)*cp(s,j)                      if nem is non zero
! f(s) is constructed by the calling programm  if i < or =0
! in the last case a function f (lies in the block dg) is supposedly
! tabulated untill point dr(j), and its' devlopment coefficients
! at the origin are in ag and the power in r of the first term is k+2

! the output functions yk and zk are in the blocks dp and dg.
! at the origin  yk = cte * r**(k+1) - developement limit,
! cte lies in ap(1) and development coefficients in ag.
!        this programm uses aprdev and yzkteg
 
      implicit double precision (a-h,o-z)
      common cg(251,30), cp(251,30), bg(10,30), bp(10,30),              &
     &         fl(30), fix(30), ibgp
      common/comdir/cl,dz,dg(251),ag(10),dp(251),ap(10),bidcom(783)
      dimension chg(10)
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),            &
     &nq(30),kap(30),nmax(30)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      common/inelma/nem
      dimension bgi(10),bgj(10),bpi(10),bpj(10)
!#mn
       external aprdev
 
      if (i.le.0) go to 51
!     construction of the function f
      do  5 l= 1,ibgp
        bgi(l) = bg(l,i)
        bgj(l) = bg(l,j)
        bpi(l) = bp(l,i)
  5     bpj(l) = bp(l,j)
      id= min(nmax(i),nmax(j))
      ap(1)=fl(i)+fl(j)
      if (nem.ne.0) go to 31
      do 11 l=1,id
 11   dg(l)=cg(l,i)*cg(l,j)+cp(l,i)*cp(l,j)
      do 21 l=1,ndor
 21   ag(l)=aprdev(bgi,bgj,l)+aprdev(bpi,bpj,l)
      go to 55

 31   do 35 l=1,id
 35   dg(l)=cg(l,i)*cp(l,j)
      do 41 l=1,ndor
 41   ag(l)=aprdev(bgi,bpj,l)
      go to 55

 51   ap(1)=k+2
      id=j
 55   call yzkteg (dg,ag,dp,chg,dr,ap(1),hx,k,ndor,id,idim)
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: yzkteg.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine yzkteg (f,af,g,ag,dr,ap,h,k,nd,np,idim)
! calculation of yk(r)=zk(r)+ r**(k+1) * integral from r to 
!   infinity of  f(u) * u**(-k-1)
! zk(r) = r**(-k) * integral from 0 to r of f(u) * u**k

! at the origin f(r)=sum from i=1 to nd of af(i)*r**(ap+i-1)
! dr tabulation points   h exponential step
! np number of tabulation points for f
! idim dimension of the blocks f,g and dr

! at the origin yk=cte*r**(k+1)-developement limit
! the constant for yk lies in ap
! output functions yk and zk lie in f and g, and their
! development coefficients at the origin in af and ag.

! integration from point to point by a 4 points method.
! integral from r to r+h = h*(-f(r-h)+13*f(r)+13*f(r+h)-f(r+h+h))/24

      implicit double precision (a-h,o-z)
      dimension f(251),af(10),g(251),ag(10),dr(251)
 
!    initialisation and development coefficients of yk
      np= min(np,idim-2)
      b=ap
      ap=0.0d00
      g(1)=0.0d00
      g(2)=0.0d00
      do 15 i=1,nd
         b=b+1.0d00
         ag(i)=af(i)/(b+k)
         if (af(i).ne.0.0d00) then
            c=dr(1)**b
            g(1)=g(1)+ag(i)*c
            g(2)=g(2)+ag(i)*(dr(2)**b)
            af(i)=(k+k+1)*ag(i)/(b-k-1)
            ap=ap+af(i)*c
         endif
 15   continue
      do 21 i=1,np
 21   f(i)=f(i)*dr(i)
      np1=np+1
      f(np1)=0.0d00
      f(np1+1)=0.0d00

!     calcualation of zk
      eh= exp(h)
      e=eh**(-k)
      b=h/2.4d+01
      c=1.3d+01*b
      ee=e*e*b
      b=b/e
      do 51 i=3,np1
 51   g(i)=g(i-1)*e+(c*(f(i)+f(i-1)*e)-(f(i-2)*ee+f(i+1)*b))
 
!     calcualation of yk
      f(np)=g(np)
      do 61 i=np1,idim
 61   f(i)=f(i-1)*e
      i=k+k+1
      b=i*b*eh
      ee=i*ee/(eh*eh)
      e=e/eh
      c=i*c
      do 71  i=np-1,2,-1
 71   f(i)=f(i+1)*e+(c*(g(i)+g(i+1)*e)-(g(i+2)*ee+g(i-1)*b))
      ee=e*e
      c=8.0d00*c/1.3d+01
      f(1)=f(3)*ee+c*(g(3)*ee+4.0d00*e*g(2)+g(1))
      ap=(ap+f(1))/(dr(1)**(k+1))
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: determ.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function determ(array,nord,nrows)
!
!     calculate determinate of a square matrix
!        (from bevington "data reduction and error analysis
!         for the physical sciences" pg 294)
!     array: matrix to be analyzed
!     nord: order of matrix
!     nrows:  first dimension of matrix in calling routine
!
      double precision array(nrows,nrows)
      determ = 1.
      do 150 k=1,nord
!
!
        if (array(k,k).ne.0) go to 130
        do 100 j=k,nord
          if (array(k,j).ne.0) go to 110
  100   continue
        determ = 0.
        go to 160
!
  110   do 120 i=k,nord
          saved = array(i,j)
          array(i,j) = array(i,k)
  120   array(i,k) = saved
        determ = -determ
!
  130   determ = determ*array(k,k)
        if (k.ge.nord) go to 150
        k1 = k+1
        do 140 i=k1,nord
          do 140 j=k1,nord
  140   array(i,j) = array(i,j)-array(i,k)*array(k,j)/array(k,k)
  150 continue
  160 return
! end double precision function determ
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: intdir.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine intdir(gg,gp,ag,ap,ggmat,gpmat,en,fl,agi,api,ainf,max0)
!            solution of the inhomogenios dirac equation
! gg gp initially exch. terms, at the time of return are wave functions
! ag and ap development coefficients of  gg and gp
! ggmat gpmat  values at the matching point for the inward integration
! en one-electron energy
! fl power of the first development term at the origin
! agi (api) initial values of the first development coefficients
! at the origin of a large (small) component
! ainf initial value for large component at point dr(max0) 
!   - at the end of tabulation of gg gp
 
      implicit double precision (a-h,o-z)
      common/comdir/cl,dz,bid1(522),dv(251),av(10),bid2(522)
      common/tabtes/hx,dr(251),test1,test2,ndor,np,nes,method,idim
      common/subdir/ell,fk,ccl,imm,nd,node,mat
      common/messag/dlabpr,numerr
      character*8 dlabpr
      dimension gg(251),gp(251),ag(10),ap(10),coc(5),cop(5),dg(5),dp(5)
      save
      data cop/2.51d+02,-1.274d+03,2.616d+03,-2.774d+03,1.901d+03/,     &
     &coc/-1.9d+01,1.06d+02,-2.64d+02,6.46d+02,2.51d+02/,               &
     &cmixn/4.73d+02/,cmixd/5.02d+02/,hxd/7.2d+02/,npi/5/,icall/0/
 
! numerical method is a 5-point predictor-corrector method
! predicted value    p(n) = y(n-1) + c * somme de i=1,5 cop(i)*y'(n-i)
! corrected value    c(n) = y(n-1) + c * somme de i=1,4 coc(i)*y'(n-i)
!                                  + coc(5)*p'(n)
! final value        y(n) = cmix*c(n) + (1.-cmix)*p(n)
!                           cmix=cmixn/cmixd
 
      if (icall.eq.0) then
         icall=1
         c=cmixn/cmixd
         a=1.0d00-c
         cmc=c*coc(5)
         f=coc(1)
         do 1 j=2,npi
            g=coc(j)
            coc(j)=c*f+a*cop(j)
 1          f=g
         coc(1)=c*cop(1)
      endif
      c=hx/hxd
      ec=en/cl
      ag(1)=agi
      ap(1)=api
      if (imm) 81,15,26
!      search for the second sign change point
 15   mat=npi
      j=1
 16   mat=mat+2
         if (mat.ge.np) then
!   i had trouble with screened k-hole for la, for f-electrons.
!   below i still define matching point if one electron energy not less
!   than -1ev.
            if (ec .gt. -0.0003) then
              mat = np - 12
              go to 25
            endif
            numerr=56011
!          * fail to find matching point
            return
         endif
         f=dv(mat)+ell/(dr(mat)*dr(mat))
         f=(f-ec)*j
         if (f) 25,25,16
 25      j=-j
      if (j.lt.0) go to 16
      if (mat .ge. np-npi) mat=np-12
 
!     initial values for the outward integration
 26   do 35 j=2,ndor
         k=j-1
         a=fl+fk+k
         b=fl-fk+k
         ep=a*b+av(1)*av(1)
         f=(ec+ccl)*ap(k)+ap(j)
         g=ec*ag(k)+ag(j)
         do 31 i=1,k
            f=f-av(i+1)*ap(j-i)
 31         g=g-av(i+1)*ag(j-i)
 
         ag(j)=(b*f+av(1)*g)/ep
 35      ap(j)=(av(1)*f-a*g)/ep
      do 41 i=1,npi
         gg(i)=0.0d00
         gp(i)=0.0d00
         dg(i)=0.0d00
         dp(i)=0.0d00
         do 41 j=1,ndor
            a=fl+j-1
            b=dr(i)**a
            a=a*b*c
            gg(i)=gg(i)+b*ag(j)
            gp(i)=gp(i)+b*ap(j)
            dg(i)=dg(i)+a*ag(j)
 41         dp(i)=dp(i)+a*ap(j)
      i=npi
      k=1
      ggmat=gg(mat)
      gpmat=gp(mat)
 
!     integration of the inhomogenious system
 51   cmcc=cmc*c

 55   continue
         a=gg(i)+dg(1)*cop(1)
         b=gp(i)+dp(1)*cop(1)
         i=i+k
         ep=gp(i)
         eg=gg(i)
         gg(i)=a-dg(1)*coc(1)
         gp(i)=b-dp(1)*coc(1)
         do 61 j=2,npi
            a=a+dg(j)*cop(j)
            b=b+dp(j)*cop(j)
            gg(i)=gg(i)+dg(j)*coc(j)
            gp(i)=gp(i)+dp(j)*coc(j)
            dg(j-1)=dg(j)
 61         dp(j-1)=dp(j)
         f=(ec-dv(i))*dr(i)
         g=f+ccl*dr(i)
         gg(i)=gg(i)+cmcc*(g*b-fk*a+ep)
         gp(i)=gp(i)+cmcc*(fk*b-f*a-eg)
         dg(npi)=c*(g*gp(i)-fk*gg(i)+ep)
         dp(npi)=c*(fk*gp(i)-f*gg(i)-eg)
      if (i.ne.mat) go to 55

      if (k.lt.0) go to 999
      a=ggmat
      ggmat=gg(mat)
      gg(mat)=a
      a=gpmat
      gpmat=gp(mat)
      gp(mat)=a
      if (imm.ne.0) go to 81
 
!     initial values for inward integration
      a=test1* abs(ggmat)
      if (ainf.gt.a) ainf=a
      max0=np+2
 73   a=7.0d+02/cl
 75   max0=max0-2
         if ((max0+1).le.(mat+npi)) then
            numerr=138021
!          *the last tabulation point is too close to the matching point
            return
         endif
      if (((dv(max0)-ec)*dr(max0)*dr(max0)).gt.a) go to 75

 81   c=-c
      a=- sqrt(-ec*(ccl+ec))
      if ((a*dr(max0)).lt.-1.7d+02) go to 73
      b=a/(ccl+ec)
      f=ainf/ exp(a*dr(max0))
      if (f.eq.0.0d00) f=1.0d00
      do 91 i=1,npi
         j=max0+1-i
         gg(j)=f* exp(a*dr(j))
         gp(j)=b*gg(j)
         dg(i)=a*dr(j)*gg(j)*c
 91      dp(i)=b*dg(i)
      i=max0-npi+1
      k=-1
      go to 51

 999  return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: edp.f90,v $:
! $Revision: 1.4 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!***********************************************************************
!
!     this subroutine calculates the ' energy dependent
!     exchange-correlation potential' (or 'dirac- hara potential')
!     ref.: paper by s.h.chou, j.j.rehr, e.a.stern, e.r.davidson (1986)
!
!     inputs:    rs in a.u.
!                xk momentum in a.u.
!     outputs:   vr --- dirac potential (Hartrees)
!     written by j. mustre 8/31/87
!**********************************************************************

      subroutine edp (rs, xk, vr)
      use par
	  use constants
      implicit double precision (a-h, o-z)

      vr = 0.0d0
      if (rs .le. 100.0) then
!       p = sqrt (k^2 + kf^2) is the local momentum, and x = p / kf
!       Reference formula 23 in Role of Inelastic effects in EXAFS
!       by Rehr and Chou. EXAFS1 conference editted by Bianconi.
!       x is local momentum in units of fermi momentum

        xf = fa / rs
        x = xk / xf
        x = x + 1.0e-5
!       set to fermi level if below fermi level
        if (x .lt. 1.00001) x = 1.00001
        c = abs( (1+x) / (1-x) )
        c = log(c)
        vr = - (xf/pi) * (1 + c * (1-x**2) / (2*x))
      endif

      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: vbh.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine vbh(rs,xmag,vxc)

      implicit double precision (a-h, o-z)

!   INPUT: density parameter rs, 2* fraction of given spin orientation.
!   OUTPUT: xc potential for given spin orientation.
!   Reference: Von Barth, Hedin, J.Phys.C, 5, 1629, (1972). eq.6.2
!   xmag is twice larger than 'x' in their paper
!   effect of tau was also found to be small. thus tau is not used

!     parameter (asm = 2.0**(-1.0/3.0) )
!     parameter (gamma = 4.0/3.0*asm/(1-asm) )
! APS parameter (gamma = 5.129762496709890 ) changed
      parameter (gamma = 5.129762802484097 )

      vxc = 0.0
      if (rs.gt.1000) goto 999
      epc = -0.0504 * flarge(rs/30)
      efc = -0.0254 * flarge(rs/75)
      xmup = -0.0504*log(1.0+30.0/rs)
!     xmuf = -0.0254*log(1.0+75.0/rs)
      vu = gamma*(efc - epc)
!     tau = xmuf-xmup-(efc-epc)*4.0/3.0
     
      alg = -1.22177412/rs + vu
      blg = xmup - vu
      vxc = alg*xmag**(1.0/3.0) + blg
!     vxc = alg*xmag**(1.0/3.0) + blg +tau*fsmall(xmag/2.0)

 999  continue
!     transform to code units (Hartrees) from Rydbergs
      vxc = vxc / 2.d0

      return
      end

      double precision function flarge(x)
      implicit double precision (a-h, o-z)
        flarge = (1+x**3)*log(1+1/x) + x/2 - x**2 - 1.0/3.0
      return
      end

!     double precision function fsmall(x)
!     implicit double precision (a-h, o-z)
!     parameter (a = 2.0**(-1.0/3.0) )
!       fsmall = ( x**(4/3) + (1.0-x)**(4/3) - a ) / (1.0-a)
!     return
!     end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: dentfa.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function dentfa (dr,dz,ch)
!     analitical approximation of potential is created for electrons in
!     thomas-fermi model for atom or free ion. dr distance from nucleus
!     with charge dz  
!     ch=ionicity = number of electrons-dz-1
      implicit double precision (a-h,o-z)
 
      dentfa=0.0d00
      if ((dz+ch).lt.1.0d-04) return
      w=dr*(dz+ch)**(1./3.)
      w=sqrt(w/0.8853)
      t=w*(0.60112*w+1.81061)+1.
      w=w*(w*(w*(w*(0.04793*w+0.21465)+0.77112)+1.39515)+1.81061)+1
      dentfa=(dz+ch)*(1.0d00-(t/w)**2)/dr
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: nucdev.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine nucdev (av,dr,dv,dz,hx,nuc,np,ndor,dr1)
!        * construction of nuclear potential *
! av coefficients of the development at the origin of nuclear potential
! dr  tabulation points
! dv  nuclear potential 
! dz  nuclear charge 
! hx  exponential step
! nuc index of the nuclear radius
! np  number of tabulation points
! ndor number of the coefficients for development at the origin
! the declared below arguments are saved, dr1 is the first
 
      implicit double precision (a-h,o-z)
      dimension av(10),dr(251),dv(251),at(251)

!    specify atomic mass and thickness of nuclear shell
! a atomic mass (negative or null for the point charge)
! epai parameter of the fermi density distribution
! (negative or null for uniform distribution), which is
!       cte / (1. + exp((r-rn)/epai) )
! with nuclear radius rn= 2.2677e-05 * (a**(1/3))

! calculate radial mesh
      a = 0.0
      epai = 0.0

      if (a.le.1.0d-01) then
         nuc=1
      else
         a=dz*(a**(1./3.))*2.2677d-05
         b=a/ exp(hx*(nuc-1))
         if (b.le.dr1) then
            dr1=b
         else
            b=log(a/dr1)/hx
            nuc=3+2*int(b/2.0)
            if (nuc.ge.np) call par_stop('dr1 too small')
!           index of atomic radius larger than dimension of dr
            dr1=a*exp(-(nuc-1)*hx)
         endif
      endif

      dr(1)=dr1/dz
      do 181 l=2,np
 181  dr(l)=dr(1)* exp(hx*(l-1))

      if (ndor.lt.5) then
!       * it should be at least 5 development coefficients
         call par_stop                                                  &
     &     ('stopped in programm nucdev, ndor should be > 4.')
!        stop
      endif
!  calculate nuclear potential on calculated radial mesh
      do 11 i=1,ndor
 11      av(i)=0.0d00
      if (epai.le.0.0) then
         do 15 i=1,np
 15         dv(i)=-dz/dr(i)
         if (nuc.le.1) then
            av(1)=-dz
         else
            av(2)=-3.0d00*dz/(dr(nuc)+dr(nuc))
            av(4)=-av(2)/(3.0d00*dr(nuc)*dr(nuc))
            l=nuc-1
            do 25 i=1,l
 25            dv(i)=av(2)+av(4)*dr(i)*dr(i)
         endif
      else
         b= exp(-dr(nuc)/epai)
         b=1.0d00/(1.0d00+b)
         av(4)=b
         av(5)=epai*b*(b-1.0d00)
         if (ndor.le.5) go to 45
         at(1)=1.0d00
         at(2)=1.0d00
         nf=1
         do 41 i=6,ndor
            n=i-4
            nf=n*nf
            dv(1)=n*at(1)
            n1=n+1
            dv(n1)=1.0d00
            do 35 j=2,n
 35         dv(j)=(n-j+2)*at(j-1)+(n-j+1)*at(j)
            do 37 j=1,n1
               m=n+1-j
               l=1
               if (mod(j,2).eq.0) l=-l
               av(i)=av(i)+l*dv(j)*(b**m)
 37            at(j)=dv(j)
 41         av(i)=b*av(i)*(epai**n)/nf
 45      do 47 i=1,np
            b=1.0d00+ exp((dr(i)-dr(nuc))/epai)
            if ((b*av(4)).gt.1.0d+15) go to 51
            dv(i)=dr(i)*dr(i)*dr(i)/b
 47         l=i
 51      if (l.ge.(np-1)) l=np-2
         k=l+1
         do 55 i=k,np
 55         dv(i)=0.0d00
         at(1)=0.0d00
         at(2)=0.0d00
         k=2
         do 61 i=4,ndor
            k=k+1
            do 58 j=1,2
 58         at(j)=at(j)+av(i)*(dr(j)**k)/k
            av(i)=av(i)/(k*(k-1))
 61         av(2)=av(2)+av(i)*(dr(1)**k)
         a=hx/2.4d+01
         b=a*1.3d+01
         k=l+1
         do 71 i=3,k
 71      at(i)=at(i-1)+b*(dv(i-1)+dv(i))-a*(dv(i-2)+dv(i+1))
         dv(l)=at(l)
         do 75 i=k,np
 75      dv(i)=dv(l)
         e= exp(hx)
         c=1.0d00/(e*e)
         i=l-1
 83      dv(i)=dv(i+1)/e+b*(at(i+1)/e+at(i))-a*(at(i+2)*c+at(i-1)*e)
         i=i-1
         if (i-1) 85,85,83
 85      dv(1)=dv(3)*c+hx*(at(1)+4.0d00*at(2)/e+at(3)*c)/3.0d00
         av(2)=(av(2)+dv(1))/dr(1)
         a=-dz/dv(l)
         do 95 i=4,ndor
 95      av(i)=-a*av(i)
         av(2)=a*av(2)
         do 97 i=1,np
 97      dv(i)=a*dv(i)/dr(i)
      endif

      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: dist.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function dist (r0, r1)
!     find distance between cartesian points r0 and r1
      implicit double precision (a-h, o-z)
      dimension r0(3), r1(3)
      dist = 0
      do 10  i = 1, 3
         dist = dist + (r0(i) - r1(i))**2
   10 continue
      dist = sqrt (dist)
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: frnrm.f90,v $:
! $Revision: 1.7 $
! $Author: hebhop $
! $Date: 2012/11/29 23:20:18 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine frnrm (rho, iz, rnrm)

        use DimsMod
      implicit double precision (a-h, o-z)

      !KJ dimension rho(nrptx)
      dimension rho(251) !KJ 11-2009: frnrm only called from coulom.f90 for 'rho' arguments of size 251 whereas
      ! nrptx is currently set to 1251 in m_dimsmod.f90 ...
      dimension xpc(251), ri(251)
!#mn
      external rr
      
!     finds norman radius

!     Need overlapped densities.  We'll get them in the form
!     4*pi*density = rho.  Also need z of atom

!     Then integrate out to the point where the integral of
!     4*pi*density*r**2 is equal to iz
      sum= (9*rho(1)*rr(1)**3+28*rho(2)*rr(2)**3+23*rho(3)*rr(3)**3)/480
!     add initial point (r=0) correction (see subroutine somm2)
      dpas = 0.05
      d1 = 3.0
      dd=exp(dpas)-1.0
      db=d1*(d1+1.0)*dd*exp((d1-1.0)*dpas)
      db=rr(1)/db
      dd=rr(1)*(1.0+1.0/(dd*(d1+1.0)))/d1
      sum = sum + dd*rho(1)*rr(1)**2 - db*rho(2)*rr(2)**2

      fl = rho(4) *rr(4)**3
      fr = rho(5) *rr(5)**3
      frr = rho(6) *rr(6)**3
      sum = sum + (25*fl + 12 *fr -frr)/480
      do 10  i = 7, nrptx
         fll = fl
         fl = fr
         fr = frr
		 if (i.le.251) then  !KJ to avoid array bounds being overstepped ...  3-2012
            frr = rho(i) * rr(i)**3
		 else
		    frr=0.d0
		 endif
         sumsav = sum
         sum = sum + (13*(fr+fl) -fll -frr)/480
         if (sum .ge. iz)  then
            inrm = i-2
            x= (iz-sumsav)/(sum-sumsav)
            goto 20
         endif
   10 continue
      call wlog(' FRNRM Could not integrate enough charge to reach required z.')
      call par_stop('FRNRM-1')
   20 continue
      rnrm = rr(inrm)*(1 + x*0.05)
     
!     add next order correction ALA 3/97
        dx05 = 0.05
        x0 = 8.8
        jnrm =  (log(rnrm) + x0) / dx05  +  2
        i0=jnrm+1
        xirf = 2
        do 710 ir = 1, jnrm+2
           ri(ir) = rr(ir)
           xpc(ir) = rho(ir)*ri(ir)**2
  710   continue

        call somm2 (ri, xpc, dx05, xirf, rnrm,0,i0)
!       dq is how many new electrons are within norman sphere
        dn1 = xirf-iz
        x2 = x - dn1/((1-x)*xpc(inrm) + x*xpc(inrm+1))
        if (abs(x2-x).gt.0.0001) then
          xirf = 2
          rnrm = rr(inrm)*(1 + x2*0.05)
          call somm2 (ri, xpc, dx05, xirf, rnrm,0,i0)
          dn2 = xirf-iz
!         Newton-Raphson methof to find zeroes
          x = x2 - dn2 * (x2-x)/(dn2-dn1)
        endif
        rnrm = rr(inrm)*(1 + x*0.05)

      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: sumax.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! SUBROUTINE SUMAX (RN, ANN, AA2, AASUM)
! This is a version of the subroutine sumax found on page 110 of
! Louck's book.  It performs eq 3.22, using simpson's rule and
! taking advantage of the logarithmic grid so that sum f(r)*dr becomes
! sum over f(r)*r*(0.05).  Linear interpolation is used at the end
! caps.  This version does not sum over 14 shells of identical
! atoms, instead it averages the contribution of one or more atoms
! of type 2 at the location of atom 1.  Louck's description (except
! for his integration algorithm) is very clear.
!
! input:  
!         rn        distance from atom 1 to atom 2 in au
!         ann       number of type 2 atoms to add to atom 1, can
!                   be fractional
!         aa2(i)    potential or density at atom 2
! output: aasum(i)  spherically summed contribution added into this
!                   array so that sumax can be called repeatedly
!                   and the overlapped values summed into aasum
!
! Note that this routine requires that all position data be on a
! grid  rr(j) = exp (-8.8d0 + (j-1)*0.05d0), which is the grid
! used by Louck, and also used by ATOM if nuclear options not used.
!
! Coded by Steven Zabinsky, December 1989
! Modified for FEFF cluster code, August 1990, siz
! Bug fixed, May 1991, SIZ
! Another bug fixed, Mar 1992, SIZ
!
! T.L.Louck, "Augmented Plane Wave Method", W.A.Benjamin, Inc., 1967

      subroutine sumax (rn, ann, aa2, aasum)
      implicit double precision (a-h, o-z)
      parameter (nptx=250)
      dimension aa2(nptx), aasum(nptx)
      dimension stor(nptx)
!#mn
       external ii, xx

!     jjchi     index beyond which aa2 is zero
!     jtop      index just below distance to neighbor
!               aasum is calculated only up to index jtop

!     Wigner-Seitz radius is set to 15 in ATOM.
      rws = 15
      jjchi = ii(rws)
      jtop  = ii(rn)

      topx = xx(jjchi)

      do 120  i = 1, jtop
         x = xx(i)
         xint = 0.0
         et = exp(x)
         blx = log(rn-et)
         if (blx .ge. topx)  goto 119
         jbl = 2.0+20.0*(blx+8.8)
         if (jbl .lt. 1)  jbl=1
         if (jbl .ge. 2)  then
!           use linear interp to make end cap near center of neighbor
            xjbl = jbl
            xbl = 0.05 * (xjbl-1.0) - 8.8
            g = xbl-blx
            xint = xint+0.5*g*(aa2(jbl)*(2.0-20.0*g)*exp(2.0*xbl)       &
     &             +20.0*g*aa2(jbl-1)*exp(2.0*(xbl-0.05)))
         endif
         tlx = log(rn+et)
         if (tlx .ge. topx)  then
            jtl = jjchi
            go to 90
         endif
         jtl = 1.0 + 20.0*(tlx+8.8)
         if (jtl .lt. jbl)  then
!           handle peculiar special case at center of atom 1
            fzn = aa2(jtl)*exp(2.0*(xbl-0.05))
            fz3 = aa2(jbl)*exp(2.0*xbl)
            fz2 = fzn+20.0*(fz3-fzn)*(tlx-xbl+0.05)
            fz1 = fzn+20.0*(fz3-fzn)*(blx-xbl+0.05)
            xint = 0.5*(fz1+fz2)*(tlx-blx)
            go to 119
         endif
         xjtl = jtl
         xtl = 0.05*(xjtl-1.0)-8.8
         c = tlx-xtl
         xint = xint+0.5*c*(aa2(jtl)*(2.0-20.0*c)                       &
     &         *exp(2.0*xtl)+aa2(jtl+1)*20.0*c                          &
     &         *exp(2.0*(xtl+0.05)))

   90    if (jtl .gt. jbl)  then
  100       xint = xint+0.5*(aa2(jbl)*exp(2.0*xbl)+aa2(jbl+1)           &
     &             *exp(2.0*(xbl+0.05)))*0.05
            jbl = jbl+1
            if (jbl .lt. jtl) then
               xbl = xbl+0.05
               go to 100
            endif
         endif
  119    stor(i) = 0.5*xint*ann/(rn*et)
  120 continue

      do 190  i = 1, jtop
         aasum(i) = aasum(i) + stor(i)
  190 continue

      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: xx.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      double precision function xx (j)
      implicit double precision (a-h, o-z)
!     x grid point at index j, x = log(r), r=exp(x)
      parameter (delta = 0.050000000000000)
      parameter (c88   = 8.800000000000000)
!     xx = -8.8 + (j-1)*0.05
      xx = -c88 + (j-1)*delta
      return
      end

      double precision function rr(j)
      implicit double precision (a-h, o-z)
!     r grid point at index j
      rr = exp (xx(j))
      return
      end

      function ii(r)
      implicit double precision (a-h, o-z)
!     index of grid point immediately below postion r
      parameter (delta = 0.050000000000000)
      parameter (c88   = 8.800000000000000)
!     ii = (log(r) + 8.8) / 0.05 + 1
      ii = (log(r) + c88) / delta + 1
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: somm2.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine somm2 (dr,dp,dpas,da,rnrm,m,np)
! Modified to use complex p and q.  SIZ 4/91
! Modified to use double simpson integration ALA 3/97
! integration by the method of simpson of dp*dr from 
! 0 to r=rnrm  with proper end corrections
! dpas=exponential step;
! for r in the neighborhood of zero dp=cte*r**da
! **********************************************************************
      implicit double precision (a-h,o-z)
      dimension dr(*)
      dimension  dp(*)

      mm = m + 1
      d1=dble(da)+mm
      da=0.0
      db=0.0
!      np-2=inrm -point of grid just below rnrm
      a1=log(rnrm/dr(np-2)) / dpas
      a2=a1**2/8.0d0
      a3=a1**3/12.0d0
      do 70 i=1,np
         if (i.eq.1) then
            dc=dp(i) *dr(i)**mm*9.0d0/24.0d0
         elseif (i.eq.2) then
            dc=dp(i) *dr(i)**mm*28.0d0/24.0d0
         elseif (i.eq.3) then
            dc=dp(i)*dr(i)**mm*23.0d0/24.0d0
         elseif (i.eq.np-3) then
            dc=dp(i)*dr(i)**mm*(25.0d0/24.0d0-a2+a3)
         elseif (i.eq.np-2) then
            dc=dp(i)*dr(i)**mm*(0.5d0+a1-3*a2-a3)
         elseif (i.eq.np-1) then
            dc=dp(i)*dr(i)**mm*(-1.0d0/24.0d0+5*a2-a3)
         elseif (i.eq.np) then
            dc=dp(i)*dr(i)**mm*(-a2+a3)
         else
!           like trapesoidal rule
            dc=dp(i)*dr(i)**mm
         endif
         da=da+dc
   70 continue
      da=dpas*da

!     add initial point (r=0) correction
      dd=exp(dpas)-1.0
      db=d1*(d1+1.0)*dd*exp((d1-1.0)*dpas)
      db=dr(1)*(dr(2)**m)/db
      dd=(dr(1)**mm)*(1.0+1.0/(dd*(d1+1.0)))/d1
      da=da+dd*dp(1)-db*dp(2)
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: str.f90,v $:
! $Revision: 1.4 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! FUNCTION ISTRLN (STRING)  Returns index of last non-blank
!                           character.  Returns zero if string is
!                           null or all blank.

      FUNCTION ISTRLN (STRING)
      CHARACTER*(*)  STRING
      CHARACTER BLANK, TAB
      PARAMETER (BLANK = ' ', TAB = '	')
!     there is a tab character here  ^

!  -- If null string or blank string, return length zero.
      ISTRLN = 0
      IF (STRING (1:1) .EQ. CHAR(0))  RETURN
      IF (STRING .EQ. ' ')  RETURN

!  -- Find rightmost non-blank character.
      ILEN = LEN (STRING)
      DO 20  I = ILEN, 1, -1
         IF (STRING(I:I).NE.BLANK .AND. STRING(I:I).NE.TAB)  GOTO 30
   20 CONTINUE
   30 ISTRLN = I

      RETURN
      END
! SUBROUTINE TRIML (STRING)  Removes leading blanks.

      SUBROUTINE TRIML (STRING)
      CHARACTER*(*)  STRING
      CHARACTER*512  TMP !KJ 7-09 increased from 200 to 512.  Would prefer a more dynamic solution FIX LATER.  Important for header feff.bin
      CHARACTER BLANK, TAB
      PARAMETER (BLANK = ' ', TAB = '	')
!     there is a tab character here  ^

      JLEN = ISTRLN (STRING)

!  -- All blank and null strings are special cases.
      IF (JLEN .EQ. 0)  RETURN

!  -- FInd first non-blank char
      DO 10  I = 1, JLEN
         IF (STRING(I:I).NE.BLANK .AND. STRING(I:I).NE.TAB)  GOTO 20
   10 CONTINUE
   20 CONTINUE

!  -- If I is greater than JLEN, no non-blanks were found.
      IF (I .GT. JLEN)  RETURN

!  -- Remove the leading blanks.
      TMP = STRING (I:)
      STRING = TMP
      RETURN
      END
! SUBROUTINE UPPER (STRING)  Changes a-z to upper case.

      SUBROUTINE UPPER (STRING)
      CHARACTER*(*)  STRING

      JLEN = ISTRLN (STRING)

      DO 10  I = 1, JLEN
         IC = ICHAR (STRING (I:I))
         IF ((IC .LT. 97)  .OR.  (IC .GT. 122))  GOTO 10
         STRING (I:I) = CHAR (IC - 32)
   10 CONTINUE

      RETURN
      END
! SUBROUTINE LOWER (STRING)  Changes A-Z to lower case.

      SUBROUTINE LOWER (STRING)
      CHARACTER*(*)  STRING

      JLEN = ISTRLN (STRING)

      DO 10  I = 1, JLEN
         IC = ICHAR (STRING (I:I))
         IF ((IC .LT. 65) .OR.  (IC .GT. 90))  GOTO 10
         STRING (I:I) = CHAR (IC + 32)
   10 CONTINUE

      RETURN
      END
!***********************************************************************
!
      SUBROUTINE BWORDS (S, NWORDS, WORDS)
!
!     Breaks string into words.  Words are seperated by one or more
!     blanks or tabs, or a comma and zero or more blanks.
!
!     ARGS        I/O      DESCRIPTION
!     ----        ---      -----------
!     S            I       CHAR*(*)  String to be broken up
!     NWORDS      I/O      Input:  Maximum number of words to get
!                          Output: Number of words found
!     WORDS(NWORDS) O      CHAR*(*) WORDS(NWORDS)
!                          Contains words found.  WORDS(J), where J is
!                          greater then NWORDS found, are undefined on
!                          output.
!
!      Written by:  Steven Zabinsky, September 1984
!      Tab char added July 1994.
!
!**************************  Deo Soli Gloria  **************************

!  -- No floating point numbers in this routine.
      IMPLICIT INTEGER (A-Z)

      CHARACTER*(*) S, WORDS(NWORDS)

      CHARACTER BLANK, COMMA, TAB
      PARAMETER (BLANK = ' ', COMMA = ',', TAB = '	')
!     there is a tab character here               ^.

!  -- BETW    .TRUE. if between words
!     COMFND  .TRUE. if between words and a comma has already been found
      LOGICAL BETW, COMFND

!  -- Maximum number of words allowed
      WORDSX = NWORDS

!  -- SLEN is last non-blank character in string
      SLEN = ISTRLN (S)
!  -- All blank string is special case
      IF (SLEN .EQ. 0)  THEN
         NWORDS = 0
         RETURN
      ENDIF

!  -- BEGC is beginning character of a word
      BEGC = 1
      NWORDS = 0

      BETW   = .TRUE.
      COMFND = .TRUE.

      DO 10  I = 1, SLEN
         IF (S(I:I) .EQ. BLANK .OR. S(I:I) .EQ. TAB)  THEN
            IF (.NOT. BETW)  THEN
               NWORDS = NWORDS + 1
               WORDS (NWORDS) = S (BEGC : I-1)
               BETW = .TRUE.
               COMFND = .FALSE.
            ENDIF
         ELSEIF (S(I:I) .EQ. COMMA)  THEN
            IF (.NOT. BETW)  THEN
               NWORDS = NWORDS + 1
               WORDS (NWORDS) = S(BEGC : I-1)
               BETW = .TRUE.
            ELSEIF (COMFND)  THEN
               NWORDS = NWORDS + 1
               WORDS (NWORDS) = BLANK
            ENDIF
            COMFND = .TRUE.
         ELSE
            IF (BETW)  THEN
               BETW = .FALSE.
               BEGC = I
            ENDIF
         ENDIF

         IF (NWORDS .GE. WORDSX)  RETURN

   10 CONTINUE

      IF (.NOT. BETW  .AND.  NWORDS .LT. WORDSX)  THEN
         NWORDS = NWORDS + 1
         WORDS (NWORDS) = S (BEGC :SLEN)
      ENDIF

      RETURN
      END

!***********************************************************************
!
      SUBROUTINE BWORDS2 (S, NWORDS, WORDS)
!
!     Breaks string into words.  Words are seperated by one or more
!     blanks or tabs.
!
!     ARGS        I/O      DESCRIPTION
!     ----        ---      -----------
!     S            I       CHAR*(*)  String to be broken up
!     NWORDS      I/O      Input:  Maximum number of words to get
!                          Output: Number of words found
!     WORDS(NWORDS) O      CHAR*(*) WORDS(NWORDS)
!                          Contains words found.  WORDS(J), where J is
!                          greater than NWORDS found, are undefined on
!                          output.
!
!      Written by:  Steven Zabinsky, September 1984
!      Tab char added July 1994.
!
!**************************  Deo Soli Gloria  **************************

!  -- No floating point numbers in this routine.
      IMPLICIT INTEGER (A-Z)

      CHARACTER*(*) S, WORDS(NWORDS)

      CHARACTER BLANK, COMMA, TAB
      PARAMETER (BLANK = ' ', TAB = '	')
!     there is a tab character here               ^.

!  -- BETW    .TRUE. if between words
!     COMFND  .TRUE. if between words and a comma has already been found
      LOGICAL BETW, COMFND

!  -- Maximum number of words allowed
      WORDSX = NWORDS

!  -- SLEN is last non-blank character in string
      SLEN = ISTRLN (S)

!  -- All blank string is special case
      IF (SLEN .EQ. 0)  THEN
         NWORDS = 0
         RETURN
      ENDIF

!  -- BEGC is beginning character of a word
      BEGC = 1
      NWORDS = 0

      BETW   = .TRUE.
      COMFND = .TRUE.

      DO 10  I = 1, SLEN
         IF (S(I:I) .EQ. BLANK .OR. S(I:I) .EQ. TAB)  THEN
            IF (.NOT. BETW)  THEN
               NWORDS = NWORDS + 1
               WORDS (NWORDS) = S (BEGC : I-1)
               BETW = .TRUE.
               COMFND = .FALSE.
            ENDIF
         ELSE
            IF (BETW)  THEN
               BETW = .FALSE.
               BEGC = I
            ENDIF
         ENDIF

         IF (NWORDS .GE. WORDSX)  RETURN

   10 CONTINUE

      IF (.NOT. BETW  .AND.  NWORDS .LT. WORDSX)  THEN
         NWORDS = NWORDS + 1
         WORDS (NWORDS) = S (BEGC :SLEN)
      ENDIF
 
      RETURN
      END


      SUBROUTINE UNTAB (STRING)
! REPLACE TABS WITH BLANKS :    TAB IS ASCII DEPENDENT
      INTEGER        ITAB , I, ILEN, ISTRLN
      PARAMETER      (ITAB = 9)
      CHARACTER*(*)  STRING, TAB*1
      EXTERNAL ISTRLN
      TAB  = CHAR(ITAB)
      ILEN = MAX(1, ISTRLN(STRING))
 10   CONTINUE 
        I = INDEX(STRING(:ILEN), TAB ) 
        IF (I .NE. 0) THEN
            STRING(I:I) = ' '
            GO TO 10
        END IF
      RETURN
! END SUBROUTINE UNTAB
      END

      logical function iscomm (line)
!     returns true if line is a comment or blank line, false otherwise
!#mn{ rewritten to allow ";*%#" as comment characters
       character*(*) line
       iscomm = ((line.eq.' ').or.(index(';*%#',line(1:1)).ne.0))
!#mn}
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: rdline.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
       subroutine rdline(jinit, line)
!
!  return next "real" command line from input file(s)
!    -  allows use of "include file" or "load file" for reading
!       from other files, and manages the set of include files
!    -  checks for and ignores comment lines and blank lines.
!    -  opens and closes all input files, including initial file.
!
!   jinit  initialization/clean-up flag     [in]
!   line   next command line to parse   [in/out]
!
! notes:
!   1. to initialize, set jinit<0 and line= main_input_file_name.inp
!      if line=' ', routine will stop program.
!   2. returned line will be sent through triml and untab.
!   3. uses routine iscomm to test if line is a comment line.
!   4. special returned values:
!        'read_line_end'  = done reading all inputs
!        'read_line_error'= an error has occurred. the calling routine
!                        should probably stop
!   5. to clean up all open files, call with jinit=0
!
! matt newville march 1999
       implicit none
       integer mwords, ilen, i, jinit, mfil, nfil
       parameter (mwords=2, mfil=10)
       character*(*) line, stat*8
       character*90  files(mfil), errmsg, words(mwords)
       parameter (stat='old')
       integer   iunit(mfil), istrln, nwords, ierr, iexist
       logical   iscomm, open
       external  istrln, iscomm
       save      files, iunit, nfil
!
! jinit=-1: initialize
       if (jinit.eq.-1) then
          jinit  = 1
          do 10 i = 1, mfil
             iunit(i) = 0
             files(i) = ' '
 10       continue
          nfil     = 1
          files(1) = line
          call triml(files(1))
          call openfl(iunit(1), files(1), stat, iexist, ierr)
          if (iexist .lt. 0) go to 2600
          if (ierr   .lt. 0) go to 2800
!
!  jinit=0:  close all opened files (except unit 5!)
       elseif (jinit.eq.0) then
          jinit = 1
          do 25, i = 1, mfil
             if ((iunit(i).gt.0).and.(iunit(i).ne.5)) then 
                inquire(unit = iunit(i), opened=open)
                if (open) then
                   close(iunit(i))
                   iunit(i) = 0
                   files(i) = ' '
                endif 
             endif 
 25       continue 
          return
       end if
!  read next line from current input file
 100   continue
!c       print*, 'rdline 100: nfil , files(nfil), iunit = ',
!c     $      nfil,files(nfil)(:20), iunit(nfil)
       line   = ' '
       read(iunit(nfil),'(a)', err =1000, end = 500) line
!
!  check if command line is 'include filename'.
!  if so, open that file, and put it in the files stack
       call untab(line)
       call triml(line)
       if (iscomm(line)) go to 100
       nwords = mwords
       words(2) = ' '
       call bwords(line, nwords, words)
       call lower(words(1))
       if (((words(1) .eq. 'include').or.(words(1) .eq. 'load'))        &
     &      .and. (nwords .gt. 1)) then
          nfil = nfil + 1
          if (nfil .gt. mfil) go to 2000
          call getfln(words(2), files(nfil), ierr)
          if (ierr .ne. 0) go to 2400
!  test for recursion:
          do 400 i = 1, nfil - 1
             if (files(nfil) .eq. files(i)) go to 3000
 400      continue
          call openfl(iunit(nfil), files(nfil), stat, iexist, ierr)
          if (iexist .lt. 0) go to 2600
          if (ierr   .lt. 0) go to 2800
          go to 100
       end if
       return
!
!  end-of-file for command line file: drop nfil by 1,
!  return to get another command line
 500   continue
       inquire(unit = iunit(nfil), opened=open)
       if (open .and. (iunit(nfil) .ne. 5)) then
          close(iunit(nfil))
       end if
       iunit(nfil) = 0
       files(nfil) = ' '
       nfil = nfil - 1
       if (nfil.gt.0) go to 100
       line = 'read_line_end'
       return
!   error messages
 1000  continue
       call wlog(' # read error: general error')
       go to 4500
 2000  continue
       call wlog(' # read error: too many nested "include"s')
       write(errmsg, '(1x,a,i3)') ' # current limit is ', mfil
       ilen  = istrln(errmsg)
       call wlog(errmsg(1:ilen))
       go to 4500
 2400  continue
       call wlog(' # read error: cannot determine file name')
       go to 4500
 2600  continue
       call wlog(' # read error: cannot find file')
       go to 4500
 2800  continue
       call wlog(' # read error: cannot open file')
       go to 4500
 3000  continue
       call wlog(' # read error: recursive use of file')
       go to 4500
 4500  continue
       errmsg = ' # >> file name = '//files(nfil)
       ilen   = istrln(errmsg)
       call wlog(errmsg(1:ilen) )
       line = 'read_line_error'
       return
! end subroutine read_line
       end
       subroutine getfln(strin, filnam, ierr)
!  strip off the matched delimeters from string, as if getting
!  a filename from "filename", etc.
       integer idel, iend, istrln, ierr
       character*(*) strin, filnam, tmp*144, ope*8, clo*8
       data ope, clo /'"{(<''[',  '"})>'']'/
!
       ierr  = 0
       tmp   = strin
       call triml(tmp)
       ilen  = istrln(tmp)
       idel  = index(ope,tmp(1:1))
       if (idel.ne.0) then
          iend = index(tmp(2:), clo(idel:idel) )
          if (iend.le.0) then
             ierr = -1
             iend = ilen 
          end if
          filnam = tmp(2:iend)
       else
          iend = index(tmp,' ') - 1
          if (iend.le.0) iend  = istrln(tmp) 
          filnam = tmp(1:iend)
       end if
       return
! end  subroutine getfln
       end
       subroutine openfl(iunit, file, status, iexist, ierr)
!  
!  open a file, 
!   if unit <= 0, the first unused unit number greater than 7 will 
!                be assigned.
!   if status = 'old', the existence of the file is checked.
!   if the file does not exist iexist is set to -1
!   if the file does exist, iexist = iunit.
!   if any errors are encountered, ierr is set to -1.
!
!   note: iunit, iexist, and ierr may be overwritten by this routine
       character*(*)  file, status, stat*10
       integer        iunit, iexist, ierr
       logical        opend, exist
       external nxtunt
!
! make sure there is a unit number and file name
       ierr   = -3
       iexist =  -1
       if (file .eq. ' ') return
       iexist = 0
       iunit  = nxtunt(iunit)
!
! if status = 'old', check that the file name exists
       ierr = -2
       stat =  status                          
       call lower(stat)
       if (stat.eq.'old') then
          iexist = -1
          inquire(file=file, exist = exist)
          if (.not.exist) return
          iexist = iunit
       end if
! 
! open the file
       ierr = -1
       open(unit=iunit, file=file, status=status, err=100)
       ierr = 0
 100   continue
       return
! end  subroutine openfl
       end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: nxtunt.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!====================================================================
      integer function nxtunt(iunit)

!  this function returns the value of the next unopened unit number
!  equal to or larger than iunit.  it will return neither unit numbers
!  0, 5, or 6 nor a negative unit number
! $Id: nxtunt.f90,v 1.2 2010/02/23 23:52:06 hebhop Exp $
! $Log: nxtunt.f90,v $
! Revision 1.2  2010/02/23 23:52:06  hebhop
! Added header to all .f90 files to show version info, i.e. date, author, revision number of last modification.
!
! Revision 1.1  2007/12/08 08:06:16  hebhop
! Lots of changes.
!
! 1. Changed all filenames to *.f90
! 2. Changed Makefile to compile all files directly instead of making recursively.
! 3. Added DEP directory and dependency files.
! 4. Added Utilities to make dependency files. Note: these probably aren't robust and should be rewritten.
! 5. Added I/O modules and Error modules.
! 6. Changed a few routines to use I/O modules.
! 7. Split atomic calculation from SCF potentials calculation.
!    Atomic calculations now calculate things for all edges.
! 8. Added hack (soon to be option) to read muffin tin potentials from external file.
!
! Revision 1.1.1.1  2007/10/23 22:07:50  ytakimot
!
! FEFF9 Project
!
! Revision 1.1.1.1  2007/06/04 23:16:47  hebhop
! Initializing feff86. All references to so2conv have changed to sfconv
! Josh Kas
!
! Revision 1.1.1.1  2006/01/12 06:37:42  hebhop
! New version of feff. feff8.5 (Extension of feff8.4)
! Includes:
! 	1) All feff8.4 capabilities.
! 	2) Screened core hole (calculation of W).
! 	3) Multiple pole self energy calculation.
! 	4) Convolution with spectral function.
! New cards and options:
! 	1) NOHOLE 2      (screened hole)
! 	2) PLASMON ipl   (multiple pole self energy)
! 	3) SO2CONV       (convolve output with spectral function)
! 	4) SELF          (print on shell self energy as calculated by Luke)
! 	5) SFSE k0        (print off shell self energy Sigma(k0,e) )
!
! Revision 1.1.1.1  2000/02/11 02:23:58  alex
! Initialize feff82
!
! Revision 1.10  1999/04/02 21:32:47  newville
! cleaned up nxtunt (matt)
!
! Revision 1.9  1999/02/11 20:08:08  alex
! x39 version: dim.h + misc. small changes
!
! Revision 1.8  1998/12/29 23:59:07  alex
! feff8x35 version
!
! Revision 1.7  1998/11/19 03:23:11  alex
! feff8x32 version
!
! Revision 1.6  1998/10/26 14:11:16  ravel
! no comments beyond column 71
!
! Revision 1.5  1998/10/18 21:47:51  alex
! feff8x30 version implements Broyden algorithm for self-consistency
!
! Revision 1.4  1998/02/24 18:31:37  ravel
! I should really be more careful.  This is the last commitment done
!      cright.
!
! Revision 1.1.1.1  1997/04/27 20:18:03  ravel
! Initial import of xanes sources, version 0.37
!
! Revision 1.1  1996/06/23 16:05:02  bruce
! Initial revision
!

       integer iunit
       logical open

       nxtunt = max(1, iunit) - 1
 10    continue
       nxtunt = nxtunt + 1
       if ((nxtunt.eq.5).or.(nxtunt.eq.6)) nxtunt = 7
       inquire (unit=nxtunt, opened=open)
       if (open) go to 10
       return
!  end integer function nxtunt
       end

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

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: padlib.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! PAD library:   Packed Ascii Data 
!   these routines contain code for handling packed-ascii-data  
!   (pad) arrays for writing printable character strings that 
!   represent real or complex scalars and arrays to a file.
!
! routines included in padlib are (dp==double precision):
!   wrpadd     write a dp array as pad character strings
!   wrpadx     write a dp complex array as pad character strings
!   rdpadr     read a pad character array as a real array
!   rdpadd     read a pad character array as a dp  array
!   rdpadc     read a pad character array as a complex array
!   rdpadx     read a pad character array as a dp complex array
!   pad        internal routine to convert dp number to pad string
!   unpad      internal routine to pad string to dp number
!
! routines not included, but required by padlib:
!     triml, istrln, wlog
!
!//////////////////////////////////////////////////////////////////////
! Copyright (c) 1997--2001 Matthew Newville, The University of Chicago
! Copyright (c) 1992--1996 Matthew Newville, University of Washington
!
! Permission to use and redistribute the source code or binary forms of
! this software and its documentation, with or without modification is
! hereby granted provided that the above notice of copyright, these
! terms of use, and the disclaimer of warranty below appear in the
! source code and documentation, and that none of the names of The
! University of Chicago, The University of Washington, or the authors
! appear in advertising or endorsement of works derived from this
! software without specific prior written permission from all parties.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
! EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
! MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
! IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
! CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
! TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
! SOFTWARE OR THE USE OR OTHER DEALINGS IN THIS SOFTWARE.
!//////////////////////////////////////////////////////////////////////
! License is applicable for routines below, until otherwise specified.
!
       subroutine wrpadd(iout,npack,array,npts)
!
! write a dp array to a file in packed-ascii-data format
!
! inputs:  [ no outputs / no side effects ]
!   iout   unit to write to (assumed open)
!   npack  number of characters to use (determines precision)
!   array  real array 
!   npts   number of array elements to read
! notes:
!   real number converted to packed-ascii-data string using pad
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       integer    iout, npack, npts, mxl, js, i
       character  str*128
       double precision array(*), xr
       js  = 0
       str = ' '
       mxl = maxlen - npack + 1
       do 20 i = 1, npts
          js = js+npack
          xr = array(i)
          call padx(xr, npack, str(js-npack+1:js))
          if ((js.ge.mxl).or.(i.eq.npts)) then
             write(iout,100) cpadr, str(1:js)
             js = 0
          end if
 20    continue
       return
 100   format(a1,a)
       end
! --padlib--
       subroutine wrpadx(iout,npack,array,npts)
! write complex*16 array as pad string
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       integer    iout, npack, npts, mxl, js, i
       complex*16 array(*)
       character  str*128
       double precision xr, xi
       js = 0
       str  = ' '
       mxl  = maxlen - 2 * npack + 1
       do 20 i = 1, npts
          js = js  + 2 * npack
          xr = dble(array(i))
          xi = dimag(array(i))
          call padx(xr, npack, str(js-2*npack+1:js-npack))
          call padx(xi, npack, str(js-npack+1:js))
          if ((js.ge.mxl).or.(i.eq.npts)) then
             write(iout,100) cpadc, str(1:js)
             js = 0
          end if
 20    continue
       return
 100   format(a1,a)
       end
! --padlib--
       subroutine wrpadr(iout,npack,array,npts)
!
! write a real array to a file in packed-ascii-data format
!
! inputs:  [ no outputs / no side effects ]
!   iout   unit to write to (assumed open)
!   npack  number of characters to use (determines precision)
!   array  real array 
!   npts   number of array elements to read
! notes:
!   real number converted to packed-ascii-data string using pad
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       integer    iout, npack, npts, mxl, js, i
       character  str*128
       real    array(*)
       double precision xr
       js  = 0
       str = ' '
       mxl = maxlen - npack + 1
       do 20 i = 1, npts
          js = js+npack
          xr = dble(array(i))
          call padx(xr, npack, str(js-npack+1:js))
          if ((js.ge.mxl).or.(i.eq.npts)) then
             write(iout,100) cpadr, str(1:js)
             js = 0
          end if
 20    continue
       return
 100   format(a1,a)
       end
! --padlib--
       subroutine wrpadc(iout,npack,array,npts)
! write complex (*8) array as pad string
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       integer    iout, npack, npts, mxl, js, i
       complex    array(*)
       character  str*128
       double precision xr, xi
       js = 0
       str  = ' '
       mxl  = maxlen - 2 * npack + 1
       do 20 i = 1, npts
          js = js  + 2 * npack
          xr = dble(array(i))
          xi = aimag(array(i))
          call padx(xr, npack, str(js-2*npack+1:js-npack))
          call padx(xi, npack, str(js-npack+1:js))
          if ((js.ge.mxl).or.(i.eq.npts)) then
             write(iout,100) cpadc, str(1:js)
             js = 0
          end if
 20    continue
       return
 100   format(a1,a)
       end
! --padlib--
       subroutine rdpadd(iou,npack,array,npts)
! read dparray from packed-ascii-data file
! arguments:
!   iou    unit to read from (assumed open)                   (in)
!   npack  number of characters to use (determines precision) (in)
!   array  real array                                         (out)
!   npts   number of array elements to read / number read     (in/out)
! notes:
!   packed-ascii-data string converted to real array using  unpad
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       integer iou, npack, npts, ndline, i, istrln, ipts, iread
       double precision    array(*), unpad , tmp
       character  ctest, ccomp
       character  str*128
       external  unpad, istrln, iread
       ccomp = cpadr
       ipts = 0
 10    continue 
          i = iread(iou, str)
          if (i.lt.0) go to 50
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = i/npack
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts  = ipts + 1
             tmp   = unpad(str(1-npack+i*npack:i*npack),npack)
             array(ipts) = tmp
             if (ipts.ge.npts) go to 50
 30       continue 
          go to 10
 50    continue 
       return
 200   continue
       call wlog (' -- Read_PAD error:  bad data at line:')
       i = istrln(str)
       call wlog (str(:i))
       stop ' -- fatal error in reading PAD data file -- '
       end
! --padlib--
       subroutine rdpadr(iou,npack,array,npts)
! read real array from packed-ascii-data file
! arguments:
!   iou    unit to read from (assumed open)                   (in)
!   npack  number of characters to use (determines precision) (in)
!   array  real array                                         (out)
!   npts   number of array elements to read / number read     (in/out)
! notes:
!   packed-ascii-data string converted to real array using  unpad
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       integer iou, npack, npts, ndline, i, istrln, ipts, iread
       real    array(*)
       double precision unpad , tmp
       character  ctest, ccomp
       character  str*128
       external  unpad, istrln, iread
       ccomp = cpadr
       ipts = 0
 10    continue 
          i = iread(iou, str)
          if (i.lt.0) go to 50
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = i/npack
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts  = ipts + 1
             tmp   = unpad(str(1-npack+i*npack:i*npack),npack)
             array(ipts) = real(tmp)
             if (ipts.ge.npts) go to 50
 30       continue 
          go to 10
 50    continue 
       return
 200   continue
       call wlog (' -- Read_PAD error:  bad data at line:')
       i = istrln(str)
       call wlog (str(:i))
       stop ' -- fatal error in reading PAD data file -- '
       end
! --padlib--
       subroutine rdpadc(iou,npack,array,npts)
! read complex array from packed-ascii-data file
! arguments:
!   iou    unit to read from (assumed open)                  (in)
!   npack  number of characters to use (determines precision)(in)
!   array  complex array                                     (out)
!   npts   number of array elements to read / number read    (in/out)
! notes:
!   packed-ascii-data string converted to real array using  unpad
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       integer iou, npack,npts, ndline, i, istrln, ipts, np, iread
       double precision  unpad, tmpr, tmpi
       complex  array(*)
       character  ctest, ccomp
       character  str*128
       external  unpad, istrln, iread
       ccomp = cpadc
       ipts = 0
       np   = 2 * npack
 10    continue 
          i = iread(iou, str)
          if (i.lt.0) go to 50
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = i / np
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts = ipts + 1
             tmpr = unpad(str(1-np+i*np:-npack+i*np),npack)
             tmpi = unpad(str(1-npack+i*np:i*np),npack)
             array(ipts) = cmplx(tmpr, tmpi)
             if (ipts.ge.npts) go to 50
 30       continue 
          go to 10
 50    continue 
       return
 200   continue
       call wlog (' -- Read_PAD error:  bad data at line:')
       i = istrln(str)
       call wlog (str(:i))
       stop ' -- fatal error in reading PAD data file -- '
       end
       subroutine rdpadx(iou,npack,array,npts)
! read complex*16 array from packed-ascii-data file
! arguments:
!   iou    unit to read from (assumed open)                  (in)
!   npack  number of characters to use (determines precision)(in)
!   array  complex array                                     (out)
!   npts   number of array elements to read / number read    (in/out)
! notes:
!   packed-ascii-data string converted to real array using  unpad
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       integer iou, npack,npts, ndline, i, istrln, ipts, np, iread
       double precision  unpad, tmpr, tmpi
       complex*16  array(*)
       character  ctest, ccomp
       character  str*128
       external  unpad, istrln, iread
       ccomp = cpadc
       ipts = 0
       np   = 2 * npack
 10    continue 
          i = iread(iou, str)
          if (i.lt.0) go to 50
          call triml(str)
          ctest  = str(1:1)
          str    = str(2:)
          ndline = i / np
          if ((ctest.ne.ccomp).or.(ndline.le.0)) go to 200
          do 30 i = 1, ndline
             ipts = ipts + 1
             tmpr = unpad(str(1-np+i*np:-npack+i*np),npack)
             tmpi = unpad(str(1-npack+i*np:i*np),npack)
             array(ipts) = cmplx(tmpr, tmpi)
             if (ipts.ge.npts) go to 50
 30       continue 
          go to 10
 50    continue 
       return
 200   continue
       call wlog (' -- Read_PAD error:  bad data at line:')
       i = istrln(str)
       call wlog (str(:i))
       stop ' -- fatal error in reading PAD data file -- '
       end

! --padlib--
       subroutine padx(xreal,npack,str)
!  convert dp number *xreal* to packed-ascii-data string *str*
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       integer  iexp, itmp, isgn, i, npack, j
       double precision xreal, xwork, xsave,onem, tenth
       parameter (onem  =  0.99999999997d0)
       parameter (tenth =  0.099999999994d0)
       character str*(*)
!
       str      = ' '
       xsave    = min(huge, max(-huge, xreal))
       isgn     = 1
       if (xsave.le.0) isgn = 0
!
       xwork    = dabs( xsave )
       iexp     = 0
       if ((xwork.lt.huge).and.(xwork.gt.tiny))  then
          iexp  =   1 + int(log(xwork) / tenlog  )
       else if (xwork.ge.huge) then
          iexp  = ihuge
          xwork = one
       else if (xwork.le.tiny)  then
          xwork = zero
       end if
! force xwork between ~0.1 and ~1
! note: this causes a loss of precision, but 
! allows backward compatibility
       xwork    = xwork / (ten ** iexp)
 20    continue
       if (xwork.ge.one) then
          xwork = xwork * 0.100000000000000d0
          iexp  = iexp + 1
       else if (xwork.le.tenth) then
          xwork = xwork * ten
          iexp  = iexp - 1
       endif
       if (xwork.ge.one) go to 20

       itmp     = int ( ibas2 * xwork ) 
       str(1:1) = char(iexp  + ioff + ibas2 )
       str(2:2) = char( 2 * itmp + isgn + ioff)
       xwork    = xwork * ibas2 - itmp
       if (npack.gt.2) then
          do 100 i = 3, npack
             itmp     = int( base * xwork + 1.d-9)
             str(i:i) = char(itmp + ioff)
             xwork    = xwork * base - itmp
 100      continue
       end if
       if (xwork.ge.0.5d0) then
          i = itmp + ioff + 1
          if (i.le.126) then
             str(npack:npack)= char(i)
          else 
             j = ichar(str(npack-1:npack-1))
             if (j.lt.126) then
                str(npack-1:npack-1) = char(j+1)
                str(npack:npack)     = char(37)
             endif 
          endif
       endif
       return
       end
! --padlib--
       double precision function unpad(str,npack)
!
!  convert packed-ascii-data string *str* to dp number *unpad*
!!! EXPANDING INCLUDE statement: ././COMMON/padlib.h 
! padlib.h -*-fortran-*-
!  header of parameters for packed-ascii-data (pad) routines
       implicit none
       character cpadr, cpadi, cpadc
       integer   maxlen, ibase, ioff, ihuge, ibas2
       double precision  ten, tenlog, huge, tiny, one, zero, base
       parameter(cpadr = '!', cpadc = '$', cpadi = '%')
       parameter(ibase = 90, ioff = 37, ihuge = 38, maxlen = 82)
       parameter(ibas2 = ibase/2, zero=0d0, one=1.d0, ten = 10.d0)
       parameter(tenlog= 2.302585092994045684d0)
       parameter(huge = ten**ihuge, tiny = one/huge)
       parameter(base = ibase*one)
!
!!! END OF : ././COMMON/padlib.h 
       double precision sum
       integer   iexp, itmp, isgn, i, npack
       character str*(*)
       unpad = zero
       if (npack.le.2) return
       iexp  =     (ichar(str(1:1)) - ioff   ) - ibas2
       isgn  = mod (ichar(str(2:2)) - ioff, 2) * 2 - 1
       itmp  =     (ichar(str(2:2)) - ioff   ) / 2
       sum   = dble(itmp/(base*base))
!       do 100 i = 3, npack
!          sum = sum + dble(ichar(str(i:i)) - ioff) / base**i
! 100   continue
       do 100 i = npack, 3, -1
          sum = sum + dble(ichar(str(i:i)) - ioff) / base**i
 100   continue
       unpad = 2 * isgn * ibase * sum * (ten ** iexp)
!c       print*, sum, iexp,unpad
       return
       end
! --padlib--
! end of pad library
! ----------
       integer function iread(lun,string)
!
! generalized internal read:
!    read a string the next line of an opened file 
!    unit, returning the real length of string
! 
! inputs:   
!   lun     opened file unit number
! outputs:
!   string  string read from file
! returns:
!   iread   useful length of string, as found from 
!                  sending string to 'sclean' to 
!                  remove non-printable characters
!                   and then istrln  
!           or
!              -1   on 'end-of-file'
!              -2   on 'error'
!
! copyright (c) 1999  Matthew Newville
       implicit none
       character*(*) string
       integer    lun, istrln
       external   istrln
       string = ' '
 10    format(a)
       read(lun, 10, end = 40, err = 50) string
       call sclean(string)
       iread = istrln(string)
       return
 40    continue 
       string = ' '
       iread = -1
       return
 50    continue 
       string = ' '
       iread = -2
       return
       end
       subroutine sclean(str) 
!
!  clean a string, especially for strings passed between 
!  different file systems, or from C functions:
!
!   1. characters in the range char(0), or char(10)...char(15) 
!      are interpreted as end-of-line characters, so that all
!      remaining characters are explicitly blanked.
!   2. all other characters below char(31) (including tab) are
!      replaced by a single blank
!
!  this is mostly useful when getting a string generated by a C 
!  function and for handling dos/unix/max line-endings.
!
! copyright (c) 1999  Matthew Newville
       character*(*) str, blank*1
       parameter (blank = ' ')
       integer i,j,is
       do 20 i = 1, len(str)
          is = ichar(str(i:i))
          if ((is.eq.0) .or. ((is.ge.10) .and. (is.le.15))) then
             do 10 j= i, len(str)
                str(j:j) = blank
 10          continue
             return
          elseif (is.le.31)  then
             str(i:i)  = blank
          end if
 20    continue 
       return
! end subroutine sclean
       end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: crystalstructure.f90,v $:
! $Revision: 1.12 $
! $Author: jorissen $
! $Date: 2012/02/04 00:38:50 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      subroutine CRYSTALSTRUCTURE(celvin)


! I believe this is the ONLY place in the entire FEFF code where the lattice of the crystal is changed (if change_to_primitive_lattice is true).
! The changes persist for the duration of the current FEFF module.  However they are not written to file.

        use struct,ncryst=>nsym
        use constants,only: pi2
        use controls,only:iprint
      implicit none
        real*8,intent(in)  :: celvin

!  Variables for the crystal structure :
      real*8, allocatable :: coorat(:,:,:)
      real*8 bvs(3,3),avs(3,3),b(3,3),tnp(48,3)
      integer maxnat
!  Variables for the symmetry information :
      real*8 point_gr(3,3,48)
      real*8,allocatable::car_rot(:,:,:),car_trans(:,:)
!  Unimportant locals :
      real*8 ascale,real_dum(3,3),xmult,ascinv,a1t(3),a2t(3),a3t(3)
	  real*8 alatt_old,alatt_new
      real*8,external :: dotthree
      integer i,j,k,ierr,np,mult(48,48),it,mtrx(48,3,3)
	  logical,parameter :: verbose=.false.
	  logical,parameter :: change_to_primitive_lattice=.true.
	  logical,parameter :: transform_coordinates=.false.


!********************* ORGANIZE CRYSTAL DATA *************************************

!  First, figure out if we are already in the primitive lattice.  If not, go there.
      a1t=a1;a2t=a2;a3t=a3
	  if (verbose) write(11,*) 'lattice type is ',lattice,'   ',latticename
      if(change_to_primitive_lattice) then
	      !The assumption is that the atom positions are given for the atoms belonging in the primitive cell but in the conventional cell coordinates.
		  !That is, to go to the primitive cell representation, one needs merely transform the coordinates, which is what is done here.
		  !Alternatively, one could find the "full" list of atom positions by applying "center" operations to the list of coordinates,
		  !E.g. for a CXY system where 40 positions are given, one can add 40 positions by doing "+(a,b,0)/2"; this fills the conventional cell.
		  
		  
		  !Correction!  It is necessary to transform the basis vectors (a1,a2,a3).
		  !However, the KKR routines expect the atom coordinates to be given in Carthesian coordinates, normalized to the length of the first lattice vector.
		  !So, the coordinates (ppos) shouldn't be changed, except for the normalization.
		  
		  
		  if(verbose) then
		     write(*,*) 'old basis'
		     write(*,*) 'a1',a1
		     write(*,*) 'a2',a2
		     write(*,*) 'a3',a3
             write(*,*) 'old positions'
		     do i=1,nats
		        write(*,*) ppos(:,i)
		     enddo
		  endif
		  alatt_old=dsqrt(a1(1)**2+a1(2)**2+a1(3)**2)  ! coordinates are expressed in units of |a1|.  However we are about to change |a1| ...
		  if(lattice.eq.'P') then   ! Primitive
		  elseif(lattice.eq.'F') then  ! Face centered
			 a1=(a2t+a3t)/dble(2)
			 a2=(a1t+a3t)/dble(2)
			 a3=(a1t+a2t)/dble(2)
			 if(transform_coordinates) then
			 do i=1,nats
				  a1t=ppos(:,i)
				  ppos(1,i)=-a1t(1)+a1t(2)+a1t(3)
				  ppos(2,i)= a1t(1)-a1t(2)+a1t(3)
				  ppos(3,i)= a1t(1)+a1t(2)-a1t(3)
			 enddo
			 endif
		  elseif(lattice.eq.'I'.or.lattice.eq.'B') then  ! Body centered
			   a1=(-a1t+a2t+a3t)/dble(2)
			   a2=( a1t-a2t+a3t)/dble(2)
			   a3=( a1t+a2t-a3t)/dble(2)
			   if(transform_coordinates) then
			   do i=1,nats
				  a1t=ppos(:,i)
				  ppos(1,i)=a1t(2)+a1t(3)
				  ppos(2,i)=a1t(1)+a1t(3)
				  ppos(3,i)=a1t(1)+a1t(2)
			   enddo
               endif
		  elseif(lattice.eq.'C') then ! xz Base centered (or yz?)
			   if(latticename.eq.'CXY') then
				  a1=( a1t+a2t)/dble(2)
				  a2=(-a1t+a2t)/dble(2)
				  a3=a3t 
			      if(transform_coordinates) then
				  do i=1,nats
					 a1t=ppos(:,i)
					 ppos(1,i)= a1t(1)+a1t(2)
					 ppos(2,i)= a1t(2)-a1t(1)
					 ppos(3,i)= a1t(3)
				  enddo
                  endif
			   elseif(latticename.eq.'CXZ') then
				  a1=( a1t+a3t)/dble(2)
				  a3=(-a1t+a3t)/dble(2)
				  a2=a2t 
			      if(transform_coordinates) then
				  do i=1,nats
					 a1t=ppos(:,i)
					 ppos(1,i)= a1t(1)+a1t(3)
					 ppos(3,i)= a1t(3)-a1t(1)
					 ppos(2,i)= a1t(2)
				  enddo
                  endif
			   elseif(latticename.eq.'CYZ') then
				  a3=( a3t+a2t)/dble(2)
				  a2=(-a3t+a2t)/dble(2)
				  a1=a1t 
			      if(transform_coordinates) then
				  do i=1,nats
					 a1t=ppos(:,i)
					 ppos(3,i)= a1t(3)+a1t(2)
					 ppos(2,i)= a1t(2)-a1t(3)
					 ppos(1,i)= a1t(1)
				  enddo		   
                  endif
			   endif
			   call wlog('crystalstructure - warning: C lattice not well tested')
		  elseif(lattice.eq.'R') then ! Rhombohedral ; the conventional cell is hexagonal
			   a1=(2.d0*a1t     -a2t  +a3t)/dble(3)
			   a2=(    -a1t+2.d0*a2t  +a3t)/dble(3)
			   a3=(    -a1t     -a2t  +a3t)/dble(3)
			   if(transform_coordinates) then
			   do i=1,nats
				  a1t=ppos(:,i)
				  ppos(1,i)=a1t(1)+a1t(3)
				  ppos(2,i)=a1t(2)+a1t(3)
				  ppos(3,i)=a1t(3)-a1t(1)-a1t(2)
			   enddo
               endif
			   call wlog('crystalstructure - warning: R lattice not well tested')
		  elseif(lattice.eq.'H') then ! Hexagonal
			 !Do nothing; a hexagonal lattice is primitive
		  else
			   stop 'unknown lattice type in crystalstructure'
		  endif
		  !At this point, I think we need to tell the rest of the program that we are in a primitive cell now:
		  lattice='P'
		  latticename='P  '
		  alatt_new=dsqrt(a1(1)**2+a1(2)**2+a1(3)**2)
		  ppos=ppos*alatt_old/alatt_new  !Renormalize so coordinates are now in units of the new lattice vector
		  if(verbose) then
		     write(*,*) 'new basis'
		     write(*,*) 'a1',a1
		     write(*,*) 'a2',a2
		     write(*,*) 'a3',a3
             write(*,*) 'new positions'
		     do i=1,nats
		        write(*,*) ppos(:,i)
		     enddo		  
		  endif
	  endif

        a1t=dble(0);a2t=dble(0);a3t=dble(0)  ! destroy temporary variables(a1t is nonsense by this time anyway!)
!  We have assumed that only the primitive atoms were given!  Eg., only 2 atoms specified for diamond input with
!  cubic lattice and 'F' option.  If not, garbage will be produced.


!  input the crystal info
!  First, figure out how many atoms there are in the unit cell :
      allocate(coorat(nph,nats,3))
      coorat=dble(0)
      natom=0
      j=0 !test variable
      do it=1,nph
        do i=1,nats
         if(ppot(i).eq.it) then
              natom(it)=natom(it)+1
              coorat(it,natom(it),:)=ppos(:,i)
           endif
        enddo
        j=j+natom(it)
        if(natom(it).eq.0) stop 'error input crystalstructure'
      enddo
      if(j.ne.nats) stop 'error input crystalstructure'

      maxnat = 0
      do i = 1,nph
        if (natom(i).gt.maxnat) maxnat = natom(i)
      end do

      call cross(a2,a3,b1)
      call cross(a3,a1,b2)
      call cross(a1,a2,b3)
      celvol=dotthree(b1,a1)
      xmult=pi2/celvol
      do i=1,3
        b1(i)=b1(i)*xmult
        b2(i)=b2(i)*xmult
        b3(i)=b3(i)*xmult
      end do
      celvol=dabs(celvol)
      if (celvin.gt.0.d0) then
	    if(verbose) write(11,*) 'cell volume found ',celvol,' ; cell volume requested ',celvin
        ascale = (celvin/celvol)**(1.d0/3.d0)
        ascinv = 1.d0/ascale
        a1=a1*ascale
        a2=a2*ascale
        a3=a3*ascale
        b1=b1*ascinv
        b2=b2*ascinv
        b3=b3*ascinv
        celvol = celvin
      endif

        alat(1)=dsqrt(a1(1)**2+a1(2)**2+a1(3)**2)
        alat(2)=dsqrt(a2(1)**2+a2(2)**2+a2(3)**2)
        alat(3)=dsqrt(a3(1)**2+a3(2)**2+a3(3)**2)
        alfalat(1)=dacos(dotthree(a2,a3)/(alat(2)*alat(3)))
        alfalat(2)=dacos(dotthree(a1,a3)/(alat(1)*alat(3)))
        alfalat(3)=dacos(dotthree(a1,a2)/(alat(1)*alat(2)))

!  Done reading input from file.

!    Now, summarize the structure to stdout :
      if(verbose)then
		  do i=1,nph
			write(11,'(/,1x,i2,5x,3x,1a12,/)')  natom(i),'in positions'
			do j=1,natom(i)
			  write(11,'(1x,3f10.5)') (coorat(i,j,k),k=1,3)
			end do
		  end do

		  write(11,'(/,1a23,/,3(/,1x,3f10.5))') ' lattice vectors (a.u.)',a1,a2,a3
		  write(11,'(/,1a23,/,3(/,1x,3f10.5))') ' in wave number space  ',b1,b2,b3

		  write(11,'(/,1a14,1f10.4)') ' cell volume =',celvol
      endif
	  
!    Save the individual (reciprocal) basis in a 3*3 matrix avs (bvs)
      do j=1,3
        avs(1,j)=a1(j)
        avs(2,j)=a2(j)
        avs(3,j)=a3(j)
        bvs(1,j)=b1(j)
        bvs(2,j)=b2(j)
        bvs(3,j)=b3(j)
      end do

!    Calculate the 'metric' of the reciprocal basis in b
      b=dble(0)
      do i=1,3
        do j=1,3
          do k=1,3
            b(i,j)=b(i,j)+bvs(i,k)*bvs(j,k)
          end do
        end do
      end do

!    Is the lattice orthogonal?
      ascale=dabs(a1(1)*a2(1)+a1(2)*a2(2)+a1(3)*a2(3))   &! a1 . a2
     &   +dabs(a1(1)*a3(1)+a1(2)*a3(2)+a1(3)*a3(3))   &! a1 . a3
     &   +dabs(a3(1)*a2(1)+a3(2)*a2(2)+a3(3)*a2(3))   ! a2 . a3
      ortho=(dabs(ascale).lt.dble(0.00000001))
      if(verbose) write(11,*) 'lattice orthogonality (T/F) :',ortho

!******************************* DETERMINE SYMMETRY OF THE CRYSTAL *********************


!    Determine the point group of the lattice
      call pointgroup(bvs,b,48,point_gr,np)
      if(verbose) write(11,*) "There are ",np," operations in the point group"

!    Now figure out the space group of lattice AND basis
      call spacegroup(avs,bvs,nph,maxnat,coorat,natom,48,point_gr,np,cryst_gr(:,:,:,2),ncryst)
      if(verbose) write(11,*) "There are ",ncryst," sym. operations"

!******************************* GIVE OUTPUT *******************************************

      if(verbose) then
        open(71,file='avsbvs.txt')
        do i=1,3
        write(71,'(3f12.4,3x,3f12.4)') avs(i,:),bvs(i,:)
        enddo
        close(71)
      endif

!    Calculate the integer representation of the symmetry matrices in mtrx, tnp and 
!    write it to file 23 if iprint says so.  
      if (verbose) open(23,file='operations.txt',form='formatted')
      do i=1,ncryst
         do j=1,3
            do k=1,3
               mtrx(i,j,k)=nint(cryst_gr(j,k,i,2))
            end do
            tnp(i,j)=cryst_gr(j,4,i,1)
         end do
         if (verbose) then
            write(23,*) "Oper.: ",i 
            write(23,'(3(/,2x,3i10))') ((mtrx(i,j,k),k=1,3),j=1,3)
            write(23,'(7x,1a1,3f10.3,1a2)')  '(',(tnp(i,j),j=1,3),' )'
            write(23,*) ""
         endif
         do j=1,3
            tnp(i,j) = pi2*tnp(i,j)
         end do
      end do
      if (verbose) close(23)


      if(verbose) then
         write(11,*) 'mtrx :'
         do j=1,3
            write(11,*) mtrx(8,j,1:3)
         enddo

         write(11,*) 'avx:'
         do j=1,3
            write(11,*) avs(j,1:3)
         enddo
         write(11,*) 'bvx:'
         do j=1,3
            write(11,*) bvs(j,1:3)
         enddo
		endif


!    Calculate the Carthesian representation of the symmetry matrices in car_rot, car_trans and print it to stdout.      
      allocate(car_rot(1:3,1:3,1:ncryst),car_trans(1:3,1:ncryst))
      if(verbose) write(11,*) "Cartesian Operators"
      car_trans=dble(0)
      do i=1,ncryst
         call change_car(bvs,avs,mtrx,i,real_dum)
           car_rot(:,:,i)=real_dum/pi2
         do j=1,3
            do k=1,3
               car_trans(j,i)=car_trans(j,i)+avs(k,j)*tnp(i,k)
            end do
         end do
		 car_trans(:,i)=car_trans(:,i)/pi2
		 if(verbose) then
			 write(11,*) i
			 write(11,'(3(/,1x,3f10.4))') ((car_rot(j,k,i),k=1,3),j=1,3)
			 write(11,*)
			 write(11,'(3f10.4)') (car_trans(j,i),j=1,3)
			 write(11,*)
		 endif
      end do


!KJ  I believe that the rest of my program does not care about the translations ; only about the rotations.
!    However, I still return the whole thing in WIEN2k-compatible format
      do i=1,ncryst
           cryst_gr(:,1:3,i,1)=car_rot(:,:,i)
      enddo
!    I leave the translations in fractional units OF THE PRIMITIVE LATTICE.  (Eg., if input is given as F,
!    specifying the cubic (conventional) lattice vectors, the translation vectors will be in fractions of
!    the rhombohedric (primitive) lattice vectors.

      deallocate(car_rot,car_trans)


      call symmetrycheck(ierr,ncryst,mtrx,tnp,mult)


	if (ierr .ne. 0) then
		call wlog('FEFF cannot use symmetry.  The calculation proceeds with 1 symmetry operation.')
		np=1
		ncryst=1
		tnp=dble(0)
		mtrx=0
		mtrx(1,1,1)=1
		mtrx(1,2,2)=1
		mtrx(1,3,3)=1
		cryst_gr=dble(0)
		cryst_gr(:,1:3,1,1)=mtrx(1,:,:)
		call change_car(bvs,avs,mtrx,1,real_dum)
		cryst_gr(:,1:3,1,2)=real_dum/pi2
	endif

 
      return
        end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: kmesh.f90,v $:
! $Revision: 1.16 $
! $Author: jorissen $
! $Date: 2012/04/03 22:39:49 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine kmesh
! given the lattice of type lattic in lat, construct the reciprocal lattice and sample the first brillouin
! zone using nk points, gathered in bk.  If usesym and use_external_symmetry_input, use the nsym symmetry operations given in file symfil to reduce
! this mesh of nk points to the irreducible part of the BZ (nk then becomes the number of irreducible points).  
        use struct,ncrystsym=>nsym
        use kklist
        use kgenwork
        use tetrahedra
        use controlkgen
      implicit none
! this routine is to a great extent identical to the program kgen of the wien2k package,
! which is an adapted version of P. Bloechl's programs.

! Some comments about the list of k-vectors :
! The bk are in carthesian units and are limited to the first BZ.
! if eg the lattice is simple cubic of size a, then each of the coordinates
! of bk(.,i) is within [0,2pi/a[.
! for non simple lattices, coordinates may appear weird :
! eg F (diamond) takes 'cubic' lattice parameter input, but can actually
! be reduced to a rhombohedric simple lattice, which has a non cubic BZ.
! In this case, negative coordinates may occur.


!  INPUT
      real*8 lat(6) ! real space lattice specified as 3 lengths and 3 angles
      character*3 lattic    ! defines bravais lattice, ie H(exagonal),R(hombohedric),F(ace centered),
                            ! I(body centered),P(rimitive),CXZ/CYZ/CXY (one face centered)
!      logical usesym     ! true : reduce mesh by symmetry ; false : don't.
        character*20 symfil   ! (optional) file containing symmetry operations (Note: no longer input; now set below; not used anyway ; KJ 1-2012)
!	integer nk  ! at calling time, requested number of k-vectors for total mesh
!  OUTPUT
!      real*8 bk(3,:),volbz,weight(:) ! list of irr. k-vectors; volume of Brillouin zone; integration weight of each vector
!     integer nk : now contains the number of irreducible k-vectors (already declared in 'INPUT' section)
!  LOCALS
      integer iz(3,3,48), iio(3,3,48)
      integer nsym !local copy
        integer i,iarb(3),ndiv(3),ir,ikp,k1,k2,k3,idiv,nkj,j
      integer,allocatable :: klist(:,:)
      real*8 sym4(3,48),pi,afact,sumwgt,ak1,ak2,ak3,am(3,3),bm(3,3),cm(3,3),dm(3,3)
        real*8,allocatable :: wei(:)
      character*512 slog
	  logical ran_already
	  logical, parameter :: write_kmesh_dat=.true.
        logical,parameter :: writewienklist=.false.
        logical,parameter :: writesymops=.false.
        logical,parameter :: use_external_symmetry_input=.false.
		logical,parameter :: debug=.false.

      pi=dacos(dble(-1))                                           
      ran_already=(allocated(bk))
      symfil='di.wiensymmetry     '	     

!****************** GET K-LIST FROM FILE
!  First, we check if the file klist.in exists; if it does, we take k-points from this file instead of calculating them.
!  That means the input from feff.inp is ignored completely.  CAREFUL : the symmetry information in module kklist should be consistent with whatever's in the file ...
      open(18,file='klist.in',form='formatted',status='old',err=1010)
      read(18,*,err=1010,end=1010) nkj,volbz ! we call this nkj instead of nk so that we can fall back to input nk in case of trouble with the file
      call init_kklist(nkj,ncrystsym)  !KJ 6-09
      do i=1,nkj
        read(18,*,err=1009,end=1009) bk(1,i),bk(2,i),bk(3,i),wei(i)
      enddo
      close(18)
        nkp=nkj
        write(slog,25) nkp
25    format(i6,'k-vectors taken from klist.in ; feff.inp ignored')
        call wlog(slog)
      return
1009  stop 'error while reading klist.in in kgen'
1010  continue

!****************** CREATE NEW K-LIST     
      sumwgt=dble(0)
      if(debug) open(66,file='outputkgen.txt',form='formatted',status='unknown')
!	  open(15,file='file.kgen',form='formatted',status='unknown')



      if(use_external_symmetry_input) then
		  iz=0
		  if (usesym .eq. 1) then
			 call reasym(symfil,nsym,iz,sym4)
		  else
			 nsym = 1
			   do k1=1,3
				  iz(k1,k1,1)=1
			   enddo
		  endif
		  write(slog,26) nsym
	26    format('Using',i4,' symmetry operation(s) to reduce the k-mesh.')
		  call wlog(slog)
	  endif


	  if(usesym.eq.1) then
		 nsym=ncrystsym
	  else
		 nsym=1
	  endif


!     copy array
      lat(1:3)=alat
	  lat(4:6)=alfalat !/dble(180)*pi
	  lattic=latticename
!      if (nsym.eq.1) then
!		 lattic='P  ' !KJ this line added KJ - don't use symmetry, primitive lattice
!		 if(.not.ran_already) call wlog ('Lattice type set to Primitive in kgen.')
!	  endif
!KJ I think this would be a big mistake ??

!*********************** PREPARE BRAVAIS AND SYMMETRY MATRICES :

      rbas(1,:)=a1
      rbas(2,:)=a2
      rbas(3,:)=a3
      gbas(1,:)=b1
      gbas(2,:)=b2
      gbas(3,:)=b3
      volbz=(2*pi)**3 / celvol
	  if(debug) then
        open(77,file='kdebug2.txt')
        write(77,*) lattic,lat,ortho,volbz,celvol
        do i=1,3
        write(77,'(3f12.4,7x,3f12.4)') rbas(i,:),gbas(i,:)
        enddo 
        write(77,*) nsym
        do i=1,nsym
        do j=1,3
        write(77,'(i3,3x,3f12.4)') i,iio(j,:,i)
        enddo
        enddo
        close(77)
      endif

      call bravais(lattic,lat(1),lat(2),lat(3),rbas,gbas,afact,iarb,lat(4),lat(5),lat(6),ortho,volbz)          
      call gbass(rbas,gbas)   
      call sdef(iz,nsym,lattic)
      call sdefl(rbas,gbas,iio,nsym,iz,lattic,ortho)

      if(debug)then
        open(77,file='kdebug.txt')
        write(77,*) lattic,lat,ortho,volbz
        do i=1,3
        write(77,'(3f12.4,7x,3f12.4)') rbas(i,:),gbas(i,:)
        enddo 
        write(77,*) nsym
        do i=1,nsym
        do j=1,3
        write(77,'(i3,3x,3f12.4)') i,iio(j,:,i)
        enddo
        enddo
        close(77)
      endif

      iz=iio !backup
      rbas(1,:)=a1
        rbas(2,:)=a2
        rbas(3,:)=a3
        gbas(1,:)=b1
        gbas(2,:)=b2
        gbas(3,:)=b3
        volbz=celvol/(2*pi)**3
        do i=1,48
           sym4(:,i)=cryst_gr(:,4,i,1)
           do j=1,3
!	   iio(j,1:3,i)=nint(cryst_gr(j,1:3,i,1))
           iio(j,1:3,i)=nint(cryst_gr(j,1:3,i,2))
           enddo
        enddo
        
        if(nsym.eq.1) then
!          enforce that the identity is the chosen one
           iio(:,:,1)=0
           sym4(:,1)=dble(0)
           do i=1,3
              iio(i,i,1)=1
           enddo
        endif	

      if(debug) then        
        open(76,file='symoptest.txt')
        do i=1,48
        do j=1,3
        write(76,'(i3,4x,3i4,4x,3i4)') i,iz(j,:,i),iio(j,1:3,i)
        enddo
        enddo
        close(76)
      endif


!************************ FIND IRREDUCIBLE K-POINTS AND TETRAHEDRA
	  call destroy_kklist  !KJ 1-2012 : if running kmesh for the second time, delete allocatable arrays first
	  call destroy_meshes !id.                                               
      nka=nkp      
      call arbmsh(gbas,nsym,iio,iarb,ndiv,sumwgt)       
!     Now nka is the number of points asked for; nkf is the nofp on the
!     actual mesh; nki of these points are in the IBZ.
!     The irreducible points are stored in bk.
      write(slog, 4020) nki,nkf,nka
 4020 format(i8,' k-points generated in the IBZ, or ',i8,' in the full BZ, while ',i8,' were asked for')
      if(.not.ran_already) call wlog(slog)

     
!********************* COPY RESULTS TO FEFF ARRAYS
      call init_kklist(nki,nsym) !KJ 6-09
	  nkp=nki
	  weight=wi
	  bk=bki


!      do i=1,48
!	do j=1,3
!	do k1=1,3
!	afact=dble(0)
!	do k2=1,3
!      afact=afact+cryst_gr(j,k2,i,1)*cryst_gr(k1,k2,i,1)
!      enddo
!	if((j.eq.k1.and.(dabs(afact-dble(1)).gt.dble(0.0001)))
!     1   .or.(j.ne.k1.and.(dabs(afact).gt.dble(0.0001))))
!     2   write(*,*) 'no inverse',i
!	enddo
!	enddo
!	enddo
!	write(*,*) 'all cleared!'
!	stop

!      call wlog('For convenience, inverting all symmetry matrices.')
        do i=1,nsym
         cm=cryst_gr(:,1:3,i,1)
           do j=1,3
           do k1=1,3
              cryst_gr(j,k1,i,1)=cm(k1,j)
           enddo
           enddo
        enddo
        afact=dble(0)

      if(writesymops) then
           open(55,file='symops_kgen.txt',form='formatted')
           do i=1,3
           do j=1,3
              cm(i,j)=gbas(j,i)/dble(6.28318)
              dm(i,j)=rbas(j,i)
           enddo
           enddo
!           write(*,*) 'possibly need transpose of cm ...'
           write(55,*) 'RBAS ------------ GBAS ------------ CM'
           do i=1,3
              write(55,1018) rbas(i,:),gbas(i,:),cm(i,:)
           enddo
1018     format(3f12.6,5x,3f12.6,5x,3f12.6)
           do i=1,nsym
               write(55,*) 'SYMMETRY OPERATION ',i
               do j=1,3
               do k1=1,3
        	      am(j,k1)=dble(iio(k1,j,i)) !the transpose of iio is its inverse
               enddo
               enddo
!           calculate am = gbas' iio(i)  rbas'  /(2pi)
               call matmm(bm,cm,am)
               call matmm(am,bm,dm)
               do j=1,3
!	          write(55,1019) iio(j,:,i),am(j,:),cryst_gr(j,1:3,i,1),
                  write(55,1019) iio(:,j,i),am(j,:),cryst_gr(j,1:3,i,1),cryst_gr(j,1:3,i,2)
               enddo
             cryst_gr(:,1:3,i,2)=am
           enddo
           close(55)
1019     format(3i6,3(5x,3f12.6))
        endif
                 
		if (allocated(wei)) deallocate(wei,klist)
		allocate(wei(nki),klist(nki,3))
		do ikp=1,nki                                                
            wei(ikp)=wi(ikp)*sumwgt/2.  ! weight=>wwi
		enddo


	  if(writewienklist) then

         IDIV=10000  
         if(iarb(1).eq.1.and.iarb(2).eq.1.and.iarb(3).eq.1) IDIV=NDIV(1)*2  
         if(iarb(1).eq.1.and.iarb(3).eq.0) IDIV=NDIV(1)*ndiv(3)*2          
         if(iarb(3).eq.1.and.iarb(1).eq.0) IDIV=NDIV(1)*ndiv(2)*2          
         if(iarb(2).eq.1.and.iarb(1).eq.0) IDIV=NDIV(2)*ndiv(3)*2          
         if(iarb(1).eq.0.and.iarb(2).eq.0.and.iarb(3).eq.0) IDIV=NDIV(1)*ndiv(2)*ndiv(3)*2                                                
         if (debug) write(66,*) 'nki,NDIV,afact ',nki,NDIV,afact                      
           open(8,file='file.klist',form='formatted',status='unknown')
         do ikp=1,nki !nk                                                  
            ak1=bki(1,ikp)/2./pi*lat(1)  !bk=>bki
            ak2=bki(2,ikp)/2./pi*lat(2)  !bk=>bki
            ak3=bki(3,ikp)/2./pi*lat(3)  !bk=>bki
            if (debug) write(66,6221) AK1,AK2,AK3,ak1*idiv,ak2*idiv,ak3*idiv
            K1=NINT(AK1*IDIV)                                                 
            K2=NINT(AK2*IDIV)                                                 
            K3=NINT(AK3*IDIV)
            if (.not.ortho) then
               klist(ikp,1)=NINT(bKi2(1,ikp)*IDIV)  !bki=>bki2
               klist(ikp,2)=NINT(bKi2(2,ikp)*IDIV)  !bki=>bki2
               klist(ikp,3)=NINT(bKi2(3,ikp)*IDIV)  !bki=>bki2
            else
               klist(ikp,1)=K1
               klist(ikp,2)=K2
               klist(ikp,3)=K3
            endif
         enddo
        
         call divisi(nki,nki,idiv,klist)  !nk,nk

         do ikp=1,nki  !nk
            if(ikp.eq.1) then 
               write(8,1523) IKP,(klist(ikp,ir),ir=1,3),IDIV,wei(ikp),-7.,1.5,nka,ndiv
            else
               write(8,1520) IKP, (klist(ikp,ir),ir=1,3),idiv,wei(ikp)
            endif                               
         enddo                                                          
         write(8,1521)
           close(8)
      endif
	  
	  if(write_kmesh_dat) then
	  open(44,file='kmesh.dat')
	  do ikp=1,nki
            if(ikp.eq.1) then 
               write(44,1525) IKP,(bki(ir,ikp),ir=1,3),wei(ikp),nka,nki,ndiv
            else
               write(44,1525) IKP, (bki(ir,ikp),ir=1,3),wei(ikp)
            endif                               
         enddo                                                          
	  close(44)
	  1525 format(i10,4f9.4,5i7)
	  endif
	  

 1520 format(I10,4I5,f5.1)                                              
 1521 format('end',/)
 1522 format(4f10.7)                                              
 1523 format(I10,4I5,3f5.1,4x,i6,' k, div: (',3i3,')')                  
 6221 format(3f12.5,10x,3f13.5)
      close(66);close(15)

!*********************** CLEAN UP UNWANTED ARRAYS
!      call destroy_meshes 
        if (dotets) call destroy_tetrahedra     

      return                                              
      end     ! subroutine kgen                                                            





!*******************************************************************************************
      subroutine ARBMSH(gbas,nsym,iio,iarb,n,sumwgt)       
!     **  CALCULATE IRREDUCIBLE K-POINTS AND FINDS INEQUIVALENT TETRAHEDRA  **
!     **  FOR BRILLOUIN ZONE INTEGRATION                              **
!     **                                                              **
!     **  INPUT :                                                     **
!     **    nsym        NUMBER OF SYMMETRY OPERATIONS                 **
!     **    IIO         SYMMETRY OPERATIONS                           **
!     **    iarb        DEPENDENCIES FOR DIVISIONS                    **
!     **                OF RECIPROCAL LATTICE VECTORS                 **
!     **                ( if iarb(1)=1 then 1ST AND 2ND LATTICE       **
!     **                  VECTORS ARE DIVIDED BY AN EQUAL NUMBER;     **
!     **                  if iarb(3)=1 then SAME FOR 2ND AND 3RD;     **
!     **                  if iarb(2)=1 then SAME FOR 3RD AND 1ST)     **
!     **                                                              **
!     **   AUTHOR: PETER E. BLOECHL                                   **
!     **                                                              **
!     **   SUBROUTINES USED:                                          **
!     **     GBASS,BASDIV,REDUZ,TETDIV,TETCNT,ORD1         **
      use kgenwork
        use controlkgen
      implicit none
      integer,intent(in) :: nsym,iio(3,3,nsym),iarb(3)
        integer,intent(inout) :: n(3)
        real*8,intent(in) :: gbas(3,3)
        real*8,intent(out) :: sumwgt
        integer ishift(3),tet0(3,4,6)
        integer nmshp
		logical,parameter :: debug=.false.         
!     ------------------------------------------------------------------
!     -- DEFINE MESH                                                  --
!     ------------------------------------------------------------------
      nmshp=nka                                                         
      call basdiv(n,nmshp,gbas,iarb)
        nkw=nmshp
        nkf=n(1)*n(2)*n(3)
        call init_workmesh(nkw)
        call init_fullmesh(nkf)
!     ------------------------------------------------------------------
!     -- FIND IRREDUCIBLE K-POINTS                                    --
!     ------------------------------------------------------------------
      call REDUZ(n,ishift,nsym,IIO,sumwgt,gbas)             
      if(debug) write(66,*) ' NO. OF INEQUIVALENT K-POINTS ', nki                                                 
        if(.not.dotets) return
!     ----------------------------------------------------------------- 
!     --  CHOOSE TETRAHEDRA                                          -- 
!     ----------------------------------------------------------------- 
      call TETDIV(n,gbas,tet0)                                      
!     ----------------------------------------------------------------- 
!     --  FIND INEQUIVALENT TETRAHEDRA                               -- 
!     ----------------------------------------------------------------- 
      call TETCNT(TET0,n)               
      return                                                            
      end                                                               
  



!     ..................................................................
      subroutine basdiv(n,nmshp,gbas,iarb)                              
!     **                                                              **
!     **  BASDIV DETERMINES DIVISION OF BASEVECTORS OF REC. LATT.     **
!     **  SO THAT THE NUMBER OF MESHPOINTS IS JUST BELOW nmshp AND    **
!     **  TAKES INTO ACCOUNT THE DEPENDENCY BY POINT-SYMMETRY         **
!     **  INPUT :                                                     **
!     **    gbas        RECIPROCAL LATTICE VECTORS                    **
!     **    iarb        DEPENDENCIES FOR DIVISIONS                    **
!     **                OF RECIPROCAL LATTICE VECTORS                 **
!     **                ( if iarb(1)=1 then 1ST AND 2ND LATTICE       **
!     **                  VECTORS ARE DIVIDED BY AN EQUAL NUMBER;     **
!     **                  if iarb(2)=1 then SAME FOR 1ST AND 3RD;     **
!     **                  if iarb(3)=1 then SAME FOR 3RD AND 2ND)     **
!     **    nmshp       TOTAL NUMBER OF GRID POINTS                   **
!     **  OUTPUT:                                                     **
!     **    n           NUMBER OF DIVISIONS OF RECIPROCAL LATTICE     **
!     **                VECTORS FOR DEFINITION OF SUBLATTICE          **
!     **    nmshp       NUMBER OF SUBLATTICE POINTS in A REC. UNIT CELL*
!     **                AND ON ALL ITS FACES                          **
!     **                                                              **
      implicit none
        integer,intent(in) ::   iarb(3)
        integer,intent(out) ::  n(3)
        integer,intent(inout) ::nmshp                                       
      real*8,intent(in) ::    gbas(3,3)
        integer i                                                 
      real*8,parameter :: opar=1.d-6 
      real*8 betr(3),rn(3),svar  
	  logical,parameter :: debug=.false.                                  
!     ==================================================================
!     == FIND UPPER LIMIT FOR THE LENGTH OF SUBLATTICE VECTORS        ==
!     ==================================================================
      do i=1,3                                                       
         betr(i)=sqrt(gbas(i,1)**2+gbas(i,2)**2+gbas(i,3)**2)            
      enddo                                                         
      svar=(dble(nmshp)/(betr(1)*betr(2)*betr(3)))**(1.D0/3.D0)         
      do i=1,3                                                       
         rn(i)=betr(i)*svar                                                
      enddo                                                          
!     ==================================================================
!     == FIND DIVISIONS OF LATTICE VECTORS                            ==
!     ==================================================================
      if(iarb(1).eq.1.and.iarb(2).eq.1)then                             
        n(1)=int((rn(1)*rn(2)*rn(3))**(1.D0/3.D0)+opar)                 
        n(2)=n(1)                                                       
        n(3)=n(1)                                                       
      else if(iarb(1).eq.1) then                                        
        n(1)=int(sqrt(rn(1)*rn(2))+opar)                               
        n(2)=n(1)                                                       
        n(3)=int(rn(3))                                                 
      else if(iarb(2).eq.1) then                                        
        n(1)=int(sqrt(rn(1)*rn(3))+opar)                               
        n(2)=int(rn(2))                                                 
        n(3)=n(1)                                                       
      else if (iarb(3).eq.1) then                                       
        n(1)=int(rn(1))                                                 
        n(2)=int(sqrt(rn(2)*rn(3))+opar)                               
        n(3)=n(2)                                                       
      else                                                              
        n(1)=int(rn(1)+opar)                                            
        n(2)=int(rn(2)+opar)                                            
        n(3)=int(rn(3)+opar)                                            
      end if                                                            
      n(1)=max0(1,n(1))                                                 
      n(2)=max0(1,n(2))                                                 
      n(3)=max0(1,n(3))                                                 
      if(debug) write(66,*) ' length of reciprocal lattice vectors:',rn
      nmshp=(n(1)+1)*(n(2)+1)*(n(3)+1)                                  
      return                                                            
      end                                                               




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

      subroutine REDUZ(n,ishift,nsym,IO,sumwgt,gbas)
!KJ  Constructs the following arrays :
!KJ  bki,bkf,bkw  ;  wi,wf,ww  ;  linkf,linkw  ;  lsymf,lsymw
!     **                                                              **
!     **  REDUZ CREATES THE RELATION BETWEEN THE MESHPOINTS AND       **
!     **  THE POINTS in THE "IRREDUCIBLE ZONE"                        **
!     **  INPUT :                                                     **
!     **    n           NUMBER OF DIVISIONS OF REC. LATTICE VECTORS   **
!     **    nmshp       NUMBER OF SUBLATTICE POINTS INSIDE AND        **
!     **                ON ALL FACES OF A REC. UNIT CELL              **
!     **    nsym        NUMBER OF SYMMETRY OPERATIONS                 **
!     **    IO          SYMMETRY OPERATIONS (BASIS ARE REC. LATT. VEC.)*
!     **    in          WORK ARRAY                                    **
!     **  OUTPUT :                                                    **
!     **    num(i)      MAPPING FROM A GENERAL POINT (i) TO THE       **
!     **                CORRESPONDING IRREDUCIBLE POINT (num)         **
!     **  REMARKS :                                                   **
!     **    THE MAPPING FROM COORDINATES TO NUMBERS IS GIVEN BY :     **
!     **   (X,Y,Z)=rbas*(i,J,K)                                       **
!     **   (i,J,K)  <->  num = i*(n(2)+1)*(n(3)+1)+J*(n(3)+1)+K+1     **
!     **                                                              **
      use kgenwork
        use controlkgen
      implicit none
        integer,intent(in) ::  n(3),nsym,IO(3,3,nsym)
        integer,intent(out) :: ishift(3)
      real*8,intent(out) ::  sumwgt
        real*8,intent(in) ::   gbas(3,3)
        real*8 wsum(nkw)
        integer i,j,i1,i2,i3,j1,j2,j3,k,l,nirr,linkwf(nkw)
        real*8 wgt,summ(3)
      integer nf
        real*8 rinda,rindb,rindc
		logical,parameter :: debug=.false.
!     ------------------------------------------------------------------
!     -- TEST WHETHER SHIFT OF THE SUBLATTICE BY (1/2,1/2,1/2) IS     --
!     --  COMPATIBLE WITH THE SYMMETRYGROUP                           --
!     ------------------------------------------------------------------
!            write(11,*) 'SYMMETRY MATRICES :'  !KJ changed lun 68 to 11
!            do i=1,nsym           
!            write(11,6003) I,((IO(K,L,I),K=1,3),L=1,3)    !KJ changed lun 68 to 11               
!            enddo
      ishift=1                                                       
      do i=1,8                                                       
         bkwi(1,i)=(i-1)/4                                                   
         bkwi(2,i)=(i-bkwi(1,i)*4-1)/2                                         
         bkwi(3,i)=i-bkwi(1,i)*4-bkwi(2,i)*2-1                                   
      enddo                                                          
      do i=1,nsym                                                    
      do J=1,8                                                       
         I1=2*bkwi(1,J)+ishift(1)                                            
         I2=2*bkwi(2,J)+ishift(2)                                            
         I3=2*bkwi(3,J)+ishift(3)                                            
         J1=IO(1,1,i)*I1+IO(1,2,i)*I2+IO(1,3,i)*I3                         
         J2=IO(2,1,i)*I1+IO(2,2,i)*I2+IO(2,3,i)*I3                         
         J3=IO(3,1,i)*I1+IO(3,2,i)*I2+IO(3,3,i)*I3                         
         if(DMOD(dble(J1-ishift(1)),2.D0).ne.0.D0.or.                   &
     &     DMOD(dble(J2-ishift(2)),2.D0).ne.0.D0.or.                    &
     &     DMOD(dble(J3-ishift(3)),2.D0).ne.0.D0) then                    
            ishift=0                                                     
            if(debug) write(66,*) 'SUBMESH SHIFT CONFLICTS WITH POINTGROUP'           
            if(debug) write(66,6003) I,((IO(K,L,I),K=1,3),L=1,3)                 
6003        format(1H ,'SYMMETRYMATRIX NR. : ',I5/3(1H ,3I10/))             
            goto 30                                                         
         end if                                                            
      enddo
        enddo
                                                          
30    continue
!!       ishift=0                                                   
      if(ishift(1).eq.1.or.ishift(2).eq.1.or.ishift(3).eq.1) then       
         ishift=1
         if(debug) write(66,*) ' SUBMESH SHIFTED; SHIFT: ',ishift                  
      else                                                              
         if(debug) write(66,*)' SUBMESH NOT SHIFTED; SHIFT: ',ishift               
      end if        

!     ==================================================================
!     ==  INITIALIZE                                                  ==
!     ==================================================================
      wsum=dble(0)
      do i=1,nkw
         linkw(i)=i                                                          
         bkwi(1,i)=(i-1)/((n(3)+1)*(n(2)+1))                                 
         bkwi(2,i)=(i-bkwi(1,i)*(n(2)+1)*(n(3)+1)-1)/(n(3)+1)                  
         bkwi(3,i)=i-bkwi(1,i)*(n(2)+1)*(n(3)+1)-bkwi(2,i)*(n(3)+1)-1            
      enddo                                                          
!     ==================================================================
!     ==  REDUCTION OF REDUCIBLE K-POINTS                             ==
!     ==================================================================
      l=0
        lsymw=0
      do i=1,nsym                                                    
      do J=1,nkw                                                   
         I1=2*bkwi(1,J)+ishift(1)                                            
         I2=2*bkwi(2,J)+ishift(2)                                            
         I3=2*bkwi(3,J)+ishift(3)                                            
         J1=MOD(IO(1,1,i)*I1+IO(1,2,i)*I2+IO(1,3,i)*I3,2*n(1))             
         J2=MOD(IO(2,1,i)*I1+IO(2,2,i)*I2+IO(2,3,i)*I3,2*n(2))             
         J3=MOD(IO(3,1,i)*I1+IO(3,2,i)*I2+IO(3,3,i)*I3,2*n(3))             
         J1=J1+(1-ISIGN(1,J1))*n(1)                                        
         J2=J2+(1-ISIGN(1,J2))*n(2)                                        
         J3=J3+(1-ISIGN(1,J3))*n(3)                                        
         J1=(J1-ishift(1))/2                                               
         J2=(J2-ishift(2))/2                                               
         J3=(J3-ishift(3))/2
           k=J1*(n(2)+1)*(n(3)+1)+J2*(n(3)+1)+J3+1
           if (k.lt.linkw(j).or.(k.eq.linkw(j).and.lsymw(j).eq.0)) then
              lsymw(j)=i
        	  linkw(J)=min0(linkw(J),k)
           endif
           if (k.eq.j.and.i.eq.1) then
              l=l+1
              linkwf(j)=l
           elseif(i.eq.1.and.k.lt.j) then
              linkwf(j)=min(linkwf(k),k)
           elseif(i.eq.1.and.k.gt.j) then
              l=l+1
              linkwf(j)=l
              write(*,*) 'warning - retest now!'
         endif
      enddo
        enddo


      if(debug) write(66,6000) nkf,(n(i),i=1,3)                         
 6000 format(1H ,' NO. OF MESH POINTS in THE BRILLOUIN ZONE =',I6/      &
     & '  DIVISION OF RECIPROCAL LATTICE VECTORS (INTERVALS)=',3I5)      
      if(verbose) write(66,*) ' point    coordinates     relation'
      sumwgt=dble(0)
        wf=dble(0) 
      nirr=0 
      do j=1,nkw
         if(linkw(j).eq.j) nirr=nirr+1  !calculate the number of irreducible points 
         wgt=1.
         if(mod(bkwi(1,j),n(1)).eq.0) wgt=wgt/2.     ! in center : weight=1 ;  in face : weight=0.5                        
         if(mod(bkwi(2,j),n(2)).eq.0) wgt=wgt/2.     ! on side   : weight=0.25; on corner : weight=0.125
         if(mod(bkwi(3,j),n(3)).eq.0) wgt=wgt/2.                            
           ww(j)=wgt
           wf(linkwf(j))=wf(linkwf(j))+wgt
         wsum(linkw(j))=wsum(linkw(j))+wgt  !the precursor of wi
         sumwgt=sumwgt+wgt                                                
         if(verbose .or. debug) then 
               write(66,100) j,bkwi(1,j),bkwi(2,j),bkwi(3,j),linkw(j),wgt,&
     &                           wsum(linkw(j))
           endif
100      format(i5,5x,3i4,i8,2f10.5)
      enddo 
        nki=nirr
      call init_irrmesh(nki)

      do j=1,nkf
           if(wf(j).ne.1.) write(*,*) j,wf(j)
        enddo

      nirr=0
      do j=1,nkw
         if(linkw(j).eq.j) then
            nirr=nirr+1 
            wi(nirr)=wsum(linkw(j))  !wien2k has a factor *2 here, which I have removed.
         endif       
      enddo
        ww=ww/sumwgt
        wf=wf/sumwgt
        wi=wi/sumwgt
        summ=dble(0)
        do i=1,nkw;summ(1)=summ(1)+ww(i);enddo
        do i=1,nkf;summ(2)=summ(2)+wf(i);enddo
        do i=1,nki;summ(3)=summ(3)+wi(i);enddo
      if(verbose.or.debug) write(66,153) summ
         

      nirr=0
        nf=0                                                            
      i=0    ! point i in the worklist is point nf in the full list and/or point nirr in the irr list                                                           
      if(verbose.or.debug) write(66,*)' internal and cartesian k-vectors:'
      do I1=1,n(1)+1                                                   
      do I2=1,n(2)+1                                                 
      do I3=1,n(3)+1                                                 
         i=i+1                                                             
         RINDA=(dble(I1-1)+dble(ishift(1))/2.D0)/dble(n(1))              
         RINDB=(dble(I2-1)+dble(ishift(2))/2.D0)/dble(n(2))              
         RINDC=(dble(I3-1)+dble(ishift(3))/2.D0)/dble(n(3))              
         bkw(1,i)=gbas(1,1)*RINDA+gbas(2,1)*RINDB+gbas(3,1)*RINDC      
         bkw(2,i)=gbas(1,2)*RINDA+gbas(2,2)*RINDB+gbas(3,2)*RINDC      
         bkw(3,i)=gbas(1,3)*RINDA+gbas(2,3)*RINDB+gbas(3,3)*RINDC      
         if(i.eq.linkw(i))then                                               
            nirr=nirr+1                                                     
            linkw(i)=nirr
        	  bki(:,nirr)=bkw(:,i)                                                     
            bki2(1,nirr)=rinda
            bki2(2,nirr)=rindb
            bki2(3,nirr)=rindc
            if(verbose.or.debug) write(66,103) rinda,rindb,rindc,                &
     &                        bki(1,nirr),bki(2,nirr),bki(3,nirr)
 103        format(3f10.5,10x,3f10.5)
         else                                                              
            linkw(i)=linkw(linkw(i))                                              
         end if
           if(linkwf(i).eq.(nf+1)) then
              nf=nf+1
        	  linkf(nf)=linkw(i)
              lsymf(nf)=lsymw(i)
        	  bkf(:,nf)=bkw(:,i)
           endif                                                            
      enddo
        enddo
        enddo                                                          
      if(nirr.ne.nki) stop 'problem in reduc'


      if(nkf.gt.5000) then
         write(*,*) 'skipping sanity check in reduz - too expensive'
        else
! sanity check :
      nirr=0
      do i=1,nkf
        do j=1,nkf
         if(i.ne.j.and.linkf(i).eq.linkf(j).and.lsymf(i).eq.lsymf(j)) then
            nirr=nirr+1
            write(*,*) 'points ',i,' and ',j,' problematic in reduz'
         endif
        enddo
        enddo
        if(nirr.gt.0) stop
!
      endif


      return                                                            
  150 format('  weights of k-points:')
  152 format(2i8,2f12.6)  
  153 format('  sum of weights: ',3f14.6)
      end                                                               


!*****************************************************************************************
      subroutine TETDIV(n,gbas,TET0)                                    
!     **                                                             ** 
!     **  TETDIV DETERMINES THE DIVISION OF THE PARALLELEPIPEDS      ** 
!     **  in TETRAHEDRONS ACCORDING TO THE SHORTEST DIAGONAL         ** 
!     **                                                             ** 
!     **  INPUT:                                                      **
!     **    n           NUMBER OF DIVISIONS OF REC. LATTICE VECTORS   **
!     **    gbas        RECIPROCAL LATTICE VECTORS                    **
!     **  OUTPUT:                                                    ** 
!     **    TET0(i,J,K) COORDINATES (i) in THE BASIS OF SUBLATTICE   ** 
!     **                VECTORS, OF THE 4 CORNERS (J) OF A           ** 
!     **                TETRAHEDRON (K) in A SUBLATTICE UNIT CELL    ** 
!     **                                                             ** 
      implicit none                               
        real*8,intent(in) :: gbas(3,3)
        integer,intent(in) :: n(3)
        integer,intent(out) :: tet0(3,4,6)
      real*8 P(8,3),DIAG(4)                                
      integer IACHT(8),TET(4,6),i,j,k,l,isvar,mndg
!     ------------------------------------------------------------------
!     -- SEARCH FOR THE SHORTEST DIAGONAL                             --
!     ------------------------------------------------------------------
      do i=0,1                                                       
      do J=0,1                                                       
      do K=0,1                                                       
      ISVAR=4*i+2*J+K+1                                                 
      do L=1,3                                                       
         P(ISVAR,L)=gbas(1,L)*dble(i)/dble(n(1))+gbas(2,L)*             &
     &           dble(J)/dble(n(2))+gbas(3,L)*dble(K)/dble(n(3))
      enddo
        enddo
        enddo
        enddo
                                                                      
      do i=1,4                                                      
         DIAG(i)=0.D0                                                     
         do J=1,3                                                      
            DIAG(i)=DIAG(i)+(P(i,J)-P(9-i,J))**2                             
           enddo
        enddo

      MNDG=1                                                           
      do i=2,4                                                      
         if(DIAG(i).LT.DIAG(MNDG)) then                                   
            MNDG=i                                                         
         end if                                                           
      enddo                                                         
!     ------------------------------------------------------------------
!     -- ROTATE PARALLELEPIPED                                        --
!     ------------------------------------------------------------------
      if(MNDG.eq.1)then                                                 
        do i=1,8                                                     
           IACHT(i)=i                                                      
          enddo
      else if(MNDG.eq.2) then                                           
        do i=1,4                                                     
           IACHT(2*i-1)=2*i                                                
           IACHT(2*i)=2*i-1                                                
          enddo
      else if(MNDG.eq.3) then                                           
        do i=0,1                                                     
        do J=1,2                                                     
           IACHT(4*i+J)=4*i+J+2                                            
           IACHT(4*i+J+2)=4*i+J                                            
          enddo
          enddo
      else if(MNDG.eq.4) then                                           
        do i=1,4                                                     
           IACHT(i)=i+4                                                    
           IACHT(i+4)=i                                                    
          enddo

      end if                                                            
!      **  CREATION OF TETRAHEDRA  **                                   
      do i=1,6                                                      
         TET(1,i)=IACHT(1)                                                
         TET(4,i)=IACHT(8)                                                
        enddo

      TET(2,1)=IACHT(2)                                                
      TET(3,1)=IACHT(4)                                                
      TET(2,2)=IACHT(4)                                                
      TET(3,2)=IACHT(3)                                                
      TET(2,3)=IACHT(3)                                                
      TET(3,3)=IACHT(7)                                                
      TET(2,4)=IACHT(7)                                                
      TET(3,4)=IACHT(5)                                                
      TET(2,5)=IACHT(5)                                                
      TET(3,5)=IACHT(6)                                                
      TET(2,6)=IACHT(6)                                                
      TET(3,6)=IACHT(2)                                                
                                                                      
      do i=1,4                                                       
      do J=1,6                                                       
         TET0(1,i,J)=(TET(i,J)-1)/4                                        
         TET0(2,i,J)=(TET(i,J)-TET0(1,i,J)*4-1)/2                          
         TET0(3,i,J)=TET(i,J)-TET0(1,i,J)*4-TET0(2,i,J)*2-1                
        enddo
        enddo

      return                                                            
      end                                                               



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


      subroutine TETCNT(TET0,n)
!     **  TETCNT CALCULATES ALL DIFFERENT TETRAHEDRA AND COUNTS THEM  **
!     **  INPUT :                                                     **
!     **    nmshp       NUMBER OF SUBLATTICE POINTS INSIDE AND        **
!     **                ON ALL FACES OF A REC. UNIT CELL              **
!     **    num(i)      MAPPING FROM A GENERAL POINT (i) TO THE       **
!     **                CORRESPONDING IRREDUCIBLE POINT (num)         **
!     **    TET0(i,J,K) COORDINATES (i) in THE BASIS OF SUBLATTICE   ** 
!     **                VECTORS, OF THE 4 CORNERS (J) OF A           ** 
!     **                TETRAHEDRON (K) in A SUBLATTICE UNIT CELL    ** 
!     **    n           NUMBER OF DIVISIONS OF REC. LATTICE VECTORS   **
!     **    NKP         NUMBER OF IRREDUCIBLE K-POINTS                **
!     **    MWRIT       INFORMATION FOR MWRIT TETRAHEDRA ARE WRITTEN  **
!     **                AT ONE TIME.                                  **
      use kgenwork
        use controlkgen
        use tetrahedra
      implicit none
        integer,intent(in) :: n(3)   
      integer TET0(3,4,6)
      integer ntt,nrec,mwrittest
        integer i,ind,ip,ipp,isvar1,isvar2,ixx,j,jmax,k,k1,k2,k3,l,m,ni,&
     &            nkitest,ntmax
      real*8 sum,v
      integer,parameter :: ICHK=0
        
      call init_tetrahedra(n(3),nkf)               
        
                                                        
      NTMAX=n(1)*n(2)*n(3)*6                                            
      IPP=0                                                             
      do K1=1,n(1)                                                   
      do K2=1,n(2)                                                   
         IND=0                                                             

         do K3=1,n(3)     
            IP=K3+(n(3)+1)*((K2-1)+(n(2)+1)*(K1-1))                           
                                                                        
            do i=1,6                                                       
            IND=IND+1                                                         
            do J=1,4                                                       
            IXX=TET0(1,J,i)*(n(2)+1)*(n(3)+1)+TET0(2,J,i)*(n(3)+1)      &
     &                 +TET0(3,J,i)                                                   
            ITET(J,IND)=IP+IXX                                                
            enddo
              enddo
           enddo                                                          
                                                                        
!     --  TRANSFORM THE EDGEPOINTS ONTO THE IRREDUCIBLE POINTS          
         do M=1,4                                                       
         do J=1,n(3)*6                                                  
             ITET(M,J)=linkw(ITET(M,J))                                          
         enddo
           enddo
                                                                        
!     --  ORDER THE POINTS OF EACH TETR. ACC. TO INREASING NUMBER       
         do K=1,3                                                       
         do J=K+1,4                                                     
         do L=1,n(3)*6                                                  
            ISVAR1=ITET(K,L)                                                  
            ISVAR2=ITET(J,L)                                                  
            ITET(K,L)=min0(ISVAR1,ISVAR2)                                     
            ITET(J,L)=max0(ISVAR1,ISVAR2)                                     
         enddo
           enddo
           enddo
                                                               
!     --  IDENTIFY THE TETRAHEDRA WITH INTEGERS                         
         do M=1,n(3)*6
            IPP=IPP+1                                                         
            IY(1,IPP)=ITET(1,M)
            IY(2,IPP)=ITET(2,M)
            IY(3,IPP)=ITET(3,M)
            IY(4,IPP)=ITET(4,M)
         enddo
         if(IPP.GE.NTMAX) then                                             
            IPP=NTMAX                                                       
            goto 100                                                        
         end if                                                            
                                                                      
      enddo
        enddo

      print*,'UNNORMAL end OF LOOP.......................STOP in TETCNT'
      STOP                                                              
                                                                        
100   continue                                                          
!     ------------------------------------------------------------------
!     --  ORDER TETRAHEDRA                                            --
!     ------------------------------------------------------------------
      NTET=IPP                                                          
      call ORD1(NTET,IY)

!     ==  CHECK ORDERING AND CALCULATE NUMBER OF INEQUIVALENT TETRAHEDRA
      NTT=1                                                             
      do i=1,NTET-1                                                 
         NTT=NTT+1                                                         
         if(IY(4,i+1).eq.IY(4,i)) then                                     
         if(IY(3,i+1).eq.IY(3,i)) then                                     
         if(IY(2,i+1).eq.IY(2,i)) then                                     
         if(IY(1,i+1).eq.IY(1,i)) then                                     
            ntt=ntt-1
         end if
         end if
         end if
         end if
      enddo
!      write(66,1018) NTT                                                 
1018  format(1H ,'NUMBER OF DIFFERENT TETRAHEDRA :',I5)                 
!     ------------------------------------------------------------------
!     --  write ON FILE                                               --
!     ------------------------------------------------------------------
      if((ntt/mwrit)*mwrit.eq.ntt) then
         NREC=NTT/MWRIT  
      else
         NREC=NTT/MWRIT+1
      end if                                                            
      V=1.D0/dble(6*n(1)*n(2)*n(3))                                     
      SUM=V*dble(NTET)                                          
      if(DABS(SUM-1.D0).GT.1.d-5) then                                  
        print*,'SUMRULE NOT FULLFILLED...................STOP in TETCNT'
        print*,' SUM ',SUM,' SHOUD BE EQUAL TO 1'                       
        STOP                                                            
      end if
                                                                    
      REWIND 15                                                         
      write(15,1234) nki,NTT,V,MWRIT,NREC                                
      NTT=0                                                             
      NREC=0
        ittfl=0                                                            
      do i=1,NTET                                                   
         if(i.eq.1) then
             NTT=NTT+1                                                       
                                                                        
             if(NTT.GT.MWRIT*(NREC+1)) then                                  
                NREC=NREC+1                                                  
                write(15,1235)(ITTFL(J),J=1,5*MWRIT)  
        		  ittfl=0                       
             end if                                                          
                                                                        
             NI=5*(NTT-1-NREC*MWRIT)                                         
             ITTFL(NI+1)=1                                               
             ITTFL(NI+2)=IY(1,i)
             ITTFL(NI+3)=IY(2,i)
             ITTFL(NI+4)=IY(3,i)
             ITTFL(NI+5)=IY(4,i)
           else if(IY(1,i).eq.IY(1,i-1).and.IY(2,i).eq.IY(2,i-1)        &
     &   .and.IY(3,i).eq.IY(3,i-1).and.IY(4,i).eq.IY(4,i-1)) then         
            NI=5*(NTT-1-NREC*MWRIT)+1                                       
            ITTFL(NI)=ITTFL(NI)+1                                       
         else 
            NTT=NTT+1                                                       
                                                                        
            if(NTT.GT.MWRIT*(NREC+1)) then                                  
               NREC=NREC+1                                                  
               write(15,1235)(ITTFL(J),J=1,5*MWRIT)                         
               ittfl=0
            end if                                                          
                                                                        
            NI=5*(NTT-1-NREC*MWRIT)                                         
            ITTFL(NI+1)=1                                               
            ITTFL(NI+2)=IY(1,i)
            ITTFL(NI+3)=IY(2,i)
            ITTFL(NI+4)=IY(3,i)
            ITTFL(NI+5)=IY(4,i)
                                                                     
         end if                                                            
      enddo                                                          
      NREC=NREC+1                                                       
      write(15,1235)ITTFL                                               
                                                                        
      if(ICHK.eq.0) return                                              
!     ------------------------------------------------------------------
!     --  CHECK OF i/O                                                --
!     ------------------------------------------------------------------
      REWIND(15)  
      read(15,1234) nkitest,NTT,V,MWRITtest,NREC     
        if(mwrittest.ne.mwrit) stop 'mwrit is wrong in tetcnt'              
        if(nkitest.ne.nki) stop 'nki is wrong in tetcnt'
 1234 format(2i10,e20.12,2i10) 
      SUM=dble(0)
                                                                  
      do i=1,NREC                                                   
         ittfl=0
         read(15,1235)(ITTFL(J),J=1,5*MWRIT)                               
 1235    format(6i10)
         JMAX=5*min0(MWRIT,NTT-(i-1)*MWRIT)                                
         do J=1,JMAX/5                                                 
            SUM=SUM+dble(ITTFL(5*(J-1)+1))*V                                  
         enddo
        enddo
                                                             
      if(DABS(SUM-1.D0).GT.1.d-5) then                                  
        print*,'SUMRULE NOT FULLFILLED...................STOP in TETCNT'
        print*,' SUM ',SUM,' SHOUD BE EQUAL TO 1'                       
        STOP                                                            
      end if                                                            
      return                                                            
      end                                                               




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





      subroutine bravais(latti,AX,BX,CX,rbas,gbas,afact,iarb,           &
     &  alpha,beta,gamma,ortho,v)
!      implicit real*8 (A-H,O-Z)
!     **                                                              **
!     **  CONSTRUCTION OF TRANSLATION VECTORS : rbas (AS COLUMNS)     **
!     **  AND RECIPROCAL LATTICE VECTORS      : gbas (AS ROWS   )     **
!     **   V: VOLUME OF THE BRILLOUIN ZONE                            **
!     **  INPUT IS THE NAME OF THE BRAVAIS LATTICE ACCORDING TO       **
!     **  TABLE 3.3 OF BRADLEY AND CRACKNELL : THE MATHEMATICAL       **
!     **  THEORY OF SYMMETRY in SOLIDS (OXFORD)                       **
!     ..................................................................
!:UB  The direct lattice vectors     : ai = rbas(i,*)
!:UB  The reciprocal lattice vectors : bi = gbas(*,i)
!:UB           redefined by GBASS as : bi = gbas(i,*) !
!:UB  if( ndiv1 = ndiv2 ) iarb(1) = 1
!:UB  if( ndiv1 = ndiv3 ) iarb(2) = 1
!:UB  if( ndiv2 = ndiv3 ) iarb(3) = 1
!:UB  ..................................................................
      implicit none
      real*8,intent(out) ::     gbas(3,3),rbas(3,3),v
        real*8,intent(inout) ::   ax,bx,cx
        real*8,intent(in) ::      alpha,beta,gamma
        integer,intent(out) ::    iarb(3)
      character*3,intent(in) :: latti
      logical,intent(out) :: ortho
      real*8 eps(3,3,3),det,ay,az,by,bz,cy,cz,pi,a1,a2,cosg1,afact,     &
     &   gamma0
        integer i,j,k

      eps=dble(0)
      afact=dble(1)
        iarb=1
        gbas=dble(0)
        rbas=dble(0)
      det=dble(0)
      ay=dble(0)
      az=dble(0)
      by=dble(0)
      bz=dble(0)
      cy=dble(0)
      cz=dble(0)

      
        if (latti(1:1).eq.'H') then

!        HEXAGONAL : GH
         rbas(1,1)=AX*sqrt(.75E0)
         rbas(1,2)=-AX/2.
         rbas(2,2)=AX
         rbas(3,3)=CX
         iarb(2)=0
         iarb(3)=0
         ortho=.FALSE.

        elseif (latti(1:1).eq.'F') then

!        ORTHOROMBIC : GOF
         AX=AX*0.5E0
         BX=BX*0.5E0
         CX=CX*0.5E0
         rbas(1,2)=BX
         rbas(1,3)=CX
         rbas(2,1)=AX
         rbas(2,3)=CX
         rbas(3,1)=AX
         rbas(3,2)=BX
         afact=0.5
         ortho=.TRUE.

        elseif (latti(1:1).eq.'B') then

!        ORTHORHOMBIC : GOV
         AX=AX*0.5E0
         BX=BX*0.5E0
         CX=CX*0.5E0
         rbas(1,1)=-AX
!        ai = rbas(i,*) >>
         rbas(1,2)=BX
         rbas(1,3)=CX
         rbas(2,1)=+AX
         rbas(2,2)=-BX
         rbas(2,3)=+CX
         rbas(3,1)=AX
         rbas(3,2)=+BX
         rbas(3,3)=-CX
         afact=0.5
         ortho=.TRUE.

        elseif ((latti(1:1).eq.'P'.and.abs(gamma-1.570796d0).gt.0.0001) &
     &    .or.(latti(1:1).eq.'P'.and.abs(beta-1.570796d0).gt.0.0001)    &
     &    .or.(latti(1:1).eq.'P'.and.abs(alpha-1.570796d0).gt.0.0001)) then

!     TRICLINIC : GT
         cosg1=(cos(gamma)-cos(alpha)*cos(beta))/sin(alpha)/sin(beta)
         gamma0=acos(cosg1)
         rbas(1,1)=AX*sin(gamma0)*sin(beta)
         rbas(1,2)=AX*cos(gamma0)*sin(beta) 
         rbas(2,2)=BX*sin(alpha)
         rbas(1,3)=AX*cos(beta)
         rbas(2,3)=BX*cos(alpha)
         rbas(3,3)=CX
         iarb=0
         ortho=.FALSE.

      elseif ((latti(1:1).eq.'C'.and.abs(gamma-1.570796d0).gt.0.0001)   &
     &        .or.       (latti(1:3).eq.'MXZ')) then

!        MONOCLINIC : GMB
!        AX = A * SIN(GAMMA) / 2
!        AY = A * COS(GAMMA) / 2
!        CX = C / 2
!        ay=ax(orig)*cos(gamma)/2 thus ay must be evaluated first
         ay=ax*cos(gamma)/2.
         ax=ax*sin(gamma)/2.
         cx=cx/2.
         rbas(1,1)=ax
         rbas(1,2)=ay
         rbas(1,3)=-cx
         rbas(2,2)=bx
         rbas(3,1)=aX
         rbas(3,2)=ay
         rbas(3,3)=CX
         iarb(1)=0
!:UB[    |b1| = |b3|
         iarb(3)=0
         ortho=.FALSE.

      elseif ((latti(1:1).eq.'S').or.(latti(1:1).eq.'P')) then

!        ORTHORHOMBIC : GO
         rbas(1,1)=AX
         rbas(2,2)=BX
         rbas(3,3)=CX
         iarb=0
         ortho=.TRUE.

        elseif (latti(1:1).eq.'C') then

!        ORTHORHOMBIC : GOB
         if(latti(2:3).eq.'XZ') then
  
            rbas(1,1)=AX*0.5E0
!           ai = rbas(i,*) >>
            rbas(1,3)=-CX*0.5E0
            rbas(3,1)=AX*0.5E0
            rbas(3,3)=CX*0.5E0
            rbas(2,2)=BX
            iarb(1)=0
            iarb(3)=0
            ortho=.TRUE.
 
         elseif(latti(2:3).eq.'YZ') then

            rbas(2,2)=BX*0.5E0
!           ai = rbas(i,*) >>
            rbas(2,3)=-CX*0.5E0
            rbas(3,2)=BX*0.5E0
            rbas(3,3)=CX*0.5E0
            rbas(1,1)=AX
            iarb(1)=0
            iarb(2)=0
            ortho=.TRUE.

         else

            rbas(1,1)=AX*0.5E0
!           ai = rbas(i,*) >>
            rbas(1,2)=-BX*0.5E0
            rbas(2,1)=AX*0.5E0
            rbas(2,2)=BX*0.5E0
            rbas(3,3)=CX
            iarb(2)=0
            iarb(3)=0
            ortho=.TRUE.

         endif

        elseif(latti(1:3).eq.'M  ') then

!        MONOCLINIC : GM
!        AX = A * SIN(GAMMA)
!        AY = A * COS(GAMMA)
         a1=ax*sin(gamma)
         a2=ax*cos(gamma)
         rbas(1,1)=a1
         rbas(1,2)=a2
         rbas(2,2)=bx
         rbas(3,3)=CX
         iarb=0
         ortho=.FALSE.

        elseif(latti(1:1).eq.'R') then

!        TRIGONAL : GRH
         rbas(1,1)=ax/2.d0/sqrt(3.d0)
         rbas(1,2)=-AX/2.d0
         rbas(1,3)=CX/3.d0
         rbas(2,1)=AX/2.d0/sqrt(3.d0)
         rbas(2,2)=AX*0.5E0
         rbas(2,3)=CX/3.d0
         rbas(3,1)=-AX/sqrt(3.d0)
         rbas(3,2)=0.d0
         rbas(3,3)=CX/3.d0
         ortho=.FALSE.

        else

!        CUBIC : GCV
         AX=AX*0.5E0
         rbas(1,1)=-AX
         rbas(2,1)=AX
         rbas(3,1)=AX
         rbas(1,2)=AX
         rbas(2,2)=-AX
         rbas(3,2)=AX
         rbas(1,3)=AX
         rbas(2,3)=AX
         rbas(3,3)=-AX
         afact=0.5
         ortho=.TRUE.

        endif

      do J=1,3
!:UB[ << ai = rbas(i,*) >>
!         write (66,240) J,(rbas(J,i),i=1,3)
      enddo

! Careful : below, gbas is calculated.  However, in wien, this gbas is not used
! (at least not in the kgen program).  So I am not 100 % sure about consistency
! with other data, although comments in the first lines of this file claim it is
! just the transpose of what it 'should' be.
  240 format (1H ,' R',I1,' = ',3F10.6)
      pi=4.*ATAN(1.)
      EPS(1,2,3)=1.E0
      EPS(2,3,1)=1.E0
      EPS(3,1,2)=1.E0
      EPS(1,3,2)=-1.E0
      EPS(3,2,1)=-1.E0
      EPS(2,1,3)=-1.E0
      do i=1,3
      do J=1,3
      do K=1,3
         det=det+EPS(i,J,K)*rbas(1,i)*rbas(2,J)*rbas(3,K)
         gbas(i,1)=gbas(i,1)+EPS(i,J,K)*rbas(2,J)*rbas(3,K)
         gbas(i,2)=gbas(i,2)+EPS(i,J,K)*rbas(3,J)*rbas(1,K)
         gbas(i,3)=gbas(i,3)+EPS(i,J,K)*rbas(1,J)*rbas(2,K)
      enddo
        enddo
        enddo
      do i=1,3
      do J=1,3
         gbas(J,i)=2*pi*gbas(J,i)/det
      enddo
        enddo
      V=(2*pi)**3/det
290   format (1H ,' G',I1,' = ',3F10.6)
!      write (66,300) iarb
300   format (1H ,' DEPENDENCE OF DIVISION OF TRANSLATION VECTORS iarb=' ,3I3)
      return
      end



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


      subroutine divisi(idkp,nkp,idiv,klist)
      implicit none
        integer,intent(in) ::    idkp,nkp
        integer,intent(out) ::   klist(idkp,3)
        integer,intent(inout) :: idiv
      integer,parameter ::     nprim=16
      integer,parameter ::     niter=10
        integer iprim(nprim),idivi,ip,ik,ir,idummy,itest

      idivi=1
        iprim(1)=2
        iprim(2)=3
        iprim(3)=5
        iprim(4)=7
      iprim(5)=11      
      iprim(6)=13     
      iprim(7)=17     
      iprim(8)=19     
      iprim(9)=23     
      iprim(10)=29     
      iprim(11)=31     
      iprim(12)=37     
      iprim(13)=41     
      iprim(14)=43     
      iprim(15)=47     
      iprim(16)=53 
!    
        do ip=1,nprim
         do idummy=1,niter
            do ik=1,nkp 
              do ir=1,3
                 itest=mod(klist(ik,ir),iprim(ip))
                 if (itest.ne.0) goto 1
            enddo
              enddo

            idivi=idivi*iprim(ip)
            do ik=1,nkp 
              do ir=1,3
               klist(ik,ir)=klist(ik,ir)/iprim(ip)
            enddo
        	  enddo
         enddo
      enddo
1     continue
      idiv=idiv/idivi
      if(idiv.eq.0) idiv=1
      return
        end


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


      subroutine GBASS(rbas,gbas)                                       
!     **  CALCULATE RECIPROCAL LATTICE VECTORS FROM real SPACE        **
!     **  LATTICE VECTORS OR VICE VERSA                               **

      implicit none
      real*8,intent(in) ::  rbas(3,3)
        real*8,intent(out) :: gbas(3,3)
        real*8 pi,det
        integer i
      pi=4.D0*DATAN(1.D0)                                               
      gbas(1,1)=rbas(2,2)*rbas(3,3)-rbas(3,2)*rbas(2,3)                 
      gbas(2,1)=rbas(3,2)*rbas(1,3)-rbas(1,2)*rbas(3,3)                 
      gbas(3,1)=rbas(1,2)*rbas(2,3)-rbas(2,2)*rbas(1,3)                 
      gbas(1,2)=rbas(2,3)*rbas(3,1)-rbas(3,3)*rbas(2,1)                 
      gbas(2,2)=rbas(3,3)*rbas(1,1)-rbas(1,3)*rbas(3,1)                 
      gbas(3,2)=rbas(1,3)*rbas(2,1)-rbas(2,3)*rbas(1,1)                 
      gbas(1,3)=rbas(2,1)*rbas(3,2)-rbas(3,1)*rbas(2,2)                 
      gbas(2,3)=rbas(3,1)*rbas(1,2)-rbas(1,1)*rbas(3,2)                 
      gbas(3,3)=rbas(1,1)*rbas(2,2)-rbas(2,1)*rbas(1,2)                 
      det=0.D0                                                          
      do i=1,3                                                      
         det=det+gbas(i,1)*rbas(i,1)                                       
      enddo                                                          
      gbas=gbas*2.D0*pi/det                                   
      return                                                            
      end                                                               


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

      subroutine ORD1(nmax,IX)                                     
!     **  ORD1 ORDERS THE ARRAY IX WITH SIZE nmax ACCORDING TO  INCREASING NUMBER   **
!     **  SUBROUTINES USED:            indexx (from Numerical recipes)               **
      implicit none
        integer,intent(in) :: nmax
        integer,intent(inout) :: ix(4,nmax)
      integer WORK(nmax),index(nmax)
        integer i,i2,i3,i4,ichang
      
!     sort first index of ix
      work=ix(1,:)
      call indexx(work,index,nmax)
      do i=1,nmax
         ix(1,i)=work(index(i))
      enddo
      work=ix(2,:)
      do i=1,nmax
         ix(2,i)=work(index(i))
        enddo
      work=ix(3,:)
      do i=1,nmax
         ix(3,i)=work(index(i))
      enddo
      work=ix(4,:)
      do i=1,nmax
         ix(4,i)=work(index(i))
      enddo
! 
!     sort higher indices with trivial procedure
 501  ichang=0
      do i=2,nmax
      if(ix(1,i).eq.ix(1,i-1)) then
          if(ix(2,i).lt.ix(2,i-1)) then
          i2=ix(2,i-1)
          i3=ix(3,i-1)
          i4=ix(4,i-1)
          ix(2,i-1)=ix(2,i)
          ix(3,i-1)=ix(3,i)
          ix(4,i-1)=ix(4,i)
          ix(2,i)=i2
          ix(3,i)=i3
          ix(4,i)=i4
          ichang=1
          else if(ix(2,i).eq.ix(2,i-1)) then
            if(ix(3,i).lt.ix(3,i-1)) then
            i3=ix(3,i-1)
            i4=ix(4,i-1)
            ix(3,i-1)=ix(3,i)
            ix(4,i-1)=ix(4,i)
            ix(3,i)=i3
            ix(4,i)=i4
            ichang=1
            else if(ix(3,i).eq.ix(3,i-1)) then
              if(ix(4,i).lt.ix(4,i-1)) then
              i4=ix(4,i-1)
              ix(4,i-1)=ix(4,i)
              ix(4,i)=i4
              ichang=1
              end if
            end if
          end if
      end if
      enddo
      if(ichang.eq.1) goto 501
      return                                                            
      end                                                               


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

      subroutine indexx(arrin,indx,n)
!     sort with heapspot (from Numerical Recipes, p.233)
      implicit none
        integer,intent(in) :: n,arrin(n)
        integer,intent(out) :: indx(n)
        integer q,j,l,ir,indxt,i

      do j=1,n
         indx(j)=j
      enddo
      L=n/2+1
      ir=n

  10  continue
      if(L.gt.1) then
         l=l-1
         indxt=indx(l)
         q=arrin(indxt)            
      else
         indxt=indx(ir)
         q=arrin(indxt)
         indx(ir)=indx(1)
         ir=ir-1
         if(ir.eq.1) then
            indx(1)=indxt
            return
         endif
      endif
      i=l
      j=l+l
  20  if(j.le.ir) then
         if(j.lt.ir) then
            if(arrin(indx(j)).lt.arrin(indx(j+1))) j=j+1
         end if
         if(q.lt.arrin(indx(j))) then
            indx(i)=indx(j)
            i=j
            j=j+j
         else
            j=ir+1
         end if
         goto 20
      end if
      indx(i)=indxt
      goto 10
      end    


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

      subroutine sdef(iio,nsym,lattic)
!    redefines symmetry operation to include cxz and cyz
!    bravais lattices (from cxy)
!
      implicit none
      character*3,intent(in) :: lattic
        integer,intent(in) ::     nsym
      integer,intent(inout) ::  iio(3,3,48)
      integer ihelp,j

      if(LATTIc(1:3).eq.'CXZ'.or.LATTIc(1:3).eq.'BO ') then
         do j=1,nsym
            ihelp=iio(2,2,j)                                   
            iio(2,2,j)=iio(3,3,j)
            iio(3,3,j)=ihelp
            ihelp=iio(1,2,j)                                   
            iio(1,2,j)=iio(1,3,j)
            iio(1,3,j)=ihelp
            ihelp=iio(2,3,j)                                   
            iio(2,3,j)=iio(3,2,j)
            iio(3,2,j)=ihelp
            ihelp=iio(2,1,j)                                   
            iio(2,1,j)=iio(3,1,j)
            iio(3,1,j)=ihelp
         enddo
      else if(LATTIc(1:3).eq.'CYZ'.or.LATTIc(1:3).eq.'AO ') then
         do j=1,nsym
            ihelp=iio(1,1,j)                                   
            iio(1,1,j)=iio(3,3,j)
            iio(3,3,j)=ihelp
            ihelp=iio(1,2,j)                                   
            iio(1,2,j)=iio(3,2,j)
            iio(3,2,j)=ihelp
            ihelp=iio(1,3,j)                                   
            iio(1,3,j)=iio(3,1,j)
            iio(3,1,j)=ihelp
            ihelp=iio(2,3,j)                                   
            iio(2,3,j)=iio(2,1,j)
            iio(2,1,j)=ihelp
         enddo
      end if
      return
      end


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

      subroutine sdefl(rbas,gbas,iio,nsym,iz,lattic,ortho)
!    redefines symmetry operation from lapw-struct with unitary transformation  u(-1) * S * u

      implicit none 
      logical,intent(in) :: ortho
      character*3,intent(in) :: lattic                
      integer,intent(out) :: iio(3,3,48)
        integer,intent(in) :: iz(3,3,48),nsym
        real*8,intent(in) :: rbas(3,3),gbas(3,3)
      real*8 gbas1(3,3),pi,a(3,3),b(3,3)
        integer i,j,k,ind,i1,i2,i3,i4
      pi=acos(-1.d0)
    
      do i=1,3
      do j=1,3          
         gbas1(j,i)=gbas(i,j)/2.d0/pi
        enddo
        enddo
 
      do ind=1,nsym 
         a=iz(:,:,ind)
         if(ortho.or.(.not.ortho.and.lattic(1:3).eq.'CXZ')) then
             call matmm(b,rbas,a)
             call matmm(a,b,gbas1)
         end if
         do i=1,3;do j=1,3
             iio(i,j,ind)=nint(a(i,j))
         enddo;enddo
      enddo
!     Write symm matrices iio to file 66 :
      do i=1,int(FLOAT(nsym)/4.+.9)                                 
         I1=4*i-3                                                          
         I2=4*i-2                                                          
         I3=4*i-1                                                          
         I4=4*i                                                            
 !        write (66,120) I1,I2,I3,I4                                        
         do J=1,3                                                      
 !           write (66,140) (Iio(J,K,I1),K=1,3),(IiO(J,K,I2),K=1,3),     &
 !    &         (IiO(J,K,I3),K=1,3),(IiO(J,K,I4),K=1,3)                          
         enddo
        enddo                                                          

  120 format (T5,'SYMMETRY MATRIX NR.',I3,T30,'SYMMETRY MATRIX NR.'     &
     &  ,I3,T55,'SYMMETRY MATRIX NR.',I3,T80,'SYMMETRY MATRIX NR.',I3)   
  140 format (T5,3I5,T30,3I5,T55,3I5,T80,3I5)                           
      return
      end


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

      subroutine  MATMM (C,A,B)                                        
!     FORM C = A B, WHERE C MAY OVERLAP WITH EITHER A OR B, OR BOTH,    
!     SINCE THE PRODUCT IS DEVELOPED in A TEMPORARY MATRIX.             
      real*8  A(3,3),AB(3,3),B(3,3),C(3,3)    
      AB(1,1) = A(1,1)*B(1,1)+A(1,2)*B(2,1)+A(1,3)*B(3,1)
      AB(1,2) = A(1,1)*B(1,2)+A(1,2)*B(2,2)+A(1,3)*B(3,2)
      AB(1,3) = A(1,1)*B(1,3)+A(1,2)*B(2,3)+A(1,3)*B(3,3)
      AB(2,1) = A(2,1)*B(1,1)+A(2,2)*B(2,1)+A(2,3)*B(3,1)
      AB(2,2) = A(2,1)*B(1,2)+A(2,2)*B(2,2)+A(2,3)*B(3,2)
      AB(2,3) = A(2,1)*B(1,3)+A(2,2)*B(2,3)+A(2,3)*B(3,3)
      AB(3,1) = A(3,1)*B(1,1)+A(3,2)*B(2,1)+A(3,3)*B(3,1)
      AB(3,2) = A(3,1)*B(1,2)+A(3,2)*B(2,2)+A(3,3)*B(3,2)
      AB(3,3) = A(3,1)*B(1,3)+A(3,2)*B(2,3)+A(3,3)*B(3,3)
      C(1,1) = AB(1,1)                                                  
      C(2,1) = AB(2,1)                                                  
      C(3,1) = AB(3,1)                                                  
      C(1,2) = AB(1,2)                                                  
      C(2,2) = AB(2,2)                                                  
      C(3,2) = AB(3,2)                                                  
      C(1,3) = AB(1,3)                                                  
      C(2,3) = AB(2,3)                                                  
      C(3,3) = AB(3,3)                                                  
      return                                                            
      end                                                               


!****************************************************************************** 
 
      subroutine reasym(fn,nsym,sym,sym4)
!   read symmetry operations from wien2k case.struct formatted file

      implicit none
!  INPUT
      character*20,intent(in) :: fn  ! file to use
!  OUTPUT
      integer,intent(out) :: nsym   ! number of symmetry operations
      integer,intent(out) :: sym(3,3,48)  !  rotation matrices
        real*8,intent(out)  :: sym4(3,48)   !  translation vectors
!  LOCALS
        integer j,j1,j2

      open(20,file=fn,form='formatted',status='old')
      read(20,1151) nsym                                                
      do j=1,nsym                                                     
         read(20,1101) ( (sym(J1,J2,J),J1=1,3),sym4(J2,J),J2=1,3 )
      enddo
 
      close(20)
        return
1101  format(3(3I2,F10.7,/)) 
1151  format(I4) 
        end



    
 
 

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: kpreppot.f90,v $:
! $Revision: 1.12 $
! $Author: jorissen $
! $Date: 2012/02/04 00:38:51 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine kpreppot !KJ for mod2 and mod3, use : subroutine kprep(em,ne,nex)


        use struct,lat=>alat
        use kklist
        use strfacs
        use workstrfacs
        use workstrfacs2
      use boundaries
        use wigner3j
        use trafo
        use controls,only : allocated,irel
        use kgenwork
        use energygrid

      implicit none
!KJ for mod2 and mod3, use
!      integer,intent(in) :: ne,nex
!      complex*16,intent(in) :: em(nex)
!KJ for mod1, use
      integer ne  !LOCAL
!KJ

! LOCALS
      integer l1,mm,isp1,j1,j2,j3p,j3m,m1,m2
        real*8,external :: cwig3j
        logical,parameter :: debug=.false.
! For structure factors :
        integer i,iq,il,a,na,ia,b,nb,ib
      integer NK,NKM
      integer,allocatable :: NLQ(:),LTAB(:),KAPTAB(:),NMUETAB(:)
      real*8 ALAT,BOA,COA,VOL,FACT(0:100),etop,gmulti,rmulti
      real*8,allocatable :: CGC(:,:)
      complex*16,allocatable :: crellocal(:,:),rclocal(:,:),rrellocal(:,:)
      complex*16 w1(2*(maxl+1)**2,2*(maxl+1)**2),w2(2*(maxl+1)**2,2*(maxl+1)**2)


!     debugging
      integer j,k,ik,l
      real*8 wiensym(3,3,48),dif
        logical addi,rtoc,fromrel

      nsym=1
        if(usesym.eq.1) nsym=48


!  debugging
      if (debug) open(101,file='instrfeff.txt')

!#######################################################################
!       FIRST:    INITIALIZE DIMENSIONS 
!#######################################################################


!      write(*,*) 'KPREPPOT ======'
!	  write(*,*) 'nats',nats
!	  write(*,*) 'lpot',lpot

      maxl=0
      do i=0,nph
         maxl=max(maxl,lpot(i))
      enddo

      nl=maxl+1
      msize=nsp*nats*(maxl+1)**2
      mls=nsp*(maxl+1)**2

!Note that a fair amount of allocations was moved to strvecgen (workstrfacs,workstrfacs2 - 2/2012) KJ
      if (.not.allocated) then
         call init_strfacs
         call init_boundaries(maxl,nats)
!	      call init_gk(msize,nkp)
         call init_workstrfacs(nats)
         call init_workstrfacs2
         call init_wigner3j(maxl)
         call init_trafo(mls)
         allocated=.true.
      endif


!KJ In mod3 or mod2,use the following :
!** PROCESS energy grid
!	   call init_energygrid(ne)
!      egrid=em(1:ne)
!	emin=dcmplx(500,0)
!	emax=-emin
!	do i=1,ne
!	   if(dble(emin-em(i)).gt.0) emin=em(i)
!	   if(dble(em(i)-emax).gt.0) emax=em(i)
!	enddo
!	write(6,*) 'emin,emax',emin,emax
!KJ In mod1, use
      ne=80
        call init_energygrid(ne)
        emin=dble(-3)  !strvecgen needs emin and emax
        emax=dble(3)
!        write(6,*) 'emin,emax',emin,emax
!KJ

!* STRUCTURE
      ALAT = lat(1)
      BOA = lat(2)/lat(1)
      COA = lat(3)/lat(1)

      brx=bramat(:,1)
        bry=bramat(:,2)
        brz=bramat(:,3)

      brx(1)=a1(1)
        brx(2)=a2(1)
        brx(3)=a3(1)
      bry(1)=a1(2)
        bry(2)=a2(2)
        bry(3)=a3(2)
      brz(1)=a1(3)
        brz(2)=a2(3)
        brz(3)=a3(3)
      brx=brx /alat
        bry=bry /alat
        brz=brz /alat


        qx(1:nats)=ppos(1,1:nats)  ! I believe these need to be in CARTHESIAN fractional coordinates
        qy(1:nats)=ppos(2,1:nats)
        qz(1:nats)=ppos(3,1:nats)

!* CALCULATION
! In SPRKKR, irel takes values from 0 to 4.  For the routines used here, only > or < 2 matters.
      if (nsp.le.1) then
           irel=1
        elseif (nsp.gt.1) then
           irel=3
        endif
!  Next variables allow to expand the clusters used for the calculation of the structure constants
!  in real (rmulti) and reciprocal (gmulti) space.
        rmulti = dble(1)
        gmulti = dble(1)



! allocate some locals
      allocate(NLQ(NQMAX),LTAB(NMUEMAX), KAPTAB(NMUEMAX),NMUETAB(NMUEMAX),CGC(NKMPMAX,2) )
      allocate(crellocal(nkmmax,NKMMAX),rclocal(NKMMAX,NKMMAX), rrellocal(NKMMAX,NKMMAX))


      if(debug) then
      write(101,*) 'alat,boa,coa','alat,boa,coa'
        write(101,*) 'brx',brx
        write(101,*) 'bry',bry
        write(101,*) 'brz',brz
        write(101,*) 'qx',qx
        write(101,*) 'qy',qy
        write(101,*) 'qz',qz
        write(101,*) 'irel',irel
        write(101,*) 'nl ',nl
        endif


!*************************************************************************************
! Construct the reciprocal lattice - primitive vectors (BGX,BGY,BGZ) of reciprocal space
      DO I = 1,3
            Iq = 1 + MOD(I,3)
            Il = 1 + MOD(Iq,3)
            BGX(I) = BRY(Iq)*BRZ(Il) - BRZ(Iq)*BRY(Il)
            BGY(I) = BRZ(Iq)*BRX(Il) - BRX(Iq)*BRZ(Il)
            BGZ(I) = BRX(Iq)*BRY(Il) - BRY(Iq)*BRX(Il)
      END DO
      VOL = DABS(BRX(1)*BGX(1)+BRY(1)*BGY(1)+BRZ(1)*BGZ(1))
      DO I = 1,3
            BGX(I) = BGX(I)/VOL
            BGY(I) = BGY(I)/VOL
            BGZ(I) = BGZ(I)/VOL
      END DO

! Calculate the sum of the k-mesh integration weights to normalize integrals :
      sumweights=dble(0)
        do i=1,nkp
          sumweights=sumweights+weight(i)
        enddo


      FACT(0) = 1.0D0
      DO I=1,100
          FACT(I) = FACT(I-1) * DBLE(I)
      END DO
      NLQ(1:nqmax) = 0


!************************** For FEFF's t-matrix (in fms2) :
!     Calculate Clebsch-Gordon coefficients <LS|J>
      do l1 = 0, maxl  !KJ used to be lx instead of maxl 11-06
      do mm = -l1, l1
      do isp1 = 1, 2
        j1 = 2 * l1
        j2 = 1
        j3p = j1 + 1
        j3m = j1 - 1
        m1 = 2*mm
        m2 = 2*isp1 - 3
!  j = l+1/2
        t3jp( l1, mm, isp1) = sqrt( j3p + 1.0e0 ) *  real( cwig3j( j1, j2, j3p, m1, m2, 2) )
        if (mod( (j2-j1-m1-m2)/2 , 2) .ne.0)  t3jp( l1, mm, isp1) = - t3jp( l1, mm, isp1)
!  j = l-1/2
        t3jm( l1, mm, isp1) = sqrt( j3m + 1.0e0 ) *  real( cwig3j( j1, j2, j3m, m1, m2, 2) )
        if (mod( (j2-j1-m1-m2)/2 , 2) .ne.0)  t3jm( l1, mm, isp1) = - t3jm( l1, mm, isp1)
      enddo
        enddo
        enddo

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



!   ********************************************************************
!   *                                                                  *
!   *   rel. quantum numbers    up to                                  *
!   *                                                                  *
!   ********************************************************************
!                     s   p   p   d   d   f   f   g   g   h
!     DATA LTAB    /  0,  1,  1,  2,  2,  3,  3,  4,  4,  5 /
!     DATA LBTAB   /  1,  0,  2,  1,  3,  2,  4,  3,  5,  4 /
!     DATA KAPTAB  / -1,  1, -2,  2, -3,  3, -4,  4, -5,  5 /
!     DATA NMUETAB /  2,  2,  4,  4,  6,  6,  8,  8, 10, 10 /

      DO I = 1,NMUEMAX
         LTAB(I) = I/2
         IF( 2*LTAB(I) .EQ. I ) THEN
            KAPTAB(I) = LTAB(I)
         ELSE
            KAPTAB(I) = - LTAB(I) - 1
         END IF
         NMUETAB(I) = 2*ABS( KAPTAB(I) )
      END DO

! calculate some gaunt symbols before ltab and nmuetab get overwritten for non-sprel calcul.
      CALL CALCCGC( LTAB,KAPTAB,NMUETAB,CGC,NKMAX,NMUEMAX,NKMPMAX )

!=======================================================================
!                initialize tables of quantum numbers
!=======================================================================
      NLM  = NL**2
! Fix site specific momentum cutoffs
      DO IQ=1,nats
         NLQ(IQ) = NL   !KJ for now, here all sites get the same l-cutoff.  We could change this using lipotx or lpot.
         NKMQ(IQ) = 2*NLQ(IQ)**2
      ENDDO

      IF( IREL .LT. 2 ) THEN
!
!-------------------------------------- non-relativistic kkr-calculation

         DO 220 IQ=1,nats
         IF( IQ .EQ. 1 ) THEN
            IND0Q(IQ) = 0
         ELSE
            IND0Q(IQ) = IND0Q(IQ-1) + NLQ(IQ-1)**2
         END IF
         NKMQ(IQ)  = NLQ(IQ)**2

            DO 220 IL=1,NLMAX
            LTAB(IL)    = IL - 1
            NMUETAB(IL) = 2*LTAB(IL)+1

  220    CONTINUE


      ELSE
!------------------------------------------ relativistic kkr-calculation
         NK   = 2*NL-1
         NKM  = 2*NLM


         WRITE(6,108)
         I         = 0
         DO 230 IQ=1,nats
         IF( IQ .EQ. 1 ) THEN
            IND0Q(IQ) = 0
         ELSE
            IND0Q(IQ) = IND0Q(IQ-1) + 2*NLQ(IQ-1)**2
         END IF

 230     CONTINUE
!
      END IF


      if (debug) then
      write(101,*) 'ind0q',ind0q
        endif
!
!=======================================================================


      if(debug) WRITE(6,8)  ALAT,nats,NL,NLM,NK,NKM

    8 FORMAT(//,10X,'ALAT =',F10.6,//,                                 &
     &  10X,'nats =',I3,5X,'NL =',I3,5X,'NLM =',I4,5X,/,               &
     & 22X,'NK =',I3,5X,'NKM =',I4,5X,//)


!sssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssss
!                         structure constants
!sssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssss
      ETA= 0D0
      RMAX=0D0  
      GMAX=0D0
           !If eta=0, an algorithm in strinit will find a value automatically.  However, if the user set a value in feff.inp, use it here: 
		   ETA=streta

!KJ following section only used in mod2 and mod3
!      etop=dble(0)
!      do i=1,ne
!	  if(dabs(dble(em(i))).gt.etop)
!    1     etop=dabs(dble(em(i)))
!      enddo
!KJ in mod1, use
      etop=emax
!KJ

        etop=etop*2  ! SPRKKR works in Ry, FEFF in Ha

           CALL STRINIT(ETOP,nats,ALAT,FACT,CGC,gmulti,rmulti ) !KJ eliminating arguments that I think are unnecessary
!           CALL STRINIT( ETA, RMAX, GMAX,ETOP,                               &
!                &                 BRX,BRY,BRZ,R1,R2,R3,NRDLTAB,QX,QY,QZ,           &
!                &                 BGX,BGY,BGZ,G1,G2,G3,NGRLTAB,                    &
!                &                 nats,ALAT,FACT,CGC,gmulti,rmulti )



!     Reset icall - strcc won't actually calculate anything
      call STRCC(dcmplx(0),ALAT,.true.)  ! 1st argument etop chosen arbitrarily - doesn't matter if 3rd arg. = true

      if(debug) then
      write(101,*) 'eta ',eta
        write(101,*) 'rmax ',rmax
        write(101,*) 'gmax ',gmax
        write(101,*) 'etop ',etop
        write(101,*) 'qx',qx
        write(101,*) 'qy',qy
        write(101,*) 'qz',qz
      write(101,*) 'nats',nats
        write(101,*) 'cgc',cgc

      endif


      call bastrmat(maxl,CGC,rclocal,crellocal,rrellocal,nkmmax,nkmpmax)
        rc=rclocal(1:mls,1:mls)
        crel=crellocal(1:mls,1:mls)
        rrel=rrellocal(1:mls,1:mls)



      drot=dcmplx(0,0)
      call makerotations
        addi=.false.
        rtoc=.false.
        fromrel=.false.
      do i = 1,48
         w1=dcmplx(0,0)
           if(fromrel) then
              w2=drot(:,:,i,1)
            CALL CHANGEREP(w2,'REL>CLM',W1,nkmmax,nkmmax,RClocal,CRELlocal,RRELlocal,'          ',0)
              w2=w1
           else
            w2=drot(:,:,i,2)
           endif
!        Convert from SPRKKR basis to FEFF basis
!        For nsp=1 : from real to spherical harmonics
         if(rtoc) then
            call changerep(w2,'RLM>CLM',w1,nkmmax,nkmmax,rclocal,crellocal,rrellocal,'          ',0)	   
           else
             w1=w2
           endif
           if(addi) then
!        To get the normalization of the spherical harmonics right, add factor i^l :
              ia=0;ib=0
              do a=0,maxl;do na=-a,a;ia=ia+1;ib=0
              do b=0,maxl;do nb=-b,b;ib=ib+1
                 w1(ia,ib)=w1(ia,ib)*dcmplx(0,1)**(a-b)
              enddo;enddo
              enddo;enddo
           endif

         

         drot(:,:,i,2)=w1
      enddo

!!KJ debugging
!      open(78,file='symops_working.txt')
!	do i=1,48
!	write(78,*) i
!	do j=1,nkmmax
!	write(78,'(100f10.4)') drot(j,:,i,2)
!      enddo
!	enddo
!	close(78)
!!KJ



!     write(*,*) 'mls= ',mls
      allocate(mrot(mls,mls,48))
        if(nsp.le.1) then
           mrot=drot(1:mls,1:mls,1:48,2)
      else
           mrot=drot(1:mls,1:mls,1:48,1)
      endif





! kill some locals
      deallocate(NLQ,LTAB,KAPTAB,NMUETAB,CGC,crellocal,rrellocal,rclocal)

!     following section only works if you've already run kgen
      if(usesym.eq.1) then
         open(55,file='symops_kgen.txt',form='formatted')
!           write(*,*) 'possibly need transpose of cm ...'
           do i=1,4
              READ(55,*)
           enddo
           do i=1,nsym
              read(55,*)
              do j=1,3
                 read(55,*) j1,j2,j3p
                 wiensym(j,1,i)=dble(j1)
                 wiensym(j,2,i)=dble(j2)
                 wiensym(j,3,i)=dble(j3p)
!	         read(55,1019) wiensym(j,:,i)
              enddo
              do k=1,48
                 dif=dble(0)
                 do j=1,3
                 do l=1,3
                    dif=dif+dabs(wiensym(j,l,i)-mrotr(j,l,k)) !mrotr(l,j,k))
!	            dif=dif+dabs(wiensym(j,l,i)-mrotr(l,j,k)) !mrotr(l,j,k))
                 enddo
                 enddo
               if(dif.lt.0.0001) then
                    symid(1,k)=i  ! sprsym(:,:,k)=wiensym(:,:,symid(1,k))
                    symid(2,i)=k  ! wiensym(i)=sprsym(symid(2,i))
                 endif
              enddo
           enddo
           close(55)
1019     format(18x,5x,3f12.6)

         if(debug) then
            open(55,file='symidcheck.txt')
            do i=1,48
                 write(55,*) i,symid(2,i),'  wiensym - mrotr'
                 do j=1,3
                    write(55,1020) wiensym(j,:,i),mrotr(j,:,symid(2,i))
                 enddo
              enddo
              close(55)
1020        format (3f12.6,5x,3f12.6)
         endif
      endif !usesym=1


!    Process the k-mesh :
      if (usesym.eq.1) then
         write(*,*) 'nkp,nka,nki,nkf',nkp,nka,nki,nkf
!    Prepare a table that will help carry out the integral
         inti=0
           intn=0
           intw=dble(0)
           symact=0
         do ik=1,nkp
              do j=1,nkf
                 if(linkf(j).eq.ik)then
                  intn(ik)=intn(ik)+1
                    inti(ik,intn(ik),1)=j
                    inti(ik,intn(ik),2)=symid(2,lsymf(j))
                    symact(symid(2,lsymf(j)))=1
                    intw(ik,intn(ik))=wf(j)
                 endif
              enddo
           enddo
	   if(debug) then
              open(55,file='matchk.txt')
              do ik=1,nkp
                 write(55,*) 'K-POINT ',ik
                 do j=1,intn(ik)
                    write(55,*) inti(ik,j,1),inti(ik,j,2),intw(ik,j)
                 enddo
              enddo
              close(55)
	   endif
        endif



      if(debug) then
           open(44,file='bkf.txt')
           do i=1,nkf
              write(44,1818) i,bkf(:,i),wf(i),linkf(i),lsymf(i)
           enddo
           close(44)
           open(44,file='bkw.txt')
           do i=1,nkw
              write(44,1818) i,bkw(:,i),ww(i),linkw(i),lsymw(i)
           enddo
           close(44)
           open(44,file='bki.txt')
           do i=1,nki
              write(44,1818) i,bki(:,i),wi(i)
           enddo
           close(44)
1818     format(i5,4f14.4,2i5)
	endif


! kill some variables of the k-mesh that are no longer needed
      deallocate(bki,bki2,wi,wf,linkf) !lsymf
        if(usesym.ne.1) deallocate(bkf)
 !     if(debug) stop

      return
  108 FORMAT(1H ,/,                                                    &
     &10X,'RELATIVISTIC QUANTUM NUMBERS',/,                            &
     &10X,'============================',//,                           &
     &10X,' I  L  KAP  J   MUE    I',                                  &
     &    '  GDIA   GOFF   GMDIA  GMOFF',                              &
     &    '  FDIA   FOFF   FMDIA  FMOFF ')

!  end subroutine kprep
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: change_car.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


      subroutine change_car(bvs,avs,mtrx,imtrx,r)

!     calculates   r = bvs' * mtrx(imtr) * avs
      implicit none
      double precision bvs(1:3,1:3),avs(1:3,1:3),r(1:3,1:3)
      integer mtrx(48,1:3,1:3),imtrx
      integer i,j,k,l

        r=dble(0)
      do i=1,3
         do j=1,3
            do k=1,3
               do l=1,3
                  r(i,j)=r(i,j)+bvs(l,i)*                               &
     &                 dble(mtrx(imtrx,l,k))*avs(k,j)
               end do
            end do
         end do
      end do


      
      return 
      end 


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: pointgroup.f90,v $:
! $Revision: 1.4 $
! $Author: jorissen $
! $Date: 2012/01/30 06:01:58 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!     pointG_find attempts to find the point group of the crystal
!     input:
!     bvs  reciprocal lattice vectors
!     b    'metric' of the bs
!     ntot max number of point groups
!
!     output:
!     point_gr point group of the crystal
!     noper    number of operations in the point group

      subroutine pointgroup(bvs,b,ntot,point_gr,nopr)
      implicit none
      integer,intent(in)  :: ntot
      integer,intent(out) :: nopr
      real*8,intent(in)   :: bvs(3,3),b(3,3)
      real*8,intent(out)  :: point_gr(3,3,ntot)
!     Internal parameters
      real*8,parameter :: eps=1.0E-8
      real*8 tbvs(3,3),inv_tbvs(3,3),dum_tbvs(3,3)
      real*8,allocatable::Gdbl(:,:),Gnorm(:)
      real*8 bhelp,dum,diag(3),g1(3),g2(3),dot1,dot2,maxB
      integer i,j,k,imax,jmax,kmax,ig1,ig2,ig3,icar,nGmax

!KJ     calculate inv_tbvs := bvs^-1     :
      do i=1,3
         do j=1,3
            tbvs(i,j)=bvs(j,i)
         end do
      end do
      call invertmatrix(3,3,tbvs,dum_tbvs,inv_tbvs)

!KJ  Prepare some variables for the upcoming test :
      maxB=dble(0)
!      write(6,*) "b"
      do i=1,3
         if (b(i,i).gt.maxB) maxB=b(i,i)
         diag(i)=dble(1)/b(i,i)
!         write(6,*) (b(i,j),j=1,3)
      end do
!      write(6,*)
      if (maxB.le.eps) stop "b is zero in pointG_find"
      bhelp=b(1,2)*b(1,3)*b(2,3)


!KJ  To determine the point group, a number of alternative lattices will be set up and
!KJ  compared to the input lattice  (all in reciprocal space).  Which alternative lattices
!KJ  make sense?  Basically, all those consisting of vectors small enough that they could be
!KJ  rotations of the input lattice.  Here we determine the corresponding cutoff in three steps.
!KJ  (I'm not sure what exactly happens here.)

      dum=b(1,1)-b(1,2)*b(1,2)*diag(2)- b(3,1)*b(3,1)*diag(3)+ 2.0d0*bhelp*diag(2)*diag(3)
      if (dum.le.eps) stop "dum(1) is zero in pointG_find"
      imax=int(sqrt(maxB/dum)+1.0d0)
!      write(6,*) maxB,dum,dble(imax)*dble(imax)*dum

      dum=b(2,2)-b(1,2)*b(1,2)*diag(1)- b(3,2)*b(3,2)*diag(3)+ 2.0d0*bhelp*diag(1)*diag(3)
      if (dum.le.eps)  stop "dum(2) is zero in pointG_find"
      jmax=int(sqrt(maxB/dum)+1.0d0)
!      write(6,*) maxB,dum,dble(jmax)*dble(jmax)*dum

      dum=b(3,3)-b(1,3)*b(1,3)*diag(1)- b(3,2)*b(3,2)*diag(2)+ 2.0d0*bhelp*diag(1)*diag(2)
      if (dum.le. eps) stop "dum(3) is zero in pointG_find"
      kmax=int(sqrt(maxB/dum)+1.0d0)
!      write(6,*) maxB,dum,dble(kmax)*dble(kmax)*dum

      nGmax=(2*imax+1)*(2*jmax+1)*(2*kmax+1)


!KJ In the following block, a number (nGmax) of reciprocal lattice vectors are saved in
!KJ Gdbl, along with their norm^2 in Gnorm.
      allocate(Gdbl(3,nGmax),Gnorm(nGmax))
      ig1=0
      do i=-imax,imax
         do icar=1,3
           g1(icar)=dble(i)*tbvs(icar,1) 
         end do
         do j=-jmax,jmax
            do icar=1,3
               g2(icar)=g1(icar)+ dble(j)*tbvs(icar,2) 
            end do
            do k=-kmax,kmax
               ig1=ig1+1

               do icar=1,3
                  Gdbl(icar,ig1)= g2(icar)+dble(k)*tbvs(icar,3)
               end do
               dum=0.0d0
               do icar=1,3
                  dum=dum+Gdbl(icar,ig1)*Gdbl(icar,ig1)
               end do
               Gnorm(ig1)=dum
            end do
         end do
      end do

      nopr=0

!     Triple loop over the G vectors. Testing for each set 
!     of three DIFFERENT G vectors if they are some rotation 
!     of the b's (bvs). This done by comparing the 'metric' of
!     of the two sets of three vectors. If match is found the 
!     rotation matrix associated with group is stored.
 

      do ig1=1,nGmax

         if (ABS((Gnorm(ig1)-b(1,1))).le.eps) then  
         do ig2=1,nGmax

            if (ig2.ne.ig1 .and. ABS(Gnorm(ig2)-b(2,2)).le.eps) then
               dot1=dble(0)
               do icar=1,3
                  dot1=dot1+Gdbl(icar,ig1)*Gdbl(icar,ig2)
               end do
               if (ABS(dot1-b(2,1)).le.eps) then

               do ig3=1,nGmax

                  if (ig3.ne.ig2 .and. ig3.ne.ig1 .and.  ABS(Gnorm(ig3)-b(3,3)).le.eps) then
                     dot1=dble(0)
                     dot2=dble(0)
                     do icar=1,3
                        dot1=dot1+Gdbl(icar,ig1)*Gdbl(icar,ig3)
                        dot2=dot2+Gdbl(icar,ig2)*Gdbl(icar,ig3)
                     end do

                     
                     if (ABS(dot1-b(1,3)).le.eps  .AND. ABS(dot2-b(2,3)).le.eps) then
                     nopr=nopr+1
                     if (nopr.gt.ntot) then
                        write(6,*) "There are over ",ntot," rotations in the point group. Something must be wrong."
                        STOP
                     end if
                     call add_oper(inv_tbvs,Gdbl,nGmax,ig1,ig2,ig3,nopr,point_gr,ntot)
                     end if
                  end if
               end do
               end if
            end if
         end do
         end if
      end do
!     By this time the point group of the lattice should be in hand.
!     If not error is raised !!!
      if (nopr.lt.1) then
         write(6,*) "There is no point group for this system.  Something must have gone wrong!!"
         STOP
      end if
      deallocate(Gnorm,Gdbl)
      return
      end

!  Subroutine add_oper adds a rotation operation matrix 
!  to the collection point_gr (total size ntot, current size npoint-1).
!  This done by using the inverse of the b's (inv_tbvs).
!  The Gvectors index ig1,ig2,ig3 (from the matrix Gdbl) are used in  
!  process.

!KJ  We seek the matrix m that transforms (b1 b2 b3) into (Gdble(ig1) Gdble(ig2) Gdble(ig3)) =: g
!KJ  This is done by multiplying    m := point_gr(:,npoint) = g * (b1 b2 b3)^-1   (=: inv_tbvs)
!KJ  Finally, for some reason, m is saved as a 9 element array instead of a 3*3 matrix.  (Silly people ...)

      subroutine add_oper(inv_tbvs,Gdbl,nGmax,ig1,ig2,ig3,npoint,point_gr,ntot)
      implicit none
      integer ntot,npoint,ig1,ig2,ig3,nGmax
      real*8 inv_tbvs(3,3)
      real*8 Gdbl(3,nGmax)
      real*8 point_gr(3,3,ntot)
      
      real*8 g(1:3,1:3)
      integer i,j,icar
      
      do icar=1,3
         g(icar,1)=Gdbl(icar,ig1)
         g(icar,2)=Gdbl(icar,ig2)
         g(icar,3)=Gdbl(icar,ig3)
      end do
      
        point_gr(:,:,npoint)=dble(0)
      do i=1,3
         do j=1,3
            do icar=1,3
               point_gr(i,j,npoint)=point_gr(i,j,npoint)+ g(i,icar)*inv_tbvs(icar,j)
            end do
         end do
      end do

      return 
      end 



!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: readcrystaldata.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      subroutine cross(a,b,c)
!    Vector product :  c = a x b
      implicit none
      real*8 a(3),b(3),c(3)
      integer i,j,k
      do i=1,3
        j=i+1
        if (j.gt.3) j=j-3
        k=j+1
        if (k.gt.3) k=k-3
        c(i)=a(j)*b(k)-a(k)*b(j)
      end do
      return
      end
!--------------------------------------------
      function dotthree(b,a)
!    Scalar product : dotthree = a . b
      implicit none
      real*8 dotthree,a(3),b(3),temp
      integer i
      temp=0.d0
      do i=1,3
        temp=temp+b(i)*a(i)
      end do
      dotthree=temp
      return
      end







!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: spacegroup.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!     spacegroup attempts to find the improper rotations of the crystal and creates the symmetry group

!KJ Important note : I am not confident that the translations come out properly!!

!
!     input:
!     bvs  reciprocal lattice vectors
!     avs  real space lattice vectors
!     b    'metric' of the bs
!     types number of types of atoms
!     maxnat maximum number of types of atoms
!     coorat coordinates of the basis
!     natom(i) number of atoms of type 'i'
!     ntot max number of point groups
!     point_gr point group of the crystal
!     npoint number of point group oper
!
!     output:
!     cryst_gr crystal group (rot + rot*translation)


      subroutine  spacegroup(avs,bvs,types,maxnat,coorat_a,             &
     &     natom,ntot,point_gr,npoint,spacegr,nspacegr)

      use constants,only : pi2
      implicit none

      integer,intent(in) :: types,maxnat,ntot,npoint
      real*8,intent(in) :: bvs(3,3),avs(3,3),                           &
     &                coorat_a(types,maxnat,3),point_gr(3,3,ntot)
      integer,intent(in) :: natom(types)
      integer,intent(out) :: nspacegr
      real*8,intent(out) :: spacegr(3,4,ntot)

      real*8 c(types,maxnat,3)
      real*8 da,ident(3,3),vdum,v1(3),r_red(3),rr(3)
      real*8, allocatable:: difs(:,:,:),co(:,:,:),rotc(:,:,:)
      integer mxnatom,it,iatom,ipoint,ntrans,nats,ncells,cell1,nn
      integer i,j,k,l,m,p,ifirst,expansion,ix,iy,iz

      real*8,parameter :: eps=1.0E-5

      logical used(ntot),debug
        logical,allocatable :: mapped(:,:),istrans(:,:,:),mappedsmall(:)
        real*8 dist
        real*8, allocatable :: trans(:,:,:,:)



      ntrans=0
        ident=dble(0)
        ident(1,1)=dble(1)
        ident(2,2)=dble(1)
        ident(3,3)=dble(1)


!KJ The coordinates are already carthesian!  Therefore, I'm skipping the next section, and instead just doing :
      c=coorat_a*dsqrt(avs(1,1)**2+avs(1,2)**2+avs(1,3)**2)
!c Change the basis coordinates to cartesian
!      c=dble(0)
!      do it=1,types
!         do iatom=1,natom(it)
!            do i=1,3
!               do j=1,3
!                  c(it,iatom,i)=c(it,iatom,i)+
!     &                 coorat_a(it,iatom,j)*avs(j,i)
!               end do
!            end do
!         end do
!      end do
!	c=c/pi2




      mxnatom=0
        nats=0
      do iatom=1,types
           nats=nats+natom(iatom)
         if (natom(iatom).gt.mxnatom) mxnatom=natom(iatom)
      end do

      if(maxnat.ne.mxnatom) stop 'atoms wrong'


      expansion=0

        i=2*expansion+1
        cell1=expansion*(i**2+i+1)
        ncells=i**3
      p= ncells * mxnatom  ! upper estimate for total number of atoms in this routine
      allocate (co(3,p,types))
      co=dble(0)

      do it=1,types
        j=0
        do ix=-expansion,expansion
        do iy=-expansion,expansion
        do iz=-expansion,expansion
        do i=1,natom(it)
         j=j+1
           r_red=dble(0)
         do k=1,3
            do l=1,3
               r_red(k)=r_red(k)+bvs(k,l)*c(it,i,l)
            end do
            r_red(k)=r_red(k)/pi2
         end do
           r_red(1)=r_red(1)+ix
           r_red(2)=r_red(2)+iy
           r_red(3)=r_red(3)+iz
! back to normal coordinates
         rr=dble(0)
         do k=1,3
            do l=1,3
               rr(k)=rr(k)+avs(k,l)*r_red(l)
            end do
         end do
         co(:,j,it)=rr
      enddo
        enddo
        enddo
      enddo
        enddo

! Rotating the basis coordinates of each type of atom and then
! finding out the differences in the position of same type 
! of atoms in rotated and original basis. This done for each element
! of the point group.
      
        allocate (difs(3,p,p),rotc(types,p,3),mapped(p,p),mappedsmall(p))
      ntrans=natom(1)*ncells
        allocate (trans(3,ntrans,ntrans,ntot),istrans(ntot,ntrans,ntrans))
        difs=dble(0)
        rotc=dble(0)
        istrans=.true.
        trans=dble(0)

      do ipoint=1,npoint  ! loop over all point group sym ops


         do it=1,types
            do iatom=1,natom(it)*ncells
                 v1=dble(0)
               do i=1,3
                  do j=1,3
                     v1(i)=v1(i)+point_gr(i,j,ipoint)*co(j,iatom,it)
                  end do
               end do
                 rotc(it,iatom,:)=v1
            end do
         end do

         do it=1,types

            nn=ncells*natom(it)
            difs=dble(0)
              do i=1,nn
              do j=1,nn
                 difs(:,i,j)=rotc(it,i,:)-co(:,j,it)
                 do k=1,3
!	           if(dabs(difs(k,i,j)).lt.0.00000001) difs(k,i,j)=dble(0)
                 enddo
              enddo
              enddo
              if(it.eq.1) trans(:,:,:,ipoint)=-difs

      debug=.false.
        if(debug) then
      open(11,file='debug.txt')
        write(11,*) 'symmetry operation'
        do i=1,3
        write(11,17) ipoint,point_gr(i,:,ipoint)
        enddo
        write(11,*) 'translation vectors'
        do i=1,ntrans
        do j=1,ntrans
        write(11,17) i,trans(:,i,j,ipoint)
        enddo
        enddo
        write(11,*) 'original coordinates'
        do i=1,types
        do j=1,natom(i)
        write(11,17) i,c(i,j,:)
        enddo
        enddo
        write(11,*) 'full set of coordinates'
        do i=1,types
        do j=1,ncells*natom(it)
        write(11,17) i,co(:,j,i)
        enddo
        enddo
        write(11,*) 'rotated coordinates'
        do i=1,types
        do j=1,ncells*natom(it)
        write(11,17) i,rotc(i,j,:)
        enddo
        enddo
17    format(i3,3f14.4)
      write(11,*) 'difs'
      do j=1,ntrans
        do i=1,natom(1)*ncells
         write(11,17) j,difs(:,j,i)
        enddo
        enddo
!	close(11)
 !     stop
        endif


            do i=1,ntrans
              do j=1,ntrans
                 if(istrans(ipoint,i,j)) then   ! don't bother if the translation's already been proven useless
                    mapped=.false.
                    do l=1,nn
                    do m=1,nn
                       dist=dble(0)
!	               debug=(i.eq.2.and.j.eq.2.and.l.eq.1.and.m.eq.1)
                       call reduce(avs,bvs,difs(:,l,m)+trans(:,i,j,ipoint)&
     &                               ,v1,p)
                       do k=1,3
                          dist=dabs(v1(k))+dist
                       enddo
                       if(dist.lt.eps.and.mapped(l,m)) then
        			       stop 'error overlap'
        			   elseif(dist.lt.eps) then
        			       mapped(l,m)=.true.
                       endif
!	 write(11,*) 'i,j,l,m',i,j,l,m
!	write(11,*) 'difslm,transij',difs(:,l,m),trans(:,i,j,ipoint)
!	write(11,*) 'v1',v1
                    enddo
                    enddo
                    mappedsmall=.false.
                    do l=1,nn
                    do m=1,nn
                       mappedsmall(l)=mappedsmall(l).or.mapped(l,m)
                    enddo
                    enddo
                    do l=1,nn
                       istrans(ipoint,i,j)=(istrans(ipoint,i,j).and.    &
     &                                               mappedsmall(l))
                    enddo
!	            if(i.eq.2.and.j.eq.2) then
!	               write(11,*) 'mapped',mapped
!	               write(11,*) 'mappedsmall',mappedsmall
!	               write(11,*) 'istransij',istrans(ipoint,i,j)
!	            endif
                 endif
              enddo
              enddo
         enddo  ! atom types it=1,types
!      close(11)!;stop

        enddo  ! point group sym ops


! Now determine the space group ...

      used=.false.
      nspacegr=0
        spacegr=dble(0)
        do i=1,npoint
         do j=1,ntrans
           do it=1,ntrans
              if(istrans(i,j,it).and.(.not.used(i))) then
                 used(i)=.true.
                 nspacegr=nspacegr+1
               do p=1,3
               do k=1,3
                  do l=1,3
                  do m=1,3
                        spacegr(p,k,nspacegr)=spacegr(p,k,nspacegr)+    &
     &                    avs(p,l)*point_gr(l,m,i)*bvs(k,m)
                  end do
                  end do
                  spacegr(p,k,nspacegr)=spacegr(p,k,nspacegr)/pi2
                 enddo
                 enddo
                 call subtract_a(bvs,trans(:,j,it,i),                   &
     &                           spacegr(:,4,nspacegr),p)
!	         spacegr(:,4,nspacegr)=trans(:,j,it,i)
              endif
           enddo
           enddo
        enddo




      if (nspacegr.lt.1) stop "Did not find any symmetry operations!!!"

     
!     Finally shift the identity operator to the top.
!     This will be better for later purposes.
     
      ifirst=0
      do i=1,nspacegr
         da=0.0d0
         do j=1,3
            da=da+abs(spacegr(j,4,i))
         end do
         if(da.le.eps) then
            da=0.0d0
            do j=1,3
              do k=1,3
               da=da+abs(spacegr(k,j,i)-ident(k,j))
              enddo
            end do
            if (da.le.eps) then
               if (ifirst.gt.0) then
                  write(6,*) "Found more than one identity operator"
                  stop
               end if
               ifirst=i
            end if
         end if
      end do

      if (ifirst.lt.1) stop "Did not find the identity operator"

      do i=1,3
        do j=1,4
         vdum=spacegr(i,j,1)
         spacegr(i,j,1)=spacegr(i,j,ifirst)
         spacegr(i,j,ifirst)=vdum
        enddo
      enddo

      return 
      end
      








!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: symmetrycheck.f90,v $:
! $Revision: 1.4 $
! $Author: jorissen $
! $Date: 2012/01/30 22:04:08 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine symmetrycheck(ierr,ntrans,mtrx,tnp,mult)

      use constants,only: pi2
      implicit none
      integer,intent(out) :: ierr
        integer,intent(in) :: mtrx(48,3,3),ntrans
      real*8,intent(in) :: tnp(48,3)

      integer mult(48,48),nerr(48),mtest(3,3),i,j,k,l,m,itest,maxerr
      real*8 ttest
        integer yes(ntrans),nspacegroup
      logical equiv
        real*8,parameter :: prec=0.00000001d0


      ierr=0
      if (ntrans .eq. 1) return

!  check for duplicate operations
      do i=2,ntrans
        do j=1,i-1
          equiv = .true.
          do k=1,3
            if (dabs(tnp(i,k)-tnp(j,k)).gt.prec) equiv= .false.
            do l=1,3
              if (mtrx(i,k,l).ne.mtrx(j,k,l)) equiv=.false.
            end do
          end do
          if ( equiv ) then
            write ( 6, '(/,1a11,2x,2i5)' ) ' equiv ops ', i, j
            write ( 6, * ) 'symmetry check fault'
          end if
        end do
      end do

!  make mul table
!    Check that the product of two sym ops is again a sym op
      do i=1,ntrans
        nerr(i) = 0
        do j=1,ntrans
          mult(i,j) = 0
            mtest=0
!  multiply i and j
          do k=1,3
            do l=1,3
              do m=1,3
                mtest(k,l) = mtest(k,l) + mtrx(i,k,m)*mtrx(j,m,l)
              end do
            end do
          end do
!  check for match
          do k=1,ntrans
            equiv = .true.
            l = 1
            m = 1
            do while ( equiv .and. ( l .le. 3 ) )
              if ( mtest( l, m ) .ne. mtrx( k, l, m ) ) equiv = .false.
              if ( m .lt. 3 ) then
                m = m + 1
              else
                m = 1
                l = l + 1
              end if
            end do
            if ( equiv ) mult( i, j ) = k
          end do
          if (mult(i,j).eq.0) stop 'no deal -- not a group'
        end do
      end do

!  if translations not correct set mult(i,j) to -1
      do i=1,ntrans
        do j=1,ntrans
          k = mult(i,j)
          l = 1
          do while ( ( mult( i, j ) .ne. -1 ) .and. ( l .lt. 4 ) )
            ttest = tnp(j,l)
            do m=1,3
              ttest = ttest + dble(mtrx(i,m,l))*(tnp(i,m)-tnp(k,m))
            end do
            ttest = dabs(ttest)/pi2
            itest = ttest * 1.001
            if (dabs(ttest-dble(itest)) .ge. 0.0001d0) mult(i,j) = -1
            l = l + 1
          end do
        end do
      end do


      yes=0
      nspacegroup=0
        do i=1,ntrans
!        Check multiplication table
         equiv=.true.
           do j=1,ntrans
              if(mult(i,j).le.0) equiv=.false.
              if(mult(j,i).le.0) equiv=.false.
         enddo
           if(equiv) then
              nspacegroup=nspacegroup+1
              yes(i)=1
           endif
        enddo

!        write(6,*) 'nspacegroup',nspacegroup
!        write(6,*) 'yes ',yes



!  check multiplication table
      do i=1,ntrans
      do j=1,ntrans
      if (mult(i,j) .le. 0) then
        nerr(i) = nerr(i) + 1
        nerr(j) = nerr(j) + 1
      end if
      end do
      end do
!  find element with max error
      ierr   = 0
      maxerr = 0
      do i=1,ntrans
        if (nerr(i) .gt. maxerr) then
          maxerr = nerr(i)
          ierr = i
        end if
      end do
!      write(6,'(21h1multiplication table,/)')
!
!      do i=1,ntrans
!        write(6,'(1x,48i3)') (mult(i,j),j=1,ntrans)
!      end do

!      write(6,*) 'Ierr = ',ierr
!        write(6,*) 'maxerr = ',maxerr


      return
      end








!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: invertmatrix.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine invertmatrix(ndim,nadp,smat,suse,sinv)
!KJ This routine added for the symmetry checkers of the KSPACE directory 5-2007      
      implicit none
      integer i,j,k,ii,ndim,nadp
      double precision smat(nadp,nadp),suse(nadp,nadp),sinv(nadp,nadp)
      double precision ratio,swap,rc1,rc2
!
!  copy, set up identity
!
      sinv=dble(0)
      do i=1,ndim
        do j=1,ndim
          suse(j,i)=smat(j,i)
        end do
        sinv(i,i)=1
      end do
!
!  do inversion by pivoted Gaussian elimination
!
      do i=1,ndim
!
        ii=i
        do j=i+1,ndim
          rc1=dabs(suse(j,i))
          rc2=dabs(suse(ii,i))
          if (rc1.gt.rc2) ii=j
        end do
        if (ii.gt.i) then
          do j=i,ndim
            swap=suse(i,j)
            suse(i,j)=suse(ii,j)
            suse(ii,j)=swap
          end do
          do j=1,ndim
            swap=sinv(i,j)
            sinv(i,j)=sinv(ii,j)
            sinv(ii,j)=swap
          end do
        end if
        if (suse(i,i).eq.dcmplx(0.d0,0.d0)) then
          write (6,*) 'ZERO DETERMINANT...'
          write (98,*) 'ZERO DETERMINANT...'
          stop
        end if
        do j=1,ndim
          if (j.ne.i) then
            ratio=-suse(j,i)/suse(i,i)
          else
            ratio=dcmplx(1.d0,0.d0)/suse(i,i)-dcmplx(1.d0,0.d0)
          endif
          do k=i,ndim
            suse(j,k)=suse(j,k)+ratio*suse(i,k)
          end do
          do k=1,ndim
            sinv(j,k)=sinv(j,k)+ratio*sinv(i,k)
          end do
        end do
!
      end do
!
      return
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: subtract_a.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! given a vector r (in cartesian coord) and bvs (reciprocal vectors)
! subroutine calculates reduced vector r_red (in units of lattice vectors)
! if there was a subtraction l is not zero on exit


      subroutine subtract_a(bvs,r,r_red,l)
        use constants,only: pi2
      implicit none
      real*8 bvs(1:3,1:3),r(1:3),r_red(1:3)
      integer l
      
      integer i,j,chng
      l=0

        r_red=dble(0)
      do i=1,3
         do j=1,3
            r_red(i)=r_red(i)+bvs(i,j)*r(j)
         end do
         r_red(i)=r_red(i)/pi2
      end do
      do i=1,3
         chng=nint(r_red(i))
         l=l+abs(chng)
         r_red(i)=r_red(i)-dble(chng)
      end do
      return 
      end




      subroutine reduce(avs,bvs,r,r_red,l)
        use constants,only: pi2
      implicit none
        real*8,intent(in) :: avs(3,3),bvs(3,3),r(3)
        real*8,intent(out) :: r_red(3)
      real*8 rr(3)
      integer,intent(inout) :: l
!	logical debug
        real*8,parameter :: eps=-0.00000001d0
      
      integer i,j,chng
      l=0

!      if(debug) write(11,*) 'r',r
!	if(debug) write(11,*) 'bvs',bvs

        r_red=dble(0)
      do i=1,3
         do j=1,3
            r_red(i)=r_red(i)+bvs(i,j)*r(j)
         end do
         r_red(i)=r_red(i)/pi2
      end do

!      if(debug) write(11,*) 'r_red',r_red
      do i=1,3
         chng=nint(r_red(i))
!	if(debug) write(11,*) i,r_red(i)-dble(1)
         l=l+abs(chng)
!	   if(debug) write(11,*) i,r_red(i)
         r_red(i)=r_red(i)-dble(chng)
!	   if(debug) write(11,*) i,r_red(i)
!    Here we must take care to deal with numerical errors ( ~ 10^-16)
!    If r is somewhere in the middle of the cell, this noise is not important.
!    If r is just above 0 or just above 1 (or any integer), it will be reduced to 0+noise - that's fine.
!    BUT if r is just below 0 or 1 (or any integer), then it will be reduced to 0-noise, and then by the
!    following statement increased to 1-noise   -   while obviously the correct result (no numerical noise) is 0!!
!    Therefore, allow for a small margin of error where negative numbers are brought to 0 instead of 1.
         if(r_red(i).lt.dble(0).and.r_red(i).gt.eps) then
            r_red(i)=dble(0)
           elseif(r_red(i).lt.dble(0)) then
              r_red(i)=r_red(i)+dble(1)
         endif
!	   if(debug) write(11,*) 'i,chng,l',i,chng,l
      end do
!	if(debug) write(11,*) 'r_red',r_red

! back to normal coordinates
      rr=dble(0)
      do i=1,3
         do j=1,3
            rr(i)=rr(i)+avs(i,j)*r_red(j)
         end do
      end do
      r_red=rr
!      if(debug) write(11,*) 'r_red',r_red

      return 
      end

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: bastrans.f90,v $:
! $Revision: 1.4 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*==bastrmat.f    processed by SPAG 6.05Rc at 11:40 on 21 Jul 2001
      SUBROUTINE BASTRMAT(LMAX,CGC,RC,CREL,RREL,NKMMAX,NKMPMAX)
!   ********************************************************************
!   *                                                                  *
!   *    INITIALIZE TRANSFORMATION MATRIX THAT TAKES MATRICES FROM     *
!   *    RELATIVISTIC  TO  REAL SPERICAL HARM.  REPRESENTATION         *
!   *                                                                  *
!   *    this is a special version of <STRSMAT> passing the            *
!   *    full BASis TRansformation MATrices  RC, CREL and RREL         *
!   *                                                                  *
!   * 13/01/98  HE                                                     *
!   ********************************************************************
!
      IMPLICIT REAL*8(A-H,O-Z)
!
!*** Start of declarations rewritten by SPAG
!
! PARAMETER definitions
!
      COMPLEX*16 CI,C1,C0
      PARAMETER (CI=(0.0D0,1.0D0),C1=(1.0D0,0.0D0),C0=(0.0D0,0.0D0))
!
! Dummy arguments
!
      INTEGER LMAX,NKMMAX,NKMPMAX
      REAL*8 CGC(NKMPMAX,2)
      COMPLEX*16 CREL(NKMMAX,NKMMAX),RC(NKMMAX,NKMMAX),                 &
     &           RREL(NKMMAX,NKMMAX)
!
! Local variables
!
      INTEGER I,IKM,J,JP05,K,L,LM,LNR,M,MUEM05,MUEP05,NK,NKM,NLM
      REAL*8 W
!
!*** End of declarations rewritten by SPAG
!

!      write(*,*) 'lmax,nkmmax,nkmpmax',lmax,nkmmax,nkmpmax

      NK = 2*(LMAX+1) + 1
      NLM = (LMAX+1)**2
      NKM = 2*NLM
!     ===================================================
!     INDEXING:
!     IKM  = L*2*(J+1/2) + J + MUE + 1
!     LM   = L*(L+1)     +     M   + 1
!     ===================================================
!
! ----------------------------------------------------------------------
! CREL  transforms from  COMPLEX (L,M,S)  to  (KAP,MUE) - representation
!                 |LAM> = sum[LC] |LC> * CREL(LC,LAM)
! ----------------------------------------------------------------------
      crel=c0 !KJ CALL ZCOPY(NKMMAX*NKMMAX,C0,0,CREL,1)

      LM = 0
      DO LNR = 0,LMAX
         DO M = -LNR,LNR
            LM = LM + 1

            IKM = 0
            DO K = 1,NK
               L = K/2
               IF ( 2*L.EQ.K ) THEN
                  JP05 = L
               ELSE
                  JP05 = L + 1
               END IF

               DO MUEM05 = -JP05,(JP05-1)
                  MUEP05 = MUEM05 + 1
                  IKM = IKM + 1

                  IF ( L.EQ.LNR ) THEN
                     IF ( MUEP05.EQ.M ) CREL(LM,IKM) = CGC(IKM,1)
                     IF ( MUEM05.EQ.M ) CREL(LM+NLM,IKM) = CGC(IKM,2)
                  END IF

               END DO
            END DO

         END DO
      END DO
!
! ----------------------------------------------------------------------
!    RC  transforms from  REAL to  COMPLEX (L,M,S) - representation
!                 |LC> = sum[LR] |LR> * RC(LR,LC)
! ----------------------------------------------------------------------
      rc=c0 !KJ CALL ZCOPY(NKMMAX*NKMMAX,C0,0,RC,1)
!
      W = 1.0D0/SQRT(2.0D0)
!
      DO L = 0,LMAX
         DO M = -L,L
            I = L*(L+1) + M + 1
            J = L*(L+1) - M + 1
!
            IF ( M.LT.0 ) THEN
               RC(I,I) = -CI*W
               RC(J,I) = W
               RC(I+NLM,I+NLM) = -CI*W
               RC(J+NLM,I+NLM) = W
            END IF
            IF ( M.EQ.0 ) THEN
               RC(I,I) = C1
               RC(I+NLM,I+NLM) = C1
            END IF
            IF ( M.GT.0 ) THEN
               RC(I,I) = W*(-1.0D0)**M
               RC(J,I) = CI*W*(-1.0D0)**M
               RC(I+NLM,I+NLM) = W*(-1.0D0)**M
               RC(J+NLM,I+NLM) = CI*W*(-1.0D0)**M
            END IF
         END DO
      END DO
!
! ----------------------------------------------------------------------
! RREL  transforms from   REAL (L,M,S)  to  (KAP,MUE) - representation
!                 |LAM> = sum[LR] |LR> * RREL(LR,LAM)
! ----------------------------------------------------------------------
!
      CALL ZGEMM('N','N',NKM,NKM,NKM,C1,RC,NKMMAX,CREL,NKMMAX,C0,RREL,  &
     &           NKMMAX)
!
      END
!*==changerep.f    processed by SPAG 6.05Rc at 11:40 on 21 Jul 2001
      SUBROUTINE CHANGEREP(A,MODE,B,N,M,RC,CREL,RREL,TEXT,LTEXT)
!   ********************************************************************
!   *                                                                  *
!   *   change the representation of matrix A and store in B           *
!   *   according to MODE:                                             *
!   *                                                                  *
!   *   RLM>REL   non-relat. REAL spher. harm.  >   (kappa,mue)        *
!   *   REL>RLM   (kappa,mue)  > non-relat. REAL spher. harm.          *
!   *   CLM>REL   non-relat. CMPLX. spher. harm.  >   (kappa,mue)      *
!   *   REL>CLM   (kappa,mue)  > non-relat. CMPLX. spher. harm.        *
!   *   RLM>CLM   non-relat. REAL spher. harm.  >  CMPLX. spher. harm. *
!   *   CLM>RLM   non-relat. CMPLX. spher. harm.  >  REAL spher. harm. *
!   *                                                                  *
!   *   the non-relat. representations include the  spin index         *
!   *                                                                  *
!   *   for LTEXT > 0 the new matrix  B  is printed                    *
!   *                                                                  *
!   ********************************************************************
!
      IMPLICIT REAL*8(A-H,O-Z)
!
!*** Start of declarations rewritten by SPAG
!
! PARAMETER definitions
!
      COMPLEX*16 C1,C0
      PARAMETER (C1=(1.0D0,0.0D0),C0=(0.0D0,0.0D0))
!
! Dummy arguments
!
      INTEGER LTEXT,M,N
      CHARACTER*7 MODE
      CHARACTER*(*) TEXT
      COMPLEX*16 A(M,M),B(M,M),CREL(M,M),RC(M,M),RREL(M,M)
!
! Local variables
!
      INTEGER KEY
      COMPLEX*16 W1(M,M)
!
!*** End of declarations rewritten by SPAG
!
!---------------------- transform MAT from (kappa,mue) to REAL (l,ml,ms)
      IF ( MODE.EQ.'REL>RLM' ) THEN
         CALL ZGEMM('N','N',N,N,N,C1,RREL,M,A,M,C0,W1,M)
         CALL ZGEMM('N','C',N,N,N,C1,W1,M,RREL,M,C0,B,M)
         KEY = 2
      ELSE IF ( MODE.EQ.'RLM>REL' ) THEN
         CALL ZGEMM('C','N',N,N,N,C1,RREL,M,A,M,C0,W1,M)
         CALL ZGEMM('N','N',N,N,N,C1,W1,M,RREL,M,C0,B,M)
         KEY = 3
      ELSE IF ( MODE.EQ.'REL>CLM' ) THEN
         CALL ZGEMM('N','N',N,N,N,C1,CREL,M,A,M,C0,W1,M)
         CALL ZGEMM('N','C',N,N,N,C1,W1,M,CREL,M,C0,B,M)
         KEY = 2
      ELSE IF ( MODE.EQ.'CLM>REL' ) THEN
         CALL ZGEMM('C','N',N,N,N,C1,CREL,M,A,M,C0,W1,M)
         CALL ZGEMM('N','N',N,N,N,C1,W1,M,CREL,M,C0,B,M)
         KEY = 3
      ELSE IF ( MODE.EQ.'CLM>RLM' ) THEN
         CALL ZGEMM('N','N',N,N,N,C1,RC,M,A,M,C0,W1,M)
         CALL ZGEMM('N','C',N,N,N,C1,W1,M,RC,M,C0,B,M)
         KEY = 2
      ELSE IF ( MODE.EQ.'RLM>CLM' ) THEN
         CALL ZGEMM('C','N',N,N,N,C1,RC,M,A,M,C0,W1,M)
         CALL ZGEMM('N','N',N,N,N,C1,W1,M,RC,M,C0,B,M)
         KEY = 2
      ELSE
         WRITE (*,*) ' MODE = ',MODE
         STOP 'in <ROTATE>  MODE not allowed'
      END IF
!
!KJ      IF ( LTEXT.GT.0 ) CALL CMATSTR(TEXT,LTEXT,B,N,M,KEY,KEY,0,1D-8,6)
!
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: calccgc.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE CALCCGC(LTAB,KAPTAB,NMUETAB,CGC,NKMAX,NMUEMAX,NKMPMAX)
!   ********************************************************************
!   *                                                                  *
!   *   CLEBSCH-GORDON-COEFFICIENTS     CGC(IKM,IS)                    *
!   *                                                                  *
!   *   IKM NUMBERS  CGC  FOR INCREASING  K  AND  MUE                  *
!   *   IKM  = L*2*(J+1/2) + J + MUE + 1                               *
!   *   IS= 1/2  SPIN DOWN/UP                                          *
!   *                                                                  *
!   ********************************************************************
!
      IMPLICIT NONE
!
!
! Dummy arguments
!
      INTEGER NKMAX,NKMPMAX,NMUEMAX
      REAL*8 CGC(NKMPMAX,2)
      INTEGER KAPTAB(NMUEMAX),LTAB(NMUEMAX),NMUETAB(NMUEMAX)
!
! Local variables
!
      INTEGER IKM,K,KAPPA,M
      REAL*8 J,L,MUE,TWOLP1
!
      IKM = 0
      DO K = 1,(NKMAX+1)
         L = LTAB(K)
         KAPPA = KAPTAB(K)
         J = ABS(KAPPA) - 0.5D0
         MUE = -J - 1.0D0
         TWOLP1 = 2.0D0*L + 1.0D0
!
         IF ( KAPPA.LT.0 ) THEN
!
!     J = L + 1/2
            DO M = 1,NMUETAB(K)
!
               MUE = MUE + 1.0D0
               IKM = IKM + 1
               CGC(IKM,1) = DSQRT((L-MUE+0.5D0)/TWOLP1)
               CGC(IKM,2) = DSQRT((L+MUE+0.5D0)/TWOLP1)
            END DO
         ELSE
!     J = L - 1/2
            DO M = 1,NMUETAB(K)
!
               MUE = MUE + 1.0D0
               IKM = IKM + 1
               CGC(IKM,1) = DSQRT((L+MUE+0.5D0)/TWOLP1)
               CGC(IKM,2) = -DSQRT((L-MUE+0.5D0)/TWOLP1)
!
            END DO
         END IF
!
!
      END DO
!
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: makerotations.f90,v $:
! $Revision: 1.4 $
! $Author: jorissen $
! $Date: 2010/05/27 22:42:30 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


      subroutine makerotations
      use boundaries,only : nkmmax,nl=>nlmax
        use trafo,only : mrotr
        use kklist,only : drot
!        use struct
      implicit none

        real*8 eulangcub(3,24),alfa,beta,gamma,w
      real*8     fact(0:100)
      character*4 symsymcub(48)
        integer i,l,m,isym,isymp,nkm,k,m1,m2,kap,lmax,kmin,kmax,ipos
        integer nmu
        real*8 mu1,mu2,j,cb,sb,db
        complex*16 eima,eimg
        integer,parameter :: nsymh=24,iinv=25
      complex*16 C0,C1,CI
      complex*16 CS,USC(3,3),W3X3(3,3)
      parameter (C0=(0.0D0,0.0D0),C1=(1.0D0,0.0D0),CI=(0.0D0,1.0D0))
      REAL*8 PI
      PARAMETER ( PI = 3.141592653589793238462643D0 )   
	  logical,parameter :: debug=.false.

!=======================================================================
! the following tables give the Euler angles corresponding to the 
! proper rotations of the cubic group Oh and the hexagonal group D6h
! taken from Bradley & Cracknell's table 1.4. 
! Note: These authors use active fixed rotation axes
!       Rose's convention used here is to use ACTIVE TEMPORARY AXES
!       accordingly alpha and gamme had to be interchanged
!
      DATA EULANGCUB /                                                  &
     &      0.0D0,    0.0D0,    0.0D0,                                  &
     &      0.0D0,  180.0D0,  180.0D0,                                  &
     &      0.0D0,  180.0D0,    0.0D0,                                  &
     &      0.0D0,    0.0D0,  180.0D0,                                  &
     &      0.0D0,   90.0D0,   90.0D0,                                  &
     &    180.0D0,   90.0D0,  270.0D0,                                  &
     &    180.0D0,   90.0D0,   90.0D0,                                  &
     &      0.0D0,   90.0D0,  270.0D0,                                  &
     &     90.0D0,   90.0D0,  180.0D0,                                  &
     &    270.0D0,   90.0D0,    0.0D0,                                  &
     &     90.0D0,   90.0D0,    0.0D0,                                  &
     &    270.0D0,   90.0D0,  180.0D0,                                  &
     &    270.0D0,   90.0D0,   90.0D0,                                  &
     &      0.0D0,   90.0D0,    0.0D0,                                  &
     &      0.0D0,    0.0D0,   90.0D0,                                  &
     &     90.0D0,   90.0D0,  270.0D0,                                  &
     &    180.0D0,   90.0D0,  180.0D0,                                  &
     &      0.0D0,    0.0D0,  270.0D0,                                  &
     &      0.0D0,  180.0D0,   90.0D0,                                  &
     &      0.0D0,  180.0D0,  270.0D0,                                  &
     &      0.0D0,   90.0D0,  180.0D0,                                  &
     &     90.0D0,   90.0D0,   90.0D0,                                  &
     &    180.0D0,   90.0D0,    0.0D0,                                  &
     &    270.0D0,   90.0D0,  270.0D0/          
!
      DATA SYMSYMCUB / 'E   ','C2x ','C2y ','C2z ','C+31','C+32',       &
     &                 'C+33','C+34','C-31','C-32','C-33','C-34',       &
     &                 'C+4x','C+4y','C+4z','C-4x','C-4y','C-4z',       &
     &                 'C2a ','C2b ','C2c ','C2d ','C2e ','C2f ',       &
     &                 'I   ','sx  ','sy  ','sz  ','S-61','S-62',       &
     &                 'S-63','S-64','S+61','S+62','S+63','S+64',       &
     &                 'S-4x','S-4y','S-4z','S+4x','S+4y','S+4z',       &
     &                 'sda ','sdb ','sdc ','sdd ','sde ','sdf '/


      fact(0) = dble(1)
      do i = 1,100
         fact(i) = fact(i-1)*dble(i)
      enddo

      lmax=nl-1
        drot=dcmplx(0)
      mrotr=dble(0)

!----------------
!-------------------------------------------------------
!  create transformation matrix   U  cartesian/sperical ccordinates
!-----------------------------------------------------------------------
!  RC,RCP  vectors in cartesian coordinates
!  RS,RSP  vectors in spherical coordinates
!         RS  = USC * RC                                 (4.40)
!         RSP = MS  * RS                                 (4.37)
!     MS(i,j) = D(j,i)                                   (4.42)
!     D  rotation matrix for complex spherical harmonics
!
      W = 1.0D0/SQRT(2.0D0)
!
! ordering of: m=-1,0,+1 >>> row 1 and 3 interchanged compared to (4.44)
      USC(1,1) = W
      USC(1,2) = -CI*W
      USC(1,3) = 0.0D0
      USC(2,1) = 0.0D0
      USC(2,2) = 0.0D0
      USC(2,3) = 1.0D0
      USC(3,1) = -W
      USC(3,2) = -CI*W
      USC(3,3) = 0.0D0


      nkm=nkmmax

      do i=1,nsymh

           alfa=eulangcub(1,i)*pi/dble(180)  ! degrees to radians
           beta=eulangcub(2,i)*pi/dble(180)
           gamma=eulangcub(3,i)*pi/dble(180)
         cb=dcos(beta/dble(2))
           sb=-dsin(beta/dble(2))

!  SET UP NONRELATIVISTIC ROTATION MATRIX
         do l=0,lmax
           do m1=-l,l
           do m2=-l,l

            eima=cdexp(-ci*m2*alfa)
              eimg=cdexp(-ci*m1*gamma)
              db=dble(0)
              kmin=max(0,m1-m2)
              kmax=min(l-m2,l+m1)
              do k=kmin,kmax
                 db=db+(-1)**k * cb**(2*l+m1-m2-2*k) * sb**(m2-m1+2*k)  &
     &          / (fact(l-m2-k)*fact(l+m1-k)*fact(k+m2-m1)*fact(k))
            enddo
              db=db*dsqrt(fact(l+m1)*fact(l-m1)*fact(l+m2)*fact(l-m2))

            drot(l*l+l+1+m2,l*l+l+1+m1,i,2)=eima*eimg*db

         enddo
           enddo
           enddo

!  SET UP RELATIVISTIC ROTATION MATRIX
         ipos=1
         do kap=1,2*lmax+1
           l=kap/2
           j=l+dble(0.5)
         if(2*l.eq.kap) j=j-dble(1)
           nmu=nint(2*j+1)

           do m1=0,nmu-1
           do m2=0,nmu-1
         mu1=-j+m1
           mu2=-j+m2

            eima=cdexp(-ci*mu2*alfa)
              eimg=cdexp(-ci*mu1*gamma)
              db=dble(0)
              kmin=max(0,nint(mu1-mu2))
              kmax=min(nint(j-mu2),nint(j+mu1))
              do k=kmin,kmax
                 db=db+(-1)**k * cb**(nint(2*j+mu1-mu2)-2*k) *          &
     &		 sb**(nint(mu2-mu1)+2*k) / (fact(nint(j-mu2)-k)                 &
     &         *fact(nint(j+mu1)-k)*fact(k+nint(mu2-mu1))*fact(k))
            enddo
              db=db*dsqrt(fact(nint(j+mu1))*fact(nint(j-mu1))*          &
     &               fact(nint(j+mu2))*fact(nint(j-mu2)))

            drot(ipos+m2,ipos+m1,i,1)=eima*eimg*db

         enddo
           enddo
           ipos=ipos+nmu
           enddo

      enddo



!-----------------------------------------------------------------------
! create the rotation matrix MROTR for vectors in cartesian coordinates
! NOTE:  U^+ D^T U gives the inverse of the real matrix  M
!        for that reason  the transposed matrix is stored as MROTR(J,I)
!-----------------------------------------------------------------------
      do ISYM = 1,NSYMH
!
         do I = 1,3
            do L = 1,3
               CS = 0.0D0
               do K = 1,3
                  CS = CS + DROT(K+1,I+1,ISYM,2)*USC(K,L)
               enddo
               W3X3(I,L) = CS
            enddo
         enddo
!
         do I = 1,3
            do L = 1,3
               CS = 0.0D0
               do K = 1,3
                  CS = CS + dconjg(USC(K,I))*W3X3(K,L)
               enddo
               if ( dimag(CS).GT.1D-8 ) write (*,*) 'ISYM=',ISYM,       &
     &              ' MROT',I,L,CS,' ???????????'
! see above >> MROTR(I,L,ISYM) = Dreal(CS)
               MROTR(L,I,ISYM) = Dreal(CS)
            enddo
         enddo
!
      enddo



!                     create matrix for inversion
!-----------------------------------------------------------------------
      mrotr(:,:,iinv)=dble(0)
        do i=1,3
           mrotr(i,i,iinv)=dble(-1)
        enddo

      drot(:,:,iinv,:)=dcmplx(0)
        i=0
        k=0
        do l=0,lmax
           do m=1,2*l+1
              i=i+1
              drot(i,i,iinv,2)=dcmplx(-1,0)**l
           enddo
           do m=1,2*(2*l+1)
              k=k+1
              drot(k,k,iinv,1)=dcmplx(-1,0)**l
           enddo
        enddo


!-----------------------------------------------------------------------
!                         include inversion
!-----------------------------------------------------------------------
      do ISYM = 2,NSYMH
         ISYMP = NSYMH + ISYM
        
         call ZGEMM('N','N',NKM,NKM,NKM,C1,DROT(1,1,ISYM,2),NKMMAX,     &
     &              DROT(1,1,IINV,2),NKMMAX,C0,DROT(1,1,ISYMP,2),NKMMAX)
         call ZGEMM('N','N',NKM,NKM,NKM,C1,DROT(1,1,ISYM,1),NKMMAX,     &
     &              DROT(1,1,IINV,1),NKMMAX,C0,DROT(1,1,ISYMP,1),NKMMAX)

         call DGEMM('N','N',3,3,3,1D0,MROTR(1,1,ISYM),3,MROTR(1,1,IINV),&
     &              3,0D0,MROTR(1,1,ISYMP),3)
      enddo

!=======================================================================
!            set up of transformation matrices completed
!=======================================================================

      if(debug)then
        open(77,file='mrotr.txt')
        do i=1,48
        if(i.le.nsymh) then
           write(77,*) 'SYMMETRY OPERATION ',i,symsymcub(i)
        else
           write(77,*) 'SYMMETRY OPERATION ',i,symsymcub(i-nsymh),'+I'
        endif
        do l=1,3
        do k=1,3
        if(dabs(mrotr(l,k,i)).lt.0.000001) mrotr(l,k,i)=dble(0)
        enddo
        write(77,'(3f14.6)') mrotr(l,:,i)
        enddo
        enddo
        close(77)
      endif


        return
        end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: strcc.f90,v $:
! $Revision: 1.10 $
! $Author: jorissen $
! $Date: 2012/10/23 18:41:32 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE STRCC(ERYD,ALAT,RESTART)
!   ********************************************************************
!   *                                                                  *
!   *    CALCULATE ALL QUANTITIES WHICH DEPEND ON THE ENERGY           *
!   *                                                                  *
!   *    the  terms  QQMLRS( MMLL, S, IQQP )  set up in  <STRAA>       *
!   *    are multiplied by  IILERS(LL,S,IQQP)  to save storage         *
!   *    this term is stored and removed at the next call of           *
!   *    <STRCC>                                                       *
!   *                                                                  *
!   ********************************************************************
!
      use boundaries
        use workstrfacs
        use workstrfacs2
        use workstrfacssimple,only: copy_workstrfacssimple
        use controls,only: singleprec

      IMPLICIT NONE


!
! PARAMETER definitions
!
      REAL*8 PI
      PARAMETER ( PI=3.141592653589793238462643D0 )
      COMPLEX*16 CI,C0
      PARAMETER (CI=(0.0D0,1.0D0), C0=(0.0D0,0.0D0))
	  real*8,parameter :: Ewald_terms_threshold=1.d14
	  ! For SnO2 Sn M4 edge FSR, 1.d8 gives much improved but somewhat broadened spectrum at the tail end;
	  ! 1.d30 gives unimproved spectrum where tail is completely wrong due to divergent Ewald summation.
	  ! 1.d20 gives only marginal improvement.
	  ! 1.d15-16 gets most of the correction but still lacking in a few energy points.
	  ! 1.d05-14 gets the complete improvement.
	  
	  

! Dummy arguments
!
      REAL*8 ALAT
      COMPLEX*16 ERYD
      LOGICAL RESTART
!
! Local variables
!
      REAL*8 ALPHA,test
      COMPLEX*16 EHOCHJ,EPWMLLH(0:LLARR),PDU,ealpha,d300b 
      INTEGER ICALL,IQQP,J13,J22,LL,MM,MMLL,S
        logical,parameter :: debug=.false.
      SAVE ICALL
!
      DATA ICALL/0/
!
      IF (RESTART) ICALL = 0
      
      IF (.NOT. RESTART) THEN



700   continue !KJ 1-2012 come here after changing Ewald parameter eta at end of this routine
      EDU = ERYD/(2*PI/ALAT)**2
      PDU = CDSQRT(EDU)
!
!  ===============================================================
!                      ********
!                      * DLM1 *
!                      ********
!  /D (6)/
!
      EPWMLLH(0) = 1.0D0
      D1TERM3(0) = CDEXP(EDU/ETA)
!
      DO LL = 1,LLMAX
         EPWMLLH(LL) = EPWMLLH(LL-1)*CI/PDU
         D1TERM3(LL) = D1TERM3(LL-1)/PDU
      END DO
!
!  ===============================================================
!                      ********
!                      * DLM2 *
!                      ********
!
!  ---------------------------------------------------------------
      IF ( ICALL.EQ.0 ) THEN
         IILERS=C0 !KJ CALL ZCOPY((1+LLARR)*NRDLMAX*NQQPMAX,C0,0,IILERS,1)
      ELSE
!     remove the energy-dependent factor IILERS from the last run
!
         DO IQQP = 1,NQQP
            DO S = 1,SMAX(IQQP)
!
               MMLL = 0
               DO LL = 0,LLMAX
!
                  DO MM = -LL, + LL
                     MMLL = MMLL + 1
                     QQMLRS(MMLL,S,IQQP) = QQMLRS(MMLL,S,IQQP) /IILERS(LL,S,IQQP)
                  END DO
               END DO
            END DO
         END DO
      END IF
!  ---------------------------------------------------------------
!
      ICALL = ICALL + 1
!        open(127,file='testtest.txt',position='append')
!
      DO IQQP = 1,NQQP
         DO S = 1,SMAX(IQQP)
            DO LL = 0,LLMAX
               EHOCHJ = 1.0D0
               IILERS(LL,S,IQQP) = 0.0D0
               DO J22 = 0,J22MAX
                  IILERS(LL,S,IQQP) = IILERS(LL,S,IQQP)   + EHOCHJ*GGJLRS(J22,LL,S,IQQP)
                  EHOCHJ = EHOCHJ*EDU
               END DO
!               test=abs(ehochj/edu *ggjlrs(j22max,ll,s,iqqp))  /abs(iilers(ll,s,iqqp))
!               if(test.gt.0.00000001) then
!                   write(127,*) iqqp,s,ll,j22max
!                   write(127,'(4e12.5)') iilers(ll,s,iqqp),test
!                 endif
!
!     /D (20) AND (22)/
               IILERS(LL,S,IQQP) = IILERS(LL,S,IQQP)*EPWMLLH(LL)
            END DO
         END DO
      END DO

!        close(127)
!
!  ---------------------------------------------------------------
!     multiply the energy-dependent factor IILERS for the
!     current energy  ERYD
!
      DO IQQP = 1,NQQP
         DO S = 1,SMAX(IQQP)
!
            MMLL = 0
            DO LL = 0,LLMAX
!
               DO MM = -LL, + LL
                  MMLL = MMLL + 1
                  QQMLRS(MMLL,S,IQQP) = QQMLRS(MMLL,S,IQQP)  *IILERS(LL,S,IQQP)
               END DO
            END DO
         END DO
      END DO
!
!  ===============================================================
!                      ********
!                      * DLM3 *
!                      ********
!    /D (13)/
!

!      IF (DEBUG) THEN
!         if(dble(eryd).gt.dble(8.0)) then
!	     open(71,file='d300terms.txt')
!         D300 = 0.0D0
!         EHOCHJ = 1.0D000
!         ALPHA = ALPHA0
!	     ealpha = ehochj*alpha
!	     d300b = 0.0d0
!         J13 = -1
! 110     CONTINUE
!         J13 = J13 + 1
!         D300 = ALPHA*EHOCHJ + D300
!	     d300b = ealpha + d300b 
!	     write(71,'(i5,7(e25.16,x))') j13,dble(d300),alpha,dble(ehochj),dble(alpha*ehochj),dble(ealpha),dble(d300b) 
!         ALPHA = ALPHA*(2.0D0*J13-1.0D0)  /(ETA*(J13+1.0D0)*(2.0D0*J13+1.0D0))
!         EHOCHJ = EHOCHJ*EDU
!	     ealpha = ealpha *( edu *(2.0D0*J13-1.0D0)  /(ETA*(J13+1.0D0)*(2.0D0*J13+1.0D0)))
!        prevent floating point underflow
!         IF ( ABS(EHOCHJ).LT.1D-50 ) EHOCHJ = C0
!
!         IF ( CDABS(ALPHA*EHOCHJ/D300).GT.1.0D-10 ) GOTO 110
!         IF ( J13.LT.J13MIN ) GOTO 110
!	     close(71)
!	     write(*,*) 'ERYD IS ',eryd
!	     write(*,*) 'ETA IS ',eta
!	    ! stop
!	     else
!	     write(*,*) 'ERYD IS ',eryd
!	     endif
!	  ENDIF !DEBUG
	  
      D300 = 0.0D0
      EHOCHJ = 1.0D000
      ALPHA = ALPHA0
      J13 = -1
 100  CONTINUE
      J13 = J13 + 1
      D300 = ALPHA*EHOCHJ + D300
      ALPHA = ALPHA*(2.0D0*J13-1.0D0)  /(ETA*(J13+1.0D0)*(2.0D0*J13+1.0D0))
      EHOCHJ = EHOCHJ*EDU
!     prevent floating point underflow
      IF ( ABS(EHOCHJ).LT.1D-50 ) EHOCHJ = C0

      IF ( CDABS(ALPHA*EHOCHJ/D300).GT.1.0D-10 ) GOTO 100
      IF ( J13.LT.J13MIN ) GOTO 100


      if(singleprec) call copy_workstrfacssimple



!KJ 1-2012 If terms are exploding, adjust Ewald parameter to knock them down.
        if ( dble(max(abs(d300),abs(qqmlrs(1,1,1)),abs(d1term3(1)))) .gt. Ewald_terms_threshold ) then
		   call change_eta(eryd)
		   ICALL=0
		   ! recalculate everything
		   goto 700
		endif
		



      END IF
! .NOT.RESTART

      if(.not.restart.and.debug) then
         write(101,*) 'eryd in strcc',eryd
         write(101,*) 'edu',edu
         write(101,*) 'alat',alat
         write(101,*) 'pi',pi
         write(101,*) 'd300',d300
         write(101,*) 'd1term3',d1term3
         write(102,*) 'qqmlrs',qqmlrs
  !      stop
      endif

      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: strinit.f90,v $:
! $Revision: 1.11 $
! $Author: jorissen $
! $Date: 2012/02/04 00:38:51 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*==strinit.f    processed by SPAG 6.05Rc at 22:58 on 17 Mar 2002
      SUBROUTINE STRINIT(ETOP,NQ,ALAT,FACT,CGC,gmulti,rmulti)
!      SUBROUTINE STRINIT(PETA,PRMAX,PGMAX,ETOP,PBRX,PBRY,PBRZ,PR1,PR2,  &
!     &                   PR3,NRDLTAB,PQX,PQY,PQZ,PBGX,PBGY,PBGZ,PG1,PG2,&
!     &            PG3,NGRLTAB,NQ,ALAT,FACT,CGC,gmulti,rmulti)
!   ********************************************************************
!   *                                                                  *
!   *               KKR - structure constant routines                  *
!   *                                                                  *
!   *                       ===============                            *
!   *                          <STRINIT>                               *
!   *                       ===============                            *
!   *                                                                  *
!   *  call once to initialize all                                     *
!   *  <STRINIT> calls <VECGEN>, <GAUNT>, <INITS>, <STRAA>             *
!   *  supply:                                                         *
!   *  ARGUMENTS       ETA, RMAX, GMAX, QX,QY,QZ                       *
!   *                                                                  *
!   *                  NT,NQ, NL,NLM,NLMQ, NK,NKM,NLIN, NKKR           *
!   *                     ^   ^                                        *
!   *                  ALAT                                            *
!   *                  ^                                               *
!   *  <STRAA>  calculates all energy- and k-indep. terms of D[L,M]    *
!   *  <INITS>  creates coefficients to transform real non-relat.      *
!   *           G[L,L'] to relat. G[Lam,Lam']                          *
!   *                                                                  *
!   *                                                                  *
!   *                       ===============                            *
!   *                           <STRCC>                                *
!   *                       ===============                            *
!   *                                                                  *
!   *  call once per energy-value                                      *
!   *  <STRC> calls NO other routines                                  *
!   *  supply:                                                         *
!   *                  ERYD,P                                          *
!   *                  ^                                               *
!   *  ERYD is converted to  EDU  used in <STRCC> and <STRBBDD>        *
!   *                                                                  *
!   *                       ===============                            *
!   *                          <STRSET>                                *
!   *                       ===============                            *
!   *  supply:                                                         *
!   *  arguments: DLLMMKE, KX,KY,KZ                                    *
!   *  KX,KY,KZ   in multiples of 2*pi/a  i.e.  in  d.u.'s             *
!   *                                                                  *
!   *  call once per k-point                                           *
!   *  <STRBBDD> is called to get the  D[L,M]'s                        *
!   *  the G[L,L']'s are then set up in a.u.                           *
!   *  conversion is managed by multiplying the gaunts with  2*pi/a    *
!   *  the factor  4*pi  is also included in the gaunts                *
!   *                                                                  *
!   *                       ===============                            *
!   *                          <STRBBDD>                               *
!   *                       ===============                            *
!   *                                                                  *
!   *  call once per k-point                                           *
!   *  supply:                                                         *
!   *  arguments: DLLMMKE, KX,KY,KZ                                    *
!   *  KX,KY,KZ   in multiples of 2*pi/a  i.e.  in  d.u.'s             *
!   *  D[L,M]     is created in  d.u.'s                                *
!   *                                                                  *
!   *  NOTE:   all str-routines work internally in d.u.'s              *
!   *                                                                  *
!   ********************************************************************
!   *                                                                  *
!   *  INITIALIZE CALCULATION OF STRUCTURE CONSTANTS                   *
!   *                                                                  *
!   ********************************************************************
!   *                                                                  *
!   *   ETA    :EWALD PARAMETER                                        *
!   *   RMAX   :RADIUS OF CONVERGENCE SPHERE IN REAL SPACE             *
!   *   GMAX   :RADIUS OF CONVERGENCE SPHERE IN RECIPROCAL SPACE       *
!   *   BRX                                                            *
!   *   BRY    :PRIMITIVE VECTORS IN REAL SPACE  (UNITS OF A)          *
!   *   BRZ                                                            *
!   *   NL     :NUMBER OF L-QUANTUM NUMBERS,LMAX=NL-1                  *
!   *   NQ     :NUMBER OF ATOMS IN THE PRIMITIVE CELL                  *
!   *   QX                                                             *
!   *   QY     :BASIS VECTORS IN REAL SPACE      (UNITS OF A)          *
!   *   QZ                                                             *
!   *                                                                  *
!   ********************************************************************
!   *                                                                  *
!   *   NPT    :NUMBER OF K-POINTS IN IRREDUCIBLE ZONE                 *
!   *   KX                                                             *
!   *   KY     :K-VECTOR     (UNITS OF 2*PI/A)   RECTANGULAR COORD.    *
!   *   KZ                                                             *
!   *                                                                  *
!   ********************************************************************
!   *                                                                  *
!   * NOTE: in contrast to the previous version of <STRINIT> the       *
!   *       subroutine is supplied with ALL necessary structural       *
!   *       information; i.e.          BRX,BRY,BRZ, NQ, QX,QY,QZ       *
!   *                                                                  *
!   *       to avoid conflicts the variable names in the argument list *
!   *       have 'P' added at the beginning                            *
!   *                                                                  *
!   ********************************************************************
!
      use workstrfacs
      use workstrfacs2
      use boundaries
      use controls,only:iprint
      IMPLICIT REAL*8(A-H,O-Z)
!
! PARAMETER definitions
!
      REAL*8 PI,SMALL,ALIM
      PARAMETER (PI=3.141592653589793238462643D0,SMALL=1D-15,ALIM=225D0)
!
! Dummy arguments
!
      REAL*8 ALAT,ETOP !,PETA,PGMAX,PRMAX
      REAL*8 FACT(0:100),CGC(NKMPMAX,2) !,&
!     &       PBRY(3),PBRZ(3),PQX(NQMAX),PQY(NQMAX),PQZ(NQMAX),PBGX(3),PBGY(3),PBGZ(3),PBRX(3)
!      INTEGER PG1(NGRLMAX),PG2(NGRLMAX),PG3(NGRLMAX),PR1(NRDLMAX0),PR2(NRDLMAX0),PR3(NRDLMAX0)
      real*8 rmulti,gmulti
!
! Local variables
!
      REAL*8 B,PRETA,VUC,PRETA2
      INTEGER NQ !,NGRLTAB,NRDLTAB
      INTEGER I,IG123,IQ,LMAX
!
!*** End of declarations rewritten by SPAG
!
!   ********************************************************************
!
      if(iprint.gt.0) WRITE (6,99001)
!      ETA = PETA
!      RMAX = PRMAX
!      GMAX = PGMAX

! -------------------------------- set ETA according to AKAI's algorithm
!
         VUC = BRX(1)*(BRY(2)*BRZ(3)-BRY(3)*BRZ(2)) + BRX(2)      &   !KJ 2-2012 PBRX->BRX etc.
               *(BRY(3)*BRZ(1)-BRY(1)*BRZ(3)) + BRX(3)             &
               *(BRY(1)*BRZ(2)-BRY(2)*BRZ(1))
         VUC = ABS(VUC)
         B = -LOG(SMALL)
         PRETA = 1D0/VUC**(2D0/3D0)/PI
         PRETA = PRETA*0.75D0
         PRETA2 = MAX(PRETA,ABS(ETOP)/ALIM)
      IF (gmax.lt.1.0)  GMAX = SQRT(B*PRETA2)
      IF (rmax.lt.1.0)  RMAX = SQRT(B/PRETA2)/PI
      IF (rmulti.gt.1d-3) rmax=rmax*rmulti  !KJ allows to rescale easily
      IF (gmulti.gt.1d-3) gmax=gmax*gmulti  !KJ
      IF ( ETA.LT.1D-3 ) THEN
         PRETA = 5D-1*SQRT(PRETA)
         ETA = 5D-1*SQRT(PRETA2)
      END IF
!      PETA = ETA
!	  write(*,*) 'ETA is ',eta

      if(eta0.lt.0.01) eta0=eta

!    Remark that, according to the prescription above,
!    The number of r-vectors is directly proportional to the volume of the unit cell
!    The number of g-vectors is inversely proportional to the volume of the unit cell !KJ



!
! ----------------------- copy structure data to be used in COMMON block
!
!        brx=pbrx
!        bry=pbry
!        brz=pbrz
!        bgx=pbgx
!        bgy=pbgy
!        bgz=pbgz
!        qx=pqx
!        qy=pqy
!        qz=pqz

!
! ---------------------- generate the  SMAX  and  NMAX  shortest vectors
! ----------------------------------------- of real and reciprocal space

      if(.not.allocated(EXPGNQ)) &   !Meaning: only on the first run of STRINIT.  I should really find a cleaner way of doing this.
      CALL STRVECGEN(NQ,ALAT)
!      CALL STRVECGEN(NQ,IPRINT,ALAT,RMAX,GMAX,GMAXSQ,NRTAB,SMAX,NMAX,   &
!     &               NQQP,NIJQ,IJQ,BRX,BRY,BRZ,BGX,BGY,BGZ,QX,QY,QZ,    &
!     &               QQPX,QQPY,QQPZ,G1,G2,G3,R1,R2,R3,NGRLMAX,NRDLMAX,  &
!     &               NRDLMAX0,NQMAX,NQQPMAX)

! ----------------------------------------- calculate Gaunt coefficients

      LMAX = NL - 1
      LLMAX = 2*LMAX
!      MMLLMAX = (LLMAX+1)**2
!
      CALL STRGAUNT(LMAX,ALAT,FACT,GNT,NGNT,IGNT,CIPWL,NLMAX,IG123,LGNT12,LGNT123)

! ------------------------------------ calculate transformation matrices

      CALL STRSMAT(LMAX,CGC,SRREL,NRREL,IRREL,NKMMAX,NKMPMAX)


      CALL STRAA(NQ,FACT,IG123)
!      CALL STRAA(IPRINT,RMAX,NRTAB,SMAX,NQ,NMAX,NQQP,LLMAX,ETA,ALPHA0,  &
!     &           BRX,BRY,BRZ,BGX,BGY,BGZ,QQPX,QQPY,QQPZ,EXPGNQ,QQMLRS,  &
!     &           G1,G2,G3,G123MAX,R1,R2,R3,R123MAX,INDR,T,HP,QJLTAB,    &
!     &           CQMLTAB,GGJLRS,FACT,IG123,LGNT12,LGNT123,NQMAX,NLMAX,  &
!     &           NGRLMAX,NRDLMAX,NRDLMAX0,J22MAX,NMARR,NQQPMAX,LLARR,   &
!     &           NLLMMMAX)
! ---------------------------------------- copy data to be used in MAIN
!      NRDLTAB = NRTAB
!      DO I = 1,NRDLTAB
!         PR1(I) = R1(I)
!         PR2(I) = R2(I)
!         PR3(I) = R3(I)
!      END DO
!      NGRLTAB = NMAX
!      DO I = 1,NGRLTAB
!         PG1(I) = G1(I)
!         PG2(I) = G2(I)
!         PG3(I) = G3(I)
!      END DO

      RETURN
!
99001 FORMAT (/,1X,79('*'),/,35X,'<STRINIT>',/,1X,79('*'),//,10X,'parameters for calculation of structure constants:')
99002 FORMAT (12X,'(',F10.5,',',F10.5,',',F10.5,' )')
99003 FORMAT (/,10X,'primitive vectors for Bravais lattice',/)
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: lu.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine cgetrf( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  CGETRF computes an LU factorization of a general M-by-N matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 3 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX array, dimension (LDA,N)
!          On entry, the M-by-N matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero. The
!                factorization has been completed, but the factor U
!                is exactly singular, and division by zero will occur
!                if it is used to solve a system of equations.
!
!  ==================================================================
!
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
!     ..
!     .. External Subroutines ..
      EXTERNAL           CGEMM, CGETF2, CLASWP, CTRSM, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGETRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )    RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'CGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
!
!        Use unblocked code.
!
         CALL CGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
!
!        Use blocked code.
!
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
!
!           Factor diagonal and subdiagonal blocks and test for exact
!           singularity.
!
            CALL CGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
!
!           Adjust INFO and the pivot indices.
!
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )    INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
!
!           Apply interchanges to columns 1:J-1.
!
            CALL CLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
!
            IF( J+JB.LE.N ) THEN
!
!              Apply interchanges to columns J+JB:N.
!
               CALL CLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,     &
     &                      IPIV, 1 )
!
!              Compute block row of U.
!
             CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,   &
     &                   N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),   &
     &                     LDA )
               IF( J+JB.LE.M ) THEN
!
!                 Update trailing submatrix.
!
                CALL CGEMM( 'No transpose', 'No transpose', M-J-JB+1,   &
     &                       N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,     &
     &                       A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),   &
     &                       LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of CGETRF
!
      END

      SUBROUTINE CGETF2( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  CGETF2 computes an LU factorization of a general m-by-n matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX array, dimension (LDA,N)
!          On entry, the m by n matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is
!               used to solve a system of equations.
!
!  ==================================================================
!
!     .. Parameters ..
      COMPLEX            ONE, ZERO
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),                    &
     &                   ZERO = ( 0.0E+0, 0.0E+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            J, JP
!     ..
!     .. External Functions ..
      INTEGER            ICAMAX
      EXTERNAL           ICAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           CGERU, CSCAL, CSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGETF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
      DO 10 J = 1, MIN( M, N )
!
!        Find pivot and test for singularity.
!
         JP = J - 1 + ICAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
!
!           Apply the interchange to columns 1:N.
!
            IF( JP.NE.J )                                               &
     &         CALL CSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
!
!           Compute elements J+1:M of J-th column.
!
            IF( J.LT.M )                                                &
     &         CALL CSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
!
         ELSE IF( INFO.EQ.0 ) THEN
!
            INFO = J
         END IF
!
         IF( J.LT.MIN( M, N ) ) THEN
!
!           Update trailing submatrix.
!
            CALL CGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ),    &
     &                  LDA, A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
!
!     End of CGETF2
!
      END
      SUBROUTINE cgetrs( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
!  -- LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  CGETRS solves a system of linear equations
!     A * X = B,  A**T * X = B,  or  A**H * X = B
!  with a general N-by-N matrix A using the LU factorization computed
!  by CGETRF.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) COMPLEX array, dimension (LDA,N)
!          The factors L and U from the factorization A = P*L*U
!          as computed by CGETRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from CGETRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  B       (input/output) COMPLEX array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  ==================================================================
!
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           CLASWP, CTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.        &
     &    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGETRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 )                                       &
     &   RETURN
!
      IF( NOTRAN ) THEN
!
!        Solve A * X = B.
!
!        Apply row interchanges to the right hand sides.
!
         CALL CLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
!
!        Solve L*X = B, overwriting B with X.
!
         CALL CTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,  &
     &               ONE, A, LDA, B, LDB )
!
!        Solve U*X = B, overwriting B with X.
!
         CALL CTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,    &
     &               NRHS, ONE, A, LDA, B, LDB )
      ELSE
!
!        Solve A**T * X = B  or A**H * X = B.
!
!        Solve U'*X = B, overwriting B with X.
!
         CALL CTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,  &
     &               A, LDA, B, LDB )
!
!        Solve L'*X = B, overwriting B with X.
!
         CALL CTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,   &
     &               LDA, B, LDB )
!
!        Apply row interchanges to the solution vectors.
!
         CALL CLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
!
      RETURN
!
!     End of CGETRS
!
      END
      SUBROUTINE XERBLA( SRNAME, INFO )
!
!  -- LAPACK auxiliary routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER*6        SRNAME
      INTEGER            INFO
!     ..
!
!  Purpose
!  =======
!
!  XERBLA  is an error handler for the LAPACK routines.
!  It is called by an LAPACK routine if an input parameter has an
!  invalid value.  A message is printed and execution stops.
!
!  Installers may consider modifying the STOP statement in order to
!  call system-specific exception-handling facilities.
!
!  Arguments
!  =========
!
!  SRNAME  (input) CHARACTER*6
!          The name of the routine which called XERBLA.
!
!  INFO    (input) INTEGER
!          The position of the invalid parameter in the parameter list
!          of the calling routine.
!
! ==================================================================
!
!     .. Executable Statements ..
!
      WRITE( *, FMT = 9999 )SRNAME, INFO
!
      STOP
!
 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ',I2,' had ',  &
     &      'an illegal value' )
!
!     End of XERBLA
!
      END
      subroutine  cswap (n,cx,incx,cy,incy)
!
!     interchanges two vectors.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex cx(*),cy(*),ctemp
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        ctemp = cx(ix)
        cx(ix) = cy(iy)
        cy(iy) = ctemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!       code for both increments equal to 1
   20 do 30 i = 1,n
        ctemp = cx(i)
        cx(i) = cy(i)
        cy(i) = ctemp
   30 continue
      return
      end
      subroutine  cscal(n,ca,cx,incx)
!
!     scales a vector by a constant.
!     jack dongarra, linpack,  3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex ca,cx(*)
      integer i,incx,n,nincx
!
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      nincx = n*incx
      do 10 i = 1,nincx,incx
        cx(i) = ca*cx(i)
   10 continue
      return
!
!        code for increment equal to 1
!
   20 do 30 i = 1,n
        cx(i) = ca*cx(i)
   30 continue
      return
      end
      SUBROUTINE CGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
!     .. Scalar Arguments ..
      COMPLEX            ALPHA
      INTEGER            INCX, INCY, LDA, M, N
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  CGERU  performs the rank 1 operation
!
!     A := alpha*x*y' + A,
!
!  where alpha is a scalar, x is an m element vector, y is an n
!  element vector and A is an m by n matrix.
!
!  Parameters
!  ==========
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the
!           matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX         .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - COMPLEX          array of dimension at least
!           ( 1 + ( m - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the m
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  Y      - COMPLEX          array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y.
!           Unchanged on exit.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!  A      - COMPLEX          array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients. On exit, A is
!           overwritten by the updated matrix.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as
!           declared in the calling (sub) program. LDA must be
!           at least max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     .. Local Scalars ..
      COMPLEX            TEMP
      INTEGER            I, INFO, IX, J, JY, KX
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CGERU ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )               &
     &   RETURN
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of CGERU .
!
      END
      SUBROUTINE CLASWP( N, A, LDA, K1, K2, IPIV, INCX )
!
!  -- LAPACK auxiliary routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX            A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  CLASWP performs a series of row interchanges on the matrix A.
!  One row interchange is initiated for each of rows K1 through
!  K2 of A.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.
!
!  A       (input/output) COMPLEX array, dimension (LDA,N)
!          On entry, the matrix of column dimension N to which the row
!          interchanges will be applied.
!          On exit, the permuted matrix.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!
!  K1      (input) INTEGER
!          The first element of IPIV for which a row interchange will
!          be done.
!
!  K2      (input) INTEGER
!          The last element of IPIV for which a row interchange will
!          be done.
!
!  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
!          The vector of pivot indices.  Only the elements in
!          positions K1 through K2 of IPIV are accessed.
!          IPIV(K) = L implies rows K and L are to be interchanged.
!
!  INCX    (input) INTEGER
!          The increment between successive values of IPIV.  If IPIV
!          is negative, the pivots are applied in reverse order.
!
! ==================================================================
!
!     .. Local Scalars ..
      INTEGER            I, IP, IX
!     ..
!     .. External Subroutines ..
      EXTERNAL           CSWAP
!     ..
!     .. Executable Statements ..
!
!     Interchange row I with row IPIV(I) for each of rows K1
!     through K2.
!
      IF( INCX.EQ.0 )                                                   &
     &   RETURN
      IF( INCX.GT.0 ) THEN
         IX = K1
      ELSE
         IX = 1 + ( 1-K2 )*INCX
      END IF
      IF( INCX.EQ.1 ) THEN
         DO 10 I = K1, K2
            IP = IPIV( I )
            IF( IP.NE.I )                                               &
     &         CALL CSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
   10    CONTINUE
      ELSE IF( INCX.GT.1 ) THEN
         DO 20 I = K1, K2
            IP = IPIV( IX )
            IF( IP.NE.I )                                               &
     &         CALL CSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   20    CONTINUE
      ELSE IF( INCX.LT.0 ) THEN
         DO 30 I = K2, K1, -1
            IP = IPIV( IX )
            IF( IP.NE.I )                                               &
     &         CALL CSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   30    CONTINUE
      END IF
!
      RETURN
!
!     End of CLASWP
!
      END
      SUBROUTINE CTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,A,LDA,   &
     &                   B, LDB )
!     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      COMPLEX            ALPHA
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  CTRSM  solves one of the matrix equations
!
!     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
!
!  where alpha is a scalar, X and B are m by n matrices, A is a unit,
!  or non-unit,  upper or lower triangular matrix  and  op( A )  is
!  one of
!
!     op( A ) = A   or   op( A ) = A'   or   op( A ) = conjg( A' ).
!
!  The matrix X is overwritten on B.
!
!  Parameters
!  ==========
!
!  SIDE   - CHARACTER*1.
!           On entry, SIDE specifies whether op( A ) appears on the
!           left or right of X as follows:
!
!              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
!
!              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
!
!           Unchanged on exit.
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix A is an upper
!           or lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used
!           in the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n'   op( A ) = A.
!
!              TRANSA = 'T' or 't'   op( A ) = A'.
!
!              TRANSA = 'C' or 'c'   op( A ) = conjg( A' ).
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of B. M must
!           be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of B.  N
!           must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX         .
!           On entry,  ALPHA specifies the scalar  alpha. When alpha
!           is zero then  A is not referenced and  B need not be set
!           before entry.
!           Unchanged on exit.
!

!  A - COMPLEX array of DIMENSION ( LDA, k ), where k is m
!           when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
!           Before entry with UPLO = 'U' or 'u', the leading k by k
!           upper triangular part of the array A must contain the
!           upper triangular matrix and the strictly lower triangular
!           part of A is not referenced.
!           Before entry  with  UPLO = 'L' or 'l',  the  leading  k
!           by k lower triangular part of the array  A must contain
!           the lower triangular matrix  and the strictly upper
!           triangular part of A is not referenced.
!           Note that when  DIAG = 'U' or 'u',  the diagonal elements
!           of A  are not referenced either,  but are assumed to be
!           unity.  Unchanged on exit.

!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as
!           declared in the calling (sub) program.  When
!           SIDE = 'L' or 'l'  then LDA  must be at least
!           max( 1, m ),  when  SIDE = 'R' or 'r'
!           then LDA must be at least max( 1, n ).
!           Unchanged on exit.
!
!  B      - COMPLEX          array of DIMENSION ( LDB, n ).
!           Before entry,  the leading  m by n part of the array
!           B must contain  the  right-hand  side  matrix  B,  and
!           on exit  is overwritten by the solution matrix  X.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as
!           declared in  the  calling  (sub)  program.   LDB  must
!           be  at  least max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
!     .. Local Scalars ..
      LOGICAL            LSIDE, NOCONJ, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      COMPLEX            TEMP
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOCONJ = LSAME( TRANSA, 'T' )
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
!
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.                       &
     &         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.                       &
     &         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.                       &
     &         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CTRSM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 )                                                      &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*inv( A )*B.
!
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*inv( A' )*B
!           or    B := alpha*inv( conjg( A' ) )*B.
!
            IF( UPPER )THEN
               DO 140, J = 1, N
                  DO 130, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     IF( NOCONJ )THEN
                        DO 110, K = 1, I - 1
                           TEMP = TEMP - A( K, I )*B( K, J )
  110                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/A( I, I )
                     ELSE
                        DO 120, K = 1, I - 1
                           TEMP = TEMP - CONJG( A( K, I ) )*B( K, J )
  120                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/CONJG( A( I, I ) )
                     END IF
                     B( I, J ) = TEMP
  130             CONTINUE
  140          CONTINUE
            ELSE
               DO 180, J = 1, N
                  DO 170, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     IF( NOCONJ )THEN
                        DO 150, K = I + 1, M
                           TEMP = TEMP - A( K, I )*B( K, J )
  150                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/A( I, I )
                     ELSE
                        DO 160, K = I + 1, M
                           TEMP = TEMP - CONJG( A( K, I ) )*B( K, J )
  160                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/CONJG( A( I, I ) )
                     END IF
                     B( I, J ) = TEMP
  170             CONTINUE
  180          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*B*inv( A ).
!
            IF( UPPER )THEN
               DO 230, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 190, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  190                CONTINUE
                  END IF
                  DO 210, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 200, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  200                   CONTINUE
                     END IF
  210             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 220, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  220                CONTINUE
                  END IF
  230          CONTINUE
            ELSE
               DO 280, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 240, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  240                CONTINUE
                  END IF
                  DO 260, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 250, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  250                   CONTINUE
                     END IF
  260             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 270, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  270                CONTINUE
                  END IF
  280          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*B*inv( A' )
!           or    B := alpha*B*inv( conjg( A' ) ).
!
            IF( UPPER )THEN
               DO 330, K = N, 1, -1
                  IF( NOUNIT )THEN
                     IF( NOCONJ )THEN
                        TEMP = ONE/A( K, K )
                     ELSE
                        TEMP = ONE/CONJG( A( K, K ) )
                     END IF
                     DO 290, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  290                CONTINUE
                  END IF
                  DO 310, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        IF( NOCONJ )THEN
                           TEMP = A( J, K )
                        ELSE
                           TEMP = CONJG( A( J, K ) )
                        END IF
                        DO 300, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  300                   CONTINUE
                     END IF
  310             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 320, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  320                CONTINUE
                  END IF
  330          CONTINUE
            ELSE
               DO 380, K = 1, N
                  IF( NOUNIT )THEN
                     IF( NOCONJ )THEN
                        TEMP = ONE/A( K, K )
                     ELSE
                        TEMP = ONE/CONJG( A( K, K ) )
                     END IF
                     DO 340, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  340                CONTINUE
                  END IF
                  DO 360, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        IF( NOCONJ )THEN
                           TEMP = A( J, K )
                        ELSE
                           TEMP = CONJG( A( J, K ) )
                        END IF
                        DO 350, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  350                   CONTINUE
                     END IF
  360             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 370, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  370                CONTINUE
                  END IF
  380          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of CTRSM .
!
      END
      SUBROUTINE CGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA,B,LDB,  &
     &                   BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      COMPLEX            ALPHA, BETA
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  CGEMM  performs one of the matrix-matrix operations
!
!     C := alpha*op( A )*op( B ) + beta*C,
!
!  where  op( X ) is one of
!
!     op( X ) = X   or   op( X ) = X'   or   op( X ) = conjg( X' ),
!
!  alpha and beta are scalars, and A, B and C are matrices,
!  with op( A ) an m by k matrix,  op( B )  a  k by n matrix and
!  C an m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be
!           used in the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n',  op( A ) = A.
!
!              TRANSA = 'T' or 't',  op( A ) = A'.
!
!              TRANSA = 'C' or 'c',  op( A ) = conjg( A' ).
!
!           Unchanged on exit.
!
!  TRANSB - CHARACTER*1.
!           On entry, TRANSB specifies the form of op( B ) to be
!           used in the matrix multiplication as follows:
!
!              TRANSB = 'N' or 'n',  op( B ) = B.
!
!              TRANSB = 'T' or 't',  op( B ) = B'.
!
!              TRANSB = 'C' or 'c',  op( B ) = conjg( B' ).
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry,  M  specifies  the number  of rows  of the
!           matrix op( A )  and of the  matrix  C.  M  must  be at
!           least  zero. Unchanged on exit.
!
!  N      - INTEGER.
!           On entry,  N  specifies the number  of columns of the
!           matrix op( B ) and the number of columns of the matrix C.
!           N must be at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry,  K  specifies  the number of columns of the
!           matrix op( A ) and the number of rows of the matrix
!           op( B ). K must be at least  zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX         .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A   - COMPLEX          array of DIMENSION ( LDA, ka ), where ka is
!        k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
!        Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
!        part of the array  A  must contain the matrix  A,  otherwise
!        the leading  k by m  part of the array  A  must contain  the
!        matrix A.
!        Unchanged on exit.
!
!  LDA - INTEGER.
!        On entry, LDA specifies the first dimension of A as declared
!        in the calling (sub) program. When  TRANSA = 'N' or 'n' then
!        LDA must be at least  max( 1, m ), otherwise  LDA must be at
!        least  max( 1, k ).
!        Unchanged on exit.
!
!  B   - COMPLEX          array of DIMENSION ( LDB, kb ), where kb is
!        n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
!        Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
!        part of the array  B  must contain the matrix  B,  otherwise
!        the leading  n by k  part of the array  B  must contain  the
!        matrix B.
!        Unchanged on exit.
!
!  LDB - INTEGER.
!        On entry, LDB specifies the first dimension of B as declared
!        in the calling (sub) program. When  TRANSB = 'N' or 'n' then
!        LDB must be at least  max( 1, k ), otherwise  LDB must be at
!        least  max( 1, n ).
!        Unchanged on exit.
!
!  BETA   - COMPLEX         .
!        On entry,  BETA  specifies the scalar  beta.  When  BETA  is
!        supplied as zero then C need not be set on input.
!        Unchanged on exit.
!
!  C      - COMPLEX          array of DIMENSION ( LDC, n ).
!        Before entry, the leading  m by n  part of the array  C must
!        contain the matrix  C,  except when  beta  is zero, in which
!        case C need not be set on entry.
!        On exit, the array  C  is overwritten by the  m by n  matrix
!        ( alpha*op( A )*op( B ) + beta*C ).
!
!  LDC    - INTEGER.
!        On entry, LDC specifies the first dimension of C as declared
!        in  the  calling  (sub)  program.   LDC  must  be  at  least
!        max( 1, m ).
!        Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
!     .. Local Scalars ..
      LOGICAL            CONJA, CONJB, NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      COMPLEX            TEMP
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     ..
!     .. Executable Statements ..
!
!  Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
!  conjugated or transposed, set  CONJA and CONJB  as true if  A  and
!  B  respectively are to be  transposed but  not conjugated  and set
!  NROWA, NCOLA and  NROWB  as the number of rows and  columns  of  A
!  and the number of rows of  B  respectively.
!
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      CONJA = LSAME( TRANSA, 'C' )
      CONJB = LSAME( TRANSB, 'C' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.                       &
     &         ( .NOT.CONJA                ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.                       &
     &         ( .NOT.CONJB                ).AND.                       &
     &         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CGEMM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.                                  &
     &    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE )))   &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( NOTB )THEN
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B + beta*C.
!
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE IF( CONJA )THEN
!
!           Form  C := alpha*conjg( A' )*B + beta*C.
!
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + CONJG( A( L, I ) )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B + beta*C
!
            DO 150, J = 1, N
               DO 140, I = 1, M
                  TEMP = ZERO
                  DO 130, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  130             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  140          CONTINUE
  150       CONTINUE
         END IF
      ELSE IF( NOTA )THEN
         IF( CONJB )THEN
!
!           Form  C := alpha*A*conjg( B' ) + beta*C.
!
            DO 200, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 160, I = 1, M
                     C( I, J ) = ZERO
  160             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 170, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  170             CONTINUE
               END IF
               DO 190, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*CONJG( B( J, L ) )
                     DO 180, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  180                CONTINUE
                  END IF
  190          CONTINUE
  200       CONTINUE
         ELSE
!
!           Form  C := alpha*A*B'          + beta*C
!
            DO 250, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 210, I = 1, M
                     C( I, J ) = ZERO
  210             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 220, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  220             CONTINUE
               END IF
               DO 240, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 230, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  230                CONTINUE
                  END IF
  240          CONTINUE
  250       CONTINUE
         END IF
      ELSE IF( CONJA )THEN
         IF( CONJB )THEN
!
!           Form  C := alpha*conjg( A' )*conjg( B' ) + beta*C.
!
            DO 280, J = 1, N
               DO 270, I = 1, M
                  TEMP = ZERO
                  DO 260, L = 1, K
                  TEMP = TEMP + CONJG( A( L, I ) )*CONJG( B( J, L ) )
  260             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  270          CONTINUE
  280       CONTINUE
         ELSE
!
!           Form  C := alpha*conjg( A' )*B' + beta*C
!
            DO 310, J = 1, N
               DO 300, I = 1, M
                  TEMP = ZERO
                  DO 290, L = 1, K
                     TEMP = TEMP + CONJG( A( L, I ) )*B( J, L )
  290             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  300          CONTINUE
  310       CONTINUE
         END IF
      ELSE
         IF( CONJB )THEN
!
!           Form  C := alpha*A'*conjg( B' ) + beta*C
!
            DO 340, J = 1, N
               DO 330, I = 1, M
                  TEMP = ZERO
                  DO 320, L = 1, K
                     TEMP = TEMP + A( L, I )*CONJG( B( J, L ) )
  320             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  330          CONTINUE
  340       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B' + beta*C
!
            DO 370, J = 1, N
               DO 360, I = 1, M
                  TEMP = ZERO
                  DO 350, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  350             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  360          CONTINUE
  370       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of CGEMM .
!
      END

      INTEGER          FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,  &
     &                 N4 )
!
!  -- LAPACK auxiliary routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER*( * )    NAME, OPTS
      INTEGER            ISPEC, N1, N2, N3, N4
!     ..
!
!  Purpose
!  =======
!
!  ILAENV is called from the LAPACK routines to choose problem-
!  dependent parameters for the local environment.  See ISPEC for
!  a description of the parameters.
!
!  This version provides a set of parameters which should give good,
!  but not optimal, performance on many of the currently available
!  computers.  Users are encouraged to modify this subroutine to set
!  the tuning parameters for their particular machine using the option
!  and problem size information in the arguments.
!
!  This routine will not function correctly if it is converted to all
!  lower case.  Converting it to all upper case is allowed.
!
!  Arguments
!  =========
!
!  ISPEC   (input) INTEGER
!       Specifies the parameter to be returned as the value of
!       ILAENV.
!       = 1: the optimal blocksize; if this value is 1, an unblocked
!            algorithm will give the best performance.
!       = 2: the minimum block size for which the block routine
!            should be used; if the usable block size is less than
!            this value, an unblocked routine should be used.
!       = 3: the crossover point (in a block routine, for N less
!            than this value, an unblocked routine should be used)
!       = 4: the number of shifts, used in the nonsymmetric
!            eigenvalue routines
!       = 5: the minimum column dimension for blocking to be used;
!            rectangular blocks must have dimension at least k by m,
!            where k is given by ILAENV(2,...) and m by ILAENV(5,...)
!       = 6: the crossover point for the SVD (when reducing an m by n
!            matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
!            this value, a QR factorization is used first to reduce
!            the matrix to a triangular form.)
!       = 7: the number of processors
!       = 8: the crossover point for the multishift QR and QZ methods
!            for nonsymmetric eigenvalue problems.
!
!  NAME    (input) CHARACTER*(*)
!          The name of the calling subroutine, in either upper case or
!          lower case.
!
!  OPTS    (input) CHARACTER*(*)
!          The character options to the subroutine NAME, concatenated
!          into a single character string.  For example, UPLO = 'U',
!          TRANS = 'T', and DIAG = 'N' for a triangular routine would
!          be specified as OPTS = 'UTN'.
!
!  N1      (input) INTEGER
!  N2      (input) INTEGER
!  N3      (input) INTEGER
!  N4      (input) INTEGER
!          Problem dimensions for the subroutine NAME; these may not
!          all be required.
!
! (ILAENV) (output) INTEGER
!          >= 0: the value of the parameter specified by ISPEC
!          < 0:  if ILAENV = -k, the k-th argument had an illegal
!                value.
!
!  Further Details
!  ===============
!
!  The following conventions have been used when calling ILAENV from
!  the LAPACK routines:
!  1)  OPTS is a concatenation of all of the character options to
!      subroutine NAME, in the same order that they appear in the
!      argument list for NAME, even if they are not used in
!      determining the value of the parameter specified by ISPEC.
!  2)  The problem dimensions N1, N2, N3, N4 are specified in the
!      order that they appear in the argument list for NAME.  N1 is
!      used first, N2 second, and so on, and unused problem dimensions
!      are passed a value of -1.
!  3)  The parameter value returned by ILAENV is checked for validity
!      in the calling subroutine.  For example, ILAENV is used to
!      retrieve the optimal blocksize for STRTRI as follows:
!
!      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
!      IF( NB.LE.1 ) NB = MAX( 1, N )
!
!  ==================================================================
!
!     .. Local Scalars ..
      LOGICAL            CNAME, SNAME
      CHARACTER*1        C1
      CHARACTER*2        C2, C4
      CHARACTER*3        C3
      CHARACTER*6        SUBNAM
      INTEGER            I, IC, IZ, NB, NBMIN, NX
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          CHAR, ICHAR, INT, MIN, REAL
!     ..
!     .. Executable Statements ..
!
      GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC
!
!     Invalid value for ISPEC
!
      ILAENV = -1
      RETURN
!
  100 CONTINUE
!
!     Convert NAME to upper case if the first character is lower case.
!
      ILAENV = 1
      SUBNAM = NAME
      IC = ICHAR( SUBNAM( 1:1 ) )
      IZ = ICHAR( 'Z' )
      IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
!
!        ASCII character set
!
         IF( IC.GE.97 .AND. IC.LE.122 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 10 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.97 .AND. IC.LE.122 )                           &
     &            SUBNAM( I:I ) = CHAR( IC-32 )
   10       CONTINUE
         END IF
!
      ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
!
!        EBCDIC character set
!
         IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.                         &
     &       ( IC.GE.145 .AND. IC.LE.153 ) .OR.                         &
     &       ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
            SUBNAM( 1:1 ) = CHAR( IC+64 )
            DO 20 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.                   &
     &             ( IC.GE.145 .AND. IC.LE.153 ) .OR.                   &
     &             ( IC.GE.162 .AND. IC.LE.169 ) )                      &
     &            SUBNAM( I:I ) = CHAR( IC+64 )
   20       CONTINUE
         END IF
!
      ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
!
!        Prime machines:  ASCII+128
!
         IF( IC.GE.225 .AND. IC.LE.250 ) THEN
            SUBNAM( 1:1 ) = CHAR( IC-32 )
            DO 30 I = 2, 6
               IC = ICHAR( SUBNAM( I:I ) )
               IF( IC.GE.225 .AND. IC.LE.250 )                          &
     &            SUBNAM( I:I ) = CHAR( IC-32 )
   30       CONTINUE
         END IF
      END IF
!
      C1 = SUBNAM( 1:1 )
      SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
      CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
      IF( .NOT.( CNAME .OR. SNAME ) )                                   &
     &   RETURN
      C2 = SUBNAM( 2:3 )
      C3 = SUBNAM( 4:6 )
      C4 = C3( 2:3 )
!
      GO TO ( 110, 200, 300 ) ISPEC
!
  110 CONTINUE
!
!     ISPEC = 1:  block size
!
!     In these examples, separate code is provided for setting NB for
!     real and complex.  We assume that NB will take the same value in
!     single or double precision.
!
      NB = 1
!
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.    &
     &            C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NB = 32
            ELSE
               NB = 32
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'PO' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            NB = 64
         ELSE IF( C3.EQ.'TRD' ) THEN
            NB = 1
         ELSE IF( C3.EQ.'GST' ) THEN
            NB = 64
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NB = 32
            END IF
         END IF
      ELSE IF( C2.EQ.'GB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N4.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'PB' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            ELSE
               IF( N2.LE.64 ) THEN
                  NB = 1
               ELSE
                  NB = 32
               END IF
            END IF
         END IF
      ELSE IF( C2.EQ.'TR' ) THEN
         IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( C2.EQ.'LA' ) THEN
         IF( C3.EQ.'UUM' ) THEN
            IF( SNAME ) THEN
               NB = 64
            ELSE
               NB = 64
            END IF
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
         IF( C3.EQ.'EBZ' ) THEN
            NB = 1
         END IF
      END IF
      ILAENV = NB
      RETURN
!
  200 CONTINUE
!
!     ISPEC = 2:  minimum block size
!
      NBMIN = 2
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.         &
     &       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         ELSE IF( C3.EQ.'TRI' ) THEN
            IF( SNAME ) THEN
               NBMIN = 2
            ELSE
               NBMIN = 2
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( C3.EQ.'TRF' ) THEN
            IF( SNAME ) THEN
               NBMIN = 8
            ELSE
               NBMIN = 8
            END IF
         ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NBMIN = 2
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         ELSE IF( C3( 1:1 ).EQ.'M' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NBMIN = 2
            END IF
         END IF
      END IF
      ILAENV = NBMIN
      RETURN
!
  300 CONTINUE
!
!     ISPEC = 3:  crossover point
!
      NX = 0
      IF( C2.EQ.'GE' ) THEN
         IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.         &
     &       C3.EQ.'QLF' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'HRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         ELSE IF( C3.EQ.'BRD' ) THEN
            IF( SNAME ) THEN
               NX = 128
            ELSE
               NX = 128
            END IF
         END IF
      ELSE IF( C2.EQ.'SY' ) THEN
         IF( SNAME .AND. C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
         IF( C3.EQ.'TRD' ) THEN
            NX = 1
         END IF
      ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
         IF( C3( 1:1 ).EQ.'G' ) THEN
            IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR.         &
     &          C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR.         &
     &          C4.EQ.'BR' ) THEN
               NX = 128
            END IF
         END IF
      END IF
      ILAENV = NX
      RETURN
!
  400 CONTINUE
!
!     ISPEC = 4:  number of shifts (used by xHSEQR)
!
      ILAENV = 6
      RETURN
!
  500 CONTINUE
!
!     ISPEC = 5:  minimum column dimension (not used)
!
      ILAENV = 2
      RETURN
!
  600 CONTINUE
!
!     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD)
!
      ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
      RETURN
!
  700 CONTINUE
!
!     ISPEC = 7:  number of processors (not used)
!
      ILAENV = 1
      RETURN
!
  800 CONTINUE
!
!     ISPEC = 8:  crossover point for multishift (used by xHSEQR)
!
      ILAENV = 50
      RETURN
!
!     End of ILAENV
!
      END

      integer function icamax(n,cx,incx)
!
!     finds the index of element having max. absolute value.
!     jack dongarra, linpack, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex cx(*)
      real smax
      integer i,incx,ix,n
      complex zdum
      real cabs1
      cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum))
!
      icamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      icamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      smax = cabs1(cx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(cabs1(cx(ix)).le.smax) go to 5
         icamax = i
         smax = cabs1(cx(ix))
    5    ix = ix + incx
   10 continue
      return
!
!        code for increment equal to 1
!
   20 smax = cabs1(cx(1))
      do 30 i = 2,n
         if(cabs1(cx(i)).le.smax) go to 30
         icamax = i
         smax = cabs1(cx(i))
   30 continue
      return
      end

      LOGICAL          FUNCTION LSAME( CA, CB )
!
!  -- LAPACK auxiliary routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     January 31, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          CA, CB
!     ..
!
!  Purpose
!  =======
!
!  LSAME returns .TRUE. if CA is the same letter as CB regardless of
!  case.
!
!  Arguments
!  =========
!
!  CA      (input) CHARACTER*1
!  CB      (input) CHARACTER*1
!          CA and CB specify the single characters to be compared.
!
! ==================================================================
!
!     .. Intrinsic Functions ..
      INTRINSIC          ICHAR
!     ..
!     .. Local Scalars ..
      INTEGER            INTA, INTB, ZCODE
!     ..
!     .. Executable Statements ..
!
!     Test if the characters are equal
!
      LSAME = CA.EQ.CB
      IF( LSAME )                                                       &
     &   RETURN
!
!     Now test for equivalence if both characters are alphabetic.
!
      ZCODE = ICHAR( 'Z' )
!
!     Use 'Z' rather than 'A' so that ASCII can be detected on Prime
!     machines, on which ICHAR returns a value with bit 8 set.
!     ICHAR('A') on Prime machines returns 193 which is the same as
!     ICHAR('A') on an EBCDIC machine.
!
      INTA = ICHAR( CA )
      INTB = ICHAR( CB )
!
      IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
!
!        ASCII is assumed - ZCODE is the ASCII code of either lower or
!        upper case 'Z'.
!
         IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
         IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
!
      ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
!
!        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower
!        or upper case 'Z'.
!
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.                         &
     &       INTA.GE.145 .AND. INTA.LE.153 .OR.                         &
     &       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.                         &
     &       INTB.GE.145 .AND. INTB.LE.153 .OR.                         &
     &       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
!
      ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
!
!        ASCII is assumed, on Prime machines - ZCODE is the ASCII code
!        plus 128 of either lower or upper case 'Z'.
!
         IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
      END IF
      LSAME = INTA.EQ.INTB
!
!     RETURN
!
!     End of LSAME
!
      END
!       SUBROUTINE CTRTRI( UPLO, DIAG, N, A, LDA, INFO )
! *
! *  -- LAPACK routine (version 2.0) --
! *     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
! *     Courant Institute, Argonne National Lab, and Rice University
! *     September 30, 1994
! *
! *     .. Scalar Arguments ..
!       CHARACTER          DIAG, UPLO
!       INTEGER            INFO, LDA, N
! *     ..
! *     .. Array Arguments ..
!       COMPLEX            A( LDA, * )
! *     ..
! *
! *  Purpose
! *  =======
! *
! *  CTRTRI computes the inverse of a complex upper or lower
! *  triangular matrix A.
! *
! *  This is the Level 3 BLAS version of the algorithm.
! *
! *  Arguments
! *  =========
! *
! *  UPLO    (input) CHARACTER*1
! *          = 'U':  A is upper triangular;
! *          = 'L':  A is lower triangular.
! *
! *  DIAG    (input) CHARACTER*1
! *          = 'N':  A is non-unit triangular;
! *          = 'U':  A is unit triangular.
! *
! *  N       (input) INTEGER
! *          The order of the matrix A.  N >= 0.
! *
! *  A       (input/output) COMPLEX array, dimension (LDA,N)
! *       On entry, the triangular matrix A.  If UPLO = 'U', the
! *       leading N-by-N upper triangular part of the array A
! *       contains the upper triangular matrix, and the strictly lower
! *       triangular part of A is not referenced.  If UPLO = 'L', the
! *       leading N-by-N lower triangular part of the array A contains
! *       the lower triangular matrix, and the strictly upper
! *       triangular part of A is not referenced.  If DIAG = 'U', the
! *       diagonal elements of A are also not referenced and are
! *       assumed to be 1.
! *       On exit, the (triangular) inverse of the original matrix, in
! *       the same storage format.
! *
! *  LDA     (input) INTEGER
! *          The leading dimension of the array A.  LDA >= max(1,N).
! *
! *  INFO    (output) INTEGER
! *       = 0: successful exit
! *       < 0: if INFO = -i, the i-th argument had an illegal value
! *       > 0: if INFO = i, A(i,i) is exactly zero.  The triangular
! *            matrix is singular and its inverse can not be computed.
! *
! *  ================================================================
! *
! *     .. Parameters ..
!       COMPLEX            ONE, ZERO
!       PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ),
!      $                   ZERO = ( 0.0E+0, 0.0E+0 ) )
! *     ..
! *     .. Local Scalars ..
!       LOGICAL            NOUNIT, UPPER
!       INTEGER            J, JB, NB, NN
! *     ..
! *     .. External Functions ..
!       LOGICAL            LSAME
!       INTEGER            ILAENV
!       EXTERNAL           LSAME, ILAENV
! *     ..
! *     .. External Subroutines ..
!       EXTERNAL           CTRMM, CTRSM, CTRTI2, XERBLA
! *     ..
! *     .. Intrinsic Functions ..
!       INTRINSIC          MAX, MIN
! *     ..
! *     .. Executable Statements ..
! *
! *     Test the input parameters.
! *
!       INFO = 0
!       UPPER = LSAME( UPLO, 'U' )
!       NOUNIT = LSAME( DIAG, 'N' )
!       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
!          INFO = -1
!       ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
!          INFO = -2
!       ELSE IF( N.LT.0 ) THEN
!          INFO = -3
!       ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
!          INFO = -5
!       END IF
!       IF( INFO.NE.0 ) THEN
!          CALL XERBLA( 'CTRTRI', -INFO )
!          RETURN
!       END IF
! *
! *     Quick return if possible
! *
!       IF( N.EQ.0 )
!      $   RETURN
! *
! *     Check for singularity if non-unit.
! *
!       IF( NOUNIT ) THEN
!          DO 10 INFO = 1, N
!             IF( A( INFO, INFO ).EQ.ZERO )
!      $         RETURN
!    10    CONTINUE
!          INFO = 0
!       END IF
! *
! *     Determine the block size for this environment.
! *
!       NB = ILAENV( 1, 'CTRTRI', UPLO // DIAG, N, -1, -1, -1 )
!       IF( NB.LE.1 .OR. NB.GE.N ) THEN
! *
! *        Use unblocked code
! *
!          CALL CTRTI2( UPLO, DIAG, N, A, LDA, INFO )
!       ELSE
! *
! *        Use blocked code
! *
!          IF( UPPER ) THEN
! *
! *           Compute inverse of upper triangular matrix
! *
!             DO 20 J = 1, N, NB
!                JB = MIN( NB, N-J+1 )
! *
! *              Compute rows 1:j-1 of current block column
! *
!             CALL CTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
!      $                  JB, ONE, A, LDA, A( 1, J ), LDA )
!             CALL CTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
!      $                  JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
! *
! *              Compute inverse of current diagonal block
! *
!             CALL CTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
!    20       CONTINUE
!          ELSE
! *
! *           Compute inverse of lower triangular matrix
! *
!             NN = ( ( N-1 ) / NB )*NB + 1
!             DO 30 J = NN, 1, -NB
!                JB = MIN( NB, N-J+1 )
!                IF( J+JB.LE.N ) THEN
! *
! *                 Compute rows j+jb:n of current block column
! *
!                CALL CTRMM( 'Left', 'Lower', 'No transpose', DIAG,
!      $                     N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
!      $                     A( J+JB, J ), LDA )
!                CALL CTRSM( 'Right', 'Lower', 'No transpose', DIAG,
!      $                     N-J-JB+1, JB, -ONE, A( J, J ), LDA,
!      $                     A( J+JB, J ), LDA )
!                END IF
! *
! *              Compute inverse of current diagonal block
! *
!             CALL CTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
!    30       CONTINUE
!          END IF
!       END IF
! *
!       RETURN
! *
! *     End of CTRTRI
! *
!       END
      SUBROUTINE CTRTI2( UPLO, DIAG, N, A, LDA, INFO )
!
!  -- LAPACK routine (version 2.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          DIAG, UPLO
      INTEGER            INFO, LDA, N
!     ..
!     .. Array Arguments ..
      COMPLEX            A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  CTRTI2 computes the inverse of a complex upper or lower triangular
!  matrix.
!
!  This is the Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  UPLO    (input) CHARACTER*1
!          Specifies whether the matrix A is upper or lower
!          triangular.
!          = 'U':  Upper triangular
!          = 'L':  Lower triangular
!
!  DIAG    (input) CHARACTER*1
!          Specifies whether or not the matrix A is unit triangular.
!          = 'N':  Non-unit triangular
!          = 'U':  Unit triangular
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX array, dimension (LDA,N)
!       On entry, the triangular matrix A.  If UPLO = 'U', the
!       leading n by n upper triangular part of the array A contains
!       the upper triangular matrix, and the strictly lower
!       triangular part of A is not referenced.  If UPLO = 'L', the
!       leading n by n lower triangular part of the array A contains
!       the lower triangular matrix, and the strictly upper
!       triangular part of A is not referenced.  If DIAG = 'U', the
!       diagonal elements of A are also not referenced and are
!       assumed to be 1.
!
!       On exit, the (triangular) inverse of the original matrix, in
!       the same storage format.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!
!  ==================================================================
!
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOUNIT, UPPER
      INTEGER            J
      COMPLEX            AJJ
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           CSCAL, CTRMV, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      NOUNIT = LSAME( DIAG, 'N' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CTRTI2', -INFO )
         RETURN
      END IF
!
      IF( UPPER ) THEN
!
!        Compute inverse of upper triangular matrix.
!
         DO 10 J = 1, N
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
!
!           Compute elements 1:j-1 of j-th column.
!
            CALL CTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,     &
     &                  A( 1, J ), 1 )
            CALL CSCAL( J-1, AJJ, A( 1, J ), 1 )
   10    CONTINUE
      ELSE
!
!        Compute inverse of lower triangular matrix.
!
         DO 20 J = N, 1, -1
            IF( NOUNIT ) THEN
               A( J, J ) = ONE / A( J, J )
               AJJ = -A( J, J )
            ELSE
               AJJ = -ONE
            END IF
            IF( J.LT.N ) THEN
!
!              Compute elements j+1:n of j-th column.
!
               CALL CTRMV( 'Lower', 'No transpose', DIAG, N-J,          &
     &                     A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
               CALL CSCAL( N-J, AJJ, A( J+1, J ), 1 )
            END IF
   20    CONTINUE
      END IF
!
      RETURN
!
!     End of CTRTI2
!
      END
      SUBROUTINE CTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX )
!     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
      CHARACTER*1        DIAG, TRANS, UPLO
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), X( * )
!     ..
!
!  Purpose
!  =======
!
!  CTRMV  performs one of the matrix-vector operations
!
!     x := A*x,   or   x := A'*x,   or   x := conjg( A' )*x,
!
!  where x is an n element vector and  A is an n by n unit, or
!  non-unit, upper or lower triangular matrix.
!
!  Parameters
!  ==========
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   x := A*x.
!
!              TRANS = 'T' or 't'   x := A'*x.
!
!              TRANS = 'C' or 'c'   x := conjg( A' )*x.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit
!           triangular as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the order of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  A      - COMPLEX          array of DIMENSION ( LDA, n ).
!        Before entry with  UPLO = 'U' or 'u', the leading n by n
!        upper triangular part of the array A must contain the upper
!        triangular matrix and the strictly lower triangular part of
!        A is not referenced.
!        Before entry with UPLO = 'L' or 'l', the leading n by n
!        lower triangular part of the array A must contain the lower
!        triangular matrix and the strictly upper triangular part of
!        A is not referenced.
!        Note that when  DIAG = 'U' or 'u', the diagonal elements of
!        A are not referenced either, but are assumed to be unity.
!        Unchanged on exit.
!
!  LDA    - INTEGER.
!        On entry, LDA specifies the first dimension of A as declared
!        in the calling (sub) program. LDA must be at least
!        max( 1, n ).
!        Unchanged on exit.
!
!  X      - COMPLEX          array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the n
!           element vector x. On exit, X is overwritten with the
!           tranformed vector x.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     .. Local Scalars ..
      COMPLEX            TEMP
      INTEGER            I, INFO, IX, J, JX, KX
      LOGICAL            NOCONJ, NOUNIT
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( UPLO , 'U' ).AND.                            &
     &         .NOT.LSAME( UPLO , 'L' )      )THEN
         INFO = 1
      ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND.                            &
     &         .NOT.LSAME( TRANS, 'T' ).AND.                            &
     &         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 2
      ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND.                               &
     &         .NOT.LSAME( DIAG , 'N' )      )THEN
         INFO = 3
      ELSE IF( N.LT.0 )THEN
         INFO = 4
      ELSE IF( LDA.LT.MAX( 1, N ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CTRMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 )                                                      &
     &   RETURN
!
      NOCONJ = LSAME( TRANS, 'T' )
      NOUNIT = LSAME( DIAG , 'N' )
!
!     Set up the start point in X if the increment is not unity. This
!     will be  ( N - 1 )*INCX  too small for descending loops.
!
      IF( INCX.LE.0 )THEN
         KX = 1 - ( N - 1 )*INCX
      ELSE IF( INCX.NE.1 )THEN
         KX = 1
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  x := A*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 20, J = 1, N
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 10, I = 1, J - 1
                        X( I ) = X( I ) + TEMP*A( I, J )
   10                CONTINUE
                     IF( NOUNIT )                                       &
     &                  X( J ) = X( J )*A( J, J )
                  END IF
   20          CONTINUE
            ELSE
               JX = KX
               DO 40, J = 1, N
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 30, I = 1, J - 1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      + INCX
   30                CONTINUE
                     IF( NOUNIT )                                       &
     &                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX + INCX
   40          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 60, J = N, 1, -1
                  IF( X( J ).NE.ZERO )THEN
                     TEMP = X( J )
                     DO 50, I = N, J + 1, -1
                        X( I ) = X( I ) + TEMP*A( I, J )
   50                CONTINUE
                     IF( NOUNIT )                                       &
     &                  X( J ) = X( J )*A( J, J )
                  END IF
   60          CONTINUE
            ELSE
               KX = KX + ( N - 1 )*INCX
               JX = KX
               DO 80, J = N, 1, -1
                  IF( X( JX ).NE.ZERO )THEN
                     TEMP = X( JX )
                     IX   = KX
                     DO 70, I = N, J + 1, -1
                        X( IX ) = X( IX ) + TEMP*A( I, J )
                        IX      = IX      - INCX
   70                CONTINUE
                     IF( NOUNIT )                                       &
     &                  X( JX ) = X( JX )*A( J, J )
                  END IF
                  JX = JX - INCX
   80          CONTINUE
            END IF
         END IF
      ELSE
!
!        Form  x := A'*x  or  x := conjg( A' )*x.
!
         IF( LSAME( UPLO, 'U' ) )THEN
            IF( INCX.EQ.1 )THEN
               DO 110, J = N, 1, -1
                  TEMP = X( J )
                  IF( NOCONJ )THEN
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*A( J, J )
                     DO 90, I = J - 1, 1, -1
                        TEMP = TEMP + A( I, J )*X( I )
   90                CONTINUE
                  ELSE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*CONJG( A( J, J ) )
                     DO 100, I = J - 1, 1, -1
                        TEMP = TEMP + CONJG( A( I, J ) )*X( I )
  100                CONTINUE
                  END IF
                  X( J ) = TEMP
  110          CONTINUE
            ELSE
               JX = KX + ( N - 1 )*INCX
               DO 140, J = N, 1, -1
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOCONJ )THEN
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*A( J, J )
                     DO 120, I = J - 1, 1, -1
                        IX   = IX   - INCX
                        TEMP = TEMP + A( I, J )*X( IX )
  120                CONTINUE
                  ELSE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*CONJG( A( J, J ) )
                     DO 130, I = J - 1, 1, -1
                        IX   = IX   - INCX
                        TEMP = TEMP + CONJG( A( I, J ) )*X( IX )
  130                CONTINUE
                  END IF
                  X( JX ) = TEMP
                  JX      = JX   - INCX
  140          CONTINUE
            END IF
         ELSE
            IF( INCX.EQ.1 )THEN
               DO 170, J = 1, N
                  TEMP = X( J )
                  IF( NOCONJ )THEN
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*A( J, J )
                     DO 150, I = J + 1, N
                        TEMP = TEMP + A( I, J )*X( I )
  150                CONTINUE
                  ELSE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*CONJG( A( J, J ) )
                     DO 160, I = J + 1, N
                        TEMP = TEMP + CONJG( A( I, J ) )*X( I )
  160                CONTINUE
                  END IF
                  X( J ) = TEMP
  170          CONTINUE
            ELSE
               JX = KX
               DO 200, J = 1, N
                  TEMP = X( JX )
                  IX   = JX
                  IF( NOCONJ )THEN
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*A( J, J )
                     DO 180, I = J + 1, N
                        IX   = IX   + INCX
                        TEMP = TEMP + A( I, J )*X( IX )
  180                CONTINUE
                  ELSE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP*CONJG( A( J, J ) )
                     DO 190, I = J + 1, N
                        IX   = IX   + INCX
                        TEMP = TEMP + CONJG( A( I, J ) )*X( IX )
  190                CONTINUE
                  END IF
                  X( JX ) = TEMP
                  JX      = JX   + INCX
  200          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of CTRMV .
!
      END
      subroutine caxpy(n,ca,cx,incx,cy,incy)
!
!     constant times a vector plus a vector.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex cx(*),cy(*),ca
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if (abs(real(ca)) + abs(aimag(ca)) .eq. 0.0 ) return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        cy(iy) = cy(iy) + ca*cx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
        cy(i) = cy(i) + ca*cx(i)
   30 continue
      return
      end
      subroutine  ccopy(n,cx,incx,cy,incy)
!
!     copies a vector, x, to a vector, y.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      complex cx(*),cy(*)
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        cy(iy) = cx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
        cy(i) = cx(i)
   30 continue
      return
      end

      SUBROUTINE CGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX,           &
     &                   BETA, Y, INCY )
!     .. Scalar Arguments ..
      COMPLEX            ALPHA, BETA
      INTEGER            INCX, INCY, LDA, M, N
      CHARACTER*1        TRANS
!     .. Array Arguments ..
      COMPLEX            A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  CGEMV  performs one of the matrix-vector operations
!
!     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y,   or
!
!     y := alpha*conjg( A' )*x + beta*y,
!
!  where alpha and beta are scalars, x and y are vectors and A is an
!  m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANS  - CHARACTER*1.
!           On entry, TRANS specifies the operation to be performed as
!           follows:
!
!              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
!
!              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y.
!
!              TRANS = 'C' or 'c'   y := alpha*conjg( A' )*x + beta*y.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX         .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - COMPLEX          array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, m ).
!           Unchanged on exit.
!
!  X      - COMPLEX          array of DIMENSION at least
!           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
!           Before entry, the incremented array X must contain the
!           vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  BETA   - COMPLEX         .
!           On entry, BETA specifies the scalar beta. When BETA is
!           supplied as zero then Y need not be set on input.
!           Unchanged on exit.
!
!  Y      - COMPLEX          array of DIMENSION at least
!           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
!           and at least
!           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
!           Before entry with BETA non-zero, the incremented array Y
!           must contain the vector y. On exit, Y is overwritten by the
!           updated vector y.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      COMPLEX            ONE
      PARAMETER        ( ONE  = ( 1.0E+0, 0.0E+0 ) )
      COMPLEX            ZERO
      PARAMETER        ( ZERO = ( 0.0E+0, 0.0E+0 ) )
!     .. Local Scalars ..
      COMPLEX            TEMP
      INTEGER            I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY
      LOGICAL            NOCONJ
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          CONJG, MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( .NOT.LSAME( TRANS, 'N' ).AND.                            &
     &         .NOT.LSAME( TRANS, 'T' ).AND.                            &
     &         .NOT.LSAME( TRANS, 'C' )      )THEN
         INFO = 1
      ELSE IF( M.LT.0 )THEN
         INFO = 2
      ELSE IF( N.LT.0 )THEN
         INFO = 3
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 6
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 8
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'CGEMV ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.                                  &
     &    ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) )                   &
     &   RETURN
!
      NOCONJ = LSAME( TRANS, 'T' )
!
!     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
!     up the start points in  X  and  Y.
!
      IF( LSAME( TRANS, 'N' ) )THEN
         LENX = N
         LENY = M
      ELSE
         LENX = M
         LENY = N
      END IF
      IF( INCX.GT.0 )THEN
         KX = 1
      ELSE
         KX = 1 - ( LENX - 1 )*INCX
      END IF
      IF( INCY.GT.0 )THEN
         KY = 1
      ELSE
         KY = 1 - ( LENY - 1 )*INCY
      END IF
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
!     First form  y := beta*y.
!
      IF( BETA.NE.ONE )THEN
         IF( INCY.EQ.1 )THEN
            IF( BETA.EQ.ZERO )THEN
               DO 10, I = 1, LENY
                  Y( I ) = ZERO
   10          CONTINUE
            ELSE
               DO 20, I = 1, LENY
                  Y( I ) = BETA*Y( I )
   20          CONTINUE
            END IF
         ELSE
            IY = KY
            IF( BETA.EQ.ZERO )THEN
               DO 30, I = 1, LENY
                  Y( IY ) = ZERO
                  IY      = IY   + INCY
   30          CONTINUE
            ELSE
               DO 40, I = 1, LENY
                  Y( IY ) = BETA*Y( IY )
                  IY      = IY           + INCY
   40          CONTINUE
            END IF
         END IF
      END IF
      IF( ALPHA.EQ.ZERO )                                               &
     &   RETURN
      IF( LSAME( TRANS, 'N' ) )THEN
!
!        Form  y := alpha*A*x + y.
!
         JX = KX
         IF( INCY.EQ.1 )THEN
            DO 60, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  DO 50, I = 1, M
                     Y( I ) = Y( I ) + TEMP*A( I, J )
   50             CONTINUE
               END IF
               JX = JX + INCX
   60       CONTINUE
         ELSE
            DO 80, J = 1, N
               IF( X( JX ).NE.ZERO )THEN
                  TEMP = ALPHA*X( JX )
                  IY   = KY
                  DO 70, I = 1, M
                     Y( IY ) = Y( IY ) + TEMP*A( I, J )
                     IY      = IY      + INCY
   70             CONTINUE
               END IF
               JX = JX + INCX
   80       CONTINUE
         END IF
      ELSE
!
!        Form  y := alpha*A'*x + y  or  y := alpha*conjg( A' )*x + y.
!
         JY = KY
         IF( INCX.EQ.1 )THEN
            DO 110, J = 1, N
               TEMP = ZERO
               IF( NOCONJ )THEN
                  DO 90, I = 1, M
                     TEMP = TEMP + A( I, J )*X( I )
   90             CONTINUE
               ELSE
                  DO 100, I = 1, M
                     TEMP = TEMP + CONJG( A( I, J ) )*X( I )
  100             CONTINUE
               END IF
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  110       CONTINUE
         ELSE
            DO 140, J = 1, N
               TEMP = ZERO
               IX   = KX
               IF( NOCONJ )THEN
                  DO 120, I = 1, M
                     TEMP = TEMP + A( I, J )*X( IX )
                     IX   = IX   + INCX
  120             CONTINUE
               ELSE
                  DO 130, I = 1, M
                     TEMP = TEMP + CONJG( A( I, J ) )*X( IX )
                     IX   = IX   + INCX
  130             CONTINUE
               END IF
               Y( JY ) = Y( JY ) + ALPHA*TEMP
               JY      = JY      + INCY
  140       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of CGEMV .
!
      END
      double precision function dcabs1(z)
      double complex z,zz
      double precision t(2)
      equivalence (zz,t(1))
      zz = z
      dcabs1 = dabs(t(1)) + dabs(t(2))
      return
      end
      SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,&
     &                   BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      DOUBLE PRECISION   ALPHA, BETA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  DGEMM  performs one of the matrix-matrix operations
!
!     C := alpha*op( A )*op( B ) + beta*C,
!
!  where  op( X ) is one of
!
!     op( X ) = X   or   op( X ) = X',
!
!  alpha and beta are scalars, and A, B and C are matrices, with op( A )
!  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n',  op( A ) = A.
!
!              TRANSA = 'T' or 't',  op( A ) = A'.
!
!              TRANSA = 'C' or 'c',  op( A ) = A'.
!
!           Unchanged on exit.
!
!  TRANSB - CHARACTER*1.
!           On entry, TRANSB specifies the form of op( B ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSB = 'N' or 'n',  op( B ) = B.
!
!              TRANSB = 'T' or 't',  op( B ) = B'.
!
!              TRANSB = 'C' or 'c',  op( B ) = B'.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry,  M  specifies  the number  of rows  of the  matrix
!           op( A )  and of the  matrix  C.  M  must  be at least  zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry,  N  specifies the number  of columns of the matrix
!           op( B ) and the number of columns of the matrix C. N must be
!           at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry,  K  specifies  the number of columns of the matrix
!           op( A ) and the number of rows of the matrix op( B ). K must
!           be at least  zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
!           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
!           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
!           part of the array  A  must contain the matrix  A,  otherwise
!           the leading  k by m  part of the array  A  must contain  the
!           matrix A.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
!           LDA must be at least  max( 1, m ), otherwise  LDA must be at
!           least  max( 1, k ).
!           Unchanged on exit.
!
!  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
!           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
!           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
!           part of the array  B  must contain the matrix  B,  otherwise
!           the leading  n by k  part of the array  B  must contain  the
!           matrix B.
!           Unchanged on exit.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
!           LDB must be at least  max( 1, k ), otherwise  LDB must be at
!           least  max( 1, n ).
!           Unchanged on exit.
!
!  BETA   - DOUBLE PRECISION.
!           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
!           supplied as zero then C need not be set on input.
!           Unchanged on exit.
!
!  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
!           Before entry, the leading  m by n  part of the array  C must
!           contain the matrix  C,  except when  beta  is zero, in which
!           case C need not be set on entry.
!           On exit, the array  C  is overwritten by the  m by n  matrix
!           ( alpha*op( A )*op( B ) + beta*C ).
!
!  LDC    - INTEGER.
!           On entry, LDC specifies the first dimension of C as declared
!           in  the  calling  (sub)  program.   LDC  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      DOUBLE PRECISION   TEMP
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
!     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
!     and  columns of  A  and the  number of  rows  of  B  respectively.
!
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'C' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.                       &
     &         ( .NOT.LSAME( TRANSB, 'C' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGEMM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.                                  &
     &    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) &
     &   RETURN
!
!     And if  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( NOTB )THEN
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B + beta*C.
!
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B + beta*C
!
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         END IF
      ELSE
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B' + beta*C
!
            DO 170, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 130, I = 1, M
                     C( I, J ) = ZERO
  130             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 140, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  140             CONTINUE
               END IF
               DO 160, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 150, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  150                CONTINUE
                  END IF
  160          CONTINUE
  170       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B' + beta*C
!
            DO 200, J = 1, N
               DO 190, I = 1, M
                  TEMP = ZERO
                  DO 180, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  180             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  190          CONTINUE
  200       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of DGEMM .
!
      END
      SUBROUTINE DGER  ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
!     .. Scalar Arguments ..
      DOUBLE PRECISION   ALPHA
      INTEGER            INCX, INCY, LDA, M, N
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  DGER   performs the rank 1 operation
!
!     A := alpha*x*y' + A,
!
!  where alpha is a scalar, x is an m element vector, y is an n element
!  vector and A is an m by n matrix.
!
!  Parameters
!  ==========
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( m - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the m
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  Y      - DOUBLE PRECISION array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y.
!           Unchanged on exit.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients. On exit, A is
!           overwritten by the updated matrix.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      DOUBLE PRECISION   ZERO
      PARAMETER        ( ZERO = 0.0D+0 )
!     .. Local Scalars ..
      DOUBLE PRECISION   TEMP
      INTEGER            I, INFO, IX, J, JY, KX
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DGER  ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )               &
     &   RETURN
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of DGER  .
!
      END
      subroutine  dscal(n,da,dx,incx)
!
!     scales a vector by a constant.
!     uses unrolled loops for increment equal to one.
!     jack dongarra, linpack, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision da,dx(*)
      integer i,incx,m,mp1,n,nincx
!
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      nincx = n*incx
      do 10 i = 1,nincx,incx
        dx(i) = da*dx(i)
   10 continue
      return
!
!        code for increment equal to 1
!
!
!        clean-up loop
!
   20 m = mod(n,5)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dx(i) = da*dx(i)
   30 continue
      if( n .lt. 5 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,5
        dx(i) = da*dx(i)
        dx(i + 1) = da*dx(i + 1)
        dx(i + 2) = da*dx(i + 2)
        dx(i + 3) = da*dx(i + 3)
        dx(i + 4) = da*dx(i + 4)
   50 continue
      return
      end
      subroutine  dswap (n,dx,incx,dy,incy)
!
!     interchanges two vectors.
!     uses unrolled loops for increments equal one.
!     jack dongarra, linpack, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dy(*),dtemp
      integer i,incx,incy,ix,iy,m,mp1,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dtemp = dx(ix)
        dx(ix) = dy(iy)
        dy(iy) = dtemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!       code for both increments equal to 1
!
!
!       clean-up loop
!
   20 m = mod(n,3)
      if( m .eq. 0 ) go to 40
      do 30 i = 1,m
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
   30 continue
      if( n .lt. 3 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,3
        dtemp = dx(i)
        dx(i) = dy(i)
        dy(i) = dtemp
        dtemp = dx(i + 1)
        dx(i + 1) = dy(i + 1)
        dy(i + 1) = dtemp
        dtemp = dx(i + 2)
        dx(i + 2) = dy(i + 2)
        dy(i + 2) = dtemp
   50 continue
      return
      end
      SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, &
     &                   B, LDB )
!     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      DOUBLE PRECISION   ALPHA
!     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DTRSM  solves one of the matrix equations
!
!     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
!
!  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
!  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
!
!     op( A ) = A   or   op( A ) = A'.
!
!  The matrix X is overwritten on B.
!
!  Parameters
!  ==========
!
!  SIDE   - CHARACTER*1.
!           On entry, SIDE specifies whether op( A ) appears on the left
!           or right of X as follows:
!
!              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
!
!              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
!
!           Unchanged on exit.
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix A is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n'   op( A ) = A.
!
!              TRANSA = 'T' or 't'   op( A ) = A'.
!
!              TRANSA = 'C' or 'c'   op( A ) = A'.
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit triangular
!           as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of B. M must be at
!           least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of B.  N must be
!           at least zero.
!           Unchanged on exit.
!
!  ALPHA  - DOUBLE PRECISION.
!           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
!           zero then  A is not referenced and  B need not be set before
!           entry.
!           Unchanged on exit.
!
!  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
!           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
!           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
!           upper triangular part of the array  A must contain the upper
!           triangular matrix  and the strictly lower triangular part of
!           A is not referenced.
!           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
!           lower triangular part of the array  A must contain the lower
!           triangular matrix  and the strictly upper triangular part of
!           A is not referenced.
!           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
!           A  are not referenced either,  but are assumed to be  unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
!           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
!           then LDA must be at least max( 1, n ).
!           Unchanged on exit.
!
!  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
!           Before entry,  the leading  m by n part of the array  B must
!           contain  the  right-hand  side  matrix  B,  and  on exit  is
!           overwritten by the solution matrix  X.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in  the  calling  (sub)  program.   LDB  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     .. Local Scalars ..
      LOGICAL            LSIDE, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      DOUBLE PRECISION   TEMP
!     .. Parameters ..
      DOUBLE PRECISION   ONE         , ZERO
      PARAMETER        ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
!
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.                       &
     &         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.                       &
     &         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.                       &
     &         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'DTRSM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 )                                                      &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*inv( A )*B.
!
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*inv( A' )*B.
!
            IF( UPPER )THEN
               DO 130, J = 1, N
                  DO 120, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     DO 110, K = 1, I - 1
                        TEMP = TEMP - A( K, I )*B( K, J )
  110                CONTINUE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  120             CONTINUE
  130          CONTINUE
            ELSE
               DO 160, J = 1, N
                  DO 150, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     DO 140, K = I + 1, M
                        TEMP = TEMP - A( K, I )*B( K, J )
  140                CONTINUE
                     IF( NOUNIT )                                       &
     &                  TEMP = TEMP/A( I, I )
                     B( I, J ) = TEMP
  150             CONTINUE
  160          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*B*inv( A ).
!
            IF( UPPER )THEN
               DO 210, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 170, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  170                CONTINUE
                  END IF
                  DO 190, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 180, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  180                   CONTINUE
                     END IF
  190             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 200, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  200                CONTINUE
                  END IF
  210          CONTINUE
            ELSE
               DO 260, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 220, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  220                CONTINUE
                  END IF
                  DO 240, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 230, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  230                   CONTINUE
                     END IF
  240             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 250, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  250                CONTINUE
                  END IF
  260          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*B*inv( A' ).
!
            IF( UPPER )THEN
               DO 310, K = N, 1, -1
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 270, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  270                CONTINUE
                  END IF
                  DO 290, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 280, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  280                   CONTINUE
                     END IF
  290             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 300, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  300                CONTINUE
                  END IF
  310          CONTINUE
            ELSE
               DO 360, K = 1, N
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( K, K )
                     DO 320, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  320                CONTINUE
                  END IF
                  DO 340, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        TEMP = A( J, K )
                        DO 330, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  330                   CONTINUE
                     END IF
  340             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 350, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  350                CONTINUE
                  END IF
  360          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of DTRSM .
!
      END
      integer function idamax(n,dx,incx)
!
!     finds the index of element having max. absolute value.
!     jack dongarra, linpack, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double precision dx(*),dmax
      integer i,incx,ix,n
!
      idamax = 0
      if( n.lt.1 .or. incx.le.0 ) return
      idamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      dmax = dabs(dx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dabs(dx(ix)).le.dmax) go to 5
         idamax = i
         dmax = dabs(dx(ix))
    5    ix = ix + incx
   10 continue
      return
!
!        code for increment equal to 1
!
   20 dmax = dabs(dx(1))
      do 30 i = 2,n
         if(dabs(dx(i)).le.dmax) go to 30
         idamax = i
         dmax = dabs(dx(i))
   30 continue
      return
      end
      integer function izamax(n,zx,incx)
!
!     finds the index of element having max. absolute value.
!     jack dongarra, 1/15/85.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double complex zx(*)
      double precision smax
      integer i,incx,ix,n
      double precision dcabs1
!
      izamax = 0
      if( n.lt.1 .or. incx.le.0 )return
      izamax = 1
      if(n.eq.1)return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      smax = dcabs1(zx(1))
      ix = ix + incx
      do 10 i = 2,n
         if(dcabs1(zx(ix)).le.smax) go to 5
         izamax = i
         smax = dcabs1(zx(ix))
    5    ix = ix + incx
   10 continue
      return
!
!        code for increment equal to 1
!
   20 smax = dcabs1(zx(1))
      do 30 i = 2,n
         if(dcabs1(zx(i)).le.smax) go to 30
         izamax = i
         smax = dcabs1(zx(i))
   30 continue
      return
      end
      subroutine  zcopy(n,zx,incx,zy,incy)
!
!     copies a vector, x, to a vector, y.
!     jack dongarra, linpack, 4/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double complex zx(*),zy(*)
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!        code for unequal increments or equal increments
!          not equal to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        zy(iy) = zx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!        code for both increments equal to 1
!
   20 do 30 i = 1,n
        zy(i) = zx(i)
   30 continue
      return
      end
      SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB,&
     &                   BETA, C, LDC )
!     .. Scalar Arguments ..
      CHARACTER*1        TRANSA, TRANSB
      INTEGER            M, N, K, LDA, LDB, LDC
      COMPLEX*16         ALPHA, BETA
!     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * ), C( LDC, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGEMM  performs one of the matrix-matrix operations
!
!     C := alpha*op( A )*op( B ) + beta*C,
!
!  where  op( X ) is one of
!
!     op( X ) = X   or   op( X ) = X'   or   op( X ) = conjg( X' ),
!
!  alpha and beta are scalars, and A, B and C are matrices, with op( A )
!  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
!
!  Parameters
!  ==========
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n',  op( A ) = A.
!
!              TRANSA = 'T' or 't',  op( A ) = A'.
!
!              TRANSA = 'C' or 'c',  op( A ) = conjg( A' ).
!
!           Unchanged on exit.
!
!  TRANSB - CHARACTER*1.
!           On entry, TRANSB specifies the form of op( B ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSB = 'N' or 'n',  op( B ) = B.
!
!              TRANSB = 'T' or 't',  op( B ) = B'.
!
!              TRANSB = 'C' or 'c',  op( B ) = conjg( B' ).
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry,  M  specifies  the number  of rows  of the  matrix
!           op( A )  and of the  matrix  C.  M  must  be at least  zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry,  N  specifies the number  of columns of the matrix
!           op( B ) and the number of columns of the matrix C. N must be
!           at least zero.
!           Unchanged on exit.
!
!  K      - INTEGER.
!           On entry,  K  specifies  the number of columns of the matrix
!           op( A ) and the number of rows of the matrix op( B ). K must
!           be at least  zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX*16      .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  A      - COMPLEX*16       array of DIMENSION ( LDA, ka ), where ka is
!           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
!           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
!           part of the array  A  must contain the matrix  A,  otherwise
!           the leading  k by m  part of the array  A  must contain  the
!           matrix A.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
!           LDA must be at least  max( 1, m ), otherwise  LDA must be at
!           least  max( 1, k ).
!           Unchanged on exit.
!
!  B      - COMPLEX*16       array of DIMENSION ( LDB, kb ), where kb is
!           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
!           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
!           part of the array  B  must contain the matrix  B,  otherwise
!           the leading  n by k  part of the array  B  must contain  the
!           matrix B.
!           Unchanged on exit.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
!           LDB must be at least  max( 1, k ), otherwise  LDB must be at
!           least  max( 1, n ).
!           Unchanged on exit.
!
!  BETA   - COMPLEX*16      .
!           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
!           supplied as zero then C need not be set on input.
!           Unchanged on exit.
!
!  C      - COMPLEX*16       array of DIMENSION ( LDC, n ).
!           Before entry, the leading  m by n  part of the array  C must
!           contain the matrix  C,  except when  beta  is zero, in which
!           case C need not be set on entry.
!           On exit, the array  C  is overwritten by the  m by n  matrix
!           ( alpha*op( A )*op( B ) + beta*C ).
!
!  LDC    - INTEGER.
!           On entry, LDC specifies the first dimension of C as declared
!           in  the  calling  (sub)  program.   LDC  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          DCONJG, MAX
!     .. Local Scalars ..
      LOGICAL            CONJA, CONJB, NOTA, NOTB
      INTEGER            I, INFO, J, L, NCOLA, NROWA, NROWB
      COMPLEX*16         TEMP
!     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER        ( ONE  = ( 1.0D+0, 0.0D+0 ) )
      COMPLEX*16         ZERO
      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
!     ..
!     .. Executable Statements ..
!
!     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
!     conjugated or transposed, set  CONJA and CONJB  as true if  A  and
!     B  respectively are to be  transposed but  not conjugated  and set
!     NROWA, NCOLA and  NROWB  as the number of rows and  columns  of  A
!     and the number of rows of  B  respectively.
!
      NOTA  = LSAME( TRANSA, 'N' )
      NOTB  = LSAME( TRANSB, 'N' )
      CONJA = LSAME( TRANSA, 'C' )
      CONJB = LSAME( TRANSB, 'C' )
      IF( NOTA )THEN
         NROWA = M
         NCOLA = K
      ELSE
         NROWA = K
         NCOLA = M
      END IF
      IF( NOTB )THEN
         NROWB = K
      ELSE
         NROWB = N
      END IF
!
!     Test the input parameters.
!
      INFO = 0
      IF(      ( .NOT.NOTA                 ).AND.                       &
     &         ( .NOT.CONJA                ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.NOTB                 ).AND.                       &
     &         ( .NOT.CONJB                ).AND.                       &
     &         ( .NOT.LSAME( TRANSB, 'T' ) )      )THEN
         INFO = 2
      ELSE IF( M  .LT.0               )THEN
         INFO = 3
      ELSE IF( N  .LT.0               )THEN
         INFO = 4
      ELSE IF( K  .LT.0               )THEN
         INFO = 5
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 8
      ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN
         INFO = 10
      ELSE IF( LDC.LT.MAX( 1, M     ) )THEN
         INFO = 13
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'ZGEMM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.                                  &
     &    ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         IF( BETA.EQ.ZERO )THEN
            DO 20, J = 1, N
               DO 10, I = 1, M
                  C( I, J ) = ZERO
   10          CONTINUE
   20       CONTINUE
         ELSE
            DO 40, J = 1, N
               DO 30, I = 1, M
                  C( I, J ) = BETA*C( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
         RETURN
      END IF
!
!     Start the operations.
!
      IF( NOTB )THEN
         IF( NOTA )THEN
!
!           Form  C := alpha*A*B + beta*C.
!
            DO 90, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 50, I = 1, M
                     C( I, J ) = ZERO
   50             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 60, I = 1, M
                     C( I, J ) = BETA*C( I, J )
   60             CONTINUE
               END IF
               DO 80, L = 1, K
                  IF( B( L, J ).NE.ZERO )THEN
                     TEMP = ALPHA*B( L, J )
                     DO 70, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
   70                CONTINUE
                  END IF
   80          CONTINUE
   90       CONTINUE
         ELSE IF( CONJA )THEN
!
!           Form  C := alpha*conjg( A' )*B + beta*C.
!
            DO 120, J = 1, N
               DO 110, I = 1, M
                  TEMP = ZERO
                  DO 100, L = 1, K
                     TEMP = TEMP + DCONJG( A( L, I ) )*B( L, J )
  100             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  110          CONTINUE
  120       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B + beta*C
!
            DO 150, J = 1, N
               DO 140, I = 1, M
                  TEMP = ZERO
                  DO 130, L = 1, K
                     TEMP = TEMP + A( L, I )*B( L, J )
  130             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  140          CONTINUE
  150       CONTINUE
         END IF
      ELSE IF( NOTA )THEN
         IF( CONJB )THEN
!
!           Form  C := alpha*A*conjg( B' ) + beta*C.
!
            DO 200, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 160, I = 1, M
                     C( I, J ) = ZERO
  160             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 170, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  170             CONTINUE
               END IF
               DO 190, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*DCONJG( B( J, L ) )
                     DO 180, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  180                CONTINUE
                  END IF
  190          CONTINUE
  200       CONTINUE
         ELSE
!
!           Form  C := alpha*A*B'          + beta*C
!
            DO 250, J = 1, N
               IF( BETA.EQ.ZERO )THEN
                  DO 210, I = 1, M
                     C( I, J ) = ZERO
  210             CONTINUE
               ELSE IF( BETA.NE.ONE )THEN
                  DO 220, I = 1, M
                     C( I, J ) = BETA*C( I, J )
  220             CONTINUE
               END IF
               DO 240, L = 1, K
                  IF( B( J, L ).NE.ZERO )THEN
                     TEMP = ALPHA*B( J, L )
                     DO 230, I = 1, M
                        C( I, J ) = C( I, J ) + TEMP*A( I, L )
  230                CONTINUE
                  END IF
  240          CONTINUE
  250       CONTINUE
         END IF
      ELSE IF( CONJA )THEN
         IF( CONJB )THEN
!
!           Form  C := alpha*conjg( A' )*conjg( B' ) + beta*C.
!
            DO 280, J = 1, N
               DO 270, I = 1, M
                  TEMP = ZERO
                  DO 260, L = 1, K
                     TEMP = TEMP +                                      &
     &                      DCONJG( A( L, I ) )*DCONJG( B( J, L ) )
  260             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  270          CONTINUE
  280       CONTINUE
         ELSE
!
!           Form  C := alpha*conjg( A' )*B' + beta*C
!
            DO 310, J = 1, N
               DO 300, I = 1, M
                  TEMP = ZERO
                  DO 290, L = 1, K
                     TEMP = TEMP + DCONJG( A( L, I ) )*B( J, L )
  290             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  300          CONTINUE
  310       CONTINUE
         END IF
      ELSE
         IF( CONJB )THEN
!
!           Form  C := alpha*A'*conjg( B' ) + beta*C
!
            DO 340, J = 1, N
               DO 330, I = 1, M
                  TEMP = ZERO
                  DO 320, L = 1, K
                     TEMP = TEMP + A( L, I )*DCONJG( B( J, L ) )
  320             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  330          CONTINUE
  340       CONTINUE
         ELSE
!
!           Form  C := alpha*A'*B' + beta*C
!
            DO 370, J = 1, N
               DO 360, I = 1, M
                  TEMP = ZERO
                  DO 350, L = 1, K
                     TEMP = TEMP + A( L, I )*B( J, L )
  350             CONTINUE
                  IF( BETA.EQ.ZERO )THEN
                     C( I, J ) = ALPHA*TEMP
                  ELSE
                     C( I, J ) = ALPHA*TEMP + BETA*C( I, J )
                  END IF
  360          CONTINUE
  370       CONTINUE
         END IF
      END IF
!
      RETURN
!
!     End of ZGEMM .
!
      END
      SUBROUTINE ZGERU ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA )
!     .. Scalar Arguments ..
      COMPLEX*16         ALPHA
      INTEGER            INCX, INCY, LDA, M, N
!     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), X( * ), Y( * )
!     ..
!
!  Purpose
!  =======
!
!  ZGERU  performs the rank 1 operation
!
!     A := alpha*x*y' + A,
!
!  where alpha is a scalar, x is an m element vector, y is an n element
!  vector and A is an m by n matrix.
!
!  Parameters
!  ==========
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of the matrix A.
!           M must be at least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of the matrix A.
!           N must be at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX*16      .
!           On entry, ALPHA specifies the scalar alpha.
!           Unchanged on exit.
!
!  X      - COMPLEX*16       array of dimension at least
!           ( 1 + ( m - 1 )*abs( INCX ) ).
!           Before entry, the incremented array X must contain the m
!           element vector x.
!           Unchanged on exit.
!
!  INCX   - INTEGER.
!           On entry, INCX specifies the increment for the elements of
!           X. INCX must not be zero.
!           Unchanged on exit.
!
!  Y      - COMPLEX*16       array of dimension at least
!           ( 1 + ( n - 1 )*abs( INCY ) ).
!           Before entry, the incremented array Y must contain the n
!           element vector y.
!           Unchanged on exit.
!
!  INCY   - INTEGER.
!           On entry, INCY specifies the increment for the elements of
!           Y. INCY must not be zero.
!           Unchanged on exit.
!
!  A      - COMPLEX*16       array of DIMENSION ( LDA, n ).
!           Before entry, the leading m by n part of the array A must
!           contain the matrix of coefficients. On exit, A is
!           overwritten by the updated matrix.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program. LDA must be at least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 2 Blas routine.
!
!  -- Written on 22-October-1986.
!     Jack Dongarra, Argonne National Lab.
!     Jeremy Du Croz, Nag Central Office.
!     Sven Hammarling, Nag Central Office.
!     Richard Hanson, Sandia National Labs.
!
!
!     .. Parameters ..
      COMPLEX*16         ZERO
      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
!     .. Local Scalars ..
      COMPLEX*16         TEMP
      INTEGER            I, INFO, IX, J, JY, KX
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF     ( M.LT.0 )THEN
         INFO = 1
      ELSE IF( N.LT.0 )THEN
         INFO = 2
      ELSE IF( INCX.EQ.0 )THEN
         INFO = 5
      ELSE IF( INCY.EQ.0 )THEN
         INFO = 7
      ELSE IF( LDA.LT.MAX( 1, M ) )THEN
         INFO = 9
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'ZGERU ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) )               &
     &   RETURN
!
!     Start the operations. In this version the elements of A are
!     accessed sequentially with one pass through A.
!
      IF( INCY.GT.0 )THEN
         JY = 1
      ELSE
         JY = 1 - ( N - 1 )*INCY
      END IF
      IF( INCX.EQ.1 )THEN
         DO 20, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               DO 10, I = 1, M
                  A( I, J ) = A( I, J ) + X( I )*TEMP
   10          CONTINUE
            END IF
            JY = JY + INCY
   20    CONTINUE
      ELSE
         IF( INCX.GT.0 )THEN
            KX = 1
         ELSE
            KX = 1 - ( M - 1 )*INCX
         END IF
         DO 40, J = 1, N
            IF( Y( JY ).NE.ZERO )THEN
               TEMP = ALPHA*Y( JY )
               IX   = KX
               DO 30, I = 1, M
                  A( I, J ) = A( I, J ) + X( IX )*TEMP
                  IX        = IX        + INCX
   30          CONTINUE
            END IF
            JY = JY + INCY
   40    CONTINUE
      END IF
!
      RETURN
!
!     End of ZGERU .
!
      END
      subroutine  zscal(n,za,zx,incx)
!
!     scales a vector by a constant.
!     jack dongarra, 3/11/78.
!     modified 3/93 to return if incx .le. 0.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double complex za,zx(*)
      integer i,incx,ix,n
!
      if( n.le.0 .or. incx.le.0 )return
      if(incx.eq.1)go to 20
!
!        code for increment not equal to 1
!
      ix = 1
      do 10 i = 1,n
        zx(ix) = za*zx(ix)
        ix = ix + incx
   10 continue
      return
!
!        code for increment equal to 1
!
   20 do 30 i = 1,n
        zx(i) = za*zx(i)
   30 continue
      return
      end
      subroutine  zswap (n,zx,incx,zy,incy)
!
!     interchanges two vectors.
!     jack dongarra, 3/11/78.
!     modified 12/3/93, array(1) declarations changed to array(*)
!
      double complex zx(*),zy(*),ztemp
      integer i,incx,incy,ix,iy,n
!
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1)go to 20
!
!       code for unequal increments or equal increments not equal
!         to 1
!
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        ztemp = zx(ix)
        zx(ix) = zy(iy)
        zy(iy) = ztemp
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
!
!       code for both increments equal to 1
   20 do 30 i = 1,n
        ztemp = zx(i)
        zx(i) = zy(i)
        zy(i) = ztemp
   30 continue
      return
      end
      SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, &
     &                   B, LDB )
!     .. Scalar Arguments ..
      CHARACTER*1        SIDE, UPLO, TRANSA, DIAG
      INTEGER            M, N, LDA, LDB
      COMPLEX*16         ALPHA
!     .. Array Arguments ..
      COMPLEX*16         A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  ZTRSM  solves one of the matrix equations
!
!     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B,
!
!  where alpha is a scalar, X and B are m by n matrices, A is a unit, or
!  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
!
!     op( A ) = A   or   op( A ) = A'   or   op( A ) = conjg( A' ).
!
!  The matrix X is overwritten on B.
!
!  Parameters
!  ==========
!
!  SIDE   - CHARACTER*1.
!           On entry, SIDE specifies whether op( A ) appears on the left
!           or right of X as follows:
!
!              SIDE = 'L' or 'l'   op( A )*X = alpha*B.
!
!              SIDE = 'R' or 'r'   X*op( A ) = alpha*B.
!
!           Unchanged on exit.
!
!  UPLO   - CHARACTER*1.
!           On entry, UPLO specifies whether the matrix A is an upper or
!           lower triangular matrix as follows:
!
!              UPLO = 'U' or 'u'   A is an upper triangular matrix.
!
!              UPLO = 'L' or 'l'   A is a lower triangular matrix.
!
!           Unchanged on exit.
!
!  TRANSA - CHARACTER*1.
!           On entry, TRANSA specifies the form of op( A ) to be used in
!           the matrix multiplication as follows:
!
!              TRANSA = 'N' or 'n'   op( A ) = A.
!
!              TRANSA = 'T' or 't'   op( A ) = A'.
!
!              TRANSA = 'C' or 'c'   op( A ) = conjg( A' ).
!
!           Unchanged on exit.
!
!  DIAG   - CHARACTER*1.
!           On entry, DIAG specifies whether or not A is unit triangular
!           as follows:
!
!              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
!
!              DIAG = 'N' or 'n'   A is not assumed to be unit
!                                  triangular.
!
!           Unchanged on exit.
!
!  M      - INTEGER.
!           On entry, M specifies the number of rows of B. M must be at
!           least zero.
!           Unchanged on exit.
!
!  N      - INTEGER.
!           On entry, N specifies the number of columns of B.  N must be
!           at least zero.
!           Unchanged on exit.
!
!  ALPHA  - COMPLEX*16      .
!           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
!           zero then  A is not referenced and  B need not be set before
!           entry.
!           Unchanged on exit.
!
!  A      - COMPLEX*16       array of DIMENSION ( LDA, k ), where k is m
!           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
!           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
!           upper triangular part of the array  A must contain the upper
!           triangular matrix  and the strictly lower triangular part of
!           A is not referenced.
!           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
!           lower triangular part of the array  A must contain the lower
!           triangular matrix  and the strictly upper triangular part of
!           A is not referenced.
!           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
!           A  are not referenced either,  but are assumed to be  unity.
!           Unchanged on exit.
!
!  LDA    - INTEGER.
!           On entry, LDA specifies the first dimension of A as declared
!           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
!           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
!           then LDA must be at least max( 1, n ).
!           Unchanged on exit.
!
!  B      - COMPLEX*16       array of DIMENSION ( LDB, n ).
!           Before entry,  the leading  m by n part of the array  B must
!           contain  the  right-hand  side  matrix  B,  and  on exit  is
!           overwritten by the solution matrix  X.
!
!  LDB    - INTEGER.
!           On entry, LDB specifies the first dimension of B as declared
!           in  the  calling  (sub)  program.   LDB  must  be  at  least
!           max( 1, m ).
!           Unchanged on exit.
!
!
!  Level 3 Blas routine.
!
!  -- Written on 8-February-1989.
!     Jack Dongarra, Argonne National Laboratory.
!     Iain Duff, AERE Harwell.
!     Jeremy Du Croz, Numerical Algorithms Group Ltd.
!     Sven Hammarling, Numerical Algorithms Group Ltd.
!
!
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     .. External Subroutines ..
      EXTERNAL           XERBLA
!     .. Intrinsic Functions ..
      INTRINSIC          DCONJG, MAX
!     .. Local Scalars ..
      LOGICAL            LSIDE, NOCONJ, NOUNIT, UPPER
      INTEGER            I, INFO, J, K, NROWA
      COMPLEX*16         TEMP
!     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER        ( ONE  = ( 1.0D+0, 0.0D+0 ) )
      COMPLEX*16         ZERO
      PARAMETER        ( ZERO = ( 0.0D+0, 0.0D+0 ) )
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      LSIDE  = LSAME( SIDE  , 'L' )
      IF( LSIDE )THEN
         NROWA = M
      ELSE
         NROWA = N
      END IF
      NOCONJ = LSAME( TRANSA, 'T' )
      NOUNIT = LSAME( DIAG  , 'N' )
      UPPER  = LSAME( UPLO  , 'U' )
!
      INFO   = 0
      IF(      ( .NOT.LSIDE                ).AND.                       &
     &         ( .NOT.LSAME( SIDE  , 'R' ) )      )THEN
         INFO = 1
      ELSE IF( ( .NOT.UPPER                ).AND.                       &
     &         ( .NOT.LSAME( UPLO  , 'L' ) )      )THEN
         INFO = 2
      ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'T' ) ).AND.                       &
     &         ( .NOT.LSAME( TRANSA, 'C' ) )      )THEN
         INFO = 3
      ELSE IF( ( .NOT.LSAME( DIAG  , 'U' ) ).AND.                       &
     &         ( .NOT.LSAME( DIAG  , 'N' ) )      )THEN
         INFO = 4
      ELSE IF( M  .LT.0               )THEN
         INFO = 5
      ELSE IF( N  .LT.0               )THEN
         INFO = 6
      ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN
         INFO = 9
      ELSE IF( LDB.LT.MAX( 1, M     ) )THEN
         INFO = 11
      END IF
      IF( INFO.NE.0 )THEN
         CALL XERBLA( 'ZTRSM ', INFO )
         RETURN
      END IF
!
!     Quick return if possible.
!
      IF( N.EQ.0 )                                                      &
     &   RETURN
!
!     And when  alpha.eq.zero.
!
      IF( ALPHA.EQ.ZERO )THEN
         DO 20, J = 1, N
            DO 10, I = 1, M
               B( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
         RETURN
      END IF
!
!     Start the operations.
!
      IF( LSIDE )THEN
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*inv( A )*B.
!
            IF( UPPER )THEN
               DO 60, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 30, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   30                CONTINUE
                  END IF
                  DO 50, K = M, 1, -1
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 40, I = 1, K - 1
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   40                   CONTINUE
                     END IF
   50             CONTINUE
   60          CONTINUE
            ELSE
               DO 100, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 70, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
   70                CONTINUE
                  END IF
                  DO 90 K = 1, M
                     IF( B( K, J ).NE.ZERO )THEN
                        IF( NOUNIT )                                    &
     &                     B( K, J ) = B( K, J )/A( K, K )
                        DO 80, I = K + 1, M
                           B( I, J ) = B( I, J ) - B( K, J )*A( I, K )
   80                   CONTINUE
                     END IF
   90             CONTINUE
  100          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*inv( A' )*B
!           or    B := alpha*inv( conjg( A' ) )*B.
!
            IF( UPPER )THEN
               DO 140, J = 1, N
                  DO 130, I = 1, M
                     TEMP = ALPHA*B( I, J )
                     IF( NOCONJ )THEN
                        DO 110, K = 1, I - 1
                           TEMP = TEMP - A( K, I )*B( K, J )
  110                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/A( I, I )
                     ELSE
                        DO 120, K = 1, I - 1
                           TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J )
  120                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/DCONJG( A( I, I ) )
                     END IF
                     B( I, J ) = TEMP
  130             CONTINUE
  140          CONTINUE
            ELSE
               DO 180, J = 1, N
                  DO 170, I = M, 1, -1
                     TEMP = ALPHA*B( I, J )
                     IF( NOCONJ )THEN
                        DO 150, K = I + 1, M
                           TEMP = TEMP - A( K, I )*B( K, J )
  150                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/A( I, I )
                     ELSE
                        DO 160, K = I + 1, M
                           TEMP = TEMP - DCONJG( A( K, I ) )*B( K, J )
  160                   CONTINUE
                        IF( NOUNIT )                                    &
     &                     TEMP = TEMP/DCONJG( A( I, I ) )
                     END IF
                     B( I, J ) = TEMP
  170             CONTINUE
  180          CONTINUE
            END IF
         END IF
      ELSE
         IF( LSAME( TRANSA, 'N' ) )THEN
!
!           Form  B := alpha*B*inv( A ).
!
            IF( UPPER )THEN
               DO 230, J = 1, N
                  IF( ALPHA.NE.ONE )THEN
                     DO 190, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  190                CONTINUE
                  END IF
                  DO 210, K = 1, J - 1
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 200, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  200                   CONTINUE
                     END IF
  210             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 220, I = 1, M
                        B( I, J ) = TEMP*B( I, J )
  220                CONTINUE
                  END IF
  230          CONTINUE
            ELSE
               DO 280, J = N, 1, -1
                  IF( ALPHA.NE.ONE )THEN
                     DO 240, I = 1, M
                        B( I, J ) = ALPHA*B( I, J )
  240                CONTINUE
                  END IF
                  DO 260, K = J + 1, N
                     IF( A( K, J ).NE.ZERO )THEN
                        DO 250, I = 1, M
                           B( I, J ) = B( I, J ) - A( K, J )*B( I, K )
  250                   CONTINUE
                     END IF
  260             CONTINUE
                  IF( NOUNIT )THEN
                     TEMP = ONE/A( J, J )
                     DO 270, I = 1, M
                       B( I, J ) = TEMP*B( I, J )
  270                CONTINUE
                  END IF
  280          CONTINUE
            END IF
         ELSE
!
!           Form  B := alpha*B*inv( A' )
!           or    B := alpha*B*inv( conjg( A' ) ).
!
            IF( UPPER )THEN
               DO 330, K = N, 1, -1
                  IF( NOUNIT )THEN
                     IF( NOCONJ )THEN
                        TEMP = ONE/A( K, K )
                     ELSE
                        TEMP = ONE/DCONJG( A( K, K ) )
                     END IF
                     DO 290, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  290                CONTINUE
                  END IF
                  DO 310, J = 1, K - 1
                     IF( A( J, K ).NE.ZERO )THEN
                        IF( NOCONJ )THEN
                           TEMP = A( J, K )
                        ELSE
                           TEMP = DCONJG( A( J, K ) )
                        END IF
                        DO 300, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  300                   CONTINUE
                     END IF
  310             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 320, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  320                CONTINUE
                  END IF
  330          CONTINUE
            ELSE
               DO 380, K = 1, N
                  IF( NOUNIT )THEN
                     IF( NOCONJ )THEN
                        TEMP = ONE/A( K, K )
                     ELSE
                        TEMP = ONE/DCONJG( A( K, K ) )
                     END IF
                     DO 340, I = 1, M
                        B( I, K ) = TEMP*B( I, K )
  340                CONTINUE
                  END IF
                  DO 360, J = K + 1, N
                     IF( A( J, K ).NE.ZERO )THEN
                        IF( NOCONJ )THEN
                           TEMP = A( J, K )
                        ELSE
                           TEMP = DCONJG( A( J, K ) )
                        END IF
                        DO 350, I = 1, M
                           B( I, J ) = B( I, J ) - TEMP*B( I, K )
  350                   CONTINUE
                     END IF
  360             CONTINUE
                  IF( ALPHA.NE.ONE )THEN
                     DO 370, I = 1, M
                        B( I, K ) = ALPHA*B( I, K )
  370                CONTINUE
                  END IF
  380          CONTINUE
            END IF
         END IF
      END IF
!
      RETURN
!
!     End of ZTRSM .
!
      END
      SUBROUTINE CLACON( N, V, X, EST, KASE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            KASE, N
      REAL               EST
!     ..
!     .. Array Arguments ..
      COMPLEX            V( N ), X( N )
!     ..
!
!  Purpose
!  =======
!
!  CLACON estimates the 1-norm of a square, complex matrix A.
!  Reverse communication is used for evaluating matrix-vector products.
!
!  Arguments
!  =========
!
!  N      (input) INTEGER
!         The order of the matrix.  N >= 1.
!
!  V      (workspace) COMPLEX array, dimension (N)
!         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
!         (W is not returned).
!
!  X      (input/output) COMPLEX array, dimension (N)
!         On an intermediate return, X should be overwritten by
!               A * X,   if KASE=1,
!               A' * X,  if KASE=2,
!         where A' is the conjugate transpose of A, and CLACON must be
!         re-called with all the other parameters unchanged.
!
!  EST    (output) REAL
!         An estimate (a lower bound) for norm(A).
!
!  KASE   (input/output) INTEGER
!         On the initial call to CLACON, KASE should be 0.
!         On an intermediate return, KASE will be 1 or 2, indicating
!         whether X should be overwritten by A * X  or A' * X.
!         On the final return from CLACON, KASE will again be 0.
!
!  Further Details
!  ======= =======
!
!  Contributed by Nick Higham, University of Manchester.
!  Originally named CONEST, dated March 16, 1988.
!
!  Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
!  a real or complex matrix, with applications to condition estimation",
!  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
!
!  Last modified:  April, 1999
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER            ITMAX
      PARAMETER          ( ITMAX = 5 )
      REAL               ONE, TWO
      PARAMETER          ( ONE = 1.0E0, TWO = 2.0E0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),                    &
     &                   CONE = ( 1.0E0, 0.0E0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            I, ITER, J, JLAST, JUMP
      REAL               ABSXI, ALTSGN, ESTOLD, SAFMIN, TEMP
!     ..
!     .. External Functions ..
      INTEGER            ICMAX1
      REAL               SCSUM1, SLAMCH
      EXTERNAL           ICMAX1, SCSUM1, SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL           CCOPY
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, CMPLX, REAL
!     ..
!     .. Save statement ..
      SAVE
!     ..
!     .. Executable Statements ..
!
      SAFMIN = SLAMCH( 'Safe minimum' )
      IF( KASE.EQ.0 ) THEN
         DO 10 I = 1, N
            X( I ) = CMPLX( ONE / REAL( N ) )
   10    CONTINUE
         KASE = 1
         JUMP = 1
         RETURN
      END IF
!
      GO TO ( 20, 40, 70, 90, 120 )JUMP
!
!     ................ ENTRY   (JUMP = 1)
!     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
!
   20 CONTINUE
      IF( N.EQ.1 ) THEN
         V( 1 ) = X( 1 )
         EST = ABS( V( 1 ) )
!        ... QUIT
         GO TO 130
      END IF
      EST = SCSUM1( N, X, 1 )
!
      DO 30 I = 1, N
         ABSXI = ABS( X( I ) )
         IF( ABSXI.GT.SAFMIN ) THEN
            X( I ) = CMPLX( REAL( X( I ) ) / ABSXI,                     &
     &               AIMAG( X( I ) ) / ABSXI )
         ELSE
            X( I ) = CONE
         END IF
   30 CONTINUE
      KASE = 2
      JUMP = 2
      RETURN
!
!     ................ ENTRY   (JUMP = 2)
!     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
!
   40 CONTINUE
      J = ICMAX1( N, X, 1 )
      ITER = 2
!
!     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
!
   50 CONTINUE
      DO 60 I = 1, N
         X( I ) = CZERO
   60 CONTINUE
      X( J ) = CONE
      KASE = 1
      JUMP = 3
      RETURN
!
!     ................ ENTRY   (JUMP = 3)
!     X HAS BEEN OVERWRITTEN BY A*X.
!
   70 CONTINUE
      CALL CCOPY( N, X, 1, V, 1 )
      ESTOLD = EST
      EST = SCSUM1( N, V, 1 )
!
!     TEST FOR CYCLING.
      IF( EST.LE.ESTOLD )                                               &
     &   GO TO 100
!
      DO 80 I = 1, N
         ABSXI = ABS( X( I ) )
         IF( ABSXI.GT.SAFMIN ) THEN
            X( I ) = CMPLX( REAL( X( I ) ) / ABSXI,                     &
     &               AIMAG( X( I ) ) / ABSXI )
         ELSE
            X( I ) = CONE
         END IF
   80 CONTINUE
      KASE = 2
      JUMP = 4
      RETURN
!
!     ................ ENTRY   (JUMP = 4)
!     X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
!
   90 CONTINUE
      JLAST = J
      J = ICMAX1( N, X, 1 )
      IF( ( ABS( X( JLAST ) ).NE.ABS( X( J ) ) ) .AND.                  &
     &    ( ITER.LT.ITMAX ) ) THEN
         ITER = ITER + 1
         GO TO 50
      END IF
!
!     ITERATION COMPLETE.  FINAL STAGE.
!
  100 CONTINUE
      ALTSGN = ONE
      DO 110 I = 1, N
         X( I ) = CMPLX( ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) ) )
         ALTSGN = -ALTSGN
  110 CONTINUE
      KASE = 1
      JUMP = 5
      RETURN
!
!     ................ ENTRY   (JUMP = 5)
!     X HAS BEEN OVERWRITTEN BY A*X.
!
  120 CONTINUE
      TEMP = TWO*( SCSUM1( N, X, 1 ) / REAL( 3*N ) )
      IF( TEMP.GT.EST ) THEN
         CALL CCOPY( N, X, 1, V, 1 )
         EST = TEMP
      END IF
!
  130 CONTINUE
      KASE = 0
      RETURN
!
!     End of CLACON
!
      END
      SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         AB( LDAB, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGBTF2 computes an LU factorization of a complex m-by-n band matrix
!  A using partial pivoting with row interchanges.
!
!  This is the unblocked version of the algorithm, calling Level 2 BLAS.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
!          On entry, the matrix A in band storage, in rows KL+1 to
!          2*KL+KU+1; rows 1 to KL of the array need not be set.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
!
!          On exit, details of the factorization: U is stored as an
!          upper triangular band matrix with KL+KU superdiagonals in
!          rows 1 to KL+KU+1, and the multipliers used during the
!          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
!          See below for further details.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  M = N = 6, KL = 2, KU = 1:
!
!  On entry:                       On exit:
!
!      *    *    *    +    +    +       *    *    *   u14  u25  u36
!      *    *    +    +    +    +       *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
!     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
!
!  Array elements marked * are not used by the routine; elements marked
!  + need not be set on entry, but are required by the routine to store
!  elements of U, because of fill-in resulting from the row
!  interchanges.
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),                    &
     &                   ZERO = ( 0.0D+0, 0.0D+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            I, J, JP, JU, KM, KV
!     ..
!     .. External Functions ..
      INTEGER            IZAMAX
      EXTERNAL           IZAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGERU, ZSCAL, ZSWAP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     KV is the number of superdiagonals in the factor U, allowing for
!     fill-in.
!
      KV = KU + KL
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGBTF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
!     Gaussian elimination with partial pivoting
!
!     Set fill-in elements in columns KU+2 to KV to zero.
!
      DO 20 J = KU + 2, MIN( KV, N )
         DO 10 I = KV - J + 2, KL
            AB( I, J ) = ZERO
   10    CONTINUE
   20 CONTINUE
!
!     JU is the index of the last column affected by the current stage
!     of the factorization.
!
      JU = 1
!
      DO 40 J = 1, MIN( M, N )
!
!        Set fill-in elements in column J+KV to zero.
!
         IF( J+KV.LE.N ) THEN
            DO 30 I = 1, KL
               AB( I, J+KV ) = ZERO
   30       CONTINUE
         END IF
!
!        Find pivot and test for singularity. KM is the number of
!        subdiagonal elements in the current column.
!
         KM = MIN( KL, M-J )
         JP = IZAMAX( KM+1, AB( KV+1, J ), 1 )
         IPIV( J ) = JP + J - 1
         IF( AB( KV+JP, J ).NE.ZERO ) THEN
            JU = MAX( JU, MIN( J+KU+JP-1, N ) )
!
!           Apply interchange to columns J to JU.
!
            IF( JP.NE.1 )                                               &
     &         CALL ZSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,              &
     &                     AB( KV+1, J ), LDAB-1 )
            IF( KM.GT.0 ) THEN
!
!              Compute multipliers.
!
               CALL ZSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
!
!              Update trailing submatrix within the band.
!
               IF( JU.GT.J )                                            &
     &            CALL ZGERU( KM, JU-J, -ONE, AB( KV+2, J ), 1,         &
     &                        AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),   &
     &                        LDAB-1 )
            END IF
         ELSE
!
!           If pivot is zero, set INFO to the index of the pivot
!           unless a zero pivot has already been found.
!
            IF( INFO.EQ.0 )                                             &
     &         INFO = J
         END IF
   40 CONTINUE
      RETURN
!
!     End of ZGBTF2
!
      END
      SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         AB( LDAB, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGBTRF computes an LU factorization of a complex m-by-n band matrix A
!  using partial pivoting with row interchanges.
!
!  This is the blocked version of the algorithm, calling Level 3 BLAS.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  KL      (input) INTEGER
!          The number of subdiagonals within the band of A.  KL >= 0.
!
!  KU      (input) INTEGER
!          The number of superdiagonals within the band of A.  KU >= 0.
!
!  AB      (input/output) COMPLEX*16 array, dimension (LDAB,N)
!          On entry, the matrix A in band storage, in rows KL+1 to
!          2*KL+KU+1; rows 1 to KL of the array need not be set.
!          The j-th column of A is stored in the j-th column of the
!          array AB as follows:
!          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
!
!          On exit, details of the factorization: U is stored as an
!          upper triangular band matrix with KL+KU superdiagonals in
!          rows 1 to KL+KU+1, and the multipliers used during the
!          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
!          See below for further details.
!
!  LDAB    (input) INTEGER
!          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  Further Details
!  ===============
!
!  The band storage scheme is illustrated by the following example, when
!  M = N = 6, KL = 2, KU = 1:
!
!  On entry:                       On exit:
!
!      *    *    *    +    +    +       *    *    *   u14  u25  u36
!      *    *    +    +    +    +       *    *   u13  u24  u35  u46
!      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
!     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
!     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
!     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
!
!  Array elements marked * are not used by the routine; elements marked
!  + need not be set on entry, but are required by the routine to store
!  elements of U because of fill-in resulting from the row interchanges.
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),                    &
     &                   ZERO = ( 0.0D+0, 0.0D+0 ) )
      INTEGER            NBMAX, LDWORK
      PARAMETER          ( NBMAX = 64, LDWORK = NBMAX+1 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,  &
     &                   JU, K2, KM, KV, NB, NW
      COMPLEX*16         TEMP
!     ..
!     .. Local Arrays ..
      COMPLEX*16         WORK13( LDWORK, NBMAX ),                       &
     &                   WORK31( LDWORK, NBMAX )
!     ..
!     .. External Functions ..
      INTEGER            ILAENV, IZAMAX
      EXTERNAL           ILAENV, IZAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZCOPY, ZGBTF2, ZGEMM, ZGERU, ZLASWP,   &
     &                   ZSCAL, ZSWAP, ZTRSM
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     KV is the number of superdiagonals in the factor U, allowing for
!     fill-in
!
      KV = KU + KL
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGBTRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
!     Determine the block size for this environment
!
      NB = ILAENV( 1, 'ZGBTRF', ' ', M, N, KL, KU )
!
!     The block size must not exceed the limit set by the size of the
!     local arrays WORK13 and WORK31.
!
      NB = MIN( NB, NBMAX )
!
      IF( NB.LE.1 .OR. NB.GT.KL ) THEN
!
!        Use unblocked code
!
         CALL ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
      ELSE
!
!        Use blocked code
!
!        Zero the superdiagonal elements of the work array WORK13
!
         DO 20 J = 1, NB
            DO 10 I = 1, J - 1
               WORK13( I, J ) = ZERO
   10       CONTINUE
   20    CONTINUE
!
!        Zero the subdiagonal elements of the work array WORK31
!
         DO 40 J = 1, NB
            DO 30 I = J + 1, NB
               WORK31( I, J ) = ZERO
   30       CONTINUE
   40    CONTINUE
!
!        Gaussian elimination with partial pivoting
!
!        Set fill-in elements in columns KU+2 to KV to zero
!
         DO 60 J = KU + 2, MIN( KV, N )
            DO 50 I = KV - J + 2, KL
               AB( I, J ) = ZERO
   50       CONTINUE
   60    CONTINUE
!
!        JU is the index of the last column affected by the current
!        stage of the factorization
!
         JU = 1
!
         DO 180 J = 1, MIN( M, N ), NB
            JB = MIN( NB, MIN( M, N )-J+1 )
!
!           The active part of the matrix is partitioned
!
!              A11   A12   A13
!              A21   A22   A23
!              A31   A32   A33
!
!           Here A11, A21 and A31 denote the current block of JB columns
!           which is about to be factorized. The number of rows in the
!           partitioning are JB, I2, I3 respectively, and the numbers
!           of columns are JB, J2, J3. The superdiagonal elements of A13
!           and the subdiagonal elements of A31 lie outside the band.
!
            I2 = MIN( KL-JB, M-J-JB+1 )
            I3 = MIN( JB, M-J-KL+1 )
!
!           J2 and J3 are computed after JU has been updated.
!
!           Factorize the current block of JB columns
!
            DO 80 JJ = J, J + JB - 1
!
!              Set fill-in elements in column JJ+KV to zero
!
               IF( JJ+KV.LE.N ) THEN
                  DO 70 I = 1, KL
                     AB( I, JJ+KV ) = ZERO
   70             CONTINUE
               END IF
!
!              Find pivot and test for singularity. KM is the number of
!              subdiagonal elements in the current column.
!
               KM = MIN( KL, M-JJ )
               JP = IZAMAX( KM+1, AB( KV+1, JJ ), 1 )
               IPIV( JJ ) = JP + JJ - J
               IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
                  JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
                  IF( JP.NE.1 ) THEN
!
!                    Apply interchange to columns J to J+JB-1
!
                     IF( JP+JJ-1.LT.J+KL ) THEN
!
                        CALL ZSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,     &
     &                              AB( KV+JP+JJ-J, J ), LDAB-1 )
                     ELSE
!
!                       The interchange affects columns J to JJ-1 of A31
!                       which are stored in the work array WORK31
!
                        CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,   &
     &                              WORK31( JP+JJ-J-KL, 1 ), LDWORK )
                        CALL ZSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,    &
     &                              AB( KV+JP, JJ ), LDAB-1 )
                     END IF
                  END IF
!
!                 Compute multipliers
!
                  CALL ZSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), &
     &                        1 )
!
!                 Update trailing submatrix within the band and within
!                 the current block. JM is the index of the last column
!                 which needs to be updated.
!
                  JM = MIN( JU, J+JB-1 )
                  IF( JM.GT.JJ )                                        &
     &               CALL ZGERU( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,    &
     &                           AB( KV, JJ+1 ), LDAB-1,                &
     &                           AB( KV+1, JJ+1 ), LDAB-1 )
               ELSE
!
!                 If pivot is zero, set INFO to the index of the pivot
!                 unless a zero pivot has already been found.
!
                  IF( INFO.EQ.0 )                                       &
     &               INFO = JJ
               END IF
!
!              Copy current column of A31 into the work array WORK31
!
               NW = MIN( JJ-J+1, I3 )
               IF( NW.GT.0 )                                            &
     &            CALL ZCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,            &
     &                        WORK31( 1, JJ-J+1 ), 1 )
   80       CONTINUE
            IF( J+JB.LE.N ) THEN
!
!              Apply the row interchanges to the other blocks.
!
               J2 = MIN( JU-J+1, KV ) - JB
               J3 = MAX( 0, JU-J-KV+1 )
!
!              Use ZLASWP to apply the row interchanges to A12, A22, and
!              A32.
!
               CALL ZLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,     &
     &                      IPIV( J ), 1 )
!
!              Adjust the pivot indices.
!
               DO 90 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
   90          CONTINUE
!
!              Apply the row interchanges to A13, A23, and A33
!              columnwise.
!
               K2 = J - 1 + JB + J2
               DO 110 I = 1, J3
                  JJ = K2 + I
                  DO 100 II = J + I - 1, J + JB - 1
                     IP = IPIV( II )
                     IF( IP.NE.II ) THEN
                        TEMP = AB( KV+1+II-JJ, JJ )
                        AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
                        AB( KV+1+IP-JJ, JJ ) = TEMP
                     END IF
  100             CONTINUE
  110          CONTINUE
!
!              Update the relevant part of the trailing submatrix
!
               IF( J2.GT.0 ) THEN
!
!                 Update A12
!
                  CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',  &
     &                        JB, J2, ONE, AB( KV+1, J ), LDAB-1,       &
     &                        AB( KV+1-JB, J+JB ), LDAB-1 )
!
                  IF( I2.GT.0 ) THEN
!
!                    Update A22
!
                     CALL ZGEMM( 'No transpose', 'No transpose', I2, J2,&
     &                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,    &
     &                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,      &
     &                           AB( KV+1, J+JB ), LDAB-1 )
                  END IF
!
                  IF( I3.GT.0 ) THEN
!
!                    Update A32
!
                     CALL ZGEMM( 'No transpose', 'No transpose', I3, J2,&
     &                           JB, -ONE, WORK31, LDWORK,              &
     &                           AB( KV+1-JB, J+JB ), LDAB-1, ONE,      &
     &                           AB( KV+KL+1-JB, J+JB ), LDAB-1 )
                  END IF
               END IF
!
               IF( J3.GT.0 ) THEN
!
!                 Copy the lower triangle of A13 into the work array
!                 WORK13
!
                  DO 130 JJ = 1, J3
                     DO 120 II = JJ, JB
                        WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
  120                CONTINUE
  130             CONTINUE
!
!                 Update A13 in the work array
!
                  CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit',  &
     &                        JB, J3, ONE, AB( KV+1, J ), LDAB-1,       &
     &                        WORK13, LDWORK )
!
                  IF( I2.GT.0 ) THEN
!
!                    Update A23
!
                     CALL ZGEMM( 'No transpose', 'No transpose', I2, J3,&
     &                           JB, -ONE, AB( KV+1+JB, J ), LDAB-1,    &
     &                           WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), &
     &                           LDAB-1 )
                  END IF
!
                  IF( I3.GT.0 ) THEN
!
!                    Update A33
!
                     CALL ZGEMM( 'No transpose', 'No transpose', I3, J3,&
     &                           JB, -ONE, WORK31, LDWORK, WORK13,      &
     &                           LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
                  END IF
!
!                 Copy the lower triangle of A13 back into place
!
                  DO 150 JJ = 1, J3
                     DO 140 II = JJ, JB
                        AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
  140                CONTINUE
  150             CONTINUE
               END IF
            ELSE
!
!              Adjust the pivot indices.
!
               DO 160 I = J, J + JB - 1
                  IPIV( I ) = IPIV( I ) + J - 1
  160          CONTINUE
            END IF
!
!           Partially undo the interchanges in the current block to
!           restore the upper triangular form of A31 and copy the upper
!           triangle of A31 back into place
!
            DO 170 JJ = J + JB - 1, J, -1
               JP = IPIV( JJ ) - JJ + 1
               IF( JP.NE.1 ) THEN
!
!                 Apply interchange to columns J to JJ-1
!
                  IF( JP+JJ-1.LT.J+KL ) THEN
!
!                    The interchange does not affect A31
!
                     CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,      &
     &                           AB( KV+JP+JJ-J, J ), LDAB-1 )
                  ELSE
!
!                    The interchange does affect A31
!
                     CALL ZSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,      &
     &                           WORK31( JP+JJ-J-KL, 1 ), LDWORK )
                  END IF
               END IF
!
!              Copy the current column of A31 back into place
!
               NW = MIN( I3, JJ-J+1 )
               IF( NW.GT.0 )                                            &
     &            CALL ZCOPY( NW, WORK31( 1, JJ-J+1 ), 1,               &
     &                        AB( KV+KL+1-JJ+J, JJ ), 1 )
  170       CONTINUE
  180    CONTINUE
      END IF
!
      RETURN
!
!     End of ZGBTRF
!
      END
      SUBROUTINE ZGETF2( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGETF2 computes an LU factorization of a general m-by-n matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
!          On entry, the m by n matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE, ZERO
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),                    &
     &                   ZERO = ( 0.0D+0, 0.0D+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            J, JP
!     ..
!     .. External Functions ..
      INTEGER            IZAMAX
      EXTERNAL           IZAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGERU, ZSCAL, ZSWAP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGETF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
      DO 10 J = 1, MIN( M, N )
!
!        Find pivot and test for singularity.
!
         JP = J - 1 + IZAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
!
!           Apply the interchange to columns 1:N.
!
            IF( JP.NE.J )                                               &
     &         CALL ZSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
!
!           Compute elements J+1:M of J-th column.
!
            IF( J.LT.M )                                                &
     &         CALL ZSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
!
         ELSE IF( INFO.EQ.0 ) THEN
!
            INFO = J
         END IF
!
         IF( J.LT.MIN( M, N ) ) THEN
!
!           Update trailing submatrix.
!
            CALL ZGERU( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ),    &
     &                  LDA, A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
!
!     End of ZGETF2
!
      END
      SUBROUTINE ZGETRF( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGETRF computes an LU factorization of a general M-by-N matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 3 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
!          On entry, the M-by-N matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!                has been completed, but the factor U is exactly
!                singular, and division by zero will occur if it is used
!                to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZGEMM, ZGETF2, ZLASWP, ZTRSM
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGETRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'ZGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
!
!        Use unblocked code.
!
         CALL ZGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
!
!        Use blocked code.
!
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
!
!           Factor diagonal and subdiagonal blocks and test for exact
!           singularity.
!
            CALL ZGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
!
!           Adjust INFO and the pivot indices.
!
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )                            &
     &         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
!
!           Apply interchanges to columns 1:J-1.
!
            CALL ZLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
!
            IF( J+JB.LE.N ) THEN
!
!              Apply interchanges to columns J+JB:N.
!
               CALL ZLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,     &
     &                      IPIV, 1 )
!
!              Compute block row of U.
!
               CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, &
     &                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), &
     &                     LDA )
               IF( J+JB.LE.M ) THEN
!
!                 Update trailing submatrix.
!
                  CALL ZGEMM( 'No transpose', 'No transpose', M-J-JB+1, &
     &                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,    &
     &                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),  &
     &                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of ZGETRF
!
      END
      SUBROUTINE ZGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  ZGETRS solves a system of linear equations
!     A * X = B,  A**T * X = B,  or  A**H * X = B
!  with a general N-by-N matrix A using the LU factorization computed
!  by ZGETRF.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B     (No transpose)
!          = 'T':  A**T * X = B  (Transpose)
!          = 'C':  A**H * X = B  (Conjugate transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) COMPLEX*16 array, dimension (LDA,N)
!          The factors L and U from the factorization A = P*L*U
!          as computed by ZGETRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from ZGETRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      COMPLEX*16         ONE
      PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           XERBLA, ZLASWP, ZTRSM
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.        &
     &    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGETRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 )                                       &
     &   RETURN
!
      IF( NOTRAN ) THEN
!
!        Solve A * X = B.
!
!        Apply row interchanges to the right hand sides.
!
         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
!
!        Solve L*X = B, overwriting B with X.
!
         CALL ZTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,  &
     &               ONE, A, LDA, B, LDB )
!
!        Solve U*X = B, overwriting B with X.
!
         CALL ZTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,    &
     &               NRHS, ONE, A, LDA, B, LDB )
      ELSE
!
!        Solve A**T * X = B  or A**H * X = B.
!
!        Solve U'*X = B, overwriting B with X.
!
         CALL ZTRSM( 'Left', 'Upper', TRANS, 'Non-unit', N, NRHS, ONE,  &
     &               A, LDA, B, LDB )
!
!        Solve L'*X = B, overwriting B with X.
!
         CALL ZTRSM( 'Left', 'Lower', TRANS, 'Unit', N, NRHS, ONE, A,   &
     &               LDA, B, LDB )
!
!        Apply row interchanges to the solution vectors.
!
         CALL ZLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
!
      RETURN
!
!     End of ZGETRS
!
      END
      SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      COMPLEX*16         A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  ZLASWP performs a series of row interchanges on the matrix A.
!  One row interchange is initiated for each of rows K1 through K2 of A.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.
!
!  A       (input/output) COMPLEX*16 array, dimension (LDA,N)
!          On entry, the matrix of column dimension N to which the row
!          interchanges will be applied.
!          On exit, the permuted matrix.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!
!  K1      (input) INTEGER
!          The first element of IPIV for which a row interchange will
!          be done.
!
!  K2      (input) INTEGER
!          The last element of IPIV for which a row interchange will
!          be done.
!
!  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
!          The vector of pivot indices.  Only the elements in positions
!          K1 through K2 of IPIV are accessed.
!          IPIV(K) = L implies rows K and L are to be interchanged.
!
!  INCX    (input) INTEGER
!          The increment between successive values of IPIV.  If IPIV
!          is negative, the pivots are applied in reverse order.
!
!  Further Details
!  ===============
!
!  Modified by
!   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      COMPLEX*16         TEMP
!     ..
!     .. Executable Statements ..
!
!     Interchange row I with row IPIV(I) for each of rows K1 through K2.
!
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = 1 + ( 1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
!
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
!
      RETURN
!
!     End of ZLASWP
!
      END
      SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETF2 computes an LU factorization of a general m-by-n matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 2 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the m by n matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -k, the k-th argument had an illegal value
!          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!               has been completed, but the factor U is exactly
!               singular, and division by zero will occur if it is used
!               to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            J, JP
!     ..
!     .. External Functions ..
      INTEGER            IDAMAX
      EXTERNAL           IDAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, DSWAP, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETF2', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
      DO 10 J = 1, MIN( M, N )
!
!        Find pivot and test for singularity.
!
         JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
!
!           Apply the interchange to columns 1:N.
!
            IF( JP.NE.J )                                               &
     &         CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
!
!           Compute elements J+1:M of J-th column.
!
            IF( J.LT.M )                                                &
     &         CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
!
         ELSE IF( INFO.EQ.0 ) THEN
!
            INFO = J
         END IF
!
         IF( J.LT.MIN( M, N ) ) THEN
!
!           Update trailing submatrix.
!
            CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,&
     &                 A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
!
!     End of DGETF2
!
      END
      SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETRF computes an LU factorization of a general M-by-N matrix A
!  using partial pivoting with row interchanges.
!
!  The factorization has the form
!     A = P * L * U
!  where P is a permutation matrix, L is lower triangular with unit
!  diagonal elements (lower trapezoidal if m > n), and U is upper
!  triangular (upper trapezoidal if m < n).
!
!  This is the right-looking Level 3 BLAS version of the algorithm.
!
!  Arguments
!  =========
!
!  M       (input) INTEGER
!          The number of rows of the matrix A.  M >= 0.
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.  N >= 0.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the M-by-N matrix to be factored.
!          On exit, the factors L and U from the factorization
!          A = P*L*U; the unit diagonal elements of L are not stored.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,M).
!
!  IPIV    (output) INTEGER array, dimension (min(M,N))
!          The pivot indices; for 1 <= i <= min(M,N), row i of the
!          matrix was interchanged with row IPIV(i).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
!                has been completed, but the factor U is exactly
!                singular, and division by zero will occur if it is used
!                to solve a system of equations.
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
!     ..
!     .. External Subroutines ..
      EXTERNAL           DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
!     ..
!     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRF', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( M.EQ.0 .OR. N.EQ.0 )                                          &
     &   RETURN
!
!     Determine the block size for this environment.
!
      NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
!
!        Use unblocked code.
!
         CALL DGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
!
!        Use blocked code.
!
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
!
!           Factor diagonal and subdiagonal blocks and test for exact
!           singularity.
!
            CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
!
!           Adjust INFO and the pivot indices.
!
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )                            &
     &         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
!
!           Apply interchanges to columns 1:J-1.
!
            CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
!
            IF( J+JB.LE.N ) THEN
!
!              Apply interchanges to columns J+JB:N.
!
               CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,     &
     &                      IPIV, 1 )
!
!              Compute block row of U.
!
               CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, &
     &                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), &
     &                     LDA )
               IF( J+JB.LE.M ) THEN
!
!                 Update trailing submatrix.
!
                  CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, &
     &                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,    &
     &                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),  &
     &                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
!
!     End of DGETRF
!
      END
      SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
!
!  -- LAPACK routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     March 31, 1993
!
!     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
!     ..
!
!  Purpose
!  =======
!
!  DGETRS solves a system of linear equations
!     A * X = B  or  A' * X = B
!  with a general N-by-N matrix A using the LU factorization computed
!  by DGETRF.
!
!  Arguments
!  =========
!
!  TRANS   (input) CHARACTER*1
!          Specifies the form of the system of equations:
!          = 'N':  A * X = B  (No transpose)
!          = 'T':  A'* X = B  (Transpose)
!          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
!
!  N       (input) INTEGER
!          The order of the matrix A.  N >= 0.
!
!  NRHS    (input) INTEGER
!          The number of right hand sides, i.e., the number of columns
!          of the matrix B.  NRHS >= 0.
!
!  A       (input) DOUBLE PRECISION array, dimension (LDA,N)
!          The factors L and U from the factorization A = P*L*U
!          as computed by DGETRF.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.  LDA >= max(1,N).
!
!  IPIV    (input) INTEGER array, dimension (N)
!          The pivot indices from DGETRF; for 1<=i<=N, row i of the
!          matrix was interchanged with row IPIV(i).
!
!  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
!          On entry, the right hand side matrix B.
!          On exit, the solution matrix X.
!
!  LDB     (input) INTEGER
!          The leading dimension of the array B.  LDB >= max(1,N).
!
!  INFO    (output) INTEGER
!          = 0:  successful exit
!          < 0:  if INFO = -i, the i-th argument had an illegal value
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION   ONE
      PARAMETER          ( ONE = 1.0D+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            NOTRAN
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           DLASWP, DTRSM, XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.        &
     &    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DGETRS', -INFO )
         RETURN
      END IF
!
!     Quick return if possible
!
      IF( N.EQ.0 .OR. NRHS.EQ.0 )                                       &
     &   RETURN
!
      IF( NOTRAN ) THEN
!
!        Solve A * X = B.
!
!        Apply row interchanges to the right hand sides.
!
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
!
!        Solve L*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,  &
     &               ONE, A, LDA, B, LDB )
!
!        Solve U*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,    &
     &               NRHS, ONE, A, LDA, B, LDB )
      ELSE
!
!        Solve A' * X = B.
!
!        Solve U'*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, &
     &               ONE, A, LDA, B, LDB )
!
!        Solve L'*X = B, overwriting B with X.
!
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,&
     &               A, LDA, B, LDB )
!
!        Apply row interchanges to the solution vectors.
!
         CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
!
      RETURN
!
!     End of DGETRS
!
      END
      SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1999
!
!     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
!     ..
!     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * )
!     ..
!
!  Purpose
!  =======
!
!  DLASWP performs a series of row interchanges on the matrix A.
!  One row interchange is initiated for each of rows K1 through K2 of A.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of columns of the matrix A.
!
!  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
!          On entry, the matrix of column dimension N to which the row
!          interchanges will be applied.
!          On exit, the permuted matrix.
!
!  LDA     (input) INTEGER
!          The leading dimension of the array A.
!
!  K1      (input) INTEGER
!          The first element of IPIV for which a row interchange will
!          be done.
!
!  K2      (input) INTEGER
!          The last element of IPIV for which a row interchange will
!          be done.
!
!  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
!          The vector of pivot indices.  Only the elements in positions
!          K1 through K2 of IPIV are accessed.
!          IPIV(K) = L implies rows K and L are to be interchanged.
!
!  INCX    (input) INTEGER
!          The increment between successive values of IPIV.  If IPIV
!          is negative, the pivots are applied in reverse order.
!
!  Further Details
!  ===============
!
!  Modified by
!   R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, I1, I2, INC, IP, IX, IX0, J, K, N32
      DOUBLE PRECISION   TEMP
!     ..
!     .. Executable Statements ..
!
!     Interchange row I with row IPIV(I) for each of rows K1 through K2.
!
      IF( INCX.GT.0 ) THEN
         IX0 = K1
         I1 = K1
         I2 = K2
         INC = 1
      ELSE IF( INCX.LT.0 ) THEN
         IX0 = 1 + ( 1-K2 )*INCX
         I1 = K2
         I2 = K1
         INC = -1
      ELSE
         RETURN
      END IF
!
      N32 = ( N / 32 )*32
      IF( N32.NE.0 ) THEN
         DO 30 J = 1, N32, 32
            IX = IX0
            DO 20 I = I1, I2, INC
               IP = IPIV( IX )
               IF( IP.NE.I ) THEN
                  DO 10 K = J, J + 31
                     TEMP = A( I, K )
                     A( I, K ) = A( IP, K )
                     A( IP, K ) = TEMP
   10             CONTINUE
               END IF
               IX = IX + INCX
   20       CONTINUE
   30    CONTINUE
      END IF
      IF( N32.NE.N ) THEN
         N32 = N32 + 1
         IX = IX0
         DO 50 I = I1, I2, INC
            IP = IPIV( IX )
            IF( IP.NE.I ) THEN
               DO 40 K = N32, N
                  TEMP = A( I, K )
                  A( I, K ) = A( IP, K )
                  A( IP, K ) = TEMP
   40          CONTINUE
            END IF
            IX = IX + INCX
   50    CONTINUE
      END IF
!
      RETURN
!
!     End of DLASWP
!
      END
      REAL             FUNCTION SCSUM1( N, CX, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            INCX, N
!     ..
!     .. Array Arguments ..
      COMPLEX            CX( * )
!     ..
!
!  Purpose
!  =======
!
!  SCSUM1 takes the sum of the absolute values of a complex
!  vector and returns a single precision result.
!
!  Based on SCASUM from the Level 1 BLAS.
!  The change is to use the 'genuine' absolute value.
!
!  Contributed by Nick Higham for use with CLACON.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of elements in the vector CX.
!
!  CX      (input) COMPLEX array, dimension (N)
!          The vector whose elements will be summed.
!
!  INCX    (input) INTEGER
!          The spacing between successive values of CX.  INCX > 0.
!
!  =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, NINCX
      REAL               STEMP
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS
!     ..
!     .. Executable Statements ..
!
      SCSUM1 = 0.0E0
      STEMP = 0.0E0
      IF( N.LE.0 )                                                      &
     &   RETURN
      IF( INCX.EQ.1 )                                                   &
     &   GO TO 20
!
!     CODE FOR INCREMENT NOT EQUAL TO 1
!
      NINCX = N*INCX
      DO 10 I = 1, NINCX, INCX
!
!        NEXT LINE MODIFIED.
!
         STEMP = STEMP + ABS( CX( I ) )
   10 CONTINUE
      SCSUM1 = STEMP
      RETURN
!
!     CODE FOR INCREMENT EQUAL TO 1
!
   20 CONTINUE
      DO 30 I = 1, N
!
!        NEXT LINE MODIFIED.
!
         STEMP = STEMP + ABS( CX( I ) )
   30 CONTINUE
      SCSUM1 = STEMP
      RETURN
!
!     End of SCSUM1
!
      END
      INTEGER          FUNCTION ICMAX1( N, CX, INCX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     September 30, 1994
!
!     .. Scalar Arguments ..
      INTEGER            INCX, N
!     ..
!     .. Array Arguments ..
      COMPLEX            CX( * )
!     ..
!
!  Purpose
!  =======
!
!  ICMAX1 finds the index of the element whose real part has maximum
!  absolute value.
!
!  Based on ICAMAX from Level 1 BLAS.
!  The change is to use the 'genuine' absolute value.
!
!  Contributed by Nick Higham for use with CLACON.
!
!  Arguments
!  =========
!
!  N       (input) INTEGER
!          The number of elements in the vector CX.
!
!  CX      (input) COMPLEX array, dimension (N)
!          The vector whose elements will be summed.
!
!  INCX    (input) INTEGER
!          The spacing between successive values of CX.  INCX >= 1.
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I, IX
      REAL               SMAX
      COMPLEX            ZDUM
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, REAL
!     ..
!     .. Statement Functions ..
      REAL               CABS1
!     ..
!     .. Statement Function definitions ..
!
!     NEXT LINE IS THE ONLY MODIFICATION.
      CABS1( ZDUM ) = ABS( REAL( ZDUM ) )
!     ..
!     .. Executable Statements ..
!
      ICMAX1 = 0
      IF( N.LT.1 )                                                      &
     &   RETURN
      ICMAX1 = 1
      IF( N.EQ.1 )                                                      &
     &   RETURN
      IF( INCX.EQ.1 )                                                   &
     &   GO TO 30
!
!     CODE FOR INCREMENT NOT EQUAL TO 1
!
      IX = 1
      SMAX = CABS1( CX( 1 ) )
      IX = IX + INCX
      DO 20 I = 2, N
         IF( CABS1( CX( IX ) ).LE.SMAX )                                &
     &      GO TO 10
         ICMAX1 = I
         SMAX = CABS1( CX( IX ) )
   10    CONTINUE
         IX = IX + INCX
   20 CONTINUE
      RETURN
!
!     CODE FOR INCREMENT EQUAL TO 1
!
   30 CONTINUE
      SMAX = CABS1( CX( 1 ) )
      DO 40 I = 2, N
         IF( CABS1( CX( I ) ).LE.SMAX )                                 &
     &      GO TO 40
         ICMAX1 = I
         SMAX = CABS1( CX( I ) )
   40 CONTINUE
      RETURN
!
!     End of ICMAX1
!
      END
      INTEGER          FUNCTION IEEECK( ISPEC, ZERO, ONE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     June 30, 1998
!
!     .. Scalar Arguments ..
      INTEGER            ISPEC
      REAL               ONE, ZERO
!     ..
!
!  Purpose
!  =======
!
!  IEEECK is called from the ILAENV to verify that Infinity and
!  possibly NaN arithmetic is safe (i.e. will not trap).
!
!  Arguments
!  =========
!
!  ISPEC   (input) INTEGER
!          Specifies whether to test just for inifinity arithmetic
!          or whether to test for infinity and NaN arithmetic.
!          = 0: Verify infinity arithmetic only.
!          = 1: Verify infinity and NaN arithmetic.
!
!  ZERO    (input) REAL
!          Must contain the value 0.0
!          This is passed to prevent the compiler from optimizing
!          away this code.
!
!  ONE     (input) REAL
!          Must contain the value 1.0
!          This is passed to prevent the compiler from optimizing
!          away this code.
!
!  RETURN VALUE:  INTEGER
!          = 0:  Arithmetic failed to produce the correct answers
!          = 1:  Arithmetic produced the correct answers
!
!     .. Local Scalars ..
      REAL               NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,    &
     &                   NEGZRO, NEWZRO, POSINF
!     ..
!     .. Executable Statements ..
      IEEECK = 1
!
      POSINF = ONE / ZERO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGINF = -ONE / ZERO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGZRO = ONE / ( NEGINF+ONE )
      IF( NEGZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGINF = ONE / NEGZRO
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEWZRO = NEGZRO + ZERO
      IF( NEWZRO.NE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      POSINF = ONE / NEWZRO
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      NEGINF = NEGINF*POSINF
      IF( NEGINF.GE.ZERO ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      POSINF = POSINF*POSINF
      IF( POSINF.LE.ONE ) THEN
         IEEECK = 0
         RETURN
      END IF
!
!
!
!
!     Return if we were only asked to check infinity arithmetic
!
      IF( ISPEC.EQ.0 )                                                  &
     &   RETURN
!
      NAN1 = POSINF + NEGINF
!
      NAN2 = POSINF / NEGINF
!
      NAN3 = POSINF / POSINF
!
      NAN4 = POSINF*ZERO
!
      NAN5 = NEGINF*NEGZRO
!
      NAN6 = NAN5*0.0
!
      IF( NAN1.EQ.NAN1 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN2.EQ.NAN2 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN3.EQ.NAN3 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN4.EQ.NAN4 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN5.EQ.NAN5 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      IF( NAN6.EQ.NAN6 ) THEN
         IEEECK = 0
         RETURN
      END IF
!
      RETURN
      END
      REAL             FUNCTION SLAMCH( CMACH )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992 
!
!     .. Scalar Arguments ..
      CHARACTER          CMACH
!     ..
!
!  Purpose
!  =======
!
!  SLAMCH determines single precision machine parameters.
!
!  Arguments
!  =========
!
!  CMACH   (input) CHARACTER*1
!          Specifies the value to be returned by SLAMCH:
!          = 'E' or 'e',   SLAMCH := eps
!          = 'S' or 's ,   SLAMCH := sfmin
!          = 'B' or 'b',   SLAMCH := base
!          = 'P' or 'p',   SLAMCH := eps*base
!          = 'N' or 'n',   SLAMCH := t
!          = 'R' or 'r',   SLAMCH := rnd
!          = 'M' or 'm',   SLAMCH := emin
!          = 'U' or 'u',   SLAMCH := rmin
!          = 'L' or 'l',   SLAMCH := emax
!          = 'O' or 'o',   SLAMCH := rmax
!
!          where
!
!          eps   = relative machine precision
!          sfmin = safe minimum, such that 1/sfmin does not overflow
!          base  = base of the machine
!          prec  = eps*base
!          t     = number of (base) digits in the mantissa
!          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
!          emin  = minimum exponent before (gradual) underflow
!          rmin  = underflow threshold - base**(emin-1)
!          emax  = largest exponent before overflow
!          rmax  = overflow threshold  - (base**emax)*(1-eps)
!
! =====================================================================
!
!     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
!     ..
!     .. Local Scalars ..
      LOGICAL            FIRST, LRND
      INTEGER            BETA, IMAX, IMIN, IT
      REAL               BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,&
     &                   RND, SFMIN, SMALL, T
!     ..
!     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
!     ..
!     .. External Subroutines ..
      EXTERNAL           SLAMC2
!     ..
!     .. Save statement ..
      SAVE               FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,   &
     &                   EMAX, RMAX, PREC
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
         BASE = BETA
         T = IT
         IF( LRND ) THEN
            RND = ONE
            EPS = ( BASE**( 1-IT ) ) / 2
         ELSE
            RND = ZERO
            EPS = BASE**( 1-IT )
         END IF
         PREC = EPS*BASE
         EMIN = IMIN
         EMAX = IMAX
         SFMIN = RMIN
         SMALL = ONE / RMAX
         IF( SMALL.GE.SFMIN ) THEN
!
!           Use SMALL plus a bit, to avoid the possibility of rounding
!           causing overflow when computing  1/sfmin.
!
            SFMIN = SMALL*( ONE+EPS )
         END IF
      END IF
!
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = BASE
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = PREC
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = T
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = EMIN
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = RMIN
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = EMAX
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = RMAX
      END IF
!
      SLAMCH = RMACH
      RETURN
!
!     End of SLAMCH
!
      END
!
!***********************************************************************
!
      SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            IEEE1, RND
      INTEGER            BETA, T
!     ..
!
!  Purpose
!  =======
!
!  SLAMC1 determines the machine parameters given by BETA, T, RND, and
!  IEEE1.
!
!  Arguments
!  =========
!
!  BETA    (output) INTEGER
!          The base of the machine.
!
!  T       (output) INTEGER
!          The number of ( BETA ) digits in the mantissa.
!
!  RND     (output) LOGICAL
!          Specifies whether proper rounding  ( RND = .TRUE. )  or
!          chopping  ( RND = .FALSE. )  occurs in addition. This may not
!          be a reliable guide to the way in which the machine performs
!          its arithmetic.
!
!  IEEE1   (output) LOGICAL
!          Specifies whether rounding appears to be done in the IEEE
!          'round to nearest' style.
!
!  Further Details
!  ===============
!
!  The routine is based on the routine  ENVRON  by Malcolm and
!  incorporates suggestions by Gentleman and Marovich. See
!
!     Malcolm M. A. (1972) Algorithms to reveal properties of
!        floating-point arithmetic. Comms. of the ACM, 15, 949-951.
!
!     Gentleman W. M. and Marovich S. B. (1974) More on algorithms
!        that reveal properties of floating point arithmetic units.
!        Comms. of the ACM, 17, 276-277.
!
! =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            FIRST, LIEEE1, LRND
      INTEGER            LBETA, LT
      REAL               A, B, C, F, ONE, QTR, SAVEC, T1, T2
!     ..
!     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
!     ..
!     .. Save statement ..
      SAVE               FIRST, LIEEE1, LBETA, LRND, LT
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ONE = 1
!
!        LBETA,  LIEEE1,  LT and  LRND  are the  local values  of  BETA,
!        IEEE1, T and RND.
!
!        Throughout this routine  we use the function  SLAMC3  to ensure
!        that relevant values are  stored and not held in registers,  or
!        are not affected by optimizers.
!
!        Compute  a = 2.0**m  with the  smallest positive integer m such
!        that
!
!           fl( a + 1.0 ) = a.
!
         A = 1
         C = 1
!
!+       WHILE( C.EQ.ONE )LOOP
   10    CONTINUE
         IF( C.EQ.ONE ) THEN
            A = 2*A
            C = SLAMC3( A, ONE )
            C = SLAMC3( C, -A )
            GO TO 10
         END IF
!+       END WHILE
!
!        Now compute  b = 2.0**m  with the smallest positive integer m
!        such that
!
!           fl( a + b ) .gt. a.
!
         B = 1
         C = SLAMC3( A, B )
!
!+       WHILE( C.EQ.A )LOOP
   20    CONTINUE
         IF( C.EQ.A ) THEN
            B = 2*B
            C = SLAMC3( A, B )
            GO TO 20
         END IF
!+       END WHILE
!
!        Now compute the base.  a and c  are neighbouring floating point
!        numbers  in the  interval  ( beta**t, beta**( t + 1 ) )  and so
!        their difference is beta. Adding 0.25 to c is to ensure that it
!        is truncated to beta and not ( beta - 1 ).
!
         QTR = ONE / 4
         SAVEC = C
         C = SLAMC3( C, -A )
         LBETA = C + QTR
!
!        Now determine whether rounding or chopping occurs,  by adding a
!        bit  less  than  beta/2  and a  bit  more  than  beta/2  to  a.
!
         B = LBETA
         F = SLAMC3( B / 2, -B / 100 )
         C = SLAMC3( F, A )
         IF( C.EQ.A ) THEN
            LRND = .TRUE.
         ELSE
            LRND = .FALSE.
         END IF
         F = SLAMC3( B / 2, B / 100 )
         C = SLAMC3( F, A )
         IF( ( LRND ) .AND. ( C.EQ.A ) )                                &
     &      LRND = .FALSE.
!
!        Try and decide whether rounding is done in the  IEEE  'round to
!        nearest' style. B/2 is half a unit in the last place of the two
!        numbers A and SAVEC. Furthermore, A is even, i.e. has last  bit
!        zero, and SAVEC is odd. Thus adding B/2 to A should not  change
!        A, but adding B/2 to SAVEC should change SAVEC.
!
         T1 = SLAMC3( B / 2, A )
         T2 = SLAMC3( B / 2, SAVEC )
         LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
!
!        Now find  the  mantissa, t.  It should  be the  integer part of
!        log to the base beta of a,  however it is safer to determine  t
!        by powering.  So we find t as the smallest positive integer for
!        which
!
!           fl( beta**t + 1.0 ) = 1.0.
!
         LT = 0
         A = 1
         C = 1
!
!+       WHILE( C.EQ.ONE )LOOP
   30    CONTINUE
         IF( C.EQ.ONE ) THEN
            LT = LT + 1
            A = A*LBETA
            C = SLAMC3( A, ONE )
            C = SLAMC3( C, -A )
            GO TO 30
         END IF
!+       END WHILE
!
      END IF
!
      BETA = LBETA
      T = LT
      RND = LRND
      IEEE1 = LIEEE1
      RETURN
!
!     End of SLAMC1
!
      END
!
!***********************************************************************
!
      SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            RND
      INTEGER            BETA, EMAX, EMIN, T
      REAL               EPS, RMAX, RMIN
!     ..
!
!  Purpose
!  =======
!
!  SLAMC2 determines the machine parameters specified in its argument
!  list.
!
!  Arguments
!  =========
!
!  BETA    (output) INTEGER
!          The base of the machine.
!
!  T       (output) INTEGER
!          The number of ( BETA ) digits in the mantissa.
!
!  RND     (output) LOGICAL
!          Specifies whether proper rounding  ( RND = .TRUE. )  or
!          chopping  ( RND = .FALSE. )  occurs in addition. This may not
!          be a reliable guide to the way in which the machine performs
!          its arithmetic.
!
!  EPS     (output) REAL
!          The smallest positive number such that
!
!             fl( 1.0 - EPS ) .LT. 1.0,
!
!          where fl denotes the computed value.
!
!  EMIN    (output) INTEGER
!          The minimum exponent before (gradual) underflow occurs.
!
!  RMIN    (output) REAL
!          The smallest normalized number for the machine, given by
!          BASE**( EMIN - 1 ), where  BASE  is the floating point value
!          of BETA.
!
!  EMAX    (output) INTEGER
!          The maximum exponent before overflow occurs.
!
!  RMAX    (output) REAL
!          The largest positive number for the machine, given by
!          BASE**EMAX * ( 1 - EPS ), where  BASE  is the floating point
!          value of BETA.
!
!  Further Details
!  ===============
!
!  The computation of  EPS  is based on a routine PARANOIA by
!  W. Kahan of the University of California at Berkeley.
!
! =====================================================================
!
!     .. Local Scalars ..
      LOGICAL            FIRST, IEEE, IWARN, LIEEE1, LRND
      INTEGER            GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,      &
     &                   NGNMIN, NGPMIN
      REAL               A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, &
     &                   SIXTH, SMALL, THIRD, TWO, ZERO
!     ..
!     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
!     ..
!     .. External Subroutines ..
      EXTERNAL           SLAMC1, SLAMC4, SLAMC5
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN
!     ..
!     .. Save statement ..
      SAVE               FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,&
     &                   LRMIN, LT
!     ..
!     .. Data statements ..
      DATA               FIRST / .TRUE. / , IWARN / .FALSE. /
!     ..
!     .. Executable Statements ..
!
      IF( FIRST ) THEN
         FIRST = .FALSE.
         ZERO = 0
         ONE = 1
         TWO = 2
!
!        LBETA, LT, LRND, LEPS, LEMIN and LRMIN  are the local values of
!        BETA, T, RND, EPS, EMIN and RMIN.
!
!        Throughout this routine  we use the function  SLAMC3  to ensure
!        that relevant values are stored  and not held in registers,  or
!        are not affected by optimizers.
!
!        SLAMC1 returns the parameters  LBETA, LT, LRND and LIEEE1.
!
         CALL SLAMC1( LBETA, LT, LRND, LIEEE1 )
!
!        Start to find EPS.
!
         B = LBETA
         A = B**( -LT )
         LEPS = A
!
!        Try some tricks to see whether or not this is the correct  EPS.
!
         B = TWO / 3
         HALF = ONE / 2
         SIXTH = SLAMC3( B, -HALF )
         THIRD = SLAMC3( SIXTH, SIXTH )
         B = SLAMC3( THIRD, -HALF )
         B = SLAMC3( B, SIXTH )
         B = ABS( B )
         IF( B.LT.LEPS )                                                &
     &      B = LEPS
!
         LEPS = 1
!
!+       WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
   10    CONTINUE
         IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
            LEPS = B
            C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
            C = SLAMC3( HALF, -C )
            B = SLAMC3( HALF, C )
            C = SLAMC3( HALF, -B )
            B = SLAMC3( HALF, C )
            GO TO 10
         END IF
!+       END WHILE
!
         IF( A.LT.LEPS )                                                &
     &      LEPS = A
!
!        Computation of EPS complete.
!
!        Now find  EMIN.  Let A = + or - 1, and + or - (1 + BASE**(-3)).
!        Keep dividing  A by BETA until (gradual) underflow occurs. This
!        is detected when we cannot recover the previous A.
!
         RBASE = ONE / LBETA
         SMALL = ONE
         DO 20 I = 1, 3
            SMALL = SLAMC3( SMALL*RBASE, ZERO )
   20    CONTINUE
         A = SLAMC3( ONE, SMALL )
         CALL SLAMC4( NGPMIN, ONE, LBETA )
         CALL SLAMC4( NGNMIN, -ONE, LBETA )
         CALL SLAMC4( GPMIN, A, LBETA )
         CALL SLAMC4( GNMIN, -A, LBETA )
         IEEE = .FALSE.
!
         IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
            IF( NGPMIN.EQ.GPMIN ) THEN
               LEMIN = NGPMIN
!            ( Non twos-complement machines, no gradual underflow;
!              e.g.,  VAX )
            ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
               LEMIN = NGPMIN - 1 + LT
               IEEE = .TRUE.
!            ( Non twos-complement machines, with gradual underflow;
!              e.g., IEEE standard followers )
            ELSE
               LEMIN = MIN( NGPMIN, GPMIN )
!            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
!
         ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
            IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN )
!            ( Twos-complement machines, no gradual underflow;
!              e.g., CYBER 205 )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
!            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
!
         ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.                   &
     &            ( GPMIN.EQ.GNMIN ) ) THEN
            IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
               LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
!            ( Twos-complement machines with gradual underflow;
!              no known machine )
            ELSE
               LEMIN = MIN( NGPMIN, NGNMIN )
!            ( A guess; no known machine )
               IWARN = .TRUE.
            END IF
!
         ELSE
            LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
!         ( A guess; no known machine )
            IWARN = .TRUE.
         END IF
!**
! Comment out this if block if EMIN is ok
         IF( IWARN ) THEN
            FIRST = .TRUE.
            WRITE( 6, FMT = 9999 )LEMIN
         END IF
!**
!
!        Assume IEEE arithmetic if we found denormalised  numbers above,
!        or if arithmetic seems to round in the  IEEE style,  determined
!        in routine SLAMC1. A true IEEE machine should have both  things
!        true; however, faulty machines may have one or the other.
!
         IEEE = IEEE .OR. LIEEE1
!
!        Compute  RMIN by successive division by  BETA. We could compute
!        RMIN as BASE**( EMIN - 1 ),  but some machines underflow during
!        this computation.
!
         LRMIN = 1
         DO 30 I = 1, 1 - LEMIN
            LRMIN = SLAMC3( LRMIN*RBASE, ZERO )
   30    CONTINUE
!
!        Finally, call SLAMC5 to compute EMAX and RMAX.
!
         CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
      END IF
!
      BETA = LBETA
      T = LT
      RND = LRND
      EPS = LEPS
      EMIN = LEMIN
      RMIN = LRMIN
      EMAX = LEMAX
      RMAX = LRMAX
!
      RETURN
!
 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',        &
     &      '  EMIN = ', I8, /                                          &
     &      ' If, after inspection, the value EMIN looks',              &
     &      ' acceptable please comment out ',                          &
     &      / ' the IF block as marked within the code of routine',     &
     &      ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / )
!
!     End of SLAMC2
!
      END
!
!***********************************************************************
!
      REAL             FUNCTION SLAMC3( A, B )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      REAL               A, B
!     ..
!
!  Purpose
!  =======
!
!  SLAMC3  is intended to force  A  and  B  to be stored prior to doing
!  the addition of  A  and  B ,  for use in situations where optimizers
!  might hold one of these in a register.
!
!  Arguments
!  =========
!
!  A, B    (input) REAL
!          The values A and B.
!
! =====================================================================
!
!     .. Executable Statements ..
!
      SLAMC3 = A + B
!
      RETURN
!
!     End of SLAMC3
!
      END
!
!***********************************************************************
!
      SUBROUTINE SLAMC4( EMIN, START, BASE )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      INTEGER            BASE, EMIN
      REAL               START
!     ..
!
!  Purpose
!  =======
!
!  SLAMC4 is a service routine for SLAMC2.
!
!  Arguments
!  =========
!
!  EMIN    (output) EMIN
!          The minimum exponent before (gradual) underflow, computed by
!          setting A = START and dividing by BASE until the previous A
!          can not be recovered.
!
!  START   (input) REAL
!          The starting point for determining EMIN.
!
!  BASE    (input) INTEGER
!          The base of the machine.
!
! =====================================================================
!
!     .. Local Scalars ..
      INTEGER            I
      REAL               A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
!     ..
!     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
!     ..
!     .. Executable Statements ..
!
      A = START
      ONE = 1
      RBASE = ONE / BASE
      ZERO = 0
      EMIN = 1
      B1 = SLAMC3( A*RBASE, ZERO )
      C1 = A
      C2 = A
      D1 = A
      D2 = A
!+    WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
!    $       ( D1.EQ.A ).AND.( D2.EQ.A )      )LOOP
   10 CONTINUE
      IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.         &
     &    ( D2.EQ.A ) ) THEN
         EMIN = EMIN - 1
         A = B1
         B1 = SLAMC3( A / BASE, ZERO )
         C1 = SLAMC3( B1*BASE, ZERO )
         D1 = ZERO
         DO 20 I = 1, BASE
            D1 = D1 + B1
   20    CONTINUE
         B2 = SLAMC3( A*RBASE, ZERO )
         C2 = SLAMC3( B2 / RBASE, ZERO )
         D2 = ZERO
         DO 30 I = 1, BASE
            D2 = D2 + B2
   30    CONTINUE
         GO TO 10
      END IF
!+    END WHILE
!
      RETURN
!
!     End of SLAMC4
!
      END
!
!***********************************************************************
!
      SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
!
!  -- LAPACK auxiliary routine (version 3.0) --
!     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
!     Courant Institute, Argonne National Lab, and Rice University
!     October 31, 1992
!
!     .. Scalar Arguments ..
      LOGICAL            IEEE
      INTEGER            BETA, EMAX, EMIN, P
      REAL               RMAX
!     ..
!
!  Purpose
!  =======
!
!  SLAMC5 attempts to compute RMAX, the largest machine floating-point
!  number, without overflow.  It assumes that EMAX + abs(EMIN) sum
!  approximately to a power of 2.  It will fail on machines where this
!  assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
!  EMAX = 28718).  It will also fail if the value supplied for EMIN is
!  too large (i.e. too close to zero), probably with overflow.
!
!  Arguments
!  =========
!
!  BETA    (input) INTEGER
!          The base of floating-point arithmetic.
!
!  P       (input) INTEGER
!          The number of base BETA digits in the mantissa of a
!          floating-point value.
!
!  EMIN    (input) INTEGER
!          The minimum exponent before (gradual) underflow.
!
!  IEEE    (input) LOGICAL
!          A logical flag specifying whether or not the arithmetic
!          system is thought to comply with the IEEE standard.
!
!  EMAX    (output) INTEGER
!          The largest exponent before overflow
!
!  RMAX    (output) REAL
!          The largest machine floating-point number.
!
! =====================================================================
!
!     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
!     ..
!     .. Local Scalars ..
      INTEGER            EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
      REAL               OLDY, RECBAS, Y, Z
!     ..
!     .. External Functions ..
      REAL               SLAMC3
      EXTERNAL           SLAMC3
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC          MOD
!     ..
!     .. Executable Statements ..
!
!     First compute LEXP and UEXP, two powers of 2 that bound
!     abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
!     approximately to the bound that is closest to abs(EMIN).
!     (EMAX is the exponent of the required number RMAX).
!
      LEXP = 1
      EXBITS = 1
   10 CONTINUE
      TRY = LEXP*2
      IF( TRY.LE.( -EMIN ) ) THEN
         LEXP = TRY
         EXBITS = EXBITS + 1
         GO TO 10
      END IF
      IF( LEXP.EQ.-EMIN ) THEN
         UEXP = LEXP
      ELSE
         UEXP = TRY
         EXBITS = EXBITS + 1
      END IF
!
!     Now -LEXP is less than or equal to EMIN, and -UEXP is greater
!     than or equal to EMIN. EXBITS is the number of bits needed to
!     store the exponent.
!
      IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
         EXPSUM = 2*LEXP
      ELSE
         EXPSUM = 2*UEXP
      END IF
!
!     EXPSUM is the exponent range, approximately equal to
!     EMAX - EMIN + 1 .
!
      EMAX = EXPSUM + EMIN - 1
      NBITS = 1 + EXBITS + P
!
!     NBITS is the total number of bits needed to store a
!     floating-point number.
!
      IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
!
!        Either there are an odd number of bits used to store a
!        floating-point number, which is unlikely, or some bits are
!        not used in the representation of numbers, which is possible,
!        (e.g. Cray machines) or the mantissa has an implicit bit,
!        (e.g. IEEE machines, Dec Vax machines), which is perhaps the
!        most likely. We have to assume the last alternative.
!        If this is true, then we need to reduce EMAX by one because
!        there must be some way of representing zero in an implicit-bit
!        system. On machines like Cray, we are reducing EMAX by one
!        unnecessarily.
!
         EMAX = EMAX - 1
      END IF
!
      IF( IEEE ) THEN
!
!        Assume we are on an IEEE machine which reserves one exponent
!        for infinity and NaN.
!
         EMAX = EMAX - 1
      END IF
!
!     Now create RMAX, the largest machine number, which should
!     be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
!
!     First compute 1.0 - BETA**(-P), being careful that the
!     result is less than 1.0 .
!
      RECBAS = ONE / BETA
      Z = BETA - ONE
      Y = ZERO
      DO 20 I = 1, P
         Z = Z*RECBAS
         IF( Y.LT.ONE )                                                 &
     &      OLDY = Y
         Y = SLAMC3( Y, Z )
   20 CONTINUE
      IF( Y.GE.ONE )                                                    &
     &   Y = OLDY
!
!     Now multiply by BETA**EMAX to get RMAX.
!
      DO 30 I = 1, EMAX
         Y = SLAMC3( Y*BETA, ZERO )
   30 CONTINUE
!
      RMAX = Y
      RETURN
!
!     End of SLAMC5
!
      END


! eta (the Ewald parameter) is declared in m_workstrfacs.
! In kprep / kpreppot, an optional user input streta is copied to eta
! Then, at the beginning of the module, strinit sets a value for eta (if no user input) and calls straa, which uses eta to calculate E and k independent parts of the Ewald sum.
! Also strcc, which contains energy-dependent data and is called once for each energy point by fmskspace, depends on eta because it uses the results of straa (eta does not
! occur explicitly in strcc).
! Finally, for each energy point and k-point in the FMS algorithm, structurefactor calls strset which calls strbbdd, which again uses eta to calculate the whole Ewald sum for a
! given E and k.

! So, in order to "change eta" for a calculation, one only needs to call strinit again.  Below is essentially a stripped-down version of kprep:

subroutine change_eta(e)

        use struct,lat=>alat
        use workstrfacs2,only: eta
        use boundaries,only: nmuemax,nkmpmax,nkmax		
		implicit none
		
real*8 :: eta_new
  complex*16,intent(in) :: e

  ! LOCALS
  ! For structure factors :
  integer i
  integer,allocatable :: LTAB(:),KAPTAB(:),NMUETAB(:)
  real*8 ALAT,FACT(0:100),etop,gmulti,rmulti  !gmulti,rmulti are dangerous: if anyone ever changes them in kprep/kpreppot, there'll be trouble ...
  real*8,allocatable :: CGC(:,:)
character*512 slog

real*8,parameter :: eta_increase_factor = 1.4d0  ! Changing this from 1.3 to 1.5 didn't matter for SnO2 Sn M4 edge FSR
real*8,parameter :: eta_max = 3.0d0


eta_new = eta * eta_increase_factor
write(slog,'(a,f7.3,a,f7.3,a,f8.4,a)') 'Changing Ewald parameter eta from ',eta,' to ',eta_new,' at energy ',dble(e),'.'
eta=eta_new
call wlog(slog)
if (eta .gt. eta_max) then
   write(slog,*) 'This is larger than the hardwired maximum of ',eta_max,' .  Please make sure there is nothing wrong in your calculation.  Quitting now.'
   call wlog(slog)
   stop
endif


   !#######################################################################
  !       FIRST:    INITIALIZE DIMENSIONS 
  !#######################################################################


  !* STRUCTURE
  ALAT = lat(1)
  !  Next variables allow to expand the clusters used for the calculation of the structure constants
  !  in real (rmulti) and reciprocal (gmulti) space.
  rmulti = dble(1)
  gmulti = dble(1)

  ! allocate some locals
  allocate(LTAB(NMUEMAX),KAPTAB(NMUEMAX),NMUETAB(NMUEMAX),CGC(NKMPMAX,2) )

  FACT(0) = 1.0D0
  DO I=1,100
     FACT(I) = FACT(I-1) * DBLE(I)
  END DO

  !   ********************************************************************
  !   *                                                                  *
  !   *   rel. quantum numbers    up to                                  *
  !   *                                                                  *
  !   ********************************************************************
  !                     s   p   p   d   d   f   f   g   g   h
  !     DATA LTAB    /  0,  1,  1,  2,  2,  3,  3,  4,  4,  5 /
  !     DATA LBTAB   /  1,  0,  2,  1,  3,  2,  4,  3,  5,  4 /
  !     DATA KAPTAB  / -1,  1, -2,  2, -3,  3, -4,  4, -5,  5 /
  !     DATA NMUETAB /  2,  2,  4,  4,  6,  6,  8,  8, 10, 10 /

  DO I = 1,NMUEMAX
     LTAB(I) = I/2
     IF( 2*LTAB(I) .EQ. I ) THEN
        KAPTAB(I) = LTAB(I)
     ELSE
        KAPTAB(I) = - LTAB(I) - 1
     END IF
     NMUETAB(I) = 2*ABS( KAPTAB(I) )
  END DO

  ! calculate some gaunt symbols before ltab and nmuetab get overwritten for non-sprel calcul.
  CALL CALCCGC( LTAB,KAPTAB,NMUETAB,CGC,NKMAX,NMUEMAX,NKMPMAX )

           !sssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssss
           !                         structure constants
           !sssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssssss

! ETOP influences eta,gmax,rmax in strinit if those values are very small.
! However, since they have already been set before (from kprep/kpreppot), those instructions will not be executed.
! Therefore, at this point ETOP doesn't matter.
ETOP=dble(0)

 CALL STRINIT(ETOP,nats,ALAT,FACT,CGC,gmulti,rmulti ) !KJ eliminating arguments that I think are unnecessary
!CALL STRINIT( ETA,RMAX,GMAX,ETOP,BRX,BRY,BRZ,R1,R2,R3,NRDLTAB,QX,QY,QZ,BGX,BGY,BGZ,G1,G2,G3,NGRLTAB,nats,ALAT,FACT,CGC,gmulti,rmulti )


! kill some locals
deallocate(LTAB,KAPTAB,NMUETAB,CGC)


return
end
	  
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: straa.f90,v $:
! $Revision: 1.9 $
! $Author: jorissen $
! $Date: 2012/02/04 00:38:51 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*==straa.f    processed by SPAG 6.05Rc at 17:21 on 20 Mar 2002
      SUBROUTINE STRAA(NQ,FACT,IG123)
!      SUBROUTINE STRAA(IPRINT,RMAX,NRTAB,SMAX,NQ,NMAX,NQQP,LLMAX,ETA,   &
!     &                 ALPHA0,BRX,BRY,BRZ,BGX,BGY,BGZ,QQPX,QQPY,QQPZ,   &
!     &                 EXPGNQ,QQMLRS,G1,G2,G3,G123MAX,R1,R2,R3,R123MAX, &
!     &                 INDR,T,HP,QJLTAB,CQMLTAB,GGJLRS,FACT,IG123,      &
!     &                 LGNT12,LGNT123,NQMAX,NLMAX,NGRLMAX,NRDLMAX,      &
!     &                 NRDLMAX0,J22MAX,NMARR,NQQPMAX,LLARR,NLLMMMAX)
!   ********************************************************************
!   *                                                                  *
!   *  CALCULATE ALL QUANTITIES INDEPENDENT OF  ENERGY  AND  K         *
!   *                THIS ROUTINE IS CALLED ONLY ONCE                  *
!   *                                                                  *
!   ********************************************************************
!
      use boundaries
	  use controls,only: IPRINT
	  use workstrfacs,m_nl=>nl  !The "NL" below is a local variable, I think
	  use workstrfacs2
      implicit none
 
! PARAMETER definitions
      REAL*8 PI
      PARAMETER (PI=3.141592653589793238462643D0)
      COMPLEX*16 CI
      PARAMETER (CI=(0.0D0,1.0D0))
 
 ! Dummy arguments
      !REAL*8 ALPHA0,ETA,RMAX
      INTEGER NQ,IG123 !,J22MAX,IPRINT,LGNT12,LGNT123,LLARR,   &
     !&        NGRLMAX,NLLMMMAX,NLMAX,NMARR,NQMAX,NQQPMAX,  &
     !&        NRDLMAX,NRDLMAX0,LLMAX,NMAX,NQQP,NRTAB,G123MAX,R123MAX	
      REAL*8 FACT(0:100) !,BGX(3),BGY(3),BGZ(3),BRX(3),BRY(3),BRZ(3),                 &
!     &       CQMLTAB(-LLARR:LLARR,0:LLARR),                 &
!     &       GGJLRS(0:J22MAX,0:LLARR,NRDLMAX,NQQPMAX),HP(NLLMMMAX),     &
!     &       QJLTAB(0:LLARR,0:LLARR),QQPX(NQQPMAX),QQPY(NQQPMAX),       &
!     &       QQPZ(NQQPMAX),T(0:LLARR,0:LLARR)
 !     COMPLEX*16 EXPGNQ(NGRLMAX,NQQPMAX),                               &
 !    &           QQMLRS(NLLMMMAX,NRDLMAX,NQQPMAX)
 !     INTEGER G1(NGRLMAX),G2(NGRLMAX),G3(NGRLMAX),INDR(NRDLMAX,NQQPMAX),&
 !    &        R1(NRDLMAX0),R2(NRDLMAX0),R3(NRDLMAX0) !,SMAX(NQQPMAX)

! Local variables
      REAL*8 ATVOL,D1TERM1,F,FAKTOR,GX,GY,GZ,Q1,Q2,Q3,RS,RSQUAD,RX,RY,RZ,WZ05
      DOUBLE PRECISION DSQRT
      INTEGER I,I1,IQQP,J,J22,JJ,LL,MM,MMLL,N,NL,S,SMAXMAX,SMAXMIN
      REAL*8 RX0,RY0,RZ0
      REAL*8,EXTERNAL :: STRCONFRA,STRFUNQJL


	INDR(:,:) = 0

!
! ----------------------------------------------------------------------
! pre factors for the  spherical harmonics
! used in   <STRAA> + <STRHARPOL>
!
      WZ05 = SQRT(1.0D0/2.0D0)
      DO LL = 0,LLMAX
         DO JJ = 0,LL
!                                                       REAL
            QJLTAB(JJ,LL) = STRFUNQJL(FACT,JJ,LL)
!                                                       COMPLEX
            CQMLTAB(-JJ,LL) = STRFUNQJL(FACT,JJ,LL)*WZ05
            CQMLTAB(+JJ,LL) = STRFUNQJL(FACT,JJ,LL)*WZ05*(-1.0D0)**JJ
            IF ( JJ.EQ.0 ) CQMLTAB(0,LL) = STRFUNQJL(FACT,0,LL)
         END DO
      END DO
!
! ----------------------------------------------------------------------
! calculation of the argument-independent terms of the
! harmonic polynomials     used in   <STRHARPOL>
!
!     T(L,J)
      T(0,0) = 1.0D0
      T(1,1) = 1.0D0
!
      DO LL = 1,LLMAX
         T(LL,LL) = T(LL-1,LL-1)*(2.0D0*LL-1.0D0)
      END DO
!     T(LL,LL) = (2*LL-1)!!
!
      HP(1) = QJLTAB(0,0)*T(0,0)
!
!
!  =====================================================================
!                      ********
!                      * DLM1 *
!                      ********
!
      RX = BRY(2)*BRZ(3) - BRZ(2)*BRY(3)
      RY = BRZ(2)*BRX(3) - BRX(2)*BRZ(3)
      RZ = BRX(2)*BRY(3) - BRY(2)*BRX(3)
!
      ATVOL = ABS(BRX(1)*RX+BRY(1)*RY+BRZ(1)*RZ)*(2*PI)**3
!
      D1TERM1 = -4.0D0*PI/ATVOL
!
      G123MAX = 0
      DO N = 1,NMAX
         G123MAX = MAX(G123MAX,ABS(G1(N)),ABS(G2(N)),ABS(G3(N)))
         IF ( G123MAX.GT.NMARR ) THEN
            WRITE (6,99001) G123MAX,NMARR
            STOP
         END IF
!
         GX = G1(N)*BGX(1) + G2(N)*BGX(2) + G3(N)*BGX(3)
         GY = G1(N)*BGY(1) + G2(N)*BGY(2) + G3(N)*BGY(3)
         GZ = G1(N)*BGZ(1) + G2(N)*BGZ(2) + G3(N)*BGZ(3)
!
         F = D1TERM1*EXP(-(GX**2+GY**2+GZ**2)/ETA)
!
         DO IQQP = 1,NQQP
            EXPGNQ(N,IQQP) = F*CDEXP(CI*2*PI*(GX*QQPX(IQQP)+GY*QQPY(IQQP)+GZ*QQPZ(IQQP)))
         END DO
      END DO
!
!  =====================================================================
!                      ********
!                      * DLM2 *
!                      ********
!
      Q1 = -SQRT(ETA/PI)*0.5D0
!
      R123MAX = 0
!
      DO IQQP = 1,NQQP
!
! ---> suppress contribution for ->R=0 and IQQP=1 (IQ=IQP)
!      using the fact that the ->R's have been ordered
         IF ( IQQP.EQ.1 ) THEN
!KJ            SMAX(iqqp) = SMAX(iqqp) - 1   !now doing this in strvecgen so it doesn't get executed every time eta changes 2-2012
            I1 = 2
         ELSE
            I1 = 1
         END IF
         S = 0
!
         DO I = I1,NRTAB

            RX0 = R1(I)*BRX(1) + R2(I)*BRX(2) + R3(I)*BRX(3)  - QQPX(IQQP)
            RY0 = R1(I)*BRY(1) + R2(I)*BRY(2) + R3(I)*BRY(3)  - QQPY(IQQP)
            RZ0 = R1(I)*BRZ(1) + R2(I)*BRZ(2) + R3(I)*BRZ(3)  - QQPZ(IQQP)
            RX = 2*PI*RX0
            RY = 2*PI*RY0
            RZ = 2*PI*RZ0
            RSQUAD = RX**2 + RY**2 + RZ**2
            RS = DSQRT(RX0**2+RY0**2+RZ0**2)

            IF ( RS.LE.RMAX ) THEN
!  ---------------------------------------------------------------------
!                         ->R    ACCEPTED
!  ---------------------------------------------------------------------
               R123MAX = MAX(R123MAX,ABS(R1(I)),ABS(R2(I)),ABS(R3(I)))
               IF ( R123MAX.GT.NMARR ) THEN
                  WRITE (6,99002) R123MAX,NMARR
                  STOP
               END IF
               S = S + 1
               INDR(S,IQQP) = I
               CALL STRHARPOL(RX,RY,RZ)
               ! Q2 = (-ETA/2.0D0)**LL
               Q2 = 1.0D0/(-ETA/2.0D0)
               Q3 = EXP(-ETA*RSQUAD/4.0D0)
               MMLL = 0
               DO LL = 0,LLMAX
                  Q2 = Q2*(-ETA/2.0D0)
                  F = Q1*Q2*Q3
                  DO MM = -LL,LL
                     MMLL = MMLL + 1
                     QQMLRS(MMLL,S,IQQP) = F*HP(MMLL)
                  END DO
               END DO
               !  /D (23)/
               DO LL = 0,LLMAX
                  FAKTOR = 1.0D0
                  DO J22 = 0,J22MAX
                     GGJLRS(J22,LL,S,IQQP) = STRCONFRA((LL-J22+0.5D0),(RSQUAD*ETA/4.0D0)) *FAKTOR
                     FAKTOR = FAKTOR/(ETA*(J22+1.0D0))
                  END DO
               END DO
            END IF
         END DO
         IF ( S.NE.SMAX(IQQP) ) THEN
            WRITE (6,*) ' WARNING FROM <STRAA> '
            WRITE (6,*) ' IQQP = ',IQQP
            WRITE (6,*) ' S    = ',S
            WRITE (6,*) ' SMAX = ',SMAX(IQQP)
         END IF
      END DO
!
!  =====================================================================
!                      ********
!                      * DLM3 *
!                      ********
!  /D (8),(13)/
!
      ALPHA0 = SQRT(ETA)/(2.0D0*PI)
!
!  =====================================================================
      IF ( IPRINT.GE.3 ) THEN
         WRITE (6,'(''  LATTICE VECTORS OF THE RECIPROCAL LATTICE'',/)')
         DO N = 1,NMAX
            WRITE (6,99003) N,G1(N),G2(N),G3(N)
         END DO
!
         WRITE (6,'(//,''  LATTICE VECTORS OF THE DIRECT LATTICE '',/)')
         DO S = 1,NRTAB
            WRITE (6,99004) S,R1(S),R2(S),R3(S)
         END DO
!
         WRITE (6,'(//,''  R-INDEX TABLE FOR OFF-DIAG. ELEMENTS  '',/)')
         DO S = 1,NRTAB
            WRITE (6,99005) S,(INDR(S,IQQP),IQQP=1,NQQP)
         END DO
      END IF
!
      SMAXMIN = 1000000
      SMAXMAX = 0
      DO I = 1,NQQP
         SMAXMIN = MIN(SMAX(I),SMAXMIN)
         SMAXMAX = MAX(SMAX(I),SMAXMAX)
      END DO
!
      NL = LLMAX/2 + 1
      if(iprint.gt.0) WRITE (6,99006) NMAX,NGRLMAX,NRTAB,NRDLMAX0,SMAXMAX,NRDLMAX,      &
     &                SMAXMIN,NRDLMAX,NL,NLMAX,NQ,NQMAX,NQQP,NQQPMAX,   &
     &                R123MAX,NMARR,G123MAX,NMARR,J22MAX,J22MAX,        &
     &                (NL**2*(NL**2+1)/2),LGNT12,IG123,LGNT123,ETA
 
	 RETURN
!  =====================================================================
99001 FORMAT ('  STOP IN <STRAA> ',/,'G123MAX=',I3,' > NMARR=',I3)
99002 FORMAT ('  STOP IN <STRAA> ',/,'R123MAX=',I3,' > NMARR=',I3)
99003 FORMAT ('  ->GN(',I3,')=  (',I3,',',I3,',',I3,')')
99004 FORMAT ('  ->RS(',I3,') =  (',I3,',',I3,',',I3,')')
99005 FORMAT ('  INDR(',I3,'):',30I4)
99006 FORMAT (/,1X,79('*'),/,12X,                                       &
     &        'array sizes for calculation of structure constants',/,1X,&
     &        79('*'),/,10X,32X,'used',14X,'available',/,10X,           &
     &        'G-vectors table       NMAX   ',I7,8X,'NGRLMAX ',I7,/,10X,&
     &        'R-vectors table       NRTAB  ',I7,8X,'NRDLMAX0',I7,/,10X,&
     &        'R-vectors (max.)      SMAX   ',I7,8X,'NRDLMAX ',I7,/,10X,&
     &        'R-vectors (min.)      SMAX   ',I7,8X,'NRDLMAX ',I7,/,10X,&
     &        'l-max + 1             NL     ',I7,8X,'NLMAX   ',I7,/,10X,&
     &        'sites                 NQ     ',I7,8X,'NQMAX   ',I7,/,10X,&
     &        'q-q''-blocks           NQQP  ',I8,8X,'NQQPMAX ',I7,/,10X,&
     &        'auxiliary array        R123MAX',I7,8X,'NMARR   ',I7,/,10X,&
     &        'auxiliary array        G123MAX',I7,8X,'NMARR   ',I7,/,10X,&
     &        'Davis eq. (22)        J22MAX ',I7,8X,'J22MAX  ',I7,/,10X,&
     &        'Gaunts                IGNT12 ',I7,8X,'LGNT12  ',I7,/,10X,&
     &        'Gaunts                IGNT123',I7,8X,'LGNT123 ',I7,/,10X,&
     &        'Ewald parameter       ETA    ',F7.2,/,1X,79('*'),/)
!    &     10X,'lattice sum  evaluated by continued fractions',/,
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: strgaunt.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE STRGAUNT(LMAX,ALAT,FACT,GNT,NGNT,IGNT,CIPWL,NLMAX,     &
     &                      IG123,LGNT12,LGNT123)
!
!   ********************************************************************
!   *                                                                  *
!   *    CALCULATION OF GAUNT COEFFICIENTS                             *
!   *                                                                  *
!   *    G(L1,M1;L2,M2;L3,M3) == INT Y(L1,M1) * Y(L2,M2) * Y(L3,M3)    *
!   *                                                                  *
!   *    CPLXYLM = FALSE : REAL SPHERICAL HARMONICS                    *
!   *              TRUE  : COMPLEX SPHERICAL HARMONICS                 *
!   *                      THE COMPLEX CONJUGATE OF Y(L1,M1) IS        *
!   *                      TAKEN                                       *
!   *    SEE EDMONDS EQS. (4.6.3), (3.7.3) AND (3.6.11)                *
!   *                                                                  *
!   *                                                                  *
!   *    TO SET UP THE GLL' - MATRIX FROM THE DLM'S THE GAUNTS ARE     *
!   *    MULTIPLIED BY THE FACTOR 4*PI                                 *
!   *    THE ADDITIONAL FACTOR 2*PI/A CONVERTS THE GLL' - MATRIX       *
!   *    FROM D.U.'S TO A.U.'S                                         *
!   *                                                                  *
!   *    THE GAUNTS ARE CALCULATED ONLY FOR  FOR LM2 <= LM1            *
!   *    FOR THE LOOP LM1=1,LM1MAX / LM2=1,LM1 / LM3=1,LM3MAX          *
!   *    NGNT     SPECIFIES THE NUMBER OF NON-ZERO GNT'S               *
!   *             FOR THE CURRENT LINEAR INDEX I == (LM1,LM2)          *
!   *    IGNT(I)  GIVES THE  LM3  FOR THE I-TH NON-ZERO GNT            *
!   *             THE ARRAYLENGTH  LGNT123  HAS TO BE CHOSEN           *
!   *             ACCORDINGLY   --  see below                          *
!   *                                                                  *
!   ********************************************************************
!
      use controls,only:cplxylm
      IMPLICIT NONE

!
! PARAMETER definitions
!
      REAL*8 PI
      PARAMETER ( PI=3.141592653589793238462643D0 )
      COMPLEX*16 CI
      PARAMETER (CI=(0.0D0,1.0D0))
!
! Dummy arguments
!
      REAL*8 ALAT
      INTEGER LGNT12,LGNT123,LMAX,NLMAX
      COMPLEX*16 CIPWL((2*NLMAX)**2)
      REAL*8 FACT(0:100),GNT(LGNT123)
      INTEGER IGNT(LGNT123),NGNT(LGNT12)
!
! Local variables
!
      COMPLEX*16 CC1,CC2,CC3
      REAL*8 CGAUNT,PRE,RGAUNT,WZ05,XL1,XL2,XL3,XM1,XM2,XM3
      REAL*8 CGCRAC
      INTEGER I,I1,I2,I3,IG123,J1,L,L1,L2,L3,LM,LM1,LM1LM2,LM2,M,M1,M2, &
     &        M3,MM1
      INTEGER NINT

      EXTERNAL CGCRAC


      gnt=dble(0)


      FACT(0) = dble(1)
      DO I = 1,100
         FACT(I) = FACT(I-1)*I
      END DO
!
      LM = 0
      DO L = 0,2*LMAX
         DO M = -L,L
            LM = LM + 1
            CIPWL(LM) = CI**L
         END DO
      END DO
!
      WZ05 = SQRT(0.5D0)
      PRE = 4*PI*2*PI/ALAT
      LM1LM2 = 0
      IG123 = 0


!
      IF ( CPLXYLM ) THEN
!
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!
         DO L1 = 0,LMAX
            DO MM1 = -L1,L1
               M1 = -MM1
               XL1 = L1
               XM1 = M1
               J1 = ABS(M1)
               LM1 = L1*(L1+1) + M1 + 1
!
               DO L2 = 0,LMAX
                  DO M2 = -L2,L2
                     XL2 = L2
                     XM2 = M2
                     LM2 = L2*(L2+1) + M2 + 1
!
!
!---> STORE ONLY GAUNT COEFFIENTS FOR  LM2 <= LM1
!
!        IF( LM2.GT.LM1) GOTO 20
                     LM1LM2 = LM1LM2 + 1
                     NGNT(LM1LM2) = 0
!
                     DO L3 = ABS(L1-L2),(L1+L2)
                        DO M3 = -L3,L3
                           XL3 = L3
                           XM3 = M3

!
                           IF ( (M1+M2+M3).EQ.0 ) THEN
!
                              CGAUNT = SQRT((2*XL1+1)*(2*XL2+1)         &
     &                                 /(4*PI*(2*XL3+1)))*(-1)**(-M3)   &
     &                                 *CGCRAC(FACT,XL1,XL2,XL3,0.0D0,  &
     &                                 0.0D0,0.0D0)                     &
     &                                 *CGCRAC(FACT,XL1,XL2,XL3,XM1,XM2,&
     &                                 -XM3)
!
                              IF ( ABS(CGAUNT).GT.1.0D-8 ) THEN
                                 IG123 = IG123 + 1
                                 IF ( IG123.GT.LGNT123 ) THEN
                                    WRITE (6,*) '   STOP IN <STRGAUNT> '
                                    WRITE (6,*) '   LGNT123 =',LGNT123, &
     &                                 '  TOO SMALL'
                                    WRITE (6,*)                         &
     &                                  '   INCREASE ARRAY - LENGTH  '
                                    WRITE (6,*)                         &
     &                                  '    100  for  l_max = 2     '
                                    WRITE (6,*)                         &
     &                                  '    400  for  l_max = 3     '
                                    WRITE (6,*)                         &
     &                                  '   1200  for  l_max = 4     '
                                    STOP
                                 END IF
                                 NGNT(LM1LM2) = NGNT(LM1LM2) + 1
                                 GNT(IG123) = PRE*CGAUNT*(-1)**J1
                                 IGNT(IG123) = L3*(L3+1) + M3 + 1
                              END IF
                           END IF
!
                        END DO
                     END DO
                  END DO
               END DO
            END DO
         END DO
!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
!
      ELSE
!
!RRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRR
!
         DO L1 = 0,LMAX
            DO M1 = -L1,L1
               XL1 = L1
               LM1 = L1*(L1+1) + M1 + 1
!
               DO L2 = 0,LMAX
                  DO M2 = -L2,L2
                     XL2 = L2
                     LM2 = L2*(L2+1) + M2 + 1
!
!---> STORE ONLY GAUNT COEFFIENTS FOR  LM2 <= LM1
!
                     IF ( LM2.LE.LM1 ) THEN
                        LM1LM2 = LM1LM2 + 1
                        NGNT(LM1LM2) = 0
!
                        DO L3 = ABS(L1-L2),(L1+L2)
                           DO M3 = -L3,L3
                              XL3 = L3
!
                              RGAUNT = 0.0D0
                              DO I1 = 1,2
                                 IF ( I1.EQ.1 ) THEN
                                    XM1 = -ABS(M1)
                                    IF ( M1.LT.0 ) CC1 = CI*WZ05
                                    IF ( M1.EQ.0 ) CC1 = 1.0D0
                                    IF ( M1.GT.0 ) CC1 = WZ05
                                 ELSE
                                    XM1 = ABS(M1)
                                    IF ( M1.LT.0 ) CC1 = -CI*WZ05*(-1)  &
     &                                 **ABS(M1)
                                    IF ( M1.EQ.0 ) CC1 = 0.0D0
                                    IF ( M1.GT.0 ) CC1 = WZ05*(-1)      &
     &                                 **ABS(M1)
                                 END IF
!
                                 DO I2 = 1,2
                                    IF ( I2.EQ.1 ) THEN
                                       XM2 = -ABS(M2)
                                       IF ( M2.LT.0 ) CC2 = CI*WZ05
                                       IF ( M2.EQ.0 ) CC2 = 1.0D0
                                       IF ( M2.GT.0 ) CC2 = WZ05
                                    ELSE
                                       XM2 = ABS(M2)
                                       IF ( M2.LT.0 )                   &
     &                                    CC2 = -CI*WZ05*(-1)**ABS(M2)
                                       IF ( M2.EQ.0 ) CC2 = 0.0D0
                                       IF ( M2.GT.0 ) CC2 = WZ05*(-1)   &
     &                                    **ABS(M2)
                                    END IF
!
                                    DO I3 = 1,2
                                       IF ( I3.EQ.1 ) THEN
                                         XM3 = -ABS(M3)
                                         IF ( M3.LT.0 ) CC3 = CI*WZ05
                                         IF ( M3.EQ.0 ) CC3 = 1.0D0
                                         IF ( M3.GT.0 ) CC3 = WZ05
                                       ELSE
                                         XM3 = ABS(M3)
                                         IF ( M3.LT.0 )                 &
     &                                      CC3 = -CI*WZ05*(-1)**ABS(M3)
                                         IF ( M3.EQ.0 ) CC3 = 0.0D0
                                         IF ( M3.GT.0 ) CC3 = WZ05*(-1) &
     &                                      **ABS(M3)
                                       END IF
!
                                       IF ( (NINT(XM1)+NINT(XM2)+NINT(  &
     &                                    XM3)).EQ.0 ) THEN
!
                                         CGAUNT = SQRT((2*XL1+1)        &
     &                                      *(2*XL2+1)/(4*PI*(2*XL3+1)))&
     &                                      *(-1)**(-NINT(XM3))         &
     &                                      *CGCRAC(FACT,XL1,XL2,XL3,   &
     &                                      0.0D0,0.0D0,0.0D0)          &
     &                                      *CGCRAC(FACT,XL1,XL2,XL3,   &
     &                                      XM1,XM2,-XM3)
!
                                         RGAUNT = RGAUNT +              &
     &                                      DREAL(CC1*CC2*CC3)*CGAUNT
                                       END IF
                                    END DO
                                 END DO
                              END DO
!
                              IF ( ABS(RGAUNT).GT.1.0D-8 ) THEN
                                 IG123 = IG123 + 1
                                 IF ( IG123.GT.LGNT123 ) THEN
                                    WRITE (6,*) '   STOP IN <STRGAUNT> '
                                    WRITE (6,*) '   LGNT123 =',LGNT123, &
     &                                 '  TOO SMALL'
                                    WRITE (6,*)                         &
     &                                  '   INCREASE ARRAY - SIZE'
                                    STOP
                                 END IF
                                 NGNT(LM1LM2) = NGNT(LM1LM2) + 1
                                 GNT(IG123) = PRE*RGAUNT
                                 IGNT(IG123) = L3*(L3+1) + M3 + 1
!                 WRITE(6,'('' GAUNT'',4I4,F20.10)')
!     &           LM1,LM2,IGNT(IG123),IG123, GNT(IG123)
!
                              END IF
!
                           END DO
                        END DO
                     END IF
                  END DO
               END DO
            END DO
         END DO
!
!RRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRRR
!
      END IF
!
!      WRITE (6,90001) LMAX,IG123
90001 FORMAT(/,10X,'for LMAX =',I2,I6,                                  &
     &' non-zero GAUNTS tabulated',/)
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: strsmat.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE STRSMAT(LMAX,CGC,SRREL,NRREL,IRREL,NKMMAX,NKMPMAX)
!   ********************************************************************
!   *                                                                  *
!   *    INITIALIZE TRANSFORMATION MATRIX THAT TAKES MATRICES FROM     *
!   *    RELATIVISTIC  TO  REAL SPERICAL HARM.  REPRESENTATION         *
!   *                                                                  *
!   *    ONLY THE NON-0 ELEMENTS OF THE MATRIX ARE STORED              *
!   *                                                                  *
!   * 25/10/95  HE  proper convention of trans. matrix introduced      *
!   ********************************************************************
!
      IMPLICIT NONE
!
! PARAMETER definitions
!
      COMPLEX*16 CI,C1,C0
      PARAMETER (CI=(0.0D0,1.0D0),C1=(1.0D0,0.0D0),C0=(0.0D0,0.0D0))
!
! Dummy arguments
!
      INTEGER LMAX,NKMMAX,NKMPMAX
      REAL*8 CGC(NKMPMAX,2)
      INTEGER IRREL(2,2,NKMMAX),NRREL(2,NKMMAX)
      COMPLEX*16 SRREL(2,2,NKMMAX)
!
! Local variables
!
      COMPLEX*16 CREL(NKMMAX,NKMMAX),RC(NKMMAX,NKMMAX),                 &
     &           RREL(NKMMAX,NKMMAX)
      INTEGER I,IKM,J,JP05,K,L,LAM,LM,LNR,LR,M,MUEM05,MUEP05,NK,NKM,NLM,&
     &        NS1,NS2
      REAL*8 W
!
      NK = 2*(LMAX+1) + 1
      NLM = (LMAX+1)**2
      NKM = 2*NLM
!     ===================================================
!     INDEXING:
!     IKM  = L*2*(J+1/2) + J + MUE + 1
!     LM   = L*(L+1)     +     M   + 1
!     ===================================================
!
! ----------------------------------------------------------------------
! CREL  transforms from  COMPLEX (L,M,S)  to  (KAP,MUE) - representation
!                 |LAM> = sum[LC] |LC> * CREL(LC,LAM)
! ----------------------------------------------------------------------
      CREL=C0 !KJ CALL ZCOPY(NKMMAX*NKMMAX,C0,0,CREL,1)
!
      LM = 0
      DO LNR = 0,LMAX
         DO M = -LNR,LNR
            LM = LM + 1
!
            IKM = 0
            DO K = 1,NK
               L = K/2
               IF ( 2*L.EQ.K ) THEN
                  JP05 = L
               ELSE
                  JP05 = L + 1
               END IF
!
               DO MUEM05 = -JP05,(JP05-1)
                  MUEP05 = MUEM05 + 1
                  IKM = IKM + 1
!
                  IF ( L.EQ.LNR ) THEN
                     IF ( MUEP05.EQ.M ) CREL(LM,IKM) = CGC(IKM,1)
                     IF ( MUEM05.EQ.M ) CREL(LM+NLM,IKM) = CGC(IKM,2)
                  END IF
!
               END DO
            END DO
!
         END DO
      END DO
!
! ----------------------------------------------------------------------
!    RC  transforms from  REAL to  COMPLEX (L,M,S) - representation
!                 |LC> = sum[LR] |LR> * RC(LR,LC)
! ----------------------------------------------------------------------
      RC=C0 !KJ CALL ZCOPY(NKMMAX*NKMMAX,C0,0,RC,1)
!
      W = 1.0D0/SQRT(2.0D0)
!
      DO L = 0,LMAX
         DO M = -L,L
            I = L*(L+1) + M + 1
            J = L*(L+1) - M + 1
!
            IF ( M.LT.0 ) THEN
               RC(I,I) = -CI*W
               RC(J,I) = W
               RC(I+NLM,I+NLM) = -CI*W
               RC(J+NLM,I+NLM) = W
            END IF
            IF ( M.EQ.0 ) THEN
               RC(I,I) = C1
               RC(I+NLM,I+NLM) = C1
            END IF
            IF ( M.GT.0 ) THEN
               RC(I,I) = W*(-1.0D0)**M
               RC(J,I) = CI*W*(-1.0D0)**M
               RC(I+NLM,I+NLM) = W*(-1.0D0)**M
               RC(J+NLM,I+NLM) = CI*W*(-1.0D0)**M
            END IF
         END DO
      END DO
!
! ----------------------------------------------------------------------
! RREL  transforms from   REAL (L,M,S)  to  (KAP,MUE) - representation
!                 |LAM> = sum[LR] |LR> * RREL(LR,LAM)
! ----------------------------------------------------------------------
      CALL ZGEMM('N','N',NKM,NKM,NKM,C1,RC,NKMMAX,CREL,NKMMAX,C0,RREL,  &
     &              NKMMAX)
!
!     ---------------------------------------------------
!     store the elements of  RREL
!     ---------------------------------------------------
      DO LAM = 1,NKM
         NS1 = 0
         NS2 = 0
!
         DO LR = 1,2*NLM
            IF ( CDABS(RREL(LR,LAM)).GT.1D-6 ) THEN
               IF ( LR.LE.NLM ) THEN
                  NS1 = NS1 + 1
                  IF ( NS1.GT.2 ) STOP ' IN <STRSMAT>   NS1 > 2'
                  SRREL(NS1,1,LAM) = RREL(LR,LAM)
                  IRREL(NS1,1,LAM) = LR
               ELSE
                  NS2 = NS2 + 1
                  IF ( NS2.GT.2 ) STOP ' IN <STRSMAT>   NS2 > 2'
                  SRREL(NS2,2,LAM) = RREL(LR,LAM)
                  IRREL(NS2,2,LAM) = LR - NLM
               END IF
            END IF
         END DO
!
         NRREL(1,LAM) = NS1
         NRREL(2,LAM) = NS2
      END DO
!
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: strvecgen.f90,v $:
! $Revision: 1.7 $
! $Author: jorissen $
! $Date: 2012/02/04 00:38:51 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*==strvecgen.f    processed by SPAG 6.05Rc at 23:00 on 17 Mar 2002
      SUBROUTINE STRVECGEN(NQ,ALAT)
!      SUBROUTINE STRVECGEN(NQ,IPRINT,ALAT,RMAX,GMAX,GMAXSQ,NRTAB,SMAX,  &
!     &                     NMAX,NQQP,NIJQ,IJQ,BRX,BRY,BRZ,BGX,BGY,BGZ,  &
!     &                     QX,QY,QZ,QQPX,QQPY,QQPZ,G1,G2,G3,R1,R2,R3,   &
!     &                     NGRLMAX,NRDLMAX,NRDLMAX0,NQMAX,NQQPMAX)
!   ********************************************************************
!   *                                                                  *
!   *   GENERATE VECTORS OF DIRECT AND RECIPROCAL SPACE FROM           *
!   *   BASIC TRANSLATION VECTORS (BRX,BRY,BRZ)                        *
!   *                                                                  *
!   ********************************************************************
!
      use energygrid,only : emin,emax
	  use controls,only: IPRINT
	  use boundaries,only : NGRLMAX,NRDLMAX,NRDLMAX0,NQMAX,NQQPMAX,nr,ng,nrdl 
	  use workstrfacs2,only : BRX,BRY,BRZ,BGX,BGY,BGZ,QX,QY,QZ,QQPX,QQPY,QQPZ,G1,G2,G3,R1,R2,R3,init_workstrfacs2_b,init_workstrfacs2_c,exit_workstrfacs2_b,init_workstrfacs2_d
	  use workstrfacs,only : IJQ,NIJQ,NMAX,NQQP,NRTAB,SMAX,RMAX,GMAX,GMAXSQ,init_workstrfacs_b,init_workstrfacs_c
      IMPLICIT REAL*8(A-H,O-Z)
!
!*** Start of declarations rewritten by SPAG
!
! PARAMETER definitions
!
      REAL*8, parameter :: PI=3.141592653589793238462643D0
	  real*8, parameter :: QQPtolerance=0.00100d0
!
! Dummy arguments
!
      REAL*8 ALAT !,GMAX,GMAXSQ,RMAX
      INTEGER NQ !,NRTAB,NMAX,IPRINT,NQQP !,NGRLMAX,NQMAX,NQQPMAX,NRDLMAX,NRDLMAX0
!      REAL*8 BGX(3),BGY(3),BGZ(3),BRX(3),BRY(3),BRZ(3),QQPX(NQQPMAX),   &
!     &       QQPY(NQQPMAX),QQPZ(NQQPMAX),QX(NQMAX),QY(NQMAX),QZ(NQMAX)
!      INTEGER G1(NGRLMAX),G2(NGRLMAX),G3(NGRLMAX),
!	  INTEGER IJQ(NQQPMAX,NQQPMAX),SMAX(NQQPMAX), NIJQ(NQQPMAX) !,R1(NRDLMAX0),R2(NRDLMAX0),R3(NRDLMAX0)

! Local variables
!
      DOUBLE PRECISION DABS,DBLE,DSQRT
      REAL*8 DD(3),DG(NGRLMAX),DGMIN,DK(3),DQ,DR(NRDLMAX0),DRMIN,DX,    &
     &       EDUMAX,EDUMIN,GA,GMAX1,GX,GY,GZ,KNX,KNY,KNZ,KSQ,P,RA,REDU, &
     &       RMAX1,RX,RY,RZ,SX,SY,SZ,VOL
      REAL*8 DMAX1,DMIN1
      INTEGER I,I1,I2,I3,IE,IETOP,IG,II,INSIDE,IQ,IQQP,IR,ISHIG,ISLOW,J,&
     &        J1,J2,J3,JHIG,JLOW,JQ,K,KK,M,N,NSG(NGRLMAX),NSH,    &
     &        NSR(NRDLMAX),NUMG,NUMGH,NUMR,NUMRH  !,NG,NR,NRDL
      INTEGER INT
	  !integer nrdl,nr 
!
!*** End of declarations rewritten by SPAG
!
      if(iprint.gt.1) WRITE (6,99001)
!
!     PRIMITIVE VECTORS (BGX,BGY,BGZ) OF RECIPROCAL SPACE
!
      DO I = 1,3
         I1 = 1 + MOD(I,3)
         I2 = 1 + MOD(I1,3)
         BGX(I) = BRY(I1)*BRZ(I2) - BRZ(I1)*BRY(I2)
         BGY(I) = BRZ(I1)*BRX(I2) - BRX(I1)*BRZ(I2)
         BGZ(I) = BRX(I1)*BRY(I2) - BRY(I1)*BRX(I2)
      END DO
      VOL = DABS(BRX(1)*BGX(1)+BRY(1)*BGY(1)+BRZ(1)*BGZ(1))
!
      DO I = 1,3
         BGX(I) = BGX(I)/VOL
         BGY(I) = BGY(I)/VOL
         BGZ(I) = BGZ(I)/VOL
         if(iprint.gt.1) WRITE (6,99008) BGX(I),BGY(I),BGZ(I)
      END DO

!KJ First calculate the number of unique q_i - q_j :
      call init_workstrfacs2_b(nqqpmax)
      NQQP = 0
      DO IQ = 1,NQ
         DO JQ = 1,NQ
            DO IQQP = 1,NQQP
               IF ( (ABS(QQPX(IQQP)-(QX(IQ)-QX(JQ))).LT.QQPtolerance) .AND.  &
                   (ABS(QQPY(IQQP)-(QY(IQ)-QY(JQ))).LT.QQPtolerance) .AND.  &
                   (ABS(QQPZ(IQQP)-(QZ(IQ)-QZ(JQ))).LT.QQPtolerance) ) THEN

                  GOTO 40
               END IF
            END DO

            NQQP = NQQP + 1
            QQPX(NQQP) = QX(IQ) - QX(JQ)
            QQPY(NQQP) = QY(IQ) - QY(JQ)
            QQPZ(NQQP) = QZ(IQ) - QZ(JQ)
 40      END DO
      END DO
!	  nqqpmax = nqqp  !It's important to get this dimension exactly right because it features in some gigantic arrays
	  call exit_workstrfacs2_b
	  call init_workstrfacs2_b(nqqp)  !reallocate qqpx,qqpy,qqpz with right sizes.
	  call init_workstrfacs_c !allocate ijq,nijq,smax
!KJ end my code to fix nqqpmax	



!
!   calculate radii RA,GA of spheres holding all vectors used in lattice
!   sums. RMAX1 is longest basis vector. GMAX1 is 2* longest vector
!   in Brillouin zone. must be reconsidered in any new applications
!KJ Note: we already know nqqp, I'm leaving the old code here just b/c too lazy to edit it ...
!
      RMAX1 = 0.0D0
      NQQP = 0
!
      DO IQ = 1,NQ
         DO JQ = 1,NQ
            DO IQQP = 1,NQQP
               IF ( (ABS(QQPX(IQQP)-(QX(IQ)-QX(JQ))).LT.QQPtolerance) .AND.  &
     &              (ABS(QQPY(IQQP)-(QY(IQ)-QY(JQ))).LT.QQPtolerance) .AND.  &
     &              (ABS(QQPZ(IQQP)-(QZ(IQ)-QZ(JQ))).LT.QQPtolerance) ) THEN

                  NIJQ(IQQP) = NIJQ(IQQP) + 1
                  IJQ(NIJQ(IQQP),IQQP) = 100*IQ + JQ
                  GOTO 50
               END IF
            END DO
!
            IF ( (NQQP+1).GT.NQQPMAX ) THEN
               WRITE (6,99002) NQQP
               STOP
            END IF
            NQQP = NQQP + 1
            SMAX(NQQP) = 0
            NIJQ(NQQP) = 1
            IJQ(1,NQQP) = 100*IQ + JQ
            QQPX(NQQP) = QX(IQ) - QX(JQ)
            QQPY(NQQP) = QY(IQ) - QY(JQ)
            QQPZ(NQQP) = QZ(IQ) - QZ(JQ)
            DQ = SQRT(QQPX(NQQP)**2+QQPY(NQQP)**2+QQPZ(NQQP)**2)
            IF ( DQ.GE.RMAX1 ) RMAX1 = DQ
!
 50      END DO
      END DO
!
      if(iprint.gt.1) WRITE (6,99009) NQQP


      IF ( IPRINT.GT.0 ) THEN
         WRITE (6,99010)
         DO N = 1,NQQP
            WRITE (6,99011) NIJQ(N),QQPX(N),QQPY(N),QQPZ(N), (INT(IJQ(M,N)/100),(IJQ(M,N)-100*INT(IJQ(M,N)/100)),M=1, MIN(5,NIJQ(N)))
            IF ( NIJQ(N).GT.5 ) WRITE (6,99012) (INT(IJQ(M,N)/100),(IJQ(M,N) -100*INT(IJQ(M,N)/100)),M=6, NIJQ(N))
         END DO
      END IF
!
      DO I = 1,3
         DD(I) = DSQRT(BRX(I)**2+BRY(I)**2+BRZ(I)**2)
         DK(I) = DSQRT(BGX(I)**2+BGY(I)**2+BGZ(I)**2)
      END DO
      DRMIN = DMIN1(DD(1),DD(2),DD(3))
      DGMIN = DMIN1(DK(1),DK(2),DK(3))
      GMAX1 = DMAX1(DK(1),DK(2),DK(3))
!
      RA = RMAX + RMAX1*1.001D0
      GA = GMAX + GMAX1
      GA = GMAX
!
      if(iprint.gt.0) WRITE (6,99015) RMAX,GMAX,RMAX1,GMAX1,RA,GA
!
      NUMR = 2*(INT(RA/DRMIN)+1) + 1
      NUMG = 2*(INT(GA/DGMIN)+1) + 1
      NUMRH = NUMR/2 + 1
      NUMGH = NUMG/2 + 1
      if(iprint.gt.0) WRITE (6,99013) NUMR,NUMG
!
! ======================================================================
!                            REAL SPACE
! ======================================================================
!
!  accept a R-point ->R[S] in list if
!
!                  |->R[S] - (->Q[i] - ->Q[i'])| < rmax
!
!  i.e. the center of the convergence sphere of radius rmax  is at
!  (->Q[i] - ->Q[i']) and is therefore different for every [i,i'].
!  the  SMAX(IQQP)  R-points ->R[S] within the sphere are picked
!  out of the list using the pointer INDR(S,IQQP) S=1,..,SMAX(IQQP)
!  INDR(S,IQQP) is set up in <STRAA> and used in <STRBBDD>.
!
      IF ( IPRINT.GT.2 ) WRITE (6,99003)


!KJ fix nr, and the other thing :)
      NR = 0
      DO I1 = -NUMRH, + NUMRH
         DO I2 = -NUMRH, + NUMRH
            DO I3 = -NUMRH, + NUMRH
               RX = I1*BRX(1) + I2*BRX(2) + I3*BRX(3)
               RY = I1*BRY(1) + I2*BRY(2) + I3*BRY(3)
               RZ = I1*BRZ(1) + I2*BRZ(2) + I3*BRZ(3)
               INSIDE = 0
               DO IQQP = 1,NQQP
                  SX = RX - QQPX(IQQP)
                  SY = RY - QQPY(IQQP)
                  SZ = RZ - QQPZ(IQQP)
                  DX = DSQRT(SX*SX+SY*SY+SZ*SZ)
                  IF ( DX.LE.RMAX ) THEN
                     INSIDE = 1
                     SMAX(IQQP) = SMAX(IQQP) + 1
                  END IF
               END DO

               IF ( INSIDE.NE.0 ) THEN
                  NR = NR + 1
               END IF

            END DO
         END DO
      END DO
	  !NRDLMAX0=NR
	  nrdl=0  !NRDLMAX=0
	  do iqqp=1,nqqp
	     if(smax(iqqp).gt.nrdl) nrdl=smax(iqqp)   !nrdlmax) !nrdlmax=smax(iqqp)
	  enddo
	  call init_workstrfacs2_c(nr,nrdl,nqqp)
	  call init_workstrfacs_b  ! iilers
	  SMAX(:)=0  !reset, because we'll count it again right now!
!KJ end my code  


      NR = 0
      DO I1 = -NUMRH, + NUMRH
         DO I2 = -NUMRH, + NUMRH
            DO I3 = -NUMRH, + NUMRH
               RX = I1*BRX(1) + I2*BRX(2) + I3*BRX(3)
               RY = I1*BRY(1) + I2*BRY(2) + I3*BRY(3)
               RZ = I1*BRZ(1) + I2*BRZ(2) + I3*BRZ(3)
               INSIDE = 0
               DO IQQP = 1,NQQP
                  SX = RX - QQPX(IQQP)
                  SY = RY - QQPY(IQQP)
                  SZ = RZ - QQPZ(IQQP)
                  DX = DSQRT(SX*SX+SY*SY+SZ*SZ)
                  IF ( DX.LE.RMAX ) THEN
                     INSIDE = 1
                     SMAX(IQQP) = SMAX(IQQP) + 1
                     IF ( SMAX(IQQP).GT.NRDLMAX ) GOTO 300
                  END IF
               END DO

               IF ( INSIDE.NE.0 ) THEN
                  NR = NR + 1
                  IF ( NR.GT.NRDLMAX0 ) GOTO 100
                  DR(NR) = DSQRT(RX*RX+RY*RY+RZ*RZ)
                  R1(NR) = I1
                  R2(NR) = I2
                  R3(NR) = I3
               END IF

            END DO
         END DO
      END DO
!
! -------------------------------- SORT VECTORS IN ORDER OF INCREASING D
!
      NSH = 1
      NSR(1) = 1
!
      DO II = 2,NR
         I = II - 1
         K = I
         P = DR(I)
!
         DO J = II,NR
            IF ( DR(J).LT.P ) THEN
               K = J
               P = DR(J)
            END IF
         END DO
!
         IF ( K.NE.I ) THEN
            DR(K) = DR(I)
            DR(I) = P
!
            IR = R1(I)
            R1(I) = R1(K)
            R1(K) = IR
            IR = R2(I)
            R2(I) = R2(K)
            R2(K) = IR
            IR = R3(I)
            R3(I) = R3(K)
            R3(K) = IR
         END IF
!
         IF ( I.GT.1 ) THEN
            IF ( ABS(DR(I)-DR(I-1)).GT.1.0D-6 ) THEN
               IF ( IPRINT.GT.2 ) WRITE (6,99017) NSH,NSR(NSH)
               NSH = NSH + 1
               NSR(NSH) = 1
            ELSE
               NSR(NSH) = NSR(NSH) + 1
            END IF
         END IF
!
         IF ( IPRINT.GT.2 ) WRITE (6,99018) I,R1(I),R2(I),R3(I),DR(I)
!
         IF ( I.EQ.(NR-1) ) THEN
            J = I + 1
            IF ( ABS(DR(J)-DR(J-1)).GT.1.0D-6 ) THEN
               IF ( IPRINT.GT.2 ) WRITE (6,99017) NSH,NSR(NSH)
               NSH = NSH + 1
               NSR(NSH) = 1
            ELSE
               NSR(NSH) = NSR(NSH) + 1
            END IF
            IF ( IPRINT.GT.2 ) WRITE (6,99018) J,R1(I),R2(I),R3(I),DR(I)
            IF ( IPRINT.GT.2 ) WRITE (6,99017) NSH,NSR(NSH)
         END IF
!
      END DO
!
!
! ======================================================================
!                           RECIPROCAL SPACE
! ======================================================================
!
!  accept a k-point ->G[n] in list if
!
!                     ( (->k+->G[n])**2 - EDU ) < GMAX**2
!
!  i.e. the center of the convergence sphere of radius  GMAX  is at +EDU
!  EDU can vary between  edumin .. edumax  and ->k is within the BZ
!  the set parameter correspond to E=0..3 Ry     !KJ changed them
!

!KJ original SPRKKR statements :
!      EDUMIN = 0.0D0/(2*PI/ALAT)**2
!      EDUMAX = 3.0D0/(2*PI/ALAT)**2
!KJ my new statements  01/2007 :
!KJ I'm choosing here a range that seems to work reasonably for applications I've tested.
!   However, eg. for diamond treated in a primitive cubic box with 8 atoms, one can see
!   the residue shoot up steeply by a factor of 100000 between energies 2.5 and 4 Ry
!   for site-offdiagonal terms of the free structure factor.
!   If a user suspects something fishy may be going on, he can use the multiplicative factors
!   to both the real and reciprocal space sums instead of tampering with the code here, as these
!   also serve to increase the radius of used vectors.
      edumin=abs(2*emin)/(2*PI/ALAT)**2
        edumax=abs(2*emax)/(2*PI/ALAT)**2
        if(iprint.gt.1) write(*,*) 'min',emin,edumin
        if(iprint.gt.1) write(*,*) 'max',emax,edumax

      IETOP = 3
      KK = 1
      GMAXSQ = GMAX**2
      IF ( IPRINT.GT.2 ) WRITE (6,99004)
	  
!KJ  First count the number of vectors needed (NG):
      NG = 0
!
      DO I1 = -NUMGH, + NUMGH
         DO I2 = -NUMGH, + NUMGH
            DO I3 = -NUMGH, + NUMGH
               GX = I1*BGX(1) + I2*BGX(2) + I3*BGX(3)
               GY = I1*BGY(1) + I2*BGY(2) + I3*BGY(3)
               GZ = I1*BGZ(1) + I2*BGZ(2) + I3*BGZ(3)
               INSIDE = 0
!
               DO J1 = -KK, + KK
                  DO J2 = -KK, + KK
                     DO J3 = -KK, + KK
                        KNX = GX + 0.5D0*(J1*BGX(1)+J2*BGX(2)+J3*BGX(3))
                        KNY = GY + 0.5D0*(J1*BGY(1)+J2*BGY(2)+J3*BGY(3))
                        KNZ = GZ + 0.5D0*(J1*BGZ(1)+J2*BGZ(2)+J3*BGZ(3))
                        KSQ = KNX**2 + KNY**2 + KNZ**2
!
                        DO IE = 0,IETOP
                           IF ( IETOP.NE.0 ) THEN
                              REDU = EDUMIN + IE*(EDUMAX-EDUMIN) /DBLE(IETOP)
                           ELSE
                              REDU = 0.0D0
                           END IF
                           IF ( (KSQ-REDU).LE.GMAXSQ ) THEN
                              INSIDE = 1
                              GOTO 61
                           END IF
                        END DO
                     END DO
                  END DO
               END DO

 61            CONTINUE
               IF ( INSIDE.NE.0 ) NG = NG + 1
            END DO
         END DO
      END DO
	  !NGRLMAX=NG
	  call init_workstrfacs2_d(NG,NQQP)
!KJ end	  
	  
      NG = 0
!
      DO I1 = -NUMGH, + NUMGH
         DO I2 = -NUMGH, + NUMGH
            DO I3 = -NUMGH, + NUMGH
               GX = I1*BGX(1) + I2*BGX(2) + I3*BGX(3)
               GY = I1*BGY(1) + I2*BGY(2) + I3*BGY(3)
               GZ = I1*BGZ(1) + I2*BGZ(2) + I3*BGZ(3)
               INSIDE = 0
!
               DO J1 = -KK, + KK
                  DO J2 = -KK, + KK
                     DO J3 = -KK, + KK
                        KNX = GX + 0.5D0*(J1*BGX(1)+J2*BGX(2)+J3*BGX(3))
                        KNY = GY + 0.5D0*(J1*BGY(1)+J2*BGY(2)+J3*BGY(3))
                        KNZ = GZ + 0.5D0*(J1*BGZ(1)+J2*BGZ(2)+J3*BGZ(3))
                        KSQ = KNX**2 + KNY**2 + KNZ**2
!
                        DO IE = 0,IETOP
                           IF ( IETOP.NE.0 ) THEN
                              REDU = EDUMIN + IE*(EDUMAX-EDUMIN) /DBLE(IETOP)
                           ELSE
                              REDU = 0.0D0
                           END IF
                           IF ( (KSQ-REDU).LE.GMAXSQ ) THEN
                              INSIDE = 1
                              GOTO 60
                           END IF
                        END DO
                     END DO
                  END DO
               END DO
!
 60            CONTINUE
               IF ( INSIDE.NE.0 ) THEN
                  NG = NG + 1
                  IF ( NG.GT.NGRLMAX ) GOTO 200
                  DG(NG) = DSQRT(GX*GX+GY*GY+GZ*GZ)
                  G1(NG) = I1
                  G2(NG) = I2
                  G3(NG) = I3
               END IF
            END DO
         END DO
      END DO
!
! -------------------------------- SORT VECTORS IN ORDER OF INCREASING D
!
      NSH = 1
      NSG(1) = 1
!
      DO II = 2,NG
         I = II - 1
         K = I
         P = DG(I)
!
         DO J = II,NG
            IF ( DG(J).LT.P ) THEN
               K = J
               P = DG(J)
            END IF
         END DO
!
         IF ( K.NE.I ) THEN
            DG(K) = DG(I)
            DG(I) = P
!
            IG = G1(I)
            G1(I) = G1(K)
            G1(K) = IG
            IG = G2(I)
            G2(I) = G2(K)
            G2(K) = IG
            IG = G3(I)
            G3(I) = G3(K)
            G3(K) = IG
         END IF
!
         IF ( I.GT.1 ) THEN
            IF ( ABS(DG(I)-DG(I-1)).GT.1.0D-7 ) THEN
               IF ( IPRINT.GT.2 ) WRITE (6,99017) NSH,NSG(NSH)
               NSH = NSH + 1
               NSG(NSH) = 1
            ELSE
               NSG(NSH) = NSG(NSH) + 1
            END IF
         END IF
!
         IF ( IPRINT.GT.2 ) WRITE (6,99018) I,G1(I),G2(I),G3(I),DG(I)
!
         IF ( I.EQ.(NG-1) ) THEN
            J = I + 1
            IF ( ABS(DG(J)-DG(J-1)).GT.1.0D-7 ) THEN
               IF ( IPRINT.GT.2 ) WRITE (6,99017) NSH,NSG(NSH)
               NSH = NSH + 1
               NSG(NSH) = 1
            ELSE
               NSG(NSH) = NSG(NSH) + 1
            END IF
            IF ( IPRINT.GT.2 ) WRITE (6,99018) J,G1(I),G2(I),G3(I),DG(I)
            IF ( IPRINT.GT.2 ) WRITE (6,99017) NSH,NSG(NSH)
         END IF
!
      END DO
!
      NMAX = NG
      NRTAB = NR
!
      if(iprint.gt.0) WRITE (6,99014) NRTAB,NMAX
      IF ( NQQP.GT.1 ) THEN
         IF ( IPRINT.GT.0 ) THEN
            WRITE (6,99016) (I,SMAX(I),I=1,NQQP)
         ELSE
            JHIG = 0
            JLOW = 1000000
            DO I = 1,NQQP
               IF ( SMAX(I).GT.JHIG ) THEN
                  ISHIG = I
                  JHIG = SMAX(I)
               END IF
               IF ( SMAX(I).LT.JLOW ) THEN
                  ISLOW = I
                  JLOW = SMAX(I)
               END IF
            END DO
            if(iprint.gt.0)WRITE (6,99016) ISLOW,JLOW
            if(iprint.gt.0)WRITE (6,99016) ISHIG,JHIG
         END IF
      END IF
!

      !KJ This used to be in straa; moved it here so it wouldn't get executed every time ETA changes.  2-2012
	  SMAX(1) = SMAX(1) - 1



      RETURN
!
 100  CONTINUE
      WRITE (6,*) NR,DX,RA,RMAX
      WRITE (6,99005) NRDLMAX0,DX,RA,RMAX
      STOP
 200  CONTINUE
      WRITE (6,99006) NGRLMAX,DX,GA,GMAX
      STOP
 300  CONTINUE
      WRITE (6,*) NR,DX,RA,RMAX
      WRITE (6,99007) NRDLMAX0,SMAX
      STOP
99001 FORMAT (/,10X,'primitive vectors of reciprocal space',/,10X,      &
     &        '       in units of 2*pi/a',/)
99002 FORMAT (/,10X,'STOP in <STRVECGEN> ',/,'NQQP =',I3,' > NQQPMAX')
99003 FORMAT (10X,'result from <STRVECGEN> for real space vectors',//,  &
     &        14X,'NO',5X,'SX',8X,'SY',8X,'SZ',8X,'D',/)
99004 FORMAT (10X,'result from <STRVECGEN> for reciprocal vectors',//,  &
     &        14X,'NO',5X,'KX',8X,'KY',8X,'KZ',8X,'D',/)
99005 FORMAT (' *** NR > NRDLMAX0 = ',I5,/,'   DX,RA,RMAX: ',3F10.5)
99006 FORMAT (' *** NG > NGRLMAX  = ',I5,/,'   DX,GA,GMAX: ',3F10.5)
99007 FORMAT (' *** SMAX > NRDLMAX0 =',I5,/,(10X,14I5))
99008 FORMAT (12X,'(',F10.5,',',F10.5,',',F10.5,' )')
99009 FORMAT (/,10X,'number of inequivalent QQP-block-matrices',        &
     &        '  NQQP =',I3)
99010 FORMAT (10X,'NIJQ (   ->Q[IQ] -  ->Q[JQ]   ) [IQ,JQ] ...')
99011 FORMAT (10X,I3,2X,'(',F7.3,',',F7.3,',',F7.3,' )',1X,             &
     &        5(:,'[',I2,',',I2,']'))
99012 FORMAT ((43X,5(:,'[',I2,',',I2,']')))
99013 FORMAT (10X,'NUMR  =',I10,10X,'NUMG  =',I10)
99014 FORMAT (10X,'NRTAB =',I10,10X,'NMAX  =',I10)
99015 FORMAT (//,10X,'RMAX  =',F10.4,10X,'GMAX  =',F10.4,/,10X,         &
     &        'RMAX1 =',F10.4,10X,'GMAX1 =',F10.4,/,10X,'RA    =',F10.4,&
     &        10X,'GA    =',F10.4,/)
99016 FORMAT (10X,'IQQP=',I4,': SMAX =',I4)
99017 FORMAT (' ',//,15X,'shell number',I5,' with',I5,' points',//)
99018 FORMAT (' ',10X,I5,3I10,F10.6)
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: strconfra.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION STRCONFRA(AA,X)
!
!   ********************************************************************
!   *                                                                  *
!   *         CONTINUED FRACTION   /D (18)/                            *
!   *                                                                  *
!   *         perform evaluation of continued fraction                 *
!   *         f(a,x) = [1/x+ (1-a)/1+ 1/x+ (2-a)/1+ ... ]              *
!   *         breaking sequence at (IMAX-a)/1+                         *
!   *                                                                  *
!   ********************************************************************
!

      IMPLICIT NONE

!
! PARAMETER definitions
!
      INTEGER IMAX0
      PARAMETER (IMAX0=100)
!
! Dummy arguments
!
      REAL*8 AA,X
      REAL*8 STRCONFRA
!
! Local variables
!
      INTEGER I,IMAX,J
      REAL*8 WERT,WERT0

      IMAX = IMAX0 - 20
!
 100  CONTINUE
      IMAX = IMAX + 20
!
      WERT = IMAX/X
!
      I = IMAX
      DO J = 2,IMAX
         WERT = 1.0D0 + WERT
         WERT = X + (I-AA)/WERT
         WERT = (I-1)/WERT
         I = I - 1
      END DO
!
      WERT = 1.0D0 + WERT
      WERT = X + (1.0D0-AA)/WERT
      WERT = 1.0D0/WERT
!
      IF ( IMAX.EQ.IMAX0 ) THEN
         WERT0 = WERT
         GOTO 100
      END IF
      IF ( ABS((WERT-WERT0)/WERT).GT.1.0D-10 ) THEN
         WERT0 = WERT
         GOTO 100
      END IF
!
      STRCONFRA = WERT
      END 

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: strfunqjl.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION STRFUNQJL(FACT,J,L)
!
!   ********************************************************************
!   *                                                                  *
!   *        PRE FACTORS FOR THE REAL SPHERICAL HARMONICS              *
!   *                                                                  *
!   ********************************************************************
!

      IMPLICIT NONE

!
! PARAMETER definitions
!
      REAL*8 PI
      PARAMETER ( PI=3.141592653589793238462643D0 )
!
! Dummy arguments
!
      INTEGER J,L
      REAL*8 FACT(0:100)
      REAL*8 STRFUNQJL
!
! Local variables
!
      REAL*8 WERT
!  /D (10)/
      IF ( J.EQ.0 ) THEN
         WERT = 0.5D0
      ELSE
         WERT = FACT(L-J)/FACT(L+J)
      END IF
      STRFUNQJL = SQRT(WERT*(2.0D0*L+1)/(2.0D0*PI))
!
      END 

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: strharpol.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      SUBROUTINE STRHARPOL(X,Y,Z)
!
!   ********************************************************************
!   *                                                                  *
!   *   HARMONIC POLYNOMIAL    R**L * YLM(->R)      ->R = (X,Y,Z)      *
!   *                                                                  *
!   *   WORKING FOR   REAL  AND  COMPLEX  SPHERICAL HARMONICS           *
!   *   SEE: WILLIAMS, JANAK AND MORUZZI                               *
!   *        PHYS.REV. B6 P.4509 (1972)                                *
!   *                                                                  *
!   ********************************************************************
!
      use boundaries
        use workstrfacs
        use workstrfacs2
        use controls,only: cplxylm

      IMPLICIT NONE

! Dummy arguments
!
      REAL*8 X,Y,Z
!
! Local variables
!
      REAL*8 CHP(0:LLARR),F,F1,F10,F2,F20,F3,RSQ,SHP(0:LLARR),XY,ZSQ
      INTEGER I,JJ,JJP1,LL,MM0LL
!

!KJ catch 0 argument (will produce NaN in calculation of T(:,:))
      if(dabs(x)+dabs(y)+dabs(z).lt.dble(0.00000001)) then
           xy=hp(1)
           hp=dble(0)
           hp(1)=xy
           return
        endif
!KJ

      SHP(0)=dble(0) ; CHP(0)=dble(1)
!
      XY = X*X + Y*Y
      ZSQ = Z*Z
      RSQ = XY + ZSQ
!
!     /WJM (B16) (B17)/
!
      DO JJ = 0,(LLMAX-1)
         JJP1 = JJ + 1
         CHP(JJP1) = X*CHP(JJ) - Y*SHP(JJ)
         SHP(JJP1) = X*SHP(JJ) + Y*CHP(JJ)
      END DO
!
!
!     T(L,J)
      T(1,0) = Z
!
!     /WJM (B19)/
!
      F1 = Z
      F2 = 0
      F3 = 1.0D0
!
      DO LL = 1,(LLMAX-1)
         F1 = F1 + Z + Z
         F2 = F2 + RSQ
         F3 = F3 + 1.0D0
         T(LL+1,0) = (F1*T(LL,0)-F2*T(LL-1,0))/F3
      END DO
!
!
!     /WJM (B20)/
!
      IF ( XY.GT.ZSQ ) THEN
!
         F20 = Z/XY
         F10 = 1.0D0 + Z*F20
!
         DO JJ = 0,(LLMAX-1)
            JJP1 = JJ + 1
            F1 = F10*(JJ+JJ+1)
            F2 = F20
!
            DO LL = (JJ+2),LLMAX
               F1 = F1 + F10
               F2 = F2 + F20
               T(LL,JJP1) = F1*T(LL-1,JJ) - F2*T(LL,JJ)
            END DO
         END DO
!
      ELSE
!
         F1 = -XY/Z
         F20 = RSQ/Z
!
         DO LL = 2,LLMAX
            JJ = LL
            F2 = F20*(LL+JJ)
            F3 = LL - JJ
!
            DO I = 1,(LL-1)
               JJ = JJ - 1
               F2 = F2 - F20
               F3 = F3 + 1.0D0
               T(LL,JJ) = (F1*T(LL,JJ+1)+F2*T(LL-1,JJ))/F3
            END DO
         END DO
!
      END IF
!
!     /WJM (B10) - B(12)/
!
!     HP(1) = QJLTAB(0,0) * T(0,0)  IN <STRAA>
!
      MM0LL = 1
      DO LL = 1,LLMAX
         MM0LL = MM0LL + LL + LL
         HP(MM0LL) = QJLTAB(0,LL)*T(LL,0)
         DO JJ = 1,LL
              if(.not.cplxylm) then
!                                                        ------
!                                                         REAL
!                                                        ------
               F = QJLTAB(JJ,LL)*T(LL,JJ)
               HP(MM0LL+JJ) = F*CHP(JJ)
               HP(MM0LL-JJ) = F*SHP(JJ)

              else
!                                                      ---------
!                                                       COMPLEX
!                                                      ---------
!               HP(MM0LL+JJ) = 
!     1			 CQMLTAB( JJ,LL)*T(LL,JJ)*DCMPLX(CHP(JJ),-SHP(JJ))
!               HP(MM0LL-JJ) = 
!     1			 CQMLTAB(-JJ,LL)*T(LL,JJ)*DCMPLX(CHP(JJ), SHP(JJ))
               stop 'activate complex code in strharpol'
!               To do that, the declaration of hp must be changed from real*8 to complex*16!  Otherwise, you will still lose
!               the complex part.
            endif
         END DO
      END DO
!

      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: cgcrac.f90,v $:
! $Revision: 1.2 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      FUNCTION CGCRAC(FACT,J1,J2,J3,M1,M2,M3)
!   ********************************************************************
!   *                                                                  *
!   *     CLEBSCH GORDAN COEFFICIENTS FOR ARBITRARY                    *
!   *     QUANTUM NUMBERS  J1,J2 ...                                   *
!   *     ACCORDING TO THE FORMULA OF   RACAH                          *
!   *     SEE: M.E.ROSE ELEMENTARY THEORY OF ANGULAR MOMENTUM          *
!   *          EQUATION (3.19)                                         *
!   *          EDMONDS EQ. (3.6.11) PAGE 45                            *
!   *                                                                  *
!   ********************************************************************
!
      IMPLICIT NONE
!
!
! Dummy arguments
!
      REAL*8 J1,J2,J3,M1,M2,M3
      REAL*8 CGCRAC
      REAL*8 FACT(0:100)
!
! Local variables
!
      INTEGER J,N,N1,N2,N3,N4,N5,NBOT,NTOP
      INTEGER NINT
      REAL*8 RFACT
      REAL*8 S,SUM,VF,X,Y
!
! INLINE FUNCTION    FACTORIAL FOR REAL ARGUMENT
      RFACT(X) = FACT(NINT(X))
!
!
      CGCRAC = 0.0D0
      IF ( ABS(M3-(M1+M2)).GT.1.0D-6 ) RETURN
      IF ( ABS(J1-J2).GT.J3 ) RETURN
      IF ( (J1+J2).LT.J3 ) RETURN
      IF ( ABS(M1).GT.(J1+1.0D-6) ) RETURN
      IF ( ABS(M2).GT.(J2+1.0D-6) ) RETURN
      IF ( ABS(M3).GT.(J3+1.0D-6) ) RETURN
!
      DO J = ABS(NINT(2*(J1-J2))),NINT(2*(J1+J2)),2
         IF ( J.EQ.NINT(2*J3) ) GOTO 100
      END DO
      RETURN
!
!
 100  CONTINUE
      X = (2.0D0*J3+1.0D0)*RFACT(J1+J2-J3)*RFACT(J1-J2+J3)              &
     &    *RFACT(-J1+J2+J3)*RFACT(J1+M1)*RFACT(J1-M1)*RFACT(J2+M2)      &
     &    *RFACT(J2-M2)*RFACT(J3+M3)*RFACT(J3-M3)
!
      Y = RFACT(J1+J2+J3+1)
!
      VF = DSQRT(X/Y)
!
!
      N1 = NINT(J1+J2-J3)
      N2 = NINT(J1-M1)
      N3 = NINT(J2+M2)
      N4 = NINT(J3-J2+M1)
      N5 = NINT(J3-J1-M2)
      NTOP = MIN(N1,N2,N3)
      NBOT = MAX(0,-N4,-N5)
!
      N = NBOT + 1
      IF ( N.EQ.(2*(N/2)) ) THEN
         S = +1.0D0
      ELSE
         S = -1.0D0
      END IF
      SUM = 0.0D0
!
      DO N = NBOT,NTOP
         S = -S
         Y = FACT(N)*FACT(N1-N)*FACT(N2-N)*FACT(N3-N)*FACT(N4+N)        &
     &       *FACT(N5+N)
         SUM = SUM + (S/Y)
      END DO
      CGCRAC = VF*SUM
      END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: rdhead.f90,v $:
! $Revision: 1.3 $
! $Author: hebhop $
! $Date: 2010/02/23 23:52:06 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
      subroutine rdhead (io, nhead, head, lhead)
      implicit double precision (a-h, o-z)

!     Reads title line(s) from unit io.  Returns number of lines
!     read.  If more than nheadx lines, skips over them.  End-of-header
!     marker is a line of 1 blank, 71 '-'s.
!     lhead is length of each line w/o trailing blanks.
!     header lines returned will have 1st space on line blank for
!     carriage control

      character*80 head(nhead)
      dimension lhead(nhead)
      character*80  line
      integer istrln
      external istrln

      n = 0
      nheadx = nhead
      nhead = 0
   10 read(io,20)  line
   20    format(a)
         if (line(4:11) .eq. '--------')  goto 100
         n = n+1
         if (n .le. nheadx)  then
            head(n) = line
            lhead(n) = istrln(head(n))
            nhead = n
         endif
      goto 10
  100 continue
      return
      end

