C    *******************************************************************
C    **                                                               **
C    ** MOLECULAR DYNAMICS FOR A LENNARD JONES FLUID                  **
C    ** 3D VERSION PASSING EDGES IN X,Y,Z DIRECTIONS                  **
C    **                                                               **
C    ** AS FAR AS WE ARE AWARE THIS PROGRAM WORKS CORRECTLY, BUT WE   **
C    ** CAN ACCEPT NO RESPONSIBILITY FOR THE CONSEQUNCES OF ANY       **
C    ** ERRORS, AND WOULD BE GRATEFUL TO HEAR FROM YOU IF YOU FIND    **
C    ** ANY. YOU SHOULD ALWAYS CHECK A PROGRAM OR SUBROUTINE FOR YOUR **
C    ** PARTICULAR APPLICATION.                                       **
C    **                                                               **
C    ** THIS PROGRAM WILL SIMULATE A THREE DIMENSIONAL LENNARD-JONES  **
C    ** FLUID. THE PROGRAM USES A THREE DIMENSIONAL SPATIAL           **
C    ** DECOMPOSITION OF THE SIMULATION SPACE INTO SUB-CUBES.         **
C    **                                                               **
C    ** SUBROUTINES CALLED:                                           **
C    **                                                               **
C    ** FORCE     CALCULATES THE  FORCES AND POTENTIAL USING THE      **
C    **           LINKED LIST.                                        **
C    ** MAPS      CREATES NEIGHBOUR LIST OF CELLS USED BY FORCE.      **
C    ** MOVEA     PERFORMS FIRST PART OF VELOCITY VERLET ALGORITHM.   **
C    ** MOVEB     PERFORMS SECOND PART OF VELOCITY VERLET ALGORITHM.  **
C    ** MOVOUT    CREATES LINKED LIST.
C    ** SCALET    SCALES THE VELOCITIES TO ENABLE EQUILIBRATION TO A  **
C    **           PARTICULAR TEMPERATURE.                             **
C    **                                                               **
C    ** PRINCIPAL VARIABLES:                                          **
C    **                                                               **
C    ** INTEGER VARIABLES:                                            **
C    **                                                               **
C    ** HEAD(NCELL)                  ARRAY HOLDING INITIAL POINTER FOR**
C    **                              EACH LINK-CELL.                  **
C    ** ISAVE                        NUMBER OF TIMESTEPS BETWEEN SAVES**
C    **                              OF CONFIGURATIONAL INFORMATION.  **
C    ** LIST(NMAX)                   ARRAY HOLDING LINKED LIST.       **
C    ** MAP(MAPSIZ)                  ARRAY CONTAINING NEIGHBOUR LIST  **
C    **                              OF CELLS CONSIDERED IN FORCE     **
C    **                              CALCULATION.                     **
C    ** MAPSIZ                       SIZE OF ARRAY MAP.               **
C    ** MMX,MMY,MMZ                  MAXIMUM NUMBER OF LINK-CELLS IN  **
C    **                              EACH COORDINATE DIRECTION.       **
C    ** MX,MY,MZ                     NUMBER OF LINK CELLS IN EACH     **
C    **                              COORDINATE DIRECTION.            **
C    ** NATM                         NUMBER OF REAL ATOMS CURRENTLY   **
C    **                              CONTROLLED BY THIS PROCESSOR.    **
C    ** NCELL                        MAXIMUM TOTAL NUMBER OF LINK-CELLS*
C    ** NMAX                         SIZE OF COORDINATE ARRAYS AND    **
C    **                              LIST ARRAY. N.B. SHOULD BE LARGE **
C    **                              ENOUGH TO HOLD ALL REAL AND EDGE **
C    **                              COORDINATES.                     **
C    ** NEQUIL                       NUMBER OF EQUILIBRATION TIMESTEPS**
C    **                              TO PERFORM.                      **
C    ** NSTEP                        NUMBER OF TIMESTEPS TO PERFORM.  **
C    **                                                               **
C    ** REAL VARIABLES:                                               **
C    **                                                               **
C    ** CELLIX,CELLIY,CELLIZ         REAL VALUES OF MX, MY, AND MZ    **
C    ** DT                           TIMESTEP.                        **
C    ** EQTEMP                       TEMPERATURE TO WHICH THE SYSTEM  **
C    **                              IS BEING EQUILIBRATED.           **
C    ** RX(NMAX),RY(NMAX),RZ(NMAX)   ARRAYS WHICH HOLD COORDINATES.   **
C    ** RCUT                         CUTOFF                           **
C    ** SFX,SFY,SFZ                  SCALE FACTORS TO ENABLE LINKED   **
C    **                              LIST CALCULATION FROM PROCESSOR  **
C    **                              COORDINATE SYSTEM.               **
C    ** SIGMA                        SIGMA FOR LENNARD-JONES POTENTIAL**
C    ** VX(NMAX),VY(NMAX),VZ(NMAX)    ARRAYS WHICH HOLD VELOCITIES.   **
C    ** V,K,W                        TOTAL POTENTIAL AND KINETIC ENERGY*
C    **                              AND VIRIAL FOR ATOMS CONTROLLED  **
C    **                              BY THIS PROCESSOR.               **
C    **                                                               **
C    *******************************************************************

      PROGRAM MD1

      IMPLICIT CHARACTER ( A-Z )

      DOUBLE PRECISION SIGMA, RCUT
      COMMON /POTNTL/ SIGMA, RCUT

      INTEGER NW1
      PARAMETER (NW1 = 11)

      INCLUDE 'md1.inc'

      DOUBLE PRECISION, ALLOCATABLE :: RX (:), RY (:), RZ (:)
      DOUBLE PRECISION, ALLOCATABLE :: VX (:), VY (:), VZ (:)
      DOUBLE PRECISION, ALLOCATABLE :: FX (:), FY (:), FZ (:)
      INTEGER, ALLOCATABLE :: NATMCL (:, :, :), HEAD (:, :, :),
     1        LIST (:, :, :, :), IDL (:, :, :, :)
      DOUBLE PRECISION, ALLOCATABLE ::
     1  FXL (:, :, :, :), FYL (:, :, :, :), FZL (:, :, :, :),
     2  RXL (:, :, :, :), RYL (:, :, :, :), RZL (:, :, :, :)
      DOUBLE PRECISION DT
      DOUBLE PRECISION DENS, DENLJ, EQTEMP
      DOUBLE PRECISION MASS, FREE, TEMP
      DOUBLE PRECISION E, V, K, W
      DOUBLE PRECISION EN, VN, KN, PRES
      DOUBLE PRECISION ACE, ACV, ACK, ACP
      DOUBLE PRECISION ACESQ, ACVSQ, ACKSQ, ACPSQ
      DOUBLE PRECISION AVE, AVV, AVK, AVP, AVT
      DOUBLE PRECISION FLE, FLV, FLK, FLP, FLT

      DOUBLE PRECISION TSTART, TEND, TIME

      INTEGER MX,MY,MZ
      INTEGER NC,M
      INTEGER STEP, NSTEP, ISAVE, IPRINT, NORM, NATM
      INTEGER NEQUIL, ISCALE, NPROSX, NPROSY, NPROSZ
      INTEGER I

      NATM = 0

      WRITE(*,'(1H1,'' **** PROGRAM MDLJ ****                   '')')
      WRITE(*,'('' MOLECULAR DYNAMICS SIMULATION                '')')
      WRITE(*,'('' WITH LINKED LIST                             '')')

C     NUMBER OF TIME STEPS

      NSTEP = 600

C     NUMBER OF EQUILIBRATION TIME STEPS

      NEQUIL = 500

C     NUMBER OF STEPS BETWEEN DATA SAVES

      ISAVE = 2*NSTEP

C     NUMBER OF STEPS BETWEEN OUTPUT

      IPRINT = 100

C     THE FOLLOWING IN LENNARD-JONES UNITS...

C     THE TEMPERATURE

      EQTEMP = 0.8D0

C     THE DENSITY

      DENS = 0.75D0

C     THE POTENTIAL CUTOFF DISTANCE

      RCUT = 2.0D0**(1.0D0/6.0D0)

C     THE TIMESTEP

      DT = 0.01D0

C     REDUNDANT VARIABLES...

      ISCALE = 0
      NPROSX = 1
      NPROSY = 1
      NPROSZ = 1

C     WRITE INPUT DATA

      OPEN (NW1,FILE='result')
      REWIND(NW1)

C     READ NUMBER OF FCC UNIT-CELLS TO USED IN ALL THREE
C     COORDINATE DIRECTIONS

      WRITE(*,'('' ENTER NC '')')
      READ(*,*) NC

      NATM = 4 * NC * NC * NC
      ALLOCATE (RX (NATM), RY (NATM), RZ (NATM),
     1          VX (NATM), VY (NATM), VZ (NATM),
     2          FX (NATM), FY (NATM), FZ (NATM))

      CALL FCC (NATM, RX, RY, RZ, VX, VY, VZ, NC)

      WRITE(*,'('' NUMBER OF ATOMS BEING USED '',I8)') NATM

      CALL HEADER (NW1, NPROSX, NPROSY, NPROSZ, NC, NATM)

      CALL PARAM (NW1,NSTEP,NEQUIL,IPRINT,ISCALE,EQTEMP,DENS,RCUT,DT)

C     CONVERT INPUT DATA TO PROGRAM UNITS

      SIGMA  = (DENS/DBLE(NATM))**(1.0D0/3.0D0)
      RCUT   = RCUT*SIGMA
      M      = IDINT(1.D0/RCUT)
      MASS   = 1.0D0
      DENLJ  = DENS
      DENS   = DENS/(SIGMA**3)
      DT     = DT*SIGMA
      FREE   = DBLE(3*(NATM-1))

C     CHECK TO SEE WHETHER SYSTEM CAN BE SIMULATED

      IF (M .LT. 1)  STOP 'SYTEM TOO SMALL FOR ARRAY'

C     CALCULATE DIMENSIONS OF PROCESSORS LINK-CELL STRUCTURE

      MX = IDINT (1.0D0 / RCUT)
      MY = IDINT (1.0D0 / RCUT)
      MZ = IDINT (1.0D0 / RCUT)

      ALLOCATE (NATMCL (MX, MY, MZ), HEAD (MX, MY, MZ),
     1         LIST (LMAX, MX, MY, MZ), IDL (LMAX, MX, MY, MZ))
      ALLOCATE (FXL (LMAX, MX, MY, MZ), FYL (LMAX, MX, MY, MZ),
     1          FZL (LMAX, MX, MY, MZ))
      ALLOCATE (RXL (LMAX, MX, MY, MZ), RYL (LMAX, MX, MY, MZ),
     1          RZL (LMAX, MX, MY, MZ))

C     ZERO ACCUMULATORS

      ACE    = 0.0D0
      ACV    = 0.0D0
      ACK    = 0.0D0
      ACP    = 0.0D0

      ACESQ  = 0.0D0
      ACVSQ  = 0.0D0
      ACKSQ  = 0.0D0
      ACPSQ  = 0.0D0

      FLE    = 0.0D0
      FLV    = 0.0D0
      FLK    = 0.0D0
      FLP    = 0.0D0
      FLT    = 0.0D0

C     WRITE OUT SOME USEFUL INFORMATION

      WRITE(*,'('' SIGMA/BOX              =  '',F10.4)')  SIGMA
      WRITE(*,'('' RCUT/BOX               =  '',F10.4)')  RCUT
      WRITE(*,'('' DT                     =  '',F10.4)')  DT

C     CALL SUBROUTINE TO CALCULATE NEIGHBOUR LIST OF NEIGHBOURING
C     CELLS THAT WE WISH TO CONSIDER IN FORCE LOOP

      CALL MAPS (MX, MY, MZ)

C     ******* DEBUG *******
      WRITE (6, *) 'MX, MY, MZ =', MX, MY, MZ

C     RECEIVE CONFIGURATIONAL INFORMATION FROM MASTER
C     LOOPS OVER ALL STEPS

      WRITE(*,'(/'' ** MOLECULAR DYNAMICS BEGINS ** ''/ )')
      WRITE(*,10001)
      WRITE(NW1,'(/'' ** MOLECULAR DYNAMICS BEGINS ** ''/ )')
      WRITE(NW1,10001)

C     START OF MD CYCLE

      DO I = 1, NATM
        FX (I) = 0.0D0 
        FY (I) = 0.0D0
        FZ (I) = 0.0D0
      ENDDO

      DO STEP=1,MIN(NSTEP,NEQUIL)
        V = 0
        K = 0
        W = 0
        PRES = 0

C       PERFORM FIRST PART OF VELOCITY VERLET INTEGRATION

        CALL MOVEA (NATM, RX, RY, RZ, VX, VY, VZ, FX, FY, FZ, DT)

C       CREATE LINKED LISTS

        CALL MOVOUT (NATM, MX, MY, MZ,
     1               NATMCL, HEAD, LIST, IDL, RXL, RYL, RZL,
     2               RX, RY, RZ)
        IF (SUM (NATMCL (1 : MX, 1 : MY, 1 : MZ)) .NE. NATM) THEN
          WRITE (6, *) 'OUCH'
          STOP
        ENDIF

C       CALCULATE FORCES AND POTENTIAL USING LINKED SCALAR ROUTINE
C       MORE THAN 95% OF CPU TIME

        CALL FORCE (NATM, MX, MY, MZ, FXL, FYL, FZL, V, W,
     1                  RXL, RYL, RZL, NATMCL, HEAD, LIST)

        CALL MOVIN (NATM, FX, FY, FZ, MX, MY, MZ,
     1              NATMCL, HEAD, LIST, IDL, FXL, FYL, FZL)

C       SECOND PART OF VELOCITY VERLET INTEGRATION

        CALL MOVEB (NATM, VX, VY, VZ, K, FX, FY, FZ, DT)

        E    = K+V
        EN   = E/DBLE(NATM)
        VN   = V/DBLE(NATM)
        KN   = K/DBLE(NATM)
        TEMP = 2.0D0*K/FREE
        PRES = DENS*TEMP+W
        PRES = PRES*SIGMA**3

C       OPTIONALLY PRINT INFORMATION

        IF ( MOD ( STEP, IPRINT ) .EQ. 0 ) THEN
             WRITE(*,'(1X,I8,5(2X,F10.6))')
     1                 STEP, EN, KN, VN, PRES, TEMP
             WRITE(NW1,'(1X,I8,5(2X,F10.6))')
     1                 STEP, EN, KN, VN, PRES, TEMP
          ENDIF


C       IF STILL EQUILIBRATING CALL SUBROUTINE TO SCALE VELOCITIES

        CALL SCALET (NATM, VX, VY, VZ, K, EQTEMP)

      ENDDO

C     START OF PRODUCTION MD CYCLE ** TIME THIS LOOP **

      CALL TIMER(TSTART)

C      CALL MOVOUT (NATM, MX, MY, MZ, NATMCL, HEAD, LIST, RX, RY, RZ)

      DO STEP=NEQUIL+1,NSTEP

        V = 0
        K = 0
        W = 0
        PRES = 0

C       CALL SUBROUTINE TO PERFORM FIRST
C       PART OF VELOCITY VERLET INTEGRATION
C       VECTOR OPERATIONS

        CALL MOVEA (NATM, RX, RY, RZ, VX, VY, VZ, FX, FY, FZ, DT)

C       CALL SUBROUTINE TO CREATE LINKED LIST AND PASS EDGES
C       BETWEEN PROCESSORS

        CALL MOVOUT (NATM, MX, MY, MZ,
     1               NATMCL, HEAD, LIST, IDL, RXL, RYL, RZL,
     2               RX, RY, RZ)

C       CALL SUBROUTINE TO CALCULATE FORCES AND POTENTIAL
C       USING LINKED
C       SCALAR ROUTINE MORE THAN 95% OF CPU TIME

        CALL FORCE (NATM, MX, MY, MZ, FXL, FYL, FZL, V, W,
     1                  RXL, RYL, RZL, NATMCL, HEAD, LIST)

        CALL MOVIN (NATM, FX, FY, FZ, MX, MY, MZ,
     1              NATMCL, HEAD, LIST, IDL, FXL, FYL, FZL)

C       CALL SUBROUTINE TO PERFORM SECOND PART
C       OF VELOCITY VERLET INTEGRATION
C       VECTOR OPERATIONS

        CALL MOVEB (NATM, VX, VY, VZ, K, FX, FY, FZ, DT)

C       CALCULATE AND ACCUMULATE GLOBAL DATA

        E    = K+V
        EN   = E/DBLE(NATM)
        VN   = V/DBLE(NATM)
        KN   = K/DBLE(NATM)
        TEMP = 2.0D0*K/FREE
        PRES = DENS*TEMP+W
        PRES = PRES*SIGMA**3

        ACE    = ACE  +EN
        ACV    = ACV  +VN
        ACK    = ACK  +KN
        ACP    = ACP  +PRES
        ACESQ  = ACESQ+EN*EN
        ACVSQ  = ACVSQ+VN*VN
        ACKSQ  = ACKSQ+KN*KN
        ACPSQ  = ACPSQ+PRES*PRES

C       OPTIONALLY PRINT INFORMATION

        IF ( MOD ( STEP, IPRINT ) .EQ. 0 ) THEN
             WRITE(*,'(1X,I8,5(2X,F10.6))')
     :                 STEP, EN, KN, VN, PRES, TEMP
             WRITE(NW1,'(1X,I8,5(2X,F10.6))')
     :                 STEP, EN, KN, VN, PRES, TEMP
          ENDIF

      ENDDO

      CALL TIMER(TEND)

      TIME = TEND-TSTART

C    *******************************************************************
C    ** ENDS THE LOOP OVER CYCLES                                     **
C    *******************************************************************

      WRITE(*,'(/'' ** MOLECULAR DYNAMICS ENDS  ** ''///)')

C     WRITE OUT FINAL AVERAGES

      NORM = DBLE(NSTEP-NEQUIL)
      AVE  = ACE/NORM
      AVK  = ACK/NORM
      AVV  = ACV/NORM
      AVP  = ACP/NORM

      ACESQ = (ACESQ/NORM)-AVE**2
      ACKSQ = (ACKSQ/NORM)-AVK**2
      ACVSQ = (ACVSQ/NORM)-AVV**2
      ACPSQ = (ACPSQ/NORM)-AVP**2

      IF (ACESQ.GT.0.0D0) FLE = DSQRT(ACESQ)
      IF (ACKSQ.GT.0.0D0) FLK = DSQRT(ACKSQ)
      IF (ACVSQ.GT.0.0D0) FLV = DSQRT(ACVSQ)
      IF (ACPSQ.GT.0.0D0) FLP = DSQRT(ACPSQ)

      AVT = AVK/1.5D0
      FLT = FLK/1.5D0

      WRITE(*,'('' AVERAGES'',5(2X,F10.5))')
     :             AVE, AVK, AVV, AVP, AVT
      WRITE(*,'('' FLUCTS  '',5(2X,F10.5))')
     :             FLE, FLK, FLV, FLP, FLT

      CALL FLOPS (NW1, NC, NSTEP - NEQUIL, RCUT, TIME,  MX, MY, MZ)

      CLOSE(NW1)

      STOP
10001 FORMAT(/1X,'TIMESTEP  ..ENERGY..  ..KINETIC..',
     :          '  ..POTENT..  .PRESSURE.  ..TEMPER..  ')

      END


      SUBROUTINE FCC (NATM, RX, RY, RZ, VX, VY, VZ, NC)
      IMPLICIT NONE
      INTEGER NATM
C      INCLUDE 'md1.inc'
      DOUBLE PRECISION RX (NATM), RY (NATM), RZ (NATM)
      DOUBLE PRECISION VX (NATM), VY (NATM), VZ (NATM)
      INTEGER NC

C     *********************************************************************
C     ** ROUTINE TO CREATE AN FCC CONFIGURATION.                         **
C     **                                                                 **
C     ** THE INITIAL CONFIGURATION IS A FACE-CENTERED CUBIC ARRANGEMENT, **
C     ** CONSISTING OF NC * NC * NC UNIT CELLS, EACH CONTAINING 4 ATOMS. **
C     ** NOTE WELL THAT THESE UNIT CELLS HAVE NO CONNECTION WITH THE     **
C     ** CELLS USED DURING UPDATING!  THE UNIT CELL SIZE IS A * A * A.   **
C     ** THE FOUR ATOMS WITHIN THIS CELL ARE DISPLACED BY                **
C     **     (0, 0, 0), (A/2, 0, A/2), (A/2, A/2, 0), (0, A/2, A/2)      **
C     ** FROM THE CORNER.  THE `EPS' SHIFTS DON'T APPEAR TO SERVE ANY    **
C     ** USEFUL PURPOSE, BUT THEY WERE IN THE ORIGINAL CODE.             **
C     ** VELOCITIES ARE INITIALISED RANDOMLY, BUT ALTERNATE ATOMS HAVE   **
C     ** OPPOSITE VELOCITIES (SO THE TOTAL MOMENTUM IS ZERO).            **
C     *********************************************************************

        DOUBLE PRECISION EPS
        PARAMETER (EPS = 1.0D-6)
        DOUBLE PRECISION BASEX, BASEY, BASEZ
        PARAMETER (BASEX = -0.5, BASEY = -0.5, BASEZ = -0.5)

        INTEGER IS
        INTEGER I, LX, LY, LZ
        DOUBLE PRECISION A

        A = 1.0 / DBLE (NC)

C       SEED FOR RANDOM NUMBER GENERATOR

        IS = 2215

        I = 0
        DO LZ = 0, NC - 1
          DO LY = 0, NC - 1
            DO LX = 0, NC - 1
              I = I + 1
              RX (I) = BASEX + A * DBLE (LX) + EPS
              RY (I) = BASEY + A * DBLE (LY) + EPS
              RZ (I) = BASEZ + A * DBLE (LZ) + EPS
              CALL XSRAND (IS, VX (I))
              CALL XSRAND (IS, VY (I))
              CALL XSRAND (IS, VZ (I))

              I = I + 1
              RX (I) = BASEX + A * (DBLE (LX) + 0.5D0) - EPS
              RY (I) = BASEY + A *  DBLE (LY)          + EPS
              RZ (I) = BASEZ + A * (DBLE (LZ) + 0.5D0) - EPS
              VX (I) = 0.0D0 - VX (I - 1)
              VY (I) = 0.0D0 - VY (I - 1)
              VZ (I) = 0.0D0 - VZ (I - 1)

              I = I + 1
              RX (I) = BASEX + A * (DBLE (LX) + 0.5D0) - EPS
              RY (I) = BASEY + A * (DBLE (LY) + 0.5D0) - EPS
              RZ (I) = BASEZ + A *  DBLE (LZ)          + EPS
              CALL XSRAND (IS, VX (I))
              CALL XSRAND (IS, VY (I))
              CALL XSRAND (IS, VZ (I))

              I = I + 1
              RX (I) = BASEX + A *  DBLE (LX)          + EPS
              RY (I) = BASEY + A * (DBLE (LY) + 0.5D0) - EPS
              RZ (I) = BASEZ + A * (DBLE (LZ) + 0.5D0) - EPS
              VX (I) = 0.0D0 - VX (I - 1)
              VY (I) = 0.0D0 - VY (I - 1)
              VZ (I) = 0.0D0 - VZ (I - 1)
            ENDDO
          ENDDO
        ENDDO
      END


      SUBROUTINE XSRAND(IS,C)
      IMPLICIT NONE
      INTEGER IS
      DOUBLE PRECISION C

C     *********************************************************************
C     **   ROUTINE TO GENERATE RANDOM NUMBERS.                           **
C     **   THIS GENERATOR HAS NOT BEEN TESTED AND SHOULD NOT BE RELIED   **
C     **   UPON TO PRODUCE GENUINLY RANDOM NUMBERS!!                     **
C     *********************************************************************

        INTEGER IMULT, IMOD, IS1, IS2, ISS2
        DOUBLE PRECISION SCALE

        DATA IMULT /16807/, IMOD /2147483647/, SCALE /4.656612875D-10/

        IF (IS .LE. 0) IS = 1
        IS2  = MOD (IS, 32768)
        IS1  = (IS - IS2) / 32768
        ISS2 = IS * IMULT
        IS2  = MOD (ISS2, 32768)
        IS1  = MOD (IS1 * IMULT + (ISS2 - IS2) / 32768, 65536)
        IS   = MOD (IS1 * 32768 + IS2, IMOD)
        C = 2.0D0 * (SCALE * DBLE (IS) - 0.5D0) * 1.0D-6
      END


      SUBROUTINE MOVOUT (NATM, MX, MY, MZ,
     1                   NATMCL, HEAD, LIST, IDL, RXL, RYL, RZL,
     2                   RX, RY, RZ)
      IMPLICIT NONE
      INCLUDE 'md1.inc'
      INTEGER NATM
      INTEGER MX, MY, MZ
      INTEGER NATMCL (MX, MY, MZ), HEAD (MX, MY, MZ),
     1        LIST (LMAX, MX, MY, MZ), IDL (LMAX, MX, MY, MZ)
      DOUBLE PRECISION RXL (LMAX, MX, MY, MZ),
     1                 RYL (LMAX, MX, MY, MZ),
     2                 RZL (LMAX, MX, MY, MZ)
      DOUBLE PRECISION RX (NATM), RY (NATM), RZ (NATM)

C     ************************************************************
C     ** BUILDS LINKED LISTS FROM VECTOR OF PARTICLES           **
C     ************************************************************

        DOUBLE PRECISION BASEX, BASEY, BASEZ
        PARAMETER (BASEX = -0.5, BASEY = -0.5, BASEZ = -0.5)

        INTEGER I, IX, IY, IZ, FREE

C       ZERO LINKED LISTS

        DO IX = 1, MX
          DO IY = 1, MY
            DO IZ = 1, MZ
              HEAD   (IX, IY, IZ) = 0
              NATMCL (IX, IY, IZ) = 0
            ENDDO
          ENDDO
        ENDDO

C       ALLOCATE ATOMS TO LISTS.
C       USE `NATMCL' AS A VESTIGIAL ``FREE LIST'' POINTER

        DO I = 1, NATM
          IX = 1 + IDINT ((RX (I) - BASEX) * MX)
          IY = 1 + IDINT ((RY (I) - BASEY) * MY)
          IZ = 1 + IDINT ((RZ (I) - BASEZ) * MZ)

          FREE = NATMCL (IX, IY, IZ) + 1
          NATMCL (IX, IY, IZ) = FREE

          LIST (FREE, IX, IY, IZ) = HEAD (IX, IY, IZ)
          IDL  (FREE, IX, IY, IZ) = I
          RXL  (FREE, IX, IY, IZ) = RX (I)
          RYL  (FREE, IX, IY, IZ) = RY (I)
          RZL  (FREE, IX, IY, IZ) = RZ (I)

          HEAD (IX, IY, IZ) = FREE
        ENDDO
      END

      SUBROUTINE MOVIN (NATM, FX, FY, FZ, MX, MY, MZ,
     1                  NATMCL, HEAD, LIST, IDL, FXL, FYL, FZL)
      IMPLICIT NONE
      INCLUDE 'md1.inc'
      INTEGER NATM
      DOUBLE PRECISION FX (NATM), FY (NATM), FZ (NATM)
      INTEGER MX, MY, MZ
      INTEGER NATMCL (MX, MY, MZ), HEAD (MX, MY, MZ),
     1        LIST (LMAX, MX, MY, MZ), IDL (LMAX, MX, MY, MZ)
      DOUBLE PRECISION FXL (LMAX, MX, MY, MZ),
     1                 FYL (LMAX, MX, MY, MZ),
     2                 FZL (LMAX, MX, MY, MZ)

        INTEGER IX, IY, IZ, I, ID

        DO IX = 1, MX
          DO IY = 1, MY
            DO IZ = 1, MZ
              DO I = 1, NATMCL (IX, IY, IZ)
                ID      = IDL (I, IX, IY, IZ)
                FX (ID) = FXL (I, IX, IY, IZ)
                FY (ID) = FYL (I, IX, IY, IZ)
                FZ (ID) = FZL (I, IX, IY, IZ)
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      END


      SUBROUTINE MAPS (MX, MY, MZ)
      IMPLICIT NONE
      INTEGER MX, MY,MZ

C     *******************************************************************
C     ** INITIALISE TABLES FOR ACCESSING NEIGHBOURS IN `FORCE'         **
C     *******************************************************************

C        INCLUDE 'md1.inc'
        INCLUDE 'neighb.inc'

        INTEGER NABOR, S
        INTEGER IX, IY, IZ
        INTEGER JX, JY, JZ
        INTEGER SX, SY, SZ

        DO NABOR = 1, 13

C         `SX', `SY', `SZ' RUN OVER DISPLACEMENTS OF 13 NEIGHBOURS
C         WITH LEXICOGRAPHICALLY GREATER (IGNORING BC'S) COORDS.

          S = 13 + NABOR

          SX = MOD (S / 3, 3) - 1
          SY =      S / 9     - 1
          SZ = MOD (S,     3) - 1

          SXAR (NABOR) = SX
          SYAR (NABOR) = SY
          SZAR (NABOR) = SZ

          DO IX = 1, MX
            JX = 1 + MOD (IX + SX + MX - 1, MX)
            JXAR   (NABOR, IX) = JX
            DSPXAR (NABOR, IX) = (IX + SX - JX) / MX
          ENDDO

          DO IY = 1, MY
            JY = 1 + MOD (IY + SY + MY - 1, MY)
            JYAR   (NABOR, IY) = JY
            DSPYAR (NABOR, IY) = (IY + SY - JY) / MY
          ENDDO

          DO IZ = 1, MZ
            JZ = 1 + MOD (IZ + SZ + MZ - 1, MZ)
            JZAR   (NABOR, IZ) = JZ
            DSPZAR (NABOR, IZ) = (IZ + SZ - JZ) / MZ
          ENDDO
        ENDDO
      END


      SUBROUTINE MOVEA (NATM, RX, RY, RZ, VX, VY, VZ, FX, FY, FZ, DT)
      IMPLICIT NONE
      INTEGER NATM
C      INCLUDE 'md1.inc'
      DOUBLE PRECISION RX (NATM), RY (NATM), RZ (NATM)
      DOUBLE PRECISION VX (NATM), VY (NATM), VZ (NATM)
      DOUBLE PRECISION FX (NATM), FY (NATM), FZ (NATM)
      DOUBLE PRECISION DT

C     *******************************************************************
C     ** FIRST PART OF THE VELOCITY VERLET ALGORITHM                   **
C     *******************************************************************

        INTEGER I
        DOUBLE PRECISION DT2, DTSQ2

        DT2   = 0.5D0 * DT
        DTSQ2 = DT * DT2

        DO I = 1, NATM

C         INTEGRATE COORDINATES A COMPLETE TIMESTEP

          RX (I) = RX (I) + DT * VX (I) + DTSQ2 * FX (I)
          RY (I) = RY (I) + DT * VY (I) + DTSQ2 * FY (I)
          RZ (I) = RZ (I) + DT * VZ (I) + DTSQ2 * FZ (I)

          RX (I) = RX (I) - DINT (RX (I) + RX (I))
          RY (I) = RY (I) - DINT (RY (I) + RY (I))
          RZ (I) = RZ (I) - DINT (RZ (I) + RZ (I))

C         INTEGRATE VELOCITIES HALF A TIMESTEP

          VX (I) = VX (I) + DT2 * FX (I)
          VY (I) = VY (I) + DT2 * FY (I)
          VZ (I) = VZ (I) + DT2 * FZ (I)
        ENDDO
      END


      SUBROUTINE MOVEB (NATM, VX, VY, VZ, K, FX, FY, FZ, DT)
      IMPLICIT NONE
      INTEGER NATM
C      INCLUDE 'md1.inc'
      DOUBLE PRECISION VX (NATM), VY (NATM), VZ (NATM)
      DOUBLE PRECISION K
      DOUBLE PRECISION FX (NATM), FY (NATM), FZ (NATM)
      DOUBLE PRECISION DT

C     *******************************************************************
C     ** SECOND PART OF VELOCITY VERLET ALGORITHM                      **
C     *******************************************************************

        DOUBLE PRECISION DT2
        INTEGER I

        DT2 = 0.5D0 * DT
        K   = 0.0D0
      
        DO I = 1, NATM

C         INTEGRATE VELOCITIES HALF A TIMESTEP

          VX (I) = VX (I) + DT2 * FX (I)
          VY (I) = VY (I) + DT2 * FY (I)
          VZ (I) = VZ (I) + DT2 * FZ (I)

C         SUM KINETIC ENERGY

          K = K + VX (I) * VX (I) + VY (I) * VY (I) + VZ (I) * VZ (I)
        ENDDO

        K = 0.5D0 * K
      END


      SUBROUTINE FORCE (NATM, MX, MY, MZ, FXL, FYL, FZL, V, W,
     1                  RXL, RYL, RZL, NATMCL, HEAD, LIST)
      IMPLICIT NONE
      INTEGER MX, MY, MZ
      INTEGER NATM
      INCLUDE 'md1.inc'
      DOUBLE PRECISION FXL (LMAX, MX, MY, MZ),
     1                 FYL (LMAX, MX, MY, MZ),
     2                 FZL (LMAX, MX, MY, MZ)
      DOUBLE PRECISION V, W
      DOUBLE PRECISION RXL (LMAX, MX, MY, MZ),
     1                 RYL (LMAX, MX, MY, MZ),
     2                 RZL (LMAX, MX, MY, MZ)
      INTEGER NATMCL (MX, MY, MZ), HEAD (MX, MY, MZ),
     1        LIST (LMAX, MX, MY, MZ)

C     *******************************************************************
C     ** ROUTINE TO COMPUTE FORCES AND POTENTIAL USING A LINK LIST     **
C     *******************************************************************

        INCLUDE 'neighb.inc'

        DOUBLE PRECISION SIGMA, RCUT
        COMMON /POTNTL/ SIGMA, RCUT

        DOUBLE PRECISION RCUTSQ, SIGSQ
        DOUBLE PRECISION VRCUT, DVRCUT, DVRC12
        DOUBLE PRECISION RXJ, RYJ, RZJ, RXIJ, RYIJ, RZIJ
        DOUBLE PRECISION RIJ, RIJSQ, SR2, SR6
        DOUBLE PRECISION FXIJ, FYIJ, FZIJ
        DOUBLE PRECISION FIJ, VIJ, WIJ

        INTEGER IX, IY, IZ
        INTEGER JX, JY, JZ
        INTEGER I, J, ILOC, NABOR

        SIGSQ  = SIGMA**2
        RCUTSQ = RCUT**2

C       CALCULATE VALUES FOR SHIFTED FORCE POTENTIAL

        SR6    = (SIGMA / RCUT)**6
        VRCUT  = SR6 * (SR6 - 1.0D0)
        DVRCUT = -1.0D0 * SR6 * (SR6 - 0.5D0) / RCUT
        DVRC12 = 12.0D0 * DVRCUT

C       ZERO FORCES AND POTENTIAL

        DO IX = 1, MX
          DO IY = 1, MY
            DO IZ = 1, MZ
              DO I = 1, NATMCL (IX, IY, IZ)
                FXL (I, IX, IY, IZ) = 0.0D0
                FYL (I, IX, IY, IZ) = 0.0D0
                FZL (I, IX, IY, IZ) = 0.0D0
              ENDDO
            ENDDO
          ENDDO
        ENDDO

        V = 0.0D0
        W = 0.0D0

C       LOOP OVER ALL CELLS

        DO IX = 1, MX
          DO IY = 1, MY
            DO IZ = 1, MZ
        
C             INTERACTIONS INTERNAL TO CELL

              ILOC = HEAD (IX, IY, IZ)

              I = ILOC
              DO WHILE (I .GT. 0)

C               LOOP OVER ALL MOLECULES BELOW I IN THE CURRENT CELL

                J = LIST (I, IX, IY, IZ)
                DO WHILE (J .GT. 0)
                  RXIJ  = RXL (I, IX, IY, IZ) - RXL (J, IX, IY, IZ)
                  RYIJ  = RYL (I, IX, IY, IZ) - RYL (J, IX, IY, IZ)
                  RZIJ  = RZL (I, IX, IY, IZ) - RZL (J, IX, IY, IZ)
                  RIJSQ = RXIJ * RXIJ + RYIJ * RYIJ + RZIJ * RZIJ
                  IF (RIJSQ .LT. RCUTSQ) THEN
                    RIJ   = DSQRT (RIJSQ)
                    SR2   = SIGSQ / RIJSQ
                    SR6   = SR2 * SR2 * SR2
                    VIJ   = SR6 * (SR6 - 1.0) -
     1                      VRCUT - DVRC12 * (RIJ - RCUT)
                    WIJ   = SR6 * (SR6 - 0.5) + DVRCUT * RIJ
                    V     = V + VIJ
                    W     = W + WIJ
                    FIJ   = WIJ / RIJSQ
                    FXIJ  = FIJ * RXIJ
                    FYIJ  = FIJ * RYIJ
                    FZIJ  = FIJ * RZIJ
                    FXL (I, IX, IY, IZ) = FXL (I, IX, IY, IZ) + FXIJ
                    FYL (I, IX, IY, IZ) = FYL (I, IX, IY, IZ) + FYIJ
                    FZL (I, IX, IY, IZ) = FZL (I, IX, IY, IZ) + FZIJ

                    FXL (J, IX, IY, IZ) = FXL (J, IX, IY, IZ) - FXIJ
                    FYL (J, IX, IY, IZ) = FYL (J, IX, IY, IZ) - FYIJ
                    FZL (J, IX, IY, IZ) = FZL (J, IX, IY, IZ) - FZIJ
                  ENDIF
                  J = LIST (J, IX, IY, IZ)
                ENDDO

                I = LIST (I, IX, IY, IZ)
              ENDDO

C             LOOP OVER ALL NEIGHBOURING CELLS

              DO NABOR = 1, 13
                JX = JXAR (NABOR, IX)
                JY = JYAR (NABOR, IY)
                JZ = JZAR (NABOR, IZ)

                J = HEAD (JX, JY, JZ)

                DO WHILE (J .NE. 0)
                  RXJ   = RXL (J, JX, JY, JZ) + DSPXAR (NABOR, IX)
                  RYJ   = RYL (J, JX, JY, JZ) + DSPYAR (NABOR, IY)
                  RZJ   = RZL (J, JX, JY, JZ) + DSPZAR (NABOR, IZ)

                  I = ILOC
                  DO WHILE (I .NE. 0)
                    RXIJ  = RXL (I, IX, IY, IZ) - RXJ
                    RYIJ  = RYL (I, IX, IY, IZ) - RYJ
                    RZIJ  = RZL (I, IX, IY, IZ) - RZJ
                    RIJSQ = RXIJ * RXIJ + RYIJ * RYIJ + RZIJ * RZIJ
                    IF (RIJSQ .LT. RCUTSQ) THEN
                      RIJ   = DSQRT (RIJSQ)
                      SR2   = SIGSQ / RIJSQ
                      SR6   = SR2 * SR2 * SR2
                      VIJ   = (SR6 * (SR6 - 1.0) -
     1                         VRCUT - DVRC12 * (RIJ - RCUT)) * 0.5
                      WIJ   = SR6 * (SR6 - 0.5) + DVRCUT * RIJ
                      FIJ   = WIJ / RIJSQ
                      WIJ   = 0.5D0 * WIJ
                      FXIJ  = FIJ * RXIJ
                      FYIJ  = FIJ * RYIJ
                      FZIJ  = FIJ * RZIJ

C                     SUM FORCES AND POTENTIAL

                      V      = V + VIJ
                      W      = W + WIJ
                      FXL (I, IX, IY, IZ) = FXL (I, IX, IY, IZ) + FXIJ
                      FYL (I, IX, IY, IZ) = FYL (I, IX, IY, IZ) + FYIJ
                      FZL (I, IX, IY, IZ) = FZL (I, IX, IY, IZ) + FZIJ

C                     SUM FORCES AND POTENTIAL

                      V      = V + VIJ
                      W      = W + WIJ
                      FXL (J, JX, JY, JZ) = FXL (J, JX, JY, JZ) - FXIJ
                      FYL (J, JX, JY, JZ) = FYL (J, JX, JY, JZ) - FYIJ
                      FZL (J, JX, JY, JZ) = FZL (J, JX, JY, JZ) - FZIJ
                    ENDIF
                    I = LIST (I, IX, IY, IZ)
                  ENDDO

                  J = LIST (J, JX, JY, JZ)
                ENDDO
              ENDDO
            ENDDO
          ENDDO
        ENDDO

C       INCORPORATE ENERGY FACTORS

        V =  4.0D0 * V
        W = 16.0D0 * W

        DO IX = 1, MX
          DO IY = 1, MY
            DO IZ = 1, MZ
              DO I = 1, NATMCL (IX, IY, IZ)
                FXL (I, IX, IY, IZ) = 48.0D0 * FXL (I, IX, IY, IZ)
                FYL (I, IX, IY, IZ) = 48.0D0 * FYL (I, IX, IY, IZ)
                FZL (I, IX, IY, IZ) = 48.0D0 * FZL (I, IX, IY, IZ)
              ENDDO
            ENDDO
          ENDDO
        ENDDO
      END


      SUBROUTINE SCALET (NATM, VX, VY, VZ, K, EQTEMP)
      IMPLICIT NONE
C      INCLUDE 'md1.inc'
      INTEGER NATM
      DOUBLE PRECISION VX (NATM), VY (NATM), VZ (NATM)
      DOUBLE PRECISION EQTEMP, K

C     *******************************************************************
C     ** SCALE VELOCITIES FOR EQUILIBRATION                            **
C     *******************************************************************

        DOUBLE PRECISION SCALEF
        INTEGER I

        SCALEF =
     1    DSQRT (EQTEMP / (2.0D0 * K / (3.0D0 * DBLE (NATM - 1))))

C       SCALE VELOCITIES

        DO I = 1, NATM
          VX (I) = VX (I) * SCALEF
          VY (I) = VY (I) * SCALEF
          VZ (I) = VZ (I) * SCALEF
        ENDDO

      END

