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