C =====================================================================
C TESTDATA: Generate various kinds of initial conditions for tree code.
C =====================================================================

      PROGRAM TSTDAT

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        CHARACTER*32 HDLINE
        COMMON /TEXT/ HDLINE
        REAL EPS, DTIME
        INTEGER NSTEPS, NOUT
        COMMON /PARAMS/ EPS, DTIME, NSTEPS, NOUT

        INTEGER TEST, SEED

        WRITE (*, '(''TEST TO PERFORM (1 TO 6): '', $)')
        READ (*, *) TEST
        IF (TEST .LT. 1 .OR. TEST .GT. 6)
     &    CALL TERROR('TEST MUST BE BETWEEN 1 AND 6')
        WRITE (*, '(''NUMBER OF PARTICLES (1 TO'', I5, ''): '', $)')
     &    MXBODY
        READ (*, *) NBODY
        IF (NBODY .LT. 1 .OR. NBODY .GT. MXBODY)
     &    CALL TERROR('NBODY MUST BE BETWEEN 1 AND MXBODY')
        WRITE (*, '(''RANDOM NUMBER SEED: '', $)')
        READ (*, *) SEED
        CALL SRAND(SEED)
        IF (TEST .EQ. 1) THEN
          CALL TEST1
        ELSE IF (TEST .EQ. 2) THEN
          CALL TEST2
        ELSE IF (TEST .EQ. 3) THEN
          CALL TEST3
        ELSE IF (TEST .EQ. 4) THEN
          CALL TEST4
        ELSE IF (TEST .EQ. 5) THEN
          CALL TEST5
        ELSE IF (TEST .EQ. 6) THEN
          CALL TEST6
        ENDIF
        CALL OUTDAT
        CALL OUTPAR
      END

C ------------------------------
C TEST1: Isolated Plummer model.
C ------------------------------

      SUBROUTINE TEST1

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        CHARACTER*32 HDLINE
        COMMON /TEXT/ HDLINE
        REAL EPS, DTIME
        INTEGER NSTEPS, NOUT
        COMMON /PARAMS/ EPS, DTIME, NSTEPS, NOUT

        REAL ZVEC(NDIM)
        DATA ZVEC / NDIM * 0.0 /

        CALL PLUM(1, NBODY, ZVEC, ZVEC)
        HDLINE = 'ISOLATED PLUMMER MODEL          '
        EPS = 0.025
        DTIME = 1.0 / 32.0
        NSTEPS = INT(5.0 / DTIME)
        NOUT = INT(0.5 / DTIME)
      END

C -------------------------------------------
C TEST2: Head-on collision of Plummer models.
C -------------------------------------------

      SUBROUTINE TEST2

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        CHARACTER*32 HDLINE
        COMMON /TEXT/ HDLINE
        REAL EPS, DTIME
        INTEGER NSTEPS, NOUT
        COMMON /PARAMS/ EPS, DTIME, NSTEPS, NOUT

        INTEGER N1
        REAL POS1(NDIM), POS2(NDIM), VEL1(NDIM), VEL2(NDIM)
        DATA POS1 / -2.0, 0.0, 0.0 /, VEL1 /  0.5, 0.0, 0.0 /
        DATA POS2 /  2.0, 0.0, 0.0 /, VEL2 / -0.5, 0.0, 0.0 /

        N1 = NBODY / 2
        CALL PLUM(1, N1, POS1, VEL1)
        CALL PLUM(N1+1, NBODY-N1, POS2, VEL2)
        HDLINE = 'HEAD-ON PARABOLIC COLLISION     '
        EPS = 0.025
        DTIME = 1.0 / 32.0
        NSTEPS = INT(12.0 / DTIME)
        NOUT = INT(0.25 / DTIME)
      END

C -----------------------------------------------------------------
C TEST3: Off-axis collision of Plummer models, with orbital angular
C momentum JRAT parametrized in units of maximum possible value.
C -----------------------------------------------------------------

      SUBROUTINE TEST3

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        CHARACTER*32 HDLINE
        COMMON /TEXT/ HDLINE
        REAL EPS, DTIME
        INTEGER NSTEPS, NOUT
        COMMON /PARAMS/ EPS, DTIME, NSTEPS, NOUT

        INTEGER N1
        REAL JRAT, DV, POS1(NDIM), POS2(NDIM), VEL1(NDIM), VEL2(NDIM)
        PARAMETER(JRAT = 0.3)
        DATA POS1 / -2.0, 0.0, 0.0 /, VEL1 / NDIM * 0.0 /
        DATA POS2 /  2.0, 0.0, 0.0 /, VEL2 / NDIM * 0.0 /

        DV = SQRT(1.0 / ABS(POS1(1) - POS2(1)))
        VEL1(2) = JRAT * DV
        VEL1(1) = SQRT(1.0 - JRAT**2) * DV
        VEL2(1) = -VEL1(1)
        VEL2(2) = -VEL1(2)
        N1 = NBODY / 2
        CALL PLUM(1, N1, POS1, VEL1)
        CALL PLUM(N1+1, NBODY-N1, POS2, VEL2)
        HDLINE = 'OFF-AXIS PARABOLIC COLLISION    '
        EPS = 0.025
        DTIME = 1.0 / 32.0
        NSTEPS = INT(24.0 / DTIME)
        NOUT = INT(0.25 / DTIME)
      END

C ------------------------------------------------
C TEST4: Generalized polytrope with n = 1, m = -1.
C ------------------------------------------------

      SUBROUTINE TEST4

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        CHARACTER*32 HDLINE
        COMMON /TEXT/ HDLINE
        REAL EPS, DTIME
        INTEGER NSTEPS, NOUT
        COMMON /PARAMS/ EPS, DTIME, NSTEPS, NOUT

        REAL ZVEC(NDIM)
        DATA ZVEC /NDIM*0.0/

        CALL POLY(1, NBODY, ZVEC, ZVEC)
        HDLINE = 'GENERALIZED POLYTROPE           '
        EPS = 0.025
        DTIME = 1.0 / 32.0
        NSTEPS = INT(20.0 / DTIME)
        NOUT = INT(0.5 / DTIME)
      END

C ------------------------------------------------------------
C TEST5: Simplified version of the "Detonating galaxy" problem
C (see Salmon, J. & Warren, M. 1994, J. Comp. Phys. 111, 136).
C ------------------------------------------------------------

      SUBROUTINE TEST5

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        CHARACTER*32 HDLINE
        COMMON /TEXT/ HDLINE
        REAL EPS, DTIME
        INTEGER NSTEPS, NOUT
        COMMON /PARAMS/ EPS, DTIME, NSTEPS, NOUT

        REAL POS2(NDIM), VEL2(NDIM), SQRT2
        PARAMETER(SQRT2 = 1.41421356237)
        
        MASS(1) = 6.0
        POS(1,1) = 1.5 - SQRT2
        POS(2,1) = 1.5
        POS(3,1) = 4.0
        VEL(1,1) = 0.0
        VEL(2,1) = - 1.0 / (7 * 2**0.25)
        VEL(3,1) = 0.0
        POS2(1)  = 1.5 + 6.0 * SQRT2
        POS2(2)  = 1.5
        POS2(3)  = 4.0
        VEL2(1)  = 0.0
        VEL2(2)  = 6.0 / (7 * 2**0.25)
        VEL2(3)  = 0.0
        CALL PLUM(2, NBODY-1, POS2, VEL2)
        HDLINE = 'DETONATING GALAXY               '
        EPS = 0.025
        DTIME = 1.0 / 32.0
        NSTEPS = INT(16.0 / DTIME)
        NOUT = INT(0.5 / DTIME)
      END

C ------------------------------------------------------------------
C TEST6: Binary phase-space hierarchy (see Soneria, R. & Peebles, J.
C 1978, Astr. J. 83, 845).
C ------------------------------------------------------------------

      SUBROUTINE TEST6

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        CHARACTER*32 HDLINE
        COMMON /TEXT/ HDLINE
        REAL EPS, DTIME
        INTEGER NSTEPS, NOUT
        COMMON /PARAMS/ EPS, DTIME, NSTEPS, NOUT

        INTEGER MXSP, LEV0, NB, SP, K, LEV1, L01
        REAL LAMBDA, MASS0, DR0, POS1(NDIM), VEL1(NDIM), DR1, DV1
        PARAMETER(MXSP = 32, LAMBDA = 1.6, MASS0 = 1.0, DR0 = 1.0)
        INTEGER LEVSTK(MXSP)
        REAL POSSTK(NDIM,MXSP), VELSTK(NDIM,MXSP), DR(NDIM), DV(NDIM)

        LEV0 = INT(LOG(REAL(NBODY) + 0.5) / LOG(2.0))
        EPS = 0.025
        NB = 0
        SP = 1
        LEVSTK(SP) = LEV0
        DO 10 K = 1, NDIM
          POSSTK(K,SP) = 0.0
          VELSTK(K,SP) = 0.0
 10     CONTINUE
 20     IF (SP .GT. 0) THEN
          LEV1 = LEVSTK(SP)
          DO 30 K = 1, NDIM
            POS1(K) = POSSTK(K,SP)
            VEL1(K) = VELSTK(K,SP)
 30       CONTINUE
          SP = SP - 1
          IF (LEV1 .EQ. 0) THEN
            NB = NB + 1
            MASS(NB) = MASS0 / 2.0**LEV0
            DO 40 K = 1, NDIM
              POS(K,NB) = POS1(K)
              VEL(K,NB) = VEL1(K)
 40         CONTINUE
          ELSE
            IF (SP + 2 .GT. MXSP)
     &        CALL TERROR('STACK OVERFLOW IN TEST6')
            L01 = LEV0 - LEV1
            DR1 = DR0 / LAMBDA ** L01
C           -------------------------------------------
C           Allow for softening in velocity difference.
C           -------------------------------------------
            DV1 = SQRT(0.25 * (MASS0 / 2.0**L01) /
     &                   SQRT(4.0 * DR1**2 + EPS**2))
            CALL PICVEC(DR, NDIM, DR1)
            CALL PICVEC(DV, NDIM, DV1)
            SP = SP + 1
            LEVSTK(SP) = LEV1 - 1
            DO 50 K = 1, NDIM
              POSSTK(K,SP) = POS1(K) + DR(K)
              VELSTK(K,SP) = VEL1(K) + DV(K)
 50         CONTINUE
            SP = SP + 1
            LEVSTK(SP) = LEV1 - 1
            DO 60 K = 1, NDIM
              POSSTK(K,SP) = POS1(K) - DR(K)
              VELSTK(K,SP) = VEL1(K) - DV(K)
 60         CONTINUE
          ENDIF
          GOTO 20
        ENDIF
        IF (NB .NE. NBODY) THEN
          WRITE (*, '(''SETTING NBODY TO'', I5)') NB
          NBODY = NB
        ENDIF
        HDLINE = 'BINARY PHASE-SPACE HIERARCHY    '
        DTIME = 1.0 / 64.0
        NSTEPS = INT(16.0 / DTIME)
        NOUT = INT(0.25 / DTIME)
      END

C -------------------------------------------------------------------
C PLUM: Generate Plummer model (see Aarseth, S. et al. 1974, Astron.
C Astrophys. 37, 183).  In units with G = 1, the model has mass M = 1
C and binding energy E = -1/4.  A total of NPLUM bodies are stored in
C the MASS, POS, and VEL arrays beginning at index NSTART.  Center-
C of-mass coordinates are offset by ROFF and VOFF.
C -------------------------------------------------------------------

      SUBROUTINE PLUM(NSTART, NPLUM, ROFF, VOFF)
      INTEGER NSTART, NPLUM
      REAL ROFF(*), VOFF(*)

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        REAL RSC, VSC, RI, VI, X, Y, CMR(NDIM), CMV(NDIM), RAND
        REAL MFRAC, SQRT2, PI
        PARAMETER(MFRAC = 0.999, SQRT2 = 1.41421356237,
     &            PI = 3.14159265359)
        INTEGER K, I

        RSC = 3.0 * PI / 16.0
        VSC = SQRT(1.0 / RSC)
        DO 10 K = 1, NDIM
          CMR(K) = 0.0
          CMV(K) = 0.0
 10     CONTINUE
        DO 20 I = NSTART, NSTART+NPLUM-1
          MASS(I) = 1.0 / REAL(NPLUM)
          RI = 1 / SQRT((MFRAC * RAND(0))**(-2.0/3.0) - 1.0)
 30       CONTINUE
            X = RAND(0)
            Y = 0.1 * RAND(0)
          IF (Y .GT. X*X * (1 - X*X)**3.5) GOTO 30
          VI = SQRT2 * X / (1 + RI*RI)**0.25
          CALL PICVEC(POS(1,I), NDIM, RSC * RI)
          CALL PICVEC(VEL(1,I), NDIM, VSC * VI)
          DO 40 K = 1, NDIM
            CMR(K) = CMR(K) + MASS(I) * POS(K,I)
            CMV(K) = CMV(K) + MASS(I) * VEL(K,I)
 40       CONTINUE
 20     CONTINUE
        DO 50 I = NSTART, NSTART+NPLUM-1
          DO 60 K = 1, NDIM
            POS(K,I) = POS(K,I) - CMR(K) + ROFF(K)
            VEL(K,I) = VEL(K,I) - CMV(K) + VOFF(K)
 60       CONTINUE
 50     CONTINUE
      END

C -------------------------------------------------------------------
C POLY: Generate generalized polytrope model with polytropic indicies
C n = 1, m = -1 (see Henon, M. 1973, Astron. Astrophys. 37, 183).  In
C units with G = 1, the model has mass M = 1 and binding energy E =
C -1/4.  A total of NPOLY bodies are stored in the MASS, POS, and VEL
C arrays beginning at index NSTART.  Center-of-mass coordinates are
C offset by ROFF and VOFF.
C -------------------------------------------------------------------

      SUBROUTINE POLY(NSTART, NPOLY, ROFF, VOFF)
      INTEGER NSTART, NPOLY
      REAL ROFF(*), VOFF(*)

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        INTEGER I, K
        REAL R, X, V, RAND, CMR(NDIM), CMV(NDIM), SQRT2, PI
        PARAMETER(SQRT2 = 1.41421356237, PI = 3.14159265359)

        DO 10 K = 1, NDIM
          CMR(K) = 0.0
          CMV(K) = 0.0
 10     CONTINUE
        DO 20 I = NSTART, NSTART+NPOLY-1
          MASS(I) = 1.0 / REAL(NBODY)
          R = 2.0 * RAND(0)
          CALL PICVEC(POS(1,I), NDIM, R)
          X = SQRT2 * COS(PI * (2.0 - RAND(0)) / 4.0)
          V = (1.0 - X*X) * SQRT(LOG(2.0 / R))
          IF (RAND(0) .LT. 0.5) V = -V
          DO 30 K = 1, NDIM
            VEL(K,I) = (V/R) * POS(K,I)
            CMR(K) = CMR(K) + MASS(I) * POS(K,I)
            CMV(K) = CMV(K) + MASS(I) * VEL(K,I)
 30       CONTINUE
 20     CONTINUE
        DO 40 I = NSTART, NSTART+NPOLY-1
          DO 50 K = 1, NDIM
            POS(K,I) = POS(K,I) - CMR(K) + ROFF(K)
            VEL(K,I) = VEL(K,I) - CMV(K) + VOFF(K)
 50       CONTINUE
 40     CONTINUE
      END

C -----------------------------------------------
C PICVEC: Select random vector with given length.
C -----------------------------------------------

      SUBROUTINE PICVEC(VEC, NDIM, RAD)
      REAL VEC(*), RAD
      INTEGER NDIM

        REAL RSQ, RAND
        INTEGER K

 10     CONTINUE
          RSQ = 0.0
          DO 20 K = 1, NDIM
            VEC(K) = 1.0 - 2.0 * RAND(0)
            RSQ = RSQ + VEC(K)**2
 20       CONTINUE
        IF (RSQ .GT. 1.0) GOTO 10
        DO 30 K = 1, NDIM
          VEC(K) = RAD * VEC(K) / SQRT(RSQ)
 30     CONTINUE
      END

C ---------------------------------------------------------------------
C SRAND: Initialize portable random number generator.  This routine and
C the following one are adapted from the RAN2 random number generator
C (see Press, W. et al 1989, Numerical Recipes, Cambridge Univ. Press).
C ---------------------------------------------------------------------

      SUBROUTINE SRAND(SEED0)
      INTEGER SEED0

        INTEGER M, A, C, J, SEED, LAST, RTAB(97)
        PARAMETER(M = 714025, A = 1366, C = 150889)
        COMMON /RANDOM/ SEED, LAST, RTAB

        SEED = MOD(C + SEED0, M)
        DO 10 J = 1, 97
          SEED = MOD(A * SEED + C, M)
          RTAB(J) = SEED
 10     CONTINUE
        SEED = MOD(A * SEED + C, M)
        LAST = SEED
      END

C ---------------------------------------------
C RAND: Generate random number between 0 and 1.
C ---------------------------------------------

      REAL FUNCTION RAND(DUMMY)
      INTEGER DUMMY

        INTEGER M, A, C, J, SEED, LAST, RTAB(97)
        REAL MINV
        PARAMETER(M = 714025, MINV = 1.0 / M, A = 1366, C = 150889)
        COMMON /RANDOM/ SEED, LAST, RTAB

        J = 1 + (97 * LAST) / M
        IF (J .LT. 1 .OR. J .GT. 97)
     &    CALL TERROR('ERROR IN RAND')
        LAST = RTAB(J)
        SEED = MOD(A * SEED + C, M)
        RTAB(J) = SEED
        RAND = MINV * LAST
      END          

C -------------------------------------------------
C OUTDAT: Output initial value data for simulation.
C -------------------------------------------------

      SUBROUTINE OUTDAT

        INTEGER MXBODY, NDIM, NBODY
        PARAMETER(MXBODY = 8192, NDIM = 3)
        REAL MASS(MXBODY), POS(NDIM,MXBODY), VEL(NDIM,MXBODY)
        COMMON /BODIES/ MASS, POS, VEL, NBODY

        INTEGER I, K

        OPEN(10, FILE = 'treebodi', STATUS = 'UNKNOWN')
        WRITE (10, '(I16)') NBODY
        WRITE (10, '(I16)') NDIM
        WRITE (10, '(E16.8E2)') 0.0
        DO 10 I = 1, NBODY
          WRITE (10, '(E16.8E2)') MASS(I)
  10    CONTINUE
        DO 20 I = 1, NBODY
          WRITE (10, '(3E16.8E2)') (POS(K,I), K = 1, NDIM)
  20    CONTINUE
        DO 30 I = 1, NBODY
          WRITE (10, '(3E16.8E2)') (VEL(K,I), K = 1, NDIM)
  30    CONTINUE
        CLOSE(10)
      END

C -----------------------------------------
C OUTPAR: Output parameters for simulation.
C -----------------------------------------

      SUBROUTINE OUTPAR

        CHARACTER*32 HDLINE
        COMMON /TEXT/ HDLINE
        REAL EPS, DTIME
        INTEGER NSTEPS, NOUT
        COMMON /PARAMS/ EPS, DTIME, NSTEPS, NOUT

        OPEN(10, FILE = 'treepars', STATUS = 'UNKNOWN')
        WRITE (10, '(A32)') HDLINE
        WRITE (10, '(I12)') NSTEPS
        WRITE (10, '(I12)') NOUT
        WRITE (10, '(F12.8)') DTIME
        WRITE (10, '(F12.8)') 1.0
        WRITE (10, '(F12.8)') EPS
        WRITE (10, '(A12)') '.FALSE.'
        WRITE (10, '(I12)') 8
        CLOSE(10)
      END

C --------------------------------------
C TERROR: Report a fatal error and quit.
C --------------------------------------

      SUBROUTINE TERROR(MSG)
      CHARACTER*(*) MSG

        WRITE (*, '(A)') MSG
	STOP
      END
