!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! G2C4: an interface between CFour and Gaussian via the "External" keyword of Gaussian.
!
! Wenli Zou,  Email: qcband@gmail.com
! Institute of Modern Physics, Northwest University, Xi'an, China
!
! Feb. 23, 2020
! Nov. 18, 2021.  1) Reorder atoms. 2) Bug fix in *.EIn for g16.c ONIOM calculation.
!
! 1. CFour ver. 2.00beta and 2.1 have been tested. Old versions do no work.
! 2. The Cartesian geometry saved in CFour's ZMAT file is in Bohr, thus UNITS=1,COORDINATES=1 should always be set up.
! 3. Numerical gradient and numerical Hessian calculations by CFour are not supported. They may be set up in Gaussian (e.g. freq=
!    numer), then CFour will be requested to do energy or analytic gradient calculations.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
program G2C4
  implicit real(kind=8) (a-h,o-z)
  parameter (iGIN=41, iGOU=42, iCTP=51, iCIN=52, iCOU=61, iC_GRD=62, iC_DIP=63, iC_FCM=64, iC_APT=65, iC_POL=66)
  character*200 :: ctmp,tag
  allocatable   :: IZAG(:), XYZG(:), DIPG(:), POLG(:), APTG(:), GRDG(:), FCMG(:)
  allocatable   :: IZAC(:), XYZC(:), DIPC(:), POLC(:), APTC(:), GRDC(:), FCMC(:)
  allocatable   :: MAPA(:), RMAT(:), Scr(:)

!---------------------------------------------------------------------------------------------------------------------------------
! 1. read arguments
!---------------------------------------------------------------------------------------------------------------------------------
  call RdArg(Imode,iGIN,iGOU,iCTP,iCIN,iCOU,iC_GRD,iC_DIP,iC_FCM,iC_APT,iC_POL,ctmp)

!---------------------------------------------------------------------------------------------------------------------------------
! 2. read *.EIn
!---------------------------------------------------------------------------------------------------------------------------------
  call RdEIn_Line1(iGIN,natom,nder,icharge,multi)
  na3 = 3*natom
  allocate(IZAG(natom), XYZG(na3))
  call RdEIn_XYZ(iGIN,natom,IZAG,XYZG)

!---------------------------------------------------------------------------------------------------------------------------------
! 3. set array length
!---------------------------------------------------------------------------------------------------------------------------------
  ! a special case: nder = 0 if natom = 1
  if(natom == 1) nder = 0
  ntt = na3*(na3+1)/2
  nss = na3*na3

  if(nder == 0) then
    lengrd = 1
    lenfcm = 1
    lenapt = 1
  else if(nder == 1) then
    lengrd = na3
    lenfcm = 1
    lenapt = 1
  else if(nder == 2) then
    lengrd = na3
    lenfcm = nss
    lenapt = 3*na3
  end if

!---------------------------------------------------------------------------------------------------------------------------------
! 4. read data from CFour output & scratch files (Imode = 1)
!---------------------------------------------------------------------------------------------------------------------------------
  if(Imode == 1) then
    allocate(IZAC(natom), XYZC(na3), DIPC(3), POLC(9), GRDC(lengrd), FCMC(lenfcm), APTC(lenapt))
    XYZC = 0.0d0
    DIPC = 0.0d0
    POLC = 0.0d0
    GRDC = 0.0d0
    FCMC = 0.0d0
    APTC = 0.0d0

    call RdC4Ene(iCOU,Energy,ctmp,tag)

    if(nder > 0 .and. natom > 1) then
      call RdC4GRD(iC_GRD,natom,IZAC,XYZC,GRDC)
      call RdC4DIP(iC_DIP,DIPC)
    end if

    if(nder > 1 .and. natom > 1) then
      call RdC4FCM(iC_FCM,natom,FCMC)
      call RdC4APT(iC_APT,natom,APTC)
      call RdC4POL(iC_POL,POLC)
    end if

  end if

!---------------------------------------------------------------------------------------------------------------------------------
! 5. Prepare new data for Gaussian / CFour
!---------------------------------------------------------------------------------------------------------------------------------
  if(Imode == 1) then
    allocate(DIPG(3), GRDG(lengrd), FCMG(lenfcm), APTG(lenapt), POLG(9))
    DIPG = DIPC
    GRDG = GRDC
    FCMG = FCMC
    APTG = APTC
    POLG = POLC

    if(nder > 0) then

      allocate(MAPA(natom), RMAT(9), Scr(ntt))

      ! Check: symmetry-equivalent atoms may be reordered by CFour if symmetry being used.
      ! The atomic ordering is saved in MAPA.
      call ckorder(6,iCOU,natom,MAPA,IZAC,XYZC,ctmp,tag)

      call reordera(1, natom, MAPA, GRDG)
      if(nder > 1 .and. natom > 1) then
        call reordera(2, natom, MAPA, FCMG)
        call reordera(3, natom, MAPA, APTG)
      end if

      ! calculate rotation matrix
      call qrotmol(0,6,natom,XYZG,XYZC,RMAT,Scr)

      ! rotate the dipole moment vector and gadients to the initial orientation
      call rotvec(1,-1,RMAT,DIPG,Scr)
      call rotvec(natom,-1,RMAT,GRDG,Scr)

      if(nder > 1) then
        ! rotate hessian, apt, and polar to the initial orientation
        call rothess(natom,-1,RMAT,FCMG,Scr)
        call Sq2Tr(na3,FCMG,Scr)
        call rotmat(natom,-1,RMAT,APTG,Scr)
        call rotmat(1,-1,RMAT,POLG,Scr)
        call Sq2Tr(3,POLG,Scr)
      end if

      deallocate(MAPA, RMAT, Scr)
    end if

  else
    allocate(IZAC(natom), XYZC(na3))
    IZAC = IZAG
    XYZC = XYZG

  end if

!---------------------------------------------------------------------------------------------------------------------------------
! 6. Generate Gaussian's *.EOu file (Imode = 1) or CFour's ZMAT file (Imode = 0)
!---------------------------------------------------------------------------------------------------------------------------------
  if(Imode == 1) then
    call WrtEOU(iGOU,nder,natom,Energy,DIPG,GRDG,FCMG,APTG,POLG)

  else
    call WrtCar(iCTP,iCIN,natom,nder,icharge,multi,IZAC,XYZC,ctmp)

  end if

end program G2C4

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! reorder atoms in coordinates or gradients (ider=1), Hessians (ider=2), and APT (ider=3)
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine reordera(ider, natm, matm, dat)
  implicit real(kind=8) (a-h,o-z)
  dimension  :: matm(natm), dat(*)
  allocatable   :: scr(:)

  if(natm> 1 .and. ider == 1) then
    allocate(scr(natm*3))
    call reorderg(natm, matm, dat, scr)
  else if(natm> 1 .and. ider == 2) then
    allocate(scr(natm*natm*9))
    call reorderh(natm, matm, dat, scr)
  else if(natm> 1 .and. ider == 3) then
    allocate(scr(natm*9))
    call reorderd(natm, matm, dat, scr)
  end if

  deallocate(scr)
  return

  contains

  subroutine reorderg(natm, matm, grad1, grad2)
    implicit real(kind=8) (a-h,o-z)
    dimension  :: matm(natm), grad1(3,natm), grad2(3,natm)

    do i=1,natm
      grad2(:,i) = grad1(:,matm(i))
    end do
    grad1 = grad2

    return
  end subroutine reorderg

  subroutine reorderh(natm, matm, hess1, hess2)
    implicit real(kind=8) (a-h,o-z)
    dimension  :: matm(natm), hess1(3,natm,3,natm), hess2(3,natm,3,natm)

    do i=1,natm
      hess2(:,:,:,i) = hess1(:,:,:,matm(i))
    end do

    do i=1,natm
      hess2(:,i,:,:) = hess1(:,matm(i),:,:)
    end do

    hess1 = hess2

    return
  end subroutine reorderh

  subroutine reorderd(natm, matm, apt1, apt2)
    implicit real(kind=8) (a-h,o-z)
    dimension  :: matm(natm), apt1(9,natm), apt2(9,natm)

    do i=1,natm
      apt2(:,i) = apt1(:,matm(i))
    end do
    apt1 = apt2

    return
  end subroutine reorderd

end subroutine reordera

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Check whether symmetry-equivalent atoms have been reordered by CFour.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine ckorder(iout,iCOU,natom,MAPA,IZA,XYZ,ctmp,tag)
  implicit real(kind=8) (a-h,o-z)
  dimension :: MAPA(natom), IZA(natom), XYZ(3,natom)
  character*100 :: ctmp,tag
  allocatable   :: iza1(:), xyz1(:,:)
  logical :: reordered

  rewind(iCOU)
  tag=' Z-matrix   Atomic            Coordinates (in bohr)'
  do while(.true.)
    read(iCOU,"(a100)",iostat=ist) ctmp
      if(ist /= 0) call XError("No Cartesian coordinates found in the CFour output file.")
    if(index(ctmp,tag(1:51)) > 0) exit
  end do

  read(iCOU,"(/)",iostat=ist)
    if(ist /= 0) call XError("Please check Cartesian coordinates in the CFour output file.")

  ! IZA & XYZ: shifted and reordered coordinates from GRD
  ! IZA1 & XYZ1: shifted coordinates in input ordering
  reordered = .false.
  allocate(iza1(natom), xyz1(3,natom))
  do i=1,natom
    MAPA(i) = i
    read(iCOU,"(a100)",iostat=ist) ctmp
      if(ist /= 0) call XError("Please check Cartesian coordinates in the CFour output file.")
    read(ctmp(13:),*) iza1(i), xyz1(:,i)
    if(iza1(i) < 1) call XError("Dummy atom or ghost atom cannot be used.")
    if(iza1(i) /= IZA(i) .or. distance(XYZ(1,i),xyz1(1,i)) > 1.d-6) then
      ! Atoms have been reordered in the CFour calculation
      reordered = .true.
    end if
  end do

  if(reordered) then
    call mapatm(natom, iza1, IZA, xyz1, XYZ, MAPA, ierr)
    if(ierr /= 0) then
      write(iout,"('  The equivalent atom for iatom =',i3,' cannot be found.')") ierr
      write(iout,"('  A temporary solution is to reorder the input atoms manually.')")
      call XError("Error in sub. mapatm.")
    end if
  end if

  deallocate(iza1, xyz1)

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Determine the map relationship between reference (1) and target (2) atoms
! It's assumed that CFour shifts, reorders, but doen't rotate the atoms.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine mapatm(natm, iza1, iza2, xyz1, xyz2, matm, ierr)
  implicit real(kind=8) (a-h,o-z)
  parameter(dtol = 0.1d-4)
  dimension  :: iza1(natm), iza2(natm), xyz1(3,natm), xyz2(3,natm), matm(natm)

  ierr = 0

  if(natm < 2) then
    matm(1) = 1
    return
  end if

  loop1 : do i=1,natm
    loop2 : do j=1,natm
      if(iza1(i) /= iza2(j)) cycle

      if(distance(xyz1(1,i),xyz2(1,j)) <= dtol) then
        matm(i) = j
        exit loop2
      end if
    end do loop2

    if(matm(i) == 0) then
      ierr = i
      exit loop1
    end if
  end do loop1

  return
end subroutine mapatm

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! distance between points a and b
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
function distance(a,b)
  implicit real(kind=8) (a-h,o-z)
  real(kind=8) :: a(3),b(3),c(3)

  c = a-b
  distance = sqrt( dot_product(c,c) )

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Write CFour's ZMAT file in Cartesian coordinates
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine WrtCar(iCTP,iCIN,natom,nder,icharge,multi,IZA,XYZ,ctmp)
  implicit real(kind=8) (a-h,o-z)
  dimension :: IZA(natom), XYZ(3,natom)
  character*200 :: ctmp

  rewind(iCIN)
  rewind(iCTP)
  do while(.true.)
    read(iCTP,"(a200)",iostat=ist) ctmp
    if(ist /= 0) then
      if(nder == 0) then
        call XError("No $SP found in CFour templet.")
      else if(nder == 1) then
        call XError("No $GRAD found in CFour templet.")
      else
        call XError("No $FREQ found in CFour templet.")
      end if
    end if

    if(ctmp(1:1) == '!') cycle

    if(nder == 0 .and. index(ctmp,"$sp") > 0) exit
    if(nder == 1 .and. index(ctmp,"$grad") > 0) exit
    if(nder == 2 .and. index(ctmp,"$freq") > 0) exit
  end do

  loop1: do while(.true.)
    read(iCTP,"(a200)",iostat=ist) ctmp
      if(ist /= 0) call XError("No end_of_calc found in CFour templet.")

    if(ctmp(1:1) == '!') cycle

    if(index(ctmp,"file_block") > 0) then
      loop2: do while(.true.)
        read(iCTP,"(a200)",iostat=ist) ctmp
          if(ist /= 0) call XError("Please check file_block in CFour templet.")
        if(index(ctmp,"end_of_file") > 0) exit loop2
        write(iCIN,"(a)") trim(ctmp)
      end do loop2
    end if

    if(index(ctmp,"calc_block") > 0) then
      ! Title
      write(iCIN,"('Input file generated by G2C4.')")

      ! Cartesian geometry
      do i=1,natom
        call ElemZA(ctmp,IZA(i))
        write(iCIN,"(a3,3f20.12)") ctmp(1:3), XYZ(:,i)
      end do

      write(iCIN,*)
      loop3: do while(.true.)
        read(iCTP,"(a200)",iostat=ist) ctmp
          if(ist /= 0) call XError("Please check calc_block in CFour templet.")
        if(index(ctmp,"end_of_calc") > 0) exit loop1

        ! replace {C}
        idxc = index(ctmp,'CHARGE={C}') + index(ctmp,'CHARGE={c}')
        if(idxc > 0) write(ctmp(idxc+7:idxc+9),"(i3.3)") icharge
        ! replace {M}
        idxm = index(ctmp,'MULT={M}') + index(ctmp,'MULT={m}')
        if(idxm > 0) write(ctmp(idxm+5:idxm+7),"(i3.3)") multi
        ! replace {R}
        idxm = index(ctmp,'REFERENCE={R}') + index(ctmp,'REFERENCE={r}')
        if(idxm > 0 .and. multi == 1) write(ctmp(idxm+10:idxm+12),"('RHF')")
        if(idxm > 0 .and. multi /= 1) write(ctmp(idxm+10:idxm+12),"('UHF')")

        write(iCIN,"(a)") trim(ctmp)
      end do loop3
    end if

  end do loop1

  write(iCIN,"(///)")

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! symmetric square matrix --> lower triangular matrix
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine Sq2Tr(N,S,Scr)
  implicit real(kind=8) (a-h,o-z)
  real(kind=8) :: Scr(*),S(N,N)

  ntt = N*(N+1)/2
  ii=0
  Do i=1,N
    Do j=1,i
      ii=ii+1
      Scr(ii)=(S(j,i)+S(i,j))*0.5d0
    end Do
  end Do

  call Copy(ntt,Scr,S)

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! copy
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine Copy(n,A,B)
  implicit real(kind=8) (a-h,o-z)
  real(kind=8) :: A(n),B(n)

  B = A

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Rotate the Hessian matrix
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine rothess(natom,mode,ROT,FCM,SCR)
  implicit double precision (a-h,o-z)
  dimension FCM(3,natom,3,natom),ROT(9),SCR(3,3,2)

  do i=1,natom
    do j=1,natom
      SCR(:,:,1) = FCM(:,j,:,i)
      call rotmat(1,mode,ROT,SCR(1,1,1),SCR(1,1,2))
      FCM(:,j,:,i) = SCR(:,:,1)
    end do
  end do

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! It performs a 3x3 rotation operation of Cartesian matrices:
! mode >=0: M' = ROT^T * M * ROT
!      < 0: M' = ROT * M * ROT^T
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine rotmat(NM,mode,ROT,AM,SCR)
  implicit double precision (a-h,o-z)
  dimension AM(9,NM),ROT(9),SCR(9)

  if(mode >= 0) then
    do i=1,NM
      call dgemm('n','n',3,3,3,1.0d0,AM(1,i),3,ROT,3,0.0d0,SCR,3)
      call dgemm('t','n',3,3,3,1.0d0,ROT,3,SCR,3,0.0d0,AM(1,i),3)
    end do
  else
    do i=1,NM
      call dgemm('n','t',3,3,3,1.0d0,AM(1,i),3,ROT,3,0.0d0,SCR,3)
      call dgemm('n','n',3,3,3,1.0d0,ROT,3,SCR,3,0.0d0,AM(1,i),3)
    end do
  end if

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! It performs a 3x3 rotation operation of Cartesian vectors:
! mode >=0: XYZ' = XYZ * ROT
!      < 0: XYZ' = XYZ * ROT^-1 = XYZ * ROT^T
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine rotvec(NV,mode,ROT,XYZ,SCR)
  implicit double precision (a-h,o-z)
  dimension XYZ(3,NV),ROT(3,3),SCR(3)

  if(mode >= 0) then
    do i=1,NV
      SCR = XYZ(:,i)
      XYZ(:,i) = 0.0d0
      do j=1,3
        do k=1,3
          XYZ(j,i)=XYZ(j,i)+ROT(k,j)*SCR(k)
        end do
      end do
    end do
  else
    do i=1,NV
      SCR = XYZ(:,i)
      XYZ(:,i) = 0.0d0
      do j=1,3
        do k=1,3
          XYZ(j,i)=XYZ(j,i)+ROT(j,k)*SCR(k)
        end do
      end do
    end do
  end if

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! This subroutine determines the rotation matrix for the best fit superimposition of two molecular Coordinates.
!
! The basic method was described in S. K. Kearsley, Acta Cryst. A45, 208 (1989), and coded in the PDBSUP program by B.Rupp and
! S.Parkin at LLNL (1996).
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine qrotmol(iprint,iout,natm,cartarget,carprobe,rmat,scr)
  implicit real(kind=8) (a-h,o-z)
  dimension cartarget(3,natm), carprobe(3,natm), rmat(3,3), scr(4,4)
  allocatable :: dxp(:,:), dxm(:,:), qmat(:,:)

  allocate(dxp(3,natm), dxm(3,natm), qmat(4,4))

  ! translate the molecules to their geometric centers
  call shift(natm,scr,cartarget)
  call shift(natm,scr,carprobe)
  if(iprint > 0) then
    write(iout,"(' Cartesian coordinates of target molecule:')")
    do i=1,natm
      write(iout,"(3f20.12)")cartarget(:,i)
    end do
    write(iout,"(' Cartesian coordinates of probe molecule:')")
    do i=1,natm
      write(iout,"(3f20.12)")carprobe(:,i)
    end do
  end if

  ! coordinate differences: plus and minus
  dxp = carprobe + cartarget
  dxm = carprobe - cartarget

  ! construct Kearsley's Q-matrix
  call conqmt(iprint,iout,natm,dxp,dxm,qmat)

  ! diagonalize Q: Q * L = L * A; A --> qmat(:,1), L --> scr
  call DiagS1(iprint,iout,4,qmat,scr)

  ! construct the best fit rotation matrix using the eigenvectors
  call conrot(iprint,iout,scr,rmat)

  deallocate(dxp, dxm, qmat)

end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Constructing the best fit rotation matrix. See the 2nd equation in
! S.K.Kearsley, On the orthogonal transformation used for structural comparisons, Acta Cryst. A45, 208 (1989)
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine conrot(iprint,iout,q,r)
  implicit real(kind=8) (a-h,o-z)
  dimension         :: q(4), r(3,3)

  r(1,1) = q(1)*q(1) + q(2)*q(2) - q(3)*q(3) - q(4)*q(4)
  r(2,1) = 2 * (q(2)*q(3) + q(1)*q(4))
  r(3,1) = 2 * (q(2)*q(4) - q(1)*q(3))
  r(1,2) = 2 * (q(2)*q(3) - q(1)*q(4))
  r(2,2) = q(1)*q(1) - q(2)*q(2) + q(3)*q(3) - q(4)*q(4)
  r(3,2) = 2 * (q(3)*q(4) + q(1)*q(2))
  r(1,3) = 2 * (q(2)*q(4) + q(1)*q(3))
  r(2,3) = 2 * (q(3)*q(4) - q(1)*q(2))
  r(3,3) = q(1)*q(1) - q(2)*q(2) - q(3)*q(3) + q(4)*q(4)

  if(iprint > 0) then
    write(iout,"(/,' Rotation matrix for the best fit:')")
    do i = 1, 3
      write(iout,"(4x,3f16.6)") r(i,:)
    end do
  end if

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Solve A * L = L * e, where A is symmetric, e will be saved in the first colum of A whereas L is saved in W.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine DiagS1(iprint,iout,N,A,W)
  implicit real(kind=8) (a-h,o-z)
  dimension :: A(N,N), W(N,N)

  Call CJCBJ(N,A,W)

  if(iprint > 0) then
    write(iout,"(/,' Eigenvalues and Eigenvectors of Q:')")
    write(iout,"(4x,4f16.6)") A(:,1)
    write(iout,"(4x,4('      ----------'))")
    do i = 1, N
      write(iout,"(4x,4f16.6)") W(i,:)
    end do
    write(iout,"(' where the smallest eigenvalue represents s.r.s. of the best fit.')")
  end if

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Reference BLAS level3 routine (version 3.4.0) --
! Reference BLAS is a software package provided by Univ. of Tennessee,    --
! Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! November 2011
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)

  ! Scalar Arguments ..
  DOUBLE PRECISION ALPHA,BETA
  INTEGER K,LDA,LDB,LDC,M,N
  CHARACTER TRANSA,TRANSB

  ! Array Arguments ..
  DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)

  ! External Functions ..
  LOGICAL LSAME
  EXTERNAL LSAME

  ! Intrinsic Functions ..
  INTRINSIC MAX

  ! Local Scalars ..
  DOUBLE PRECISION TEMP
  INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
  LOGICAL NOTA,NOTB

  ! Parameters ..
  DOUBLE PRECISION ONE,ZERO
  PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)

  ! Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not transposed and set  NROWA, NCOLA
  ! and NROWB as the number of rows and  columns of  A  and the  number of  rows  of  B  respectively.
  NOTA = LSAME(TRANSA,'N')
  NOTB = LSAME(TRANSB,'N')
  IF (NOTA) THEN
      NROWA = M
      NCOLA = K
  ELSE
      NROWA = K
      NCOLA = M
  END IF
  IF (NOTB) THEN
      NROWB = K
  ELSE
      NROWB = N
  END IF

  ! Test the input parameters.
  INFO = 0
  IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND. (.NOT.LSAME(TRANSA,'T'))) THEN
      INFO = 1
  ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND. (.NOT.LSAME(TRANSB,'T'))) THEN
      INFO = 2
  ELSE IF (M<0) THEN
      INFO = 3
  ELSE IF (N<0) THEN
      INFO = 4
  ELSE IF (K<0) THEN
      INFO = 5
  ELSE IF (LDA<MAX(1,NROWA)) THEN
      INFO = 8
  ELSE IF (LDB<MAX(1,NROWB)) THEN
      INFO = 10
  ELSE IF (LDC<MAX(1,M)) THEN
      INFO = 13
  END IF
  IF (INFO/=0) THEN
      WRITE(*,"(/,' Parameter number ',i2,' is illegal.')") INFO
      call XError("DGEMM has a problem.")
  END IF

  ! Quick return if possible.
  IF ((M==0) .OR. (N==0) .OR. (((ALPHA==ZERO).OR. (K==0)).AND. (BETA==ONE))) RETURN

  ! And if  alpha==zero.
  IF (ALPHA==ZERO) THEN
      IF (BETA==ZERO) THEN
          DO J = 1,N
              DO I = 1,M
                  C(I,J) = ZERO
              END DO
          END DO
      ELSE
          DO J = 1,N
              DO I = 1,M
                  C(I,J) = BETA*C(I,J)
              END DO
          END DO
      END IF
      RETURN
  END IF

  ! Start the operations.
  IF (NOTB) THEN
      IF (NOTA) THEN

          ! Form  C := alpha*A*B + beta*C.
          DO J = 1,N
              IF (BETA==ZERO) THEN
                  DO I = 1,M
                      C(I,J) = ZERO
                  END DO
              ELSE IF (BETA/=ONE) THEN
                  DO I = 1,M
                      C(I,J) = BETA*C(I,J)
                  END DO
              END IF
              DO L = 1,K
                  IF (B(L,J)/=ZERO) THEN
                      TEMP = ALPHA*B(L,J)
                      DO I = 1,M
                          C(I,J) = C(I,J) + TEMP*A(I,L)
                      END DO
                  END IF
              END DO
          END DO
      ELSE

          ! Form  C := alpha*A**T*B + beta*C
          DO J = 1,N
              DO I = 1,M
                  TEMP = ZERO
                  DO L = 1,K
                      TEMP = TEMP + A(L,I)*B(L,J)
                  END DO
                  IF (BETA==ZERO) THEN
                      C(I,J) = ALPHA*TEMP
                  ELSE
                      C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                  END IF
              END DO
          END DO
      END IF
  ELSE
      IF (NOTA) THEN

          ! Form  C := alpha*A*B**T + beta*C
          DO J = 1,N
              IF (BETA==ZERO) THEN
                  DO I = 1,M
                      C(I,J) = ZERO
                  END DO
              ELSE IF (BETA/=ONE) THEN
                  DO I = 1,M
                      C(I,J) = BETA*C(I,J)
                  END DO
              END IF
              DO L = 1,K
                  IF (B(J,L)/=ZERO) THEN
                      TEMP = ALPHA*B(J,L)
                      DO I = 1,M
                          C(I,J) = C(I,J) + TEMP*A(I,L)
                      END DO
                  END IF
              END DO
          END DO
      ELSE

          ! Form  C := alpha*A**T*B**T + beta*C
          DO J = 1,N
              DO I = 1,M
                  TEMP = ZERO
                  DO L = 1,K
                      TEMP = TEMP + A(L,I)*B(J,L)
                  END DO
                  IF (BETA==ZERO) THEN
                      C(I,J) = ALPHA*TEMP
                  ELSE
                      C(I,J) = ALPHA*TEMP + BETA*C(I,J)
                  END IF
              END DO
          END DO
      END IF
  END IF

  RETURN
END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Reference BLAS level1 routine (version 3.1) --
! Reference BLAS is a software package provided by Univ. of Tennessee,    --
! Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! November 2011
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
LOGICAL FUNCTION LSAME(CA,CB)

  ! Scalar Arguments ..
  CHARACTER CA,CB

  ! Intrinsic Functions ..
  INTRINSIC ICHAR

  ! Local Scalars ..
  INTEGER INTA,INTB,ZCODE

  ! Test if the characters are equal
  LSAME = CA == CB
  IF (LSAME) RETURN

  ! Now test for equivalence if both characters are alphabetic.
  ZCODE = ICHAR('Z')

  ! Use 'Z' rather than 'A' so that ASCII can be detected on Prime
  ! machines, on which ICHAR returns a value with bit 8 set.
  ! ICHAR('A') on Prime machines returns 193 which is the same as
  ! ICHAR('A') on an EBCDIC machine.
  INTA = ICHAR(CA)
  INTB = ICHAR(CB)

  IF (ZCODE==90 .OR. ZCODE==122) THEN

      ! ASCII is assumed - ZCODE is the ASCII code of either lower or upper case 'Z'.
      IF (INTA>=97 .AND. INTA<=122) INTA = INTA - 32
      IF (INTB>=97 .AND. INTB<=122) INTB = INTB - 32

  ELSE IF (ZCODE==233 .OR. ZCODE==169) THEN

      ! EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or upper case 'Z'.
      IF (INTA>=129 .AND. INTA<=137 .OR. INTA>=145 .AND. INTA<=153 .OR. INTA>=162 .AND. INTA<=169) INTA = INTA + 64
      IF (INTB>=129 .AND. INTB<=137 .OR. INTB>=145 .AND. INTB<=153 .OR. INTB>=162 .AND. INTB<=169) INTB = INTB + 64

  ELSE IF (ZCODE==218 .OR. ZCODE==250) THEN

      ! ASCII is assumed, on Prime machines - ZCODE is the ASCII code plus 128 of either lower or upper case 'Z'.
      IF (INTA>=225 .AND. INTA<=250) INTA = INTA - 32
      IF (INTB>=225 .AND. INTB<=250) INTB = INTB - 32
  END IF
  LSAME = INTA == INTB

  RETURN
END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Diagonalize a real symmetric matrix.
! The subroutines were taken from S. L. Xu's FORTRAN Algorithm book, Tsinghua, 1995.
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE CJCBJ(N,A,V)
  implicit real(kind=8) (a-h,o-z)
  parameter(EPS=1.0d-8,Zero=0.0d0,One=1.0d0,Two=2.0d0)
  DIMENSION A(N,N), V(N,N)
  INTEGER P,Q

  DO 20 I=1,N
    V(I,I)=One
    DO 10 J=1,N
      IF (I /= J) V(I,J)=Zero
    10  CONTINUE
  20  CONTINUE
  FF=Zero

  DO 500 I=2,N
  DO 500 J=1,I-1
  500  FF=FF+A(I,J)*A(I,J)

!ooo  FF=SQRT(Two*FF)
  FF=SQRT(Two*ABS(FF))
  205  FF=FF/(One*N)
  25  DO 30 I=2,N
  DO 30 J=1,I-1
!ooo    IF (ABS(A(I,J)) >= FF) THEN
    IF ((ABS(A(I,J)) - FF) >= EPS) THEN
      P=I
      Q=J
      GOTO 600
    END IF
  30  CONTINUE

  IF (FF >= EPS) GOTO 205
  goto 1000

  600  X=-A(P,Q)
  Y=(A(Q,Q)-A(P,P))/Two
  OMEGA=X/SQRT(X*X+Y*Y)
  IF (Y < Zero) OMEGA=-OMEGA
  SN=One+SQRT(One-OMEGA*OMEGA)
  SN=OMEGA/SQRT(Two*SN)
  CN=SQRT(One-SN*SN)
  FM=A(P,P)
  A(P,P)=FM*CN*CN+A(Q,Q)*SN*SN+A(P,Q)*OMEGA
  A(Q,Q)=FM*SN*SN+A(Q,Q)*CN*CN-A(P,Q)*OMEGA
  A(P,Q)=Zero
  A(Q,P)=Zero

  DO 60 J=1,N
    IF ((J /= P).AND.(J /= Q)) THEN
      FM=A(P,J)
      A(P,J)= FM*CN+A(Q,J)*SN
      A(Q,J)=-FM*SN+A(Q,J)*CN
    END IF
  60  CONTINUE

  DO 70 I=1,N
    IF ((I /= P).AND.(I /= Q)) THEN
      FM=A(I,P)
      A(I,P)= FM*CN+A(I,Q)*SN
      A(I,Q)=-FM*SN+A(I,Q)*CN
    END IF
  70  CONTINUE

  DO 80 I=1,N
    FM=V(I,P)
    V(I,P)= FM*CN+V(I,Q)*SN
    V(I,Q)=-FM*SN+V(I,Q)*CN
  80  CONTINUE

  GOTO 25

  1000  do i=2,N
    A(i,1) = A(i,i)
  end do
  call eigsrt(N,A,V)

  RETURN
END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! Sort eigenvectors and eigenvalues.
! The subroutines were taken from G. Y. He and Y. L. Gao's FORTRAN Algorithm book, Science Press, 2002.
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE eigsrt(n,d,v)
 implicit real(kind=8) (a-h,o-z)
 dimension d(n),v(n,n)

 do i=1,n-1
   k=i
   p=d(i)
   do j=i+1,n
!    if(d(j)>=p) then  ! from large to small
     if(d(j)<=p) then  ! from small to large
       k=j
       p=d(j)
     endif
   end do
   if(k/=i) then
     d(k)=d(i)
     d(i)=p
     do j=1,n
       p=v(j,i)
       v(j,i)=v(j,k)
       v(j,k)=p
     end do
   endif
 end do

 return
END

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! construct Kearsley's Q-matrix. See the last equation in
! S.K.Kearsley, On the orthogonal transformation used for structural comparisons, Acta Cryst. A45, 208 (1989)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine conqmt(iprint,iout,n,xp,xm,q)
  implicit real(kind=8) (a-h,o-z)
  dimension         :: xp(3,n), xm(3,n), q(4,4)

  q = 0.0d0

  do i = 1, n
    q(1,1) = q(1,1) + xm(1,i)*xm(1,i) + xm(2,i)*xm(2,i) + xm(3,i)*xm(3,i)
    q(2,2) = q(2,2) + xp(2,i)*xp(2,i) + xp(3,i)*xp(3,i) + xm(1,i)*xm(1,i)
    q(3,3) = q(3,3) + xp(1,i)*xp(1,i) + xp(3,i)*xp(3,i) + xm(2,i)*xm(2,i)
    q(4,4) = q(4,4) + xp(1,i)*xp(1,i) + xp(2,i)*xp(2,i) + xm(3,i)*xm(3,i)

    q(2,1) = q(2,1) + xp(2,i)*xm(3,i) - xm(2,i)*xp(3,i)
    q(3,1) = q(3,1) + xm(1,i)*xp(3,i) - xp(1,i)*xm(3,i)
    q(4,1) = q(4,1) + xp(1,i)*xm(2,i) - xm(1,i)*xp(2,i)
    q(3,2) = q(3,2) + xm(1,i)*xm(2,i) - xp(1,i)*xp(2,i)
    q(4,2) = q(4,2) + xm(1,i)*xm(3,i) - xp(1,i)*xp(3,i)
    q(4,3) = q(4,3) + xm(2,i)*xm(3,i) - xp(2,i)*xp(3,i)

    q(1,2) = q(2,1)
    q(1,3) = q(3,1)
    q(1,4) = q(4,1)
    q(2,3) = q(3,2)
    q(2,4) = q(4,2)
    q(3,4) = q(4,3)
  end do

  if(iprint > 0) then
    write(iout,"(/,' Q-matrix:')")
    write(iout,"(4x,4f16.6)") q
  end if

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
! shift the coordinates to the geometric center
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine Shift(n,o,xyz)
  implicit real(kind=8) (a-h,o-z)
  dimension :: xyz(3,*), o(3)

  o = 0.0d0
  do i=1,n
    o = o + xyz(:,i)
  end do
  o = o /dble(n)
  do i=1,n
    xyz(:,i) = xyz(:,i) - o
  end do

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Write Gaussian's *.EOu file
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine WrtEOU(iGOU,nder,natom,Energy,DIP,GRD,FCM,APT,POL)
  Implicit Real*8(A-H,O-Z)
  dimension :: DIP(*), GRD(*), FCM(*), APT(*), POL(*)

  na3 = 3*natom
  ntt = na3*(na3+1)/2

  rewind(iGOU)
  if(nder == 0) then
    ! energy, dipole moment
    write(iGOU,"(4d20.12)") Energy, (0.0d0, i=1,3)
    ! gradients
    write(iGOU,"(3d20.12)") (0.0d0, i=1,na3)
    ! polarizability (l.t. part)
    write(iGOU,"(3d20.12)") (0.0d0, i=1,6)
    ! apt
    write(iGOU,"(3d20.12)") (0.0d0, i=1,3*na3)
    ! hessian matrix (l.t. part)
    write(iGOU,"(3d20.12)") (0.0d0, i=1,ntt)

  else if(nder == 1) then
    ! energy, dipole moment
    write(iGOU,"(4d20.12)") Energy, (DIP(i), i=1,3)
    ! gradients
    write(iGOU,"(3d20.12)") (GRD(i), i=1,na3)
    ! polarizability (l.t. part)
    write(iGOU,"(3d20.12)") (0.0d0, i=1,6)
    ! apt
    write(iGOU,"(3d20.12)") (0.0d0, i=1,3*na3)
    ! hessian matrix (l.t. part)
    write(iGOU,"(3d20.12)") (0.0d0, i=1,ntt)

  else if(nder == 2) then
    ! energy, dipole moment
    write(iGOU,"(4d20.12)") Energy, (DIP(i), i=1,3)
    ! gradients
    write(iGOU,"(3d20.12)") (GRD(i), i=1,na3)
    ! polarizability (l.t. part)
    write(iGOU,"(3d20.12)") (POL(i), i=1,6)
    ! apt
    write(iGOU,"(3d20.12)") (APT(i), i=1,3*na3)
    ! hessian matrix (l.t. part)
    write(iGOU,"(3d20.12)") (FCM(i), i=1,ntt)

  end if

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read APT data from CFour's DIPDER file
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine RdC4APT(iC_APT,natom,APT)
  Implicit Real*8(A-H,O-Z)
  dimension :: APT(3,3,natom)
  logical :: ifopen

  inquire(unit=iC_APT,opened=ifopen)
    if(.NOT.ifopen) return

  rewind(iC_APT)

  do ixyz = 1,3
    read(iC_APT,*,iostat=ist)
      if(ist /= 0) call XError("Please check the DIPDER file.")
    do iatom = 1,natom
      read(iC_APT,*,iostat=ist) ZA, APT(ixyz,:,iatom)
        if(ist /= 0) call XError("Please check the APT data in the DIPDER file.")
    end do
  end do

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read Hessian matrix from CFour's FCMFINAL file
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine RdC4FCM(iC_FCM,natom,FCM)
  Implicit Real*8(A-H,O-Z)
  dimension :: FCM(*)
  logical :: ifopen

  inquire(unit=iC_FCM,opened=ifopen)
    if(.NOT.ifopen) call XError("-C_FCM is required for hessian calculations.")

  rewind(iC_FCM)
  read(iC_FCM,*,iostat=ist)
    if(ist /= 0) call XError("Please check the FCMFINAL file.")

  read(iC_FCM,*,iostat=ist) FCM(1:9*natom*natom)
    if(ist /= 0) call XError("Please check the Hessian matrix in the FCMFINAL file.")

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read Cartesian coordinates and gradients from CFour's GRD file
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine RdC4GRD(iC_GRD,natom,IZA,XYZ,GRD)
  Implicit Real*8(A-H,O-Z)
  dimension :: IZA(natom), XYZ(3,natom), GRD(3,natom)
  logical :: ifopen

  inquire(unit=iC_GRD,opened=ifopen)
    if(.NOT.ifopen) call XError("-C_GRD is required for gradient and hessian calculations.")

  rewind(iC_GRD)
  read(iC_GRD,*,iostat=ist)
    if(ist /= 0) call XError("Please check the GRD file.")

  do i=1,natom
    read(iC_GRD,*,iostat=ist) ZA, XYZ(:,i)
      if(ist /= 0) call XError("Please check Cartesian coordinates in the GRD file.")
    IZA(i) = nint(ZA)
  end do

  do i=1,natom
    read(iC_GRD,*,iostat=ist) ZA, GRD(:,i)
      if(ist /= 0) call XError("Please check Cartesian gradients in the GRD file.")
  end do

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read polarizability tensor from CFour's POLAR file
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine RdC4POL(iC_POL,POL)
  Implicit Real*8(A-H,O-Z)
  dimension :: POL(9)
  logical :: ifopen

  inquire(unit=iC_POL,opened=ifopen)
    if(.NOT.ifopen) return

  rewind(iC_POL)
  read(iC_POL,*,iostat=ist) POL
    if(ist /= 0) call XError("No polarizability tensor found in the POLAR file.")

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read dipole moment vector from CFour's DIPOL file
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine RdC4Dip(iC_DIP,DIP)
  Implicit Real*8(A-H,O-Z)
  dimension :: DIP(3)
  logical :: ifopen

  inquire(unit=iC_DIP,opened=ifopen)
    if(.NOT.ifopen) return

  rewind(iC_DIP)
  read(iC_DIP,*,iostat=ist) DIP
    if(ist /= 0) call XError("No dipole moment vector found in the DIPOL file.")

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read total energy from CFour's output file
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine RdC4Ene(iCOU,ENE,ctmp,tag)
  Implicit Real*8(A-H,O-Z)
  character*200 :: ctmp,tag

  ENE = 0.0d0

  ! read total energy
  rewind(iCOU)
  tag="  The final electronic energy is"
  do while(.true.)
    read(iCOU,"(a64)",iostat=ist) ctmp
      if(ist /= 0) call XError("No total energy found at the end of the CFour output file.")
    if(index(ctmp,tag(1:32)) > 0) then
      read(ctmp(33:64),*) ENE
      exit
    end if
  end do

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read Cartesian coordinates (in a.u.) from Gaussian's *.EIn. Fixed for G16.c ONIOM calculation.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine RdEIn_XYZ(iGIN,natom,IZA,XYZ)
  Implicit Real*8(A-H,O-Z)
  dimension :: IZA(natom), XYZ(3,natom)
  allocatable :: Scr(:)

  IZA = 0
  XYZ = 0.0d0

  allocate(Scr(3))

  rewind(iGIN)
  read(iGIN,*) natom1
  i1 = 0
  do i = 1, natom1
    read(iGIN,*,iostat=ist) iza1, Scr
    if(ist /= 0) call XError("Please check the Cartesian coordinates in *.EIn.")
    if(iza1 > 0) then
      i1 = i1 + 1
      IZA(i1) = iza1
      XYZ(:,i1) = Scr
    end if
  end do

  deallocate(Scr)
  if(i1 /= natom) call XError("Wrong natom in *.EIn.")

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read the first line of Gaussian's *.EIn. Fixed for G16.c ONIOM calculation.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine RdEIn_Line1(iGIN,natom,nder,icharge,multi)
  Implicit Real*8(A-H,O-Z)

  rewind(iGIN)

  natom=-1
  nder=-1
  icharge=-1
  multi=-1

  read(iGIN,*,iostat=ist) natom,nder,icharge,multi
  if(ist /=0) call XError("Please check the first line in *.EIn.")
  if(natom < 1) call XError("Natom < 1.")
  if(nder < 0 .or. nder > 2) call XError("Nder is out of range.")
  if(multi < 1) call XError("Multi cannot be smaller than 1.")

  ! G16.c's ONIOM calculation also prints dummy atoms, which has to be fixed.
  natom1 = 0
  do i=1, natom
    read(iGIN,*) i1
    if(i1 > 0) natom1 = natom1 + 1
  end do
  natom = natom1

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read arguments:  -G2C (imode = 0; default) or -C2G (imode = 1)
!
! -G2C: Gaussian's *.EIn file name (via -GIN), CFour's ZMAT file name (via -CIN), and a CFour templet file name (via -CTP) should
!       be provided.
! -C2G: Gaussian's *.EIn file name (via -GIN) and *.EOu file name (via -GOU), and CFour's output file name (via -COU to provide
!       total energy) and some of the following scratch files if nder > 0 should be provided,
!       nder = 1 : -C_GRD, and -C_DIP (optional)
!       nder = 2 : -C_GRD, -C_DIP (optional), -C_FCM, -C_APT (optional), and -C_POL (optional)
!       in which
!       -C_GRD is the GRD file with Cartesian coordinates and gradients,
!       -C_DIP is the DIPOL file with dipole moment vector,
!       -C_FCM is the FCMFINAL file with Cartesian hessian matrix,
!       -C_APT is the DIPDER file with dipole moment derivatives for IR intensity, and
!       -C_POL is the POLAR file with polarizability tensor.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine RdArg(imode,iGIN,iGOU,iCTP,iCIN,iCOU,iC_GRD,iC_DIP,iC_FCM,iC_APT,iC_POL,ctmp)
  implicit real(kind=8) (a-h,o-z)
  character*200 :: ctmp
  logical :: ifopen

  imode = 0

  i = 0
  do while(.true.)
    i = i + 1
    call Get1Cmd(i,.True.,ctmp)
    istr=nonspace(ctmp)
    iend=len_trim(ctmp)

    if(iend == 0) then
      exit
    else if(ctmp(istr:iend) == '-C2G') then
      imode = 1
    else if(ctmp(istr:iend) == '-G2C') then
      imode = 0
    else if(ctmp(istr:iend) == '-GIN') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -GIN.")
      else
        open(iGIN,file=ctmp(istr:iend),status='old',iostat=ist)
        if(ist /= 0) call XError("Cannot open old file for -GIN.")
      end if
    else if(ctmp(istr:iend) == '-GOU') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -GOU.")
      else
        open(iGOU,file=ctmp(istr:iend),status='replace',iostat=ist)
        if(ist /= 0) call XError("Cannot open file for -GOU.")
      end if
    else if(ctmp(istr:iend) == '-CTP') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -CTP.")
      else
        open(iCTP,file=ctmp(istr:iend),iostat=ist)
        if(ist /= 0) call XError("Cannot open file for -CTP.")
      end if
    else if(ctmp(istr:iend) == '-CIN') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -CIN.")
      else
        open(iCIN,file=ctmp(istr:iend),status='replace',iostat=ist)
        if(ist /= 0) call XError("Cannot open file for -CIN.")
      end if
    else if(ctmp(istr:iend) == '-COU') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -COU.")
      else
        open(iCOU,file=ctmp(istr:iend),iostat=ist)
        if(ist /= 0) call XError("Cannot open file for -COU.")
      end if
    else if(ctmp(istr:iend) == '-C_GRD') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -C_GRD.")
      else
        open(iC_GRD,file=ctmp(istr:iend),iostat=ist)
        if(ist /= 0) call XError("Cannot open file for -C_GRD.")
      end if
    else if(ctmp(istr:iend) == '-C_DIP') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -C_DIP.")
      else
        open(iC_DIP,file=ctmp(istr:iend),iostat=ist)
        if(ist /= 0) call XError("Cannot open file for -C_DIP.")
      end if
    else if(ctmp(istr:iend) == '-C_FCM') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -C_FCM.")
      else
        open(iC_FCM,file=ctmp(istr:iend),iostat=ist)
        if(ist /= 0) call XError("Cannot open file for -C_FCM.")
      end if
    else if(ctmp(istr:iend) == '-C_APT') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -C_APT.")
      else
        open(iC_APT,file=ctmp(istr:iend),iostat=ist)
        if(ist /= 0) call XError("Cannot open file for -C_APT.")
      end if
    else if(ctmp(istr:iend) == '-C_POL') then
      i = i + 1
      call Get1Cmd(i,.False.,ctmp)
      istr=nonspace(ctmp)
      iend=len_trim(ctmp)
      if(iend == 0) then
        call XError("No file name provided for -C_POL.")
      else
        open(iC_POL,file=ctmp(istr:iend),iostat=ist)
        if(ist /= 0) call XError("Cannot open file for -C_POL.")
      end if
    else
      call XError("Unknown argument "//ctmp(istr:iend))
    end if
  end do

  if(Imode == 1) then
    inquire(unit=iGIN,opened=ifopen)
      if(.NOT.ifopen) call XError("-GIN is not defined!")
    inquire(unit=iGOU,opened=ifopen)
      if(.NOT.ifopen) call XError("-GOU is not defined!")
    inquire(unit=iCOU,opened=ifopen)
      if(.NOT.ifopen) call XError("-COU is not defined!")
  else
    inquire(unit=iGIN,opened=ifopen)
      if(.NOT.ifopen) call XError("-GIN is not defined!")
    inquire(unit=iCTP,opened=ifopen)
      if(.NOT.ifopen) call XError("-CTP is not defined!")
    inquire(unit=iCIN,opened=ifopen)
      if(.NOT.ifopen) call XError("-CIN is not defined!")
  end if

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read an argument, in upper case if ifUP
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine Get1Cmd(i,ifUP,ctmp)
  Implicit Real*8(A-H,O-Z)
  logical ifUP
  character*200 ctmp

  call get_command_argument(i,ctmp)
  ! call getarg(i,ctmp)
  if(ifUP) call charl2u(ctmp)

  Return
End

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! position of the first non-space character in a string.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
function nonspace(string)
  implicit double precision (a-h,o-z)
  character*(*) string

  length=LEN_TRIM(string)
  if(length <= 1) then
    i=length
  else
    do i=1,length
      if(string(i:i) /= ' ') exit
    end do
  endif

  nonspace=i

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! CHA --> cha
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine charu2l(cha)
  implicit real(kind=8) (a-h,o-z)
  character*(*) :: cha
  character*1  :: U2L

  do i=1,len_trim(cha)
    cha(i:i)=U2L(cha(i:i))
  end do

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! cha --> CHA
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine charl2u(cha)
  implicit real(kind=8) (a-h,o-z)
  character*(*) :: cha
  character*1  :: L2U

  do i=1,len_trim(cha)
    cha(i:i)=L2U(cha(i:i))
  end do

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! L --> l
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
function U2L(letter)
  implicit real(kind=8) (a-h,o-z)
  character*1 :: letter,U2L

  if((ichar(letter) >= 65).and.(ichar(letter) <= 90))then
    U2L=char(ichar(letter)+32)
  else
    U2L=letter
  endif

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! l --> L
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
function L2U(letter)
  implicit real(kind=8) (a-h,o-z)
  character*1 :: letter,L2U

  if( ichar(letter) >= 97 .and. ichar(letter) <= 122 )then
    L2U=char(ichar(letter)-32)
  else
    L2U=letter
  endif

  return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! read an error message and stop
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine XError(inf)
  implicit real(kind=8) (a-h,o-z)
  character*(*) :: inf

  write(*,"(/,' *** Error! ',a)")trim(inf)

  stop

return
end

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!
! Returns element symbol "el" for nuclear charge iza.
!
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
subroutine ElemZA(el,iza)
  implicit real(kind=8) (a-h,o-z)
  parameter (maxza=120)
  character*3 :: el,atomlib(maxza)
  data (atomlib(i),i=1,maxza) / &
   'H  ','HE ','LI ','BE ','B  ','C  ','N  ','O  ','F  ','NE ',   'NA ','MG ','AL ','SI ','P  ','S  ','CL ','AR ','K  ','CA ', &
   'SC ','TI ','V  ','CR ','MN ','FE ','CO ','NI ','CU ','ZN ',   'GA ','GE ','AS ','SE ','BR ','KR ','RB ','SR ','Y  ','ZR ', &
   'NB ','MO ','TC ','RU ','RH ','PD ','AG ','CD ','IN ','SN ',   'SB ','TE ','I  ','XE ','CS ','BA ','LA ','CE ','PR ','ND ', &
   'PM ','SM ','EU ','GD ','TB ','DY ','HO ','ER ','TM ','YB ',   'LU ','HF ','TA ','W  ','RE ','OS ','IR ','PT ','AU ','HG ', &
   'TL ','PB ','BI ','PO ','AT ','RN ','FR ','RA ','AC ','TH ',   'PA ','U  ','NP ','PU ','AM ','CM ','BK ','CF ','ES ','FM ', &
   'MD ','NO ','LR ','RF ','DB ','SG ','BH ','HS ','MT ','DS ',   'RG ','CN ','NH ','FL ','MC ','LV ','TS ','OG ','UUE','UBN'/
  save atomlib

  el = "???"
  if(iza > 0 .and. iza <= maxza) el = adjustl(atomlib(iza))
  call charu2l(el(2:3))

  return
end

!--- END


      SUBROUTINE G1MOVC(IFUNCO,IREPT)
C
C          ------------------------------------------------
C          ROUTINE NO. (1031)   VERSION (A7.6)    11:FEB:85
C          ------------------------------------------------
C
C          THIS PERFORMS THE CHARACTER CONTROL FUNCTIONS.
C
C
C          THE ARGUMENTS ARE AS FOLLOWS:
C
C          <IFUNCO> DETERMINES THE ACTION:
C                   =  1, A WHOLE SPACE FORWARD IS DONE,
C                   =  2, A HALF SPACE FORWARD IS DONE,
C                   =  3, A WHOLE SPACE BACK IS DONE,
C                   =  4, A HALF SPACE BACK IS DONE,
C                   =  5, A WHOLE LINE FEED IS DONE,
C                   =  6, A HALF LINE FEED IS DONE,
C                   =  7, A WHOLE LINE BACK IS DONE,
C                   =  8, A HALF LINE BACK IS DONE,
C                   =  9, A CARRIAGE RETURN IS DONE,
C                   = 10, A NEW PAGE IS BEGUN.
C          <IREPT>  GIVES THE NO. OF TIMES THIS IS REPEATED.
C
C
      LOGICAL SPACIN,FORWRD
      LOGICAL TYPMOD
C
      COMMON /T1CMOC/ ADDSPX,ADDLNX,ADDSPY,ADDLNY
      COMMON /T1CMOD/ TYPMOD
      COMMON /T1CPOS/ XCHAR,YCHAR
      COMMON /T1TSPA/ X1TYPW,X2TYPW,Y1TYPW,Y2TYPW
      COMMON /T1TYPQ/ IQUAD
C
C
      IF (IFUNCO.LT.1.OR.IFUNCO.GT.10) RETURN
      IF (IREPT.LT.1)                  RETURN
C
      FORWRD= .TRUE.
      GO TO (1,2,3,4,11,12,13,14,20,21), IFUNCO
C
C          THE FOLLOWING SECTIONS INITIALISE FOR FULL-SPACE
C          FORWARD, HALF-SPACE FORWARD, FULL-SPACE BACK AND
C          HALF-SPACE BACK, RESPECTIVELY. THE LOOP THEN DOES
C          THE REQUIRED ACTION <IREPT> TIMES, ALSO CHECKING
C          WHEN IN TYPING MODE TO ENSURE THAT PROPER WRAP-
C          ROUND OCCURS WHEN THE (BORDERED) CHAR. WINDOW IS
C          EXCEEDED. IF THE UPPER OR LOWER PAGE LIMITS ARE
C          ALSO EXCEEDED, A JUMP IS MADE TO LOOP-100 TO
C          ALLOW FOR THIS BEFORE CONTINUING WITH THE SPACES.
C
    1 XINCSP= ADDSPX
      YINCSP= ADDSPY
      GO TO 5
C
    2 XINCSP= 0.5*ADDSPX
      YINCSP= 0.5*ADDSPY
      GO TO 5
C
    3 XINCSP= -ADDSPX
      YINCSP= -ADDSPY
      FORWRD= .FALSE.
      GO TO 5
C
    4 XINCSP= -0.5*ADDSPX
      YINCSP= -0.5*ADDSPY
      FORWRD= .FALSE.
C
    5 IF (TYPMOD) GO TO 6
C
      XCHAR= XCHAR+IREPT*XINCSP
      YCHAR= YCHAR+IREPT*YINCSP
      RETURN
C
    6 ISTEPS= 0
    7   ISTEPS= ISTEPS+1
        IF (ISTEPS.GT.IREPT) RETURN
C
        XCHAR= XCHAR+XINCSP
        YCHAR= YCHAR+YINCSP
C
        IF ((IQUAD.EQ.1.OR.IQUAD.EQ.3).AND.
     &      ((XCHAR-X1TYPW)*(XCHAR-X2TYPW).GT.0.0)) GO TO 8
        IF ((IQUAD.EQ.2.OR.IQUAD.EQ.4).AND.
     &      ((YCHAR-Y1TYPW)*(YCHAR-Y2TYPW).GT.0.0)) GO TO 8
        GO TO 7
C
    8   IF (.NOT.FORWRD) GO TO 9
        XINCLN= ADDLNX
        YINCLN= ADDLNY
        IF (IQUAD.EQ.1) XCHAR= X1TYPW+0.0001
        IF (IQUAD.EQ.2) YCHAR= Y1TYPW+0.0001
        IF (IQUAD.EQ.3) XCHAR= X2TYPW-0.0001
        IF (IQUAD.EQ.4) YCHAR= Y2TYPW-0.0001
        GO TO 10
C
    9   XINCLN= -ADDLNX
        YINCLN= -ADDLNY
        IF (IQUAD.EQ.1) XCHAR= X2TYPW-0.0001
        IF (IQUAD.EQ.2) YCHAR= Y2TYPW-0.0001
        IF (IQUAD.EQ.3) XCHAR= X1TYPW+0.0001
        IF (IQUAD.EQ.4) YCHAR= Y1TYPW+0.0001
C
   10   IREPTL= 1
        SPACIN= .TRUE.
        GO TO 17
C
C          THE FOLLOWING SECTIONS PERFORM THE SAME FUNCTIONS FOR
C          FULL LINEFEEDS, HALF LINEFEEDS, FULL BACK LINES AND
C          HALF BACK LINES RESP., REPEATING THE ACTION EITHER
C          <IREPT> TIMES OR ONCE DEPENDING ON THE ORIGIN OF THE
C          ACTION. IF A PAGE OVERFLOW IS BEING CORRECTED AS A
C          RESULT OF A LINE OVERFLOW, CONTROL RETURNS TO LABEL-7.
C          LINE OVERFLOW CANNOT RESULT FROM A PAGE OVERFLOW, SO
C          EQUIVALENT USE OF THE PREVIOUS SECTION IS NOT NEEDED.
C
   11 XINCLN= ADDLNX
      YINCLN= ADDLNY
      GO TO 15
C
   12 XINCLN= 0.5*ADDLNX
      YINCLN= 0.5*ADDLNY
      GO TO 15
C
   13 XINCLN= -ADDLNX
      YINCLN= -ADDLNY
      FORWRD= .FALSE.
      GO TO 15
C
   14 XINCLN= -0.5*ADDLNX
      YINCLN= -0.5*ADDLNY
      FORWRD= .FALSE.
C
   15 IF (TYPMOD) GO TO 16
C
      XCHAR= XCHAR+IREPT*XINCLN
      YCHAR= YCHAR+IREPT*YINCLN
      RETURN
C
   16 IREPTL= IREPT
      SPACIN= .FALSE.
   17 DO 100 ISTEPL= 1,IREPTL
        XCHAR= XCHAR+XINCLN
        YCHAR= YCHAR+YINCLN
C
        IF ((IQUAD.EQ.2.OR.IQUAD.EQ.4).AND.
     &      ((XCHAR-X1TYPW)*(XCHAR-X2TYPW).GT.0.0)) GO TO 18
        IF ((IQUAD.EQ.1.OR.IQUAD.EQ.3).AND.
     &      ((YCHAR-Y1TYPW)*(YCHAR-Y2TYPW).GT.0.0)) GO TO 18
        GO TO 100
C
   18   IF (.NOT.FORWRD) GO TO 19
        IF (IQUAD.EQ.1) YCHAR= Y2TYPW-0.0001
        IF (IQUAD.EQ.2) XCHAR= X1TYPW+0.0001
        IF (IQUAD.EQ.3) YCHAR= Y1TYPW+0.0001
        IF (IQUAD.EQ.4) XCHAR= X2TYPW-0.0001
        GO TO 100
C
   19   IF (IQUAD.EQ.1) YCHAR= Y1TYPW+0.0001
        IF (IQUAD.EQ.2) XCHAR= X2TYPW-0.0001
        IF (IQUAD.EQ.3) YCHAR= Y2TYPW-0.0001
        IF (IQUAD.EQ.4) XCHAR= X1TYPW+0.0001
  100 CONTINUE
      IF (SPACIN) GO TO 7
      RETURN
C
C          THIS SECTION DOES A CARRIAGE RETURN (IE. RESETS
C          THE CHARACTER POSITION TO THE APPROPRIATE MARGIN)
C          PROVIDED THAT TYPING MODE IS CURRENTLY IN EFFECT.
C
   20 IF (.NOT.TYPMOD) RETURN
C
      IF (IQUAD.EQ.1) XCHAR= X1TYPW+0.0001
      IF (IQUAD.EQ.2) YCHAR= Y1TYPW+0.0001
      IF (IQUAD.EQ.3) XCHAR= X2TYPW-0.0001
      IF (IQUAD.EQ.4) YCHAR= Y2TYPW-0.0001
      RETURN
C
C          WHEN TYPING MODE IS SET, THIS SECTION WILL DO
C          A PAGE RESET BY RELOCATING THE CHAR. POSITION
C          TO THE TOP-LEFT CORNER OF THE CHARACTER SPACE.
C
   21 IF (.NOT.TYPMOD) RETURN
C
      IF (IQUAD.NE.1) GO TO 22
      XCHAR= X1TYPW+0.0001
      YCHAR= Y2TYPW-0.0001
      RETURN
C
   22 IF (IQUAD.NE.2) GO TO 23
      XCHAR= X1TYPW+0.0001
      YCHAR= Y1TYPW+0.0001
      RETURN
C
   23 IF (IQUAD.NE.3) GO TO 24
      XCHAR= X2TYPW-0.0001
      YCHAR= Y1TYPW+0.0001
      RETURN
C
   24 XCHAR= X2TYPW-0.0001
      YCHAR= Y2TYPW-0.0001
      RETURN
      END


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine pdg2id (ityp,iso3,pdgid)
c
c     Author   : Steffen A. Bass
c     Date     : 06/08/98
c     Revision : 1.0
c
c based on ityp2pdg.f from Henning Weber
c
c     converts PDG-Id to  UrQMD-Id
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      implicit none

      integer pdgid,i
      integer ityp
      integer iso3

      integer tab_size
      parameter (TAB_SIZE = 180)

      integer idtab(3,TAB_SIZE)

      data idtab/
c Neutron
     .       1, -1,  2112,
c Proton
     .       1,  1,  2212,
c N*
     .       2, -1, 12112,        2,  1, 12212,
     .       3, -1,  1214,        3,  1,  2124,
     .       4, -1, 22112,        4,  1, 22212,
     .       5, -1, 32112,        5,  1, 32212,
     .       6, -1,  2116,        6,  1,  2216,
     .       7, -1, 12116,        7,  1, 12216,
     .       8, -1, 21214,        8,  1, 22124,
     .       9, -1, 42112,        9,  1, 42212,
     .      10, -1, 31214,       10,  1, 32124,
     .      14, -1,  1218,       14,  1,  2128,
c Delta
     .      17, -3,  1114,  17, -1,  2114,  17, 1,  2214,  17, 3,  2224,
     .      18, -3, 31114,  18, -1, 32114,  18, 1, 32214,  18, 3, 32224,
     .      19, -3,  1112,  19, -1,  1212,  19, 1,  2122,  19, 3,  2222,
     .      20, -3, 11114,  20, -1, 12114,  20, 1, 12214,  20, 3, 12224,
     .      21, -3, 11112,  21, -1, 11212,  21, 1, 12122,  21, 3, 12222,
     .      22, -3,  1116,  22, -1,  1216,  22, 1,  2126,  22, 3,  2226,
     .      23, -3, 21112,  23, -1, 21212,  23, 1, 22122,  23, 3, 22222,
     .      24, -3, 21114,  24, -1, 22114,  24, 1, 22214,  24, 3, 22224,
     .      25, -3, 11116,  25, -1, 11216,  25, 1, 12126,  25, 3, 12226,
     .      26, -3,  1118,  26, -1,  2118,  26, 1,  2218,  26, 3,  2228,
c Lambda
     .      27,  0,  3122,
     .      28,  0, 13122,
     .      29,  0,  3124,
     .      30,  0, 23122,
     .      31,  0, 33122,
     .      32,  0, 13124,
     .      33,  0, 43122,
     .      34,  0, 53122,
     .      35,  0,  3126,
     .      36,  0, 13126,
     .      37,  0, 23124,
     .      38,  0,  3128,
     .      39,  0, 23126,
c Sigma
     .      40, -2,  3112,    40,  0,  3212,    40,  2,  3222,
     .      41, -2,  3114,    41,  0,  3214,    41,  2,  3224,
     .      42, -2, 13112,    42,  0, 13212,    42,  2, 13222,
     .      43, -2, 13114,    43,  0, 13214,    43,  2, 13224,
     .      44, -2, 23112,    44,  0, 23212,    44,  2, 23222,
     .      45, -2,  3116,    45,  0,  3216,    45,  2,  3226,
     .      46, -2, 13116,    46,  0, 13216,    46,  2, 13226,
     .      47, -2, 23114,    47,  0, 23214,    47,  2, 23224,
     .      48, -2,  3118,    48,  0,  3218,    48,  2,  3228,
c Xi
     .      49, -1,  3312,     49,  1,  3322,
     .      50, -1,  3314,     50,  1,  3324,
     .      51, -1,203312,     51,  1,203322,
     .      52, -1, 13314,     52,  1, 13324,
     .      53, -1,103316,     53,  1,103326,
     .      54, -1,203316,     54,  1,203326,
c Omega
     .      55,  0,  3334,
c gamma
     .     100,  0,    22,
c pion
     .     101, -2,  -211,    101,  0,   111,    101,  2,   211,
c eta
     .     102,  0,   221,
c omega
     .     103,  0,   223,
c rho
     .     104, -2,  -213,    104,  0,   113,    104,  2,   213,
c f0(980)
     .     105,  0,9010221,
c kaon
     .     106, -1,   311,    106,  1,   321,
c eta'
     .     107,  0,   331,
c k*(892)
     .     108, -1,   313,    108,  1,   323,
c phi
     .     109,  0,   333,
c k0*(1430)
     .     110, -1, 10311,    110,  1, 10321,
c a0(980)
     .     111, -2,-9000211,  111,  0, 9000111,  111,  2,9000211,
c f0(1370)
     .     112,  0, 10221,
c k1(1270)
     .     113, -1, 10313,    113,  1, 10323,
c a1(1260)
     .     114, -2,-20213,    114,  0, 20113,    114,  2, 20213,
c f1(1285)
     .     115,  0, 20223,
c f1'(1510)
     .     116,  0, 40223,
c k2*(1430)
     .     117, -1,   315,    117,  1,   325,
c a2(1329)
     .     118, -2,  -215,    118,  0,   115,    118,  2,   215,
c f2(1270)
     .     119,  0,   225,
c f2'(1525)
     .     120,  0,   335,
c k1(1400)
     .     121, -1, 20313,    121,  1, 20323,
c b1
     .     122, -2,-10213,    122,  0, 10113,    122,  2, 10213,
c h1
     .     123,  0, 10223,
c K* (1410)
     .     125, -1,100313,    125,  1,100323,
c rho (1450)
     .     126, -2,-100213,   126,  0,100113,    126,  2,100213,
c omega (1420)
     .     127,  0,100223,
c phi(1680)
     .     128,  0,100333,
c k*(1680)
     .     129, -1, 30313,    129,  1, 30323,
c rho(1700)
     .     130, -2,-30213,    130,  0, 30113,    130,  2, 30213,
c omega(1650)
     .     131,  0, 30223,
c phi(1850)
     .     132,  0,   337,
c D
     .     133,  -1,   421,    133,   1,   411,
c D*
     .     134,  -1, 10421,    134,   1, 10411,
c J/Psi
     .     135,  0, 443,
c Chi_c
     .     136,  0, 100443,
c Psi'
     .     137,  0, 10441,
c Ds
     .     138,   0,   431,
c Ds*
     .     139,   0,   433 /

cb search for the ITYP in IDTAB

      do 99 i=1,TAB_SIZE
         if(idtab(3,i).eq.pdgid) then
            ityp=idtab(1,i)
            iso3=idtab(2,i)
            return
         elseif((pdgid.lt.0).and.(idtab(3,i).eq.abs(pdgid))) then
            ityp=-1*idtab(1,i)
            iso3=-1*idtab(2,i)
            return
         endif
 99   continue

      ityp=99
      iso3=0
      return

c      write(6,*) ' fatal error in pdg2ityp: unknown PDG-Id: ',pdgid
c      stop

c handle all unknown ityps

      end


         program ELC
c
c   October 6, 1999
c
c   This is a total rewrite of the Avni code.
c
          implicit double precision(a-h,o-z)
c
          parameter(Nmaxphase=1500000)    ! was 1500000
          parameter(Nmaxeclipse=1000)
c
c   UPDATE September 11, 2001
c
c   Change the dimension of obsparm to 9.
c
c   UPDATE September 21, 2008
c
c   Change the dimension of obsparm to 11
c
c
c   UPDATE October 10, 2008
c
c   change the dimensions of obsparm, obv, sobv, and eobv to 11
c
          dimension obsparm(19)
          dimension xmod(Nmaxphase),ymodU(Nmaxphase),ymodB(Nmaxphase),
     $      ymodV(Nmaxphase),ymodR(Nmaxphase),ymodI(Nmaxphase),
     $      ymodJ(Nmaxphase),ymodH(Nmaxphase),ymodK(Nmaxphase),
     &      ymods1(Nmaxphase),ymods2(Nmaxphase),ymodd(Nmaxphase),
     &      RV1(Nmaxphase),RV2(Nmaxphase),ymods3(Nmaxphase),
     $      drv1(Nmaxphase),drv2(Nmaxphase),RV3(Nmaxphase)
          dimension wave(8),dbolx(8,2),dboly(8,2),dwavex(8,3),
     @       dwavey(8,3)
          dimension xRVmod(Nmaxphase)
c
c   RVG BUG ALERT  June 12, 2001
c
c   Dimension the variables needed for the model atmospheres here.
c
          parameter (maxlines=1300,maxmu=115)  ! was 960
          dimension atmT(maxlines),atmg(maxlines),atmmu(maxlines,maxmu),
     %       Nmu(maxlines)
          dimension atmint1(maxlines,maxmu),atmint2(maxlines,maxmu)
          dimension atmint3(maxlines,maxmu),atmint4(maxlines,maxmu)
          dimension atmint5(maxlines,maxmu),atmint6(maxlines,maxmu)
          dimension atmint7(maxlines,maxmu),atmint8(maxlines,maxmu)
c
c
c   RVG BUG ALERT   May 8, 2001
c
c   Define the variables needed for spots
c
          dimension spotdparm(2,4),spot1parm(2,4),spot2parm(2,4)
c
c
c   UPDATE JULY 7, 2004
c
c   This array is needed for the sub-random Sobel sequence, used in
c   place of ran9
c
          dimension xsob(2)
c
c   UPDATE May 8, 2006
c
c   Add this array for power-law limb darkening coefficients.
c   8=filter index, 9=coefficient c1,c2,c3 ...
c
          dimension powercoeff(8,9)
c
c
c   UPDATE January 12, 2009
c
c   make fracs fracs1, fracs2, .... fracs8 and put them in the
c   argument of subroutine lightcurve.  In this was one can use
c   Nmaxphase in the dimension statement
c
          dimension fracs1(Nmaxphase,4),fracs2(Nmaxphase,4)
          dimension fracs3(Nmaxphase,4),fracs4(Nmaxphase,4)
          dimension fracs5(Nmaxphase,4),fracs6(Nmaxphase,4)
          dimension fracs7(Nmaxphase,4),fracs8(Nmaxphase,4)
          dimension Ncycle(34),Ttimes(34,Nmaxeclipse),
     @       Tseps(34,Nmaxeclipse),Tdur1(34,Nmaxeclipse)
          dimension compfracs(8,3),Tdur2(34,Nmaxeclipse)
c
          dimension gaplow(9999),gaphigh(9999)
          dimension xSC(9999),ySC(9999)
c
c   NEW BUG ALERT  July 13, 2001
c
c   Add a new character string and common block for a 'parameter string'
c   This string of parameters will be fed to the genetic code to make it
c   easier to compute uncertainties on the physical quantities like mass
c   and radius.
c
c   UPDATE June 14, 2002
c
c   Make the length of parmstring character*237.
c
c   UPDATE October 31, 2002
c
c   Make the length of parmstring 249
c
c   UPDATE October 22, 2008
c
c   Make the length of parmstring 259
c
          character*1000 parmstring
          character*2000 planetparm
          character*1700 dynparm,line
c
c
c   NEW BUG August 2, 2001
c
c   Change 'sw4' to 'T0'
c
c   UPDATE August 10, 2004
c
c   Add the 8 variables below.
c
c   UPDATE May 8, 2006
c
c   Add sw21-sw24, powercoeff below.
c
c   UPDATE November 6, 2008
c
c   Add sw25-sw34
c
c          common /stringblock/ parmstring,planetparm,dynparm,line
cc
c          common /realblock/ fill1,fill2,omega1,omega2,dphase,Q,finc,
c     @      Teff1,Teff2,Tgrav1,Tgrav2,betarim,rinner,router,tdisk,xi,
c     &      alb1,alb2,rLx,Period,fm,separ,gamma,wave,dbolx,dboly,dwavex,
c     @      dwavey,t3,g3,SA3,density,sw1,sw2,sw3,T0,ecc,argper,pshift,
c     @      sw5,sw6,sw7,sw8,sw9,primmass,primK,primrad,ratrad,frac1,
c     @      frac2,ecosw,temprat,bigI,bigbeta,sw23,sw24,powercoeff,sw25,
c     @      sw26,sw27,sw28,sw29,sw30,contam,Tconj,beam1,beam2,ocose,
c     @      osine,omegadot,contamS0,contamS1,contamS2,contamS3,sw47,
c     @      sw48,sw49,gaplow,gaphigh,
c     @      P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,P2Q,
c     @         P2ratrad,
c     @         P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,P3Omega,P3Q,
c     @         P3ratrad,
c     @         P4tconj,P4period,P4T0,P4ecos,P4esin,P4incl,P4Omega,P4Q,
c     @         P4ratrad,
c     @         P5tconj,P5period,P5T0,P5ecos,P5esin,P5incl,P5Omega,P5Q,
c     @         P5ratrad,
c     @         P6tconj,P6period,P6T0,P6ecos,P6esin,P6incl,P6Omega,P6Q,
c     @         P6ratrad,
c     @         P7tconj,P7period,P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,
c     @         P7ratrad,
c     @         P8tconj,P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,
c     @         P8ratrad,xSC,ySC
cc
c          common /spotblock/ spot1parm,spot2parm,spotdparm
cc
c          common /intblock/ Nalph1,Nbet1,Nalph2,Nbet2,
c     &       Ntheta,Nradius,Nref,
c     $       idraw,iecheck,iidint,iatm,ism1,
c     $       ilaw,icnU,icnB,icnV,icnR,icnI,icnJ,icnH,icnK,icnRV1,icnRV2,
c     &       iRVfilt,isw1,isw2,isw3,isw4,
c     %       ikeep,isynch,isw5,isw6,isw7,isw8,isw9,idark1,idark2,isw12,isw13,
c     %       isw21,isw22,isw23,isw24,
c     %       isw25,isw26,isw27,isw28,isw29,isw30,isw31,isw32,isw33,isw34,
c     $       NSC
cc
c          common /fracblock/ compfracs
cc
c          common /thirdblock/ tertperiod,tertt0,tertecos,tertesin,
c     @        tertincl,tertOmega,tertQ,tertconj,tertratrad,hh,sw72,sw73
c
          common /realatm/ atmT,atmg,atmmu,atmint1,atmint2,atmint3,
     @     atmint4,atmint5,atmint6,atmint7,atmint8,Tmax,Tmin,gmax,gmin

          common /intatm/  Nlines,Nmu,Nalph3,Nbet3,itconj,it1,it2,it3,
     @     it4
c
c
c   Open the parameter file and read all of the parameters.
c   Pass the parameters to the light curve routines
c   via a common block.
c
        ifastflag=0   !disable fast genetic mode
c
c   RVG BUG ALERT  May 9, 2001
c
c   Add the spot parameters to the arguments of getinput and recordparm
c
c   UPDATE August 10, 2004
c
c   Add the 8 real variables and 4 integer variables to the list.
c
          call getinput(Nalph1,Nbet1,Nalph2,Nbet2,fill1,fill2,omega1,
     $       omega2,dphase,Q,finc,Teff1,Teff2,Tgrav1,Tgrav2,betarim,
     $       rinner,router,tdisk,xi,Ntheta,Nradius,alb1,alb2,Nref,
     %       rLx,Period,fm,separ,gamma,t3,g3,SA3,density,sw1,sw2,sw3,T0,
     $       idraw,iecheck,iidint,iatm,ism1,icnU,icnB,icnV,icnR,icnI,
     @       icnJ,icnH,icnK,iRVfilt,isw1,isw2,isw3,isw4,ilaw,wave,dbolx,
     @       dboly,dwavex,dwavey,ecc,argper,pshift,sw5,sw6,sw7,sw8,sw9,
     $       ikeep,isynch,isw5,isw6,isw7,isw8,isw9,spot1parm,spot2parm,
     %       spotdparm,primmass,primK,primrad,ratrad,frac1,frac2,ecosw,
     %       temprat,idark1,idark2,isw12,isw13,isw21,isw22,isw23,isw24,
     @       bigI,bigbeta,sw23,sw24,powercoeff, sw25,sw26,sw27,sw28,
     @       sw29,sw30,contam,Tconj,beam1,beam2,isw25,isw26,isw27,isw28,
     &       isw29,isw30,isw31,isw32,isw33,isw34,ocose,osine,omegadot,
     @       contamS0,contamS1,contamS2,contamS3,sw47,sw48,sw49)
c
c   UPDATE May 8, 2006
c
c   Add isw21-isw24, sw21-sw24, powercoeff to list above.
c
c
c   Load the atmosphere table here, rather than in the subroutine
c
c  If the flag iatm>0, then load the model atmosphere table.
c
          if(iatm.ge.1)then
            call loadtable(maxlines,maxmu,Nlines,atmT,atmg,atmmu,Nmu,
     &         atmint1,atmint2,atmint3,atmint4,atmint5,
     @         atmint6,atmint7,atmint8,Tmax,Tmin,gmax,gmin)
          endif
c
c   November 17, 2012
c
c   If isw30 >= 1, then load the third body parameters
c
          if((isw30.ge.1).and.(isw7.ge.2))then
            call getbody3(Nalph3,Nbet3,tertperiod,tertt0,tertecos,
     @         tertesin,tertincl,tertOmega,tertQ,dwavex,dwavey,itconj,
     @         it1,it2,it3,it4,tertconj,tertratrad,hh,sw72,sw73,
     @         P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,P2Q,
     @         P2ratrad,
     @         P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,P3Omega,P3Q,
     @         P3ratrad,
     @         P4tconj,P4period,P4T0,P4ecos,P4esin,P4incl,P4Omega,P4Q,
     @         P4ratrad,
     @         P5tconj,P5period,P5T0,P5ecos,P5esin,P5incl,P5Omega,P5Q,
     @         P5ratrad,
     @         P6tconj,P6period,P6T0,P6ecos,P6esin,P6incl,P6Omega,P6Q,
     @         P6ratrad,
     @         P7tconj,P7period,P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,
     @         P7ratrad,
     @         P8tconj,P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,
     @         P8ratrad)
c
c   if it1=1, assume the mass ratios are logs
c
            if(it1.eq.1)then
              savtertQ=tertQ
              savP2Q=P2Q
              savP3Q=P3Q
              savP4Q=P4Q
              savP5Q=P5Q
              savP6Q=P6Q
              savP7Q=P7Q
              savP8Q=P8Q
              tertQ=10.0d0**(tertQ)
              P2Q=10.0d0**(P2Q)
              P3Q=10.0d0**(P3Q)
              P4Q=10.0d0**(P4Q)
              P5Q=10.0d0**(P5Q)
              P6Q=10.0d0**(P6Q)
              P7Q=10.0d0**(P7Q)
              P8Q=10.0d0**(P8Q)
            endif
          endif
c
c   UPDATE December 15, 2012
c
c   if isw31 >= 1, load the gap parameters
c
          if(isw31.ge.1)call getgap(isw31,gaplow,gaphigh)
c
          NSC=0
          call getSC(NSC,xSC,ySC)
c
c   UPDATE JULY 7, 2004
c
c   Initialize the Sobel sequence here.
c
          nnn=-11
          call sobseq(nnn,xsob)
c
c   UPDATE January 30, 2010
c
c   if isw28 is greater than 0, then set the value of T0 based
c   on the time of transit Tconj.
c
          if(isw28.gt.0)then
            call getT0(finc,period,ecc,argper,T0,Tconj)
          endif
c
          call lightcurve(Nphase,Nmaxphase,xmod,ymodU,ymodB,
     $      ymodV,ymodR,ymodI,ymodJ,ymodH,ymodK,ymods1,ymods2,ymods3,
     %      ymodd,RV1,RV2,drv1,drv2,obsparm,ifastflag,NRVphase,xRVmod,
     &         fracs1,fracs2,fracs3,fracs4,fracs5,fracs6,fracs7,fracs8,
     @         Ncycle,Ttimes,Tseps,RV3,parmstring,planetparm,dynparm,
     @    line,fill1,fill2,omega1,
     @    omega2,dphase,Q,finc,Teff1,Teff2,Tgrav1,Tgrav2,betarim,
     @    rinner,router,tdisk,xi,alb1,alb2,rLx,Period,fm,separ,
     @    gamma,wave,dbolx,dboly,dwavex,dwavey,t3,g3,SA3,density,
     @    sw1,sw2,sw3,T0,ecc,argper,pshift,sw5,sw6,sw7,sw8,sw9,
     @    primmass,primK,primrad,ratrad,frac1,frac2,ecosw,temprat,
     @    bigI,bigbeta,sw23,sw24,powercoeff,sw25,sw26,sw27,sw28,
     @    sw29,sw30,contam,Tconj,beam1,beam2,ocose,osine,omegadot,
     @    contamS0,contamS1,contamS2,contamS3,sw47,sw48,sw49,gaplow,
     @    gaphigh,P2tconj,P2period,P2T0,P2ecos,P2esin,P2incl,P2Omega,
     @    P2Q,P2ratrad,P3tconj,P3period,P3T0,P3ecos,P3esin,P3incl,
     @    P3Omega,P3Q,P3ratrad,P4tconj,P4period,P4T0,P4ecos,P4esin,
     @    P4incl,P4Omega,P4Q,P4ratrad,P5tconj,P5period,P5T0,P5ecos,
     @    P5esin,P5incl,P5Omega,P5Q,P5ratrad,P6tconj,P6period,P6T0,
     @    P6ecos,P6esin,P6incl,P6Omega,P6Q,P6ratrad,P7tconj,P7period,
     @    P7T0,P7ecos,P7esin,P7incl,P7Omega,P7Q,P7ratrad,P8tconj,
     @    P8period,P8T0,P8ecos,P8esin,P8incl,P8Omega,P8Q,P8ratrad,
     @    xSC,ySC,spot1parm,spot2parm,spotdparm,Nalph1,Nbet1,Nalph2,
     @    Nbet2,Ntheta,Nradius,Nref,idraw,iecheck,iidint,iatm,ism1,
     @    ilaw,icnU,icnB,icnV,icnR,icnI,icnJ,icnH,icnK,icnRV1,icnRV2,
     @    iRVfilt,isw1,isw2,isw3,isw4,ikeep,isynch,isw5,isw6,isw7,
     @    isw8,isw9,idark1,idark2,isw12,isw13,isw21,isw22,isw23,isw24,
     @    isw25,isw26,isw27,isw28,isw29,isw30,isw31,isw32,isw33,isw34,
     @    NSC,compfracs,tertperiod,tertt0,tertecos,tertesin,
     @    tertincl,tertOmega,tertQ,tertconj,tertratrad,hh,sw72,sw73,
     @    Nmaxeclipse,Tdur1,Tdur2)
c
          if((isw30.ge.1).and.(it1.eq.1))then
            tertQ=savtertQ
            P2Q=savP2Q
            P3Q=savP3Q
            P4Q=savP4Q
            P5Q=savP5Q
            P6Q=savP6Q
            P7Q=savP7Q
            P8Q=savP8Q
          endif
c
c   Write out eclipse times if isw23 > 0 and Nbody >= 3
c
          if((isw30.ge.3).and.(isw23.ge.1))then
            call writeeclipse(Ncycle,Ttimes,Tseps,isw30,Nmaxeclipse,
     @        Tdur1,Tdur2)
          endif
c
          call wlinmod(Nphase,xmod,ymodU,'modelU.linear',isw7)
          call wlinmod(Nphase,xmod,ymodB,'modelB.linear',isw7)
          call wlinmod(Nphase,xmod,ymodV,'modelV.linear',isw7)
          call wlinmod(Nphase,xmod,ymodR,'modelR.linear',isw7)
          call wlinmod(Nphase,xmod,ymodI,'modelI.linear',isw7)
          call wlinmod(Nphase,xmod,ymodJ,'modelJ.linear',isw7)
          call wlinmod(Nphase,xmod,ymodH,'modelH.linear',isw7)
          call wlinmod(Nphase,xmod,ymodK,'modelK.linear',isw7)
c
          zp=80.0d0
          call wmagmod(Nphase,xmod,ymodU,'modelU.mag',isw7,zp)
          call wmagmod(Nphase,xmod,ymodB,'modelB.mag',isw7,zp)
          call wmagmod(Nphase,xmod,ymodV,'modelV.mag',isw7,zp)
          call wmagmod(Nphase,xmod,ymodR,'modelR.mag',isw7,zp)
          call wmagmod(Nphase,xmod,ymodI,'modelI.mag',isw7,zp)
          call wmagmod(Nphase,xmod,ymodJ,'modelJ.mag',isw7,zp)
          call wmagmod(Nphase,xmod,ymodH,'modelH.mag',isw7,zp)
          call wmagmod(Nphase,xmod,ymodK,'modelK.mag',isw7,zp)

          call wlinmod(Nphase,xmod,ymods1,'lcstar1.linear',isw7)
          call wlinmod(Nphase,xmod,ymods2,'lcstar2.linear',isw7)
          call wlinmod(Nphase,xmod,ymods3,'lcstar3.linear',isw7)
          if(iidint.ge.1)call wlinmod(Nphase,xmod,ymodd,'lcdisk.linear',isw7)
c
          call wlinmod(NRVphase,xRVmod,RV1,'star1.RV',isw7)
          call wlinmod(NRVphase,xRVmod,RV2,'star2.RV',isw7)
          if(isw30.ge.3)call wlinmod(NRVphase,xRVmod,RV3,'star3.RV',
     @          isw7)
          call wlinmod(NRVphase,xRVmod,dRV1,'star1.delRV',isw7)
          call wlinmod(NRVphase,xRVmod,dRV2,'star2.delRV',isw7)
c

c
c   RVG BUG ALERT   May 16, 2001
c
c   Close the input file within the lightcurve subroutine, not here.
c
c          close(2)   ! close the output file
c
          end
c
c   &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
c
          include 'lcsubs.for'
          include 'dynamicssubs.for'


MODULE vector_class
!
!   This module implements a vector class.  This initial
!   version of the class holds an arbitrary-length rank 1
!   REAL vector.  It includes procedures to put and gut
!   the data, as well as a finalizer to deallocate the
!   data before an object of this type is destroyed.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/29/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Type definition
TYPE,PUBLIC :: vector  ! This will be the name we instantiate

   ! Instance variables.
   PRIVATE
   REAL,DIMENSION(:),POINTER :: v
   LOGICAL :: v_allocated = .FALSE.

CONTAINS

   ! Bound procedures
   PROCEDURE,PUBLIC :: set_vector => set_vector_sub
   PROCEDURE,PUBLIC :: get_vector => get_vector_sub
   FINAL :: clean_vector

END TYPE vector

! Restrict access to the actual procedure names
PRIVATE :: set_vector_sub, get_vector_sub, clean_vector_sub

! Now add methods
CONTAINS

   SUBROUTINE set_vector_sub(this, array)
   !
   ! Subroutine to store data in the vector
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(vector) :: this                 ! Vector object
   REAL,DIMENSION(:),INTENT(IN) :: array ! Input data

   ! Declare local variables
   INTEGER :: istat                      ! Allocate status

   ! Save data, for deleting any data that might have been
   ! stored in this object.
   IF ( this%v_allocated ) THEN
      DEALLOCATE(this%v,STAT=istat)
   END IF
   ALLOCATE(this%v(SIZE(array,1)),STAT=istat)
   this%v = array
   this%v_allocated = .TRUE.

   END SUBROUTINE set_vector_sub

   SUBROUTINE get_vector_sub(this, array)
   !
   ! Subroutine to get data in the vector
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(vector) :: this                  ! Vector object
   REAL,DIMENSION(:),INTENT(OUT) :: array ! Output data

   ! Declare local variables
   INTEGER :: array_length                ! Length of array
   INTEGER :: data_length                 ! Length of data vector
   INTEGER :: istat                       ! Allocate status

   ! Retrieve data.  If the size of the stored data does
   ! not match the array size, then return only a subset
   ! of the data or else pad the real data with zeros.
   IF ( this%v_allocated ) THEN

      ! Return as much data as possible, truncating or
      ! zero padding as necessary.
      array_length = SIZE(array,1)
      data_length  = SIZE(this%v,1)
      IF ( array_length > data_length ) THEN
         array(1:data_length) = this%v
         array(data_length+1:array_length) = 0
      ELSE IF ( array_length == data_length ) THEN
         array = this%v
      ELSE
         array = this%v(1:array_length)
      END IF

   ELSE

      ! No data--return zeros.
      array = 0

   END IF

   END SUBROUTINE get_vector_sub

   SUBROUTINE clean_vector(this)
   !
   ! Subroutine to finalize the vector
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(vector) :: this                 ! Vector object

   ! Declare local variables
   INTEGER :: istat                      ! Allocate status

   ! Debugging message
   WRITE (*,*) 'In finalizer ...'

   ! Save data, for deleting any data that might have been
   ! stored in this object.
   IF ( this%v_allocated ) THEN
      DEALLOCATE(this%v,STAT=istat)
   END IF

   END SUBROUTINE clean_vector

END MODULE vector_class