      program ECRIMAT
      IMPLICIT REAL*8(A-H,O-X,Z),logical*1(y)
      parameter(maxsym=8,ngru3=2048,maxal=56)
      include 'maxorb.prm'
      parameter(lungo=100,maxorbcas=16,maxne=maxorbcas+2)
      dimension ITAB(NGRU3),JTAB(NGRU3)
      real*4 DTAB(NGRU3)
      real*8 DTAB8(NGRU3)
      character*1000 namel
      character*80 prefix,det,davec,mat,info,cdi
      dimension e(maxal)
      dimension itv(12),ipv(12)
      double precision,dimension(:,:),allocatable :: b
      character(1),allocatable,dimension(:) :: iwspin
      character*1 ctps,cex,c256
      character*60 detc
      character*2 ibla2,type
      common /orb/ enuc,eref,norb,noca,nocb
     *,iorb(2*maxorb),ninac,nvirt,noca0
      common/detsto/mdestod,ndestod,mdestod1,ndestod1,npie2,mpie2,
     *mpie256,mdestod256,mdestod2561,
     *ctps((maxne)*lungo*2),cex(lungo),c256((maxne/4+1)*lungo)
      common /cs/ noac,nelac,numac(maxorbcas),itype(maxorb),is0,ms2
      integer precis(1000)
      prefix=' '
      det=' '
      davec=' '
      info=' '
      mat=' '
      cdi=' '
      ydetv=.false.
      nprint=0
      itest25=1
      precis=0
      type='R4'
      shift=0.d0
      call LECNAM('&ECRM',namel,5,ierr,1)
      call namela(namel,prefix,'PREFIX')
      call namela(namel,DET,'DET')
      call namela(namel,MAT,'MAT')
      call namela(namel,CDI,'CDI')
      call namela(namel,INFO,'INFO')
      call namela(namel,DAVEC,'DAVEC')
      call nameli(namel,PRECIS,'PRECIS',4)
      call namell(namel,YDETV,'YDETV',1)
      call nameli(namel,NPRINT,'NPRINT',4)
      call namela(namel,TYPE,'TYPE')
      call namelD(namel,SHIFT,'SHIFT',8)
      print*,'type',type
      if(ydetv) itest25=1
      if(det.eq.' ') det=trim(prefix)//'det'
      if(davec.eq.' ') davec=trim(prefix)//'davec'
      if(info.eq.' ') info=trim(prefix)//'Info'
      if(mat.eq.' ') mat=trim(prefix)//'mat'
      if(cdi.eq.' ') cdi=trim(prefix)//'cdi'
      print*,'det',det
      open(61,file=det,status='old',form='unformatted')
      open(2,file=davec,status='old',form='unformatted')
      open(1,file=mat,status='old',form='unformatted')
      open(3,file=info,status='old',form='formatted')
      open(4,file=cdi,status='old',form='formatted')
      call LECNAM('&CDI',namel,4,ierr,1)
      call nameli(namel,MS2,'MS2',4)
      call LECNAM('&COST_MO',namel,3,ierr,1)
      call nameli(namel,NORB,'NORB',4)
      read(2)n,nvec
      print*,'n,nvec',n,nvec
      allocate(b(n,n))
      read(2) e(1:nvec)
      print*,'e',e(1:nvec)
c
c     lecture de la matrice
c
 341  continue
      if(type=='R8') then
         dtab8=0.d0
         read(1) itab,jtab,dtab8
      else
         dtab=0.d0
         read(1) itab,jtab,dtab
         dtab8=dtab
      endif
      NM=NGRU3
c     pour sortir de la boucle à la fin du fichier
      IF(ITAB(NGRU3).EQ.-1) NM=JTAB(NGRU3)
      DO KK=1,NM
         I=ITAB(KK)
         J=JTAB(KK)
         if(i==-1) exit
         IF(I.EQ.J) then
            b(i,i)=DTAB8(KK)*2+b(i,i)+shift
         else
            b(i,j)=DTAB8(KK)+b(i,j)
            b(j,i)=DTAB8(KK)+b(j,i)
         endif
      enddo
      if(itab(ngru3).ge.0) goto 341
c     nombre d'orbitales
      print*,'norb',norb
      allocate (iwspin(1:norb+norb))
      iorb(1:norb)=(/(k,k=1,norb)/)
      iorb(norb+1:norb+norb)=iorb(1:norb)
      iwspin(1:norb)='+'
      iwspin(norb+1:norb+norb)='-'
c
c     lecture des determinants
c
      mdestod=0
      mdestod=0
      ibla1=0
      ibla2='=>'

      call rew61
      do ll=1,n
         call venond(ne,itv,ipv,ierr,itest25)
         ne1=ne
         if(ne.ne.0) then
            if(ipv(ne).eq.norb+norb+1)ne1=ne-1
         endif
         l=ne*10+5
         if(l.gt.50) then
            write(6,6666)(IORB(itv(I)),IWSPIN(itv(I)),I=1,ne),
     *      ibla1,ibla2
            detc(1:35)='                                   '
c            detc(1:50)='                          '//
c     *      '                        '
            write(detc,6666)(IORB(ipv(I)),IWSPIN(ipv(I)),I=1,ne1)
            write(6,'(4x,a54,i6)') detc(1:54),ll
         else
            detc(1:50)='                          '//
     *      '                        '
            write(detc,6666) (IORB(itv(I)),IWSPIN(itv(I)),I=1,ne1),
     *      ibla1,ibla2, (IORB(ipv(I)),IWSPIN(ipv(I)),I=1,ne1)
            write(6,'(4x,a60,i8)') detc(1:60),ll
         endif
6666        FORMAT(1X, 12(I3,A2))
      enddo
      if(nprint>0)call script(b,n,n,n,n)
      print*,'precis',precis(1:10)
      if(any(precis/=0)) then
!
! Exemple d'utilisation de precis
! precis=4,7,33,62
! le programme ecrit les valeurs precises de b(4,7) et de b(33,62)
!
         print*,'PRECIS'
         do k=1,500,2
            if(precis(k)==0) exit
            print'(2i5,f25.15)',precis(k:k+1),b(precis(k),precis(k+1))
         enddo
         stop
      endif
      if(nprint<2) stop
      do k=1,n
         do l=1,k
            print'(2i4,f25.15)',k,l,b(k,l)
         enddo
      enddo
      end
