C 13 MAR 06 - MWS - ASSIGN MCSCF LAGRANGIAN TO UNIQUE DAF RECORD
C 14 NOV 05 - DGF - PAD COMMON BLOCK ENRGYS
C 19 SEP 05 - MWS - ADJUSTMENT FOR H OR I FUNCTION RUNS
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 27 JUN 05 - MWS - CASTRF: OPTIONAL ORBITAL PURIFICATION
C  1 JUN 05 - MWS - PAD THE COMMON TRFOPT
C 30 APR 05 - DGF - CHANGES TO IMPLEMENT FMO-MCSCF, SYNCHRONISE SYMBLK
C 13 FEB 05 - MWS - PAD COMMON BLOCK NSHEL
C  5 FEB 05 - DGF - CASGRD: TOLERANCE MADE A FUNCTION OF TARGET ACURCY
C  7 SEP 04 - MWS - PAD COMMON BLOCK INTFIL
C  9 JUN 04 - MWS - CASHS2: GLOBAL SUM INTEGRALS IF PARALLEL
C 19 MAY 04 - DGF - CHANGES TO ADD THE FMO METHOD
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  3 SEP 03 - JI  - CASHS2: FIX INDEX ARRAY USE TO ENABLE NON-FORS SOSCF
C 14 JAN 03 - JI  - ADD HOOKS FOR THE ORMAS CI STEP
C 12 DEC 02 - YA  - CASMAC: PARALLELIZE FOCK BUILD FROM DUPL. AO LIST
C  7 AUG 02 - MWS - CASMAC,CASFCK,CASGRD: RETURN MAX ROTATION INDICES
C 22 MAY 02 - MWS - CASINT: CHANGES FOR PARALLEL RUNS WITH DET CI STEPS
C 16 NOV 01 - MWS - SOFTEN CLENMO PARAMETERS IN NON-ABELIAN GROUPS
C 19 SEP 01 - MWS - CONVERT MXAOCI PARAMTER TO MXAO
C  1 AUG 01 - JI  - TWEAKS FOR GENERAL CI
C 11 OCT 00 - MWS - UPDATE THE DETWFN COMMON
C 28 JUL 00 - MWS - CASTRF: ADD NO SYM OPTION, CHANGE TOLZ/TOLE AGAIN.
C 11 JUN 00 - MWS - CASMAC,CASTRF: ALWAYS ALLOCATE HONDO INTEGRAL BUFFER
C  1 MAY 00 - MWS - NO SYM OPTION IN TRFOPT COMMON, RESTORE ORIG TOLZ
C 16 FEB 00 - MWS - CHANGE CLENMO TOLZ PARAMETER
C 21 DEC 99 - MWS - CHANGE INTEGRAL SYMMETRY TEST
C  9 APR 99 - MWS - CASTRF: REVERT MOST CASES TO 3 STEPS (UNDO 27 SEP)
C 13 MAR 99 - MWS - CASTRF: ORTHOGONALIZE ONLY FIRST -L0- ORBITALS
C 12 NOV 98 - GDF - CHANGE BIT PACKING TO ISHIFT
C 26 OCT 98 - MAF - CASTRF: ALLOW FOR USE OF SPHERICAL HARMONICS
C 27 SEP 98 - BMB - TWOTFF: FIXED BUG FOR LABSIZ=2
C 13 APR 98 - MWS - CHANGES RELATED TO USING DETERMINANTS FOR THE CI
C 20 NOV 97 - GMC - CASHES,CASHS2: SET A MAX SIZE ON HESSIAN GUESS
C  1 OCT 97 - GMC - CASHS2: ONLY MASTER NODE READS 1E- INTEGRALS
C 28 SEP 97 - MWS - CONVERT PARALLEL CALLS FROM TCGMSG TO DDI
C 24 JUL 97 - MWS - CASTRF: CHANGE PASS SIZE COMPUTATIONS
C  8 MAY 97 - MWS - CASFCK: REMOVE IV COMPUTATION FROM CORE INDEXING IF
C 21 APR 97 - MWS - ADD MOFRZ VARIABLE TO MCINP COMMON
C 19 FEB 97 - GMC - CASMAC,CASGRD,CASTRN: NON-FORS SOSCF, ADDED CASHS2
C  3 FEB 97 - MWS - CASMAC: SAVE LAGRANGIAN FOR SOSCF CORRECTLY
C 30 JAN 97 - MWS - TWOTRF,TWOTFF: REMOVE CRAY WARNINGS
C  8 JAN 97 - GMC - COMMONS CASOPT AND NTNOPT PADDED OUT
C 18 DEC 96 - MWS - ADJUST CALL TO TWOEI ROUTINE, PASS DIRECT DIMENSIONS
C 26 NOV 96 - VAG - INCREASE CI AO'S TO 768
C 29 SEP 96 - GMC - FIX TO ALLOW PARALLEL FOCAS AND SOSCF
C 22 JUN 96 - MWS - ADD PRINT FLAGS TO MCINP COMMON
C 24 MAY 96 - GMC - VARIOUS IMPROVEMENTS BASED ON BURN IN PERIOD
C 18 APR 96 - GMC - INCLUDE FOCAS CODE FROM HONDO 8,
C                   AND USE THIS TO BUILD APPROX SOSCF METHOD.
C
C*MODULE MCCAS   *DECK CASMAC
      SUBROUTINE CASMAC(NPFLG8,DOEXCH,ITSO,IROTMX,JROTMX,DEAMAX)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXNORO=250, MXATM=2000, LDIIS=19, MXAO=8192)
      PARAMETER (MXSH=5000, MXGTOT=20000, MXGSH=30, MXG2=MXGSH*MXGSH)
      PARAMETER (MXRT=100)
C
      LOGICAL SOME,MORE,OUT,DBUG,PACK2E,SCHWRZ,DOEXCH,DIRTRF
      LOGICAL GOPARR,DSKWRK,MASWRK
      LOGICAL CANONC,FCORE,FORS,NOCI,EKT,LINSER
      LOGICAL FOCAS,SOSCF,NOTRF,DROPC,DUPAO,SVDSKW
C
      DOUBLE PRECISION METHOD
C
C     ----- FIRST ORDER MCSCF MAIN ROUTINE -----
C     WRITTEN BY MICHEL DUPUIS. ADAPTED FROM HONDO BY GALINA CHABAN
C
      COMMON /CASOPT/ CASHFT,CASDII,NRMCAS,FOCAS,SOSCF,DROPC
      COMMON /DETWFN/ WSTATE(MXRT),SPINS(MXRT),CRIT,PRTTOL,SDET,SZDET,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),NCORSV,NCOR,NACT,NORBDT,
     *                NADET,NBDET,KDET,KSTDET,IROOT,IPURES,MAXW1,NITER,
     *                MAXP,NCIDET,IGPDET,KSTSYM,NFTGCI
      COMMON /DIICAS/ NCALL,NDIIS,IDARE(LDIIS*2),IDARF(LDIIS*2)
      COMMON /FMCOM / X(1)
      COMMON /FMOINF/ NFG,NLAYER,NATFMO,NBDFG,NAOTYP,NBODY
      COMMON /FMORUN/ ESPSCF,IDAFMO,ICURLAY,ICURFG,JCURFG,KCURFG,NCURSH,
     *                NGAU,ICURPOP,IFMOSTP,MONCOR,NAT1E,NEEDR,MODRST,
     *                NORBPROJ
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /INTOPT/ ISCHWZ,IECP,NECP,IEFLD
      COMMON /MCINP / METHOD,CISTEP,ACURCY,ENGTOL,DAMP,MICIT,NWORD,NORB,
     *                NOROT(2,MXNORO),MOFRZ(15),NPFLG(10),
     *                NOFO,MCFMO,CANONC,FCORE,FORS,NOCI,EKT,LINSER
      COMMON /MCPAR / NFZC,MCORBS,NCI,MORBS,MORB,NUM1
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /NTNOPT/ ENERGY,ENERG0,DEMAX,SQCDF,ITER,MICRO,NOTRF
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NNA,NNB,NNC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),JCODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),
     *                LEVNR(MXAO),IOUT(MXAO),
     *                NREFS,IEXCT,NFOCI,INTACT
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFMEM/ IFCK,IDUM,IDEN,JDUM(3),IBUF,KDUM(2),LAST
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, HALF=0.5D+00, UTOL=0.5D+00)
      PARAMETER (CVGMCF=0.05D+00, TOL=1.0D-10)
      PARAMETER (DMPMCV=5.0D+00)
C
      DATA NFT13  /13/
      DATA NFTG   /15/
      DATA CHECK/8HCHECK   /
      DATA RHF/8HRHF     /
      DATA HESSN,DRC/8HHESSIAN ,8HDRC     /
      DATA ALDET,GUGA,GENCI,ORMAS
     *       /8HALDET   ,8HGUGA    ,8HGENCI   ,8HORMAS   /
C
C     ----- SET PRINT OPTIONS -----
C
      SOME= NPRINT.NE.-5 .AND. MASWRK
      MORE= NPRINT.GE. 1 .AND. MASWRK
      OUT = NPFLG8.GT. 0 .AND. MASWRK
      DBUG= NPFLG8.GE. 2 .AND. MASWRK
C
C        ----- SET ORBITAL SPACE PARAMETERS -----
C        MORB=TOTAL VARIATION SPACE, USUALLY THE FULL BASIS SET
C        MORBS=TOTAL OCCUPIED, INCLUDING CORE
C        MCORBS=NUMBER OF CORE ORBITALS
C        SO -NCI- BELOW IS THE NUMBER OF ACTIVE ORBITALS.
C
      NORBSV = NORB
      NORB = MIN(NORB,NQMT)
      IF(CISTEP.EQ.ALDET  .OR.  CISTEP.EQ.GENCI
     *     .OR.  CISTEP.EQ.ORMAS) THEN
        MORB=NORB
        MORBS=NACT+NCORSV
        MCORBS=NCORSV
      END IF
      IF(CISTEP.EQ.GUGA) THEN
         MORB=NORB
         MORBS=NORBS
         MCORBS=NCORBS
      END IF
C
C     FMO-MCSCF OPTIONS:
C     MCFMO=0 DO NOT DO ANYTHING ADDITIONAL
C          =1 DO NOT TAKE INTO ACCOUNT ROTATIONS BETWEEN REGULAR AND
C             PROJECTED-OUT MOS FOR CHECKING CONVERGENCE (DEFAULT).
C          =2 EXPLICITLY ZERO LAGRANGIAN ELEMENTS FOR THESE ROTATIONS.
C
      IF(NFG.EQ.0.OR.MCFMO.EQ.0) THEN
        MORBD=MORB
      ELSE
        MORBD=MORB-NORBPROJ
      ENDIF
      DEAMAX=ZERO
C
      MINTMX=NINTMX
      IF(NINTIC.NE.0) MINTMX=0
C     MEMORY IS ALLOCATED ELSEWHERE
C
      NCI   = MORBS-MCORBS
      NCI2  = (NCI * NCI + NCI)/2
      L0  = NQMT
      L1  = NUM
      L2  = (L1 *L1 + L1)/2
      L3  =  L1 * L1
C
      NFZC =0
      NUM1 = L1
C
      NPR = MCORBS * (MORBS - MCORBS) + MORBS * (MORB - MORBS)
      IF (.NOT.FORS) THEN
         NPR = NPR + NCI2 - NCI
         MORBS2 = (MORBS*MORBS+MORBS)/2
         MORBS4 = (MORBS2*MORBS2+MORBS2)/2
      END IF
      MCALL = 0
      MDIIS = 0
      MICRO = 0
      NSO=1
      SOGTOL = 0.25D-00
C     NEVALS HAS DIFFERENT MEANING IN FMO
      IF(NFG.EQ.0) THEN
         IF (NEVALS.GT.0) NSO=0
         IF (NEVALS.GT.0) SOGTOL = 0.5D-00
         IF (RUNTYP.EQ.DRC .AND. NEVALS.EQ.1) NSO=1
      ELSE
C       10 IS THE SAME AS 10 BELOW IN ITER.EQ.10
C       0.5D-01 IS THE DEFAULT OF CASDII. USE CASDII ONLY IF THE USER
C       EXPLICITLY SET IT. IT IS NOT GOOD TO USE 0.5D-01 BELOW BUT
C       WHAT ELSE?
        IF(CASDII.NE.0.5D-01.AND.ITER.LT.NOFO) SOGTOL=CASDII
      ENDIF
      IF (RUNTYP.EQ.HESSN) NSO=1
      IF (RUNTYP.EQ.DRC .AND. NEVALS.EQ.1) NSO=1
      IF (NOFO.EQ.0) NSO=0
C
C     ----- CHECK MEMORY AVAILABLE -----
C
      CALL GOTFM(NGOTMX)
      IF(NWORD.GT.0) NGOTMX=MIN(NWORD,NGOTMX)
      NEED = (L2+NCI2)*NCI2 + MAX(NCI2*NCI2, L1*(6+5*L1)+NCI2)
     *     + MAX(L3, NINTMX+NINTMX) + 9*L1
      IF(SOSCF) NEED = NEED + 5*NPR + L1
      IF(.NOT.FORS) NEED = NEED + MORBS4 + NINTMX + NINTMX
      IF(SOME .AND. FOCAS) WRITE(IW,9982) NEED,NGOTMX
      IF(SOME .AND. SOSCF) WRITE(IW,9983) NEED,NGOTMX
      IF(NEED.GT.NGOTMX) THEN
         IF (MASWRK) WRITE(IW,8999) NEED-NGOTMX
         CALL ABRT
      END IF
      IF (EXETYP.EQ.CHECK) RETURN
C
C     ----- CONSTRUCT THE (PQ|IJ)' FROM (PQ|KL) AND GAMMA(KL,IJ) -----
C
      CALL TSECND(TIM0)
C
      CALL VALFM(LOADFM)
      LXPQIJ = LOADFM + 1
      LGIJKL = LXPQIJ + L2*NCI2
      LAST   = LGIJKL + NCI2*NCI2
      NEED1 = LAST - LOADFM - 1
      CALL GETFM(NEED1)
C
      CALL VALFM(LOADFM)
      LXX  = LOADFM + 1
      LIXX = LXX    + NINTMX
      LAST = LIXX   + NINTMX
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL CASINT(X(LXPQIJ),X(LXX),X(LIXX),X(LGIJKL),L2,NCI2,NFT13,NFTG)
C
      CALL RETFM(NEED)
      IF(SOME) THEN
          CALL TSECND(TIM1)
          DELT =  TIM1- TIM0
          TIM0 =  TIM1
          WRITE(IW,9998) DELT
      END IF
C
C     ----- GET ORBITAL SYMMETRY -----
C
      CALL VALFM(LOADFM)
      LVEC   = LOADFM + 1
      LMOIRP = LVEC   + L3
      LNEWOR = LMOIRP + L1
      LOLDOR = LNEWOR + L1
      LAST   = LOLDOR + L1
      NEED2 = LAST - LOADFM - 1
      CALL GETFM(NEED2)
C
      CALL VALFM(LOADFM)
      LS   = LOADFM + 1
      LQ   = LS     + L2
      LT   = LQ     + L3
      LAST = LT     + L1
      NEED = LAST - LOADFM - 1
      CALL GETFM(NEED)
C
      CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
      CALL DAREAD(IDAF,IODA,X(LS)  ,L2,12,0)
      CALL DAREAD(IDAF,IODA,X(LQ)  ,L3,45,0)
      CALL TRFSYM(X(LOLDOR),X(LMOIRP),X(LNEWOR),X(LQ),X(LS),X(LVEC),
     *            X(LT),IA,L0,L1,MORB,L1)
C
C     ----- GET SYMMETRY MAPPING OF MO INDICES -----
C
      CALL CASMAP(X(LMOIRP),X(LNEWOR),X(LOLDOR),MORB)
C
      CALL RETFM(NEED)
      IF(SOME) THEN
          CALL TSECND(TIM1)
          DELT =  TIM1- TIM0
          TIM0 =  TIM1
          WRITE(IW,9997) DELT
      END IF
C
C     ----- CONSTRUCT FOCK OPERATORS -----
C
      CALL VALFM(LOADFM)
      LFCAO = LOADFM + 1
      LFAAO = LFCAO  + L2
      LGIJ  = LFAAO  + L2
      LFCMO = LGIJ   + NCI2
      LFAMO = LFCMO  + MAX(NPR,L2)
      LLAGR = LFAMO  + MAX(NPR,L2)
      LSQWK1= LLAGR  + MAX(NPR,L3)
      LSQWK2= LSQWK1 + MAX(NPR,L3)
      LEWRK = LSQWK2 + MAX(NPR,L3)
      LIWRK = LEWRK  + L1*8
      LWRK  = LIWRK  + L1
      LXX   = LWRK   + L1
      LIXX  = LXX    + MINTMX
      LBMAT = LIXX   + MINTMX
      LAST  = LBMAT  + L2
      IF(NINTIC.NE.0) THEN
         LXX  = LBUFPIC
         LIXX = LIXIC
      ENDIF
C
      IF(DIRTRF) THEN
         NSH2 = (NSHELL*NSHELL+NSHELL)/2
         CALL BASCHK(LMAX)
                       NANGM =  4
         IF(LMAX.EQ.2) NANGM =  6
         IF(LMAX.EQ.3) NANGM = 10
         IF(LMAX.EQ.4) NANGM = 15
         IF(LMAX.EQ.5) NANGM = 21
         IF(LMAX.EQ.6) NANGM = 28
         MAXG = NANGM**4
         LXINTS= LAST
         LGHOND= LXINTS + NSH2
         LDSH  = LGHOND + MAXG
         LDDIJ = LDSH   + NSH2
         LAST  = LDDIJ  + 49*MXG2
      ELSE
         LXINTS= LAST
         LGHOND= LAST
         LDSH  = LAST
         LDDIJ = LAST
      END IF
C
      IF (SOSCF) THEN
         LGRAD = LAST
         LPGRAD= LGRAD  + NPR
         LHESS = LPGRAD + NPR
         LDISP = LHESS  + NPR
         LUPDTI= LDISP  + NPR
         LAST  = LUPDTI + NPR
      ELSE
         LGRAD = LAST
         LPGRAD= LAST
         LHESS = LAST
         LDISP = LAST
         LWRK  = LAST
      END IF
C
      NEED3 = LAST - LOADFM - 1
      CALL GETFM(NEED3)
C
C     ----- F-ACTIVE CALCULATION OVER AO'S -----
C     -LFAMO- IS USED TO STORE THE ACTIVE DENSITY MATRIX IN AO BASIS
C
      CALL CASDE1(X(LVEC),L1,X(LFAMO),X(LGIJ))
C
C     ----- CALCULATE ACTIVE FOCK MATRIX IN AO BASIS
C
      IF(DIRTRF) THEN
         NINT=0
         NSCHWZ=0
         SCHWRZ = ISCHWZ.GT.0
         DUMMY = ZERO
         IF(DOEXCH) THEN
            CALL EXCHNG(X(LXINTS),X(LGHOND),X(LDDIJ),NSH2,MAXG,INTTYP)
         ELSE
            CALL DAREAD(IDAF,IODA,X(LXINTS),NSH2,54,0)
         END IF
         IF(SCHWRZ) CALL SHLDEN(RHF,X(LFAMO),DUMMY,DUMMY,X(LDSH),
     *                          IA,L1,L2,NSH2,1)
         CALL VCLR(X(LFAAO),1,L2)
         CALL TWOEI(RHF,.TRUE.,.FALSE.,.FALSE.,.FALSE.,
     *              INTTYP,SCHWRZ,NINT,NSCHWZ,L1,L2,
     *              DUMMY,DUMMY,IDUMMY,1,
     *              X(LXINTS),NSH2,X(LGHOND),MAXG,X(LDDIJ),
     *              IA,X(LFAMO),X(LFAAO),DUMMY,DUMMY,X(LDSH),
     *              DUMMY,DUMMY,1)
         CALL DSCAL(L2,HALF,X(LFAAO),1)
         II=LFAAO-1
         DO 110 I=1,L1
            II = II+I
            X(II) = X(II) + X(II)
  110    CONTINUE
      ELSE
         SVDSKW = DSKWRK
         DSKWRK = .TRUE.
         CALL SEQREW(IJKO)
         DUPAO  = ITRFAO.EQ.1
         CALL HSTAR(X(LFAMO),X(LFAAO),X(LXX),X(LIXX),
     *              NINTMX,IA,NOPK,DUPAO)
         DSKWRK = SVDSKW
      END IF
C
C     ----- ADD PARTIAL FOCK MATRICES IF DISTRIBUTED PROCESSING
C
      IF (GOPARR) THEN
         CALL DDI_GSUMF(2200,X(LFAAO),L2)
         CALL DDI_GSUMI(2201,NINT  ,1)
         CALL DDI_GSUMI(2202,NSCHWZ,1)
      END IF
C
C     ----- SYMMETRIZE "SKELETON" FOCK MATRICES -----
C     AT THIS POINT -LFCAO- IS WORKING STORAGE
C
      CALL SYMH(X(LFAAO),X(LFCAO),IA)
C
      IF(SOME) THEN
          CALL TSECND(TIM1)
          DELT =  TIM1- TIM0
          TIM0 =  TIM1
          WRITE(IW,9996) DELT
      END IF
C
C     ---- RECOVER F-CORE IN AO BASIS ----
C
      CALL DAREAD(IDAF,IODA,X(LFCAO),L2,35,0)
C
C     ----- PRINT OPTIONS FOR MICROITERATIONS -----
C
  120 MICRO=MICRO+1
      OUT  =(OUT.AND.(MICRO.EQ.1)) .OR. DBUG
      SOME =SOME.AND.(MICRO.EQ.1)
C
C         TRANSFORM FC AND FA FROM AO TO MO BASIS
C
      CALL TFTRI(X(LFCMO),X(LFCAO),X(LVEC),X(LWRK),MORB,L1,L1)
      CALL TFTRI(X(LFAMO),X(LFAAO),X(LVEC),X(LWRK),MORB,L1,L1)
C
C         ASSEMBLE THE LAGRANGIAN MATRIX
C
      CALL CASLGR(X(LXPQIJ),X(LMOIRP),X(LVEC),X(LGIJ),X(LFCMO),X(LFAMO),
     *            X(LLAGR),X(LSQWK1),X(LSQWK2),L2,L1,MORB,OUT)
C
C     =============== START OF SOSCF CONVERGER =================
C     POSSIBLE APPROX SECOND ORDER MCSCF BASED ON HESSIAN UPDATE
C     SCHEME OF FISHER AND ALMLOF (IMPLEMENTED BY GALINA CHABAN)
C
      IF (SOSCF .AND. ITER.GT.NSO) THEN
C
C     ------ TRANSPOSE LAGRANGIAN MATRIX AND SAVE FOR GRADIENT -----
C
      DO 122 I=1,MORBS
         DO 121 J=1,MORB
            X(LSQWK1+(J-1)*MORBS+I-1)=X(LLAGR+(I-1)*MORB+J-1)
  121    CONTINUE
  122 CONTINUE
      CALL DAWRIT(IDAF,IODA,X(LSQWK1),L3,403,NAV)
C
      CALL CASGRD(X(LLAGR),X(LGRAD),MORB,MORBD,NPR,DEMAX0,DEAMAX,IROTMX,
     *            JROTMX,MCFMO.EQ.2)
C
      IF (DEMAX0.LT.1.0D-08) GO TO 160
      IF (DEMAX0.LT.SOGTOL .OR. ITSO.GT.0) THEN
         IF(ITSO.EQ.0) THEN
            IF(FORS) THEN
               CALL CASHES(X(LLAGR),X(LHESS),X(LFCMO),X(LFAMO),
     *                     X(LGIJ),MORB,NPR)
            ELSE
               CALL VALFM(LOADFM)
               LINT   = LOADFM + 1
               LXBUF  = LINT   + MORBS4
               LIXBUF = LXBUF  + NINTMX
               LAST   = LIXBUF + NINTMX
               NEED = LAST - LOADFM - 1
               CALL GETFM(NEED)
               CALL CASHS2(X(LLAGR),X(LHESS),X(LFCMO),X(LFAMO),
     *                     X(LGIJ),X(LGIJKL),X(LINT),X(LXBUF),X(LIXBUF),
     *                     MORB,NPR,NCI2,NINTMX,MORBS4,IJKT)
               CALL RETFM(NEED)
            END IF
            CALL DAWRIT(IDAF,IODA,X(LHESS),NPR,57,0)
            MICIT = 1
         ELSE
            CALL DAREAD(IDAF,IODA,X(LHESS),NPR,57,0)
         END IF
C
         ITSO = ITSO+1
C
C     ------ PERFORM NEWTON-RAPHSON STEP -----
C     ALL OF -LFCMO-, -LFAMO-, -LLAGR-, -LSQWK1-, AND -LSQWK2-
C     ARE USED AS SCRATCH STORAGE OF LENGTH -NPR-, DESTROYING
C     ANY PREVIOUS CONTENTS OF THESE.
C
         IF (ITSO.GT.1) THEN
            CALL DAREAD(IDAF,IODA,X(LPGRAD),NPR,55,0)
            CALL DAREAD(IDAF,IODA,X(LDISP),NPR,56,0)
         END IF
         CALL SONEWT(X(LHESS),X(LGRAD),X(LPGRAD),X(LDISP),
     *               X(LFCMO),X(LFAMO),X(LLAGR),X(LSQWK1),
     *               X(LSQWK2),X(LUPDTI),DEMAX0,NPR,ITSO,23)
         CALL CASTRN(X(LDISP),X(LVEC),X(LSQWK1),X(LWRK),
     *               L1,NPR,SQCDF,FORS)
         CALL DCOPY(NPR,X(LGRAD),1,X(LPGRAD),1)
         CALL DAWRIT(IDAF,IODA,X(LPGRAD),NPR,55,0)
         CALL DAWRIT(IDAF,IODA,X(LDISP),NPR,56,0)
C
         CVGMIC = MAX(ACURCY,DEMAX0*CVGMCF)
         DEMAX=DEMAX0
         GO TO 145
      END IF
C
C     ------ CHECK IF SOSCF HAS TURNED ON -----
C     IF ITS NOT ON BY THE NOFO-TH ITERATION, THE JOB IS PROBABLY BAD
C
      IF (ITER.EQ.NOFO .AND. ITSO.LT.1) THEN
         IF (MASWRK) WRITE(IW,9985)
         CALL ABRT
      END IF
C
      END IF
C
C     =============== END OF SOSCF CONVERGER =================
C
C     =============== START OF FOCAS CONVERGER =================
C
C     ----- CALCULATE EFFECTIVE FOCK OPERATOR -----
C
      CALL CASFCK(X(LLAGR),X(LMOIRP),X(LFCMO),X(LFAMO),X(LBMAT),MORB,
     *            MORBD,DEMAX0,DEAMAX,IROTMX,JROTMX,MCFMO.EQ.2,SOME,OUT)
C
C     ------ TRANSPOSE LAGRANGIAN MATRIX AND SAVE FOR GRADIENT -----
C
      IF(MICRO.EQ.1) THEN
         DO 125 I=1,MORBS
         DO 125 J=1,MORB
  125       X(LSQWK1+(J-1)*MORBS+I-1)=X(LLAGR+(I-1)*MORB+J-1)
         CALL DAWRIT(IDAF,IODA,X(LSQWK1),L3,403,NAV)
      ELSE
         IF(DEMAX0.GT.(DEMAX+DEMAX)) THEN
            MICRO=MICRO-1
            GO TO 160
         END IF
      END IF
C
C     ----- SAVE EFFECTIVE FOCK OPERATOR FOR DIIS METHOD
C
      CALL DAWRIT(IDAF,IODA,X(LBMAT),L2,321,NAV)
C
C     ----- RENORMALIZATION
C
      IF(NRMCAS.EQ.1) CALL CASREN(X(LBMAT),X(LGIJ))
C
C     ----- LEVEL SHIFT -----
C
      IF(CASHFT.NE.ZERO) CALL CASSHF(X(LBMAT),CASHFT)
C
C     -LLAGR- IS USED AS SCRATCH STORAGE HERE
C
      CALL DIISMC(MCALL,MDIIS,X(LMOIRP),X(LBMAT),X(LFCMO),X(LVEC),
     *            L1,MORB,X(LLAGR),X(LSQWK2),X(LSQWK1),X(LFCMO),MICRO+1)
C
      IF(MICRO.EQ.1) THEN
        DEMAX=DEMAX0
        IF(DEMAX.LT.ACURCY) DAMP=ZERO
        CVGMIC = MAX(ACURCY,DEMAX0*CVGMCF)
        IF(DEMAX0.LT.CASDII) THEN
           CALL DIISMC(NCALL,NDIIS,X(LMOIRP),X(LBMAT),X(LFCMO),X(LVEC),
     *                 L1,MORB,X(LLAGR),X(LSQWK2),X(LSQWK1),X(LFCMO),
     *                 MICRO)
        ELSE
           NCALL=0
           NDIIS=0
        END IF
      END IF
C
C        DAMPING MINILOOP BEGINS HERE
C
  140 CONTINUE
C
C     ----- REORDER BY SYMMETRY -----
C     -LFCMO- HOLDS THE REORDERED B MATRIX
C
      CALL CASREO(X(LBMAT),X(LFCMO),X(LNEWOR),MORB,NIRRED)
C
C     ----- DIAGONALIZE B MATRIX AND TRANSFORM VECTORS
C     -LLAGR- HOLDS EIGENVECTORS
C     -LSQWK1- HOLDS EIGENVALUES
C
      IF(MICRO.GT.1) THEN
         DAMP0=DAMP
         DAMP=DAMP+DMPMCV
      END IF
      CALL CASDIA(X(LFCMO),X(LLAGR),X(LSQWK1),MORB,MORB,MORB,X(LVEC),
     *            L1,X(LOLDOR),X(LWRK),X(LEWRK),X(LIWRK),UMAX,OUT)
      IF(MORE) THEN
         WRITE(IW,9990) MICRO,DEMAX0,UMAX
      END IF
      IF(MICRO.GT.1) DAMP=DAMP0
      IF(UMAX.GT.UTOL) THEN
         DAMP=MAX(DAMP,ONE)
         DAMP=DAMP+DAMP
         CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
         GO TO 140
      END IF
C
      IF(MICRO.EQ.1) SQCDF=UMAX
C
C     =============== END OF FOCAS CONVERGER =================
C
C     ----- WRITE UPDATED VECTORS -----
C
  145 CONTINUE
      DO 150 I=0,L3-1
         IF(ABS(X(LVEC+I)).LT.TOL) X(LVEC+I)=ZERO
  150 CONTINUE
      CALL DAWRIT(IDAF,IODA,X(LVEC),L3,15,NAV)
C
      IF(SOME) THEN
          CALL TSECND(TIM1)
          DELT =  TIM1- TIM0
          TIM0 =  TIM1
          IF (ITSO.GE.1) THEN
             WRITE(IW,9995) DELT
          ELSE
             WRITE(IW,9994) DELT
          END IF
      END IF
C
      IF(DEMAX0.GT.CVGMIC.AND.MICRO.LT.MICIT) GO TO 120
C
C     ----- RESTORE MEMORY -----
C
  160 CONTINUE
      CALL RETFM(NEED3)
      CALL RETFM(NEED2)
      CALL RETFM(NEED1)
      IF(MASWRK  .AND.  NPRINT.NE.-5) THEN
         WRITE(IW,*) '..... DONE WITH CASSCF ORBITAL UPDATE .....'
         CALL TIMIT(1)
      END IF
      NORB = NORBSV
      RETURN
C
 8999 FORMAT(/,' NEED MORE CORE FOR FIRST-ORDER CASSCF',/
     *         ' INCREASE CORE BY AT LEAST ',I10,' WORDS',/)
 9982 FORMAT(/,10X,26(1H-),/,
     *         10X,'FIRST-ORDER CASSCF PROGRAM',/,
     *         10X,26(1H-),/,
     *         10X,'PROGRAM WRITTEN BY A.MARQUEZ AND M.DUPUIS',/,
     *          /,'  NUMBER OF WORDS NEEDED     = ',I10,/
     *            '  NUMBER AVAILABLE           = ',I10,/)
 9983 FORMAT(/,10X,38(1H-),/,
     *         10X,'APPROXIMATE SECOND-ORDER MCSCF PROGRAM',/,
     *         10X,38(1H-),/,
     *         10X,'PROGRAM WRITTEN BY G.CHABAN, A.MARQUEZ,',
     *             ' AND M.DUPUIS',/,
     *          /,'  NUMBER OF WORDS NEEDED     = ',I10,/
     *            '  NUMBER AVAILABLE           = ',I10,/)
 9985 FORMAT(/,1X,'FIRST ORDER METHOD DOES NOT GET CLOSE ENOUGH ',
     *            'TO CORRECT ANSWER',/,1X,'TO START APPROXIMATE ',
     *            'SECOND ORDER METHOD.',/,
     *         1X,'YOU SHOULD CONSIDER GETTING BETTER STARTING ',
     *            'ORBITALS OR USING FULLNR=.TRUE.',/)
 9998 FORMAT(' ----- GAMMA(IJKL)*(PQ|KL) PRODUCTS -----',
     *       ' CPU TIME = ',F10.3)
 9997 FORMAT(' ----- ORBITAL SYMMETRY             -----',
     *       ' CPU TIME = ',F10.3)
 9996 FORMAT(' ----- FOCK OPERATORS CONSTRUCTION  -----',
     *       ' CPU TIME = ',F10.3)
 9994 FORMAT(' ----- EFFECTIVE FOCK + ROTATE ORBS -----',
     *       ' CPU TIME = ',F10.3)
 9995 FORMAT(' ----- HESSIAN UPDATE + ROTATE ORBS -----',
     *       ' CPU TIME = ',F10.3)
 9990 FORMAT(5X,'MICIT =',I4,' ASYMM =',F12.6,' ROTMAX =',F12.6)
      END
C*MODULE MCCAS   *DECK CASDE1
      SUBROUTINE CASDE1(V,LDV,DVAL,GIJ)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION V(LDV,*),DVAL(*),GIJ(*)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORB,NUM
C
      PARAMETER (ZERO=0.0D+00)
C
C         BACK TRANSFORM ACTIVE-ACTIVE BLOCK OF DENSITY TO AO BASIS
C
      NUM3 = NUM*NUM
      NCI2 = (NCI*(NCI+1))/2
      CALL DAREAD(IDAF,IODA,V,NUM3,15,0)
      CALL DAREAD(IDAF,IODA,GIJ,NCI2,320,0)
C
      MPQ=0
      DO 30 MP=1,NUM
      DO 30 MQ=1,MP
         MPQ=MPQ+1
         DUM=ZERO
         KL=0
         DO 20 K=1,NCI
         DO 10 L=1,K
            KL=KL+1
            GPQ = GIJ(KL)*V(MP,K+NCORBS)*V(MQ,L+NCORBS)
            GQP = GIJ(KL)*V(MQ,K+NCORBS)*V(MP,L+NCORBS)
   10       DUM = DUM + GPQ + GQP
   20       DUM = DUM - GPQ
   30    DVAL(MPQ)=DUM
      RETURN
      END
C*MODULE MCCAS   *DECK CASINT
      SUBROUTINE CASINT(XPQKL,X,IX,GIJKL,NUM2,NCI2,NFT13,NFTG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL PACK2E,GOPARR,DSKWRK,MASWRK
C
      DIMENSION XPQKL(NUM2,NCI2),GIJKL(NCI2,NCI2),X(*),IX(*)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORB,NUM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- READ (PQ|KL) INTEGRALS AS WRITTEN IN CASTR1 -----
C
      CALL SEQREW(NFT13)
      DO MKL=1,NCI2
         CALL TRFRD(NFT13,XPQKL(1,MKL),NX,IX,NIX,NUM2)
      ENDDO
      CALL SEQREW(NFT13)
C
C     ----- INITIALIZE TO ZERO -----
C
      CALL VCLR(GIJKL,1,NCI2*NCI2)
C
C     ----- READ TWO-PARTICLE DENSITY MATRIX -----
C     GUGA CODE HAS DUPLICATED FILES FOR DM2, BUT OTHER CI PROGRAMS
C     HAVE THIS DATA ONLY ON THE MASTER NODE.  SO JUST PRETEND THAT
C     THE DENSITY MATRIX FILE IS PRESENT ONLY ON THE MASTER NODE.
C
      IF(MASWRK) THEN
         CALL SEQREW(NFTG)
   30    CALL PREAD(NFTG,X,IX,NG,NINTMX)
         IF(NG.EQ.0) GO TO 50
         MG=IABS(NG)
         DO 40 II=1,MG
            VAL=X(II)
            NPACK = II
            IF (LABSIZ .EQ. 2) THEN
*I32           LABEL1 = IX( 2*NPACK - 1 )
*I32           LABEL2 = IX( 2*NPACK     )
*I32           IPACK = ISHFT( LABEL1, -16 )
*I32           JPACK = IAND( LABEL1, 65535 )
*I32           KPACK = ISHFT( LABEL2, -16 )
*I32           LPACK = IAND( LABEL2, 65535 )
*I64           LABEL = IX(NPACK)
*I64           IPACK = ISHFT( LABEL, -48 )
*I64           JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64           KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64           LPACK = IAND( LABEL, 65535 )
            ELSE IF (LABSIZ .EQ. 1) THEN
*I32           LABEL = IX(NPACK)
*I32           IPACK = ISHFT( LABEL, -24 )
*I32           JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32           KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32           LPACK = IAND( LABEL, 255 )
*I64           IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64              LABEL = IX( NPACK/2 )
*I64              IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64              JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64              KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64              LPACK = IAND( LABEL, 255 )
*I64           ELSE
*I64              LABEL = IX( (NPACK/2)+1 )
*I64              IPACK = ISHFT( LABEL, -56 )
*I64              JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64              KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64              LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64           END IF
            END IF
            I = IPACK
            J = JPACK
            K = KPACK
            L = LPACK
C
            IJ=IA(I)+J
            KL=IA(K)+L
            GIJKL(IJ,KL)=VAL
            GIJKL(KL,IJ)=VAL
   40    CONTINUE
         IF(NG.GT.0) GO TO 30
   50    CONTINUE
         CALL SEQREW(NFTG)
      END IF
      IF(GOPARR) CALL DDI_BCAST(2206,'F',GIJKL,NCI2*NCI2,MASTER)
C
C     --- CONSTRUCT (PQ|IJ)' = SUM OVER KL OF (PQ|KL)*GAMMA(KL,IJ) ---
C
      DO 70 MPQ=1,NUM2
         DO 60 MIJ=1,NCI2
            X(MIJ)=ZERO
            MKL=0
            DO 60 MK=1,NCI
            DO 60 ML=1,MK
               MKL=MKL+1
               IF(GIJKL(MKL,MIJ).EQ.ZERO) GO TO 60
               VAL=XPQKL(MPQ,MKL)
               IF(MK.NE.ML) VAL=VAL+VAL
               X(MIJ)=X(MIJ)+VAL*GIJKL(MKL,MIJ)
   60          CONTINUE
            DO 70 MIJ=1,NCI2
   70          XPQKL(MPQ,MIJ)=X(MIJ)
C
      RETURN
      END
C*MODULE MCCAS   *DECK CASMAP
      SUBROUTINE CASMAP(MOSIRP,NEWORD,OLDORD,NORB)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER OLDORD,OLDOM
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
      COMMON /SYMQMT/ IRPLAB(14),IRPNUM(14),IRPDIM(14),IRPDEG(14)
      DIMENSION MOSIRP(*),NEWORD(*),OLDORD(*)
C
C     ----- THIS ROUTINE CALCULATES A MAPPING BY SYMMETRY OF -----
C           THE MO'S IN A WAY THAT ALL THE MO'S OF SYMMETRY 1
C           COME FIRST, THEN COME THE MO'S OF SYMMETRY 2 ...
C
      NEWOM=0
      OLDOM=0
      DO 10 IRP=1,NIRRED
         IF(IRPNUM(IRP).EQ.0) GO TO 10
         DO 20 I=1,NORB
            IF(MOSIRP(I).EQ.IRP) THEN
              NEWOM=NEWOM+1
              NEWORD(I)=NEWOM
              OLDOM=OLDOM+1
              OLDORD(OLDOM)=I
            END IF
   20       CONTINUE
   10 CONTINUE
C
      RETURN
      END
C*MODULE MCCAS   *DECK CASLGR
      SUBROUTINE CASLGR(XPQIJ,MOSIRP,C,GIJ,FC,FA,
     *                  E,Y,X,NUM2,NUM,NORB,DBUG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
      PARAMETER (ZERO=0.0D+00,TWO=2.0D+00)
C
      LOGICAL DBUG,GOPARR,DSKWRK,MASWRK,NXT,DIRTRF
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORBX,NUM1
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
      DIMENSION XPQIJ(NUM2,*),C(NUM,*),GIJ(*),FC(*),FA(*),
     *          E(NORB,NORBS),X(NUM,*),Y(NUM,*),MOSIRP(*)
C
C     ----- CALCULATE LAGRANGIAN MATRIX -----
C
      IB(I,J)=IA(MAX(I,J))+MIN(I,J)
C
      DO 10 J=1,NCI
      DO 10 I=1,NUM
   10    Y(I,J)=ZERO
C
      IF (GOPARR) THEN
         NXT = IBTYP.EQ.1  .AND.  ITRFAO.EQ.1
         NEXT = -1
         MINE = -1
      END IF
C
C     ----- CALCULATE Y(P,T) = SUM OVER Q,U OF C(Q,U)*(PQ|TU)' -----
C
      MT=1
   15 CONTINUE
      IF (GOPARR) THEN
        IF (NXT) THEN
          MINE = MINE + 1
          IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
          IF (NEXT.NE.MINE) GO TO 35
        ELSE
          IPROC = MOD (MT-1,NPROC)
          IF (IPROC.NE.ME) GO TO 35
        END IF
      END IF
C
      DO 30 MU=1,NCI
         MTU=IB(MT,MU)
         MPQ=0
         DO 20 MP=1,NUM
         DO 20 MQ=1,MP
            MPQ=MPQ+1
            X(MP,MQ)=XPQIJ(MPQ,MTU)
   20       X(MQ,MP)=X(MP,MQ)
         DO 30 MP=1,NUM
   30       Y(MP,MT)=Y(MP,MT)+DDOT(NUM,X(1,MP),1,C(1,MU+NCORBS),1)
C
   35 CONTINUE
      MT = MT + 1
      IF (MT.LE.NCI) GO TO 15
C
C     ----- ADD PARTIAL -Y- IF DISTRIBUTED PROCESSING -----
C
      IF (GOPARR) THEN
         IF (NXT) THEN
            CALL DDI_GSUMF(2203,Y,NUM*NCI)
            CALL DDI_DLBRESET
         ELSE
            DO 38 MT=1,NCI
               IPROC = MOD(MT-1,NPROC)
               CALL DDI_BCAST(2209,'F',Y(1,MT),NUM,IPROC)
   38       CONTINUE
         END IF
      END IF
C
      DO 40 J=1,NORBS
      DO 40 I=1,NORB
   40    E(I,J)=ZERO
C
C     ----- FOCK OPERATORS CONTRIBUTIONS -----
C
      IF (NCORBS.NE.0) THEN
      DO 50 MI=1,NCORBS
      DO 50  I=1,NORB
         IF(MOSIRP(I).EQ.MOSIRP(MI)) THEN
            IJ=IB(I,MI)
            E(I,MI)=TWO*(FC(IJ)+FA(IJ))
         END IF
   50    CONTINUE
      END IF
C
C     ----- ONE-PARTICLE DENSITY MATRIX CONTRIBUTIONS -----
C
      DO 70 MT=1,NCI
         MK=MT+NCORBS
         DO 70 I=1,NORB
            DUM=ZERO
            IF(MOSIRP(I).EQ.MOSIRP(MK)) THEN
               DO 60 MU=1,NCI
   60             DUM=DUM+GIJ(IB(MT,MU))*FC(IB(MU+NCORBS,I))
            END IF
   70       E(I,MK)=DUM
C
C     ----- TWO-PARTICLE DENSITY MATRIX CONTRIBUTIONS -----
C
      DO 80 MT=1,NCI
         MK=MT+NCORBS
         DO 80  I=1,NORB
         IF(MOSIRP(I).EQ.MOSIRP(MK)) THEN
            E(I,MK)=E(I,MK)+DDOT(NUM,C(1,I),1,Y(1,MT),1)
         END IF
   80    CONTINUE
C
      IF(DBUG) THEN
         WRITE(IW,9999)
         JMIN=1
   90    JMAX=MIN(NORBS,JMIN+7)
         DO 100 I=1,NORB
  100    WRITE(IW,9998) I,(E(I,J),J=JMIN,JMAX)
         WRITE(IW,9997)
         JMIN=JMAX+1
         IF(JMIN.LE.NORBS) GO TO 90
      END IF
C
      RETURN
 9999 FORMAT(/,' LAGRANGIAN MATRIX',/)
 9998 FORMAT(I5,8F15.10)
 9997 FORMAT(/)
      END
C*MODULE MCCAS   *DECK CASFCK
      SUBROUTINE CASFCK(E,MOSIRP,FC,FA,B,NORB,NORBD,DEMAX,FMOMAX,
     *                  IROTMX,JROTMX,CLNFMO,SOME,DBUG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL CLNFMO,SOME,DBUG
C
      DIMENSION E(NORB,*),FC(*),FA(*),B(*),MOSIRP(*)
      DIMENSION II(4),JJ(4),GRD(4)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORBX,NUM
C
      PARAMETER (ZERO=0.0D+00,TWO=2.0D+00)
      PARAMETER (SQRT21=.70710678118654746172D+00)
C
C     ----- CALCULATE EFFECTIVE FOCK OPERATOR -----
C
      IJ=0
      DO 20 I=1,NORBS
      DO 10 J=1,I-1
   10    B(IJ+J)=E(I,J)-E(J,I)
   20    IJ=IJ+I
C
C     ----- SET TO ZERO ACTIVE-ACTIVE BLOCK -----
C
      DO 30 I=1,NCI
      DO 30 J=1,I-1
         IJ=IA(I+NCORBS)+J+NCORBS
   30    B(IJ)=ZERO
C
C     ----- CORE-VIRTUAL ELEMENTS -----
C
      DO 40 J=NORBS+1,NORB
      DO 40 I=1,NORBS
         IJ=IA(J)+I
   40    B(IJ)=E(J,I)
C
C     ----- SET TO ZERO THE VIRTUAL-VIRTUAL BLOCK -----
C
      DO 45 I=NORBS+1,NORB
         IJ=IA(I)
         DO 45 J=NORBS+1,I-1
   45    B(IJ+J)=ZERO
C
C     ----- DIAGONAL ELEMENTS -----
C
      DO 50 I=1,NORBS
         IJ=IA(I)+I
         B(IJ)=E(I,I)*SQRT21
   50 CONTINUE
      DO 60 I=NORBS+1,NORB
         IJ=IA(I)+I
         B(IJ)=(TWO*SQRT21)*(FC(IJ)+FA(IJ))
   60 CONTINUE
      IF(DBUG) THEN
         WRITE(IW,9994)
         CALL PRTRI(B,NORB)
      END IF
C
C     ----- SEARCH MAX OFF DIAGONAL ELEMENT -----
C
      IF(DBUG) WRITE(IW,9999)
      INDEX=1
      IF (NCORBS.NE.0) THEN
         IJ=(NCORBS*(NCORBS+1))/2
      ELSE
         IJ=1
      END IF
C
      DEMAX=ZERO
      FMOMAX=ZERO
      DO 80 I=NCORBS+1,NORB
         IF (I.LE.1) GO TO 80
         DO 70 J=1,MIN(I-1,NORBS)
            IF(MOSIRP(I).NE.MOSIRP(J)) THEN
               B(IJ+J)=ZERO
            ELSE
               IF(DBUG) THEN
                 II(INDEX)=I
                 JJ(INDEX)=J
                 GRD(INDEX)=B(IJ+J)*TWO
                 INDEX=INDEX+1
                 IF(INDEX.GT.4) THEN
                    WRITE(IW,9998) (II(K),JJ(K),GRD(K),K=1,4)
                    INDEX=1
                 END IF
               END IF
               FMOMAX = MAX(FMOMAX,ABS(B(IJ+J)))
               IF(CLNFMO.AND.I.GT.NORBD) B(IJ+J)=ZERO
               IF(ABS(B(IJ+J)).GT.DEMAX.AND.I.LE.NORBD) THEN
                  DEMAX = ABS(B(IJ+J))
                  IROTMX= I
                  JROTMX= J
               END IF
            END IF
   70    CONTINUE
         IJ=IJ+I
   80 CONTINUE
C
      IF(DBUG.AND.INDEX.GT.1)
     *   WRITE(IW,9998) (II(K),JJ(K),GRD(K),K=1,INDEX-1)
      IF(DBUG) WRITE(IW,9997)
C
      IV=IA(NCORBS+1)+NCORBS+1
      IF (NCORBS.NE.0) THEN
         IC=IA(NCORBS)+NCORBS
         DCV=ABS(B(IV)-B(IC))
         IF(SOME.AND.DCV.LT.0.5D+00) WRITE(IW,9996) DCV
      END IF
      IC=IA(NORBS+1)+NORBS+1
      DCV=ABS(B(IV)-B(IC))
      IF(SOME.AND.DCV.LT.0.5D+00) WRITE(IW,9995) DCV
      RETURN
C
9999  FORMAT(/,' GRADIENT VECTOR (ONLY NONREDUNDANT ROTATIONS)',/)
9998  FORMAT(4(2I5,E20.12))
9997  FORMAT(/)
9996  FORMAT(' ----- WARNING : CORE-ACTIVE GAP    = ',F10.5)
9995  FORMAT(' ----- WARNING : ACTIVE-VIRTUAL GAP = ',F10.5)
9994  FORMAT(/,' EFFECTIVE FOCK OPERATOR',/)
      END
C*MODULE MCCAS   *DECK CASREN
      SUBROUTINE CASREN(B,GIJ)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
      PARAMETER (ONE=1.0D+00,TWO=2.0D+00)
      PARAMETER (SQRT21=.70710678118654746172D+00)
      PARAMETER (TENM08=1.0D-08)
C
C     ----- RENORMALIZE EFFECTIVE FOCK OPERATOR ELEMENTS -----
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORB,NUM
C
      DIMENSION B(*),GIJ(*)
C
C     ----- CORE - VIRTUAL -----
C
      DO 20 MA=NORBS+1,NORB
         IJ=IA(MA)
      IF (NCORBS.NE.0) THEN
         DO 10 MI=1,NCORBS
   10       B(IJ+MI)=B(IJ+MI)*SQRT21
      END IF
   20    CONTINUE
C
C    ----- ACTIVE - VIRTUAL -----
C
      DO 40 MU=1,NCI
         FACTOR=ONE/SQRT(GIJ(IA(MU)+MU))
         DO 30 MA=NORBS+1,NORB
            IJ=IA(MA)+MU+NCORBS
   30       B(IJ)=B(IJ)*FACTOR
   40    CONTINUE
C
C     ----- CORE - ACTIVE -----
C
      DO 60 MU=1,NCI
         DUM=TWO-GIJ(IA(MU)+MU)
         IF(DUM.LE.TENM08) GO TO 60
            FACTOR=ONE/SQRT(DUM)
            IJ=IA(MU+NCORBS)
      IF (NCORBS.NE.0) THEN
            DO 50 MI=1,NCORBS
   50          B(IJ+MI)=B(IJ+MI)*FACTOR
      END IF
   60    CONTINUE
C
      RETURN
      END
C*MODULE MCCAS   *DECK CASSHF
      SUBROUTINE CASSHF(B,SHIFT)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      DIMENSION B(*)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORB,NUM
C
      DO 10 I=1,NCORBS
         IJ=IA(I)+I
   10    B(IJ)=B(IJ)-SHIFT
      DO 20 I=NORBS+1,NORB
         IJ=IA(I)+I
   20    B(IJ)=B(IJ)+SHIFT
C
      RETURN
      END
C*MODULE MCCAS   *DECK CASREO
      SUBROUTINE CASREO(B,BORD,NEWORD,NORB,NIRRED)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      DIMENSION B(*),BORD(*),NEWORD(*)
C
      COMMON /IJPAIR/ IA(MXAO)
C
C     ----- REORDER FOCK OPERATOR BY SYMMETRY -----
C
      IB(I,J) = IA(MAX(I,J)) + MIN(I,J)
C
      IF(NIRRED.EQ.1) THEN
C
        NORB2=IA(NORB)+NORB
        DO 10 I=1,NORB2
   10      BORD(I)=B(I)
      ELSE
        IJ=0
        DO 20 I=1,NORB
        DO 20 J=1,I
           IJ=IJ+1
           NIJ=IB(NEWORD(I),NEWORD(J))
   20      BORD(NIJ)=B(IJ)
      END IF
C
      RETURN
      END
C*MODULE MCCAS   *DECK CASDIA
      SUBROUTINE CASDIA(A,VEC,EIG,NVEC,N,NDIM,C,NUM,OLDORD,T,WRK,IWRK,
     *                  UMAX,DBUG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL DBUG
C
      INTEGER OLDORD
C
C          NOTE THAT -EIG- AND -T- ARE EQUIVALENT BY CALL
C
      DIMENSION A(*),VEC(NDIM,*),EIG(*),C(NUM,*),T(*),
     *          WRK(N,8),IWRK(N),OLDORD(*)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORB,NUM1
      COMMON /SYMQMT/ IRPLAB(14),IRPNUM(14),IRPDIM(14),IRPDEG(14)
      COMMON /SYMBLK/ NIRRED,NSALC,NSALC2,NSALC3,NSAFMO
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- DIAGONALIZE FOCK OPERATOR AND TRANSFORM ORBITALS -----
C
      DO 10 J=1,N
      DO 10 I=1,N
   10 VEC(I,J)=ZERO
      UMAX=ZERO
C
C     ----- LOOP OVER -IRREPS- -----
C
      I1=1
      I2=1
      DO 70 IRP=1,NIRRED
      N1=IRPNUM(IRP)
      IF(N1.EQ.0) GO TO 70
      NVEC1=N1
      IF(NIRRED.EQ.1) THEN
         NVEC1=NVEC
         N1=NVEC
      END IF
      DO 60 LL=1,IRPDIM(IRP)
C
C     ----- DIAGONALIZE BLOCK -----
C
      DO 20 I=1,N1
      DO 20 J=1,I
      IJ  =IA(I     )+ J
      IJSS=IA(I+I1-1)+(J+I1-1)
   20 A(IJ)=A(IJSS)
      MCORBS=0
      MORBS=0
      DO 25 I=1,N1
         IF(OLDORD(I1+I-1).LE.NCORBS) MCORBS=MCORBS+1
         IF(OLDORD(I1+I-1).LE.NORBS)  MORBS=MORBS+1
   25 CONTINUE
      IF(DBUG) THEN
         WRITE(IW,9999) IRP,MCORBS,MORBS,N1
         WRITE(IW,9998)
         CALL PRTRI(A,N1)
      END IF
      CALL GLDIAG(NDIM,NVEC1,N1,A,WRK,EIG(I1),VEC(1,I1),IERR,IWRK)
      IF(IERR.NE.0) CALL ABRT
      CALL CASROT(VEC(1,I1),NDIM,C,NUM,N1,MCORBS,MORBS,
     *            OLDORD(I1),T,UMAX,DBUG)
      IF(I1.EQ.1) GO TO 50
      DO 30 J=1,N1
      DO 30 I=1,N1
   30 VEC(N1-I+I1,J+I1-1)=VEC(N1-I+1,J+I1-1)
      DO 40 J=1,N1
      DO 40 I=1,I1-1
   40 VEC(I,J+I1-1)=ZERO
   50 CONTINUE
C
      I1=I1+ N1
      I2=I2+(N1*(N1+1))/2
   60 CONTINUE
   70 CONTINUE
C
      RETURN
 9998 FORMAT(/,' EFFECTIVE FOCK OPERATOR',/)
 9999 FORMAT(/,' SYMMETRY #',I3,'  NCORBS =',I5,'  NORBS =',I5,
     *         '  NORB =',I5)
      END
C*MODULE MCCAS   *DECK CASROT
      SUBROUTINE CASROT(U,NDIM,C,NUM,NORB,NCORBS,NORBS,
     *                  OLDORD,T,TMAX,DBUG)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DOUBLE PRECISION METHOD
C
      INTEGER OLDORD
C
      LOGICAL CANONC,FCORE,FORS,NOCI,EKT,LINSER,DBUG
C
      DIMENSION U(NDIM,*),C(NUM,*),T(*),OLDORD(*)
C
      PARAMETER (MXNORO=250)
C
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /MCINP / METHOD,CISTEP,ACURCY,ENGTOL,DAMP,MICIT,NWORD,
     *                NORBX,NOROT(2,MXNORO),MOFRZ(15),NPFLG(10),
     *                NOFO,MCFMO,CANONC,FCORE,FORS,NOCI,EKT,LINSER
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, ROTMAX=0.4D+00)
C
C     ----- SEARCH FOR MAX OVERLAP -----
C
      DO 10 I=1,NORB-1
         UMAX=ABS(U(I,I))
         JMAX=I
         DO 20 J=I+1,NORB
            IF(ABS(U(I,J)).GT.UMAX) THEN
               JMAX=J
               UMAX=ABS(U(I,J))
            END IF
   20    CONTINUE
         IF(JMAX.NE.I) THEN
            DO 30 J=1,NORB
               DUM=U(J,I)
               U(J,I)=U(J,JMAX)
   30          U(J,JMAX)=DUM
         END IF
   10 CONTINUE
C
C     ----- KEEP RELATIVE PHASE -----
C
      DO 40 I=1,NORB
      IF(U(I,I).LT.ZERO) THEN
         DO 50 J=1,NORB
   50       U(J,I)=-U(J,I)
      END IF
   40 CONTINUE
C
C     ----- SET TO ZERO THE CORE-CORE BLOCK -----
C
      IF (NCORBS.GT.1) THEN
      DO 60 I=1,NCORBS-1
      DO 60 J=I+1,NCORBS
         U(I,J)=ZERO
   60    U(J,I)=ZERO
      END IF
C
C     ----- SET TO ZERO THE ACTIVE-ACTIVE BLOCK -----
C
      DO 65 I=NCORBS+1,NORBS-1
      DO 65 J=I+1,NORBS
         U(I,J)=ZERO
   65    U(J,I)=ZERO
C
C     ----- SEARCH MAX OFF-DIAGONAL ELEMENT -----
C
      UMAX=ZERO
      DUM=ONE/(ONE+DAMP)
      DO 70 I=2,NORB
      DO 70 J=1,MIN(NORBS,I-1)
         U(J,I)=U(J,I)*DUM
         ROT=ABS(U(J,I))
         IF(ROT.GT.ROTMAX) THEN
            U(J,I)=ROTMAX*ROT/U(J,I)
            ROT=ROTMAX
         END IF
         UMAX=MAX(UMAX,ROT)
         U(I,J)=-U(J,I)
   70 CONTINUE
C
      IF(UMAX.EQ.ZERO) RETURN
C
      TMAX=MAX(TMAX,UMAX)
      DO 80 I=NORBS+1,NORB-1
      DO 80 J=I+1,NORB
         U(I,J)=ZERO
   80    U(J,I)=ZERO
      DO 90 I=1,NORB
   90    U(I,I)=ONE
C
C     ----- ORTHONORMALIZE TRANSFORMATION MATRIX -----
C
      DO 100 I=1,NORB
         DUM=ONE/SQRT(DDOT(NORB,U(1,I),1,U(1,I),1))
         CALL DSCAL(NORB,DUM,U(1,I),1)
         DO 100 J=I+1,NORB
            DUM=DDOT(NORB,U(1,I),1,U(1,J),1)
  100       CALL DAXPY(NORB,-DUM,U(1,I),1,U(1,J),1)
C
      IF(DBUG) THEN
         WRITE(IW,9999)
         JMIN=1
  110    JMAX=MIN(JMIN+7,NORB)
         DO 120 I=1,NORB
  120       WRITE(IW,9998) I,(U(I,J),J=JMIN,JMAX)
         WRITE(IW,9997)
         JMIN=JMAX+1
         IF(JMIN.LE.NORB) GO TO 110
      END IF
C
C     ----- TRANSFORM ORBITALS -----
C
      DO 140 K=1,NUM
         DO 130 I=1,NORB
            T(I)=ZERO
            DO 130 J=1,NORB
  130          T(I)=T(I)+C(K,OLDORD(J))*U(J,I)
         DO 140 I=1,NORB
  140       C(K,OLDORD(I))=T(I)
C
      RETURN
 9999 FORMAT(/,' TRANSFORMATION MATRIX',/)
 9998 FORMAT(I5,8F15.10)
 9997 FORMAT(/)
      END
C*MODULE MCCAS   *DECK DIISMC
      SUBROUTINE DIISMC(NCALL,NDIIS,ISYM,F,F0,C,NUM,NORB,U,T,
     *                  C0,S,MICRO)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
C         NOTE THAT -F0- AND -S- ARE EQUIVALENT BY CALL
C
      DIMENSION ISYM(*),F(*),F0(*),C(NUM,*),C0(NUM,*),U(NORB,*),
     *                  T(*),S(*)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,SVDSKW,DBUG
C
      PARAMETER (MDIIS=19, MXDIIS=MDIIS+1)
      PARAMETER (LDII=MXDIIS*MXDIIS)
      PARAMETER (MXAO=8192)
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00)
C
      COMMON /DIICAS/ NCAL,NDII,IDARE(MDIIS*2),IDARF(MDIIS*2)
      COMMON /DIIFIL/ IDAF30,NAV30,IODA30(4*MDIIS+5)
      COMMON /DIIMAT/ DIIB(MXDIIS,MXDIIS),DIIC(MXDIIS),DIIQ(MXDIIS),
     *                IDIIB(MXDIIS)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      DATA DBUG   /.FALSE./
      DATA TOLDET /1.0D-20/
C
      IB(I,J) = IA(MAX(I,J)) + MIN(I,J)
C
C     ----- THIS VERSION WORKS IN A FIXED MO BASIS SET -----
C
C     -----------------------------------------------------------
C     MAP FOR -IDAF30- FILE
C     -----------------------------------------------------------
C     REC#   1                          REF. VECTORS   (MACROIT.)
C            2                          DIIS MATRIX    (   "    )
C            3 ... MDIIS+2              FOCK OPERATOS  (   "    )
C            MDIIS+3 ... 2*MDIIS+2      ERROR VECTORS  (   "    )
C            +1                         REF. VECTORS   (MICROIT.)
C            +2                         DIIS MATRIX    (   "    )
C            +3 ... +MDIIS+2            FOCK OPERATORS (   "    )
C            +MDIIS+3 ... +2*MDIIS+2    ERROR VECTORS  (   "    )
C     -----------------------------------------------------------
C
      SVDSKW = DSKWRK
      DSKWRK=.FALSE.
C
C     ----- INITIALIZATION -----
C
      NCALL=NCALL+1
      NDIIS=NDIIS+1
      NUM2=(NUM*(NUM+1))/2
      NUM3=NUM*NUM
      NORB2=(NORB*(NORB+1))/2
      IF(MICRO.EQ.1) THEN
         IREC=0
         IDIIS=0
      ELSE
         IREC=2*MDIIS+2
         IDIIS=MDIIS
      END IF
C
      IF(DBUG) WRITE(IW,9000)
      IF(DBUG) CALL PRTRI(F,NORB)
C
C     ----- SAVE REFERENCE VECTORS -----
C
      IF(NDIIS.EQ.1) THEN
         CALL RAWRIT(IDAF30,IODA30,C,NUM3,IREC+1,NAV30)
         DO 10 JDIIS=2,MXDIIS
            DIIB(JDIIS,    1)=-ONE
            DIIB(    1,JDIIS)=-ONE
   10    CONTINUE
         DIIB(1,1)=ZERO
C
C     ----- READ REFERENCE VECTORS AND DIIS MATRIX -----
C
      ELSE
         CALL RAREAD(IDAF30,IODA30,C0  ,NUM3,IREC+1,NAV30)
         CALL RAREAD(IDAF30,IODA30,DIIB,LDII,IREC+2,NAV30)
C
C     ----- GET PROJECTION MATRIX -----
C
         CALL DAREAD(IDAF,IODA,S,NUM2,12,0)
         DO 15 I=1,NORB
         DO 12 NU=1,NUM
            T(NU)=ZERO
            DO 12 MU=1,NUM
               IJ=IB(MU,NU)
   12          T(NU)=T(NU)+C0(MU,I)*S(IJ)
         DO 15 NU=1,NUM
   15       C0(NU,I)=T(NU)
C
         DO 20 I=1,NORB
         DO 20 J=1,NORB
         IF(ISYM(I).EQ.ISYM(J)) THEN
            U(I,J)=DDOT(NUM,C(1,I),1,C0(1,J),1)
         ELSE
            U(I,J)=ZERO
         END IF
   20    CONTINUE
C
C     ----- DIIS DIMENSION TOO BIG DROP ONE COLUMN+ROW -----
C
         IF(NDIIS.GT.MDIIS) THEN
            DO 30 JDIIS=1+IDIIS,NDIIS-1+IDIIS
               IDARE(JDIIS)=IDARE(JDIIS+1)
               IDARF(JDIIS)=IDARF(JDIIS+1)
   30       CONTINUE
            NDIIS=NDIIS-1
         END IF
C
C     ----- NORMAL SITUATION -----
C
            DO 40 JDIIS=NDIIS,2,-1
            DO 40 KDIIS=2,NDIIS
   40          DIIB(KDIIS+1,JDIIS+1)=DIIB(KDIIS,JDIIS)
C
      END IF
C
      IDARE(NDIIS+IDIIS)=MOD(NCALL-1,MDIIS)+3+IREC
      IDARF(NDIIS+IDIIS)=IDARE(NDIIS+IDIIS)+MDIIS
C
      IF(NDIIS.NE.1) THEN
         IF(DBUG) WRITE(IW,8999)
         IF(DBUG) CALL PRSQ(U,NORB,NORB,NORB)
         CALL TFTRI(F0,F,U,T,NORB,NORB,NORB)
         DO 50 I=1,NORB2
   50       F(I)=F0(I)
         IF(DBUG) WRITE(IW,8998)
         IF(DBUG) CALL PRTRI(F,NORB)
      END IF
      CALL RAWRIT(IDAF30,IODA30,F,NORB2,IDARF(NDIIS+IDIIS),NAV30)
C
C     ----- READ ERROR VECTOR (ACTUAL MO BASIS) -----
C
      CALL DAREAD(IDAF,IODA,F,NUM2,321,0)
C
C     ----- ELIMINATE DIAGONAL -----
C
      DO 60 I=1,NORB
   60   F(IA(I)+I)=ZERO
C
C     ----- TRANSFORM TO C0 BASIS -----
C
      IF(NDIIS.NE.1) THEN
         CALL TFTRI(F0,F,U,T,NORB,NORB,NORB)
         DO 70 I=1,NORB2
   70       F(I)=F0(I)
      END IF
C
      IF(DBUG) WRITE(IW,*) 'ERROR VECTOR (FULL)'
      IF(DBUG) CALL PRTRI(F,NORB)
C
C     ----- KEEP ONLY OFF-DIAGONAL SYMMETRY UNIQUE ELEMENTS -----
C
      N2=0
      DO 80 I=1,NORB
      DO 80 J=1,I-1
      IF(ISYM(I).NE.ISYM(J)) GO TO 80
         N2=N2+1
         F(N2)=F(IA(I)+J)
80    CONTINUE
C
      IF(DBUG) WRITE(IW,8997) N2,(F(I),I=1,N2)
C
C     ----- SAVE ERROR VECTOR -----
C
      CALL RAWRIT(IDAF30,IODA30,F,N2,IDARE(NDIIS+IDIIS),NAV30)
C
C     ----- SET UP DIIS EQUATIONS -----
C
      DO 90 JDIIS=1,NDIIS-1
         CALL RAREAD(IDAF30,IODA30,F0,N2,IDARE(JDIIS+IDIIS),NAV30)
         BIJ=DDOT(N2,F,1,F0,1)
         DIIB(2,NDIIS-JDIIS+2)=BIJ
   90    DIIB(NDIIS-JDIIS+2,2)=BIJ
      DIIB(2,2)=DDOT(N2,F,1,F,1)
C
C     ----- SAVE DIIS MATRIX -----
C
      CALL RAWRIT(IDAF30,IODA30,DIIB,LDII,2+IREC,NAV30)
C
      IF(NDIIS.EQ.1) THEN
         CALL RAREAD(IDAF30,IODA30,F,NORB2,IDARF(NDIIS+IDIIS),NAV30)
      ELSE
C
C     ----- SOLVE DIIS EQUATIONS -----
C
  100 LDIIS=NDIIS+1
      DO 110 JDIIS=2,NDIIS+1
  110    DIIC(JDIIS)=ZERO
      DIIC(1)=-ONE
      NODCMP=1
C
      IF(DBUG) THEN
         WRITE(IW,8996)
         CALL PRSQ(DIIB,LDIIS,LDIIS,MXDIIS)
         CALL PRSQ(DIIC,    1,LDIIS,MXDIIS)
      END IF
C
      CALL LINEQU(DIIB,MXDIIS,DIIC,LDIIS,IDIIB,DIIQ,DIIDET,IERR,NODCMP)
      IF(IERR.NE.0) THEN
         WRITE(IW,9998)
         CALL ABRT
      END IF
      IF(ABS(DIIDET).LT.TOLDET) THEN
C
C     ----- DIIS SPACE ILL-CONDITIONED, REDUCE DIMENSION -----
C
         CALL RAREAD(IDAF30,IODA30,DIIB,LDII,2+IREC,NAV30)
         NDIIS=NDIIS-1
         DO 120 JDIIS=1+IDIIS,NDIIS+IDIIS
            IDARE(JDIIS)=IDARE(JDIIS+1)
            IDARF(JDIIS)=IDARF(JDIIS+1)
  120    CONTINUE
         GO TO 100
      END IF
C
      IF(DBUG) CALL PRSQ(DIIC,    1,LDIIS,MXDIIS)
C
C     ----- GET EXTRAPOLATED F0 MATRIX -----
C
      DO 130 I=1,NORB2
  130    F0(I)=ZERO
      DO 140 JDIIS=1,NDIIS
         CALL RAREAD(IDAF30,IODA30,F,NORB2,IDARF(JDIIS+IDIIS),NAV30)
  140    CALL DAXPY(NUM2,DIIC(NDIIS-JDIIS+2),F,1,F0,1)
C
      IF(DBUG) THEN
         WRITE(IW,8995)
         CALL PRTRI(F0,NORB)
      END IF
C
C     ----- BACK TRANSFORM TO C BASIS -----
C
      DO 150 I=1,NORB
      DO 150 J=1,I
         DUM=U(I,J)
         U(I,J)=U(J,I)
  150    U(J,I)=DUM
      CALL TFTRI(F,F0,U,T,NORB,NORB,NORB)
C
      IF(DBUG) THEN
         WRITE(IW,8994)
         CALL PRTRI(F,NORB)
      END IF
C
      END IF
      DSKWRK = SVDSKW
      RETURN
C
8994  FORMAT(/,' EXTRAPOLATED FOCK OPERATOR (C )',/,1X,31('-'),/)
8995  FORMAT(/,' EXTRAPOLATED FOCK OPERATOR (C0)',/,1X,31('-'),/)
8996  FORMAT(/,' DIIS EQUATIONS',/)
8997  FORMAT(/,' DIMENSION OF ERROR VECTOR = ',I4,/,
     1         ' ERROR VECTOR',/,(10F12.5))
8998  FORMAT(/,' FOCK OPERATOR (C0)',/,1X,13('-'),/)
8999  FORMAT(/,' U MATRIX',/,1X,8('-'),/)
9000  FORMAT(/,' FOCK OPERATOR (C )',/,1X,31('-'),/)
9998  FORMAT(' -DIIS- SYSTEM OF LINEAR EQUATION IS SINGULAR')
      END
C*MODULE MCCAS   *DECK CASGRD
      SUBROUTINE CASGRD(E,GRAD,NORB,NORBD,NPR,ORBGRD,FMOGRD,IROTMX,
     *                  JROTMX,CLNFMO)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION GRAD(NPR),E(NORB,*)
C
      LOGICAL CANONC,FCORE,FORS,NOCI,EKT,LINSER,CLNFMO
      DOUBLE PRECISION METHOD
      PARAMETER (MXNORO=250)
C
      COMMON /MCINP / METHOD,CISTEP,ACURCY,ENGTOL,DAMP,MICIT,NWORD,
     *                NORBY,NOROT(2,MXNORO),MOFRZ(15),NPFLG(10),
     *                NOFO,MCFMO,CANONC,FCORE,FORS,NOCI,EKT,LINSER
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORBX,NUM
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- FORM ORBITAL GRADIENT FOR APPROX 2ND ORDER MCSCF
C          E      - LAGRANGIAN MATRIX
C          GRAD   - GRADIENT VECTOR
C          NPR    - NUMBER OF ROTATION PARAMETERS
C          ORBGRD - MAXIMUM ORBITAL GRADIENT COMPONENT
C          NORBD  - THE NUMBER OF ORBITALS USED TO DETERMINE MCSCF
C                   CONVERGENCE, NORMALLY EQUAL TO NORB EXCEPT FMO
C                   RUNS WHEN ROTATIONS OF NORMAL AND PROJECTED OUT
C                   ORBITALS WITH ASTRONOMICAL ENERGIES NEVER QUITE
C                   CONVERGE. NOTE THAT THESE ROTATIONS -WILL- BE
C                   OPTIMISED, JUST NOT USED WHEN DECIDING IF CONVERGED.
C                   THE PROBLEM APPEARS TO BE MOSTLY IN CORE-VIRTUAL
C                   ROTATIONS OF SUCH ORBITALS AND THE OFFENDING
C                   LAGRANGIAN ELEMENT IS PROPORTIONAL(?) TO B
C                   (PARAMETER IN FMO PROJECTION OPERATORS, $FMO
C                   ORSHFT).  ROTATIONS INVOLVING CORE AND THOSE
C                   PROJECTED OUT ORBITALS.  FOR STATISTICS KEEP
C                   ORBGRD FOR ALL ROTATIONS IN FMOGRD.
C          CLNFMO - WHETHER TO EXPLICITLY ZERO OUT ROTATIONS DESCRIBED
C                   ABOVE.
C
      SMALL = 1.0D-03 * ACURCY
      K=0
      ORBGRD=ZERO
      FMOGRD=ZERO
C              ACT-CORE AND VIRT-CORE
      DO 200 I = NCORBS+1,NORB
         DO 100 J = 1,NCORBS
            K=K+1
            IF(I.LE.NORBS) THEN
               GRAD(K)= E(I,J) - E(J,I)
            ELSE
               GRAD(K)= E(I,J)
            END IF
            FMOGRD=MAX(FMOGRD,ABS(GRAD(K)))
            IF (ABS(GRAD(K)).LT.SMALL.OR.CLNFMO.AND.I.GT.NORBD)
     *         GRAD(K)=ZERO
            IF(ABS(GRAD(K)).GT.ORBGRD.AND.I.LE.NORBD) THEN
               ORBGRD=ABS(GRAD(K))
               IROTMX=I
               JROTMX=J
            END IF
  100    CONTINUE
  200 CONTINUE
C              VIRT-ACT
      DO 400 I = NORBS+1,NORB
         DO 300 J = NCORBS + 1, NORBS
            K=K+1
            GRAD(K)= E(I,J)
            FMOGRD=MAX(FMOGRD,ABS(GRAD(K)))
            IF (ABS(GRAD(K)).LT.SMALL.OR.CLNFMO.AND.I.GT.NORBD)
     *         GRAD(K)=ZERO
            IF(ABS(GRAD(K)).GT.ORBGRD.AND.I.LE.NORBD) THEN
               ORBGRD=ABS(GRAD(K))
               IROTMX=I
               JROTMX=J
            END IF
  300    CONTINUE
  400 CONTINUE
C              ACT-ACT
      IF(.NOT.FORS) THEN
         DO 600 I = NCORBS+2,NORBS
            DO 500 J = NCORBS+1,I-1
               K=K+1
               GRAD(K) = E(I,J) - E(J,I)
               FMOGRD=MAX(FMOGRD,ABS(GRAD(K)))
               IF (ABS(GRAD(K)).LT.SMALL) GRAD(K)=ZERO
               IF(ABS(GRAD(K)).GT.ORBGRD) THEN
                  ORBGRD=ABS(GRAD(K))
                  IROTMX=I
                  JROTMX=J
               END IF
  500       CONTINUE
  600    CONTINUE
      END IF
C
      RETURN
      END
C*MODULE MCCAS   *DECK CASHES
      SUBROUTINE CASHES(E,HESS,FC,FA,GIJ,NORB,NPR)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      DIMENSION HESS(NPR),E(NORB,*),FC(*),FA(*),GIJ(*)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORBX,NUM
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, HTOL=0.5D-02)
C
C     ----- FORM ORBITAL HESSIAN FOR APPROX 2ND ORDER MCSCF
C
C          E      - LAGRANGIAN MATRIX
C          FC,FA  - CORE AND ACTIVE FOCK-LIKE MATRICES
C          GIJ    - ONE-BODY DENSITY
C          HESS   - APPROX INVERSE DIAGONAL HESSIAN
C          NPR    - NUMBER OF ROTATION PARAMETERS
C
      K=0
      DO 200 IU = 1,NORB - NCORBS
         I = IU + NCORBS
         II=IA(I)+I
         IIU=IA(IU)+IU
         DO 100 J = 1,NCORBS
            JJ=IA(J)+J
            K=K+1
            IF (I.GT.NORBS) THEN
               HESS(K)=TWO*(FC(II) + FA(II)) - E(J,J)
            ELSE
               HESS(K)=TWO*(FC(II) + FA(II)) - E(I,I) - E(J,J)
     *                 + GIJ(IIU)*(FC(JJ) + FA(JJ))
            END IF
  100    CONTINUE
  200 CONTINUE
      DO 400 I = NORBS+1,NORB
         II=IA(I)+I
         DO 300 JU = 1, NCI
            J = JU + NCORBS
            JJU=IA(JU)+JU
            K=K+1
            HESS(K)= GIJ(JJU)*(FC(II) + FA(II)) - E(J,J)
  300    CONTINUE
  400 CONTINUE
C
C     INVERT THE DIAGONAL HESSIAN
C
      DO 500 IPR=1,NPR
          IF(HESS(IPR).GT.HTOL) THEN
             HESS(IPR)=ONE/HESS(IPR)
          ELSE
             HESS(IPR)=ONE/HTOL
          ENDIF
  500 CONTINUE
C
      RETURN
      END
C*MODULE MCCAS   *DECK CASHS2
      SUBROUTINE CASHS2(E,HESS,FC,FA,GIJ,GIJKL,XX,X,IX,
     *                  NORB,NPR,NCI2,NINTMX,MAXINT,IJKT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      DIMENSION HESS(NPR),E(NORB,*),FC(*),FA(*),XX(MAXINT)
      DIMENSION GIJ(*),GIJKL(NCI2,NCI2),X(NINTMX),IX(NINTMX)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORBX,NUM
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /ORDOPT/ IDUM(6),NOSQUR
C
      PARAMETER (ONE=1.0D+00, TWO=2.0D+00, HTOL=5.0D-03)
C
C     ----- FORM ORBITAL HESSIAN FOR APPROX 2ND ORDER MCSCF
C          E      - LAGRANGIAN MATRIX
C          FC     - CORE FOCK MATRIX
C          FA     - ACTIVE FOCK MATRIX
C          GIJ    - 1-BODY DENSITY OVER ACTIVE MO'S
C          GIJKL  - 2-BODY DENSITY OVER ACTIVE MO'S
C          XX     - 2-E INTEGRALS
C          HESS   - APPROX INVERSE DIAGONAL HESSIAN
C          NPR    - NUMBER OF ROTATION PARAMETERS
C
      CALL SEQREW(IJKT)
      IF(MASWRK) CALL SEQADV(IJKT)
      CALL VCLR(XX,1,MAXINT)
C
C     ----- READ IN INTEGRALS FROM -IJKT- -----
C
  110 CALL PREAD(IJKT,X,IX,NX,NINTMX)
      IF(NX.EQ.0) GO TO 130
      MX=IABS(NX)
      IF(MX.GT.NINTMX) THEN
         CALL ABRT
         STOP
      END IF
      DO 120 M=1,MX
C
         NPACK = M
         IF (LABSIZ .EQ. 2) THEN
*I32       LABEL1 = IX( 2*NPACK - 1 )
*I32       LABEL2 = IX( 2*NPACK     )
*I32       IPACK = ISHFT( LABEL1, -16 )
*I32       JPACK = IAND( LABEL1, 65535 )
*I32       KPACK = ISHFT( LABEL2, -16 )
*I32       LPACK = IAND( LABEL2, 65535 )
*I64       LABEL = IX(NPACK)
*I64       IPACK = ISHFT( LABEL, -48 )
*I64       JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64       KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64       LPACK = IAND( LABEL, 65535 )
         ELSE IF (LABSIZ .EQ. 1) THEN
*I32       LABEL = IX(NPACK)
*I32       IPACK = ISHFT( LABEL, -24 )
*I32       JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32       KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32       LPACK = IAND( LABEL, 255 )
*I64       IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64         LABEL = IX( NPACK/2 )
*I64         IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64         JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64         KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64         LPACK = IAND( LABEL, 255 )
*I64       ELSE
*I64         LABEL = IX( (NPACK/2)+1 )
*I64         IPACK = ISHFT( LABEL, -56 )
*I64         JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64         KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64         LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64       END IF
         END IF
C
         K = IPACK
         L = JPACK
         I = KPACK
         J = LPACK
C
         IF(NOSQUR.EQ.1) THEN
            IIDUM=I
            JJDUM=J
            I=K
            J=L
            K=IIDUM
            L=JJDUM
         END IF
         IJ=IA(I)+J
         KL=IA(K)+L
         IJKL=(IJ*IJ-IJ)/2 + KL
         XX(IJKL)=X(M)
  120 CONTINUE
      IF(NX.GT.0) GO TO 110
C
  130 CONTINUE
      IF(GOPARR) CALL DDI_GSUMF(2210,XX,MAXINT)
C
C         FOR DIAGONAL HESSIAN FORMULAE, SEE APPENDIX A OF
C         H.J.AA.JENSEN, H.AGREN CHEM.PHYS. 104. 220-250(1986)
C
C         AN APPROXIMATION TO CORE-ACTIVE AND CORE-VIRTUAL TERMS.
C
C         SEE G.M.CHABAN, M.W.SCHMIDT, M.S.GORDON  THEORET.CHEM.ACC.
C         97, 88-95(1997) FOR JUSTIFICATION OF THE APPROXIMATIONS HERE.
C
      K=0
      DO 200 IU = 1,NORB - NCORBS
         I = IU + NCORBS
         II =IA(I )+I
         IIU=IA(IU)+IU
         DO 100 J = 1,NCORBS
            JJ=IA(J)+J
            K=K+1
            IF (I.GT.NORBS) THEN
               HESS(K)=TWO*(FC(II) + FA(II)) - E(J,J)
            ELSE
               HESS(K)=TWO*(FC(II) + FA(II)) - E(I,I) - E(J,J)
     *          + GIJ(IIU)*(FC(JJ) + FA(JJ))
            END IF
  100    CONTINUE
  200 CONTINUE
C
C         AN APPROXIMATION TO ACTIVE-VIRTUAL TERMS
C
      DO 400 I = NORBS+1,NORB
         II=IA(I)+I
         DO 300 JU = 1, NCI
            J = JU + NCORBS
            JJU=IA(JU)+JU
            K=K+1
            HESS(K)= GIJ(JJU)*(FC(II) + FA(II)) - E(J,J)
  300    CONTINUE
  400 CONTINUE
C
C         AN EXACT EVALUATION OF THE ACTIVE-ACTIVE TERMS
C
      DO 600 IU = 2,NCI
         I = IU + NCORBS
         II=IA(I)+I
         IIU=IA(IU)+IU
         DO 500 J = NCORBS+1,I-1
            JU = J-NCORBS
            JJ =IA(J )+J
            JJU=IA(JU)+JU
            IJ =IA(MAX( I,J ))+MIN( I,J )
            IJU=IA(MAX(IU,JU))+MIN(IU,JU)
            K=K+1
            HESS(K)= GIJ(JJU)*FC(II) - E(J,J)
     *             + GIJ(IIU)*FC(JJ) - E(I,I)
     *             - TWO*GIJ(IJU)*FC(IJ)
            DO 20 LU = 1, NCI
               L = LU + NCORBS
               IL  = IA(MAX( I,L ))+MIN( I,L )
               ILU = IA(MAX(IU,LU))+MIN(IU,LU)
               JL  = IA(MAX( J,L ))+MIN( J,L )
               JLU = IA(MAX(JU,LU))+MIN(JU,LU)
C
               DO 10 MU = 1, NCI
                  M = MU + NCORBS
                  IM  = IA(MAX( I,M ))+MIN( I,M )
                  IMU = IA(MAX(IU,MU))+MIN(IU,MU)
                  JM  = IA(MAX( J,M ))+MIN( J,M )
                  JMU = IA(MAX(JU,MU))+MIN(JU,MU)
                  IF(L.GE.M) THEN
                     LM   = IA(L ) + M
                     LMU  = IA(LU) + MU
                     ILIM = (IL*IL-IL)/2 + IM
                     JLJM = (JL*JL-JL)/2 + JM
                  ELSE
                     LM   = IA(M ) + L
                     LMU  = IA(MU) + LU
                     ILIM = (IM*IM-IM)/2 + IL
                     JLJM = (JM*JM-JM)/2 + JL
                  END IF
                  MXTEMP = MAX(JJ,LM)
                  JJLM = (MXTEMP*MXTEMP-MXTEMP)/2 + MIN(JJ,LM)
                  MXTEMP = MAX(II,LM)
                  IILM = (MXTEMP*MXTEMP-MXTEMP)/2 + MIN(II,LM)
                  MXTEMP = MAX(IJ,LM)
                  IJLM = (MXTEMP*MXTEMP-MXTEMP)/2 + MIN(IJ,LM)
                  MXTEMP = MAX(IL,JM)
                  ILJM = (MXTEMP*MXTEMP-MXTEMP)/2 + MIN(IL,JM)
C
                  HESS(K) = HESS(K) + GIJKL(IIU,LMU) * XX(JJLM)
     *                           +TWO*GIJKL(IMU,ILU) * XX(JLJM)
     *                               +GIJKL(JJU,LMU) * XX(IILM)
     *                           +TWO*GIJKL(JMU,JLU) * XX(ILIM)
     *                           -TWO*GIJKL(IJU,LMU) * XX(IJLM)
     *                       -TWO*TWO*GIJKL(IMU,JLU) * XX(ILJM)
   10          CONTINUE
   20       CONTINUE
  500    CONTINUE
  600 CONTINUE
C
C     INVERT THE DIAGONAL HESSIAN
C
      DO 900 IPR=1,NPR
          IF(HESS(IPR).GT.HTOL) THEN
             HESS(IPR)=ONE/HESS(IPR)
          ELSE
             HESS(IPR)=ONE/HTOL
          ENDIF
  900 CONTINUE
C
      RETURN
      END
C*MODULE MCCAS   *DECK CASTRN
      SUBROUTINE CASTRN(X,C,G,WRK,L1,NPR,SQCDF,FORS)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION X(NPR),C(L1,L1),G(L1,L1),WRK(L1)
C
      LOGICAL FORS
C
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORB,NUM
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00)
C
C     ----- ORBITAL TRANSFORMATION FOR APPROX 2ND ORDER MCSCF
C          X      = ROTATION PARAMETERS
C          G      = TRANSFORMATION MATRIX ( G = EXP(X))
C          C      = MATRIX OF MO COEFFICIENTS TO BE ROTATED
C          L1     = NUMBER OF BASIS FUNCTIONS
C          NPR    = NUMBER OF ROTATION PARAMETERS
C
      CALL VCLR(G,1,L1*L1)
C
C     ----- FORM MATRIX G = I + X -----
C
      K=0
      DO 200 I = NCORBS+1,NORB
         DO 100 J = 1,NCORBS
            K=K+1
            G(I,J)= X(K)
            G(J,I)=-X(K)
  100    CONTINUE
  200 CONTINUE
C
      DO 400 I = NORBS+1,NORB
         DO 300 J = NCORBS + 1, NORBS
            K=K+1
            G(I,J)= X(K)
            G(J,I)=-X(K)
  300    CONTINUE
  400 CONTINUE
C
      IF(.NOT.FORS) THEN
         DO 420 I = NCORBS+2,NORBS
            DO 410 J = NCORBS+1,I-1
               K=K+1
               G(I,J)= X(K)
               G(J,I)=-X(K)
  410       CONTINUE
  420    CONTINUE
      END IF
C
      DO 440 I=1,L1
         G(I,I) = ONE
  440 CONTINUE
C
C     ----- ORTHONORMALIZE THE TRANSFORMATION MATRIX -----
C
      DO 460 I=1,L1
         DUM = DDOT(L1,G(1,I),1,G(1,I),1)
         CALL DSCAL(L1,ONE/SQRT(DUM),G(1,I),1)
         IF(I.EQ.L1) GO TO 460
         IP1=I+1
         DO 450 J=IP1,L1
            DUM = DDOT(L1,G(1,I),1,G(1,J),1)
            CALL DAXPY(L1,-DUM,G(1,I),1,G(1,J),1)
  450    CONTINUE
  460 CONTINUE
C
C     ----- COMPUTE MEASURE OF ORBITAL ROTATION CHANGE -----
C
      SQCDF = ZERO
      DO 550 I = NCORBS+1,NORB
         DO 500 J = 1,NCORBS
            SQCDF = SQCDF+G(I,J)*G(I,J)
  500    CONTINUE
  550 CONTINUE
      DO 650 I = NORBS+1,NORB
         DO 600 J = NCORBS + 1, NORBS
            SQCDF = SQCDF+G(I,J)*G(I,J)
  600    CONTINUE
  650 CONTINUE
C
C     ----- ROTATE THE ORBITALS -C- BY TRANSFORMATION -G- -----
C
      DO 750 I=1,L1
         DO 730 J=1,L1
            DUM=ZERO
            DO 720 K=1,L1
               DUM=DUM+C(I,K)*G(K,J)
  720       CONTINUE
            WRK(J)=DUM
  730    CONTINUE
         DO 740 J=1,L1
            C(I,J)=WRK(J)
  740    CONTINUE
  750 CONTINUE
      RETURN
      END
C*MODULE MCCAS   *DECK CASTRF
      SUBROUTINE CASTRF(NPRINT,DOEXCH)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DOUBLE PRECISION METHOD
C
      LOGICAL DOFOCK,DOEXCH,TWOSTP,ABEL,ABELPT
      LOGICAL MASWRK,DSKWRK,GOPARR,DIRTRF
      LOGICAL SOME,DBUG,PACK2E,INITAL
      LOGICAL CANONC,FCORE,FORS,NOCI,EKT,LINSER,NOTRF
C
      PARAMETER (NFT13=13)
      PARAMETER (MXNORO=250, MXATM=2000, MXRT=100, MXAO=8192,
     *           MXSH=5000, MXGTOT=20000, MXGSH=30, MXG2=MXGSH*MXGSH)
C
      COMMON /DETWFN/ WSTATE(MXRT),SPINS(MXRT),CRIT,PRTTOL,SDET,SZDET,
     *                GRPDET,STSYM,GLIST,
     *                NFLGDM(MXRT),IWTS(MXRT),NCORSV,NCOR,NACT,NORBDT,
     *                NADET,NBDET,KDET,KSTDET,IROOT,IPURES,MAXW1,NITER,
     *                MAXP,NCIDET,IGPDET,KSTSYM,NFTGCI
      COMMON /DIRMEM/ IPQKL,IVEC,IDEN,IFCK,NBF,NOC,NDIM,MINPQ,MAXPQ
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FMCOM / X(1)
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /MCINP / METHOD,CISTEP,ACURCY,ENGTOL,DAMP,MICIT,NWORD,NORB,
     *                NOROT(2,MXNORO),MOFRZ(15),NPFLG(10),
     *                NOFO,MCFMO,CANONC,FCORE,FORS,NOCI,EKT,LINSER
      COMMON /MCPAR / NFZC,MCORBS,NCI,MORBS,MORB,NBF1
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),CH(MXGTOT),CI(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),KNG(MXSH),
     *                KLOC(MXSH),KMIN(MXSH),KMAX(MXSH),NSHELL
      COMMON /NTNOPT/ ENERGY,ENERG0,DEMAX,SQCDF,ITER,MICRO,NOTRF
      COMMON /ORBSET/ NORBMX,NORBS,NCORBS,NLEVS,NNA,NNB,NNC,NSYM,MSYM,
     *                IDOCC,IVAL,IMCC,ISYM(MXAO),JCODE(MXAO),
     *                NLCS(MXAO),LEVPT(MXAO),LEVNR(MXAO),IOUT(MXAO),
     *                NREFS,IEXCT,NFOCI,INTACT
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SYMTRY/ MAPSHL(MXSH,48),MAPCTR(MXATM,48),
     *                TSYM(432),INVT(48),NT
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
C
      DIMENSION IX(1)
      EQUIVALENCE (IX(1),X(1))
C
      SAVE INITAL
C
      DATA INITAL/.TRUE./
      DATA DOFOCK/.TRUE./
      DATA CHECK/8HCHECK   /
      DATA ALDET,GUGA,GENCI,ORMAS
     *       /8HALDET   ,8HGUGA    ,8HGENCI   ,8HORMAS   /
C
C     ----- SPECIAL INTEGRAL TRANSFORMATION -----
C           FOR FIRST-ORDER CASSCF PROGRAM
C
      SOME = NPRINT.NE.-5 .AND. MASWRK
      DBUG = NPRINT.GT. 0 .AND. MASWRK
      IF(SOME) WRITE(IW,9999)
      IF(SOME) CALL TSECND(T0)
C
      IF (DIRTRF) THEN
        IF (SOME) WRITE(IW,9020)
      ELSE
        IF (SOME) WRITE(IW,9030)
      END IF
C
C        NFT13 IS USED HERE TO STORE SEMI-TRANSFORMED INTEGRALS.
C
      IF (INITAL) THEN
         CALL SEQOPN(IJKT,'MOINTS','UNKNOWN',.FALSE.,'UNFORMATTED')
         CALL SEQOPN(NFT13,'CASINTS','UNKNOWN',.FALSE.,'UNFORMATTED')
         INITAL = .FALSE.
      END IF
C
      DO 10 I=1,MXAO
   10 IA(I)=(I*I-I)/2
C
C        ----- SET ORBITAL SPACE PARAMETERS -----
C        MORB=TOTAL VARIATION SPACE, USUALLY THE FULL BASIS SET
C        MORBS=TOTAL OCCUPIED, INCLUDING CORE
C        MCORBS=NUMBER OF CORE ORBITALS
C        NQMT=NUMBER OF LINEARLY INDEPENDENT ORBITALS
C        NCI=NUMBER OF ACTIVE ORBITALS
C
      NORBSV = NORB
      NORB = MIN(NORB,NQMT)
      NFZC = 0
      IF(CISTEP.EQ.ALDET  .OR.  CISTEP.EQ.GENCI
     *        .OR.CISTEP.EQ.ORMAS) THEN
         MORB=NORB
         MORBS=NACT+NCORSV
         MCORBS=NCORSV
      END IF
      IF(CISTEP.EQ.GUGA) THEN
         MORB=NORB
         MORBS=NORBS
         MCORBS=NCORBS
      END IF
C
      CALL GOTFM(NGOTMX)
      IF(NWORD.GT.0) NGOTMX=MIN(NWORD,NGOTMX)
C
      NCI = MORBS-MCORBS
      NCI2 = (NCI*NCI+NCI)/2
      L0 = NQMT
      L1 = NUM
      L2 = (L1*L1+L1)/2
      L3 = L1*L1
C
C          ASSIGN SOME COMMON BLOCK ELEMENTS BASED ON THIS
C
      NBF1 = L1
      NBF  = L1
      NOC  = NCI
      NDIM = L2
C
C        ---- OPTION TO DEFEAT SYMMETRY USAGE ----
C
      ABEL=ABELPT()
      IF(NOSYMT.EQ.1) CALL SYMOFF
C
C        ---- CLEAN UP AND ORTHONORMALIZE ORBITALS ----
C
      CALL VALFM(LOADFM)
      LVEC  = LOADFM  + 1
      LQ    = LVEC  + L3
      LS    = LQ    + L3
      LTMP  = LS    + L2
      LLABS = LTMP  + L1
      LWRK  = LLABS + L1
      LAST  = LWRK  + L3
      NEEDO = LAST - LVEC
      CALL GETFM(NEEDO)
C
      CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
      CALL DAREAD(IDAF,IODA,X(LS)  ,L2,12,0)
      CALL DAREAD(IDAF,IODA,X(LQ)  ,L3,45,0)
C             TRADITIONAL SETTINGS ARE 1D-08 AND 1D-06, RESPECTIVELY
      IF(NT.GT.1) THEN
         IF(ABEL) THEN
            TOLZ=1.0D-09
            TOLE=1.0D-07
         ELSE
            TOLZ=1.0D-11
            TOLE=1.0D-10
         END IF
         IF(ITER.EQ.1  .OR.  SQCDF.GT.1.0D-04) THEN
            TOLZ=TOLZ*10.0D+00
            TOLE=TOLE*10.0D+00
         END IF
         CALL CLENMO(X(LVEC),L1,L0,TOLZ,TOLE,IW,.FALSE.)
      END IF
C
C            OPTION TO PURIFY ORBITALS
C
      IF(IPURTF.EQ.2) THEN
        CALL SYMMOS(X(LLABS),X(LQ),X(LS),X(LVEC),X(LWRK),L0,L1,NORB,L1)
        CALL ORBPUR(X(LS),X(LVEC),L1,L0,.TRUE.)
        CALL DAREAD(IDAF,IODA,X(LQ),L3,45,0)
      END IF
C
      CALL ORTHO(X(LQ),X(LS),X(LVEC),X(LTMP),L0,L0,L1,L2,L1)
      CALL TFSQB(X(LVEC),X(LQ),X(LTMP),L0,L1,L1)
C
      CALL DAWRIT(IDAF,IODA,X(LVEC),L3,15,0)
      CALL RETFM(NEEDO)
C
C     ----- ASSIGN IRREP TO MO'S -----
C
      LVEC   = LOADFM + 1
      LMOIRP = LVEC   + L3
      LMOLAB = LMOIRP + L1
      LMODEG = LMOLAB + L1
      LWRK   = LMODEG + L1
      LS     = LWRK   + L1
      LQ     = LS     + L2
      LAST   = LQ     + L3
      NEEDS1 = LMOLAB - LVEC
      NEEDS2 = LAST - LMOLAB
      CALL GETFM(NEEDS1)
      CALL GETFM(NEEDS2)
      IF(EXETYP.EQ.CHECK) GO TO 90
C
      CALL DAREAD(IDAF,IODA,X(LVEC),L3,15,0)
      CALL DAREAD(IDAF,IODA,X(LS),L2,12,0)
      CALL DAREAD(IDAF,IODA,X(LQ),L3,45,0)
      CALL TRFSYM(X(LMOLAB),X(LMOIRP),X(LMODEG),X(LQ),X(LS),X(LVEC),
     *            X(LWRK),IA,L0,L1,MORB,L1)
C
   90 CONTINUE
      CALL RETFM(NEEDS2)
      IF(SOME) CALL TSECND(T1)
C
      NTSAVE = NT
      IF(DIRTRF  .AND.  .NOT.ABEL) NT=1
C
C     ----- TRANSFORM 2E-INTEGRALS AND FORM FOCK CORE OPERATOR -----
C
      LEN=L2*NCI2
C
      LWRK = LMOLAB
      LXBUF = LWRK+L2
      LIXBUF= LXBUF  + NINTMX
      LJFLG  = LIXBUF + NINTMX
      I03  = LJFLG  + NPROC
C  4 IS USED FOR THE DENSITY, 5 FOR THE FOCK MATRIX
      I04  = I03+LEN
      I05=I04+L2
      I06=I05+L2
C  THE NEXT TWO ARE USED AS INTEGRAL BUFFERS
      I07=I06+MAX(L2,NINTMX)
      LAST=I07+MAX(L2,NINTMX*LABSIZ)
      I06A=I06
      I07A=I07
      IF(NINTIC.NE.0) THEN
         I06A=LBUFPIC
         I07A=LIXIC
      ENDIF
C     IN THE ABOVE MEMORY ALLOCATION NINTMX SHOULD BE USE (NOT MINTMX).
C
C     ----- MEMORY FOR DIRECT CASSCF -----
C
      IVEC = LVEC+MCORBS*L1
      IDEN = I04
      IFCK = I05
C
      IF (DIRTRF) THEN
         CALL BASCHK(LMAX)
                       NANGM =  4
         IF(LMAX.EQ.2) NANGM =  6
         IF(LMAX.EQ.3) NANGM = 10
         IF(LMAX.EQ.4) NANGM = 15
         IF(LMAX.EQ.5) NANGM = 21
         IF(LMAX.EQ.6) NANGM = 28
         MAXG = NANGM**4
         NSH2   = (NSHELL*NSHELL+NSHELL)/2
         LGHND  = LAST
         LXINTS = LGHND  + MAXG
         LDDIJ  = LXINTS + NSH2
         LAST   = LDDIJ  + 49*MXG2
      ELSE
         MAXG   = 1
         NSH2   = 1
         LGHND  = LAST
         LXINTS = LAST
         LDDIJ  = LAST
      END IF
      I08  = LAST
C
      NEED1 = I04 - LWRK
      NEED2 = LAST - I04
      NEED  = NEEDS1+NEED1+NEED2
C
      IF(NEED.GT.NGOTMX) THEN
         IF (MASWRK) WRITE(IW,9998) NEED-NGOTMX
         CALL ABRT
      END IF
C
      CALL GETFM(NEED1)
      CALL GETFM(NEED2)
C
C        ---- GENERATE EXCHANGE INTEGRALS FOR SCHWARZ SCREENING ----
C
      IF(DIRTRF) THEN
         IF(EXETYP.EQ.CHECK) THEN
            CALL VCLR(X(LXINTS),1,NSH2)
         ELSE
            IF(DOEXCH) THEN
               CALL EXCHNG(X(LXINTS),X(LGHND),X(LDDIJ),NSH2,MAXG,INTTYP)
            ELSE
               CALL DAREAD(IDAF,IODA,X(LXINTS),NSH2,54,0)
            END IF
        END IF
      END IF
C
      CALL VCLR(X(I03),1,LEN)
C
      LEFT=NGOTMX-NEED
      NMIN=L1*NCI
      IF(LEFT.LT.NMIN) THEN
         NEED3 = 0
         GO TO 100
      END IF
C
C     ----- THREE STEP TRANSFORMATION ( -L- , -K- , AND -IJ- ) -----
C
      LPASS=MIN(LEFT/NMIN,L2)
      IF(LPASS.LT.L2) THEN
         LEFT = LEFT - LPASS*NCI2
         LPASS = LEFT/NMIN
      END IF
      NPASS=(L2-1)/LPASS+1
      IF (GOPARR) NPASS = ((NPASS-1+NPROC)/NPROC)*NPROC
      LPASS=(L2-1)/NPASS+1
      NEED3=NMIN*LPASS
      IF (SOME  .AND.  LPASS.LT.L2) THEN
        WRITE(IW,9991) NEED+L2*NMIN
      ENDIF
C
C     ----- ONE PASS ONLY NEEDED ----
C
      IF(LPASS.EQ.L2.AND.MPTRAN.EQ.0) THEN
         NEED=NEED+NEED3
         CALL GETFM(NEED3)
         IF(SOME) WRITE(IW,9995) NEED,NGOTMX,NPASS
         IPQKL = I08
         IF (EXETYP.EQ.CHECK) THEN
            CALL RETFM(NEED3)
            GO TO 250
         END IF
         CALL CASTR3(X(I03),X(I08),X(I05),X(LWRK),X(LVEC),X(I04),X(I06),
     *               X(I07),X(I06A),X(I07A),L2,L1,MCORBS,NCI,IJKO,NFT13,
     *               CUTTRF,NPQKL,ECORE,DOFOCK,
     *               X(LJFLG),X(LGHND),X(LXINTS),X(LDDIJ),MAXG,NSH2)
         CALL RETFM(NEED3)
C
C     -----             SEVERAL PASSES NEEDED                    -----
C     ----- IT MAY BE BETTER TO SWITCH TO THE TWO-STEP ALGORITHM -----
C     PARALLEL RUNS MUST EXECUTE THE THREE STEPS ALGORITHM, ALWAYS.
C     SEQUENTIAL RUNS MIGHT BE BETTER OFF DOING THE TWO STEPS
C     ALGORITHM IF THERE ARE MANY PASSES (MUCH DISK I/O) OR IF THE
C     AO INTEGRALS ARE DIRECT (MUCH COMPUTATION ON EACH PASS).
C
      ELSE
         TWOSTP = MPTRAN.EQ.2  .OR.  DIRTRF  .OR.  NPASS.GT.MAX(NCI,10)
         IF(TWOSTP  .AND.  .NOT.GOPARR) GO TO 100
         NEED=NEED+NEED3
         CALL GETFM(NEED3)
         LDIM = I08 + NEED3
         NEED4 = LPASS*NCI2
         NEED = NEED + NEED4
         CALL GETFM(NEED4)
         IF(SOME) WRITE(IW,9995) NEED,NGOTMX,NPASS
         IF (EXETYP.EQ.CHECK) THEN
            CALL RETFM(NEED4)
            CALL RETFM(NEED3)
            GO TO 250
         END IF
         IPQKL = I08
         CALL CASTR4(X(I03),X(I08),X(I05),X(LWRK),X(LVEC),X(I04),X(I06),
     *               X(I07),X(I06A),X(I07A),X(LDIM),X(LJFLG),L2,L1,
     *               MCORBS,NCI,LPASS,NPASS,IJKO,NFT13,CUTTRF,NPQKL,
     *               ECORE,X(LGHND),X(LXINTS),X(LDDIJ),MAXG,NSH2,SOME)
         CALL RETFM(NEED4)
         CALL RETFM(NEED3)
      END IF
      GO TO 200
C
C     --- TWO STEP TRANSFORMATION ( COMBINED -KL- , AND -IJ- LATER ) ---
C
  100   CONTINUE
        IF(SOME) WRITE(IW,9993) NEED,NGOTMX
        IPQKL = I03
        IF (EXETYP.EQ.CHECK) GO TO 250
        CALL CASTR1(X(I03),X(I05),X(LWRK),X(LVEC),X(I04),X(I06),
     *              X(I07),X(I06A),X(I07A),L2,L1,MCORBS,NCI,IJKO,NFT13,
     *              CUTTRF,NPQKL,ECORE,X(LJFLG),
     *              X(LGHND),X(LXINTS),X(LDDIJ),MAXG,NSH2)
C
C     ----- TRANSFORM 1E-INTEGRALS -----
C
  200 CONTINUE
      DO 50 I=0,L1*NCI-1
   50    X(LVEC+I)=X((LVEC+MCORBS*L1)+I)
      CALL TR1E(X(I04),X(I05),X(LVEC),X(I06),L1,NCI,MCORBS,IJKT,
     *          DBUG,X(LMOLAB))
C
  250 CONTINUE
      CALL RETFM(NEED2)
      IF(SOME) THEN
         CALL TSECND(T2)
         WRITE(IW,8000) ENUCR,ECORE,T1-T0,T2-T1
      END IF
C
C     ----- FINISH 2E-INTEGRALS TRANSFORMATION -----
C
      SOME=DBUG.OR.SOME
C
C     ----- TRANSFORM (PQ|KL) -> (IJ|KL) -----
C
      I05=I04+L1*NCI
      I06=I05+L3
      I07=I06+L3
      I08=I07+L2
      LAST2 = I08+L2
      NEED2 = LAST2- I04
      CALL GETFM(NEED2)
      IF(DBUG) WRITE(IW,9996)
      IF (EXETYP.EQ.CHECK) GO TO 400
      CALL CASTR2(X(I03),X(I05),X(I06),X(I07),
     *     X(I08),X(LVEC),X(I04),X(LMOIRP),
     *     L2,L1,IJKT,CUTTRF,DBUG,NO,X(LXBUF),X(LIXBUF))
C
C     ----- ALL IS DONE -----
C
  400 CONTINUE
      CALL RETFM(NEED2)
      CALL RETFM(NEED1)
      CALL RETFM(NEEDS1)
      CALL SEQREW(IJKT)
      IF (.NOT. DIRTRF) CALL SEQREW(IJKO)
      IF(SOME) THEN
         IF(EXETYP.NE.CHECK) THEN
            CALL TSECND(T3)
            WRITE(IW,8020) T3-T2
            WRITE(IW,9992) NPQKL,NO
         END IF
         WRITE(IW,*) '..... END OF CAS INTEGRAL TRANSFORMATION .....'
         CALL TIMIT(1)
      END IF
      NORB = NORBSV
C
      NT = NTSAVE
      IF(NOSYMT.EQ.1) CALL SYMON
      RETURN
C
 9020 FORMAT(1X,'AO INTEGRALS WILL BE CALCULATED IN DIRECT MODE...')
 9030 FORMAT(1X,'AO INTEGRALS WILL BE READ IN FROM DISK...')
 9999 FORMAT(/,10X,30('-'),
     1       /,10X,'CASSCF INTEGRAL TRANSFORMATION',
     2       /,10X,30('-'))
 9998 FORMAT(/' NOT ENOUGH CORE TO TRANSFORM THE 2E- INTEGRALS'/
     *        ' INCREASE CORE BY AT LEAST ',I10,' WORDS')
 9996 FORMAT(/' TRANSFORMED 2E- INTEGRALS')
 9991 FORMAT(1X,'MEMORY WHICH WOULD BE NEEDED FOR SINGLE PASS',
     *          ' TRANSFORMATION = ',I10)
 9995 FORMAT(/1X,'----- CHOOSING THREE STEPS TRANSFORMATION -----'/
     1        1X,'NUMBER OF WORDS USED      = ',I10/
     2        1X,'NUMBER OF WORDS AVAILABLE = ',I10/
     *        1X,'NUMBER OF PASSES          = ',I10)
 9993 FORMAT(/1X,'----- CHOOSING TWO STEPS TRANSFORMATION -----'/
     1        1X,'NUMBER OF WORDS USED      = ',I10/
     2        1X,'NUMBER OF WORDS AVAILABLE = ',I10)
 9992 FORMAT(/1X,'NUMBER OF (PQ|KL) INTEGRALS WRITTEN ',I10/
     1        1X,'NUMBER OF (IJ|KL) INTEGRALS WRITTEN ',I10)
 8000 FORMAT(/1X,'----- NUCLEAR REPULSION ENERGY = ',F15.8/
     1        1X,'----- FROZEN CORE ENERGY       = ',F15.8//
     2        1X,'... SYMMETRY ...           CPU =',F8.2/
     3        1X,'... (PQ|RS) -> (PQ|KL) ... CPU =',F8.2)
 8020 FORMAT(1X,'... (PQ|KL) -> (IJ|KL) ... CPU =',F8.2)
      END
C*MODULE MCCAS   *DECK CASTR1
      SUBROUTINE CASTR1(XPQKL,F,WRK,C,D,XX1,IX1,XX,IX,NUM2,NUM,NCORB,
     *                  NCI,IJK,NFT,TOL,NPQKL,EC,JFLG,GHONDO,XINTS,DDIJ,
     *                  MAXG,NSH2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL PACK2E,DIRTRF,GOPARR,DSKWRK,MASWRK
C
      DIMENSION XPQKL(NUM2,*),F(*),C(NUM,*),D(*),XX1(*),IX1(*),XX(*),
     *          IX(*),WRK(*),JFLG(0:NPROC-1),GHONDO(MAXG),XINTS(NSH2),
     *          DDIJ(*)
C
      COMMON /DIRCAS/ I2CASE
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
      PARAMETER (ZERO=0.0D+00, PT5=0.5D+00)
C
      EC=ZERO
      NCI2=(NCI*(NCI+1))/2
C
      IF(NCORB.NE.0) THEN
C
C     ----- CALCULATE CORE DENSITY MATRIX -----
C
         CALL GETDEN(D,C,NUM,NCORB)
C
C     ----- GET 1E-CONTRIBUTION -----
C
         CALL DAREAD(IDAF,IODA,F,NUM2,11,0)
         EC = TRACEP(D,F,NUM)
         CALL DCOPY(NUM2,ZERO,0,F,1)
      END IF
C
C     ----- PROCESS 2E-INTEGRALS -----
C
      CALL DCOPY(NUM2*NCI2,ZERO,0,XPQKL,1)
      IF(.NOT.DIRTRF) THEN
C
C     ----- 2E-INTEGRALS FROM DISK -----
C
        DO 5 KAP=0,NPROC-1
            JFLG(KAP)=1
    5    CONTINUE
         KAP = -1
         IFLG=  1
C
         CALL SEQREW(IJK)
C        FIRST, PROCESS IN CORE INTEGRALS
         NPACKIC=0
C
   10    CONTINUE
         IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
            NXX=NXXIC
            NINT=NXX
         ELSE
C           IF ALL IN CORE BAIL OUT
            IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 70
            IF(.NOT. GOPARR .OR. ITRFAO.EQ.1) THEN
               CALL PREAD(IJK,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
            ELSE
               CALL PREADP(IJK,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX,
     *                     KAP,IFLG,JFLG,NPROC)
               IF(IFLG.EQ.0) THEN
                  CALL SEQREW(IJK)
                  GO TO 70
               END IF
            END IF
C
            IF(NXX.EQ.0) GO TO 20
            NINT=ABS(NXX)
            IF(NINT.GT.NINTMX) THEN
               WRITE(IW,9999)
               CALL ABRT
            END IF
         ENDIF
C
         IF(NCORB.NE.0) THEN
            CALL TWOTFF(XPQKL,C(1,NCORB+1),F,D,NUM2,NUM,NCI,XX,IX,NXX,
     *                  NPACKIC)
         ELSE
            CALL TWOTRF(XPQKL,C(1,NCORB+1),    NUM2,NUM,NCI,XX,IX,NXX,
     *                  NPACKIC)
         END IF
C
   20    CONTINUE
         IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C        SWITCH TO INTEGRALS ON DISK
         IF((.NOT.GOPARR .OR. ITRFAO.EQ.1) .AND. NXX.LE.0) THEN
            CALL SEQREW(IJK)
            GO TO 70
         END IF
         GO TO 10
      END IF
C
C     ----- DIRECT CASSCF -----
C
      IF(DIRTRF) THEN
         I2CASE=2
         CALL DIRJK(GHONDO,XINTS,DDIJ,XX,IX,MAXG,NSH2)
      END IF
C
C     -----         POST-PROCESSING OF FOCK MATRIX              -----
C
   70 CONTINUE
      IF(NCORB.NE.0) THEN
         DO 80 MP=2,NUM
         DO 80 MQ=1,MP-1
            MPQ=IA(MP)+MQ
   80       F(MPQ)=F(MPQ)*PT5
         CALL SYMH(F,WRK,IA)
C
C     ----- 2E-CONTRIBUTION TO FROZEN CORE ENERGY -----
C
         EC = EC+TRACEP(D,F,NUM)
         EC = EC+EC
      END IF
C
C     ----- SAVE (PQ|KL) INTEGRALS FOR MICROITERATIONS -----
C
      NPQKL=0
      CALL SEQREW(NFT)
      DO 30 MKL=1,NCI2
         CALL DCOPY(NUM2,XPQKL(1,MKL),1,XX1,1)
         CALL TRFWTM(NFT,XX1,NUMX,IX1,IXNUM,NUM2,1,TOL)
         NPQKL=NPQKL+NUMX
   30 CONTINUE
C
      RETURN
 9999 FORMAT(' INCONSISTENT FILE PARAMETERS IN -CASTR1- . STOP')
      END
C*MODULE MCCAS   *DECK CASTR2
      SUBROUTINE CASTR2(XPQKL,X,Y,XX,IX,CO,CT,MOSIRP,
     *                  NBF2,NBF,NFTO,TOL,DBUG,NO,XBUF,IXBUF)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DBUG,PACK2E,MASWRK,DSKWRK,GOPARR,NXT,DIRTRF,SYM2EI
C
      DIMENSION XBUF(*),IXBUF(*),XPQKL(NBF2,*),X(NBF,*),Y(NBF,*)
      DIMENSION CO(NBF,*),CT(NCI,*),MOSIRP(*),XX(*),IX(*)
C
      COMMON /MCPAR / NFZC,NCORBS,NCI,NORBS,NORB,NUM1
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C-MWS COMMON /SYMMUL/ NIJREP(14,14),IJREP(2,14,14,14)
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
      PARAMETER (ZERO=0.0D+00)
C
C     ----- TRANSFORM (PQ|KL) TO (IJ|KL) -----
C
      DO 10 MK=1,NCI
      DO 10 MP=1,NBF
   10    CT(MK,MP)=CO(MP,MK)
C
      IF (GOPARR) THEN
         NXT = IBTYP.EQ.1  .AND.  ITRFAO.EQ.1
         IPCOUNT = ME - 1
         NEXT = -1
         MINE = -1
      END IF
C
C-MWS-     GO TO 100
C     THE OTHER CODE AT THE BOTTOM (STARTING AT 100) IS ALSO A
C     WORKING CODE.  TO USE IT IN PARALLEL MODE, DON'T CALL GLOBAL
C     SUM IN GUGSRT, AND MAKE ALL NODES WRITE 1E INTEGRALS IN TR1E
C     AND READ THEM IN GUGSRT.
C
      NUMX=0
      NREC=0
      NINT=0
      NO=0
      MKL=0
      NKL=0
      MK=1
C
   60 CONTINUE
      IF (GOPARR) THEN
        IF (NXT) THEN
          MINE = MINE + 1
          IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
          IF (NEXT.NE.MINE) THEN
             NKL = NKL + MK
             IF(MK.GT.NCORBS) MKL = MKL + MK - NCORBS
             GO TO 55
          END IF
        ELSE
          IPCOUNT = IPCOUNT + 1
          IF (MOD(IPCOUNT,NPROC).NE.0) THEN
             NKL = NKL + MK
             IF(MK.GT.NCORBS) MKL = MKL + MK - NCORBS
             GO TO 55
          END IF
        END IF
      END IF
C
      DO 50 ML=1,MK
         NKL=NKL+1
         MAJ=0
         IF(MK.LE.NCORBS .OR. ML.LE.NCORBS) GO TO 40
         MKL=MKL+1
         MPQ=0
         DO 20 MP=1,NBF
         DO 20 MQ=1,MP
            MPQ=MPQ+1
            X(MP,MQ)=XPQKL(MPQ,MKL)
   20       X(MQ,MP)=X(MP,MQ)
C
         CALL MRARBR(X,NBF,NBF,NBF,CO,NBF,NCI,Y,NBF)
         CALL MRARBR(CT,NCI,NCI,NBF,Y,NBF,NCI,X,NBF)
C
C-MWS    KLREP=IJREP(2,1,MOSIRP(MK),MOSIRP(ML))
         DO 30 MA=1,NORBS
         DO 30 MJ=1,MA
            MAJ=MAJ+1
            DUM=ZERO
            IF(MA.LE.NCORBS .OR. MJ.LE.NCORBS) GO TO 30
            IF(MAJ.LT.NKL) GO TO 30
C-MWS       IF(KLREP.NE.IJREP(2,1,MOSIRP(MA),MOSIRP(MJ))) GO TO 30
            IF(.NOT.SYM2EI(MOSIRP(MA),MOSIRP(MJ),
     *                     MOSIRP(MK),MOSIRP(ML))) GO TO 30
            DUM=X(MA-NCORBS,MJ-NCORBS)
   30       XX(MAJ)=DUM
C
   40    CONTINUE
         MLTEMP = ML
         CALL TRFWT(NFTO,XX,NUMX,IX,XBUF,MAJ,1,TOL,NREC,DBUG,
     *              MK,MLTEMP,IXBUF)
         IF(DBUG.AND.NUMX.GT.0)
     *      CALL TRFOUT(XX,NUMX,IX,NUMX,NORB,MK,ML)
         CALL VCLR(XX,1,NBF2)
   50 CONTINUE
C
   55 CONTINUE
      MK=MK+1
      IF(MK.LE.NORBS) GO TO 60
C
      IF (DBUG) CALL TR2OUT(0,0,0,0,0,ZERO,1)
      NINT = NREC*NINTMX+NUMX
      NREC = NREC+1
      NUMX = -NUMX
      CALL PWRIT(NFTO,XBUF,IXBUF,NUMX,NINTMX)
C
      IF (GOPARR) THEN
         CALL DDI_GSUMI(2204,NINT,1)
         IF (NXT) CALL DDI_DLBRESET
      END IF
C
      IF (MASWRK.AND.DBUG) WRITE (IW,9008) NINT,NREC,NINTMX
      NO=NINT
      RETURN
C
C-MWS-      DIMENSION XIJKL(*)
C  THE ABOVE STORAGE WAS FIRST THE CALLING ARGUMENT TO THIS ROUTINE,
C  AND WAS EQUIVALENT BY CALL TO THE ARRAY -XPQKL-
C-MWS-  100 CONTINUE
C-MWS-C
C-MWS-      IJKL=0
C-MWS-      MKL =0
C-MWS-      MK=1
C-MWS-C
C-MWS-  190 CONTINUE
C-MWS-      IF (GOPARR) THEN
C-MWS-        IF (NXT) THEN
C-MWS-          MINE = MINE + 1
C-MWS-          IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
C-MWS-          IF (NEXT.NE.MINE) THEN
C-MWS-             MKL = MKL + MK
C-MWS-             DO 145 ML=1,MK
C-MWS-                DO 135 MJ=ML,MK
C-MWS-                   IJKL = IJKL + 1
C-MWS-                   XIJKL(IJKL) = ZERO
C-MWS-  135           CONTINUE
C-MWS-                DO 145 MA=MK+1,NCI
C-MWS-                DO 145 MJ=1,MA
C-MWS-                   IJKL = IJKL + 1
C-MWS-                   XIJKL(IJKL) = ZERO
C-MWS-  145        CONTINUE
C-MWS-             GO TO 180
C-MWS-          END IF
C-MWS-        ELSE
C-MWS-          IPCOUNT = IPCOUNT + 1
C-MWS-          IF (MOD(IPCOUNT,NPROC).NE.0) THEN
C-MWS-             MKL = MKL + MK
C-MWS-             DO 165 ML=1,MK
C-MWS-                DO 155 MJ=ML,MK
C-MWS-                   IJKL = IJKL + 1
C-MWS-                   XIJKL(IJKL) = ZERO
C-MWS-  155           CONTINUE
C-MWS-                DO 165 MA=MK+1,NCI
C-MWS-                DO 165 MJ=1,MA
C-MWS-                   IJKL = IJKL + 1
C-MWS-                   XIJKL(IJKL) = ZERO
C-MWS-  165        CONTINUE
C-MWS-             GO TO 180
C-MWS-          END IF
C-MWS-        END IF
C-MWS-      END IF
C-MWS-C
C-MWS-      DO 140 ML=1,MK
C-MWS-         MKL=MKL+1
C-MWS-         MPQ=0
C-MWS-         DO 110 MP=1,NBF
C-MWS-         DO 110 MQ=1,MP
C-MWS-            MPQ=MPQ+1
C-MWS-            X(MP,MQ)=XPQKL(MPQ,MKL)
C-MWS-  110       X(MQ,MP)=X(MP,MQ)
C-MWS-C
C-MWS-         CALL MRARBR(X,NBF,NBF,NBF,CO,NBF,NCI,Y,NBF)
C-MWS-         CALL MRARBR(CT,NCI,NCI,NBF,Y,NBF,NCI,X,NBF)
C-MWS-C
C-MWS-         MA = MK
C-MWS-         DO 120 MJ=ML,MA
C-MWS-            IJKL = IJKL + 1
C-MWS-  120       XIJKL(IJKL)=X(MA,MJ)
C-MWS-         DO 130 MA=MK+1,NCI
C-MWS-         DO 130 MJ=1,MA
C-MWS-            IJKL = IJKL + 1
C-MWS-  130       XIJKL(IJKL)=X(MA,MJ)
C-MWS-  140 CONTINUE
C-MWS-C
C-MWS-  180 CONTINUE
C-MWS-      MK = MK + 1
C-MWS-      IF (MK.LE.NCI) GO TO 190
C-MWS-C
C-MWS-      IF (GOPARR) THEN
C-MWS-         CALL DDI_GSUMF(2205,XIJKL,IJKL)
C-MWS-         IF (NXT) CALL DDI_DLBRESET
C-MWS-      END IF
C-MWS-C
C-MWS-      NUMX=0
C-MWS-      NREC=0
C-MWS-      NINT=0
C-MWS-      NO  =0
C-MWS-      IJKL=0
C-MWS-      NKL =0
C-MWS-      DO 170 MK=1,NORBS
C-MWS-      DO 170 ML=1,MK
C-MWS-         NKL=NKL+1
C-MWS-         MAJ=0
C-MWS-         IF(MK.LE.NCORBS .OR. ML.LE.NCORBS) GO TO 160
C-MWS-         DO 150 MA=1,NORBS
C-MWS-         DO 150 MJ=1,MA
C-MWS-            MAJ=MAJ+1
C-MWS-            DUM=ZERO
C-MWS-            IF(MA.LE.NCORBS .OR. MJ.LE.NCORBS) GO TO 150
C-MWS-            IF(MAJ.LT.NKL) GO TO 150
C-MWS-            IJKL = IJKL + 1
C-MWS-            IF(.NOT.SYM2EI(MOSIRP(MA),MOSIRP(MJ),
C-MWS*                           MOSIRP(MK),MOSIRP(ML))) GO TO 150
C-MWS-            DUM=XIJKL(IJKL)
C-MWS-  150       XX(MAJ)=DUM
C-MWS-C
C-MWS-  160    CALL TRFWT(NFTO,XX,NUMX,IX,XBUF,MAJ,1,TOL,NREC,DBUG,
C-MWS-     *              MK,ML,IXBUF)
C-MWS-         IF(DBUG.AND.NUMX.GT.0)
C-MWS-     *      CALL TRFOUT(XX,NUMX,IX,NUMX,NORB,MK,ML)
C-MWS-         CALL VCLR(XX,1,NBF2)
C-MWS-  170 CONTINUE
C-MWS-C
C-MWS-      IF (DBUG) CALL TR2OUT(0,0,0,0,0,ZERO,1)
C-MWS-      NINT = NREC*NINTMX+NUMX
C-MWS-      NREC = NREC+1
C-MWS-      NUMX = -NUMX
C-MWS-      CALL PWRIT(NFTO,XBUF,IXBUF,NUMX,NINTMX)
C-MWS-      IF (MASWRK.AND.DBUG) WRITE (IW,9008) NINT,NREC,NINTMX
C-MWS-      NO=NINT
C-MWS-C
C-MWS-      RETURN
C
 9008 FORMAT(49H TOTAL NUMBER OF TRANSFORMED 2E-INTEGRALS KEPT = ,I10,
     +     4H IN ,I10,14H RECORD(S) OF ,I5,11H INTEGRALS.)
      END
C*MODULE MCCAS   *DECK CASTR3
      SUBROUTINE CASTR3(XPQKL,XPQRJ,F,WRK,C,D,XX1,IX1,XX,IX,NUM2,NUM,
     *                  NCORB,NCI,IJK,NFT,TOL,NPQKL,EC,DOFOCK,
     *                  JFLG,GHONDO,XINTS,DDIJ,MAXG,NSH2)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      LOGICAL DOFOCK,MASWRK,DSKWRK,GOPARR
C
      DIMENSION XPQKL(NUM2,*),XPQRJ(NCI,NUM2,*)
      DIMENSION C(NUM,*),F(*),WRK(*),D(*),XX1(*),IX1(*),XX(*),IX(*),
     *          JFLG(0:NPROC-1),GHONDO(MAXG),XINTS(NSH2),DDIJ(*)
C
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
C
      PARAMETER (ZERO=0.0D+00)
C
      CALL TR1MC(XPQRJ,F,WRK,C,C(1,NCORB+1),D,XX,IX,JFLG,NPROC,
     *           NUM2,NUM,NCORB,NCI,IJK,EC,DOFOCK,
     *           GHONDO,XINTS,DDIJ,MAXG,NSH2)
C
C     ----- TRANSFORM SECOND INDEX: (PQ|RL) -> (PQ|KL) -----
C
      DO 120 MPQ=1,NUM2
         MKL=0
         DO 120 MK=1,NCI
            DO 100 MR=1,NUM
               XX1(MR)=XPQRJ(MK,MPQ,MR)
  100       CONTINUE
            DO 120 ML=1,MK
               MKL=MKL+1
               DUM=ZERO
               DO 110 MR=1,NUM
                  DUM=DUM+C(MR,NCORB+ML)*XX1(MR)
  110          CONTINUE
               XPQKL(MPQ,MKL)=DUM
  120       CONTINUE
C
C     ----- SAVE (PQ|KL) INTEGRALS FOR MICROITERATIONS -----
C
      NCI2=(NCI*(NCI+1))/2
      NPQKL=0
      CALL SEQREW(NFT)
      DO 140 MKL=1,NCI2
         CALL DCOPY(NUM2,XPQKL(1,MKL),1,XX1,1)
         CALL TRFWTM(NFT,XX1,NUMX,IX1,IXNUM,NUM2,1,TOL)
  140    NPQKL=NPQKL+NUMX
C
      RETURN
      END
C*MODULE MCCAS   *DECK CASTR4
      SUBROUTINE CASTR4(XPQKL,XPQRJ,F,WRK,C,D,XX1,IX1,XX,IX,XDIM,JFLG,
     *                  NUM2,NUM,NCORB,NCI,NDIM,NPASS,
     *                  IJK,NFT,TOL,NPQKL,EC,
     *                  GHONDO,XINTS,DDIJ,MAXG,NSH2,SOME)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      LOGICAL PACK2E,MASWRK,DSKWRK,GOPARR,NXT,DIRTRF,SOME
C
      DIMENSION XPQKL(NUM2,*),XPQRJ(NCI,NDIM,*),JFLG(0:NPROC-1)
      DIMENSION F(*),C(NUM,*),D(*),XX(*),IX(*),WRK(*),XDIM(NDIM,*)
      DIMENSION XX1(*),IX1(*),GHONDO(MAXG),XINTS(NSH2),DDIJ(*)
C
      COMMON /DIRCAS/ I2CASE
      COMMON /DIRMEM/ IPQKL,IVEC,IDEN,IFCK,NBF,NOC,MDIM,MINPQ,MAXPQ
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(950)
      COMMON /INTFIL/ NINTMX,NHEX,NTUPL,PACK2E,INTTYP,IGRDTYP
      COMMON /INT2IC/ NINTIC,ININTIC,NXXIC,LBUFPIC,LIXIC,LABSIX,NINTIX
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /TRFOPT/ CUTTRF,NWDTRF,MPTRAN,ITRFAO,NOSYMT,IPURTF,DIRTRF
C
      PARAMETER (ZERO=0.0D+00,PT5=0.5D+00)
C
      EC=ZERO
      NCI2=(NCI*(NCI+1))/2
      IF(NCORB.NE.0) THEN
C
C     ----- CALCULATE CORE DENSITY MATRIX -----
C
         CALL GETDEN(D,C,NUM,NCORB)
C
C     ----- GET 1E-CONTRIBUTION -----
C
         CALL DAREAD(IDAF,IODA,F,NUM2,11,0)
         EC = TRACEP(D,F,NUM)
         CALL DCOPY(NUM2,ZERO,0,F,1)
      END IF
C
      IF (GOPARR) THEN
         NXT = IBTYP.EQ.1  .AND.  ITRFAO.EQ.1
         IPCOUNT = ME - 1
         NEXT = -1
         MINE = -1
      END IF
C
C     ----- PROCESS 2E-INTEGRALS -----
C
      MINPQ=1
      IPASS=0
   50 CONTINUE
      MAXPQ=MIN(NUM2,MINPQ+NDIM-1)
      IPASS = IPASS+1
      IF (GOPARR) THEN
        IF (NXT) THEN
          MINE = MINE + 1
          IF(MINPQ.EQ.1) THEN
             IF(MASWRK) THEN
                NEXT = 0
             ELSE
                IF(MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
                IF(NEXT.EQ.0) CALL DDI_DLBNEXT(NEXT)
             END IF
          ELSE
             IF (MINE.GT.NEXT) CALL DDI_DLBNEXT(NEXT)
             IF (NEXT.EQ.0) CALL DDI_DLBNEXT(NEXT)
          END IF
          IF (NEXT.NE.MINE) THEN
            IF(SOME) WRITE(IW,9400) IPASS
             GO TO 125
          END IF
        ELSE
          IPCOUNT = IPCOUNT + 1
          IF (MOD(IPCOUNT,NPROC).NE.0) THEN
             IF(IPASS.LE.NPASS .AND. SOME) WRITE(IW,9400) IPASS
             GO TO 125
          END IF
        END IF
      END IF
      IF(IPASS.GT.NPASS) GO TO 125
C
      IF(SOME) CALL TSECND(T0)
      CALL VCLR(XPQRJ,1,NUM*NCI*NDIM)
C
C     ----- 2E-INTEGRALS ON DISK -----
C
      IF (.NOT.DIRTRF) THEN
         DO 55 KAP=0,NPROC-1
            JFLG(KAP)=1
   55    CONTINUE
         KAP = -1
         IFLG=  1
C
         CALL SEQREW(IJK)
C        FIRST, PROCESS IN CORE INTEGRALS
         NPACKIC=0
   60    CONTINUE
         IF(NPACKIC.EQ.0.AND.NINTIC.NE.0) THEN
            NXX=NXXIC
            NINT=NXX
         ELSE
C           IF ALL IN CORE BAIL OUT
            IF(NINTIC.NE.0.AND.NXXIC.LT.NINTIC) GO TO 70
            IF(.NOT. GOPARR .OR. ITRFAO.EQ.1) THEN
               CALL PREAD(IJK,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX)
            ELSE
               CALL PREADP(IJK,XX(NINTIC+1),IX(ININTIC+1),NXX,NINTMX,
     *                     KAP,IFLG,JFLG,NPROC)
               IF(IFLG.EQ.0) THEN
                  CALL SEQREW(IJK)
                  GO TO 70
               END IF
            END IF
C
            IF(NXX.EQ.0) GO TO 20
            NINT=ABS(NXX)
            IF(NINT.GT.NINTMX) THEN
              IF(MASWRK) WRITE(IW,9999)
              CALL ABRT
            END IF
         ENDIF
         IF(NCORB.NE.0.AND.MINPQ.EQ.1) THEN
            CALL ONEPFF(XPQRJ,C(1,NCORB+1),F,D,NDIM,MINPQ,MAXPQ,
     *                  NUM,NCI,XX,IX,NXX,NPACKIC)
         ELSE
            CALL ONEPRF(XPQRJ,C(1,NCORB+1),NDIM,MINPQ,MAXPQ,
     *                  NUM,NCI,XX,IX,NXX,NPACKIC)
         END IF
C
   20    CONTINUE
         IF(NPACKIC.EQ.0) NPACKIC=NINTIC
C        SWITCH TO INTEGRALS ON DISK
         IF((.NOT.GOPARR .OR. ITRFAO.EQ.1) .AND. NXX.LE.0) THEN
            CALL SEQREW(IJK)
            GO TO 70
         END IF
         GO TO 60
      END IF
C
C     ----- DIRECT TRANSFORMATION -----
C
      IF (DIRTRF) THEN
         IF(NCORB.NE.0.AND.MINPQ.EQ.1) THEN
            I2CASE=4
         ELSE
            I2CASE=5
         END IF
         MDIM=NDIM
         CALL DIRJK(GHONDO,XINTS,DDIJ,XX,IX,MAXG,NSH2)
      END IF
C
   70 CONTINUE
C
C     -----         POST-PROCESSING OF FOCK MATRIX              -----
C
      IF(NCORB.NE.0.AND.MINPQ.EQ.1) THEN
         DO 80 MP=2,NUM
         DO 80 MQ=1,MP-1
            MPQ=IA(MP)+MQ
   80       F(MPQ)=F(MPQ)*PT5
         CALL SYMH(F,WRK,IA)
      END IF
C
C     ----- TRANSFORM SECOND INDEX: (PQ|RL) -> (PQ|KL) -----
C
      DO 120 MPQ=1,MAXPQ-MINPQ+1
         MKL=0
         DO 120 MK=1,NCI
         DO 120 ML=1,MK
            MKL=MKL+1
            DUM=ZERO
            DO 110 MR=1,NUM
  110          DUM=DUM+C(MR,NCORB+ML)*XPQRJ(MK,MPQ,MR)
  120    XPQKL(MPQ+MINPQ-1,MKL)=DUM
C
  125 CONTINUE
      MINPQ=MAXPQ+1
      IF(SOME) THEN
         CALL TSECND(TIM)
         TIM = TIM - T0
         WRITE(IW,9390) IPASS,TIM
         CALL FLSHBF(IW)
      END IF
      IF(MINPQ.LE.NUM2) GO TO 50
C
      IF (GOPARR) THEN
         IF (NXT) THEN
            CALL DDI_GSUMF(2206,XPQKL,NUM2*NCI2)
            CALL DDI_DLBRESET
         ELSE
            DO 126 IPASS=0,NPASS-1
               JPASS = IPASS*NDIM
               IPROC = MOD(NPASS-IPASS,NPROC)
               IF (ME.EQ.IPROC) THEN
                  DO 127 I=1,NCI2
                     DO 127 J=1,NDIM
                        JDIM = JPASS + J
                        XDIM(J,I) = XPQKL(JDIM,I)
  127             CONTINUE
               END IF
               CALL DDI_BCAST(2208,'F',XDIM,NDIM*NCI2,IPROC)
               IF (ME.NE.IPROC) THEN
                  DO 128 I=1,NCI2
                     DO 128 J=1,NDIM
                        JDIM = JPASS + J
                        XPQKL(JDIM,I) = XDIM(J,I)
  128             CONTINUE
               END IF
  126       CONTINUE
         END IF
C
         CALL DDI_BCAST(2207,'F',F,NUM2,MASTER)
      END IF
C
C     ----- 2E-CONTRIBUTION TO FROZEN CORE ENERGY -----
C
      IF(NCORB.NE.0) THEN
         EC = EC+TRACEP(D,F,NUM)
         EC = EC+EC
      END IF
C
C     ----- SAVE (PQ|KL) INTEGRALS FOR MICROITERATIONS -----
C
      NPQKL=0
      CALL SEQREW(NFT)
      DO 130 MKL=1,NCI2
         CALL DCOPY(NUM2,XPQKL(1,MKL),1,XX1,1)
         CALL TRFWTM(NFT,XX1,NUMX,IX1,IXNUM,NUM2,1,TOL)
         NPQKL=NPQKL+NUMX
  130 CONTINUE
C
      RETURN
 9390 FORMAT(1X,'PASS #',I4,' COMPLETED IN',F12.1,' SECONDS.')
 9400 FORMAT(1X,'PASS #',I4,' IS ASSIGNED TO A DIFFERENT PROCESSOR.')
 9999 FORMAT(' INCONSISTENT FILE PARAMETERS IN -CASTR4- . STOP')
      END
C*MODULE MCCAS   *DECK TWOTRF
      SUBROUTINE TWOTRF(XPQKL,CO,NUM2,NUM,NOC,XX,IX,NXX,NPACKIC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      DIMENSION XPQKL(NUM2,*),CO(NUM,*),XX(*),IX(*)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /PCKLAB/ LABSIZ
C
      NINT = ABS(NXX)
C
      IF(LABSIZ.GE.2) THEN
C
C     ----- TWO BYTES PER LABEL -----
C
         DO 20 M=1,NINT
                       NPACK = NPACKIC+M
            VAL1 = XX(NPACK)
            VAL3 = VAL1
C
*I32                     LABEL = IX( 2*NPACK - 1 )
*I32                     IPACK = ISHFT( LABEL, -16 )
*I32                     JPACK = IAND( LABEL, 65535 )
*I32                     LABEL = IX( 2*NPACK     )
*I32                     KPACK = ISHFT( LABEL, -16 )
*I32                     LPACK = IAND( LABEL, 65535 )
*I64                     LABEL = IX(NPACK)
*I64                     IPACK = ISHFT( LABEL, -48 )
*I64                     JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64                     KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64                     LPACK = IAND( LABEL, 65535 )
                       MP = IPACK
                       MQ = JPACK
                       MR = KPACK
                       MS = LPACK
C
            MPQ= IA(MP)+MQ
            MRS= IA(MR)+MS
            IF(MP.EQ.MQ) VAL1 = VAL1+VAL1
            IF(MR.EQ.MS) VAL3 = VAL3+VAL3
            MKL=0
            DO 10 MK=1,NOC
            DO 10 ML=1,MK
               MKL = MKL+1
               XPQKL(MPQ,MKL) = XPQKL(MPQ,MKL) +
     *               VAL1*(CO(MS,MK)*CO(MR,ML)+CO(MS,ML)*CO(MR,MK))
               XPQKL(MRS,MKL) = XPQKL(MRS,MKL) +
     *               VAL3*(CO(MQ,MK)*CO(MP,ML)+CO(MQ,ML)*CO(MP,MK))
   10       CONTINUE
   20    CONTINUE
C
      ELSE
C
C     ----- ONE BYTE PER LABEL -----
C
*VDIR NODIVLOOP
         DO 40 M=1,NINT
                       NPACK = NPACKIC+M
            VAL1 = XX(NPACK)
            VAL3 = VAL1
C
*I32                     LABEL = IX(NPACK)
*I32                     IPACK = ISHFT( LABEL, -24 )
*I32                     JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32                     KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32                     LPACK = IAND( LABEL, 255 )
*I64                     IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64                       LABEL = IX( NPACK/2 )
*I64                       IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64                       JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64                       LPACK = IAND( LABEL, 255 )
*I64                     ELSE
*I64                       LABEL = IX( (NPACK/2)+1 )
*I64                       IPACK = ISHFT( LABEL, -56 )
*I64                       JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64                       LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64                     END IF
                       MP = IPACK
                       MQ = JPACK
                       MR = KPACK
                       MS = LPACK
C
            MPQ= IA(MP)+MQ
            MRS= IA(MR)+MS
            IF(MP.EQ.MQ) VAL1 = VAL1+VAL1
            IF(MR.EQ.MS) VAL3 = VAL3+VAL3
            MKL=0
            DO 30 MK=1,NOC
            DO 30 ML=1,MK
               MKL = MKL+1
               XPQKL(MPQ,MKL) = XPQKL(MPQ,MKL) +
     *               VAL1*(CO(MS,MK)*CO(MR,ML)+CO(MS,ML)*CO(MR,MK))
               XPQKL(MRS,MKL) = XPQKL(MRS,MKL) +
     *               VAL3*(CO(MQ,MK)*CO(MP,ML)+CO(MQ,ML)*CO(MP,MK))
   30       CONTINUE
   40     CONTINUE
C
      END IF
C
      RETURN
      END
C*MODULE MCCAS   *DECK TWOTFF
      SUBROUTINE TWOTFF(XPQKL,CO,FC,DC,NUM2,NUM,NOC,XX,IX,NXX,NPACKIC)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      PARAMETER (MXAO=8192)
C
      DIMENSION XPQKL(NUM2,*),CO(NUM,*),FC(*),DC(*),XX(*),IX(*)
C
      COMMON /IJPAIR/ IA(MXAO)
      COMMON /PCKLAB/ LABSIZ
C
      NINT = ABS(NXX)
C
      IF(LABSIZ.GE.2) THEN
C
C     ----- TWO LABELS PER INTEGRAL -----
C
         DO 20 M=1,NINT
                       NPACK = NPACKIC+M
            VAL1 = XX(NPACK)
            VAL3 = VAL1
            VAL4 = (VAL1+VAL1)+(VAL1+VAL1)
C
*I32                     LABEL1 = IX( 2*NPACK - 1 )
*I32                     LABEL2 = IX( 2*NPACK     )
*I32                     IPACK = ISHFT( LABEL1, -16 )
*I32                     JPACK = IAND( LABEL1, 65535 )
*I32                     KPACK = ISHFT( LABEL2, -16 )
*I32                     LPACK = IAND( LABEL2, 65535 )
*I64                     LABEL = IX(NPACK)
*I64                     IPACK = ISHFT( LABEL, -48 )
*I64                     JPACK = IAND( ISHFT( LABEL, -32 ), 65535 )
*I64                     KPACK = IAND( ISHFT( LABEL, -16 ), 65535 )
*I64                     LPACK = IAND( LABEL, 65535 )
                       MP = IPACK
                       MQ = JPACK
                       MR = KPACK
                       MS = LPACK
C
            MPQ= IA(MP)+MQ
            MRS= IA(MR)+MS
            MPR= IA(MP)+MR
            MPS= IA(MP)+MS
            MQR= IA(MAX(MQ,MR))+MIN(MQ,MR)
            MQS= IA(MAX(MQ,MS))+MIN(MQ,MS)
            FC(MPQ) = FC(MPQ)+VAL4*DC(MRS)
            FC(MRS) = FC(MRS)+VAL4*DC(MPQ)
            FC(MPR) = FC(MPR)-VAL1*DC(MQS)
            FC(MPS) = FC(MPS)-VAL1*DC(MQR)
            FC(MQR) = FC(MQR)-VAL1*DC(MPS)
            FC(MQS) = FC(MQS)-VAL1*DC(MPR)
            IF(MP.EQ.MQ) VAL1 = VAL1+VAL1
            IF(MR.EQ.MS) VAL3 = VAL3+VAL3
            MKL=0
            DO 10 MK=1,NOC
            DO 10 ML=1,MK
               MKL = MKL+1
               XPQKL(MPQ,MKL) = XPQKL(MPQ,MKL) +
     *               VAL1*(CO(MS,MK)*CO(MR,ML)+CO(MS,ML)*CO(MR,MK))
               XPQKL(MRS,MKL) = XPQKL(MRS,MKL) +
     *               VAL3*(CO(MQ,MK)*CO(MP,ML)+CO(MQ,ML)*CO(MP,MK))
   10       CONTINUE
   20    CONTINUE
C
      ELSE
C
C     ----- ONE LABEL PER INTEGRAL -----
C
         DO 40 M=1,NINT
                       NPACK = NPACKIC+M
            VAL1 = XX(NPACK)
            VAL3 = VAL1
            VAL4 = (VAL1+VAL1)+(VAL1+VAL1)
C
*I32                     LABEL = IX(NPACK)
*I32                     IPACK = ISHFT( LABEL, -24 )
*I32                     JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I32                     KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I32                     LPACK = IAND( LABEL, 255 )
*I64                     IF ( MOD(NPACK,2) .EQ. 0 ) THEN
*I64                       LABEL = IX( NPACK/2 )
*I64                       IPACK = IAND( ISHFT( LABEL, -24 ), 255 )
*I64                       JPACK = IAND( ISHFT( LABEL, -16 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL,  -8 ), 255 )
*I64                       LPACK = IAND( LABEL, 255 )
*I64                     ELSE
*I64                       LABEL = IX( (NPACK/2)+1 )
*I64                       IPACK = ISHFT( LABEL, -56 )
*I64                       JPACK = IAND( ISHFT( LABEL, -48 ), 255 )
*I64                       KPACK = IAND( ISHFT( LABEL, -40 ), 255 )
*I64                       LPACK = IAND( ISHFT( LABEL, -32 ), 255 )
*I64                     END IF
                       MP = IPACK
                       MQ = JPACK
                       MR = KPACK
                       MS = LPACK
C
            MPQ= IA(MP)+MQ
            MRS= IA(MR)+MS
            MPR= IA(MP)+MR
            MPS= IA(MP)+MS
            MQR= IA(MAX(MQ,MR))+MIN(MQ,MR)
            MQS= IA(MAX(MQ,MS))+MIN(MQ,MS)
            FC(MPQ) = FC(MPQ)+VAL4*DC(MRS)
            FC(MRS) = FC(MRS)+VAL4*DC(MPQ)
            FC(MPR) = FC(MPR)-VAL1*DC(MQS)
            FC(MPS) = FC(MPS)-VAL1*DC(MQR)
            FC(MQR) = FC(MQR)-VAL1*DC(MPS)
            FC(MQS) = FC(MQS)-VAL1*DC(MPR)
            IF(MP.EQ.MQ) VAL1 = VAL1+VAL1
            IF(MR.EQ.MS) VAL3 = VAL3+VAL3
            MKL=0
            DO 30 MK=1,NOC
            DO 30 ML=1,MK
               MKL = MKL+1
               XPQKL(MPQ,MKL) = XPQKL(MPQ,MKL) +
     *               VAL1*(CO(MS,MK)*CO(MR,ML)+CO(MS,ML)*CO(MR,MK))
               XPQKL(MRS,MKL) = XPQKL(MRS,MKL) +
     *               VAL3*(CO(MQ,MK)*CO(MP,ML)+CO(MQ,ML)*CO(MP,MK))
   30       CONTINUE
   40     CONTINUE
C
      END IF
C
      RETURN
      END
