C 20 AUG 07 - DRM - PROVIDE RANDOM INITIAL CLUSTER GENERATION OPTION
C 20 AUG 07 - LVS - STCOR,RSTCOR: SAVE DISPERSION COEFS FOR EFP1-MP2
C 24 MAR 07 - MWS - PAD THE FRGINF,EFPPAR COMMON BLOCKS
C 22 DEC 06 - TN  - GLOBOP INTERFACED WITH FMO
C 14 NOV 05 - DGF - PAD COMMON BLOCK SCFOPT
C 19 SEP 05 - IA  - SYNCHRONIZE FRGINF COMMON
C  5 JUL 05 - MWS - SELECT NEW ATOM,BASIS,EFP,PCM,DAF DIMENSIONS
C 27 JUN 05 - HL  - GLOPDR: FIX RANDOM NUMBERS FOR PARALLEL GLOBOP
C 14 MAR 05 - HL  - STCOR,RSTCOR: SAVE CANONICAL MO, UPDATE EFDSPL ARGS
C  7 MAR 05 - IA  - STCOR,RSTCOR: SAVE DYNAMIC POLARIZABILITY
C 13 FEB 05 - JS  - ADD EFP MP2 CHANGES TO GLOFRG
C 22 NOV 04 - IA  - FIX STORING BEST EFP2 PAULI REPULSION INFORMATION
C  9 DEC 03 - MWS - SYNCH COMMON BLOCK RUNOPT
C  3 JUL 03 - JMM - SUPPRESS PRINTING FOR MONTE CARLO JOBS
C 26 MAR 03 - PND - CHANGE MOVIE OUTPUTS
C 17 AUG 02 - MWS - FIX COORDINATE STORAGE PROBLEM FROM 7 AUG 02 CHANGE
C  7 AUG 02 - HT  - USE DYNAMIC MEMORY FOR EFP PAULI REPULSION
C 17 APR 02 - MWS - SYNCH UP EFMULT AND FRGINF COMMON
C 26 MAR 02 - MWS - FIXES RELATING TO ONLY AB INITIO ATOMS PRESENT
C  6 SEP 01 - KRG - RAND3: ENSURE POSITIVE SEEDING
C 25 JUN 01 - MWS - ALTER COMMON BLOCK SCFOPT
C 13 JUN 01 - MWS - GLOFRG: CALL MEMORY ROUTINE FOR CAVITY CONSTRUCTION
C 20 FEB 01 - PND - MONTE CARLO/SIMULATED ANNEALING GLOBAL OPTIMIZER
C
C*MODULE GLOBOP  *DECK GLOPDR
      SUBROUTINE GLOPDR
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,MOVIE,MOVIE2,MCMIN
      LOGICAL OPTN,MIN_C,SMC,RNDINI,ALERT
C
      PARAMETER (MXATM=2000, MXAO=8192, MXSH=5000, MXGTOT=20000,
     *           MXPT=2000, MXFRG=1050, MXDFG=5, MXFGPT=12000,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 FRGNME
      DIMENSION SCALE(2),IFXFRG(MXFRG),IFRMOV(MXFRG),ARAN(3*MXATM)
      DIMENSION AVEXYZ(MXFRG,3),JMOVED(MXFRG)
C
      COMMON /APPLE/  MOVIE,MOVIE2
      COMMON /EFPBAS/ EX(MXGTOT,MXDFG),CS(MXGTOT,MXDFG),
     *                CP(MXGTOT,MXDFG),CD(MXGTOT,MXDFG),
     *                CF(MXGTOT,MXDFG),CG(MXGTOT,MXDFG),
     *                PRNAME(MXFGPT),PRCORD(3,MXFGPT),EFZNUC(MXFGPT),
     *                KSTART(MXSH,MXDFG),KATOM(MXSH,MXDFG),
     *                KTYPE(MXSH,MXDFG),KNG(MXSH,MXDFG),
     *                KLOC(MXSH,MXDFG),KMIN(MXSH,MXDFG),
     *                KMAX(MXSH,MXDFG),NSHELL(MXDFG),NGAUSS(MXDFG),
     *                NATEF(MXDFG),NUMEF(MXDFG),NTPATM
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /FMCOM / XX(1)
      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 /OUTPUT/ NPRINT,ITOL,ICUT,NORMF,NORMP,NOPK
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /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 /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IKREP,IEF,IP_F,NFMOPCM
      COMMON /SCFOPT/ CONVHF,MAXIT,MCONV,NPUNCH,NPREO(4)
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /SIMEN / EPREV,EMIN,ALPHA,DAVE,XMIN,XMAX,YMIN,YMAX
     *               ,ZMIN,ZMAX,XRANGE,YRANGE,ZRANGE,SEPTOL
     *               ,DACRAT,UPDFAC
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /POLTMP/ POLT2(9),
     *                ACHGHF(2,MXPT),ADIPHF(3,MXPT),AQADHF(6,MXPT),
     *                AMULTMP(MXPT),BMULTMP(MXPT),
     *                AMULTMP2(MXPT),BMULTMP2(MXPT),
     *                TCLPD(4*MXPT),TZLPD(4*MXPT),
     *                JNLPR(4*MXPT),JKFR(MXPT),JKLR(MXPT),
     *                NDPTS(MXFRG),
     *                IEFP2,IEFMON,IEFSCR,IEFSCR2,IEFDIP,IEFQUD,IEFREP,
     *                IEFPOL,IEFPOL2,NDTTPT
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
C
      PARAMETER (ZERO=0.0D+00, ONE=1.0D+00, TWO=2.0D+00,
     *           UNITS = ONE/0.52917724924D+00)
C
      PARAMETER (NNAM=30)
      DIMENSION QNAM(NNAM),KQNAM(NNAM)
      DATA QNAM/8HTEMPI   ,8HTEMPF   ,8HNTEMPS  ,8HNGEOPT  ,
     *          8HSCALE   ,8HALPHA   ,8HMOVIE2  ,8HBOLTWT  ,
     *          8HXMIN    ,8HXMAX    ,8HYMIN    ,8HYMAX    ,
     *          8HZMIN    ,8HZMAX    ,8HSEPTOL  ,8HNPRT    ,
     *          8HRANDOM  ,8HIFXFRG  ,8HNFRMOV  ,8HDACRAT  ,
     *          8HUPDFAC  ,8HMCMIN   ,8HNTRAN   ,8HNROT    ,
     *          8HOPTN    ,8HNBLOCK  ,8HAIMOVE  ,8HNSTMIN  ,
     *          8HRNDINI  ,8HRIORD   /
      DATA KQNAM / 3,  3,1,1,
     *            23,  3,0,5,
     *             3,  3,3,3,
     *             3,  3,3,1,
     *             5,201,1,3,
     *             3,  0,1,1,
     *             0,  1,3,1,
     *             0,  5/
C
      DATA GLOBOP/8HGLOBOP  /
      DATA OPT   /8HOPTIMIZE/
      DATA STANDARD /8HSTANDARD/, AVESTEP/8HAVESTEP /
      DATA DEBUG /8HDEBUG   /, RAND1/8HRAND1   /,RAND3/8HRAND3   /
      DATA RAND /8HRAND    /
C
      IF(MASWRK) WRITE(IW,*) 'JUST-INSIDE-GLOBOP: IPCM,IEFP=',IPCM,IEFP
C
      NFTEN = 35
      NFTCR = 36
      CALL SEQOPN(NFTEN, 'SIMEN','UNKNOWN',.FALSE.,'FORMATTED')
      CALL SEQOPN(NFTCR,'SIMCOR','UNKNOWN',.FALSE.,'FORMATTED')
C
      NPUNCH=-2
C
C        NEXT THREE INITIALIZATIONS MAY BE A BUG.
C        WITHOUT THEM, FTNCHEK COMPLAINS THEY ARE UNINITIALIZED VALUES.
C
      TEMPER=0.0D+00
      DO I=1,3*NAT
         ARAN(I)=0.0D+00
      ENDDO
      DO I=1,NFRG
         IFRMOV(I)=0
      ENDDO
C
      TEMPI = 20000.0D+00
      TEMPF = 0.0D+00
      NTEMPS = 1
      NFRMOV = 1
      NGEOPT = 100
      NTRAN = 5
      NROT = 5
      NBLOCK=0
      MCMIN=.TRUE.
      OPTN=.FALSE.
C
      MIN_C=.FALSE.
      NSTMIN= 10
      SMC=.FALSE.
      AIMOVE=0.0D+00
C
      SCALE(1) = ONE
      SCALE(2) = ONE
      ALPHA = ZERO
      DACRAT = 0.5D+00
      UPDFAC = 0.95D+00
      SEPTOL = 1.5D+00
      XMIN = -1.0D+10
      XMAX =  1.0D+10
      YMIN = -1.0D+10
      YMAX =  1.0D+10
      ZMIN = -1.0D+10
      ZMAX =  1.0D+10
      BOLTWT = STANDARD
      RNDINI=.FALSE.
      RIORD=RAND
C
C          NPRTGO=1 MEANS NORMAL PRINTING
C                =2 MEANS SUPPRESSED PRINTING
C
      NPRTGO = 2
C
C          IGOFLG=1 MEANS MONTE CARLO GLOBAL OPTIMIZATION IN PROGRESS
C                =2 MEANS ORDINARY GEOMETRY OPTIMIZATION
C
      IGOFLG = 1
      RANDOM = RAND3
      DO 75 IFR=1,MXFRG
       IFXFRG(IFR)=0
 75   CONTINUE
      MOVIE2 = .FALSE.
C
      JRET = 0
      CALL NAMEIO (IR,JRET,GLOBOP,NNAM,QNAM,KQNAM,
     *             TEMPI,TEMPF,NTEMPS,NGEOPT,SCALE,ALPHA,MOVIE2,
     *             BOLTWT,XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,
     *             SEPTOL,NPRTGO,RANDOM,IFXFRG,NFRMOV,DACRAT,
     *             UPDFAC,MCMIN,NTRAN,NROT,OPTN,NBLOCK,AIMOVE,NSTMIN,
     *             RNDINI,RIORD,0,0,0,0,
     *     0,0,0,0,0,     0,0,0,0,0,
     *     0,0,0,0,0,     0,0,0,0,0,     0,0,0,0,0,     0,0,0,0,0)
      IF(JRET.GT.1) THEN
         IF(MASWRK) WRITE(IW,*) 'ERROR IN $GLOBOP GROUP'
         CALL ABRT
      END IF
C
      IF(MASWRK) THEN
          WRITE(IW,9100) TEMPI,TEMPF,NTEMPS,NGEOPT,
     *                   NFRMOV,NTRAN,NROT,NBLOCK,SCALE,SEPTOL,
     *                   MCMIN,NSTMIN,OPTN,
     *                   XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,
     *                   ALPHA,DACRAT,UPDFAC,BOLTWT,
     *                   AIMOVE,NPRTGO,RANDOM,MOVIE2,RNDINI,RIORD
          WRITE(IW,9101) (IFXFRG(III),III=1,NFRG)
      END IF
 9100 FORMAT(/10X,'---- MONTE CARLO/SIMULATED ANNEALING OPTIONS -----'/
     *    1X,'TEMPI=',F6.1,' TEMPF=',F6.1,' NTEMPS=',I4,' NGEOPT=',I5/
     *    1X,'NFRMOV=',I4,' NTRAN=',I4,' NROT=',I4,' NBLOCK=',I4,
     *       ' SCALE=',2F6.2,' SEPTOL=',F6.3/
     *    1X,'MCMIN=',L2,' NSTMIN=',I4,' OPTN=',L2/
     *    1X,'XMIN/MAX=',2F8.2,' YMIN/MAX=',2F8.2,' ZMIN/MAX=',2F8.2/
     *    1X,'ALPHA=',F10.4,' DACRAT=',F10.4,' UPDFAC=',F10.4,
     *       ' BOLTWT=',A8/
     *    1X,'AIMOVE=',F8.4,'  NPRT=',I4,'  RANDOM=',A8,'  MOVIE2=',L2,
     *    1X,'RNDINI=',L2,'  RIORD=',A8)
 9101 FORMAT(1X,'IFXFRG=',15I5)
C
      XMIN = XMIN * UNITS
      XMAX = XMAX * UNITS
      YMIN = YMIN * UNITS
      YMAX = YMAX * UNITS
      ZMIN = ZMIN * UNITS
      ZMAX = ZMAX * UNITS
      XRANGE = XMAX - XMIN
      YRANGE = YMAX - YMIN
      ZRANGE = ZMAX - ZMIN
      SEPTOL = SEPTOL * UNITS
      SCALE(1) = SCALE(1) * UNITS
      IF(TEMPI.LE.ZERO) THEN
        IF(MASWRK) WRITE(IW,*)
     *      'INITIAL TEMPERATURE MUST BE GREATER THAN ZERO.'
        CALL ABRT
      END IF
      GAMR = 1.0D+00
      IF(TEMPF.LT.ZERO) THEN
        IF(MASWRK) WRITE(IW,*)
     *      'FINAL TEMPERATURE MUST BE GREATER THAN ZERO.'
        CALL ABRT
      ELSE IF(TEMPF.GT.TEMPI) THEN
        IF(MASWRK) WRITE(IW,*)
     *      'FINAL TEMPERATURE CAN NOT BE GREATER THAN INITIAL.'
        CALL ABRT
      ELSE IF(TEMPF.EQ.ZERO) THEN
        IF(NTEMPS.GT.1) THEN
C CALCULATE FINAL TEMPERATURE BASED ON COOLING RATE OF 0.95
          GAMR=0.95D+00
C         GAMR=0.98D+00
         TEMPF=TEMPI*GAMR**(NTEMPS-1)
        ELSE IF(NTEMPS.LT.1) THEN
         IF(MASWRK) WRITE(IW,*)'NTEMPS MUST BE POSITIVE'
         CALL ABRT
        END IF
      ELSE
        IF(NTEMPS.GT.1) THEN
         GAMR = (TEMPF/TEMPI)**(ONE/(NTEMPS-1))
        ELSE IF(NTEMPS.LT.1) THEN
         IF(MASWRK) WRITE(IW,*)'NTEMPS MUST BE POSITIVE'
         CALL ABRT
        ELSE
C CALCULATE NUMBER OF TEMPERATURES BASED ON COOLING RATE OF 0.95
         GAMR=0.95D+00
C         GAMR=0.98D+00
         NTEMPS=INT(LOG(TEMPF/TEMPI)/LOG(GAMR))+1
         IF(MASWRK) WRITE(IW,*)'NUMBER OF TEMPERATURES WILL BE ',NTEMPS
        END IF
      END IF
      IF(NGEOPT.LE.0) THEN
       IF(MASWRK) WRITE(IW,*)'NGEOPT MUST BE POSITIVE'
       CALL ABRT
      END IF
      IF(BOLTWT.EQ.STANDARD) THEN
        IBWM = 0
      ELSE IF(BOLTWT.EQ.AVESTEP) THEN
        IBWM = 1
      ELSE
        IF(MASWRK) WRITE(IW,*)'ILLEGAL VALUE FOR BOLTWT IN $GLOBOP'
        CALL ABRT
      END IF
      IF(RANDOM.EQ.DEBUG) THEN
        IRTP = 0
      ELSE IF(RANDOM.EQ.RAND1) THEN
        IRTP = 1
      ELSE IF(RANDOM.EQ.RAND3) THEN
        IRTP = 3
      ELSE
        IF(MASWRK) WRITE(IW,*)'ILLEGAL VALUE FOR RANDOM IN $GLOBOP'
        CALL ABRT
      END IF
      IF(RIORD.NE.STANDARD.AND.RIORD.NE.RAND) THEN
        IF(MASWRK) WRITE(IW,*)'ILLEGAL VALUE FOR RIORD IN $GLOBOP'
        CALL ABRT
      END IF
      IF(NFRMOV.LT.0) THEN
        IF(MASWRK) WRITE(IW,*) 'NFRMOV CANNOT BE NEGATIVE'
        CALL ABRT
      ELSE IF(NFRMOV.GT.NFRG) THEN
        IF(MASWRK) WRITE(IW,*)'NFRMOV=',NFRMOV,
     *         ' CANNOT BE GREATER THAN THE NUMBER OF FRAGMENTS=',NFRG
        CALL ABRT
      END IF
C
C  TO WRITE THE ENERGY AND COORDS FROM A SINGLE TEMP MONTE CARLO RUN
C
      IF(TEMPF.EQ.0.0D+00) THEN
         SMC=.TRUE.
      END IF
C
      NPBFMX=NPBF(1)
      DO 15 IFRG=2,NFRG
        IF(NPBF(IFRG).GT.NPBFMX) NPBFMX=NPBF(IFRG)
 15   CONTINUE
C
C  ALLOCATE DYNAMIC MEMORY
C
      IF(AIMOVE.EQ.0.0D+00) THEN
         IMXRAN = NGEOPT*(6*NFRMOV+1)
      ELSE
         IMXRAN = NGEOPT*(6*NFRMOV+3*NAT+1)
      END IF
C
      MXBF=0
      DO I = 1, NFRG
         MXBF=MAX(MXBF,NPBF(I))
      END DO
C
      CALL VALFM(LOADFM)
      LDC     = LOADFM  + 1
      LDA     = LDC     + 3*NFRG
      LDMC    = LDA     + 3*NFRG
      LDMA    = LDMC    + 3*NFRG
      LRN     = LDMA    + 3*NFRG
      LWRK    = LRN     + IMXRAN
      LCMIN   = LWRK    + NUM*NUM
      LCOLD   = LCMIN   + 3*NAT + 22*NMTTPT + 12*NPTTPT + 12*NDPTTPT
     *                  + 3*NRTTPT + 3*NTPATM + MXBF*NTMO
     *                  + MXBF*NTAO + 3*NTMO + 3*NDTTPT
      LPROVEC = LCOLD   + 3*NAT + 22*NMTTPT + 12*NPTTPT + 12*NDPTTPT
     *                  + 3*NRTTPT + 3*NTPATM + MXBF*NTMO
     *                  + MXBF*NTAO + 3*NTMO + 3*NDTTPT
      LCANVEC = LPROVEC + MXBF*NTMO
      LAST    = LCANVEC + MXBF*NTAO
      NEED = LAST  - LOADFM - 1
      CALL GETFM(NEED)
C
      LENPV=MXBF*NTMO
      IF (NFRG.GT.0.AND.NTMO.GT.0) THEN
         CALL DAREAD(IDAF,IODA,XX(LPROVEC),LENPV,267,0)
      END IF
      LENCV=MXBF*NTAO
      IF (NFRG.GT.0.AND.NTAO.GT.0) THEN
         CALL DAREAD(IDAF,IODA,XX(LCANVEC),LENCV,269,0)
      END IF
C
      CALL SEQOPN(4,'IRCDATA','NEW',.FALSE.,'FORMATTED')
C     IF(MOVIE2) CALL SEQOPN(4,'IRCDATA','NEW',.FALSE.,'FORMATTED')
C
C HERE WE WILL RANDOMIZE THE INITIAL GEOMETRY IF RNDINI=.TRUE.
C
      IF(RNDINI) THEN
         IF(MASWRK) WRITE(6,*) 'RNDINI IN PROGRESS...'
C
C SPREAD MOLECULES FAR APART IN ORDER TO PREVENT PROXIMITY ALERTS
C
      ISTOVR=LRN+IMXRAN-10     
  441 CONTINUE
C
C  GENERATE IMXRAN RANDOM NUMBERS
C
      INIT=0
      IF(MASWRK) THEN
         CALL RNGEN(XX(LRN),IMXRAN,IRTP,INIT)
         CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
      ELSE
         CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
      END IF
      INIT=1
      IRN=LRN
C
C CALCULATE AVERAGE X,Y,Z COORDINATES OF EACH FRAGMENT IN  
C ORDER TO CENTER ALL MOLECULES AT (0,0,0) BEFORE RANDOMIZING
C
      IAT=0
      DO 1929 IFRG=1,NFRG
         AVEXYZ(IFRG,1)=ZERO
         AVEXYZ(IFRG,2)=ZERO
         AVEXYZ(IFRG,3)=ZERO
         DO 1919 III=1,NMPTS(IFRG)
            IAT=IAT+1
            AVEXYZ(IFRG,1)=AVEXYZ(IFRG,1)+EFC(1,IAT)
            AVEXYZ(IFRG,2)=AVEXYZ(IFRG,2)+EFC(2,IAT)
            AVEXYZ(IFRG,3)=AVEXYZ(IFRG,3)+EFC(3,IAT)
 1919    CONTINUE
         DENOM=NMPTS(IFRG)
         AVEXYZ(IFRG,1)=AVEXYZ(IFRG,1)/DENOM
         AVEXYZ(IFRG,2)=AVEXYZ(IFRG,2)/DENOM
         AVEXYZ(IFRG,3)=AVEXYZ(IFRG,3)/DENOM
 1929 CONTINUE
C
      NMST=0
      NPST=0
      NDPST=0
      NRST=0
      NDST=0
      NATST=0
      NORST=0
      NAOST=0
      DO 867 INF=1,NFRG
         DX = 3.0D+02*(TWO*XX(IRN  )-ONE)-AVEXYZ(INF,1)
         DY = 3.0D+02*(TWO*XX(IRN+1)-ONE)-AVEXYZ(INF,2)
         DZ = 3.0D+02*(TWO*XX(IRN+2)-ONE)-AVEXYZ(INF,3)
         IRN=IRN+3
         CALL EFDSPL(INF,
     *            DX,DY,DZ,ZERO,ZERO,ZERO,
     *            NMST,NPST,NDPST,NRST,NDST,NATST,NORST,
     *            XX(LPROVEC),NAOST,XX(LCANVEC),MXBF)
         NMST  = NMST  + NMPTS(INF)
         NPST  = NPST  + NPPTS(INF)
         NDPST = NDPST + NDPPTS(INF)
         NRST  = NRST  + NRPTS(INF)
         NDST  = NDST  + NDPTS(INF)
         NATST = NATST + NATEF(ISET(INF))
         NORST = NORST + NORB(INF)
         NAOST = NAOST + NAO(ISET(INF))
  867 CONTINUE
      CALL PXALRT(ALERT)
      IF(ALERT) GO TO 441
C
C     IPXALT=0
C
C CALCULATE AVERAGE X,Y,Z COORDINATES OF EACH FRAGMENT IN
C ORDER TO CENTER ALL MOLECULES AT (0,0,0) BEFORE RANDOMIZING
C
      IAT=0
      DO 1729 IFRG=1,NFRG
         AVEXYZ(IFRG,1)=ZERO
         AVEXYZ(IFRG,2)=ZERO
         AVEXYZ(IFRG,3)=ZERO
         DO 1719 III=1,NMPTS(IFRG)
            IAT=IAT+1
            AVEXYZ(IFRG,1)=AVEXYZ(IFRG,1)+EFC(1,IAT)
            AVEXYZ(IFRG,2)=AVEXYZ(IFRG,2)+EFC(2,IAT)
            AVEXYZ(IFRG,3)=AVEXYZ(IFRG,3)+EFC(3,IAT)
 1719    CONTINUE
         DENOM=NMPTS(IFRG)
         AVEXYZ(IFRG,1)=AVEXYZ(IFRG,1)/DENOM
         AVEXYZ(IFRG,2)=AVEXYZ(IFRG,2)/DENOM
         AVEXYZ(IFRG,3)=AVEXYZ(IFRG,3)/DENOM
 1729 CONTINUE
C
C KEEPS TRACK OF WHICH FRAGMENTS HAVE ALREADY BEEN PLACED IN CLUSTER
C
      IF(RIORD.EQ.RAND) THEN
         DO 586 INF=1,NFRG
            JMOVED(INF)=0
  586    CONTINUE
      END IF
      DO 111 IMF=1,NFRG
C
C CHOOSE A FRAGMENT WE HAVE NOT YET MOVED
C
         IF(RIORD.EQ.RAND) THEN
  770       CONTINUE
            INF=INT(NFRG*XX(IRN))+1
            IRN=IRN+1
            IF(IRN.GT.ISTOVR) THEN
C
C           GENERATE IMXRAN RANDOM NUMBERS
C
               INIT=0
               IF(MASWRK) THEN
                  CALL RNGEN(XX(LRN),IMXRAN,IRTP,INIT)
                  CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
               ELSE
                  CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
               END IF
               INIT=1
               IRN=LRN
            END IF
            IF(INF.GT.NFRG) GO TO 770 
            IF(JMOVED(INF).EQ.1) GO TO 770
            JMOVED(INF)=1
         ELSE
            INF=IMF
         END IF
C
C  GENERATE IMXRAN RANDOM NUMBERS
C
      INIT=0
      IF(MASWRK) THEN
         CALL RNGEN(XX(LRN),IMXRAN,IRTP,INIT)
         CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
      ELSE
         CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
      END IF
      INIT=1
      IRN=LRN
C
         NMST=0
         NPST=0
         NDPST=0
         NRST=0
         NDST=0
         NATST=0
         NORST=0
         NAOST=0
         DO 238 IJK=1,INF-1
            NMST  = NMST  + NMPTS(IJK)
            NPST  = NPST  + NPPTS(IJK)
            NDPST = NDPST + NDPPTS(IJK)
            NRST  = NRST  + NRPTS(IJK)
            NDST  = NDST  + NDPTS(IJK)
            NATST = NATST + NATEF(ISET(IJK))
            NORST = NORST + NORB(IJK)
            NAOST = NAOST + NAO(ISET(IJK))
  238    CONTINUE
         IFIRST=1
C
C WE RETURN HERE EACH TIME WE GET A PROXIMITY ALERT
C FOR THE CURRENT FRAGMENT
C
  729    CONTINUE   
C
C FIRST TIME WE MOVE FRAGMENT, START AT ORIGIN
C
         IF(IFIRST.EQ.1) THEN
         DX = 3.0D+00*(TWO*XX(IRN  )-ONE)-AVEXYZ(INF,1)
         DY = 3.0D+00*(TWO*XX(IRN+1)-ONE)-AVEXYZ(INF,2)
         DZ = 3.0D+00*(TWO*XX(IRN+2)-ONE)-AVEXYZ(INF,3)
         DA = 3.141592654D+00*(TWO*XX(IRN+3)-ONE)
         DB = 3.141592654D+00*(TWO*XX(IRN+4)-ONE)
         DC = 3.141592654D+00*(TWO*XX(IRN+5)-ONE)
         ELSE
         DX = 3.0D+00*(TWO*XX(IRN  )-ONE)
         DY = 3.0D+00*(TWO*XX(IRN+1)-ONE)
         DZ = 3.0D+00*(TWO*XX(IRN+2)-ONE)
         DA = 3.141592654D+00*(TWO*XX(IRN+3)-ONE)
         DB = 3.141592654D+00*(TWO*XX(IRN+4)-ONE)
         DC = 3.141592654D+00*(TWO*XX(IRN+5)-ONE)
         END IF
         IRN=IRN+6
         CALL EFDSPL(INF,
     *        DX,DY,DZ,DA,DB,DC,
     *        NMST,NPST,NDPST,NRST,NDST,NATST,NORST,XX(LPROVEC),
     *        NAOST,XX(LCANVEC),MXBF)
         CALL PXALRT(ALERT)
         IF(ALERT) THEN
            IFIRST=0
C           IPXALT=IPXALT+1
C           IF(MASWRK) WRITE(6,*) 'RNDINI PROXIMITY ALERT #'
C    *      ,IPXALT, ' CURRENT FRAGMENT: ', INF
            IF(IRN.GT.ISTOVR) THEN
C
C  GENERATE IMXRAN RANDOM NUMBERS
C
            INIT=0
            IF(MASWRK) THEN
               CALL RNGEN(XX(LRN),IMXRAN,IRTP,INIT)
               CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
            ELSE
               CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
            END IF
            INIT=1
            IRN=LRN
C
            END IF
            GO TO 729
         END IF
  111 CONTINUE       
         IF (NFRG.GT.0.AND.NTMO.GT.0)
     *       CALL DAWRIT(IDAF,IODA,XX(LPROVEC),LENPV,267,0)
         IF (NFRG.GT.0.AND.NTAO.GT.0)
     *       CALL DAWRIT(IDAF,IODA,XX(LCANVEC),LENCV,269,0)
C
C TELL LOG FILE WHERE THE NEW COORIDNATES ARE
C
         IF(MASWRK) WRITE(6,*) ' '
         IF(MASWRK) WRITE(6,*) 'COORDINATES FROM INITIAL ',
     *              'RANDOMIZATION ARE THOSE BELOW AT NSERCH = 0.'
C
C OPTIMIZE
C
      TRUNTP=RUNTYP
      RUNTYP=OPT
      CALL SIGX(.FALSE.)
      RUNTYP=TRUNTP
C
C ENDS THE IF(RNDINI) ENVIRONMENT
C
      END IF
C
C  INITIALIZE GLOBAL OPTIMIZATION COUNT
C
      IGLO=0
      NACC=0
      NRPA=0
      NREJ=0
C
C  INITIALIZE DMAT
C
      IDMC=LDMC
      IDMA=LDMA
      DO 25 INF=1,NFRG
       XX(IDMC  ) = SCALE(1)
       XX(IDMC+1) = SCALE(1)
       XX(IDMC+2) = SCALE(1)
       XX(IDMA  ) = SCALE(2)
       XX(IDMA+1) = SCALE(2)
       XX(IDMA+2) = SCALE(2)
       IDMC=IDMC+3
       IDMA=IDMA+3
 25   CONTINUE
C
C   EVALUATE ENERGY AND WAVE FUNCTION AT FIRST GEOMETRY
C
      XRAN=ZERO
      IF(MASWRK .AND. NPRINT.NE.-5) WRITE(IW,9050)
      CALL GLOFRG(TEMPER,XX(LDC),XX(LDA),XX(LWRK),XRAN,XX(LCMIN),
     $            IGLO,XX(LDMC),XX(LDMA),IFRMOV,XX(LCOLD),MCMIN,MIN_C,
     $            SMC,AIMOVE,ARAN,NSTMIN,NFTEN,NFTCR,
     *            XX(LPROVEC),MXBF,NTMO,XX(LCANVEC),NTAO)
      IGLO=IGLO+1
      NPRINT=-5
C
      TEMPER = TEMPI
      ACCRATT = DACRAT
      IF(MASWRK) WRITE(IW,9126) GAMR,DACRAT,UPDFAC
C
C     ----LOOP OVER TEMPERATURE STARTS HERE ----
C
      DO 200 ITM=1,NTEMPS
      IF(MASWRK) WRITE(IW,9020) ITM,TEMPER
C
C  UPDATE MAXIMUM STEP SIZES TO GET DESIRED ACCEPTANCE RATIO
C
      IF(ACCRATT.GT.DACRAT) THEN
         UFAC = ONE/UPDFAC
      ELSE IF(ACCRATT.LT.DACRAT) THEN
         UFAC = UPDFAC
      ELSE
         UFAC = ONE
      END IF
C
      IDMC=LDMC
      IDMA=LDMA
      IDC=LDC
      IDA=LDA
      DO 225 INF=1,NFRG
       XX(IDMC  ) = XX(IDMC  ) * UFAC
       XX(IDMC+1) = XX(IDMC+1) * UFAC
       XX(IDMC+2) = XX(IDMC+2) * UFAC
       XX(IDMA  ) = XX(IDMA  ) * UFAC
       XX(IDMA+1) = XX(IDMA+1) * UFAC
       XX(IDMA+2) = XX(IDMA+2) * UFAC
       IF(MASWRK) WRITE(IW,229) INF,XX(IDMC),XX(IDMC+1),XX(IDMC+2),
     $                              XX(IDMA),XX(IDMA+1),XX(IDMA+2)
 229   FORMAT(1X,'MAX.DISP.:',I3,6F10.5)
       XX(IDC  ) = ZERO
       XX(IDC+1) = ZERO
       XX(IDC+2) = ZERO
       XX(IDA  ) = ZERO
       XX(IDA+1) = ZERO
       XX(IDA+2) = ZERO
       IDC=IDC+3
       IDA=IDA+3
       IDMC=IDMC+3
       IDMA=IDMA+3
 225   CONTINUE
C
C  GENERATE IMXRAN RANDOM NUMBERS
C
      INIT=0
      IF(MASWRK)THEN
         CALL RNGEN(XX(LRN),IMXRAN,IRTP,INIT)
         CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
      ELSE
         CALL DDI_BCAST(2600,'F',XX(LRN),IMXRAN,MASTER)
      END IF
      INIT=1
      IRN=LRN
C
      IF(NBLOCK.EQ.0) NBLOCK=NGEOPT/(NTRAN+NROT)
      IF(NBLOCK.EQ.0) THEN
        IF(MASWRK) WRITE(IW,9124) NGEOPT,NROT,NTRAN
        CALL ABRT
      END IF
 9124 FORMAT(1X,'NBLOCK HAS BEEN SET TO ZERO.  CHANGE THIS VALUE,'/
     *       1X,'OR ELSE NROT, NTRAN & NGEOPT IN $GLOBOP.'/
     *       1X,'NGEOPT=',I5,' NROT,NTRAN=',2I5/
     *       1X,'NBLOCK IS COMPUTED FROM NGEOPT/NROT+NTRAN')
     
 
C
C        BIG LOOP OVER BLOCKS OF RANDOM COORDINATES
C
      NACCT=0
      NRPAT=0
      NREJT=0
      DO 180 IGM=1,NBLOCK
         IF(MASWRK) WRITE(IW,9040) IGM,NBLOCK
C
C              LOOP OVER TRANSLATIONAL HOPS
C
         IFRAG=0
         DO 178 ITRAN=1,NTRAN
            II=0
            DO INF=1,NFRG
               IFRMOV(INF)=0
            ENDDO
C
  115       CONTINUE
            IF(IFRAG.EQ.NFRG) IFRAG=0
            IFRAG=IFRAG+1
            IF(IFXFRG(IFRAG).GT.0) THEN
               GO TO 115
            ELSE
               IFRMOV(IFRAG)=1
               II=II+1
               IF(II.LT.NFRMOV) GO TO 115
            END IF
C
C   DETERMINE NEW TEST COORDINATES
C
            IDC=LDC
            IDMC=LDMC
            DO 110 INF=1,NFRG
               IF(IFXFRG(INF).EQ.0.AND.IFRMOV(INF).EQ.1) THEN
                  XX(IDC  ) = XX(IDMC  )*(TWO*XX(IRN  )-ONE)
                  XX(IDC+1) = XX(IDMC+1)*(TWO*XX(IRN+1)-ONE)
                  XX(IDC+2) = XX(IDMC+2)*(TWO*XX(IRN+2)-ONE)
                  IRN=IRN+3
               ELSE
                  XX(IDC  ) = ZERO
                  XX(IDC+1) = ZERO
                  XX(IDC+2) = ZERO
               END IF
               IDMC=IDMC+3
               IDC=IDC+3
  110       CONTINUE
            XRAN = XX(IRN)
C
            IF(AIMOVE.GT.0.0D+00) THEN
               DO I=1,3*NAT
                  ARAN(I)=XX(IRN+I)
               ENDDO
               IRN=IRN+3*NAT+1
            ELSE
               IRN=IRN+1
            END IF
C
C    EVALUATE ENERGY AT NEW GEOMETRY
C
            IF(MASWRK.AND.NPRTGO.NE.2) WRITE(IW,*)
     *           'EVALUATE ENERGY AT NEW TRANSLATIONAL GEOMETRY'
C
            IF(MOD(IGLO-1,NGEOPT).EQ.0) MIN_C=.TRUE.
            CALL GLOFRG(TEMPER,XX(LDC),XX(LDA),XX(LWRK),XRAN,XX(LCMIN),
     $                  IGLO,XX(LDMC),XX(LDMA),IFRMOV,XX(LCOLD),
     $                  MCMIN,MIN_C,SMC,AIMOVE,ARAN,NSTMIN,NFTEN,NFTCR,
     *                  XX(LPROVEC),MXBF,NTMO,XX(LCANVEC),NTAO)
            MIN_C=.FALSE.
            IGLO=IGLO+1
  178    CONTINUE
C
C CLEAR TRANSLATIONAL DISPLACEMENTS
C
         IDC=LDC
         DO INF=1,NFRG
            XX(IDC  ) = ZERO
            XX(IDC+1) = ZERO
            XX(IDC+2) = ZERO
            IDC=IDC+3
         ENDDO
C
C              LOOP OVER ROTATIONAL HOPS
C
         IFRAG=0
         DO 179 IROT=1,NROT
            II=0
            DO INF=1,NFRG
              IFRMOV(INF)=0
            ENDDO
C
  125       CONTINUE
            IF(IFRAG.EQ.NFRG) IFRAG=0
            IFRAG=IFRAG+1
            IF(IFXFRG(IFRAG).GT.0) THEN
               GO TO 125
            ELSE
               IFRMOV(IFRAG)=1
               II=II+1
               IF(II.LT.NFRMOV) GO TO 125
            END IF
C
C   DETERMINE NEW TEST COORDINATES
C
            IDA=LDA
            IDMA=LDMA
            DO 120 INF=1,NFRG
               IF(IFXFRG(INF).EQ.0.AND.IFRMOV(INF).EQ.1) THEN
                  XX(IDA  ) = XX(IDMA  )*(TWO*XX(IRN  )-ONE)
                  XX(IDA+1) = XX(IDMA+1)*(TWO*XX(IRN+1)-ONE)
                  XX(IDA+2) = XX(IDMA+2)*(TWO*XX(IRN+2)-ONE)
                  IRN=IRN+3
               ELSE
                  XX(IDA  ) = ZERO
                  XX(IDA+1) = ZERO
                  XX(IDA+2) = ZERO
               END IF
               IDMA=IDMA+3
               IDA =IDA +3
  120       CONTINUE
            XRAN = XX(IRN)
            IRN=IRN+1
C
C    EVALUATE ENERGY AT NEW GEOMETRY
            IF(MASWRK.AND.NPRTGO.NE.2) WRITE(IW,*)
     *           'EVALUATE ENERGY AT NEW ROTATIONAL GEOMETRY'
C
            CALL GLOFRG(TEMPER,XX(LDC),XX(LDA),XX(LWRK),XRAN,XX(LCMIN),
     *                  IGLO,XX(LDMC),XX(LDMA),IFRMOV,XX(LCOLD),
     *                  MCMIN,MIN_C,SMC,AIMOVE,ARAN,NSTMIN,NFTEN,NFTCR,
     *                  XX(LPROVEC),MXBF,NTMO,XX(LCANVEC),NTAO)
            IGLO=IGLO+1
 179     CONTINUE
 180  CONTINUE
C
C               -180- IS THE END OF THE LOOP OVER BLOCKS
C
      ACCRATT=NACCT
      ACCRATT=ACCRATT/(NACCT+NREJT-NRPAT)
      IF(MASWRK) WRITE(IW,9011) TEMPER,NRPAT,NGEOPT-NRPAT,NREJT-NRPAT,
     $                          NACCT,ACCRATT,EMIN,IGOMIN
      TEMPER = TEMPER * GAMR
 200  CONTINUE
      ACCRAT=NACC
      ACCRAT=ACCRAT/(NACC+NREJ-NRPA)
      IF(MASWRK) THEN
         WRITE(IW,9005)
         WRITE(IW,9010) IGLO,NRPA,IGLO-NRPA,NREJ-NRPA,NACC,ACCRAT,
     *                  EPREV,EMIN,IGOMIN
         CALL PRFC
         CALL PRMNC(XX(LCMIN))
      END IF
C
      RUNTYP=OPT
      IF(NPRTGO.LT.0) NPRTGO=0
C
C  GEOMETRY OPTIMIZATION ON FINAL SA GEOMETRY
C
      IF(OPTN) THEN
         IF(MASWRK) WRITE(IW,9003)
         CALL SIGX(.FALSE.)
         IF(MASWRK) WRITE(IW,9002)
      END IF
C
C  GEOMETRY OPTIMIZATION ON MINIMUM-ENERGY SA GEOMETRY
C
      IF(OPTN) THEN
         IF(MASWRK) WRITE(IW,9004)
C
         CALL RSTCOR(XX(LCMIN),XX(LPROVEC),XX(LCANVEC),MXBF)
         IF (NFRG.GT.0.AND.NTMO.GT.0) THEN
            CALL DAWRIT(IDAF,IODA,XX(LPROVEC),LENPV,267,0)
         END IF
         IF (NFRG.GT.0.AND.NTAO.GT.0) THEN
            CALL DAWRIT(IDAF,IODA,XX(LCANVEC),LENCV,269,0)
         END IF
C
         CALL SIGX(.FALSE.)
         IF(MASWRK) WRITE(IW,9001)
      END IF
C
      CALL RETFM(NEED)
      CALL SEQCLO(NFTEN,'KEEP')
      CALL SEQCLO(NFTCR,'KEEP')
      IF(MASWRK) WRITE(IW,*) '..... END OF GLOBAL OPTIMIZATION .....'
      CALL TIMIT(1)
      RETURN
C
 9001 FORMAT(/10X,'***MINIMIZATION FROM MINIMUM-ENERGY SA ',
     *       'GEOMETRY COMPLETE***'/)
 9002 FORMAT(/10X,'***MINIMIZATION FROM FINAL SA GEOMETRY',
     *        ' COMPLETE***'/)
 9003 FORMAT(/10X,'***MINIMIZING ENERGY FROM FINAL SA GEOMETRY',
     *        '***'/)
 9004 FORMAT(/10X,'***MINIMIZING ENERGY FROM MINIMUM-ENERGY ',
     *        'SA GEOMETRY***'/)
 9005 FORMAT(/10X,'***GLOBAL OPTIMIZATION COMPLETE*** '/)
 9010 FORMAT(1X,'TOTAL NUMBER OF GEOMETRIES =   ',I6/
     *       1X,'NUMBER OF GEOMETRIES REJECTED '/
     *       1X,' DUE TO PROXIMITY ALERT =      ',I6/
     *       1X,'NUMBER OF ENERGY EVALUATIONS = ',I6/
     *       1X,'NUMBER OF ENERGIES REJECTED =  ',I6/
     *       1X,'NUMBER OF ENERGIES ACCEPTED =  ',I6/
     *       1X,'ACCEPTANCE RATIO =            ',F11.3/
     *       1X,'FINAL ENERGY FOUND =            ',F16.10/
     *       1X,'MINIMUM ENERGY FOUND =          ',F16.10,1X,
     *       1X,'AT GEOMETRY NUMBER ',I6//)
 9011 FORMAT(/10X,31(1H-)/10X,31HSTATISTICS FROM MONTE CARLO RUN/10X,
     *       31(1H-),//
     *       1X,'AT TEMPERATURE =               ',F9.2/
     *       1X,'NUMBER OF GEOMETRIES REJECTED ',/
     *       1X,' DUE TO PROXIMITY ALERT =      ',I6/
     *       1X,'NUMBER OF ENERGY EVALUATIONS = ',I6/
     *       1X,'NUMBER OF ENERGIES REJECTED =  ',I6/
     *       1X,'NUMBER OF ENERGIES ACCEPTED =  ',I6/
     *       1X,'ACCEPTANCE RATIO =            ',F11.3/
     *       1X,'MINIMUM ENERGY FOUND SO FAR =   ',F16.10,1X,
     *       1X,'AT GEOMETRY NUMBER ',I6,//)
 9020 FORMAT(1X,'TEMPERATURE NUMBER ',I3,' IS ',F9.2)
 9126 FORMAT(1X,'GAMR=',F12.6,' DACRAT=',F12.6,' UPDFAC=',F12.6)
 9040 FORMAT(/2X,'STARTING BLOCK',I4,1X,'OF',I4,'.'/)
 9050 FORMAT(/1X,19(1H-),5X,46(1H-)/
     *        1X,'GLOBAL OPTIMIZATION',5X,
     *        'WRITTEN BY PAUL DAY AND PRADIPTA BANDYOPADHYAY'/
     *        1X,19(1H-),5X,46(1H-))
      END
C*MODULE GLOBOP  *DECK GLOFRG
      SUBROUTINE GLOFRG(TEMPER,DSPCAR,DSPANG,WRK,XRAN,CMIN,IGLO,DMATC,
     *                  DMATA,IFRMOV,COLD,MCMIN,MIN_C,SMC,AIMOVE,
     *                  ARAN,NSTMIN,NFTEN,NFTCR,PROVEC,MXBF,NTMOX,
     *                  CANVEC,NTAOX)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK,PRXALT,ACCEPT,MOVIE,MOVIE2,
     *        MCMIN,MIN_C,SMC
C
      PARAMETER (MXATM=2000, MXAO=8192, MXSH=5000, MXGTOT=20000,
     *           MXPT=2000, MXFRG=1050, MXDFG=5, MXFGPT=12000,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 FRGNME
C
      DIMENSION WRK(*),DSPCAR(*),DSPANG(*),IFRMOV(*),DMATC(*),DMATA(*)
      DIMENSION COLD(*),CMIN(*),PROVEC(MXBF,NTMOX),ARAN(*)
      DIMENSION CANVEC(MXBF,NTAOX)
C
      COMMON /APPLE/  MOVIE,MOVIE2
      COMMON /EFPBAS/ EX(MXGTOT,MXDFG),CS(MXGTOT,MXDFG),
     *                CP(MXGTOT,MXDFG),CD(MXGTOT,MXDFG),
     *                CF(MXGTOT,MXDFG),CG(MXGTOT,MXDFG),
     *                PRNAME(MXFGPT),PRCORD(3,MXFGPT),EFZNUC(MXFGPT),
     *                KSTART(MXSH,MXDFG),KATOM(MXSH,MXDFG),
     *                KTYPE(MXSH,MXDFG),KNG(MXSH,MXDFG),
     *                KLOC(MXSH,MXDFG),KMIN(MXSH,MXDFG),
     *                KMAX(MXSH,MXDFG),NSHELL(MXDFG),NGAUSS(MXDFG),
     *                NATEF(MXDFG),NUMEF(MXDFG),NTPATM
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /EFPFMO/ IEFPFMO,ISWENUC,REPNUCEFP,EFPEFP,RUNEFP
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      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 /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /FUNCT / E,EG(3*MXATM)
      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 /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
      COMMON /PCMPAR/ IPCM,NFT26,NFT27,IKREP,IEF,IP_F,NFMOPCM
      COMMON /POLTMP/ POLT2(9),
     *                ACHGHF(2,MXPT),ADIPHF(3,MXPT),AQADHF(6,MXPT),
     *                AMULTMP(MXPT),BMULTMP(MXPT),
     *                AMULTMP2(MXPT),BMULTMP2(MXPT),
     *                TCLPD(4*MXPT),TZLPD(4*MXPT),
     *                JNLPR(4*MXPT),JKFR(MXPT),JKLR(MXPT),
     *                NDPTS(MXFRG),
     *                IEFP2,IEFMON,IEFSCR,IEFSCR2,IEFDIP,IEFQUD,IEFREP,
     *                IEFPOL,IEFPOL2,NDTTPT
      COMMON /RUNOPT/ RUNTYP,EXETYP,NEVALS,NGLEVL,NHLEVL
      COMMON /SIMDAT/ NACC,NREJ,IGOMIN,NRPA,IBWM,NACCT,NREJT,NRPAT,
     *                NPRTGO,IDPUNC,IGOFLG
      COMMON /SIMEN / EPREV,EMIN,ALPHA,DAVE,XMIN,XMAX,YMIN,YMAX
     *               ,ZMIN,ZMAX,XRANGE,YRANGE,ZRANGE,SEPTOL
     *               ,DACRAT,UPDFAC
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
      PARAMETER (ZERO=0.0D+00,ONE=1.0D+00,SCALTM=3.1667606D-06)
C
      DATA CHECK /8HCHECK   /
      DATA OPT/8HOPTIMIZE/,ENERGY/8HENERGY  /
C
      TRUNTP=RUNTYP
      LENPV=MXBF*NTMO
      LENCV=MXBF*NTAO
C
C      RESTORE THE COORDINATES OF THE LOWEST ENERGY CONFIGURATIONS
C
      IF(MIN_C) THEN
         CALL RSTCOR(CMIN,PROVEC,CANVEC,MXBF)
         IF (NFRG.GT.0.AND.NTMO.GT.0) THEN
            CALL DAWRIT(IDAF,IODA,PROVEC,LENPV,267,0)
         END IF
         IF (NFRG.GT.0.AND.NTAO.GT.0) THEN
            CALL DAWRIT(IDAF,IODA,CANVEC,LENCV,269,0)
         END IF
      END IF
      IF(IGLO.EQ.0) IM_A=1
      PRXALT=.FALSE.
C
C        GENERATE RANDOM COORDINATES IF NOT AT FIRST POINT
C
      IF(IGLO.GT.0) THEN
         BETA = ONE/(TEMPER*SCALTM)
         IF(IBWM.EQ.1) BETA = BETA/DAVE
C
C SAVE CURRENT COORDINATES
C
         IF (NFRG.GT.0.AND.NTMO.GT.0) THEN
            CALL DAREAD(IDAF,IODA,PROVEC,LENPV,267,0)
         END IF
         IF (NFRG.GT.0.AND.NTAO.GT.0) THEN
            CALL DAREAD(IDAF,IODA,CANVEC,LENCV,269,0)
         END IF
         CALL STCOR(COLD,PROVEC,CANVEC,MXBF)
C
C           MOVE AB INITIO ATOMS
C
         IIND=0
         DO IAB=1,NAT
            C(1,IAB)=C(1,IAB)+AIMOVE*(2.0D+00*ARAN(IIND+1)-ONE)
            C(2,IAB)=C(2,IAB)+AIMOVE*(2.0D+00*ARAN(IIND+2)-ONE)
            C(3,IAB)=C(3,IAB)+AIMOVE*(2.0D+00*ARAN(IIND+3)-ONE)
            IIND=IIND+3
         ENDDO
C
         NMST=0
         NPST=0
         NDPST=0
         NRST=0
         NDST=0
         NATST=0
         NORST=0
         NAOST=0
         IFRC=1
         DAVE=ZERO
C
C           MOVE FRAGMENT LOCATIONS
C
         DO 400 INF=1,NFRG
            IF(IFRMOV(INF).NE.0) THEN
C
C  CHECK IF STEP WILL BE OUT OF BOUNDS.  IF SO,
C  USE PERIODIC BOUNDARY.
C
 390           CONTINUE
               IOOB=0
C
               XTEMP=EFC(1,1+NMST)+DSPCAR(IFRC)
               YTEMP=EFC(2,1+NMST)+DSPCAR(IFRC+1)
               ZTEMP=EFC(3,1+NMST)+DSPCAR(IFRC+2)
C
               IF(XTEMP.GT.XMAX) THEN
                  DSPCAR(IFRC)=DSPCAR(IFRC) - XRANGE
                  IOOB=1
               ELSE IF(XTEMP.LT.XMIN) THEN
                  DSPCAR(IFRC)=DSPCAR(IFRC) + XRANGE
                  IOOB=1
               END IF
               IF(YTEMP.GT.YMAX) THEN
                  DSPCAR(IFRC+1)=DSPCAR(IFRC+1) - YRANGE
                  IOOB=1
               ELSE IF(YTEMP.LT.YMIN) THEN
                  DSPCAR(IFRC+1)=DSPCAR(IFRC+1) + YRANGE
                  IOOB=1
               END IF
               IF(ZTEMP.GT.ZMAX) THEN
                  DSPCAR(IFRC+2)=DSPCAR(IFRC+2) - ZRANGE
                  IOOB=1
               ELSE IF(ZTEMP.LT.ZMIN) THEN
                  DSPCAR(IFRC+2)=DSPCAR(IFRC+2) + ZRANGE
                  IOOB=1
               END IF
               IF(IOOB.EQ.1) GO TO 390
C
               DAVE=DAVE+ABS(DSPCAR(IFRC  ))+ABS(DSPCAR(IFRC+1))
     *                  +ABS(DSPCAR(IFRC+2))+ABS(DSPANG(IFRC  ))
     *                  +ABS(DSPANG(IFRC+1))+ABS(DSPANG(IFRC+2))
C
C                 THIS MOVES THE FRAGMENT IN QUESTION.
C
               CALL EFDSPL(INF,
     *               DSPCAR(IFRC),DSPCAR(IFRC+1),DSPCAR(IFRC+2),
     *               DSPANG(IFRC),DSPANG(IFRC+1),DSPANG(IFRC+2),
     *               NMST,NPST,NDPST,NRST,NDST,NATST,NORST,PROVEC,
     *               NAOST,CANVEC,MXBF)
            END IF
            NMST  = NMST  + NMPTS(INF)
            NPST  = NPST  + NPPTS(INF)
            NDPST = NDPST + NDPPTS(INF)
            NRST  = NRST  + NRPTS(INF)
            NDST  = NDST  + NDPTS(INF)
            NATST = NATST + NATEF(ISET(INF))
            NORST = NORST + NORB(INF)
            NAOST = NAOST + NAO(ISET(INF))
            IFRC=IFRC+3
  400    CONTINUE
C
         IF (NFRG.GT.0.AND.NTMO.GT.0)
     *       CALL DAWRIT(IDAF,IODA,PROVEC,LENPV,267,0)
         IF (NFRG.GT.0.AND.NTAO.GT.0)
     *       CALL DAWRIT(IDAF,IODA,CANVEC,LENCV,269,0)
C
         DAVE = DAVE/(6*NFRG)
      END IF
C         END OF "IF(NGLO.GT.0)"
C
C        PRINT COORDINATES OF THIS GLOBAL OPTIMIZATION POINT
C
      IF(MASWRK  .AND.  NPRTGO.NE.2) THEN
         WRITE(IW,9008) IGLO
      IF(NPRTGO.NE.2) CALL PRATM(IW,1)
      END IF
C
C-MWS-      IF(MASWRK.AND.NPRTGO.GT.1) THEN
C-MWS-         WRITE (IW,9008) IGLO
C-MWS-         IF(ICOORD.NE.4) THEN
C-MWS-            DO 100 I = 1,NAT
C-MWS-              WRITE (IW,9028) I,ANAM(I),BNAM(I),C(1,I)*UNITS,
C-MWS-     $        C(2,I)*UNITS,C(3,I)*UNITS
C-MWS-  100       CONTINUE
C-MWS-         END IF
C-MWS-C
C-MWS-         IF(NFRG.GT.0) THEN
C-MWS-            WRITE(IW,9011)
C-MWS-            WRITE(IW,9021)
C-MWS-            IAT=0
C-MWS-            DO 120 IFRG=1,NFRG
C-MWS-               WRITE(IW,9022) FRGNAM(IFRG)
C-MWS-               DO 110 III=1,NMPTS(IFRG)
C-MWS-                  IAT=IAT+1
C-MWS-                  IF(FMASS(III,IFRG).GT.ZERO) THEN
C-MWS-                     XF = EFC(1,IAT)*UNITS
C-MWS-                     YF = EFC(2,IAT)*UNITS
C-MWS-                     ZF = EFC(3,IAT)*UNITS
C-MWS-                     WRITE(IW,9031) FRGNME(IAT),XF,YF,ZF
C-MWS-                  END IF
C-MWS-  110         CONTINUE
C-MWS-  120      CONTINUE
C-MWS-         END IF
C-MWS-      END IF
C-MWS- 9011 FORMAT(1X,'COORDS OF FRAGMENT MULTIPOLE CENTERS (ANG.)')
C-MWS- 9021 FORMAT(1X,'MULTIPOLE NAME',9X,'X',18X,'Y',18X,'Z'/
C-MWS-     *       1X,60(1H-))
C-MWS- 9022 FORMAT(1X,'FRAGNAME=',A6)
C-MWS- 9028 FORMAT(1X,I3,2X,A8,A2,3F18.13)
C-MWS- 9031 FORMAT(1X,A8,7X,3F18.13)
C
C     CHECK THE DISPLACEMENT FOR NUCLEI TOO CLOSE TOGETHER
C     IF ANY ARE, REGISTER A PROXIMITY ALERT!
C
      IF(NFRG.GT.0) THEN
        IAT=0
        KMASS=0
        DO 220 IFRG=1,NFRG
         DO 210 III=1,NMPTS(IFRG)
          IAT=IAT+1
          IF(FMASS(III+KMASS).GT.ZERO) THEN
           XF = EFC(1,IAT)
           YF = EFC(2,IAT)
           ZF = EFC(3,IAT)
           IF(ICOORD.NE.4) THEN
           DO 200 I = 1,NAT
             SEP2 = (XF-C(1,I))**2+(YF-C(2,I))**2+(ZF-C(3,I))**2
             SEP = SQRT(SEP2)
             IF(SEP.LT.SEPTOL) THEN
               PRXALT = .TRUE.
               IF(MASWRK.AND.NPRTGO.NE.2) WRITE(IW,9228)IGLO,III,IFRG,I
             END IF
  200      CONTINUE
           END IF
           IAT2=0
           KMASS2=0
           DO 202 IFRG2=1,NFRG
             DO 201 III2=1,NMPTS(IFRG2)
               IAT2=IAT2+1
               IF(IFRG2.LE.IFRG) GO TO 201
               IF(FMASS(III2+KMASS2).GT.ZERO) THEN
                 XF2 = EFC(1,IAT2)
                 YF2 = EFC(2,IAT2)
                 ZF2 = EFC(3,IAT2)
                 SEP2 = (XF-XF2)**2+(YF-YF2)**2+(ZF-ZF2)**2
                 SEP = SQRT(SEP2)
                 IF(SEP.LT.SEPTOL) THEN
                    PRXALT = .TRUE.
                    IF(MASWRK.AND.NPRTGO.NE.2) WRITE(IW,9229)
     $                                 IGLO,III,IFRG,III2,IFRG2
                 END IF
               END IF
  201        CONTINUE
             KMASS2=KMASS2+NMPTS(IFRG2)
  202      CONTINUE
          END IF
  210    CONTINUE
         KMASS=KMASS+NMPTS(IFRG)
  220   CONTINUE
      END IF
C
C
      E = ZERO
      ACCEPT=.FALSE.
      IF(PRXALT) THEN
        NRPA = NRPA +1
        NRPAT = NRPAT +1
        IF(MASWRK.AND.NPRTGO.NE.2) WRITE(IW,*)
     *           'REJECTED DUE TO PROXIMITY ALERT'
        GO TO 440
      END IF
      IF (IGLO.EQ.0) THEN
        E=ZERO
        IF(MCMIN) THEN
          RUNTYP=OPT
          CALL SIGX(.FALSE.)
          RUNTYP=TRUNTP
C------ADDITION-OF-PRADIPTA
          IF(IEFPFMO.EQ.0.AND.ICOORD.NE.4) CALL FFSVMO(0,WRK)
C---------------------------
        ELSE
C--       IF(MASWRK) WRITE(IW,*) 'JUST-INSIDE-GLOFRG-IPCM-2',IPCM,IEFP
          IF (IEFPFMO.EQ.1) THEN
            RUNTYP=ENERGY
            CALL FMOX(1)
            RUNTYP=TRUNTP
          ELSE
            CALL ENERGX
          ENDIF
C--       IF(MASWRK) WRITE(IW,*) 'JUST-INSIDE-GLOFRG-IPCM-3',IPCM,IEFP
C
C--------HERE-THE-ENERGY-AND-STEP-NUMBER-ARE-WRITTEN-TO-THE-DISK-FILE
C
          IF(MASWRK) WRITE(NFTEN,*) E,IGLO
          IF(MASWRK) CALL FLSHBF(NFTEN)
C
C--------HERE-COORDINATES--ARE-WRITTEN-TO-THE-DISK-FILE
C
          DO 1700 I=1,NAT
            IF(MASWRK) WRITE(NFTCR,*) C(1,I),C(2,I),C(3,I)
 1700     ENDDO
          IAT=0
          KMASS=0
          DO 1720 IFRG=1,NFRG
             DO 1710 III=1,NMPTS(IFRG)
                IAT=IAT+1
                IF(MASWRK.AND.FMASS(III+KMASS).GT.ZERO) WRITE(NFTCR,*)
     *               EFC(1,IAT),EFC(2,IAT),EFC(3,IAT)
 1710         CONTINUE
              KMASS=KMASS+NMPTS(IFRG)
 1720      CONTINUE
           IF(MASWRK) CALL FLSHBF(NFTCR)
           IF(IEFPFMO.EQ.0.AND.ICOORD.NE.4) CALL FFSVMO(0,WRK)
        END IF
C
C           SAVE, INITIALIZING THE "BEST POINT SO FAR" INFORMATION
C
        EPREV=E
        EMIN=E
        IF (NFRG.GT.0.AND.NTMO.GT.0) THEN
           CALL DAREAD(IDAF,IODA,PROVEC,LENPV,267,0)
        END IF
        IF (NFRG.GT.0.AND.NTAO.GT.0) THEN
           CALL DAREAD(IDAF,IODA,CANVEC,LENCV,269,0)
        END IF
        CALL STCOR(CMIN,PROVEC,CANVEC,MXBF)
C
        IGOMIN = IGLO
        IF(MASWRK) WRITE(IW,9290) IGLO,E
        IF(MOVIE2) THEN
          CALL PRMOV(4,1)
        ELSE
          IF(MASWRK)WRITE(4,9291)E,IGLO
          IF(NPRTGO.NE.2) CALL PRATM(4,1)
        END IF
      ELSE
C
C-----IF-IGLO.GT.0
        E=ZERO
C---FOR THE EFP+PCM PART
        IF(IP_F.EQ.1) CALL MAKCVM
C---    IF(MASWRK) WRITE(IW,*)'IP_F-VALUE',IP_F,IPCM,IEFP
        IF(MCMIN.AND.(NSTMIN.EQ.1.OR.(MOD(IGLO+1,NSTMIN).EQ.0)))
     *    THEN
           RUNTYP=OPT
           CALL SIGX(.FALSE.)
           RUNTYP=TRUNTP
           IF(IDPUNC.EQ.1)GO TO 450
         ELSE
C------PRADIPTA
           IF((ICOORD.EQ.4).OR.(IP_F.EQ.1).OR.(NSTMIN.EQ.1)) THEN
             IF (IEFPFMO.EQ.1) THEN
               RUNTYP=ENERGY
               CALL FMOX(1)
               RUNTYP=TRUNTP
             ELSE
               CALL ENERGX
             ENDIF
           ELSE
             IF (IEFPFMO.EQ.1) THEN
                RUNTYP=ENERGY
                CALL FMOX(1)
                RUNTYP=TRUNTP
              ELSE
                CALL ENERGX
              ENDIF
C------IT-IS-A-TEMPORARY-ARRANGEMENT-
C----I-WILL-LOOK-FOR-THE-BUG-LATER
C             CALL ONEEI
C             CALL WFN
C             CALL FFSVMO(1,WRK)
C
           END IF
         END IF
         IF(MASWRK.AND.NPRTGO.NE.2) WRITE(IW,*)'EPREV,E',EPREV,E
         IF(E.LT.EPREV) THEN
          ACCEPT=.TRUE.
         ELSE
          APROP = EXP(-(E-EPREV)*BETA)
          IF(MASWRK.AND.NPRTGO.NE.2) WRITE(IW,*)'APROP,XRAN',APROP,XRAN
          IF(APROP.GT.XRAN) THEN
            ACCEPT=.TRUE.
          END IF
         END IF
C
C           STORE (AND PRINT INFO ABOUT) THIS ENERGY/GEOMETRY/EFP DATA,
C           IF ITS THE BEST ENERGY FOUND SO FAR
C
         IF(E.LT.EMIN) THEN
           EMIN=E
           IF (NFRG.GT.0.AND.NTMO.GT.0) THEN
             CALL DAREAD(IDAF,IODA,PROVEC,LENPV,267,0)
           END IF
           IF (NFRG.GT.0.AND.NTAO.GT.0) THEN
             CALL DAREAD(IDAF,IODA,CANVEC,LENCV,269,0)
           END IF
           CALL STCOR(CMIN,PROVEC,CANVEC,MXBF)
C
           IM_A=IM_A+1
           IF(MASWRK .AND. NPRTGO.NE.2) WRITE(IW,*)'IM_A1',E,EMIN,IM_A
           IF(.NOT.SMC) THEN
             IF(MASWRK) WRITE(NFTEN,*) E,IGLO
             CALL FLSHBF(NFTEN)
             DO 1800 I=1,NAT
                IF(MASWRK) WRITE(NFTCR,*) C(1,I),C(2,I),C(3,I)
 1800        ENDDO
             IAT=0
             KMASS=0
             DO 1820 IFRG=1,NFRG
                DO 1810 III=1,NMPTS(IFRG)
                   IAT=IAT+1
                   IF(MASWRK .AND. FMASS(III+KMASS).GT.ZERO)
     *                WRITE(NFTCR,*) EFC(1,IAT),EFC(2,IAT),
     *                               EFC(3,IAT)
 1810           CONTINUE
                KMASS=KMASS+NMPTS(IFRG)
 1820       CONTINUE
            IF(MASWRK) CALL FLSHBF(NFTCR)
           END IF
C
           IGOMIN = IGLO
         END IF
      END IF
 440  CONTINUE
C
      IF(E.EQ.ZERO   .AND.  IGLO.EQ.0  .AND. EXETYP.NE.CHECK) THEN
         IF (MASWRK .AND. NPRTGO.NE.2) WRITE(IW,9100)
         CALL ABRT
      END IF
C
C                   ******
      IF(IGLO.EQ.0) RETURN
C                   ******
C
 450  CONTINUE
        IF(ACCEPT) THEN
C  USE THIS GEOMETRY AS STARTING POINT FOR NEXT STEP
C  AND KEEP THIS ENERGY AS REFERENCE ENERGY FOR NEXT GEOMETRY
C  AND REFINE DMAT TO GIVE A BETTER STEP
         NACC=NACC+1
         NACCT=NACCT+1
         EPREV=E
         IF(MASWRK .AND. NPRTGO.NE.2) WRITE(IW,9290) IGLO,E
         IGOFLG=1
         IF(MOVIE2)THEN
           CALL PRMOV(4,1)
         ELSE
           IF(MASWRK .AND. NPRTGO.NE.2)WRITE(4,9291)E,IGLO
           IF(NPRTGO.NE.2) CALL PRATM(4,1)
         END IF
         IF(ALPHA.NE.ZERO) THEN
         II=1
         IF(MASWRK) WRITE(IW,9009) ALPHA
         DO 445 INF=1,NFRG
          IF(IFRMOV(INF).NE.0) THEN
           DMATC(II) = DMATC(II)*(ONE-ALPHA) + ALPHA*ABS(DSPCAR(II))
           DMATC(II+1)=DMATC(II+1)*(ONE-ALPHA)+ALPHA*ABS(DSPCAR(II+1))
           DMATC(II+2) = DMATC(II+2)*(ONE-ALPHA)+ALPHA*ABS(DSPCAR(II+2))
           DMATA(II) = DMATA(II)*(ONE-ALPHA) + ALPHA*ABS(DSPANG(II))
           DMATA(II+1) = DMATA(II+1)*(ONE-ALPHA)+ALPHA*ABS(DSPANG(II+1))
           DMATA(II+2) = DMATA(II+2)*(ONE-ALPHA)+ALPHA*ABS(DSPANG(II+2))
          END IF
          II=II+3
 445     CONTINUE
         END IF
C-----WRITE-THE-ENERGY-AND-COORDINATES-OF-THE ACCEPTED STEP-
        IF(SMC) THEN
           IF(MASWRK) WRITE(NFTEN,*) E,IGLO
           IF(MASWRK) CALL FLSHBF(NFTEN)
C--------
           DO 2400 I=1,NAT
              IF(MASWRK) WRITE(NFTCR,*) C(1,I),C(2,I),C(3,I)
 2400      ENDDO
           IAT=0
           KMASS=0
           DO 2420 IFRG=1,NFRG
              DO 2410 III=1,NMPTS(IFRG)
                 IAT=IAT+1
                 IF(MASWRK.AND.FMASS(III+KMASS).GT.ZERO) WRITE(NFTCR,*)
     *               EFC(1,IAT),EFC(2,IAT),EFC(3,IAT)
 2410        CONTINUE
             KMASS=KMASS+NMPTS(IFRG)
 2420      CONTINUE
        END IF
        GO TO 500
C
        ELSE
C  RESTORE OLD COORDINATES
          IF(MASWRK.AND.NPRTGO.NE.2) WRITE(IW,*)
     *       'WE SHOULD BE HERE ONLY IF IT WAS REJECTED'
C
         CALL RSTCOR(COLD,PROVEC,CANVEC,MXBF)
         IF (NFRG.GT.0.AND.NTMO.GT.0) THEN
            CALL DAWRIT(IDAF,IODA,PROVEC,LENPV,267,0)
         END IF
         IF (NFRG.GT.0.AND.NTAO.GT.0) THEN
            CALL DAWRIT(IDAF,IODA,CANVEC,LENCV,269,0)
         END IF
C
         NREJ = NREJ + 1
         NREJT = NREJT + 1
C----WRITES-THE-ENERGY-AND-COORDINATES-OF-THE-PREVIOUS-STEP
          IF(SMC) THEN
             IF(MASWRK) WRITE(NFTEN,*) EPREV,IGLO
             IF(MASWRK) CALL FLSHBF(NFTEN)
C--------
             DO 2300 I=1,NAT
               IF(MASWRK) WRITE(NFTCR,*) C(1,I),C(2,I),C(3,I)
 2300        ENDDO
             IAT=0
             KMASS=0
             DO 2320 IFRG=1,NFRG
                DO 2310 III=1,NMPTS(IFRG)
                   IAT=IAT+1
                   IF(MASWRK.AND.FMASS(III+KMASS).GT.ZERO)
     *                WRITE(NFTCR,*)
     *                EFC(1,IAT),EFC(2,IAT),EFC(3,IAT)
 2310         CONTINUE
              KMASS=KMASS+NMPTS(IFRG)
 2320       CONTINUE
          END IF
C
        END IF
 500  CONTINUE
C
      RETURN
C
 9008 FORMAT(1X,'NUCLEAR COORDINATES FOR GLOBAL OPTIMIZATION POINT',I3)
 9009 FORMAT(3X,'USING ALPHA=',F5.4,1X,'TO UPDATE DMAT.')
 9100 FORMAT(1X,' ***  SCF DID NOT CONVERGE AT INITIAL GEOMETRY')
 9228 FORMAT(1X,'IN GEOMETRY ',I5,' POINT ',I5,' IN FRAGMENT ',I5,
     $ /,'IS TOO CLOSE TO NUCLEI ',I5)
 9229 FORMAT(1X,'IN GEOMETRY ',I5,' POINT ',I5,' IN FRAGMENT ',I5,
     $ /,'IS TOO CLOSE TO POINT ',I5,' IN FRAGMENT ',I5)
 9290 FORMAT(/3X,'ENERGY ACCEPTED AT GLOBAL SEARCH POINT',I6,
     *           ' IS ',F20.10)
 9291 FORMAT('ENERGY = ',F20.8,' ACCEPTED AT GLOBAL SEARCH POINT',I6)
      END
C*MODULE GLOBOP  *DECK STCOR
      SUBROUTINE STCOR(CMIN,PROVEC,CANVEC,MXBF)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000, MXAO=8192, MXSH=5000, MXGTOT=20000,
     *           MXFRG=1050, MXFGPT=12000, MXDFG=5, MXIFRQ=12,
     *           MXDPPT=MXFRG*MXDFG*12, MXPT=2000)
C
      CHARACTER*8 FRGNME,REPNAM,POLNAM,DPOLNAM,DNAME,DPSNAM
C
      COMMON /EFPBAS/ EX(MXGTOT,MXDFG),CS(MXGTOT,MXDFG),
     *                CP(MXGTOT,MXDFG),CD(MXGTOT,MXDFG),
     *                CF(MXGTOT,MXDFG),CG(MXGTOT,MXDFG),
     *                PRNAME(MXFGPT),PRCORD(3,MXFGPT),EFZNUC(MXFGPT),
     *                KSTART(MXSH,MXDFG),KATOM(MXSH,MXDFG),
     *                KTYPE(MXSH,MXDFG),KNG(MXSH,MXDFG),
     *                KLOC(MXSH,MXDFG),KMIN(MXSH,MXDFG),
     *                KMAX(MXSH,MXDFG),NSHELL(MXDFG),NGAUSS(MXDFG),
     *                NATEF(MXDFG),NUMEF(MXDFG),NTPATM
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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 /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /EFPPAR/ EFP(3,MXFGPT),EFPOL(9,MXFGPT),
     *                EFDP(3,MXIFRQ*MXFGPT),EFDPOL(9,MXIFRQ*MXFGPT),
     *                ENO,DIND(3,MXFGPT),DINDD(3,MXFGPT),
     *                POLNAM(MXFGPT),DPOLNAM(MXIFRQ*MXFGPT),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
      COMMON /POLTMP/ POLT2(9),
     *                ACHGHF(2,MXPT),ADIPHF(3,MXPT),AQADHF(6,MXPT),
     *                AMULTMP(MXPT),BMULTMP(MXPT),
     *                AMULTMP2(MXPT),BMULTMP2(MXPT),
     *                TCLPD(4*MXPT),TZLPD(4*MXPT),
     *                JNLPR(4*MXPT),JKFR(MXPT),JKLR(MXPT),
     *                NDPTS(MXFRG),
     *                IEFP2,IEFMON,IEFSCR,IEFSCR2,IEFDIP,IEFQUD,IEFREP,
     *                IEFPOL,IEFPOL2,NDTTPT
      COMMON /POL2  / CHGHF(2,MXFGPT),DIPHF(3,MXFGPT),QADHF(6,MXFGPT),
     *                AMULTHF(MXFGPT),BMULTHF(MXFGPT),
     *                AMULT2HF(MXFGPT),BMULT2HF(MXFGPT),
     *                EFPOL2(9,MXFRG),DIND2(3,MXFGPT),DINDD2(3,MXFGPT),
     *                DCORD(3,MXPT),CDIS(3,MXFGPT),
     *                CLPD(4*MXFGPT),ZLPD(4*MXFGPT),
     *                NLPD(4*MXFGPT),KFD(MXFGPT),KLD(MXFGPT),
     *                DNAME(MXPT),DPSNAM(MXFGPT)
      COMMON /REPPAR/ CREP(3,MXFGPT),CLPR(4*MXFGPT),ZLPR(4*MXFGPT),
     *                NLPR(4*MXFGPT),KFR(MXFGPT),KLR(MXFGPT),
     *                REPNAM(MXFGPT)
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
      DIMENSION CMIN(*)
C
      DIMENSION PROVEC(MXBF,*),CANVEC(MXBF,*)
C
C     STORE NEW MINIMUM ENERGY COORDINATES
C
         IMN=1
         IF(ICOORD.NE.4) THEN
         DO 100 I = 1,NAT
            CMIN(IMN  ) = C(1,I)
            CMIN(IMN+1) = C(2,I)
            CMIN(IMN+2) = C(3,I)
            IMN=IMN+3
  100    CONTINUE
         END IF
C
         IF(NFRG.GT.0) THEN
            IAT=0
            DO 120 IFRG=1,NFRG
               DO 110 III=1,NMPTS(IFRG)
                  IAT=IAT+1
                  CMIN(IMN  ) = EFC(1,IAT)
                  CMIN(IMN+1) = EFC(2,IAT)
                  CMIN(IMN+2) = EFC(3,IAT)
                  IMN=IMN+3
  110         CONTINUE
  120      CONTINUE
C
            IAT=0
            NPST=0
            NDPST=0
            NRST=0
            NATST=0
            NORST=0
            NAOST=0
            NDST=0
            DO 121 IFRG=1,NFRG
               DO 119 III=1,NMPTS(IFRG)
                  IAT=IAT+1
C
                  CMIN(IMN  ) =  EFDIP(1,IAT)
                  CMIN(IMN+1) =  EFDIP(2,IAT)
                  CMIN(IMN+2) =  EFDIP(3,IAT)
                  CMIN(IMN+3) =  EFQAD(1,IAT)
                  CMIN(IMN+4) =  EFQAD(2,IAT)
                  CMIN(IMN+5) =  EFQAD(3,IAT)
                  CMIN(IMN+6) =  EFQAD(4,IAT)
                  CMIN(IMN+7) =  EFQAD(5,IAT)
                  CMIN(IMN+8) =  EFQAD(6,IAT)
                  CMIN(IMN+9) =  EFOCT(1,IAT)
                  CMIN(IMN+10) =  EFOCT(2,IAT)
                  CMIN(IMN+11) =  EFOCT(3,IAT)
                  CMIN(IMN+12) =  EFOCT(4,IAT)
                  CMIN(IMN+13) =  EFOCT(5,IAT)
                  CMIN(IMN+14) =  EFOCT(6,IAT)
                  CMIN(IMN+15) =  EFOCT(7,IAT)
                  CMIN(IMN+16) =  EFOCT(8,IAT)
                  CMIN(IMN+17) =  EFOCT(9,IAT)
                  CMIN(IMN+18) =  EFOCT(10,IAT)
                  IMN=IMN+19
  119         CONTINUE
              DO 111 III=1,NPPTS(IFRG)
                  NPST=NPST+1
                  CMIN(IMN  ) =  EFP(1,NPST)
                  CMIN(IMN+1) =  EFP(2,NPST)
                  CMIN(IMN+2) =  EFP(3,NPST)
                  CMIN(IMN+3) =  EFPOL(1,NPST)
                  CMIN(IMN+4) =  EFPOL(2,NPST)
                  CMIN(IMN+5) =  EFPOL(3,NPST)
                  CMIN(IMN+6) =  EFPOL(4,NPST)
                  CMIN(IMN+7) =  EFPOL(5,NPST)
                  CMIN(IMN+8) =  EFPOL(6,NPST)
                  CMIN(IMN+9) =  EFPOL(7,NPST)
                  CMIN(IMN+10) =  EFPOL(8,NPST)
                  CMIN(IMN+11) =  EFPOL(9,NPST)
                  IMN=IMN+12
  111         CONTINUE
              DO 112 III=1,NRPTS(IFRG)
                  NRST=NRST+1
                  CMIN(IMN  ) =  CREP(1,NRST)
                  CMIN(IMN+1) =  CREP(2,NRST)
                  CMIN(IMN+2) =  CREP(3,NRST)
                  IMN=IMN+3
  112         CONTINUE
              DO 113 III=1,NATEF(ISET(IFRG))
                  NATST=NATST+1
                  CMIN(IMN  ) =  PRCORD(1,NATST)
                  CMIN(IMN+1) =  PRCORD(2,NATST)
                  CMIN(IMN+2) =  PRCORD(3,NATST)
                  IMN=IMN+3
  113         CONTINUE
              DO 115 NSHL = 1,NSHELL(ISET(IFRG))
                 ITYP=KMAX(NSHL,ISET(IFRG))-KMIN(NSHL,ISET(IFRG))+1
                 LOC = KLOC(NSHL,ISET(IFRG))
                 IF(ITYP.EQ.3) THEN
                   DO  III=1,NORB(IFRG)
                    CMIN(IMN  ) =  PROVEC(LOC  ,NORST+III)
                    CMIN(IMN+1) =  PROVEC(LOC+1,NORST+III)
                    CMIN(IMN+2) =  PROVEC(LOC+2,NORST+III)
                    IMN=IMN+3
                   END DO
                 END IF
                 IF(ITYP.EQ.4) THEN
                   DO  III=1,NORB(IFRG)
                    CMIN(IMN  ) =  PROVEC(LOC+1,NORST+III)
                    CMIN(IMN+1) =  PROVEC(LOC+2,NORST+III)
                    CMIN(IMN+2) =  PROVEC(LOC+3,NORST+III)
                    IMN=IMN+3
                   END DO
                 END IF
                 IF(ITYP.EQ.6) THEN
                   DO  III=1,NORB(IFRG)
                    CMIN(IMN  ) =  PROVEC(LOC  ,NORST+III)
                    CMIN(IMN+1) =  PROVEC(LOC+1,NORST+III)
                    CMIN(IMN+2) =  PROVEC(LOC+2,NORST+III)
                    CMIN(IMN+3) =  PROVEC(LOC+3,NORST+III)
                    CMIN(IMN+4) =  PROVEC(LOC+4,NORST+III)
                    CMIN(IMN+5) =  PROVEC(LOC+5,NORST+III)
                    IMN=IMN+6
                   END DO
                 END IF
                 IF(ITYP.EQ.10) THEN
                   DO  III=1,NORB(IFRG)
                    CMIN(IMN  ) =  PROVEC(LOC  ,NORST+III)
                    CMIN(IMN+1) =  PROVEC(LOC+1,NORST+III)
                    CMIN(IMN+2) =  PROVEC(LOC+2,NORST+III)
                    CMIN(IMN+3) =  PROVEC(LOC+3,NORST+III)
                    CMIN(IMN+4) =  PROVEC(LOC+4,NORST+III)
                    CMIN(IMN+5) =  PROVEC(LOC+5,NORST+III)
                    CMIN(IMN+6) =  PROVEC(LOC+6,NORST+III)
                    CMIN(IMN+7) =  PROVEC(LOC+7,NORST+III)
                    CMIN(IMN+8) =  PROVEC(LOC+8,NORST+III)
                    CMIN(IMN+9) =  PROVEC(LOC+9,NORST+III)
                    IMN=IMN+10
                   END DO
                 END IF
                 IF(ITYP.EQ.15) THEN
                   DO  III=1,NORB(IFRG)
                    CMIN(IMN  ) =  PROVEC(LOC  ,NORST+III)
                    CMIN(IMN+1) =  PROVEC(LOC+1,NORST+III)
                    CMIN(IMN+2) =  PROVEC(LOC+2,NORST+III)
                    CMIN(IMN+3) =  PROVEC(LOC+3,NORST+III)
                    CMIN(IMN+4) =  PROVEC(LOC+4,NORST+III)
                    CMIN(IMN+5) =  PROVEC(LOC+5,NORST+III)
                    CMIN(IMN+6) =  PROVEC(LOC+6,NORST+III)
                    CMIN(IMN+7) =  PROVEC(LOC+7,NORST+III)
                    CMIN(IMN+8) =  PROVEC(LOC+8,NORST+III)
                    CMIN(IMN+9) =  PROVEC(LOC+9,NORST+III)
                    CMIN(IMN+10) =  PROVEC(LOC+10,NORST+III)
                    CMIN(IMN+11) =  PROVEC(LOC+11,NORST+III)
                    CMIN(IMN+12) =  PROVEC(LOC+12,NORST+III)
                    CMIN(IMN+13) =  PROVEC(LOC+13,NORST+III)
                    CMIN(IMN+14) =  PROVEC(LOC+14,NORST+III)
                    IMN=IMN+15
                   END DO
                 END IF
                 IF(ITYP.EQ.3) THEN
                   DO  III=1,NAO(ISET(IFRG))
                    CMIN(IMN  ) =  CANVEC(LOC  ,NAOST+III)
                    CMIN(IMN+1) =  CANVEC(LOC+1,NAOST+III)
                    CMIN(IMN+2) =  CANVEC(LOC+2,NAOST+III)
                    IMN=IMN+3
                   END DO
                 END IF
                 IF(ITYP.EQ.4) THEN
                   DO  III=1,NAO(ISET(IFRG))
                    CMIN(IMN  ) =  CANVEC(LOC+1,NAOST+III)
                    CMIN(IMN+1) =  CANVEC(LOC+2,NAOST+III)
                    CMIN(IMN+2) =  CANVEC(LOC+3,NAOST+III)
                    IMN=IMN+3
                   END DO
                 END IF
                 IF(ITYP.EQ.6) THEN
                   DO  III=1,NAO(ISET(IFRG))
                    CMIN(IMN  ) =  CANVEC(LOC  ,NAOST+III)
                    CMIN(IMN+1) =  CANVEC(LOC+1,NAOST+III)
                    CMIN(IMN+2) =  CANVEC(LOC+2,NAOST+III)
                    CMIN(IMN+3) =  CANVEC(LOC+3,NAOST+III)
                    CMIN(IMN+4) =  CANVEC(LOC+4,NAOST+III)
                    CMIN(IMN+5) =  CANVEC(LOC+5,NAOST+III)
                    IMN=IMN+6
                   END DO
                 END IF
                 IF(ITYP.EQ.10) THEN
                   DO  III=1,NAO(ISET(IFRG))
                    CMIN(IMN  ) =  CANVEC(LOC  ,NAOST+III)
                    CMIN(IMN+1) =  CANVEC(LOC+1,NAOST+III)
                    CMIN(IMN+2) =  CANVEC(LOC+2,NAOST+III)
                    CMIN(IMN+3) =  CANVEC(LOC+3,NAOST+III)
                    CMIN(IMN+4) =  CANVEC(LOC+4,NAOST+III)
                    CMIN(IMN+5) =  CANVEC(LOC+5,NAOST+III)
                    CMIN(IMN+6) =  CANVEC(LOC+6,NAOST+III)
                    CMIN(IMN+7) =  CANVEC(LOC+7,NAOST+III)
                    CMIN(IMN+8) =  CANVEC(LOC+8,NAOST+III)
                    CMIN(IMN+9) =  CANVEC(LOC+9,NAOST+III)
                    IMN=IMN+10
                   END DO
                 END IF
                 IF(ITYP.EQ.15) THEN
                   DO  III=1,NAO(ISET(IFRG))
                    CMIN(IMN  ) =  CANVEC(LOC  ,NAOST+III)
                    CMIN(IMN+1) =  CANVEC(LOC+1,NAOST+III)
                    CMIN(IMN+2) =  CANVEC(LOC+2,NAOST+III)
                    CMIN(IMN+3) =  CANVEC(LOC+3,NAOST+III)
                    CMIN(IMN+4) =  CANVEC(LOC+4,NAOST+III)
                    CMIN(IMN+5) =  CANVEC(LOC+5,NAOST+III)
                    CMIN(IMN+6) =  CANVEC(LOC+6,NAOST+III)
                    CMIN(IMN+7) =  CANVEC(LOC+7,NAOST+III)
                    CMIN(IMN+8) =  CANVEC(LOC+8,NAOST+III)
                    CMIN(IMN+9) =  CANVEC(LOC+9,NAOST+III)
                    CMIN(IMN+10) =  CANVEC(LOC+10,NAOST+III)
                    CMIN(IMN+11) =  CANVEC(LOC+11,NAOST+III)
                    CMIN(IMN+12) =  CANVEC(LOC+12,NAOST+III)
                    CMIN(IMN+13) =  CANVEC(LOC+13,NAOST+III)
                    CMIN(IMN+14) =  CANVEC(LOC+14,NAOST+III)
                    IMN=IMN+15
                   END DO
                 END IF
  115         CONTINUE
                 DO  III=1,NORB(IFRG)
                   CMIN(IMN  ) =  CENTCD(1,NORST+III)
                   CMIN(IMN+1) =  CENTCD(2,NORST+III)
                   CMIN(IMN+2) =  CENTCD(3,NORST+III)
                   IMN=IMN+3
                 END DO
                 NORST=NORST+NORB(IFRG)
                 NAOST=NAOST+NAO(ISET(IFRG))
C
C SAVE DYNAMIC POLARIZABILITY
C
              DO 116 III=1,NDPPTS(IFRG)
                  NDPST=NDPST+1
                  CMIN(IMN  ) =  EFDP(1,NDPST)
                  CMIN(IMN+1) =  EFDP(2,NDPST)
                  CMIN(IMN+2) =  EFDP(3,NDPST)
                  CMIN(IMN+3) =  EFDPOL(1,NDPST)
                  CMIN(IMN+4) =  EFDPOL(2,NDPST)
                  CMIN(IMN+5) =  EFDPOL(3,NDPST)
                  CMIN(IMN+6) =  EFDPOL(4,NDPST)
                  CMIN(IMN+7) =  EFDPOL(5,NDPST)
                  CMIN(IMN+8) =  EFDPOL(6,NDPST)
                  CMIN(IMN+9) =  EFDPOL(7,NDPST)
                  CMIN(IMN+10) =  EFDPOL(8,NDPST)
                  CMIN(IMN+11) =  EFDPOL(9,NDPST)
                  IMN=IMN+12
  116         CONTINUE
C
C SAVE DISPERSION COEFFICIENTS FOR EFP1-MP2
C
              DO 117 III=1,NDPTS(IFRG)
                  NDST=NDST+1
                  CMIN(IMN  ) =  CDIS(1,NDST)
                  CMIN(IMN+1) =  CDIS(2,NDST)
                  CMIN(IMN+2) =  CDIS(3,NDST)
                  IMN=IMN+3
  117         CONTINUE
  121      CONTINUE
         END IF
      RETURN
      END
C*MODULE GLOBOP  *DECK RSTCOR
      SUBROUTINE RSTCOR(CMIN,PROVEC,CANVEC,MXBF)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      PARAMETER (MXATM=2000, MXAO=8192, MXSH=5000, MXGTOT=20000,
     *           MXFRG=1050, MXFGPT=12000, MXDFG=5, MXIFRQ=12,
     *           MXDPPT=MXFRG*MXDFG*12, MXPT=2000)
C
      CHARACTER*8 FRGNME,REPNAM,POLNAM,DPOLNAM,DNAME,DPSNAM
C
      COMMON /EFPBAS/ EX(MXGTOT,MXDFG),CS(MXGTOT,MXDFG),
     *                CP(MXGTOT,MXDFG),CD(MXGTOT,MXDFG),
     *                CF(MXGTOT,MXDFG),CG(MXGTOT,MXDFG),
     *                PRNAME(MXFGPT),PRCORD(3,MXFGPT),EFZNUC(MXFGPT),
     *                KSTART(MXSH,MXDFG),KATOM(MXSH,MXDFG),
     *                KTYPE(MXSH,MXDFG),KNG(MXSH,MXDFG),
     *                KLOC(MXSH,MXDFG),KMIN(MXSH,MXDFG),
     *                KMAX(MXSH,MXDFG),NSHELL(MXDFG),NGAUSS(MXDFG),
     *                NATEF(MXDFG),NUMEF(MXDFG),NTPATM
      COMMON /EFPCMO/ NOCC(MXDFG),NVIR(MXDFG),NAO(MXDFG),NTAO,
     *                CANFOK(MXAO,MXDFG)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      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 /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /EFPPAR/ EFP(3,MXFGPT),EFPOL(9,MXFGPT),
     *                EFDP(3,MXIFRQ*MXFGPT),EFDPOL(9,MXIFRQ*MXFGPT),
     *                ENO,DIND(3,MXFGPT),DINDD(3,MXFGPT),
     *                POLNAM(MXFGPT),DPOLNAM(MXIFRQ*MXFGPT),
     *                POLSCR(MXFGPT),IPLSCR,INDSCR
      COMMON /FRGTYP/ NDFRG,ISET(MXFRG),NAMIDX(MXDFG)
      COMMON /PAULMO/ CENTNM(MXFGPT),CENTCD(3,MXFGPT),NORB(MXFRG),
     *                NPBF(MXFRG),NTMO
      COMMON /POLTMP/ POLT2(9),
     *                ACHGHF(2,MXPT),ADIPHF(3,MXPT),AQADHF(6,MXPT),
     *                AMULTMP(MXPT),BMULTMP(MXPT),
     *                AMULTMP2(MXPT),BMULTMP2(MXPT),
     *                TCLPD(4*MXPT),TZLPD(4*MXPT),
     *                JNLPR(4*MXPT),JKFR(MXPT),JKLR(MXPT),
     *                NDPTS(MXFRG),
     *                IEFP2,IEFMON,IEFSCR,IEFSCR2,IEFDIP,IEFQUD,IEFREP,
     *                IEFPOL,IEFPOL2,NDTTPT
      COMMON /POL2  / CHGHF(2,MXFGPT),DIPHF(3,MXFGPT),QADHF(6,MXFGPT),
     *                AMULTHF(MXFGPT),BMULTHF(MXFGPT),
     *                AMULT2HF(MXFGPT),BMULT2HF(MXFGPT),
     *                EFPOL2(9,MXFRG),DIND2(3,MXFGPT),DINDD2(3,MXFGPT),
     *                DCORD(3,MXPT),CDIS(3,MXFGPT),
     *                CLPD(4*MXFGPT),ZLPD(4*MXFGPT),
     *                NLPD(4*MXFGPT),KFD(MXFGPT),KLD(MXFGPT),
     *                DNAME(MXPT),DPSNAM(MXFGPT)
      COMMON /REPPAR/ CREP(3,MXFGPT),CLPR(4*MXFGPT),ZLPR(4*MXFGPT),
     *                NLPR(4*MXFGPT),KFR(MXFGPT),KLR(MXFGPT),
     *                REPNAM(MXFGPT)
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
      DIMENSION CMIN(*)
C
      DIMENSION PROVEC(MXBF,*),CANVEC(MXBF,*)
C
C     RESTORE MINIMUM ENERGY COORDINATES OF AB INITIO ATOMS
C
      IMN=1
      IF(ICOORD.NE.4) THEN
         DO 100 I = 1,NAT
            C(1,I) = CMIN(IMN)
            C(2,I) = CMIN(IMN+1)
            C(3,I) = CMIN(IMN+2)
            IMN=IMN+3
  100    CONTINUE
      END IF
C
      IF(NFRG.GT.0) THEN
C
C     RESTORE MINIMUM ENERGY COORDINATES OF THE EFP
C
         IAT=0
         DO 120 IFRG=1,NFRG
            DO 110 III=1,NMPTS(IFRG)
               IAT=IAT+1
               EFC(1,IAT) = CMIN(IMN)
               EFC(2,IAT) = CMIN(IMN+1)
               EFC(3,IAT) = CMIN(IMN+2)
               IMN=IMN+3
  110       CONTINUE
  120    CONTINUE
C
         IAT=0
         NPST=0
         NDPST=0
         NRST=0
         NATST=0
         NORST=0
         NAOST=0
         NDST=0
C
         DO 121 IFRG=1,NFRG
C
C   RECOVER MULTIPOLE POTENTIAL
C
            DO 119 III=1,NMPTS(IFRG)
               IAT=IAT+1
               EFDIP(1,IAT) =  CMIN(IMN)
               EFDIP(2,IAT) =  CMIN(IMN+1)
               EFDIP(3,IAT) =  CMIN(IMN+2)
               EFQAD(1,IAT) =  CMIN(IMN+3)
               EFQAD(2,IAT) =  CMIN(IMN+4)
               EFQAD(3,IAT) =  CMIN(IMN+5)
               EFQAD(4,IAT) =  CMIN(IMN+6)
               EFQAD(5,IAT) =  CMIN(IMN+7)
               EFQAD(6,IAT) =  CMIN(IMN+8)
               EFOCT(1,IAT) =  CMIN(IMN+9)
               EFOCT(2,IAT) =  CMIN(IMN+10)
               EFOCT(3,IAT) =  CMIN(IMN+11)
               EFOCT(4,IAT) =  CMIN(IMN+12)
               EFOCT(5,IAT) =  CMIN(IMN+13)
               EFOCT(6,IAT) =  CMIN(IMN+14)
               EFOCT(7,IAT) =  CMIN(IMN+15)
               EFOCT(8,IAT) =  CMIN(IMN+16)
               EFOCT(9,IAT) =  CMIN(IMN+17)
               EFOCT(10,IAT) = CMIN(IMN+18)
               IMN=IMN+19
  119       CONTINUE
C
C     RECOVER DIPOLE POLARIZABILITY TENSORS
C
            DO 111 III=1,NPPTS(IFRG)
               NPST=NPST+1
               EFP(1,NPST) = CMIN(IMN)
               EFP(2,NPST) = CMIN(IMN+1)
               EFP(3,NPST) = CMIN(IMN+2)
               EFPOL(1,NPST) = CMIN(IMN+3)
               EFPOL(2,NPST) = CMIN(IMN+4)
               EFPOL(3,NPST) = CMIN(IMN+5)
               EFPOL(4,NPST) = CMIN(IMN+6)
               EFPOL(5,NPST) = CMIN(IMN+7)
               EFPOL(6,NPST) = CMIN(IMN+8)
               EFPOL(7,NPST) = CMIN(IMN+9)
               EFPOL(8,NPST) = CMIN(IMN+10)
               EFPOL(9,NPST) = CMIN(IMN+11)
               IMN=IMN+12
  111       CONTINUE
C
C       RECOVER FITTED REPULSION POTENTIAL
C
            DO 112 III=1,NRPTS(IFRG)
               NRST=NRST+1
               CREP(1,NRST) = CMIN(IMN)
               CREP(2,NRST) = CMIN(IMN+1)
               CREP(3,NRST) = CMIN(IMN+2)
               IMN=IMN+3
  112       CONTINUE
C
C       RECOVER PAULI FORMULA FOR EXCHANGE POTENTIAL
C
            DO 113 III=1,NATEF(ISET(IFRG))
               NATST=NATST+1
               PRCORD(1,NATST) = CMIN(IMN)
               PRCORD(2,NATST) = CMIN(IMN+1)
               PRCORD(3,NATST) = CMIN(IMN+2)
               IMN=IMN+3
  113       CONTINUE
C
            DO 115 NSHL = 1,NSHELL(ISET(IFRG))
               ITYP=KMAX(NSHL,ISET(IFRG))-KMIN(NSHL,ISET(IFRG))+1
               LOC = KLOC(NSHL,ISET(IFRG))
               IF(ITYP.EQ.3) THEN
                  DO III=1,NORB(IFRG)
                     PROVEC(LOC,NORST+III) = CMIN(IMN)
                     PROVEC(LOC+1,NORST+III) = CMIN(IMN+1)
                     PROVEC(LOC+2,NORST+III) = CMIN(IMN+2)
                     IMN=IMN+3
                  END DO
               END IF
               IF(ITYP.EQ.4) THEN
                  DO III=1,NORB(IFRG)
                     PROVEC(LOC+1,NORST+III) = CMIN(IMN)
                     PROVEC(LOC+2,NORST+III) = CMIN(IMN+1)
                     PROVEC(LOC+3,NORST+III) = CMIN(IMN+2)
                     IMN=IMN+3
                  END DO
               END IF
               IF(ITYP.EQ.6) THEN
                  DO III=1,NORB(IFRG)
                     PROVEC(LOC,NORST+III) = CMIN(IMN)
                     PROVEC(LOC+1,NORST+III) = CMIN(IMN+1)
                     PROVEC(LOC+2,NORST+III) = CMIN(IMN+2)
                     PROVEC(LOC+3,NORST+III) = CMIN(IMN+3)
                     PROVEC(LOC+4,NORST+III) = CMIN(IMN+4)
                     PROVEC(LOC+5,NORST+III) = CMIN(IMN+5)
                     IMN=IMN+6
                  END DO
               END IF
               IF(ITYP.EQ.10) THEN
                  DO  III=1,NORB(IFRG)
                     PROVEC(LOC,NORST+III) = CMIN(IMN)
                     PROVEC(LOC+1,NORST+III) = CMIN(IMN+1)
                     PROVEC(LOC+2,NORST+III) = CMIN(IMN+2)
                     PROVEC(LOC+3,NORST+III) = CMIN(IMN+3)
                     PROVEC(LOC+4,NORST+III) = CMIN(IMN+4)
                     PROVEC(LOC+5,NORST+III) = CMIN(IMN+5)
                     PROVEC(LOC+6,NORST+III) = CMIN(IMN+6)
                     PROVEC(LOC+7,NORST+III) = CMIN(IMN+7)
                     PROVEC(LOC+8,NORST+III) = CMIN(IMN+8)
                     PROVEC(LOC+9,NORST+III) = CMIN(IMN+9)
                     IMN=IMN+10
                  END DO
               END IF
               IF(ITYP.EQ.15) THEN
                  DO  III=1,NORB(IFRG)
                     PROVEC(LOC,NORST+III) = CMIN(IMN)
                     PROVEC(LOC+1,NORST+III) = CMIN(IMN+1)
                     PROVEC(LOC+2,NORST+III) = CMIN(IMN+2)
                     PROVEC(LOC+3,NORST+III) = CMIN(IMN+3)
                     PROVEC(LOC+4,NORST+III) = CMIN(IMN+4)
                     PROVEC(LOC+5,NORST+III) = CMIN(IMN+5)
                     PROVEC(LOC+6,NORST+III) = CMIN(IMN+6)
                     PROVEC(LOC+7,NORST+III) = CMIN(IMN+7)
                     PROVEC(LOC+8,NORST+III) = CMIN(IMN+8)
                     PROVEC(LOC+9,NORST+III) = CMIN(IMN+9)
                     PROVEC(LOC+10,NORST+III) = CMIN(IMN+10)
                     PROVEC(LOC+11,NORST+III) = CMIN(IMN+11)
                     PROVEC(LOC+12,NORST+III) = CMIN(IMN+12)
                     PROVEC(LOC+13,NORST+III) = CMIN(IMN+13)
                     PROVEC(LOC+14,NORST+III) = CMIN(IMN+14)
                     IMN=IMN+15
                  END DO
               END IF
               IF(ITYP.EQ.3) THEN
                  DO  III=1,NAO(ISET(IFRG))
                     CANVEC(LOC,NAOST+III) = CMIN(IMN)
                     CANVEC(LOC+1,NAOST+III) = CMIN(IMN+1)
                     CANVEC(LOC+2,NAOST+III) = CMIN(IMN+2)
                     IMN=IMN+3
                  END DO
               END IF
               IF(ITYP.EQ.4) THEN
                  DO  III=1,NAO(ISET(IFRG))
                     CANVEC(LOC+1,NAOST+III) = CMIN(IMN)
                     CANVEC(LOC+2,NAOST+III) = CMIN(IMN+1)
                     CANVEC(LOC+3,NAOST+III) = CMIN(IMN+2)
                     IMN=IMN+3
                  END DO
               END IF
               IF(ITYP.EQ.6) THEN
                  DO  III=1,NAO(ISET(IFRG))
                     CANVEC(LOC,NAOST+III) = CMIN(IMN)
                     CANVEC(LOC+1,NAOST+III) = CMIN(IMN+1)
                     CANVEC(LOC+2,NAOST+III) = CMIN(IMN+2)
                     CANVEC(LOC+3,NAOST+III) = CMIN(IMN+3)
                     CANVEC(LOC+4,NAOST+III) = CMIN(IMN+4)
                     CANVEC(LOC+5,NAOST+III) = CMIN(IMN+5)
                     IMN=IMN+6
                  END DO
               END IF
               IF(ITYP.EQ.10) THEN
                  DO  III=1,NAO(ISET(IFRG))
                     CANVEC(LOC,NAOST+III) = CMIN(IMN)
                     CANVEC(LOC+1,NAOST+III) = CMIN(IMN+1)
                     CANVEC(LOC+2,NAOST+III) = CMIN(IMN+2)
                     CANVEC(LOC+3,NAOST+III) = CMIN(IMN+3)
                     CANVEC(LOC+4,NAOST+III) = CMIN(IMN+4)
                     CANVEC(LOC+5,NAOST+III) = CMIN(IMN+5)
                     CANVEC(LOC+6,NAOST+III) = CMIN(IMN+6)
                     CANVEC(LOC+7,NAOST+III) = CMIN(IMN+7)
                     CANVEC(LOC+8,NAOST+III) = CMIN(IMN+8)
                     CANVEC(LOC+9,NAOST+III) = CMIN(IMN+9)
                     IMN=IMN+10
                  END DO
               END IF
               IF(ITYP.EQ.15) THEN
                  DO  III=1,NAO(ISET(IFRG))
                     CANVEC(LOC,NAOST+III) = CMIN(IMN)
                     CANVEC(LOC+1,NAOST+III) = CMIN(IMN+1)
                     CANVEC(LOC+2,NAOST+III) = CMIN(IMN+2)
                     CANVEC(LOC+3,NAOST+III) = CMIN(IMN+3)
                     CANVEC(LOC+4,NAOST+III) = CMIN(IMN+4)
                     CANVEC(LOC+5,NAOST+III) = CMIN(IMN+5)
                     CANVEC(LOC+6,NAOST+III) = CMIN(IMN+6)
                     CANVEC(LOC+7,NAOST+III) = CMIN(IMN+7)
                     CANVEC(LOC+8,NAOST+III) = CMIN(IMN+8)
                     CANVEC(LOC+9,NAOST+III) = CMIN(IMN+9)
                     CANVEC(LOC+10,NAOST+III) = CMIN(IMN+10)
                     CANVEC(LOC+11,NAOST+III) = CMIN(IMN+11)
                     CANVEC(LOC+12,NAOST+III) = CMIN(IMN+12)
                     CANVEC(LOC+13,NAOST+III) = CMIN(IMN+13)
                     CANVEC(LOC+14,NAOST+III) = CMIN(IMN+14)
                     IMN=IMN+15
                  END DO
               END IF
  115       CONTINUE
            DO III=1,NORB(IFRG)
               CENTCD(1,NORST+III) = CMIN(IMN)
               CENTCD(2,NORST+III) = CMIN(IMN+1)
               CENTCD(3,NORST+III) = CMIN(IMN+2)
               IMN=IMN+3
            END DO
            NORST=NORST+NORB(IFRG)
            NAOST=NAOST+NAO(ISET(IFRG))
C
C RECOVER DYNAMIC POLARIZABILITY
C
            DO 116 III=1,NDPPTS(IFRG)
               NDPST=NDPST+1
               EFDP(1,NDPST) = CMIN(IMN)
               EFDP(2,NDPST) = CMIN(IMN+1)
               EFDP(3,NDPST) = CMIN(IMN+2)
               EFDPOL(1,NDPST) = CMIN(IMN+3)
               EFDPOL(2,NDPST) = CMIN(IMN+4)
               EFDPOL(3,NDPST) = CMIN(IMN+5)
               EFDPOL(4,NDPST) = CMIN(IMN+6)
               EFDPOL(5,NDPST) = CMIN(IMN+7)
               EFDPOL(6,NDPST) = CMIN(IMN+8)
               EFDPOL(7,NDPST) = CMIN(IMN+9)
               EFDPOL(8,NDPST) = CMIN(IMN+10)
               EFDPOL(9,NDPST) = CMIN(IMN+11)
               IMN=IMN+12
  116       CONTINUE
C
C RECOVER DISPERSION COEFFICIENTS FOR EFP1-MP2
C
            DO 117 III=1,NDPTS(IFRG)
                NDST=NDST+1
                CDIS(1,NDST) = CMIN(IMN  )
                CDIS(2,NDST) = CMIN(IMN+1)
                CDIS(3,NDST) = CMIN(IMN+2)
                IMN=IMN+3
  117       CONTINUE
C
  121    CONTINUE
      END IF
C
      CALL EFCM
C
      RETURN
      END
C*MODULE GLOBOP  *DECK PRMNC
      SUBROUTINE PRMNC(CMIN)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000, MXPT=2000, MXFRG=1050, MXAO=8192,
     *           MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*6 FRGNAM
      CHARACTER*8 FRGNME,PTNAM
C
      DIMENSION CMIN(*)
C
      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 /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      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 /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /FRAGMT/ XCRD(3,MXFRG),YCRD(3,MXFRG),ZCRD(3,MXFRG),
     *                PTNAM(3,MXFRG),FRGNAM(MXFRG)
      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
      PARAMETER (ZERO=0.0D+00,UNITS = 0.52917724924D+00)
C
C     PRINT MINIMUM ENERGY COORDINATES
C
      IF(MASWRK) WRITE(IW,9010)
C
      IMN=1
      IF(ICOORD.NE.4) THEN
         DO I = 1,NAT
            IF(MASWRK) WRITE(IW,9028) I,ANAM(I),BNAM(I),
     *             CMIN(IMN)*UNITS,CMIN(IMN+1)*UNITS,CMIN(IMN+2)*UNITS
         IMN=IMN+3
         ENDDO
      END IF
C
      IF(NFRG.GT.0) THEN
         IF(MASWRK) WRITE(IW,9011)
         IF(MASWRK) WRITE(IW,9021)
         IAT=0
         KMASS=0
         DO 120 IFRG=1,NFRG
            IF(MASWRK) WRITE(IW,9022) FRGNAM(IFRG)
            DO 110 III=1,NMPTS(IFRG)
               IAT=IAT+1
               IF(FMASS(III+KMASS).GT.ZERO) THEN
                  XF =  CMIN(IMN)*UNITS
                  YF =  CMIN(IMN+1)*UNITS
                  ZF =  CMIN(IMN+2)*UNITS
                  IF(MASWRK) WRITE(IW,9031) FRGNME(IAT),XF,YF,ZF
               END IF
               IMN=IMN+3
  110      CONTINUE
           KMASS=KMASS+NMPTS(IFRG)
  120   CONTINUE
      END IF
C
      RETURN
C
 9010 FORMAT(/2X,'COORDINATES OF MINIMUM ENERGY GEOMETRY (ANGS):'/)
 9011 FORMAT(1X,'COORDINATES OF FRAGMENT MULTIPOLE CENTERS (ANGS)')
 9021 FORMAT(1X,'MULTIPOLE NAME',9X,'X',18X,'Y',18X,'Z'/
     *       1X,60(1H-))
 9022 FORMAT(1X,'FRAGNAME=',A6)
 9028 FORMAT(1X,I3,2X,A8,A2,3F18.13)
 9031 FORMAT(1X,A8,7X,3F18.13)
C
      END
C*MODULE GLOBOP  *DECK PRFC
      SUBROUTINE PRFC
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      PARAMETER (MXATM=2000, MXAO=8192, MXPT=2000, MXFRG=1050,
     *           MXFGPT=12000,
     *           MXDFG=5, MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*6 FRGNAM
      CHARACTER*8 FRGNME,PTNAM
C
      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 /RUNLAB/ TITLE(10),ANAM(MXATM),BNAM(MXATM),BFLAB(MXAO)
      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 /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      COMMON /FRAGMT/ XCRD(3,MXFRG),YCRD(3,MXFRG),ZCRD(3,MXFRG),
     *                PTNAM(3,MXFRG),FRGNAM(MXFRG)
      COMMON /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
      PARAMETER (ZERO=0.0D+00,UNITS = 0.52917724924D+00)
C
C     PRINT MINIMUM ENERGY COORDINATES
C
      IF(MASWRK) WRITE(IW,9010)
C
      IF(ICOORD.NE.4) THEN
         DO I = 1,NAT
            IF(MASWRK) WRITE (IW,9028) I,ANAM(I),BNAM(I),
     *               C(1,I)*UNITS,C(2,I)*UNITS,C(3,I)*UNITS
         ENDDO
      END IF
C
      IF(NFRG.GT.0) THEN
         IF(MASWRK) WRITE(IW,9011)
         IF(MASWRK) WRITE(IW,9021)
         IAT=0
         KMASS=0
         DO 120 IFRG=1,NFRG
            IF(MASWRK) WRITE(IW,9022) FRGNAM(IFRG)
            DO 110 III=1,NMPTS(IFRG)
               IAT=IAT+1
               IF(FMASS(III+KMASS).GT.ZERO) THEN
                  XF = EFC(1,IAT)*UNITS
                  YF = EFC(2,IAT)*UNITS
                  ZF = EFC(3,IAT)*UNITS
                  IF(MASWRK) WRITE(IW,9031) FRGNME(IAT),XF,YF,ZF
               END IF
  110      CONTINUE
           KMASS=KMASS+NMPTS(IFRG)
  120   CONTINUE
      END IF
C
      RETURN
C
 9010 FORMAT(2X,'COORDINATES OF FINAL GEOMETRY (ANGS):'/)
 9011 FORMAT(1X,'COORDINATES OF FRAGMENT MULTIPOLE CENTERS (ANGS)')
 9021 FORMAT(1X,'MULTIPOLE NAME',9X,'X',18X,'Y',18X,'Z'/
     *       1X,60(1H-))
 9022 FORMAT(1X,'FRAGNAME=',A6)
 9028 FORMAT(1X,I3,2X,A8,A2,3F18.13)
 9031 FORMAT(1X,A8,7X,3F18.13)
C
      END
C*MODULE GLOBOP  *DECK RNGEN
      SUBROUTINE RNGEN(RANNUM,NRN,IRTP,INIT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      DIMENSION RANNUM(NRN),ITIMST(6)
C
      COMMON /MACHIN/ NWDVAR,MAXFM,MAXSM,LIMFM,LIMSM
C
C        THE SEED -IX- IS EITHER A CONSTANT FOR DEBUGGING PURPOSES,
C        OR IS BASED ON THE TIME STRING.  ALL VALUES IN THE TIME
C        STRING ARE SUMMED SINCE DIFFERENT O/S RETURN THE SECONDS
C        FIELD IN DIFFERENT POSITIONS.  WE WANT TO BE SURE TO PICK
C        UP THE SECONDS PART OF THE STRING TO BE MORE RANDOMIZED.
C
      IF(INIT.EQ.0) THEN
         IA = 1345
         IC = 0
         M = 2**19 - 1
         IF(IRTP.EQ.0) THEN
            IX = 64097
         ELSE
            CALL TMDATE(ITIMST)
            IX=0
            LENTIM=6
            IF(NWDVAR.EQ.1) LENTIM=3
            DO I=1,LENTIM
               IX=IX+ITIMST(I)
            ENDDO
         END IF
         IX  = IABS(IX)
         IDUM= -IX
      END IF
C
      IF(IRTP.EQ.3) THEN
         DO I=1,NRN
            CALL RAND3(IDUM,RANNUM(I))
         ENDDO
      ELSE
         DO I=1,NRN
            ITEMP = IA*IX + IC
            IX = MOD(ITEMP,M)
            RANNUM(I)=IX
            RANNUM(I)=RANNUM(I)/(M-1)
         ENDDO
      END IF
      RETURN
      END
C*MODULE GLOBOP  *DECK RAND3
      SUBROUTINE RAND3(IDUM,RAN3)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
C  ON FIRST CALL IDUM SHOULD BE LESS THAN ZERO
C  (C) COPR. 1986-92 NUMERICAL RECIPES SOFTWARE
C
      INTEGER IDUM
      INTEGER MBIG,MSEED,MZ
      PARAMETER (MBIG=1000000000,MSEED=161803398,MZ=0,FAC=1.0D+00/MBIG)
      DIMENSION MA(55)
      SAVE IFF,INEXT,INEXTP,MA
      DATA IFF /0/
C
      IF(IDUM.LT.0.OR.IFF.EQ.0) THEN
        IFF=1
        MJ=IABS(MSEED-IABS(IDUM))
        MJ=MOD(MJ,MBIG)
        MA(55)=MJ
        MK=1
        DO 11 I=1,54
          II=MOD(21*I,55)
          MA(II)=MK
          MK=MJ-MK
          IF(MK.LT.MZ) MK=MK+MBIG
          MJ=MA(II)
11      CONTINUE
        DO 13 K=1,4
          DO 12 I=1,55
            MA(I)=MA(I)-MA(1+MOD(I+30,55))
            IF(MA(I).LT.MZ) MA(I)=MA(I)+MBIG
12        CONTINUE
13      CONTINUE
        INEXT=0
        INEXTP=31
        IDUM=1
      END IF
C
      INEXT=INEXT+1
      IF(INEXT.EQ.56) INEXT=1
      INEXTP=INEXTP+1
      IF(INEXTP.EQ.56) INEXTP=1
C
      MJ=MA(INEXT)-MA(INEXTP)
      IF(MJ.LT.MZ) MJ=MJ+MBIG
      MA(INEXT)=MJ
      RAN3=MJ*FAC
      RETURN
      END
C
C THIS SR IS USED IF RNDINI=TRUE. 
C
      SUBROUTINE PXALRT(ALERT)
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
C
      LOGICAL ALERT
C
      PARAMETER (MXATM=2000,
     *           MXPT=2000, MXFRG=1050, MXDFG=5, MXFGPT=12000,
     *           MXDPPT=MXFRG*MXDFG*12)
C
      CHARACTER*8 FRGNME
C
      COMMON /EFMULT/ EFC(3,MXFGPT),EFCHG(2,MXFGPT),EFATRM(MXFGPT),
     *                EFBTRM(MXFGPT),EFATRM2(MXFGPT),EFBTRM2(MXFGPT),
     *                EFDIP(3,MXFGPT),EFQAD(6,MXFGPT),
     *                EFOCT(10,MXFGPT),FRGNME(MXFGPT)
      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 /FRGMSS/ FPMASS(MXPT),FMASS(MXFGPT),
     *                FPNUC(MXPT),FGNUC(MXFGPT)
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM),IAN(MXATM)
      COMMON /SIMEN / EPREV,EMIN,ALPHA,DAVE,XMIN,XMAX,YMIN,YMAX
     *               ,ZMIN,ZMAX,XRANGE,YRANGE,ZRANGE,SEPTOL
     *               ,DACRAT,UPDFAC
      COMMON /ZMTALT/ NZMAT2,NZVAR2,NVAR2,NZMTRD,ICOORD
C
C     CHECK THE DISPLACEMENT FOR NUCLEI TOO CLOSE TOGETHER
C     IF ANY ARE, REGISTER A PROXIMITY ALERT!
C
      ALERT=.FALSE.
      IF(NFRG.GT.0) THEN
        IAT=0
        KMASS=0
        DO 220 IFRG=1,NFRG
         DO 210 III=1,NMPTS(IFRG)
          IAT=IAT+1
          IF(FMASS(III+KMASS).GT.0.0D+00) THEN
           XF = EFC(1,IAT)
           YF = EFC(2,IAT)
           ZF = EFC(3,IAT)
           IF(ICOORD.NE.4) THEN
           DO 200 I = 1,NAT
             SEP2 = (XF-C(1,I))**2+(YF-C(2,I))**2+(ZF-C(3,I))**2
             SEP = 8.0D-01*SQRT(SEP2)
             IF(SEP.LT.SEPTOL) THEN
             ALERT = .TRUE.
             RETURN
             END IF
  200      CONTINUE
           END IF
           IAT2=0
           KMASS2=0
           DO 202 IFRG2=1,NFRG
             DO 201 III2=1,NMPTS(IFRG2)
               IAT2=IAT2+1
               IF(IFRG2.LE.IFRG) GO TO 201
               IF(FMASS(III2+KMASS2).GT.0.0D+00) THEN
                 XF2 = EFC(1,IAT2)
                 YF2 = EFC(2,IAT2)
                 ZF2 = EFC(3,IAT2)
                 SEP2 = (XF-XF2)**2+(YF-YF2)**2+(ZF-ZF2)**2
                 SEP = 8.0D-01*SQRT(SEP2)
                 IF(SEP.LT.SEPTOL) THEN
                 ALERT = .TRUE.
                 RETURN
                 END IF
               END IF
  201        CONTINUE
             KMASS2=KMASS2+NMPTS(IFRG2)
  202      CONTINUE
          END IF
  210    CONTINUE
         KMASS=KMASS+NMPTS(IFRG)
  220   CONTINUE
      END IF
C      
      RETURN 
      END

