      module mod_rotat
      integer,private :: natom
      integer :: nrot
      character(4),private,allocatable,dimension(:) :: atom
      real(8),private,allocatable,dimension(:,:) :: coor
      character(4),allocatable,dimension(:) :: rot_atom
      real(8),allocatable,dimension(:,:) :: rot_coor
      integer,private :: i,j,k,l,ii,jj,kk,ll
      
      contains
!*******************************************************************
       subroutine init_rotat(norb,natom_in,atom_in,coor_in)
      implicit none
      character(4),intent(in),dimension(natom_in) :: atom_in
      real(8),intent(in),dimension(3,natom_in) :: coor_in
      integer,intent(in) :: norb,natom_in
      allocate(rot_atom(natom_in))
      allocate(rot_coor(3,natom_in))
      allocate(atom(natom_in))
      allocate(coor(3,natom_in))
      nrot=0
      natom=natom_in
      atom=atom_in
      coor=coor_in
      end subroutine
!*******************************************************************
       subroutine close_rotat
      implicit none
      print*,'CLOSE_ROTAT'
!      if(allocated(atom)) deallocate(atom)
!      if(allocated(coor)) deallocate(coor)
!      if(allocated(rot_atom)) deallocate(rot_atom)
!      if(allocated(rot_coor)) deallocate(rot_coor)
      nrot=0
      end subroutine
!*******************************************************************
       subroutine rotat1(donnee)
      implicit none
      character(*) donnee
      character(132) donnee_tmp
      !chracter(4) atom1
      character(80) para,ortho
      character(4) at1,at2,at3
      real(8) x1,x2,x3,y1,y2,y3,z1,z2,z3,anorm
      logical yw
      yw=.false.
      
      if(yw)print*,'entree rotat1 ',trim(donnee)
      if(yw)print*,'atom',atom(1:natom)
      if(yw)print*,'coor'
      if(yw)call script(coor,3,natom,3,natom)
!
! Donnee:
! ROT_ atom='C1',para='0,C1'
! ROT_ atom='C2',ortho='0,C1,C3'
!
      nrot=nrot+1
      para=' '
      ortho=' '
      if(index(donnee,'CLOSE')>0) then
         call close_rotat
         return
      endif
      donnee_tmp=donnee
      call namela(donnee_tmp,rot_atom(nrot),'ATOM')
      call namela(donnee_tmp,PARA,'PARA')
      call namela(donnee_tmp,ORTHO,'ORTHO')
      if(yw)print*,'para',para

      if(para/=' ') then
         if(ortho/=' ') stop
     *   'give only para or ortho, but not both of them'
!        compute "para" vector
         i=index(para,',')
         at1=para(1:i-1)
         at2=para(i+1:len_trim(para))
         call ch_coor(at1,x1,y1,z1)
         call ch_coor(at2,x2,y2,z2)
         if(yw)print*,'DONNEE ',trim(donnee_tmp)
         call nameld(donnee_tmp,X1,'X1',8)
         call nameld(donnee_tmp,Y1,'Y1',8)
         call nameld(donnee_tmp,Z1,'Z1',8)
         call nameld(donnee_tmp,X2,'X2',8)
         call nameld(donnee_tmp,Y2,'Y2',8)
         call nameld(donnee_tmp,Z2,'Z2',8)
         if(yw)print'(a,3f10.6)','x1,y1,z1',x1,y1,z1
         if(yw)print'(a,3f10.6)','x2,y2,z2',x2,y2,z2
         x1=x2-x1
         y1=y2-y1
         z1=z2-z1
         anorm=sqrt(x1*x1+y1*y1+z1*z1)
         rot_coor(1,nrot)=x1/anorm
         rot_coor(2,nrot)=y1/anorm
         rot_coor(3,nrot)=z1/anorm
         print'(a,3f10.6)','ROT_ vector',rot_coor(:,nrot)
      else if(ortho/=' ') then
         i=index(ortho,',')
         ortho(i:i)=' '
         j=index(ortho,',')
         at1=para(1:i-1)
         at2=para(i+1:j-1)
         at3=para(j+1:len_trim(ortho))
         call ch_coor(at1,x1,y1,z1)
         call ch_coor(at2,x2,y2,z2)
         call ch_coor(at3,x3,y3,z3)
         call nameld(donnee_tmp,X1,'X1',8)
         call nameld(donnee_tmp,Y1,'Y1',8)
         call nameld(donnee_tmp,Z1,'Z1',8)
         call nameld(donnee_tmp,X2,'X2',8)
         call nameld(donnee_tmp,Y2,'Y2',8)
         call nameld(donnee_tmp,Z2,'Z2',8)
         call nameld(donnee_tmp,X3,'X3',8)
         call nameld(donnee_tmp,Y3,'Y3',8)
         call nameld(donnee_tmp,Z3,'Z3',8)
         if(yw)print'(a,3f10.6)','x1,y1,z1',x1,y1,z1
         if(yw)print'(a,3f10.6)','x2,y2,z2',x2,y2,z2
         if(yw)print'(a,3f10.6)','x3,y3,z3',x3,y3,z3
         x2=x3-x2
         y2=y3-y2
         z2=z3-z2
         x1=x3-x1
         y1=y3-y1
         z1=z3-z1
         rot_coor(1,nrot)=y2*z1-z2*y1
         rot_coor(2,nrot)=-x2*z1+z2*x1
         rot_coor(3,nrot)=x2*y1-y2*x1
!         anorm=sqrt(rot_coord(1,nrot)*rot_coord(1,nrot)+
!     *   rot_coord(2,nrot)*rot_coord(2,nrot)+
!     *   rot_coord(3,nrot)*rot_coord(3,nrot))
         anorm=sqrt(dot_product(rot_coor(:,nrot),rot_coor(:,nrot)))
         rot_coor(:,nrot)=rot_coor(:,nrot)/anorm
      endif
      print*,'donnee__',trim(donnee)
      end subroutine
!*******************************************************************
       subroutine rotat2(ul,n,m,orbi,sym1,nsym,is,v)
      implicit none
      real(8) ul(n,n),anorm,v(n,n)
      integer n,m
      character(8) orbi(n),orbi1
      real(8),allocatable :: pass(:,:)
      logical,allocatable :: y(:)
      character(3) sym1(nsym-1)
      integer nsym,is
      real(8) verif(20,20)
      logical yw
      yw=.false.
      allocate(y(n))
      y=.false.
      if(yw)print*,'ul'
      if(yw)call script(ul,n,n,n,n)
      if(yw)print*,'orbi'
      if(yw)print*,orbi
      if(yw)print*,'rot_atom',rot_atom
      if(yw)print*,'rot_coor'
      if(yw)print*,'sym1',sym1
      if(yw)call script(rot_coor,3,nrot,3,natom)

      
      ii=0
      do i=1,nrot
         do j=1,n
            orbi1=orbi(j)
            if(rot_atom(i)==orbi(j)(1:4)) then
               y(j)=.true.
               ii=ii+1
               cycle
            endif
         enddo
      enddo
      if(yw)print*,'n,ii',n,ii
      ii=n-ii
               

      allocate(pass(n,nrot+ii))
      pass=0.d0

      do i=1,nrot
         do j=1,n
            orbi1=orbi(j)
            call maj(orbi1,8)
            if(rot_atom(i)==orbi(j)(1:4)) then
               if(orbi1(7:7)=='X') then
                  pass(j,i)=rot_coor(1,i)
               else if(orbi1(7:7)=='Y') then
                  pass(j,i)=rot_coor(2,i)
               else if(orbi1(7:7)=='Z') then
                  pass(j,i)=rot_coor(3,i)
               endif
            endif
         enddo
      enddo
      
      kk=0
      do i=1,nrot+ii
         anorm=dot_product(pass(:,i),pass(:,i))
         if(anorm>1.d-6) then
            kk=kk+1
            pass(:,kk)=pass(:,i)
         endif
      enddo
      if(yw)call script(pass,n,kk,n,nrot+ii)
      if(yw)print*,'verif'
      if(yw)
     *verif(1:kk,1:kk)=matmul(transpose(pass(:,1:kk)),pass(:,1:kk))
      if(yw)call script(verif,kk,kk,20,20)
      if(yw)
     *verif(1:n,1:n)=matmul(pass(:,1:kk),transpose(pass(:,1:kk)))
      if(yw)call script(verif,n,n,20,20)

      ul(1:kk,1:kk)=matmul(transpose(pass(:,1:kk)),
     *matmul(ul,pass(:,1:kk)))
      if(yw)print*,'ul reduit'
      if(yw)call script(ul,kk,kk,n,n)
      call hdiag(ul,v,kk,n)
      if(yw)call script(ul,kk,kk,n,n)
      if(yw)call script(pass,n,kk,n,nrot+ii)
      if(yw)call script(v,kk,kk,n,n)
      v(1:n,1:kk)=matmul(pass(:,1:kk),v(1:kk,1:kk))
      !v(1:n,1:kk)=matmul(v(1:kk,1:kk),pass(1:n,1:kk))
      if(yw)call script(v,n,kk,n,n)
      m=kk
      deallocate(y,pass)
      end subroutine
!*******************************************************************
       subroutine ch_coor(at1,x1,y1,z1)
      implicit none
      character(4) at1
      real(8) x1,y1,z1
      if(at1=='0') then
         x1=0.d0
         y1=0.d0
         z1=0.d0
      else
         do i=1,natom
            if(at1==atom(i)) then
               x1=coor(1,i)
               y1=coor(2,i)
               z1=coor(3,i)
               !print*,'trouve',i,x1,y1,z1
               return
            end if
         end do
         print*,'Rot: atom '//at1//' not found'
         stop
      endif
      end subroutine
!*******************************************************************
      end module
      
