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

module mod_QCsymmetry
  !! author: MDG
  !! version: 1.0
  !! date: 01/30/22
  !!
  !! class definition for 2D (axial) and 3D (icosahedral) quasi-crystal symmetry
  !!
  !! For the 3D QCs, we use an approach similar to that of the regular space groups
  !! with generator strings; for the 2D axial QCs, that has not been implemented yet
  !! and the approach is more direct in terms of the definition of the generator matrices.

use mod_kinds
use mod_global

IMPLICIT NONE

private

!>  SGname all icosahedral space group names
! ICOSAHEDRAL SPACE GROUPS
  character(13), public, dimension(11) :: SGname_ico = (/  &
          " P 5 3 2     ", " P 5_1 3 2   ", " I 5 3 2     ", " I 5_1 3 2   ", &
          " F 5 3 2     ", " F 5_1 3 2   ", " P -5 -3 2/m ", " P -5 -3 2/q ", &
          " I -5 -3 2/m ", " F -5 -3 2/m ", " F -5 -3 2/q " /)

!>  GL encoded generator strings
  character(57), public, dimension(11) :: GL_ico = (/  &
        "2b000000c000000                                          ", &
        "2bA00000c000000                                          ", &
        "3aBBBBBBb000000c000000                                   ", &
        "3aBBBBBBbA00000c000000                                   ", &
        "7aBB0000a0BB000a00BB00a000BB0a0000BBb000000c000000       ", &
        "7aBB0000a0BB000a00BB00a000BB0a0000BBbA00000c000000       ", &
        "3b000000c000000d000000                                   ", &
        "3b000000c000000d000000                                   ", &
        "4aBBBBBBb000000c000000d000000                            ", &
        "8aBB0000a0BB000a00BB00a000BB0a0000BBb000000c000000d000000", &
        "3b000000c000000d000000                                   " /)

!> SGorder_ico is the order of the icosahedral 6D space groups
  integer(kind=irg), public, dimension(11) :: SGorder_ico = (/ &
        3182, 3182, 3183, 3183, 3187, 3187, 5442, 5442, 5543, 5547, 5442 /)

! class definition
type, public :: QCspacegroup_T
private
  integer(kind=irg)           :: nsg
  integer(kind=irg)           :: nsym
  integer(kind=irg)           :: SGnum
  integer(kind=irg)           :: GENnum             !< number of generator matrices
  integer(kind=irg)           :: MATnum             !< number of non-zero symmetry matrices
  integer(kind=irg)           :: NUMpt              !< number of point group operators
  integer(kind=irg)           :: N_Axial
  logical                     :: reduce             !< switch to enable/disable reduction to fundamental cell
  real(kind=dbl),allocatable, public  :: data(:,:,:)        !< all symmetry matrices for a given spacegroup
  real(kind=dbl),allocatable, public  :: direc(:,:,:)       !< direct space point group matrices
  real(kind=dbl),allocatable, public  :: recip(:,:,:)       !< reciprocal space point group matrices
  real(kind=dbl),allocatable, public  :: icos(:,:,:)        !< dummy 6x6 matrix used for various computations
  real(kind=dbl),allocatable  :: c(:,:)             !< dummy 6x6 matrix used for various computations
  character(11)               :: name
  character(fnlen),allocatable, public :: SGname(:)
  character(3)                :: QCtype
  character(57),allocatable, public   :: GL(:)

contains
private
  procedure, pass(self) :: printSGtable_
  procedure, pass(self) :: GetQCSpaceGroup_
  procedure, pass(self) :: setnsg_
  procedure, pass(self) :: setSGnum_
  procedure, pass(self) :: setNUMpt_
  procedure, pass(self) :: setMATnum_
  procedure, pass(self) :: setQCtype_
  procedure, pass(self) :: getnsg_
  procedure, pass(self) :: getSGnum_
  procedure, pass(self) :: getNUMpt_
  procedure, pass(self) :: getMATnum_
  procedure, pass(self) :: getnsym_
  procedure, pass(self) :: getQCtype_
  procedure, pass(self) :: getAxialGroupNames_
  procedure, pass(self) :: fillgen_QC_
  procedure, pass(self) :: MakeQCGenerators_
  procedure, pass(self) :: GenerateQCSymmetry_
  procedure, pass(self) :: matrixmult_
  procedure, pass(self) :: isnew_
  procedure, pass(self) :: isitnew_
  procedure, pass(self) :: IsGAllowedQC_
  procedure, pass(self) :: GetSymmetryOperators_
  ! procedure, pass(self) ::
  ! procedure, pass(self) ::
  ! procedure, pass(self) ::

  generic, public :: printSGtable => printSGtable_
  generic, public :: GetQCSpaceGroup => GetQCSpaceGroup_
  generic, public :: setnsg => setnsg_
  generic, public :: setSGnum => setSGnum_
  generic, public :: setNUMpt => setNUMpt_
  generic, public :: setMATnum => setMATnum_
  generic, public :: setQCtype => setQCtype_
  generic, public :: getnsg => getnsg_
  generic, public :: getSGnum => getSGnum_
  generic, public :: getNUMpt => getNUMpt_
  generic, public :: getMATnum => getMATnum_
  generic, public :: getnsym => getnsym_
  generic, public :: getQCtype => getQCtype_
  generic, public :: fillgen_QC => fillgen_QC_
  generic, public :: MakeQCGenerators => MakeQCGenerators_
  generic, public :: GenerateQCSymmetry => GenerateQCSymmetry_
  generic, public :: matrixmult => matrixmult_
  generic, public :: isnew => isnew_
  generic, public :: isitnew => isitnew_
  generic, public :: IsGAllowedQC => IsGAllowedQC_
  generic, public :: GetSymmetryOperators => GetSymmetryOperators_
  ! generic, public ::
  ! generic, public ::
  ! generic, public ::

end type QCspacegroup_T

! the constructor routine for this class
interface QCspacegroup_T
  module procedure QCspacegroup_constructor
end interface QCspacegroup_T

contains

!--------------------------------------------------------------------------
type(QCspacegroup_T) function QCspacegroup_constructor( nD, QCtype ) result(QCSG)
!DEC$ ATTRIBUTES DLLEXPORT :: QCspacegroup_constructor
!! author: MDG
!! version: 1.0
!! date: 01/30/22
!!
!! constructor for the QCspacegroup_T Class

IMPLICIT NONE

integer(kind=irg), INTENT(IN)   :: nD
character(3),INTENT(IN),OPTIONAL:: QCtype

if (nD.eq.3) then
! get the number of space groups in the SGname array
  QCSG%nsg = 11
  allocate( QCSG%data(6000,7,7)  )         !< all symmetry matrices for a given spacegroup
  allocate( QCSG%direc(6000,6,6) )         !< direct space point group matrices
  allocate( QCSG%recip(6000,6,6) )         !< reciprocal space point group matrices
  allocate( QCSG%icos(6,6,120))
  allocate( QCSG%c(7,7) )                  !< dummy matrix used for various computations
  allocate( QCSG%GL(QCSG%nsg), QCSG%SGname(QCSG%nsg) )
  QCSG%GL = GL_ico
  QCSG%SGname = SGname_ico
end if

if (nD.eq.2) then ! axial space groups
  call QCSG%setQCtype(QCtype)
  allocate( QCSG%data(200,6,6)  )         !< all symmetry matrices for a given spacegroup
  allocate( QCSG%direc(100,5,5) )         !< direct space point group matrices
  allocate( QCSG%recip(100,5,5) )         !< reciprocal space point group matrices
  allocate( QCSG%icos(5,5,40))
  allocate( QCSG%c(6,6) )                 !< dummy matrix used for various computations
! get the number of space groups in the SGname array; those names are constructed on the fly...
  call QCSG%getAxialGroupNames_()
end if

end function QCspacegroup_constructor

!--------------------------------------------------------------------------
subroutine QCspacegroup_destructor(self)
!DEC$ ATTRIBUTES DLLEXPORT :: QCspacegroup_destructor
!! author: MDG
!! version: 1.0
!! date: 01/30/22
!!
!! destructor for the QCcell_T Class

IMPLICIT NONE

type(QCspacegroup_T), INTENT(INOUT)  :: self

call reportDestructor('QCspacegroup_T')

end subroutine QCspacegroup_destructor

!--------------------------------------------------------------------------
recursive subroutine setnsg_(self, nsg)
!DEC$ ATTRIBUTES DLLEXPORT :: setnsg_
  !! author: MDG
  !! version: 1.0
  !! date: 01/13/20
  !!
  !! set nsg

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self
integer(kind=irg),INTENT(IN)          :: nsg

self%nsg= nsg

end subroutine setnsg_

!--------------------------------------------------------------------------
recursive function getnsg_(self) result(nsg)
!DEC$ ATTRIBUTES DLLEXPORT :: getnsg_
  !! author: MDG
  !! version: 1.0
  !! date: 01/13/20
  !!
  !! get nsg

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self
integer(kind=irg)                     :: nsg

nsg = self%nsg

end function getnsg_

!--------------------------------------------------------------------------
recursive subroutine setSGnum_(self, SGnum)
!DEC$ ATTRIBUTES DLLEXPORT :: setSGnum_
  !! author: MDG
  !! version: 1.0
  !! date: 01/13/20
  !!
  !! set SGnum

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self
integer(kind=irg),INTENT(IN)          :: SGnum

self%SGnum= SGnum

end subroutine setSGnum_

!--------------------------------------------------------------------------
recursive function getSGnum_(self) result(SGnum)
!DEC$ ATTRIBUTES DLLEXPORT :: getSGnum_
  !! author: MDG
  !! version: 1.0
  !! date: 01/13/20
  !!
  !! get SGnum

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self
integer(kind=irg)                     :: SGnum

SGnum = self%SGnum

end function getSGnum_

!--------------------------------------------------------------------------
recursive subroutine setNUMpt_(self, NUMpt)
!DEC$ ATTRIBUTES DLLEXPORT :: setNUMpt_
  !! author: MDG
  !! version: 1.0
  !! date: 01/13/20
  !!
  !! set NUMpt

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self
integer(kind=irg),INTENT(IN)          :: NUMpt

self%NUMpt= NUMpt

end subroutine setNUMpt_

!--------------------------------------------------------------------------
recursive function getNUMpt_(self) result(NUMpt)
!DEC$ ATTRIBUTES DLLEXPORT :: getNUMpt_
  !! author: MDG
  !! version: 1.0
  !! date: 01/13/20
  !!
  !! get NUMpt

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self
integer(kind=irg)                     :: NUMpt

NUMpt = self%NUMpt

end function getNUMpt_

!--------------------------------------------------------------------------
recursive subroutine setMATnum_(self, MATnum)
!DEC$ ATTRIBUTES DLLEXPORT :: setMATnum_
  !! author: MDG
  !! version: 1.0
  !! date: 01/13/20
  !!
  !! set MATnum

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self
integer(kind=irg),INTENT(IN)          :: MATnum

self%MATnum= MATnum

end subroutine setMATnum_

!--------------------------------------------------------------------------
recursive function getMATnum_(self) result(MATnum)
!DEC$ ATTRIBUTES DLLEXPORT :: getMATnum_
  !! author: MDG
  !! version: 1.0
  !! date: 01/13/20
  !!
  !! get MATnum

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self
integer(kind=irg)                     :: MATnum

MATnum = self%MATnum

end function getMATnum_

!--------------------------------------------------------------------------
recursive function getnsym_(self) result(nsym)
!DEC$ ATTRIBUTES DLLEXPORT :: getnsym_
  !! author: MDG
  !! version: 1.0
  !! date: 01/13/20
  !!
  !! get nsym

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self
integer(kind=irg)                     :: nsym

nsym = self%nsym

end function getnsym_

!--------------------------------------------------------------------------
recursive subroutine setQCtype_(self, QCtype)
!DEC$ ATTRIBUTES DLLEXPORT :: setQCtype_
  !! author: MDG
  !! version: 1.0
  !! date: 01/31/22
  !!
  !! set QCtype

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)    :: self
character(3),INTENT(IN)                 :: QCtype

self%QCtype = QCtype

end subroutine setQCtype_

!--------------------------------------------------------------------------
recursive function getQCtype_(self) result(QCtype)
!DEC$ ATTRIBUTES DLLEXPORT :: getQCtype_
  !! author: MDG
  !! version: 1.0
  !! date: 01/31/22
  !!
  !! get QCtype

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)    :: self
character(3)                            :: QCtype

QCtype = self%QCtype

end function getQCtype_

!--------------------------------------------------------------------------
!--------------------------------------------------------------------------
!--------------------------------------------------------------------------
!--------------------------------------------------------------------------
recursive subroutine printSGtable_(self)
!DEC$ ATTRIBUTES DLLEXPORT :: printSGtable_
!! author: MDG/SS
!! version: 1.0
!! date: 01/30/22
!!
!! list the space groups...
!!
!! Daniel Rokhsar, David Wright, David Mermin, Scale equivalence of
!! quasicrystallographic space groups, PHYS REV B, 37(14), 1987.

use mod_io

IMPLICIT NONE

class(QCspacegroup_T), INTENT(INOUT)  :: self

type(IO_T)                            :: Message

character(25)                         :: sgname1, sgname2
character(fnlen)                      :: str, str1
integer(kind=irg)                     :: ii, nsg

nsg = self%getnsg_()

if(mod(nsg,2) .ne. 0) then
  do ii = 1, floor(float(nsg)/2.0) + 1
    if(ii .lt. floor(float(nsg)/2.0) + 1) then
      write(str,'(I3,A)') 2*ii-1,':'
      write(str1,'(I3,A)') 2*ii,':'
      sgname1 = ''
      sgname2 = ''
      sgname1 = trim(self%SGname(2*ii-1))
      sgname2 = trim(self%SGname(2*ii))
      call Message%printMessage(trim(str)//' '//sgname1//trim(str1)//' '//sgname2)
    else
      write(str,'(I3,A)')2*ii-1,':'
      sgname1 = ''
      sgname1 = trim(self%SGname(2*ii-1))
      call Message%printMessage(trim(str)//sgname1)
    end if
  end do
else
  do ii = 1, nsg/2
    write(str,'(I3,A)')2*ii-1,':'
    write(str1,'(I3,A)')2*ii,': '
    sgname1 = ''
    sgname2 = ''
    sgname1 = trim(self%SGname(2*ii-1))
    sgname2 = trim(self%SGname(2*ii))
    call Message%printMessage(trim(str)//' '//sgname1//trim(str1)//' '//sgname2)
  end do
end if

end subroutine printSGtable_

!--------------------------------------------------------------------------
recursive subroutine getAxialGroupNames_(self)
!DEC$ ATTRIBUTES DLLEXPORT :: getAxialGroupNames_
!! author: MDG/SS
!! version: 1.0
!! date: 01/31/22
!!
!! generate the space group symbols for the axial groups of order 8, 10, or 12

use mod_io

class(QCspacegroup_T), INTENT(INOUT)  :: self

type(IO_T)                            :: Message

integer(kind=irg)                     :: n      ! axial rotational symmetry
character(1)                          :: lat    ! primitive or centered
character(fnlen)                      :: str, str1, str2    ! concatanate various symbols here
character(25)                         :: bspace, sgname1, sgname2
integer(kind=irg)                     :: nsg, styp, p, io_int(1), ii
logical                               :: pflag

! n is the rotational symmetry of the highest symmetry axis
! styp is the categorization of n based on the following conditions
! 1. styp == 1 for n power of odd prime e.g. 3-fold, 7-fold, 9-fold etc.
! 2. styp == 2 for n power of two e.g. 2-fold, 4-fold, 8-fold etc.
! 3. styp == 3 for n twice the power of odd prime e.g. 6-fold, 10-fold etc.
! 4. styp == 4 for n even but not twice a prime power e.g. 12-fold, 20-fold etc.
! 5. styp == 5 for n odd but not a prime power e.g. 15-fold, 21-fold etc.

if(trim(self%getQCtype_()) .eq. 'Oct') then
  n     = 8
  styp  = 2
else if(trim(self%getQCtype_()) .eq. 'Dec') then
  n     = 10
  styp  = 3
else if(trim(self%getQCtype_()) .eq. 'DoD') then
  n     = 12
  styp  = 4
else
  call Message%printError('getAxialGroupNames_:','only 8, 10 and 12 fold symmetries have been implemented thus far.')
end if

call Message%printMessage('')
select case(styp)
  case(2)
    nsg = 57 + 3*(n - 1) + 2*(n/2 - 1)
    call self%setnsg_(nsg)
    io_int(1) = nsg
    write(str,'(I2)') n
    call Message%WriteValue('Number of space groups for axial symmetry of '//trim(str)//' = ',io_int,1,'(I3,/)')
    if(.not.(allocated(self%SGname))) allocate(self%SGname(nsg))
    self%SGname = ''

  case(3)
    nsg = 17 + 2*(n - 1)
    call self%setnsg_(nsg)
    io_int(1) = nsg
    write(str,'(I2)') n
    call Message%WriteValue('Number of space groups for axial symmetry of '//trim(str)//' = ',io_int,1,'(I3,/)')
    if(.not.(allocated(self%SGname))) allocate(self%SGname(nsg))

    ! fill out the names and print on screen
    write(str1,'(I6)') n
    str1 = adjustl(str1)
    write(str,'(A,A)')'P',trim(str1)
    self%SGname(1) = trim(str)

    write(str1,'(I6)') -n
    str1 = adjustl(str1)
    write(str,'(A,A)')'P',trim(str1)
    self%SGname(2) = trim(str)

    do ii = 3, n+1
      write(str1,'(I6)') ii-2
      str1 = adjustl(str1)
      str1 = '_'//trim(str1)
      write(str2,'(I6,A)') n,trim(str1)
      str2 = adjustl(str2)
      write(str,'(A,A)')'P',trim(str2)
      self%SGname(ii) = trim(str)
    end do

    write(str1,'(I6)') n
    str1 = adjustl(str1)
    str1 = trim(str1)//' 2 2'
    write(str,'(A,A)')'P',trim(str1)
    self%SGname(n+2) = trim(str)

    do ii = n+3, 2*n+1
      write(str1,'(I6)') ii-n-2
      str1 = adjustl(str1)
      str1 = '_'//trim(str1)//' 2 2'
      write(str2,'(I6,A)') n,trim(str1)
      str2 = adjustl(str2)
      write(str,'(A,A)')'P',trim(str2)
      self%SGname(ii) = trim(str)
    end do

    write(str1,'(I6)') -n
    str1 = adjustl(str1)
    self%SGname(2*n+2) = 'P'//trim(str1)//' m 2'
    self%SGname(2*n+3) = 'P'//trim(str1)//' c 2'
    self%SGname(2*n+4) = 'P'//trim(str1)//' 2 m'
    self%SGname(2*n+5) = 'P'//trim(str1)//' 2 c'

    write(str1,'(I6)') n
    str1 = adjustl(str1)
    write(str2,'(I6)') n/2
    str2 = adjustl(str2)

    self%SGname(2*n+6) = 'P'//trim(str1)//' m m'
    self%SGname(2*n+7) = 'P'//trim(str1)//' c c'
    self%SGname(2*n+8) = 'P'//trim(str1)//'_'//trim(str2)//' m c'
    self%SGname(2*n+9) = 'P'//trim(str1)//'_'//trim(str2)//' c m'

    self%SGname(2*n+10) = 'P'//trim(str1)//' / m'
    self%SGname(2*n+11) = 'P'//trim(str1)//'_'//trim(str2)//' / m'
    self%SGname(2*n+12) = 'P'//trim(str1)//' / m 2 / m 2 / m'
    self%SGname(2*n+13) = 'P'//trim(str1)//'/ m 2 / c 2 / c'
    self%SGname(2*n+14) = 'P'//trim(str1)//'_'//trim(str2)//' / m 2 / m 2 / c'
    self%SGname(2*n+15) = 'P'//trim(str1)//'_'//trim(str2)//' / m 2 / c 2 / m'

  case(4)
    nsg = 13 + 2*(n - 1)
    call self%setnsg_(nsg)
    io_int(1) = nsg
    write(str,'(I2)') n
    call Message%WriteValue('Number of space groups for axial symmetry of '//trim(str)//' = ',io_int,1,'(I3,/)')
    if(.not.(allocated(self%SGname))) allocate(self%SGname(nsg))

    write(str1,'(I6)') n
    str1 = adjustl(str1)
    write(str,'(A,A)')'P',trim(str1)
    self%SGname(1) = trim(str)

    write(str1,'(I6)') -n
    str1 = adjustl(str1)
    write(str,'(A,A)')'P',trim(str1)
    self%SGname(2) = trim(str)

    do ii = 3, n+1
      write(str1,'(I6)') ii-2
      str1 = adjustl(str1)
      str1 = '_'//trim(str1)
      write(str2,'(I6,A)') n,trim(str1)
      str2 = adjustl(str2)
      write(str,'(A,A)')'P',trim(str2)
      self%SGname(ii) = trim(str)
    end do

    write(str1,'(I6)') n
    str1 = adjustl(str1)
    str1 = trim(str1)//' 2 2'
    write(str,'(A,A)')'P',trim(str1)
    self%SGname(n+2) = trim(str)

    do ii = n+3, 2*n+1
      write(str1,'(I6)') ii-n-2
      str1 = adjustl(str1)
      str1 = '_'//trim(str1)//' 2 2'
      write(str2,'(I6,A)') n,trim(str1)
      str2 = adjustl(str2)
      write(str,'(A,A)')'P',trim(str2)
      self%SGname(ii) = trim(str)
    end do

    write(str1,'(I6)') -n
    str1 = adjustl(str1)
    self%SGname(2*n+2) = 'P'//trim(str1)//' 2 m'
    self%SGname(2*n+3) = 'P'//trim(str1)//' 2 c'

    write(str1,'(I6)') n
    str1 = adjustl(str1)
    write(str2,'(I6)') n/2
    str2 = adjustl(str2)

    self%SGname(2*n+4) = 'P'//trim(str1)//' m m'
    self%SGname(2*n+5) = 'P'//trim(str1)//' c c'
    self%SGname(2*n+6) = 'P'//trim(str1)//'_'//trim(str2)//' c m'

    self%SGname(2*n+7) = 'P'//trim(str1)//' / m'
    self%SGname(2*n+8) = 'P'//trim(str1)//'_'//trim(str2)//' / m'
    self%SGname(2*n+9) = 'P'//trim(str1)//' / m 2 / m 2 / m'
    self%SGname(2*n+10) = 'P'//trim(str1)//'/ m 2 / c 2 / c'
    self%SGname(2*n+11) = 'P'//trim(str1)//'_'//trim(str2)//' / m 2 / c 2 / m'

  case DEFAULT
    call Message%printError('getAxialGroupNames_:','n-fold axis couldn''t be categorized into one of the 5 categories. &
      see: The space groups of axial crystals and quasicrystals, REVIEW OF MODERN PHYSICS, 63(3), 1991');
end select

end subroutine getAxialGroupNames_

!--------------------------------------------------------------------------
recursive subroutine GetQCSpaceGroup_(self)
!DEC$ ATTRIBUTES DLLEXPORT :: GetQCSpaceGroup_
!! author: MDG/SS
!! version: 1.0
!! date: 01/30/22
!!
!! ask the user for space group number

use mod_io

class(QCspacegroup_T), INTENT(INOUT)  :: self

type(IO_T)                            :: Message

integer(kind=irg)                     :: io_int(1)

 ! get the space group number
 call Message%printMessage('Enter space group number', frm = "(//A)")

 call Message%ReadValue('    Space group number --> ', io_int, 1)
 self%SGnum = io_int(1)

end subroutine GetQCSpaceGroup_

!--------------------------------------------------------------------------
recursive subroutine fillgen_QC_(self, t)
!DEC$ ATTRIBUTES DLLEXPORT :: fillgen_QC_
!! author: MDG/SS
!! version: 1.0
!! date: 02/01/22
!!
!! fills in a generator matrix based on an input string

IMPLICIT NONE

class(QCspacegroup_T),INTENT(INOUT)         :: self
character(1),INTENT(IN)                     :: t(7) !< 7-character input string
integer(kind=irg)                           :: j    !< auxiliary variable

! first fill the array with zeroes and a 1 at 4,4
 self%c(1:7,1:7) = 0.0D0
 self%c(7,7)     = 1.0D0

! then check for the particular matrix type
 select case (t(1))
 case('a')
  self%c(1,1) = 1.0D0; self%c(2,2) = 1.0D0; self%c(3,3) = 1.0D0
  self%c(4,4) = 1.0D0; self%c(5,5) = 1.0D0; self%c(6,6) = 1.0D0
 case('b')
  self%c(1,1) = 1.0D0; self%c(6,2) = 1.0D0; self%c(2,3) = 1.0D0
  self%c(3,4) = 1.0D0; self%c(4,5) = 1.0D0; self%c(5,6) = 1.0D0
 case('c')
  self%c(2,1) =  1.0D0; self%c(6,2) = 1.0D0; self%c(4,3) = -1.0D0
  self%c(5,4) = -1.0D0; self%c(3,5) = 1.0D0; self%c(1,6) =  1.0D0
 case('d')
  self%c(1,1) = -1.0D0; self%c(2,2) = -1.0D0; self%c(3,3) = -1.0D0
  self%c(4,4) = -1.0D0; self%c(5,5) = -1.0D0; self%c(6,6) = -1.0D0
 end select

! then fill in the translational component
 do j=1,6
  select case (t(j+1))
   case('A'); self%c(j,7) = 1.0D0/5.0D0
   case('B'); self%c(j,7) = 1.0D0/2.0D0
  end select
 end do

end subroutine fillgen_QC_

!--------------------------------------------------------------------------
recursive subroutine GenerateQCSymmetry_(self, dopg)
!DEC$ ATTRIBUTES DLLEXPORT :: GenerateQCSymmetry_
!! author: MDG/SS
!! version: 1.0
!! date: 02/01/22
!!
!! compute all relevant symmetry operators

use mod_io

IMPLICIT NONE

class(QCspacegroup_T),INTENT(INOUT)       :: self
logical,INTENT(IN)                        :: dopg

type(IO_T)                                :: Message

integer(kind=irg)                         :: i,j,k,nsym,k1,k2,l1,l2,sg(4),sgnum, io_int(1) !< loop counters (mostly)
real(kind=dbl)                            :: q,sm, eps                    !< auxiliary variables.

eps = 0.1D0

! create the space group generator matrices
call self%MakeQCGenerators()
call Message%printMessage(' Created generator matrices ')

if (self%getQCtype().eq.'Ico') then
  sg = (/5,6,10,11/)
  do k = 1,4
   if(self%SGnum .eq. sg(k) ) then
    call Message%printMessage('--> Face-centered Icosahedral quasicrystal detected. Generating space group symmetry. ')
   end if
  end do

  nsym = self%GENnum
  sgnum = self%getSGnum()

  ! generate new elements from the squares of the generators
   do k=1,self%GENnum
    call self%matrixmult(k,k)
    if (self%isitnew_(nsym).eqv..TRUE.) then
     nsym=nsym+1
     self%data(nsym,:,:) = self%c(:,:)
    end if
   end do

   io_int(1) = SGorder_ico(sgnum)
   call Message%WriteValue(' Creating factor group with ', io_int, 1,"(I5,' elements')")
  ! generate the remainder of the factorgroup
   k1=1
   do while (k1.le.nsym)
    k2=k1+1
    do while (k2.le.nsym)
     call self%matrixmult(k2,k1)
     if (self%isitnew_(nsym).eqv..TRUE.) then
      nsym=nsym+1
      self%data(nsym,:,:) = self%c(:,:)
     end if
     if (nsym.eq.SGorder_ico(sgnum)) then  ! we stop when we have them all
      k1 = nsym
      k2 = nsym
     end if
     k2=k2+1
    end do
    k1=k1+1
   end do
   self%MATnum = nsym
   self%nsym = nsym
   call Message%printMessage(' ---> Factor group completed ')

  ! reduce the translation operators to the fundamental unit cell
   do i=1,self%MATnum
     self%data(i,6,7)=mod( self%data(i,6,7),1.0_dbl)
   end do

  ! generate point group symmetry if flag is passed
  if(dopg.eqv..TRUE.) then
    call Message%printMessage(' creating point group matrices')
    self%NUMpt = 0
    do i = 1,self%MATnum
      sm = 0.D0
      do j = 1,6
        sm = sm + self%data(i,j,7)**2
      end do
      if(sm .lt. eps) then
        self%NUMpt = self%NUMpt + 1
        self%direc(self%NUMpt,1:6,1:6) = self%data(i,1:6,1:6)
      end if
    end do
    call Message%printMessage(' ----> completed')
  end if
else ! axial space groups
   nsym = self%GENnum
! generate new elements from the squares of the generators
   do k=1,self%GENnum
    call self%matrixmult(k,k)
    if (self%isitnew(nsym).eqv..TRUE.) then
     nsym=nsym+1
     self%data(nsym,:,:) = self%c(:,:)
    end if
   end do

  ! generate the remainder of the factorgroup
   k1=1
   do while (k1.le.nsym)
    k2=k1+1
    do while (k2.le.nsym)
     call self%matrixmult(k2,k1)
     if (self%isitnew(nsym).eqv..TRUE.) then
      nsym=nsym+1
      self%data(nsym,:,:) = self%c(:,:)
     end if
     k2=k2+1
    end do
    k1=k1+1
   end do
   self%MATnum = nsym

  ! reduce the translation operators to the fundamental unit cell
   do i=1,self%MATnum
     self%data(i,5,6)=mod( self%data(i,5,6),1.0_dbl)
   end do

  ! generate point group symmetry if flag is passed
  if(dopg) then
    self%NUMpt = 0
    do i = 1,self%MATnum
      sm = 0.D0
      do j = 1,5
        sm = sm + self%data(i,j,6)**2
      end do
      if(sm .lt. eps) then
        self%NUMpt = self%NUMpt + 1
        self%direc(self%NUMpt,1:5,1:5) = self%data(i,1:5,1:5)
      end if
    end do
  end if
  self%MATnum = nsym
  self%nsym = nsym
end if

end subroutine GenerateQCSymmetry_

!--------------------------------------------------------------------------
recursive subroutine MakeQCGenerators_(self)
!DEC$ ATTRIBUTES DLLEXPORT :: MakeQCGenerators_
!! author: MDG/SS
!! version: 1.0
!! date: 02/01/22
!!
!! get all the QC generators

IMPLICIT NONE

class(QCspacegroup_T),INTENT(INOUT)       :: self

real(kind=dbl),allocatable                :: g1(:,:), g2(:,:), g3(:,:)
character(100)                            :: genst                        !< full generator string
character(1)                              :: t(7), ngen
integer(kind=irg)                         :: i, k, l

if (self%getQCtype().eq.'Ico') then
  allocate( g1(6,6), g2(6,6), g3(6,6) )
  genst = trim(self%GL(self%SGnum))

  write (*,*) ' genst = ', genst

  ngen = genst(1:1)

  read(ngen,*) self%GENnum

  ! create the generator matrices
  do i = 1,self%GENnum
    do  k = 1,7
        l = 1 + 7*(i-1) + k
        t(k) = genst(l:l)
    end do
    call self%fillgen_QC(t)
    self%data(i,:,:) = self%c(:,:)
  end do
else
  allocate( g1(5,5), g2(5,5), g3(5,5) )
  if(self%getQCtype().eq.'Dec') then
    g1(1,1:5) = (/0.D0, 0.D0, 0.D0, -1.D0, 0.D0/)
    g1(2,1:5) = (/1.D0, 1.D0, 1.D0, 1.D0, 0.D0/)
    g1(3,1:5) = (/-1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
    g1(4,1:5) = (/0.D0, -1.D0, 0.D0, 0.D0, 0.D0/)
    g1(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)

    g2(1,1:5) = (/0.D0, 0.D0, 0.D0, -1.D0, 0.D0/)
    g2(2,1:5) = (/0.D0, 0.D0, -1.D0, 0.D0, 0.D0/)
    g2(3,1:5) = (/0.D0, -1.D0, 0.D0, 0.D0, 0.D0/)
    g2(4,1:5) = (/-1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
    g2(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)

    g3(1,1:5) = (/-1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
    g3(2,1:5) = (/0.D0, -1.D0, 0.D0, 0.D0, 0.D0/)
    g3(3,1:5) = (/0.D0, 0.D0, -1.D0, 0.D0, 0.D0/)
    g3(4,1:5) = (/0.D0, 0.D0, 0.D0, -1.D0, 0.D0/)
    g3(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, -1.D0/)

    ! generator r^1/2
    self%data(1,1:6,1:6) = 0.D0
    self%data(1,6,6)     = 1.D0

    self%data(1,1:5,1:5) = g1(1:5,1:5)
    self%data(1,5,6)     = 0.5D0

    ! generator h (primary m) + translation
    self%data(2,1:6,1:6) = 0.D0
    self%data(2,6,6)     = 1.D0

    self%data(2,1:5,1:5) = g2(1:5,1:5)
    self%data(2,5,6)     = 0.5D0

    ! generator m (secondary m)
    self%data(3,1:6,1:6) = 0.D0
    self%data(3,6,6)     = 1.D0

    self%data(3,1:5,1:5) = g3(1:5,1:5)

  else if(self%getQCtype().eq.'Oct') then
    g1(1,1:5) = (/0.D0, 0.D0, 0.D0, -1.D0, 0.D0/)
    g1(2,1:5) = (/1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
    g1(3,1:5) = (/0.D0, 1.D0, 0.D0, 0.D0, 0.D0/)
    g1(4,1:5) = (/0.D0, 0.D0, 1.D0, 0.D0, 0.D0/)
    g1(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)

    g2(1,1:5) = (/0.D0, 0.D0, 0.D0, 1.D0, 0.D0/)
    g2(2,1:5) = (/0.D0, 0.D0, 1.D0, 0.D0, 0.D0/)
    g2(3,1:5) = (/0.D0, 1.D0, 0.D0, 0.D0, 0.D0/)
    g2(4,1:5) = (/1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
    g2(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 0.D0/)

    g3(1,1:5) = (/-1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
    g3(2,1:5) = (/0.D0, -1.D0, 0.D0, 0.D0, 0.D0/)
    g3(3,1:5) = (/0.D0, 0.D0, -1.D0, 0.D0, 0.D0/)
    g3(4,1:5) = (/0.D0, 0.D0, 0.D0, -1.D0, 0.D0/)
    g3(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, -1.D0/)

    self%data(1,1:6,1:6) = 0.D0
    self%data(1,6,6)     = 1.D0

    self%data(1,1:5,1:5) = g1(1:5,1:5)
    self%data(1,5,6)     = 0.5D0

    ! generator h (primary m) + translation
    self%data(2,1:6,1:6) = 0.D0
    self%data(2,6,6)     = 1.D0

    self%data(2,1:5,1:5) = g2(1:5,1:5)
    self%data(2,5,6)     = 0.5D0

    ! generator m (secondary m)
    self%data(3,1:6,1:6) = 0.D0
    self%data(3,6,6)     = 1.D0

    self%data(3,1:5,1:5) = g3(1:5,1:5)

  else if(self%getQCtype().eq.'DoD') then

    g1(1,1:5) = (/0.D0, 1.D0, 0.D0, -1.D0, 0.D0/)
    g1(2,1:5) = (/1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
    g1(3,1:5) = (/0.D0, 1.D0, 0.D0, 0.D0, 0.D0/)
    g1(4,1:5) = (/0.D0, 0.D0, 1.D0, 0.D0, 0.D0/)
    g1(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)

    g2(1,1:5) = (/0.D0, 0.D0, 0.D0, 1.D0, 0.D0/)
    g2(2,1:5) = (/0.D0, 0.D0, 1.D0, 0.D0, 0.D0/)
    g2(3,1:5) = (/0.D0, 1.D0, 0.D0, 0.D0, 0.D0/)
    g2(4,1:5) = (/1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
    g2(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)

    g3(1,1:5) = (/-1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
    g3(2,1:5) = (/0.D0, -1.D0, 0.D0, 0.D0, 0.D0/)
    g3(3,1:5) = (/0.D0, 0.D0, -1.D0, 0.D0, 0.D0/)
    g3(4,1:5) = (/0.D0, 0.D0, 0.D0, -1.D0, 0.D0/)
    g3(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, -1.D0/)

    self%data(1,1:6,1:6) = 0.D0
    self%data(1,6,6)     = 1.D0

    self%data(1,1:5,1:5) = g1(1:5,1:5)
    self%data(1,5,6)     = 0.0D0

    ! generator h (primary m) + translation
    self%data(2,1:6,1:6) = 0.D0
    self%data(2,6,6)     = 1.D0

    self%data(2,1:5,1:5) = g2(1:5,1:5)
    self%data(2,5,6)     = 0.0D0

    ! generator m (secondary m)
    self%data(3,1:6,1:6) = 0.D0
    self%data(3,6,6)     = 1.D0

    self%data(3,1:5,1:5) = g3(1:5,1:5)
  end if

  self%GENnum = 3
end if

end subroutine MakeQCGenerators_

!--------------------------------------------------------------------------
recursive subroutine matrixmult_(self, k1, k2)
!DEC$ ATTRIBUTES DLLEXPORT :: matrixmult_
!! author: MDG/SS
!! version: 1.0
!! date: 02/01/22
!!
!! multiplies symmetry matrices together

IMPLICIT NONE

class(QCspacegroup_T),INTENT(INOUT)   :: self
integer(kind=irg),INTENT(IN)          :: k1              !< index of first 6x6 input matrix
integer(kind=irg),INTENT(IN)          :: k2              !< index of second 6x6 input matrix

integer(kind=irg)                     :: i,j,k,nn        !< loop counters
real(kind=dbl),parameter              :: eps=0.0005_dbl  !< truncation constant

if (self%getQCtype_().eq.'Ico') then
  nn = 7
else
  nn = 6
end if

do i=1,nn
  do j=1,nn
    self%c(i,j) = 0.0_dbl
    do k=1,nn
      self%c(i,j)=self%c(i,j)+self%data(k1,i,k)*self%data(k2,k,j)
    end do
  end do
end do

! bring the translational part of the matrix back to
! the first unit cell and correct possible rounding errors
if (self%getQCtype_().eq.'Ico') then
  do k = 1,6
    if (abs(self%c(k,7)).lt.eps) self%c(k,7)=0.0_dbl
    if (self%c(k,7).lt.0.0_dbl) then
     do while (self%c(k,7).lt.0.0_dbl)
      self%c(k,7)=self%c(k,7)+1.0_dbl
     end do
    end if
    if (self%c(k,7).gt.1.0_dbl) then
     do while (self%c(k,7).gt.1.0_dbl)
      self%c(k,7)=self%c(k,7)-1.0_dbl
     end do
    end if
    if (abs(self%c(k,7)-1.0_dbl).lt.eps) self%c(k,7)=0.0_dbl
  end do
else
! only a_5 is checked since the other are always 0
  if (abs(self%c(5,6)).lt.eps) self%c(5,6)=0.0_dbl
  if (self%c(5,6).lt.0.0_dbl) then
   do while (self%c(5,6).lt.0.0_dbl)
    self%c(5,6)=self%c(5,6)+1.0_dbl
   end do
  end if
  if (self%c(5,6).gt.1.0_dbl) then
   do while (self%c(5,6).gt.1.0_dbl)
    self%c(5,6)=self%c(5,6)-1.0_dbl
   end do
  end if
  if (abs(self%c(5,6)-1.0_dbl).lt.eps) self%c(5,6)=0.0_dbl
end if

end subroutine matrixmult_

!--------------------------------------------------------------------------
recursive function MatrixPower_(s, A, n) result(B)
!DEC$ ATTRIBUTES DLLEXPORT :: MatrixPower_
!! author: MDG/SS
!! version: 1.0
!! date: 02/01/22
!!
!! multiplies symmetry matrices together

IMPLICIT NONE

integer(kind=irg),INTENT(IN)          :: s
real(kind=dbl),INTENT(IN)             :: A(s,s)
integer(kind=irg),INTENT(IN)          :: n

real(kind=dbl)                        :: B(s,s), tmp(s,s)
integer(kind=irg)                     :: i, m

if (n.eq.0) then
  B = 0.D0
  do i = 1,m
    B(i,i) = 1.D0
  end do
else if (n.eq.1) then
  B = A
else if (n.gt.1) then
  tmp = A
  do i = 1,n-1
    tmp = matmul(A, tmp)
  end do
  B = tmp
end if

end function MatrixPower_

!--------------------------------------------------------------------------
recursive subroutine GetSymmetryOperators_(self)
!DEC$ ATTRIBUTES DLLEXPORT :: GetSymmetryOperators_
!! author: MDG/SS
!! version: 1.0
!! date: 02/01/22
!!
!! generate all symmetry operators using the generators in 6 index notation.
!! The generators are borrowed from:
!! F. Gahler, CRYSTALLOGRAPHY OF DODECAGONAL QUASICRYSTALS  (Dodecahedral, Decahedral, Octahedral)
!! T. Janssen, Crystallography of Quasi-Crystals, Acta Cryst. (1986). A42, 261-271 (Icosahedral)

IMPLICIT NONE

class(QCspacegroup_T),INTENT(INOUT)   :: self

real(kind=dbl),allocatable            :: g1(:,:), g2(:,:), g3(:,:), O1(:,:,:), O2(:,:,:), O3(:,:,:), O(:,:)
integer(kind=irg)                     :: ii, jj, kk, nsym, nsym2

if (self%getQCtype_().eq.'DoD') then
  allocate(g1(5,5), g2(5,5), g3(5,5),O1(5,5,12),O2(5,5,2), O3(5,5,2), O(5,5))

  g1(1,1:5) = (/0.D0, 1.D0, 0.D0, -1.D0, 0.D0/)
  g1(2,1:5) = (/1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
  g1(3,1:5) = (/0.D0, 1.D0, 0.D0, 0.D0, 0.D0/)
  g1(4,1:5) = (/0.D0, 0.D0, 1.D0, 0.D0, 0.D0/)
  g1(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)

  g2(1,1:5) = (/0.D0, 0.D0, 0.D0, 1.D0, 0.D0/)
  g2(2,1:5) = (/0.D0, 0.D0, 1.D0, 0.D0, 0.D0/)
  g2(3,1:5) = (/0.D0, 1.D0, 0.D0, 0.D0, 0.D0/)
  g2(4,1:5) = (/1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
  g2(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)

! generate all powers of the matrix
  do ii = 1,12
    O1(:,:,ii) = MatrixPower_(5,g1,ii)
    if(ii .le. 2) then
      O2(:,:,ii) = MatrixPower_(5,g2,ii)
    end if
  end do

! combine the rotations and mirrors to generate all 24 operators
! START WITH IDENTITY OPERATOR
  nsym = 1
  self%icos = 0.D0
  do ii = 1,5
    self%icos(ii,ii,1) = 1.D0
  end do

  do ii = 1,12
    O = O1(:,:,ii)
    if(self%isnew_(5, O, nsym)) then
      nsym = nsym + 1
      self%icos(:,:,nsym) = O(1:5,1:5)
    end if
  end do

  do ii = 1,2
    O = O2(:,:,ii)
    if(self%isnew_(5, O, nsym)) then
      nsym = nsym + 1
      self%icos(:,:,nsym) = O(1:5,1:5)
    end if
  end do

  ! go through all combinations two at a time (2 possible configurations)
  do ii = 1,12
    do jj = 1,2
      O = matmul(O1(:,:,ii), O2(:,:,jj))
      if(self%isnew_(5, O, nsym)) then
        nsym = nsym + 1
        self%icos(:,:,nsym) = O(1:5,1:5)
      end if

      O = matmul(O2(:,:,jj), O1(:,:,ii))
      if(self%isnew_(5, O, nsym)) then
        nsym = nsym + 1
        self%icos(:,:,nsym) = O(1:5,1:5)
      end if

    end do
  end do

  self%nsym = nsym
end if

if (self%getQCtype_().eq.'Dec') then
  allocate(g1(5,5), g2(5,5), g3(5,5),O1(5,5,10),O2(5,5,2), O3(5,5,2), O(5,5))

  g1(1,:) = (/0.D0,-1.D0,1.D0,0.D0,0.D0/)
  g1(2,:) = (/0.D0,-1.D0,0.D0,1.D0,0.D0/)
  g1(3,:) = (/0.D0,-1.D0,0.D0,0.D0,0.D0/)
  g1(4,:) = (/1.D0,-1.D0,0.D0,0.D0,0.D0/)
  g1(5,:) = (/0.D0,0.D0,0.D0,0.D0,1.D0/)

  ! generate all powers of the matrix
  do ii = 1,4
    O1(:,:,ii) = MatrixPower_(5,g1,ii)
  end do

! combine the rotations and mirrors to generate all 24 operators
! START WITH IDENTITY OPERATOR
  nsym = 1
  self%icos = 0.D0
  do ii = 1,5
    self%icos(ii,ii,1) = 1.D0
  end do

  do ii = 1,4
    O = O1(:,:,ii)
    if(self%isnew_(5, O, nsym)) then
      nsym = nsym + 1
      self%icos(:,:,nsym) = O(1:5,1:5)
    end if
  end do
  self%nsym = nsym
end if

if (self%getQCtype_().eq.'Oct') then
  allocate(g1(5,5), g2(5,5), g3(5,5),O1(5,5,8),O2(5,5,2), O3(5,5,2), O(5,5))

  g1(1,1:5) = (/0.D0, 0.D0, 0.D0, -1.D0, 0.D0/)
  g1(2,1:5) = (/1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
  g1(3,1:5) = (/0.D0, 1.D0, 0.D0, 0.D0, 0.D0/)
  g1(4,1:5) = (/0.D0, 0.D0, 1.D0, 0.D0, 0.D0/)
  g1(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)

  g2(1,1:5) = (/0.D0, 0.D0, 0.D0, 1.D0, 0.D0/)
  g2(2,1:5) = (/0.D0, 0.D0, 1.D0, 0.D0, 0.D0/)
  g2(3,1:5) = (/0.D0, 1.D0, 0.D0, 0.D0, 0.D0/)
  g2(4,1:5) = (/1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
  g2(5,1:5) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)

  ! generate all powers of the matrix
  do ii = 1,8
    O1(:,:,ii) = MatrixPower_(5,g1,ii)
    if(ii .le. 2) then
      O2(:,:,ii) = MatrixPower_(5,g2,ii)
    end if
  end do

  ! combine the rotations and mirrors to generate all 24 operators
  ! START WITH IDENTITY OPERATOR
  nsym = 1
  self%icos = 0.D0
  do ii = 1,5
    self%icos(ii,ii,1) = 1.D0
  end do

  do ii = 1,8
    O = O1(:,:,ii)
    if(self%isnew_(5, O, nsym)) then
      nsym = nsym + 1
      self%icos(:,:,nsym) = O(1:5,1:5)
    end if
  end do

  do ii = 1,2
    O = O2(:,:,ii)
    if(self%isnew_(5, O, nsym)) then
      nsym = nsym + 1
      self%icos(:,:,nsym) = O(1:5,1:5)
    end if
  end do

  ! go through all combinations two at a time (2 possible configurations)
  do ii = 1,8
    do jj = 1,2
      O = matmul(O1(:,:,ii), O2(:,:,jj))
      if(self%isnew_(5, O, nsym)) then
        nsym = nsym + 1
        self%icos(:,:,nsym) = O(1:5,1:5)
      end if

      O = matmul(O2(:,:,jj), O1(:,:,ii))
      if(self%isnew_(5, O, nsym)) then
        nsym = nsym + 1
        self%icos(:,:,nsym) = O(1:5,1:5)
      end if

    end do
  end do

  self%nsym = nsym
end if

if (self%getQCtype_().eq.'Ico') then
  allocate(g1(6,6), g2(6,6), g3(6,6),O1(6,6,5),O2(6,6,6), O3(6,6,2), O(6,6))

  g1(1,:) = (/1.D0, 0.D0, 0.D0, 0.D0, 0.D0, 0.D0/)
  g1(2,:) = (/0.D0, 0.D0, 1.D0, 0.D0, 0.D0, 0.D0/)
  g1(3,:) = (/0.D0, 0.D0, 0.D0, 1.D0, 0.D0, 0.D0/)
  g1(4,:) = (/0.D0, 0.D0, 0.D0, 0.D0, 1.D0, 0.D0/)
  g1(5,:) = (/0.D0, 0.D0, 0.D0, 0.D0, 0.D0, 1.D0/)
  g1(6,:) = (/0.D0, 1.D0, 0.D0, 0.D0, 0.D0, 0.D0/)

  g2(1,:) = (/0.D0, 0.D0, 0.D0,  0.D0, 0.D0, 1.D0/)
  g2(2,:) = (/1.D0, 0.D0, 0.D0,  0.D0, 0.D0, 0.D0/)
  g2(3,:) = (/0.D0, 0.D0, 0.D0,  0.D0, 1.D0, 0.D0/)
  g2(4,:) = (/0.D0, 0.D0, -1.D0, 0.D0, 0.D0, 0.D0/)
  g2(5,:) = (/0.D0, 0.D0, 0.D0, -1.D0, 0.D0, 0.D0/)
  g2(6,:) = (/0.D0, 1.D0, 0.D0,  0.D0, 0.D0, 0.D0/)

  ! Inversion operator
  g3 = 0.D0
  do ii = 1,6
    g3(ii,ii) = -1.D0
  end do

  do ii = 1,5
    O1(:,:,ii) = MatrixPower_(6, g1, ii)
  end do

  do ii = 1,3
    O2(:,:,ii)  = MatrixPower_(6, g2, ii)
  end do

  do ii = 1,2
    O3(:,:,ii) = MatrixPower_(6, g3, ii)
  end do

  ! START WITH IDENTITY OPERATOR
  nsym = 1
  self%icos = 0.D0
  do ii = 1,6
    self%icos(ii,ii,1) = 1.D0
  end do

  ! go through all combinations one at a time (2 possible configurations)

  do ii = 1,5
    O = O1(:,:,ii)
    if(self%isnew_(6, O, nsym)) then
      nsym = nsym + 1
      self%icos(:,:,nsym) = O(1:6,1:6)
    end if
  end do

  do ii = 1,3
    O = O2(:,:,ii)
    if(self%isnew_(6, O, nsym)) then
      nsym = nsym + 1
      self%icos(:,:,nsym) = O(1:6,1:6)
    end if
  end do

  ! go through all combinations two at a time (2 possible configurations)
  do ii = 1,5
    do jj = 1,3
      O = matmul(O1(:,:,ii), O2(:,:,jj))
      if(self%isnew_(6, O, nsym)) then
        nsym = nsym + 1
        self%icos(:,:,nsym) = O(1:6,1:6)
      end if

      O = matmul(O2(:,:,jj), O1(:,:,ii))
      if(self%isnew_(6, O, nsym)) then
        nsym = nsym + 1
        self%icos(:,:,nsym) = O(1:6,1:6)
      end if
    end do
  end do

  ! now multiply all the genrators with the already existing symmetry operators
  ! in the SYM_icos matrix
  nsym2 = nsym
  do ii = 1,5
    do jj = 1,nsym2
      O = matmul(O1(:,:,ii),self%icos(:,:,jj))
      if(self%isnew_(6, O, nsym)) then
          nsym = nsym + 1
          self%icos(:,:,nsym) = O(1:6,1:6)
        end if

        O = matmul(self%icos(:,:,jj), O1(:,:,ii))
        if(self%isnew_(6, O, nsym)) then
          nsym = nsym + 1
          self%icos(:,:,nsym) = O(1:6,1:6)
        end if

    end do
  end do

  nsym2 = nsym
  do ii = 1,3
    do jj = 1,nsym2
      O = matmul(O2(:,:,ii),self%icos(:,:,jj))
      if(self%isnew_(6, O, nsym)) then
          nsym = nsym + 1
          self%icos(:,:,nsym) = O(1:6,1:6)
        end if

        O = matmul(self%icos(:,:,jj), O2(:,:,ii))
        if(self%isnew_(6, O, nsym)) then
          nsym = nsym + 1
          self%icos(:,:,nsym) = O(1:6,1:6)
        end if

    end do
  end do

  nsym2 = nsym
  do ii = 1,5
    do jj = 1,nsym2
      O = matmul(O1(:,:,ii),self%icos(:,:,jj))
      if(self%isnew_(6, O, nsym)) then
          nsym = nsym + 1
          self%icos(:,:,nsym) = O(1:6,1:6)
        end if

        O = matmul(self%icos(:,:,jj), O1(:,:,ii))
        if(self%isnew_(6, O, nsym)) then
          nsym = nsym + 1
          self%icos(:,:,nsym) = O(1:6,1:6)
        end if

    end do
  end do

  nsym2 = nsym
  do ii = 1,3
    do jj = 1,nsym2
      O = matmul(O2(:,:,ii),self%icos(:,:,jj))
      if(self%isnew_(6, O, nsym)) then
          nsym = nsym + 1
          self%icos(:,:,nsym) = O(1:6,1:6)
        end if

        O = matmul(self%icos(:,:,jj), O2(:,:,ii))
        if(self%isnew_(6, O, nsym)) then
          nsym = nsym + 1
          self%icos(:,:,nsym) = O(1:6,1:6)
        end if

    end do
  end do

  nsym2 = nsym
  do ii = 1,nsym2
    O = matmul(g3,self%icos(:,:,ii))
    if(self%isnew_(6, O, nsym)) then
        nsym = nsym + 1
        self%icos(:,:,nsym) = O(1:6,1:6)
    end if
  end do

  self%nsym = nsym
end if

deallocate(g1, g2, g3, O1, O2, O3, O)

end subroutine GetSymmetryOperators_

!--------------------------------------------------------------------------
recursive function isnew_(self, s, sym, nsym) result(new_sym)
!DEC$ ATTRIBUTES DLLEXPORT :: isnew_
!! author: MDG/SS
!! version: 1.0
!! date: 02/01/22
!!
!! is this a new matrix ?

IMPLICIT NONE

class(QCspacegroup_T),INTENT(INOUT)   :: self
integer(kind=irg),INTENT(IN)          :: s
real(kind=dbl),INTENT(IN)             :: sym(s,s)
integer(kind=irg),INTENT(IN)          :: nsym

integer(kind=irg)                     :: ii, jj
real(kind=dbl)                        :: eps = 1.0D-4
logical                               :: new_sym

new_sym = .TRUE.

do ii = 1,nsym
  if(sum(abs(self%icos(:,:,ii) - sym)) .lt. eps) then
    new_sym = .FALSE.
    EXIT
  end if
end do

end function isnew_

!--------------------------------------------------------------------------
logical recursive function isitnew_(self, nsym)
!DEC$ ATTRIBUTES DLLEXPORT :: isitnew_
!! author: MDG/SS
!! version: 1.0
!! date: 02/01/22
!!
!! is this a new matrix ?

IMPLICIT NONE

class(QCspacegroup_T),INTENT(INOUT)     :: self
integer(kind=irg),INTENT(IN)            :: nsym               !< index of matrix to be compared

integer(kind=irg)                       :: k                  !< loop counters
real(kind=dbl),parameter                :: eps=1.0D-14       !< comparison threshold

isitnew_ = .TRUE.

k=1
comparison: do while (k.le.nsym)
  ! write (*,*) k, nsym
  ! write (*,*) (abs( self%c(:,:) - self%data(k,:,:) ) .lt. eps)
  ! if (all( abs( self%c(:,:) - self%data(k,:,:) ) .lt. eps)) then
  if (sum( abs( self%c(:,:) - self%data(k,:,:) )) .le. eps) then
    isitnew_ = .FALSE.
    ! write (*,*) k, 'FALSE'
    EXIT comparison
  end if
  k=k+1
end do comparison

end function isitnew_

!--------------------------------------------------------------------------
recursive function IsGAllowedQC_(self,g) result(res)
!DEC$ ATTRIBUTES DLLEXPORT :: IsGAllowedQC_
!! author: MDG/SS
!! version: 1.0
!! date: 02/02/22
!!
!!

IMPLICIT NONE

class(QCspacegroup_T),INTENT(INOUT)   :: self
integer(kind=irg),INTENT(IN)          :: g(6)           !< input reciprocal lattice vector

integer(kind=irg)                     :: seo,sgnum,icase  !< auxiliary variable
logical                               :: res

! Determine whether or not this vector is
! actually allowed by the lattice centering
sgnum = self%getSGnum()
icase = 0

if((sgnum .eq. 1) .or. (sgnum .eq. 2) .or. (sgnum .eq. 7) .or. (sgnum .eq. 8)) icase = 1 ! primitive

if((sgnum .eq. 3) .or. (sgnum .eq. 4) .or. (sgnum .eq. 9)) icase = 2 ! body-centered

if((sgnum .eq. 5) .or. (sgnum .eq. 6) .or. (sgnum .eq. 10) .or. (sgnum .eq. 11)) icase = 3 ! face-centered

res = .TRUE.
select case (icase)
  case (1)
                                ! all reflections allowed for a primitive lattice
  case (2)
   seo = mod(sum(g)+100,2); if (seo.eq.1)   res = .FALSE.     ! body-centered sum all even

  case (3)
   seo = sum(mod(g+100,2)); if (seo .le. 5) res = .FALSE.     ! face-centered all even or all odd

  case DEFAULT
end select

end function IsGAllowedQC_

end module mod_QCsymmetry


! ===================================================================
!
!                   Grid_construction_High_Temperature
!
! ===================================================================
!
! Region High Temperature (HT):
!
! From the specific internal energy value referred to the maximum point
! on the saturation curve up to T = 500K (internal energy).
! Left boundary: Maximum pressure 50MPa
! Right boundary: Minimum pressure 0.5MPa
! note: discritization log on vvv_HT to minimize errors
! ===================================================================
SUBROUTINE grid_construction_high_temperature()
!
     USE def_constants
     USE def_variables, ONLY: y_mesh_HT,x_mesh_HT,y_mesh_sat_HT,v_left_HT,v_right_HT,&
&                             spline_left_HT, spline_right_HT,ppp_HT,vvv_HT,ccc_HT,TTT_HT,cpcp_HT
     USE non_linear_solvers
     USE properties
     USE grid_functions
!
INTEGER  ::  i, j, Niter, exitflag
!INTEGER, DIMENSION (NNN_HT,MMM_HT)  ::
!
REAL(pr)   ::  u_min, res, delta, T_guess, v_guess, p_min,&
&              temp,press,out_2, sound
!
REAL(pr), DIMENSION (NNN_HT)     :: T_pmax, p_HT, T_pmin
REAL(pr), DIMENSION (NNN_sat_HT) :: T_sat_pmax, T_sat_pmin, p_sat_HT
REAL(pr), DIMENSION (NNN_HT,MMM_HT) :: res_pT_HT, vvv_log
!
! data used for bicubic interpolation
!
!REAL(8) :: v1, v2, v3, v4, u1, u2, u3, u4
!REAL(8) :: F1, F2, F3, F4, G1, G2, G3, G4
!REAL(8) :: a1, a2, a3, a4, b1, b2, b3, b4
!REAL(8) :: dF1v, dF2v, dF3v, dF4v, dF1u, dF2u, dF3u, dF4u, dF1vu, dF2vu,
!dF3vu, dF4vu
!REAL(8) :: dF1vv, dF2vv, dF3vv, dF4vv, dF1uu, dF2uu, dF3uu, dF4uu
!REAL(8) :: dF1x, dF2x, dF3x, dF4x, dF1y, dF2y, dF3y, dF4y, dF1xy, dF2xy,
!dF3xy, dF4xy
!REAL(8), DIMENSION (4, 4) :: A_bicub, C_bicub
!
!--------------------------------------------------
!
!1) DEFINITION OF ARRAY u:
!
!--------------------------------------------------
u_min = e_umax
!
! arrays x_mesh_HT, y_mesh_HT
!
delta       = (u_end - u_min)/(NNN_HT-1)
y_mesh_HT   =  u_min + (/(i*delta, i=0,NNN_HT-1)/)
delta       = (x_mesh_max - x_mesh_min)/(MMM_HT-1)
x_mesh_HT   =  x_mesh_min + (/(i*delta, i=0,MMM_HT-1)/)
!
! array y_mesh_sat_HT
!
delta         = (u_end - u_min)/(NNN_sat_HT-1)
y_mesh_sat_HT = u_min + (/(i*delta, i=0,NNN_sat_HT-1)/)
!
!-----------------------------------------------------------------------
!
!2) EVALUATION OF v_max(u) AND v_min(u) FOR EACH ELEMENT OF THE ARRAY u:
!
! Concerning the evaluation of v_min(u): P = 10MPa, vmin = v_B
! V_max: P = 0.5MPa, vmax = v_C
!
!-----------------------------------------------------------------------
!print*, 'start left'
!
!Left boundary, vmin
!
        T_guess = T_B
        v_guess = v_B

        ppp_HT(:,1) = p_max
!
        DO i=1,NNN_HT
!print*,i, 'in', ppp_HT(i,1), y_mesh_HT(i),T_guess, v_guess
!
              CALL New_Rap2D(2, TTT_HT(i,1), vvv_HT(i,1), &
              & res, Niter, exitflag, ppp_HT(i,1), y_mesh_HT(i),&
              & T_guess, v_guess)
!
             CALL sound_speed(TTT_HT(i,1),vvv_HT(i,1), sound)
             ccc_HT(i,1) = sound
!print*,'out',TTT_HT(i,1), vvv_HT(i,1),res, Niter, exitflag,ccc_HT(i,1)
!
              IF (res > res_ref) THEN
                print*, "left_HT", res,i, "iter", Niter,"flag",exitflag
                STOP
              ENDIF
              T_guess = TTT_HT(i,1)
              v_guess = vvv_HT(i,1)
         END DO
!
! Right boundary of HT domain.
!
!print*, 'start right'
        T_guess = T_C
        v_guess = v_C
        ppp_HT(:,MMM_HT) = p_tri
!
        DO i=1,NNN_HT
!
              CALL New_Rap2D(2, TTT_HT(i,MMM_HT), vvv_HT(i,MMM_HT), &
              & res, Niter, exitflag, ppp_HT(i,MMM_HT), y_mesh_HT(i),&
              & T_guess, v_guess)
!
             CALL sound_speed(TTT_HT(i,MMM_HT),vvv_HT(i,MMM_HT), sound)
             ccc_HT(i,MMM_HT) = sound
!
              IF (res > res_ref) THEN
                print*, "right_HT", res,i, "iter", Niter,"flag",exitflag
                STOP
              ENDIF
              T_guess = TTT_HT(i,MMM_HT)
              v_guess = vvv_HT(i,MMM_HT)
!              print*, vvv_HT(i,MMM_HT)
         ENDDO
!
! Middle domain of the two boundaries. v_min-->v_max, u_min-->u_max
! vvv_HT in the physical space is built by the X in the transformed
! space with a LINEAR SCALING TRANSFORMATION
!print*, 'start middle'
!
        T_guess = TTT_HT(1,1)
        DO j=2,MMM_HT-1
           DO i=1, NNN_HT
!
        vvv_log(i,j) = ((x_mesh_HT(j) - x_mesh_min)/(x_mesh_max - x_mesh_min))*&
     &               (LOG10(vvv_HT(i,MMM_HT))-LOG10(vvv_HT(i,1)))+ LOG10(vvv_HT(i,1))
       vvv_HT(i,j) = 10_pr **vvv_log(i,j)
!                vvv_HT(i,j) = ((x_mesh_HT(j) - x_mesh_min) /&
!                & (x_mesh_max - x_mesh_min)) *(vvv_HT(i,MMM_HT)-vvv_HT(i,1))+&
!                & vvv_HT(i,1)
!
                CALL New_Rap1D(1, temp, out_2, res, Niter,&
               & exitflag, y_mesh_HT(i), T_guess,&
               & vvv_HT(i,j), out_2)
!
                TTT_HT(i,j) = temp
                T_guess = temp
!
!
              CALL pressure(TTT_HT(i,j),vvv_HT(i,j),press)
              ppp_HT(i,j) = press
!
             CALL sound_speed(TTT_HT(i,j),vvv_HT(i,j), sound)
             ccc_HT(i,j) = sound
!
                IF (res > res_ref) THEN
                  print*, "middle_HT", res,i, "iter", Niter
                  STOP
                ENDIF
           END DO
        END DO
!
!
!
!
! grid for Cp
!
!        DO j = 1,MMM_HT
!           DO  i = 1, NNN_HT
!               CALL heat_cap_p(TTT_HT(i,j),vvv_HT(i,j),cpcp_HT(i,j))
!
!               IF ( (cpcp_HT(i,j) /= cpcp_HT(i,j)) .OR. (cpcp_HT(i,j) <= 0.0) .OR.&
!&                   (cpcp_HT(i,j) >  cp_cr  ) ) THEN
!                  print*,'cp no values in HT kJ/(kgK)', cpcp_HT(i,j)/1000.0,i,j
!                  cpcp_HT(i,j) = cp_cr
!               ENDIF
!
!             ENDDO
!        ENDDO
!
!

!------------------------------------------------------------------
!
! Spline coeff construction
!
!---------------------------------------------------------------------
!print*, 'start spline left'
        T_guess = T_B
        v_guess = v_B
!
        DO i=1,NNN_sat_HT
!
              CALL New_Rap2D(2, T_sat_pmax(i), v_left_HT(i), &
              & res, Niter, exitflag, p_max, y_mesh_sat_HT(i),&
              & T_guess, v_guess)
!
              IF (res > res_ref) THEN
                print*, "left_sp_HT", res,i, "iter", Niter,"flag",exitflag
                STOP
              ENDIF
              T_guess = T_sat_pmax(i)
              v_guess = v_left_HT(i)
!
         END DO
!
!print*, 'start spline right'
        T_guess = T_C
        v_guess = v_C
!
        DO i=1,NNN_sat_HT
!
              CALL New_Rap2D(2, T_sat_pmin(i), v_right_HT(i), &
              & res, Niter, exitflag, p_tri, y_mesh_sat_HT(i),&
              & T_guess, v_guess)
!
              IF (res > res_ref) THEN
                print*, "right_sp_HT", res,i, "iter", Niter,"flag",exitflag
                STOP
              ENDIF
              T_guess = T_sat_pmin(i)
              v_guess = v_right_HT(i)
!
         END DO
!
! construction of spline coefficients associated to the boundary curves
!
DO i = 1, NNN_HT-1
   j = 3 * (i-1) + 1
   call polyfit(spline_left_HT(:,i), y_mesh_sat_HT(j:j+3), v_left_HT(j:j+3),ord_spline)
   call polyfit(spline_right_HT(:,i), y_mesh_sat_HT(j:j+3), v_right_HT(j:j+3),ord_spline)
ENDDO
!print*,'------------------------------------------------------'
print*,           'HT GRID FINISH'
!print*,'------------------------------------------------------'
!
!
END SUBROUTINE Grid_construction_High_Temperature


      subroutine fpopdi(ifsu,ifsv,ifbu,ifbv,u,mu,v,mv,z,mz,z0,dz,
     * iopt,ider,tu,nu,tv,nv,nuest,nvest,p,step,c,nc,fp,fpu,fpv,
     * nru,nrv,wrk,lwrk)
c  given the set of function values z(i,j) defined on the rectangular
c  grid (u(i),v(j)),i=1,2,...,mu;j=1,2,...,mv, fpopdi determines a
c  smooth bicubic spline approximation with given knots tu(i),i=1,..,nu
c  in the u-direction and tv(j),j=1,2,...,nv in the v-direction. this
c  spline sp(u,v) will be periodic in the variable v and will satisfy
c  the following constraints
c
c     s(tu(1),v) = dz(1) , tv(4) <=v<= tv(nv-3)
c
c  and (if iopt(2) = 1)
c
c     d s(tu(1),v)
c     ------------ =  dz(2)*cos(v)+dz(3)*sin(v) , tv(4) <=v<= tv(nv-3)
c     d u
c
c  and (if iopt(3) = 1)
c
c     s(tu(nu),v)  =  0   tv(4) <=v<= tv(nv-3)
c
c  where the parameters dz(i) correspond to the derivative values g(i,j)
c  as defined in subroutine pogrid.
c
c  the b-spline coefficients of sp(u,v) are determined as the least-
c  squares solution  of an overdetermined linear system which depends
c  on the value of p and on the values dz(i),i=1,2,3. the correspond-
c  ing sum of squared residuals sq is a simple quadratic function in
c  the variables dz(i). these may or may not be provided. the values
c  dz(i) which are not given will be determined so as to minimize the
c  resulting sum of squared residuals sq. in that case the user must
c  provide some initial guess dz(i) and some estimate (dz(i)-step,
c  dz(i)+step) of the range of possible values for these latter.
c
c  sp(u,v) also depends on the parameter p (p>0) in such a way that
c    - if p tends to infinity, sp(u,v) becomes the least-squares spline
c      with given knots, satisfying the constraints.
c    - if p tends to zero, sp(u,v) becomes the least-squares polynomial,
c      satisfying the constraints.
c    - the function  f(p)=sumi=1,mu(sumj=1,mv((z(i,j)-sp(u(i),v(j)))**2)
c      is continuous and strictly decreasing for p>0.
c
c  ..scalar arguments..
      integer ifsu,ifsv,ifbu,ifbv,mu,mv,mz,nu,nv,nuest,nvest,
     * nc,lwrk
      real z0,p,step,fp
c  ..array arguments..
      integer ider(2),nru(mu),nrv(mv),iopt(3)
      real u(mu),v(mv),z(mz),dz(3),tu(nu),tv(nv),c(nc),fpu(nu),fpv(nv),
     * wrk(lwrk)
c  ..local scalars..
      real res,sq,sqq,step1,step2,three
      integer i,id0,iop0,iop1,i1,j,l,laa,lau,lav1,lav2,lbb,lbu,lbv,
     * lcc,lcs,lq,lri,lsu,lsv,l1,l2,mm,mvnu,number
c  ..local arrays..
      integer nr(3)
      real delta(3),dzz(3),sum(3),a(6,6),g(6)
c  ..function references..
      integer max0
c  ..subroutine references..
c    fpgrdi,fpsysy
c  ..
c  set constant
      three = 3
c  we partition the working space
      lsu = 1
      lsv = lsu+4*mu
      lri = lsv+4*mv
      mm = max0(nuest,mv+nvest)
      lq = lri+mm
      mvnu = nuest*(mv+nvest-8)
      lau = lq+mvnu
      lav1 = lau+5*nuest
      lav2 = lav1+6*nvest
      lbu = lav2+4*nvest
      lbv = lbu+5*nuest
      laa = lbv+5*nvest
      lbb = laa+2*mv
      lcc = lbb+2*nvest
      lcs = lcc+nvest
c  we calculate the smoothing spline sp(u,v) according to the input
c  values dz(i),i=1,2,3.
      iop0 = iopt(2)
      iop1 = iopt(3)
      call fpgrdi(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,z,mz,dz,
     * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,
     * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
     * wrk(lcc),wrk(lcs),nru,nrv)
      id0 = ider(1)
      if(id0.ne.0) go to 5
      res = (z0-dz(1))**2
      fp = fp+res
      sq = sq+res
c in case all derivative values dz(i) are given (step<=0) or in case
c we have spline interpolation, we accept this spline as a solution.
  5   if(step.le.0. .or. sq.le.0.) return
      dzz(1) = dz(1)
      dzz(2) = dz(2)
      dzz(3) = dz(3)
c number denotes the number of derivative values dz(i) that still must
c be optimized. let us denote these parameters by g(j),j=1,...,number.
      number = 0
      if(id0.gt.0) go to 10
      number = 1
      nr(1) = 1
      delta(1) = step
  10  if(iop0.eq.0) go to 20
      if(ider(2).ne.0) go to 20
      step2 = step*three/tu(5)
      nr(number+1) = 2
      nr(number+2) = 3
      delta(number+1) = step2
      delta(number+2) = step2
      number = number+2
  20  if(number.eq.0) return
c the sum of squared residuals sq is a quadratic polynomial in the
c parameters g(j). we determine the unknown coefficients of this
c polymomial by calculating (number+1)*(number+2)/2 different splines
c according to specific values for g(j).
      do 30 i=1,number
         l = nr(i)
         step1 = delta(i)
         dzz(l) = dz(l)+step1
         call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz,
     *    iop0,iop1,tu,nu,tv,nv,p,c,nc,sum(i),fp,fpu,fpv,mm,mvnu,
     *    wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     *    wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
     *    wrk(lcc),wrk(lcs),nru,nrv)
         if(id0.eq.0) sum(i) = sum(i)+(z0-dzz(1))**2
         dzz(l) = dz(l)-step1
         call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz,
     *    iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu,
     *    wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     *    wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
     *    wrk(lcc),wrk(lcs),nru,nrv)
         if(id0.eq.0) sqq = sqq+(z0-dzz(1))**2
         a(i,i) = (sum(i)+sqq-sq-sq)/step1**2
         if(a(i,i).le.0.) go to 80
         g(i) = (sqq-sum(i))/(step1+step1)
         dzz(l) = dz(l)
  30  continue
      if(number.eq.1) go to 60
      do 50 i=2,number
         l1 = nr(i)
         step1 = delta(i)
         dzz(l1) = dz(l1)+step1
         i1 = i-1
         do 40 j=1,i1
            l2 = nr(j)
            step2 = delta(j)
            dzz(l2) = dz(l2)+step2
            call fpgrdi(ifsu,ifsv,ifbu,ifbv,1,u,mu,v,mv,z,mz,dzz,
     *       iop0,iop1,tu,nu,tv,nv,p,c,nc,sqq,fp,fpu,fpv,mm,mvnu,
     *       wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     *       wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
     *       wrk(lcc),wrk(lcs),nru,nrv)
            if(id0.eq.0) sqq = sqq+(z0-dzz(1))**2
            a(i,j) = (sq+sqq-sum(i)-sum(j))/(step1*step2)
            dzz(l2) = dz(l2)
  40     continue
         dzz(l1) = dz(l1)
  50  continue
c the optimal values g(j) are found as the solution of the system
c d (sq) / d (g(j)) = 0 , j=1,...,number.
  60  call fpsysy(a,number,g)
      do 70 i=1,number
         l = nr(i)
         dz(l) = dz(l)+g(i)
  70  continue
c we determine the spline sp(u,v) according to the optimal values g(j).
  80  call fpgrdi(ifsu,ifsv,ifbu,ifbv,0,u,mu,v,mv,z,mz,dz,
     * iop0,iop1,tu,nu,tv,nv,p,c,nc,sq,fp,fpu,fpv,mm,mvnu,
     * wrk(lsu),wrk(lsv),wrk(lri),wrk(lq),wrk(lau),wrk(lav1),
     * wrk(lav2),wrk(lbu),wrk(lbv),wrk(laa),wrk(lbb),
     * wrk(lcc),wrk(lcs),nru,nrv)
      if(id0.eq.0) fp = fp+(z0-dz(1))**2
      return
      end


*------------------------------------------------------------------------
*        G E N I N T B R
*------------------------------------------------------------------------
*
*       Generate the list of integrals that could arise from a set
*       of orbitals.

        SUBROUTINE genintbr(nclosd,maxorb,lmax,ql,qintptr,qpackn,qvalue,
     :                                               rel,skip)
        IMPLICIT real*8 (a-h,o-z)

        POINTER (ql,l(1)),(qintptr,intptr(0:2*lmax+1,7)),
     :          (qpackn,ipackn(1)),(qvalue,value(1))
        INTEGER l,intptr,ipackn
        INTEGER maxorb,lmax,n
        LOGICAL omit, ltriang, gen, rel, skip
	CHARACTER*3 el
C >>>>  The hlc routine requires an array of electron labels
*	for diagonstic purposes.  The A3 format of MCHF is not
*	compatible with the Belfast Integer (3H   ) format.
*	No problem will be encountered as long as an error is
*	not detected by hlc.
*       .. sweep through to find dimensions
	gen = .false.
*
*       Generate the list of possible integrals
*
*       Make the FK integrals: i2 <= i4
*
10      n = 0
        do k = 0,2*lmax+1
          do i2 = 1,maxorb
            l2 = l(i2)
            do i4 = i2,maxorb
              l4 = l(i4)
              if (ltriang(k,l2,l2) .and. ltriang(k,l4,l4)) then
                n = n+1
		if (gen) then
                  ipackn(n) = (k*64 + i2)*64 + i4
		  j2 = i2+nclosd
		  j4 = i4+nclosd
CGG		  value(n) = fk(j2,j4,k,rel)
		  value(n) = rk(j2,j4,j2,j4,k,rel)
                  if (abs(value(n)).lt.(1.e-39)) stop
*                 write (*,*) 'Fk',n,ipackn(n),i2,i4,k, value(n)
		end if
              end if
            end do
          end do
          if (gen) then
	    intptr(k,1) = n
C           write (*,*) k,intptr(k,1)
	  end if
        end do
*
*       Make the GK integrals: i2 < i4
*
        do k = 0,2*lmax+1
          do i2 = 1,maxorb
            l2 = l(i2)
            do i4 = i2+1,maxorb
              l4 = l(i4)
              if (ltriang(k,l2,l4) ) then
                n = n+1
		if (gen) then
                  ipackn(n) = (k*64 + i2)*64 + i4
		  j2 = i2+nclosd
		  j4 = i4+nclosd
C		  value(n) = gk(j2,j4,k,rel)
		  value(n) = rk(j2,j4,j4,j2,k,rel)
                  if (abs(value(n)).lt.(1.e-29)) stop
*                 write (*,*) 'Gk',n,ipackn(n),i2,i4,k, value(n)
		end if
              end if
            end do
          end do
          if (gen) then
	    intptr(k,2) = n
C           write (*,*) k,intptr(k,2)
	  end if
        end do
*
*       Make the RK integrals: i1<=i2; i1 <= i3; i1<=i4
*
        do k = 0,2*lmax+1
          do i1 = 1,maxorb
            l1 = l(i1)
            do i2 = i1,maxorb
              l2 = l(i2)
              do i3=i1,maxorb
                l3 = l(i3)
                if (ltriang(k,l1,l3)) then
                  do i4 = i1,maxorb
                    l4 = l(i4)
*                   .. omit if FK
                    omit = (i1.eq.i4.and.i2.eq.i3).or.
     :                     (i1.eq.i3.and.i2.eq.i4)
                    if ( .not. omit .and. ltriang(k,l2,l4) ) then
                      n = n+1
		      if (gen) then
                        ipackn(n) = (((k*64+i1)*64+i2)*64+i3)*64+i4
			j1 = i1+nclosd
			j2 = i2+nclosd
			j3 = i3+nclosd
			j4 = i4+nclosd
			value(n) = rk(j1,j2,j3,j4,k,rel)
*                       write (*,*) 'Rk',n,ipackn(n),i1,i2,i3,i4,k,
*    :                              value(n)
                      end if
                    end if
                  end do
                end if
              end do
            end do
          end do
          if (gen) then
	    intptr(k,3) = n
C           write (*,*) k,intptr(k,3)
	  end if
        end do
*
*       Make the L integrals: i2 < i4
*
        do i2 = 1,maxorb
          l2 = l(i2)
          do i4 = i2,maxorb
            l4 = l(i4)
            if (l2 .eq. l4) then
              n = n+1
	      if (gen) then
                ipackn(n) = i2*64 + i4
                j1 = i2 + nclosd
                j2 = i4 + nclosd
		value(n) = hlc(el,j1,j2,rel)
*               write (*,*) 'HL',n,ipackn(n),i2,i4, value(n)
	      end if
            end if
          end do
        end do
        if (gen) then
	  do k = 0,2*lmax+1
	    intptr(k,4) = n
	  end do
C         write (*,*) 0,intptr(0,4)
	end if

*       Omit Breit-Pauli integrals if skip=true
	if (skip) go to 20
*
*       Make the Z integrals: i2 < i4
*
        do i2 = 1,maxorb
          l2 = l(i2)
          do i4 = i2,maxorb
            l4 = l(i4)
            if (l2 .eq. l4 .and. l2 .gt. 0) then
              n = n+1
	      if (gen) then
                ipackn(n) = i2*64 + i4
		j2 = i2+nclosd
		j4 = i4+nclosd
		value(n) = zeta(j2,j4)
*               write (*,*) 'Zeta',n,ipackn(n),i2,i4, value(n)
	      end if
            end if
          end do
        end do
        if (gen) then
	  do k = 0,2*lmax+1
	    intptr(k,5) = n
	  end do
C         write (*,*) 0,intptr(0,5)
	end if
*
*       Make the NK integrals: i1<=i3; i2 <= i4
*       Note that for these integrals, the packing
*       routine packs K+1, where K=-1,0,1,..  So
*       here k = K+1
*
        do k = 0,2*lmax+1
 	  if (k .eq. 0) then
 	    kk = k+1
 	  else
 	    kk = k-1
 	  end if
	  km = k-1
          do i1 = 1,maxorb
            l1 = l(i1)
            do i2 = 1,maxorb
              l2 = l(i2)
              do i3=i1,maxorb
                l3 = l(i3)
                if (ltriang(kk,l1,l3).or. ltriang(kk+2,l1,l3) ) then
*               if ( ltriang(kk+2,l1,l3) ) then
                  do i4 = i2,maxorb
                    l4 = l(i4)
                    if (ltriang(kk,l2,l4) .or.ltriang(kk+2,l2,l4)) then
                      n = n+1
		      if (gen) then
                        ipackn(n) = (((k*64+i1)*64+i2)*64+i3)*64+i4
			j1 = i1+nclosd
			j2 = i2+nclosd
			j3 = i3+nclosd
			j4 = i4+nclosd
			value(n) = sn(j1,j2,j3,j4,km)
*                       write (*,*) 'Nk',n,ipackn(n),i1,i2,i3,i4,km,
*    :                     value(n)
                      end if
                    end if
                  end do
                end if
              end do
            end do
          end do
          if (gen) then
	    intptr(k,6) = n
C           write (*,*) k,intptr(k,6)
	  end if
        end do
*
*       Make the VK integrals: i2 < i4
*
        do k = 0,2*lmax+1
	  kp = k+1
          do i1 = 1,maxorb
            l1 = l(i1)
            do i2 = 1,maxorb
              l2 = l(i2)
              do i3=1,maxorb
                l3 = l(i3)
                if (ltriang(kp,l1,l3)) then
                  do i4 = i2,maxorb
                    l4 = l(i4)
                    if ( ltriang(kp,l2,l4) ) then
                      n = n+1
		      if (gen) then
                        ipackn(n) = (((k*64+i1)*64+i2)*64+i3)*64+i4
			j1 = i1+nclosd
			j2 = i2+nclosd
			j3 = i3+nclosd
			j4 = i4+nclosd
			value(n) = vk(j1,j2,j3,j4,k)
*                       write (*,*) 'Vk',n,ipackn(n),i1,i2,i3,i4,k,
*    :                        value(n)
                      end if
                    end if
                  end do
                end if
              end do
            end do
          end do
          if (gen) then
	    intptr(k,7) = n
C           write (*,*) k,intptr(k,7)
	  end if
        end do
*
*       Note: SK integrals are the same as Nk

20      continue
*       .. allocate memory for integral book keeping
        if (.not. gen) then
          call alloc(qintptr,((2*lmax+2)*7),4)
          write(*,*) 'Allocating space for ',n,' integrals'
          call alloc(qpackn,n,4)
          call alloc(qvalue,n,8)
          gen = .true.
	  go to 10
	end if
*	do ic = 1,7
*	   print *, ic, (intptr(ll,ic),ll=0,2*lmax+1)
*	end do
*
        end


*DECK CATANH
      COMPLEX FUNCTION CATANH (Z)
C***BEGIN PROLOGUE  CATANH
C***PURPOSE  Compute the arc hyperbolic tangent.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4C
C***TYPE      COMPLEX (ATANH-S, DATANH-D, CATANH-C)
C***KEYWORDS  ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS,
C             FNLIB, INVERSE HYPERBOLIC TANGENT
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C CATANH(Z) calculates the complex arc hyperbolic tangent of Z.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CATAN
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  CATANH
      COMPLEX Z, CI, CATAN
      SAVE CI
      DATA CI /(0.,1.)/
C***FIRST EXECUTABLE STATEMENT  CATANH
      CATANH = -CI*CATAN(CI*Z)
C
      RETURN
      END


!****************************************************************************************************
!
!   Subroutine : Set Initial Conditions
!
!****************************************************************************************************
subroutine set_initial()
    use iric
    use global_variables

    real(8) :: zsum

    ! cross-sectional averaged elevation and set water level and depth
    do i = 1, isize-1
        zsum = 0.0d0
        do j = 1, jsize-1
            zsum = zsum + zc(i,j)
        end do
        zave(i) = dble(zsum / (jsize-1))

        !write(*,*) i, zave(i)
        do j = 1, jsize-1
            wl(i,j) = zave(i) + 2.0d0
            depth(i,j) = wl(i,j) - zc(i,j)
            if(depth(i,j) < 0.0d0)then
                depth(i,j) = 0.0d0
            end if
        end do
    end do

end subroutine


subroutine calc_Xika(Xika0,xi,rho,nui,nk,delta,obj_func,Xika,ncomp,nbeads,nsitemax)
    implicit none
    integer,intent(in) :: ncomp, nbeads, nsitemax
    real(8), intent(in), dimension(0:ncomp-1, 0:nbeads-1, 0:nsitemax-1) :: Xika0
    real(8), intent(in), dimension(0:ncomp-1) :: xi
    real(8), intent(in), dimension(0:ncomp-1,0:nbeads-1) :: nui
    real(8), intent(in), dimension(0:nbeads-1,0:nsitemax-1) :: nk
    real(8), intent(in), dimension(0:ncomp-1,0:ncomp-1,0:nbeads-1,0:nbeads-1,0:nsitemax-1,0:nsitemax-1) :: delta
    real(8), intent(in) :: rho
    real(8), intent(out), dimension(0:ncomp-1,0:nbeads-1,0:nsitemax-1) :: obj_func
    real(8), intent(out), dimension(0:ncomp-1,0:nbeads-1,0:nsitemax-1) :: Xika
    integer :: i,k,a,j,l,b

    !initialize Xika to 1.0
    Xika=1.0

    do i=0, ncomp-1
        do k=0, nbeads-1
            do a=0, nsitemax-1
                do j=0, ncomp-1
                    do l=0, nbeads-1
                        do b=0, nsitemax-1
                            Xika(i,k,a)=Xika(i,k,a) + (rho * xi(j) * nui(j,l) * nk(l,b) * Xika0(j,l,b) * delta(i,j,k,l,a,b))
                        enddo
                    enddo
                enddo
            enddo
        enddo
    enddo
    Xika = (1.0/Xika)

    obj_func = Xika - Xika0

end subroutine

subroutine min_xika(rho,Xika_init,xi,nui,nk,delta,maxiter,tol,Xika_final,nrho,ncomp,nbeads,nsitemax)
    implicit none
    integer, intent(in) :: nrho,ncomp,nbeads,nsitemax
    real(8), intent(in), dimension(0:nrho-1) :: rho
    real(8), intent(in), dimension(0:ncomp-1, 0:nbeads-1, 0:nsitemax-1) :: Xika_init
    real(8), intent(in), dimension(0:ncomp-1) :: xi
    real(8), intent(in), dimension(0:ncomp-1,0:nbeads-1) :: nui
    real(8), intent(in), dimension(0:nbeads-1,0:nsitemax-1) :: nk
    real(8), intent(in), dimension(0:nrho-1,0:ncomp-1,0:ncomp-1,0:nbeads-1,0:nbeads-1,0:nsitemax-1,0:nsitemax-1) :: delta
    integer, intent(in) :: maxiter
    real(8), intent(in) :: tol
    real(8), intent(out), dimension(0:nrho-1,0:ncomp-1, 0:nbeads-1, 0:nsitemax-1) :: Xika_final
    real(8), dimension(0:ncomp-1, 0:nbeads-1, 0:nsitemax-1) :: Xika,obj_func,Xika0
    real(8), dimension(0:(ncomp*nbeads*nsitemax)-1) :: Xika_flat
    integer :: i,iter

    Xika=Xika_init

    do i=0, nrho-1
        !write(*,*) Xika0
        do iter=0, maxiter-1
            Xika0=Xika
            call calc_Xika(Xika0,xi,rho(i),nui,nk,delta(i,:,:,:,:,:,:),obj_func,Xika,ncomp,nbeads,nsitemax)
            if(maxval(dabs(obj_func)).lt.tol) exit
        enddo
        Xika_final(i,:,:,:)=Xika
        !write(*,*) i,iter,Xika,obj_func
    end do
    !write(*,*) i,rho(i),Xika,Xika_final(i,:,:,:)
end subroutine


!***********************************************************************
!                                                                      *
      SUBROUTINE LODRWF(IIERR)
!                                                                      *
!   This subroutine loads  radial wavefunctions from the  .rwf  file   *
!   and performs some related setup.                                   *
!                                                                      *
!   Call(s) to: [LIB92]: ALLOC, DALLOC, INTRPQ, ORTHSC.                *
!                                                                      *
!   Written by Farid A. Parpia            Last revision: 05 Oct 1992   *
!   Block version by Xinghong He          Last revision: 27 May 1997   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:24:43   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE parameter_def,   ONLY: NNNP
      USE memory_man
      USE DEBUG_C
      USE DEF_C,           ONLY: C, Z
      USE GRID_C
      USE NPAR_C
      USE ORB_C
      USE WAVE_C,          ONLY: PZ, PF,QF
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE intrpq_I
      USE orthsc_I
      IMPLICIT NONE
!-----------------------------------------------
!   G l o b a l   P a r a m e t e r s
!-----------------------------------------------
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(OUT) :: IIERR
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: J, I, K, NWIN, IOS, NPY, NAKY, MY
      integer :: ierr
      REAL(DOUBLE) :: CON, FKK, EY, PZY, DNORM
      real(double), dimension(:), pointer :: PA, QA, RA
!-----------------------------------------------
!
!
!   Write entry message
!
      WRITE (6, *) 'Loading Radial WaveFunction File ...'
!
!   Allocate storage to orbital arrays
!
      CALL ALLOC(PF, NNNP, NW, 'PF', 'LODRWF')
      CALL ALLOC(QF, NNNP, NW, 'QF', 'LODRWF')

!
!   Setup: (1) Orbital arrays to zero
!          (2) Array E to -1 (no orbitals estimated)
!          (3) Parameters GAMMA for each orbital
!
      CON = Z/C
      CON = CON*CON
!
      DO J = 1, NW
!
         PF(:N,J) = 0.0D00
         QF(:N,J) = 0.0D00
!
         E(J) = -1.0D00
!
         K = ABS(NAK(J))
         IF (NPARM > 0) THEN
            GAMA(J) = DBLE(K)
         ELSE IF (NPARM == 0) THEN
            FKK = DBLE(K*K)
            IF (FKK >= CON) THEN
               GAMA(J) = SQRT(FKK - CON)
            ELSE
               !WRITE (istde,*) 'LODRWF: Imaginary gamma parameter'
               !WRITE (istde,*) ' for ',NP(J),NH(J),' orbital; the'
               !WRITE (istde,*) ' point model for the nucleus'
               !WRITE (istde,*) ' is inappropriate for Z > ',C,'.'
               STOP 'lodrwf: Inappropriate gamma'
            ENDIF
         ENDIF
!
      END DO
!
!   Read orbital information from Read Orbitals File; write summary
!   to  .dbg  file if option set
!
      IF (LDBPR(3)) WRITE (99, 300)
      NWIN = 0
    3 CONTINUE
      READ (23, IOSTAT=IOS) NPY, NAKY, EY, MY

      IF (IOS == 0) THEN
         CALL ALLOC (PA,MY, 'PA', 'LODRWF')
         CALL ALLOC (QA,MY, 'QA', 'LODRWF')
         CALL ALLOC (RA,MY, 'RA', 'LODRWF')

         READ (23) PZY, (PA(I),I=1,MY), (QA(I),I=1,MY)
         READ (23) (RA(I),I=1,MY)

         DO J = 1, NW
            IF (.NOT.(E(J)<0.0D00 .AND. NPY==NP(J) .AND. NAKY==NAK(J))) CYCLE
            PZ(J) = PZY
            E(J) = EY
            CALL INTRPQ(PA, QA, MY, RA, J, DNORM)
            IF (LDBPR(3)) WRITE (99, 301) NP(J), NH(J), E(J), DNORM
            NWIN = NWIN + 1
         END DO
         CALL DALLOC (PA, 'PA', 'LODRWF' )
         CALL DALLOC (QA, 'QA', 'LODRWF')
         CALL DALLOC (RA, 'RA', 'LODRWF')
         GO TO 3
      ENDIF
      IF (LDBPR(3)) WRITE (99, *) ' orbitals renormalised;'
!
!   Stop with an error message if all orbitals are not known
!
      IF (NWIN < NW) THEN
         IIERR = 1
         GO TO 5
      ENDIF
!
!   Schmidt orthogonalise the orbitals
!
      CALL ORTHSC
      IF (LDBPR(3)) WRITE (99, *) ' orbitals orthogonalised and renormalised;'
!
      IIERR = 0
    5 CONTINUE
      RETURN
!
  300 FORMAT(/,'From SUBROUTINE LODRWF:'/,' Orbital',8X,'Eigenvalue',19X,'Norm')
  301 FORMAT(2X,I2,A2,4X,1P,1D22.15,4X,1D22.15)
      RETURN
!
      END SUBROUTINE LODRWF


subroutine wave(uo        ,t         ,uuvar     ,pi        ,wh        , &
              & c         ,rk        ,h         ,ag        ,wavek     )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program 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 General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: wave.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/utils_gpl/morphology/packages/morphology_kernel/src/wave.f90 $
!!--description-----------------------------------------------------------------
! computes a correction factor to
! account for the wave effect on the
! transport relation.
! -
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    implicit none
!
! Call variables
!
    real(fp), intent(in)               :: ag !  Description and declaration in esm_alloc_real.f90
    real(fp), intent(in)               :: c !  Description and declaration in esm_alloc_real.f90
    real(fp), intent(in)               :: h
    real(fp), intent(in)               :: pi !  Description and declaration in const.igs
    real(fp), intent(in)               :: rk
    real(fp), intent(in)               :: t
    real(fp)        :: uo
    real(fp)        :: uuvar
    real(fp), intent(in)               :: wavek
    real(fp), intent(in)               :: wh
!
!
! Local variables
!
    real(fp)                       :: a0
    real(fp)                       :: fw
    real(fp)                       :: rksi
    real(fp)                       :: uor
    real(fp)                       :: var
!
!
!! executable statements -------------------------------------------------------
!
    !
    !
    !
    if (wh<=0.) then
       return
    endif
    if (wavek*h>75.) then
       uo = 0.
    else
       uo = pi*wh/t/sinh(wavek*h)
    endif
    uor = uo
    a0 = uor*t/2./pi/rk
    a0 = max(a0, 2.0_fp)
    fw = exp( - 5.977 + 5.213/a0**.194)
    rksi = c*sqrt(fw/2./ag)
    var = rksi*uor
    uuvar = uuvar + .5*var*var
end subroutine wave


*     MB03ND EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
*     .. Local Scalars ..
      DOUBLE PRECISION PIVMIN, SAFMIN, THETA
      INTEGER          I, INFO, N, NUMSV
*     .. Local Arrays ..
      DOUBLE PRECISION E(NMAX-1), E2(NMAX-1), Q(NMAX), Q2(NMAX)
*     .. External Functions ..
      DOUBLE PRECISION DLAMCH
      EXTERNAL         DLAMCH
*     .. External Functions ..
      INTEGER          MB03ND
      EXTERNAL         MB03ND
*     .. Intrinsic Functions ..
      INTRINSIC        MAX
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, THETA
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99993 ) N
      ELSE
         READ ( NIN, FMT = * ) ( Q(I), I = 1,N )
         READ ( NIN, FMT = * ) ( E(I), I = 1,N-1 )
*        Print out the bidiagonal matrix J.
         WRITE ( NOUT, FMT = 99997 )
         DO 20 I = 1, N - 1
            WRITE ( NOUT, FMT = 99996 ) I, I, Q(I), I, (I+1), E(I)
   20    CONTINUE
         WRITE ( NOUT, FMT = 99995 ) N, N, Q(N)
*        Compute Q**2, E**2, and PIVMIN.
         Q2(N) = Q(N)**2
         PIVMIN = Q2(N)
         DO 40 I = 1, N - 1
            Q2(I) = Q(I)**2
            E2(I) = E(I)**2
            PIVMIN = MAX( PIVMIN, Q2(I), E2(I) )
   40    CONTINUE
         SAFMIN = DLAMCH( 'Safe minimum' )
         PIVMIN = MAX( PIVMIN*SAFMIN, SAFMIN )
*        Compute the number of singular values of J < =  THETA.
         NUMSV = MB03ND( N, THETA, Q2, E2, PIVMIN, INFO )
*
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
            WRITE ( NOUT, FMT = 99994 ) NUMSV, THETA
         END IF
      END IF
      STOP
*
99999 FORMAT (' MB03ND EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from MB03ND = ',I2)
99997 FORMAT (' The Bidiagonal Matrix J is',/)
99996 FORMAT (2(' (',I1,',',I1,') = ',F7.4,2X))
99995 FORMAT (' (',I1,',',I1,') = ',F7.4)
99994 FORMAT (/' J has ',I2,' singular values < =  ',F7.4)
99993 FORMAT (/' N is out of range.',/' N = ',I5)
      END