      SUBROUTINE REIJKL(factor,norb,nsym,itsym,its,nos,jd1)
C 
C     PREPARATION POUR LE STOCKAGE DES INTEGRALES BIELECTONIQUES
C 
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      DIMENSION NOS(20),ITSYM(ID3),ITS(20,20)
      COMMON /HND/ ZHANDY,ZTHREE,zmotra,zfac
      COMMON /MOTRA/ NAOCSYM(8),NAVISYM(8),NINASYM(8),NPERM(id1)
      COMMON /INT/ NI4,NI3,NI2,NR4,
     * F(ID2),AJ(ID2),AK(ID2),NUM(ID2),NDEB(500),NBO(99),
     * NAD(2000),KT(2000),INDIC(ID2),JNDIC(ID2),LNDIC(ID2)
      INTEGER*2 INDIC,JNDIC,LNDIC,NAD,KT,NOMS(ID1,20)
      EQUIVALENCE (F(1),NOMS(1,1))
      common/caratte/cara1,cara2
      character*1 cara1,cara2
      common /toul/ ztoul
! supprime par daniel      cara1=char(-1)
      cara2=char(0)
      if (id1.ne.jd1) then
      write (6,*) '   ATTENTION: LA DIMENSION ID1 N''EST PAS LA MEME'
      write (6,*) '   DANS REIJKL ET DANS LE PROGRAMME PRINCIPAL'
      stop 12
      endif
      k28=id2*8
      if (id1*20*2.gt.k28) then
      write (6,*) '   ERREUR DIMENSIONS DANS REIJKL (EQUIV. F-NOMS)'
      stop 12
      endif
      rewind 25
      READ (25) NSYM,NORB,NOC,NDEGEN,(ITSYM(I),I=1,NORB)
      READ (25) ((ITS(I,J),I=1,NSYM),J=1,NSYM)
      IJ=0
      NUM(1)=0
      DO 1 I=2,ID1
      DO 1 J=1,I
      IJ=IJ+1
    1 NUM(IJ+1)=NUM(IJ)+IJ
      DO 801 I=1,NSYM
  801 NOS(I)=0
      DO 802 I=1,NORB
      IS=ITSYM(I)
      DO 803 J=1,I
      JS=ITSYM(J)
      IJS=ITS(IS,JS)
      NOS(IJS)=NOS(IJS)+1
      IJ=NUM(I)+J
      INDIC(IJ)=IJS
  803 JNDIC(IJ)=NOS(IJS)
  802 CONTINUE
      NDEB(1)=0
      NSM1=NSYM-1
      DO 804 K=1,NSM1
      KP1=K+1
      if (kp1.gt.500) then
	 write (6,*) ' errore, KP1 =',kp1
	 stop 12
      endif
  804 NDEB(KP1)=NDEB(K)+(NOS(K)*(NOS(K)+1))/2
      NIJKL=NDEB(NSYM)+(NOS(NSYM)*(NOS(NSYM)+1))/2
      NJP=0
      DO 820 IS=1,NSYM
      DO 820 JS=1,IS
      NJP=NJP+1
      if (njp.gt.2000) then
	 write (6,*) ' errore, NJP =',njp
	 stop 12
      endif
      IF(JS.EQ.IS)GOTO 821
      NAD(NJP)=0
      KT(NJP)=0
      GOTO 820
  821 NAD(NJP)=IS
      KT(NJP)=1
  820 CONTINUE
      NSYT=NJP
      if (zhandy) then
         if(.not.zthree)then
            ni2=nijkl
            nr4=25534
            ni4=1
            ni3=1
            WRITE (6,74) NIJKL,2
         else
            ni3=nijkl
            nr4=1
            ni4=1
            ni2=1
            write (6,74) nijkl,3
            if (zfac) then
c_toul
               if (ztoul) then
               call intmaxt(bigint,norb,nsym,nos)
               else
               call intmax(bigint,norb,nsym,nos)
               endif
c_toul         
               print'(''     MAXIMUM INTEGRAL IS '',D10.4)',bigint
               factor=8388607.d0/bigint
            endif
           print'(''     FACTOR WILL BE '',D10.4)',factor
         endif
      else
         ni2=1
         nr4=1
         ni3=1
         ni4=nijkl
         WRITE (6,74) NIJKL,4
         if (zfac) then
c_toul
               if (ztoul) then
               call intmaxt(bigint,norb,nsym,nos)
               else
               call intmax(bigint,norb,nsym,nos)
               endif
c_toul         
            print'(''     MAXIMUM INTEGRAL IS '',D10.4)',bigint
cele         factor=2147483647.d0/bigint
            factor=2147483646.d0/bigint
         endif
         print'(''     FACTOR WILL BE '',D10.4)',factor
      endif
   74 FORMAT (//5X,'DIMENSION DU TABLEAU IJKL:',I10,' *',i1,' BYTES')
      RETURN
      END
C***********************************************************************
      SUBROUTINE intmax(bigint,norb,nsym,nos)
C 
C     trova l'integrale piu' grande
C 
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      PARAMETER(MBUF=3255,NBUF=4096)
      COMMON /HND/ ZHANDY,ZTHREE,zmotra,zfac
      COMMON /INT/ NI4,NI3,NI2,NR4,
     * F(ID2),AJ(ID2),AK(ID2),NUM(ID2),NDEB(500),NBO(99),
     * NAD(2000),KT(2000),INDIC(ID2),JNDIC(ID2),LNDIC(ID2)
      INTEGER*2 INDIC,JNDIC,LNDIC,NAD,KT,NOMS(ID1,20)
      DIMENSION NOS(20),XX(MBUF),IX(MBUF),XXm(NBUF),IXm(NBUF)
      EQUIVALENCE (F(1),NOMS(1,1)),(AJ(1),XX(1))
      bigint=0.d0
      k22=id2*2
      if (nbuf.gt.k22) then
      write (6,*) '   *** ERREUR DIMENSIONS DANS INTMAX ***'
      stop
      endif
      WRITE (6,1000)
 1000 FORMAT (5X,'LECTURE DES INTEGRALES')
      REWIND 50
      if (.not.zmotra) READ (50) FACDUM
   20 if (zmotra) then
         READ(50)XXm,IXm
         do n=1,nbuf
         lab=ixm(N)
         if (lab.eq.0) return
         A8=abs(XX(N))
         if (a8.gt.bigint) bigint=a8
         enddo
      else
         READ(50)XX,IX
         do n=1,mbuf
         lab=ix(N)
         if (lab.eq.0) return
         A8=abs(XX(N))
         if (a8.gt.bigint) bigint=a8
         enddo
      endif
      goto 20
      END
C***********************************************************************
      SUBROUTINE intmaxt(bigint,norb,nsym,nos)
C
C     trova l'integrale piu' grande
C
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      PARAMETER(MBUF=3255,NBUF=4096)
      COMMON /HND/ ZHANDY,ZTHREE,zmotra,zfac
      COMMON /INT/ NI4,NI3,NI2,NR4,
     * F(ID2),AJ(ID2),AK(ID2),NUM(ID2),NDEB(500),NBO(99),
     * NAD(2000),KT(2000),INDIC(ID2),JNDIC(ID2),LNDIC(ID2)
      INTEGER*2 INDIC,JNDIC,LNDIC,NAD,KT,NOMS(ID1,20)
      DIMENSION NOS(20),XX(MBUF),XXm(NBUF)
      EQUIVALENCE (F(1),NOMS(1,1)),(AJ(1),XX(1))
      integer*2 ind(4096),jnd(4096),knd(4096),lnd(4096)

      bigint=0.d0
      k22=id2*2
      if (nbuf.gt.k22) then
      write (6,*) '   *** ERREUR DIMENSIONS DANS INTMAX ***'
      stop
      endif
      WRITE (6,1000)
 1000 FORMAT (5X,'LECTURE DES INTEGRALES')
      REWIND 50
c   20 READ(50)chin,chin,chin,chin,xxm
   20 read(50)ind,jnd,knd,lnd,xxm
         do n=1,nbuf
         lab=knd(n)
         if (lab.eq.0) return
         a8=abs(xxm(n))
         if (a8.gt.bigint) bigint=a8
         enddo
      goto 20
      END       
C***********************************************************************
      SUBROUTINE ITIJKL(factor,norb,nsym,nos,nijkl,ijkl4,
     * ijkl2,rijkl,ijkl3)
C 
C     LECTURE DES INTEGRALES BIELECTRONIQUES
C 
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      PARAMETER(MBUF=3255,NBUF=4096)
c     character*2000 namel
      common /hst/ host
      character*8 host
      dimension ijkl4(*)
      integer*2 ijkl2(*)
      character*3 ijkl3(*)
      character*4 cara
      character*1 pivec(4),pivec2(4)
      equivalence (itamp,pivec2(1))
      equivalence (jtamp,pivec(1))
      equivalence (idummy,cara)
      real*4 rijkl(*)
      COMMON /HND/ ZHANDY,ZTHREE,zmotra,zfac
      COMMON /MOTRA/ NAOCSYM(8),NAVISYM(8),NINASYM(8),NPERM(id1)
      COMMON /INT/ NI4,NI3,NI2,NR4,
     * F(ID2),AJ(ID2),AK(ID2),NUM(ID2),NDEB(500),NBO(99),
     * NAD(2000),KT(2000),INDIC(ID2),JNDIC(ID2),LNDIC(ID2)
      INTEGER*2 INDIC,JNDIC,LNDIC,NAD,KT,NOMS(ID1,20)
      DIMENSION NOS(20),XX(MBUF),IX(MBUF),XXm(NBUF),IXm(NBUF)
      EQUIVALENCE (F(1),NOMS(1,1)),(AJ(1),XX(1))
      idummy=0
      k22=id2*2
      if (mbuf.gt.k22) then
      write (6,*) '   *** ERREUR DIMENSIONS DANS ITIJKL ***'
      stop
      endif
      WRITE (6,1000)
 1000 FORMAT (5X,'LECTURE DES INTEGRALES')
c      if (host.eq.'        ') call getenv('HOSTTYPE',host)
c      if (host.eq.'       ') call getenv('HOSTNAME',host)
      call getenv('HOSTTYPE',host)
      write (6,'(a,a)') '    HOSTTYPE=',host
      if (.not.zmotra) write (6,*) '    INTEGRALI DA HONDO + IJKLPI'
      if (zmotra) write (6,*) '    INTEGRALI DA MOLCAS + MOTRA'
      do 500 k=1,ni2
 500     ijkl2(k)=0
      do 501 k=1,ni4
 501     ijkl4(k)=0
      do k=1,ni3
         ijkl3(k)=cara(2:4)
      enddo
      khan=0
      REWIND 50
      if (.not.zmotra) READ (50) FACDUM
      WRITE (6,10) FACTOR
   10 FORMAT (5X,'INTEGRAL PREFACTOR =',D15.2)
      NNT=NUM(NORB)+NORB
      NTT=NDEB(NSYM)+(NOS(NSYM)*(NOS(NSYM)+1))/2
      M=0
      N=1
      if (.not.zmotra) then
      READ(50)XX,IX
      DO 820 I=1,NORB
      II=NUM(I)
      DO 820 J=1,I
      IJ=II+J
      IJS=INDIC(IJ)
      IJP=JNDIC(IJ)
      DO 830 K=1,I
      LMAX=K
      IF(K.EQ.I)LMAX=J
      KK=NUM(K)
      DO 830 L=1,LMAX
      KL=KK+L
      KLS=INDIC(KL)
      M=M+1
      IF(KLS.NE.IJS) GO TO 830
      KLP=JNDIC(KL)
  831 LAB=IX(N)
      IF(LAB.EQ.0)GOTO 860
      IF(LAB.GT.M)GOTO 830
      N1=MAX0(IJP,KLP)
      N2=MIN0(IJP,KLP)
      NA=NUM(N1)+N2+NDEB(KLS)
      A8=XX(N)*factor
c      write (6,*) '0',xx(n),i,j,k,l
      CALL HANDY(NA,A8,KHAN,ZHANDY,zthree,ijkl4,ijkl3,ijkl2,rijkl)
c     CALL HANDY(NA,A8,KHAN,ZHANDY)
      N=N+1
      IF(N.LE.MBUF)GOTO 830
      READ(50)XX,IX
      N=1
  830 CONTINUE
  820 CONTINUE
      else
      READ(50)XXm,IXm
  821 itamp=0
      jtamp=ixm(n)
c  ... DEC
      if (host.eq.'alpha   '.or.host.eq.'ALPHA   '.or.
     *    host.eq.'   alpha'.or.host.eq.'   ALPHA') then
      pivec2(1)=pivec(4)
      i=itamp
      pivec2(1)=pivec(3)
      j=itamp
      pivec2(1)=pivec(2)
      k=itamp
      pivec2(1)=pivec(1)
      l=itamp
c  ... AIX
      else
      pivec2(4)=pivec(4)
      i=itamp
      pivec2(4)=pivec(3)
      j=itamp
      pivec2(4)=pivec(2)
      k=itamp
      pivec2(4)=pivec(1)
      l=itamp
      endif
      i=nperm(i)
      j=nperm(j)
      k=nperm(k)
      l=nperm(l)
      if (i.lt.j) then
      itamp=i
      i=j
      j=itamp
      endif
      if (k.lt.l) then
      itamp=k
      k=l
      l=itamp
      endif
c      write (6,*) '2',n,xxm(n),i,j,k,l
      II=NUM(i)
      IJ=II+J
      KK=NUM(K)
      KL=KK+L
      if (ij.lt.kl) then
      itamp=ij
      ij=kl
      kl=itamp
      endif
c      write (6,*) 'ij,kl',ij,kl
      IJS=INDIC(IJ)
      IJP=JNDIC(IJ)
      KLS=INDIC(KL)
c      write (6,*) 'inic',(indic(icel),icel=1,10)
c      write (6,*) 'nperm',(nperm(icel),icel=1,7)
      IF(KLS.NE.IJS) then
      print * ,'Attenzione errore in ITIJKL'
      print * ,'KLS,IJS',KLS,IJS
      endif
      KLP=JNDIC(KL)
      LAB=IXm(N)
      IF(LAB.EQ.0)GOTO 860
      N1=MAX0(IJP,KLP)
      N2=MIN0(IJP,KLP)
      NA=NUM(N1)+N2+NDEB(KLS)
      A8=XXm(N)*factor
      CALL HANDY(NA,A8,KHAN,ZHANDY,zthree,ijkl4,ijkl3,ijkl2,rijkl)
c     CALL HANDY(NA,A8,KHAN,ZHANDY)
      IF(N.Lt.NBUF) then
      N=N+1
      goto 821
      endif
      READ(50)XXm,IXm
      N=1
      goto 821
      endif
  860 RETURN
      return
      END
C***********************************************************************
      SUBROUTINE ITIJKLt(factor,norb,nsym,nos,nijkl,ijkl4,
     * ijkl2,rijkl,ijkl3)
C 
C     LECTURE DES INTEGRALES BIELECTRONIQUES
C 
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      PARAMETER(NBUF=4096)
c     character*2000 namel
      common /hst/ host
      character*8 host
      dimension ijkl4(*)
      integer*2 ijkl2(*)
      character*3 ijkl3(*)
      character*4 cara
      character*1 pivec2(4)
      equivalence (itamp,pivec2(1))
      equivalence (idummy,cara)
      real*4 rijkl(*)
      COMMON /HND/ ZHANDY,ZTHREE,zmotra,zfac
      COMMON /MOTRA/ NAOCSYM(8),NAVISYM(8),NINASYM(8),NPERM(id1)
      COMMON /INT/ NI4,NI3,NI2,NR4,
     * F(ID2),AJ(ID2),AK(ID2),NUM(ID2),NDEB(500),NBO(99),
     * NAD(2000),KT(2000),INDIC(ID2),JNDIC(ID2),LNDIC(ID2)
      INTEGER*2 INDIC,JNDIC,LNDIC,NAD,KT,NOMS(ID1,20)
      DIMENSION NOS(20),XXm(NBUF)
      EQUIVALENCE (F(1),NOMS(1,1))
c_toul
      integer*2 ind(4096),jnd(4096),knd(4096),lnd(4096)
c_toul
      idummy=0
      k22=id2*2
      if (nbuf.gt.k22) then
      write (6,*) '   *** ERREUR DIMENSIONS DANS ITIJKLt ***'
      stop
      endif
      WRITE (6,1000)
 1000 FORMAT (5X,'LECTURE DES INTEGRALES')
      if (host.eq.'        ') call getenv('HOSTTYPE',host)
      write (6,*) '    HOSTTYPE=',host
      write (6,*) '    INTEGRALI LETTI CON IL FORMALISMO DI TOLOSA'
      do 500 k=1,ni2
 500     ijkl2(k)=0
      do 501 k=1,ni4
 501     ijkl4(k)=0
      do k=1,ni3
         ijkl3(k)=cara(2:4)
      enddo
      khan=0
      REWIND 50
      WRITE (6,10) FACTOR
   10 FORMAT (5X,'INTEGRAL PREFACTOR =',D15.2)
      NNT=NUM(NORB)+NORB
      NTT=NDEB(NSYM)+(NOS(NSYM)*(NOS(NSYM)+1))/2
      M=0
      N=1
c   5  READ(50)chin1,chin2,chin3,chin4,xxm
   5  read(50)ind,jnd,knd,lnd,xxm
      do indn=1,nbuf
c      i=ichar(chin1(indn))
c      j=ichar(chin2(indn))
c      k=ichar(chin3(indn))
c      l=ichar(chin4(indn))
c      if (i.lt.0) i=i+256
c      if (j.lt.0) j=j+256
c      if (k.lt.0) k=k+256
c      if (l.lt.0) l=l+256
      i=ind(indn)
      j=jnd(indn)
      k=knd(indn)
      l=lnd(indn)
      if (k.eq.0) return
      II=NUM(i)
      IJ=II+J
      KK=NUM(K)
      KL=KK+L
      if (ij.lt.kl) then
      itamp=ij
      ij=kl
      kl=itamp
      endif
c      write (6,*) 'ij,kl',ij,kl
      IJS=INDIC(IJ)
      IJP=JNDIC(IJ)
      KLS=INDIC(KL)
c      write (6,*) 'inic',(indic(icel),icel=1,10)
c      write (6,*) 'nperm',(nperm(icel),icel=1,7)
      IF(KLS.NE.IJS) then
      print * ,'Attenzione errore in ITIJKL'
      print * ,'KLS,IJS',KLS,IJS
      endif
      KLP=JNDIC(KL)
      N1=MAX0(IJP,KLP)
      N2=MIN0(IJP,KLP)
      NA=NUM(N1)+N2+NDEB(KLS)
      A8=XXm(indn)*factor
c      write (6,7) indn,xxm(indn),i,j,k,l,a8
      CALL HANDY(NA,A8,KHAN,ZHANDY,zthree,ijkl4,ijkl3,ijkl2,rijkl)
c     CALL HANDY(NA,A8,KHAN,ZHANDY)
      enddo
      goto 5
    7 format (i4,F12.8,4I4,F20.2)
   12 NTER=NORB*(NORB+1)/2
      nfind=4096-indn
   11 if (nfind.ge.nter) return
      read (50)
      nfind=nfind+4096
      goto 11  
      END
C***********************************************************************
      SUBROUTINE HANDY(I,A8,khan,zhandy,zthree,ijkl4,ijkl3,ijkl2,rijkl)
C 
C     STOCKAGE DES INTEGRALES A LA HANDY (N.C.HANDY, CHEM.PHYS.LETT.
C     74, 280 (1980))
C 
      integer*2 ijkl2(*)
      real*4 rijkl(*)
      character*3 ijkl3(*)
      dimension ijkl4(*)
      logical*1 zhandy,zthree
      character*4 cara
      equivalence (idummy,cara)
      REAL*8 A8
      if (zhandy) then
         A=A8
         if(.not.zthree)then
            IF (ABS(A).GT.20000.) GOTO 10
            IJKL2(I)=A
            RETURN
 10         KHAN=KHAN+1
            IF (KHAN.GT.25534) then
 20            WRITE (6,30)
 30       FORMAT (//5X,'TOO MANY INTEGRALS > 20000, DECREASE FACTOR'//)
               STOP 12
            endif
            RIJKL(KHAN)=A
            IF (KHAN.GT.12767) GOTO 15
            IJKL2(I)=KHAN+20000
            RETURN
 15         IJKL2(I)=-KHAN-7233
            RETURN
         else
            idummy=a
            if(idummy.gt.8388607)then
               print*,' Un integrale troppo grande ',idummy
               print*,' Il massimo si ha con 8388607'
               print*,' Riduci FACTOR'
               stop 'riduci factor'
            endif
            ijkl3(i)=cara(2:4)
         endif
      else
C
C     Aumento di 1 il max intero 2147483647 per sicurezza
c
         if (abs(a8).gt.2147483648.d0) then
            write (6,40)
            STOP 12
         endif
 40      format (//5X,'INTEGRAL OVERFLOW, DECREASE FACTOR'//)
         ijkl4(i)=nint(a8)
         return
      endif
      END
C***********************************************************************
      FUNCTION AI(I,J,K,L)
C
C     REPERAGE DE L'INTEGRALE BIELECTRONIQUE IJKL DANS LE TABLEAU IJKL2
C
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      COMMON /HND/ ZHANDY,ZTHREE,zmotra,zfac
      COMMON /INT/ NI4,NI3,NI2,NR4,
     * F(ID2),AJ(ID2),AK(ID2),NUM(ID2),NDEB(500),NBO(99),
     * NAD(2000),KT(2000),INDIC(ID2),JNDIC(ID2),LNDIC(ID2)
      INTEGER*2 INDIC,JNDIC,LNDIC,NAD,KT
      COMMON /MEM/ MEMSIZ,LOFFS,LOCMEM,LOCM1,LOCM2,LOCM3,LOCM4,LOCM(6)
      integer pick3
      pointer ijkl2(:),ijkl4(:),ijkl3(:),rijkl(:)
      common /big/ ijkl2,ijkl4,ijkl3,rijkl
      integer*2 ijkl2
      character*3,ijkl3
      real*4 rijkl
      IF (I.GE.J) GO TO 10
      IJ=NUM(J)+I
      GO TO 15
   10 IJ=NUM(I)+J
   15 IF (K.GE.L) GO TO 20
      KL=NUM(L)+K
      GO TO 25
   20 KL=NUM(K)+L
   25 IJS=INDIC(IJ)
      KLS=INDIC(KL)
      IF (IJS.LE.KLS) GO TO 30
      IJKLS=NUM(IJS)+KLS
      GO TO 35
   30 IJKLS=NUM(KLS)+IJS
      NIJ=IJ
      IJ=KL
      KL=NIJ
      IJS=KLS
      KLS=INDIC(KL)
   35 CONTINUE
      IF (NAD(IJKLS)) 40,300,45
   40 ZSIG=.TRUE.
      NADI=-NAD(IJKLS)
      GO TO 50
   45 ZSIG=.FALSE.
      NADI=NAD(IJKLS)
   50 KTYP=KT(IJKLS)
      GO TO (60,70,75,80,85,90,95,100,105,62),KTYP
   62 NIJ=LNDIC(IJ)
      NKL=LNDIC(KL)
      GO TO 63
   60 NIJ=JNDIC(IJ)
      NKL=JNDIC(KL)
   63 IF (NIJ.LE.NKL) GO TO 65
      IJKL=NUM(NIJ)+NKL
      GO TO 200
   65 IJKL=NUM(NKL)+NIJ
      GO TO 200
   70 NIJ=JNDIC(IJ)
      NKL=JNDIC(KL)
      IJKL=NBO(KLS)*(NIJ-1)+NKL
      GO TO 200
   75 NIJ=LNDIC(IJ)
      NKL=JNDIC(KL)
      IJKL=NBO(KLS)*(NIJ-1)+NKL
      GO TO 200
   80 NIJ=JNDIC(IJ)
      NKL=LNDIC(KL)
      IJKL=NBO(KLS)*(NIJ-1)+NKL
      GO TO 200
   85 NIJ=LNDIC(IJ)
      NKL=LNDIC(KL)
      IJKL=NBO(KLS)*(NIJ-1)+NKL
      GO TO 200
   90 NIJ=JNDIC(IJ)
      NKL=JNDIC(KL)
      IJKL=NBO(IJS)*(NKL-1)+NIJ
      GO TO 200
   95 NIJ=LNDIC(IJ)
      NKL=JNDIC(KL)
      IJKL=NBO(IJS)*(NKL-1)+NIJ
      GO TO 200
  100 NIJ=JNDIC(IJ)
      NKL=LNDIC(KL)
      IJKL=NBO(IJS)*(NKL-1)+NIJ
      GO TO 200
  105 NIJ=LNDIC(IJ)
      NKL=LNDIC(KL)
      IJKL=NBO(IJS)*(NKL-1)+NIJ
  200 NNJK=NDEB(NADI)+IJKL
      if (zhandy) then
         if(.not.zthree)then
      AI=PICK2(nnjk,ijkl2,rijkl)
      else
         ai=pick3(nnjk,ijkl3)
         endif
      else
      AI=PICK4(nnjk,ijkl4)
      endif
      IF (ZSIG) AI=-AI
      RETURN
  300 AI=0.D0
      RETURN
      END
C***********************************************************************
      FUNCTION PICK2(NNJK,IJKL2,RIJKL)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      integer*2 ijkl2(*)
      real*4 rijkl(*)
      LAI=IJKL2(NNJK)
      IF (LAI.GT.20000) then
      PICK2=RIJKL(LAI-20000)
      ELSEIF (LAI.LT.-20000) then
      PICK2=RIJKL(-LAI-7233)
      ELSE
      PICK2=DBLE(LAI)
      endif
      return
      END
C***********************************************************************
      FUNCTION PICK4(NNJK,IJKL4)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      dimension ijkl4(*)
      PICK4=ijkl4(nnjk)
      return
      END
C***********************************************************************
      integer FUNCTION PICK3(NNJK,IJKL3)
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      character*3 ijkl3
      dimension ijkl3(*)
      common/caratte/c1,c2
      character*1 c1,c2
      character*4 cara
c     integer*2 i2
      equivalence (idummy,cara)
      equivalence (z2,cara(2:2))
c c1=char(-1),c2=char(0)      
      cara(2:4)=ijkl3(nnjk)
      if (z2) then
         cara(1:1)=c2
      else
         cara(1:1)=c1
      endif
      pick3=idummy
      return
      END
C***********************************************************************
      SUBROUTINE itijkl_int(factor,norb,nact,ncore,ain)
C 
C     LECTURE DES INTEGRALES BIELECTRONIQUES
C 
      IMPLICIT REAL*8(A-H,O-Y),LOGICAL*1(Z)
      include 'cippi.prm'
      common /hst/ host
      character*8 host
      dimension ain(norb,ncore+nact,ncore+nact,ncore+nact)
      DIMENSION XXm(4096)
c_toul
      integer*2 ind(4096),jnd(4096),knd(4096),lnd(4096)
c_toul
 1000 FORMAT (5X,'LECTURE DES INTEGRALES')
      if (host.eq.'        ') call getenv('HOSTTYPE',host)
      write (6,*) '    HOSTTYPE=',host
      write (6,*) '    INTEGRALI LETTI CON IL FORMALISMO DI TOLOSA'

      REWIND 50
      WRITE (6,10) FACTOR
   10 FORMAT (5X,'INTEGRAL PREFACTOR =',D15.2)
      nca=ncore+nact

      write (6,*) 'Sono in reijkl',nca,norb,ncore,nact
      call flush(6)
   5  read(50)ind,jnd,knd,lnd,xxm
      do indn=1,4096
      i=ind(indn)
      j=jnd(indn)
      k=knd(indn)
      l=lnd(indn)
      if (k.eq.0) return
      A8=XXm(indn)*factor
      if ((i.le.nca).and.(j.le.nca).and.(k.le.nca).and.(l.le.nca)) then
      ain(i,j,k,l)=a8
      ain(i,j,l,k)=a8
      ain(j,i,k,l)=a8
      ain(j,i,l,k)=a8
      ain(k,l,i,j)=a8
      ain(l,k,i,j)=a8
      ain(k,l,j,i)=a8
      ain(l,k,j,i)=a8
c      write (6,*) 'storo 1',i,j,k,l,a8      
c      call flush(6)
      cycle
      endif
      if (j.le.nca.and.k.le.nca.and.l.le.nca) then
      ain(i,j,k,l)=a8
      ain(i,j,l,k)=a8
c      write (6,*) 'storo 2',i,j,k,l,a8      
c      call flush(6)
      cycle
      endif
      if (i.le.nca.and.k.le.nca.and.l.le.nca) then
      ain(j,i,k,l)=a8
      ain(j,i,l,k)=a8
c      write (6,*) 'storo 3',i,j,k,l,a8      
c      call flush(6)
      cycle
      endif
      if (i.le.nca.and.j.le.nca.and.l.le.nca) then
      ain(k,l,i,j)=a8
      ain(k,l,j,i)=a8
c      write (6,*) 'storo 4',i,j,k,l,a8      
c      call flush(6)
      cycle
      endif
      if (i.le.nca.and.j.le.nca.and.k.le.nca) then
      ain(l,k,i,j)=a8
      ain(l,k,j,i)=a8
c      write (6,*) 'storo 5',i,j,k,l,a8      
c      call flush(6)
      cycle
      endif
   
      enddo
      goto 5

      return
      END
