!
!----------------------------------------------------------------
! adressage par interpolation : mod_addr
!
! Adressage d'une liste quelconque de ndet determinants sur
! norb orbitales
!
! Utilisation : (voir un exemple dans cost2/source/adressage/ADRESSAGE.f)
!
! I.   Compiler votre programme en le liant a mod_addr.o

! II.  ajouter "use mod_addr" dans toutes les subroutines utilisant 
!      l'adressage

! III. Les determinants a adresser doivent etre ecrits sous forme
!      d'occupation. Par exemple :
!      det(:, i)= (/ 2, 1,-1, 0, 0, 0, 0, 0/)
!      "2,1,-1, 0" : 2electrons, alpha, beta, orbitale vide
!      ces determinants peuvent etre en memoire, ou sur un fichier

! IV.  allouer un vecteur aa12 (qui est declare dans mod_addr, le nom
!      est donc impose)
!      nb_int32=(norb*2-1)/32+1
!      allocate(aa12(nb_int32,ndet))
!      aa12 sont des entiers qui representent la liste des 
!      determinants, en occupation de bits
!      declarer un vecteur d'entiers bb12(:), l'allouer a bb12(nb_int32)
!
! V.   remplir aa12. on remplit aa12(:,i) a partir de det(i) en appelant :
!      call adr_interpol_trad(det(:,i),aa12(:,i),norb)
!
! VI.  definir nb_seg. La droite d'interpolation est decoupee en 
!      nb_seg segments. Plus le nombre de segments est grand, plus la 
!      recherche de l'adresse est rapide. En theorie, il n'y a pas de 
!      limite pour la valeur de nb_seg. nb_seg>=1. nb_seg peut d'autre
!      part tres bien etre plus grand que ndet.
!      2 vecteurs real(8) et 2 vecteurs integer(4) sont alloues a la
!      dimension nb_seg. La limitation est la. Une valeur typique 
!      est ndet/10
!
! VII.  Appeler un programme d'initialisation (qui se trouve dans mod_addr)
!      call init_adr_interpol(norb,ndet,0)
!      aa12 est maintenant reordonne. ne pas le toucher pendant tout le
!      temps ou on utilise l'adressage.
!
! VIII. Utilisation de l'adressage : 
!      1. traduire le determinant det(:) dont on veut l'adresse en binaire :
!         call adr_interpol_trad(det(:),bb12(:),norb)
!      2. calculer l'adresse :
!         call adr_interpol(bb12,pos)    "pos" est l'adresse
!
! IX.  Eventuellement, sortir de l'environnement "adressage"  
!      call close_adr_interpol       
!      (desalloue aa12)
!----------------------------------------------------------------
!
module mod_addr
integer,allocatable,dimension(:),private :: iorad,aa3_ord,iadr,iadr_ord
real(8),allocatable,dimension(:,:),private :: dss
integer,private :: norb
integer,private :: ndet,nb_int32,nder1,nprint
real(8),allocatable,private :: seg_coef_a(:),seg_coef_b(:)
real(8),private :: rlong_seg
integer,allocatable,dimension(:,:) :: aa12
integer :: nb_seg
integer,dimension(0:1000) :: long_int=(/0,1,(2,i=2,3),(3,i=4,7),&
(4,i=8,15),(5,i=16,31),(6,i=32,63),(7,i=64,127),(8,i=128,255),&
(9,i=256,511),(10,i=512,1000)/)
integer,private,save :: ninac,nvirt,noac,iopt,lt,lp
integer,save :: long_spin
integer,allocatable,dimension(:),private :: numac,numin,numvir
character(100) :: format!='(a,4(2l1,1x),2(4l1,1x))'

contains
!*******************************************************
subroutine init_adr_interpol(norb_in,ndet_in,nprint_in)
implicit none
integer :: norb_in,ndet_in,norb2,p,jos,i,j,pos,ifil,nprint_in
real(8) :: pas_moyen
logical :: yw=.false.
integer,allocatable,dimension(:) :: bb12
norb=norb_in
ndet=ndet_in
if(iopt==0)nb_int32=(norb*2-1)/32+1
if(iopt==1)nb_int32=((noac+long_int(ninac)+long_int(nvirt))*2-1)/32+1
allocate(iorad(ndet))
allocate(aa3_ord(nb_int32))
allocate(iadr(nb_int32))
allocate(iadr_ord(nb_int32))
allocate(bb12(nb_int32))
if(iopt==0) then
   norb2=norb*2
else
   norb2=(noac+long_int(ninac)+long_int(nvirt))*2
endif
nder1=mod(norb2-1,32)+1
nprint=nprint_in

if(nprint>0) then
   call titre('Adressage par interpolation. Preparation#',300)
endif

!stocker aa12 avant de le detruire
call open_chose_number(ifil,'AA12','unknown','unformatted')
do i=1,ndet
   write(ifil) aa12(:,i)
enddo

! Reordonner aa12 dans en ordre croissant
!print*,'avant listordigo3',ndet,norb2,nb_int32
!print*,'avant listordigo3',aa12
call listordigo3(aa12,ndet,norb2,0)
!print*,'apres listordigo3'

! On prepare l'adressage, on calcule les segments de droite
call calc_rank_mol_0(aa12,norb2,ndet,nb_int32)

! Calcul de iorad : correspondance entre l'adresse et le rang
! 1. initialisation de iorad
iorad(:)=(/(i,i=1,ndet)/)
pas_moyen=0.d0

! 2. calcul de iorad
rewind ifil
do i=1,ndet
   read(ifil) bb12
   call adr_interpol(bb12,pos,j)
   if(yw)write(6,'(a,2i5,10i12)',advance='no') &
   'Adressage i,pos,bb12,ipas',i,pos,aa12(:,i)
   if(yw) print'(2x,a,i6)',bin_bbb(bb12,norb),j
   iorad(pos)=i
   pas_moyen=pas_moyen+abs(j)*1.d0
enddo
if(nprint>0)print*,'pas moyen de recherche de l''adresse  ',pas_moyen
deallocate(bb12)
if(yw)print*,'iorad',iorad
if(nprint>0) then
   call titre('Fin de la preparation a l''adressage par interpolation#',300)
endif

end subroutine
!*******************************************************
subroutine close_adr_interpol
deallocate(aa12)
deallocate(iorad)
deallocate(aa3_ord)
deallocate(iadr)
deallocate(iadr_ord)
deallocate(dss)
deallocate(seg_coef_a,seg_coef_b)
end subroutine
!*******************************************************
subroutine listordigo3(inlist,ndet,norb2,nprint1)
implicit none
integer,DIMENSION(nb_int32,ndet) :: InList
integer :: col,nprint1,i,m,ii,j,ideb,ifin,k,ndet,norb2
logical :: y,yw

yw=.false.
if(yw) then
   do i=1,ndet
      print*,'listordigo3: inlist',i,inlist(:,i)
   enddo
endif

! 1. On change les valeurs de inlist pour que l'ordre des nombres
! soit 'ordre des bits'
do i=1,ndet
   do m=1,nb_int32
      if(inlist(m,i)>=0) then
         inlist(m,i)=(inlist(m,i)-huge(i))-1
      else
         inlist(m,i)=(inlist(m,i)+huge(i))+1
      endif
   enddo
enddo
if(yw) then
   do i=1,ndet
      print*,'listordigo3: ordre des bits',i,inlist(:,i)
   enddo
endif

! 2. On reordonne inlist

call HPSORT(inlist,ndet,nb_int32,nb_int32)
if(yw) then
   print*,' '
   do i=1,ndet
      print'(a,i2,a,10i12)','out reordonne colonne',nb_int32,&
      '     :   ',i,inlist(:,i)
   enddo
endif
open(99,file='BID')

ideb=0
ifin=0
do col=nb_int32-1,1,-1
   if(yw) print*,' '
   if(yw) print*,'**** ordonnancement colonne',col,' ****'
   write(99,*) 0
   ii=0
   y=.false.
   do j=2,ndet
      if(y) then
         if(any(inlist(col+1:nb_int32,j)/=inlist(col+1:nb_int32,j-1))) then
             y=.false.
             ifin=j-1
             write(99,*) ideb,ifin
             if(yw)write(6,*) 'ideb,ifin',ideb,ifin
         endif
      else
         if(all(inlist(col+1:nb_int32,j)==inlist(col+1:nb_int32,j-1))) then
            ideb=j-1
            y=.true.
         endif
      endif
   enddo
   if(yw)print*,'col,y',col,y
   if(y) then
       write(99,*) ideb,ndet!;  write(6,*) 'ideb,ndet',ideb,ndet
       if(yw)print*,'w ideb ifin',ideb,ndet
   endif
   rewind 99
   read(99,*) k
   do
      read(99,*,end=1) ideb,ifin
       if(yw)print*,'r ideb ifin',ideb,ifin
      call HPSORT(inlist(:,ideb:ifin),ifin-ideb+1,nb_int32,col)
   enddo

1  continue
   rewind 99
   if(yw) then
      print*,' '
      do i=1,ndet
         print'(a,i2,a,10i12)','Out reordonne colonne',col,&
         '     :   ',i,inlist(:,i)
      enddo
   endif
enddo

! 3. On remet les vieilles valeurs de inlist
if(yw) print*,' '
if(yw) print*,'On remet les vieilles valeurs de inlist'
do i=1,ndet
   do m=1,nb_int32
      if(inlist(m,i)>=0) then
         inlist(m,i)=(inlist(m,i)-huge(i))-1
      else
         inlist(m,i)=(inlist(m,i)+huge(i))+1
      endif
   enddo
enddo

print*,' '
if(yw) then
   do i=1,ndet
      print*,'OUT',inlist(:,i)
   enddo
endif
close(99,status='delete')
end subroutine
!*****************************************************************
 subroutine calc_dss
allocate(dss(32,nb_int32))
do i=1,nb_int32
   do j=1,32
      dss(j,i)=2.d0**(32*(i-1)+j-1)
   enddo
enddo
end subroutine

!*****************************************************************
 subroutine calc_rank_mol_0(aa3,norb2,ndet,nb_int32)
implicit none
integer :: norb2,ndet
real(8) y,tot_err,rlong,rj,rjd,rjf,rlong_der_seg
integer :: nn,err,MAX_ERR_PLUS,MAX_ERR_MOINS,max_err
integer aa3(nb_int32,ndet)
! nb_int32 est le nb d'entiers necessaires pour representer un det.
! il a ete calcule lors du reordonnancement des det.
integer i,j,k,l,long_seg
logical :: ytest=.false.,yw=.false.

integer :: norb_loc,nder2,nb_int32
integer,allocatable,dimension(:) :: ideb,ifin
real(8),allocatable,dimension(:) :: raa3

norb_loc=norb2/2
nder2=nb_int32*32-norb2
! parametre:

allocate(seg_coef_a(nb_seg),seg_coef_b(nb_seg))
allocate(ideb(nb_seg),ifin(nb_seg))
allocate(raa3(ndet))

call calc_dss
call rlis(rlong,aa3(:,ndet))
! rlong=reel representant approximativement les entiers du dernier det
! (le plus grand)

rlong_seg=rlong/(nb_seg)  !longueur d'un segment
rlong_der_seg=rlong-(nb_seg-1)*rlong_seg
if(nprint>0) then
   print*,' '
   print*,'Plus grande valeur reelle de la liste',rlong
   print*,"Longueur d'un segment                ",rlong_seg
   print*,"Longueur du dernier segment          ",rlong_der_seg
endif


! On exprime les listes en reels
do i=1,ndet
   call rlis(raa3(i),aa3(:,i))
enddo

! On calcule ideb,ifin, debut et fin de chaque classe
k=0
ideb=0
ifin=0
ideb(1)=1
ifin(nb_seg)=ndet
do i=1,ndet
   call rlis(rj,aa3(:,i))
   j=int(rj/rlong_seg)
   j=min(j,nb_seg-1)
   if(j>k) then
      ideb(k+2)=i
      ifin(k+1)=i-1
   endif
   k=j
enddo


do i=1,nb_seg
   if(ideb(i)==0) ideb(i)=ideb(i-1)
   if(ndet<=1000) then
      if(ifin(i)/=0) then
         call rlis(rjd,aa3(:,ideb(i)))
         call rlis(rjf,aa3(:,ifin(i)))
!         print'(3i6,4d12.4)',i,ideb(i),ifin(i),rjd,rjf
      else
         call rlis(rjd,aa3(:,ideb(i)))
!         print'(3i6,4d12.4)',i,ideb(i),ifin(i),rjd
      endif
   endif
enddo


! Equation des segments de droite
if(yw) then
   print*,' '
   print*,'-----------------------------------------------'
   print*,'Equations des segments de droite'
   print*,' '
   print*, '     seg    ideb    ifin          a               b'
endif
do i=1,nb_seg
   if(ideb(i)>=ifin(i)) then
      seg_coef_a(i)=0.d0
      seg_coef_b(i)=1.d0*ideb(i)
   else if(ideb(i)<ifin(i)) then
      seg_coef_a(i)=1.d0*(ifin(i)-ideb(i))/(raa3(ifin(i))-raa3(ideb(i)))
      seg_coef_b(i)=1.d0*ideb(i)-seg_coef_a(i)*raa3(ideb(i))
   endif
!   if(yw)print'(a,3i6,4d16.4)','segments: i,ideb(i),ifin(i),seg_coef_a(i),seg_coef_b(i)',&
!   i,ideb(i),ifin(i),seg_coef_a(i),seg_coef_b(i)
   if(yw)print'(3i8,2d16.4)', i,ideb(i),ifin(i),seg_coef_a(i),seg_coef_b(i)
enddo
if(yw)print*,'-----------------------------------------------'
if(yw)print*,' '

if(yw) then
   i=0
   do k=1,nb_seg
      do l=1,ndet/nb_seg
         print*,'-------------------------------------------------'
         i=i+1
         write(75,*),'TEST segment:',k,' ; pos ds seg:',l,' ; det:',i,'$'
         call scril
         print*,'TEST aa3     ',aa3(:,i)
         print*,'TEST raa3    ',raa3(i)
         j=int(raa3(i)/rlong_seg+1)
         if(j==nb_seg+1) j=nb_seg
         print*,'TEST j    ',j
         print*,'TEST ideb    ',ideb(j)
         print*,'TEST ifin    ',ifin(j)
         y=seg_coef_a(j)*raa3(i)+seg_coef_b(j)
         print*,'TEST y       ',y
         print*,'TEST nint(y) ',nint(y),'  -----',i
      enddo
   enddo
endif

if(ytest.or.nprint>1) then
   !differences avec les valeurs de la droite
   tot_err=0.d0
   max_err=0
   max_err_plus=0
   max_err_moins=0
   print*,' '
   if(ndet<=1000)&
   print*, '  Det     x=aa3(Det)    Seg    y(aa3)      int(y)      err'

   do i=1,ndet
      j=int(raa3(i)/rlong_seg+1)
      j=min(j,nb_seg)
      y=seg_coef_a(j)*raa3(i)+seg_coef_b(j)
      err=nint(y)-i
      if(ndet<=1000)print'(i6,d16.6,i6,2x,f7.2,i11,4x,i6,6x,a)'&
      ,i,raa3(i),j,y,nint(y),err,bin_bbb(aa3(:,i),norb)
      tot_err=tot_err+1.d0*abs(err)
      max_err=max(max_err,abs(err))
      if(err>0) then
         max_err_plus=max_err_plus+err
      else
         max_err_moins=max_err_moins+err
      endif
   enddo
   print*,'erreur moyenne',tot_err/ndet
   print*,'erreur max    ',max_err
   print*,'sum err>0     ',max_err_plus
   print*,'sum err<0     ',max_err_moins
endif
deallocate(ideb,ifin,raa3)
end subroutine
!*****************************************************************
!*****************************************************************
 subroutine rlis(rlong,aa3)
!----------------------------------------------------------------
! tranform list of intergers into one real(8)
!----------------------------------------------------------------
implicit none
real(8) :: rlong
integer :: aa3(nb_int32)
integer :: i,j
rlong=0.d0
do i=1,nb_int32-1
   do j=1,32
      if(btest(aa3(i),j-1)) rlong=rlong+dss(j,i)
   enddo
enddo
do j=1,nder1
   if(btest(aa3(nb_int32),j-1)) rlong=rlong+dss(j,nb_int32)
enddo
end subroutine
!*****************************************************************
 subroutine adr_interpol(aa3,pos,npas1,ywloc,isaut_moyen_in)
!use mod_bin
implicit none
integer :: pos,pos_tmp,npas
integer aa3(nb_int32),n,j,i,k,pos_ref
real(8) :: raa,y,radr
logical :: yw
integer :: direction,isaut_moyen,isaut_moyen0
integer,optional :: npas1,isaut_moyen_in
logical,optional :: ywloc

!
!---------------------------------------------------
! INPUT : aa3(1:nblis) input determinant, described by the binary
!         representation of nb_int32 integers
! OUTPUT : pos = rank of the determinant
!---------------------------------------------------
!

yw=.false.
if(present(ywloc)) yw=ywloc

if(yw) print*,' '
if(yw) print*,'-------------------------------------------'
if(yw)print*,'entree adr_interpol    det  ',bin_bbb(aa3,norb)
if(present(isaut_moyen_in)) then
   isaut_moyen0=isaut_moyen_in
   isaut_moyen=isaut_moyen_in
   if(yw)print*,'isaut_moyen_in',isaut_moyen_in
else
   isaut_moyen=1
   isaut_moyen0=1
endif


! Transform the nb_int32 integers (aa3) into a real number raa
call rlis(raa,aa3(:))

! Transform aa3 into aa3_ord, where the integers increase according
! to the list of determinants
call adr_interpol_order(aa3,aa3_ord,nb_int32)

if(yw) then
   print*,'aa3 (entiers representant le det)',aa3
   print*,'raa (reel    representant le det)',raa
   print*,'rlong_seg (longueur du segment)  ',rlong_seg
   print*,'raa/rlong_seg+1 (numero du segment)',raa/rlong_seg+1
   print*,'nb_seg (nb de segments)           ',nb_seg
endif


! Find j, segment to which belongs the det
j=int(raa/rlong_seg+1)
j=min(j,nb_seg)

! The equation of the segment j is "y=coef_a(j)*raa+seg_coef_b(j)"
! --> the integer value of y gives an approximation of the final rank pos
! i.e. a starting point for the search of pos
y=seg_coef_a(j)*raa+seg_coef_b(j)
pos_ref=nint(y)


if(yw) then
   print*,'numero segment (valeur entiere)   ',j
   print'(a,2d23.16)','a,b (coefs de la droite)          ',&
   seg_coef_a(j),seg_coef_b(j)
   print*,'y (y=a(j)*raa+b(j), valeur estimee du numero du det)',y
   print*,'pos_ref=nint(y) (valeur entiere de la valeur estimee)',pos_ref
   print*,' '
   print'(a,i7)','pos_ref (adresse de depart = '//&
   'pt de depart de la recherche):',pos_ref
endif

!--------------------------------
! start searching
!--------------------------------
npas=0

! if the starting point is not inside the segment, it is sure that
! the determinant does not belong to the det basis
! the output rank is 0, exit the subroutine
if(pos_ref>ndet) then
   pos=0
   if(yw)print*,'NON trouve! sortie 0 adr_interpol',pos
   return
endif
if(pos_ref<1) then
   pos=0
   if(yw)print*,'NON trouve! sortie 1 adr_interpol',pos
   return
endif
if(yw)print*,'verif: Le det d''essai est bien a l''interieur du fragment'

! Compute iadr(1:nb_int32) = starting determinant
iadr(:)=aa12(:,pos_ref)
call rlis(radr,iadr)
call adr_interpol_order(iadr,iadr_ord,nb_int32)


! check, perhaps we found the good det
if(yw)print*,'1er essai  :',iadr
if(all(iadr==aa3)) then
   pos=pos_ref
   if(yw)print*,'trouve ! sortie 2 adr_interpol  pos=',pos
   goto 1
endif
if(yw)print*,'aa3 (but)  :',aa3

!
!------------------------------------
! Find in what direction we must seek
!------------------------------------
!
direction=0
if(pos_ref==ndet) direction=-1
if(pos_ref==1) direction=1
if(yw)print*,'precalcul de la direction : direction=',direction


if(yw)write(75,*),'(pos_ref --> iadr) (',pos_ref,' --> ',iadr,'). On cherche:',aa3,'$'
if(yw)call scril

! trouver la direction
if(direction==0) then
      do i=nb_int32,1,-1
         if(iadr_ord(i)>aa3_ord(i)) then
            direction=-1
            exit
         else if(iadr_ord(i)<aa3_ord(i)) then
            direction=1
            exit
         endif
      enddo
!   endif
endif
if(yw)print'(a,i3,a,2d25.10)','direction de depart',direction,'  <--  ',raa,radr
!
!-------------------------------------------------------
! direction was found (1 or -1)
!-------------------------------------------------------
!

pos=0
pos_tmp=pos_ref
!
!-------------------------------------------------------
! increment trying det until finding searched det aa3
!-------------------------------------------------------
!
if(direction==1) then
   k=0
   do
      ! count search iterations
      k=k+1
      ! stop if too many search iterations
      if(k==10000) then
         print*,'IPAS trop grand'
         print'(20i12)','aa3',aa3
         print'(2a)','det ',bin_bbb(aa3,norb)
         stop
      endif

      ! increment rank of trying det
      ! check if we are already inside the fragment
      ! if not, decrease isaut_moyen
      ! if isaut_moyen was already 1, it means that the det does not exist
      if(yw)print*,'isaut_moyen avant rech de sortie du fragment',&
      isaut_moyen
      do
         pos_tmp=pos_ref+isaut_moyen
         if(pos_tmp>size(aa12,2)) then
            if(isaut_moyen==1) then
               if(yw) print*,'pos_tmp,size(aa12,2)',&
               pos_tmp,size(aa12,2),'  exit'
               return
            else
               isaut_moyen=isaut_moyen/2
               cycle
            endif
         endif
         exit
      enddo
      if(yw)print*,'isaut_moyen apres rech de sortie du fragment',&
      isaut_moyen
      iadr=aa12(:,pos_tmp)
      call adr_interpol_order(iadr,iadr_ord,nb_int32)
      if(yw) write(6,'(a,10i13)')'nouveau determinant d essai',iadr
      ! pos_tmp is now the trying det, iadr(1:nb_int32) is its
      ! binary representation

2     continue

      npas=npas+1

      if(yw)write(75,*)'iadr=(',iadr,'), aa3=(',aa3,'), pos_tmp=',pos_tmp,&
      ', npas=',npas,k,', diff=(',iadr-aa3,')','$'
      if(yw) call scril

      !---------------------------------------------------------
      ! find the position of the trying det with respect to the
      ! searched det (we seek here in upwards direction (direction==1)
      !---------------------------------------------------------

      do i=nb_int32,1,-1
         if(yw)print*,'iadr_ord(i),aa3_ord(i)',iadr_ord(i),aa3_ord(i)
         if(iadr_ord(i)<aa3_ord(i)) then
            ! we are still below, continue
            pos_ref=pos_tmp
            if(yw)print*,'coucou1',i
            exit
         else if(iadr_ord(i)>aa3_ord(i)) then
            ! we are above ! two solutions:
            ! 1. if isaut_moyen==1, it is impossible, therefore the det
            !    does not exist
            if(isaut_moyen==1) then
               pos=0
               if(yw)print*,'NON trouve! sortie +6 adr_interpol',pos,npas
               return
            ! 2. isaut_moyen>1. reduce isaut_moyen, redo comparison
            else
               isaut_moyen=isaut_moyen/2
               if(yw)print*,'coucou2',i,isaut_moyen
               pos_tmp=pos_ref+isaut_moyen
               iadr=aa12(:,pos_tmp)
               call adr_interpol_order(iadr,iadr_ord,nb_int32)
               npas=npas+1
               goto 2
            endif
         else
            ! equality iadr(i)==aa3(i)
            if(i==1) then
               ! FOUND!
               pos=pos_tmp
               if(yw)print*,'trouve en ',npas,&
               ' pas ! sortie 3 adr_interpol',pos
               goto 1
            else
               ! continue comparison for iadr(i-1)
               if(yw)print*,'coucou3',i
               cycle
            endif
         endif
      enddo
      if(yw)print'(2a,2i7)','det ',bin_bbb(aa3,norb),pos_tmp,npas

   enddo
else
   k=0
   do
      ! count search iterations
      k=k+1
      ! stop if too many search iterations
      if(k==10000) then
         print*,'-IPAS trop grand'
         print'(a,20i12)','aa3',aa3
         print'(2a)','det ',bin_bbb(aa3,norb)
         stop
      endif

      ! increment rank of trying det
      ! check if we are inside the fragment again
      ! if not, decrease isaut_moyen and re-increment
      ! if isaut_moyen was already 1, it means that the det does not exist
      if(yw)print*,'isaut_moyen avant rech de sortie du fragment',&
      isaut_moyen
      do
         pos_tmp=pos_ref-isaut_moyen
         if(pos_tmp<1) then
            if(isaut_moyen==1) then
               if(yw) print*,'pos_tmp,size(aa12,2)',&
               pos_tmp,size(aa12,2),'  exit'
               return
            else
               isaut_moyen=isaut_moyen/2
               cycle
            endif
         endif
         exit
      enddo
      if(yw)print*,'isaut_moyen apres rech de sortie du fragment',&
      isaut_moyen
      iadr=aa12(:,pos_tmp)
      call adr_interpol_order(iadr,iadr_ord,nb_int32)
      !if(yw) write(6,'(a,10i13)')'nouveau determinant d essai',iadr
      ! pos_tmp is now the trying det, iadr(1:nb_int32) is its
      ! binary representation

3     continue

      npas=npas-1

      if(yw)write(75,*)'iadr=(',iadr,'), aa3=(',aa3,'), pos_tmp=',pos_tmp,&
      ', Npas=',npas,k,', diff=(',iadr-aa3,')','$'
      if(yw) call scril

      !---------------------------------------------------------
      ! find the position of the trying det with respect to the
      ! searched det (we seek here in upwards direction (direction==1)
      !---------------------------------------------------------

      do i=nb_int32,1,-1
         if(iadr_ord(i)>aa3_ord(i)) then
            ! we are still above, continue
            pos_ref=pos_tmp
            if(yw)print*,'coucou1',i
            exit
         else if(iadr_ord(i)<aa3_ord(i)) then
            ! we are below ! two solutions:
            ! 1. if isaut_moyen==1, it is impossible, therefore the det
            !    does not exist
            if(isaut_moyen==1) then
               pos=0
               if(yw)print*,'NON trouve! sortie -6 adr_interpol',&
               pos,npas
               return
            ! 2. isaut_moyen>1. reduce isaut_moyen, redo comparison
            else
               isaut_moyen=isaut_moyen/2
               if(yw)print*,'coucou2',i,isaut_moyen
               pos_tmp=pos_ref-isaut_moyen
               iadr=aa12(:,pos_tmp)
               call adr_interpol_order(iadr,iadr_ord,nb_int32)
               npas=npas-1
               goto 3
            endif
         else
            ! equality iadr(i)==aa3(i)
            if(i==1) then
               ! FOUND!
               pos=pos_tmp
               if(yw)print*,'trouve en ',npas,&
               ' pas ! sortie 3 adr_interpol',pos
               goto 1
            else
               ! continue comparison for iadr(i-1)
               if(yw)print*,'coucou3',i
               cycle
            endif
         endif
      enddo
      if(yw)print'(2a,2i7)','det ',bin_bbb(aa3,norb),pos,npas

   enddo
endif

1 continue
if(pos>0) pos=iorad(pos)
if(present(npas1)) then
   npas1=npas
endif
if(yw)print*,'SORTIE adr_interpol','   adresse (iorad(pos)) =======',pos
if(yw)print*,'-----------sortie adr_interpol-----------------------'

end subroutine

!**********************************************************************
function bin_bbb(bbb,n)

! a definir dans module separe (rajouter "use...", ou "common...") : 
! - iopt (0 ou 1, selon que les det sont ecrits
!   0 : en occupation (IC selectionnee)
!   1 : en actives, trou, virtuelle
! - lt,lp : nb de bits necessaires pour ecrire la plus grande occupee
!  et la plus grande virtuelle

implicit none
character(n) bin_bbb
integer bbb((n+n-1)/32+1),n,k,m,l,i,j,ii,lj,mj,llj,mmj,kk
logical :: yw=.false.
bin_bbb=' '
do k=1,n
   bin_bbb(k:k)='0'
enddo
if(iopt==0) then
   m=0
   l=1
   do k=1,n
      if(btest(bbb(l),m)) bin_bbb(k:k)='u'
      m=m+1
      if(m==32) then
         m=0
         l=l+1
      endif
   enddo
   do k=1,n
      if(btest(bbb(l),m)) then
         if(bin_bbb(k:k)=='u') then
            bin_bbb(k:k)='2'
         else
            bin_bbb(k:k)='d'
         endif
      endif
      m=m+1
      if(m==32) then
         m=0
         l=l+1
      endif
   enddo
else
   do k=1,ninac
      kk=numin(k)
      bin_bbb(kk:kk)='2'
   enddo

   !particule alpha
   if(yw)write(6,format) 'entree bin_bbb : det ',((btest(bbb(l),m),m=0,min(31,mod(long_spin*2,32)-1)),l=1,n/32+1)
   m=0
   l=1
   i=0
   call mvbits(bbb(l), m, lp, i, 0) 
   if(yw)write(6,*)'mvbits P',m,i,0
   !ii=i+noac+ninac
   if(i>0) then
      ii=numvir(i)
      bin_bbb(ii:ii)='u'
      if(yw) write(6,*) 'part u en',ii
   endif
   call bin_jncr(l,m,lp)

   !particule beta
   i=0
   call mvbits(bbb(l), m, lp, i, 0) 
   if(yw)write(6,*)'mvbits P',m,i,0
   !ii=i+noac+ninac
   if(i>0) then
      ii=numvir(i)
      bin_bbb(ii:ii)='d'
      if(yw) write(6,*) 'part d en',ii
   endif
   call bin_jncr(l,m,lp)

   ! trou alpha
   i=0
   call mvbits(bbb(l), m, lt, i, 0) 
   if(yw)write(6,*)'mvbits T',m,i,0
   if(i>0) then
      ii=numin(i)
      bin_bbb(ii:ii)='u'
      if(yw) write(6,*) 'trou u en',ii
   endif
   call bin_jncr(l,m,lt)

   ! trou beta
   i=0
   call mvbits(bbb(l), m, lt, i, 0) 
   if(yw)write(6,*)'mvbits T',m,i,0
   if(i>0) then
      ii=numin(i)
      bin_bbb(ii:ii)='d'
      if(yw) write(6,*) 'trou u en',ii
   endif
   call bin_jncr(l,m,lt)

   if(yw)write(6,*)  'bin_bbb ',bin_bbb

   ! actives alpha
   do kk=1,noac
      if(yw)write(6,*)'kku',kk
      !k=kk+ninac
      k=numac(kk)
      if(btest(bbb(l),m)) bin_bbb(k:k)='u'
      if(btest(bbb(l),m).and.yw)write(6,*)'u en',k
      m=m+1
      if(m==32) then
         m=0
         l=l+1
      endif
   enddo

   if(yw)write(6,*)  'bin_bbb ',bin_bbb

   ! actives beta
   do kk=1,noac
      if(yw)write(6,*)'kkd',kk
      !k=kk+ninac
      k=numac(kk)
      if(btest(bbb(l),m)) then
         if(bin_bbb(k:k)=='u') then
            bin_bbb(k:k)='2'
         else
            bin_bbb(k:k)='d'
         endif
      endif
      if(btest(bbb(l),m).and.yw)write(6,*)'d en',k
      m=m+1
      if(m==32) then
         m=0
         l=l+1
      endif
   enddo
   if(yw)write(6,*)  'bin_bbb ',bin_bbb
endif
!CALL MVBITS(FROM, FROMPOS, LEN, TO, TOPOS) 
end function
!*****************************************************************
subroutine adr_interpol_order(aa3,iadr_ord_loc,nb_int32)
implicit none
integer,dimension(nb_int32) :: aa3,iadr_ord_loc
integer m,nb_int32
do m=1,nb_int32
   if(aa3(m)>=0) then
      iadr_ord_loc(m)=(aa3(m)-huge(m))-1
   else
      iadr_ord_loc(m)=(aa3(m)+huge(m))+1
   endif
enddo
end subroutine
!*****************************************************************
subroutine adr_interpol_trad_init(iopt_in,noac_in,ninac_in,nvirt_in&
,numac_in,norb_in)
implicit none
integer,intent(in) :: iopt_in,noac_in,ninac_in,nvirt_in,numac_in(noac_in)
integer,intent(in) :: norb_in
logical,allocatable :: yac(:)
logical :: yw=.true.
integer :: i,n,ii,l
iopt=iopt_in
ninac=ninac_in
nvirt=nvirt_in
noac=noac_in
lt=long_int(ninac)
lp=long_int(nvirt)
!print*,'lp',lp,nvirt,long_int(0:nvirt);stop
long_spin=lt+noac+lp
if(yw) print*,'lt,lp,long_spin',lt,lp,long_spin
allocate(numac(noac),numin(ninac),numvir(nvirt),yac(norb_in))
numac=numac_in
yac=.false.
if(yw)print*,'norb',norb_in
yac(numac)=.true.
n=0
do i=1,norb_in
   if(.not.yac(i)) then
      n=n+1
      numin(n)=i
      if(n==ninac) then
         ii=i
         exit
      endif
   endif
enddo
n=0
do i=ii+1,norb_in
   if(.not.yac(i)) then
      n=n+1
      numvir(n)=i
   endif
enddo
if(yw)print*,'numac',numac
if(yw)print*,'numin',numin
if(yw)print*,'numvir',numvir
format=' '
format(1:5)='(a,2('
!format='(a,4(2l1,1x),2(4l1,1x))'
write(format(6:8),'(i3)') lp
format(6:8)=adjustl(format(6:8))
l=len_trim(format)
write(format(l+1:l+9),'(a9)') 'l1,1x),2('
l=len_trim(format)
write(format(l+1:l+3),'(i3)') lt
format(l+1:l+3)=adjustl(format(l+1:l+3))
l=len_trim(format)
write(format(l+1:l+9),'(a9)') 'l1,1x),2('
l=len_trim(format)
write(format(l+1:l+3),'(i3)') noac
format(l+1:l+3)=adjustl(format(l+1:l+3))
l=len_trim(format)
format(l+1:l+7)='l1,1x))'
!print*,'format ',format;stop

      
end subroutine
!*****************************************************************
subroutine adr_interpol_trad(det,aa,norb)
!
!-------------------------------------------------------------
! Ecriture des determinants en trou-CAS-part (iopt=1)
!
!    |  part A  |  part B  |  trou A  |  trou B  |   act A   |   act B   |
! L:     lp         lp         lt         lt         noac        noac
!
! part A = particule alpha...      L=nb de bits reserves dean l'entier
!                                  representant le determinant
!-------------------------------------------------------------
!
implicit none
integer lj,mj,llj,mmj,det(norb),aa((norb*2-1)/32+1),norb,j,jj,k
logical :: yw=.false.
aa(:)=0
if(iopt==0) then
   call bin_init12(lj,mj,llj,mmj,norb)
   do j=1,norb
      call bin_incr12(lj,mj,llj,mmj,norb)
      if(det(j)>0) aa(lj)=ibset(aa(lj),mj)
      if(det(j)==-1.or.det(j)==2) &
      aa(llj)=ibset(aa(llj),mmj)
   enddo
else
   if(yw)print*,'----------------------------'
   if(yw)print'(a,30i3)','Det',det

   call bin_init12(lj,mj,llj,mmj,norb)
   if(yw)print*,'init lj,mj,norb',lj,mj,norb

   ! poser la particule alpha
   lj=1
   mj=0
   do jj=1,nvirt
      !j=jj+ninac+noac
      j=numvir(jj)
      if(det(j)==1) then
         call mvbits(jj, 0, lp, aa(lj), mj)
         if(yw)print*,'p1mvbits',jj,mj
         call bin_jncr(lj,mj,lp)
         goto 1
      endif
   enddo
   ! poser la particule beta
   call bin_jncr(lj,mj,lp)
   do jj=1,nvirt
      !j=jj+ninac+noac
      j=numvir(jj)
      if(det(j)==-1) then
         call mvbits(jj, 0, lp, aa(lj), mj)
         if(yw)print*,'p2mvbits',jj,mj
         exit
      endif
   enddo
   1 continue
   if(yw)print format,'P Aa1  ',(btest(aa(1),k),k=0,15)

   ! poser le trou alpha
   call bin_jncr(lj,mj,lp)
   do jj=1,ninac
      j=numin(jj)
      if(det(j)==1) then
         call mvbits(jj, 0, lp, aa(lj), mj)
         if(yw)print*,'t1mvbits',j,mj
         call bin_jncr(lj,mj,lt)
         goto 2
      endif
   enddo
   call bin_jncr(lj,mj,lt)
   do jj=1,ninac
      j=numin(jj)
      if(det(j)==-1) then
         call mvbits(jj, 0, lp, aa(lj), mj)
         if(yw)print*,'t2mvbits',j,mj
         exit
      endif
   enddo
   2 continue
   if(yw)print format,'T Aa1  ',(btest(aa(1),k),k=0,15)

   ! poser les actives alpha
   call bin_jncr(lj,mj,lt)
   do jj=1,noac
      !j=jj+ninac
      j=numac(jj)
      if(det(j)>0) aa(lj)=ibset(aa(lj),mj)
      if(det(j)>0.and.yw) print*,'acta',lj,mj
      call bin_incr(lj,mj)
   enddo
   ! poser les actives beta
   do jj=1,noac
      !j=jj+ninac
      j=numac(jj)
      if(det(j)==-1.or.det(j)==2) aa(lj)=ibset(aa(lj),mj)
      if((det(j)==-1.or.det(j)==2).and.yw) print*,'actb',lj,mj
      call bin_incr(lj,mj)
   enddo
   if(yw)print format,'C Aa1  ',(btest(aa(1),k),k=0,15)
endif
!CALL MVBITS(FROM, FROMPOS, LEN, TO, TOPOS) 
end subroutine
!*****************************************************************
 subroutine bin_init12(lj,mj,llj,mmj,n)
implicit none
integer llj,mmj,n,l
integer lj,mj
lj=1
mj=-1
if(iopt==0) then
   llj=n/32+1
   mmj=mod(n,32)-1
else
   l=long_int(ninac)+noac+long_int(nvirt)
   llj=l/32+1
   mmj=mod(l,32)-1
endif
end subroutine
!*****************************************************************
 subroutine bin_init1(lj,mj)
implicit none
integer lj,mj
lj=1
mj=-1
end subroutine
!*****************************************************************
 subroutine bin_init2(llj,mmj,n)
implicit none
integer llj,mmj,n,l
if(iopt==0) then
   llj=n/32+1
   mmj=mod(n,32)-1
else
   l=long_int(ninac)+noac+long_int(nvirt)
   llj=l/32+1
   mmj=mod(l,32)-1
endif
end subroutine
!*****************************************************************
end module
!*****************************************************************
 subroutine bin_incr12(lj,mj,llj,mmj,noac)
implicit none
integer lj,mj,llj,mmj,noac
mj=mj+1
mmj=mmj+1
if(mj>31) then
   mj=0
   lj=lj+1
endif
if(mmj>31) then
   mmj=0
   llj=llj+1
endif
end subroutine
!*****************************************************************
 subroutine bin_incr(lj,mj)
implicit none
integer lj,mj
mj=mj+1
if(mj>31) then
   mj=0
   lj=lj+1
endif
end subroutine
!*****************************************************************
subroutine bin_jncr(lj,mj,delmj)
implicit none
integer lj,mj,delmj
mj=mj+delmj
lj=lj+mj/32
mj=mod(mj,32)
end subroutine
!*****************************************************************
 SUBROUTINE HPSORT(ra,n,nb_int32,col)
  implicit none
  integer :: ra(nb_int32,n),n,nb_int32,col
  integer l,ir,i,j
  integer,allocatable :: rra(:)
  logical :: yw=.false.
  if(yw)print*,'HPSORT n nb_int32,col',n,nb_int32,col
  allocate(rra(nb_int32))
  L=N/2+1
  IR=N
  !The index L will be decremented from its initial value during the
  !"hiring" (heap creation) phase. Once it reaches 1, the index IR
  !will be decremented from its initial value down to 1 during the
  !"retirement-and-promotion" (heap selection) phase.
10 continue
  if(L > 1)then
    L=L-1
    RRA(:)=RA(:,L)
  else
    RRA(:)=RA(:,IR)
    RA(:,IR)=RA(:,1)
!   modif pour le cas n==1 (Nadia)
    if(N/=1) IR=IR-1
    if(IR.eq.1)then
      RA(:,1)=RRA
      deallocate(rra)
      return
    end if
  end if
  I=L
  J=L+L
20 if(J.le.IR)then
  if(J < IR)then
    if(RA(col,J) < RA(col,J+1))  J=J+1
  end if
  if(RRA(col) < RA(col,J))then
    RA(:,I)=RA(:,J)
    I=J; J=J+J
  else
    J=IR+1
  end if
  goto 20
  end if
  RA(:,I)=RRA(:)
  goto 10
END subroutine
