! Molecular Orbital PACkage (MOPAC)
! Copyright (C) 2021, Virginia Polytechnic Institute and State University
!
! MOPAC is free software: you can redistribute it and/or modify it under
! the terms of the GNU Lesser General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! MOPAC is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU Lesser General Public License for more details.
!
! You should have received a copy of the GNU Lesser General Public License
! along with this program.  If not, see <https://www.gnu.org/licenses/>.

program BZ 
  !***************************************************************
  !
  !   General Brillouin Zone plotting program.
  !   The main functions within BZ are:
  !
  !  1. To calculate the eigenvalue spectrum at specified points in the
  !     electronic or phonon BZ, and to determine the space-group 
  !     irreducible representations.
  !
  !  2. To plot the eigenvalue spectrum along lines within the BZ.
  !
  !  3. To plot eigenvalue surfaces within a BZ.
  !
  !***************************************************************
  use ifqwin
  use common_common, only : tvec, id, numat, phonon, ir, iw, jobnam, &
    data_set_name, units, iw_new, nfirst, nlast, per_atom, mr1, mr2, mr3, bcc, &
    keywrd, coord, ref_coord, line, sec_det, nvecs, size_x, size_y, l_read_dat
  implicit none
  integer :: i, i99, itype, j, mvecs, natot, alloc_stat, io_stat
 
  double precision, allocatable, dimension(:) :: MOPAC_sec_det
  logical :: exists, suffix = .false., is_brz = .false., is_dat = .false.
  double precision, external :: reada 
  character      :: num
  ! 
  iw = 6
#ifdef MOPAC_F2003
  i = command_argument_count()
#else
  i = iargc()
#endif
  l_read_dat = (i < 2)
  if (i == 0) then
    call graphics(0.0, 0.0, 1)
    write(iw,*)
    write(iw,*)" Program BZ generates Brillouin zones for systems with translation vectors"
    write(iw,*)
    write(iw,*)" It requires one or two arguments:"
    write(iw,*)" First argument: The name of the file containing information on the system,"
    write(iw,*)"                 this file is generated by MOPAC and its name ends in '.brz'"
    write(iw,*)
    write(iw,*)" Second argument (optional): The name of the file that contains the 'walk' in"
    write(iw,*)" 'k'-space.  This file will be generated if the 'walk' is supplied at run-time."
    write(iw,'(/5x,a)')"Press ""RETURN"" to quit"
    read (iw, "(Q,A)", end = 1100, err = 1100)i, line 
    call graphics(0.0, 0.0, 100)
    stop
  else
#ifdef MOPAC_F2003
    call get_command_argument(1, jobnam)
#else
    call getarg(1, jobnam)
#endif
    j = len_trim(jobnam) 
    if (jobnam(j - 3:j - 3) == ".") then
      suffix = .true.
      keywrd = jobnam(j - 2:)
      call upcase(keywrd(:3))
      is_brz = (keywrd(:3) == "BRZ")     
      jobnam = jobnam(:j - 4)
    end if
    if (i > 1) then
      ir = 25
#ifdef MOPAC_F2003
      call get_command_argument(2, data_set_name)
#else
      call getarg(2, data_set_name)
#endif
      i = len_trim(data_set_name) 
      if (i > 4) then
        if (data_set_name(i - 3:i - 3) == ".") then
          suffix = .true.
          keywrd = data_set_name(i - 2:)
          call upcase(keywrd(:3))
          is_dat = (keywrd(:3) == "DAT")     
          data_set_name = data_set_name(:i - 4)
        end if
      end if
      if (suffix) then
        if (is_brz .and. is_dat) then
          i99 = 0; io_stat = 0  ! Everything is okay
        else if (.not. is_brz .and. .not. is_dat) then
          i99 = 1; io_stat = 1  ! Swap names around
        else
          suffix = .false.
        end if
      end if    
      if (.not. suffix) then
!
!  Check that the data_set_name applies to the stored instruction set
!
        inquire (file=trim(jobnam)//".brz", exist = exists)
        i99 = 1
        io_stat = 1
        if (exists) then
          open (unit = 18, file = trim(jobnam)//".brz", status = "OLD", iostat = i99)
          if (i99 == 0) then
            read (18, *, iostat=io_stat)mvecs, mr1, mr2, mr3, bcc
          end if
          close (unit = 18)
        end if
      end if
      if (i99 /= 0 .or. io_stat /= 0) then
        keywrd = trim(jobnam)
        jobnam = trim(data_set_name)
        data_set_name = trim(keywrd)
      end if
    else
      ir = 6
      data_set_name = jobnam
    end if
  end if
!
! Read in (unformatted) information on the system from the <file>.brz file.
!
  inquire (file=trim(jobnam)//".brz", exist = exists)
  if (.not. exists) then
    call graphics(0.0, 0.0, 1)
    write (iw, '(/10x,a,/)') " File '"//trim(jobnam)//".brz' does not exist."
    write(iw,'(/5x,a)')"Press ""RETURN"" to quit"
    read (iw, "(Q,A)", end = 1100, err = 1100)i, line 
    call graphics(0.0, 0.0, 100)
    stop    
  end if  
  open (unit = 18, file = trim(jobnam)//".brz", status = "OLD", iostat = i99)
  if (i99 /= 0) then
    open (unit = iw_new, file = trim(data_set_name)//".txt", form = "FORMATTED", status = "UNKNOWN", iostat = i99)
    write (iw, '(/10x,a,/)') " Failed to open '"//trim(jobnam)//".brz'"
    write (iw_new, '(/10x,a,/)') " Failed to open '"//trim(jobnam)//".brz'"
    stop
  end if
!  write (iw, "(//,3A)") " Data for ", trim(jobnam), " is being read off disk"
  read (18, *, iostat=io_stat) mvecs, mr1, mr2, mr3, bcc
  mr1 = max(1, mr1)
  mr2 = max(1, mr2)
  mr3 = max(1, mr3)
  if (io_stat /= 0) then
   write (6,'(/,a)') " File exists, but the first five data could not be read."
   call sleep (60)
  end if
!
!  Create array to hold the secular determinant from MOPAC
!
  allocate (MOPAC_sec_det((mvecs*(mvecs+1))/2), stat = alloc_stat)
  if( alloc_stat /= 0 ) then
    write(iw,*)" Unable to allocate 'MOPAC_sec_det'"
    stop
  endif
  read (18, *, iostat=io_stat) MOPAC_sec_det 
  if (io_stat /= 0) then
   write (6,'(/,a)') " File exists, but the second set of data"
   write (6,'(a,i7,a)') " (the secular determinant) could not be read."
   call sleep (60)
  end if
  allocate (coord(3,2000), ref_coord(3,2000))
  read (18,*) tvec, id, numat, ((coord(j, i), j = 1, 3), i = 1, numat)
  ref_coord(:,:numat) = coord(:,:numat)
!
!  Create arrays to hold the starting and stopping addresses (from MOPAC)
!
  allocate (nfirst(numat), nlast(numat), per_atom(numat), stat = alloc_stat)
  if( alloc_stat /= 0 ) then
    write(iw,*)" Unable to allocate 'nfirst' and 'nlast'"
    stop
  endif
  read (18, *, end = 1000, err = 1000) (nfirst(i), nlast(i), i = 1, numat)
  per_atom = nlast - nfirst + 1
  phonon = (per_atom(1) == 3)
  if (phonon) then
    units = " cm^(-1)."
  else
    units = " eV."
  end if
  !
  !   Convert from MOPAC's giant unit cell to fundamental unit cell
  !
  !  mvecs = total number of vectors in the system.
  !  nvecs = number of vectors in a primitive unit cell
  !
  nvecs = (2*mvecs)/(mr1*mr2*mr3)
  if (.not. bcc) nvecs = nvecs/2
  natot = numat
  numat = numat * nvecs / mvecs
  do i = 1, 3
    tvec(i, 1) = tvec(i, 1) / mr1
    tvec(i, 2) = tvec(i, 2) / mr2
    tvec(i, 3) = tvec(i, 3) / mr3
  end do
!
!  Convert from secular determinant into small matrices representing
!  the interaction of the CUC with all cells.
!
  allocate (sec_det(nvecs,nvecs*mr1*mr2*mr3*8))
!
! All <file>.brz now read in. Read in data on what BZ has to do.
!
  call graphics(0.0, 0.0, 1)
  if (l_read_dat) then 
    call graphics(0.0, 0.0, 97)
    write (iw, "(A)") &
       & "     Do you want to calculate a point [0], ", &
       & "              or draw band-structures [1], "
    if (id /= 1) write (iw, "(A,\)") "              or draw energy surfaces [2], "
 !   write (iw, "(A)") " or do you want advice on diagnostics [3]?"
  else
    open(unit = ir, file = trim(data_set_name)//".dat", status = "OLD", iostat = i99)
    if (i99 /= 0) then
      inquire (file = trim(data_set_name)//".dat", exist = exists)
      if (exists) then
        write(iw,'(/10x,a)') " File: '"//trim(data_set_name)//".dat' exists, but cannot be opened"
      else
        write(iw,'(/10x,a)') " File: '"//trim(data_set_name)//".dat' does not exist"
      end if
      write(iw,'(/5x,a)')"Press ""RETURN"" to quit"
      read(iw,'(a)') num 
      if (num /= "{") call graphics(0.0, 0.0, 100)
      stop
    end if
!
!  Copy everything from the input file, and put it in a scratch file
!
     open(unit=99, status='SCRATCH', iostat = io_stat) 
     do
       do
         read(ir,'(a)', iostat = io_stat)line
         if (line(1:1) /= "*") exit
       end do       
       if (io_stat /= 0) exit
       write(99,'(a)')trim(line)
     end do
     close (ir)
     rewind(99)
     ir = 99
  end if  
!
! if  data-set <file>.dat supplied, then ir = 99, otherwise ir = 6
!
  read (ir, "(Q,A)", end = 1100, err = 1100)i, line 
!
! Keywords being read in, so allow room for extra data
!
  i = max(len_trim(line), 30)
  if (id /= 1) then
    line(i:) = ": Do you want to calculate a point [0], or draw band-structures [1], or draw energy surfaces [2] "
  else
    line(i:) = ": Do you want to calculate a point [0], or draw band-structures [1]"
  end if
  call write_keystrokes(line, len_trim(line))
  read(line, '(a80)') keywrd 
  call upcase(keywrd)
  if (index(keywrd," OPS")   + index(keywrd," SEC")    + index(keywrd," FRACT")  + index(keywrd," ROTSEC") + &
      index(keywrd," TRANS") + index(keywrd," SYMSEC") + index(keywrd," PRTVEC") + index(keywrd," ROTFOK") + &
      index(keywrd," VECT") + index(keywrd," SYMTRZ") /= 0) &
    open (unit = iw_new, file = trim(data_set_name)//".txt", form = "FORMATTED", status = "UNKNOWN", iostat = i99)
   call setup(MOPAC_sec_det, nvecs, sec_det)  
!
!  Rotate so that the first translation vector is along the "x" axis,
!  and, if it exists, the second translation vector is in the "x-y" plane.
!
!  Symmetrize the small matrices using information supplied by <filename>.ops
!
  size_x = 1.0
  size_y = 1.0
  i = index(keywrd, " SIZE=")
  if (i > 0) then
    size_x = real(reada(keywrd, i))
    size_y = size_x
  end if
  call orient(nvecs, sec_det, natot, coord) 
  itype = Nint (reada (keywrd, 1))
!
! Setup is now complete.  Use graphics for lines and surfaces
! data is either read in from channel 99 if a data-set <file>.dat has been supplied, of channel 6 otherwise.
!
  if (itype == 0) then
!
!  Calculate a point in "k" space, then do symmetry analysis, if symmetry data set exists
!
     call point(nvecs, sec_det)
  else if (itype == 1) then
!
!  Generate a picture of the band-structure.
!
    call make_line(nvecs, sec_det)
  else if (itype == 2) then
!
!  Generate pictures of energy surfaces.
!
    call surfac(nvecs, sec_det)
  else
    write (iw, "(A)") &
       & " Diagnostic Key-Words.  These are added after the numeric option ", &
       & " OPS:     Print the space-group symmetry operations", &
       & " SEC:     Print the Secular Determinant from MOPAC", &
       & " FRACT:   Print the Fractional Unit Cell Coordinates", &
       & " ROTSEC:  Print the Secular Determinant in crystal coordinate frame", &
       & " TRANS:   Print the transform to convert Cartesian into crystal coordinates", &
       & " SYMSEC:  Print the symmetrized Secular Determinant", " ", &
       & " For SEC, ROTSEC, and SYMSEC, an optional '=n' "// &
           & "can be added to print only the first 'n' unit cell interactions"
    write(iw,*)" Press return to exit"
    read(*,*)
    call graphics(0.0, 0.0, 100)
  end if
  stop
  1000 write (6, *) " Binary file missing or corrupt"
  1100 stop
  end program BZ
  subroutine write_keystrokes(text, len_text)
  use common_common, only : jobnam, l_read_dat
  implicit none
  integer, intent (in) :: len_text
  character, intent (in) :: text*(len_text)
!
  logical :: first = .true.
  integer :: status
  save
    if (.not. l_read_dat) return
    if (first) then
      first = .false.
      open (unit = 16, file = trim(jobnam)//".dat")
      rewind (16)
    end if
    write(16,'(a)', iostat = status) text
    return
  end subroutine write_keystrokes
  
