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