************************************************************************
* This file is part of OpenMolcas.                                     *
*                                                                      *
* OpenMolcas is free software; you can redistribute it and/or modify   *
* it under the terms of the GNU Lesser General Public License, v. 2.1. *
* OpenMolcas is distributed in the hope that it will be useful, but it *
* is provided "as is" and without any express or implied warranties.   *
* For more details see the full text of the license in the file        *
* LICENSE or in <http://www.gnu.org/licenses/>.                        *
************************************************************************
*PAM04      SUBROUTINE SORT (BUFOUT,INDOUT,FC,FIIJJ,FIJIJ,NINTGR)
      SUBROUTINE SORT_MRCI (BUFS,INDS,FC,FIIJJ,FIJIJ,NINTGR)
      IMPLICIT REAL*8 (A-H,O-Z)
      INTRINSIC ABS,LOG10
#include "SysDef.fh"
#include "warnings.fh"
#include "mrci.fh"
c      DIMENSION BUFOUT(NBSIZ3,NCHN3)
c      DIMENSION INDOUT(RTOI*NBSIZ3,NCHN3)
*PAM04      DIMENSION BUFOUT(*)
*PAM04      DIMENSION INDOUT(*)
      DIMENSION BUFS(NBITM3,NCHN3)
      DIMENSION INDS(NBITM3+2,NCHN3)
      DIMENSION FC(NBTRI),FIIJJ(*),FIJIJ(*)
      DIMENSION IVEC(20),IPOF(65)
      DIMENSION NORB0(9)
      IAD50=0
      CALL iDAFILE(LUTRA,2,iTraToc,nTraToc,IAD50)
      NVT=IROW(NVIRT+1)
      DO 50 I=1,20
        IVEC(I)=0
50    CONTINUE
      IN=1
      DO 3 I=1,NSYM
        CALL IPO(IPOF(IN),NVIR,MUL,NSYM,I,-1)
        IN=IN+NSYM
3     CONTINUE
C ORDER OF RECORD-CHAINS IS
C 1.  NOT2 CHAINS (AB/IJ)
C 2.  NOT2 CHAINS (AI/BJ)
C 3.  NOT2 CHAINS (AI/JK)
C RECORD STRUCTURE IS
C 1.  NBITM3 INTEGRALS
C 2.  NBITM3 INDICES
C 3.  NUMBER OF INTEGRALS IN THIS RECORD
C 4.  ADDRESS OF LAST RECORD
      NOT2=IROW(LN+1)
      NOTT=2*NOT2
      NOVST=LN*NVIRT+1+NVT
      IDISK=0
CPAM97 The portable code should then be:
*PAM04      NBITM3=(RTOI*NBSIZ3-2)/(RTOI+1)
*PAM04      IBOFF3=RTOI*NBITM3
*PAM04      IBBC3=IBOFF3+NBITM3+1
*PAM04      IBDA3=IBBC3+1

      DO 5 IREC=1,NCHN3
*PAM04        INDOUT(IBBC3+(IREC-1)*RTOI*NBSIZ3)= 0
*PAM04        INDOUT(IBDA3+(IREC-1)*RTOI*NBSIZ3)=-1
        INDS(NBITM3+1,IREC)=0
        INDS(NBITM3+2,IREC)=-1
5     CONTINUE
      NORB0(1)=0
      DO 2 I=1,NSYM
        NORB0(I+1)=NORB0(I)+NORB(I)
2     CONTINUE
C READ ONE-ELECTRON ORBITALS. USE FIIJJ TEMPORARILY AS READ BUFFER.
      NORBTT=0
      DO 7654 ISYM=1,nsym
        NORBTT=NORBTT+(NORB(ISYM)*(NORB(ISYM)+1))/2
 7654 CONTINUE
      EFROZ=POTNUC
      CALL FZERO(FC,NBTRI)
      IADD17=ITOC17(2)
      CALL dDAFILE(LUONE,2,FIIJJ,NORBTT,IADD17)
      IBUF=0
      KORBI=0
      DO 200 ISYM=1,NSYM
        DO 199 JORBI=KORBI+1,KORBI+NORB(ISYM)
          DO 198 IORBI=KORBI+1,JORBI
            IBUF=IBUF+1
            ONEHAM=FIIJJ(IBUF)
            NI=ICH(IORBI)
            NJ=ICH(JORBI)
            IF(NI.EQ.0.OR.NJ.EQ.0)GO TO 198
            IF(NI.LT.NJ) THEN
              NTMP=NI
              NI=NJ
              NJ=NTMP
            END IF
            IF(NJ.GT.0) THEN
              IJT=IROW(NI)+NJ
              FC(IJT)=FC(IJT)+ONEHAM
            ELSE IF(NI.EQ.NJ) THEN
              EFROZ=EFROZ+2*ONEHAM
            END IF
198       CONTINUE
199     CONTINUE
        KORBI=KORBI+NORB(ISYM)
200   CONTINUE
      IF(IPRINT.GE.20) THEN
         CALL TRIPRT('FC IN SORT_MRCI BEFORE TWOEL',' ',FC,NORBT)
         WRITE(6,'(A,F20.8)') ' EFROZ:',EFROZ
      CALL XFLUSH(6)
      END IF
      CALL FZERO(FIIJJ,NBTRI)
      CALL FZERO(FIJIJ,NBTRI)
C TWO-ELECTRON INTEGRALS
      DO 313 NSP=1,NSYM
      NOP=NORB(NSP)
      DO 312 NSQ=1,NSP
      NSPQ=MUL(NSP,NSQ)
      NOQ=NORB(NSQ)
      DO 311 NSR=1,NSP
      NSPQR=MUL(NSPQ,NSR)
      NOR=NORB(NSR)
      NSSM=NSR
      IF(NSR.EQ.NSP)NSSM=NSQ
      DO 310 NSS=1,NSSM
      IF(NSS.NE.NSPQR)GO TO 310
      NOS=NORB(NSS)
      NORBP=NOP*NOQ*NOR*NOS
      IF(NORBP.EQ.0)GO TO 310
      CALL dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50)
      IOUT=0
      DO 309 NV=1,NOR
      NXM=NOS
      IF(NSR.EQ.NSS)NXM=NV
      DO 308 NX=1,NXM
      NTM=1
      IF(NSP.EQ.NSR)NTM=NV
      DO 307 NT=NTM,NOP
      NUMIN=1
      IF(NSP.EQ.NSR.AND.NT.EQ.NV)NUMIN=NX
      NUMAX=NOQ
      IF(NSP.EQ.NSQ)NUMAX=NT
      DO 306 NU=NUMIN,NUMAX
      IOUT=IOUT+1
      IF(IOUT.GT.NTIBUF) THEN
         CALL dDAFILE(LUTRA,2,TIBUF,NTIBUF,IAD50)
         IOUT=1
      END IF
      M1=ICH(NORB0(NSP)+NT)
      M2=ICH(NORB0(NSQ)+NU)
      M3=ICH(NORB0(NSR)+NV)
      M4=ICH(NORB0(NSS)+NX)
      IF(M1.EQ.0.OR.M2.EQ.0)GO TO 306
      IF(M3.EQ.0.OR.M4.EQ.0)GO TO 306
C ORDER THESE INDICES CANONICALLY
      N1=M1
      N2=M2
      IF(M1.GT.M2)GO TO 11
      N1=M2
      N2=M1
11    N3=M3
      N4=M4
      IF(M3.GT.M4)GO TO 12
      N3=M4
      N4=M3
12    NI=N1
      NJ=N2
      NK=N3
      NL=N4
      IF(NI.GT.NK)GO TO 502
      IF(NI.EQ.NK)GO TO 14
      NI=N3
      NJ=N4
      NK=N1
      NL=N2
      GO TO 502
14    IF(NJ.GT.NL)GO TO 502
      NL=N2
      NJ=N4
502   FINI=TIBUF(IOUT)
      IF(NI.LE.0 .OR. NJ.LE.0)GO TO 41
      IF(NK.LE.0 .OR. NL.LE.0)GO TO 41
      DFINI=ABS(FINI)+1.D-20
      IEXP=INT(-LOG10(DFINI))+5
      IF(IEXP.LE.20)IVEC(IEXP)=IVEC(IEXP)+1
      IF(NI.NE.NJ.OR.NK.NE.NL)GO TO 42
      IJ=IROW(NI)+NK
      FIIJJ(IJ)=FINI
C SKIP (AA/II) INTEGRALS
      GO TO 306
42    IF(NI.NE.NK.OR.NJ.NE.NL)GO TO 43
      IJ=IROW(NI)+NJ
      FIJIJ(IJ)=FINI
43    IF(NI.LE.LN)GO TO 306
      IF(NJ.GT.LN)GO TO 102
      IF(NK.GT.LN)GO TO 103
C AIJK
      JK=NOTT+IROW(NK)+NL
*PAM04      IPOS=INDOUT(IBBC3+(JK-1)*RTOI*NBSIZ3)+1
*PAM04      INDOUT(IBBC3+(JK-1)*RTOI*NBSIZ3)=IPOS
      IPOS=INDS(NBITM3+1,JK)+1
      INDS(NBITM3+1,JK)=IPOS
c      BUFOUT(IPOS,JK)=FINI
*PAM04      BUFOUT(IPOS+(JK-1)*NBSIZ3)=FINI
      BUFS(IPOS,JK)=FINI
*PAM04      INDOUT(IBOFF3+IPOS+(JK-1)*RTOI*NBSIZ3)=IROW(NI)+NJ
      INDS(IPOS,JK)=IROW(NI)+NJ
      IF(IPOS.LT.NBITM3)GO TO 306
      JDISK=IDISK
*PAM04      CALL dDAFILE(Lu_60,1,INDOUT(1+(JK-1)*RTOI*NBSIZ3),NBSIZ3,IDISK)
      CALL iDAFILE(Lu_60,1,INDS(1,JK),NBITM3+2,IDISK)
      CALL dDAFILE(Lu_60,1,BUFS(1,JK),NBITM3,IDISK)
*PAM04      INDOUT(IBBC3+(JK-1)*RTOI*NBSIZ3)=0
*PAM04      INDOUT(IBDA3+(JK-1)*RTOI*NBSIZ3)=JDISK
      INDS(NBITM3+1,JK)=0
      INDS(NBITM3+2,JK)=JDISK
      GO TO 306
103   IF(NL.GT.LN)GO TO 306
C AIBJ
      IIJ=NOT2+IROW(NJ)+NL
      IF(NL.GT.NJ)IIJ=NOT2+IROW(NL)+NJ
*PAM04      IPOS=INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)+1
*PAM04      INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)=IPOS
      IPOS=INDS(NBITM3+1,IIJ)+1
      INDS(NBITM3+1,IIJ)=IPOS
c      BUFOUT(IPOS,IIJ)=FINI
*PAM04      BUFOUT(IPOS+(IIJ-1)*NBSIZ3)=FINI
      BUFS(IPOS,IIJ)=FINI
      NSA=NSM(NI)
      NAV=NI-LN-NVIRP(NSA)
      NSB=NSM(NK)
      NBV=NK-LN-NVIRP(NSB)
      NSIJT=(MUL(NSM(NJ),NSM(NL))-1)*NSYM
      IF(NL.GT.NJ)GO TO 105
      INAV=IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV
      GO TO 104
105   INAV=IPOF(NSIJT+NSB)+(NAV-1)*NVIR(NSB)+NBV
104   CONTINUE
*PAM04      INDOUT(IPOS+IBOFF3+(IIJ-1)*RTOI*NBSIZ3)=INAV
      INDS(IPOS,IIJ)=INAV
      IF(IPOS.LT.NBITM3)GO TO 108
      JDISK=IDISK
*PAM04      CALL dDAFILE(Lu_60,1,INDOUT(1+(IIJ-1)*RTOI*NBSIZ3),NBSIZ3,IDISK)
      CALL iDAFILE(Lu_60,1,INDS(1,IIJ),NBITM3+2,IDISK)
      CALL dDAFILE(Lu_60,1,BUFS(1,IIJ),NBITM3,IDISK)
*PAM04      INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)=0
*PAM04      INDOUT(IBDA3+(IIJ-1)*RTOI*NBSIZ3)=JDISK
      INDS(NBITM3+1,IIJ)=0
      INDS(NBITM3+2,IIJ)=JDISK
108   IF(NJ.NE.NL)GO TO 306
      IF(NI.EQ.NK)GO TO 306
      IKT=IROW(NI)+NK
      FC(IKT)=FC(IKT)-FINI
      GO TO 306
102   IF(NK.GT.LN)GO TO 306
C ABIJ
      IIJ=IROW(NK)+NL
*PAM04      IPOS=INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)+1
*PAM04      INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)=IPOS
      IPOS=INDS(NBITM3+1,IIJ)+1
      INDS(NBITM3+1,IIJ)=IPOS
*PAM04      BUFOUT(IPOS+(IIJ-1)*NBSIZ3)=FINI
      BUFS(IPOS,IIJ)=FINI
      NSA=NSM(NI)
      NAV=NI-LN-NVIRP(NSA)
      NSB=NSM(NJ)
      NBV=NJ-LN-NVIRP(NSB)
      NSIJT=(MUL(NSM(NK),NSM(NL))-1)*NSYM
      INAV=IPOF(NSIJT+NSA)+(NBV-1)*NVIR(NSA)+NAV
*PAM04      INDOUT(IBOFF3+IPOS+(IIJ-1)*RTOI*NBSIZ3)=INAV
      INDS(IPOS,IIJ)=INAV
      IF(IPOS.LT.NBITM3)GO TO 106
      JDISK=IDISK
*PAM04      CALL dDAFILE(Lu_60,1,INDOUT(1+(IIJ-1)*RTOI*NBSIZ3),NBSIZ3,IDISK)
      CALL iDAFILE(Lu_60,1,INDS(1,IIJ),NBITM3+2,IDISK)
      CALL dDAFILE(Lu_60,1,BUFS(1,IIJ),NBITM3,IDISK)
*PAM04      INDOUT(IBBC3+(IIJ-1)*RTOI*NBSIZ3)=0
*PAM04      INDOUT(IBDA3+(IIJ-1)*RTOI*NBSIZ3)=JDISK
      INDS(NBITM3+1,IIJ)=0
      INDS(NBITM3+2,IIJ)=JDISK
106   IF(NK.NE.NL)GO TO 306
      IF(NI.EQ.NJ)GO TO 306
      IJT=IROW(NI)+NJ
      FC(IJT)=FC(IJT)+2*FINI
      GO TO 306
C CHECK FOR FOCK-MATRIX, AND FROZEN ENERGY, CONTRIBUTIONS
41    CONTINUE
      IF(NI.LT.0) THEN
        IF((NI.EQ.NJ).AND.(NK.EQ.NL)) EFROZ=EFROZ+4*FINI
        IF((NI.EQ.NK).AND.(NJ.EQ.NL)) EFROZ=EFROZ-2*FINI
      ELSE IF(NL.LT.0) THEN
        IF((NK.EQ.NL).AND.(NJ.GT.0)) THEN
          IJT=IROW(NI)+NJ
          FC(IJT)=FC(IJT)+2*FINI
        ELSE IF((NJ.EQ.NL).AND.(NK.GT.0)) THEN
          IKT=IROW(NI)+NK
          FC(IKT)=FC(IKT)-FINI
        END IF
      END IF
306   CONTINUE
307   CONTINUE
308   CONTINUE
309   CONTINUE
310   CONTINUE
311   CONTINUE
312   CONTINUE
313   CONTINUE
C EMPTY LAST BUFFERS
      If ( (NOVST+NCHN3).gt.mChain ) then
         WRITE(6,*)'SORT_MRCI Error: NOVST+NCHN3>MCHAIN (See code).'
         CALL QUIT(_RC_GENERAL_ERROR_)
      End If
      DO 150 I=1,NCHN3
      JDISK=IDISK
*PAM04      CALL dDAFILE(Lu_60,1,INDOUT(1+(I-1)*RTOI*NBSIZ3),NBSIZ3,IDISK)
      CALL iDAFILE(Lu_60,1,INDS(1,I),NBITM3+2,IDISK)
      CALL dDAFILE(Lu_60,1,BUFS(1,I),NBITM3,IDISK)
      LASTAD(NOVST+I)=JDISK
150   CONTINUE
      DO 95 J=1,NORBT
      IND=IROW(J+1)
      FC(IND)=FC(IND)+EFROZ/NELEC
95    CONTINUE
      IADD25=0
      CALL dDAFILE(Lu_25,1,FC,NBTRI,IADD25)
      IAD25S=IADD25
      NOVS=NOVST+NCHN3
*      IF(IPRINT.GE.2) THEN
        WRITE(6,154)
        CALL XFLUSH(6)
        WRITE(6,155)(IVEC(I),I=1,20)
154     FORMAT(//6X,'STATISTICS FOR INTEGRALS, FIRST ENTRY 10**3-10**4',
     *  /)
        CALL XFLUSH(6)
155     FORMAT(6X,5I10)
*      END IF
      RETURN
c Avoid unused argument warnings
      IF (.FALSE.) CALL Unused_integer(NINTGR)
      END
