subroutine faimolden1(molden_modele,ol,prefix,molden_loc)
use mod_lirorb
use mod_script
!
!=================================================================
! fabrication d'un fichier molden a partir d'un fichier modele
! 
! molden_modele : fichier molden modele
! OL : fichier d'orbitales (en clair)
! prefix == $Project//'.'
! molden_loc : fichier molden cree
!
! En entree : molden_modele, OL, prefix
!             un fichier $Project.Infoloc contenant au moins LABEL
!=================================================================
!
implicit real(8)(a-h,o-x,z),logical(1)(y)
integer,parameter :: maxloop=1000000
character(80)aa,oa
character(*)molden_modele,ol,prefix,molden_loc
dimension isym(8)
allocatable ORB(:,:),iord(:),occup(:),orb1(:,:)
character(18),allocatable :: tipo(:)
character(8),allocatable :: label(:)
character(100000) namel
character(4) :: atom(1000)
logical :: y(1000),yw=.false.
if(yw)print*,'***********entree faimolden1***************'
!
! Open
!
!print*,'molden_modele  ',trim(molden_modele)
call open_chose_number(ifil_molden_modele,molden_modele,'old','formatted')
call open_chose_number(ifil_molden_loc,molden_loc,'unknown','formatted')
!call open_chose_number(ifil_ol,ol,'old','formatted')
!open(1,file=molden_modele,status='old')
!open(2,file=ol,status='old')
!open(3,file=molden_loc,status='unknown')
!
! Lecture et recopie du debut du fichier molden
!
call faimtest('MO')
do jjjj=1,maxloop
   read(ifil_molden_modele,'(a80)') aa
   write(ifil_molden_loc,'(a)') trim(aa)
   if(aa(2:5)=='[MO]') exit
enddo
if(jjjj>=maxloop) print*,'boucle infinie',stop
!
! Lecture des OL
!
call open_chose_number(ifil,'BID','unknown','unformatted')
call open_chose_number(ifil98,'BID98','unknown','unformatted')
close(ifil,status='delete')
close(ifil98,status='delete')
!print*,'OL',ol
call lirorb(ol,norb,nsym,isym,ifil,ifil98)
allocate(orb(norb,norb))
allocate(orb1(norb,norb))
allocate(tipo(norb))
allocate(occup(norb))
allocate(label(norb))
read(ifil) orb
read(ifil) occup
read(ifil) tipo
close(ifil,status='delete')
if(yw) then
   print*,'Orbitals'
   call mscript(orb)
   print*,'TIPO'
   do k=1,norb
      print*,k,tipo(k)
   enddo
endif
!
! Lecture des labels
!
if(yw)print*,'Lecture des labels'
open(4,file=trim(prefix)//'Infoloc',status='old')
call LECNAM('&COST_AO',namel,4,ierr,0)
close(4)
call namela(namel,LABEL,'LABEL')
do i=1,norb
   call maj(label(i),8)
enddo
if(yw) then
   print*,'LABEL'
   do k=1,norb
      print*,k,label(k)
   enddo
endif

!
! Lecture des noms des atomes
!
natom=0
if(yw)print*,'Lecture des noms des atomes'
rewind ifil_molden_modele
call faimtest('ATOM')
do jjjj=1,maxloop
   read(ifil_molden_modele,'(a)') aa
   call maj(aa(1:8),8)
   if(aa(1:8)==' [ATOMS]') exit
enddo
if(jjjj>=maxloop) print*,'boucle infinie',stop
call faimtest('[')
do jjjj=1,maxloop
   read(ifil_molden_modele,'(a)') aa
   call maj(aa(1:9),9)
   if(index(aa,'[')>0) exit
   natom=natom+1
   atom(natom)=aa(1:4)
enddo
if(jjjj>=maxloop) print*,'boucle infinie',stop
if(yw)print*,'atom',atom(1:natom)
rewind ifil_molden_modele
call faimtest('GTO')
do jjjj=1,maxloop
   read(ifil_molden_modele,'(a)') aa
   if(aa(1:6)==' [GTO]') exit
enddo
if(jjjj>=maxloop) print*,'boucle infinie',stop
read(ifil_molden_modele,'(a)') aa


!
! Lecture des couches des atomes
! generation des OA S --> 1S ; P --> 2PX,2PY,2PZ, ...
! On recherche l'OA dans la base d'OA de Infoloc
! On copie la ligne des OL (ordre ijkloc) vers les OL (ordre molden)
!
if(yw)print*,'Lecture des couches des atomes'
j=0
y(1:norb)=.false.
do i=1,natom
   call faimtest('^')
   do jjjj=1,maxloop
      read(ifil_molden_modele,'(a)') aa
      call maj(aa,80)
      if(yw)print*,'AA ',trim(aa)
      if(aa==' ') exit

      if(aa(4:4)=='S') then

         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'1S')

         read(aa(5:),*) n
         if(yw)print*,'n',n
         do k=1,n
            read(ifil_molden_modele,'(a)')
         enddo

      else if(aa(4:4)=='P') then

         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'2PX')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'2PY')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'2PZ')

         read(aa(5:),*) n
         if(yw)print*,'n',n
         do k=1,n
            read(ifil_molden_modele,'(a)')
         enddo

      else if(aa(4:4)=='D') then

         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'3D0')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'3D1+')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'3D1-')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'3D2+')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'3D2-')

         read(aa(5:),*) n
         if(yw)print*,'n',n
         do k=1,n
            read(ifil_molden_modele,'(a)')
         enddo

      else if(aa(4:4)=='F') then

         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'4F0')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'4F1+')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'4F1-')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'4F2+')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'4F2-')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'4F3+')
         call cherche(norb,atom(i),label,y,yw,orb,orb1,j,'4F3-')

         read(aa(5:),*) n
         if(yw)print*,'n',n
         do k=1,n
            read(ifil_molden_modele,'(a)')
         enddo
      endif

   enddo
   if(jjjj>=maxloop) print*,'boucle infinie',stop
   read(ifil_molden_modele,'(a)')
enddo
if(yw)print*,'y',y(1:norb)
if(yw)print*,'j',j
if(any(.not.y(1:norb))) then
   print*,'Des OA n''ont pas ete reconnues'
   print*,'y',y(1:norb)
   print*,'label=',label(1:norb)
   close(ifil_molden_loc,status='delete')
   stop
endif
if(yw)call mscript(orb1)
 
!!     
      
!
! fabrication de la fin du ficher
!
rewind ifil_molden_modele
call faimtest('MO')
do jjjj=1,maxloop
   read(ifil_molden_modele,'(a80)') aa
   if(aa(2:5)=='[MO]') exit
enddo
if(jjjj>=maxloop) print*,'boucle infinie',stop
do i=1,norb
   read(ifil_molden_modele,'(a80)') aa
   write(ifil_molden_loc,'(a)') trim(aa)
   read(ifil_molden_modele,'(a80)') aa
   write(ifil_molden_loc,'(a)') 'Ene=     0.0000'
   read(ifil_molden_modele,'(a80)') aa
   write(ifil_molden_loc,'(a)') trim(aa)
   read(ifil_molden_modele,'(a80)') aa
   write(ifil_molden_loc,'(a6,f11.5)') 'Occup=',occup(i)
   do j=1,norb
      read(ifil_molden_modele,'(a80)') aa
      write(ifil_molden_loc,'(i4,f19.8)') j,orb1(j,i)
   enddo
enddo
call titre('Fichier# '//trim(molden_loc)//'# cree#',72)
close(ifil_molden_modele)
!close(ifil_ol)
close(ifil_molden_loc)
end
      
!*********************************************************************
 subroutine cherche(norb,atom,label,y,yw,orb,orb1,j,lab)
character(80) oa
real(8) ORB(norb,norb),orb1(norb,norb)
character(8) :: label(norb)
logical :: y(1000),yw
character(*) lab
character(4) atom
!
j=j+1
oa=atom//trim(lab)
if(yw)print*,'faimolden : dans cherche oa= "',oa(1:8),'"'

do k=1,norb
   if(oa(1:8)==label(k)) then
      if(y(k)) cycle
      if(yw)print*,'|'//trim(oa)//'|',' trouve en',k,orb(k,5)
      y(k)=.true.
      orb1(j,:)=orb(k,:)
      return
   endif
enddo
if(yw) print*,'faimolden : dans cherche oa non trouve'
end
subroutine faimtest(aa)
character(*) :: aa
logical :: yw1=.false.
if(yw1) print*,'faimolden1 recherche ',trim(aa)
end
