subroutine faimolden(prefix,ol,molden_loc0,ybon)
implicit real(8)(a-h,o-x,z),logical(1)(y)
character(80) molden_modele,molden_loc
character(*) :: ol,molden_loc0,prefix
logical(1) :: yw=.false.
logical ybon
character(135) currdir

call titre('FAIMOLDEN  FAIMOLDEN  FAIMOLDEN  FAIMOLDEN#',50)

call system('echo $CurrDir > RENAME_BID')
call open_chose_number(ifil,'RENAME_BID','old', &
'formatted')
read(ifil,'(a)') currdir
close(ifil,status='delete')

!***********molden_modele
molden_modele=trim(prefix)//'scf.molden'
print*,'searching ',trim(molden_modele)//'...'
open(99,file=molden_modele,status='old',err=1)
goto 10
1    continue
molden_modele=trim(prefix)//'rasscf.molden'
print*,'searching ',trim(molden_modele)//'...'
open(99,file=molden_modele,status='old',err=2)
goto 10
2    continue
molden_modele=trim(prefix)//'guessorb.molden'
print*,'searching ',trim(molden_modele)//'...'
open(99,file=molden_modele,status='old',err=3)
goto 10
3    continue

print*,'No old molden file found'
print*, &
'No molden file will be generated for LOs'
ybon=.false.
return

10   continue
ybon=.true.
close(99)
print*,'...old model molden file found:  ',trim(molden_modele)

!***********OL

!***********molden_loc
molden_loc=trim(prefix)//trim(molden_loc0)

!**************
! Molden pour les orbitales en symetrie
call faimolden1(molden_modele,ol,prefix,trim(currdir)//'/'//molden_loc)
close(99)

end
subroutine desym_OL(OL,occupat)
!
!========================================================================
! desymetrisation des OL
! On part des OL symetriques exprimees dans les OA non symetriques (orb)
! On genere les OL non sym (loc) dans la meme base d'OA
!========================================================================
!

use mod_script
use mod_lirorb
implicit real(8)(a-h,o-x,z),logical(1)(y)
real(8),allocatable,dimension(:,:) :: ORB,orb2,orb3
real(8),allocatable :: occup(:),occup2(:),occup3(:)
logical(1),allocatable :: y(:),occupat2(:)
integer :: isym(8)
character(*) :: OL
character(18),allocatable :: tipo(:),tipo2(:),tipo3(:)
integer :: itransf(8,8),p(8)
integer ibid(8)
logical(1) :: yw=.false.
logical :: occupat(*)
itransf(1,:)=(/1, 1, 1, 1, 1, 1, 1, 1/)
itransf(2,:)=(/1,-1, 1,-1, 1,-1, 1,-1/)
itransf(3,:)=(/1, 1,-1,-1, 1, 1,-1,-1/)
itransf(4,:)=(/1,-1,-1, 1, 1,-1,-1, 1/)
itransf(5,:)=(/1, 1, 1, 1,-1,-1,-1,-1/)
itransf(6,:)=(/1,-1, 1,-1,-1, 1,-1, 1/)
itransf(7,:)=(/1, 1,-1,-1,-1,-1, 1, 1/)
itransf(8,:)=(/1,-1,-1, 1,-1, 1, 1,-1/)

call lirorb(ol,norb,nsym,isym,99,98)
allocate(ORB(norb,norb),orb2(norb,norb),tipo(norb),occup(norb))
allocate(orb3(norb,norb))
allocate(y(norb),occup2(norb),occup3(norb))
allocate(occupat2(norb))
allocate(tipo2(norb))
allocate(tipo3(norb))
read(99) orb
read(99) occup
read(99) tipo
close(98)

if(yw) then
   do i=1,norb
      print*,'DESYM',i,occup(i),'   ',trim(tipo(i))
   enddo
endif

y=.false.
ii=0
test=2.d0
do icas=1,2
   do i=1,norb
      if(tipo(i)(1:2)=='A_') cycle
      !print*,i,occup(i),test,abs(occup(i)-test)
      if(abs(occup(i)-test).gt.1.d-8) cycle
      !print*,'OK'
      if(y(i)) cycle
      y(i)=.true.
      nequiv=1
      p(1)=i
      do j=i+1,norb
         if(y(j)) cycle
         if(tipo(i)/=tipo(j)) cycle
         if(test-occup(j).gt.1.d0) cycle
         y(j)=.true.
         nequiv=nequiv+1
         p(nequiv)=j
      enddo
      !if(yw)print*,'p',p(1:nequiv)
      tipo2(ii+1:ii+nequiv)=tipo(p(1:nequiv))
      occupat2(ii+1:ii+nequiv)=occupat(p(1:nequiv))
      iiii=0
      if(yw) then
         do iii=ii+1,ii+nequiv
            iiii=iiii+1
            print*,'tipo2_1',iii,iiii,i,p(iiii),'   ',trim(tipo2(iii)),occupat(i)
         enddo
      endif
      occup2(ii+1:ii+nequiv)=occup(p(1:nequiv))
      orb2(:,ii+1:ii+nequiv)=0.d0
      do k=1,nequiv
         do l=1,nequiv
            orb2(:,ii+k)=orb2(:,ii+k)+orb(:,p(l))*itransf(l,k)
         enddo
      enddo
      ii=ii+nequiv
   enddo
   if(test==0.d0) exit
   test=0.d0
   if(yw)print*,'y',y
   do i=1,norb
      if(tipo(i)(1:2)/='A_') cycle
      if(y(i)) cycle
      y(i)=.true.
      nequiv=1
      p(1)=i
      do j=i+1,norb
         if(y(j)) cycle
         if(tipo(i)/=tipo(j)) cycle
         y(j)=.true.
         nequiv=nequiv+1
         p(nequiv)=j
      enddo
      !if(yw)print*,'p',p(1:nequiv)
      tipo2(ii+1:ii+nequiv)=tipo(p(1:nequiv))
      occupat2(ii+1:ii+nequiv)=occupat(p(1:nequiv))
      iiii=0
      if(yw) then
         do iii=ii+1,ii+nequiv
            iiii=iiii+1
            print*,'tipo2_2',iii,iiii,i,p(iiii),'   ',trim(tipo2(iii)),occupat(i)
         enddo
      endif
      occup2(ii+1:ii+nequiv)=occup(p(1:nequiv))
      orb2(:,ii+1:ii+nequiv)=0.d0
      do k=1,nequiv
         do l=1,nequiv
            orb2(:,ii+k)=orb2(:,ii+k)+orb(:,p(l))*itransf(l,k)
         enddo
      enddo
      orb2(:,ii+1:ii+nequiv)=orb2(:,ii+1:ii+nequiv)/ &
      dsqrt(1.d0*nequiv)
      ii=ii+nequiv
   enddo
enddo
if(yw)print*,'y',y

! Reorder G-O-A-O-G

tipo3=' '
j=0
! G Occ
do i=1,norb
   if(tipo2(i)(1:1)/='G') cycle
   if(.not.occupat2(i)) cycle
   j=j+1
   tipo3(j)=tipo2(i)
   orb3(:,j)=orb2(:,i)
   occup3(j)=occup2(i)
enddo
! C
do i=1,norb
   if(tipo2(i)(1:1)/='C') cycle
   j=j+1
   tipo3(j)=tipo2(i)
   orb3(:,j)=orb2(:,i)
   occup3(j)=occup2(i)
enddo
! O Occ
do i=1,norb
   if(tipo2(i)(1:1)/='O') cycle
   if(.not.occupat2(i)) cycle
   j=j+1
   tipo3(j)=tipo2(i)
   orb3(:,j)=orb2(:,i)
   occup3(j)=occup2(i)
enddo
! A
do i=1,norb
   if(tipo2(i)(1:1)/='A') cycle
   j=j+1
   tipo3(j)=tipo2(i)
   orb3(:,j)=orb2(:,i)
   occup3(j)=occup2(i)
enddo
! O virt
do i=1,norb
   if(tipo2(i)(1:1)/='O') cycle
   if(occupat2(i)) cycle
   j=j+1
   tipo3(j)=tipo2(i)
   orb3(:,j)=orb2(:,i)
   occup3(j)=occup2(i)
enddo
! T
do i=1,norb
   if(tipo2(i)(1:1)/='T') cycle
   j=j+1
   tipo3(j)=tipo2(i)
   orb3(:,j)=orb2(:,i)
   occup3(j)=occup2(i)
enddo
! G Virt
do i=1,norb
   if(tipo2(i)(1:1)/='G') cycle
   if(occupat2(i)) cycle
   j=j+1
   tipo3(j)=tipo2(i)
   orb3(:,j)=orb2(:,i)
   occup3(j)=occup2(i)
enddo
orb2=orb3
occup2=occup3
tipo2=tipo3

!call mscript(orb)
!call mscript(orb2)
rewind 99
rewind 1
write(99) orb2
write(99) occup2
write(99) tipo2
ibid(1)=norb
call ecriorb( &
'*Orbitales creees par Lewis (non sym dans OA non sym)', &
'LEWORB_LOCLOC',1,ibid,99,8,newformat='O')
open(99,file='BIDORB'//trim(ol),status='old',form='unformatted')
close(99,status='delete')
close(8)
!call mscript(orb2)
!print*,'occup',occup2
!print*,'tipo',tipo2
call titre('LO desymetrisation : labels#'//&
'(order of desymetrised orbitals in molden,#'&
//'File LOCLOC)#',300)
call ecrlab(norb,tipo2)

nfroz=0
ndel=0
do i=1,norb
   if(tipo2(i)(1:1)=='G') then
      if(occupat2(i)) then
         nfroz=nfroz+1
      else
         ndel=ndel+1
      endif
   endif
enddo
print*,' '
call titre('Rank or LOs in CASDILOC#',300)
call ecrlab(norb-nfroz-ndel,tipo2(nfroz+1:norb-ndel))


deallocate(tipo3,orb3,occup3,occupat2)
end
