Chimie Théorique » Opt'n Path

SUBROUTINE WriteMixed_Gaussian(na,atome,NCart,ind_zmat,val_zmat)

!----------------------------------------------------------------------

!  Copyright 2003-2014 Ecole Normale Supérieure de Lyon,

!  Centre National de la Recherche Scientifique,

!  Université Claude Bernard Lyon 1. All rights reserved.

!

!  This work is registered with the Agency for the Protection of Programs

!  as IDDN.FR.001.100009.000.S.P.2014.000.30625

!

!  Authors: P. Fleurat-Lessard, P. Dayal

!  Contact: optnpath@gmail.com

!

! This file is part of "Opt'n Path".

!

!  "Opt'n Path" is free software: you can redistribute it and/or modify

!  it under the terms of the GNU Affero General Public License as

!  published by the Free Software Foundation, either version 3 of the License,

!  or (at your option) any later version.

!

!  "Opt'n Path" 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 Affero General Public License for more details.

!

!  You should have received a copy of the GNU Affero General Public License

!  along with "Opt'n Path". If not, see <http://www.gnu.org/licenses/>.

!

! Contact The Office of Technology Licensing, valorisation@ens-lyon.fr,

! for commercial licensing opportunities.

!----------------------------------------------------------------------

  Use Path_module, only :   Nom

  Use Io_module

  IMPLICIT NONE

! Parameters of the subroutine

! na: number of atoms in the system

  integer(KINT), INTENT(IN) ::  na

! atome: Mass number of the atoms of the system

  integer(KINT), INTENT(IN) ::  atome(na)

! nCart: number of atoms described in cartesian

  integer(KINT), INTENT(IN) ::  NCart

! ind_zmat: for "zmat" atoms contains the indices of reference atoms

  integer(KINT), INTENT(IN) ::  ind_zmat(Na,5)

! val_zmat: for "zmat" atoms contains the values from reference atoms

  real(KREAL), INTENT(IN)   :: val_zmat(Na,3)

  character(6) :: at1, at2, at3, at4, d, a, dh

  Character(6) :: x,y,z

  character(SCHARS), ALLOCATABLE :: tab(:) ! 3*na

  character(LCHARS) :: ligne

  INTEGER(KINT) :: i,n1,n2,n3,n4, NZmat,ITab

  ALLOCATE(tab(3*na))

! We first write the Cartesian atoms

  DO I=1,NCart

! Name of the atom

     n1=ind_zmat(i,1)

     write(at1,11) nom(atome(n1)),n1

     Call CleanString(at1,' ')

! x

     write(x,11) 'x',i

     Call CleanString(x,' ')

     write(tab(3*i-2),'(A,1X,F12.8)') trim(x),val_zmat(i,1)

! y

     write(y,11) 'y',i

     Call CleanString(y,' ')

     write(tab(3*i-1),'(A,1X,F12.8)') trim(y),val_zmat(i,2)

! z

     write(z,11) 'z',i

     Call CleanString(z,' ')

     write(tab(3*i),'(A,1X,F12.8)') trim(z),val_zmat(i,3)

! write the line

     write(ligne,'(1X,A,1X,A,1X,A,1X,A)') Trim(at1),x,y,z

     write(IOOUT,*) TRIM(ligne)

  END DO

  NZmat=na-NCart

  ITab=3*NCart+1

  DO i=NCart+1,NZmat

     IF (i .GE. 1)  THEN

        n1=ind_zmat(i,1)

        write(at1,11) nom(atome(n1)),n1

11      format(a2,i3)

        Call CleanString(at1,' ')

        write(ligne,4) at1

     END IF

     IF (i .GE. 2)  THEN

        n2=ind_zmat(i,2)

        write(at2,11) nom(atome(n2)),n2

        Call CleanString(At2,' ')

        write(d,11) 'R',i-1

        Call CleanString(D,' ')

        write(ligne,4) at1,at2,d

        write(tab(ITab),12) d,val_zmat(i,1)

        ITab=ITab+1

12      format(a8,f8.4)

     END IF

     IF (i .GE. 3)  THEN

        n3=ind_zmat(i,3)

        write(at3,11) nom(atome(n3)),n3

        Call CleanString(At3,' ')

        write(a,11) 'A',na+i-3

        Call CleanString(A,' ')

        write(ligne,4) at1,at2,d,at3,a

        write(tab(ITab),13) a,val_zmat(i,2)

        ITab=ITab+1

13      format(a8,f8.3)

     END IF

     IF (i .GE. 4)  THEN

        n4=ind_zmat(i,4)

        write(at4,11) nom(atome(n4)),n4

        Call CleanString(At4,' ')

        write(dh,11) 'DH',na+na+i-6

        Call CleanString(dh,' ')

        write(ligne,4) at1,at2,d,at3,a,at4,dh

4       format(7a6)

        write(tab(ITab),13) dh,val_zmat(i,3)

        ITab=ITab+1

     END IF

     write(IOOUT,*) TRIM(ligne)

     END DO

     write(IOOUT,*)

     DO i=1,ITab

        write(IOOUT,*) TRIM(tab(i))

     END DO

     write(IOOUT,*)

     DEALLOCATE(Tab)

   END SUBROUTINE WriteMixed_Gaussian