module structure

  use constants,   only : dp, sq2, sq3, tpi, pi, zero, half, one, two
  use constants,   only : alat, tpiba, tpiba2, eps
  use utilities,   only : error
  implicit none

  real(dp)        :: at(3,3), &      ! basis vectors of the Bravais lattice
                                     ! (in units of alat)
                     bg(3,3),&       ! basis vectors of the reciprocal lattice
                                     ! (in units of tpiba = 2 pi / alat)
                     omega           ! volume of the unit cell

  character (len=15) :: lattice_type !

  type atom
   real(DP), pointer     :: tau(:)  ! cartesian coordinates of the atom
   character (len=2)     :: label   ! label for the atomic species
   integer               :: itype   ! pointer to the tables of at species
  end type atom

  type pseudo
   real(dp), pointer :: vps(:)  ! reciprocal-space table for pseudo-potential
   real(dp)          :: dq      ! v(i*dq) = vps(i)
   complex(dp),pointer :: vg(:) ! the pseudo-potential on the G-vector array
   complex(dp),pointer :: vgq(:) ! the pseudo-potential on the G+q-vector array
  end type pseudo

  type element
   character (len=2)     :: name    ! name of the species (matches atom%label)
   real(dp)              :: zv      ! valence number
   complex(dp), pointer  :: s(:)    ! structure factor for the present species
   type(pseudo)          :: ps      ! pseudopotential for the present species
  end type element

  type(atom), allocatable          :: atoms(:)
  type(element), allocatable       :: species(:)
  integer                          :: ntyp, nats, nelec


contains

  subroutine latgen(lattice,celldm)

    !   This routine sets up the alat, at, bg, omega, tpiba, 
    !   tpiba2 (=tpiba^2), and lattice_type variables (see
    !   above for a definition of these variables). The alat, 
    !   tpiba, and tpiba2 variable actually define physical units
    !   and they are therefore found in the "constants" module.

    use utilities, only: error, inv3x3
    implicit none

    character (len=*), intent(in)  :: lattice   ! index of the Bravais lattice
    real(DP),          intent(in)  :: celldm(6) ! shape & dimensions of the 

    ! simple cubic lattice
    !    label       = 'sc'
    !    celldm(1)   = lattice parameter
    !    celldm(2:6) : not used
    !
    ! face-centered cubic lattice
    !    label       = 'fcc'
    !    celldm(1)   = lattice parameter
    !    celldm(2:6) : not used
    !
    ! body-centered cubic lattice
    !    label       = 'bcc'
    !    celldm(1)   = lattice parameter
    !    celldm(2:6) : not used
    !
    ! Other Bravais lattices not yet implemented
    !
    ! hexagonal lattice
    !    label       = 'hexagonal'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(3)   = c/a
    !    celldm(2)   : not used
    !    celldm(4:6) : not used
    !
    ! trigonal lattice
    !    label       = 'trigonal'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(4)   = cos(alpha) ! angle between a1 and a2
    !    celldm(2:3) : not used
    !    celldm(5:6) : not used
    !
    ! tetragonal lattice
    !    label       = 'tetragonal'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(3)   = c/a
    !    celldm(2)   : not used
    !    celldm(4:6) : not used
    !
    ! body-centered tetragonal lattice
    !    label       = 'bc-tetragonal'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(3)   = c/a
    !    celldm(2)   : not used
    !    celldm(4:6) : not used
    !
    ! simple orthorombic lattice
    !    label       = 'orthorombic'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(2)   = b/a
    !    celldm(3)   = c/a
    !    celldm(4:6) : not used
    !
    ! one-face centered orthorombic lattice
    !    label       = 'ofc-orthorombic'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(2)   = b/a
    !    celldm(3)   = c/a
    !    celldm(4:6) : not used
    !
    ! all-face centered orthorombic lattice
    !    label       = 'afc-orthorombic'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(2)   = b/a
    !    celldm(3)   = c/a
    !    celldm(4:6) : not used
    !
    ! simple monoclinic lattice
    !    label       = 'monoclinic'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(2)   = b/a
    !    celldm(3)   = c/a
    !    celldm(4)   = cos(alpha) ! angle between a and b
    !    celldm(5:6) : not used
    !
    ! one-face centered monoclinic lattice
    !    label       = 'ofc-monoclinic'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(2)   = b/a
    !    celldm(3)   = c/a
    !    celldm(4)   = cos(alpha) ! angle between a and b
    !    celldm(5:6) : not used
    !
    ! triclinic lattice
    !    label       = 'triclinic'
    !    celldm(1)   = lattice parameter (a)
    !    celldm(2)   = b/a
    !    celldm(3)   = c/a
    !    celldm(4)   = cos(alpha) ! angle between b and c
    !    celldm(5)   = cos(beta ) ! angle between a and c
    !    celldm(6)   = cos(gamma) ! angle between a and b
    !

    real(DP) :: term,   &     !\
                term1,  &     ! \ 
                term2,  &     !   Auxiliary variables
                cbya,   &     ! /
                singam, &     !/ 
                sin           ! the sine function
    integer  :: ipol          ! counter on the coordinates 

    alat         = celldm(1)
    at (:,:)     = zero
    lattice_type = lattice

    select case(lattice)

    case ( 'sc' )       !     simple cubic lattice
       if ( celldm( 1 ) <= zero ) &
            call error( 'latgen', 'SC: wrong celldm', 1 )
       at(1,1) = one; at(2,2) = one; at(3,3) = one

    case ( 'fcc' )        !     fcc lattice
       if ( celldm( 1 ) <= zero ) &
            call error( 'latgen', 'FCC: wrong celldm', 2 )
       at(:,:) = half
       at(1,1) = ZERO; at(2,2)= ZERO; at(3,3) = ZERO
    case ( 'bcc' )        !     bcc lattice
       if ( celldm( 1 ) <= zero ) &
            call error( 'latgen', 'BCC: wrong celldm', 3 )
       at(:,:) = half
       at(1,1) = -half; at(2,2) = -half; at(3,3) = -half; 
    case ( 'hexagonal' )          !     hexagonal lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 3 ) <= zero ) &
            call error( 'latgen', 'HEXAGONAL: wrong celldm', 4 )
       cbya = celldm( 3 )
       at ( 1,1 ) =   one
       at ( 2,1 ) = - half
       at ( 2,2 ) =   sq3 / two
       at ( 3,3 ) =   cbya

    case ( 'trigonal' )          !     trigonal lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 4 ) <= -half ) & 
            call error( 'latgen', 'TRIGONAL: wrong celldm', 5 )
       term1 = sqrt( one + two * celldm(4) )
       term2 = sqrt( one - celldm( 4 ) )
       at ( 2,1 ) =   sq2 * term2 / sq3
       at ( 3,1 ) =   term1 / sq3
       at ( 1,2 ) =   term2 / sq2
       at ( 2,2 ) = - at ( 1,2 ) / sq3
       at ( 3,2 ) =   at ( 3,1 )
       at ( 1,3 ) = - at ( 1,2 )
       at ( 2,3 ) =   at ( 2,2 )
       at ( 3,3 ) =   at ( 3,1 )
       
    case ( 'tetragonal' )          !     tetragonal lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 3 ) <= zero ) & 
            call error( 'latgen', 'TETRAGONAL: wrong celldm', 6 )
       cbya = celldm( 3 )
       at ( 1,1 ) = one
       at ( 2,2 ) = one
       at ( 3,3 ) = cbya
       
    case ( 'bc-tetragonal' )          !     body centered tetragonal lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 3 ) <= zero ) &
            call error( 'latgen', 'Body-Centered TETRAGONAL: wrong celldm', 7 )
       cbya = celldm( 3 )
       at ( 1,1 ) =   half
       at ( 2,1 ) =   at ( 1,1 )
       at ( 3,1 ) =   cbya / two
       at ( 1,2 ) =   at ( 1,1 )
       at ( 2,2 ) = - at ( 1,1 )
       at ( 3,2 ) =   at ( 3,1 )
       at ( 1,3 ) = - at ( 1,1 )
       at ( 2,3 ) = - at ( 1,1 )
       at ( 3,3 ) =   at ( 3,1 )
       
    case ( 'orthorombic' )          !     Simple orthorombic lattice
       if ( celldm( 1 ) <= zero .or. & 
            celldm( 2 ) <= zero .or. & 
            celldm( 3 ) <= zero )    &
            call error( 'latgen', 'ORTHOROMBIC: wrong celldm', 8 )
       at ( 1,1 ) = one
       at ( 2,2 ) = celldm( 2 )
       at ( 3,3 ) = celldm( 3 )

    case ( 'ofc-orthorombic' )      !     One face centered orthorombic lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 2 ) <= zero .or. &
            celldm( 3 ) <= zero )    & 
            call error( 'latgen', &
            'One-Face-Centered ORTHOROMBIC: wrong celldm', 9 )
       at ( 1,1 ) =   half
       at ( 2,1 ) =   half * celldm( 2 )
       at ( 1,2 ) = - at ( 1,1 )
       at ( 2,2 ) =   at ( 2,1 )
       at ( 3,3 ) =   celldm( 3 )

    case ( 'afc-orthorombic' )       !  All face centered orthorombic lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 2 ) <= zero .or. &
            celldm( 3 ) <= zero )    &
            call error( 'latgen', &
            'All-Face-Centered ORTHOROMBIC: wrong celldm', 10 )
       at ( 1,1 ) = half
       at ( 2,1 ) = half * celldm( 2 )
       at ( 1,2 ) = at ( 1,1 )
       at ( 3,2 ) = half * celldm( 3 )
       at ( 2,3 ) = half * celldm( 2 )
       at ( 3,3 ) = at ( 3,2 )

    case ( 'bc-orthorombic' )        !     Body centered orthorombic lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 2 ) <= zero .or. &
            celldm( 3 ) <= zero )    &
            call error( 'latgen', &
            'Body-Centered ORTHOROMBIC: wrong celldm', 11 )
       at ( 1,1 ) =   half
       at ( 2,1 ) =   half * celldm( 2 )
       at ( 3,1 ) =   half * celldm( 3 )
       at ( 1,2 ) = - at ( 1,1 )
       at ( 2,2 ) =   at ( 2,1 )
       at ( 3,2 ) =   at ( 3,1 )
       at ( 1,3 ) = - at ( 1,1 )
       at ( 2,3 ) = - at ( 2,1 )
       at ( 3,3 ) =   at ( 3,1 )

    case ( 'monoclinic' )          !     Simple monoclinic lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 2 ) <= zero .or. &
            celldm( 3 ) <= zero .or. &
            abs ( celldm( 4 ) ) > one ) & 
            call error( 'latgen', 'MONOCLINIC: wrong celldm', 12 )
       sin = sqrt( one - celldm( 4 ) ** 2 )
       at ( 1,1 ) = one
       at ( 1,2 ) = celldm( 2 ) * celldm( 4 )
       at ( 2,2 ) = celldm( 2 ) * sin
       at ( 3,3 ) = celldm( 3 )
       
    case ( 'ofc-monoclinic' )          !  One-face centered monoclinic lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 2 ) <= zero .or. &
            celldm( 3 ) <= zero .or. &
            abs ( celldm( 4 ) ) > one ) & 
            call error( 'latgen', &
            'One-Face-Centered MONOCLINIC: wrong celldm', 13 )
       sin = sqrt( one - celldm( 4 ) ** 2 )
       at ( 1,1 ) =   celldm( 4 )
       at ( 3,1 ) =   sin
       at ( 1,2 ) =   at ( 1,1 )
       at ( 3,2 ) = - at ( 3,1 )
       at ( 1,3 ) =   celldm( 2 )
       at ( 2,3 ) =   celldm( 3 )
       
    case ( 'triclinic' )         !     Triclinic lattice
       if ( celldm( 1 ) <= zero .or. &
            celldm( 2 ) <= zero .or. &
            celldm( 3 ) <= zero .or. &
            abs ( celldm( 4 ) ) > one .or. &
            abs ( celldm( 5 ) ) > one .or. & 
            abs ( celldm( 6 ) ) > one ) &
            call error( 'latgen', 'TRICLINIC: wrong celldm', 14 )
       sin    = sqrt( one - celldm( 4 ) ** 2 )
       singam = sqrt( one - celldm( 6 ) ** 2 )
       term = sqrt( ( one + &
            two * celldm( 4 ) * celldm( 5 )  * celldm( 6 ) - &
            celldm( 4 ) ** 2 - & 
            celldm( 5 ) ** 2 - &
            celldm( 6 ) ** 2 ) &
            / ( one - celldm( 6 ) ** 2 ) )
       at ( 1,1 ) =   one
       at ( 1,2 ) =   celldm( 2 ) * celldm( 6 )
       at ( 2,2 ) =   celldm( 2 ) * singam
       at ( 1,3 ) =   celldm( 3 ) * celldm( 5 )
       at ( 2,3 ) =   celldm( 3 ) * ( celldm( 4 ) &
            - celldm( 5 ) * celldm( 6 ) ) / singam
       at ( 3,3 ) =   celldm( 3 ) * term
       
    case default
       call error('latgen', lattice//': wrong lattice label', 999 )

    end select

    call inv3x3(at,bg,omega) ! calculate the basis vectors of the 
    bg     = transpose(bg)   ! reciprocal lattice
    omega  = omega * alat**3
    tpiba  = two  * pi / alat
    tpiba2 = tpiba * tpiba

    return
  end subroutine latgen

  subroutine setup_elements 

    integer :: ityp, na, nb
    character (len=2), allocatable :: label(:)
!
! set number of atoms  
!
    nats = size(atoms)
    write (*,fmt='(" # of atoms/cell  = ",i4)') nats

    allocate(label(nats))
    label(:) = ''
!
! set number of atomic type and for each atom its type variable
!
    ntyp =0
    do na=1,nats
       ityp = 0
       do nb=1,na-1
         if (atoms(nb)%label==atoms(na)%label) ityp = atoms(nb)%itype
       end do
       if (ityp==0) then
           ntyp=ntyp+1
           ityp=ntyp
           label(ityp)=atoms(na)%label
       end if
       atoms(na)%itype = ityp
!       write(*,*) atoms(na)%tau(:), atoms(na)%label, atoms(nb)%itype
    enddo

    write (*,fmt='(" # of atomic type = ",i4)') ntyp

    allocate(species(ntyp))
!
! set the species names
!
    species%name = label(1:ntyp)
    write(*,*) species%name

    deallocate(label)

    return 
  end subroutine setup_elements

  subroutine set_electron_nmbr

    integer na, ityp, izv

    if (.not.allocated(atoms)) call error ( 'setup_electron_nmbr', &
       ' needed information on atoms is not available yet ',1)

    if (.not.allocated(species)) call error ( 'setup_electron_nmbr', &
       ' needed information on species is not available yet ',1)

    nelec = 0
    do na=1,nats
      ityp = atoms(na)%itype
      izv = nint(species(ityp)%zv)
      if (abs(species(ityp)%zv-izv) > eps) call error ('setup_electron_nmbr', &
         'an atom has non integer ionic charge',na)
      nelec = nelec + izv
    end do

    write (*,fmt='(" # of electrons/cell =",i6)') nelec

    return
  end subroutine set_electron_nmbr

end module structure

