C 11 Apr 08 - SAN - synchronize call to STONE
c 28 Aug 07 - HL  - FMOX: FMO-PCM gradients
C 20 Aug 07 - TN  - calls to do electrostatic derivative, and for MCP
C 20 Aug 07 - DGF - various changes for FMO 3.1 release
C 12 Jul 07 - MC  - add FMO-TDDFT arguments
C 24 Mar 07 - MWS - pad FRGINF common block
C 22 Dec 06 - DGF - various changes for FMO 3.0 release
C  6 Nov 06 - MWS - adjust wavefunction and GDDI common block
C 29 Mar 06 - TN  - EDIMER: fix irststp=5 logic
c 17 Jan 06 - DGF - FMOX: don't reset NEFSP
C 14 Nov 05 - DGF - various changes for FMO 2.1 release
C 19 Sep 05 - MWS - add true nuclear charge array to INFOA common
C  6 Jul 05 - DGF - FMOX: redimension for CCSD(TQ) records
C  1 Jun 05 - DGF - fixes for the 2nd release
c 15 mar 05 - dgf - major changes for the second release
c  5 Feb 05 - DGF - MONOSCF: fix parallel DDI/DFT bug
c  3 Jun 04 - DGF - FMOX: restart bug fixed
c 19 May 04 - DGF,KK - implement Fragment Molecular Orbital (FMO) method
c
C*MODULE fmo     *DECK fmox
      SUBROUTINE fmox(modeff)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      logical GOPARR,DSKWRK,MASWRK,isgddi,parout,INITGDDI,DIRSCF,FDIFF,
     *        MMONLY,QMMM,SAVDSK,some,orbxch,enexch,docas,dosap,dospc,
     *        atonce,correl,primul,gcorrel,squit,linear,needdm,doddcor,
     *        esdder,savgrd,forbconv,conv2mc,savdir,modQbas,totdens,
     *        densgrid,semidyn,broadden,spargrid,densgrid0,spargrid0,
     *        inifmo0,isgddi0,grandmas,densfmo0,didcc,exclmol,dovpcm,
     *        pcmnotconv,domp,dotd,MPTEST,dopleda,doscfprp,ext2lay,fmoq,
     *        dolat,addesp,addesp0,diffesp,TRIPLET,SG1,SG1T
      Integer ddi_world,ddi_group
      Parameter(ddi_world=0,ddi_group=1)
      Parameter(MXATM=2000,MXRT=100,MAXNZ=137,MaxLay=5,MXSFMO=MaxLay*40,
     *          MXGFMO=MaxLay*100,MXAFMO=MaxLay*10,MAXL=5,MXPTPT=100,
     *          MXFGPT=12000,MXFRG=1050,MXDFG=5,MXDPPT=MXFRG*MXDFG*12,
     *          MXGRID=10)
      parameter (nstfmo=10,maxpst=10,zero=0.0D+00,one=1.0D+00,maxelm=3,
     *           nextracc=17,nedft=2)
      dimension mcnvfmo(nstfmo),ngrfmo(maxpst,MaxLay),nstjob(maxpst),
     *          loadbf(maxpst,MaxLay),loadgr(maxpst,MaxLay),ncvscf(2),
     *          nelm(0:maxelm),dum3(3),vdwrad(MAXNZ),extracc(nextracc,3)
     *         ,maxg(3),ngm(3),etotdft(nedft),prtdst(3),eint0(4),
     *          rappri(3),lbody(MaxLay),tabm(137),iexcit(5),
     *          eexcit(mxrt,2),texcit(3,mxrt,2),monoc(mxrt),
     *          monvr(mxrt),idxyz(mxrt),isumd(mxrt+1),
     *          osmd(mxrt,2)
      COMMON /BASSPH/ QMTTOL,ISPHER
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,BSLRD(137),NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0,
     *                NANGPT(MXGRID),NANGPT0(MXGRID),SG1
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /EFFMOP/ LEFLDFMO,LEFADDFMO,LDINDFMO,LDINDDFMO,
     *                LDIND2FMO,LDINDD2FMO,LDEFEF,LDEFTF,LTORQF
      COMMON /EFPFMO/ IEFPFMO,ISWENUC,REPNUCEFP,EFPEFP,RUNEFP
      COMMON /ELPROP/ ELDLOC,ELMLOC,ELPLOC,ELFLOC,
     *                IEDEN,IEMOM,IEPOT,IEFLD,MODENS,
     *                IEDOUT,IEMOUT,IEPOUT,IEFOUT,
     *                IEDINT,IEMINT,IEPINT,IEFINT
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /FGRAD / DEF(3,MXFGPT),DEFT(3,MXFRG),TORQ(3,MXFRG),
     *                EFCENT(3,MXFRG),FRGMAS(MXFRG),FRGMI(6,MXFRG),
     *                ATORQ(3,MXFRG)
      COMMON /FMCOM / X(1)
      COMMON /FRGINF/ NMPTS(MXFRG),NMTTPT,IEFC,IEFD,IEFQ,IEFO,
     *                NPPTS(MXFRG),NPTTPT,IEFP,
     *                NRPTS(MXFRG),NRTTPT,IREP,ICHGP,NFRG,
     *                NDPPTS(MXDPPT),NDPTTPT,IEFDP,LSTMPTS(MXFRG)
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,npglob,nnglob,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /GRDPAR/ ORIGIN(3),XVEC(3),YVEC(3),ZVEC(3),UX(3),UY(3),
     *                UZ(3),GRDSIZ,NGRID,IGUNIT,NXG,NYG,NZG,modgrid
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INFOTD/ TDM(3,mxrt),CNVTOL,TRIPLET,MOCC(mxrt),MVIR(mxrt),
     *                NRADT,NTHET,NPHIT,NSTAT,NTRIAL,MAXVEK,NTHST,
     *                IRECTD,NLEBT,SG1T
      common /INT2IC/ NINTIC,iNINTIC,nxxic,lbufpic,lixic,labsix,nintix
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
      COMMON /MCPFMO/ IMCPFMO,LFZCOR,LIFMPTYP,LIFMPTYP2,LMCPSW,
     *                LIZCOR2
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /PCMCHG/ PB,PX,PC,UNZ,QNUC,FN,FE,UNZOR,PORT
      COMMON /PCMDIM/ mxsp,mxts,mempcm1,mempcm2,NTS
      COMMON /PCMOPT/ RABI,RASC,REFPOL,THRSLS,DENSLS,WB,WA,ETA2,GD,EVAC,
     *                RHOW,PM,AREATL,AREAKP,BONDRY,OMEGA,RET,FRO,EPSINF,
     *                EPS,DR,RSOLV,VMOL,TCE,STEN,DSTEN,CMF,TABS,IDIRCT,
     *                IPCDER,IDP,ICOMP,IFIELD,ICAV,IDISP,IPRINT,IRETCAV,
     *                ICENT,IFAST,NEVAL,IEFPOL,KEEPSM,IMGABI,IMGASC,NADD
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEFPCM,IP_F,nfmopcm
      COMMON /PCMPLY/ STOT,VOL,CCX,CCY,CCZ,RDIF,NESF,NESFP,NESFF,I_NESF,
     *                L_AST
      COMMON /PCMPNT/ LXYZRE,LSSFE,LLIST,LALPCM,LRINPCM,LINAPCM,LINFPCM,
     *                LINIPCM,LMEPCM,LAXYZCT,LXYZCT2,LNVERT,LQSN,LQSE,
     *                LQFS,LQIND,LISPHE,LVAD,LQOR,LVECMUL,LAIPRJ,LFIPRJ
     *                ,mPEL
      COMMON /POINTS/ NPOINT,IPUNIT,XPOINT(MXPTPT),YPOINT(MXPTPT),
     *                ZPOINT(MXPTPT)
      COMMON /RAIOLN/ JRECLN(10),JRECST(10)
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /STNBUF/ STNPNT(4,2*MXATM),BIGEXP,NPTSTN,NBUFFM
      COMMON /TIMING/ CPU,WALL
      COMMON /TINOPT/ MMONLY, QMMM
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      COMMON /ZMAT  / NZMAT,NZVAR,NVAR,NSYMC,LINEAR
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
      common /fmodim/ maxbnd,maxknd,maxcbs,maxcao,maxvec,maxl1,
     *                maxnat,maxabd,maxbas
      common /fmoinf/ nfg,nlayer,natfmo,nbdfg,naotyp,nbody
      common /fmolat/ untang(3),untorg(3),respbc(4),abclat(3),anglat(3),
     *                symtra(3,24),symope(3,3,24),iatorg,nsymop,maxklms,
     *                ioporg(3),iopdir(3),iopabc(3),iopang(3)
      common /fmoopt/ espsca(9),RESPAP(2),rESPPC(2),rESDIM,restri(4),
     *                rcorsd,respct,convfg,cnvdmp,coroff,IXESP,mxitfg,
     *                nguess,NBSSE,modorb,modpar,irststp,irstlay,nprfmo,
     *                nfmopal,modprp,maxl1c,ipieda,modgrd,modesp,ivmul
      common /fmopnt/ lichfg,lmulfg,lidmrec,lfrgnam,llayfrg,lindat,
     *                lnCBS,lfmozan,lfmoc,lfmomas,lizbas,liaglob,libdgh,
     *                liabdfg,ljabdfg,lnCAO,lidxCAO,liaprjo,ljaprjo,
     *                lCoreAO,lOccCor,lshiftb,liodfmo,lfmoda,lfmodb,
     *                lfmoespa,lfmoespb,llocfmo,lscffrg,lrij,lpopmul,
     *                lpopmat,lialoc,lindbd,liatfrg,lindfrg,lindgfrg,
     *                lnatfrg,lnat0frg,lianfrg,lzanfrg,lcfrg,llibish,
     *                llibnsh,llibng,lindatg,lfmobuf(3),lfmode,lnumfrg,
     *                lloctat,liaoglob,lloadm,lfmoge,ldgrid,liodcfmo,
     *                ljob2grp,lfmopg,lemocdr,luntxyz,luntrot,lstonep,
     *                lmapsu,lfrgmul
      common /fmorun/ espscf,e0scf(2),IDAFMO,icurlay,icurfg,jcurfg,
     *                kcurfg,ncursh,ngau,icurpop,ifmostp,moncor,nat1e,
     *                needr,modrst,norbproj,nunesp,iskipesp,icurunt
      common /fmoshl/ natl,numl,fzan(MXAFMO),fC(MXGFMO,MAXL),fEX(MXGFMO)
     *               ,lshell,LSTART(MXSFMO),LATOM(MXSFMO),LTYPE(MXSFMO),
     *                LNG(MXSFMO),LMIN(MXSFMO),LMAX(MXSFMO),llay(MXAFMO)
      data dbgfmo/8HDBGFMO  /,debug/8HDEBUG   /
      data rnone/8HNONE    /,POINTS  /8HPOINTS  /,cochrg/8HCOCHARGE/
      data OPTMIZ /8HOPTIMIZE/, SADPT  /8HSADPOINT/,GRAD/8HGRADIENT/,
     *     OPTFMO/8HOPTFMO  /,CHECK/8HCHECK   /,RMC/8HMCSCF   /,
     *     rohf/8HROHF    /,energy/8HENERGY  /,fmo0/8HFMO0    /
      data nelm/0,3,9,19/
c
c     this is the main FMO driver.
c
c     modef: GAMESS interface mode
c     0: run single point FMO energy and optionally gradient (ENERGY,GRADIENT)
c        (no interface with the rest of GAMESS)
c     1: run optimisation or saddle point GAMESS engines(OPTIMIZE,SADPOINT)
c        (coord.+grad. are interchanged)
c     2: run optimisation or saddle point (OPTFMO) using FMO specific engines
c        (no interface with the rest of GAMESS)
c
c     modef=1 requires that the number of atoms be supported by GAMESS.
c     Coordinates will be, however, read from $FMOXYZ, not from $DATA.
c
c     parstat: parallelisation status:
c     consists of two words:
c     1st: scope: Global (all nodes), Group (one group), Node (one node)
c     2nd: parallelisation within that scope (Full,None,Bcast)
c     GroupFull implies both levels parallelisation (inter and intra-group)
c     In some cases parallelisation is changed by an input option, in which case
c     both choices are shown.
c     Bcast means the master(s) broadcast(s) accumulated data unto the plebs.
c
c     NEVALS is the ruthless wight raking weeks of debugging time.
c     Its intricate delicacy of coexisting with FMO is a tale to be told.
c     Among the victims is the RMS based convergence criteria in RHF
c     that devoured one week of exclusive debugging in October 2003.
c     Insanity will lurk in the shadow the moment you endevour touching it.
c
c     Note on FMO-ROHF: it is implemented using MCSCF drivers.
c
      call timit(1)
      CALL DERCHK(NDER)
      some=(exetyp.eq.debug.or.exetyp.eq.dbgfmo).and.maswrk
      ifmostp=0
      norbproj=0
c     norbproj is the number of orbitals projected out in FMOHOP
c     we are assuming to be in the world scope now to set dimensions properly!
      nprocg=nproc
      ngrmax=nprocg
c     Care should be taken to set ngrmax for DDI (now it works).
c
c     Pretend that FMO0 run is RUNTYP=energy from now on and save modef.
c
      runtyps=runtyp
      if(runtyp.eq.fmo0) then
        runtyp=energy
        ifgfmo0=modeff
        modef=0
        modefb=0
        if(ifgfmo0.eq.0) maxcbs=0
c       inifmo0=nfg.eq.1
        inifmo0=maxcbs.eq.0
        if(.not.inifmo0) modefb=1
c       This is a bizarre solution to force storing $DATA's basis set in
c       fmosavb only the first time FMOX is called.
c       No ES moments
        nevsav=0
c       No restarts
        isgddi0=.false.
c       no GDDI parallelisation inside FMOX because it is done in FMO0X.
      else
        ifgfmo0=0
        inifmo0=.false.
        modef=modeff
        modefb=modeff
        nevsav=nevals
        isgddi0=isgddi
      endif
      nzmtsav=nzmat
      if(modef.ne.0) nzmat=0
c     zero out nzmat to prevent GRADX from converting the gradient into
c     internals for each fragment: it will be done later.
      savdsk=DSKWRK
      savdir=dirscf
      if(isgddi) then
        grandmas=meglob.eq.0
      else
        grandmas=maswrk
      endif
      if(modef.eq.1) then
c
c         Try broadcasting the coordinates to slay the macabre converge-me-not
c         (suspected artefact of mixed node (GDDI only?) parallelisation).
c         This has to be done in the world scope (by any chosen node).
c         Note that inidfmo will broadcast initial densities/populations/
c         charges so everything will be ghastly synchronised.
c         modef=1 rescticts this bcast to optimisation runs only (OPTIMIZE).
c
c        write(6,*) 'wwwbcasting',nat
         call ddi_bcast(2422,'F',C,3*nat,0)
      endif
      CALL SEQREW(IR)
      CALL FNDGRP(IR,' $STONE ',IEOF)
      IF(IEOF.EQ.0) NPTSTN=1
c     To force the calculation of Stone analysis that might be else skipped.
c
      if(isgddi0) call gddi_scope(ddi_group)
c
c     save integral packing options
c
      labsix=labsiz
      nintix=nintic
c
c     Initialize FMO-TDDFT properties
c
      call vclr(eexcit,1,mxrt*2)
      call vclr(osmd,1,mxrt*2)
      call vclr(texcit,1,3*mxrt*2)
      call viclr(monoc,1,mxrt)
      call viclr(monvr,1,mxrt)
      call viclr(idxyz,1,mxrt)
      call viclr(isumd,1,mxrt+1)
      nstmono=0
c
c     FMO has its own coordinate and basis set input.
c     First get the dimensions.
c
      nbody=0
      maxl1c=0
      maxbas=1
      n0bda=0
      mconvex=10
c     natl and numl are substituted by "1", since they are not used with
c     imode=1.
      icurunt=0
      call fmominp(1,nder,ifgfmo0,idum,idum,dum,idum,idum,dum,dum,dum,
     *             dum,dum,idum,dum,nacut,modmol,idum,idum,orshft,lbody,
     *             gcorrel,fmoq,iexcit,exfid)
      call fmopinp(1,idum,mcnvfmo,mconvex,idum,idum,ngrfmo,prtdst,ncvscf
     *            ,1,1,idum,idum,ngrmax,savgrd,loadbf,loadgr,l1dir,ngm,
     *             vdwrad,grdpad,mpcmit,convpcm,pcmoff,imect,n0bda,0,
     *             dum,dum,dum,0,dum,eint0,rappri,irestl)
      nfgsav=nfg
      ntimout=0
      dopleda=ipieda.ne.0.and.irststp.eq.2.and.mxitfg.eq.1
     *        .and.n0bda.eq.0
      doscfprp=iand(ixesp,2048).ne.0
      ext2lay=iand(ixesp,64).ne.0
      if(ext2lay.and.nfmopcm.ne.0) then
c       It is quite easy to support, just set up nbody properly.
        if(maswrk) write(iw,*) 'This run is not supported.'
        call abrt
      endif
c
c     This is a weird run, that can be called
c     FMO3-RHF/FMO2-RHF:MP2, that is, correlated contribution for a part
c     of the system is added to the full uncorrelated energy.
c     Note this is not the same as FMO3-RHF:FMO2-MP2, since in the latter
c     no 3-body RHF terms are added to the 2-nd layer.
c
      ne0bda=0
      nepl0=0
      if(n0bda.ne.0) then
         ne0bda=n0bda
      else
        if(ipieda.ne.0) then
          ne0bda=nfg*2
          nepl0=nfg*3
        endif
c       it should have been nbdfg, but the latter is unknown yet.
c       guess nbdfg=nfg*2. ne0bda is only used for allocation/reading.
      endif
c
      if(ifgfmo0.ne.0.and.nbody.gt.1.and.isgddi) then
c       It is easy to do so, just replace more isgddis by isgddi0 below.
c       What one really wants to say here is why one wants to
c       run FMO0 with nbody>1 for?
        write(iw,*) 'GDDI is not permitted with FMO0 and nbody>1'
        call abrt
      endif
      if(n0bda.ne.0.and.isgddi.and.ngroups.gt.1) then
c       trap BDA runs which are not fully GDDI parallelised.
        write(iw,*) 'Set ngroups=1 and rerun.'
        call abrt
      endif
      if(n0bda.ne.0.and.nlayer.gt.1) then
        write(iw,*) 'Split layers and run separately.'
        call abrt
      endif
c
      if(nder.gt.0.and.irststp.ge.4.and..not.savgrd) then
        if(maswrk) write(iw,9410)
        call abrt
      endif
      if(nfmopcm.ne.0.and.irststp.gt.2) then
        if(maswrk) write(iw,9440)
        call abrt
      endif
c
      nfthes=38
      if(runtyp.eq.OPTMIZ.or.savgrd) then
        if(savgrd) dskwrk=.true.
        CALL SEQOPN(NFThes,'HESSIAN','UNKNOWN',.FALSE.,'UNFORMATTED')
        CALL SEQREW(NFThes)
        if(savgrd) dskwrk=savdsk
      endif
c
c     Scan $FMOXYZ to find natfmo.
c
cnb   Do only for the first point during optimisation (maxbas?)
c
      call fmoxyz(' $FMOXYZ',1,natfmo,dum,dum3,idum)
c     write(6,*) 'Prescan',natfmo,maxbas
c     ifgfmo0=0 is a special run to read in constant array size options in $FMO.
      if(runtyps.eq.fmo0.and.ifgfmo0.eq.0) goto 5556
c     if(ifgfmo0.gt.nfg) goto 5556
c
      dosap=respap(1).ne.zero.or.respap(2).ne.zero
      dospc=resppc(1).ne.zero.or.resppc(2).ne.zero
      esdder=nder.gt.0.and.iand(ixesp,32).eq.0
      modQbas=nfg.ne.0.and.iand(ixesp,128).ne.0
      atonce=iand(modpar,4).ne.0
      broadden=iand(modpar,64).ne.0.and..not.savgrd
c     broadden does not work with MFMO?! -> bug?
      primul=dospc.and.iand(nprfmo,8).ne.0
c     PLEDA runs do not produce meaningful Mulliken populations
c     however, CT is OK? So stop printing just the charges.
      orbxch=mod(modorb,2).ne.0
      enexch=mod(modorb/2,2).ne.0
      totdens=iand(modprp,1).ne.0
      densgrid=iand(modprp,4).ne.0
      spargrid=iand(modprp,8).ne.0
      if(densgrid.and.spargrid) then
        write(iw,*) 'Either bit 4 or 8 may be set in modprp, not both!'
        call abrt
      endif
      densgrid0=densgrid.and.nbody.eq.0
      spargrid0=spargrid.and.nbody.eq.0
      if(spargrid.and.nbody.gt.2) call abrt
      exclmol=iand(modmol,2).ne.0
      needr=0
c     If(dosap.or.dospc.or.resdim.ne.zero) needr=1
      If(dosap.or.dospc.or.resdim.ne.zero.or.rcorsd.ne.0) needr=1
      needr2=0
c     If(dosap.or.dospc) needr2=1
c     The definition below ignores the secret 2nd option but is suitable
c     for delivering 3-body Mulliken charges.
      if(respap(1).ne.zero.and.respap(1).lt.1.0D+03.or.
     *   resppc(1).ne.zero.and.resppc(1).lt.1.0D+03) needr2=1
      if(nbody.gt.2.and.(restri(1).ne.0.or.restri(2).ne.0.or.
     *   restri(3).ne.0.or.restri(4).ne.0)) needr=1
      mbody=max(nbody,1)
      nfg2=(nfg*nfg-nfg)/2
      nfg3=(nfg*nfg*nfg-3*nfg*nfg+2*nfg)/6
      if(nbody.lt.2) nfg2=0
      if(nbody.lt.3) nfg3=0
c     For exclmol the total properties and even delta-E info is probably
c     not valid (except some limit cases). At present avoid allocating
c     any nfg3 storage for nbody=3 and exclmol, although the same can be
c     done for nbody=2 too.
      if(exclmol.and.iand(modmol,4).ne.0) nfg3=0
c     nfg2 and nfg3 ARE NOT always larger than nfg (nfg2)!!
      nnfg=nfg
      if(nbody.ge.2) nnfg=max(nnfg,nfg2)
      if(nbody.ge.3) nnfg=max(nnfg,nfg3)
      nc1=natfmo*3
      nfcrec=4
      needdm=nfg3.ne.0.and.needr2.ne.0.and.iand(IXESP,2).eq.0.and.
     *       iand(IXESP,8192).ne.0
c     check if we need to exchange dimer densities.
c     the purpose to use needr2 rather than needr is to force dimer density
c     exchange only when it is really needed, that is, when monomer and
c     dimer approximations are used, but not when only trimer ones are in use.
c     needr forces computation of distances for any approximation.
c     Do not use density matrices for the economy mode (exclmol+nbody=3),
c     which is probably reasonable.
c
      addesp=iand(modesp,4).ne.0
      addesp0=addesp.and.(iand(modesp,8).ne.0.or.needr.eq.0)
c     If distances are unavailable, use ADDESP for all dimers.
      diffesp=iand(modesp,16).ne.0
      iskipesp=0
c
      if(nzmtsav.GT.0) then
        NC1 = NVAR
        nfcrec=43
      endif
      if (IEFPFMO.EQ.1) NC1 = NC1 + 6*NFRG
      mfg2=(nfg*nfg-nfg)/2
c     nfg2 cannot be used for NBODY=1, although distances may be needed, NFG2=0
c     mfg2=nfg2
c     if(dolat) mfg2=0
c     dolat is undefined, and rij is allocated some space which is wasted
c     for lattice runs (as it is reallocated below).
c
      CALL VALFM(LOADFM)
      llibish=LOADFM+1
      llibnsh=llibish+(MAXNZ*maxbas*nlayer-1)/nwdvar+1
      llibng=llibnsh+(MAXNZ*maxbas*nlayer-1)/nwdvar+1
      last=llibng+(MAXNZ*maxbas*nlayer-1)/nwdvar+1
      NEED0 = LAST- LOADFM -1
      CALL GETFM(NEED0)
      call fmosavb(modefb,x(llibish),x(llibnsh),x(llibng))
      loadhf=mod(modpar,2)
      semidyn=isgddi0.and.loadhf.ne.0.and.jbtyp.gt.0
      nlmoset=1
      if(modQbas) nlmoset=3
c     one element of lfmoc is used for the centre of the molecule
c
      CALL VALFM(LOADFM)
      lichfg=LOADFM+1
      lmulfg=lichfg+(nfg-1)/nwdvar+1
      lnumfrg=lmulfg+(nfg-1)/nwdvar+1
      lfrgnam=lnumfrg+(nfg+1-1)/nwdvar+1
      llayfrg=lfrgnam+nfg
      lindat=llayfrg+(nfg*2-1)/nwdvar+1
c     lindat gets extra nfg+1 data to accomodate 0-terminated style.
c     It seems that for some extravagant use this extra grace space is
c     insufficient...
      lindtmp=lindat+(natfmo+nfg+1-1)/nwdvar+1
      last=lindtmp+(natfmo-1)/nwdvar+1
      if(runtyp.ne.optfmo) then
        lfmozan=last
        lfmoc=lfmozan+natfmo
        lfmomas=lfmoc+3*(natfmo+1)
        lizbas=lfmomas+natfmo
        last=lizbas+(natfmo-1)/nwdvar+1
c       Otherwise the memory is allocated in OPTFMOX.
      endif
      liaglob=last
      liabdfg=liaglob+(MXATM-1)/nwdvar+1
      ljabdfg=liabdfg+(MaxBnd-1)/nwdvar+1
      lidxCAO=ljabdfg+(MaxBnd-1)/nwdvar+1
      lnCBS=lidxCAO+(MaxBnd*(nlayer+1)-1)/nwdvar+1
      lnCAO=lnCBS+(MaxKnd-1)/nwdvar+1
      liaprjo=lnCAO+(nlmoset*MaxKnd-1)/nwdvar+1
      ljaprjo=liaprjo+(MaxCAO*MaxKnd-1)/nwdvar+1
      lCoreAO=ljaprjo+(MaxCAO*MaxKnd-1)/nwdvar+1
      lOccCor=lCoreAO+MaxCBS*MaxCAO*nlmoset*MaxKnd
      lshiftb=lOccCor+MaxCAO*MaxKnd
      ltaotyp=lshiftb+MaxCAO*MaxKnd
      ltaotypi=ltaotyp+MaxKnd
      ljobgrp=ltaotypi+nlayer
      lemon=ljobgrp+(nfg+1-1)/nwdvar+1
      lglocon=lemon+nfg*4*nlayer
      lidmrec=lglocon+ngrmax
      lmpfmo=lidmrec+(nlayer-1)/nwdvar+1
      lfmodft=lmpfmo+(nlayer-1)/nwdvar+1
      lmaxl30=lfmodft+nlayer
      litrlay=lmaxl30+(nfg-1)/nwdvar+1
      lscffrg=litrlay+(nlayer-1)/nwdvar+1
      lfmoscf=lscffrg+nfg
      lfmoci=lfmoscf+nlayer
      lfmocc=lfmoci+nlayer
      lfmotd=lfmocc+nlayer
      llcorrel=lfmotd+nlayer
      lijvec=llcorrel+(nlayer-1)/nwdvar+1
      lmannod=lijvec+(2*maxvec-1)/nwdvar+1
      lmolfrg=lmannod+(ngrmax*maxpst*nlayer-1)/nwdvar+1
      lemolfrg=lmolfrg+(nfg-1)/nwdvar+1
      lmastid=lemolfrg+nfg*3
      lmconfg=lmastid+nprocg
      libfconv=lmconfg+(nfg+mconvex*4-1)/nwdvar+1
      lmapconv=libfconv+(2*natl-1)/nwdvar+1
      lnprfrg=lmapconv+(natl*numl-1)/nwdvar+1
c     lmapconv's real dimensions are unknown. At most natl*numl will be
c     read and processed.
      lr0bda=lnprfrg+(nfg-1)/nwdvar+1
      le0bda=lr0bda+ne0bda
      lefmo0=le0bda+4*ne0bda*nlayer
      lepl0ds=lefmo0+ne0bda*nlayer
      last=lepl0ds+nepl0
      lloadm=last
      if(loadhf.eq.1) then
        lloadd=lloadm+(nfg-1)/nwdvar+1
        liwrkd=lloadd+(nfg2-1)/nwdvar+1
        last=liwrkd+(nnfg-1)/nwdvar+1
      else
        lloadd=last
        liwrkd=last
      endif
      lrij=last
      if(needr.ne.0) then
        lrwrk=lrij+mfg2
        last=lrwrk+nfg
      else
        lrwrk=last
      endif
      lifgbuf=last
      if(atonce) then
        lnfgbuf=lifgbuf+(2*nfg*ngrmax-1)/nwdvar+1
        last=lnfgbuf+(2*ngrmax-1)/nwdvar+1
      else
        lnfgbuf=last
      endif
      lloadt=last
      if(nbody.gt.2.and.loadhf.eq.1) last=lloadt+(nfg3-1)/nwdvar+1
      if(spargrid) then
        lnoffg=last
        lindgrd=lnoffg+(nfg-1)/nwdvar+1
        last=lindgrd+(6*nfg-1)/nwdvar+1
      endif
      lemocdr=last
      if(nfmopcm.ne.0) last=lemocdr+3*nfg
c
      LDEFTF=last
      LTORQF=last
      if(IEFPFMO.EQ.1) call efpmem(nder,last,needefp)
c
      NEED = LAST- LOADFM -1
      CALL GETFM(NEED)
c
c     Electrostatic moments for all n-mers will be calculated for all points
c     the user asked for (if any) plus the centre of mass/charge of the
c     molecule. However, the total moments for the molecule will be computed
c     only for the last point.
c     Finally, for now there are no masses so only the centre of charge is
c     available!
      iwhere=0
      if(elmloc.eq.cochrg) iwhere=1
      if(iemom.eq.0) iwhere=-1
c     if(iwhere.eq.0) then
c       if(maswrk)
c    *    write(6,*) 'No masses available! using charges for $ELMOM.'
c       iwhere=1
c     endif
      ELMLOCs=ELMLOC
      ELMLOC=points
      if(modef.eq.0.and.(ifgfmo0.eq.0.or.inifmo0)) npoint=npoint+1
      if(npoint.gt.MXPTPT) then
        write(6,*) 'Too many ES points',MXPTPT
        call abrt
      endif
c
      call fmominp(2,nder,ifgfmo0,x(lichfg),x(lmulfg),x(lfrgnam),
     *             x(llayfrg),x(lindat),x(lscffrg),x(lfmoscf),x(lfmoci),
     *             x(lfmodft),x(lfmocc),x(lmpfmo),x(lfmotd),nacut,modmol
     *            ,x(lmolfrg),x(lnprfrg),orshft,lbody,gcorrel,fmoq,
     *             iexcit,exfid)
      call fmopinp(2,x(lmannod),mcnvfmo,mconvex,x(lmconfg),x(lijvec),
     *            ngrfmo,prtdst,ncvscf,natl,numl,x(libfconv),x(lmapconv)
     *            ,ngrmax,savgrd,loadbf,loadgr,l1dir,ngm,vdwrad,grdpad,
     *             mpcmit,convpcm,pcmoff,imect,n0bda,ne0bda,x(lr0bda),
     *             x(le0bda),x(lefmo0),nepl0,x(lepl0ds),eint0,rappri,
     *             irestl)
c
      if(nacut.ne.0) call fmoauto(nacut,x(lindat))
      if(ixftch(x(lindat),1).eq.0)
     *  call fmogind(natfmo+nfg+1,x(lindat),x(lindtmp))
c
c     Convert van der Waals radii to Angstrom
c
      UNITS=0.52917724924D+00
      if(iand(nfmopal,1).ne.0) UNITS=0.529177249D+00
      call dscal(MAXNZ,one/UNITS,vdwrad,1)
c
      if(iand(modmol,1).ne.0.and.nder.gt.0) modmol=modmol-1
      if(RUNTYP.ne.GRAD) savgrd=.false.
c
c     check input consistency
c
      call fmocheck(nder,x(lmulfg),x(lscffrg),x(lfmoscf),x(lfmoci),
     *              x(lfmodft),x(lfmocc),x(lmpfmo),x(lfmotd),x(llcorrel)
     *             ,domp,dotd)
c
      if(ext2lay) then
c       check if this run should be allowed.
        if(lbody(1).ne.3.or.lbody(2).ne.2.or.
     *     iand(ixftch(x(llcorrel),1),1).ne.0.or.
     *     iand(ixftch(x(llcorrel),2),1).ne.1) then
          if(maswrk) write(iw,*) 'Only FMO3-RHF/FMO2-MP2 is allowed.'
          call abrt
        endif
      endif
c
c     read MP2 group to get MPPROP if not done yet.
c
      MPTEST=.FALSE.
      if(mplevl.eq.0.and.domp) CALL MP2INP(mptest)
c
c     if(nevsav.gt.0.and.iand(nguess,128).eq.0.or.i0bda.gt.1) irststp=2
      if(nevsav.gt.0) call dacopy(9,one,espsca,1)
c     Force monomer restart for geometry optimisations
c     Forbid using ESPSCA from the second geometry during optimisations
      if(MMONLY.or.QMMM) ICOORD =  5
      LINEAR=.false.
      if(modef.eq.0) then
        if(MMONLY.or.QMMM) then
c         if(maswrk) CLOSE(UNIT=IDAF,STATUS='DELETE')
          call CLOSDA('DELETE')
          CALL OPENDA(0)
          CALL TINKIN(IR,IW)
c         what is that argument in LINKIN supposed to mean?
          CALL LINKIN(1)
          CALL TOPTIN
c         CALL TIN2GMS
          CALL TIN2fmo(natfmo,x(lfmozan),x(lfmoc))
c         LINEAR=.false.
        else
          call fmoxyz(' $FMOXYZ',0,natfmo,x(lfmozan),x(lfmoc),x(lizbas))
        endif
      endif
      if(modef.ne.2) then
        call gmsxyz(modef,nfthes,nc1,natfmo,x(lfmozan),x(lfmoc),
     *              x(lizbas),nfcrec,nevsav,grandmas,squit)
      else
c      if(runtyp.eq.optfmo) that is always true for modef=2
       squit=.false.
      endif
c
      CALL RAMS(TABM,2)
      call fmorams(natfmo,x(lfmozan),TABM,x(lfmomas),0)
      call fmocinp(x(lfmozan),x(lfmoc),x(lfmomas),dolat)
c
      if(dolat.and.loadhf.eq.1) call abrt
      if(dolat) call abrt
c     if(dolat.and.addesp) call abrt
c     DOLAT does basically the same thing as ADDESP, but the two may not be set
c     together.
      if(iand(modesp,3).ne.0.and.(dolat.or.addesp)) call abrt
c     Likewise, no point of doing n-mer consistent distances: that is
c     automatic with the either other option.
      if(resppc(1).gt.resdim.and.addesp) call abrt
c     This is a program limitation (in fmoatfrg charges are not engaged in
c     computing VI(J)+VJ(I)). Stricly speaking, resppc = resdim is also
c     forbidden (but for reals the equality of distances "never" holds).
      if(addesp.and.ngroups.gt.1) call abrt
c     One should exchange the monomer potentials between groups.
c
c     BDA loop
c
      i0bda=0
   80 continue
      i0bda=i0bda+1
      if(n0bda.ne.0) then
        call bdaxyz(x(lr0bda+i0bda-1)/UNITS,x(lindat),x(lfmoc))
        call viclr(x(lmolfrg),1,nfg)
      endif
      if(nevsav.gt.0.and.iand(nguess,128).eq.0.or.i0bda.gt.1) irststp=2
c
c     Form cavity around the whole molecule.
c     Do this is the global scope?
c
c     IF(IPCM.EQ.1.OR.IP_F.EQ.1) THEN
      lesolv2=last
      lesolv3=last
      IF(nfmopcm.ne.0) then
        call vclr(x(lemocdr),1,3*nfg)
c       replace NESFP that was not available in PCMINP.
c       if(NESFP.lt.0) NESFP = NATfmo
        if(isgddi) call gddi_scope(ddi_world)
c       read PCM input (not done yet!) and allocate PCM memory
        call inppcm(nder,natfmo,natfmo)
c       call inppcm(nder,MXATM,natfmo)
c       CAVITM and DISRPM retesserate so they have to be called before
c       (or after) starting FMO-PCM.
        IF(IFIELD.NE.0) CALL EFIELDM
        IF(ICAV.EQ.1) CALL CAVITM
        IF(IDISP.EQ.1) CALL DISRPM
        CALL PEDRAM
c       NTSPAR must be set in world scope !! (or use NPROCG)
        NTSPAR=(NTS-1)/NPROC+1
        if(isgddi) call gddi_scope(ddi_group)
        UNZ=zero
c
c       QSE and QSN have to be zeroed here, because SOLVNT is not called (QSN)
c       and QSE calues are used before charges are set to something at the
c       end of the first monomer SCF iteration.
c
        nesolv=nfg
        if(nbody.ge.2) nesolv=nesolv+nfg2
        if(nbody.ge.3) nesolv=nesolv+nfg3
        call vclr(x(lQSE),1,NTS)
        call vclr(x(lQSN),1,NTS)
        if(nder.gt.0) then
          call vclr(x(lQFS),1,NTS)
          call vclr(x(lQIND),1,NTS)
        endif
c
        CALL VALFM(lfmasc)
c       ichfmo is unknown and unneeded at this point, use 0.
        call calcasc(0,NTSPAR,0,0,lfmasc,needasc,lesolv,nesolv,lpel,
     *               lvnuc,lqtmp)
        CALL GETFM(needasc)
        if(nbody.ge.2) lesolv2=lesolv+nfg
        if(nbody.ge.3) lesolv3=lesolv2+nfg2
        if(I_NESF.ne.natfmo) then
          write(iw,*) '!!!Warning: PCM monomer analysis is invalid!!!'
c         It is assumed that each sphere corresponds to one atom (one-to-one).
c         It is also not checked but assumed that user did not enter spheres
c         manually.
        endif
      else
        lfmasc=0
        needasc=0
        nesolv=0
        lesolv=last
        NTSPAR=0
      END IF
c
c     nelm gives the number of electrostatic moments
c     (maxelm is up to octopoles).
c     iemom=0 none
c     iemom=1 dipole+point coordinates (one point max) 3+3
c     iemom=2 the above plus quadrupole (5)
c     iemom=3 the above plus octopole (10)
c     fmoelm(*,1-nfg) are used for the moments of each fragment
c     fmoelm(*,nfg+1) are used for the 2nd order moments
c     fmoelm(*,nfg+2) are used for the 3rd order moments
c     fmoelm(*,nfg+3) are used for the 1st order moments
c     fmoelm(*,nfg+4) are used as temporary storage for 3-body
c     (the reason for the funny order is the global sum up to nfg+1 or nfg+2).
      if(iemom.lt.0.or.iemom.gt.3) call abrt
      if(irststp.ge.4.and..not.savgrd.and.iemom.ne.0) then
        if(maswrk) write(iw,9420)
        iemom=0
      endif
      if(irststp.ge.4.and.primul) then
        if(maswrk) write(iw,9422)
        primul=.false.
c       The problem of turning off both ES moments and Mulliken charges is that
c       the number of trimers present will be printed as zero.
      endif
c     if(dopleda) then
c       Perhaps there is a meaning to these ES moments?
c       if(maswrk) write(iw,9422)
c       iemom=0
c     endif
      nfmoelm=nelm(iemom)
      if(nfmoelm.gt.0) call fndcntr(x(lfmozan),x(lfmoc),x(lfmomas),
     *              iwhere,XPOINT(npoint),YPOINT(npoint),ZPOINT(npoint))
c     for now, enforce COORD=TINKER for all FMO-MOMM runs.
c     compute MM energy
c     if(qmmm.and.modef.eq.0) CALL ANALYZE
      if(squit) goto 5555
      if(modQbas.and.(runtyp.eq.OPTMIZ.or.runtyp.eq.OPTFMO)) call abrt
      if(modQbas) call oneei
      call fmolmo(' $FMOHYB',' $FMOLMO',x(ltaotyp),x(liaprjo),x(ljaprjo)
     *           ,x(lCoreAO),x(lOccCor),x(lnCBS),x(lnCAO),x(lshiftb),
     *            x(llibish),orshft,modQbas)
      call fmobon(' $FMOBND',x(ltaotyp),x(ltaotypi),x(liabdfg),
     *            x(ljabdfg),x(lidxcao))
c     if(nacut.ne.0) call fmoauto(nacut,x(lindat))
      if(iand(ixesp,128+256).ne.0.and.nbdfg.eq.0) then
        write(iw,*) 'Please reset 128+256 flags in ixesp in $FMO'
        call abrt
      endif
c     check the above guess of ne0bda=(nbdfg)=2*nbdfg
      if(n0bda.eq.0.and.ipieda.ne.0.and.ne0bda.lt.nbdfg) call abrt
c
      if(nbdfg.ne.0) call bdapun(units,x(lfmoc),x(liabdfg),x(ljabdfg),
     *                           n0bda.eq.0.and.ipieda.ne.0,x(lr0bda))
c
      if(rcorsd.ne.0.and..not.gcorrel) then
        write(iw,9200)
        rcorsd=0
c       having non-zero rcorsd creates a bug below (edim? overused)
      endif
      nenc=0
      if(gcorrel) nenc=2
      nen=nenc+2
      if(nbsse.ne.0) nen=4+2+nenc
      if(ipieda.ne.0) nen=nen+2
      nedimes=nen-1
      nedimex=nen
      nfg2e=nfg2*nen
      if(dolat) nfg2e=0
      nfg2l=nfg2
      if(dolat.or.nbody.le.1.or..not.primul) nfg2l=0
      nent=2
      if(needdm) nent=3
      if(gcorrel) nent=nent+1
      nfg3e=nfg3*nent
      natfmob=natfmo+nbdfg
      nappri=0
      if(rappri(3).ne.0)
     *  nappri=int((rappri(2)-rappri(1))/rappri(3))+1
      CALL VALFM(LOADFM)
      liatfrg=LOADFM+1
      lindfrg=liatfrg+(natfmob-1)/nwdvar+1
      lindgfrg=lindfrg+(nfg-1)/nwdvar+1
      lnatfrg=lindgfrg+(nfg-1)/nwdvar+1
      lnat0frg=lnatfrg+(nfg-1)/nwdvar+1
      lianfrg=lnat0frg+(nfg-1)/nwdvar+1
      lzanfrg=lianfrg+(natfmob-1)/nwdvar+1
      lcfrg=lzanfrg+natfmob
      lialoc=lcfrg+3*natfmob
      ledim=lialoc+(natfmob-1)/nwdvar+1
      lerapp=ledim+nfg2e+1
      lnrapp=lerapp+nappri*2
      lctdim=lnrapp+(nappri*2-1)/nwdvar+1
      last=lctdim+nfg2l
      letrim=last
      if(nfg3e.ne.0) last=letrim+nfg3e
      lindatg=last
      if(nbdfg.ne.0) last=lindatg+(natfmo*maxabd-1)/nwdvar+1
c     lialoc stores fragment and atomic numbers (iat,ifg)
c     separately for all "verite" atoms and ghost atoms.
c     lindatg contains shadow indat, which means secondary, tertiary etc
c     fragment indices that arise because ghost atoms belong to 2 or more
c     fragments.
      lklms=last
      if(dolat) last=lklms+(4*maxklms-1)/nwdvar+1
      leexfg=last
      if(dotd.and.nbody.ge.2) last=leexfg+2*nfg*mxrt
C
C     MCP/FMO
C
      IF (IMCPFMO.EQ.1) CALL MCPFALOC(LAST)
C
      NEED2= LAST- LOADFM -1
      CALL GETFM(NEED2)
c     lindfrg is used as temporary storage.
c     if(ixftch(x(lindat),1).eq.0)
c    *  call fmogind(natfmo+nfg+1,x(lindat),x(lindfrg))
c
c     Generate asymmetric units around the central one.
c
      if(dolat) then
        call genklms(0,0,0,1,nunint,nunesp,nunptc,x(lklms))
      else
        nunint=0
        nunesp=0
        nunptc=0
      endif
c
c     Create the grid around the total molecule. The monomer density will
c     not be evaluated on the grid in this case.
c
      if(iand(modprp,16).ne.0) then
        if(densgrid.and.ifgfmo0.ne.0) then
          write(6,9430)
          call abrt
        endif
        call totgrid(x(lfmozan),x(lfmoc),vdwrad,grdpad)
      endif
      if(nappri.ne.0) call vclr(x(lerapp),1,nappri*2)
      if(nappri.ne.0) call viclr(x(lnrapp),1,nappri*2)
      NDAR30c=1+nfg*2*2
c
c     Initialise FMO0
c
      if(ifgfmo0.ne.0) then
        call viclr(maxg,1,3)
        if(spargrid.and.grandmas)
     *    call makescube(0,ifgfmo0,0,x(llayfrg),x(lindat),x(lfmozan),
     *                   x(lfmoc),x,x(lnoffg),x(lindgrd),maxg)
c       In the above call grid array is not used so a dummy argument is passed
c       liatfrg is used as a temporary array of approximate size
c       maxnat+maxabd*2 (cannot exceed natfmo).
c       lnat0frg is used as temporary array of size nfg
c       lianfrg is used as temporary array of size natfmo
c       lialoc is used as a temporary array of size natfmo
        call pullfrg(ifgfmo0,x(liatfrg),x(lnat0frg),x(lianfrg),x(lialoc)
     *              ,x(lindat),x(liabdfg),x(ljabdfg),x(lfmozan),x(lfmoc)
     *              ,x(lizbas),x(lichfg),x(lmulfg),x(lfrgnam),x(llayfrg)
     *              ,x(lscffrg),x(lmconfg),x(lmolfrg),x(lnprfrg))
      endif
c
      call makefg(x(lindat),x(liabdfg),x(ljabdfg),x(lfmozan),x(lfmoc),
     *            x(lialoc),x(liatfrg),x(lindfrg),x(lindgfrg),x(lnatfrg)
     *           ,x(lnat0frg),x(lianfrg),x(lzanfrg),x(lcfrg))
c
      IF (IMCPFMO.EQ.1) CALL MCPPRPR(X(LFMOZAN),X(LINDFRG),X(LNAT0FRG),
     *       X(LNATFRG),X(LIATFRG),X(LFZCOR),X(LIZCOR2),X(LIFMPTYP),
     *       X(LIFMPTYP2),X(LMCPSW))
c
      if(nbdfg.eq.0.and.mod(nguess/4,2).eq.1) nguess=nguess-4
      nat1e=natfmo*(nunesp+1)
cnb   fill numfrg array and avoid one DDI op.
c     skip framents if not in the layer?
c
cnb
c     nstjob is set up based on loadbf and loadgr for the first layer.
c     nstjob(2) will be recomputed for each layer in inidfmo but
c     nstjob(1) at present will not be (but it should be too).
c     nstjob should be recomputed for each layer. Now nstjob(1) is not.
      call viclr(nstjob,1,maxpst)
      nocctdm=0
      nvirtdm=0
      itdfrg=iexcit(1)
      call fillind(nfg2,nfg3,loadhf,x(lnumfrg),x(liwrkd),x(lloadm),
     *             x(lloadd),x(lloadt),x(lmaxl30),x(llayfrg),x(lindat),
     *             x(lindatg),x(lnCBS),x(liabdfg),x(ljabdfg),x(lidxcao),
     *             x(lscffrg),x(lichfg),ichfmo,nefmo,l0fmo,l1fmo,
     *             orbxch,enexch,docas,loadbf(1,1),loadgr(1,1),nstjob,
     *             semidyn,spargrid,x(lnoffg),x(lindgrd),vdwrad,grdpad,
     *             nxyzg,maxg,itdfrg,nocctdm,nvirtdm,some)
      if(docas.and..not.orbxch) then
        write(6,*) 'Please set orbital exchange flag in MODORB'
        call abrt
      endif
c     if(ifgdon.eq.0.and.ifgacc.ne.0.or.ifgdon.ne.0.and.ifgacc.eq.0)then
c       write(iw,*) 'Donor/acceptor choice is wrong',ifgdon,ifgacc
c       call abrt
c     endif
      maxl2=(maxl1*maxl1+maxl1)/2
      maxl3=maxl1*maxl1
      LDAR30=maxl2
      if(orbxch) LDAR30=maxl3
      if(docas)  LDAR30=maxl2+maxl3
      if(enexch) LDAR30=LDAR30+maxl1
c
      forbconv=irststp.eq.2.and.maxl1c.ne.0
      densfmo0=ifgfmo0.ne.0.and.maxl1c.ne.0
      conv2mc=forbconv.and.maxl1.eq.maxl1c
      if(forbconv) then
        ierr=0
        if(conv2mc) then
c         This means converting RHF -> MCSCF, require modorb=3 for both.
          if(modorb.ne.3) ierr=1
        else
c         Otherwise present code requires modorb=0 or modorb=1.
c         if(modorb.ne.0) ierr=1
          if(enexch) ierr=1
        endif
c       Request sequential unilayer code
        if(nlayer.gt.1.or.ngroups.gt.1) ierr=1
        if(ierr.ne.0) then
          if(maswrk) write(iw,9010)
          call abrt
        endif
      endif
c     Compute only the nbody-th density for densgrid, but each ibody-th for
c     spargrid.
      if(.not.spargrid) nxyzg=nzg*nyg*nxg
      ngbody=0
      if(densgrid) ngbody=1
      if(spargrid) ngbody=mbody
      nxyzgm=ngm(3)*ngm(2)*ngm(1)
      if((densgrid.or.spargrid).and.nxyzg.eq.0) then
        write(iw,9400) nxg,nyg,nzg
        call abrt
      endif
      nxyzgm0=nxyzgm
      if(nbody.ne.0) nxyzgm0=0
c
      l2fmo=(l1fmo*l1fmo+l1fmo)/2
c     Set up record size for the total density
c     if(iand(l1fmo,2).eq.0) then
c       ndrecsiz=l1fmo+1
c       ndrec=l1fmo/2
c     else
c       ndrecsiz=l1fmo
c       ndrec=(l1fmo+1)/2
c     endif
      l1fmoc=0
c
c     if(forbconv.or.densfmo0) then
      if(forbconv) then
        maxl2c=(maxl1c*maxl1c+maxl1c)/2
        maxl3c=maxl1c*maxl1c
        LDAR30c=maxl2c
        if(orbxch) LDAR30c=maxl3c
        if(docas)  LDAR30c=maxl2c+maxl3c
        if(enexch) LDAR30c=LDAR30c+maxl1c
      endif
c     auxiliary density file
      IDAcFMO=30
c     note: suffix d is obsolete. Now it applies to n-mers (not just dimers).
      maxl1d=maxl1*mbody
      maxl2d=(maxl1d*maxl1d+maxl1d)/2
      maxl3d=maxl1d*maxl1d
      maxm2d=maxl2d
      if(orbxch.or.ixftch(x(lijvec),1).ne.0) maxm2d=maxm2d+maxl3d
c     maxl3d can be used for reading $VECs even if orbxch is false
      maxm2d=maxm2d+maxl3d
      if(enexch) maxm2d=maxm2d+maxl1d
      if(dosap) maxm2d=maxm2d+maxl1
      if(dospc) maxm2d=maxm2d+maxl1
c     should be if(dospc) maxm2d=maxm2d+maxnat, but dmexch uses maxl1
c     dosap and dospc values are used only in dmexch.
c     maxl1 is for monomers, double for dimers.
c     for DA and DB LDAR30 is enough except for NBSSE.ne.0 runs
c     if memory request grows to be too large that can be used.
c     lwrk is used as maxl2 + maxl1(enexch) + maxl3(orbxch)
c     NDAR30 allocates one record for record indexing.
c     n30ex allocates some space for restart check
      n30ex=5+nlayer
      NDAR30=1+nfg*2*2
      if(addesp.or.diffesp) NDAR30=NDAR30+nfg*2
c     ndrecoff=NDAR30-1
c     if(totdens) NDAR30=NDAR30+ndrec
      NDAR30i=(NDAR30+n30ex-1)/nwdvar+1
      NDAR30ci=(NDAR30c+n30ex-1)/nwdvar+1
      LDAR30=max(LDAR30,NDAR30i)
c     if(totdens) LDAR30=max(LDAR30,ndrecsiz)
c     if(forbconv.or.densfmo0) LDAR30c=max(LDAR30c,NDAR30ci)
      if(forbconv) LDAR30c=max(LDAR30c,NDAR30ci)
      NDAR30q=nfg2*2
      LDAR30q=maxl2d
c     this is somewhat stupid: better alter maxl30 instead.
c
      nfrgmul=0
      if(ivmul.gt.1) nfrgmul=nfrgmul+3
      if(ivmul.gt.2) nfrgmul=nfrgmul+6
      if(ivmul.gt.3) nfrgmul=nfrgmul+10
      needmd=0
      if((nfmoelm.gt.0.or.primul.or.nder.gt.0).and.nbody.gt.1) needmd=1
c     should one add .and.rcorsd.ne.0?
      CALL VALFM(LOADFM)
      lfmoda=LOADFM+1
      lfmodb=lfmoda+maxm2d
      lfmoespa=lfmodb+maxm2d
      lfmoespb=lfmoespa+maxl2d
      liodfmo=lfmoespb+maxl3d
      lisdrec=liodfmo+NDAR30i
      llocfmo=lisdrec+NDAR30i
      lwrk=llocfmo+(2*2*nbdfg-1)/nwdvar+1
      lwrk1=lwrk+maxl1d+maxl2d+maxl3d
      lwrk2=lwrk1+maxl1d*8
c     lwrk2=lwrk1+maxl1d*2
      lmapi=lwrk2+maxl2d
      lmapj=lmapi+(maxl1d-1)/nwdvar+1
      lfmoelm=lmapj+(maxl1d-1)/nwdvar+1
      lstonep=lfmoelm+nfmoelm*(nfg+4)
c     3 above is really nbody but to replace one needs to check carefully
      lfrgmul=lstonep+maxnat*nbody*(nfrgmul+1)
      last=lfrgmul
      if(nfrgmul.gt.0) last=lfrgmul+3*natfmob+nfrgmul*natfmob*2
      if(forbconv) then
        liodcfmo=last
        lorbconv=liodcfmo+NDAR30ci
        last=lorbconv+maxl3c+maxl2c+maxl1c
      else
        lorbconv=last
      endif
c     if(densfmo0) then
c       liodcfmo=last
c       last=liodcfmo+NDAR30ci
c     endif
      if(fmoq) then
        ledimq=last
        last=ledimq+nfg2
      else
        ledimq=last
      endif
      if(fmoq.or.needdm) then
        liodcfmo=last
        ljob2grp=liodcfmo+(NDAR30q-1)/nwdvar+1
        last=ljob2grp+(nfg2-1)/nwdvar+1
      else
        ljob2grp=last
      endif
      lfmobuf(1)=lwrk
      lfmobuf(2)=lwrk2
      lfmobuf(3)=0
c     stash away allocated memory
      lindbd=last
      if(nbdfg.ne.0) then
        last=lindbd+(maxabd*natfmo-1)/nwdvar+1
c       maxabd sets the maximum number of bonds broken at a single atom.
c       at present it is 4 (since precision is lost, normally only 1 bond
c       at most is broken).
      endif
      lwrkc=last
c     ljob2grp=last
c     lwrkc stores density+orbitals+energy for the 3rd fragment in trimers
      if(nbody.gt.2) then
        ndc=maxl2
        if(orbxch) ndc=ndc+maxl3
        if(enexch) ndc=ndc+maxl1
        lmap3=lwrkc+ndc
        last=lmap3+(maxl1d*3-1)/nwdvar+1
c       if(needdm) then
c         ljob2grp=last
c         last=ljob2grp+(nfg2-1)/nwdvar+1
c       endif
      else
        lmap3=last
      endif
      lpopmat=last
      lpopmul=last
c     2 in popmul and popmat below refer to 2 iterations to save data
      if(dosap.or.dospc) then
        last=lpopmul+maxl1*nfg*2
        if(dospc) then
          lpopmat=last
          last=lpopmat+maxnat*nfg*2
        endif
      endif
      lzsave=last
      if(nbsse.ne.0) then
        last=lzsave+maxnat*mbody
      endif
      lfmode=last
      lfmopg=last
      if(nder.gt.0) then
        lfmopg=lfmode+3*natfmo*mbody
        last=lfmopg
        if(nfmopcm.gt.0) last=lfmopg+3*natfmo
      endif
      latmulq=last
      if(primul) then
        latmulqi=latmulq+natfmo*mbody
        last=latmulqi+natfmo*mbody
      else
        latmulqi=last
      endif
c     lindd=last
      if(totdens) then
c       ldbuff=lindd+(ndrec*2-1)/nwdvar+1
c       lloctat=ldbuff+ndrecsiz
        lloctat=last
        liaoglob=lloctat+(natfmo-1)/nwdvar+1
        ltotd=liaoglob+(maxl1d-1)/nwdvar+1
        last=ltotd+l2fmo
c       l2fmo is often a huge buffer. While it is easy to split it in FMO,
c       the same buffer will have to be used in GAMESS when reading this
c       density so for now put everything in-core.
      else
c       ldbuff=last
        lloctat=last
        liaoglob=last
      endif
      if(densgrid.and.ifgfmo0.ne.0) then
c       Allocate nothing for non-sparse density in FMO0.
      else
        ldgrid=last
        if(densgrid.and.ifgfmo0.eq.0 .or.spargrid) then
          last=ldgrid+nxyzg*ngbody
        endif
      endif
      ldgridm=last
      last=ldgridm+nxyzgm
c     Properties become a bit messy for multilayer runs. We accumulate
c     the properties for the current layer in latmulqi and then add to latmulq.
      lnmdfrg=last
      lnmtfrg=last
      lndtfrg=last
      if(nbody.gt.1) then
        last=lnmdfrg+(nfg*2-1)/nwdvar+1
        if(nbody.gt.2) then
          lnmtfrg=last
          lndtfrg=lnmtfrg+(nfg*2-1)/nwdvar+1
          last=lndtfrg+(nfg2*2-1)/nwdvar+1
        endif
        lnmmfrg=last
        lnddfrg=last
        if(ext2lay) then
          lnddfrg=lnmmfrg+(nfg-1)/nwdvar+1
          last=lnddfrg+(nfg2-1)/nwdvar+1
        endif
      endif
c     nmdfrg(*,1) tells how many times monomer I enters into total dimer
c     properties sum(IJ) { PIJ-PI-PJ }. Without approximations this number is
c     always nfg-2, however it becomes smaller if resdim is active or for
c     multilayer runs.
c     nmdfrg(*,2) stores the same value for explicitly correlated monomers.
c     (nmdfrg(*,1) is equal to nmdfrg(*,2) if rcorsd is large enough so that
c     it does not exclude correlation from any dimer and molfrg is not used).
      luntxyz=last
      if(dolat) then
        call fmon123(x(lnumfrg),n1fmo,n2fmo,n3fmo)
        lunitnr=luntxyz+3*natfmob*(nunptc+1)
        lnsymeq=lunitnr+nunptc
        luntrot=lnsymeq+(nunptc-1)/nwdvar
        lesplat=luntrot+3*3*(nunptc+1)
        lmapsu=lesplat+n2fmo*nsymop
        last=lmapsu+(nunptc-1)/nwdvar
      else
        lunitnr=last
        lnsymeq=last
        luntrot=last
        lesplat=last
        lmapsu=last
      endif
      lesp1i=last
      if(dolat.or.addesp) then
        lesp1j=lesp1i+maxl2
        lczi=lesp1j+maxl2
        lczj=lczi+maxnat*4
        last=lczj+maxnat*4
      else
        lesp1j=last
        lczi=last
        lczj=last
      endif
      lCTDM=last
      if(dotd.and.iexcit(4).eq.2) then
        if(NSTAT.eq.0) then
          if(maswrk) write(iw,*) 'Define TDDFT in $CONTRL'
          call abrt
        endif
        last=lCTDM+nocctdm*nvirtdm*NSTAT
c       This requires TDDFT!=NONE in $CONTRL.
      endif
      NEED1 = LAST- LOADFM -1
      CALL GETFM(NEED1)
c
      if(nder.gt.0) call vclr(x(lfmode),1,3*natfmo*mbody)
      if(esdder)   call viclr(x(lisdrec),1,NDAR30)
      if(dopleda) call vclr(x(lepl0ds),1,nepl0)
      if(primul) call vclr(x(lstonep),1,maxnat*nbody)
      if(nfrgmul.gt.0) call vclr(x(lfrgmul),1,(3+nfrgmul*2)*natfmob)
c
      if(nfrgmul.gt.0) then
        if(dolat) call abrt
c       To implement, use lattice's UNTXYZ in stone multipole integrals.
        luntxyz=lfrgmul
        lfrgmul=lfrgmul+3*natfmob
      endif
c
c     This is needed to avoid strange artefacts.
      NEEDL=0
      if(dolat) then
        call vclr(x(lesplat),1,n2fmo*nsymop)
c       call vclr(x(lespl1i),1,n2fmo*nunesp)
c       call vclr(x(lespli1),1,n2fmo*nunesp)
c       Save the unit coordinates for FMO/PBC.
        call dcopy(natfmob*3,x(lcfrg),1,x(luntxyz),1)
c       write(6,6666)((x(luntxyz-1+jj+(kk-1)*3),jj=1,3),kk=1,nat)
c6666 format(100(3F12.5,/))
        call RUNITV(3,3,x(luntrot))
        do iu=1,nunptc
          ik=ixftch(x(lklms),(iu-1)*4+1)
          il=ixftch(x(lklms),(iu-1)*4+2)
          im=ixftch(x(lklms),(iu-1)*4+3)
          ig=ixftch(x(lklms),(iu-1)*4+4)
          luntxyzi=luntxyz+3*natfmob*iu
          luntroti=luntrot+3*3*iu
c         write(6,*) 'wwklms',iu,ik,il,im,ig
          call symolcc(ik,il,im,ig,natfmob,x(luntxyz),x(luntxyzi),
     *                 x(luntroti))
c         write(6,6666)((x(luntxyzi-1+jj+(kk-1)*3),jj=1,3),kk=1,nat)
        enddo
        if(nbody.gt.1) then
          call uniqpair(x(lfmozan),x(luntxyz),x(lunitnr),x(lnsymeq),
     *                  natfmob,nunptc,1,nunint,nsuint)
          call uniqpair(x(lfmozan),x(luntxyz),x(lunitnr),x(lnsymeq),
     *                  natfmob,nunptc,nunint+1,nunesp,msuesp)
          if(nunesp+1.le.nunptc) then
            call uniqpair(x(lfmozan),x(luntxyz),x(lunitnr),x(lnsymeq),
     *                    natfmob,nunptc,nunesp+1,nunptc,msuptc)
          else
            msuptc=0
          endif
          nsuesp=nsuint+msuesp
          nsuptc=nsuesp+msuptc
          inext=0
          do iu=1,nunptc
            ju=ixftch(x(lnsymeq),iu)
            if(ju.gt.0) then
              inext=inext+1
              ku=inext
            else
              ku=ixftch(x(lmapsu),-ju)
            endif
            call ixstor(x(lmapsu),iu,ku)
          enddo
c         write(6,*) 'wwwnse',(ixftch(x(lnsymeq),i),i=1,nunptc)
c         write(6,*) 'wwwnSE',(ixftch(x(lmapsu),i),i=1,nunptc)
        endif
        if(nbody.gt.1) then
          nfg2e=(nfg2+nfg*nfg*nsuptc)*nen
          nfg2l=nfg2+nfg*nfg*nsuint
          if(.not.primul) nfg2l=0
          if(needr.ne.0) mfg2=nfg2+nfg*nfg*nsuptc
c         rij, edim and ctdim are not allocated yet!
c         CT is only for SCF dimers, E and R are for all.
          CALL VALFM(LOADFM)
          ledim=LOADFM+1
          lctdim=ledim+nfg2e+1
          lrij=lctdim+nfg2l
          last=lrij+mfg2
          NEEDL = LAST- LOADFM -1
          CALL GETFM(NEEDL)
        endif
      endif
      nfg2d=nfg2e/nen
c
      IF (IEFPFMO.EQ.1) THEN
        CALL EFPFMOIO(0)
        IF (NDER.GT.0) THEN
          CALL VCLR(X(LDEFTF),1,3*NFRG*NBODY)
          CALL VCLR(X(LTORQF),1,3*NFRG*NBODY)
          CALL VCLR(X(LDEFEF),1,6*NFRG)
        END IF
        if (isgddi) then
          call gddi_scope(ddi_world)
          CALL EFPPARL
        end if
        CALL EFPFMODER(NDER,X(LDEFTF),X(LTORQF),X(LDEFEF))
        if(isgddi) then
          call gddi_scope(ddi_group)
          CALL EFPPARL
        end if
      ENDIF
c
      IDAFMO=40
      DSKWRK=.true.
c     CALL RAOPEN(IDAFMO,x(liodfmo),0,NDAR30,LDAR30,NPRINT)
      call RAOPEN2(IDAFMO,x(liodfmo),0,NDAR30,LDAR30,0,NPRINT)
c     if(forbconv.or.densfmo0)  then
      if(forbconv)  then
        call viclr(x(liodcfmo),1,NDAR30c+n30ex)
        call RAOPEN2(IDAcFMO,x(liodcfmo),0,NDAR30c,LDAR30c,0,NPRINT)
c       It is vital to reserve the first record on IDAcFMO for indexing.
c       This is accomplished by writing something not very meaningful yet.
c       Such dummy writing also ensures that JRECST is correct later.
c       For FMO0 do a restart of the density file.
c       if(forbconv.or.inifmo0) then
          call rawrites(IDAcFMO,x(liodcfmo),x(liodcfmo),NDAR30ci,
     *                  NDAR30ci,1,0)
c       else
c         here is a potentially dangerous part (if iolib is later altered)
c         (see fmorst for more comments).
c         call ixstor(x(liodcfmo),1,1)
c         call raread(IDAcFMO,x(liodcfmo),x(liodcfmo),NDAR30ci,1,0)
c         JRECST(IDAcFMO/10)=ixftch(x(liodcfmo),NDAR30c+5)
c       endif
      endif
      if(fmoq.or.needdm) then
        if(forbconv) call abrt
        call RAOPEN2(IDAcFMO,x(liodcfmo),0,NDAR30q,LDAR30q,0,NPRINT)
      endif
      DSKWRK=savdsk
c
c     Note on RAWRIT vs RAWRITE.
c     RAWRIT can be used if nlayer is 1. Otherwise one writes the same record
c     with different size and this cannot be done by RAWRIT (since later
c     writing has usually larger size). Therefore RAWRITE is used throughout.
c     Note that RAWRITE by allocating more phys records
c     makes the file size larger as well. An
c     economic solution is to set LEN1 argument in RAWRITE to the max
c     size for a given record, not to the max size for the whole file.
c     Such max size is stored in MAXL30.
C     for one layer use RAWRIT style (0 arg)??
c
c     emon structure: (for monomer I), 3+4 are used for BSSE.
c     emon(i,1) E(I) FMO with default correlation
c     emon(i,2) E(I) FMO without correlation
c     emon(i,3) E(I) free monomer with correlation
c     emon(i,4) E(I) free monomer without correlation
c
c     edim structure: for dimer IJ
c     edim(ij,1) EIJ, default correlated
c     edim(ij,2) Tr(delta(DIJ)*VIJ), uncorrelated
c     edim(ij,3) EIJ, uncorrelated
c     edim(ij,4) Tr(delta(DIJ)*VIJ), def. correlated
c     edim(ij,5) E'I+E'J, BSSE(1,2,3), in the dimer basis, default correlated
c     edim(ij,6) Tr(delta(DIJ)*VIJ), BSSE(1,2), from monomers, uncorrelated
c     edim(ij,7) E'I+E'J, BSSE(1,2,3), in the dimer basis, uncorrelated
c                (reserved but not yet used).
c     edim(ij,8) Tr(delta(DIJ)*VIJ), BSSE(1,2), def. corelated
c                (reserved but not yet used).
c     edim(ij,5) delta-EIJ, electrostatic (ES).
c     edim(ij,5 or 6) delta-EIJ, exchange-repulsion (EX).
c     ES or EX options are really incompatible with BSSE now.
c     Note that D and E have different order of correlated/uncorrelated.
c     It comes from corr. D being an extravagance.
c
c     etrim structure: for trimer IJK
c     etrim(ijk,1) EIJK, default correlated
c     etrim(ijk,2) Tr(delta(DIJK)*VIJK)
c     etrim(ijk,3) Tr(delta*delta(DIJK)*VIJK)
c     etrim(ijk,4) EIJK, uncorrelated
c     Depending on the option needdm, EIJK, uncorrelated can be stored in
c     etrim(ijk,3).
c
c     BSSE with correlation is not entirely finished and needs a good check.
c
c     extracc holds extra (by-product) CC energies, such as MP2 or
c     lower order CC.
c     etotdft will probably not work in multilayer FMO if DFT is mixed with
c     some other wavefunction.
      call vclr(etotdft,1,nedft)
      call vclr(x(lemon),1,nfg*4*nlayer)
      if(nbody.gt.1) call vclr(x(ledim),1,nfg2e)
      if(nfg3e.ne.0) call vclr(x(letrim),1,nfg3e)
      if(fmoq) call vclr(x(ledimq),1,nfg2)
      if(nfmoelm.ne.0) call vclr(x(lfmoelm),1,nfmoelm*(nfg+nbody-1))
      call viclr(x(lidmrec),1,nlayer)
      if(dotd.and.nbody.ge.2) then
        call vclr(x(leexfg),1,2*nfg*mxrt)
        if(iexcit(4).eq.2) call vclr(x(lctdm),1,nocctdm*nvirtdm*NSTAT)
      endif
c
      if(isgddi0) then
        call gddi_mastid(x(lmastid))
      else
        call ixstor(x(lmastid),1,master)
c       mastid(0)=master
      endif
      if(nbdfg.ne.0) call setindbd(x(liabdfg),x(ljabdfg),x(lindbd))
      if(totdens) then
      call glolat(x(lloctat),x(llibish),x(llibnsh),x(lizbas),x(lfmozan))
      endif
c
c     process restart initialisation
c
      call fmorst(nfg2,nfg3,nen,nent,l1fmo,NDAR30,NDAR30i,x(liodfmo),
     *            x(llayfrg),x(lemon),x(ledim),x(letrim),x(lidmrec),
     *            ifgfmo0,broadden.and.(mygroup.ne.0.or..not.maswrk),
     *            irestl,some)
c
c     Enforce restarting from layer 1 for FMO optimisations.
      if(nevsav.gt.0) irstlay=1
c     write(6,*) 'old modrst',modrst
c     if(nevsav.gt.0) modrst=mod(modrst,2)+2
      if(irststp.ge.2) modrst=mod(modrst,2)+2
c     write(6,*) 'new modrst',modrst
c     Adjust interation count (it also points out at the orbital location)
c
      ngrdsiz=3*natfmo*mbody
      nelmsiz=nfmoelm*(nfg+nbody)
      nesdsiz=0
      if(esdder) nesdsiz=NDAR30
      if(savgrd) call grdrst(0,nfthes,ngrdsiz,x(lfmode),nelmsiz,
     *                       x(lfmoelm),nesdsiz,x(lisdrec),.false.,
     *                       IDAFMO,ndar30,NDAR30i,x(liodfmo))
c
      needm=need0+need+need1+need2+needl
      if(maswrk.and.nevsav.eq.0)
     *  call fmoout(needm,lbody,x(lfmozan),x(lmulfg),x(lscffrg),
     *              x(lfmoscf),x(lfmoci),x(lfmodft),x(lfmocc),x(lmpfmo),
     *              x(lfmotd),modmol,x(lmolfrg),nstfmo,ncvscf,mcnvfmo,
     *              ngrfmo,loadbf,loadgr,nstjob,ichfmo,nacut,savgrd,
     *              nxg,nyg,nzg,ngm,vdwrad,grdpad,spargrid,nxyzg,ifgfmo0
     *             ,orshft,mpcmit,iexcit)
c
c     emolfrg is used as temporary buffer. Note that moldim should be called
c     after fmoout to have the original array printed out.
      call moldim(x(lmolfrg),x(lemolfrg))
c
      needr0=needr
c
c     PFTYP is not stored in any common block so we do not use PFTYP
c
      PFTYP=rnone
      runtype=runtyp
      if(runtyp.eq.OPTMIZ.or.runtyp.eq.sadpt.or.runtyp.eq.OPTFMO)
     *  runtype=grad
c     if(needdm) call gddi_create(nfg2,iddm)
c       the actual number of used elements is nscf (defined below)
      didcc=.false.
      if(exetyp.eq.check) goto 110
c
c     The PCM loop is hidden inside monoscf for unilayer nfmopcm=1.
c     the explicit loop here is used otherwise.
c
      nbodysav=nbody
      nfg3sav=nfg3
      nfg3esav=nfg3e
      if(nfmopcm.gt.1.or.nfmopcm.gt.0.and.nlayer.gt.1) then
        iterpcm=1
        eprev=zero
c       overwrite nbody with the value in nfmopcm to converge the density
c       and apparent charges at that level.
        if(nfmopcm.lt.nbody) nbody=nfmopcm
        if(nbody.lt.3) then
          nfg3=0
          nfg3e=0
        endif
        if(nbody.ne.nbodysav) then
          nextra=1
        else
          nextra=0
        endif
      else
        iterpcm=0
        nextra=0
      endif
      if(nfmopcm.gt.1.and.mpcmit.gt.2.and.nder.gt.0) nextra=1
      enucfmos=zero
      nextra0=nextra
      runtype0=runtype
c     The PCM[n] loop, n>1 (for MFMO n>=1).
   90 continue
c     hui li - do not run properties in pcm iterations
      runtype=runtype0
      if(nfmopcm.gt.1 .and. iterpcm.lt.mpcmit .and. runtype.eq.grad)
     *  runtype=energy
      if(nfmopcm.gt.1.and.mpcmit.gt.2.and.nextra.lt.nextra0)
     *  runtype=runtype0
      dovpcm=nextra.eq.nextra0.and.iterpcm.lt.mpcmit
      enucfmo=zero
c     if(nfg3e.ne.0) call vclr(x(letrim),1,nfg3e)
      call vclr(extracc,1,nextracc*mbody)
      if(primul) call vclr(x(latmulq),1,natfmo*mbody)
      if(nfmopcm.gt.0) call vclr(x(lesolv),1,nesolv)
      call i0copy(nfg,x(llayfrg),0,x(llayfrg),nfg)
      if(nbody.gt.1.and.primul) call vclr(x(lctdim),1,nfg2l)
c
      do 100 ilay=irstlay,nlayer
        icurlay=ilay
        scftypi=x(lfmoscf-1+ilay)
        mplevli=IXFTCH(x(lmpfmo),ilay)
        DFTYPE=x(lfmodft-1+ilay)
        if(DFTYPE.ne.rnone) then
          NDFTFG=1
          call INPGDFT(DFTYPE,PFTYP)
        else
          NDFTFG=0
          DFTTYP(3)=ONE
        endif
        CITYPi=x(lfmoci-1+ilay)
        CCTYPi=x(lfmocc-1+ilay)
        TDDFTi=x(lfmotd-1+ilay)
        if(nfmopcm.eq.0) nbody=lbody(ilay)
c       That means that setting different nbody in MFMO will not work in
c       FMO/PCM.
        if(nfmopcm.ne.0.and.gcorrel.and.
     *     mpcmit.eq.2.and.iterpcm.eq.1) then
c         during the first iteration in FMO/PCM[1(n)] one only
c         wants to get the density and dynamic correlation is a waste.
c         Note that during FMO/PCM[n] one needs correlation, as the
c         total correlated energy must converge.
          mplevli=0
          CITYPi=rnone
          CCTYPi=rnone
          TDDFTi=rnone
          if(maswrk) write(iw,*) 'Turning off correlation...'
        endif
        if(maswrk) then
          write(iw,9100) ilay,nbody,scftypi,mplevli,dftype,CITYPi,
     *                   CCTYPi,TDDFTi
        endif
        if(CCTYPi.ne.rnone) didcc=.true.
c       Scan for ROHF and replace it by MCSCF
        moncor=0
        if(scftypi.eq.rohf) then
c         Signal to MCSCF that active space will be hadrwired to ROHF.
          moncor=-1
          scftypi=rmc
        endif
c
        correl=mplevli.ne.0 .or. CITYPi.ne.rnone .or. CCTYPi.ne.rnone
     *         .or.tddfti.ne.rnone
c       add other corrl
        if(correl.and..not.ext2lay.and.
     *     (rcorsd.gt.resdim.or.rcorsd.eq.0.and.resdim.ne.0)) then
          write(6,*) 'Invalid rcorsd and resdim',rcorsd,resdim
          call abrt
        endif
        if(citypi.ne.rnone.and.nder.gt.0) then
c         See below what needs to be done.
          write(6,*) 'FMO-CI gradient is not finished yet.'
c         call abrt
        endif
        if(ext2lay) then
          if(ilay.eq.1) then
c           Set each fragment to layer 1.
            call icopy(nfg,1,0,x(llayfrg),1)
          else
c           Restore layer assignment
            call i0copy(nfg,x(llayfrg),nfg,x(llayfrg),0)
            resdim=1.0D+06
c           Input should have resdim=0, to which resdim=1.0D+06 is equivalent,
c           but the correlated code must not have resdim=0.
          endif
        endif
c
c       Step 1: initial density matrices
c
        liemon=lemon+(ilay-1)*4*nfg
c
c       One of those FTNCHECK things
c
        ilay1=ilay
c
        if(isgddi0.and.ngrfmo(1,ilay).ne.0)
     *    call fmopre(ilay1,1,ngrfmo,x(lmannod),x(lmastid))
c       write(6,*) 'mastids',(mastid(i),i=0,ngroups-1)
c
        doddcor=((MPLEVLi.gt.0.and.(MPPROP.ne.0.or.nder.gt.0)).or.
     *           citypi.ne.rnone.or.tddfti.ne.rnone.and.nder.gt.0).and.
     *          .not.doscfprp
        if(doddcor.and.nbody.gt.2) then
c         Only energy can be obtained. Properties need both uncorr. and corr.
c         dimer runs if RCORSD is not zero.
          write(6,*) 'Correlated properties not available for nbody>2'
c         call abrt
        endif
c
        if(iterpcm.le.1.or.nlayer.gt.1) then
c       inidfmo has to be called with the correct nbody/nfg3/nfg3e
c       (to fill in indexing arrays and sum them up in parallel).
        nbodys2=nbody
        nbody=nbodysav
        call inidfmo(ilay1,loadhf,x(ljobgrp),x(lloadm),x(lloadd),
     *              x(lloadt),x(llayfrg),x(lindat),x(lnumfrg),x(lnatfrg)
     *              ,x(liaglob),x(lfmozan),x(lfmoc),x(lizbas),x(liabdfg)
     *              ,x(ljabdfg),x(liodfmo),x(lmaxl30),x(lfmoda),
     *               x(lfmodb),x(liemon+nfg*2),x(lglocon),x(llocfmo),
     *               x(lwrk),x(lmolfrg),x(lscffrg),mcnvfmo,x(lmconfg),
     *               x(lijvec),correl,scftypi,mplevli,CITYPi,CCTYPi,
     *               tddfti,orbxch,enexch,atonce,dosap,dospc,docas,
     *               nactfmo,ncasfmo,x(lmastid),needr0,x(lrij),x(lrwrk),
     *               nfg2,mfg2,nfg3sav,x(liwrkd),enucfmo,x(lpopmul),
     *               x(lpopmat),needmd,x(lnmdfrg),x(lnmtfrg),x(lndtfrg),
     *               prtdst,x(lifgbuf),x(lnfgbuf),nscf,nemc,forbconv,
     *               conv2mc,l1fmoc,IDAcFMO,x(liodcfmo),x(libfconv),
     *               x(lmapconv),x(lorbconv),loadbf(1,ilay),
     *               loadgr(1,ilay),nstjob,semidyn,broadden,vdwrad,
     *               exclmol,densgrid0,nxyzg,x(ldgrid),ngm,nxyzgm0,
     *               x(ldgridm),grdpad,spargrid0,x(lnoffg),x(lindgrd),
     *               x(lnprfrg),ifgfmo0,isgddi0,m0fmo,doddcor,dolat,
     *               nunptc,natfmob,x(luntxyz),x(lnsymeq),x(lstonep),
     *               nfrgmul,x(lfrgmul),iexcit)
          nbody=nbodys2
          l0fmo=l0fmo-m0fmo
        endif
        if(ext2lay.and.ilay.eq.1.and.nbody.eq.3) then
          call adjprp(2,x(llayfrg),x(lnmmfrg),x(lnddfrg))
        endif
c       if(ilay.lt.irstlay) goto 100
        if(nbody.lt.1) goto 105
        if(forbconv) goto 105
c       if(needdm) then
c         if the value below exceeds integers that means the memory will not
c         work anyway. needmddi is an upper bound, exactly true for
c         molecular clusters but usually about 2 times an overestimate.
c         needmddi=(nscf*maxl2+(nfg2-1)/nwdvar)/1000000+1
c         if(maswrk) write(6,9110) needmddi
c       endif
c
c
c       Now the big monomer SCF iterations start
c
c      write(6,*) 'wwwrij',(x(lrij+ij-1),ij=1,nfg2)
c
       call monoscf(ilay1,nder,runtype,loadhf,ndar30,ndar30i,x(ljobgrp),
     *             x(lloadm),x(llayfrg),x(lnumfrg),x(lnatfrg),x(liaglob)
     *             ,ichfmo,nefmo,x(liodfmo),x(lmaxl30),x(lidmrec),
     *              x(lfmoda),x(lfmodb),x(lfmoespa),x(lwrk),x(lwrk1),
     *              x(lwrk2),x(liemon),x(lglocon),x(lfmode),x(lfmopg),
     *              x(latmulq),x(latmulqi),mbody,nfmoelm,x(lfmoelm),
     *              needmd,x(lnmmfrg),x(lnmdfrg),x(lnmtfrg),x(lmolfrg),
     *              x(lscffrg),correl,scftypi,mplevli,CITYPi,CCTYPi,
     *              tddfti,mcnvfmo,ncvscf,x(lmconfg),dosap,dospc,docas,
     *              primul,orbxch,enexch,atonce,x(litrlay),nfglay,
     *              x(lpopmul),x(lpopmat),x(lifgbuf),x(lnfgbuf),ngrfmo,
     *              x(lmannod),x(lmastid),x(lnprfrg),totdens,l2fmo,
     *             x(ltotd),x(liaoglob),exclmol,densgrid,nxyzg,x(ldgrid)
     *             ,ntimout,loadgr(1,ilay),nstjob(1),l1dir,ngm,nxyzgm,
     *              x(ldgridm),grdpad,vdwrad,spargrid,x(lnoffg),
     *              x(lindgrd),ifgfmo0,isgddi0,grandmas,densfmo0,IDAcFMO
     *             ,x(liodcfmo),extracc,nextracc,lfmasc,needasc,
     *              x(lesolv),nesolv,iterpcm,NTSPAR,dovpcm,pcmoff,
     *              etotdft,nedft,x(LAXYZCT),x(lPEL),x(lVNUC),dopleda,
     *              x(lepl0ds),x(lefmo0+(ilay-1)*nfg*2),doscfprp,ext2lay
     *             ,dolat,n2fmo,x(lklms),x(luntrot),x(lesplat),addesp,
     *              diffesp,x(lstonep),natfmob,nfrgmul,x(lfrgmul),iexcit
     *             ,eexcit,texcit,idxyz,monoc,monvr,nstmono,nocctdm,
     *              nvirtdm,x(lctdm))
c       write(6,*) 'NI stat: ',(nni(i),i=1,9),'NJ stat: ',(nnj(i),i=1,9)
c       Reset nbody to show results for the the first unconverged nbody level.
        if(ntimout.gt.1) nbody=1
        if(ntimout.ne.0) goto 110
c
c       if(dolat) then
c         do iu=1,nunesp
c           do ifg=1,nfg
c             ind=lespl1i+(iu-1)*n2fmo+(ifg-1)*maxl2
c             write(6,*) 'ESP1(I),1e',ifg,iu
c             call prtri(x(ind),maxl1)
c           enddo
c         enddo
c         do iu=2,nunesp
c           ind2=lespl1i+(iu-1)*n2fmo+(ifg-1)*maxl2
c           call daxpy(n2fmo,one,x(ind2),1,x(lespl1i),1)
c         enddo
c         do ifg=1,nfg
c           write(6,*) 'ESP1,1e',ifg
c           ind=lespl1i+(ifg-1)*maxl2
c           call prtri(x(ind),maxl1)
c         enddo
c         call genlatv(ilay1,natfmob,maxklms,n2fmo,nunptc,x(lklms),
c    *            x(luntxyz),x(luntrot),x(lcfrg),x(lfmoespa),x(lesplat))
c       endif
c
c      save monomer energies for restarts
c
        if(nfglay.ne.0) call eminout(1,ilay1,ifgfmo0,x(llayfrg),x(lemon)
     *                              ,some)
        if(nbody.lt.2) goto 105
c
c       compute all dimer energies and BBSE corrections if requested.
c
        if(nfglay.ne.0) then
          if(isgddi0.and.ngrfmo(2,ilay).ne.0)
     *      call fmopre(ilay1,2,ngrfmo,x(lmannod),x(lmastid))
c     It is an annoying artifact of ngrfmo(1) and ngrfmo(2) division in which
c     a master can become a slave and vice versa.
          lfmoelmd=lfmoelm+nfmoelm*nfg
          lfmoelmt=lfmoelm+nfmoelm*(nfg+1)
c         CIS properties can be added similar to MPPROP
c         GUGA CI gradients are not quite working. One has to sort out
c         densities (CI and SCF, getting both properties at the same time etc).
c         The real question is: how to do FMO-CI?
c         Two approaches seem meaningful:
c         1. Define only one fragment as CI. This makes FMO-RHF:CI and is
c            well defined (not fully programmed yet).
c         2. Define some fragments as CI and study local excitation energies
c            while abandoning all other properties (-all- is really meant here,
c            including pair interaction energies)..
c         if(doddcor.and.nlayer.gt.1) call abrt
c     multi-layer runs need sophisticated setup of MP2/RHF densities
c     doddcor tells whether to do delta-DIJ terms for RHF and dynamic
c     correlation (if false, do only RHF delta-DIJ terms).
c     At present only MP2 is supported.
c         will doddcor be proper for restarts?
c         irec0cor=idmrec0(ilay)
          irec0cor=ixftch(x(lidmrec),ilay)
c         this is a bit of a hack to get irec0rhf
          irec0rhf=1
          if(irec0cor.eq.1) irec0rhf=nfg*2+1
          irec0=irec0cor
          if(doddcor) irec0=irec0rhf
          if(dopleda) irec0cor=irec0rhf
c         For PL0, irec0cor points to PL0  monomer densities DI
c         For PL0, irec0    points to free monomer densities DI
          if(fmoq.or.needdm) call viclr(x(ljob2grp),1,nfg2)
c         ifmoqit=0
c         nfmoqit=20
c  95     continue
c         ifmoqit=ifmoqit+1
          call edimer(ilay1,nder,runtype,loadhf,x(ljobgrp),x(lloadm),
     *               x(lloadd),x(llayfrg),x(lnumfrg),x(lcfrg),x(liodfmo)
     *               ,x(lmaxl30),x(lindat),x(liaglob),x(lidmrec),
     *                needr.gt.0,x(lfmoda),x(lfmodb),x(lwrk),x(lwrk1),
     *                x(lwrk2),x(lzsave),x(lfmoespa),x(lfmoespb),
     *                x(liemon),x(ledim),x(lfmode),x(lfmopg),enucfmo,
     *                x(latmulq+natfmo),nfmoelm,x(lfmoelmd),x(lfmoelmt),
     *                x(lnddfrg),x(lndtfrg),x(liabdfg),x(ljabdfg),
     *                x(llocfmo),x(lmolfrg),x(lscffrg),x(lmapi),x(lmapj)
     *               ,mcnvfmo,mconvex,x(lmconfg),x(lijvec),correl,
     *               scftypi,mplevli,CITYPi,CCTYPi,tddfti,nfg2d,nfg2,nen
     *               ,nactfmo,ncasfmo,primul,orbxch,enexch,ntimout,nscf,
     *                nemc,docas,nedimes,nedimex,x(ljob2grp),needdm,
     *                ngrfmo,x(lmannod),x(lmastid),x(lnprfrg),x(lisdrec)
     *               ,nfthes,ngrdsiz,nelmsiz,nesdsiz,x(lfmoelm),ndar30,
     *                NDAR30i,savgrd,modmol,exclmol,totdens,x(ltotd),
     *               x(liaoglob),densgrid,nxyzg,x(ldgrid),loadgr(2,ilay)
     *               ,nstjob(2),l1dir,grdpad,vdwrad,spargrid,x(lnoffg),
     *                x(lindgrd),extracc,nextracc,irec0,irec0cor,doddcor
     *               ,x(lesolv),dovpcm,etotdft,nedft,x(LAXYZCT),x(lPEL),
     *               x(lVNUC),x(lQSE),X(LISPHE),x(lqtmp),imect,x(lctdim)
     *               ,x(lpopmat),x(lialoc),x(lindbd),ext2lay,fmoq,
     *                IDAcFMO,x(liodcfmo),dopleda,dolat,nunint,nunptc,
     *                natfmob,x(luntxyz),x(luntrot),x(lesp1i),x(lesp1j),
     *                x(lczi),x(lczj),x(lnsymeq),maxl2,n2fmo,x(lklms),
     *                x(lesplat),addesp,addesp0,x(lstonep),some,iexcit,
     *                eexcit,texcit,idxyz,monoc,monvr,nstmono,isumd,
     *                x(leexfg),nocctdm,nvirtdm,x(lctdm),exfid)
          if(ntimout.gt.1) nbody=2
          if(ntimout.ne.0) goto 110
c      write(6,*) '2NI stat: ',(nni(i),i=1,9),'NJ stat: ',(nnj(i),i=1,9)
          if(fmoq) then
c           if(fmoq) call viclr(x(ljob2grp),1,nfg2)
            call efmoq(ilay1,loadhf,x(lloadd),x(llayfrg),x(lmolfrg),
     *                IDAcFMO,x(liodcfmo),modmol,exclmol,x(ledimq))
c           call vclr(x(ledimq),1,nfg2)
c           e1sum=ddot(nfg,x(lemon),1,one,0)
c           e2sum=ddot(nfg2*2,x(ledim),1,one,0)
c           write(6,*) 'FMOQ iter=',ifmoqit,' E=',-(nfg-2)*e1sum+e2sum
c           if(ifmoqit.lt.nfmoqit) then
c             call vclr(x(ledim),1,nfg2e)
c             if(nfmoelm.ne.0) call vclr(x(lfmoelm+nfg*nfmoelm),1,
c    *                                   nfmoelm)
c             goto 95
c           endif
          endif
          if(nbody.lt.3) goto 105
c
          if(isgddi0.and.ngrfmo(3,ilay).ne.0)
     *      call fmopre(ilay1,3,ngrfmo,x(lmannod),x(lmastid))
          call etrimer(ilay1,nder,runtype,loadhf,x(lloadt),x(llayfrg),
     *                 x(lnumfrg),x(liodfmo),x(lindat),x(liaglob),
     *                 x(lfmoda),x(lfmodb),x(lwrkc),x(lwrk),x(lwrk1),
     *                 x(lwrk2),x(lfmoespa),x(letrim),x(lfmode),
     *                 x(lfmopg),x(latmulq+natfmo*2),nfmoelm,x(lfmoelmt)
     *                ,x(liabdfg),x(ljabdfg),x(llocfmo),x(lmolfrg),
     *                 x(lscffrg),x(lmapi),x(lmapj),x(lmap3),mcnvfmo,
     *                 mconvex,x(lmconfg),correl,mplevli,CITYPi,CCTYPi,
     *                 tddfti,nfg3,nent,nactfmo,maxl1d,primul,orbxch,
     *                 enexch,ntimout,x(ljob2grp),needdm,x(lnprfrg),
     *                 totdens,x(ltotd),x(liaoglob),modmol,exclmol,
     *                 densgrid,x(ldgrid),l1dir,grdpad,vdwrad,extracc,
     *                 nextracc,irec0,doddcor,x(lesolv3),dovpcm,etotdft,
     *                 nedft,x(LAXYZCT),x(lPEL),x(lVNUC),IDAcFMO,
     *                 x(liodcfmo),x(luntrot),x(lstonep),some)
        endif
c
  105   continue
c         reset for the next layer. If layers have the same basis set (size),
c         previous layer's orbitals/densities can be read.
        modrst=0
        irststp=0
        if(iand(nguess,32768).ne.0) then
c         MP2 density??
          modrst=1
          irststp=2
        endif
        needr0=0
c       rij is computed for layer 1 that is supposed to include all atoms!!
c       (that gibberish means that rij are not recomputed for layers beyond 1)
        if(esdder) call viclr(x(lisdrec),1,NDAR30)
c       Clear isdrec for the next layer, not to reuse the old potentials.
  100 continue
c
  110 continue
      if(nfmopcm.eq.0) nbody=lbody(inamax(MaxLay,lbody,1))
c
c     RESDIM runs alter iodfmo and it has to be saved now.
c
      if(esdder) then
        call ixstor(x(liodfmo),NDAR30+5,JRECST(IDAFMO/10))
        call rawrites(IDAFMO,x(liodfmo),x(liodfmo),NDAR30i,NDAR30i,1,0)
      endif
c
c     if(needdm) call gddi_destroy(iddm)
      ndata=0
      if(isgddi0) then
        CALL TSECND(TIMe0)
        wall0=wall
c       if(.not.maswrk) call vclr(x(ledim),1,nfg2e+1)
        call gddi_scope(ddi_world)
        if(nfmoelm.ne.0) then
          call ddi_gsumf(2416,x(lfmoelm),nfmoelm*(nfg+nbody-1))
          ndata=ndata+nfmoelm*(nfg+nbody-1)
        endif
        x(ledim+nfg2e)=enucfmo
        call ddi_gsumf(2415,x(ledim),nfg2e+1)
        enucfmo=x(ledim+nfg2e)
        ndata=ndata+nfg2e+1
        if(fmoq) then
          call ddi_gsumf(2415,x(ledimq),nfg2)
          ndata=ndata+nfg2
        endif
        if(nfg3e.ne.0) then
          call ddi_gsumf(2415,x(letrim),nfg3e)
          ndata=ndata+nfg3e
        endif
        if(ndftfg.eq.1) then
          call ddi_gsumf(2415,etotdft,nedft)
          ndata=ndata+nedft
        endif
        if(didcc) then
          call ddi_gsumf(2415,extracc,nextracc*mbody)
          ndata=ndata+nextracc*mbody
        endif
        if(dotd.and.nbody.ge.2) then
          call ddi_gsumi(2415,isumd,mxrt+1)
          call ddi_gsumf(2415,eexcit(1,2),mxrt)
          call ddi_gsumf(2415,texcit(1,1,2),3*mxrt)
          call ddi_gsumf(2415,x(leexfg),2*nfg*mxrt)
          ndata=ndata+4*mxrt+mxrt+1+2*nfg*mxrt
        endif
        if(primul) then
          call ddi_gsumf(2416,x(latmulq),natfmo*mbody)
          ndata=ndata+natfmo*mbody
        endif
        if(nder.gt.0) then
          call ddi_gsumf(2416,x(lfmode),3*natfmo*mbody)
          ndata=ndata+3*natfmo
        endif
        if(totdens) then
          call ddi_gsumf(2416,x(ltotd),l2fmo)
          ndata=ndata+l2fmo
        endif
        if(densgrid.and.ifgfmo0.eq.0 .or.spargrid) then
          call ddi_gsumf(2416,x(ldgrid),nxyzg*ngbody)
          ndata=ndata+nxyzg*ngbody
        endif
        if(nfmopcm.ne.0) then
          call ddi_gsumf(2416,x(lesolv),nesolv)
          ndata=ndata+nesolv
          if(iterpcm.gt.0.and.dovpcm) then
            call ddi_gsumf(2418,x(lPEL),NTS)
            call ddi_gsumf(2418,x(lVNUC),NTS)
            ndata=ndata+NTS*2
          endif
        endif
        if(nbody.gt.1.and.primul) then
          call ddi_gsumf(2415,x(lctdim),nfg2l)
          ndata=ndata+nfg2l
        endif
        if(dopleda) then
c         Sum upper two monomer energies.
c         no MFMO here! Easy to change (add ilay loop).
c         call ddi_gsumf(2415,x(lemon+nfg*2),nfg*2)
          call ddi_gsumf(2415,x(lepl0ds),nepl0)
          ndata=ndata+nepl0
        endif
        if(IEFPFMO.EQ.1.and.NDER.GT.0) then
          call ddi_gsumf(2415,x(LDEFTF),3*NFRG*NBODY)
          call ddi_gsumf(2415,x(LTORQF),3*NFRG*NBODY)
          ndata=ndata+3*NFRG*NBODY*2
        endif
        call gddi_scope(ddi_group)
        CALL TSECND(TIMe1)
        if(maswrk) write(iw,9600) ndata,wall-wall0
      else
        if(nder.gt.0) call ddi_gsumf(2416,x(lfmode),3*natfmo*mbody)
        if(densgrid.and.ifgfmo0.eq.0 .or.spargrid)
     *    call ddi_gsumf(2416,x(ldgrid),nxyzg*ngbody)
        if(IEFPFMO.EQ.1.and.NDER.GT.0) then
          call ddi_gsumf(2416,x(LDEFTF),3*NFRG*NBODY)
          call ddi_gsumf(2416,x(LTORQF),3*NFRG*NBODY)
        endif
        if(nfmopcm.ne.0.and.iterpcm.gt.0.and.dovpcm) then
          call ddi_gsumf(2418,x(lPEL),NTS)
          call ddi_gsumf(2418,x(lVNUC),NTS)
        endif
      endif
c     write(6,*) 'wwwdgrid2',(x(ldgrid+i-1),i=1,nxyzg)
c     For DFT, project out junk from gradient for each ibody separately.
c     Note that it should be done only after global summing the gradient.
      IF(nder.gt.0.and.(NDFTFG.EQ.1.OR.DFTTYP(1).NE.0.0D+00)) then
        CALL TSECND(TIMe0)
        wall0=wall
c       we must cheat RAMS subroutine because it is not smart enough to have
c       NAT as its argument. RAMs is also treacherously called from PRJGRD,
c       thus nat restore we must after all is done.
        natsav=nat
        nat=natfmo
        do ibody=1,nbody
          call dftgprj(x(lfmode+(ibody-1)*3*natfmo),x(lfmozan),x(lfmoc),
     *                 x(lfmomas),natfmo,tabm)
        enddo
        nat=natsav
        CALL TSECND(TIMe1)
        if(maswrk) write(iw,9610) wall-wall0
      endif
      IF(iterpcm.gt.0.and.dovpcm) then
c
c     Finish off some FMO-PCM properties.
c
        if(isgddi) call gddi_scope(ddi_world)
c       2 in calcasc means 2nd iteration (skipping initial guess formation).
        call calcasc(2,NTSPAR,ichfmo,nefmo,lfmasc,needasc,idum1,nesolv,
     *               idum2,idum3,idum4)
        if(isgddi) call gddi_scope(ddi_group)
      endif
c
c       Step 6: Compute total energy and properties
c
      nenm=1
      if(gcorrel) nenm=nenm+1
      if(ntimout.gt.1) then
        if(modef.ne.0) nfmoelm=0
        enucfmo=0
c       For diverged runs during geometry optimisation dipole moments are
c       not accumulated.
c       For other RUNTYPs some dipole moments may be available, some are
c       zero (unconverged ones).
c       enucfmo is not properly computed either (it can be got; but why?).
      endif
c     Enucfmo is not computed correctly for 1-body FMO with fractioned bonds or
c     MFMOn-PCM[1], n>1. Zero out for the latter case rather that try to get it.
      if(nfmopcm.eq.1.and.nlayer.gt.1.and.nbody.eq.1.and.nbodysav.gt.1)
     *  enucfmo=zero
c     FMO-PCM[2] does not call inidfmo for iterpcm>1, this enucfmo gets wrong
c     values. Recover by saving the value for iterpcm=1 and then reusing it.
c     Do not do it for multilayer runs.
      if(nlayer.eq.1) then
        if(iterpcm.eq.1) enucfmos=enucfmo
        if(iterpcm.gt.1) enucfmo=enucfmos
      endif
c     if(maswrk)
c     if(exetyp.ne.check)
c
      if(irststp.eq.2.and.ispher.eq.1) l0fmo=0
c     l0fmo is definitely wrong for restarts (because QMTSYM is not called in
c     GUESS). For now just zero out. It seems possible to save l0fmo on F40...
c
C
C     COPY TO DEFT AND TORQ FOR NEXT CALCULATIONS (FMO/EFP)
C
      IF (IEFPFMO.EQ.1.AND.NDER.GT.0) THEN
        CALL DCOPY(NFRG*3,X(LDEFTF+(NBODY-1)*NFRG*3),1,DEFT,1)
        CALL DCOPY(NFRG*3,X(LTORQF+(NBODY-1)*NFRG*3),1,TORQ,1)
      END IF
c
      call fmoprop(nder,ichfmo,nefmo,l0fmo,l1fmo,nfg2d,nfg2,nfg3,nenm,
     *             nen,nent,needdm,x(lichfg),x(lfrgnam),x(llayfrg),
     *             x(lindat),x(liabdfg),x(ljabdfg),x(litrlay),x(lfmozan)
     *            ,x(lscffrg),x(lfmoscf),x(llcorrel),modmol,exclmol,
     *             x(lmolfrg),x(lemolfrg),x(lemon),x(ledim),x(letrim),
     *             x(ledimq),x(lesolv),x(lemocdr),x(lfmode),fmoq,primul,
     *             enucfmo,x(latmulq),nfmoelm,x(lfmoelm),nelm,modef,
     *             gcorrel,nedimes,nedimex,ifgfmo0,doddcor,isgddi0,
     *             extracc,nextracc,didcc,etotdft,nedft,x(lctdim),n0bda,
     *             i0bda,x(le0bda),x(lefmo0),x(lepl0ds),eint0,dopleda,
     *             rappri,nappri,x(lerapp),x(lnrapp),ext2lay,x(LDEFTF),
     *             x(LTORQF),dolat,nunint,x(lnsymeq),dotd,iexcit,eexcit,
     *             texcit,nstmono,osmd,isumd,x(leexfg))
c
      if(iterpcm.gt.0) then
        econv=etot-eprev
        if(maswrk.and.nextra.eq.nextra0) write(iw,9700) iterpcm,econv
        eprev=etot
        pcmnotconv=(abs(econv).ge.convpcm.and.iterpcm.lt.mpcmit).and.
     *              nextra.eq.nextra0
        iterpcm=iterpcm+1
        if(pcmnotconv.or.nextra.gt.0) then
c         if(.not.pcmnotconv) then
          if(.not.pcmnotconv.or.mpcmit.eq.2.and.nextra.gt.0) then
            nextra=nextra-1
            nbody=nbodysav
            nfg3=nfg3sav
            nfg3e=nfg3esav
          endif
          call vclr(x(lemon),1,nfg*4*nlayer)
          if(nbody.gt.1) call vclr(x(ledim),1,nfg2e)
          if(nfg3e.ne.0) call vclr(x(letrim),1,nfg3e)
          if(nfmoelm.ne.0) call vclr(x(lfmoelm),1,nfmoelm*(nfg+nbody-1))
c         fmode was zeroed out by H. Li and this was commented out because
c         in FMO/PCM iterations the gradient is not computed.
c         if(nder.gt.1) call vclr(x(lfmode),1,3*natfmo*mbody)
          goto 90
        endif
        if(iterpcm.ge.mpcmit) then
          if(mpcmit.eq.2) then
c           FMOn/PCM[m(l)] at present can only be run for m=1.
            write(iw,9710) nbody,1,nfmopcm
          else
            write(iw,*) 'PCM[2] did not converge!'
c           call abrt
          endif
        endif
      endif
c
      nbody=nbodysav
      nfg3=nfg3sav
      nfg3e=nfg3esav
c
c     Silly way to pass some results to FMO0.
c
      if(ifgfmo0.ne.0) then
        icurlay=ixftch(x(llayfrg),1)
        espscf=x(lfrgnam)
        num=ixftch(x(lnumfrg),1)
        nat=ixftch(x(lnatfrg),1)
        SCFTYP=x(lscffrg)
        nat1e=ixftch(x(lmaxl30),1)
      endif
c
      lfmodel=lfmode+3*natfmo*(mbody-1)
c     if(runtyp.eq.OPTMIZ.or.runtyp.eq.sadpt)
      if(modef.ne.2) call gmsprop(modef,nfthes,nc1,x(lfmodel),nfcrec,
     *                            grandmas)
c     restore coordinates
      if(modef.eq.1) then
        call gmsxyz(0,nfthes,nc1,natfmo,x(lfmozan),x(lfmoc),x(lizbas),
     *              nfcrec,nevsav,grandmas,squit)
        squit=.false.
      endif
c
c     Save the total electron density
c
      if(totdens) then
        call CLOSDA('DELETE')
        CALL OPENDA(0)
        CALL dawrit(IDAF,IODA,x(ltotd),l2fmo,16,0)
c       write(6,*) 'wwwcurdt'
c       call prtri(x(ltotd),21)
      endif
c     Only the global master dumps cube
c     if(densgrid.and.grandmas)
      if(densgrid.and.ifgfmo0.eq.0.and.grandmas) then
        write(iw,*) 'Punching cube data...'
        call makecube(0,nbody,natfmo,x(lfmozan),x(lfmoc),x(ldgrid),
     *                NXG,NYG,NZG,ORIGIN,UX,UY,UZ)
        call timit(1)
      endif
      if(spargrid.and.(ifgfmo0.ne.0.and.maswrk.or.grandmas)) then
        write(iw,*) 'Punching sparse cube data...'
        do ibody=1,mbody
          iibody=ibody
          if(nbody.eq.0) iibody=0
         call makescube(1,ifgfmo0,iibody,x(llayfrg),x(lindat),x(lfmozan)
     *                  ,x(lfmoc),x(ldgrid+(ibody-1)*nxyzg),x(lnoffg),
     *                   x(lindgrd),maxg)
        enddo
        call timit(1)
      endif
c
c     Save the energy gradient
c
      if(runtyp.eq.optfmo) call dcopy(natfmo*3,x(lfmodel),1,x(lfmoge),1)
c
      DSKWRK=.true.
      if(fmoq.or.needdm) then
        call RACLOS(IDAcFMO,'DELETE')
      endif
c     if(forbconv.or.densfmo0) then
      if(forbconv) then
c       if(densfmo0) l1fmo=0
        call bconvrec(x(lfmozan),x(lizbas),x(liabdfg),NDAR30c,
     *                x(liodcfmo),l1fmo,l1fmoc,IDAcFMO,x(libfconv),
     *                maxl1.ne.maxl1c)
        call rawrites(IDAcFMO,x(liodcfmo),x(liodcfmo),NDAR30ci,NDAR30ci,
     *                1,0)
        CALL RACLOS(IDAcFMO,'KEEP')
      endif
      CALL RACLOS(IDAFMO,'KEEP')
      DSKWRK=savdsk
      if(dolat) CALL RETFM(NEEDL)
      CALL RETFM(NEED1)
      CALL RETFM(NEED2)
c
      IF (IEFPFMO.EQ.1) CALL EFPFMOIO(1)
c
 5555 continue
      IF(nfmopcm.ne.0) then
        CALL RETFM(needasc)
c       memPCM1 and memPCM2 are allocated in INPPCM.
        CALL RETFM(memPCM2)
        CALL RETFM(memPCM1)
      endif
      if(i0bda.lt.n0bda) goto 80
      if(n0bda.ne.0.and.maswrk) call bdaeout(n0bda,x(le0bda))
      if(dopleda) call eplout(x(lepl0ds),eint0)
c
      CALL RETFM(NEED)
      CALL RETFM(NEED0)
c
c     restore SCF settings that are likely to have been overwritten
c     during SCF and would otherwise have been erroneously used as the
c     default values during any goemtry optimisation.
c     Since calling NAMEIO involves a broadcast, it is probably better done
c     in the current group scope.
      if(modef.ne.0) CALL SCFIN
c
      if(.not.squit) then
        nevals=nevsav+1
        if(maswrk) write(iw,9000)
c       Print timing on slaves
        iptim0=iptim
        iptim=1
        call timit(1)
        iptim=iptim0
        nzmat=nzmtsav
      else
c       call gddi_scope(ddi_world)
c       It is needed just to get NPROC next time FMOX is called. Or should
c       we do it always?
      endif
 5556 continue
      if(runtyp.eq.OPTMIZ.or.savgrd) then
         if(savgrd) dskwrk=.true.
         CALL SEQCLO(NFThes,'KEEP')
         if(savgrd) dskwrk=savdsk
      endif
      if(isgddi0) call gddi_scope(ddi_world)
      if(ntimout.gt.1) then
        if(maswrk) write(iw,9300)
        call abrt
      endif
      ELMLOC=ELMLOCs
c     Restore integral packing options. Important!
      labsiz=labsix
      nintic=nintix
c     FMO can now set DIRSCF to .true. whereas it was .false. before calling
c     FMOX. This leads to memory leaks because in core integral buffer
c     is not returned, therefore, restore the pristine value.
      DIRSCF=savdir
      norbproj=0
      nfg=nfgsav
      runtyp=runtyps
      return
 9000 format(//1x,'Successfully finished FMO calculation.',/)
 9010 format(/1x,'Orbital conversion requires unilayer sequential run',
     *       /1x,'with modorb=3 for RHF->MCSCF and modorb=0 otherwise.')
 9100 format(//1x,'Starting layer',I2,' nbody=',I1,/1x,'SCFTYP=',A8,
     *         'MPLEVL=',I1,' DFTTYP=',A8,'CITYP=',A8,'CCTYP=',A8,
     *         'TDDFT=',A8//)
c9110 format(/1x,'The average amount of MEMDDI you need is ',I4,
c    *       /1x,'At least double of that value is recommended.',/)
 9200 format(/1x,'Rcorsd is reset to zero: no electron correlation.',/)
 9300 format(//1x,'Aborting due to an unrecoverable error.',/)
 9400 format(//1x,'No or invalid grid defined in $GRID: ',3I6)
 9410 format(/1x,'To restart gradient from dimers, add 1024 to irest',
     *       /1x,'and provide a gradient restart file.',/)
 9420 format(/1x,'No ES moments will be computed because property',
     *            ' restart is off.',/)
 9422 format(/1x,'No Mulliken charges will be printed because property',
     *            ' restart is off.',/)
c9422 format(/1x,'No ES moments will be computed during a PL0 run.',/)
 9430 format(//1x,'Automatic non-sparse grid is not programmed for ',
     *            'FMO0. Remove 16 from modprp.',/)
 9440 format(/1x,'FMO-PCM restarts not supported.')
 9600 format(/1x,'Data exchange of',I11,' words took',F8.1,' s.')
 9610 format(/1x,'DFT gradient projection took',F8.1,' s.')
 9700 format(/1x,'PCM iteration',I4,', convergence=',F15.9)
 9710 format(/1x,'The FMO',I1,'/PCM[',I1,'(',I1,')] finished.')
      end
C*MODULE fmo     *DECK inidfmo
      SUBROUTINE inidfmo(ilay,loadhf,jobgrp,loadm,loadd,loadt,layfrg,
     *                   indat,numfrg,natfrg,iaglob,fmozan,fmoc,izbas,
     *                   iabdfg,jabdfg,iodfmo,maxl30,da,db,emon,glocon,
     *                   locfmo,vec,molfrg,scffrg,mcnvfmo,mconfg,ijvec,
     *                   correl,scftypi,mplevli,CITYPi,CCTYPi,tddfti,
     *                   orbxch,enexch,atonce,dosap,dospc,docas,nactfmo,
     *                   ncasfmo,mastid,needr0,rij,rwrk,nfg2,mfg2,nfg3,
     *                  iwrkd,enucfmo,popmul,popmat,needmd,nmdfrg,nmtfrg
     *                  ,ndtfrg,prtdst,ifgbuf,nfgbuf,nscf,nemc,forbconv,
     *                   conv2mc,l1fmoc,IDAcFMO,iodcfmo,ibfconv,
     *                   mapconv,orbconv,loadbf,loadgr,nstjob,semidyn,
     *                   broadden,vdwrad,exclmol,densgrid,nxyzg,dgrid,
     *                   ngm,nxyzgm,dgridm,grdpad,spargrid,noffg,indgrd,
     *                   nprfrg,ifgfmo0,isgddi0,m0fmo,doddcor,dolat,
     *                   nunptc,natfmob,untxyz,nsymeq,stonep,nfrgmul,
     *                   frgmul,iexcit)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      Parameter (MXATM=2000,MXAO=8192,MXRT=100)
      integer ddi_world,ddi_group,ddi_masters
      Parameter(ddi_world=0,ddi_group=1,ddi_masters=2)
      logical myjob,isgddi,parout,INITGDDI,GOPARR,DSKWRK,MASWRK,orbxch,
     *        enexch,atonce,odexch,docas,dosap,dospc,fmodscf,fmodtrf,
     *        inirev,correl,parhop,forbconv,conv2mc,ijmc,semidyn,
     *        semidyno,broadden,densgrid,spargrid,isgddi0,doddcor,
     *        dolat,exclmol,skipc
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,npglob,nnglob,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /GRDPAR/ ORIGIN(3),XVEC(3),YVEC(3),ZVEC(3),UX(3),UY(3),
     *                UZ(3),GRDSIZ,NGRID,IGUNIT,NXG,NYG,NZG,modgrid
      COMMON /GSSORD/ IORDER(MXAO),JORDER(MXAO),NORDER
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,npreo(4)
      COMMON /STNBUF/ STNPNT(4,2*MXATM),BIGEXP,NPTSTN,NBUFFM
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      common /fmodim/ maxbnd,maxknd,maxcbs,maxcao,maxvec,maxl1,
     *                maxnat,maxabd,maxbas
      Common /fmoinf/ nfg,nlayer,natfmo,nbdfg,naotyp,nbody
      common /fmoopt/ espsca(9),RESPAP(2),rESPPC(2),rESDIM,restri(4),
     *                rcorsd,respct,convfg,cnvdmp,coroff,IXESP,mxitfg,
     *                nguess,NBSSE,modorb,modpar,irststp,irstlay,nprfmo,
     *                nfmopal,modprp,maxl1c,ipieda,modgrd,modesp,ivmul
      common /fmorun/ espscf,e0scf(2),IDAFMO,icurlay,icurfg,jcurfg,
     *                kcurfg,ncursh,ngau,icurpop,ifmostp,moncor,nat1e,
     *                needr,modrst,norbproj,nunesp,iskipesp,icurunt
      dimension jobgrp(*),loadm(*),loadd(*),loadt(*),layfrg(*),indat(*),
     *          numfrg(*),natfrg(*),iaglob(*),fmozan(*),fmoc(3,*),
     *          izbas(*),iabdfg(*),jabdfg(*),iodfmo(*),maxl30(*),da(*),
     *          db(*),emon(nfg,2),glocon(*),locfmo(2,2,*),vec(*),
     *          molfrg(*),scffrg(*),mcnvfmo(*),mconfg(*),ijvec(2,*),
     *          mastid(*),rij(*),rwrk(*),iwrkd(*),popmul(maxl1,*),
     *          popmat(maxnat,*),nmdfrg(nfg,2),nmtfrg(nfg,2),
     *          ndtfrg(nfg2,2),ifgbuf(*),nfgbuf(*),iodcfmo(*),
     *          ibfconv(2,*),mapconv(*),orbconv(*),loadbf(*),loadgr(*),
     *          nstjob(*),vdwrad(*),dgrid(nxyzg,*),ngm(3),dgridm(*),
     *          noffg(*),indgrd(6,*),nprfrg(*),prtdst(3),ORIGM(3),
     *          UXM(3),UYM(3),UZM(3),untxyz(3,natfmob,*),nsymeq(*),
     *          stonep(*),frgmul(nfrgmul,*),iexcit(5)
      data RMC/8HMCSCF   /,RNONE/8HNONE    /,energy/8HENERGY  /
c
c     compute initial density for all monomers
c     parstat: GlobalFull
cnb   what to do with not recomputing the distances in layers?
c
      ifmostp=1
      call viclr(jobgrp,1,nfg)
c     call viclr(numfrg,1,nfg)
      if(nbdfg.ne.0) call viclr(locfmo,1,2*2*nbdfg)
c     if(dosap) call viclr(ialoc,1,natfmo+nbdfg)
      if(needmd.ne.0) call viclr(nmdfrg,1,nfg*2)
      if(needr0.ne.0) call vclr(rij,1,mfg2)
      inirev=iand(modpar,8).ne.0
      parhop=iand(modpar,16).eq.0.and.goparr
      if(densgrid.and.ifgfmo0.eq.0.or.spargrid) call vclr(dgrid,1,nxyzg)
      if((loadbf(1).ne.0.or.loadbf(2).ne.0).and.nlayer.gt.1) then
c       mainly, monomers have to be rebalanced for each layer.
c       Also, at present only layer one is set up in fillind.
        write(6,*) 'Semidynamic load balancing is not quite finished'
        call abrt
      endif
      m0fmo=0
c
      icurpop=1
c
      if(docas) then
        maxitsav=maxit
        call mcin
        maxit=maxitsav
      endif
      ncasfmo=0
      nactfmo=0
c     ncasfmo is the number of CAS active orbitals
c     nactfmo is the number of CAS core+active orbitals for the CAS monomer
c
      if(nbsse.eq.3.and.correl) then
c       run free monomers with correlation
        mplevl=mplevli
        cctyp=cctypi
        cityp=citypi
        tddftyp=tddfti
      endif
      nconv=-1
      nfge=nfg
      if(rcorsd.ne.0) nfge=nfg*2
c
c     Broadcast all densities for the broadden option. The global master will
c     do this.
c
      if(broadden) then
        if(maswrk) write(iw,*) 'Broadcasting the densities...'
c       dosap and dospc are set to .false. to prevent brodcasting Mulliken
c       charges+populations. Note that RAWRITE will allocate maxl30 space
c       on F40 so that it is fine to write only densities now.
c       It is faster to broadcast everything at once, but that would require
c       huge amounts of memory (because only the grandmaster has to send
c       everything at once), so turn it off.
c       For correlation the program assumes having both SCF and correlated
c       densities, so for a shortcut just broadcast both.
        nloop=0
        if(doddcor) nloop=1
c       To avoid using different densities on the grandmaster and slaves,
c       synchronise modrst.
        if(isgddi0) call gddi_scope(ddi_world)
        CALL DDI_BCAST(2421,'I',modrst,1,0)
        if(isgddi0) call gddi_scope(ddi_group)
        do iloop=0,nloop
         if(nloop.eq.0) then
           irec0=mod(modrst-1,2)*2*nfg+1
         else
           irec0=iloop*2*nfg+1
c          If both records are needed, one will be for modrst.
         endif
         call dmexch(ilay,nfge,jobgrp,layfrg,numfrg,natfrg,scffrg,idafmo
     *              ,iodfmo,maxl30,emon,glocon,nconv,irec0,.false.,
     *               .false.,orbxch,enexch,.false.,mastid,popmul,popmat,
     *               ifgbuf,nfgbuf)
        enddo
      else
        irec0=1
      endif
      if(irststp.gt.ifmostp) then
c       modrst points to the next iteration density. Shift more for MP2.
c       Shift is mean here only in the sense between 0 and 1, so that
c       modrst-2 is the same as modrst. 
        modrst0=modrst-1
c       if(doddcor) modrst0=modrst-2
        if(doddcor) modrst0=modrst
        if(maswrk) write(iw,*) 'Monomer restart dens record is',modrst0
      endif
c
c     by setting icurfg and jcurfg to zero we avoid computing 2e ESP
c     when forming Huckel guess.
c
      jcurfg=0
      kcurfg=0
c     point to the Huckel guess HMO (hybrid MO).
c     icurlay=nlayer+1
      icurlay=ilay
      net=0
      netc=0
      if(isgddi0) call GDDICOUNT(-1,lgroup,myjob)
c     natcur=1
      do 100 iifg=1,nfg
        ifg=iifg
        if(loadhf.eq.1) ifg=loadm(iifg)
        if(inirev) ifg=nfg-iifg+1
c       if(ifg.gt.1) natcur=natcur+natfrg(ifg-1)
        if(layfrg(ifg).lt.ilay) then
c         To avoid double counting, zero out numfrg for previous layers
c         except one group. For DDI no gsum is done so no zeroing out.
          if(isgddi0.and.mygroup.ne.0) numfrg(ifg)=0
          goto 100
        endif
        numfrg(ifg)=0
        icurfg=ifg
        if(isgddi0) then
          call GDDICOUNT(0,lgroup,myjob)
          if(.not.myjob) goto 100
        endif
        if(maswrk) write(6,9000) ifg
        jobgrp(ifg)=mygroup
        imxl30=maxl30(ifg)
c       SCFTYP=scffrg(ifg)
c       odexch=SCFTYP.eq.rmc
c       SCFTYP alters behaviour of HUCKEL in a way we are not ready for.
        odexch=scffrg(ifg).eq.rmc
c
c       destroy DA. Molecules have different size -> DA should be reopened.
c
c       if(maswrk) CLOSE(UNIT=IDAF,STATUS='DELETE')
        call CLOSDA('DELETE')
        CALL OPENDA(0)
        NEVALS=0
        call makemol(ifg,0,0,ilay,0,0,0,0,0,0,0,.true.)
        l1=num
        l2=(l1*l1+l1)/2
        l3=l1*l1
        if(layfrg(ifg).eq.ilay.and.maswrk) then
          if(nbody.le.1) then
            enucfmo=enucfmo+enucr
          else
            enucfmo=enucfmo-(nfg-2)*enucr
          endif
        endif
        if(maswrk.or..not.isgddi0) numfrg(ifg)=num+ishft(na,16)
cnb     for restart jobs save RIJ??
        if(needr0.ne.0.and.ifg.gt.1) call monor(.true.,ifg,indat,fmozan,
     *    fmoc,iabdfg,jabdfg,rij((ifg*ifg-3*ifg)/2+2),rwrk,vdwrad)
c       Fill in additional distances for lattice runs.
c       (between the central cell and the rest).
        if(dolat.and.needr0.ne.0) call latrij(ifg,indat,fmozan,natfmob,
     *              untxyz,iabdfg,jabdfg,rij,rwrk,vdwrad,nunptc,nsymeq)
c
        if(needmd.ne.0) then
c         nmdfrg(ifg)=nfg-2
          imdfrg=0
          ifglay=layfrg(ifg)
c         the reason why nmdfrg can be computed here and nmtfrg cannot is that
c         for dimers one only needs one row of rij (with fixed i) that is
c         guaranteed to have been computed on this very node, but for trimers
c         one needs not only rij (and rik) but also rjk that may not be there.
c         Funnily in the sequential case it is guaranteed that ifg>jfg>kfg
c         and thus one can fill trimer arrays here.
          do jfg=1,ifg-1
            jfglay=layfrg(jfg)
c           if doing ifg,jfg SCF dimer in the current layer ilay
            if((ifglay.eq.ilay.or.jfglay.eq.ilay).and.
     *         ifglay.ge.ilay.and.jfglay.ge.ilay) then
              if(resdim.eq.0) then
                imdfrg=imdfrg+1
                nmdfrg(jfg,1)=nmdfrg(jfg,1)+1
              else
                rrij=fmodist(ifg,0,0,jfg)
                if(rrij.le.resdim) then
                  imdfrg=imdfrg+1
                  nmdfrg(jfg,1)=nmdfrg(jfg,1)+1
                  if(rcorsd.ne.0) then
                    ires=molfrg(ifg)+molfrg(jfg)
                    if(exclmol) then
                      skipc=ires.ge.0.and.ires.ne.2
                    else
                      skipc=ires.eq.0.or.ires.eq.2
                    endif
                    if(rrij.le.rcorsd.and..not.skipc) then
                      nmdfrg(ifg,2)=nmdfrg(ifg,2)+1
                      nmdfrg(jfg,2)=nmdfrg(jfg,2)+1
c                     (*,1) keeps coefficients for no correlation
c                     (*,2) keeps coefficients for correlation
c                     A monomer contribution is assigned to either of the two
c                     nmdfrg(jfg,1)=nmdfrg(jfg,1)-1
c                     imdfrg=imdfrg-1
                    endif
                  endif
                endif
              endif
            endif
          enddo
          nmdfrg(ifg,1)=nmdfrg(ifg,1)+imdfrg
c         if(doddcor) nmdfrg(ifg,1)=nmdfrg(ifg,1)-nmdfrg(ifg,2)
c         get SCF factors by subtracting MP2 from total
        endif
c
c       Read in the orbitals, overwriting restart data.
c
c       l0=nqmt
        igot=0
        call fmorvec(ifg,0,ijvec,l1,l1,da(l2+1),igot)
c
c       restart: save numfrg and quit. If any broken bonds are there, one
c       has to fill locfmo which is done in ONEEI (FMOHOP).
c       change FMOHOP to save locfmo during monomer SCF?
c       For restart jobs with IJVEC set for the current monomer ifg process
c       ifg not as restart but as usual initial guess.
c
        if(irststp.gt.ifmostp.and.igot.eq.0) then
c
c         First do orbital conversion if needed.
c
          iirec=mod(modrst0,2)*2*nfg+1+ifg
          iirecc=1+ifg
          if(forbconv) then
            if(conv2mc) then
              nread=l3+l1
              ist=1
              if(odexch) ist=ist+l2
              CALL rareads(IDAFMO,iodfmo,da(ist),nread,iirec,0)
              nwrite=nread
              imxl30c=imxl30
              if(odexch) then
                nwrite=nwrite+l2
                imxl30c=nwrite
c               using nwrite instead of the proper value prohibits multilayers
c
c               possibly reorder the active orbitals for MCSCF
c               GUESS in $GUESS must be MODAF (or SKIP)!
                CALL GUESMO(GUESS)
                if(norder.eq.1) then
                  call REORDR(da(ist),IORDER,l1,l1)
                  if(maswrk) write(6,*) 'Reordered the orbitals'
                endif
                call DMTX2(da,da(l2+1),na,l1,l1)
c               call prsq(da(ist),l1,l1,l1)
                write(ip,*) 'Active orbitals for the MCSCF monomer'
                write(ip,*) '$VEC1'
                call PUSQL(da(ist),l1,l1,l1)
                write(ip,*) '$END'
              endif
              CALL rawrites(IDAcFMO,iodcfmo,da,imxl30c,nwrite,iirecc,0)
c             write(6,*) 'conving',ifg,nread,nwrite,l1,iirecc
              l1fmoc=l1fmoc+l1
            else
              call readmond(da,orbxch.and..not.odexch,.false.,na,l1,
     *                      iodfmo,iirec)
              call convorb(ifg,l1,orbxch,da,l1c,orbconv,ibfconv,mapconv,
     *                     iaglob,izbas)
              l1fmoc=l1fmoc+l1c
              l2c=(l1c*l1c+l1c)/2
              l3c=l1c*l1c
              m2c=l2c
              if(orbxch) m2c=l3c
              imxl30c=m2c
c               Such imxl30c assumes one layer!
             CALL rawrites(IDAcFMO,iodcfmo,orbconv,imxl30c,m2c,iirecc,0)
            endif
          else
c
c           if skipping altogether monomer runs one must fill locfmo now.
c           it is possible not to call filloc if irststp eq 2 but then
c           parallel summing of locfmo should be done after monoscf
c           also read in $MCSCF and active space groups
c           write(6,*) 'wwwreading',iirec
            if(dosap.or.dospc) then
              call oneei
             call readmond(da,orbxch.and..not.odexch,.false.,na,l1,
     *                     iodfmo,iirec)
              CALL daread(IDAF,IODA,db,l2,12,0)
              call mulpop(num,da,db,popmul(1,ifg))
              if(dospc) then
                if(NPTSTN.ne.0) then
c                 Stone for the restart density (save it first).
                  CALL dawrit(IDAF,IODA,da,l2,16,0)
                  call stone(ip,rnone)
                  call dcopy(nat,stonep,1,popmat(1,ifg),1)
                  if(nfrgmul.gt.0.and.maswrk) call storemul(1,ifg,nat,
     *                     nfrgmul,untxyz,frgmul,natfrg,c,stonep(1+nat))
                else
                  call mulpopa(popmul(1,ifg),popmat(1,ifg))
                endif
              endif
              if(odexch) call readcas(nactfmo,ncasfmo)
            else
c             if(nbdfg.ne.0.and.irststp.ge.2) call filloc(odexch,nactfmo)
              if(irststp.ge.2) then
                if(nbdfg.ne.0) call filloc
                if(odexch) call readcas(nactfmo,ncasfmo)
              endif
            endif
          endif
          m0fmo=m0fmo+(num-nqmt)
          goto 100
        endif
        if(odexch) call readcas(nactfmo,ncasfmo)
c
c       mod(nguess,2).eq.1 is a semi-abandoned option. LABSIZ and DIRSCF
c       are not adjusted here.
c
        if(mod(nguess,2).eq.1.or.nbsse.eq.3) then
          if(maswrk) write(6,9010) ifg
          call fmoconv(mcnvfmo(ifmostp),mconfg(ifg),l1,vec,enexch,orbxch
     *                ,.true.,.false.,.false.)
          call fmosdir(0,fmodscf,fmodtrf)
          CALL BRNCHX(energy)
          call fmosdir(1,fmodscf,fmodtrf)
c         save the vaccuum energies for BSSE
c         nbdfg=nbdfgs
          if(nbsse.eq.3) then
             emon(ifg,1)=etot
             if(rcorsd.ne.0) emon(ifg,2)=escf
c            MP2; note that other correlation methods should be added
          endif
c         Density is overread in this subroutine. Perhaps it could be read
c         more sparingly.
          CALL daread(IDAF,IODA,da,l2,16,0)
c         Compute the monomer density on a grid
          if(nxyzgm.ne.0.and.iand(nprfrg(ifg),4).ne.0) then
            call mongrid(NGm,ORIGM,UXM,UYM,UZM,vdwrad,grdpad)
            call vclr(dgridm,1,nxyzgm)
            call fmoprc(1,1,l2,da,dgridm,1,NGm(1),1,NGm(2),1,NGm(3),
     *                  1,NGm(1),1,NGm(2),1,NGm(3), 0,0,0,0,0,0,
     *                  ORIGM,UXM,UYM,UZM)
            call ddi_gsumf(2416,dgridm,nxyzgm)
            call makecube(ifg,0,nat,zan,c,dgridm,NGm(1),NGm(2),NGm(3),
     *                    ORIGM,UXM,UYM,UZM)
          endif
          if(densgrid) then
c           Compute the total density on a grid
            call grdbox(ixmin,ixmax,iymin,iymax,izmin,izmax,vdwrad,
     *                  grdpad)
            call fmoprc(1,1,l2,da,dgrid,1,NXG,1,NYG,1,NZG,ixmin,ixmax,
     *                  iymin,iymax,izmin,izmax, 0,0,0,0,0,0,
     *                  ORIGIN,UX,UY,UZ)
          endif
          if(spargrid) then
c           Compute the total density on a sparse grid
            ioff=noffg(ifg)
            call fmoprc(1,1,l2,da,dgrid(ioff,1),indgrd(1,ifg),
     *                  indgrd(2,ifg),indgrd(3,ifg),indgrd(4,ifg),
     *                  indgrd(5,ifg),indgrd(6,ifg),indgrd(1,ifg),
     *                  indgrd(2,ifg),indgrd(3,ifg),indgrd(4,ifg),
     *                  indgrd(5,ifg),indgrd(6,ifg), 0,0,0,0,0,0,
     *                  ORIGIN,UX,UY,UZ)
          endif
        else if(igot.eq.0) then
          CALL ONEEI
c         possibly reorder the active orbitals for MCSCF
c         GUESS in $GUESS must be MODAF (or SKIP)!
          if(scftypi.eq.rmc.and.odexch.and.iand(nguess,512).ne.0) then
            if(maswrk) write(6,*) 'Looking for reordering'
c           write fake density to satisfy GUESS
            call vclr(da,1,l2)
            CALL dawrit(IDAF,IODA,da,l2,16,0)
            CALL GUESMO(GUESS)
            if(norder.eq.1) then
c             Assuming modorb=3
              lrecsiz=l2+l3+l1
              iirec=1+ifg
c             iirec is hardwired to the first set.
              CALL rareads(IDAFMO,iodfmo,da,lrecsiz,iirec,0)
              call icopy(l1,IORDER,1,db,1)
              call REORDR(da(l2+1),db,l1,l1)
              call REORDR(da(l2+l3+1),IORDER,l1,1)
c             CALL rawrites(IDAFMO,iodfmo,da,imxl30,lrecsiz,iirec,0)
              CALL dawrit(IDAF,IODA,da(1),l2,16,0)
              CALL dawrit(IDAF,IODA,da(l2+1),l3,15,0)
              CALL dawrit(IDAF,IODA,da(l2+l3+1),l1,17,0)
              if(maswrk) write(6,*) 'Reordered the orbitals+energies'
            endif
          else
            CALL GUESMO(GUESS)
          endif
c       else if(orbxch) then
        else
          call DMTX2(da,da(l2+1),na,l1,l1)
          CALL dawrit(IDAF,IODA,da,l2,16,0)
          if(enexch) then
c           this is probably not a good idea. What can be done instead?
c           The user only provided the orbitals, no energies.
            call vclr(da(l2+l3+1),1,l1)
            CALL dawrit(IDAF,IODA,da(l2+l3+1),l1,17,0)
          endif
          if(dosap.or.dospc) call oneei
        endif
        if(dosap.or.dospc) then
          CALL daread(IDAF,IODA,da,l2,16,0)
          CALL daread(IDAF,IODA,db,l2,12,0)
          call mulpop(l1,da,db,popmul(1,ifg))
          if(NPTSTN.ne.0) then
c           Stone for the guess (e.g., Huckel(!!)) density.
            call stone(ip,rnone)
            call dcopy(nat,stonep,1,popmat(1,ifg),1)
            if(nfrgmul.gt.0.and.maswrk) call storemul(1,ifg,nat,nfrgmul,
     *                             untxyz,frgmul,natfrg,c,stonep(1+nat))
          else
            call mulpopa(popmul(1,ifg),popmat(1,ifg))
          endif
        endif
        lenrec=0
        if(.not.orbxch.or.odexch) then
          CALL daread(IDAF,IODA,da,l2,16,0)
          lenrec=lenrec+l2
        endif
        if(orbxch.or.odexch) then
          CALL daread(IDAF,IODA,da(lenrec+1),l3,15,0)
          lenrec=lenrec+l3
        endif
        if(enexch) then
          CALL daread(IDAF,IODA,da(lenrec+1),l1,17,0)
          lenrec=lenrec+l1
        endif
c       if(odexch) call prsq(da,1,lenrec,lenrec)
        CALL rawrites(IDAFMO,iodfmo,da,imxl30,lenrec,ifg+1,0)
        m0fmo=m0fmo+(num-nqmt)
  100 continue
      if(isgddi0) call GDDICOUNT( 1,lgroup,myjob)
c
c     exchange the basis set size for all fragments. Since it is stored
c     as an array for each fragment, the order is independent of how
c     parallel work was distributed and we can fill it once for all.
c     dmexch uses it so the array must be ready before calling dmexch.
c     Only masters sum the array to avoid double counting.
c     One can do the operation two ways: eith global sum over ALL nodes
c     or first global sum by masters and the broadcast within a group
c     the cost is M*logM +M*N*logN and M*N*log(MN). The first way usually wins
c     mathematically but practically latency can make the second way
c     faster if M*N is small. M - number of DDI groups, N - group size.
c
c     CALL gddi_gsum(2,'I',numfrg,nfg)
c     since FMOHOP is now divided into nodes locfmo must be summed within
c     the group.
c     write(6,*) 'locfmo:',(((locfmo(i,j,k),i=1,2),j=1,2),k=1,nbdfg)
      if(nbdfg.ne.0.and.parhop) call ddi_gsumi(2417,locfmo,2*2*nbdfg)
      if(isgddi0) then
        call gddi_scope(ddi_masters)
        numfrg(nfg+1)=nactfmo+ishft(ncasfmo,16)
        if(maswrk) then
          call ddi_gsumi(2417,m0fmo,1)
c         l0fmo is not broadcast to slaves because it is used for print-out only
c         no need to sum numfrg?
          call ddi_gsumi(2417,numfrg,nfg+1)
          if(nbdfg.ne.0) call ddi_gsumi(2418,locfmo,2*2*nbdfg)
          if(needr0.ne.0) call ddi_gsumf(2419,rij,mfg2)
          if(needmd.ne.0) then
            call ddi_gsumi(2420,nmdfrg,nfg*2)
            if(nfg3.ne.0) then
              call proindt(nfg2,nfg3,ilay,loadhf,layfrg,numfrg,molfrg,
     *                     nmtfrg,ndtfrg,iwrkd,loadt,net,netc)
              call ddi_gsumi(2421,nmtfrg,nfg*2)
              call ddi_gsumi(2422,ndtfrg,nfg2*2)
              idum=0
              call DDI_nsumi(2423,net,netc,idum,idum,2)
            endif
          endif
c         if(dospc) call ddi_gsumi(2420,ialoc,natfmo+nbdfg)
          if(nfrgmul.gt.0) then
            call ddi_gsumf(2419,untxyz,natfmob*3)
            call ddi_gsumf(2419,frgmul,natfmob*nfrgmul)
          endif
        endif
        call gddi_scope(ddi_group)
c       now masters broadcast the array within each group. It
c       is needed even on slave nodes for reading (pretending;
c       actually, accepting a broadcast) density etc.
        if(goparr) then
          CALL DDI_BCAST(2421,'I',numfrg,nfg+1,master)
         if(nbdfg.ne.0) CALL DDI_BCAST(2422,'I',locfmo,2*2*nbdfg,master)
          if(needr0.ne.0) call DDI_BCAST(2423,'F',rij,mfg2,master)
c         if(dospc) CALL DDI_BCAST(2424,'I',ialoc,natfmo+nbdfg,master)
          if(needmd.ne.0) then
            call DDI_BCAST(2425,'I',nmdfrg,nfg*2,master)
            if(nbody.gt.2) then
              call DDI_BCAST(2426,'I',nmtfrg,nfg*2,master)
              call DDI_BCAST(2427,'I',ndtfrg,nfg2*2,master)
              if(loadhf.ne.0.and.nfg3.ne.0)
     *          call DDI_BCAST(2428,'I',loadt,nfg3,master)
            endif
          endif
c         nmdfrg is used for deciding properties etc so slaves must have it.
          if(nfrgmul.gt.0) then
            call DDI_BCAST(2419,'F',untxyz,natfmob*3,master)
            call DDI_BCAST(2419,'F',frgmul,natfmob*nfrgmul,master)
          endif
        endif
        nactfmo=iand(numfrg(nfg+1),65535)
        ncasfmo=ishft(numfrg(nfg+1),-16)
c       write(6,*) 'wwwCAStest',nactfmo,ncasfmo
      else
        if(maswrk.and.nfg3.ne.0.and.needmd.ne.0)
     *    call proindt(nfg2,nfg3,ilay,loadhf,layfrg,numfrg,molfrg,nmtfrg
     *                ,ndtfrg,iwrkd,loadt,net,netc)
      endif
c
c     redo the load balancing, shifting all separated dimers toward the end.
c     if rcorsd is active put all correlated dimers to the front.
c     scale the load by some distance factor?
c     add correlation as given by rcorsd/selected dimers?
c
      nes=0
      nemc=0
      nemc0=0
      if(needr0.ne.0.and.loadhf.ne.0.and.nbody.gt.1) then
        ishift=maxl1*2
        ij=0
c       write(6,*) 'oloadd',(loadd(i),i=1,nfg2)
        nec=0
        nstjob(2)=0
        do ifg=1,nfg
          do jfg=1,ifg-1
            ij=ij+1
            l1ij=iand(numfrg(ifg),65535)+iand(numfrg(jfg),65535)
            loo=l1ij
            rrij=rij(ij)
            ijmc=scffrg(ifg).eq.rmc.or.scffrg(jfg).eq.rmc
            if(ijmc) nemc0=nemc0+1
            semidyno=semidyn.and.loadbf(2).ne.0.and.loadgr(2).ne.0.and.
     *               l1ij.ge.loadbf(2)
            ires=molfrg(ifg)+molfrg(jfg)
            if(exclmol) then
              skipc=ires.ge.0.and.ires.ne.2
            else
              skipc=ires.eq.0.or.ires.eq.2
            endif
            if(tddfti.ne.rnone) then
             if(iexcit(1).ne.ifg.and.iexcit(1).ne.jfg.or.
     *          iexcit(2).lt.2) skipc=.true.
            endif
            if(rrij.le.resdim.and.resdim.ne.0) then
              loo=loo+ishift
              if((rrij.le.rcorsd.or.rcorsd.eq.0).and..not.skipc) then
                loo=loo+ishift
                nec=nec+1
              endif
c             SCF and MP2 semidynamic jobs are given hiher priority.
c             ES jobs are unchanged. 4 comes from 1(RHF)+1(MP2)+1(MCSCF),
c             raised by 1 (at present MRMP2 is not yet supported).
              if(semidyno) then
                loo=loo+ishift*4
                nstjob(2)=nstjob(2)+1
              endif
            else
              nes=nes+1
              if(resdim.ne.0) ijmc=.false.
              if(resdim.eq.0.and.semidyno) nstjob(2)=nstjob(2)+1
            endif
            if(ijmc) then
              loo=loo+ishift
              nemc=nemc+1
            endif
            iwrkd(ij)=loo
          enddo
        enddo
        if(resdim.eq.0) nes=0
        if(.not.correl) then
          nec=0
          netc=0
        endif
        call indsort(nfg2,iwrkd,loadd)
c       write(6,*) 'nloadd',(loadd(i),i=1,nfg2)
        if(maswrk) then
          if(nemc0.ne.0) then
            write(iw,9100) nes,nfg2-nes,nemc
          else
            write(iw,9110) nes,nfg2-nes,nec
          endif
          if(nbody.gt.2) write(iw,9120) net,netc
        endif
      endif
      nscf=nfg2-nes
      if(nstjob(2).ne.0.and.maswrk)
     *  write(iw,9140) ilay,nstjob(2),'   dimer',loadbf(2),loadgr(2)
c
      if(maswrk.and.iand(nprfmo,3).eq.0) then
        write(iw,*) 'nums:',(iand(numfrg(i),65535),i=1,nfg)
        write(iw,*) 'nas:',(ishft(numfrg(i),-16),i=1,nfg)
        write(iw,*) 'locfmo:',(((locfmo(i,j,k),i=1,2),j=1,2),k=1,nbdfg)
        write(iw,*) 'nactfmo:',nactfmo
c       write(iw,9020)
c    *    (i,ishft(ialoc(i),-16),iand(ialoc(i),65535),i=1,natfmo+nbdfg)
c9020 format(1x,'iatg=',I5,' ifg=',I5,' iatl=',I5)
        if(nbody.gt.1) then
          write(6,*) 'nmdfrg1:',(nmdfrg(i,1),i=1,nfg)
          write(6,*) 'nmdfrg2:',(nmdfrg(i,2),i=1,nfg)
        endif
        if(nbody.gt.2) then
          write(6,*) 'nmtfrg1:',(nmtfrg(i,1),i=1,nfg)
          write(6,*) 'nmtfrg2:',(nmtfrg(i,2),i=1,nfg)
          write(6,*) 'ndtfrg1:',(ndtfrg(i,1),i=1,nfg2)
          write(6,*) 'ndtfrg2:',(ndtfrg(i,2),i=1,nfg2)
        endif
      endif
      nerr=0
      if(maswrk.and.needr0.ne.0.and.(iand(nprfmo,4).ne.0.or.
     *   prtdst(1).ne.0.or.prtdst(2).ne.0.or.prtdst(3).ge.0))
     *  call fmoprr(indat,iabdfg,jabdfg,fmozan,fmoc,vdwrad,rij,
     *              iand(nprfmo,4).ne.0,prtdst,nerr)
      if(goparr) call DDI_BCAST(2428,'I',nerr,1,master)
      if(nerr.ne.0) call abrt
c
c     exchange density matrices
c
c     for restarts with approximations we need to exchange the recomputed
c     charges/populations. Density is also exchanged (waste). Perhaps one
c     should dump charges/populations/distances and just read them.
c
      if(isgddi0.and.(irststp.le.ifmostp.or.dosap.or.dospc))
     *  call dmexch(ilay,nfge,jobgrp,layfrg,numfrg,natfrg,scffrg,idafmo,
     *              iodfmo,maxl30,emon,glocon,nconv,irec0,dosap,dospc,
     *              orbxch,enexch,atonce,mastid,popmul,popmat,ifgbuf,
     *              nfgbuf)
c     1 indicates one reserved record (the first one) for the record indexing
      icurlay=ilay
      if(nbsse.eq.3.and.correl) then
c       run free monomers with correlation
        mplevl=0
        cctyp=rnone
        cityp=rnone
        tddftyp=rnone
      endif
      return
 9000 format(/1x,'Running initial guess for monomer ',I4,/)
 9010 format(/1x,'Running free monomer SCF for monomer',I5,/)
 9100 format(/1x,'There are',I8,' separated and',I7,' SCF (',I6,
     *           ' of them MCSCF) dimers.')
 9110 format(/1x,'There are',I8,' separated and',I7,' SCF (',I6,
     *           ' of them correlated) dimers.')
 9120 format(/1x,'There are',I7,' SCF (',I6,
     *           ' of them correlated) trimers.')
 9140 format(/1x,'Layer',I2,' static LB for',I6,A8,'(s) larger than ',
     *           I5,' on',I5,' group(s).',/)
      end
C*MODULE fmo     *DECK monoscf
      subroutine monoscf(ilay,nder,runtyp,loadhf,ndar30,ndar30i,jobgrp,
     *                   loadm,layfrg,numfrg,natfrg,iaglob,ichfmo,nefmo,
     *                   iodfmo,maxl30,idmrec0,da,db,fmoespa,vec,wrk1,
     *                   wrk2,emon,glocon,fmode,fmopg,atmulq,atmulqi,
     *                  mbody,nfmoelm,fmoelm,needmd,nmmfrg,nmdfrg,nmtfrg
     *                  ,molfrg,scffrg,correl,scftypi,mplevli,CITYPi,
     *                   CCTYPi,tddfti,mcnvfmo,ncvscf,mconfg,dosap,dospc
     *                  ,docas,primul,orbxch,enexch,atonce,liter,nfglay,
     *                  popmul,popmat,ifgbuf,nfgbuf,ngrfmo,mannod,mastid
     *                  ,nprfrg,totdens,l2fmo,totd,iaoglob,exclmol,
     *                   densgrid,nxyzg,dgrid,ntimout,loadgr,nstjob,
     *                   l1dir,ngm,nxyzgm,dgridm,grdpad,vdwrad,spargrid,
     *                   noffg,indgrd,ifgfmo0,isgddi0,grandmas,densfmo0,
     *                   IDAcFMO,iodcfmo,extracc,nextracc,lfmasc,needasc
     *                  ,esolv,nesolv,iterpcm,NTSPAR,dovpcm,pcmoff,
     *                   etotdft,nedft,XYZCTS,PEL,VNUC,dopleda,epl0ds,
     *                   efmo0,doscfprp,ext2lay,dolat,n2fmo,klms,untrot,
     *                   esplat,addesp,diffesp,stonep,natfmob,nfrgmul,
     *                   frgmul,iexcit,eexcit,texcit,idxyz,monoc,monvr,
     *                   nstmono,nocctdm,nvirtdm,ctdm)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      integer ddi_world,ddi_group
      Parameter(ddi_world=0,ddi_group=1)
      parameter(MXATM=2000,MXRT=100,MXGRID=10)
      parameter (maxpst=10,zero=0.0D+00,one=1.0D+00,half=0.5D+00)
      logical myjob,isgddi,parout,INITGDDI,GOPARR,DSKWRK,MASWRK,conv,
     *        dosap,dospc,docas,primul,orbxch,enexch,atonce,odexch,
     *        correl,fmodscf,fmodtrf,doprop,skipc,skipci,fmajor,
     *        desperate,despread,doddcor,lbmcscf,AIMPAC,RPAC,PLTORB,
     *        MOLPLT,totdens,clrden,densgrid,clrcow,forcedir,fordir,
     *        spargrid,isgddi0,grandmas,donor,acceptor,tightint,DIRSCF,
     *        FDIFF,densfmo0,exclmol,updpcm,dovpcm,dopleda,doscfprp,
     *        ext2lay,dolat,addesp,diffesp,lcflag,lrint,lcsav,corsav,
     *        TRIPLET,SG1,SG1T,gopsav
      dimension jobgrp(*),layfrg(*),numfrg(*),natfrg(*),iaglob(*),
     *          iodfmo(*),maxl30(*),idmrec0(*),da(*),db(*),fmoespa(*),
     *         vec(*),wrk1(*),wrk2(*),emon(nfg,*),glocon(0:*),mcnvfmo(*)
     *         ,ncvscf(2),mconfg(*),fmode(3,natfmo,*),fmopg(3,*),
     *         loadm(*),liter(*),molfrg(*),scffrg(*),popmul(maxl1,nfg,2)
     *         ,popmat(maxnat,nfg,2),ifgbuf(*),nfgbuf(*),atmulq(*),
     *          atmulqi(*),fmoelm(nfmoelm,*),nmmfrg(*),nmdfrg(nfg,2),
     *          nmtfrg(nfg,2),ngrfmo(maxpst,*),mannod(*),mastid(*),
     *          nprfrg(*),totd(*),iaoglob(*),dgrid(nxyzg,*),ngm(3),
     *          dgridm(*),vdwrad(*),noffg(*),indgrd(6,*),iodcfmo(*),
     *          ORIGM(3),UXM(3),UYM(3),UZM(3),extracc(nextracc,*),
     *          esolv(*),etotdft(nedft),XYZCTS(mxts,3),PEL(*),VNUC(*),
     *          epl0ds(nfg,*),efmo0(nfg,2),klms(4,*),untrot(3,3,*),
     *          esplat(n2fmo,*),stonep(*),frgmul(nfrgmul,natfmob,2),
     *          iexcit(5),eexcit(mxrt,2),texcit(3,mxrt,2),idxyz(mxrt)
     *         ,monoc(mxrt),monvr(mxrt),ctdm(*)
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,BSLRD(137),NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0,
     *                NANGPT(MXGRID),NANGPT0(MXGRID),SG1
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
      COMMON /DMPING/ SHIFTO,SHIFTV,DMPCUT,SWDIIS,DIRTHR
      COMMON /EFPFMO/ IEFPFMO,ISWENUC,REPNUCEFP,EFPEFP,RUNEFP
      COMMON /ELPROP/ ELDLOC,ELMLOC,ELPLOC,ELFLOC,
     *                IEDEN,IEMOM,IEPOT,IEFLD,MODENS,
     *                IEDOUT,IEMOUT,IEPOUT,IEFOUT,
     *                IEDINT,IEMINT,IEPINT,IEFINT
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,npglob,nnglob,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /GRDPAR/ ORIGIN(3),XVEC(3),YVEC(3),ZVEC(3),UX(3),UY(3),
     *                UZ(3),GRDSIZ,NGRID,IGUNIT,NXG,NYG,NZG,modgrid
      COMMON /INTRFC/ FRIEND,AIMPAC,RPAC,PLTORB,MOLPLT
      common /INT2IC/ NINTIC,iNINTIC,nxxic,lbufpic,lixic,labsix,nintix
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /INFOTD/ TDM(3,mxrt),CNVTOL,TRIPLET,MOCC(mxrt),MVIR(mxrt),
     *                NRADT,NTHET,NPHIT,NSTAT,NTRIAL,MAXVEK,NTHST,
     *                IRECTD,NLEBT,SG1T
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /PCMCHG/ PB,PX,PC,UNZ,QNUC,FN,FE,UNZOR,PORT
      COMMON /PCMDIM/ mxsp,mxts,mempcm1,mempcm2,NTS
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEFPCM,IP_F,nfmopcm
      COMMON /PSILVL/ IPSI,ISKPRP
      COMMON /RAIOLN/ JRECLN(10),JRECST(10)
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ pUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,npreo(4)
      COMMON /SCFWFN/ AROHF(3),BROHF(3),PACAVO(6),IACAVO,IUHFNO,MVOQ
      COMMON /STNBUF/ STNPNT(4,2*MXATM),BIGEXP,NPTSTN,NBUFFM
      COMMON /TIMING/ CPU,WALL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      common /fmodim/ maxbnd,maxknd,maxcbs,maxcao,maxvec,maxl1,
     *                maxnat,maxabd,maxbas
      common /fmoinf/ nfg,nlayer,natfmo,nbdfg,naotyp,nbody
      common /fmolat/ untang(3),untorg(3),respbc(4),abclat(3),anglat(3),
     *                symtra(3,24),symope(3,3,24),iatorg,nsymop,maxklms,
     *                ioporg(3),iopdir(3),iopabc(3),iopang(3)
      common /fmoopt/ espsca(9),RESPAP(2),rESPPC(2),rESDIM,restri(4),
     *                rcorsd,respct,convfg,cnvdmp,coroff,IXESP,mxitfg,
     *                nguess,NBSSE,modorb,modpar,irststp,irstlay,nprfmo,
     *                nfmopal,modprp,maxl1c,ipieda,modgrd,modesp,ivmul
      common /fmorun/ espscf,e0scf(2),IDAFMO,icurlay,icurfg,jcurfg,
     *                kcurfg,ncursh,ngau,icurpop,ifmostp,moncor,nat1e,
     *                needr,modrst,norbproj,nunesp,iskipesp,icurunt
      data energy/8HENERGY  /,rnone/8HNONE    /,RMC/8HMCSCF   /
c
c     Self consistent field iterations for monomer fragments in the field
c     of other monomers.
c     parstat: GlobalFull
      ifmostp=2
      ntimout=0
c
c     point densities to the last converged SCF
c     DGF is not sure if TDDFT gradient replaces the ground state density.
c     If it does not, the tddft clause should be removed from all similar
c     statements with tddfti.ne.rnone.and.nder.gt.0.
      if(MPLEVLi.gt.0.and.(MPPROP.ne.0.or.nder.gt.0).or.
     *   citypi.ne.rnone.or.(tddfti.ne.rnone.and.nder.gt.0)) then
        if(irststp.ge.ifmostp) modrst=modrst-1
c       if(irststp.gt.ifmostp) modrst=modrst-1
      else
        if(irststp.gt.ifmostp) modrst=modrst-1
      endif
      if(irststp.gt.ifmostp) then
        if(maswrk) write(iw,*) 'Dimer restart density record is',modrst
        idmrec0(ilay)=mod(modrst,2)*2*nfg+1
        nfglay=-1
        return
      endif
c
c     Turn off grid switching altogether
c
      NRADs=NRAD0
      NPHIs=NPHI0
      NTHEs=NTHE0
      swoffs=swoff
      swdiisv=swdiis
      npcmsav=nfmopcm
      nfglay=0
      do ifg=1,nfg
        if(layfrg(ifg).ge.ilay) nfglay=nfglay+1
      enddo
      if(coroff.ne.0) then
c       turn off grid switching for FMO monomers
        NRAD0=NRAD
        NPHI0=NPHI
        NTHE0=NTHE
        swoff=0
        if(coroff.ge.1.0D+00) coroff=0
c       the real usage of this is for restart jobs so that DFT is done
c       right away, but swoff is turned off.
      endif
c     Do not do switching DIIS->SOSCF during monomer SCF.
      if(nbody.gt.1) swdiis=0
c
c     If doing any correlation beyond SCF do it only after SCF converges.
c
      RUNFMO=energy
c
      if(dopleda) then
        mplevl=mplevli
        cctyp=cctypi
        cityp=citypi
        tddftyp=tddfti
      else
        mplevl=0
        cctyp=rnone
        cityp=rnone
        tddftyp=rnone
      endif
      corsav=correl
c     MCONV=mcnvfmo(ifmostp)
c
      idad=0
      idat=0
      idad2=0
      idat2=0
      nextra=0
      if(correl.or.runtyp.ne.energy.or.densgrid.or.spargrid.or.
     *   iterpcm.gt.0) nextra=1
c    *   ifgdon.ne.0.and.ifgacc.ne.0.or.iterpcm.gt.0) nextra=1
c     one can save on properties by doing them during the extra run
c
      if(dopleda) nextra=0
      nextra0=nextra
      iemoms=iemom
c     if(nextra.ne.0.and.) iemom=0
      skipc=rcorsd.ne.0.and.molfrg(1).ge.0.and.needmd.ne.0
      lbmcscf=docas.and.mod(modpar,2).ne.0.and.ngrfmo(6,ilay).ne.0.and.
     *        isgddi0
c
      mgroups=1
      if(isgddi0) mgroups=ngroups
      if(isgddi.and.tddfti.ne.rnone) nvirtdm=0
      desperate=mod(nguess/256,2).ne.0
      despread=desperate.and.iand(nguess,2048).eq.0
cnb   desperate will not work with Huckel dimers
      gdenmax=zero
      nconv=0
      conv=.false.
      fmajor=.false.
      icut0=icut
      itol0=itol
      icoroff=0
      ipcmoff=0
      gediff=zero
      CONVHF0=CONVHF
c     fmajor forces loosened convergence to become tight if otherwise converged.
      clrden=.true.
c     clear the total density only when needed.
      iter=1
      jter=1
      if(irststp.eq.ifmostp.and.modrst.ne.0) iter=modrst
      iter0=iter
  200   continue
        ndesper=0
        nodesper=0
        call viclr(jobgrp,1,nfg)
c
c       At each iteration both new and old (from the previous iteration)
c       density matrices (DM) are handled. The new ones are saved after
c       each SCF iteration, the old ones are read in to obtain ESPs and
c       serve as initial guess.
c
c       The structure of file 30:
c       rec. # (N is equal to nfg)
c          1... N  alpha DM for each fragment, iteration I1
c        N+1...2N  beta  DM for each fragment, iteration I1
c       2N+1...3N  alpha DM for each fragment, iteration I2
c       3N+1...4N  beta  DM for each fragment, iteration I2
c          1... N  ESP for each fragment, iteration I1
c          1... N  ESP for each fragment, iteration I2
c
c       I1 and I2 are consequent iterations. They change like this:
c       (iteration zero denotes initial guess).
c
c       iter  0   1   2   3   4    etc
c       I1    0   0   2   2   4
c       I2        1   1   3   3
c
c       For RHF no beta matrices are stored. Alpha matrices hold the total
c       density.
c
        irec0new=mod(iter,2)*2*nfg+1
        irec0old=mod(iter-1,2)*2*nfg+1
c       the first 2 is because two iterations, the second because alpha & beta
        inxtpop=3-icurpop
c       3-x changes 1 into 2 and 2 into 1.
        if(dopleda) inxtpop=icurpop
        espscf=one
        if(jter.le.9) espscf=espsca(jter)
        if(fmajor) espscf=one
        if(maswrk.and.espscf.ne.one) write(6,9120) espscf
c       if(.not.dopleda) idmrec0(ilay)=irec0old
        idmrec0(ilay)=irec0old
        dftsav=DFTYPE
        lcsav=LCFLAG
        cisav=cityp
        tdsav=tddftyp
        mp2sav=mplevl
        ndftsav=NDFTFG
        hfssav=DFTTYP(3)
        if(coroff.ne.0) then
          if((gediff.gt.coroff.or.iter.eq.iter0).and.icoroff.eq.0) then
            if(maswrk.and.DFTYPE.ne.rnone)
     *        write(6,*) 'DFT is swithed off!'
            DFTYPE=rnone
            NDFTFG=0
            DFTTYP(3)=1.0D+00
            LCFLAG=.FALSE.
cnb         it is a good idea to reduce convergence.
          else
            icoroff=1
c           icoroff prevents frantic switching DFT on and off: switching on
c           is done only once, thereafter DFT is never switched off.
          endif
        endif
c       moditer=mod(iter-iter0,2)
        if(isgddi0) call GDDICOUNT(-1,lgroup,myjob)
        nconv=0
        if(cnvdmp.ne.0)
     *    call adjconv(iter,gdenmax,itol0,icut0,CONVHF0,fmajor)
        gdenmax=zero
        gediff=zero
        call vclr(glocon,1,mgroups)
c       Do not zero out SCF properties for the extra iteration with selected
c       monomers.
        if(nextra0.eq.nextra.or.molfrg(1).lt.0) then
          if(primul) call vclr(atmulqi,1,natfmo*mbody)
          if(nfmoelm.ne.0) call vclr(fmoelm(1,nfg+3),1,nfmoelm*2)
c         clear temporary storage for 2 and 3 body terms
        endif
c       only the first half need be cleared.
c       if(totdens) call viclr(indd,1,ndrec)
        if(totdens.and.clrden) call vclr(totd,1,l2fmo)
       if(densgrid.and.ifgfmo0.eq.0.and.clrden) call vclr(dgrid,1,nxyzg)
        if(spargrid.and.clrden) call vclr(dgrid,1,nxyzg*nbody)
        if(ndftfg.eq.1) call vclr(etotdft,1,nedft)
c
        nfmopcm=npcmsav
        if(nlayer.eq.1) then
          updpcm=nfmopcm.eq.1.or.nfmopcm.gt.1.and.dovpcm.and.
     *           (iterpcm.eq.1.or.nextra.ne.nextra0)
        else
          updpcm=nfmopcm.gt.0.and.dovpcm.and.
     *           (ilay.eq.1.and.iterpcm.eq.1.or.nextra.ne.nextra0)
        endif
c       if(pcmoff.ne.0.and.updpcm.and.nextra.eq.nextra0) then
        ipcmoff1=ipcmoff
        if(pcmoff.ne.0.and.updpcm) then
          if((gediff.gt.pcmoff.or.iter.eq.iter0).and.ipcmoff.eq.0) then
            nfmopcm=0
            updpcm=.false.
            if(maswrk) write(6,*) 'PCM is swithed off!'
          else
            ipcmoff=1
          endif
        endif
c
c       PCM potentials etc will be updated during unilayer FMO if:
c       1) doing PCM[1] or
c       2) doing the first PCM iteration of PCM[2]  or
c       3) computing properties in any other PCM iteration of PCM[2]
c
c       PCM potentials etc will be updated during multilayer FMO if:
c       1) doing the first PCM iteration for layer 1 or
c       2) computing properties (which means building many-body potentials)
c
        if(nfmopcm.ne.0.and.ilay.eq.1) call vclr(VNUC,1,NTS)
        if(updpcm) then
          if(ilay.eq.1) call vclr(PEL,1,NTS)
        endif
        if(nfmopcm.ne.0) then
          do ifg=1,nfg
            if(layfrg(ifg).ge.ilay) esolv(ifg)=zero
          enddo
        endif
       if(nfrgmul.gt.0) call vclr(frgmul(1,1,inxtpop),1,nfrgmul*natfmob)
        clrden=.false.
        jbsav=jbtyp
        ngrsav=ngroups
        clrcow=.false.
        do 230 iifg=1,nfg
          if(loadhf.eq.1) then
            ifg=loadm(iifg)
          else
            ifg=iifg
          endif
          if(layfrg(ifg).lt.ilay) goto 230
c         Odd iteration numbers run MCSCF for the chosen one,
c         even ones run RHF for the rest, if lbmcscf is active.
c         if(lbmcscf.and.(iifg.eq.1.and.moditer.ne.0.or.
c    *                    iifg.ne.1.and.moditer.eq.0)) goto 230
          if(lbmcscf.and.iifg.le.1+1) then
c           write(6,*) 'The 6th groupie'
            igrfmo=1
c           The first (MCSCF) fragment will be done with ngrfmo(6), which
c           really can only be meaningfully 1 (or 0).
c           The rest will be done with ngrfmo(1).
            if(iifg.eq.1) igrfmo=6
            call GDDICOUNT( 1,lgroup,myjob)
            call fmopre(ilay,igrfmo,ngrfmo,mannod,mastid)
            call GDDICOUNT(-1,lgroup,myjob)
          endif
          eprev=emon(ifg,1)
c         nfglay=nfglay+1
c         Check if selected correlation is active.
          skipci=skipc.and.nmdfrg(ifg,2).eq.0.or.
     *           tddfti.ne.rnone.and.iexcit(1).ne.ifg.and.iexcit(3).eq.0
c         Most likely, only energy will be correct if skipci is set below
c         (since for nbody=1 nmdfrg is not set and thus multiplicative
c         constants for properties are not adjusted for such skipci).
          if(nbody.eq.1.and.rcorsd.ne.0.and.exclmol)
     *      skipci=molfrg(ifg).eq.0
          if(nextra0.ne.nextra.and.skipci) then
            if(maswrk) write(iw,*)'Skipping correlation for monomer',ifg
c           avoid double counting by assigning those unneeded monomers
c           as converged on the grand master.
            if(grandmas) then
              nconv=nconv+1
            else
              emon(ifg,1)=zero
              emon(ifg,2)=zero
            endif
c           do the properties only
c           dc=-nmdfrg(ifg)
c           if(nbody.gt.1.and.nfmoelm.ne.0) then
c             call daxpy(nfmoelm,dc,fmoelm(1,ifg),1,fmoelm(1,nfg+2),1)
c           endif
            goto 230
          endif
          if(nfmoelm.ne.0) call vclr(fmoelm(1,ifg),1,nfmoelm)
          emon(ifg,1)=zero
          emon(ifg,2)=zero
c
c         If doing correlation now check if the correlated energy is needed:
c         it may not be if selected fragment option is used.
c         iifg is compared because it runs through reordered jobs (job index).
c
          if(nstjob.ne.0.and.iifg.le.nstjob) then
            if(mygroup.lt.loadgr) then
              jbtyp=0
              ngroups=loadgr
              clrcow=.true.
c             temporarily switch to static load balancing and use the reduced
c             number of groups in GDDICOUNT too.
            else
c             otherwise skip the static jobs
              goto 230
            endif
          endif
c
c         reset the inner counter before switching to dynamic load balancing.
c         do not reset the global counter itself.
          if(isgddi0.and.clrcow.and.jbtyp.gt.0) then
            call GDDICOUNT(-1,lgroup,myjob)
            clrcow=.false.
          endif
c
          if(isgddi0) then
            call GDDICOUNT(0,lgroup,myjob)
            ngroups=ngrsav
            jbtyp=jbsav
            if(.not.myjob) goto 230
          endif
          jobgrp(ifg)=mygroup
c
          SCFTYP=scffrg(ifg)
          odexch=scftyp.eq.rmc
          if(scftypi.ne.rmc.and.SCFTYP.eq.rmc) SCFTYP=scftypi
c         SCFTYP must be fixed with scftypi AFTER(!!) assigning odexch
c         so that saving orbitals as controlled by odexch is done to allow
c         for the following layer's MCSCF.
c
c         if(cityp.ne.rnone.and.tddftyp.ne.rnone
c         Special code mainly for TDDFT gradient (iexcit(3)>0).
          if(tddftyp.ne.rnone.and.iexcit(1).ne.ifg) then
            tddftyp=rnone
          endif
c         if(exclmol.and.molfrg(ifg).eq.0) then
c           This resetting correlation only works for nbody=1. Otherwise
c           only energy is correct(?)
c           DFTYPE=rnone
c           NDFTFG=0
c           DFTTYP(3)=1.0D+00
c           mplevl=0
c           cityp=rnone
c           if(nextra.ne.nextra0.and.maswrk)
c    *        write(iw,*) 'No electron correlation for IFG=',ifg
c         else
c           if(maswrk) write(iw,*) 'Using DFTTYP=',DFTYPE
c         endif
c
          if(maswrk) write(iw,9200) SCFTYP,ifg,iand(numfrg(ifg),65535)
c         if(maswrk) CLOSE(UNIT=IDAF,STATUS='DELETE')
          call CLOSDA('DELETE')
          CALL OPENDA(0)
          icurfg=0
          call makemol(ifg,0,0,ilay,0,0,0,0,0,0,0,.true.)
          l1=num
          l2=(l1*l1+l1)/2
          l3=l1*l1
          if(maswrk.and.labsiz.ne.labsix) write(iw,9205) labsiz,labsix
         if(maswrk.and.NINTIC.ne.0) write(iw,9207) LABSIZ,NINTIC,ININTIC
c         all CI runs generate CI density.
          doddcor=(MPLEVL.gt.0.and.(MPPROP.ne.0.or.nder.gt.0)).or.
     *            cityp.ne.rnone.or.(tddftyp.ne.rnone.and.nder.gt.0)
          icurfg=ifg
          iconfg=mconfg(ifg)
c         overwrite fragment specific converger with the step converger
          if(iter-iter0.ge.ncvscf(2)) iconfg=-1
          fordir=forcedir(nintic*nproc,l1dir,l1,maswrk)
          if(nintic.ne.0.and.scftyp.eq.rmc.and.goparr) fordir=.true.
          call fmoconv(mcnvfmo(ifmostp),iconfg,l1,vec,enexch,
     *                 orbxch,iter.eq.iter0,iter-iter0.ge.ncvscf(1),
     *                 fordir)
c
          tightint=iand(nprfrg(ifg),32).ne.0.and.DIRSCF.and.FDIFF
c
c         reset icut for "poorly" converging FDIFF fragments
c
          icutifg=icut
          if(tightint) then
            icut=icut+1
            if(maswrk) write(iw,9203) icut
          endif
c
c         provide initial density from previous run
c         will not work for ROHF/UHF!
c
          donor=.false.
          acceptor=.false.
c         donor=iand(nprfrg(ifg),8).ne.0
c         acceptor=iand(nprfrg(ifg),16).ne.0
          lrece=0
          if(enexch) lrece=l1
c         write(6,*) 'wwwreading2',ifg+irec0old
          if(orbxch) then
            if(odexch) then
             CALL rareads(IDAFMO,iodfmo,da,l2+l3+lrece,ifg+irec0old,0)
             lenrec=l2+l3+lrece
            else
            CALL rareads(IDAFMO,iodfmo,da(l2+1),l3+lrece,ifg+irec0old,0)
             call DMTX2(da,da(l2+1),na,l1,l1)
            endif
            CALL dawrit(IDAF,IODA,da(l2+1),L3,15,0)
            mrece=l3
          else
            CALL rareads(IDAFMO,iodfmo,da,l2+lrece,ifg+irec0old,0)
            mrece=0
            if(iand(nguess,4096).ne.0.and.iter.gt.1) then
              if(maswrk) write(6,*) 'Scaling densities'
              CALL rareads(IDAFMO,iodfmo,db,l2+lrece,ifg+irec0new,0)
              call daxpy(l2+lrece,one,db,1,da,1)
              call dscal(l2+lrece,half,da,1)
            endif
          endif
          CALL dawrit(IDAF,IODA,da,L2,16,0)
          if(enexch) call dawrit(IDAF,IODA,da(mrece+l2+1),L1,17,0)
c
c         save previous density for convergence test in a work area
          call dcopy(l2,da,1,wrk2,1)
c
c         write(6,*) 'wwwInitial density'
c         call prtril(wrk2,L1)
c
          icurfg=ifg
          jcurfg=0
          kcurfg=0
c
          nprsav=nprint
          npusav=npunch
          if(iand(nprfrg(ifg),1).ne.0) nprint=7
          if(iand(nprfrg(ifg),8).ne.0) npunch=2
c
c         Fix for ROHF, works only with CI or charge transfer (donor+acceptor).
c         Alpha orbitals and density are copied to beta (as initial guess)!
c         With this fix only energy will be computed correctly here.
c         Other properties are computed correctly in ROHF, but not here
c         (such as ES moments)?
c
          if(nextra.lt.nextra0.and.(donor.or.acceptor)) then
            if(orbxch) call dawrit(IDAF,IODA,da(l2+1),L3,19,0)
            CALL dawrit(IDAF,IODA,da,L2,20,0)
            if(enexch) call dawrit(IDAF,IODA,da(mrece+l2+1),L1,21,0)
            if(mul.ne.1) call abrt
            mul=2
            if(donor) then
              ne=ne-1
              nb=nb-1
            endif
            if(acceptor) then
              ne=ne+1
              na=na-1
            endif
          endif
c         if(updpcm) then
          if(nfmopcm.ne.0) then
            ida=1
c           if(nextra.ne.nextra0) then
c             if(nfmopcm.ge.2) ida=ida-nmdfrg(ifg,1)
c             if(nfmopcm.ge.3) ida=ida+nmtfrg(ifg,1)
c           endif
            if(ilay.ne.1) ida=0
c           Here we use the fact that for multilayer runs the first layer has
c           all fragments and the fact that nuclear potential has no many-body
c           corrections (so it is only computed in monoscf).
c           Note that PCMNUP must be called for all n-mers as it computes
c           the corresponding correction to the n-mer energy.
            call pcmnup(ida,vnuc)
          endif
c
c         Compute energy (SCF) of monomers
c
          delescf=0
          nloop=0
c         loop twice for MP2 grad/prop: RHF and then MP2.
c
          if(doddcor) nloop=1
          do iloop=nloop,0,-1
            if(iloop.gt.0) then
              mplevl=0
              cityp=rnone
              tddftyp=rnone
            endif
cnb         one can save time by resetting RUNTYP to ENERGY if idad is 0?
            NEVALS=iter
c           NEVALS=NEVALS+1
c           ENERGX increments NEVALS for each fragment. This is undesired
c           because it leads to e.g. SOSCF skipping DIIS for the first time
c           some fragments run.
            call fmosdir(0,fmodscf,fmodtrf)
            mvoqsav=MVOQ
            if(iand(nprfrg(ifg),2).ne.0) MVOQ=6
            if(cisav.ne.rnone) nprint=7
            CALL BRNCHX(RUNFMO)
c           Try converging once again with an alternative converger
            if(etot.eq.0.and.desperate) then
              if(maswrk) write(iw,9300)
c             Increase accuracy of DIRSCF/FDIFF.
              if(DIRSCF.and.FDIFF) icut=icut+1
c             to reuse integrals
              irest=2
              if(despread) then
c               do not use density from the previous run that failed, use the
c               pristine one (otherwise continue converging).
                CALL dawrit(IDAF,IODA,wrk2,L2,16,0)
                if(orbxch) then
                  write(iw,*) 'Not ready yet'
                  call abrt
                endif
              endif
              call fmoconv(mcnvfmo(ifmostp),iconfg,l1,vec,enexch,
     *                     orbxch,iter.eq.iter0,.true.,fordir)
              CALL BRNCHX(RUNFMO)
c             for desperate runs abort if not converged.
              if(etot.eq.0) then
                if(maswrk) write(iw,9310)
c               call abrt
                if(maswrk) nodesper=nodesper+1
              else
                if(maswrk) ndesper=ndesper+1
              endif
            endif
            MVOQ=mvoqsav
            call fmosdir(1,fmodscf,fmodtrf)
            if(RUNFMO.ne.energy.and.etot.eq.0) then
              if(maswrk) write(iw,9400)
              call abrt
            endif
            if(tddftyp.ne.rnone) then
              call tdmono(eexcit,texcit,IDXYZ,MONOC,MONVR,NSTMONO)
              if(iexcit(4).eq.2) then
                nvirtdm=nqmt-nocctdm
                nread=nocctdm*nvirtdm*NSTAT
c               The following DAREAD is "tricky", because the
c               record was saved only on the master in TDDFT. 
                gopsav=goparr
                goparr=.false.
                if(maswrk) CALL DAREAD(IDAF,IODA,CTDM,nread,471,0)
                goparr=gopsav
c               Fortunately, we do not need CTDM on slaves in GDDI.
c               However, we do need it for DDI.
                if(.not.isgddi.and.goparr) 
     *            CALL DDI_BCAST(2007,'F',CTDM,nread,MASTER) 
                if(isgddi.and..not.maswrk) then
c                 call vclr(CTDM,1,nread)
                  nvirtdm=0
                endif
              endif
            endif
c
c           Destroy the correlated density if so asked for.
c
            if(doscfprp.and.iloop.ne.nloop) then
c             write(6,*) 'Destroying the good D.'
              CALL daread(IDAF,IODA,da,L2,308,0)
              CALL dawrit(IDAF,IODA,da,L2,16,0)
            endif
c
            if((dosap.or.dospc).and..not.dopleda) then
c             update Mulliken populations+charges. Do not update for PL0.
              CALL daread(IDAF,IODA,da,l2,16,0)
              CALL daread(IDAF,IODA,db,l2,12,0)
              call mulpop(l1,da,db,popmul(1,ifg,inxtpop))
              if(dospc) then
                if(NPTSTN.ne.0) then
                  if(nprint.eq.-5.or.ISKPRP.ne.0) call stone(ip,rnone)
                  call dcopy(nat,stonep,1,popmat(1,ifg,inxtpop),1)
                  if(nfrgmul.gt.0.and.maswrk) call storemul(0,ifg,nat,
     *        nfrgmul,frgmul,frgmul(1,1,inxtpop),natfrg,c,stonep(1+nat))
                else
               call mulpopa(popmul(1,ifg,inxtpop),popmat(1,ifg,inxtpop))
                endif
              endif
            endif
c
            CALL daread(IDAF,IODA,da,L2,16,0)
c           write(6,*) 'wwwdens1',ifg,irec0new,da(1),da(2)
c         write(6,*) 'wwwoutdens'
c         call prtril(da,l1)
            if(nextra.lt.nextra0.and.(donor.or.acceptor)) then
c             The environment is of closed shell type, so there is only one ESP.
              CALL daread(IDAF,IODA,db,L2,20,0)
              call daxpy(l2,one,db,1,da,1)
            endif
            if(iloop.ne.nloop) then
              dele=delescf
c
c           This is the latest fix that replaces delta-D (MP2) by that of RHF.
c           To get back the MP2 value just erase the if and keep the else part.
c
            else
              dele=TRACEP(da,fmoespa,l1)
            endif
            memon=1+iloop
c
            emon(ifg,memon)=etot-dele
c           check convergence for SCF only
            if(etot.eq.zero) emon(ifg,memon)=zero
c
            if(dopleda) then
              if(maswrk) then
                epl0ds(ifg,1)=escf-dele-e0scf(1)
                epl0ds(ifg,2)=dele-e0scf(2)
              endif
            endif
c
c           save the density or orbitals
c
            imxl30=maxl30(ifg)
            lenrec=0
            if(.not.orbxch.or.odexch) then
cnb           remove this daread?
              CALL daread(IDAF,IODA,da,l2,16,0)
              lenrec=lenrec+l2
            endif
            if(orbxch.or.odexch) then
              CALL daread(IDAF,IODA,da(lenrec+1),l3,15,0)
              lenrec=lenrec+l3
            endif
            if(enexch) then
              CALL daread(IDAF,IODA,da(lenrec+1),l1,17,0)
              lenrec=lenrec+l1
            endif
c
            CALL rawrites(IDAFMO,iodfmo,da,imxl30,lenrec,ifg+irec0new,0)
            if(addesp.or.diffesp) then
              irecv=(irec0new-1)/2+nfg*4+1+ifg
              CALL rawrites(IDAFMO,iodfmo,fmoespa,imxl30,lenrec,irecv,0)
            endif
cnb         This will not work for correlation?
c           Should we save only if converged?
c           if(densfmo0.and.ifg.eq.1) then
c             write(6,*) 'wwwsaving',ifg,ifgfmo0,lenrec
c             call prtril(da,l1)
c           endif
            if(densfmo0.and.ifg.eq.1)
     *      CALL rawrites(IDAcFMO,iodcfmo,da,imxl30,lenrec,ifgfmo0+1,0)
c
c           check convergence for SCF
c
            nconv0=nconv
            if(iloop.eq.nloop) then
            if(orbxch.and..not.odexch) CALL daread(IDAF,IODA,da,l2,16,0)
              call DDIFF(da,wrk2,L2,denmax)
              gdenmax=max(gdenmax,denmax)
              ediff=emon(ifg,memon)-eprev
              aediff=abs(ediff)
              gediff=max(gediff,aediff)
c             write(6,*) 'wwwhaha',gediff,aediff
              conv=(jter.ge.mxitfg.or.aediff.lt.convfg.or.dopleda)
     *             .and.etot.ne.0
              fmajor=.false.
              if(conv.and.(espscf.ne.one.or.itol0.ne.itol.or.
     *           icut0.ne.icutifg.or.CONVHF0.ne.CONVHF)) then
                conv=.false.
                fmajor=.true.
              endif
c             Force "convergence" for the extra iteration that does corr/grad
c             if(conv.and.iter.lt.mxitfg.or.nextra.lt.nextra0)
c             if((aediff.lt.convfg.or.dopleda.or.nextra.lt.nextra0)
c             Force convergence if there is only one fragment in this layer.
              if((aediff.lt.convfg.or.dopleda.or.nextra.lt.nextra0
     *            .or.nfglay.eq.1.and..not.dolat).and.etot.ne.0)
     *           nconv=nconv+1
c             we may violate memory if popmat was not allocated. Lest this
c             happen point to the first element.
              ifg0=ifg
              inxtpop0=inxtpop
              if(.not.primul) then
                ifg0=1
                inxtpop0=1
              endif
c             Only do properties for converged SCF and for its own layer.
c             With the present implementation some monomers will be treated
c             redundantly if SCC converges not for all monomers at the same
c             time. However, if gradient or correlation is requested we can
c             save on properties by running them during the extra run.
c             For selected monomers some correlated runs will be skipped so do
c             properties as for uncorrelated cases.
c             Add support for molfrg for RHF runs.
              if(molfrg(1).ge.0) then
c               doprop=(conv.and.skipci).or.nextra0.ne.nextra
                doprop=(conv.and.skipci).or.nextra0.ne.nextra.or.
     *                 rcorsd.eq.0
              else
                if(correl.or.nder.gt.0.or.densgrid.or.spargrid) then
                  doprop=nextra0.ne.nextra.or.dopleda
                else
                  doprop=conv
c                 Do SCF properties only if correlation will not be run.
                endif
              endif
c             Save energies without dynamic correlation.
c             ESCF is saved by MP2 by may not be available otherwise.
              if(rcorsd.ne.zero.and..not.doddcor) emon(ifg,2)=escf-dele
            endif
c
            idam=1
            if(layfrg(ifg).ne.ilay) idam=0
c           if(ilay.eq.1.and.ext2lay) idam=idam+nmmfrg(ifg)
            if(nbody.gt.1) idad=-nmdfrg(ifg,1)
            if(nbody.gt.2) idat=nmtfrg(ifg,1)
            if(iloop.ne.0) then
              if(nbody.gt.1) idad=idad+nmdfrg(ifg,2)
              if(nbody.gt.2) idat=idat-nmtfrg(ifg,2)
c             do not accumulate RHF monomer properties
              idam=0
              if(ilay.eq.2.and.ext2lay) idam=-1
              if(ilay.eq.2.and.ext2lay) idad=idad+nmmfrg(ifg)
            endif
            if(nloop.gt.0.and.iloop.eq.0) then
              if(nbody.gt.1) idad=-nmdfrg(ifg,2)
              if(nbody.gt.2) idat= nmtfrg(ifg,2)
            endif
c
c           iloop=1 SCF nmdfrg(ifg,1)
c           iloop=0 MP2 nmdfrg(ifg,2)
c           idat=((nfg-2)*(nfg-3))/2-1
            if(doprop) then
c             extracc needs not be zeroed out at each iteration since we are
c             guaranteed to have the extra SCC iteration for correlation.
              if(cctyp.ne.rnone.and.maswrk) then
                if(nbody.gt.1) idad2=-nmdfrg(ifg,2)
                if(nbody.gt.2) idat2=nmtfrg(ifg,2)
                call addecc(1,idam,idad2,idat2,extracc,nextracc)
              endif
              call addprop(1,layfrg(ifg).eq.ilay,primul,idam,idad,idat,
     *                     iaglob,popmat(1,ifg0,inxtpop0),nfmoelm,
     *                     fmoelm(1,ifg),fmoelm(1,nfg+3),fmoelm(1,nfg+4)
     *                   ,atmulqi,atmulqi(natfmo+1),atmulqi(natfmo*2+1))
              if(iloop.ne.0) call vclr(fmoelm(1,ifg),1,nfmoelm)
c             clear off RHF moments to be replaced by MP2. Note that
c             RHF moments as accumulated in fmoelm(1,ifg) contribute
c             to 2 and 3-body properties (before they are done in).
              if(totdens) then
                call fmototd(idam+idad+idat,l2,da,totd,iaoglob)
                clrden=.true.
c               one has to clear density during the next iteration
c              (if there is a next iteration).
              endif
c             Compute the monomer density on a grid
c             For FMO0 runs replace local ifg by global.
              if(nxyzgm.ne.0.and.iand(nprfrg(ifg),4).ne.0) then
                call mongrid(NGm,ORIGM,UXM,UYM,UZM,vdwrad,grdpad)
                call vclr(dgridm,1,nxyzgm)
                call fmoprc(1,1,l2,da,dgridm,1,NGm(1),1,NGm(2),1,NGm(3),
     *                      1,NGm(1),1,NGm(2),1,NGm(3), 0,0,0,0,0,0,
     *                      ORIGM,UXM,UYM,UZM)
                call ddi_gsumf(2416,dgridm,nxyzgm)
                ifgifg=ifg
                if(ifgfmo0.ne.0) ifgifg=ifgfmo0
                if(maswrk) call makecube(ifgifg,1,nat,zan,c,dgridm,
     *                          NGm(1),NGm(2),NGm(3),ORIGM,UXM,UYM,UZM)
              endif
              if(densgrid.and.(ifgfmo0.eq.0.or.ifg.eq.1)) then
c               Compute the total density on a grid
                call grdbox(ixmin,ixmax,iymin,iymax,izmin,izmax,vdwrad,
     *                      grdpad)
                idamdt=idam
                if(nbody.gt.1) idamdt=idam+idad
                if(nbody.gt.2) idamdt=idam+idad+idat
                call fmoprc(idamdt,1,l2,da,dgrid,1,NXG,1,NYG,1,NZG,
     *                      ixmin,ixmax,iymin,iymax,izmin,izmax,
     *                      0,0,0,0,0,0, ORIGIN,UX,UY,UZ)
                clrden=.true.
c               one has to clear density during the next iteration
c               (if there is a next iteration).
              endif
              if(spargrid.and.(ifgfmo0.eq.0.or.ifg.eq.1)) then
c               Compute the total density on a sparse grid
c               First compute with factor 1 and then scale for all n-body
c               terms.
                ioff=noffg(ifg)
                call fmoprc(1,1,l2,da,dgrid(ioff,1),indgrd(1,ifg),
     *                      indgrd(2,ifg),indgrd(3,ifg),indgrd(4,ifg),
     *                      indgrd(5,ifg),indgrd(6,ifg),indgrd(1,ifg),
     *                      indgrd(2,ifg),indgrd(3,ifg),indgrd(4,ifg),
     *                      indgrd(5,ifg),indgrd(6,ifg), 0,0,0,0,0,0,
     *                      ORIGIN,UX,UY,UZ)
                nxyzgi=(indgrd(2,ifg)-indgrd(1,ifg)+1)*
     *                 (indgrd(4,ifg)-indgrd(3,ifg)+1)*
     *                 (indgrd(6,ifg)-indgrd(5,ifg)+1)
                damd=idam+idad
                if(damd.ne.zero.and.nbody.gt.1)
     *           call daxpy(nxyzgi,damd,dgrid(ioff,1),1,dgrid(ioff,2),1)
                damdt=idam+idad+idat
                if(damdt.ne.zero.and.nbody.gt.2)
     *          call daxpy(nxyzgi,damdt,dgrid(ioff,1),1,dgrid(ioff,3),1)
                dam=idam
                call dscal(nxyzgi,dam,dgrid(ioff,1),1)
                clrden=.true.
c               one has to clear density during the next iteration
c               (if there is a next iteration).
              endif
              if(dolat) then
                call genlatv(ifg,l1,l2,n2fmo,klms,untrot,fmoespa,db,vec,
     *                       wrk1,esplat)
              endif
            endif
c
            if(updpcm) then
              ida=idam
c             This code is not correct for PCM gradient!
              if(nextra.ne.nextra0) then
                if(nfmopcm.ge.2) ida=ida+idad
                if(nfmopcm.ge.3) ida=ida+idat
              else
                if(ilay.eq.1.and.nlayer.gt.1.and.iterpcm.eq.1) ida=1
              endif
              fda=-ida
              if(ida.ne.0) call EPOTEN(fda,XYZCTS(1,1),XYZCTS(1,2),
     *                                 XYZCTS(1,3),PEL,da,NTS,L2)
            endif
            if(nfmopcm.ne.0) then
              if(maswrk) esolv(ifg)=(PC-PX)*half
            endif
            if(ndftfg.eq.1.and.maswrk) then
              fda=idam+idad+idat
              call daxpy(nedft,fda,edft,1,etotdft,1)
            endif
c
c           accumulate gradient
c
c           Gradient is run as an extra iteration after SCC converges,
c           therefore, one has nconv.
c           It is now possible that NDER>0 but the current RUNTYP is ENERGY.
c           if(doprop.and.nder.gt.0.and.maswrk) then
           if(doprop.and.nder.gt.0.and.runtyp.ne.energy.and.maswrk) then
              call fmodeg(idam,fmode,fmopg,iaglob)
              if(nbody.gt.1) call fmodeg(idam+idad,fmode(1,1,2),fmopg,
     *                                   iaglob)
              if(nbody.gt.2) call fmodeg(idam+idad+idat,fmode(1,1,3),
     *                                   fmopg,iaglob)
              if(nbody.eq.2.and.ext2lay)
     *          call fmodeg(idam+idad,fmode(1,1,3),fmopg,iaglob)
              IF (IEFPFMO.EQ.1) THEN
                CALL EFPDEG(idam,1)
                if(nbody.gt.1) CALL EFPDEG(idam+idad,2)
                if(nbody.gt.2) CALL EFPDEG(idam+idad+idat,3)
              ENDIF
            endif
C
c       avoiding the next call makes FMO-1 gradient sensible.
c--         IF (DOPROP.AND.NDER.GT.0.AND.RUNTYP.NE.ENERGY
c--  *          .AND.IAND(MODGRD,2).NE.0.and.iloop.eq.0) THEN
c--           CALL FMOESDER(l1,l2,da,layfrg,scffrg,idmrec0,da,da,
c--  *                      da,da,da,1,0, 0,0,0,
c--  *                    .false.,.false.,.false.,.false.,.false.)
c--         ENDIF
C
            IF (IEFPFMO.EQ.1.AND.NDER.GT.0) CALL DEFPCLR
            if(iloop.gt.0) then
c             mplevl=2
              mplevl=mp2sav
              cityp=cisav
              tddftyp=tdsav
c             This will not work for TDDFT gradient: need to use iexcit
              irest=5
              delescf=dele
            endif
          enddo
c         possibly dump PLTORB data for the selected fragment
          if(conv.and.npunch.ne.0.and.PLTORB) CALL PLTMEM
          npunch=npusav
          nprint=nprsav
          mplevl=mp2sav
          cityp=cisav
          tddftyp=tdsav
          irest=0
          if(maswrk) then
            if(doprop) then
c             if(correl.and..not.dopleda) then
              if(correl) then
                write(6,9217) jter,ifg,emon(ifg,1),emon(ifg,2)
              else
                write(6,9215) jter,ifg,emon(ifg,1)
              endif
            else
              write(6,9210) jter,ifg,emon(ifg,1),denmax,ediff
            endif
          endif
c
c         Avoid energy double counting due to secret group switching
c         Zero out the first (MCSCF) energy on slaves
          if(lbmcscf.and.iifg.eq.1.and..not.maswrk) then
            emon(ifg,memon)=zero
            nconv=nconv0
          endif
c
c           Replace polarised monomer energies with FMO0 ones.
c           This is needed to compute dimer corrections.
c           Note that we print polarised energies as EFMOc.
c
            if(dopleda) then
c             subtract environmental potential on monomer IFG due to the rest of
c             monomers. Thus emon(ifg,) contains free monomer energies
c             (unperturbed by the env.), but with the environment subracted,
c             so that dimer corrections (E'IJ-E'I-E'J) could be estimated
c             (using E'I computed here).
              if(maswrk) then
              if(correl) then
                epl0ds(ifg,3)=emon(ifg,1)-emon(ifg,2)-
     *                        (efmo0(ifg,1)-efmo0(ifg,2))
                emon(ifg,3)=efmo0(ifg,2)+(emon(ifg,1)-emon(ifg,2))
                emon(ifg,4)=efmo0(ifg,2)
c               set correlated energy to E(FMO0,SCF)+Ecorr(PL0,MP2)
c               set uncorrelated energy to E(FMO0,SCF)
c               This is done because in FMOPROP one subtracts E(FMO0,SCF)
c               and Ecorr(PL0,MP2) from EIJ(PL0,MP2) to get energy
c               components.
              else
                emon(ifg,3)=efmo0(ifg,1)
c               set uncorrelated energy to E(FMO0,SCF)
              endif
              endif
c             if(correl) emon(ifg,2)=efmo0(ifg,2)
c             The SCF value of efmo0(ifg,*) must be equal to e0scf(1)
c             (the former is given in the input, the latter comes from SCF).
c             memon is 1 (for PL0 runs).
              memonp=1
              if(correl) memonp=2
              if(abs(efmo0(ifg,memonp)-e0scf(1)).gt.1.0D-06) then
                if(maswrk) write(6,*) 'Mismatch in E0',ifg,e0scf(1),
     *                                efmo0(ifg,memonp)
c               call abrt
              endif
c             write(6,*) 'wwwE0',emon(ifg,1),emon(ifg,2)
            endif
c
c         restore icut for "poorly" converging fragments
c
          icut=icutifg
c
  230   continue
        call timit(1)
        CALL TSECND(TIMe0)
        wall0=wall
        if(isgddi0) call GDDICOUNT( 1,lgroup,myjob)
        CALL TSECND(TIMe1)
        if(maswrk) write(iw,9600) ' Monomer',wall-wall0
c
c     use the latest monomer density in the dimer ESP.
c
        if(.not.dopleda) idmrec0(ilay)=irec0new
c       idmrec0(ilay)=irec0new
c
        if(nfglay.ne.0) then
          if(isgddi0) then
c
c           echange density matrices
c
            nfge=nfg*2
c           if(nconv.eq.nfglay.and.rcorsd.ne.0) nfge=nfg*2
c           Note that nfge is not nfglay but nfg. It is a waste of time
c           but it is required to extract data properly.
            if(maswrk) glocon(mygroup)=gediff
c
c           write(6,*) 'irec0new',irec0new
            call dmexch(ilay,nfge,jobgrp,layfrg,numfrg,natfrg,scffrg,
     *                  idafmo,iodfmo,maxl30,emon,glocon,nconv,irec0new,
     *                  dosap,dospc,orbxch,enexch,atonce,mastid,
     *                  popmul(1,1,inxtpop),popmat(1,1,inxtpop),ifgbuf,
     *                  nfgbuf)
            gediff=glocon(idamax(mgroups,glocon,1)-1)
c           idamax thinks that the array starts from 1, not from 0.
c           For DDI gediff is set above and needs not be exchanged between
c           groups.
          endif
c
c         save record indexing for restarts
c
          iodfmo(NDAR30+3)=ilay
          iodfmo(NDAR30+4)=iter+1
          iodfmo(NDAR30+5)=JRECST(IDAFMO/10)
c         iter+1 means in the restart the first iteration will be iter+1
c         and densities from iter will be used.
          call icopy(nlayer,idmrec0,1,iodfmo(NDAR30+6),1)
          call rawrites(IDAFMO,iodfmo,iodfmo,NDAR30i,NDAR30i,1,0)
        endif
c
c     Do correlation if needed at the N+1 iteration (after SCF converges in
c     N iterations.
c
        conv=nconv.eq.nfglay.and.espscf.eq.one.and.
     *       (coroff.eq.0.or.NDFTFG.eq.ndftsav).and.npcmsav.eq.nfmopcm
c
        if((nfmopcm.eq.1.or.nfmopcm.gt.1.and.iterpcm.eq.1).and.
     *     (.not.conv.or.nextra.eq.1).and.
     *     (nlayer.eq.1.or.ilay.eq.1.and.iterpcm.eq.1)) then
          if(isgddi0) call gddi_scope(ddi_world)
c         Do not recalculate charges if converged, because it would lead to
c         monomers and dimers having different charges. Only recalculate if
c         monomers are not converged!
c         Summing should be done in the world scope, since each node has a
c         dyo lepta contribution.
          call ddi_gsumf(2418,PEL,NTS)
          call ddi_gsumf(2418,VNUC,NTS)
          iterasc=jter
c         Do not start over from the ASC initial guess for higher layers
c         or consequent PCM iterations.
          if(ilay.gt.1.or.iterpcm.gt.1) iterasc=2
          if(pcmoff.ne.0.and.ipcmoff1.ne.ipcmoff) iterasc=1
          call calcasc(iterasc,NTSPAR,ichfmo,nefmo,lfmasc,needasc,idum1,
     *                 nesolv,idum2,idum3,idum4)
          if(isgddi0) call gddi_scope(ddi_group)
        endif
        if(nfrgmul.gt.0) then
          if(isgddi0) call gddi_scope(ddi_world)
          call ddi_gsumf(2418,frgmul(1,1,inxtpop),nfrgmul*natfmob)
          if(isgddi0) call gddi_scope(ddi_group)
        endif
c
        if(maswrk.and.nextra.eq.nextra0)
     *    write(iw,9105) jter,nconv,gdenmax,gediff
c
        NDFTFG=ndftsav
        dftype=dftsav
        DFTTYP(3)=hfssav
        LCFLAG=lcsav
        if(conv) then
           if(correl) then
             mplevl=mplevli
             cctyp=cctypi
             cityp=citypi
             tddftyp=tddfti
           endif
           RUNFMO=runtyp
           if(maswrk.and.nextra.ne.0) write(iw,9250)
c          switch groups if needed.
           if(nextra.ne.0.and.isgddi0.and.ngrfmo(4,ilay).ne.0)
     *       call fmopre(ilay,4,ngrfmo,mannod,mastid)
           nextra=nextra-1
           iemom=iemoms
        endif
        icurpop=inxtpop
        iter=iter+1
        jter=jter+1
        CALL TSECND(TYME)
        IF(TYME.GT.TIMLIM) THEN
          IF(MASWRK) WRITE(IW,9500)
          ntimout=1
        ENDIF
        if(jter.gt.mxitfg.and..not.conv) then
          IF(MASWRK) WRITE(IW,9510)
          nextra=-1
          ntimout=2
          conv=.true.
          iter=iter+1
        ENDIF
      if((.not.conv.or.nextra.ge.0).and.TYME.le.TIMLIM) goto 200
      if(conv) iter=iter-1-nextra0
      if(nfglay.eq.0) iter=0
      liter(ilay)=iter
c     Now add the contribution from this later.
c     Note that for one layer runs atmulqi/atmulq are
c     equivalent by call so that there is no need to copy.
      if(primul) call daxpy(natfmo*nbody,one,atmulqi,1,atmulq,1)
c     fmoelm(1,nfg+3) contains the sum of contribution due to this layer
cnb   at present 3-body properties will not work with layers
c     (to fix, save 2-body and 1-body sums with trimer factors)
c     add them to the total
c     add sums of 1 body terms for 2 and 3 body.
      if(nfmoelm.ne.0)
     *  call daxpy(nfmoelm*2,one,fmoelm(1,nfg+3),1,fmoelm(1,nfg+1),1)
c
      if(nfglay.eq.0) then
        if(maswrk) write(iw,9240)
      else
        if(nconv.eq.nfglay.and.maswrk) write(iw,9220) ilay,iter-iter0+1
        if(nconv.ne.nfglay.and.maswrk) write(iw,9230) ilay,iter-iter0
      endif
      if(dopleda) liter(ilay)=min(iter,mxitfg)
      if(desperate) then
        if(isgddi0) then
          call gddi_scope(ddi_world)
          idum=0
          call DDI_nsumi(2423,ndesper,nodesper,idum,idum,2)
          call gddi_scope(ddi_group)
        endif
c       Statistics printed here is for the last iteration. It is permitted for
c       some fragments not to converge sometime before the final iteration.
        if(maswrk) write(iw,9320) ndesper,nodesper
c       if(nodesper.ne.0) call abrt
      endif
      if(dopleda.and.isgddi0) then
        call gddi_scope(ddi_world)
        call ddi_gsumf(2415,emon(1,3),nfg*2)
        call gddi_scope(ddi_group)
      endif
      if(dolat.and.nbody.gt.1) then
        call gddi_scope(ddi_world)
        call ddi_gsumf(2415,esplat,n2fmo*nsymop)
        call gddi_scope(ddi_group)
      endif
c     IF (GOPARR.and.nfmoelm.ne.0)
c    *  CALL DDI_BCAST(2421,'F',fmoelm,nfmoelm*(nfg+1),MASTER)
c     GAMESS does not seem to have SCF properties on slaves.
c     Broadcast is needed only if ngrfmo(2) and ngrfmo(1) divides the groups
c     unevenly in such a way that a master can become a slave after
c     switching when doing dimers. Should we do it only when needed?
c     Note that broadcasts are redundant for layers (only one is needed but
c     currently it is done nlayer times.
c
      NRAD0=NRADs
      NPHI0=NPHIs
      NTHE0=NTHEs
      swoff=swoffs
      swdiis=swdiisv
c
c     SAVE FMO1-TDDFT RESULTS
c
      if (tddfti.ne.rnone) then
        if(isgddi) then
          call gddi_scope(ddi_world)
          idum=0
          call DDI_nsumi(2423,nstmono,nvirtdm,idum,idum,2)
          call DDI_gsumi(2423,monoc,mxrt)
          call DDI_gsumi(2423,monvr,mxrt)
          call DDI_gsumi(2423,idxyz,mxrt)
          call DDI_gsumf(2423,eexcit,mxrt)
          call DDI_gsumf(2423,texcit,3*mxrt)
          if(iexcit(2).eq.2)
     *      call DDI_gsumf(2423,CTDM,nocctdm*nvirtdm*NSTAT)
          call gddi_scope(ddi_group)
        endif
      endif
      correl=corsav
c
c     Use RHF, not MP2 Mulliken populations and charges.
c
      if(doddcor.and..not.doscfprp) icurpop=3-icurpop
c
c     if(dopleda) icurpop=1
c
      return
 9105 format(//1x,77(1H-),/1x,'FMO iter',I3,', ',I4,
     *       ' fragment(s) converged, maxD',F13.10,', maxE',
     *       F13.10,/1x,77(1H-))
 9120 format(/1x,'Warning: ESPs for all fragments are scaled by the ',
     *           'factor',F9.6)
 9200 format(/1x,'Running ',A8,' energy for monomer',I5,', L1=',I5,/)
 9203 format(1x,'Using tighter ICUT=',I2)
 9205 format(/1x,'Resetting LABSIZ=',2I2,/)
 9207 format(1x,'Int dimensions: LABSIZ=',I1,', NINTIC=',I9,
     *          ' ININTIC=',I9)
 9210 format(/1x,'Iter=',I3,' iFrag=',I5,' EFMO=',F16.9,
     *       ', DD=',F12.9,', DE=',F12.9/)
 9215 format(/1x,'Iter=',I3,' iFrag=',I5,' EFMOu=',F16.9)
 9217 format(/1x,'Iter=',I3,' iFrag=',I5,' EFMOc=',F16.9,' EFMOu=',
     *           F16.9)
 9220 format(/1x,12(1H-),'Monomer SCF for layer',I2,' converged in',I3,
     *       ' iterations!',12(1H-))
 9230 format(/1x,9(1H-),'Monomer SCF for layer',I2,' did not converge',
     *                   ' in',I3,' iterations!',9(1H-))
 9240 format(/1x,9(1H-),'No monomers in this layer! ',
     *                   'Is this what you intended?',9(1H-))
 9250 format(/1x,'-Monomer SCF converging: one extra iteration ',
     *                   'to do correlation or properties.-')
 9300 format(/1x,'Trying desperately the alternative SCF converger.')
 9310 format(/1x,'Despite trying desperately, SCF did not converge.')
 9320 format(/1x,'Desperately converged',I5,', diverged',I5,' monomers.'
     *          ,/)
 9400 format(/1x,'Gradient requires converged SCF.',/)
 9500 format(/1x,'Running out of time...',/)
 9510 format(/1x,'Two many iterations: monomer SCF is not converged.')
 9600 format(/1x,A8,' SCF synchronisation took',F8.1,' s.')
      END
C*MODULE fmo     *DECK edimer
      subroutine edimer(ilay,nder,runtyp,loadhf,jobgrp,loadm,loadd,
     *                  layfrg,numfrg,cfrg,iodfmo,maxl30,indat,iaglob,
     *                  idmrec0,haver,da,db,wrk,wrk1,dij,zsave,fmoespa,
     *                  fmoespb,emon,edim,fmode,fmopg,enucfmo,atmulq,
     *                  nfmoelm,fmoelmd,fmoelmt,nddfrg,ndtfrg,iabdfg,
     *                  jabdfg,locfmo,molfrg,scffrg,mapi,mapj,mcnvfmo,
     *                  mconvex,mconfg,ijvec,correl,scftypi,mplevli,
     *                  CITYPi,CCTYPi,tddfti,nfg2d,nfg2,nen,nactfmo,
     *                  ncasfmo,primul,orbxch,enexch,ntimout,nscf,nemc,
     *                  docas,nedimes,nedimex,job2grp,needdm,ngrfmo,
     *                  mannod,mastid,nprfrg,isdrec,nfthes,ngrdsiz,
     *                  nelmsiz,nesdsiz,fmoelm,ndar30,NDAR30i,savgrd,
     *                  modmol,exclmol,totdens,totd,iaoglob,densgrid,
     *                  nxyzg,dgrid,loadgr,nstjob,l1dir,grdpad,vdwrad,
     *                  spargrid,noffg,indgrd,extracc,nextracc,irec0,
     *                  irec0cor,doddcor,esolv,dovpcm,etotdft,nedft,
     *                 XYZCTS,PEL,VNUC,QSE,ISPHE,qtmp,imect,ctdim,popmat
     *                 ,ialoc,indbd,ext2lay,fmoq,IDAcFMO,iodcfmo,dopleda
     *                 ,dolat,nunint,nunptc,natfmob,untxyz,untrot,esp1i,
     *                  esp1j,czi,czj,nsymeq,maxl2,n2fmo,klms,esplat,
     *                  addesp,addesp0,stonep,some,iexcit,eexcit,texcit,
     *                  idxyz,monoc,monvr,nstmono,isumd,eexfg,
     *                  nocctdm,nvirtdm,ctdm,exfid)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      parameter (MXATM=2000,MXSH=5000,MXGTOT=20000,MXRT=100,maxpst=10,
     *           MXGRID=10)
      parameter (zero=0.0D+00,one=1.0D+00,half=0.5D+00)
      logical myjob,isgddi,parout,INITGDDI,GOPARR,DSKWRK,MASWRK,DIRSCF,
     *        FDIFF,AIMPAC,RPAC,PLTORB,MOLPLT,orbxch,enexch,esd,primul,
     *        iodexch,jodexch,fmodscf,fmodtrf,prerhf,lie,correl,haver,
     *        usedij,sepdim,needdm,desperate,despread,doddcor,doddcori,
     *        docas,lbmcscf,savgrd,copycore,projact,totdens,densgrid,
     *        clrcow,forcedir,fordir,spargrid,tightint,skipc,exclmol,
     *        flipsd,dovpcm,ext2lay,fmoq,dopleda,dolat,addesp,addesp0,
     *        addespij,some,lcflag,lrint,lcsav,gopsav,SG1
      character*8 dimdek,end
      character*1 flipch
      integer ddi_world,ddi_group
      Parameter(ddi_world=0,ddi_group=1)
      dimension jobgrp(*),loadm(*),loadd(*),layfrg(*),numfrg(*),
     *          cfrg(3,*),iodfmo(*),maxl30(*),indat(*),iaglob(*),
     *          idmrec0(*),da(*),db(*),wrk(*),wrk1(*),dij(*),zsave(*),
     *          fmoespa(*),fmoespb(*),emon(nfg,2),edim(nfg2d,*),
     *          fmode(3,natfmo,*),fmopg(3,*),atmulq(*),fmoelmd(nfmoelm),
     *          fmoelmt(nfmoelm,2),nddfrg(*),ndtfrg(nfg2,2),iabdfg(*),
     *          jabdfg(*),locfmo(*),molfrg(*),scffrg(*),mapi(*),mapj(*),
     *         mcnvfmo(*),mconfg(*),ijvec(*),job2grp(*),ngrfmo(maxpst,*)
     *         ,mannod(*),mastid(*),nprfrg(*),isdrec(*),fmoelm(*),
     *          totd(*),iaoglob(*),dgrid(nxyzg,*),vdwrad(*),noffg(*),
     *          indgrd(6,*),extracc(nextracc,*),esolv(*),etotdft(*),
     *          XYZCTS(mxts,3),PEL(*),VNUC(*),QSE(*),ISPHE(*),qtmp(*),
     *          ctdim(*),popmat(maxnat,nfg,2),ialoc(*),indbd(maxabd,*),
     *          iodcfmo(*),untxyz(3,natfmob,0:nunptc+1),
     *          untrot(3,3,0:nunptc),esp1i(*),esp1j(*),czi(*),czj(*),
     *          nsymeq(*),klms(4,*),esplat(n2fmo,*),stonep(*),iexcit(5),
     *          eexcit(mxrt,2),texcit(3,mxrt,2),idxyz(mxrt),
     *          monoc(mxrt),monvr(mxrt),icst(mxrt),isumd(mxrt+1),
     *          eexfg(2,nfg,mxrt),ctdm(*)
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,BSLRD(137),NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0,
     *                NANGPT(MXGRID),NANGPT0(MXGRID),SG1
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /NLRC  / LCFLAG,LRINT,EMU,EMU2,LRFILE
      COMMON /EFPFMO/ IEFPFMO,ISWENUC,REPNUCEFP,EFPEFP,RUNEFP
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,npglob,nnglob,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /GRDPAR/ ORIGIN(3),XVEC(3),YVEC(3),ZVEC(3),UX(3),UY(3),
     *                UZ(3),GRDSIZ,NGRID,IGUNIT,NXG,NYG,NZG,modgrid
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      common /INT2IC/ NINTIC,iNINTIC,nxxic,lbufpic,lixic,labsix,nintix
      COMMON /INTRFC/ FRIEND,AIMPAC,RPAC,PLTORB,MOLPLT
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /MP2PAR/ OSPT,CODEMP,SCSPT,TOL,METHOD,NWDMP2,MEMPRI,MPPROP,
     *                NACORE,NBCORE,NOA,NOB,NORB,NBF,NOMIT,MOCPHF,MAXITC
      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 /OPTSCF/ DIRSCF,FDIFF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /PCMCHG/ PB,PX,PC,UNZ,QNUC,FN,FE,UNZOR,PORT
      COMMON /PCMDIM/ mxsp,mxts,mempcm1,mempcm2,NTS
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEFPCM,IP_F,nfmopcm
      COMMON /PSILVL/ IPSI,ISKPRP
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ pUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,npreo(4)
      COMMON /SCFWFN/ AROHF(3),BROHF(3),PACAVO(6),IACAVO,IUHFNO,MVOQ
      COMMON /STNBUF/ STNPNT(4,2*MXATM),BIGEXP,NPTSTN,NBUFFM
      COMMON /TIMING/ CPU,WALL
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      common /fmodim/ maxbnd,maxknd,maxcbs,maxcao,maxvec,maxl1,
     *                maxnat,maxabd,maxbas
      common /fmoinf/ nfg,nlayer,natfmo,nbdfg,naotyp,nbody
      common /fmoopt/ espsca(9),RESPAP(2),rESPPC(2),rESDIM,restri(4),
     *                rcorsd,respct,convfg,cnvdmp,coroff,IXESP,mxitfg,
     *                nguess,NBSSE,modorb,modpar,irststp,irstlay,nprfmo,
     *                nfmopal,modprp,maxl1c,ipieda,modgrd,modesp,ivmul
      common /fmorun/ espscf,e0scf(2),IDAFMO,icurlay,icurfg,jcurfg,
     *                kcurfg,ncursh,ngau,icurpop,ifmostp,moncor,nat1e,
     *                needr,modrst,norbproj,nunesp,iskipesp,icurunt
      data dimdek/' $FMOEND'/,end/' $END'/,RMC/8HMCSCF   /,
     *     rhf/8HRHF     /,energy/8HENERGY  /,rnone/8HNONE    /
c
c     parstat: GlobalFull
c     ifmostp is set really only for makmol in order to read MP2 data.
      ifmostp=3
      if(dolat) iskipesp=1
      ntimout=0
      prerhf=mod(nguess/16,2).ne.0
      copycore=iand(nguess,32).ne.0
      projact=iand(nguess,64).ne.0
      sepdim=mod(modpar,2).ne.0.and.ngrfmo(5,ilay).ne.0.and.resdim.ne.0
     *      .and.isgddi
      flipsd=iand(modpar,128).ne.0.and.resdim.ne.0
      lbmcscf=docas.and.mod(modpar,2).ne.0.and.ngrfmo(7,ilay).ne.0.and.
     *        nemc.ne.0.and.isgddi
      write(ip,9200) dimdek
      rij=zero
c     haver=rESDIM.ne.zero
      usedij=iand(IXESP,2).eq.0
      desperate=mod(nguess/256,2).ne.0
      despread=desperate.and.iand(nguess,2048).eq.0
      esd=nder.gt.0.and.resdim.ne.0.and.iand(ixesp,32).eq.0
      ndesper=0
      nodesper=0
      dftsav=DFTYPE
      ndftsav=NDFTFG
      lcsav=LCFLAG
      cisav=cityp
      mp2sav=mplevl
      hfssav=DFTTYP(3)
      tdsav=tddftyp
c     if(needdm) call viclr(job2grp,1,nfg2)
c     WRITE(IW,9086)
c     CALL EGOUT(fmode(1,1,2),natfmo)
c9086 FORMAT(/10X,36(1H-)/10X,'2-body gradient after VDER',
c    *       /10X,36(1H-))
c
      if(isgddi) call GDDICOUNT(-1,lgroup,myjob)
c     doddcor=MPLEVLi.gt.0.and.(MPPROP.ne.0.or.nder.gt.0).or.
c    *        citypi.ne.rnone
      if(doddcor) ixesp=ixesp+1024
c     raising 1024th bit signals ESPs to always use RHF densities.
      memon=1
      if(rcorsd.ne.0) memon=2
      if(dopleda) memon=memon+2
c     allways use uncorrelated monomer energies for separated dimers.
      lijfg=0
      iter0=0
      jbsav=jbtyp
      ngrsav=ngroups
      clrcow=.false.
      do iifg=1,nfg
        njfg=iifg-1
        iusu=0
        do 500 iu=0,nunint
        if(iu.gt.0) then
c         skip symmetry equivalent groups.
          if(nsymeq(iu).le.0) goto 500
          iusu=iusu+1
          call CLOSDA('DELETE')
          CALL OPENDA(0)
          iiifg=iifg
          call makemol(iiifg,0,0,ilay,0,0,0,0,0,0,0,.true.)
          call monbsr(nat,ich,mul,num,nqmt,ne,na,nb,nshell,ngau,enucr,
     *                nat0,ich0,mul0,num0,nqmt0,ne0,na0,nb0,
     *                nsh0,ngau0,enucr0)
          ne0c=ne0+ich0
          call dcopy(nat,zan,1,czi,1)
          call dcopy(nat*3,c,1,czi(nat+1),1)
        endif
        do 450 jjfg=1,njfg
          lijfg=lijfg+1
          if(loadhf.eq.1) then
            ijfg=loadd(lijfg)
            call tribrk(ijfg,-1,ifg,jfg)
c           ifg=ifg+1
          else
            ijfg=lijfg
            ifg=iifg
            jfg=jjfg
          endif
c         if(dolat.and.iu.gt.0) then
c           This is potentially problematic.
c           The following arrays are affected:
c           ndtfrg,nddfrg,esolv,job2grp
c           ijfg=ijfg+nfg2+(iusu-1)*nfg*nfg
c         endif
c         Switch groups for separated dimers and/or after MCSCF dimers
          if(sepdim.and.lijfg.eq.nscf+1.or.
     *      lbmcscf.and.lijfg.eq.nemc+1) then
c           write(6,*) 'The 5/7th groupie'
            CALL TSECND(TIMe0)
            wall0=wall
            call GDDICOUNT( 1,lgroup,myjob)
            igrfmo=5
            if(lbmcscf.and.lijfg.eq.nemc+1) igrfmo=7
            call fmopre(ilay,igrfmo,ngrfmo,mannod,mastid)
            call GDDICOUNT(-1,lgroup,myjob)
            CALL TSECND(TIMe1)
            if(maswrk) then
              if(igrfmo.eq.5) write(iw,9600) ' ESD ',wall-wall0
              if(igrfmo.eq.7) write(iw,9600) 'dimMCSCF',wall-wall0
            endif
          endif
c
          NDFTFG=ndftsav
          dftype=dftsav
          DFTTYP(3)=hfssav
          LCFLAG=lcsav
          mplevl=mp2sav
          cityp=cisav
          tddftyp=tdsav
c
          lie=.false.
c
c         skip dimers from higher layers
          if(.not.((layfrg(ifg).eq.ilay.or.layfrg(jfg).eq.ilay).and.
     *      layfrg(ifg).ge.ilay.and.layfrg(jfg).ge.ilay)) goto 450
c         skip dimers that have been done (restart jobs, no BSSE).
          if(irststp.ge.4.and.irststp.ne.5.and.edim(ijfg,1).ne.zero)
     *       goto 445
c         skip dimers that have been done (restart jobs, BSSE).
c         if(irststp.eq.5.and.edim(ijfg,1).ne.zero.and.edim(ijfg,5)
c    *       .ne.zero) goto 445
          if(nbsse.ne.0) then
            if(irststp.eq.5.and.edim(ijfg,1).ne.zero.and.
     *         edim(ijfg,5).ne.zero) goto 445
          endif
          if(iand(modmol,1).ne.0) then
c           check if MOLFRG option tells to ignore dimers except those with
c           one from the chosen group.
            ires=molfrg(ifg)+molfrg(jfg)
            if(exclmol) then
              if(ires.ge.0.and.ires.ne.2) goto 450
            else
              if(ires.eq.0.or.ires.eq.2) goto 450
            endif
          endif
          if(tddfti.ne.rnone.and.iexcit(3).eq.0) then
           if(iexcit(1).ne.ifg.and.iexcit(1).ne.jfg) goto 450
          endif
c
          if(ext2lay.and.ilay.eq.2) then
            call vclr(edim(ijfg,1),nfg2,nen)
          endif
c
          CALL TSECND(TYME)
          IF(TYME.GT.TIMLIM) THEN
            IF(MASWRK) WRITE(IW,9500)
            ntimout=1
            goto 590
          ENDIF
c
          if(nstjob.ne.0.and.lijfg.le.nstjob) then
            if(mygroup.lt.loadgr) then
              jbtyp=0
              ngroups=loadgr
              clrcow=.true.
c             temporarily switch to static load balancing and use the reduced
c             number of groups in GDDICOUNT too.
            else
c             otherwise skip the static jobs
              goto 450
            endif
          endif
c
c         reset the inner counter before switching to dynamic load balancing.
c         do not reset the global counter itself.
          if(isgddi.and.clrcow.and.jbtyp.gt.0) then
c           write(6,*) 'wwwClearing the counter'
            call GDDICOUNT(-1,lgroup,myjob)
            clrcow=.false.
          endif
c
          if(isgddi) then
            call GDDICOUNT(0,lgroup,myjob)
            ngroups=ngrsav
            jbtyp=jbsav
            if(.not.myjob) goto 450
          endif
          if(haver) rij=fmodist(ifg,0,0,jfg)
          l1i=iand(numfrg(ifg),65535)
          l1j=iand(numfrg(jfg),65535)
          nai=ishft(numfrg(ifg),-16)
          naj=ishft(numfrg(jfg),-16)
          SCFi=scffrg(ifg)
          SCFj=scffrg(jfg)
          iodexch=scfi.eq.rmc
          jodexch=scfj.eq.rmc
          l2i=(l1i*l1i+l1i)/2
          l2j=(l1j*l1j+l1j)/2
c         LL1 printed below is an overestimate of the true L1,
c         used only for print-out.
          ll1=l1i+l1j
          if(dolat) then
c           Assume equal size fragments!
            ig=1
            jg=klms(4,iu)
            indi=(ifg-1)*maxl2+1
            indj=(jfg-1)*maxl2+1
            call dcopy(l2i,esplat(indi,ig),1,esp1i,1)
            call dcopy(l2j,esplat(indj,jg),1,esp1j,1)
          endif
          addespij=addesp.and.(rij.gt.zero.or.addesp0).and.
     *            (rij.le.resdim.or.resdim.eq.zero)
          if(addesp) then
            iskipesp=0
            if(addespij) iskipesp=1
          endif
          if(addespij) then
c           ADDESP option supports size-based load balancing (LOADHF),
c           and IFG can come in "random" order.
            call CLOSDA('DELETE')
            CALL OPENDA(0)
            call makemol(ifg,0,0,ilay,0,0,0,0,0,0,0,.true.)
            nat0=nat
            call dcopy(nat,zan,1,czi,1)
            call dcopy(nat*3,c,1,czi(nat+1),1)
            irecv=(irec0-1)/2+nfg*4+1
            CALL rareads(IDAFMO,iodfmo,esp1i,l2i,irecv+ifg,0)
            CALL rareads(IDAFMO,iodfmo,esp1j,l2j,irecv+jfg,0)
            write(6,*) 'VI',irecv+ifg
            call prtril(esp1i,l1i)
            write(6,*) 'VJ',irecv+jfg
            call prtril(esp1i,l1j)
          endif
          if(dolat.or.addespij) then
            call pairvij(ilay,ifg,jfg,iu,nat0,natfmob,nunptc,untxyz,
     *                   cfrg,fmoespa,esp1i,esp1j,czi,czj,dolat)
          endif
          if(ipieda.ne.0.and.nfmopcm.gt.0) then
c           call epcmscr(da,db,ilay,lijfg,lijfg,l1i,l1i,orbxch,iodexch,
c    *                 iodexch,iodfmo,irec0,indat,XYZCTS,QSE,ISPHE,qtmp)
            call epcmscr(da,db,ilay,ifg,jfg,l1i,l1j,orbxch,iodexch,
     *                 jodexch,iodfmo,irec0,indat,XYZCTS,QSE,ISPHE,qtmp)
          endif
c         ijskip=0
          esd2m=emon(ifg,memon)+emon(jfg,memon)
          if(rij.gt.resdim.and.resdim.ne.zero .or. ipieda.ne.0) then
c           ijskip=1
c           compute energies of separated dimers.
c           note that no BSSE check is done which means for separated dimers
c           we ignore BSSE corrections (be it good or bad).
c           jfg and ifg are interchanged to have ifg<jfg order
c
c           esdim is called with DB because FMOESP overwrites DA
c
            esd2=esd2m
            if(flipsd.and.l1i.lt.l1j) then
              ifrg=jfg
              jfrg=ifg
              flipch='D'
            else
              ifrg=ifg
              jfrg=jfg
              flipch='d'
            endif
            call esdim(nder,jfrg,ifrg,esd2,rij,ilay,irec0,irec0,idmrec0,
     *                 layfrg,iodfmo,maxl30,scffrg,wrk,fmoespa,db,dij,
     *                 isdrec,orbxch)
            if(maswrk) then
              edim(ijfg,1)=edim(ijfg,1)+esd2
c             if(nfmopcm.ne.0) esolv(nfg+ijfg)=esolv(ifg)+esolv(jfg)
              write(iw,9020) flipch,ifg,jfg,ll1,edim(ijfg,1)
              call timit(1)
              if(rcorsd.ne.0) edim(ijfg,3)=edim(ijfg,1)
              if(ipieda.ne.0) then
                edim(ijfg,nedimes)=esd2-esd2m
                edim(ijfg,nedimex)=zero
              endif
            endif
c
c           For separated dimers we only get ENUC contribution to properties
c
            if(rij.gt.resdim.and.resdim.ne.zero) then
              if(maswrk) enucfmo=enucfmo+enucr
              lie=.true.
              goto 440
            endif
c           Else repeat the dimer with SCF
          endif
c         NEVALS=0
          icurfg=0
          SCFTYP0=SCFTYPi
c         if(iodexch.or.jodexch) SCFTYP0=rmc
c         Reset to RHF if both fragments are RHF (assuming for now SCFi=SCFj)
          if(.not.iodexch.and..not.jodexch) SCFTYP0=SCFi
c         if(scftypi.ne.rmc.and.SCFTYP0.eq.rmc) SCFTYP0=scftypi
c         same as in monoscf, SCFTYP0 may be altered only after odexch is set.
          SCFTYP=SCFTYP0
          if(rcorsd.ne.0.and.correl) then
c           check if MOLFRG option further restricts the correlation
            ires=molfrg(ifg)+molfrg(jfg)
            if(exclmol) then
              skipc=ires.ge.0.and.ires.ne.2
            else
              skipc=ires.eq.0.or.ires.eq.2
            endif
            if(tddfti.ne.rnone) then
             if(iexcit(1).ne.ifg.and.iexcit(1).ne.jfg.or.
     *          iexcit(2).lt.2) skipc=.true.
            endif
            if(rij.gt.rcorsd.or.skipc) then
              mplevl=0
              cctyp=rnone
              cityp=rnone
              tddftyp=rnone
              if(skipc.and.maswrk) write(iw,9050) ifg,jfg
            else
              mplevl=mplevli
              cctyp=cctypi
              cityp=citypi
              tddftyp=tddfti
c             DAF records
c              16 contains MP2 density (1st order)
c             308 contains SCF density (0th order)
            endif
          endif
          doddcori=MPLEVL.gt.0.and.(MPPROP.ne.0.or.nder.gt.0).or.
     *             cityp.ne.rnone.or.(tddftyp.ne.rnone.and.nder.gt.0)
          irecd=16
          if(doddcori) irecd=308
          if(maswrk) then
            if(dolat) then
              write(iw,9002) scftyp0,ifg,jfg,iu,ll1,mplevl,cctyp,cityp
            else
              write(iw,9000) scftyp0,ifg,jfg,ll1,mplevl,cctyp,cityp,
     *                       TDDFTYP
            endif
          endif
          call CLOSDA('DELETE')
          CALL OPENDA(0)
          if(iu.eq.0) then
            call makemol(ifg,jfg,0,ilay,0,0,0,0,0,0,0,.true.)
          else
c           for PBC runs with propagated cells one has to add JFG using
c           new propagated coordinates, so that makmol has to be split
c           (IFG - original cell, JFG - propagated).
            call makemol(jfg,0,0,ilay,0,nat0,nsh0,ngau0,ne0c,ich0,
     *                   mul0,.true.)
          endif
c
          if(moncor.ge.0) moncor=0
c         fmonad sets norb.
          if(iodexch) then
            if(moncor.ge.0) moncor=naj
            call fmonad(idum1,idum2)
            nai=nactfmo
          endif
          if(jodexch) then
            if(moncor.ge.0) moncor=nai
            call fmonad(idum1,idum2)
            naj=nactfmo
          endif
c
          l1=num
          l2=(l1*l1+l1)/2
          l3=l1*l1
          if(maswrk) enucfmo=enucfmo+enucr
c         nai and naj for RHF are NA (the number of alpha electrons)
c         for MCSCF they become the number of occupied orbitals
          if(maswrk.and.labsiz.ne.labsix) write(iw,9005) labsiz,labsix
         if(maswrk.and.NINTIC.ne.0) write(iw,9007) LABSIZ,NINTIC,ININTIC
c
c       Compute dimer initial density
c
          call diminid(0,jfg,ifg,l1j,l1i,naj,nai,l1,da,db,wrk,wrk1,
     *                 iodfmo,irec0,iabdfg,jabdfg,indat,iaglob,locfmo,
     *                 mapj,mapi,orbxch,enexch,jodexch,iodexch,
     *                 iu,untrot(1,1,iu),some)
          if(dolat.or.addespij) then
            call addv2(l1,l2,mapi,mapj,esp1i,esp1j,fmoespa)
c           write(6,*) 'VIJ'
c           call prtril(fmoespa,l1)
          endif
c         do lfg=1,nfg
c           if(lfg.ne.ifg.and.lfg.ne.jfg) then
c             write(6,*) 'Distance map for dimer',ifg,jfg,lfg
c             call mapdist(wrk,indat,indatg,iaglob,ifg,jfg,0,lfg)
c           endif
c         enddo
          call dcopy(l2,da,1,dij,1)
c         write(6,*) 'wwwinidens'
c         call prtril(da,l1)
          igot=0
c         The second l1 in fmorvec should be L0; however, L0 is unknown yet,
c         because initial guess has not been called.
          if(orbxch) call fmorvec(ifg,jfg,ijvec,l1,l1,da(1+l2),igot)
          if(mod(nguess/2,2).eq.0.and.igot.eq.0) then
            write(6,*) 'running Huckel guess for dimer'
            ifmostp=3
            icurfg=0
            jcurfg=0
            kcurfg=0
            CALL ONEEI
            NEVALS=0
            call vclr(wrk,1,l1)
            CALL dawrit(IDAF,IODA,wrk,l1,17,0)
            CALL GUESMO(GUESS)
          endif
          ifmostp=4
          icurfg=ifg
          jcurfg=jfg
          kcurfg=0
c           MCONV=mcnvfmo(ifmostp)
c         if(SCFTYP.eq.rmc) call readcas
          fordir=forcedir(nintic*nproc,l1dir,l1,maswrk)
          if(nintic.ne.0.and.scftyp.eq.rmc.and.goparr) fordir=.true.
          iconvij=-1
          call fmocvij(ifg,jfg,0,mconvex,mconfg(nfg+1),iconvij)
          call fmoconv(mcnvfmo(ifmostp),iconvij,l1,wrk,enexch,orbxch,
     *                 irststp.le.3.or.iter0.eq.0,.false.,fordir)
          iter0=1
c         It may be a good idea to call MCIN to be sure
          if(irststp.gt.ifmostp.and.edim(ijfg,1).ne.zero) goto 430
c         skip dimer energy for restart jobs ifmostp=5.
c
          NEVALS=NEVALS+1
          irestsav=irest
c
          tightint=(iand(nprfrg(ifg),32).ne.0.or.iand(nprfrg(jfg),32)
     *              .ne.0).and.DIRSCF.and.FDIFF
          icutsav=icut
          if(tightint) then
            icut=icut+1
            if(maswrk) write(iw,9203) icut
          endif
          nprsav=nprint
          if(cityp.ne.rnone) nprint=7
c
c         Compute PCM correction to the dimer energies. Note that
c         nuclear potential is also computed but at present extravagantly.
c
          if(nfmopcm.ne.0) then
c           ida=1
c           if(nfmopcm.gt.2) ida=ida-ndtfrg(ijfg,1)
c           if(nfmopcm.lt.2) ida=0
            ida=0
            call pcmnup(ida,vnuc)
          endif
c
c         Run RHF before DFT or MCSCF
c
          if(SCFTYP0.eq.rmc.and.prerhf) then
            CALL daread(IDAF,IODA,wrk,L3,15,0)
c           write(6,*) 'www1: Initial orbitals'
c           call prsq(wrk,l1,l1,l1)
            SCFTYP=RHF
            mvoqsav=MVOQ
            MVOQ=6
            call fmosdir(0,fmodscf,fmodtrf)
            CALL BRNCHX(energy)
c           This code is not quite ready for non-singlets
            call fmosdir(1,fmodscf,fmodtrf)
            MVOQ=mvoqsav
            if(iand(nguess,16384).ne.0) then
c             old style matching: match blindly
              call fmodor(enexch,wrk,da(1+l2),da,da(1+l2+l3),wrk(l3+1),
     *                    wrk(l3+l1+1),wrk1,nai+naj,l1,l2,l3)
            else
c             new style: match CAS orbitals and then fill in the core as left.
              call matchcas(enexch,wrk,da(1+l2),da,da(1+l2+l3),wrk(l3+1)
     *                     ,wrk(l3+l1+1),wrk1,nai+naj,ncasfmo,l1,l2,l3)
            endif
c           write(6,*) 'www1.5: RHF orbitals'
c           call prsq(da(1+l2),l1,l1,l1)
            if(copycore) then
c
c             Use RHF core for MCSCF core, but restore MCSCF active orbitals
c             (that is, use monomer MCSCF orbitals).
c             wrk holds initial orbitals (most likely, obtained by
c             adding two monomer sets), da will store converged RHF set.
c
c             Possibly rid of fractioned bond projections (projact).
c             Project initial MCSCF orbitals.
c
            if(projact) call projgues(l1,l2,wrk,db(1+l2+l3),db(1+l2),db)
c           write(6,*) 'www2: Projected orbitals',l1
c           call prsq(wrk,l1,l1,l1)
              ncoremc=nai+naj-ncasfmo
              nshift=1+ncoremc*l1
c             copy LCAO coeffiecints for the MCSCF monomer into dimer MOs
c             while keeping RHF dimer LCAO coeffiecints for other AOs.
              call nzcopy(l1*ncasfmo,wrk(nshift),1,da(nshift+l2),1)
c           write(6,*) 'www3: Final orbitals',ncoremc,ncasfmo
c           call prsq(da(1+l2),l1,l1,l1)
              CALL dawrit(IDAF,IODA,da(1+l2),L3,15,0)
            endif
            irest=2
c           since we run CAS again
          endif
c
          if(dftype.ne.rnone.and.prerhf) then
            DFTYPE=rnone
            NDFTFG=0
            DFTTYP(3)=1.0D+00
            LCFLAG=.false.
            CALL BRNCHX(energy)
            NDFTFG=ndftsav
            dftype=dftsav
            DFTTYP(3)=hfssav
            LCFLAG=lcsav
            irest=2
          endif
          SCFTYP=SCFTYP0
          IRSTLsav=IRSTLAY
          IRSTLAY=moncor+nactfmo
          if(moncor.lt.0) IRSTLAY=nai+naj
c         write(6,*) 'wwwIRSTLAY',nai,naj,IRSTLAY
          call fmosdir(0,fmodscf,fmodtrf)
c
          CALL BRNCHX(RUNTYP)
c         Try converging once again with an alternative converger
          if(etot.eq.0.and.desperate) then
            if(maswrk) write(iw,9300)
c           Increase accuracy of DIRSCF/FDIFF.
            if(DIRSCF.and.FDIFF) icut=icut+1
c           to reuse integrals
            irest=2
            if(despread) then
c             do not use density from the previous run that failed, use the
c             pristine one (otherwise continue converging).
              CALL dawrit(IDAF,IODA,dij,L2,16,0)
              if(orbxch) then
                write(iw,*) 'Not ready yet'
                call abrt
              endif
            endif
            call fmoconv(mcnvfmo(ifmostp),iconvij,l1,wrk,enexch,orbxch,
     *                   irststp.le.3.or.iter0.eq.0,.true.,fordir)
            CALL BRNCHX(RUNTYP)
c           for desperate runs abort if not converged.
            if(etot.eq.0) then
              if(maswrk) write(iw,9310)
c             call abrt
              if(maswrk) nodesper=nodesper+1
            else
              if(maswrk) ndesper=ndesper+1
            endif
          endif
          call fmosdir(1,fmodscf,fmodtrf)
          IRSTLAY=IRSTLsav
          irest=irestsav
          icut=icutsav
          nprint=nprsav
          if(RUNTYP.ne.energy.and.etot.eq.0) then
c           if(maswrk) write(iw,9400)
            write(iw,9400)
            write(iw,*) 'zero energy?',meglob,RUNTYP,etot
            call abrt
          endif
c
          if(TDDFTYP.ne.rnone.and.rij.le.rcorsd.and..not.skipc) then
c
c        Monomer MO for TDDFT/HF calculations
c
            if (iexcit(4).gt.0) then
              if (ifg.eq.iexcit(1)) then
                call monovec(wrk,fmoespb,mapi,L1i,L1,ifg,irec0,iodfmo,
     *          orbxch,enexch,iodexch)
              else
                call monovec(wrk,fmoespb,mapj,L1j,L1,jfg,irec0,iodfmo,
     *          orbxch,enexch,iodexch)
              endif
            endif
            idfg=ifg
            if(ifg.eq.iexcit(1)) idfg=jfg
c        -- Excitation type check
            if(maswrk) then
            gopsav=goparr
            goparr=.false.
            call excheck(wrk,fmoespb,db,wrk1,nqmt,L1,NSTMONO,MONOC,MONVR
     *                  ,ICST,iexcit(4),idfg,eexfg,nocctdm,nvirtdm,na,
     *                   nqmt-na,exfid,ctdm)
c        -- Summing energy and transition dipole moment
            call tdesum(eexcit,texcit,IDXYZ,NSTMONO,ICST,ISUMD,
     *                  ifg,jfg,idfg,rij,eexfg)
            goparr=gopsav
            endif
c
          endif
c
c         write(iw,*) 'Final 2e ESP is'
c         call prtril(wrk,l1)
c         CALL daread(IDAF,IODA,da,l2,irecd,0)
c         call vsub(dij,1,da,1,db,1,l2)
c         call prtril(db,l1)
c         db holds DIJ-DI-DJ
c         dijc=TRACEP(db,wrk,l1)
c         write(6,*) 'wwwcorr',ifg,jfg,' Ec=',dijc
c
c         properties must be computed with the highest correlated density
          if(primul) then
            if(NPTSTN.ne.0) then
              if(nprint.eq.-5.or.ISKPRP.ne.0) call stone(ip,rnone)
              call dcopy(nat,stonep,1,wrk1,1)
            else
              CALL daread(IDAF,IODA,da,l2,16,0)
              CALL daread(IDAF,IODA,db,l2,12,0)
              call vclr(wrk,1,l1)
              call mulpop(l1,da,db,wrk)
              call mulpopa(wrk,wrk1)
            endif
          if(maswrk) ctdim(ijfg)=ctpair(ifg,jfg,wrk1,popmat(1,1,icurpop)
     *                                 ,indat,iaglob,ialoc,indbd,imect)
          endif
c         3-body properties with correlation are not finished. One would have
c         to put a loop from 1 to 2 here, similar to monoscf. The only
c         finished 3-body properties are those in extracc for FMO-CC
c         (and the 3-body correlation energy). BUT NOT dipole moments nor
c         gradients.
          if(nbody.gt.2) then
            ida=-ndtfrg(ijfg,1)
            ida2=-ndtfrg(ijfg,2)
c           For trimers Dij contribution is needed per se, saved in
c           fmoelmt(1,2) and then explicitly added to the dimer sum
c           (that contains not only Dij but Di and Dj).
            call vclr(fmoelmt(1,2),1,nfmoelm)
            call addprop(2,primul,primul,1,ida,1,iaglob,wrk1,nfmoelm,
     *                   fmoelmt(1,2),fmoelmt,fmoelmt,atmulq,
     *                   atmulq(natfmo+1),atmulq)
            call daxpy(nfmoelm,one,fmoelmt(1,2),1,fmoelmd,1)
          else
            ida=0
            ida2=0
            call addprop(2,primul,primul,1,ida,1,iaglob,wrk1,nfmoelm,
     *                   fmoelmd,fmoelmt,fmoelmt,atmulq,atmulq,atmulq)
          endif
c         if(primul.and.maswrk) ctdim(ijfg)=ctpair(ifg,jfg,wrk1,
c    *               popmat(1,1,icurpop),indat,iaglob,ialoc,indbd,imect)
          if(cctyp.ne.rnone.and.maswrk)
     *      call addecc(2,0,1,ida2,extracc,nextracc)
          CALL daread(IDAF,IODA,da,l2,irecd,0)
c
          if(totdens) call fmototd(1+ida,l2,da,totd,iaoglob)
          if(densgrid) then
          call grdbox(ixmin,ixmax,iymin,iymax,izmin,izmax,vdwrad,grdpad)
            call fmoprc(1+ida,1,l2,da,dgrid,1,NXG,1,NYG,1,NZG,
     *                  ixmin,ixmax,iymin,iymax,izmin,izmax,0,0,0,0,0,0,
     *                  ORIGIN,UX,UY,UZ)
          endif
          if(spargrid) then
c           Compute the total density on a sparse grid
c           First compute on the grid for fragment J (J<I).
            joff=noffg(jfg)
            call fmoprc(1+ida,1,l2,da,dgrid(joff,2),indgrd(1,jfg),
     *                  indgrd(2,jfg),indgrd(3,jfg),indgrd(4,jfg),
     *                  indgrd(5,jfg),indgrd(6,jfg),indgrd(1,jfg),
     *                  indgrd(2,jfg),indgrd(3,jfg),indgrd(4,jfg),
     *                  indgrd(5,jfg),indgrd(6,jfg), 0,0,0,0,0,0,
     *                  ORIGIN,UX,UY,UZ)
c           Now compute on the grid for fragment I excluding J's grid.
            ioff=noffg(ifg)
            call fmoprc(1+ida,2,l2,da,dgrid(ioff,2),indgrd(1,ifg),
     *                  indgrd(2,ifg),indgrd(3,ifg),indgrd(4,ifg),
     *                  indgrd(5,ifg),indgrd(6,ifg),indgrd(1,ifg),
     *                  indgrd(2,ifg),indgrd(3,ifg),indgrd(4,ifg),
     *                  indgrd(5,ifg),indgrd(6,ifg),indgrd(1,jfg),
     *                  indgrd(2,jfg),indgrd(3,jfg),indgrd(4,jfg),
     *                  indgrd(5,jfg),indgrd(6,jfg),ORIGIN,UX,UY,UZ)
          endif
c
c         the second fmoelmt is dummy
c         if(ijskip.ne.0) goto 315
c
c         call DENDD1(DA,DB,L2)
          dele=TRACEP(da,fmoespa,l1)
          if(maswrk) then
            edim(ijfg,1)=etot-dele
c         ESCF may not be available. It is safer to use the value from previous
c         iteration (if available). delE is the same for correlated/
c         uncorrelated cases as the density is the same (e.g., MP2 and RHF).
            if(rcorsd.ne.0) edim(ijfg,3)=escf-dele
            if(etot.eq.zero) edim(ijfg,1)=zero
            if(ipieda.ne.0) edim(ijfg,nedimex)=
     *                        e0scf(1)-esd2m-edim(ijfg,nedimes)
c           write(6,*) 'wwwaha',ijfg,e0scf(1),esd2m,edim(ijfg,nedimes),
c    *                          edim(ijfg,nedimex)
          endif
c
c         if(nbsse.eq.3) CALL dawrit(IDAF,IODA,da,L2,16,0)
c             CALL dawrit(IDAF,IODA,fmoespb,L2,16,0)
c         if(nbsse.eq.0.or.nbsse.eq.3) then
          if(usedij) then
c           dij holds DI+DJ, subtract from DIJ
c           call daxpy(l2,-one,dij,1,da,1)
            call vsub(dij,1,da,1,db,1,l2)
c           db holds DIJ-DI-DJ
            if(maswrk) edim(ijfg,2)=TRACEP(db,fmoespa,l1)
c           if(needdm) then
c             call GDDI_PUT(iddm,ijfg,l2,db)
c             if(maswrk) job2grp(ijfg)=meglob+nprocg
c           endif
            if(fmoq.or.needdm) then
              l2all=l2
c             l2all should be max(L){l2(L)}, the max value over layers:
c             now MFMOQ FMO3/ESapp must have the same basis set.
              CALL rawrites(IDAcFMO,iodcfmo,db,l2all,l2,ijfg,0)
              if(maswrk) job2grp(ijfg)=l1*npglob+mygroup
c             write(6,*) 'wwwdens',ijfg
c             call prtril(db,l1)
            endif
c           write(6,*) 'wwwdens',ijfg
c           call prtril(db,l1)
c
            if(doddcori) then
c             one has to toil constructing DI+DJ again, this time correlated.
c             We do not want any orbitals or energies so set the options to .f.
              CALL daread(IDAF,IODA,dij,l2,16,0)
c             write(6,*) 'read dimer density from ',16
c             call prtril(dij,l1)
c             delec=TRACEP(dij,fmoespa,l1)
c             It is probably a bug to set orbxch to .false. below.
              call diminid(0,jfg,ifg,l1j,l1i,naj,nai,l1,da,db,wrk,wrk1,
     *                iodfmo,irec0cor,iabdfg,jabdfg,indat,iaglob,locfmo,
     *                mapj,mapi,.false.,.false.,.false.,.false.,
     *                iu,untrot(1,1,iu),some)
c             da holds correlated DI+DJ, dij holds correlated DIJ.
c             put DIJ-DI-DJ into db.
              call vsub(da,1,dij,1,db,1,l2)
c             write(6,*) 'den'
c             call prtril(dij,l1)
c             write(6,*) 'V'
c             call prtril(fmoespa,l1)
              if(maswrk) edim(ijfg,4)=TRACEP(db,fmoespa,l1)
              if(nbsse.ne.0) CALL daread(IDAF,IODA,da,l2,irecd,0)
c             the BSSE code although not really ready for doddcor is expecting
c             to find the dimer density in DA.
c             correct E'(MP2) for dimers:
c             it is up to now: EMP2-Tr(D(RHF)V)
c             it should be:    EMP2-Tr(D(MP2)V)
c             dele contains Tr(D(RHF)V), delec contains Tr(D(MP2)V)
c
c             This is the latest fix to replace the delta-D (MP2) by RHF.
c             To put back, uncomment the edim(ijfg,1) assignment below.
c
c             if(maswrk) edim(ijfg,1)=edim(ijfg,1)+dele-delec
            endif
            if(dopleda) then
c             construct (DIJ-DI-DJ) for PL0 densities and compute its trace
c             with VIJ. Store this in edim(*,4), overwriting those values
c             which are set if doddcor. Note that edim(*,4) in doddcor
c             although computed, is not used for anything.
              if(maswrk) edim(ijfg,4)=TRACEP(da,fmoespa,l1)
              call diminid(0,jfg,ifg,l1j,l1i,naj,nai,l1,da,db,wrk,wrk1,
     *                iodfmo,irec0cor,iabdfg,jabdfg,indat,iaglob,locfmo,
     *                mapj,mapi,orbxch,.false.,.false.,.false.,
     *                iu,untrot(1,1,iu),some)
              if(maswrk) edim(ijfg,4)=edim(ijfg,4)-TRACEP(da,fmoespa,l1)
c             write(6,*) 'wwwhi',edim(ijfg,4)
            endif
          endif
          if(maswrk) then
            if(correl) then
              write(iw,9110) ifg,jfg,edim(ijfg,1)
              write(iw,9100) ifg,jfg,edim(ijfg,3),edim(ijfg,2)
            else
              write(iw,9100) ifg,jfg,edim(ijfg,1),edim(ijfg,2)
            endif
          endif
  430     continue
c
c       Compute BSSE corrections
c
          if(nbsse.ne.0) then
            ifmostp=5
c           MCONV=mcnvfmo(ifmostp)
c           -1 should be replaced by mconfg for that fragment.
            call fmoconv(mcnvfmo(ifmostp),-1,l1,wrk,enexch,orbxch,
     *                   .false.,.false.,fordir)
c           if doing vaccuum BSSE rerun dimer in vaccuum
c           if(nbsse.eq.3) then
c             if(maswrk) write(iw,9005) ifg,jfg
c             CALL BRNCHX(RUNTYP)
c             edim(3,ijfg)=etot
            if(nbsse.ne.3) then
              call dcopy(l2,da,1,dij,1)
              if(maswrk) edim(ijfg,5)=edim(ijfg,1)
            else
              if(maswrk) edim(ijfg,5)=zero
            endif
c           the following is used below: ifg >= jfg
c           this is why jfg must be run first (ij.eq.1)
            do ij=1,2
              if(maswrk.and.ij.eq.1) write(iw,9010) scftyp,jfg,ifg
              if(maswrk.and.ij.eq.2) write(iw,9010) scftyp,ifg,jfg
              if(ij.eq.1) then
                icurfg=jfg
                jcurfg=ifg
                scftyp=scfi
              else
                icurfg=ifg
                jcurfg=jfg
                scftyp=scfj
              endif
              kcurfg=0
              call makesbs(ij,icurfg,zsave,nesav,indat,iaglob)
c
c             Initial guess density
c
              call diminid(ij,jfg,ifg,l1j,l1i,naj,nai,l1,da,db,wrk,wrk1,
     *                     iodfmo,irec0,iabdfg,jabdfg,indat,iaglob,
     *                     locfmo,mapj,mapi,orbxch,enexch,jodexch,
     *                     iodexch,iu,untrot(1,1,iu),some)
c
              call fmosdir(0,fmodscf,fmodtrf)
c             CALL BRNCHX(RUNTYP)
c             it is possible to compute BSSE gradient. But for now only energy
c             (that is, gradient is computed without BSSE).
              CALL BRNCHX(energy)
              call fmosdir(1,fmodscf,fmodtrf)
c
              if(nbsse.ne.3) then
                call DENDD1(DA,DB,L2)
                if(maswrk)
     *            edim(ijfg,5)=edim(ijfg,5)-(etot-TRACEP(da,fmoespa,l1))
c               dij holds DIJ, substract DI and DJ
                call daxpy(l2,-one,da,1,dij,1)
              else
c               edim(5) contains the sum of I and J energies in the I+J basis
                if(maswrk) edim(ijfg,5)=edim(ijfg,5)+etot
              endif
            enddo
c           dij holds DIJ-DI-DJ
            if(nbsse.ne.3.and.usedij.and.maswrk)
     *        edim(ijfg,6)=TRACEP(dij,fmoespa,l1)
          endif
c 315     continue
          if(nfmopcm.ne.0) then
            if(nfmopcm.gt.1.and.dovpcm) then
              ida=1
              if(nfmopcm.gt.2) ida=ida-ndtfrg(ijfg,1)
              fda=-ida
              call EPOTEN(fda,XYZCTS(1,1),XYZCTS(1,2),XYZCTS(1,3),PEL,
     *                    da,NTS,L2)
            endif
            if(maswrk) esolv(nfg+ijfg)=(PC-PX)*half
          endif
          if(ndftfg.eq.1.and.maswrk) then
            fda=1+ida
            call daxpy(nedft,fda,edft,1,etotdft,1)
          endif
c
c         accumulate gradient
c
c         if(nbody.eq.2) ida=0
c         ida=ida+1
          idad=1
          if(ilay.eq.1.and.ext2lay) idad=idad+nddfrg(ijfg)
          if(nder.gt.0.and.runtyp.ne.energy.and.maswrk) then
            if(idad.ne.0) call fmodeg(idad,fmode(1,1,2),fmopg,iaglob)
            if(nbody.gt.2.and.idad+ida.ne.0)
     *        call fmodeg(idad+ida,fmode(1,1,3),fmopg,iaglob)
            if(nbody.eq.2.and.ext2lay)
     *        call fmodeg(1,fmode(1,1,3),fmopg,iaglob)
c             effectively, this is always ilay=2 (since nbody(1)=3,2)
            IF (IEFPFMO.EQ.1) THEN
              CALL EFPDEG(1,2)
              if(nbody.gt.2.and.1+ida.ne.0) CALL EFPDEG(1+ida,3)
            ENDIF
          endif
C
          IF (NDER.GT.0.AND.RUNTYP.NE.ENERGY.AND.
     *       IAND(MODGRD,2).NE.0)                THEN
            CALL FMOESDER(l1,l2,da,layfrg,scffrg,idmrec0,da,wrk1,
     *                    mapi,mapj,mapi,1,irec0, 0,0,0,
     *                    orbxch,enexch,.false.,jodexch,iodexch)
          ENDIF
C
          IF (IEFPFMO.EQ.1.AND.NDER.GT.0) CALL DEFPCLR
c
          if(npunch.ne.0.and.PLTORB) CALL PLTMEM
c
c         save data for restarts
c         synchronise the format with edin
c
  440     continue
          if(savgrd) call grdrst(1,nfthes,ngrdsiz,fmode,nelmsiz,fmoelm,
     *                  nesdsiz,isdrec,lie,IDAFMO,ndar30,NDAR30i,iodfmo)
  445     continue
          if(maswrk) then
            write(ip,9210) ifg,jfg,ilay,(edim(ijfg,ien),ien=1,nen)
          endif
c
  450   continue
        if(dolat) then
          call dcopy(3*natfmob,untxyz,1,cfrg,1)
          call monbsr(nat0,ich0,mul0,num0,nqmt0,ne0,na0,nb0,nsh0,ngau0
     *          ,enucr0,nat,ich,mul,num,nqmt,ne,na,nb,nshell,ngau,enucr)
        endif
        njfg=nfg
  500 continue
      enddo
  590 continue
      if(iand(ixesp,1024).ne.0) ixesp=ixesp-1024
      call timit(1)
      CALL TSECND(TIMe0)
      wall0=wall
      if(isgddi) call GDDICOUNT( 1,lgroup,myjob)
      CALL TSECND(TIMe1)
      if(maswrk) write(iw,9600) 'Dimer',wall-wall0
      write(ip,9200) END
c
c     finish up separated dimer gradients.
c
      if(esd) call esdgrd(ilay,loadhf,jobgrp,loadm,layfrg,numfrg,iodfmo,
     *                    maxl30,iaglob,scffrg,ngrfmo,mannod,mastid,da,
     *                    fmoespa,fmoespb,wrk1,fmode,fmopg,isdrec,
     *                    orbxch,irec0)
c
c     exchange dimer job indices.
c
c     if(needdm.and.isgddi) then
c       call gddi_scope(ddi_world)
c       call ddi_gsumi(2418,job2grp,nfg2)
c       call gddi_scope(ddi_group)
c       write(6,*) 'job2grp',(job2grp(i),i=1,nfg2)
c     endif
      if(needdm.and.isgddi)
     *  call ddexch(ilay,nfg2,job2grp,layfrg,IDAcFMO,iodcfmo,mastid,da)
      if(desperate) then
        if(isgddi) then
          call gddi_scope(ddi_world)
          idum=0
          call DDI_nsumi(2423,ndesper,nodesper,idum,idum,2)
          call gddi_scope(ddi_group)
        endif
        if(maswrk) write(iw,9320) ndesper,nodesper
c       if(nodesper.ne.0) call abrt
      endif
      call timit(1)
      return
 9000 format(/1x,A8,' dimer',2I5,', LL1=',I4,
     *           ' (MP',I1,', CC=',A8,', CI=',A8,', TD=',A8,').',/)
 9002 format(/1x,'Running ',A8,' dimer',2I5,'(',I5,')',' LL1=',I4,
     *           '(MP',I1,',CC=',A8,',CI=',A8,').',/)
 9005 format(/1x,'Resetting LABSIZ=',2I2,/)
 9007 format(1x,'Int dimensions: LABSIZ=',I1,', NINTIC=',I9,
     *          ' ININTIC=',I9)
c9005 format(/1x,'Running energy for dimer ',2I4,' in vaccuum',/)
 9010 format(/1x,'Running ',A8,' energy for monomer',I5,
     *           ' including the basis set for fragment',I5/)
 9020 format(/1x,'energy of the separated ',a1,'imer',2I5,', L1=',I5,
     *           ' is',F20.9/)
 9050 format(/1x,'No electron correlation for the dimer',2I5/)
 9100 format(/1x,' iFrag=',I5,' jFrag=',I5,' EFMOu=',F16.9,' Tr=',F12.9)
 9110 format(/1x,' iFrag=',I5,' jFrag=',I5,' EFMOc=',F16.9)
 9200 format(a8)
 9203 format(1x,'Using tighter ICUT=',I2)
 9210 format(1x,2I5,I3,3F22.10,2(/14x,3F22.10))
c9215 format(1x,2I5,I3,3F22.10,/14x,3F22.10)
 9300 format(/1x,'Trying desperately the alternative SCF converger.')
 9310 format(/1x,'Despite trying desperately, SCF did not converge.')
 9320 format(/1x,'Desperately converged',I5,', diverged',I5,' dimers.',
     *           /)
 9400 format(/1x,'Gradient requires converged SCF.',/)
 9500 format(/1x,'Running out of time...',/)
 9600 format(/1x,A5,' synchronisation took',F8.1,' s.')
      END
C*MODULE fmo     *DECK esdim
      subroutine esdim(nder,iifg,jjfg,edimij,rij,ilay,irec0i,irec0j,
     *                 idmrec,layfrg,iodfmo,maxl30,scffrg,da,fa,db,fb,
     *                 isdrec,orbxch)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      Parameter(MXRT=100,MXATM=2000,zero=0.0D+00,one=1.0D+00)
      LOGICAL dosap,dospc,orbxch,odexch,full2e,esdder
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /FMCOM / X(1)
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      Common /fmoinf/ nfg,nlayer,natfmo,nbdfg,naotyp,nbody
      common /fmoopt/ espsca(9),RESPAP(2),rESPPC(2),rESDIM,restri(4),
     *                rcorsd,respct,convfg,cnvdmp,coroff,IXESP,mxitfg,
     *                nguess,NBSSE,modorb,modpar,irststp,irstlay,nprfmo,
     *                nfmopal,modprp,maxl1c,ipieda,modgrd,modesp,ivmul
      common /fmorun/ espscf,e0scf(2),IDAFMO,icurlay,icurfg,jcurfg,
     *                kcurfg,ncursh,ngau,icurpop,ifmostp,moncor,nat1e,
     *                needr,modrst,norbproj,nunesp,iskipesp,icurunt
      dimension idmrec(*),layfrg(*),iodfmo(*),maxl30(*),scffrg(*),da(*),
     *          fa(*),db(*),fb(*),isdrec(*)
      DATA rmc/8HMCSCF     /
c
c     compute energies of the separated dimer iifg,jjfg
c     Most work is done with monomer basis sets/coordinates.
c     parstat: GroupFull
c     For gradients runs Schwarz screening is less dense (more integrals are
c     computed compared to energy runs) due to simultaneously contracting two
c     densities (for each monomer in the dimer), thus very minor differences
c     in energies (with and without gradients) may be observed.
c
      ifmostp=6
c
c     Note on DB: ONEEI  puts 1e ESP into DB by using pointers.
c     Note on FA: FMOESP puts 2e ESP into FA by using pointers (and adds DB).
c
      dosap=respap(2).ne.zero
      dospc=resppc(2).ne.zero
      esdder=nder.gt.0.and.iand(ixesp,32).eq.0
c
c     2nd bit of modpar needs to be reset to enforce ESP shell parallelisation
c     because here we have only one fragment and fragment par. is no good!
c
      modpars=modpar
      if(iand(modpar,2).ne.0) modpar=modpar-2
c
      full2e=(rij.le.respap(2).or..not.dosap).and.
     *       (rij.le.resppc(2).or..not.dospc)
c     There are two symmetric contribution (I-J and J-I) to dimer energies.
c     It is not important now that for ij=1 ifg<jfg.
      enucrij=zero
c     l1i=0
      l2i=0
      do ij=1,2
        if(ij.eq.1) then
          ifg=iifg
          jfg=jjfg
          irec0=irec0i
        else
          ifg=jjfg
          jfg=iifg
          irec0=irec0j
        endif
        icurfg=0
c       if(maswrk) CLOSE(UNIT=IDAF,STATUS='DELETE')
        call CLOSDA('DELETE')
        CALL OPENDA(0)
        call makemol(ifg,0,0,ilay,0,0,0,0,0,0,0,.false.)
        l1=num
        l2=(l1*l1+l1)/2
        enucrij=enucrij+enucr
c
c       add Tr(DI*uJ) and, possibly, Tr(DI*vJ), if the latter is
c       done with point charges.
c       secret arguments to fmoesp
        icurfg=ifg
        jcurfg=jfg
        kcurfg=0
c       3rd argument is dummy (Hamiltonian)
        nat1es=nat1e
        nat1e=1
        if(full2e) nat1e=2
c       if doing full I-J ESP, do only lower triangle (symmetric).
c       if(full2e.and.jfg.gt.ifg) nat1e=0
        if(full2e.and.ij.eq.1) nat1e=0
        odexch=scffrg(ifg).eq.rmc
        call readmond(da,orbxch.and..not.odexch,.false.,na,l1,iodfmo,
     *                ifg+irec0)
        call fmoesp(l1,l2,x,layfrg,scffrg,idmrec)
        nat1e=nat1es
c       add Tr(DI*uJ)+Tr(DI*vJ)+EN
c       enucr (EN) is set in fmoesp as epot.
        edimij=edimij+TRACEP(da,fa,l1)
c
c       if(.false.) then
        if(ij.eq.2.and.esdder) then
c         Here we write to the 3rd block reserved for beta densities.
c         This should be changed when FMO-ROHF is implemented.
          nreci=1+iifg+nfg
          nrecj=1+jjfg+nfg
          if(isdrec(nreci).eq.0) then
            call vclr(db,1,l2i)
          else
            CALL rareads(IDAFMO,iodfmo,db,l2i,nreci,0)
          endif
          call daxpy(l2i,one,fb,1,db,1)
          imxl30=maxl30(iifg)
          CALL rawrites(IDAFMO,iodfmo,db,imxl30,l2i,nreci,0)
          isdrec(nreci)=1
c         write(6,*) 'Saved Vm',l1i,l2i,nreci
c         call prtril(db,l1i)
          if(isdrec(nrecj).eq.0) then
            call vclr(db,1,l2)
          else
            CALL rareads(IDAFMO,iodfmo,db,l2,nrecj,0)
          endif
          call daxpy(l2,one,fa,1,db,1)
          imxl30=maxl30(jjfg)
          CALL rawrites(IDAFMO,iodfmo,db,imxl30,l2,nrecj,0)
          isdrec(nrecj)=1
c         write(6,*) 'Saving Vm',l1,l2,nrecj
c         call prtril(db,l1)
        endif
c       l1i=l1
        l2i=l2
c
c       Memo on array usage for separated dimer gradients
c       ij=1: lmoespa (aka fa) contains FI
c       ij=1: lwrkesp (aka fb) contains FI
c       ij=2: lmoespa (aka fa) contains FJ+GJ
c       ij=2: lwrkesp (aka fb) contains FI+GI
c       where F and G stand for one and two-electron contributions to ESPs
c       (subscript I means that matrix elements are for AOs in I).
c       fb is not used if only energy is computed.
c
      enddo
c     epot is set in FMOESP for ifg>jfg
      edimij=edimij+epot
c     edimij=edimij+emoni+emonj+epot
      enucr=enucrij+epot
c     enucrij is enuc(i)+enuc(j)
c     epot is deltaEnuc(ij) (cross term).
      modpar=modpars
      ifmostp=3
      return
      end
C*MODULE fmo     *DECK etrimer
      subroutine etrimer(ilay,nder,runtyp,loadhf,loadt,layfrg,numfrg,
     *                   iodfmo,indat,iaglob,da,db,dc,wrk,wrk1,dij,
     *                   fmoespa,etrim,fmode,fmopg,atmulq,nfmoelm,fmoelm
     *                  ,iabdfg,jabdfg,locfmo,molfrg,scffrg,mapi,mapj,
     *                   map3,mcnvfmo,mconvex,mconfg,correl,mplevli,
     *                   CITYPi,CCTYPi,tddfti,nfg3,nent,nactfmo,maxl1d,
     *                   primul,orbxch,enexch,ntimout,job2grp,needdm,
     *                   nprfrg,totdens,totd,iaoglob,modmol,exclmol,
     *                   densgrid,dgrid,l1dir,grdpad,vdwrad,extracc,
     *                   nextracc,irec0,doddcor,esolv,dovpcm,etotdft,
     *                   nedft,XYZCTS,PEL,VNUC,IDAcFMO,iodcfmo,untrot,
     *                   stonep,some)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      integer ddi_world,ddi_group
      parameter (MXATM=2000,MXRT=100,MXGRID=10)
      parameter (zero=0.0D+00,one=1.0D+00,half=0.5D+00)
      Parameter(ddi_world=0,ddi_group=1)
      logical myjob,isgddi,parout,INITGDDI,GOPARR,DSKWRK,MASWRK,DIRSCF,
     *        FDIFF,AIMPAC,RPAC,PLTORB,MOLPLT,some,orbxch,primul,enexch,
     *        iodexch,jodexch,kodexch,fmodscf,fmodtrf,prerhf,correl,
     *        needdm,totdens,densgrid,desperate,despread,forcedir,
     *        fordir,tightint,exclmol,skipc,doddcor,dovpcm,SG1
      character*8 tridek,end
      dimension layfrg(*),numfrg(*),iodfmo(*),indat(*),iaglob(*),da(*),
     *          db(*),dc(*),wrk(*),wrk1(*),dij(*),fmoespa(*),
     *          etrim(nfg3,*),fmode(3,natfmo,*),fmopg(3,*),atmulq(*),
     *          fmoelm(nfmoelm),iabdfg(*),jabdfg(*),locfmo(*),molfrg(*),
     *          scffrg(*),mapi(*),mapj(*),map3(maxl1d,3),loadt(*),
     *          mcnvfmo(*),mconfg(*),job2grp(*),nprfrg(*),totd(*),
     *          iaoglob(*),dgrid(*),vdwrad(*),extracc(nextracc,*),
     *          esolv(*),etotdft(*),XYZCTS(mxts,3),PEL(*),VNUC(*),
     *          iodcfmo(*),untrot(3,3,*),stonep(*)
      COMMON /DFGRID/ DFTTHR,DFTGTHR,SWOFF,SW0,BSLRD(137),NDFTFG,
     *                NRAD,NTHE,NPHI,NRAD0,NTHE0,NPHI0,
     *                NANGPT(MXGRID),NANGPT0(MXGRID),SG1
      COMMON /DFTPAR/ DFTTYP(20),EXENA,EXENB,EXENC,IDFT34,NAUXFUN,
     *                                                    NAUXSHL
      COMMON /EFPFMO/ IEFPFMO,ISWENUC,REPNUCEFP,EFPEFP,RUNEFP
      COMMON /ENRGYS/ ENUCR,EELCT,ETOT,SZ,SZZ,ECORE,ESCF,EERD,E1,E2,
     *                VEN,VEE,EPOT,EKIN,ESTATE(MXRT),STATN,EDFT(2)
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,npglob,nnglob,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /GRDPAR/ ORIGIN(3),XVEC(3),YVEC(3),ZVEC(3),UX(3),UY(3),
     *                UZ(3),GRDSIZ,NGRID,IGUNIT,NXG,NYG,NZG,modgrid
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      common /INT2IC/ NINTIC,iNINTIC,nxxic,lbufpic,lixic,labsix,nintix
      COMMON /INTRFC/ FRIEND,AIMPAC,RPAC,PLTORB,MOLPLT
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /OPTSCF/ DIRSCF,FDIFF
      COMMON /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /PCKLAB/ LABSIZ
      COMMON /PCMCHG/ PB,PX,PC,UNZ,QNUC,FN,FE,UNZOR,PORT
      COMMON /PCMDIM/ mxsp,mxts,mempcm1,mempcm2,NTS
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IRPPCM,IEFPCM,IP_F,nfmopcm
      COMMON /PSILVL/ IPSI,ISKPRP
      COMMON /RESTAR/ TIMLIM,IREST,NREC,INTLOC,IST,JST,KST,LST
      COMMON /RUNOPT/ pUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,npreo(4)
      COMMON /STNBUF/ STNPNT(4,2*MXATM),BIGEXP,NPTSTN,NBUFFM
      COMMON /WFNOPT/ SCFTYP,VBTYP,DFTYPE,TDDFTYP,CITYP,CCTYP,
     *                MPLEVL,MPCTYP
      Common /fmoinf/ nfg,nlayer,natfmo,nbdfg,naotyp,nbody
      common /fmoopt/ espsca(9),RESPAP(2),rESPPC(2),rESDIM,restri(4),
     *                rcorsd,respct,convfg,cnvdmp,coroff,IXESP,mxitfg,
     *                nguess,NBSSE,modorb,modpar,irststp,irstlay,nprfmo,
     *                nfmopal,modprp,maxl1c,ipieda,modgrd,modesp,ivmul
      common /fmorun/ espscf,e0scf(2),IDAFMO,icurlay,icurfg,jcurfg,
     *                kcurfg,ncursh,ngau,icurpop,ifmostp,moncor,nat1e,
     *                needr,modrst,norbproj,nunesp,iskipesp,icurunt
      data tridek/' $FMOENT'/,end/' $END'/,RMC/8HMCSCF   /,
     *     rhf/8HRHF     /,energy/8HENERGY  /,rnone/8HNONE    /
c
c     parstat: GlobalFull
c     ifmostp is set really only for makmol in order to read MP2 data.
      ifmostp=8
      if(nunesp.gt.0) iskipesp=1
      ntimout=0
      prerhf=mod(nguess/16,2).ne.0
      desperate=mod(nguess/256,2).ne.0
      despread=desperate.and.iand(nguess,2048).eq.0
      ndesper=0
      nodesper=0
      write(ip,9200) tridek
      dftsav=DFTYPE
      ndftsav=NDFTFG
      hfssav=DFTTYP(3)
      if(doddcor) ixesp=ixesp+1024
c     raising 1024th bit signals ESPs to always use RHF densities.
c
c     NB: For FMO-ROHF reroutined to MCSCF the active space read in inidfmo
c     corresponds to closed shell singlet no matter what multiplicity.
c     This is not a problem since real multiplicity will be used where needed.
c
      if(isgddi) call GDDICOUNT(-1,lgroup,myjob)
      lijkfg=0
      iter0=0
      rmin=0
      rmax=0
      do 450 iifg=1,nfg
        do 450 jjfg=1,iifg-1
          do 450 kkfg=1,jjfg-1
          lijkfg=lijkfg+1
          if(loadhf.eq.1.and.nfg3.ne.0) then
             ijkfg=loadt(lijkfg)
c            write(6,*) 'breaking',ijkfg,lijkfg
             call cubbrk(ijkfg,-1,ifg,jfg,kfg)
c            write(6,*) 'broke',ifg,jfg,kfg
          else
             ijkfg=lijkfg
             ifg=iifg
             jfg=jjfg
             kfg=kkfg
          endif
          ifglay=layfrg(ifg)
          jfglay=layfrg(jfg)
          kfglay=layfrg(kfg)
c
c         skip trimers from higher layers
          if(.not.((ifglay.eq.ilay.or.jfglay.eq.ilay.or.kfglay.eq.ilay)
     *       .and.ifglay.ge.ilay.and.jfglay.ge.ilay.and.kfglay.ge.ilay))
     *       goto 450
          if(nfg3.ne.0) then
c           skip trimers that have been done for restart jobs
            if(irststp.ge.9.and.etrim(ijkfg,1).ne.zero) goto 440
          endif
          if(iand(modmol,1).ne.0) then
c           check if MOLFRG option tells to ignore dimers except those with
c           one from the chosen group.
            ires=molfrg(ifg)+molfrg(jfg)+molfrg(kfg)
            if(exclmol) then
              if(ires.ge.0.and.ires.ne.3) goto 450
            else
              if(ires.ge.0.and.ires.ne.1) goto 450
            endif
          endif
          if(needr.ne.0.and.restri(1).ne.0) then
            call fmodist3(ifg,jfg,kfg,rmin,rmax)
            if(rmin.gt.restri(1).and.rmax.gt.restri(2).or.
     *         rmax.gt.restri(3).and.restri(3).ne.0) then
c             SCF dimer + separate monomer: no contribution
c             Now, there is no need to zero out: already done.
c             if(maswrk) write(iw,9110) ifg,jfg,kfg
              goto 440
            endif
c           else: do SCF below.
          endif
          CALL TSECND(TYME)
          IF(TYME.GT.TIMLIM) THEN
            IF(MASWRK) WRITE(IW,9500)
            ntimout=1
            goto 590
          ENDIF
c
          if(isgddi) then
            call GDDICOUNT(0,lgroup,myjob)
            if(.not.myjob) goto 450
          endif
          l1i=iand(numfrg(ifg),65535)
          l1j=iand(numfrg(jfg),65535)
          l1k=iand(numfrg(kfg),65535)
c         LL1 printed below is an overestimate of the true L1,
c         used only for print-out.
          ll1=l1i+l1j+l1k
          icurfg=0
          nai=ishft(numfrg(ifg),-16)
          naj=ishft(numfrg(jfg),-16)
          nak=ishft(numfrg(kfg),-16)
          iodexch=scffrg(ifg).eq.rmc
          jodexch=scffrg(jfg).eq.rmc
          kodexch=scffrg(kfg).eq.rmc
          SCFTYPi=scffrg(ifg)
c         SCFTYPj=scffrg(jfg)
c         SCFTYPk=scffrg(kfg)
          SCFTYP0=SCFTYPi
          if(iodexch.or.jodexch.or.kodexch) SCFTYP0=rmc
          SCFTYP=SCFTYP0
          if(rcorsd.ne.0.and.correl) then
c           check if MOLFRG option further restricts the correlation
            ires=molfrg(ifg)+molfrg(jfg)+molfrg(kfg)
            if(exclmol) then
              skipc=ires.ge.0.and.ires.ne.3
            else
              skipc=ires.ge.0.and.ires.ne.1
            endif
            if(rmax.gt.restri(4).and.restri(4).ne.0 .or. skipc) then
              mplevl=0
              cctyp=rnone
              cityp=rnone
              TDDFTYP=rnone
            else
              mplevl=mplevli
              cctyp=cctypi
              cityp=citypi
              TDDFTYP=tddfti
            endif
          endif
          if(maswrk) write(iw,9000) scftyp0,ifg,jfg,kfg,ll1,mplevl,
     *                              cctyp,cityp,TDDFTYP
c         if(maswrk) CLOSE(UNIT=IDAF,STATUS='DELETE')
          call CLOSDA('DELETE')
          CALL OPENDA(0)
          call makemol(ifg,jfg,kfg,ilay,0,0,0,0,0,0,0,.true.)
c
          if(moncor.ge.0) moncor=0
c         fmonad sets norb.
          if(iodexch) then
            if(moncor.ge.0) moncor=naj+nak
            call fmonad(idum1,idum2)
            nai=nactfmo
          endif
          if(jodexch) then
            if(moncor.ge.0) moncor=nai+nak
            call fmonad(idum1,idum2)
            naj=nactfmo
          endif
          if(kodexch) then
            if(moncor.ge.0) moncor=nai+naj
            call fmonad(idum1,idum2)
            nak=nactfmo
          endif
c
          l1=num
          l2=(l1*l1+l1)/2
          l3=l1*l1
c         nai and naj for RHF are NA (the number of alpha electrons)
c         for MCSCF they become the number of occupied orbitals
          if(maswrk.and.labsiz.ne.labsix) write(iw,9005) labsiz,labsix
c
c       Compute trimer initial density
c
          call triminid(kfg,jfg,ifg,l1k,l1j,l1i,nak,naj,nai,l1,da,db,dc,
     *                  wrk,wrk1,iodfmo,irec0,iabdfg,jabdfg,indat,iaglob
     *                 ,locfmo,map3(1,3),map3(1,2),map3(1,1),orbxch,
     *                  enexch,kodexch,jodexch,iodexch,some)
          call dcopy(l2,da,1,dij,1)
c         do lfg=1,nfg
c           if(lfg.ne.ifg.and.lfg.ne.jfg.and.lfg.ne.kfg) then
c             write(6,*) 'Distance map for trimer',ifg,jfg,kfg,lfg
c             call mapdist(wrk,indat,indatg,iaglob,ifg,jfg,kfg,lfg)
c           endif
c         enddo
          igot=0
c         if(orbxch) call fmorvec(ifg,jfg,ijvec,l1,l1,da(1+l2),igot)
          if(mod(nguess/2,2).eq.0.and.igot.eq.0) then
            ifmostp=8
            icurfg=0
            jcurfg=0
            kcurfg=0
            CALL ONEEI
            NEVALS=0
            CALL GUESMO(GUESS)
          endif
          ifmostp=9
          icurfg=ifg
          jcurfg=jfg
          kcurfg=kfg
c           MCONV=mcnvfmo(ifmostp)
c         if(SCFTYP.eq.rmc) call readcas
          fordir=forcedir(nintic*nproc,l1dir,l1,maswrk)
          if(nintic.ne.0.and.scftyp.eq.rmc.and.goparr) fordir=.true.
          iconvijk=-1
          call fmocvij(ifg,jfg,kfg,mconvex,mconfg(nfg+1),iconvijk)
          call fmoconv(mcnvfmo(ifmostp),iconvijk,l1,wrk,enexch,orbxch,
     *                 irststp.le.3.or.iter0.eq.0,.false.,fordir)
          iter0=1
          if(nfg3.ne.0) then
c           It may be a good idea to call MCIN to be sure
            if(irststp.gt.ifmostp.and.etrim(ijkfg,1).ne.zero) goto 450
c           skip trimers energy for restart jobs ifmostp=: not finished yet.
          endif
c
          NEVALS=NEVALS+1
c
          irestsav=irest
          tightint=(iand(nprfrg(ifg),32).ne.0.or.iand(nprfrg(jfg),32)
     *              .ne.0.or.iand(nprfrg(kfg),32).ne.0).and.
     *             DIRSCF.and.FDIFF
          icutsav=icut
          if(tightint) then
            icut=icut+1
            if(maswrk) write(iw,9203) icut
          endif
c
c         Compute PCM ASC-nuclei correction to the trimer energies.
c
          if(nfmopcm.gt.0) then
c           ida=1
c           if(nfmopcm.lt.3) ida=0
            ida=0
            call pcmnup(ida,vnuc)
          endif
c
          if(nbdfg.ne.0.and.SCFTYP0.eq.rmc.and.prerhf) then
            CALL daread(IDAF,IODA,wrk,L3,15,0)
            SCFTYP=RHF
            call fmosdir(0,fmodscf,fmodtrf)
            CALL BRNCHX(energy)
cnb         fmodor is not really ready for trimers!
c           call abrt
            call fmodor(enexch,wrk,da(1+l2),da,da(1+l2+l3),wrk(l3+1),
     *                  wrk(l3+l1+1),wrk1,nai+naj+nak,l1,l2,l3)
            call fmosdir(1,fmodscf,fmodtrf)
            irest=2
c           since we run CAS again
          endif
          if(dftype.ne.rnone.and.prerhf) then
            DFTYPE=rnone
            NDFTFG=0
            DFTTYP(3)=1.0D+00
            CALL BRNCHX(energy)
            NDFTFG=ndftsav
            dftype=dftsav
            DFTTYP(3)=hfssav
            irest=2
c           since we run SCF again
c         else
c           if(coroff.ne.0.and.swoff.eq.0) swoff=coroff
          endif
          SCFTYP=SCFTYP0
          IRSTLsav=IRSTLAY
          IRSTLAY=moncor+nactfmo
          if(moncor.lt.0) IRSTLAY=nai+naj+nak
          call fmosdir(0,fmodscf,fmodtrf)
          CALL BRNCHX(RUNTYP)
c         Try converging once again with an alternative converger
          if(etot.eq.0.and.desperate) then
            if(maswrk) write(iw,9300)
c           Increase accuracy of DIRSCF/FDIFF.
            if(DIRSCF.and.FDIFF) icut=icut+1
c           to reuse integrals
            irest=2
            if(despread) then
c             do not use density from the previous run that failed, use the
c             pristine one (otherwise continue converging).
              CALL dawrit(IDAF,IODA,dij,L2,16,0)
              if(orbxch) then
                write(iw,*) 'Not ready yet'
                call abrt
              endif
            endif
            call fmoconv(mcnvfmo(ifmostp),iconvijk,l1,wrk,enexch,orbxch,
     *                   irststp.le.3.or.iter0.eq.0,.true.,fordir)
            CALL BRNCHX(RUNTYP)
c           for desperate runs abort if not converged.
            if(etot.eq.0) then
              if(maswrk) write(iw,9310)
c             call abrt
              if(maswrk) nodesper=nodesper+1
            else
              if(maswrk) ndesper=ndesper+1
            endif
          endif
          call fmosdir(1,fmodscf,fmodtrf)
          IRSTLAY=IRSTLsav
          irest=irestsav
          icut=icutsav
c
cnb       avoid DENDD1
          call DENDD1(DA,DB,L2)
          selfv=TRACEP(da,fmoespa,l1)
          if(maswrk.and.nfg3.ne.0) then
            etrim(ijkfg,1)=etot-selfv
            if(rcorsd.ne.0) etrim(ijkfg,nent)=escf-selfv
            if(etot.eq.zero) etrim(ijkfg,1)=one
c           Assign +1 to signal to the properties that this trimer diverged.
          endif
c
          delv=zero
c         the energy corrections below destroy shells, atomic coordinates etc
c         (by making dimer corrdinates instead of trimer).
c         Therefore, all properties should be computed before these corrections.
          if(primul) then
            if(NPTSTN.ne.0) then
              if(nprint.eq.-5.or.ISKPRP.ne.0) call stone(ip,rnone)
              call dcopy(nat,stonep,1,wrk1,1)
            else
              CALL daread(IDAF,IODA,da,l2,16,0)
              CALL daread(IDAF,IODA,db,l2,12,0)
              call mulpop(l1,da,db,wrk)
              call mulpopa(wrk,wrk1)
            endif
          endif
c
          if(cctyp.ne.rnone.and.maswrk)
     *      call addecc(3,0,0,1,extracc,nextracc)
          call addprop(3,primul,primul,1,1,1,iaglob,wrk1,nfmoelm,fmoelm,
     *                 fmoelm,fmoelm,atmulq,atmulq,atmulq)
c         the second and the third fmoelm are dummy
c
          if(totdens) call fmototd(1,l2,da,totd,iaoglob)
          if(densgrid) then
          call grdbox(ixmin,ixmax,iymin,iymax,izmin,izmax,vdwrad,grdpad)
            call fmoprc(1,1,l2,da,dgrid,1,NXG,1,NYG,1,NZG,ixmin,ixmax,
     *                  iymin,iymax,izmin,izmax, 0,0,0,0,0,0,
     *                  ORIGIN,UX,UY,UZ)
          endif
c
          if(nfmopcm.ne.0) then
            if(nfmopcm.gt.2.and.dovpcm)
     *        call EPOTEN(-one,XYZCTS(1,1),XYZCTS(1,2),XYZCTS(1,3),PEL,
     *                    da,NTS,L2)
            if(maswrk) esolv(ijkfg)=(PC-PX)*half
          endif
          if(ndftfg.eq.1.and.maswrk) then
            call daxpy(nedft,one,edft,1,etotdft,1)
          endif
c
c         accumulate gradient
c
          if(nder.gt.0.and.runtyp.ne.energy.and.maswrk) then
            call fmodeg(1,fmode(1,1,3),fmopg,iaglob)
            IF (IEFPFMO.EQ.1) call EFPDEG(1,3)
          ENDIF
C
          IF (NDER.GT.0.AND.RUNTYP.NE.ENERGY.AND.
     *      IAND(MODGRD,2).NE.0)                 THEN
            CALL FMOESDER(l1,l2,da,layfrg,scffrg,idmrec0,dc,wrk1,
     *                    mapi,mapj,map3,maxl1d,irec0, 0,0,0,
     *                    orbxch,enexch,kodexch,jodexch,iodexch)
          ENDIF
C
          IF (IEFPFMO.EQ.1.AND.NDER.GT.0) CALL DEFPCLR
c
          if(npunch.ne.0.and.PLTORB) CALL PLTMEM
c
c         idijk=-1
cnba+     this needs to be fixed. Slaves should participate.
          if(needdm.and.maswrk) then
c           DI+DJ+DK comes with a plus if approximations are used
c           (entirely equivalent formulation)
c
c           first get dimer density contractions
c
c           idijk=0
c           idijk counts how many times we add DI+DJ+DK.
c           in case of approximations this term appears for each separated dimer
c           for no approximations the formula in use is different and there is
c           one such term always.
c
            call vclr(wrk,1,l2)
c
            ijfg=(ifg*ifg-3*ifg)/2+jfg+1
            igotij=job2grp(ijfg)
            if(igotij.ne.0) then
c             this will not work with broken bonds!
              call makemol(ifg,jfg,0,ilay,1,0,0,0,0,0,0,.false.)
              l1ij=num
              l2ij=(l1ij*l1ij+l1ij)/2
c             call GDDI_GET(iddm,igotij,ijfg,l2ij,db)
              CALL rareads(IDAcFMO,iodcfmo,db,l2ij,ijfg,0)
              call diminid(-1,ifg,jfg,l1i,l1j,nai,naj,l1ij,da,db,wrk,
     *                     wrk1,iodfmo,irec0,iabdfg,jabdfg,indat,iaglob,
     *                     locfmo,mapi,mapj,orbxch,enexch,iodexch,
     *                     jodexch,0,untrot,some)
c             write(6,*) 'www den ij',ijfg
c             call prtril(db,l1ij)
c             call readmond(dc,orbxch,kodexch,nak,l1k,iodfmo,irec0+kfg)
              call stuff123(l1ij,l1,maxl1d,mapi,mapj,map3(1,1),map3(1,2)
     *                     ,wrk1,db,wrk)
            endif
            ikfg=(ifg*ifg-3*ifg)/2+kfg+1
            igotik=job2grp(ikfg)
c           note that mapi and mapj arrays are also used to store mapk.
c           the order of mapi and mapj should be the same in diminid and
c           stuff123.
            if(igotik.ne.0) then
              call makemol(ifg,kfg,0,ilay,1,0,0,0,0,0,0,.false.)
              l1ik=num
              l2ik=(l1ik*l1ik+l1ik)/2
c             call GDDI_GET(iddm,igotik,ikfg,l2ik,db)
              CALL rareads(IDAcFMO,iodcfmo,db,l2ik,ikfg,0)
              call diminid(-1,ifg,kfg,l1i,l1k,nai,nak,l1ik,da,db,wrk,
     *                     wrk1,iodfmo,irec0,iabdfg,jabdfg,indat,iaglob,
     *                     locfmo,mapi,mapj,orbxch,enexch,iodexch,
     *                     kodexch,0,untrot,some)
c             write(6,*) 'www den ik',ikfg
c             call prtril(db,l1ik)
c             call readmond(dc,orbxch,jodexch,naj,l1j,iodfmo,irec0+jfg)
              call stuff123(l1ik,l1,maxl1d,mapi,mapj,map3(1,1),map3(1,3)
     *                     ,wrk1,db,wrk)
            endif
            jkfg=(jfg*jfg-3*jfg)/2+kfg+1
            igotjk=job2grp(jkfg)
            if(igotjk.ne.0) then
              call makemol(jfg,kfg,0,ilay,1,0,0,0,0,0,0,.false.)
              l1jk=num
              l2jk=(l1jk*l1jk+l1jk)/2
c             call GDDI_GET(iddm,igotjk,jkfg,l2jk,db)
              CALL rareads(IDAcFMO,iodcfmo,db,l2jk,jkfg,0)
              call diminid(-1,jfg,kfg,l1j,l1k,naj,nak,l1jk,da,db,wrk,
     *                     wrk1,iodfmo,irec0,iabdfg,jabdfg,indat,iaglob,
     *                     locfmo,mapj,mapi,orbxch,enexch,jodexch,
     *                     kodexch,0,untrot,some)
c             write(6,*) 'www den ik',jkfg
c             call prtril(db,l1jk)
c             call readmond(dc,orbxch,iodexch,nai,l1i,iodfmo,irec0+ifg)
              call stuff123(l1jk,l1,maxl1d,mapj,mapi,map3(1,2),map3(1,3)
     *                     ,wrk1,db,wrk)
c             write(6,*) 'www den jk',jkfg
c             call prtri(db,14)
            endif
            if(igotij+igotik+igotjk.ne.0) delv=TRACEP(wrk,fmoespa,l1)
c           It is possible to replace this TRACEP by daxpy.
          endif
          if(nfg3.ne.0) then
c           if((needdm.or.needr2.eq.0).and.maswrk) then
            if(maswrk) then
              dele=selfv-delv-TRACEP(dij,fmoespa,l1)
              if(needdm) then
                etrim(ijkfg,2)=dele+delv
                etrim(ijkfg,3)=dele
              else
                etrim(ijkfg,2)=dele
              endif
c             write(6,*) 'www3',dele,selfv,delv,TRACEP(dij,fmoespa,l1)
            endif
c           That is, do not include dV terms into it.  -> change to include.
c 300       continue
c
            if(maswrk) then
            if(correl) then
             write(iw,9110) ifg,jfg,kfg,etrim(ijkfg,1)
             write(iw,9100) ifg,jfg,kfg,etrim(ijkfg,nent),etrim(ijkfg,2)
            else
              write(iw,9100) ifg,jfg,kfg,etrim(ijkfg,1),etrim(ijkfg,2)
            endif
           write(ip,9210) ifg,jfg,kfg,ilay,(etrim(ijkfg,ien),ien=1,nent)
            endif
          endif
  440     continue
c
  450 continue
  590 continue
      if(isgddi) call GDDICOUNT( 1,lgroup,myjob)
      write(ip,9200) END
      NDFTFG=ndftsav
      dftype=dftsav
      DFTTYP(3)=hfssav
      if(doddcor) ixesp=ixesp-1024
      if(desperate) then
        if(isgddi) then
          call gddi_scope(ddi_world)
          idum=0
          call DDI_nsumi(2423,ndesper,nodesper,idum,idum,2)
          call gddi_scope(ddi_group)
        endif
        if(maswrk) write(iw,9320) ndesper,nodesper
c       if(nodesper.ne.0) call abrt
      endif
      call timit(1)
      return
 9000 format(/1x,A8,' trimer ',3I4,', LL1=',I4,
     *           ' (MP',I1,', CC=',A8,', CI=',A8,', TD=',A8,').',/)
 9005 format(/1x,'Resetting LABSIZ=',2I2,/)
c9005 format(/1x,'Running energy for trimer ',3I4,' in vaccuum',/)
c9010 format(/1x,'Running ',A8,' energy for monomer ',I3,
c    *           ' including the basis set for fragment',I3/)
c9020 format(/1x,'energy of the separated trimer ',2I4,', L1=',I5,
c    *           ' is',F20.9/)
 9200 format(a8)
 9203 format(1x,'Using tighter ICUT=',I2)
 9210 format(1x,3I5,I3,2F22.10,2F16.10)
 9100 format(/1x,' iFrag=',I5,' jFrag=',I5,' kFrag=',I5,' EFMOu=',F16.9,
     *           ' Tr=',F12.9)
 9110 format(/1x,' iFrag=',I5,' jFrag=',I5,' kFrag=',I5,' EFMOc=',F16.9)
c9110 format(/1x,'Skipping iFrag=',I5,' jFrag=',I5,' kFrag=',I5,/)
 9300 format(/1x,'Trying desperately the alternative SCF converger.')
 9310 format(/1x,'Despite trying desperately, SCF did not converge.')
 9320 format(/1x,'Desperately converged',I5,', diverged',I5,' trimers.'
     *          ,/)
 9500 format(/1x,'Running out of time...',/)
      END
C*MODULE fmo     *DECK efmoq
      subroutine efmoq(ilay,loadhf,loadd,layfrg,molfrg,IDAcFMO,
     *                 iodcfmo,modmol,exclmol,edimq)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      logical GOPARR,DSKWRK,MASWRK,ISGDDI,PAROUT,INITGDDI,myjob,exclmol
      Parameter(MXATM=2000)
      dimension loadd(*),layfrg(*),iodcfmo(*),edimq(*),molfrg(*)
      COMMON /GDDI/   ISCOPE,NGROUPS,MYGROUP,MEGLOB,npglob,nnglob,JBTYP,
     *                ISGDDI,PAROUT,INITGDDI
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /IOFILE/ IR,IW,IP,IS,IPK,IDAF,NAV,IODA(950)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      Common /fmoinf/ nfg,nlayer,natfmo,nbdfg,naotyp,nbody
      common /fmoopt/ espsca(9),RESPAP(2),rESPPC(2),rESDIM,restri(4),
     *                rcorsd,respct,convfg,cnvdmp,coroff,IXESP,mxitfg,
     *                nguess,NBSSE,modorb,modpar,irststp,irstlay,nprfmo,
     *                nfmopal,modprp,maxl1c,ipieda,modgrd,modesp,ivmul
c
c     The main FMOQ correction driver.
c
      if(isgddi) call GDDICOUNT(-1,lgroup,myjob)
      lijfg=0
      do 450 iifg=1,nfg
        do 450 jjfg=1,iifg-1
          lijfg=lijfg+1
          if(loadhf.eq.1) then
            ijfg=loadd(lijfg)
            call tribrk(ijfg,-1,ifg,jfg)
c           ifg=ifg+1
          else
            ijfg=lijfg
            ifg=iifg
            jfg=jjfg
          endif
          if(resdim.ne.0) then
            rij=fmodist(ifg,0,0,jfg)
            if(rij.gt.resdim) goto 450
          endif
c         skip dimers from higher layers
          if(.not.((layfrg(ifg).eq.ilay.or.layfrg(jfg).eq.ilay).and.
     *       layfrg(ifg).ge.ilay.and.layfrg(jfg).ge.ilay)) goto 450
          if(iand(modmol,1).ne.0) then
c           check if MOLFRG option tells to ignore dimers except those with
c           one from the chosen group.
            ires=molfrg(ifg)+molfrg(jfg)
            if(exclmol) then
              if(ires.ge.0.and.ires.ne.2) goto 450
            else
              if(ires.eq.0.or.ires.eq.2) goto 450
            endif
          endif
          if(isgddi) then
            call GDDICOUNT(0,lgroup,myjob)
            if(.not.myjob) goto 450
          endif
          call makemol(ifg,jfg,0,ilay,0,0,0,0,0,0,0,.true.)
c         l0=nqmt
          l1=num
          l2=(l1*l1+l1)/2
c         l3=l1*l1
          if(maswrk) write(iw,9000) ifg,jfg,l1
          call fmoqesp(ilay,ijfg,ifg,jfg,l1,l2,loadd,IDAcFMO,iodcfmo,
     *                 edimq)
c
  450 continue
      if(isgddi) call GDDICOUNT(1,lgroup,myjob)
      return
 9000 format(/1x,'Running dimer',2I5,', LL1=',I4)
      END
