!***********************************************************************
! This file is part of OpenMolcas.                                     *
!                                                                      *
! OpenMolcas is free software; you can redistribute it and/or modify   *
! it under the terms of the GNU Lesser General Public License, v. 2.1. *
! OpenMolcas is distributed in the hope that it will be useful, but it *
! is provided "as is" and without any express or implied warranties.   *
! For more details see the full text of the license in the file        *
! LICENSE or in <http://www.gnu.org/licenses/>.                        *
!***********************************************************************

subroutine StdSewInput(LuRd,ifnr,mdc,iShll,BasisTypes,STDINP,lSTDINP,iErr)
!***********************************************************************
! This is a simplified copy of the BASI section of RdCtl_Seward that   *
! reads the string vector STDINP with the standard seward input        *
! generated by ZMatrixConverter.                                       *
!***********************************************************************

use Basis_Info, only: dbsc, nCnttp, Shells
use Center_Info, only: dc, n_dc
use Sizes_of_Seward, only: S
use Gateway_Info, only: UnNorm, Do_FckInt
use stdalloc, only: mma_allocate, mma_deallocate
use Constants, only: Angstrom
use Definitions, only: wp, iwp, u6

implicit none
#include "Molcas.fh"
integer(kind=iwp), intent(in) :: LuRd, lSTDINP
integer(kind=iwp), intent(inout) :: ifnr, mdc, iShll
integer(kind=iwp), intent(out) :: BasisTypes(4), iErr
character(len=180), intent(in) :: STDINP(mxAtom*2)
#include "print.fh"
integer(kind=iwp) :: i, ib, iend, Indx, iOff, iSh, iSTDINP, itype, jShll, lAng, Last, LenBSL, LuWr, n, nCnt
character(len=256) :: Basis_lib, Fname
character(len=180) :: Key, KWord, Line
character(len=80) :: BsLbl
character(len=180) :: Ref(2)
character(len=4) :: dbas
character(len=*), parameter :: DefNm = 'basis_library' !CGGd
integer(kind=iwp), parameter :: nBuff = 10000
real(kind=wp), allocatable :: Buffer(:)
integer(kind=iwp), external :: iCLast

!                                                                      *
!***********************************************************************
!                                                                      *
iErr = 0
!                                                                      *
!***********************************************************************
!                                                                      *
LuWr = u6

itype = 0

BasisTypes(:) = 0
!                                                                      *
!***** BASI ************************************************************
!                                                                      *
iSTDINP = 2

call mma_allocate(Buffer,nBuff,Label='Buffer')

do
  nCnttp = nCnttp+1
  if (nCnttp > Mxdbsc) then
    write(LuWr,*) ' Increase Mxdbsc'
    iErr = 1
    return
  end if

  ! Read the basis set label

  Key = STDINP(iSTDINP)
  BSLbl = Key(1:80)
  !call UpCase(BSLbl)
  LenBSL = len(BSLbl)
  Last = iCLast(BSLbl,LenBSL)
  Indx = index(BSLbl,'/')
  if (Indx == 0) then
    call WhichMolcas(Basis_lib)
    if (Basis_lib(1:1) /= ' ') then
      ib = index(Basis_lib,' ')-1
      if (ib < 1) call SysAbendMsg('rdCtl','Too long PATH to MOLCAS',' ')
      Fname = Basis_lib(1:ib)//'/basis_library'
    else
      Fname = DefNm
    end if
    Indx = Last+1
    dbsc(nCnttp)%Bsl = BSLbl
  else
    Fname(1:Last-(Indx+2)+1) = BSLbl(Indx+2:Last)
    if (Fname == ' ') then
      call WarningMessage(2,' No basis set library specified for;BSLbl='//BSLbl//';Fname='//Fname)
      call Quit_OnUserError()
    end if
    Fname = adjustl(Fname)
    dbsc(nCnttp)%Bsl = BSLbl(1:Indx-1)
  end if

  n = index(dbsc(nCnttp)%Bsl,' ')
  dbsc(nCnttp)%Bsl(n:n+5) = '.....'

  if (Show .and. (nPrint(2) >= 6)) then
    write(LuWr,*)
    write(LuWr,*)
    write(LuWr,'(1X,A,I5,A,A)') 'Basis Set ',nCnttp,' Label: ',BSLbl(1:Indx-1)
    write(LuWr,'(1X,A,A)') 'Basis set is read from library:',Fname(1:index(Fname,' '))
  end if

  jShll = iShll
  dbsc(nCnttp)%Bsl_old = dbsc(nCnttp)%Bsl
  dbsc(nCnttp)%mdci = mdc
  call GetBS(Fname,dbsc(nCnttp)%Bsl,iShll,Ref,UnNorm,LuRd,BasisTypes,STDINP,iSTDINP,.true.,.true.,' ')

  Do_FckInt = Do_FckInt .and. dbsc(nCnttp)%FOp
  if (itype == 0) then
    if ((BasisTypes(3) == 1) .or. (BasisTypes(3) == 2)) iType = BasisTypes(3)
  else
    if ((BasisTypes(3) == 1) .or. (BasisTypes(3) == 2)) then
      if (BasisTypes(3) /= iType) then
        BasisTypes(3) = -1
      end if
      iType = BasisTypes(3)
    end if
  end if
  if (itype == 1) ifnr = 1
  if (itype == 2) ifnr = 0

  if (Show .and. (nPrint(2) >= 6) .and. (Ref(1) /= '') .and. (Ref(2) /= '')) then
    write(LuWr,'(1x,a)') 'Basis Set Reference(s):'
    if (Ref(1) /= '') write(LuWr,'(5x,a)') Trim(Ref(1))
    if (Ref(2) /= '') write(LuWr,'(5x,a)') Trim(Ref(2))
    write(LuWr,*)
    write(LuWr,*)
  end if
  dbsc(nCnttp)%ECP = dbsc(nCnttp)%nPrj+dbsc(nCnttp)%nSRO+dbsc(nCnttp)%nSOC+dbsc(nCnttp)%nPP+dbsc(nCnttp)%nM1+dbsc(nCnttp)%nM2 /= 0
  dbsc(nCnttp)%nShells = dbsc(nCnttp)%nVal+dbsc(nCnttp)%nPrj+dbsc(nCnttp)%nSRO+dbsc(nCnttp)%nSOC+dbsc(nCnttp)%nPP

  lAng = max(dbsc(nCnttp)%nVal,dbsc(nCnttp)%nSRO,dbsc(nCnttp)%nPrj)-1
  S%iAngMx = max(S%iAngMx,lAng)
  ! No transformation needed for s and p shells
  Shells(jShll+1)%Transf = .false.
  Shells(jShll+1)%Prjct = .false.
  Shells(jShll+2)%Transf = .false.
  Shells(jShll+2)%Prjct = .false.
  nCnt = 0
  if (dbsc(nCnttp)%Aux) then
    do iSh=jShll+1,iShll
      Shells(iSh)%Aux = .true.
    end do
  end if
  !                                                                    *
  !*********************************************************************
  !                                                                    *
  ! Here we will have to fix that the 6-31G family of basis sets
  ! should by default be used with 6 d-functions rather than 5.

  KWord = ''
  KWord(1:Indx-1) = BSLbl(1:Indx-1)
  call UpCase(KWord)
  if (index(KWord,'6-31G') /= 0) then
    iSh=jShll+3
    if (iSh <= iShll) then
      Shells(iSh)%Transf = .false.
      Shells(iSh)%Prjct = .false.
    end if
  end if
  !                                                                    *
  !*********************************************************************
  !                                                                    *
  do
    iSTDINP = iSTDINP+1
    Line = STDINP(iSTDINP)
    KWord = Line
    call UpCase(KWord)
    if (KWord(1:4) == 'END ') then
      if (nCnt == 0) then
        call WarningMessage(2,' Input error, no center specified!')
        call Quit_OnUserError()
      end if
      dbsc(nCnttp)%nCntr = nCnt
      call mma_allocate(dbsc(nCnttp)%Coor_Hidden,3,nCnt,Label='dbsc:C')
      dbsc(nCnttp)%Coor => dbsc(nCnttp)%Coor_Hidden(:,:)
      call DCopy_(3*nCnt,Buffer,1,dbsc(nCnttp)%Coor,1)
      mdc = mdc+nCnt
      exit
    end if

    ! Read Coordinates

    nCnt = nCnt+1
    n_dc = max(mdc+nCnt,n_dc)
    if (mdc+nCnt > MxAtom) then
      call WarningMessage(2,' RdCtl: Increase MxAtom')
      write(LuWr,*) '        MxAtom=',MxAtom
      call Quit_OnUserError()
    end if
    iend = index(KWord,' ')
    if (iEnd > LENIN+1) then
      write(u6,*) 'Warning: the label ',KWord(1:iEnd),' will be truncated to ',LENIN,' characters!'
    end if
    dc(mdc+nCnt)%LblCnt = KWord(1:min(LENIN,iend-1))
    dbas = trim(dc(mdc+nCnt)%LblCnt(1:LENIN))
    call Upcase(dbas)
    if (dbas == 'DBAS') then
      call WarningMessage(2,' RdCtl: ZMAT does not work with DBAS')
      call Quit_OnUserError()
    end if
    if (mdc+nCnt > 1) call Chk_LblCnt(dc(mdc+nCnt)%LblCnt,mdc+nCnt-1)
    iOff = 1+(nCnt-1)*3
    !write(u6,*) line
    read(Line,*)
    read(Line(6:),*)(Buffer(iOff+i),i=0,2) ! CGGn
    if (index(KWord,'ANGSTROM') /= 0) then
      do i=0,2
        Buffer(iOff+i) = Buffer(iOff+i)/Angstrom
      end do
    end if
  end do

  iSTDINP = iSTDINP+2
  if (iSTDINP >= lSTDINP) exit
end do

call mma_deallocate(Buffer)

if (S%iAngMx < 0) then
  write(u6,*) ' There is an error somewhere in the input!'
  write(u6,*) 'S%iAngMx < 0'
  iErr = 1
  return
end if

return

end subroutine StdSewInput
