subroutine group
use lewis_module
use mod_script
use mod_lirorb
implicit real*8 (a-h,o-x,z),logical*1(y)
logical :: yw=.false.
character(200) :: bond
character(100) oa,nom
integer :: numero_OA0,g_occ,g_vir,g_act,g_numac(32),g_nelac,g_occ_s,g_vir_s
integer :: fnat_tmp
character(11) :: ecrlabel


!
!=====================================================================
! Generation d'orbitales locales par diagonalisation de
! sous-matrices densite
!=====================================================================
!

if(scforbin==' ') then
    call titre('Donnee GROUP : '// &
    'Aucun fichier d''orbitales de reference' &
    //'n''a ete trouve#On orthonormalise maintenant les OL#' &
    //'stop',60)
    stop
endif

!
!----------------------------------------------
! Extraire la matrice densite des OA trouvees
!----------------------------------------------
!
!
! Lire la matrice densite dans la base des OA symetriques
!
call open_chose_number(ifil_dens,'DENS_OA','unknown', &
'unformatted')
read(ifil_dens) dens

if(yw) then
   do i=1,norb
      print*,'label_OA',i,ecrlabel(label(i))
   enddo
   print*,' '
   !print*,'matrice densite'
   !call mscript(dens)
endif


!
! Lecture de la donnee "GROUP", stockage dans un fichier
!
open(99)
long_data=-1
do
   read(5,'(A)') bond
   if(bond==' ') cycle
   bond=adjustl(bond)
   if(bond(1:1)=='*') cycle
   call maj(bond,200)
   if(bond(1:3)=='END') exit
   long_data=long_data+1
   write(99,'(a)') trim(bond)
enddo
if(yw) print*,'long_data0',long_data

!
! Traiter symetrie par symetrie: boucle sur les sym
ifin=0
print*,'----------------------------------------'
rewind 99
read(99,*) g_occ,g_vir,g_act,g_nelac
print*,'Definition du groupe:'
print'(a,i4)','Occupees           ',g_occ
print'(a,i4)','Virtuelles         ',g_vir
print'(a,i4)','actives            ',g_act
print'(a,i4)','Electrons actifs   ',g_nelac
if(g_act>0) then
   read(99,*) g_numac(1:g_act)
   long_data=long_data-1
   print'(a,20i4)','Place des actives  ', g_numac(1:g_act)
endif
if(yw) print*,'long_data0',long_data
print'(a)','Orbitales atomiques du groupe:'
do i=1,long_data
   read(99,'(a200)') bond
   print*,trim(bond)
enddo
print*,'----------------------------------------'

allocate(workl1((g_occ+g_vir+g_act)*nsym))
allocate(iwork1((g_occ+g_vir+g_act)*nsym))
allocate(work3(norb,(g_occ+g_vir+g_act)*nsym))
work3=0.d0
ioatot=0
do is=1,nsym
   print*,' '
   print*,'--------------------------------- '
   if(yw)print*,'------symetrie',is,' ------------ '
   ioatot0=ioatot
   ideb=ifin+1
   ifin=ifin+isym(is)
   if(yw)print*,'ideb,ifin',ideb,ifin

   !
   ! lire les donnees de "group"
   !
   rewind 99
   ioa=0
   g_nelac=0
   read(99,*) g_occ,g_vir,g_act,g_nelac
   if(yw)print*,'g_occ,g_vir,g_act,g_nelac',g_occ,g_vir,g_act,g_nelac
   
   if(g_act>0) then
      read(99,*) g_numac(1:g_act)
      if(yw) print*,'g_numac',g_numac(1:g_act)
   endif
   if(yw) print*,'long_data',long_data
   fnat_tmp=0
   do i=1,long_data
      read(99,'(a200)') bond
   !   1. lire l'atome
      ib=index(bond,' ')
      if(yw)print*,'BOND   ',trim(bond)
      oa=bond(1:ib-1)
      nom=oa(1:4)
      fnat_tmp=fnat_tmp+1
      atoms_in_LO_tmp(fnat_tmp)=trim(nom(1:4))
   !   2. lire les couches
      do
         bond(1:ib-1)=' '
         bond=adjustl(bond)
         if(bond==' ') exit
         ib=index(bond,' ')
   !       trouver quelle occurence de la couche prendre (ex. 1S(2) :
   !       occurence 2)
         call group_occurence(bond(1:ib-1),n,ib,ib1)
         oa(5:5+ib1-2)=bond(1:ib1-1)
   !   3. chercher l'OA dans la liste
         if(yw)print'(a,i3,3a,i4,a,i4)',&
         'Sym: ',is,'    OA: ',oa(1:4)//'|'//oa(5:5+ib1-2), &
         '    numero_OA0: ',numero_OA0(oa(1:4),oa(5:5+ib1-2),ideb,ifin),&
         '    occurrence: ',n
         num_oa=numero_OA0(oa(1:4),oa(5:5+ib1-2),ideb,ifin)
         if(num_oa==0) cycle
         ioa=ioa+1
         ioatot=ioatot+1
         iwork(ioa)=num_OA+n
      enddo
   enddo
   if(ioa==0) cycle
   print'(a,i2,a)','symetrie',is,'     numeros des OA correspondant a la donnee du groupe:'
   print'(i8,100i12)',iwork(1:ioa)
   print'(8a12)',label0(iwork(1:ioa))
   print*,' '

      !print*,'dens dans group'
      !if(mprint(1)>2)
      !*call mscript(dens)
   work1(1:ioa,1:ioa)=dens(iwork(1:ioa),iwork(1:ioa))
   if(yw.or.mprint(1)>0) then
      print*,'mat densite extraite'
      call mscript(work1(1:ioa,1:ioa))
   endif
   !
   ! diagonalisation de la matrice densite extraite
   !
   call hdiag(work1(1:ioa,1:ioa),work2(1:ioa,1:ioa),ioa,ioa)
   print*, 'orbitales naturelles'
   print*,' '
   print'(5x,10f8.4)', (/(work1(i,i),i=1,ioa)/)
   call mscript(work2(1:ioa,1:ioa))
   if(yw)print*,'ioatot0,ioa',ioatot0,ioa,ioatot
   i=0
   do j=ioatot0+1,ioatot
      if(yw)print*,'rempl workl1',j
      i=i+1
      workl1(j)=work1(i,i)
      iwork1(j)=is
   enddo
   do i=1,ioa
      do j=1,ioa
         work3(iwork(j),ioatot0+i)=work2(j,i)
      enddo
   enddo
enddo
print*,'--------------------------------- '
print*,' '
if(yw) then
   print'(a,10i10)','symmetry',iwork1(1:ioatot)
   print'(a,10f10.5)','occup   ',workl1(1:ioatot)
   do i=1,norb
      if(any(abs(work3(i,1:ioatot))>1.d-6))print'(a,10f10.6)',&
      label0(i),work3(i,1:ioatot)
   enddo
endif
!print*,'workl1',workl1(1:ioatot)
call reor2(workl1,iwork1,work3(1:norb,1:ioatot),ioatot,norb)
!if(yw) then
   print*,'OL du groupe, en symetrie, rangees par ordre d''occupation'
   print*,'Attention ! les numeros des orbitales occupees, actives et virtuelles'
   print*,'declarees en donnee dans &lewis correspondent a cette numerotation !'
   ifin=0
   do ii=1,ioatot,10
      ideb=ifin+1
      ifin=min(ifin+10,ioatot)
      print*,' '
      print'(a,i6,9i10)','symmetry',iwork1(ideb:ifin)
      print'(a,i6,9i10)','numero  ',(/(k,k=ideb,ifin)/)
      print'(a,10f10.5)','occup  ',workl1(ideb:ifin)
      print*,' '
      do i=1,norb
         if(any(abs(work3(i,ideb:ifin))>1.d-6))&
         print'(a,10f10.6)',label0(i),work3(i,ideb:ifin)
      enddo
   enddo
!endif
!   
!print*,'workl1',workl1(1:ioatot)
!print*,'iwork1',iwork1(1:ioatot)

print*,' '
print *,'--------------------------------'
print*,' '
print*,'Transformation : OL du groupes desymetrisees:'
print*,' '

ywork(1:ioatot)=.false.
!
! icrementer nelac
!
!nelac=nelac+g_nelac
!
l=maxval(len_trim(label_OL_temp))
do is=1,nsym
   !
   ! Ajouter les orbitales actives, occupees et virtuelles
   !
   iorb0=iorb

   ! Actives
   do i=1,g_act
      ywork(g_numac(i))=.true.
      if(iwork1(i)/=is) cycle
      iorb=iorb+1
      fnat(iorb)=fnat_tmp
      if(i<=(g_nelac+1)/2) then
         focvir(iorb)='ACTO'
      else
         focvir(iorb)='ACTV'
      endif
      fsigpi(iorb)='????'
      atoms_in_LO(iorb,1:fnat_tmp)=atoms_in_LO_tmp(1:fnat_tmp)
      active(iorb)=.TRUE.
      label_OL_temp(iorb)='A_'//trim(nom)//'.GA'
      l=len_trim(label_OL_temp(iorb))
      write(label_OL_temp(iorb)(l+1:l+2),'(i2.2)') g_numac(i)
      print'(a,i2,a,a,i4,a,i4,a)','Gen:   Sym',is,'  grp Act: ' ,label_OL_temp(iorb)(1:l),iorb,'  (numero dans le groupe:',g_numac(i),')'
      orb(:,iorb)=0.d0
      do j=1,norb
         orb(j,iorb)=work3(j,g_numac(i))
         !diff(iwork(j))=.false.
      enddo
   enddo
   ii=0

   ! Occupees
   g_occ_s=0
   icompt=0
   do i=1,g_occ+g_act
      if(ywork(i)) cycle
      icompt=icompt+1
      if(iwork1(i)==is) g_occ_s=g_occ_s+1
      if(icompt==g_occ) exit
   enddo
   if(yw)print*,'is,g_occ_s',is,g_occ_s
   do i=1,ioatot
      if(g_occ_s==0) exit
      if(yw)print*,'coucouO',ywork(i),iwork1(i),is,i,ii
      if(ywork(i)) cycle
      if(iwork1(i)/=is) cycle
      ii=ii+1
      if(yw)print*,'coucou_occ',ii,g_occ_s
      iorb=iorb+1
      fnat(iorb)=fnat_tmp
      focvir(iorb)='OCC'
      fsigpi(iorb)='????'
      atoms_in_LO(iorb,1:fnat_tmp)=atoms_in_LO_tmp(1:fnat_tmp)
      occupat(iorb)=.TRUE.
      noc=noc+1
      label_OL_temp(iorb)='O_'//trim(nom)//'.GO'
      l=len_trim(label_OL_temp(iorb))
      write(label_OL_temp(iorb)(l+1:l+2),'(i2.2)') i
      print'(a,i2,2a,i4,a,i4,a)','Gen:   Sym',is,'  grp Occ: ' &
      ,label_OL_temp(iorb)(1:l),iorb,'  (numero dans le groupe:',i,')'
      orb(:,iorb)=0.d0
      do j=1,norb
         orb(j,iorb)=work3(j,i)
         !diff(iwork(j))=.false.
      enddo
      if(ii==g_occ_s) exit
      !do j=ideb,ifin
      !   print*,j,'   ',label0(j),orb(j,iorb)
      !enddo
      !orb=matmul(pass,orb)
      !do j=1,norb
      !   print*,j,'   ',label(j),orb(j,iorb)
      !enddo
   enddo

   ! Virtuelles
   g_vir_s=0
   icompt=0
   if(ioatot-g_vir-g_act+1<=0) then
      print'(/,a)','Error in GROUP'
      print'(a,3i6)','In data: nb of orb / nb of act / nb of virt',ioatot,g_act,g_vir
      print'(a,i6,a,/)','(nb of orb) - (nb of act) - (nb of virt) =',ioatot-g_vir-g_act,'  (<0)'
      stop
   endif
   do i=ioatot,ioatot-g_vir-g_act+1,-1
      if(ywork(i)) cycle
      icompt=icompt+1
      if(iwork1(i)==is) g_vir_s=g_vir_s+1
      if(icompt==g_vir) exit
   enddo
   if(yw)print'(a,50l1)','ywork',ywork(1:ioatot)
   if(yw)print*,'is,g_vir_s',is,g_vir_s
   ii=0
   if(yw)print*,'ioatot',ioatot
   do i=ioatot,1,-1
      if(yw)print*,'coucouV',ywork(i),iwork1(i),is,i,ii
      if(g_vir_s==0) exit
      if(ywork(i)) cycle
      if(iwork1(i)/=is) cycle
      ii=ii+1
      if(yw)print*,'coucou_vir',ii,g_vir_s
      iorb=iorb+1
      fnat(iorb)=fnat_tmp
      focvir(iorb)='VIRT'
      fsigpi(iorb)='????'
      atoms_in_LO(iorb,1:fnat_tmp)=atoms_in_LO_tmp(1:fnat_tmp)
      occupat(iorb)=.FALSE.
      label_OL_temp(iorb)='O_'//trim(nom)//'.GV'
      l=len_trim(label_OL_temp(iorb))
      write(label_OL_temp(iorb)(l+1:l+2),'(i2.2)') i
      print'(a,i2,2a,i4,a,i4,a)','Gen:   Sym',is,'  grp Vir: ' &
      ,label_OL_temp(iorb)(1:l),iorb,'  (numero dans le groupe:',i,')'
      orb(:,iorb)=0.d0
      do j=1,norb
         orb(j,iorb)=work3(j,i)
      enddo
      if(ii==g_vir_s) exit
   enddo
   if(yw)print*,'iorb0,iorb',iorb0,iorb

   print*,' '
   print*,'OL desymetrisees du groupe, symetrie',is
   do i=iorb0+1,iorb
      if(yw)print*,'orb',i
      orb(:,i)=matmul(pass,orb(:,i))
   enddo
   do j=1,norb
      if(any(abs(orb(j,iorb0+1:iorb))>1.d-8)) then
         diff(j)=.false.
         print'(i4,2a,10F10.6)',j,'   ',ecrlabel(label(j)),orb(j,iorb0+1:iorb)
      endif
   enddo
print*,' '
enddo



close(ifil_dens)
close(99,status='delete')
deallocate(workl1,iwork1,work3)
end
!**********************************************************
 subroutine group_occurence(bond,n,ib,ib1)
character(*) :: bond
i=index(bond,'(')
if(i==0) then
   n=0
   ib1=ib
else
   j=index(bond,')')
   read(bond(i+1:j-1),*) n
   n=n-1
   ib1=ib-(j-i+1)
endif
end
!**********************************************************
subroutine reor2(workl1,iwork1,work3,ioa,norb)
real(8) :: workl1(ioa),a,work3(1:norb,1:ioa)
integer :: iwork1(ioa)
do i=1,ioa
   do j=i+1,ioa
      if(workl1(j)>workl1(i)) then
         a=workl1(j)
         workl1(j)=workl1(i)
         workl1(i)=a
         k=iwork1(j)
         iwork1(j)=iwork1(i)
         iwork1(i)=k
         do k=1,norb
            a=work3(k,i)
            work3(k,i)=work3(k,j)
            work3(k,j)=a
         enddo
      endif
   enddo
enddo
end
