Program lewis
!Appel des modules
Use lewis_module !module des variables
Use mod_script   !module de Daniel
use mod_lirorb   !module exportation Molcas
use decode_multip_data
use mod_scriptol
implicit real*8 (a-h,o-x,z),logical*1(y)
!Definition de variables
character(200) :: bond
real(8) ::anorm
integer::nombre_liaison
integer cherche_at0
logical,allocatable :: occupat_tri(:)
logical ybon
real(4) :: t0,t1
      !logical,allocatable :: ycopy_tmp(:)
yw=.false.

call banner('  Lewis')

call lectures
!
! Gestion de la symetrie
! On appelle sym0, qui va etendre la liste des atomes et generer les
! OA sans symetrie
! On calcule pass, mat de passage des OA symetriques vers les OA symetriques
!
call sym0
!
! natom, atom et label ont maintenant ete modifies
! les valeurs en symetrie sont dans natom0, atom0 et label0
!
allocate(ORB(NORB,NORB))
allocate(work1(NORB,NORB))
allocate(work2(NORB,NORB))
allocate(iwork(NORB))
allocate(ywork(NORB))
!      allocate(ORB2(NORB,NORB))
allocate(S(NORB,NORB))
allocate(S0(NORB,NORB))
allocate(diff(norb))
allocate(occupat(norb))
allocate(active(norb))
allocate(orbtri(norb,norb))
allocate(occ(norb))
allocate(occact(norb))
allocate(label_OL(norb))
allocate(label_OL_temp(norb))
allocate(fnat(norb),fsigpi(norb))
allocate(focvir(norb))
allocate(atoms_in_LO(norb,max_atoms_in_LO))
allocate(fnat2(norb),fsigpi2(norb))
allocate(focvir2(norb))
allocate(atoms_in_LO2(norb,max_atoms_in_LO))
allocate(ycopy(norb))
allocate(ycopy2(norb))
fnat=0
fsigpi='00000000'
focvir='FVFV'
atoms_in_LO='0000'
label_ol=' '
label_ol_temp=' '
ORB=0.D0
active=.false.
!
! Matrice de recouvrement entre OA
! Mat entre OA symetriques (s0) lue, mat entre OA non sym calculee (s)
!
open(2,file=trim(prefix)//'Mono',status='old',form='unformatted')
call lis(2,S0,'SYM',norb)
close(2)
if(nprint>=3)print*,'Mat de recouvrement des OA en symetrie'
if(nprint>=3)call mscript(s0)
if(nsym>1) then
   s=matmul(pass,matmul(s0,transpose(pass)))
   do i=1,99
      call search_files(i)
   enddo
   if(yw)print*,'Mat de recouvrement des OA desymetrisees'
   if(yw)call mscript(s)
else
   s=s0
endif


!
!=================================================================
!               Lecture des Orbitales de Reference
!               si elles sont donnees
!=================================================================
!
if(scforbin==' ') then
   call titre('Aucun fichier d''orbitales de reference' &
   //' n''a ete trouve#On orthonormalise maintenant les OL#',60)
else
   call titre('Le fichier d''orbitales de reference est#'// &
   trim(scforbin)//'#',60)
   print*,'Donnees ref_inac et ref_acf :'
   print'(a,8i5)', &
   ' Inactives dans les references  ref_inac=',ref_inac(1:nsym)
   print'(a,8i5)', &
   ' Actives dans les references    ref_act= ',ref_act(1:nsym)
   if(all(ref_act==0).and.index(scforbin,'RasOrb')>0) then
      call titre('ATTENTION ! scforbin=...RasOrb et il'// &
      ' n''y a pas d''actives#',60)
   endif
   call lir_Orb_Ref
         ! on a maintenant le niveau de Fermi (fermi0)
         ! si ref_inac n'est pas donne on le calcul a partir de
         ! ref_act
   if(all(ref_inac==0)) &
   ref_inac(1:nsym)=fermi0(1:nsym)-ref_act(1:nsym)

         ! on recopiera eventuellement des orbitales de reference
         ! pour en faire des orbitales finales (commande 'CP')
   call open_chose_number(ifil_CP,'CPfile','unknown' &
   ,'unformatted')
   ycopy=.false.
endif
print*,' '
print*,' '
print*,' '
!
!=================================================================
!               Generation des OL de valence
!=================================================================
!
call generOL
! en sortie de generOL:
!    iorb = nb d'OL generees
!    ncoeur = nb d'OL de coeur generees

nvalence=iorb-ncoeur-ndiff  !Totalise les orbitales de valence
call titre('Fin de la generation des OL de valence brutes,'// &
' non symetriques#', &
60)
print'(a40,i4)','Orb de coeur',ncoeur
print'(a40,i4)','Orb de Valence',nvalence
print'(a40,i4)','Occupees',noc
print'(a40,i4)','Diffuses',ndiff
print'(a40,i4)','OL generees',ncoeur+nvalence
print*,' '
print*,' '
if(ncoeur+nvalence==0) then
   print'(a,/)','===No LO generated===   STOP';stop
endif
print*,' '
print*,' '
!
!=================================================================
!

!
!=================================================================
!        Generation des OL diffuses (etape 1)
! Test : le nombre d'OA entrant dans les OL est-il egal au nb d'OL
! generees ?
!=================================================================
!
call titre('Generation des OL diffuses (etape 2)#'// &
'Les OA qui n''ont pas ete utilisees#'// &
'vont servir pour creer les diffuses atomiques#',60)
call test_coherence_OA_OL


!
!=================================================================
!        Generation des OL diffuses (etape 2)
!     Generation des Labels des orbitales diffuses
!      (ils sont de la forme T_...)
!=================================================================
!
do i=1,norb
   if(diff(i)) then
      iorb=iorb+1
      fnat(iorb)=1
      focvir(iorb)='VIRT'
      fsigpi(iorb)='DIFF_'//trim(label(i)(8:10))
      atoms_in_LO(iorb,1)=trim(label(i)(1:4))
      label_OL_temp(iorb)='T_'//trim(label(i))
      !print*,'LAB',i,trim(label(i)),label_OL_temp(iorb)
      l=len_trim(label_OL_temp(iorb))
      if(label_OL_temp(iorb)(1:l)== &
         label_OL_temp(iorb-1)(1:l)) then
         l1=len_trim(label_OL_temp(iorb-1))
         if(l==l1) then
            label_OL_temp(iorb-1)=trim(label_OL_temp(iorb-1))//'.1 &
            '
            label_OL_temp(iorb)=trim(label_OL_temp(iorb))//'.2'
         else
            read(label_OL_temp(iorb-1)(l+2:l1),*) n
            write(label_OL_temp(iorb)(l+2:l+4),'(i3)') n+1
            label_OL_temp(iorb)(l+2:l+4)=adjustl( &
            label_OL_temp(iorb)(l+2:l+4))
            label_OL_temp(iorb)(l+1:l+1)='.'
         endif
      endif
      orb(i,iorb)=1.D0
      if(mprint(1)>0) &
      print*,'diffuse generee ',i,'  '//label_OL_temp(iorb)
   end if
end do

print*,'                    Les OL diffuses ont ete generees'
print*,'                    Nombre d''OL :',iorb
print*,' '
print*,' '
print*,' '

      !print*,'ycopy',ycopy



!
!=================================================================
!        Les OL ont toutes ete generees
!    On reordonne les OL (Occ - Act - Virt)
! Tri de ORB et Génération d'un fichier d'occupation
!=================================================================
!
occ=0.D0
occact=0.D0
ywork=.false.
orbtri=0.D0
      !allocate(ycopy_tmp(norb))
allocate(occupat_tri(norb))
!on prend les orbitales de coeur
do i=1,norb
   if(label_OL_TEMP(i)(1:1)=='C'.or.label_OL_TEMP(i)(1:1)=='c') then
      iorbtri=iorbtri+1
      orbtri(:,iorbtri)=orb(:,i)
      occ(iorbtri)=2.D0
      label_OL(iorbtri)=trim(label_OL_temp(i))
      fnat2(iorbtri)=fnat(i)
      focvir2(iorbtri)=focvir(i)
      fsigpi2(iorbtri)=fsigpi(i)
      occupat_tri(iorbtri)=occupat(i)
      ycopy2(iorbtri)=ycopy(i)
      atoms_in_LO2(iorbtri,1:fnat(i))=atoms_in_LO(i,1:fnat(i))
      ywork(i)=.true.
   end if
end do
!on prend les occupées
do i=1,norb
   if(ywork(i)) cycle
   if(occupat(i).and.label_OL_TEMP(i)(1:1)/='A') then
      iorbtri=iorbtri+1
      orbtri(:,iorbtri)=orb(:,i)
      occ(iorbtri)=2.D0
      label_OL(iorbtri)=trim(label_OL_temp(i))
      fnat2(iorbtri)=fnat(i)
      focvir2(iorbtri)=focvir(i)
      fsigpi2(iorbtri)=fsigpi(i)
      occupat_tri(iorbtri)=occupat(i)
      ycopy2(iorbtri)=ycopy(i)
      atoms_in_LO2(iorbtri,1:fnat(i))=atoms_in_LO(i,1:fnat(i))
      ywork(i)=.true.
   end if
end do
!on prend les actives
do i=1,norb
   if(ywork(i)) cycle
   if(label_OL_TEMP(i)(1:1)=='A') then
            !print*,'occu',i,occupat(i),label_OL_TEMP(i)
      iorbtri=iorbtri+1
      orbtri(:,iorbtri)=orb(:,i)
      occact(iorbtri)=0.D0
      if(occupat(i)) occact(iorbtri)=2.d0
      label_OL(iorbtri)=trim(label_OL_temp(i))
      fnat2(iorbtri)=fnat(i)
      focvir2(iorbtri)=focvir(i)
      fsigpi2(iorbtri)=fsigpi(i)
      occupat_tri(iorbtri)=occupat(i)
      ycopy2(iorbtri)=ycopy(i)
      atoms_in_LO2(iorbtri,1:fnat(i))=atoms_in_LO(i,1:fnat(i))
      ywork(i)=.true.
   end if
end do
!on prend les non-occupées de valence
do i=1,norb
   if(ywork(i)) cycle
   if(.not. occupat(i).and..not.active(i).and. &
   label_OL_TEMP(i)(1:1)/='t'.and.label_OL_TEMP(i)(1:1)/='T') then
      iorbtri=iorbtri+1
      orbtri(:,iorbtri)=orb(:,i)
      label_OL(iorbtri)=trim(label_OL_temp(i))
      fnat2(iorbtri)=fnat(i)
      focvir2(iorbtri)=focvir(i)
      fsigpi2(iorbtri)=fsigpi(i)
      occupat_tri(iorbtri)=occupat(i)
      ycopy2(iorbtri)=ycopy(i)
      atoms_in_LO2(iorbtri,1:fnat(i))=atoms_in_LO(i,1:fnat(i))
      ywork(i)=.true.
   end if
   ilongueur=len_trim(label_OL(i))
end do
!on prend les diffuses
do i=1,norb
   if(ywork(i)) cycle
   if(label_OL_TEMP(i)(1:1)/='t'.or.label_OL_TEMP(i)(1:1)/='T') then
      iorbtri=iorbtri+1
      orbtri(:,iorbtri)=orb(:,i)
      label_OL(iorbtri)=trim(label_OL_temp(i))
      fnat2(iorbtri)=fnat(i)
      focvir2(iorbtri)=focvir(i)
      fsigpi2(iorbtri)=fsigpi(i)
      occupat_tri(iorbtri)=occupat(i)
      ycopy2(iorbtri)=ycopy(i)
      atoms_in_LO2(iorbtri,1:fnat(i))=atoms_in_LO(i,1:fnat(i))
      ywork(i)=.true.
   end if
   ilongueur=len_trim(label_OL(i))
end do
orb=orbtri
occupat=occupat_tri
deallocate(occupat_tri)
print*,' '

deallocate(orbtri)
      !do i=1,norb
      !   print*,'label_OL',i,label_OL(i)
      !enddo

!
! Eventuellement, modifier le label 'A-->O ; O-->A
!
!

!
!=================================================================
! On a obtenu la matrice des OL non sym dans les OA non sym (orb)
! reordonnee Occ - Act - Virt
!=================================================================
!
if(mprint(1)>1) then
   print*,'matrice brute (OL non sym dans OA non sym, ordonnees'// &
   ' G-C-VALocc-A-VALvirt-DEL).'
   print*,'(Symetrie inconnue)'
   !print*,'label_ol',label_ol
   call scriptol2(orb,norb,norb,norb,norb,label, &
   (/(i,i=1,norb)/),label_ol,occ)
endif
if(worb) then
   write(ifil_orb,*)&
   'Matrice brute (OL non sym dans OA non sym, ordonnees'// &
   ' G-C-VALocc-A-VALvirt-DEL).'
   write(ifil_orb,'(a,/)')'(Symetrie inconnue)'
   call scriptol2(orb,norb,norb,norb,norb,label, &
           (/(i,i=1,norb)/),label_ol,occ,ifil_orb)
endif
!
!=================================================================
!          Normalisation des OL
!=================================================================
! de valence
do i=1,norb
   if(ycopy2(i)) cycle
   anor=dot_product(orb(:,i),matmul(s,orb(:,i)))
   orb(:,i)=orb(:,i)/dsqrt(anor)
         !print*,'i,anor',i,anor
enddo
if(mprint(1)>1) &
print*,'matrice des OL non sym dans OA non sym, normalisees'
if(mprint(1)>1) &
call scriptol2(orb,norb,norb,norb,norb,label, &
(/(i,i=1,norb)/),label_ol,occ)

!
!=================================================================
!          Symetrisation des OM de Reference
!      --> OM de Reference exprimees dans la base des OA non sym
!=================================================================
!
 if(scforbin/=' ') then
    call symetrisation_OM
    print*,' '
    print*,' '
    print*,' '
    if(mprint(1)>1) then
      print*, &
      'OM de Reference exprimees dans la base des OA non sym'
      call scriptol2(orbscf,norb,norb,norb,norb,label, &
      (/(i,i=1,norb)/),(/('                    ',i=1,norb)/),occ)
    endif
endif

!
!=================================================================
! Occupation des atomes
!=================================================================
!
      !call crea_LOinfo(iwork)
      !call occupation_atomes(atom0,natom0,prefix)
      !stop
!
!=================================================================
!            Symetrisation des OL
! OL de symetrie exprimee dans la base des OA locales (non sym)
! (ce n'est pas un changement de base, ce sont de nouvelles orbitales)
!=================================================================
!
call orbsym_baseloc

if(mprint(1)>1) &
print*,'matrice brute en symetrie (OL sym dans OA non sym)'
if(mprint(1)>1) &
call scriptol2(orb,norb,norb,norb,norb,label, &
(/(i,i=1,norb)/),label_ol,occ)


!
!=================================================================
! Calcul de la Matrice brute en symetrie
! OL de symetrie exprimee dans la base des OA symetrisees
!=================================================================
!
orb=matmul(transpose(pass),orb)

if(mprint(1)>=1) &
print*,'matrice brute en symetrie (OL sym dans OA sym)'
if(mprint(1)>1) &
call scriptol3(orb,norb,norb,norb,norb,label0, &
(/(i,i=1,norb)/),label_ol,occ)
if(worb) then
   write(ifil_orb,*)&
   'Matrice des OL non sym dans OA non sym, normalisees'
   write(ifil_orb,'(a,/)')'(Symetrie inconnue)'
   call scriptol3(orb,norb,norb,norb,norb,label0, &
   (/(i,i=1,norb)/),label_ol,occ,ifil_orb)
endif


!
!================================================================
! Orbitales de reference copiees
!================================================================
!
if(scforbin/=' ') then
   call copy2
   
   if(mprint(1)>=1) &
   print*,'matrice brute en symetrie (OL sym dans OA sym)'// &
   ' apres recopie d''orbitales de reference'
   if(mprint(1)>1) &
   call scriptol3(orb,norb,norb,norb,norb,label0, &
   (/(i,i=1,norb)/),label_ol,occ)
   
         !print*,'ycopy2',ycopy2
endif


!
!=================================================================
!            On reordonne les OL sym par sym(Etape 5)
! OL sym dans OA sym, reordonnees sym par sym
!=================================================================
!
call titre('Attribution d''une symetrie a chaque orbitale#'// &
'puis on reordonne les OL par symetrie#',60)
call reorsy
if(mprint(1)>1) &
print*,'matrice des OL d''essai '// &
'(OL sym dans OA sym, reordonnee sym par sym)'
if(mprint(1)>1) &
call scriptol3(orb,norb,norb,norb,norb,label0, &
(/(i,i=1,norb)/),label_ol,occ)
if(worb) then
   write(ifil_orb,*)&
   'Matrice des OL ',&
   '(OL sym dans OA sym, reordonnee sym par sym)'
   call scriptol3(orb,norb,norb,norb,norb,label0, &
   (/(i,i=1,norb)/),label_ol,occ,ifil_orb)
endif



! on reordonne de nouveau en OAV dans chaque symetrie
! Il faudrait verifier si le reordonnancement precedent etait necessaire
      !print*,'label_OL',label_OL
call reor_OAV


!
!=================================================================
! Eventuellement, renommer les orbitales
!=================================================================
!
call modif_act
call rename_loc
call titre('New orbital ordering#',300)
ifin=0
do is=1,nsym
   if(isym(is)==0) cycle
   ideb=ifin+1
   ifin=ifin+isym(is)
   print'(/,a,i2)','Labels, symmetry',is
   call ecrlab(isym(is),label_ol(ideb:ifin))
enddo
print*,' '

!
!=================================================================
! Appel du Mode 2 du programme (Projection sur des OM de reference
! SCF ou CASSCF)
!=================================================================
!
if(scforbin/=' ') then
   call projection
   if(mprint(1)>=1) then
      print*,'matrice des OL projetees (OL sym dans OA sym,'// &
      ' reordonnee sym par sym)'
      call scriptol3(orb,norb,norb,norb,norb,label0, &
      (/(i,i=1,norb)/),label_ol,occ)
   endif
end if



!
!=================================================================
!         Orthogonalisation des OL
!=================================================================
!

j=0
do is=1,nsym
   i=sum(isym(1:is-1))
   do k=1,isym(is)
      if(ycopy(i+k)) then
         j=j+1
         iwork(j)=k
      endif
   enddo
   do k=1,isym(is)
      if(.not.ycopy(i+k)) then
         j=j+1
         iwork(j)=k
      endif
   enddo
enddo
      !print*,'ycopy',ycopy
      !print*,'isym',isym

      !do i=1,norb
      !   print'(i5,2x,a,2x,a)',i,focvir(i),fsigpi(i)
      !enddo

      !print'(a,50i3)','iwork',iwork



call cpu_time(t0)
call ortho(iwork(1:norb),ycopy)           ! Orthogonalisation
call cpu_time(t1)
print*,'orthogonalisation terminee. Cpu ',t1-t0

if(scforbin==' ') then
   call titre('OL orthogonalisees (OL sym dans OA sym,#'// &
   ' reordonnee sym par sym, orthonormales)#',60)
else
   call titre('OL projetees orthogonalisees '// &
   '(OL sym dans OA sym,#'// &
   ' reordonnee sym par sym, orthonormales)#',60)
endif
ifin=0


!
!=================================================================
! Reordonnancement des orbitales: 
! mise des gelees occupees en tete
! mise des gelees virtuelles en queue
!=================================================================
!
call reorgel
!
!=================================================================
!    Occupation des orbitales
!=================================================================
!

if(scforbin/=' ') then
! on lit la matrice densite dans la base des OA symetrisees
    call open_chose_number(ifil_dens,'DENS_OA','old', &
    'unformatted')
    read(ifil_dens) dens
    close(ifil_dens,status='delete')
!          call mscript(dens)

! on l'ecrit dans la base des OL
   ifin=0
   do is=1,nsym
       ideb=ifin+1
       ifin=ifin+isym(is)
!             print*,'S0 is',is
!             call mscript(S0(ideb:ifin,ideb:ifin))
!             print*,'orb is',is
!             call mscript(orb(ideb:ifin,ideb:ifin))

             ! transpose(P).S
       work1(ideb:ifin,ideb:ifin)= &
       matmul(transpose(orb(ideb:ifin,ideb:ifin)), &
       S0(ideb:ifin,ideb:ifin))

             ! transpose(P).S.dens
       work1(ideb:ifin,ideb:ifin)=matmul(work1(ideb:ifin, &
       ideb:ifin), &
       dens(ideb:ifin,ideb:ifin))
!             print*,'work1 is',is
!             call mscript(work1(ideb:ifin,ideb:ifin))

             ! transpose(P).S.dens.P
       work1(ideb:ifin,ideb:ifin)=matmul(work1(ideb:ifin, &
       ideb:ifin), &
       orb(ideb:ifin,ideb:ifin))

!             print*,'DENS en base d''OL  sym',is

       do i=ideb,ifin
          if(label_OL(i)(1:1)=='A') occ(i)=work1(i,i)
       enddo
             !print*,'OCC0',occ(ideb:ifin)
! remise de 2. et 0. sur l'occupation des orbitales
             !print*,'OCC',occ(ideb:ifin)
             !print*,'nocs',nocs(is)
             !print*,'noacs',noacs(is)
   enddo
endif


ifin=0
do is=1,nsym
   if(isym(is)==0) cycle
   print*,' '
   print*,'OL  Symetrie',is
   ideb=ifin+1
   ifin=ifin+isym(is)
   !call scriptol3(orb(:,ideb:ifin), &
   !norb,ifin-ideb+1,norb,ifin-ideb+1,label0, &
   !(/(i,i=ideb,ifin)/),label_ol(ideb:ifin),occ(ideb:ifin))
   call scriptolu(orb(:,ideb:ifin),labelH=label_ol(ideb:ifin), &
   occup=occ(ideb:ifin),numeroH=(/(i,i=ideb,ifin)/), &
   labelV=label0)
enddo




!      do i=1,norb
!         print*,'label_OL',i,label_OL(i)
!      enddo

!=================================================================
! Exportation des données
!=================================================================

! - en base d'OA symetrisees

open(9,file='ORB_TMP',form='unformatted',status='unknown')
titre2='*Orbitales creees par Lewis'
do is=1,nsym
   if(isym(is)==0) cycle
   ideb=isymt(is)+1
   ifin=isymt(is+1)
   write(9) orb(ideb:ifin,ideb:ifin)
enddo
do is=1,nsym
   if(isym(is)==0) cycle
   ideb=isymt(is)+1
   ifin=isymt(is+1)
   write(9) occ(ideb:ifin)
enddo
do is=1,nsym
   if(isym(is)==0) cycle
   ideb=isymt(is)+1
   ifin=isymt(is+1)
   write(9) label_OL(ideb:ifin)(1:18)
enddo
call ecriorb(titre2,'LOCORB',nsym,isym,9,8,newformat='O')
close(9,status='delete')
close(8)

! - en base d'OA locales

open(9,file='ORB_TMP',form='unformatted',status='unknown')
if(scforbin==' ') then
   titre2='*Orbitales creees par Lewis (non optimales, pas'// &
   ' de fichier SCF pour projection)'
else
   titre2='*Orbitales creees par Lewis, en base d''OA locales (desymetrisees)'
endif
orb=matmul(pass,orb)
write(9) orb
write(9) occ
write(9) label_OL(1:norb)(1:18)
iwork(1)=norb


call ecriorb(titre2,'LEWORB_LOC',1,iwork,9,8,newformat='O')
close(9,status='delete')
close(8)
call desym_OL('LEWORB_LOC',occupat)

!
! Fabrication d'une file Info sans symetrie
!
call fai_infoloc

!
! File SCH_FERMI
!
open(99,file='SCH_FERMI',status='unknown')
write(99,'(a,8(i4,'',''))') ' &ferm fermi=',fermi0(1:nsym)
write(99,'(a)') ' /'
close(99)
!
! Generation des donnees pour motra et molcost
!

open(99,file='DOLO_MOTRAIN',form='formatted',status='unknown')
write(99,'(a)') ' &MOTRA &END'
write(99,'(a)') 'TITLE'
write(99,'(a)') prefix(1:len_trim(prefix)-1)
if(ychol) then
   write(99,'(a)') 'CTONLY'
   write(99,'(a)') 'KPQ'
   write(99,'(a)'),'FROZEN'
   write(99,'(8i4)') (0,k=1,nsym)
   write(99,'(a)') 'DELETE'
   write(99,'(8i4)')  (0,k=1,nsym)
else
   write(99,'(a)'),'FROZEN'
   write(99,'(8i4)') frozen(1:nsym)
   write(99,'(a)') 'DELETE'
   write(99,'(8i4)') DELETE(1:nsym)
endif
write(99,'(a)') 'END OF INPUT'
close(99)
open(99,file='DOLO_MOLCOSTIN',form='formatted',status='unknown')
write(99,'(a)') ' &COST'
write(99,'(a)') ' prefix='//"'"//trim(prefix)//"'"
if(ychol) write(99,'(a)') ' ychol=t,chol_ord=''KPQ'''
write(99,'(a,8(i4,","))') ' FROZEN=',frozen(1:nsym)
write(99,'(a,8(i4,","))') ' DELETE=',DELETE(1:nsym)
write(99,'(a,8(i4,","))') ' FERMI=',fermi0(1:nsym)-frozen(1:nsym)
write(99,'(a)') ' /'
close(99)


deallocate(label0)

close(26,status='delete')
do i=1,99
   call search_files(i)
enddo
!
!=================================================================
! fabrication du fichier LOinfo
!=================================================================
!
call crea_LOinfo(iwork)
call occupation_atomes(atom0,natom0,prefix,liste_multat2)
deallocate(atom0)
! fabrication de fichiers molden
!=================================================================
!
! 1. molden pour les orb symetriques
!if(scforbin/=' ') then
   call faimolden(prefix,'LEWORB_LOC','lewis.molden',ybon)


! 2. molden pour les orb desymetrisees (locales)
   if(ybon) &
   call faimolden(prefix,'LEWORB_LOCLOC','lewis.LOC.molden',ybon)
!endif

!controle des files ouvertes
do i=1,99
   call search_files(i)
enddo
call titre('Fin Lewis   Fin Lewis   Fin Lewis   Fin Lewis#',60)
end


!*****************************************************************
 subroutine fai_infoloc
use lewis_module
character(1) :: cote=''''
logical yexist

print*,' '
call titre('Create Infoloc file#',300)
inquire(file=trim(prefix)//'Infoloc',exist=yexist)
if(yexist) then
   print*,'The ',trim(prefix)//'Infoloc',' already exist'
   print*,'It will not be created'
   print*,'to overwrite it, delete it before running lewis'
   return
endif

open(99,file=trim(prefix)//'Infoloc',status='unknown')

write(99,'(a)') ' &cost_AO'
write(99,'(a,i1)')' nsym=1'
write(99,1001) ' isym=',norb
write(99,'(a6,i5)')' norb=',norb
write(99,'(a6)')' its=1'
write(99,'(a,f20.12)') ' enuc=',enuc
write(99,'(a,i4)')' natom=',natom
write(99,'(a)') ' atom='
write(99,1003) (cote,atom(k),cote,k=1,natom)
1003 format(100(1x,5(a1,a4,a1,','),/))
write(99,'(a)')' label='
write(99,1002) (cote,label(k)(1:4)//label(k)(7:10),cote,k=1,norb)
1002 format(100(1x,5(a1,a8,a1,','),/))

write(99,'(a)')' coor='
do l=1,natom
   write(99,'(3(f20.10,'',''))') coord(:,l)
enddo
write(99,'(a)')' /'
      !
      !
close(99)
1001 format(a,8(i4,','))


end
!*****************************************************************
 subroutine projection
use lewis_module
use mod_script
use mod_lirorb
use mod_scriptol
!
!=================================================================
! Projection sur des OM de reference SCF ou CASSCF
!=================================================================
!
implicit real*8 (a-h,o-x,z),logical*1(y)
real(4) :: t0,t1
real(8),allocatable :: work(:,:)
yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5
call titre('Orbitales de Reference :# scforbin=' &
//trim(scforbin)//'#'// &
'Projections sur ces orbitales de reference#',60)

!
!=============================================================
! Lecture des orbitales de reference, projection
!=============================================================
!
!      open(25,file=scforbin,status='old')
!      call lirorb(scforbin,norb2,nsym2,isym2,26,25)


ifin=0
allocate(orb3(norb,norb))
orb3=0.d0

deallocate(orbscf,occscf)
!=================================================================
do is=1,nsym
   rewind 26
   ideb=ifin+1
   ifin=ifin+isym(is)
         !call mscript(orb(ideb:ifin,ideb:ifin))
   norbs=isym(is)
   if(yw)print*,'projection is,norbs',is,norbs
   allocate(orbscf(norbs,norbs))
   allocate(occscf(norbs))
         !allocate(col(norbs))
   do k=1,is-1
      if(isym(k)>0) read(26)
   enddo
   if(isym(is)>0) read(26) orbscf
!         print*,'Voici la matrice SCF, sym=',is
!         call mscript(orbscf)
!         print*,'Voici la matrice OL, sym=',is
!         call mscript(orb(ideb:ifin,ideb:ifin))
!         print*,'Voici la matrice S0, sym=',is
!         call mscript(s0(ideb:ifin,ideb:ifin))
!         print*,'Voici la matrice OL*SCF, sym=',is
!         call mscript(matmul(transpose(orbscf),
!     *   matmul(s0(ideb:ifin,ideb:ifin),orb(ideb:ifin,ideb:ifin))))
   do k=is+1,nsym
      if(isym(k)>0) read(26)
   enddo
   do k=1,is-1
      if(isym(k)>0) read(26)
   enddo
   if(isym(is)>0) read(26) occscf
   n2=nocs(is)
   n3=nocs(is)+noacs(is)
   n2ref=ref_inac(is)
   n3ref=n2ref+ref_act(is)
         !print*,'n2ref,n3ref',n2ref,n3ref
         !print*,'n2,n3',n2,n3
         !print*,'ref_act',ref_act
         !print*,'ref_inac',ref_inac
         !print*,'noacs',noacs
         !print*,'nocs',nocs

!
!=============================================================
! projection des occupees
!=============================================================
!
   if(n2>=1) then
      print*,' '
      print'(a,i2,a,2i5,a,2i5,a)', &
      'sym',is,'   Projection sur les occupees  '// &
      '   [',1,n2,']  -->  [',1,n2ref,']'
      allocate(work(ideb:ifin,n2))
      work=matmul(S0(ideb:ifin,ideb:ifin),orb(ideb:ifin,ideb:ideb+n2-1))
   endif
   !do j=1,n2
   !   print*,'OCC ',j,'  sym',is,'    ',trim(label_OL(j+ideb-1))
   !enddo
   do j=1,n2
!           normalisation de orb (OL)
            !do k=ideb,ifin
      anorm=dot_product(orb(ideb:ifin,j+ideb-1), &
      work(ideb:ifin,j))
      anorm=sqrt(anorm)
      orb(ideb:ifin,j+ideb-1)=orb(ideb:ifin,j+ideb-1)/anorm
            !enddo
            !projection
      orb3(ideb:ifin,j+ideb-1)=0.d0
      do k=1,n2ref
         dot_p1=dot_product(orbscf(:,k), &
         work(ideb:ifin,j))
         !matmul(S0(ideb:ifin,ideb:ifin),orb(ideb:ifin,j+ideb-1)))
         orb3(ideb:ifin,j+ideb-1)=orb3(ideb:ifin,j+ideb-1) &
         +dot_p1*orbscf(:,k)
      end do
      anorm2=dot_product(orb3(ideb:ifin,j+ideb-1), &
      work(ideb:ifin,j))
      !matmul(S0(ideb:ifin,ideb:ifin),orb3(ideb:ifin,j+ideb-1)))
      anorm2=sqrt(anorm2)
      if(anorm2<0.8) then
         print'(a,i6,f8.4,a,i2,a)', &
         'rec faible avec l''espace des occupees  ', &
         j+ideb-1,anorm2,'   sym',is,'   '// &
         trim(label_OL(j+ideb-1))
      else
         if(mprint(2)==1) print'(a,i6,f8.4,a,i2,a)', &
         'rec avec l''espace des occupees         ', &
         j+ideb-1,anorm2,'   sym',is,'   '// &
         trim(label_OL(j+ideb-1))
      endif
   end do
   if(n2>=1) deallocate(work)
   if(yw)print*,'OL apres proj des occupees, sym=',is
   if(yw)call mscript(orb3(ideb:ifin,ideb:ifin))

!
!=============================================================
! projection des actives
!=============================================================
!
   if(n3>n2)print*,' '
   if(n3>n2)print'(a,i2,a,2i5,a,2i5,a)', &
   'sym',is,'   Projection sur les actives   '// &
   '   [',n2+1,n3,']  -->  [',n2ref+1,n3ref,']'
   !do j=n2+1,n3
   !   print*,'ACT ',j,'  sym',is,'    ',trim(label_OL(j+ideb-1))
   !enddo
   !print*,'n2,n3,n2ref,n3ref',n2,n3,n2ref,n3ref
   do j=n2+1,n3
      anorm=dot_product(orb(ideb:ifin,j+ideb-1), &
      matmul(S0(ideb:ifin,ideb:ifin),orb(ideb:ifin,j+ideb-1)))
      anorm=sqrt(anorm)
      orb(ideb:ifin,j+ideb-1)=orb(ideb:ifin,j+ideb-1)/anorm
      orb3(ideb:ifin,j+ideb-1)=0.d0
      do k=n2ref+1,n3ref
         orb3(ideb:ifin,j+ideb-1)=orb3(ideb:ifin,j+ideb-1) &
         +dot_product(orbscf(:,k), &
         matmul(S0(ideb:ifin,ideb:ifin),orb(ideb:ifin,j+ideb-1))) &
         *orbscf(:,k)
      end do
      anorm2=dot_product(orb3(ideb:ifin,j+ideb-1), &
      matmul(S0(ideb:ifin,ideb:ifin),orb3(ideb:ifin,j+ideb-1)))
      anorm2=sqrt(anorm2)
      if(anorm2<0.8) then
         print'(a,i6,f8.4,a,i2,a)', &
         'rec faible avec l''espace des actives   ', &
         j+ideb-1,anorm2,'   sym',is,'   '// &
         trim(label_OL(j+ideb-1))
      else
         if(mprint(3)==1) print'(a,i6,f8.4,a,i2,a)', &
         'rec avec l''espace des actives          ', &
         j+ideb-1,anorm2,'   sym',is,'   '// &
         trim(label_OL(j+ideb-1))
      endif
   end do
   if(yw)print*,'OL apres proj des actives, sym=',is
   if(yw)call mscript(orb3(ideb:ifin,ideb:ifin))

!
!=============================================================
! projection des virtuelles
!=============================================================
!

   if(norbs>n3) then
      print*,' '
      print'(a,i2,a,2i5,a,2i5,a)', &
      'sym',is,'   Projection sur les virtuelles'// &
      '   [',n3+1,norbs,']  -->  [',n3ref+1,norbs,']'
   endif
   !do j=n3+1,norbs
   !   print*,'VIR ',j,'  sym',is,'    ',trim(label_OL(j+ideb-1))
   !enddo
   call cpu_time(t0)

   !work1=matmul(S0(ideb:ifin,ideb:ifin),&
   !orb(ideb:ifin,n3+1+ideb-1:norbs+ideb-1))
   do i=ideb,ifin
      do j=n3+1+ideb-1,norbs+ideb-1
         dd=0.d0
         do k=ideb,ifin
            dd=dd+s0(k,i)*orb(k,j)
         enddo
         work1(i,j)=dd
      enddo
   enddo
   do j=n3+1,norbs
      anorm=dot_product(orb(ideb:ifin,j+ideb-1), &
      work1(ideb:ifin,j+ideb-1))
      !matmul(S0(ideb:ifin,ideb:ifin),orb(ideb:ifin,j+ideb-1)))
      anorm=sqrt(anorm)
      orb(ideb:ifin,j+ideb-1)=orb(ideb:ifin,j+ideb-1)/anorm
      orb3(ideb:ifin,j+ideb-1)=0.d0
      do m=n3ref+1,norbs
         orb3(ideb:ifin,j+ideb-1)=orb3(ideb:ifin,j+ideb-1) &
         +dot_product(orbscf(:,m), &
         work1(ideb:ifin,j+ideb-1))*orbscf(:,m)/anorm
         !matmul(s0(ideb:ifin,ideb:ifin),orb(ideb:ifin,j+ideb-1))) &
         !*orbscf(:,m)
      end do
      anorm2=dot_product(orb3(ideb:ifin,j+ideb-1), &
      matmul(S0(ideb:ifin,ideb:ifin),orb3(ideb:ifin,j+ideb-1)))
      anorm2=sqrt(anorm2)
      printlim=0.8
      if(label_OL(j+ideb-1)(1:1)=='T'.or.label_OL(j+ideb-1)(1:1)=='t')&
      printlim=0.6
      if(anorm2<printlim) then
         print'(a,i6,f8.4,a,i2,a)', &
         'rec faible avec l''espace des virtuelles', &
         j+ideb-1,anorm2,'   sym',is,'   '// &
         trim(label_OL(j+ideb-1))
      else
         if(mprint(4)==1) print'(a,i6,f8.4,a,i2,a)', &
         'rec avec l''espace des virtuelles       ', &
         j+ideb-1,anorm2,'   sym',is,'   '// &
         trim(label_OL(j+ideb-1))
      endif
   end do
   call cpu_time(t1)
   if(n2>=1) then
           if(yw)print*,'cpu proj virt',t1-t0
      if(yw)print*,'OL apres proj des virtuelles, sym=',is
   endif
   if(yw)call scriptol3(orb3(ideb:ifin,ideb:ifin), &
   norbs,norbs,norbs,norbs,label0, &
   (/(i,i=1,norbs)/),label_ol(ideb:ifin),occscf)
   deallocate(orbscf,occscf)
enddo

orb=orb3

!
!=================================================================
! On teste si les espaces de Reference et ceux des OL sont de
! memes tailles
!=================================================================
!
ybon=.true.
do is=1,nsym
   if(ref_inac(is)/=nocs(is)) then
      ybon=.false.
      exit
   endif
   if(ref_act(is)/=noacs(is)) then
      ybon=.false.
      exit
   endif
enddo
if(.not.ybon) then
   print*,' '
   print*,' '
   print*,'==================================================='
   print*,'STOP  STOP  STOP  STOP  STOP  STOP  STOP  STOP '
   print*,'Les tailles des espaces "occupees", "actives" et'// &
   ' "virtuelles" sont differentes'
   print*,'pour les orbitales de reference et les OL'
   print*,' '
   print'(a,8i5)','Tailles des occ Ref',ref_inac(1:nsym)
   print'(a,8i5)','Tailles des occ OL ',nocs(1:nsym)
   print'(a,8i5)','Tailles des act Ref',ref_act(1:nsym)
   print'(a,8i5)','Tailles des act OL ',noacs(1:nsym)
   print'(a,8i5)','Fermi0             ',fermi0(1:nsym)
   print*,'==================================================='
   print*,' '
   print*,' '
   stop
endif
!=================================================================

end
!
!Orthogonalisation
!
!*****************************************************************
 subroutine ortho(i_work,ycopy_loc)
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
integer :: i_work(norb)
logical :: ycopy_loc(norb)
yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5
call titre('Orthonormalisation of LOs#',300)

!do k=1,norb
!   print*,'LABEL0,label_OL   ',label0(k),'     |      ',label_OL(k),k
!enddo
do is=1,nsym
   if(isym(is)==0) cycle
   print*,' '
   print'(a,i2,a)','Orthonormalisation symmetry',is,&
   '. suite of orthognalisations:'
   ideb=isymt(is)+1
   ifin=isymt(is+1)
   if(yw)print*,'ortho sym',is,'       ideb,ifin',ideb,ifin
   call ortho1(orb(ideb:ifin,ideb:ifin), &
   isym(is),ycopy_loc(ideb:ifin),icoeur(is),ivalence(is), &
   s0(ideb:ifin,ideb:ifin),nprint,i_work(ideb:ifin))
enddo
end
!*****************************************************************
 subroutine ortho1(orb,norb,ycopy,ncoeur,nvalence,s,nprint,i_work)
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
dimension s(norb,norb),orb(norb,norb)
integer :: i_work(norb)
logical :: ycopy(norb)
yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5

! Normalisation avant d'orthogonaliser
! (pour eviter certains problemes numeriques)
do k=1,norb          !normalisation
   anorm=dot_product(orb(:,k), matmul(S,orb(:,k)))
   anorm=sqrt(anorm)
   if(yw)print*,'anorm',k,anorm
   orb(:,k)=orb(:,k)/anorm
end do
if(yw)print*,'ortho1 apres 1ere normalisation'
if(yw)call mscript(orb)

! Eventuellement, 1ere orthogonalisation pour les OM copiees
! les OM copiees sont deja orthogonales, donc pas de 1er S**-1/2
! Elles sont exprimees sur toutes les OA, donc on projette par
! Schmidt pour toutes les OA
! pas de 2eme S-1/2Orthonormalisation symmetry
nb_copy=count(ycopy)
if(nb_copy>0) then
   if(yw)print'(a,2i5,20i3)','ortho OM copiees',nb_copy, &
   i_work(1:nb_copy)
   call hier3(orb,norb,i_work,0,nb_copy,norb,S,0,1,0)
   print'(i4,a,i5,a)',norb-nb_copy,' LOs have been orthogonalised to'&
   ,nb_copy,' copied orbitals'
   if(yw)print*,'ortho1 apres hier3 pour copy'
   if(yw)call mscript(orb)
   if(yw)print*,'matmul(transpose(orb),matmul(S,orb))'
   if(yw)call mscript(matmul(transpose(orb),matmul(S,orb)))
endif

! Appel a hier3 : S**-1/2 sur coeur, Schmidt val/coeur, S**-1/2 val
if(yw)print*,'0,ncoeur,ncoeur+nvalence' &
,0,ncoeur,ncoeur+nvalence

print'(a,i14,a)','S-1/2 for',ncoeur,' core LOs,'
print'(a,i4,a)','orthogonalisation of',nvalence,' valence LOs to core,'
print'(a,i9,a)','S-1/2 for the ', nvalence,' valence LOs'
call hier3(orb,norb,(/(k,k=1,norb)/), &
nb_copy,ncoeur,ncoeur+nvalence,S,1,1,1)
if(yw)print*,'ortho1 apres 1er hier3'
if(yw)call mscript(orb)
if(yw)print*,'Rec'
if(yw)call mscript(matmul(transpose(orb),matmul(s,orb)))
if(yw)print*,'ncoeur,ncoeur+nvalence,norb' &
,ncoeur,ncoeur+nvalence,norb

! Appel a hier3 : Schmidt virt/(val+coeur), S**-1/2 virt
print'(a,i4,a,i4,a)','orthogonalisation of',norb-ncoeur-nvalence,&
' last LOs to',ncoeur+nvalence,' core+valence LOs,'
print'(a,i9,a)','S-1/2 for the ', norb-ncoeur-nvalence,' last LOs'
call hier3(orb,norb,(/(k,k=1,norb)/), &
ncoeur,ncoeur+nvalence,norb,S,0,1,1)
if(yw)print*,'ortho1 apres 2eme hier3'
if(yw)call mscript(orb)
if(yw)print*,'Rec a la fin'
if(yw)call mscript(matmul(transpose(orb),matmul(s,orb)))

! Normalisation apres orthogonalisation
do k=1,norb
   anorm=dot_product(orb(:,k), matmul(S,orb(:,k)))
   anorm=sqrt(anorm)
   orb(:,k)=orb(:,k)/anorm
end do
if(yw)print*,'ortho1 apres 2eme normalisation'
if(yw)call mscript(orb)
end
!
!Fonction cherche numero OA, ligne ds la matrice
!
 function numero_OA(atome,OA)
use lewis_module
Use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
character(6) :: atome
character(*) :: OA
integer :: numero_OA
yw=.false.
numero_OA=0
do i=1,norb
   if(yw)print*,':::'//atome//OA//':::'//label(i)//':::',i
   if(atome//OA==label(i)) then
      numero_OA=i
      if (yw) print*,'trouve',i
      return
   end if
end do
return
end
!
!Fonction cherche numero OA, ligne ds la matrice
!
 function numero_OA0(atome,OA,ideb,ifin)
use lewis_module
Use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
character(4) :: atome
character(*) :: OA
integer :: numero_OA0
yw=.false.
numero_OA0=0
do i=ideb,ifin
   if(yw)write(6,*)':::'//atome//OA//':::'//label0(i)//':::',i
   if(atome//OA==label0(i)) then
      numero_OA0=i
      return
   end if
end do
return
end
!
!copie d'une orbitale depuis les orbitales en donnee
!
!*****************************************************************
 subroutine copy(bond)
use lewis_module
Use mod_script
implicit none
integer,parameter :: maxat_CP=3,maxshell_CP=100
character(*):: bond
integer::sym,num,l,nat_CP,numoa,i,numero_oa,cherche_at,iat,iii(1)
integer :: cherche_at2,js,iii_sv
real(8) :: orbscf_sv
character(20) name
character(4) :: at(maxat_CP),shell(maxshell_CP)
character :: label_CP,asym,bsym
logical :: yw=.false.
character(8) :: type
yw=(yw.or.nprint==5).and..not.nprint==-5
if(yw) print*,' '
if(yw)print*,'------------entree copy----------   '
if(yw)print*,'bond:   ',"'"//bond(1:6)//"'"

! le string BOND en entree contient un nom d'atome sur 6 caracteres
! il y a eventuellement une couche (1S, 1S(2), 2PX, 2P...) donnee dans
! la variable en commun suppdata

l=len_trim(suppdata)+1
if(suppdata(l-1:l-1)/=',') suppdata(l:l)=','
if(yw)print*,'suppdata ',trim(suppdata)
at=' '
call namela(suppdata,AT,'ATOM')
do i=1,maxat_CP
   if(at(i)==' ') then
      nat_cp=i-1
      exit
   endif
enddo
label_CP=' '
shell=' '
call namela(suppdata,SHELL,'SHELL')
call namela(suppdata,label_CP,'LABEL')
call nameli(suppdata,SYM,'SYM',4)
call nameli(suppdata,NUM,'NUM',4)
call namela(suppdata,TYPE,'TYPE')
if(label_CP==' ') then
   if(num<=ref_inac(sym)) then
      label_CP='O'
      occupat(iorb)=.TRUE.
      focvir(iorb)='OCC'
      noc=noc+1
   else if(num<=ref_inac(sym)+ref_act(sym)) then
      label_CP='A'
      if(num<=fermi0(sym)) then
         occupat(iorb)=.TRUE.
         focvir(iorb)='ACTO'
         noc=noc+1
      else
         occupat(iorb)=.false.
         focvir(iorb)='ACTV'
      endif
            !noacs(sym)=noacs(sym)+1
      !print*,'NOACS',sym,noacs(sym)
   else
      occupat(iorb)=.false.
      focvir(iorb)='VIRT'
   endif
endif
write(asym,'(i1)') sym
if(yw) then
   print*,'num',num
   print*,'sym',sym
   print*,'atom ',at(1:nat_CP)
   print*,'shell ',shell(1:nat_CP)
   print*,'type ',type
endif
iorb=iorb+1
ycopy(iorb)=.true.
fnat(iorb)=nat_CP
fsigpi(iorb)=type
orb(:,iorb)=0.d0
if(type=='CORE') ncoeur=ncoeur+1
do i=1,nat_CP
   atoms_in_LO(iorb,i)=at(i)
enddo
if(nat_cp==1) then
   name=label_CP//'_'//trim(at(1))//'.'//trim(shell(1))//'.CP'
else if(nat_cp==2) then
   name=label_CP//'_'//trim(at(1))//'.'//trim(shell(1))//'-'//trim(at(2))//'.'//trim(shell(2))//'.CP'
endif
label_OL_temp(iorb)=name
write(bsym,'(i1)') sym
if(shell(1)/=' ') then
   do i=1,nat_CP
      iat=cherche_at2(at(i)//'_'//bsym)
      if(yw)print*,'iat',at(i)//'_'//bsym,iat
      if(iat>0) then
         numoa=numero_OA(at(i)//'_'//bsym,shell(i))
         if(yw)print*,'numoa     ',at(i)//'_'//bsym,shell(i),numoa
         diff(numoa)=.FALSE.
      endif
   enddo
else
   iii=maxloc(abs(orbscf(:,sum(isym(1:sym-1))+num)))
   numoa=numero_OA(label0(iii(1))(1:4)//'_'//bsym,label0(iii(1))(5:8))
   diff(numoa)=.FALSE.
   shell(1)=label0(iii(1))(5:8)
   if(yw)print*,'iii',iii(1),numoa,'   ',label0(iii(1))(5:8)
   if(nat_cp==1) then
      name=label_CP//'_'//trim(at(1))//'.'//trim(shell(1))//'.CP'
   else if(nat_cp==2) then
      iii_sv=iii(1)
      orbscf_sv=orbscf(iii(1),sum(isym(1:sym-1))+num)
      orbscf(iii(1),sum(isym(1:sym-1))+num)=0.d0
      iii=maxloc(abs(orbscf(:,sum(isym(1:sym-1))+num)))
      numoa=numero_OA(label0(iii(1))(1:4)//'_'//bsym,label0(iii(1))(5:8))
      diff(numoa)=.FALSE.
      shell(2)=label(iii(1))(5:8)
      name=label_CP//'_'//trim(at(1))//'.'//trim(shell(1))//'-'//trim(at(2))//'.'//trim(shell(2))//'.CP'
   endif
   label_OL_temp(iorb)=name
endif   

! ecriture sur file CPfile de l'orbitale scf a copier (l'orbitale est
! en symetrie, exprimee dans des OA de symetrie)
write(ifil_CP) sym,num,orbscf(:,sum(isym(1:sym-1))+num)

end
!
!Formation orbitale de coeur
!
!*****************************************************************
 subroutine coeur(bond,pref,iocc)
use lewis_module
Use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*):: bond
integer::numero,numero_OA
character(8) couche
character c
character pref
integer iocc
yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5
if(yw) print*,' '
if(yw)print*,'------------entree coeur bond:----------   '
if(yw)print*,'bond:   ',"'"//bond(1:6)//"'"
if(yw)print*,'pref:  ',"'"//pref//"'"

! le string BOND en entree contient un nom d'atome sur 6 caracteres

!=======================
! Donnee SHELL= (couche)
!=======================

! il y a eventuellement une couche (1S, 1S(2), 2PX, 2P...) donnee dans
! la variable en commun suppdata

! si la couche n'est pas donnee, elle est 1S...
couche='1S'
i=index(suppdata,'SHELL=')
if(yw)print*,'suppdata:  ',"'"//trim(suppdata)//"'"
!... sinon:
!  1. la couche a ete stockee dans suppdata, on la lit:
if(i>0) then
   couche=suppdata(i+6:)
   j=index(couche,')')
   couche(j+1:)=' '
   if(yw)print*,'couche lue:  ',"'"//couche(1:j)//"'"
endif
!  2. si on n'a pas donne que SHELL= dans suppdata:
i=index(couche,',')
if(i>0) then
   couche(i:)=' '
   if(yw)print*,'couche corrigee:  ',"'"//couche(1:i-1)//"'"
endif
if(yw)print*,'couche retenue a la fin: ',"'"//trim(couche)//"'"

!  3. couches de nombres quantiques plus eleves
!     Si on a donne couche==1S(2), on ne cherche pas la 1ere S, mais
!     la 2eme. Il y a un decalage de 1 par rapport a couche==1S
idecal=0
i1=index(couche,'(')
if(i1>0) then
   i2=index(couche,')')
   read(couche(i1+1:i2-1),*) idecal
   idecal=idecal-1
   couche(i1:)=' '
endif

!==========================
! Numero de l'OA
!==========================
numero=numero_OA(bond(1:6),couche)+idecal
if(numero==idecal) then
   print*,'AO not found:  ',"'"//bond(1:6)//couche//"'";stop
endif
diff(numero)=.FAlSE.

! Creation de l'orbitale

iorb=iorb+1
fnat(iorb)=1
if(iocc==2) then
   occupat(iorb)=.true.
   noc=noc+1
   focvir(iorb)='OCC'
   if(pref=='C'.or.pref=='c') then
      fsigpi(iorb)='CORE'
   else
      fsigpi(iorb)='ATOM'
      if(pref=='A'.or.pref=='a') focvir(iorb)='ACTO'
   endif
else
   occupat(iorb)=.false.
   focvir(iorb)='VIRT'
   if(pref=='A'.or.pref=='a') focvir(iorb)='ACTV'
   fsigpi(iorb)='ATOM'
endif
if(idecal==0) then
   label_OL_temp(iorb)=pref//'_'//trim(bond)//'_'//trim(couche)
else
   if(idecal>9) stop 'idecal trop grand dans coeur'
   write(c,'(i1)') idecal+1
   label_OL_temp(iorb)=pref//'_'//trim(bond)//'_'//trim(couche) &
   //'('//c//')'
endif
if(yw)print*,'COEUR genere orb',iorb,numero,label_OL_temp(iorb)
ORB(numero,iorb)=1.D0
atoms_in_LO(iorb,1)=label_OL_temp(iorb)(3:6)
do i=1,norb
   if(abs(orb(i,iorb))>1.d-6) &
   print'(a,2f10.6)',label(i),orb(i,iorb)
enddo
if(yw)print*,'------------sortie coeur bond:----------   '
if(yw) print*,' '


end
!
!Fonction cherche numero atome, numero atome pour obtenir coord
!
 function cherche_at(atome)
use lewis_module
implicit real*8 (a-h,o-x,z),logical*1(y)
character(6) :: atome
integer cherche_at
yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5
if(yw) print*,'cherche_at natom',natom
do i=1,natom
   if(yw)print*,'on cherche : ',atome,' ; ds la liste : ',atom(i)
   if(atome==atom(i)) then
      cherche_at=i
      if(yw)print*,'atome trouve',i
      return
   end if
end do
print*,'cherche_at : atome non trouve',atome
stop
end
 function cherche_at2(atome)
use lewis_module
implicit real*8 (a-h,o-x,z),logical*1(y)
character(6) :: atome
integer cherche_at2
yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5
if(yw) print*,'cherche_at natom',natom
do i=1,natom
   if(yw)print*,'on cherche : ',atome,' ; ds la liste : ',atom(i)
   if(atome==atom(i)) then
      cherche_at2=i
      if(yw)print*,'atome trouve',i
      return
   end if
end do
cherche_at2=0
if(yw)print*,'cherche_at : atome non trouve',atome
end
 function cherche_at0(atome)
use lewis_module
implicit real*8 (a-h,o-x,z),logical*1(y)
character(4) :: atome
integer cherche_at0
yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5
do i=1,natom0
   if(yw)print*,'on cherche : ',atome,' ; ds la liste : ',atom0(i)
   if(atome==atom0(i)) then
      cherche_at0=i
      if(yw)print*,'cherche_at0',cherche_at0
      return
   end if
end do
print*,atome,' cherche_at0 : atome non trouve'
end
!
!Produit vectoriel à partir des atomes
!
!*****************************************************************
 subroutine produit_vect(prem,seco,troi,prov)
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
integer::prem,seco,troi
real(8):: vex1,vex2,vey1,vey2,vez1,vez2
real(8) :: prov(3)
yw=.false.
vex1=coord(1,seco)-coord(1,prem)
vey1=coord(2,seco)-coord(2,prem)
vez1=coord(3,seco)-coord(3,prem)
vex2=coord(1,troi)-coord(1,seco)
vey2=coord(2,troi)-coord(2,seco)
vez2=coord(3,troi)-coord(3,seco)
prov(1)=(vey1 * vez2) - (vez1 * vey2)
prov(2)=(vez1 * vex2) - (vex1 * vez2)
prov(3)=(vex1 * vey2) - (vey1 * vex2)
if(yw) then
   print*,'produit_vect coordonnees'
   print'(a,3f10.6,a8)','atome 1 :',coord(:,prem),atom(prem)
   print'(a,3f10.6,a8)','atome 2 :',coord(:,seco),atom(seco)
   print'(a,3f10.6,a8)','atome V :',coord(:,troi),atom(troi)
   print'(a,3f10.6)','prod vec:',prov
   print*,'atomes  ',atom(prem),' | ',atom(seco),' | ',atom(troi)
   print*,'*************************'
endif
end
!
!Produit vectoriel général
!
!*****************************************************************
 subroutine produit_vectoriel(vect1,vect2,vectfi)
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
real(8),dimension(3)::vect1,vect2,vectfi
vectfi(1)=(vect1(2) * vect2(3)) - (vect1(3) * vect2(2))
vectfi(2)=(vect1(3) * vect2(1)) - (vect1(1) * vect2(3))
vectfi(3)=(vect1(1) * vect2(2)) - (vect1(2) * vect2(1))
end
!
!Fonction cherche atome proche
!
!*****************************************************************
 function atome_proche(chiffre1,chiffre2)
!
!--------------------------------------------------------------------
! en entree, chiffre1,chiffre2 : 2 numeros d'atomes (non sym)
! en sortie : atome_proche : le numero de
! l'atome de la molecule le plus proche de
! chiffre1 et different de chiffre2, tel que les 3 atomes ne soient
! pas alignes
!--------------------------------------------------------------------
!
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
real(8),allocatable,dimension(:) ::L
integer::chiffre1,chiffre2,atome_proche
real(8),dimension(3) :: prov1
distmin=1000000.d0
      !print*,'chiffre1,chiffre2',chiffre1,chiffre2
allocate(L(Natom))
do i=1,natom
   if (i==chiffre1) cycle
   if (i==chiffre2) cycle
   L(i)=distanc(chiffre1,i)
   if (L(i)<=distmin) then
!           les atomes ne doivent pas etre alignes
      call produit_vect(chiffre1,chiffre2,i,prov1)
            !print*,'prov1',prov1,chiffre1,chiffre2,i
      if(all(abs(prov1)<0.5)) cycle
      atome_proche=i
   end if
   distmin=min(distmin,L(i))
end do
if (distmin>4.) then
   atome_proche=0
end if
end
!
!Fonction cherche atome proche (atomes exprimes en caracteres)
!
 function atome_proche_char(nom1,nom2)
!
!--------------------------------------------------------------------
! en entree, nom1,nom2 : 2 string
!    nom1 : nom de l'atome dont on cherche les voisins
!    nom2 : nom1 ne doit pas etre inclus dans nom2
! en sortie : atome_proche : le nom de
! l'atome de la molecule le plus proche de
! nom1 et non inclus dans chiffre2, tel que les 3 atomes ne soient
! pas alignes
!--------------------------------------------------------------------
!
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
real(8),allocatable,dimension(:) ::L
character(*)::nom1,nom2
real(8),dimension(3) :: prov1
character(6) :: aa,atome_proche_char
integer cherche_at
yw=.false.

distmin=1000000.d0
      !print*,'chiffre1,chiffre2',chiffre1,chiffre2
allocate(L(Natom))

i1=cherche_at(nom1)
if(yw)print*,'nom1,i1',nom1,i1
do i=1,natom
   aa=atom(i)
   if(aa==nom1) cycle
   if (index(nom2,'_'//trim(aa)//'_')>0) cycle
   L(i)=distanc(i1,i)
   if (L(i)<=distmin) then
      atome_proche_char=aa
   end if
   distmin=min(distmin,L(i))
end do
end
!
!Fonction distance internucleaire
!
 Function distanc(ato1m,ato2m)
!
!------------------------------------------------------------
! Distance entre les atomes ato1m et ato2m
! en entree :
! ato1m,ato2m = numero des deux atomes dans la liste des atomes
! non symetriques (locaux) (liste longue)
! en sortie :
! la distance entre ces 2 atomes
!------------------------------------------------------------
!
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
integer::ato1m,ato2m
yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5
if(yw)print*,'distanc ato1m,ato2m',ato1m,ato2m
dx=coord(1,ato2m)-coord(1,ato1m)
dy=coord(2,ato2m)-coord(2,ato1m)
dz=coord(3,ato2m)-coord(3,ato1m)
distanc=SQRT(dx**2+dy**2+dz**2)
end
!
!Fonction distance internucleaire minimale
!
 Function distancmin(ato1m,ato2m)
!
!------------------------------------------------------------
! Distance minimale entre les atomes ato1m et ato2m (atomes
! dans la liste des atomes symetriques) (liste courte)
! en entree :
! ato1m,ato2m = numero des deux atomes dans la liste des atomes
! symetriques (liste courte)
! en sortie :
! la distance minimale tous les equivalents par symetrie de
! ato1m et ato2m
!------------------------------------------------------------
!
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
real(8) distancmin
integer::ato1m,ato2m
yw=.false.
distancmin=100000000.d0
      !print*,'distancmin',ato1m,ato2m
! boucle sur les atomes de la liste longue
do iat1=1,natom
         !print*,'atom1',atom(iat1),atom0(ato1m)
   if(atom(iat1)(1:4)/=atom0(ato1m)(1:4)) cycle
! l'atome iat1 de la liste longue appartient a la famille de ato1m de
! la liste courte

! 2eme boucle sur les atomes de la liste longue
   do iat2=1,natom
            !print*,'atom2',atom(iat2),atom0(ato2m)
      if(iat1==iat2) cycle
      if(atom(iat2)(1:4)/=atom0(ato2m)(1:4)) cycle
! 2eme atome (iat2) de la liste longue trouve

! distance iat1-iat2
      dx=coord(1,iat1)-coord(1,iat2)
      dy=coord(2,iat1)-coord(2,iat2)
      dz=coord(3,iat1)-coord(3,iat2)
      distancmin=min(distancmin,SQRT(dx**2+dy**2+dz**2))
            !print*,'distancmin',iat1,iat2,distancmin
   enddo
enddo
end
!
!Doublet DS1
!
!*****************************************************************
 subroutine doubletDS1(bond)
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*):: bond
integer::tbond
character(6)::atomc,atom1,atom2,atom3
real(8),dimension(3)::d
integer,dimension(4):: numero
integer cherche_at
dimension vnorm(3)
character(2) :: list_atoms(100),cha1
character :: chiffre(10)=(/'0','1','2','3','4','5','6','7','8','9'/)

list_atoms=' '
list_atoms(1:8)=  (/'LI','BE','B ','C ','N ','O ','F ','NE'/)
list_atoms(9:16)=  (/'NA','MG','AL','SI','P ','S ','CL','AR'/)

tbond=len_trim(bond)
! Le nb d'atomes est donne par la longueur de bond
! (7 car par atome, 6 pour le dernier atome)
nat_axe=(len_trim(bond)+1)/7-1
atomc=bond(1:6)
if (nat_axe==1) then
   atom1=bond(8:13)
   atom2=atomc
   atom3=atomc
else if (nat_axe==2) then
   atom1=bond(8:13)
   atom2=bond(15:20)
   atom3=atomc
else if (nat_axe==3) then
   atom1=bond(8:13)
   atom2=bond(15:20)
   atom3=bond(22:27)
end if
      !print*,'atomc,atom1,atom2,atom3,nat_axe',
      !*atomc,atom1,atom2,atom3,nat_axe
natomc=cherche_at(atomc)
natom1=cherche_at(atom1)
natom2=cherche_at(atom2)
natom3=cherche_at(atom3)
      !print*,'natomc,natom1,natom2,natom3',natomc,natom1,natom2,natom3
do i=1,3
   d(i)=3*coord(i,natomc)-(coord(i,natom1)+ &
   coord(i,natom2)+coord(i,natom3))
end do

!---------------------------------------------
! longueur du nom de l'atome, sans son numero
!---------------------------------------------
do i=1,4
   if(any(atomc(i:i)==chiffre(:)).or.atomc(i:i)==' ') then
      long_atom1=i-1
      exit
   endif
enddo


!-------------------------------------------------------------
! numero des OA de la liaison dans la base d'OA de la molecule
!-------------------------------------------------------------
cha1=' '
cha1(1:long_atom1)=atomc(1:long_atom1)

! 1) Orbitales 2s, 2p
if(any(cha1==list_atoms(1:8)(1:2))) then
   print*,'atome 1ere ligne',cha1,list_atoms(1:8)(1:2)
   numero(1)=numero_OA(atomc,'2PX')
   numero(2)=numero_OA(atomc,'2PY')
   numero(3)=numero_OA(atomc,'2PZ')
   numero(4)=numero_OA(atomc,'1S')+1
endif
! 1) Orbitales 3s, 3p
if(any(cha1==list_atoms(9:16)(1:2))) then
   print*,'atome 2eme ligne'
   numero(1)=numero_OA(atomc,'2PX')+1
   numero(2)=numero_OA(atomc,'2PY')+1
   numero(3)=numero_OA(atomc,'2PZ')+1
   numero(4)=numero_OA(atomc,'1S')+2
endif
iorb=iorb+1
fnat(iorb)=1
focvir(iorb)='OCC'
if(prefix_label_OL=='A'.or.prefix_label_OL=='a') focvir(iorb)='ACTO'
fsigpi(iorb)='LP'
atoms_in_LO(iorb,1)=atomc(1:4)
label_OL_temp(iorb)=prefix_label_OL//'_'//trim(atomc)//'.LPsig'
      !print*,'label  ',label_OL_temp(iorb)
occupat(iorb)=.TRUE.
noc=noc+1

!     normalisation de la partie P
vnorm=0.d0
do i=1,3
   k=numero(i)
   do j=1,3
      l=numero(j)
      vnorm(i)=vnorm(i)+d(j)*s(k,l)
   enddo
enddo
anorm=sqrt(dot_product(vnorm,d))
do j=1,3
   ORB(numero(j),iorb)=d(j)/anorm
   diff(numero(i))=.FALSE.
end do
ORB(numero(4),iorb)=1
do i=1,norb
   if(abs(orb(i,iorb))>1.d-6) &
   print'(a,2f10.6)',label(i),orb(i,iorb)
enddo
end
!
!Doublet DP1
!
!*****************************************************************
 subroutine doubletDP1(bond,neldp1)
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*):: bond
integer::tbond,nblanc,rblanc,cherche_at
integer,dimension(3)::blanc
character(6)::atomc,atom1,atom2,atom3
real(8),dimension(3)::d,prov1,prov2,prov3
integer,dimension(3):: numero
character(500) :: deja
character(6) :: atome_proche_char
character(2) :: list_atoms(100),cha1
character :: chiffre(10)=(/'0','1','2','3','4','5','6','7','8','9'/)

list_atoms=' '
list_atoms(1:8)=  (/'LI','BE','B ','C ','N ','O ','F ','NE'/)
list_atoms(9:16)=  (/'NA','MG','AL','SI','P ','S ','CL','AR'/)


yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5
!
!------------------------------------------
! 2 possibilites :
!
! 1. les atomes voisins sont donnes
! nb d'atomes donnes dans bond :
!
! Le nb d'atomes est donne par la longueur de bond
! (7 car par atome, 6 pour le dernier atome)
!
! puis noms de ces atomes (atomc, atom1 atom2) (liste longue)
!
! ex : DP1 N1  _1 C1  _1 C2  _2
!
! 2. la donnees est atomc ; nvois=n
!    ou n est le nb de voisins a trouver
!
! ex : DP1 C1 ; nvois=3
!------------------------------------------
!
if(yw) print*,'entree DP1 bond',trim(bond)

atomc=bond(1:6)

ynvois=.false.
if(yw)print*,'suppdata= ',trim(suppdata)
if(suppdata/=' ') then
   i=index(suppdata,'NVOIS=')
   ynvois=i>0
   if(i>0) then
      read(suppdata(i+6:),*) nvois
      deja='_'
      atom1=atome_proche_char(atomc,deja)
      if(yw)print*,'atome_proche_char',atom1
      deja=trim(deja)//atom1//'_'
      atom2=atome_proche_char(atomc,deja)
      if(yw)print*,'atome_proche_char',atom2
      atom3=' '
      if(nvois>2) then
         deja=trim(deja)//atom2//'_'
         atom3=atome_proche_char(atomc,deja)
         if(yw)print*,'atome_proche_char',atom3
      endif
   endif
   i=index(suppdata,'INPLANE')
   yinplane=i>0
else
   ynvois=.false.
   yinplane=.false.
endif

if(.not.ynvois) then
   nvois=(len_trim(bond)+1)/7-1
   if(yw) print*,'DP1 nvois',nvois
!    noms des atomes en entree
   if (nvois==2) then
      atom1=bond(8:13)
      atom2=bond(15:20)
      atom3=' '
   else if (nvois==3) then
      atom1=bond(8:13)
      atom2=bond(15:20)
      atom3=bond(22:27)
   else
      print*,'DP1: NVOIS must be 2 or 3';stop
   end if
end if

if(yinplane.and.nvois==3) then
   print*,'3 voisins et INPLANE impossible'
   stop
endif

if(bond(28:)/=' ') then
   print*,'DP1 plus de 3 atomes voisins'
   print*,'atomc ',atomc
   print*,'atom1 ',atom1
   print*,'atom2 ',atom2
   print*,'atom3 ',atom3
   print*,'reste de la donnee ',bond(21:)
   stop
endif


! numeros des atomes en entree
natomc=cherche_at(atomc)
if(yw)print*,'atome qui porte les doublets',natomc
if(yw)print*,'atom1,atom2,atom3',atom1,atom2,atom3
natom1=cherche_at(atom1)
natom2=cherche_at(atom2)
natom3=0
if(atom3/=' ') natom3=cherche_at(atom3)
if(yw)print*,'DP1 atomes voisins',natom1,natom2,natom3


! axe : prov1 = atomc-atom1 ^ atomc-atom2
if(nvois==2) then
   if(yinplane) then
            !print*,'atomc',coord(:,natomc)
            !print*,'atom1',coord(:,natom1)
            !print*,'atom2',coord(:,natom2)
      call produit_vectoriel(coord(:,natomc)-coord(:,natom1) &
      ,coord(:,natomc)-coord(:,natom2),prov2)
            !print*,'prov1',prov1
      call produit_vectoriel(prov2,coord(:,natomc)-coord(:,natom1) &
      ,prov1)
            !print*,'prov1',prov1
   else
      call produit_vect(natom1,natomc,natom2,prov1)
   endif
else
   call produit_vect(natom1,natom2,natom3,prov1)
endif
print'(a,3f10.4)','direction de l''orbitale',prov1
!      call produit_vect(natom3,natomc,natom1,prov3)
!      d=(prov1+prov2+prov3)/3
d=prov1


! longueur du nom de l'atome, sans son numero
do i=1,4
   if(any(atomc(i:i)==chiffre(:)).or.atom1(i:i)==' ') then
      long_atomc=i-1
      exit
   endif
enddo

! Generation de l'orbitale pi
cha1=' '
cha1(1:long_atomc)=atomc(1:long_atomc)

if(any(cha1==list_atoms(1:8)(1:2))) then
        print*,'1ere ligne'
   numero(1)=numero_OA(atomc,'2PX')
   numero(2)=numero_OA(atomc,'2PY')
   numero(3)=numero_OA(atomc,'2PZ')
else if(any(cha1==list_atoms(9:16)(1:2))) then
        print*,'2eme ligne'
   numero(1)=numero_OA(atomc,'2PX')+1
   numero(2)=numero_OA(atomc,'2PY')+1
   numero(3)=numero_OA(atomc,'2PZ')+1
endif
iorb=iorb+1
fnat(iorb)=1
if(neldp1==2) then
   focvir(iorb)='OCC'
   if(prefix_label_OL=='A'.or.prefix_label_OL=='a') focvir(iorb)='ACTO'
   fsigpi(iorb)='LP'
   label_OL_temp(iorb)=prefix_label_OL//'_'//trim(atomc)//'.LPpi'
         !print*,'label  ',label_OL_temp(iorb)
   occupat(iorb)=.TRUE.
   noc=noc+1
else
   focvir(iorb)='VIRT'
   if(prefix_label_OL=='A'.or.prefix_label_OL=='a') focvir(iorb)='ACTV'
   fsigpi(iorb)='EMPTY_P'
   label_OL_temp(iorb)=prefix_label_OL//'_'//trim(atomc)//'.Vpi'
   occupat(iorb)=.FALSE.
endif
atoms_in_LO(iorb,1)=atomc(1:4)
do j=1,3
   ORB(numero(j),iorb)=d(j)
   diff(numero(j))=.FALSE.
end do
do i=1,norb
   if(abs(orb(i,iorb))>1.d-6) &
   print'(a,2f10.6)',label(i),orb(i,iorb)
enddo
end
!
!Doublet D2
!
!*****************************************************************
 subroutine doubletD2(bond)
use lewis_module
use mod_script
!
!--------------------------------------------------------------
! en entree, bond, soit 1, 2 ou 3 atomes (atomc, atom1, atom2)
!--------------------------------------------------------------
!
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*):: bond
integer::tbond,natompro1,cherche_at,atome_proche
character(6)::atomc,atom1,atom2
real(8),dimension(3)::d,vec1,vec2,prov1,prov2
integer,dimension(4):: numero
dimension vnorm(3)
character :: chiffre(10)=(/'0','1','2','3','4','5','6','7,','8','9'/)
character(2) :: list_atoms(100),cha1


list_atoms=' '
list_atoms(1:8)=  (/'LI','BE','B ','C ','N ','O ','F ','NE'/)
list_atoms(9:16)=  (/'NA','MG','AL','SI','P ','S ','CL','AR'/)



yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5
tbond=len_trim(bond)
if(yw)print*,'D2 bond   ',trim(bond)


!
!------------------------------------------
! nb d'atomes donnes dans bond :
!
! Le nb d'atomes est donne par la longueur de bond
! (7 car par atome, 6 pour le dernier atome)
!
! puis noms de ces atomes (atomc, atom1 atom2) (liste longue)
!------------------------------------------
!
nat_axe=(len_trim(bond)+1)/7-1
if(yw) print*,'D2 nat_axe',nat_axe
! noms des atomes en entree
atomc=bond(1:6)
if (nat_axe==1) then
   atom1=bond(8:13)
   atom2=atomc
else if (nat_axe==2) then
   atom1=bond(8:13)
   atom2=bond(15:20)
end if



! numeros des atomes en entree
natomc=cherche_at(atomc)
if(yw)print*,'atome qui porte les doublets',natomc
natom1=cherche_at(atom1)
natom2=cherche_at(atom2)
if(yw)print*,'atomes voisins',natom1,natom2

!
!----------------------------------------------
! On fabrique le doublet sigma
!----------------------------------------------
!
! calcul de d, vecteur directeur du doublet sigma
do i=1,3
   d(i)=2*coord(i,natomc)-(coord(i,natom1)+ &
   coord(i,natom2))
end do

! normalisation de d (provisoire, sans tenir compte
! de la non-orthogonalite de la base)
d=d/dsqrt(d(1)*d(1)+d(2)*d(2)+d(3)*d(3))

! longueur du nom de l'atome, sans son numero
do i=1,4
   if(any(atomc(i:i)==chiffre(:)).or.atomc(i:i)==' ') then
      long_atomc=i-1
      exit
   endif
enddo


! numero : rang de la 1ere apparition du label atomc//2PX, atomc//2PY...
cha1=' '
cha1(1:long_atomc)=atomc(1:long_atomc)

if(any(cha1==list_atoms(1:8)(1:2))) then
   numero(1)=numero_OA(atomc,'2PX')
   numero(2)=numero_OA(atomc,'2PY')
   numero(3)=numero_OA(atomc,'2PZ')
   numero(4)=numero_OA(atomc,'1S')+1
else if(any(cha1==list_atoms(9:16)(1:2))) then
   numero(1)=numero_OA(atomc,'2PX')+1
   numero(2)=numero_OA(atomc,'2PY')+1
   numero(3)=numero_OA(atomc,'2PZ')+1
   numero(4)=numero_OA(atomc,'1S')+2
endif
print*,'numero',numero

! on incremente le nb d'OL generees
iorb=iorb+1
fnat(iorb)=1
focvir(iorb)='OCC'
if(prefix_label_OL=='A'.or.prefix_label_OL=='a') focvir(iorb)='ACTO'
fsigpi(iorb)='LP'
atoms_in_LO(iorb,1)=atomc(1:4)
! on fabrique le label :
label_OL_temp(iorb)=prefix_label_OL//'_'//atomc//'.LP.SIG'
! on declare l'OL occupee
occupat(iorb)=.TRUE.
noc=noc+1
! on normalise la partie P de l'orbitale
vnorm=0.d0
do i=1,3
   k=numero(i)
   do j=1,3
      l=numero(j)
      vnorm(i)=vnorm(i)+d(j)*s(k,l)
   enddo
enddo
anorm=sqrt(dot_product(vnorm,d))
! on remplit la partie X,Y,Z du doublet de atomc dan ORB
do j=1,3
   ORB(numero(j),iorb)=d(j)/anorm
! on declare l'OL non diffuse (valence) :
   diff(numero(j))=.FALSE.
end do
! on remplit la partie S du doublet de atomc dan ORB
ORB(numero(4),iorb)=1
!
!
!
!----------------------------------------------
! On fabrique le doublet pi
!----------------------------------------------
!
if(nat_axe==1) then
!cas d'un seul atome en plus de atomc
! on cherche natompro1, atome proche de atom1, mais different de atomc
   natompro1=atome_proche(natom1,natomc)
! vecteurs vec1=natompro1-natom1, vec2=natomc-natom1
   do k=1,3
      if(yw)print*,natompro1,natom1,natomc
      vec1(k)=coord(k,natompro1)-coord(k,natom1)
      vec2(k)=coord(k,natomc)-coord(k,natom1)
   end do
! vecteur prov1, orthogonal au plan des 3 atomes
! vecteur prov2, orthogonal a natomc-natom1, dan le plan des 2 atomes
! (orbitale n)
   call produit_vectoriel(vec2,vec1,prov1)
   call produit_vectoriel(prov1,vec2,prov2)
! normalisation de prov2 (provisoire, sans tenir compte
! de la non-orthogonalite de la base)
   prov2=prov2/dsqrt(prov2(1)*prov2(1)+prov2(2)*prov2(2) &
   +prov2(3)*prov2(3))
! on genere l'orbitale (incr iorb, label, remplit ORB)
   iorb=iorb+1
   fnat(iorb)=1
   focvir(iorb)='OCC'
   if(prefix_label_OL=='A'.or.prefix_label_OL=='a') focvir(iorb)='ACTO'
   fsigpi(iorb)='LP'
   atoms_in_LO(iorb,1)=atomc(1:4)
   label_OL_temp(iorb)=prefix_label_OL//'_'//atomc//'.LP.N'
   occupat(iorb)=.TRUE.
   noc=noc+1
   do l=1,3
      ORB(numero(l),iorb)=prov2(l)
   end do
!
!
else if(nat_axe==2) then
!cas avec 2 atomes en plus de atomc
   do m=1,3
      vec1(m)=coord(m,natom1)-coord(m,natomc)
      vec2(m)=coord(m,natom2)-coord(m,natomc)
   end do
! prov1 est le vecteur du doublet pi:
   call produit_vectoriel(vec2,vec1,prov1)
! on genere l'orbitale (incr iorb, label, remplit ORB)
   iorb=iorb+1
   fnat(iorb)=1
   focvir(iorb)='OCC'
   if(prefix_label_OL=='A'.or.prefix_label_OL=='a') focvir(iorb)='ACTO'
   fsigpi(iorb)='LP'
   atoms_in_LO(iorb,1)=atomc(1:4)
   label_OL_temp(iorb)=prefix_label_OL//'_'//atomc//'.LP.PI'
   occupat(iorb)=.TRUE.
   noc=noc+1
   do n=1,3
      ORB(numero(n),iorb)=prov1(n)
   end do
end if
do i=1,norb
   if(any(abs(orb(i,iorb-1:iorb))>1.d-6)) &
   print'(a,2f10.6)',label(i),orb(i,iorb-1:iorb)
enddo
end
!
!Doublet D3
!
!*****************************************************************
 subroutine doubletD3(bond)
use lewis_module
use mod_script
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*):: bond
character(6)::atomc,atom1
real(8),dimension(3)::d,cart,prov
integer,dimension(4):: numero
integer:: cherche_at
dimension vnorm(3)
character :: chiffre(10)=(/'0','1','2','3','4','5','6','7,','8','9'/)
character(2) :: list_atoms(100),cha1


list_atoms=' '
list_atoms(1:8)=  (/'LI','BE','B ','C ','N ','O ','F ','NE'/)
list_atoms(9:16)=  (/'NA','MG','AL','SI','P ','S ','CL','AR'/)


yw=.false.
yw=(yw.or.nprint==5).and..not.nprint==-5



! noms et numeros des atomes en entree
atomc=bond(1:6)
atom1=bond(8:13)
natomc=cherche_at(atomc)
natom1=cherche_at(atom1)


! axes
do j=1,3
   d(j)=coord(j,natom1)-coord(j,natomc)
end do
if(d(2)/=0) then
   cart(1)=1
   cart(2)=-(d(1)/d(2))
   cart(3)=0
else if(d(1)/=0) then
   cart(1)=-(d(2)/d(1))
   cart(2)=1
   cart(3)=0
else
   cart(1)=1
   cart(2)=0
   cart(3)=0
end if

! longueur du nom de l'atome, sans son numero
do i=1,4
   if(any(atomc(i:i)==chiffre(:)).or.atomc(i:i)==' ') then
      long_atomc=i-1
      exit
   endif
enddo


! numero : rang de la 1ere apparition du label atomc//2PX, atomc//2PY...
cha1=' '
cha1(1:long_atomc)=atomc(1:long_atomc)



! generation des orbitales
if(any(cha1==list_atoms(1:8)(1:2))) then
   numero(1)=numero_OA(atomc,'2PX')
   numero(2)=numero_OA(atomc,'2PY')
   numero(3)=numero_OA(atomc,'2PZ')
   numero(4)=numero_OA(atomc,'1S')+1
else if(any(cha1==list_atoms(9:16)(1:2))) then
   numero(1)=numero_OA(atomc,'2PX')+1
   numero(2)=numero_OA(atomc,'2PY')+1
   numero(3)=numero_OA(atomc,'2PZ')+1
   numero(4)=numero_OA(atomc,'1S')+2
endif


! generation du premier doublet sur l'axe
iorb=iorb+1
fnat(iorb)=1
focvir(iorb)='OCC'
if(prefix_label_OL=='A'.or.prefix_label_OL=='a') focvir(iorb)='ACTO'
fsigpi(iorb)='LP'
atoms_in_LO(iorb,1)=atomc(1:4)
label_OL_temp(iorb)=prefix_label_OL//'_'//trim(atomc)//'.LPsig'
      !print*,'label  ',label_OL_temp(iorb)
occupat(iorb)=.TRUE.
noc=noc+1
vnorm=0.d0
do i=1,3
   k=numero(i)
   do j=1,3
      l=numero(j)
      vnorm(i)=vnorm(i)+d(j)*s(k,l)
   enddo
enddo
anorm=sqrt(dot_product(vnorm,d))
do l=1,3
   ORB(numero(l),iorb)=-d(l)/anorm
   diff(numero(l))=.FALSE.
end do
ORB(numero(4),iorb)=1
diff(numero(4))=.FALSE.


! 1er double pi
iorb=iorb+1
fnat(iorb)=1
focvir(iorb)='OCC'
if(prefix_label_OL=='A'.or.prefix_label_OL=='a') focvir(iorb)='ACTO'
fsigpi(iorb)='LP'
atoms_in_LO(iorb,1)=atomc(1:4)
label_OL_temp(iorb)=prefix_label_OL//'_'//trim(atomc)//'.LPpi1'
      !print*,'label  ',label_OL_temp(iorb)
occupat(iorb)=.TRUE.
noc=noc+1
!     normalisation de la partie P
do i=1,3
   ORB(numero(i),iorb)=cart(i)
end do


! 2eme doublet pi
call produit_vectoriel(d,cart,prov)
iorb=iorb+1
fnat(iorb)=1
focvir(iorb)='OCC'
if(prefix_label_OL=='A'.or.prefix_label_OL=='a') focvir(iorb)='ACTO'
fsigpi(iorb)='LP'
atoms_in_LO(iorb,1)=atomc(1:4)
label_OL_temp(iorb)=prefix_label_OL//'_'//trim(atomc)//'.LPpi2'
      !print*,'label  ',label_OL_temp(iorb)
occupat(iorb)=.TRUE.
noc=noc+1
do k=1,3
   ORB(numero(k),iorb)=prov(k)  !écrit la seconde pi liante
end do
do i=1,norb
   if(any(abs(orb(i,iorb-2:iorb))>1.d-6)) &
   print'(a,3f10.6)',label(i),orb(i,iorb-2:iorb)
enddo
end
!*****************************************************************
 subroutine incrementer_couches(label0,norb)
character(8) label0(norb)
character(1) c
logical yw
yw=.false.
k=0
if(yw)print*,'label0 avant'
if(yw)print'(5a10)', label0
do
   k=k+1
   if(k>norb) exit
   n_egaux=0
   do l=k+1,norb
      if(label0(k)/=label0(l)) exit
      n_egaux=n_egaux+1
   enddo
   do l=1,n_egaux
      k=k+1
      if(k>norb) exit
      read(label0(k)(5:5),'(i1)') i
      write(label0(k)(5:5),'(i1)') i+l
   enddo
enddo
if(yw)print*,'------------------ '
if(yw)print*,'label0 apres'
if(yw)print'(5a10)', label0
end
!*****************************************************************
 subroutine search_files(i)
implicit none
integer i
character(80) name
logical opened
if(i==5.or.i==6.or.i==7) return
inquire(i,opened=opened)
if(opened) then
   inquire(i,name=name)
   print*,'found file ',i,'  ',trim(name)
endif
end subroutine
!*****************************************************************
 subroutine copy2
use lewis_module
implicit none
integer i,sym,num
rewind ifil_CP
do i=1,norb
   if(ycopy2(i)) then
      read(ifil_cp) sym,num,orb(:,i)
   endif
enddo
end subroutine
function ecrlabel(label)
character(*) label
character(11) ecrlabel
n=4
do i=1,4
   if(label(i:i)==' ') then
      n=i-1
      exit
   endif
enddo
ecrlabel=' '
ecrlabel(1:n)=label(1:n)
ecrlabel(n+1:n+3)=label(5:6)
ecrlabel(n+5:n+8)=label(7:10)
end
!*****************************************************************
 subroutine modif_act
use lewis_module
use mod_scriptol
implicit none
character(300) :: aa
character(18) :: lab,lab1,lab0
integer sym,l,ll,i,k,ideb,ifin,is,j,isdeb,isfin
character(1) :: newlabel
logical :: y=.false.,yequal,yOK,yall
rewind 5
do
read(5,'(a)',end=1) aa
   aa=adjustl(aa)
   call maj(aa,300)
   if(aa(1:3)=='ACT'.or.aa(1:4)=='UNAC'.or. &
      aa(1:3)=='FRE'.or.aa(1:4)=='UNFR') then
      i=index(aa,'EQUAL')
      j=index(aa,'ALL')
      yequal=.false.
      if(i>0) then
         yequal=.true.
         aa(i:)=' '
      endif
      yall=.false.
      if(j>0) then
         yall=.true.
         aa(j:)=' '
      endif
      !l=index(aa,' ')
      !print*,'l',l
      !aa(1:l)=' '
      aa=adjustl(aa)
      l=len_trim(aa)
      aa(l+1:l+1)=','
      newlabel='O'
      call nameli(aa,sym,'SYM',4)
      call namela(aa,newlabel,'NEWLABEL')
      call namela(aa,lab,'LABEL')
      k=sum(isym(1:sym-1))
      lab1=' '
      if(sym==0) then
         isdeb=1
         isfin=nsym
      else
         isdeb=sym
         isfin=sym
      endif
      do sym=isdeb,isfin
         do i=1,isym(sym)
            k=k+1
            lab0=label_ol(k)
            call maj(lab0,18)
            if(yequal) then
               yOK=trim(lab0)==trim(lab)
            else
               yOK=index(lab0,trim(lab))>0
            endif
            if(yOK) then
               if(lab1/=' '.and..not.yall) then
                  print*,'Data: '//trim(aa)
                  print*,'the given label corresponds to more than LO'
                  print*,'given label: ',lab
                  print*,'label 1:  ',lab1
                  print*,'label 2:  ',label_ol(k)
                  stop
               endif
               lab1=label_ol(k)
               if(aa(1:3)=='ACT') then
                  if(label_ol(k)(1:1)=='A') then
                     print*,'label is already active:  ',label_ol(k)
                     stop
                  endif
                  label_ol(k)(1:1)='A'
                  y=.true.
                  print'(4a,i1,2a)','ACTIVATED:     ','label=',trim(lab)&
                  ,'   sym=',sym,'    New Label: ',label_ol(k)
               else if(aa(1:4)=='UNAC') then
                  if(label_ol(k)(1:1)/='A') then
                     print*,'label is not active:  ',label_ol(k)
                     stop
                  endif
                  label_ol(k)(1:1)=newlabel
                  y=.true.
                  print'(4a,i1,2a)','UNACTIVATED:   ','label=',trim(lab)&
                  ,'   sym=',sym,'    New Label: ',label_ol(k)
               elseif(aa(1:3)=='FRE') then
                  if(label_ol(k)(1:1)=='G') then
                     print*,'label is already frozen:  ',label_ol(k)
                     stop
                  endif
                  if(label_ol(k)(1:1)=='O') label_ol(k)(1:1)='o'
                  if(label_ol(k)(1:1)=='V') label_ol(k)(1:1)='v'
                  if(label_ol(k)(1:1)=='C') label_ol(k)(1:1)='c'
                  y=.true.
                  print'(4a,i1,2a)','FROZEN:     ','label=',trim(lab)&
                  ,'   sym=',sym,'    New Label: ',label_ol(k)
               endif
               else if(aa(1:4)=='UNFR') then
                  if(label_ol(k)(1:1)/='G') then
                     print*,'label is not frozen:  ',label_ol(k)
                     stop
                  endif
                  label_ol(k)(1:1)=newlabel
                  y=.true.
                  print'(4a,i1,2a)','UNFROZEN:   ','label=',trim(lab)&
                  ,'   sym=',sym,'    New Label: ',label_ol(k)
            endif
         enddo
      enddo
      if(lab1==' ') then
         print'(a,i1)','(UN)ACTIVATION or (UN)FREEZE demanded: label='//trim(lab)//'  sym=',sym
         print*,'but no LO label contains "'//trim(lab)//'" string'
         if(yequal) print*,'("equal" option was on)'
         call titre('program stopped#',300)
         call ecrlab(norb,label_ol)
         stop
      endif
      !print*,aa(1:4),'   ',trim(lab),'   ','sym=',sym
   endif
enddo
1 continue
if(y) then
   noacs=0
   call titre('There are (un)activated or (un)frozen orbitals.#'// &
   '-->  New symmetry reordering#',60)
   call reor_OAV
   call reorsy
      
endif
end

