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