home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol268 / gaslibx.for < prev    next >
Encoding:
Text File  |  1986-05-22  |  38.6 KB  |  1,260 lines
  1. C    [GASLIBX.FOR of JUGPDS Vol.10]
  2. C
  3. C    * Extended GASP II Library for Fortran-80 by M. Yamagiwa *
  4. C
  5.         SUBROUTINE      GASP(NSET,QSET)
  6. C////////////////////////////////////////////////////////////////
  7. C/                                                              /
  8. C/      Program-id.     GASPX                                   /
  9. C/      Date-written.   Feb. 4th 1984                           /
  10. C/      File-name.      GASPX.FOR                               /
  11. C/      Remarks.        Subroutine GASPX page 307               /
  12. C/            GASPX is the master control routine and /
  13. C/            is referred to as the GASPX executive.    /
  14. C/                                /
  15. C////////////////////////////////////////////////////////////////
  16. C
  17.     DIMENSION    NSET(1),QSET(1)
  18. C
  19.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  20.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  21.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  22. C
  23.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  24.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  25.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  26.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  27. C
  28.         NOT = 0
  29.     1   CALL    DATAN(NSET,QSET)
  30. C
  31. C       --- Print out filing array.
  32. C
  33.         JEVNT = 101
  34.         CALL    MONTR(NSET,QSET)
  35.         WRITE(NPRNT,403)
  36.   403     FORMAT(1H0,28X,'** Intermediate Results **'//)
  37. C
  38. C       --- Obtain next event which is first entry in file 1.
  39. C           ATRIB(1) is event time, ATRIB(2) is event code.
  40. C
  41.    10   CALL    RMOVE(MFE(1),1,NSET,QSET)
  42.         TNOW = ATRIB(1)
  43.         JEVNT = JTRIB(1)
  44. C
  45. C       --- Test to see if this event is a moitor event.
  46. C
  47.         IF (JEVNT - 100)13,12,6
  48.    13   I = JEVNT
  49. C
  50. C       --- Call programmers event routines.
  51. C
  52.         CALL    EVNTS(I, NSET,QSET)
  53. C
  54. C       --- Test methode for stopping
  55. C
  56.         IF (MSTOP) 40,8,20
  57.    40   MSTOP = 0
  58. C
  59. C       --- Test for no summary report.
  60. C
  61.         IF (NORPT) 14,22,42
  62.    20   IF (TNOW - TFIN) 8,22,22
  63.    22   CALL    SUMRY(NSET,QSET)
  64.         CALL    OTPUT(NSET,QSET)
  65. C
  66. C       --- Test number of runs remaining
  67. C
  68.    42   IF (NRUNS - 1) 14,9,23
  69.    23   NRUNS = NRUNS - 1
  70.         NRUN = NRUN + 1
  71.                         GO TO 1
  72.    14   CALL    ERROR(93,NSET,QSET)
  73.     6   CALL    MONTR(NSET,QSET)
  74.                         GO TO 10
  75. C
  76. C       --- Reset JMNIT
  77. C
  78.    12   IF (JMNIT) 14,30,31
  79.    30   JMNIT = 1
  80.                         GO TO 10
  81.    31   JMNIT = 0
  82.                         GO TO 10
  83. C
  84. C       --- Test to see if event information is to be printed.
  85. C
  86.     8   IF (JMNIT) 14,10,32
  87.    32    JTRIB(1) = JEVNT
  88.         JEVNT = 100
  89.         CALL    MONTR(NSET,QSET)
  90.                         GO TO 10
  91. C
  92. C       --- If all runs are completed return to main program 
  93. C           for instructions.
  94. C
  95.     9   RETURN
  96.         END
  97. C
  98.         SUBROUTINE      COLCT(X,N,NSET,QSET)
  99. C////////////////////////////////////////////////////////////////
  100. C/                                                              /
  101. C/      Program-id.     COLCTX                                  /
  102. C/    Date-written.    4th,Feb,1984                /
  103. C/      File-name.      COLCT.FOR                               /
  104. C/      Remarks.        Subroutine COLCTX.FOR page 74.          /
  105. C/                      This subroutine collects sample data on /
  106. C/                      the value of a variable.                /
  107. C/                                                              /
  108. C////////////////////////////////////////////////////////////////
  109. C
  110.     DIMENSION    NSET(1),QSET(1)
  111. C
  112.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  113.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  114.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  115. C
  116.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  117.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  118.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  119.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  120. C
  121. C
  122.         IF (N.GT.0) GO TO 20
  123.    10   CALL    ERROR(90,NSET,QSET)
  124.    20   IF (N .GT. NCLCT) GO TO 10
  125.         SUMA(N,1) = SUMA(N,1) + X
  126.         SUMA(N,2) = SUMA(N,2) + X*X
  127.         SUMA(N,3) = SUMA(N,3) + 1.0
  128.         SUMA(N,4) = AMIN1(SUMA(N,4),X)
  129.         SUMA(N,5) = AMAX1(SUMA(N,5),X)
  130.         RETURN
  131.         END
  132. C
  133.         SUBROUTINE      DATAN(NSET,QSET)
  134. C////////////////////////////////////////////////////////////////
  135. C/                                                              /
  136. C/      Program-id.     DATANX                                  /
  137. C/      Date-written.    3rd,Feb,1984                           /
  138. C/      File-name.      DATANX.FOR                              /
  139. C/      Remarks.        Subroutine DATANX.FOR page 301.         /
  140. C/            Initialize GASP variables to permit the /
  141. C/            starting of the Simulation.        /
  142. C/                                                              /
  143. C////////////////////////////////////////////////////////////////
  144. C
  145.     DIMENSION    NSET(1),QSET(1)
  146. C
  147.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  148.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  149.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  150. C
  151.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  152.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  153.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  154.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  155. C
  156.         IF (NOT) 23,1,2
  157. C
  158. C       --- NEP is a control variable for determining the starting
  159. C           card type for multiple run problems.        
  160. C           the value of NEP specifies the starting card type.
  161. C
  162.     2   NT = NEP
  163.         GO TO (1,5,6,41,42,8,43,299,15,20),NT
  164.    23   CALL    ERROR(95,NSET,QSET)
  165.     1   NOT = 1
  166.         NRUN = 1
  167. C
  168. C       --- Data card type one
  169. C
  170.     WRITE(3,200)
  171.   200    FORMAT(1H0,9X,'1',9X,'2',9X,'3',9X,'4',9X,'5',9X,'6',9X,'7'/
  172.      1  1H ,'123456789',1H0,'123456789',1H0,'123456789',1H0,'123456789'
  173.      2  ,1H0,'123456789',1H0,'123456789',1H0,'1234567890')
  174.         READ(NCRDR,101) NAME,NPROJ,MON,NDAY,NYR,NRUNS
  175.   101     FORMAT(6A2,I4,I2,I2,I4,I4)
  176.     WRITE(3,201) NAME,NPROJ,MON,NDAY,NYR,NRUNS
  177.   201      FORMAT(1H ,6A2,I4,I2,I2,I4,I4)
  178.         IF (NRUNS) 30,30,5
  179.    30      CALL    EXIT
  180. C
  181. C       --- Type 1 Data Card
  182. C
  183.     5   READ(NCRDR,803) NPRMS,NHIST,NCLCT,NSTAT,ID,IM,NOQ,MXC,IMM
  184.   803     FORMAT(9I5)
  185.     WRITE(3,804) NPRMS,NHIST,NCLCT,NSTAT,ID,IM,NOQ,MXC,IMM
  186.   804      FORMAT(1H ,9I5)
  187.         IF (NHIST) 41,41,6
  188. C
  189. C       --- Type 3 Data Card is used only if NHIST is greater
  190. C           than zero. Specify number of cells in histograms not
  191. C           including end cells.
  192. C
  193.     6   READ(NCRDR,103) (NCELS(I),I=1,NHIST)
  194.   103     FORMAT(10I5)
  195.     WRITE(3,203) (NCELS(I),I=1,NHIST)
  196.   203      FORMAT(1H ,10I5)
  197. C
  198. C       --- Type 4 Data Card
  199. C           Specify KRANK = Ranking row.
  200. C
  201.    41   READ(NCRDR,103) (KRANK(I),I=1,NOQ)
  202.     WRITE(3,203) (KRANK(I),I=1,NOQ)
  203. C
  204. C       --- Type 5 Data Card
  205. C           Specify INN=1 for LVF, INN=2 for HVF
  206. C
  207.    42      READ(NCRDR,103) (INN(I),I=1,NOQ)
  208.     WRITE(3,203) (INN(I),I=1,NOQ)
  209.         IF (NPRMS) 23,43,8
  210.     8 DO 9 I=1,NPRMS
  211. C       
  212. C       --- Type 6 Data Card used only if NPRMS is greater than
  213. C           zero.
  214. C
  215.         READ(NCRDR,106) (PARAM(I,J),J =1,4)
  216.   106     FORMAT(4F10.4)
  217.     WRITE(3,206) (PARAM(I,J),J=1,4)
  218.   206      FORMAT(1H ,4F10.4)
  219.     9 CONTINUE
  220. C
  221. C     ---  Type 7 Data Card
  222. C          The NEP value is for the next run.
  223. C          Set JSEED greater than zero to set tnow equal to TBEG
  224. C
  225.    43   READ(NCRDR,104) MSTOP,JCLR,NORPT,NEP,TBEG,TFIN,JSEED
  226.   104     FORMAT(4I5,2F10.3,I4)
  227.     WRITE(3,204) MSTOP,JCLR,NORPT,NEP,TBEG,TFIN,JSEED
  228.   204      FORMAT(1H ,4I5,2F10.3,I4)
  229.         IF (JSEED) 26,26,27
  230.    27   ISEED = JSEED
  231.     CALL    DRAND(ISEED,RNUM)
  232.         TNOW = TBEG
  233.         DO 142 J=1,NOQ
  234.   142   QTIME(J) = TNOW
  235.    26   JMNIT = 0
  236. C
  237. C       --- Initialize nset
  238. C           Specify inputs for next run
  239. C           Read in initial events
  240. C
  241.   299    DO 300 JS = 1,ID
  242. C
  243. C       --- Type 8 Data Card
  244. C           Initialize NSET,QSET by JQ equal to a negative value on
  245. C           first event card.
  246. C           Read in intial vents. End initial events and entities
  247. C           with JQ equal to zero.
  248. C
  249.     READ(NCRDR,1110) JQ,(JTRIB(JK),JK=1,IM)
  250.   1110      FORMAT(7I10)
  251.     WRITE(3,2110) JQ,(JTRIB(JK),JK=1,IM)
  252.   2110      FORMAT(1H ,7I10)
  253.         IF (JQ) 44,15,320
  254.    44      INIT = 1
  255.     CALL    SET(1,NSET,QSET)
  256.                         GO TO 300
  257.   320    READ(NCRDR,1120) (ATRIB(JK),JK=1,IMM)
  258.  1120      FORMAT(7F10.4)
  259.     WRITE(3,2120) (ATRIB(JK),JK=1,IMM)
  260.  2120    FORMAT(1H ,7F10.4)
  261.     CALL    FILEM(JQ,NSET,QSET)
  262.   300 CONTINUE
  263. C
  264. C       --- JCLR be positive for initialization of storage arrays.
  265. C
  266.    15      IF (JCLR) 20,20,10
  267.    10      IF (NCLCT) 23,110,116
  268.   116     DO 18 I = 1,NCLCT
  269.         DO 17 J = 1,3
  270.    17      SUMA(I,J) = 0.
  271.         SUMA(I,4) = 1.0E20
  272.    18   SUMA(I,5) = -1.0E20
  273.   110   IF (NSTAT) 23,111,117
  274.   117 DO 360 I=1,NSTAT
  275.         SSUMA(I,1) = TNOW
  276.         DO 370 J =2,3
  277.   370     SSUMA(I,J) = 0.
  278.     SSUMA(I,4) = 1.0E20
  279.         SSUMA(I,5) = -1.0E20
  280.   360 CONTINUE
  281.   111     IF (NHIST) 23,20,118
  282.   118 DO 380 K = 1,NHIST
  283.         DO 380 L = 1,MXC
  284.         JCELS(K,L) = 0
  285.   380 CONTINUE
  286. C
  287. C       --- Print out program identification information.
  288. C
  289.    20   WRITE(1,102) NPROJ,NAME,MON,NDAY,NYR,NRUN
  290.   102     FORMAT(1H1,19X,'Simulation Project No.',I4,2X,'on',2X,
  291.      1    6A2//,20X,'Date',I3,'/',I3,'/',I5,12X,'Run number',I5//)
  292. C
  293. C       --- Print parameter values and scale.
  294. C
  295.         IF (NPRMS) 60,60,62
  296.    62   DO 64 I=1,NPRMS
  297.           WRITE(1,107) I,(PARAM(I,J),J=1,4)
  298.   107       FORMAT(10X,' Parameter No.',I5,4F12.4)
  299.    64 CONTINUE
  300.    60    RETURN
  301.     END
  302. C
  303.         SUBROUTINE      DRAND(ISEED,RNUM)
  304. C////////////////////////////////////////////////////////////////
  305. C/                                                              /
  306. C/      Program-id.     DRAND                                   /
  307. C/      Date-written.   Jan. 16th 1984                          /
  308. C/      File-name.      DRAND.FOR                               /
  309. C/      Remarks.        Subroutine DRAND.FOR page 96.           /
  310. C/                      this subroutine generates a uniformly   /
  311. C/                      distributed random variable in the      /
  312. C/                      interval 0 to 1, a pseudo-random number /
  313. C/                      DRAND is a modefied IBM 1130 subroutine /
  314. C/                                                              /
  315. C////////////////////////////////////////////////////////////////
  316. C
  317.         CALL    RANDU(ISEED,RNUM)
  318.         RETURN
  319.         END
  320.         SUBROUTINE      ERROR(J,NSET,QSET)
  321. C////////////////////////////////////////////////////////////////
  322. C/                                                              /
  323. C/      Program-id.     ERRORX                                  /
  324. C/      Date-written.    4th,Feb,1984                           /
  325. C/      File-name.      ERRORX.FOR ver2.0                       /
  326. C/      Remarks.        Subroutine ERRORX.FOR page 303.         /
  327. C/                      Subroutine ERROR is called when an e    /
  328. C/                      error is detected in any GASP subroutine/
  329. C/                      except PRNTQ,SUMRY, and MONTR, all of   /
  330. C/                      which print their own message.          /
  331. C/                                                              /
  332. C////////////////////////////////////////////////////////////////
  333. C
  334.     DIMENSION    NSET(1),QSET(1)
  335. C
  336.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  337.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  338.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  339. C
  340.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  341.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  342.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  343.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  344. C
  345. C
  346.     WRITE(NPRNT,100) J,TNOW
  347.   100    FORMAT(//26X,'Error exit, Type',I3,' Error.'//,26X,
  348.      $  ' File status at time',F10.4/)
  349.     WRITE(NPRNT,200)
  350.   200    FORMAT(20X,'NSET'/)
  351.       DO  210 I=1,ID
  352.     IL = (I-1) * MXX + 1
  353.     IV = IL + MXX - 1
  354.      WRITE(NPRNT,90) I,(NSET(IJ),IJ=IL,IV)
  355.    90    FORMAT(3X,I5,5X,12I8)
  356.   210 CONTINUE
  357.     WRITE(NPRNT,202)
  358.   202    FORMAT(//20X,'QSET'/)
  359.       DO 215 I=1,ID
  360.     IL = (I-1) * IMM + 1
  361.     IV = IL + IMM - 1
  362.         WRITE(NPRNT,95) I,(QSET(IJ),IJ=IL,IV)
  363.    95    FORMAT(3X,I5,4X,8(E12.6,2X))
  364.   215 CONTINUE
  365.     WRITE(NPRNT,99)
  366.    99    FORMAT(1H0)
  367.     IF (NCLCT) 7,7,8
  368.     8    WRITE(NPRNT,98)
  369.    98    FORMAT(/1H ,'Array SUMA',/)
  370.       DO  110  I=1,NCLCT
  371.     WRITE(NPRNT,80) I,(SUMA(I,K),K=1,5)
  372.    80      FORMAT(I10,5F10.4)
  373.   110 CONTINUE
  374.     WRITE(NPRNT,99)
  375.     7    IF (NSTAT) 9,9,10
  376.    10    WRITE(NPRNT,97)
  377.    97    FORMAT(/1H ,'Array SSUMA'/)
  378.       DO 111  I=1,NSTAT
  379.     WRITE(NPRNT,80) I,(SSUMA(I,K),K=1,5)
  380.   111 CONTINUE
  381.     WRITE(NPRNT,99)
  382.     9    IF (NHIST) 11,11,12
  383.   12    WRITE(NPRNT,96)
  384.   96    FORMAT(/1H ,'Array JCELS' /)
  385.     DO 112 I=1,NHIST
  386.     NCL = NCELS(I) + 2
  387.   112    WRITE(NPRNT,26) I,(JCELS(I,K),K=1,NCL)
  388.    26    FORMAT(7X,I3,5X,23I4)
  389.    11    NFOOL = 0
  390.     IF (NFOOL) 3,4,3
  391.     3    RETURN
  392.     4    CALL    EXIT
  393.     END
  394. C
  395.         SUBROUTINE      FILEM(JQ,NSET,QSET)
  396. C////////////////////////////////////////////////////////////////
  397. C/                                                              /
  398. C/      Program-id.     FILEMX                                  /
  399. C/      Date-written.    4th,Feb,1984                           /
  400. C/      File-name.      FILEMX.FOR                              /
  401. C/      Remarks.        Subroutine FILEMX.FOR page 306.         /
  402. C/                      FILEMX is called to file an entry in    /
  403. C/                      file JQ of the array NSET,QSET.         /
  404. C/                                                              /
  405. C////////////////////////////////////////////////////////////////
  406. C
  407.     DIMENSION    NSET(1),QSET(1)
  408. C
  409.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  410.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  411.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  412. C
  413.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  414.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  415.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  416.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  417. C
  418. C
  419. C       --- Test to see if there is an avilable column for storage.
  420. C
  421.         IF (MFA - ID) 2,2,3
  422.     3   WRITE(NPRNT,4)
  423.     4     FORMAT(//24H Overlap Set Given Below/)
  424.         CALL    ERROR(87,NSET,QSET)
  425. C
  426. C       --- Put attribute value in file
  427. C
  428.     2   INDX = (MFA - 1) * IMM
  429.       DO  1 I=1,IMM
  430.     INDX = INDX + 1
  431.     QSET(INDX) = ATRIB(I)
  432.     1 CONTINUE
  433.     INDX = (MFA - 1) * MXX
  434.       DO 10 I=1,IM
  435.     INDX = INDX + 1
  436.         NSET(INDX) = JTRIB(I)
  437.    10 CONTINUE
  438.     CALL    SET(JQ,NSET,QSET)
  439.     RETURN
  440.     END
  441. C
  442.         SUBROUTINE      HISTO(X1,A,W,N)
  443. C////////////////////////////////////////////////////////////////
  444. C/                                                              /
  445. C/      Program-id.     HISTOX                                  /
  446. C/    Date-written.    4th,Feb,1984                /
  447. C/      File-name.      HISTO.FOR                               /
  448. C/      Remarks.        Subroutine HISTOX.FOR page 79.          /
  449. C/                      HISTO tabulates the number of times X1  /
  450. C/                      is within the specified cell limits.    /
  451. C/                                                              /
  452. C////////////////////////////////////////////////////////////////
  453. C
  454.     DIMENSION    NSET(1),QSET(1)
  455. C
  456.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  457.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  458.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  459. C
  460.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  461.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  462.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  463.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  464. C
  465. C
  466.         IF (N- NHIST) 11,11,2
  467.     2   WRITE(NPRNT,250) N
  468.   250     FORMAT(' Error in histogram',I4,//)
  469.         CALL    EXIT
  470.    11   IF (N) 2,2,3
  471. C
  472. C       --- Translate X1 by subtracing A if X.LE.A
  473. C
  474.     3   X = X1 - A
  475.         IF (X) 6,7,7
  476.     6   IC = 1
  477.                         GO TO 8
  478. C
  479. C       --- Determine cell number IC.
  480. C
  481.     7   IC = X / W + 2.0
  482.         IF (IC - NCELS(N) - 1) 8,8,9
  483.     9   IC = NCELS(N) + 2
  484.     8   JCELS(N,IC) = JCELS(N,IC) + 1
  485.         RETURN
  486.         END
  487. C
  488.         SUBROUTINE      MONTR(NSET,QSET)
  489. C////////////////////////////////////////////////////////////////
  490. C/                                                              /
  491. C/      Program-id.     MONTRX                                  /
  492. C/    Date-written.    4th,Feb,1984                /
  493. C/      File-name.      MONTRX.FOR                              /
  494. C/      Remarks.        Subroutine MONTRX.FOR page 309.         /
  495. C/                      The monitoring of events as they        /
  496. C/                      occur.                                  /
  497. C/                                                              /
  498. C////////////////////////////////////////////////////////////////
  499. C
  500.     DIMENSION    NSET(1),QSET(1)
  501. C
  502.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  503.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  504.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  505. C
  506.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  507.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  508.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  509.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  510. C
  511. C
  512. C       --- IF JEVNT .GE. 101   Print NSET,QSET
  513. C
  514.         IF (JEVNT - 101) 9,7,9
  515. 7       WRITE(NPRNT,100) TNOW
  516. 100    FORMAT(1H0,10X,'** GASP IIex JOB Storage area dump at',F10.4,
  517.      $  2X,'Time units**'//)
  518.     WRITE(NPRNT,200)
  519. 200    FORMAT(20X,'NSET'/)
  520.     DO 210 I=1,ID
  521.     IL = (I-1) * MXX + 1
  522.     IV = IL + MXX - 1
  523. 210    WRITE(NPRNT,90) I,(NSET(IJ),IJ=IL,IV)
  524. 90    FORMAT(3X,I5,5X,12I8)
  525.     WRITE(NPRNT,202)
  526. 202    FORMAT(//20X,'QSET' /)
  527.     DO 215 I=1,ID
  528.     IL = (I-1) * IMM + 1
  529.     IV = IL + IMM - 1
  530. 215    WRITE(NPRNT,95) I,(QSET(IJ),IJ=IL,IV)
  531. 95    FORMAT(3X,I5,4X,8(E12.6,2X))
  532.     RETURN
  533. 9    IF(MFE(1)) 3,6,1
  534. C
  535. C    --- IF JMNIT = 1,Print TNOW,Current event code, and all
  536. C        attributes of the next event.
  537. C
  538. 1    IF(JMNIT - 1) 5,4,3
  539. 3    WRITE(NPRNT,199)
  540. 199    FORMAT(///26X,' Error Exit,Type 99 Error. ')
  541.     CALL    EXIT
  542. 4    INDX = MFE(1)
  543.     IL = (INDX-1) * MXX + 1
  544.     IV = IL + MXX - 1
  545.     WRITE(NPRNT,103) TNOW,JTRIB(1),(NSET(I),I=IL,IV)
  546. 103    FORMAT(/10X,'Next Event(NSET).... ',(6I8))
  547.     IL = (INDX - 1) * IMM + 1
  548.     IV = IL + IMM - 1
  549.     WRITE(NPRNT,120) (QSET(I) ,I=IL,IV)
  550. 120    FORMAT(/10X,'Next Event(QSET).... ',(6E12.4))
  551. 5    RETURN
  552. 6    WRITE(NPRNT,104) TNOW
  553. 104    FORMAT(10X,' File is Empty at ',F10.2)
  554.                     GO TO 5
  555.     END
  556. C
  557.         SUBROUTINE      PRNTQ(JQ,NSET,QSET)
  558. C////////////////////////////////////////////////////////////////
  559. C/                                                              /
  560. C/      Program-id.     PRNTQX                                  /
  561. C/    Date-written.    4th,Feb,1984                /
  562. C/      File-name.      PRNTQX.FOR                              /
  563. C/      Remarks.        Subroutine PRNTQX.FOR page 310.         /
  564. C/                      PRNTQX computes and prints the time-    /
  565. C/                      integrated average and standard of the  /
  566. C/                      number of entries in particular file    /
  567. C/                      file and the maximum number of entries  /
  568. C/                      that  were in the file since the file   /
  569. C/                      was last initialized.                   /
  570. C/                                                              /
  571. C////////////////////////////////////////////////////////////////
  572. C
  573.     DIMENSION    NSET(1),QSET(1)
  574. C
  575.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  576.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  577.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  578. C
  579.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  580.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  581.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  582.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  583. C
  584. C
  585.         WRITE(NPRNT,100) JQ
  586.         IF (TNOW - TBEG) 12,12,13
  587.    12   WRITE(NPRNT,105)
  588.   105     FORMAT(/25X,'No Printout TNOW = TBEG '//)
  589.                         GO TO 2
  590. C
  591. C       --- Compute expect no.
  592. C
  593.    13   XNQ = NQ(JQ)
  594.         X = (ENQ(JQ) + XNQ * (TNOW - QTIME(JQ)))/(TNOW - TBEG)
  595.     STD = (VNQ(JQ)+XNQ*XNQ*(TNOW-QTIME(JQ)))/(TNOW-TBEG)-X*X
  596.     IF (STD.GT.0.0) GO TO 130
  597.     STD = 0.0
  598.                     GO TO 140
  599. 130    STD = STD ** 0.5
  600. 140    WRITE(NPRNT,104) X,STD,MAXNQ(JQ)
  601.     WRITE(NPRNT,101)
  602. C
  603. C       --- Print file in proper order requires tracing through the
  604. C           pointers of the file
  605. C
  606.     NSQ = 1
  607.     WRITE(NPRNT,200)
  608. 200    FORMAT(20X,'NSET'/)
  609. 230    LINE = MFE(JQ)
  610.         IF (LINE - 1) 4,1,1
  611. 4       WRITE(NPRNT,102)
  612. 2       RETURN
  613. 1    L1 = LINE - 1
  614.     GO TO (202,201),NSQ
  615. 202    INDX = L1 * MXX
  616.     IB = INDX + 1
  617.     IE = INDX + MXX
  618.     WRITE(NPRNT,106) LINE,(NSET(I),I=IB,IE)
  619.                     GO TO 210
  620. 201    INDX = L1 * IMM
  621.     IB = INDX + 1
  622.     IE = INDX + IMM
  623.     WRITE(NPRNT,103) LINE,(QSET(I),I=IB,IE)
  624. 210    INDX = LINE * MXX - 1
  625.     LINE = NSET(INDX)
  626.     IF (LINE - 7777) 1,2220,5
  627. 2220    IF (NSQ - 2) 221,2,2
  628. 221    NSQ = NSQ + 1
  629.     WRITE(NPRNT,205)
  630. 205    FORMAT(//20X,'QSET'/)
  631.                     GO TO 230
  632.     5    WRITE(NPRNT,199)
  633. 199    FORMAT(///26X,'Error Exit, Type 94 Error.')
  634. 100    FORMAT(//29X,' File Printout, File  No.',I3)
  635. 101    FORMAT(/35X,' File Contents' //)
  636. 102    FORMAT(/33X,'The File  is Empty'//)
  637. 103    FORMAT(3X,I5,4X,8(E12.6,2X))
  638. 104     FORMAT(/25X,'Average Number in file  was',F10.4,/25X,
  639.      $  'STD. DEV.',18X,F10.4,/25X,'Maximum',24X,I4)
  640. 106    FORMAT(3X,I5,5X,12I8)
  641.         CALL    EXIT
  642.         END
  643. C
  644.         SUBROUTINE      RANDU(IY,YFL)
  645. C////////////////////////////////////////////////////////////////
  646. C/                                                              /
  647. C/      Program-id.     RANDU                                   /
  648. C/      Date-written.   Jan. 16th 1984                          /
  649. C/      File-name.      RANDU.FOR                               /
  650. C/      Remarks.        Subroutine RANDU.FOR page 96.           /
  651. C/                      RANDU is a modefied IBM 1130 subroutine /
  652. C/                                                              /
  653. C////////////////////////////////////////////////////////////////
  654. C
  655.         IY = IY * 899
  656.         IF (IY) 5,6,6
  657. 5       IY = IY + 32767 + 1
  658. 6       YFL = IY
  659.         YFL = YFL / 32767.0
  660.         RETURN
  661.         END
  662. C
  663.         SUBROUTINE      RMOVE(KCOLL,JQ,NSET,QSET)
  664. C////////////////////////////////////////////////////////////////
  665. C/                                                              /
  666. C/      Program-id.     RMOVEX                                  /
  667. C/    Date-written.    Feb. 4th 1984                /
  668. C/      File-name.      RMOVEX.FOR                              /
  669. C/      Remarks.        Subroutine RMOVEX.FOR page 312.         /
  670. C/                      Subroutine RMOVEX is called to remove   /
  671. C/                      an entry from file JQ of the array      /
  672. C/                      NSET,QSET.                              /
  673. C/                                                              /
  674. C////////////////////////////////////////////////////////////////
  675. C
  676.     DIMENSION    NSET(1),QSET(1)
  677. C
  678.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  679.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  680.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  681. C
  682.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  683.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  684.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  685.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  686. C
  687. C
  688. C    --- The dummy array KCOLL is used as an argument to force
  689. C        the call by name option on computer such as the IBM 360
  690. C
  691.     KCOL = KCOLL(1)
  692.         IF (KCOL) 16,16,2
  693. 16      CALL    ERROR(97,NSET,QSET)
  694. 2       MLC(JQ) = KCOL
  695. C
  696. C       --- Put values of KCOL in attrib
  697. C
  698.     INDX = (KCOL - 1) * IMM
  699.     DO 3 I=1,IMM
  700.     INDX = INDX + 1
  701. 3    ATRIB(I) = QSET(INDX)
  702.     INDX = (KCOL - 1) * MXX
  703.     DO 10 I=1,IM
  704.     INDX = INDX + 1
  705. 10    JTRIB(I) = NSET(INDX)
  706. C
  707. C    --- Set OUT=1 and call SET to remove entry from NSET
  708. C
  709.     OUT = 1.0
  710.     CALL    SET(JQ,NSET,QSET)
  711.     RETURN
  712.     END
  713. C
  714.         SUBROUTINE      SET(JQ,NSET,QSET)
  715. C////////////////////////////////////////////////////////////////
  716. C/                                                              /
  717. C/      Program-id.     SETX                                    /
  718. C/    Date-written.    Feb. 4th 1984                /
  719. C/      File-name.      SETX  .FOR ver2.0                       /
  720. C/      Remarks.        Subroutine SETX.FOR page 313.           /
  721. C/                      Subroutine SETX is the heart of the     /
  722. C/                      information storage and retrieval       /
  723. C/                      system. SETX performs three functions:  /
  724. C/            1. Initialize the filing array NSET,    /
  725. C/                      2. Updates the pointer system.          /
  726. C/                      3. Maintain statistics on the number    /
  727. C/                         of entries in each file.             /
  728. C/                                                              /
  729. C////////////////////////////////////////////////////////////////
  730. C
  731.     DIMENSION    NSET(1),QSET(1)
  732. C
  733.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  734.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  735.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  736. C
  737.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  738.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  739.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  740.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  741. C
  742. C
  743. C       --- INIT should be one for initialization of file
  744. C
  745.         IF (INIT - 1) 27,28,27
  746. C
  747. C       --- Initialize file to zero. Set up pointers
  748. C           must initialize KRANK(JQ)
  749. C           must initialize INN(JQ)
  750. C
  751.    28    KOL = 7777
  752.     KOF = 8888
  753.     KLE = 9999
  754.     MX = IM + 1
  755.     MXX = IM + 2
  756.     MAXQS = ID * IMM
  757.     MAXNS = ID * MXX
  758. C
  759. C    --- Inirtialize pointing cells of NSET and zero other cells
  760. C        of NSET
  761. C
  762.     DO 2 J=1,MAXQS
  763.     2    QSET(J) = 0.0
  764.     DO 4 J=1,MAXNS
  765.     4    NSET(J) = 0
  766.     DO 1 I=1,ID
  767.     INDX = I * MXX
  768.     NSET(INDX - 1) = I + 1
  769.     1    NSET(INDX) = I - 1
  770.     NSET(MAXNS - 1) = KOF
  771.     DO 3 K=1,NOQ
  772.     NQ(K) = 0
  773.     MLC(K) = 0
  774.     MFE(K) = 0
  775.     MAXNQ(K) = 0
  776.     MLE(K) = 0
  777.     ENQ(K) = 0.0
  778.     VNQ(K) = 0.0
  779.     3    QTIME(K) = TNOW
  780. C
  781. C    --- First available column = 1
  782. C
  783.     MFA = 1
  784.     INIT = 0
  785.     OUT = 0.0
  786.     RETURN
  787. C
  788. C       --- MFEX is first entry in file which has not been compared 
  789. C           with ITEM to be inserted.
  790. C
  791.    27    MFEX = MFE(JQ)
  792. C
  793. C       --- KNT is a check code to indicate that no comparisons have
  794. C           been made.
  795. C
  796.         KNT = 2
  797. C
  798. C       --- KS is the row on which items of file JQ are ranked.
  799. C
  800.         KS = KRANK(JQ)
  801.     KSJ = 1
  802.     IF (KS - 100) 1020,100,1000
  803.  1000    KSJ = 2
  804.     KS = KS - 100
  805. C
  806. C       --- Test for putting value in or out
  807. C           if out equals one an item is to be removed from file JQ
  808. C           If OUT is less than ONE an item is to be inserted in
  809. C           file JQ
  810. C
  811.  1020    IF (OUT - 1.0) 8,5,100
  812. C
  813. C       --- Putting an entry in file JQ
  814. C
  815.    8    INDX = MFA * MXX - 1
  816.     NXFA = NSET(INDX)
  817. C
  818. C       --- If INN(JQ) equals two the file is a HVF file. If INN(JQ)
  819. C           is one the file is a LVF file. For LVF files try to insert
  820. C           Stating at end of file. MLEX is last entry in file which
  821. C           has not been compared with items to be inserted.
  822. C
  823.         IF (INN(JQ) - 1) 100,7,6
  824.     7   MLEX = MLE(JQ)
  825. C
  826. C       --- If MLEX is zero file is empty. item to be inserted will be
  827. C           only item in file.
  828. C
  829.         IF (MLEX) 100,10,11
  830.    10    INDX = MFA * MXX
  831.     NSET(INDX) = KLE
  832.         MFE(JQ) = MFA
  833. C
  834. C       --- There is no successor of item inserted. Since item was 
  835. C           inserted in column MFA the last entry of file JQ is in
  836. C           column MFA.
  837. C
  838.    17    INDX = MFA * MXX - 1
  839.     NSET(INDX) = KOL
  840.         MLE(JQ) = MFA
  841. C
  842. C       --- Set new MFA equal to successor of old MFA. that is NXFA
  843. C
  844.    14   MFA = NXFA
  845.         IF (MFA - KOF) 237,238,238
  846.   237    INDX = NXFA * MXX
  847.     NSET(INDX) = KLE
  848. C
  849. C       ---Update statistics of file JQ
  850. C
  851.   238   XNQ = NQ(JQ)
  852.         ENQ(JQ) = ENQ(JQ) + XNQ * (TNOW - QTIME(JQ))
  853.         VNQ(JQ) = VNQ(JQ) + XNQ * XNQ * (TNOW - QTIME(JQ))
  854.         QTIME(JQ) = TNOW
  855.         NQ(JQ) = NQ(JQ) + 1
  856.         MAXNQ(JQ) = MAX0(MAXNQ(JQ),NQ(JQ))
  857.         MLC(JQ) = MFE(JQ)
  858.         RETURN
  859. C
  860. C       --- Test ranking value of new item against value of item
  861. C           in column
  862. C
  863.    11    GO TO (1100,1120),KSJ
  864.  1100    INDX1 = (MFA - 1) * IMM + KS
  865.     INDX2 = (MLEX - 1) * IMM + KS
  866.     IF (QSET(INDX1) - QSET(INDX2)) 12,13,13
  867.  1120    INDX1 = (MFA - 1) * MXX + KS
  868.     INDX2 = (MLEX - 1) * MXX + KS
  869. C
  870. C    --- Test ranking value of new item against value of
  871. C        item in column MLEX
  872. C
  873.     IF(NSET(INDX1) - NSET(INDX2)) 12,13,13
  874. C
  875. C       --- Insert item after column MLEX.
  876. C
  877.    13    INDX = MLEX * MXX - 1
  878.     MSU = NSET(INDX)
  879.     NSET(INDX) = MFA
  880.     INDX = MFA * MXX
  881.     NSET(INDX) = MLEX
  882.     GO TO (18,17),KNT
  883. C
  884. C       --- Since KNT equals one a comparison was made and there
  885. C           is A.
  886. C
  887.    18    INDX = MFA * MXX - 1
  888.     NSET(INDX) = MSU
  889.     INDX = MSU * MXX
  890.     NSET(INDX) = MFA
  891.                     GO TO 14
  892. C
  893. C       --- Set KNT to one since a comparison was made.
  894. C
  895.    12   KNT = 1
  896. C
  897. C       --- Test MFA against predecessor of MLEX by letting
  898. C           MLEX equal predecessor of MLEX.
  899. C
  900.     INDX = MLEX * MXX
  901.     MLEX = NSET(INDX)
  902.         IF (MLEX-KLE) 11,16,11
  903. C
  904. C       --- If MLEX had no predecessor MFA is first in file
  905. C
  906.    16    INDX = MFA * MXX
  907.     NSET(INDX) = KLE
  908.         MFE(JQ) = MFA
  909. C
  910. C
  911. C
  912.    26    INDX = MFA * MXX - 1
  913.     NSET(INDX) = MFEX
  914.     INDX = MFEX * MXX
  915.     NSET(INDX) = MFA
  916.         GO TO 14
  917. C
  918. C       --- FOR HVF OPERATION TRY TO INSERT ITEM STARTING AT BEGINNING
  919. C           OF FILE JQ.
  920. C
  921.     6   IF (MFEX) 100,10,19
  922. C
  923. C       --- Test ranking value of new item against value of
  924. C           item in column MFEX.
  925. C   
  926.    19    GO TO (1200,1220),KSJ
  927.  1200    INDX1 = (MFA - 1) * IMM + KS
  928.     INDX2 = (MFEX - 1) * IMM + KS
  929.     IF (QSET(INDX1) - QSET(INDX2)) 20,21,21
  930.  1220    INDX1 = (MFA - 1) * MXX + KS
  931.     INDX2 = (MFEX - 1) * MXX + KS
  932.     IF (NSET(INDX1) - NSET(INDX2)) 20,21,21
  933. C
  934. C       --- If new value if lower. MFA must be compared against 
  935. C           successor of MFEX.
  936. C
  937.    20   KNT = 1
  938. C
  939. C       --- Let MPRE = MFEX and let MFEX be the successor of MFEX.
  940. C
  941.         MPRE = MFEX
  942.     INDX = MFEX * MXX - 1
  943.     MFEX = NSET(INDX)
  944.         IF (MFEX-KOL) 19,24,19
  945. C
  946. C       --- If new value is higher, it should be inserted between
  947. C           MFEX and ITS.
  948. C
  949.    21      GO TO (22,16),KNT
  950.    22      KNT = 2
  951. C
  952. C       --- MFA is to be inserted after MPRE. Make MPRE the prdece
  953. C           ssor of MFA and MFA the successor of MPRE.
  954. C
  955.    24    INDX = MFA * MXX
  956.     NSET(INDX) = MPRE
  957.     INDX = MPRE * MXX - 1
  958.     NSET(INDX) = MFA
  959. C
  960. C       --- If KNT was not reset to 2, thre is no successor of MFA
  961. C           pointers are updated at statement 17.
  962. C
  963.         GO TO (17,26), KNT
  964. C
  965. C       --- Removal of an item from file JQ.
  966. C
  967.     5   OUT = 0.0
  968. C
  969. C       --- Update pointing system to account for removal of MLC(JQ)
  970. C
  971.     INDX = (MLC(JQ) - 1) * IMM
  972.     DO 32 I=1,IMM
  973.     INDX = INDX + 1
  974.    32    QSET(INDX) = 0.0
  975.     INDX = (MLC(JQ) - 1) * MXX
  976.     DO 1300    I=1,IM
  977.     INDX = INDX + 1
  978.  1300    NSET(INDX) = 0
  979.     INDX = MLC(JQ) * MXX
  980.     JL = NSET(INDX - 1)
  981.     JK = NSET(INDX)
  982.     IF (JL - KOL) 33,34,33
  983.    33    IF (JK - KLE) 35,36,35
  984.    35    INDX = JK * MXX - 1
  985.     NSET(INDX) = JL
  986.     INDX = JL * MXX
  987.     NSET(INDX) = JK
  988. C
  989. C    --- Update pointers
  990. C
  991.    37    INDX = MLC(JQ) * MXX - 1
  992.     NSET(INDX) = MFA
  993.     NSET(INDX +1) = KLE
  994.     IF (MFA - KOF) 234,235,235
  995.   234    INDX = MFA * MXX
  996.     NSET(INDX) =MLC(JQ)
  997.   235    MFA = MLC(JQ)
  998.     MLC(JQ) = MFE(JQ)
  999. C
  1000. C       --- Update file statistaics
  1001. C
  1002.         XNQ = NQ(JQ)
  1003.         ENQ(JQ) = ENQ(JQ) + XNQ * (TNOW - QTIME(JQ))
  1004.         VNQ(JQ) = VNQ(JQ) + XNQ * XNQ * (TNOW - QTIME(JQ))
  1005.         QTIME(JQ) = TNOW
  1006.         NQ(JQ) = NQ(JQ) - 1
  1007.         RETURN
  1008. C
  1009. C       --- MLC was first entry but not last entry. update pointers.
  1010. C
  1011.    36    INDX = JL * MXX
  1012.     NSET(INDX) = KLE
  1013.     MFE(JQ) = JL
  1014.                     GO TO 37
  1015.    34      IF (JK - KLE) 38,39,38
  1016. C
  1017. C       --- MLC was last entry but not first entry. Update pointers.
  1018. C
  1019.    38    INDX = JK * MXX - 1
  1020.     NSET(INDX) = KOL
  1021.     MLE(JQ) = JK
  1022.     GO TO 37
  1023. C
  1024. C       --- MLC was both the last and first entry, therefore, it is
  1025. C           the only entry.
  1026. C
  1027.    39   MFE(JQ) = 0
  1028.         MLE(JQ) = 0
  1029.                         GO TO 37
  1030.   100    CALL    ERROR(88,NSET,QSET)
  1031.     RETURN
  1032.         END
  1033. C
  1034.         SUBROUTINE      SUMRY(NSET,QSET)
  1035. C////////////////////////////////////////////////////////////////
  1036. C/                                                              /
  1037. C/      Program-id.     SUMRYX                                  /
  1038. C/    Date-written.    Feb. 4th 1984                /
  1039. C/      File-name.      SUMRY.FOR                               /
  1040. C/      Remarks.        Subroutine SUMRYX.FOR page 318.         /
  1041. C/            Subroutine SUMRYX is the basic output     /
  1042. C/            routine of GASP II. It processes the    /
  1043. C/            the data collected in subroutine COLCT    /
  1044. C/            TMST, and HISTO and prints out a data    /
  1045. C/            summary.                /
  1046. C/                                /
  1047. C////////////////////////////////////////////////////////////////
  1048. C
  1049.     DIMENSION    NSET(1),QSET(1)
  1050. C
  1051.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  1052.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  1053.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  1054. C
  1055.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  1056.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  1057.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  1058.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  1059. C
  1060. C
  1061.     WRITE(NPRNT,21)
  1062.    21    FORMAT(1H1,29X,'** GASPex Summary Report ** '/)
  1063.     WRITE(NPRNT,102) NPROJ,NAME,MON,NDAY,NYR,NRUN
  1064.   102    FORMAT(20X,'Simulation Project No.',I4,2X,'on',2X,
  1065.      1  6A2//,20X,'Date',I3,'/',I3,'/',I5,12X,'Run number',I5/)
  1066.     IF(NPRMS) 147,147,146
  1067.   146 DO  64  I=1,NPRMS
  1068.         WRITE(NPRNT,107) I,(PARAM(I,J),J=1,4)
  1069.   107      FORMAT(10X,' Parameter No.',I5,4F12.4)
  1070.    64 CONTINUE
  1071. 147    IF(NCLCT) 5,60,66
  1072.     5    WRITE(NPRNT,199)
  1073.   199      FORMAT(///26X,'Error Exit, Type 98 Error.')
  1074.     CALL    EXIT
  1075.    66    WRITE(NPRNT,23)
  1076.    23    FORMAT(//34X,'** Generated Data ** ',/17X,'Code',4X,
  1077.      1    'Mean',6X,'STD.DEV.',5X,'Min.',7X,'Max.',5X,'OBS.'/)
  1078. C
  1079. C    --- Compute and print statistics gathered by CLCT
  1080. C
  1081.       DO 2 I=1,NCLCT
  1082.     IF(SUMA(I,3)) 5,62,61
  1083.    62    WRITE(NPRNT,63) I
  1084.    63    FORMAT(17X,I3,10X,'No Values Recorded ')
  1085.                     GO TO 2
  1086.    61    XS = SUMA(I,1)
  1087.     XSS = SUMA(I,2)
  1088.     XN = SUMA(I,3)
  1089.     AVG = XS / XN
  1090.     STD = (((XN * XSS) - (XS * XS))/(XN * (XN - 1.0)))**0.5
  1091.     N = XN
  1092.     WRITE(NPRNT,24) I,AVG,STD,SUMA(I,4),SUMA(I,5),N
  1093.    24    FORMAT(17X,I3,4F11.4,I7)
  1094.     2 CONTINUE
  1095.    60    IF(NSTAT) 5,67,4
  1096.     4    WRITE(NPRNT,29)
  1097.    29      FORMAT(/34X,'** Time Generated Data **'/,17X,'Code',4X,
  1098.      1    'Mean',6X,'STD.DEV.',5X,'Min.',7X,'Max.',3X,'Total Time '/)
  1099. C
  1100. C    --- Compute and print statistics gathered by TMST
  1101. C
  1102.       DO 6 I=1,NSTAT
  1103.     IF(SSUMA(I,1)) 5,71,72
  1104.    71    WRITE(NPRNT,63) I
  1105.                     GO TO 6
  1106.    72    XT = SSUMA(I,1)
  1107.     XS = SSUMA(I,2)
  1108.     XSS = SSUMA(I,3)
  1109.     AVG = XS / XT
  1110.     STD = (XSS/XT - AVG*AVG) ** 0.5
  1111.     WRITE(NPRNT,30) I,AVG,STD,SSUMA(I,4),SSUMA(I,5),XT
  1112.    30    FORMAT(17X,I3,5F11.4)
  1113.     6 CONTINUE
  1114.    67    IF(NHIST) 5,75,9
  1115.     9    WRITE(NPRNT,25)
  1116.    25      FORMAT(/27X,'** Generated Frequency Distributions **',/
  1117.      1         17X,'Code',20X,'Histograms')
  1118. C
  1119. C    --- Print histograms
  1120. C
  1121.       DO  12  I=1,NHIST
  1122.     NCL = NCELS(I) + 2
  1123.         WRITE(NPRNT,26) I,(JCELS(I,J),J=1,NCL)
  1124.    26      FORMAT(/17X,I3,5X,11I4,/(25X,11I4))
  1125.    12 CONTINUE
  1126. C
  1127. C    --- Print files and file statistics
  1128. C
  1129.    75 DO  15  I=1,NOQ
  1130.     CALL    PRNTQ(I,NSET,QSET)
  1131.    15 CONTINUE
  1132.     RETURN
  1133.     END
  1134. C
  1135.         SUBROUTINE      TMST(X,T,N,NSET,QSET)
  1136. C////////////////////////////////////////////////////////////////
  1137. C/                                                              /
  1138. C/      Program-id.     TMSTX                                   /
  1139. C/    Date-written.    4th,Feb,1984                /
  1140. C/      File-name.      TMST.FOR                                /
  1141. C/      Remarks.        Subroutine TMSTX.FOR page 76.           /
  1142. C/                      This subroutine collects sample data    /
  1143. C/                      on observations of a variable made over /
  1144. C/                      a period of time.                       /
  1145. C/                                                              /
  1146. C////////////////////////////////////////////////////////////////
  1147. C
  1148.     DIMENSION    NSET(1),QSET(1)
  1149. C
  1150.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  1151.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  1152.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  1153. C
  1154.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  1155.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  1156.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  1157.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  1158. C
  1159. C
  1160.         IF (N .GT. 0) GO TO 20
  1161.    10   CALL    ERROR(91,NSET,QSET)
  1162.    20   IF (N .GT. NSTAT) GO TO 10
  1163.         TT = T - SSUMA(N,1)
  1164.         SSUMA(N,1) = SSUMA(N,1) + TT
  1165.         SSUMA(N,2) = SSUMA(N,2) + X*TT
  1166.         SSUMA(N,3) = SSUMA(N,3) + X*X*TT
  1167.         SSUMA(N,4) = AMIN1(SSUMA(N,4),X)
  1168.         SSUMA(N,5) = AMAX1(SSUMA(N,5),X)
  1169.         RETURN
  1170.         END
  1171. C
  1172.     SUBROUTINE    FINDN(NVAL,MCODE,JQ,JATT,KCOL,NSET,QSET)
  1173. C////////////////////////////////////////////////////////////////
  1174. C/                                /
  1175. C/    Program-id.    FINDN.FOR                /
  1176. C/    Date-written.    5th,Feb,1984                /
  1177. C/    Remarks.    GASP IIex Library subroutine from    /
  1178. C/            page 304                /
  1179. C/                                /
  1180. C////////////////////////////////////////////////////////////////
  1181. C
  1182.     DIMENSION    NSET(1),QSET(1)
  1183. C
  1184.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  1185.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  1186.      2           TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  1187. C
  1188.       COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  1189.      1           MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),
  1190.      2          PARAM(20,4),QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),
  1191.      3         NPROJ,MON,NDAY,NYR,JCLR,JTRIB(12)
  1192. C
  1193. C
  1194. C    --- The column to be considered as a candidate is NEXTK
  1195. C
  1196.     KBEST = 0
  1197.     NEXTK = MFE(JQ)
  1198.     IF (NEXTK) 16,1,2
  1199. 16    CALL    ERROR(89,NSET,QSET)
  1200. 1    KCOL  = KBEST
  1201.     RETURN
  1202. C
  1203. C    --- MGRNV is +1 for greater than search and -1 for less than 
  1204. C        search NMAMN is +1 for maximum and -1 for minimum
  1205. C
  1206. 2    GO TO (11,12,13,14,11),MCODE
  1207. 11    MGRNV = 1
  1208.     NMAMN = 1
  1209.     GO TO 20
  1210. 12    MGRNV = 1
  1211.     NMAMN = -1
  1212.     GO TO 20
  1213. 13    MGRNV = -1
  1214.     NMAMN = 1
  1215.     GO TO 20
  1216. 14    MGRNV = -1
  1217.     NMAMN = -1
  1218. 20    INDX = (NEXTK - 1) * MXX + JATT
  1219.     IF (MGRNV * (NSET(INDX) - NVAL)) 4,21,66
  1220. C
  1221. C    --- When equality is obtatined test for MCODE=5, the search for
  1222. C        a specified value
  1223. C
  1224. 21    IF (MCODE - 5) 4,15,4
  1225. 66    IF (MCODE - 5) 6,4,6
  1226. 6    IF(KBEST) 16,8,7
  1227. 7    IF(NMAMN*(NSET(INDX)-NSET(KINDX))) 4,4,8
  1228. 8    KBEST = NEXTK
  1229.     KINDX = INDX
  1230. 4    INDS = (NEXTK)*MXX - 1
  1231.     NEXTK = NSET(INDS)
  1232.     IF (NEXTK - 7777) 20,1,1
  1233. 15    KCOL=NEXTK
  1234.     RETURN
  1235.     END
  1236. C
  1237.     FUNCTION    UNFRM(A,B)
  1238. C////////////////////////////////////////////////////////////////
  1239. C/                                /
  1240. C/    Program-id.    Function UNFRM                /
  1241. C/    Date-written.    5th,Feb,1984                /
  1242. C/    Remarks.    The function RNORM generates a deviate    /
  1243. C/            from a normal distribution .        /
  1244. C/            From page 97                /
  1245. C/                                /
  1246. C////////////////////////////////////////////////////////////////
  1247. C
  1248.         COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  1249.      $  NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,ISEED,TNOW,
  1250.      $  TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4),IMM,MAXQS,MAXNS
  1251.     COMMON /C2/ATRIB(10),ENQ(4),INN(4),JCELS(5,22),KRANK(4),
  1252.      $  MAXNQ(4),MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4),
  1253.      $  QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON,NDAY,NYR,
  1254.      $  JCLR,JTRIB(12)
  1255. C
  1256.     CALL    DRAND (ISEED,RNUM)
  1257.     UNFRM = A + (B-A) * RNUM
  1258.     RETURN
  1259.     END
  1260.