C	[GASLIBX.FOR of JUGPDS Vol.10]
C
C	* Extended GASP II Library for Fortran-80 by M. Yamagiwa *
C
        SUBROUTINE      GASP(NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     GASPX                                   /
C/      Date-written.   Feb. 4th 1984                           /
C/      File-name.      GASPX.FOR                               /
C/      Remarks.        Subroutine GASPX page 307               /
C/			GASPX is the master control routine and /
C/			is referred to as the GASPX executive.	/
C/								/
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
        NOT = 0
    1   CALL    DATAN(NSET,QSET)
C
C       --- Print out filing array.
C
        JEVNT = 101
        CALL    MONTR(NSET,QSET)
        WRITE(NPRNT,403)
  403     FORMAT(1H0,28X,'** Intermediate Results **'//)
C
C       --- Obtain next event which is first entry in file 1.
C           ATRIB(1) is event time, ATRIB(2) is event code.
C
   10   CALL    RMOVE(MFE(1),1,NSET,QSET)
        TNOW = ATRIB(1)
        JEVNT = JTRIB(1)
C
C       --- Test to see if this event is a moitor event.
C
        IF (JEVNT - 100)13,12,6
   13   I = JEVNT
C
C       --- Call programmers event routines.
C
        CALL    EVNTS(I, NSET,QSET)
C
C       --- Test methode for stopping
C
        IF (MSTOP) 40,8,20
   40   MSTOP = 0
C
C       --- Test for no summary report.
C
        IF (NORPT) 14,22,42
   20   IF (TNOW - TFIN) 8,22,22
   22   CALL    SUMRY(NSET,QSET)
        CALL    OTPUT(NSET,QSET)
C
C       --- Test number of runs remaining
C
   42   IF (NRUNS - 1) 14,9,23
   23   NRUNS = NRUNS - 1
        NRUN = NRUN + 1
        				GO TO 1
   14   CALL    ERROR(93,NSET,QSET)
    6   CALL    MONTR(NSET,QSET)
        				GO TO 10
C
C       --- Reset JMNIT
C
   12   IF (JMNIT) 14,30,31
   30   JMNIT = 1
        				GO TO 10
   31   JMNIT = 0
        				GO TO 10
C
C       --- Test to see if event information is to be printed.
C
    8   IF (JMNIT) 14,10,32
   32	JTRIB(1) = JEVNT
        JEVNT = 100
        CALL    MONTR(NSET,QSET)
        				GO TO 10
C
C       --- If all runs are completed return to main program 
C           for instructions.
C
    9   RETURN
        END
C
        SUBROUTINE      COLCT(X,N,NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     COLCTX                                  /
C/	Date-written.	4th,Feb,1984				/
C/      File-name.      COLCT.FOR                               /
C/      Remarks.        Subroutine COLCTX.FOR page 74.          /
C/                      This subroutine collects sample data on /
C/                      the value of a variable.                /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
        IF (N.GT.0) GO TO 20
   10   CALL    ERROR(90,NSET,QSET)
   20   IF (N .GT. NCLCT) GO TO 10
        SUMA(N,1) = SUMA(N,1) + X
        SUMA(N,2) = SUMA(N,2) + X*X
        SUMA(N,3) = SUMA(N,3) + 1.0
        SUMA(N,4) = AMIN1(SUMA(N,4),X)
        SUMA(N,5) = AMAX1(SUMA(N,5),X)
        RETURN
        END
C
        SUBROUTINE      DATAN(NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     DATANX                                  /
C/      Date-written.    3rd,Feb,1984                           /
C/      File-name.      DATANX.FOR                              /
C/      Remarks.        Subroutine DATANX.FOR page 301.         /
C/			Initialize GASP variables to permit the /
C/			starting of the Simulation.		/
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
        IF (NOT) 23,1,2
C
C       --- NEP is a control variable for determining the starting
C           card type for multiple run problems.        
C           the value of NEP specifies the starting card type.
C
    2   NT = NEP
        GO TO (1,5,6,41,42,8,43,299,15,20),NT
   23   CALL	ERROR(95,NSET,QSET)
    1   NOT = 1
        NRUN = 1
C
C       --- Data card type one
C
	WRITE(3,200)
  200	FORMAT(1H0,9X,'1',9X,'2',9X,'3',9X,'4',9X,'5',9X,'6',9X,'7'/
     1  1H ,'123456789',1H0,'123456789',1H0,'123456789',1H0,'123456789'
     2  ,1H0,'123456789',1H0,'123456789',1H0,'1234567890')
        READ(NCRDR,101) NAME,NPROJ,MON,NDAY,NYR,NRUNS
  101     FORMAT(6A2,I4,I2,I2,I4,I4)
	WRITE(3,201) NAME,NPROJ,MON,NDAY,NYR,NRUNS
  201	  FORMAT(1H ,6A2,I4,I2,I2,I4,I4)
        IF (NRUNS) 30,30,5
   30      CALL    EXIT
C
C       --- Type 1 Data Card
C
    5   READ(NCRDR,803) NPRMS,NHIST,NCLCT,NSTAT,ID,IM,NOQ,MXC,IMM
  803     FORMAT(9I5)
	WRITE(3,804) NPRMS,NHIST,NCLCT,NSTAT,ID,IM,NOQ,MXC,IMM
  804	  FORMAT(1H ,9I5)
        IF (NHIST) 41,41,6
C
C       --- Type 3 Data Card is used only if NHIST is greater
C           than zero. Specify number of cells in histograms not
C           including end cells.
C
    6   READ(NCRDR,103) (NCELS(I),I=1,NHIST)
  103     FORMAT(10I5)
	WRITE(3,203) (NCELS(I),I=1,NHIST)
  203	  FORMAT(1H ,10I5)
C
C       --- Type 4 Data Card
C           Specify KRANK = Ranking row.
C
   41   READ(NCRDR,103) (KRANK(I),I=1,NOQ)
	WRITE(3,203) (KRANK(I),I=1,NOQ)
C
C       --- Type 5 Data Card
C           Specify INN=1 for LVF, INN=2 for HVF
C
   42      READ(NCRDR,103) (INN(I),I=1,NOQ)
	WRITE(3,203) (INN(I),I=1,NOQ)
        IF (NPRMS) 23,43,8
    8 DO 9 I=1,NPRMS
C       
C       --- Type 6 Data Card used only if NPRMS is greater than
C           zero.
C
        READ(NCRDR,106) (PARAM(I,J),J =1,4)
  106     FORMAT(4F10.4)
	WRITE(3,206) (PARAM(I,J),J=1,4)
  206	  FORMAT(1H ,4F10.4)
    9 CONTINUE
C
C     ---  Type 7 Data Card
C          The NEP value is for the next run.
C          Set JSEED greater than zero to set tnow equal to TBEG
C
   43   READ(NCRDR,104) MSTOP,JCLR,NORPT,NEP,TBEG,TFIN,JSEED
  104     FORMAT(4I5,2F10.3,I4)
	WRITE(3,204) MSTOP,JCLR,NORPT,NEP,TBEG,TFIN,JSEED
  204	  FORMAT(1H ,4I5,2F10.3,I4)
        IF (JSEED) 26,26,27
   27   ISEED = JSEED
	CALL	DRAND(ISEED,RNUM)
        TNOW = TBEG
        DO 142 J=1,NOQ
  142   QTIME(J) = TNOW
   26   JMNIT = 0
C
C       --- Initialize nset
C           Specify inputs for next run
C           Read in initial events
C
  299	DO 300 JS = 1,ID
C
C       --- Type 8 Data Card
C           Initialize NSET,QSET by JQ equal to a negative value on
C           first event card.
C           Read in intial vents. End initial events and entities
C           with JQ equal to zero.
C
	READ(NCRDR,1110) JQ,(JTRIB(JK),JK=1,IM)
  1110	  FORMAT(7I10)
	WRITE(3,2110) JQ,(JTRIB(JK),JK=1,IM)
  2110	  FORMAT(1H ,7I10)
        IF (JQ) 44,15,320
   44      INIT = 1
	CALL	SET(1,NSET,QSET)
        				GO TO 300
  320	READ(NCRDR,1120) (ATRIB(JK),JK=1,IMM)
 1120	  FORMAT(7F10.4)
	WRITE(3,2120) (ATRIB(JK),JK=1,IMM)
 2120	FORMAT(1H ,7F10.4)
	CALL	FILEM(JQ,NSET,QSET)
  300 CONTINUE
C
C       --- JCLR be positive for initialization of storage arrays.
C
   15      IF (JCLR) 20,20,10
   10      IF (NCLCT) 23,110,116
  116     DO 18 I = 1,NCLCT
        DO 17 J = 1,3
   17      SUMA(I,J) = 0.
        SUMA(I,4) = 1.0E20
   18   SUMA(I,5) = -1.0E20
  110   IF (NSTAT) 23,111,117
  117 DO 360 I=1,NSTAT
        SSUMA(I,1) = TNOW
        DO 370 J =2,3
  370     SSUMA(I,J) = 0.
	SSUMA(I,4) = 1.0E20
        SSUMA(I,5) = -1.0E20
  360 CONTINUE
  111     IF (NHIST) 23,20,118
  118 DO 380 K = 1,NHIST
        DO 380 L = 1,MXC
        JCELS(K,L) = 0
  380 CONTINUE
C
C       --- Print out program identification information.
C
   20   WRITE(1,102) NPROJ,NAME,MON,NDAY,NYR,NRUN
  102     FORMAT(1H1,19X,'Simulation Project No.',I4,2X,'on',2X,
     1    6A2//,20X,'Date',I3,'/',I3,'/',I5,12X,'Run number',I5//)
C
C       --- Print parameter values and scale.
C
        IF (NPRMS) 60,60,62
   62   DO 64 I=1,NPRMS
          WRITE(1,107) I,(PARAM(I,J),J=1,4)
  107       FORMAT(10X,' Parameter No.',I5,4F12.4)
   64 CONTINUE
   60	RETURN
	END
C
        SUBROUTINE      DRAND(ISEED,RNUM)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     DRAND                                   /
C/      Date-written.   Jan. 16th 1984                          /
C/      File-name.      DRAND.FOR                               /
C/      Remarks.        Subroutine DRAND.FOR page 96.           /
C/                      this subroutine generates a uniformly   /
C/                      distributed random variable in the      /
C/                      interval 0 to 1, a pseudo-random number /
C/                      DRAND is a modefied IBM 1130 subroutine /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
        CALL    RANDU(ISEED,RNUM)
        RETURN
        END
        SUBROUTINE      ERROR(J,NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     ERRORX                                  /
C/      Date-written.    4th,Feb,1984                           /
C/      File-name.      ERRORX.FOR ver2.0                       /
C/      Remarks.        Subroutine ERRORX.FOR page 303.         /
C/                      Subroutine ERROR is called when an e    /
C/                      error is detected in any GASP subroutine/
C/                      except PRNTQ,SUMRY, and MONTR, all of   /
C/                      which print their own message.          /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
	WRITE(NPRNT,100) J,TNOW
  100	FORMAT(//26X,'Error exit, Type',I3,' Error.'//,26X,
     $  ' File status at time',F10.4/)
	WRITE(NPRNT,200)
  200	FORMAT(20X,'NSET'/)
      DO  210 I=1,ID
	IL = (I-1) * MXX + 1
	IV = IL + MXX - 1
 	WRITE(NPRNT,90) I,(NSET(IJ),IJ=IL,IV)
   90	FORMAT(3X,I5,5X,12I8)
  210 CONTINUE
	WRITE(NPRNT,202)
  202	FORMAT(//20X,'QSET'/)
      DO 215 I=1,ID
	IL = (I-1) * IMM + 1
	IV = IL + IMM - 1
        WRITE(NPRNT,95) I,(QSET(IJ),IJ=IL,IV)
   95	FORMAT(3X,I5,4X,8(E12.6,2X))
  215 CONTINUE
	WRITE(NPRNT,99)
   99	FORMAT(1H0)
	IF (NCLCT) 7,7,8
    8	WRITE(NPRNT,98)
   98	FORMAT(/1H ,'Array SUMA',/)
      DO  110  I=1,NCLCT
	WRITE(NPRNT,80) I,(SUMA(I,K),K=1,5)
   80	  FORMAT(I10,5F10.4)
  110 CONTINUE
	WRITE(NPRNT,99)
    7	IF (NSTAT) 9,9,10
   10	WRITE(NPRNT,97)
   97	FORMAT(/1H ,'Array SSUMA'/)
      DO 111  I=1,NSTAT
	WRITE(NPRNT,80) I,(SSUMA(I,K),K=1,5)
  111 CONTINUE
	WRITE(NPRNT,99)
    9	IF (NHIST) 11,11,12
  12	WRITE(NPRNT,96)
  96	FORMAT(/1H ,'Array JCELS' /)
	DO 112 I=1,NHIST
	NCL = NCELS(I) + 2
  112	WRITE(NPRNT,26) I,(JCELS(I,K),K=1,NCL)
   26	FORMAT(7X,I3,5X,23I4)
   11	NFOOL = 0
	IF (NFOOL) 3,4,3
    3	RETURN
    4	CALL	EXIT
	END
C
        SUBROUTINE      FILEM(JQ,NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     FILEMX                                  /
C/      Date-written.    4th,Feb,1984                           /
C/      File-name.      FILEMX.FOR                              /
C/      Remarks.        Subroutine FILEMX.FOR page 306.         /
C/                      FILEMX is called to file an entry in    /
C/                      file JQ of the array NSET,QSET.         /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
C       --- Test to see if there is an avilable column for storage.
C
        IF (MFA - ID) 2,2,3
    3   WRITE(NPRNT,4)
    4     FORMAT(//24H Overlap Set Given Below/)
        CALL    ERROR(87,NSET,QSET)
C
C       --- Put attribute value in file
C
    2   INDX = (MFA - 1) * IMM
      DO  1 I=1,IMM
	INDX = INDX + 1
	QSET(INDX) = ATRIB(I)
    1 CONTINUE
	INDX = (MFA - 1) * MXX
      DO 10 I=1,IM
	INDX = INDX + 1
        NSET(INDX) = JTRIB(I)
   10 CONTINUE
	CALL	SET(JQ,NSET,QSET)
	RETURN
	END
C
        SUBROUTINE      HISTO(X1,A,W,N)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     HISTOX                                  /
C/	Date-written.	4th,Feb,1984				/
C/      File-name.      HISTO.FOR                               /
C/      Remarks.        Subroutine HISTOX.FOR page 79.          /
C/                      HISTO tabulates the number of times X1  /
C/                      is within the specified cell limits.    /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
        IF (N- NHIST) 11,11,2
    2   WRITE(NPRNT,250) N
  250     FORMAT(' Error in histogram',I4,//)
        CALL    EXIT
   11   IF (N) 2,2,3
C
C       --- Translate X1 by subtracing A if X.LE.A
C
    3   X = X1 - A
        IF (X) 6,7,7
    6   IC = 1
        				GO TO 8
C
C       --- Determine cell number IC.
C
    7   IC = X / W + 2.0
        IF (IC - NCELS(N) - 1) 8,8,9
    9   IC = NCELS(N) + 2
    8   JCELS(N,IC) = JCELS(N,IC) + 1
        RETURN
        END
C
        SUBROUTINE      MONTR(NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     MONTRX                                  /
C/	Date-written.	4th,Feb,1984				/
C/      File-name.      MONTRX.FOR                              /
C/      Remarks.        Subroutine MONTRX.FOR page 309.         /
C/                      The monitoring of events as they        /
C/                      occur.                                  /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
C       --- IF JEVNT .GE. 101   Print NSET,QSET
C
        IF (JEVNT - 101) 9,7,9
7       WRITE(NPRNT,100) TNOW
100	FORMAT(1H0,10X,'** GASP IIex JOB Storage area dump at',F10.4,
     $  2X,'Time units**'//)
	WRITE(NPRNT,200)
200	FORMAT(20X,'NSET'/)
	DO 210 I=1,ID
	IL = (I-1) * MXX + 1
	IV = IL + MXX - 1
210	WRITE(NPRNT,90) I,(NSET(IJ),IJ=IL,IV)
90	FORMAT(3X,I5,5X,12I8)
	WRITE(NPRNT,202)
202	FORMAT(//20X,'QSET' /)
	DO 215 I=1,ID
	IL = (I-1) * IMM + 1
	IV = IL + IMM - 1
215	WRITE(NPRNT,95) I,(QSET(IJ),IJ=IL,IV)
95	FORMAT(3X,I5,4X,8(E12.6,2X))
	RETURN
9	IF(MFE(1)) 3,6,1
C
C	--- IF JMNIT = 1,Print TNOW,Current event code, and all
C	    attributes of the next event.
C
1	IF(JMNIT - 1) 5,4,3
3	WRITE(NPRNT,199)
199	FORMAT(///26X,' Error Exit,Type 99 Error. ')
	CALL	EXIT
4	INDX = MFE(1)
	IL = (INDX-1) * MXX + 1
	IV = IL + MXX - 1
	WRITE(NPRNT,103) TNOW,JTRIB(1),(NSET(I),I=IL,IV)
103	FORMAT(/10X,'Next Event(NSET).... ',(6I8))
	IL = (INDX - 1) * IMM + 1
	IV = IL + IMM - 1
	WRITE(NPRNT,120) (QSET(I) ,I=IL,IV)
120	FORMAT(/10X,'Next Event(QSET).... ',(6E12.4))
5	RETURN
6	WRITE(NPRNT,104) TNOW
104	FORMAT(10X,' File is Empty at ',F10.2)
					GO TO 5
	END
C
        SUBROUTINE      PRNTQ(JQ,NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     PRNTQX                                  /
C/	Date-written.	4th,Feb,1984				/
C/      File-name.      PRNTQX.FOR                              /
C/      Remarks.        Subroutine PRNTQX.FOR page 310.         /
C/                      PRNTQX computes and prints the time-    /
C/                      integrated average and standard of the  /
C/                      number of entries in particular file    /
C/                      file and the maximum number of entries  /
C/                      that  were in the file since the file   /
C/                      was last initialized.                   /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
        WRITE(NPRNT,100) JQ
        IF (TNOW - TBEG) 12,12,13
   12   WRITE(NPRNT,105)
  105     FORMAT(/25X,'No Printout TNOW = TBEG '//)
        				GO TO 2
C
C       --- Compute expect no.
C
   13   XNQ = NQ(JQ)
        X = (ENQ(JQ) + XNQ * (TNOW - QTIME(JQ)))/(TNOW - TBEG)
	STD = (VNQ(JQ)+XNQ*XNQ*(TNOW-QTIME(JQ)))/(TNOW-TBEG)-X*X
	IF (STD.GT.0.0) GO TO 130
	STD = 0.0
					GO TO 140
130	STD = STD ** 0.5
140	WRITE(NPRNT,104) X,STD,MAXNQ(JQ)
	WRITE(NPRNT,101)
C
C       --- Print file in proper order requires tracing through the
C           pointers of the file
C
	NSQ = 1
	WRITE(NPRNT,200)
200	FORMAT(20X,'NSET'/)
230	LINE = MFE(JQ)
        IF (LINE - 1) 4,1,1
4       WRITE(NPRNT,102)
2       RETURN
1	L1 = LINE - 1
	GO TO (202,201),NSQ
202	INDX = L1 * MXX
	IB = INDX + 1
	IE = INDX + MXX
	WRITE(NPRNT,106) LINE,(NSET(I),I=IB,IE)
					GO TO 210
201	INDX = L1 * IMM
	IB = INDX + 1
	IE = INDX + IMM
	WRITE(NPRNT,103) LINE,(QSET(I),I=IB,IE)
210	INDX = LINE * MXX - 1
	LINE = NSET(INDX)
	IF (LINE - 7777) 1,2220,5
2220	IF (NSQ - 2) 221,2,2
221	NSQ = NSQ + 1
	WRITE(NPRNT,205)
205	FORMAT(//20X,'QSET'/)
					GO TO 230
    5	WRITE(NPRNT,199)
199	FORMAT(///26X,'Error Exit, Type 94 Error.')
100	FORMAT(//29X,' File Printout, File  No.',I3)
101	FORMAT(/35X,' File Contents' //)
102	FORMAT(/33X,'The File  is Empty'//)
103	FORMAT(3X,I5,4X,8(E12.6,2X))
104     FORMAT(/25X,'Average Number in file  was',F10.4,/25X,
     $  'STD. DEV.',18X,F10.4,/25X,'Maximum',24X,I4)
106	FORMAT(3X,I5,5X,12I8)
        CALL    EXIT
        END
C
        SUBROUTINE      RANDU(IY,YFL)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     RANDU                                   /
C/      Date-written.   Jan. 16th 1984                          /
C/      File-name.      RANDU.FOR                               /
C/      Remarks.        Subroutine RANDU.FOR page 96.           /
C/                      RANDU is a modefied IBM 1130 subroutine /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
        IY = IY * 899
        IF (IY) 5,6,6
5       IY = IY + 32767 + 1
6       YFL = IY
        YFL = YFL / 32767.0
        RETURN
        END
C
        SUBROUTINE      RMOVE(KCOLL,JQ,NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     RMOVEX                                  /
C/	Date-written.	Feb. 4th 1984				/
C/      File-name.      RMOVEX.FOR                              /
C/      Remarks.        Subroutine RMOVEX.FOR page 312.         /
C/                      Subroutine RMOVEX is called to remove   /
C/                      an entry from file JQ of the array      /
C/                      NSET,QSET.                              /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
C	--- The dummy array KCOLL is used as an argument to force
C	    the call by name option on computer such as the IBM 360
C
	KCOL = KCOLL(1)
        IF (KCOL) 16,16,2
16      CALL    ERROR(97,NSET,QSET)
2       MLC(JQ) = KCOL
C
C       --- Put values of KCOL in attrib
C
	INDX = (KCOL - 1) * IMM
	DO 3 I=1,IMM
	INDX = INDX + 1
3	ATRIB(I) = QSET(INDX)
	INDX = (KCOL - 1) * MXX
	DO 10 I=1,IM
	INDX = INDX + 1
10	JTRIB(I) = NSET(INDX)
C
C	--- Set OUT=1 and call SET to remove entry from NSET
C
	OUT = 1.0
	CALL	SET(JQ,NSET,QSET)
	RETURN
	END
C
        SUBROUTINE      SET(JQ,NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     SETX                                    /
C/	Date-written.	Feb. 4th 1984				/
C/      File-name.      SETX  .FOR ver2.0                       /
C/      Remarks.        Subroutine SETX.FOR page 313.           /
C/                      Subroutine SETX is the heart of the     /
C/                      information storage and retrieval       /
C/                      system. SETX performs three functions:  /
C/			1. Initialize the filing array NSET,	/
C/                      2. Updates the pointer system.          /
C/                      3. Maintain statistics on the number    /
C/                         of entries in each file.             /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
C       --- INIT should be one for initialization of file
C
        IF (INIT - 1) 27,28,27
C
C       --- Initialize file to zero. Set up pointers
C           must initialize KRANK(JQ)
C           must initialize INN(JQ)
C
   28	KOL = 7777
	KOF = 8888
	KLE = 9999
	MX = IM + 1
	MXX = IM + 2
	MAXQS = ID * IMM
	MAXNS = ID * MXX
C
C	--- Inirtialize pointing cells of NSET and zero other cells
C	    of NSET
C
	DO 2 J=1,MAXQS
    2	QSET(J) = 0.0
	DO 4 J=1,MAXNS
    4	NSET(J) = 0
	DO 1 I=1,ID
	INDX = I * MXX
	NSET(INDX - 1) = I + 1
    1	NSET(INDX) = I - 1
	NSET(MAXNS - 1) = KOF
	DO 3 K=1,NOQ
	NQ(K) = 0
	MLC(K) = 0
	MFE(K) = 0
	MAXNQ(K) = 0
	MLE(K) = 0
	ENQ(K) = 0.0
	VNQ(K) = 0.0
    3	QTIME(K) = TNOW
C
C	--- First available column = 1
C
	MFA = 1
	INIT = 0
	OUT = 0.0
	RETURN
C
C       --- MFEX is first entry in file which has not been compared 
C           with ITEM to be inserted.
C
   27	MFEX = MFE(JQ)
C
C       --- KNT is a check code to indicate that no comparisons have
C           been made.
C
        KNT = 2
C
C       --- KS is the row on which items of file JQ are ranked.
C
        KS = KRANK(JQ)
	KSJ = 1
	IF (KS - 100) 1020,100,1000
 1000	KSJ = 2
	KS = KS - 100
C
C       --- Test for putting value in or out
C           if out equals one an item is to be removed from file JQ
C           If OUT is less than ONE an item is to be inserted in
C           file JQ
C
 1020	IF (OUT - 1.0) 8,5,100
C
C       --- Putting an entry in file JQ
C
   8	INDX = MFA * MXX - 1
	NXFA = NSET(INDX)
C
C       --- If INN(JQ) equals two the file is a HVF file. If INN(JQ)
C           is one the file is a LVF file. For LVF files try to insert
C           Stating at end of file. MLEX is last entry in file which
C           has not been compared with items to be inserted.
C
        IF (INN(JQ) - 1) 100,7,6
    7   MLEX = MLE(JQ)
C
C       --- If MLEX is zero file is empty. item to be inserted will be
C           only item in file.
C
        IF (MLEX) 100,10,11
   10	INDX = MFA * MXX
	NSET(INDX) = KLE
        MFE(JQ) = MFA
C
C       --- There is no successor of item inserted. Since item was 
C           inserted in column MFA the last entry of file JQ is in
C           column MFA.
C
   17	INDX = MFA * MXX - 1
	NSET(INDX) = KOL
        MLE(JQ) = MFA
C
C       --- Set new MFA equal to successor of old MFA. that is NXFA
C
   14   MFA = NXFA
        IF (MFA - KOF) 237,238,238
  237	INDX = NXFA * MXX
	NSET(INDX) = KLE
C
C       ---Update statistics of file JQ
C
  238   XNQ = NQ(JQ)
        ENQ(JQ) = ENQ(JQ) + XNQ * (TNOW - QTIME(JQ))
        VNQ(JQ) = VNQ(JQ) + XNQ * XNQ * (TNOW - QTIME(JQ))
        QTIME(JQ) = TNOW
        NQ(JQ) = NQ(JQ) + 1
        MAXNQ(JQ) = MAX0(MAXNQ(JQ),NQ(JQ))
        MLC(JQ) = MFE(JQ)
        RETURN
C
C       --- Test ranking value of new item against value of item
C           in column
C
   11	GO TO (1100,1120),KSJ
 1100	INDX1 = (MFA - 1) * IMM + KS
	INDX2 = (MLEX - 1) * IMM + KS
	IF (QSET(INDX1) - QSET(INDX2)) 12,13,13
 1120	INDX1 = (MFA - 1) * MXX + KS
	INDX2 = (MLEX - 1) * MXX + KS
C
C	--- Test ranking value of new item against value of
C	    item in column MLEX
C
	IF(NSET(INDX1) - NSET(INDX2)) 12,13,13
C
C       --- Insert item after column MLEX.
C
   13	INDX = MLEX * MXX - 1
	MSU = NSET(INDX)
	NSET(INDX) = MFA
	INDX = MFA * MXX
	NSET(INDX) = MLEX
	GO TO (18,17),KNT
C
C       --- Since KNT equals one a comparison was made and there
C           is A.
C
   18	INDX = MFA * MXX - 1
	NSET(INDX) = MSU
	INDX = MSU * MXX
	NSET(INDX) = MFA
					GO TO 14
C
C       --- Set KNT to one since a comparison was made.
C
   12   KNT = 1
C
C       --- Test MFA against predecessor of MLEX by letting
C           MLEX equal predecessor of MLEX.
C
	INDX = MLEX * MXX
	MLEX = NSET(INDX)
        IF (MLEX-KLE) 11,16,11
C
C       --- If MLEX had no predecessor MFA is first in file
C
   16	INDX = MFA * MXX
	NSET(INDX) = KLE
        MFE(JQ) = MFA
C
C
C
   26	INDX = MFA * MXX - 1
	NSET(INDX) = MFEX
	INDX = MFEX * MXX
	NSET(INDX) = MFA
        GO TO 14
C
C       --- FOR HVF OPERATION TRY TO INSERT ITEM STARTING AT BEGINNING
C           OF FILE JQ.
C
    6   IF (MFEX) 100,10,19
C
C       --- Test ranking value of new item against value of
C           item in column MFEX.
C   
   19	GO TO (1200,1220),KSJ
 1200	INDX1 = (MFA - 1) * IMM + KS
	INDX2 = (MFEX - 1) * IMM + KS
	IF (QSET(INDX1) - QSET(INDX2)) 20,21,21
 1220	INDX1 = (MFA - 1) * MXX + KS
	INDX2 = (MFEX - 1) * MXX + KS
	IF (NSET(INDX1) - NSET(INDX2)) 20,21,21
C
C       --- If new value if lower. MFA must be compared against 
C           successor of MFEX.
C
   20   KNT = 1
C
C       --- Let MPRE = MFEX and let MFEX be the successor of MFEX.
C
        MPRE = MFEX
	INDX = MFEX * MXX - 1
	MFEX = NSET(INDX)
        IF (MFEX-KOL) 19,24,19
C
C       --- If new value is higher, it should be inserted between
C           MFEX and ITS.
C
   21      GO TO (22,16),KNT
   22      KNT = 2
C
C       --- MFA is to be inserted after MPRE. Make MPRE the prdece
C           ssor of MFA and MFA the successor of MPRE.
C
   24	INDX = MFA * MXX
	NSET(INDX) = MPRE
	INDX = MPRE * MXX - 1
	NSET(INDX) = MFA
C
C       --- If KNT was not reset to 2, thre is no successor of MFA
C           pointers are updated at statement 17.
C
        GO TO (17,26), KNT
C
C       --- Removal of an item from file JQ.
C
    5   OUT = 0.0
C
C       --- Update pointing system to account for removal of MLC(JQ)
C
	INDX = (MLC(JQ) - 1) * IMM
	DO 32 I=1,IMM
	INDX = INDX + 1
   32	QSET(INDX) = 0.0
	INDX = (MLC(JQ) - 1) * MXX
	DO 1300	I=1,IM
	INDX = INDX + 1
 1300	NSET(INDX) = 0
	INDX = MLC(JQ) * MXX
	JL = NSET(INDX - 1)
	JK = NSET(INDX)
	IF (JL - KOL) 33,34,33
   33	IF (JK - KLE) 35,36,35
   35	INDX = JK * MXX - 1
	NSET(INDX) = JL
	INDX = JL * MXX
	NSET(INDX) = JK
C
C	--- Update pointers
C
   37	INDX = MLC(JQ) * MXX - 1
	NSET(INDX) = MFA
	NSET(INDX +1) = KLE
	IF (MFA - KOF) 234,235,235
  234	INDX = MFA * MXX
	NSET(INDX) =MLC(JQ)
  235	MFA = MLC(JQ)
	MLC(JQ) = MFE(JQ)
C
C       --- Update file statistaics
C
        XNQ = NQ(JQ)
        ENQ(JQ) = ENQ(JQ) + XNQ * (TNOW - QTIME(JQ))
        VNQ(JQ) = VNQ(JQ) + XNQ * XNQ * (TNOW - QTIME(JQ))
        QTIME(JQ) = TNOW
        NQ(JQ) = NQ(JQ) - 1
        RETURN
C
C       --- MLC was first entry but not last entry. update pointers.
C
   36	INDX = JL * MXX
	NSET(INDX) = KLE
	MFE(JQ) = JL
					GO TO 37
   34      IF (JK - KLE) 38,39,38
C
C       --- MLC was last entry but not first entry. Update pointers.
C
   38	INDX = JK * MXX - 1
	NSET(INDX) = KOL
	MLE(JQ) = JK
	GO TO 37
C
C       --- MLC was both the last and first entry, therefore, it is
C           the only entry.
C
   39   MFE(JQ) = 0
        MLE(JQ) = 0
        				GO TO 37
  100	CALL	ERROR(88,NSET,QSET)
	RETURN
        END
C
        SUBROUTINE      SUMRY(NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     SUMRYX                                  /
C/	Date-written.	Feb. 4th 1984				/
C/      File-name.      SUMRY.FOR                               /
C/      Remarks.        Subroutine SUMRYX.FOR page 318.         /
C/			Subroutine SUMRYX is the basic output 	/
C/			routine of GASP II. It processes the	/
C/			the data collected in subroutine COLCT	/
C/			TMST, and HISTO and prints out a data	/
C/			summary.				/
C/								/
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
	WRITE(NPRNT,21)
   21	FORMAT(1H1,29X,'** GASPex Summary Report ** '/)
	WRITE(NPRNT,102) NPROJ,NAME,MON,NDAY,NYR,NRUN
  102	FORMAT(20X,'Simulation Project No.',I4,2X,'on',2X,
     1  6A2//,20X,'Date',I3,'/',I3,'/',I5,12X,'Run number',I5/)
	IF(NPRMS) 147,147,146
  146 DO  64  I=1,NPRMS
        WRITE(NPRNT,107) I,(PARAM(I,J),J=1,4)
  107	  FORMAT(10X,' Parameter No.',I5,4F12.4)
   64 CONTINUE
147	IF(NCLCT) 5,60,66
    5	WRITE(NPRNT,199)
  199	  FORMAT(///26X,'Error Exit, Type 98 Error.')
	CALL	EXIT
   66	WRITE(NPRNT,23)
   23	FORMAT(//34X,'** Generated Data ** ',/17X,'Code',4X,
     1	'Mean',6X,'STD.DEV.',5X,'Min.',7X,'Max.',5X,'OBS.'/)
C
C	--- Compute and print statistics gathered by CLCT
C
      DO 2 I=1,NCLCT
	IF(SUMA(I,3)) 5,62,61
   62	WRITE(NPRNT,63) I
   63	FORMAT(17X,I3,10X,'No Values Recorded ')
					GO TO 2
   61	XS = SUMA(I,1)
	XSS = SUMA(I,2)
	XN = SUMA(I,3)
	AVG = XS / XN
	STD = (((XN * XSS) - (XS * XS))/(XN * (XN - 1.0)))**0.5
	N = XN
	WRITE(NPRNT,24) I,AVG,STD,SUMA(I,4),SUMA(I,5),N
   24	FORMAT(17X,I3,4F11.4,I7)
    2 CONTINUE
   60	IF(NSTAT) 5,67,4
    4	WRITE(NPRNT,29)
   29	  FORMAT(/34X,'** Time Generated Data **'/,17X,'Code',4X,
     1    'Mean',6X,'STD.DEV.',5X,'Min.',7X,'Max.',3X,'Total Time '/)
C
C	--- Compute and print statistics gathered by TMST
C
      DO 6 I=1,NSTAT
	IF(SSUMA(I,1)) 5,71,72
   71	WRITE(NPRNT,63) I
					GO TO 6
   72	XT = SSUMA(I,1)
	XS = SSUMA(I,2)
	XSS = SSUMA(I,3)
	AVG = XS / XT
	STD = (XSS/XT - AVG*AVG) ** 0.5
	WRITE(NPRNT,30) I,AVG,STD,SSUMA(I,4),SSUMA(I,5),XT
   30	FORMAT(17X,I3,5F11.4)
    6 CONTINUE
   67	IF(NHIST) 5,75,9
    9	WRITE(NPRNT,25)
   25	  FORMAT(/27X,'** Generated Frequency Distributions **',/
     1		 17X,'Code',20X,'Histograms')
C
C	--- Print histograms
C
      DO  12  I=1,NHIST
	NCL = NCELS(I) + 2
        WRITE(NPRNT,26) I,(JCELS(I,J),J=1,NCL)
   26	  FORMAT(/17X,I3,5X,11I4,/(25X,11I4))
   12 CONTINUE
C
C	--- Print files and file statistics
C
   75 DO  15  I=1,NOQ
	CALL	PRNTQ(I,NSET,QSET)
   15 CONTINUE
	RETURN
	END
C
        SUBROUTINE      TMST(X,T,N,NSET,QSET)
C////////////////////////////////////////////////////////////////
C/                                                              /
C/      Program-id.     TMSTX                                   /
C/	Date-written.	4th,Feb,1984				/
C/      File-name.      TMST.FOR                                /
C/      Remarks.        Subroutine TMSTX.FOR page 76.           /
C/                      This subroutine collects sample data    /
C/                      on observations of a variable made over /
C/                      a period of time.                       /
C/                                                              /
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
        IF (N .GT. 0) GO TO 20
   10   CALL    ERROR(91,NSET,QSET)
   20   IF (N .GT. NSTAT) GO TO 10
        TT = T - SSUMA(N,1)
        SSUMA(N,1) = SSUMA(N,1) + TT
        SSUMA(N,2) = SSUMA(N,2) + X*TT
        SSUMA(N,3) = SSUMA(N,3) + X*X*TT
        SSUMA(N,4) = AMIN1(SSUMA(N,4),X)
        SSUMA(N,5) = AMAX1(SSUMA(N,5),X)
        RETURN
        END
C
	SUBROUTINE	FINDN(NVAL,MCODE,JQ,JATT,KCOL,NSET,QSET)
C////////////////////////////////////////////////////////////////
C/								/
C/	Program-id.	FINDN.FOR				/
C/	Date-written.	5th,Feb,1984				/
C/	Remarks.	GASP IIex Library subroutine from	/
C/			page 304				/
C/								/
C////////////////////////////////////////////////////////////////
C
	DIMENSION	NSET(1),QSET(1)
C
      COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
C
      COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
     2	 	 PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
     3		 NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
C
C
C	--- The column to be considered as a candidate is NEXTK
C
	KBEST = 0
	NEXTK = MFE(JQ)
	IF (NEXTK) 16,1,2
16	CALL	ERROR(89,NSET,QSET)
1	KCOL  = KBEST
	RETURN
C
C	--- MGRNV is +1 for greater than search and -1 for less than 
C	    search NMAMN is +1 for maximum and -1 for minimum
C
2	GO TO (11,12,13,14,11),MCODE
11	MGRNV = 1
	NMAMN = 1
	GO TO 20
12	MGRNV = 1
	NMAMN = -1
	GO TO 20
13	MGRNV = -1
	NMAMN = 1
	GO TO 20
14	MGRNV = -1
	NMAMN = -1
20	INDX = (NEXTK - 1) * MXX + JATT
	IF (MGRNV * (NSET(INDX) - NVAL)) 4,21,66
C
C	--- When equality is obtatined test for MCODE=5, the search for
C	    a specified value
C
21	IF (MCODE - 5) 4,15,4
66	IF (MCODE - 5) 6,4,6
6	IF(KBEST) 16,8,7
7	IF(NMAMN*(NSET(INDX)-NSET(KINDX))) 4,4,8
8	KBEST = NEXTK
	KINDX = INDX
4	INDS = (NEXTK)*MXX - 1
	NEXTK = NSET(INDS)
	IF (NEXTK - 7777) 20,1,1
15	KCOL=NEXTK
	RETURN
	END
C
	FUNCTION	UNFRM(A,B)
C////////////////////////////////////////////////////////////////
C/								/
C/	Program-id.	Function UNFRM				/
C/	Date-written.	5th,Feb,1984				/
C/	Remarks.	The function RNORM generates a deviate	/
C/			from a normal distribution .		/
C/			From page 97				/
C/								/
C////////////////////////////////////////////////////////////////
C
        COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
     $  NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
     $  TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
	COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
     $  MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4),
     $  QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON,NDAY,NYR,
     $  JCLR,JTRIB(12)
C
	CALL	DRAND (ISEED,RNUM)
	UNFRM = A + (B-A) * RNUM
	RETURN
	END
