module decode_multip_data
integer ifilr,ifilw,ifilrw
character(200),private :: bond
contains
!******************************************************************
 subroutine decode_multip_data1(bond_ext)
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*) bond_ext
yw=.false.
ymod=.false.


call open_chose_number(ifilr,'decode_multip_data_FILR', &
'unknown','formatted')
call open_chose_number(ifilw,'decode_multip_data_FILW', &
'unknown','formatted')
ifilrw=ifilr+ifilw
if(yw) print*,'ifilr,ifilw,ifilrw',ifilr,ifilw,ifilrw
write(ifilr,'(a)') bond_ext
if(yw)print*,'decode_multip_data bond_ext',trim(bond_ext)

!
!-----------------------------------------------------
!     mettre des ' ' autour des ";"
!-----------------------------------------------------
!
call decode_pv(bond,ymod)
!
!-----------------------------------------------------
!     traitement des etoiles "*"
!-----------------------------------------------------
!
if(bond(1:2)/='CP') call decode_star(bond,ymod)
!
!-----------------------------------------------------
!     traitement des crochets "[ ]"
!-----------------------------------------------------
!
call decode_croc(bond,ymod)
!
!-----------------------------------------------------
!     traitement des donnees multiples pour p,d,f...
!-----------------------------------------------------
!
call shell_mul(bond,ymod)

if(ymod) then
   rewind ifilr
   print*,'Donnees multiples generees'
   rewind ifilr
   do
      read(ifilr,'(a)',end=2) bond
      print'(a)',trim(bond)
   enddo
2       continue
   print*,'--------------------------'
endif
if(yw)print*,'sortie decode_multip_data ymod',ymod
end subroutine
!******************************************************************
 subroutine decode_croc(bond,ymod)
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*) bond
yw=.false.
!
!-----------------------------------------------------
!     1. traitement des doubles crochets "[[ ]]"
!-----------------------------------------------------
!
rewind ifilr
rewind ifilw
if(index(bond,'[')==0) return
do
   read(ifilr,'(a)',end=1) bond
   long=len_trim(bond)
! Are there double "[" ?
   call repl_all(bond,'[[','??',yrepl2)
   if(yrepl2) then
! ... yes, there are
      call repl_all(bond,']]','##',yrepl2)
      if(yw)print*,'bond1',trim(bond)
! treat double now
      call repl(bond,'[','?',ydum)
      call repl(bond,']','#',ydum)
      call repl_all(bond,'??','[',yrepl)
      call repl_all(bond,'##',']',yrepl)
      if(yw)print*,'bond2',trim(bond)
      call croc(bond,ncroc,ymod)
      if(yw)print*,'bond3',trim(bond)
   else
      ymod=.true.
      write(ifilw,'(a)') bond
   endif
enddo
1    continue


ifilw=ifilrw-ifilw
ifilr=ifilrw-ifilr


!
!-----------------------------------------------------
!     2. traitement des simples crochets "[ ]"
!-----------------------------------------------------
!
rewind ifilr
rewind ifilw
do
   read(ifilr,'(a)',end=2) bond
   call repl(bond,'?','[',ydum)
   call repl(bond,'#',']',ydum)
   if(yw)print*,'bond4',trim(bond)
   long=len_trim(bond)
! Are there single "[" ?
   yyes=index(bond,'[')/=0
   if(yyes) then
! ... yes, there are
! treat single now
      call repl_all(bond,'?','[',yrepl)
      call repl_all(bond,'#',']',yrepl)
      if(yw)print*,'bond5',trim(bond)
      call croc(bond,ncroc,ymod)
      if(yw)print*,'bond6',trim(bond)
   else
      write(ifilw,'(a)') bond
      ymod=.true.
   endif
enddo
2    continue


ifilw=ifilrw-ifilw
ifilr=ifilrw-ifilr


return
end subroutine
!******************************************************************
 subroutine croc(bond,ncroc,ymod)
implicit real*8 (a-h,o-x,z),logical*1(y)
integer,dimension(:),allocatable :: icro1,icro2,ibl1,ibl2
character(*) bond
character*300 orb1,c1,c2
yw=.false.
ncroc=0
if(yw)print*,'entree croc'
long=len_trim(bond)
!      print*,'O1.',bond(1:long)
yrepl=.true.
do while(yrepl)
   call repl(bond,'[ ','[',yrepl)
   long=len_trim(bond)
   if(yw)print*,'O2.',bond(1:long)
   call repl(bond,' ]',']',yrepl)
   long=len_trim(bond)
   if(yw)print*,'O3.',bond(1:long)
enddo
orb1(1:long)=bond(1:long)
ncro=0
long=len_trim(bond)
ich=0
!-----------------------------------------
!     on compte les [
!-----------------------------------------
do k=1,21
   ichv=ich
   ich=index(bond(1+ich:long),'[')+ich
!         print*,'ich',ich,k
!         if(ich.ne.0)print'(a)',
!     *   '12345678901234567890123456789012345678901234567890'
!         if(ich.ne.0)print'(a)',bond(1:long)
   if(ich-ichv.eq.0) goto 1
   ncro=ncro+1
enddo
      !stop 'ncro'
1    continue
!-----------------------------------------
!     verif : on compte les ]
!-----------------------------------------
ncro2=0
ich=0
do k=1,21
   ichv=ich
   ich=index(bond(1+ich:long),']')+ich
   if(ich-ichv.eq.0) goto 3
   ncro2=ncro2+1
enddo
3    continue
if(ncro.ne.ncro2) then
   print*,'[...] en nombre inegal,  ligne'
   print*,bond(1:long)
   stop
endif
if(ncro.eq.0) goto 10
if(ncro.ne.0) then
!         print'(a)',
!     *   '12345678901234567890123456789012345678901234567890'
!         print'(a)',bond(1:long)
!         print*,'ncro',ncro
endif
!-----------------------------------------
!     on note les places des [ ]
!-----------------------------------------
allocate (icro1(ncro))
allocate (icro2(ncro))
ich=0
icro1=0   ;   icro2=0
do k=1,ncro
   ichv=ich
   ich=index(bond(1+ich:long),'[')+ich
   if(ich-ichv.eq.0) exit
   icro1(k)=ich
   ich=index(bond(1+ich:long),']')+ich
   icro2(k)=ich
   if(ich-ichv.eq.0) exit
enddo
if(any(icro1(1:ncro).eq.0).or. &
   any(icro2(1:ncro).eq.0).or. &
   any(icro2(1:ncro)-icro1(1:ncro).le.0)) then
   print*,'erreur dans les "[" "]" '
   print*,bond
   stop
endif
if(ncro.ne.0) then
if(yw)print*,'icro1',icro1(1:ncro)
if(yw)print*,'icro2',icro2(1:ncro)
endif
!-----------------------------------------
!     on compte les donnees dans [ ]
!-----------------------------------------
nbl=0
do k=icro1(1)+1,icro2(1)-1
   if(bond(k:k).eq.' '.and.bond(k-1:k-1).ne.' ')nbl=nbl+1
enddo
if(yw)print*,'nbl',nbl
!     verif pour les autres icor
do ic=2,ncro
   nbl2=0
   do k=icro1(ic)+1,icro2(ic)-1
      if(bond(k:k).eq.' '.and.bond(k-1:k-1).ne.' ')nbl2=nbl2+1
   enddo
!         print*,'nbl2',nbl2
   if(nbl.ne.nbl2) then
      print*,'erreur dans le nombre de donnees dans le [  ]'
      print'(a)', &
      ' 12345678901234567890123456789012345678901234567890'
      print*,bond(1:long)
      stop
   endif
enddo
ndon=nbl+1
if(nbl.ne.0.and.yw) print*,'ndon',ndon
!-----------------------------------------
!     on remplace
!-----------------------------------------
allocate (ibl1(ncro))
allocate (ibl2(ncro))
ibl1(1:ncro)=icro1(1:ncro)+1
do jbl=1,ndon
   long=len_trim(bond)
   orb1=bond
   if(yw)print*,'ORB1.',orb1(1:long)
   do ic=1,ncro
      ii1=index(bond(ibl1(ic):long),' ')
      ii2=index(bond(ibl1(ic):long),']')
      if(ii1==0) ii1=ii2+1
      ibl2(ic)=min(ii1,ii2)-2+ibl1(ic)
      if(yw) &
      print*,'jbl,ic,ibl1(ic),ibl2(ic)',jbl,ic,ibl1(ic),ibl2(ic)
      c1=bond(icro1(ic):icro2(ic))
      l1=len_trim(c1)
      if(yw)print*,'c1 ',c1(1:l1)
      c2=bond(ibl1(ic):ibl2(ic))
      l2=ibl2(ic)-ibl1(ic)+1
      if(yw)print*,'c2 ',c2(1:l2)
      long1=len_trim(orb1)
      if(yw)print*,'orb1.',orb1(1:long1)
      if(yw)print*,'c1(1:l1),c2(1:l2)',c1(1:l1),'|',c2(1:l2)
      call repl(orb1,c1(1:l1),c2(1:l2),yrepl)
      long2=len_trim(orb1)
      if(yw)print*,'orb2.',orb1(1:long2)
   enddo
   if(yw)print*,'orb2.',orb1(1:long2)
   ibl1(1:ncro)=ibl2(1:ncro)+2
      write(ifilw,'(a)') orb1(1:long2)
      ymod=.true.
      if(yw) print*,'croc ecrit ',orb1(1:long2),ifilw
   ncroc=ncroc+1
enddo

deallocate (ibl1)
deallocate (ibl2)
deallocate (icro1)
deallocate (icro2)
10   continue
if(yw)print*,'sortie croc'
return
end subroutine
!******************************************************************


 subroutine shell_mul(bond,ymod)
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*) bond
character(100) orb1
yw=.false.
if(yw)print*,'entree shell_mul'
!
!-----------------------------------------------------
!     traitement des donnees multiples pour p,d,f...
!-----------------------------------------------------
!
rewind ifilr
rewind ifilw
do
   read(ifilr,'(a)',end=3) bond
   long=len_trim(bond)
   if(yw)print*,'bond ',trim(bond)
   yreplt=.false.
   orb1=bond
   call repl(orb1,'2P(','2PX(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+1)
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+1)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'2P(','2PY(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+1)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+1)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'2P(','2PZ(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+1)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+1)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'3D(','3D0(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+1)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+1)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'3D(','3D1+(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'3D(','3D1-(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'3D(','3D2+(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'3D(','3D2-(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'4F(','4F0(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+1)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+1)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'4F(','4F1+(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'4F(','4F1-(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'4F(','4F2+(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'4F(','4F2-(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'4F(','4F3+(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   orb1=bond
   call repl(orb1,'4F(','4F3-(',yrepl)
   if(yrepl)write(ifilw,'(a)') orb1(1:long+2)
   if(yrepl) ymod=.true.
   if(yw.and.yrepl)print*,'Ecrit',bond(1:long+2)
   yreplt=yreplt.or.yrepl
   if(.not.yreplt) write(ifilw,'(a)') bond(1:long)
   if(yrepl) ymod=.true.
   if(yw.and.yreplt)print*,'Ecrit',bond(1:long)
enddo
3    continue
4    continue


ifilw=ifilrw-ifilw
ifilr=ifilrw-ifilr


if(yw)print*,'sortie shell_mul'
end subroutine shell_mul
!******************************************************************

 subroutine decode_star(bond,ymod)
use lewis_module
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*) bond
character(80) bondloc
character(500) aa
yw=.false.
if(yw)print*,'entree decode_star'

rewind ifilr
rewind ifilw

do
   read(ifilr,'(a)',end=1) bond
   if(yw)print*,'bond dans decode_star ',trim(bond)
   i=index(bond,'*')
   if(i==0) return

   if(index(bond(i+1:),'*')/=0) then
      call decode_star_2at(bond,ifilw,ymod)
   else
      call decode_star_1at(bond,i,ifilw,ymod)
   endif
   if(yw) print*,'ymod',ymod
   if(.not.ymod) then
      print*,'La donnee multiple ',trim(bond), &
      ' n''a pas été decodee'
      print*,'Verifiez :'
      print*,'- si les atomes At* ont leurs correspondants'
      print*,'- si dist est correct'
      stop
   endif
enddo
1    continue

ifilw=ifilrw-ifilw
ifilr=ifilrw-ifilr

if(yw)print*,'sortie decode_star'
end subroutine



!******************************************************************
 subroutine decode_star_1at(bond,i,ifilw,ymod)
use lewis_module
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*) bond
character(500) aa
yw=.false.

!
!====================================================
! en entree, bond contient UN atome multiple A*
! recherche tous les atomes de la molecule qui s'ecrivent A...
! ou "..." sont des chiffres (pas des lettres)
! genere toutes les lignes contenant A...
! Les ecrit sur ifilw
!====================================================
!
if(index(bond,'DIST=')/=0) then
   print*,'pas de donnee multiple (ex C*-O) dans une liaison'
   stop
endif

l=len_trim(bond)
iblan2=l+1
do j=i+1,l
   if(bond(j:j)==' ') then
      iblan2=j
      exit
   endif
enddo
iblan1=0
do j=i-1,1,-1
   if(bond(j:j)==' ') then
      iblan1=j
      exit
   endif
enddo

do i=1,natom0
   aa=trim(bond)
   if(yw)print*,'natom0',i,atom0(i),bond(iblan1+1:iblan2-2)
   if(yw)print*,'index6',index6(atom0(i),bond(iblan1+1:iblan2-2))
   if(index6(atom0(i),bond(iblan1+1:iblan2-2))>0) then
      if(yw)print*,trim(aa)
      if(yw)print*,aa(iblan1+1:iblan2-2)
      if(yw)print*,trim(atom0(i))
      call repl(aa(iblan1+1:),aa(iblan1+1:iblan2-1), &
      trim(atom0(i)),yrepl)
      write(ifilw,'(a)') trim(aa)
      ymod=.true.
      if(yw)write(6,'(a)') trim(aa)
   endif
enddo
if(yw)print*,'STAR',trim(bond),iblan1,iblan2

end subroutine
!******************************************************************
 subroutine decode_star_2at(bond,ifilw,ymod)
use lewis_module
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*) bond
character(500) aa,bb
character(4) :: atom1,atom2
yw=.false.
!
!====================================================
! en entree, bond contient 2 atomes multiples A* B* et
! une distance dist=d
! recherche tous les atomes de la molecule qui s'ecrivent A...B...
! ou "..." sont des chiffres (pas des lettres)
! genere toutes les lignes contenant A...,B...
! calcule la distance A-B, generela ligne si la distance est <=d
! Les ecrit sur ifilw
!====================================================
!

aa=trim(bond)
bb=trim(bond)
if(yw)print*,'bond   ',trim(bond)
istar1=index(aa,'*')
aa(istar1:istar1)=' '
jstar1=index(aa,'*')

! La donnee est-elle correcte ?
k1=index(bond,'DIST')
k2=index(bond,';')
if(k1==0.or.k2==0) then
   print*,' '
   print*,'============================================='
   print*,' donnee incorrecte     '//trim(bond)
   print*,' s''il y a 2 "*", on doit donner "; DIST="'
   print*,'============================================='
   print*,' '
   stop
endif

! lecture de la distance minimale
read(bond(k1+5:),*) distmin
isuite=index(bond(k1:),',')+k1-1
      !print*,'isuite',isuite,k1,k2
if(isuite==k1-1) then
   bb(k2:)=' '
   bond(k2:)=' '
else
   bb(k1:isuite)=' '
   bond(k1:isuite)=' '
endif
      !print*,'bond   ',trim(bond)

! Extraction des 2 atomes sans "*"
do k=istar1-1,1,-1
   if(bond(k:k)==' ') then
      ibl1=k
      exit
   endif
enddo
atom1=bond(ibl1+1:istar1-1)
do k=jstar1-1,1,-1
   if(index('-=~^ ',bond(k:k))/=0) then
      iliaison=k
      exit
   endif
enddo
atom2=bond(iliaison+1:jstar1-1)

do i=1,natom0
   if(index6(atom0(i),trim(atom1))==0) cycle
   if(yw)print*,'atom0(i)',atom0(i)
   if(atom1==atom2) then
      ideb=i
   else
      ideb=1
   endif
   do j=ideb,natom0
      if(index6(atom0(j),trim(atom2))>0) then
         d=distancmin(i,j)*0.529177249
         if(yw)print*,'d,distmin',d,distmin
         if(d>distmin) cycle
         bb=trim(bond)
         if(mprint(1)>0) &
         print'(2a,f10.6,a,f10.6)','Donnee multiple generee     ', &
         trim(atom0(i))//bond(iliaison:iliaison) &
         //trim(atom0(j))//'  dist=',d,' <= ',distmin
         if(yw)print*,'bond avant modif ',trim(bb)
         if(yw)print*,'istar1+2:jstar1',istar1+2,jstar1
         call repl(bb(istar1+2:),bb(istar1+2:jstar1), &
         trim(atom0(j)),yrepl)
         if(yw)print*,'ibl1+1:istar1',ibl1+1,istar1
         if(yw)print*,'bond avant modif ',trim(bb)
         call repl(bb,bb(ibl1+1:istar1),trim(atom0(i)),yrepl)
         if(yw)print*,'bond modifie ',trim(bb)
         write(ifilw,'(a)') trim(bb)
      ymod=.true.
      endif
   enddo
enddo
      !if(bond(iliaison:iliaison)=='^') stop

end subroutine

!******************************************************************
 subroutine decode_pv(bond,ymod)
!-----------------------------------------------------
!     mettre des ' ' autour des ";"
!-----------------------------------------------------
implicit real*8 (a-h,o-x,z),logical*1(y)
character(*) bond
yw=.false.
if(yw)print*,'entree decode_pv'

rewind ifilr
rewind ifilw

do
   read(ifilr,'(a)',end=1) bond
   i=index(bond,';')
   if(i==0) return

   l=len_trim(bond)
   y=.false.
   if(bond(i+1:i+1)/=' ') then
      y=.true.
      bond(i+2:l+1)=bond(i+1:l)
      bond(i+1:i+1)=' '
      l=l+1
   endif
   if(bond(i-1:i-1)/=' ') then
      y=.true.
      bond(i+1:l+1)=bond(i:l)
      bond(i:i)=' '
   endif
   if(.not.y) return
   write(ifilw,'(a)') bond
      ymod=.true.
enddo
1    continue

ifilw=ifilrw-ifilw
ifilr=ifilrw-ifilr


end subroutine
!******************************************************************

end module decode_multip_data

