SUBROUTINE COLCT(X,N,NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. COLCT / C/ Date-written. Jan. 16th 1984 / C/ File-name. COLCT.FOR / C/ Remarks. Subroutine COLCT.FOR page 74. / C/ This subroutine collects sample data on / C/ the value of a variable. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C C IF (N.GT.0) GOTO 20 10 CALL ERROR(90,NSET) 20 IF (N.GT.NCLCT) GOTO 10 SUMA(N,1) = SUMA(N,1) + X SUMA(N,2) = SUMA(N,2) + X*X SUMA(N,3) = SUMA(N,3) + 1.0 SUMA(N,4) = AMIN1(SUMA(N,4),X) SUMA(N,5) = AMAX1(SUMA(N,5),X) RETURN END C SUBROUTINE DATAN(NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. DATAN / C/ Date-written. Jan. 16th 1984 / C/ File-name. DATAN.FOR / C/ Remarks. Subroutine DATAN.FOR page 44. / C/ Initialize GASP variables to permit the / C/ starting of the Simulation. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C C IF (NOT) 23,1,2 C C --- NEP is a control variable for determining the starting C card type for multiple run problems. C the value of NEP specifies the starting card type. C 2 NT = NEP GO TO (1,5,6,41,42,8,43,299,15,20),NT 23 CALL ERROR(95,NSET) 1 NOT = 1 NRUN = 1 C C --- Type 1 Data Card C WRITE(3,200) 200 FORMAT(1H0,9X,'1',9X,'2',9X,'3',9X,'4',9X,'5',9X,'6',9X,'7'/ 1 1H ,'123456789',1H0,'123456789',1H0,'123456789',1H0,'123456789' 2 ,1H0,'123456789',1H0,'123456789',1H0,'1234567890') READ(NCRDR,101) NAME,NPROJ,MON,NDAY,NYR,NRUNS 101 FORMAT(6A2,I4,I2,I2,I4,I4) WRITE(3,201) NAME,NPROJ,MON,NDAY,NYR,NRUNS 201 FORMAT(1H ,6A2,I4,I2,I2,I4,I4) IF (NRUNS) 30,30,5 30 CALL EXIT C C --- Data card type two C 5 READ(NCRDR,803) NPRMS,NHIST,NCLCT,NSTAT,ID,IM,NOQ,MXC,SCALE 803 FORMAT(8I5,F10.2) WRITE(3,804) NPRMS,NHIST,NCLCT,NSTAT,ID,IM,NOQ,MXC,SCALE 804 FORMAT(1H ,8I5,F10.2) IF (NHIST) 41,41,6 C C --- Data card type three is used only if NHIST is greater C than zero. Specify number of cells in histograms not C including end cells. C 6 READ(NCRDR,103) (NCELS(I),I=1,NHIST) 103 FORMAT(10I5) WRITE(3,203) (NCELS(I),I=1,NHIST) 203 FORMAT(1H ,10I5) C C --- Data card type four C Specify KRANK = Ranking row. C 41 READ(NCRDR,103) (KRANK(I),I=1,NOQ) WRITE(3,203) (KRANK(I),I=1,NOQ) C C --- Data card type five C Specify INN=1 for LVF, INN=2 for HVF C 42 READ(NCRDR,103) (INN(I),I=1,NOQ) WRITE(3,203) (INN(I),I=1,NOQ) IF (NPRMS) 23,43,8 8 DO 9 I=1,NPRMS C C --- Data card type six used only if NPRMS is greater than C zero. C READ(NCRDR,106) (PARAM(I,J),J =1,4) 106 FORMAT(4F10.4) WRITE(3,206) (PARAM(I,J),J=1,4) 206 FORMAT(1H ,4F10.4) 9 CONTINUE C C ---Data card type seven. C The NEP value is for the next run. C Set JSEED greater than zero to set tnow equal to TBEG C 43 READ(NCRDR,104) MSTOP,JCLR,NORPT,NEP,TBEG,TFIN,JSEED 104 FORMAT(4I5,2F10.3,I4) WRITE(3,204) MSTOP,JCLR,NORPT,NEP,TBEG,TFIN,JSEED 204 FORMAT(1H ,4I5,2F10.3,I4) IF (JSEED) 27,26,27 27 ISEED = JSEED CALL DRAND(ISEED,RNUM) TNOW = TBEG DO 142 J=1,NOQ QTIME(J) = TNOW 142 CONTINUE 26 JMNIT = 0 C C --- Initialize nset C Specify inputs for next run C Read in initial events C 299 DO 300 JS = 1,ID C C --- Data card type 8 C Initialize NSET by JQ equal to a negative value on C first event card. C Read in intial vents. End initial events and entities C with JQ equal to zero. C READ(NCRDR,1110) JQ WRITE(3,2110) JQ 1110 FORMAT(I10) 2110 FORMAT(1H ,I10) IF (JQ) 44,15,320 44 INIT = 1 CALL SET(1,NSET) GO TO 300 320 READ(NCRDR,1120) (ATRIB(JK),JK=1,IM) 1120 FORMAT(7F10.4) WRITE(3,2120) (ATRIB(JK),JK=1,IM) 2120 FORMAT(1H ,7F10.4) CALL FILEM(JQ,NSET) 300 CONTINUE C C --- JCLR be positive for initialization of storage arrays. C 15 IF (JCLR) 20,20,10 10 IF (NCLCT) 23,110,116 116 DO 18 I = 1,NCLCT DO 17 J = 1,3 17 SUMA(I,J) = 0. SUMA(I,4) = 1.0E20 18 SUMA(I,5) = -1.0E20 110 IF (NSTAT) 23,111,117 117 DO 360 I=1,NSTAT SSUMA(I,1) = TNOW DO 370 J =2,3 370 SSUMA(I,J) = 0. SSUMA(I,4) = 1.0E20 SSUMA(I,5) = -1.0E20 360 CONTINUE 111 IF (NHIST) 23,20,118 118 DO 380 K = 1,NHIST DO 380 L = 1,MXC 380 JCELS(K,L) = 0 C C --- Print out program identification information. C 20 WRITE(1,102) NPROJ,NAME,MON,NDAY,NYR,NRUN 102 FORMAT(1H1,19X,'Simulation Project No.',I4,2X,'on',2X, 1 6A2//,20X,'Date',I3,'/',I3,'/',I5,12X,'Run number',I5//) C C --- Print parameter values and scale. C IF (NPRMS.LE.0) GO TO 60 DO 64 I=1,NPRMS WRITE(1,107) I,(PARAM(I,J),J=1,4) 107 FORMAT(10X,' Parameter No.',I5,4F12.4) 64 CONTINUE 60 WRITE(1,1107) SCALE 1107 FORMAT(//37X,' Scale =',F10.4) RETURN END C SUBROUTINE DRAND(ISEED,RNUM) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. DRAND / C/ Date-written. Jan. 16th 1984 / C/ File-name. DRAND.FOR / C/ Remarks. Subroutine DRAND.FOR page 96. / C/ Generates a uniformly distributed / C/ random variable between 0.0 and 1.0. / C/ This is a pseudo-random number and was / C/ modified for IBM 1130 subroutine / C/ / C//////////////////////////////////////////////////////////////// C C * This is a dummy; real work is done by RANDU. C CALL RANDU(ISEED,RNUM) RETURN END C SUBROUTINE ERROR(J,NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. ERROR / C/ Date-written. Jan. 16th 1984 / C/ File-name. ERROR.FOR ver2.0 / C/ Remarks. Subroutine ERROR.FOR page 93. / C/ Subroutine ERROR is called when an e / C/ error is detected in any GASP subroutine/ C/ except PRNTQ,SUMRY, and MONTR, all of / C/ which print their own message. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C WRITE(NPRNT,100) J 100 FORMAT(///26X,'Error exit, Type',I3,' Error.') JEVNT = 101 C C --- Print filing array NSET C CALL MONTR(NSET) WRITE(NPRNT,101) 101 FORMAT(1H0,31X,'Sceduled events'//) C C --- Print next event file C CALL PRNTQ(1,NSET) C C --- Print summary report up to present C CALL SUMRY(NSET) IF (JEVNT - 101) 5,6,5 5 RETURN 6 CALL EXIT END C SUBROUTINE FILEM(JQ,NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. FILEM / C/ Date-written. Jan. 16th 1984 / C/ File-name. FILEM.FOR / C/ Remarks. Subroutine FILEM.FOR page 68. / C/ FILEM is called to file an entry in / C/ file JQ of the array NSET. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C C --- Test to see if there is an avilable column for storage. C IF (MFA - ID) 2,2,3 3 WRITE(NPRNT,4) 4 FORMAT(//24H Overlap Set Given Below/) CALL ERROR(87,NSET) C C --- Put attribute value in file C 2 DO 1 I=1,IM DEL = 0.000001 IF (ATRIB(I)) 5,1,1 5 DEL = -0.000001 NSET(I,MFA) = SCALE * (ATRIB(I) + DEL) 1 CONTINUE C C --- Call SET to put new entry in proper place in NSET C CALL SET (JQ,NSET) RETURN END C SUBROUTINE GASP(NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. GASP / C/ Date-written. Jan. 16th 1984 / C/ File-name. GASP.FOR / C/ Remarks. Subroutine GASP page 34 / C/ GASP is the master control routine and / C/ is referred to as the GASP executive. / C/ Source. Original GASP developed at U.S.Steel / C/ GASP II was developed at Arizona / C/ State University with FORTRAN IV / C/ on IBM 1130 . / C/ The present version ofGASP II is based / C/ on the book "Simulation with GASP II" / C/ by A. Alan, B.Pritsker & P. J. Kiviat / C/ 1969 / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C NOT = 0 1 CALL DATAN(NSET) C C --- Print out filing array. C JEVNT = 101 CALL MONTR(NSET) WRITE(NPRNT,403) 403 FORMAT(1H0,28X,'** Intermediate Results **'//) C C --- Obtain next event which is first entry in file 1. C ATRIB(1) is event time, ATRIB(2) is event code. C 10 CALL RMOVE(MFE(1),1,NSET) TNOW = ATRIB(1) JEVNT = ATRIB(2) C C --- Test to see if this event is a moitor event. C IF (JEVNT - 100) 13,12,6 13 I = JEVNT C C --- Call programmers event routines. C CALL EVNTS(I, NSET) C C --- Test methode for stopping C IF (MSTOP) 40,8,20 40 MSTOP = 0 C C --- Test for no summary report. C IF (NORPT) 14,22,42 20 IF (TNOW - TFIN) 8,22,22 22 CALL SUMRY(NSET) CALL OTPUT(NSET) C C --- Test number of runs remaining C 42 IF (NRUNS - 1) 14,9,23 23 NRUNS = NRUNS - 1 NRUN = NRUN + 1 GO TO 1 14 CALL ERROR(93,NSET) 6 CALL MONTR(NSET) GO TO 10 C C --- Reset JMNIT C 12 IF (JMNIT) 14,30,31 30 JMNIT = 1 GO TO 10 31 JMNIT = 0 GO TO 10 C C --- Test to see if event information is to be printed. C 8 IF (JMNIT) 14,10,32 32 ATRIB(2) = JEVNT JEVNT = 100 CALL MONTR(NSET) GO TO 10 C C --- If all runs are completed return to main program C for instructions. C 9 RETURN END C SUBROUTINE HISTO(X1,A,W,N) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. HISTO / C/ Date-written. Jan. 16th 1984 / C/ File-name. HISTO.FOR / C/ Remarks. Subroutine HISTO.FOR page 79. / C/ HISTO tabulates the number of times X1 / C/ is within the specified cell limits. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C IF (N- NHIST) 11,11,2 2 WRITE(NPRNT,250) N 250 FORMAT(' Error in histogram',I4,//) CALL EXIT 11 IF (N) 2,2,3 C C --- Translate X1 by subtracing A if X.LE.A C 3 X = X1 - A IF (X) 6,7,7 6 IC = 1 GO TO 8 C C --- Determine cell number IC. C 7 IC = X / W + 2.0 IF (IC - NCELS(N) - 1) 8,8,9 9 IC = NCELS(N) + 2 8 JCELS(N,IC) = JCELS(N,IC) + 1 RETURN END C SUBROUTINE MONTR(NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. MONTR / C/ Date-written. Jan. 16th 1984 / C/ File-name. MONTR.FOR / C/ Remarks. Subroutine MONTR.FOR page 87. / C/ The monitoring of events as they / C/ occur. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C C C --- IF JEVNT .GE. 101 Print NSET C IF (JEVNT - 101) 9,7,9 7 WRITE(NPRNT,100) TNOW DO 1000 I=1,ID 100 FORMAT(1H0,10X,'** GASP Job Storage area dump at',F10.4, 1 2X,'Time units **'//) 1000 WRITE(NPRNT,101) I,(NSET(J,I),J=1,MXX) 101 FORMAT(I5,12I9) RETURN 9 IF (MFE(1)) 3,6,1 C C --- IF JMNIT = 1 Print TNOQ, Current event code, and all C attributes of the next event. C 1 IF (JMNIT - 1) 5,4,3 3 WRITE(NPRNT,199) 199 FORMAT(///26X,' Error Exit, type 99 error.') CALL EXIT 4 MMFE = MFE(1) WRITE(NPRNT,103) TNOW,ATRIB(2),(NSET(I,MMFE),I=1,MXX) 103 FORMAT(/10X,'Current event.... Time =',F8.2,5X,'Event =', 1 F7.2/10X,'Next event.......',/(10X,12I9)//) 5 RETURN 6 WRITE(NPRNT,104) TNOW 104 FORMAT(10X,' File 1 is empty at',F10.2) GO TO 5 END C SUBROUTINE PRNTQ(JQ,NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. PRNTQ / C/ Date-written. Jan. 29th 1984 / C/ File-name. PRNTQ.FOR / C/ Remarks. Subroutine PRNTQ.FOR page 81. / C/ PRNTQ computes and prints the time- / C/ integrated average and standard of the / C/ number of entries in particular file / C/ file and the maximum number of entries / C/ that were in the file since the file / C/ was last initialized. / C/ Modified Example-3 / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C WRITE(NPRNT,100) JQ IF (TNOW - TBEG) 12,12,13 12 WRITE(NPRNT,105) 105 FORMAT(/25X,'No Printout TNOW = TBEG '//) GO TO 2 C C --- Compute expect no. C 13 XNQ = NQ(JQ) X = (ENQ(JQ) + XNQ * (TNOW - QTIME(JQ)))/(TNOW - TBEG) STD1=(VNQ(JQ)+XNQ*XNQ*(TNOW-QTIME(JQ)))/(TNOW-TBEG)-X*X IF (STD1.GT.0.0) GO TO 14 STD = 0.0 GO TO 15 14 STD = STD1 ** 0.5 15 WRITE(NPRNT,104) X,STD,MAXNQ(JQ) C C --- Print file in proper order requires tracing through the C pointers of the file C LINE = MFE(JQ) IF (LINE - 1) 4,1,1 4 WRITE(NPRNT,102) 2 RETURN C 1 WRITE(NPRNT,101) 6 DO 77 I=1,IM ATRIB(I) = NSET(I,LINE) ATRIB(I) = ATRIB(I) / SCALE 77 CONTINUE WRITE(NPRNT,103) (ATRIB(I),I=1,IM) LINE = NSET(MX,LINE) IF (LINE - 7777) 6,2,5 5 WRITE(NPRNT,199) 199 FORMAT(///26X,'Error Exit, Type 94 Error.') 100 FORMAT(//29X,' File Printout, File No.',I3) 101 FORMAT(/35X,' File Contents'/) 102 FORMAT(/33X,'The File is empty') 103 FORMAT(10X,10F10.4) 104 FORMAT(/25X,'Average Number in file was',F10.4,/25X, 1 'STD. DEV.',18X,F10.4,/25X,'Maximum',24X,I4) CALL EXIT END C SUBROUTINE RANDU(IY,YFL) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. RANDU / C/ Date-written. Jan. 16th 1984 / C/ File-name. RANDU.FOR / C/ Remarks. Subroutine RANDU.FOR page 96. / C/ RANDU is a modefied IBM 1130 subroutine / C/ / C//////////////////////////////////////////////////////////////// C IY = IY * 899 IF (IY.GE.0) GO TO 10 IY = IY + 32767 + 1 10 YFL = IY YFL = YFL / 32767.0 RETURN END C SUBROUTINE RMOVE(KCOL,JQ,NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. RMOVE / C/ Date-written. Jan. 16th 1984 / C/ File-name. RMOVE.FOR / C/ Remarks. Subroutine RMOVE.FOR page 69. / C/ Subroutine RMOVE is called to remove / C/ an entry from file JQ of the array / C/ NSET. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C IF (KCOL) 16,16,2 16 CALL ERROR(97,NSET) 2 MLC(JQ) = KCOL C C --- Put values of KCOL in attrib C DO 3 I=1,IM ATRIB(I) = NSET(I,KCOL) ATRIB(I) = ATRIB(I)/SCALE 3 CONTINUE C C --- Set OUT=1 and call set to remove entry from NSET C OUT = 1.0 CALL SET(JQ,NSET) RETURN END C SUBROUTINE SET(JQ,NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. SET / C/ Date-written. Jan. 16th 1984 / C/ File-name. SET.FOR Ver2.0 / C/ Remarks. Subroutine SET.FOR page 62. / C/ Subroutine SET is the heart of the / C/ information storage and retrieval / C/ system. SET performs three functions: / C/ 1. Initialize the filing array NSET / C/ 2. Updates the pointer system. / C/ 3. Maintain statistics on the number / C/ of entries in each file. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C C C --- INIT should be one for initialization of file C IF (INIT - 1) 27,28,27 C C --- Initialize file to zero. Set up pointers C must initialize KRANK(JQ) C must initialize INN(JQ) C 28 KOL = 7777 KOF = 8888 KLE = 9999 MX = IM + 1 MXX = IM + 2 C C --- Inirtialize pointing cells of NSET and zero other cells C of NSET C DO 1 I=1,ID DO 2 J=1,IM 2 NSET(J,I) = 0 NSET(MXX,I) = I - 1 1 NSET(MX,I) = I + 1 NSET(MX,ID) = KOF DO 3 K=1,NOQ NQ(K) = 0 MLC(K) = 0 MFE(K) = 0 MAXNQ(K) = 0 MLE(K) = 0 ENQ(K) = 0.0 VNQ(K) = 0.0 QTIME(K) = TNOW 3 CONTINUE C C --- First available column = 1 C MFA = 1 INIT = 0 OUT = 0.0 RETURN C C --- MFEX is first entry in file which has not been compared C with ITEM to be inserted. C 27 MFEX = MFE(JQ) C C --- KNT is a check code to indicate that no comparisons have C been made. C KNT = 2 C C --- KS is the row on which items of file JQ are ranked. C KS = KRANK(JQ) C C --- Test for putting value in or out C if out equals one an item is to be removed from file JQ C If OUT is less than ONE an item is to be inserted in C file JQ C IF (OUT-1.0) 8,5,100 C C --- Putting an entry in file JQ C 8 NXFA = NSET(MX,MFA) C C --- If INN(JQ) equals two the file is a HVF file. If INN(JQ) C is one the file is a LVF file. For LVF files try to insert C Stating at end of file. MLEX is last entry in file which C has not been compared with items to be inserted. C IF (INN(JQ) - 1) 100,7,6 7 MLEX = MLE(JQ) C C --- If MLEX is zero file is empty. item to be inserted will be C only item in file. C IF (MLEX) 100,10,11 10 NSET(MXX,MFA) = KLE MFE(JQ) = MFA C C --- There is no successor of item inserted. Since item was C inserted in column MFA the last entry of file JQ is in C column MFA. C 17 NSET(MX,MFA) = KOL MLE(JQ) = MFA C C --- Set new MFA equal to successor of old MFA. that is NXFA C 14 MFA = NXFA IF (MFA - KOF) 237,238,238 237 NSET(MXX,MFA) = KLE C C ---Update statistics of file JQ C 238 XNQ = NQ(JQ) ENQ(JQ) = ENQ(JQ) + XNQ * (TNOW - QTIME(JQ)) VNQ(JQ) = VNQ(JQ) + XNQ * XNQ * (TNOW - QTIME(JQ)) QTIME(JQ) = TNOW NQ(JQ) = NQ(JQ) + 1 MAXNQ(JQ) = MAX0(MAXNQ(JQ),NQ(JQ)) MLC(JQ) = MFE(JQ) RETURN C C --- Test ranking value of new item against value of item C in column C 11 IF (NSET(KS,MFA)-NSET(KS,MLEX)) 12,13,13 C C --- Insert item after column MLEX. C 13 MSU = NSET(MX,MLEX) NSET(MX,MLEX) = MFA NSET(MXX,MFA) = MLEX GO TO (18,17),KNT C C --- Since KNT equals one a comparison was made and there C is A. C 18 NSET(MX,MFA) = MSU NSET(MXX,MSU) = MFA GO TO 14 C C --- Set KNT to one since a comparison was made. C 12 KNT = 1 C C --- Test MFA against predecessor of MLEX by letting C MLEX equal predecessor of MLEX. C MLEX = NSET(MXX,MLEX) IF (MLEX-KLE) 11,16,11 C C --- If MLEX had no predecessor MFA is first in file C 16 NSET(MXX,MFA) = KLE MFE(JQ) = MFA C C C 26 NSET(MX,MFA) = MFEX NSET(MXX,MFEX) = MFA GO TO 14 C C --- FOR HVF OPERATION TRY TO INSERT ITEM STARTING AT BEGINNING C OF FILE JQ. C 6 IF (MFEX) 100,10,19 C C --- Test ranking value of new item against value of C item in column MFEX. C 19 IF (NSET(KS,MFA)-NSET(KS,MFEX)) 20,21,21 C C --- If new value if lower. MFA must be compared against C successor of MFEX. C 20 KNT = 1 C C --- Let MPRE = MFEX and let MFEX be the successor of MFEX. C MPRE = MFEX MFEX = NSET(MX,MFEX) IF (MFEX-KOL) 19,24,19 C C --- If new value is higher, it should be inserted between C MFEX and ITS. C 21 GO TO (22,16), KNT 22 KNT = 2 C C --- MFA is to be inserted after MPRE. Make MPRE the prdece C ssor of MFA and MFA the successor of MPRE. C 24 NSET(MXX,MFA) = MPRE NSET(MX,MPRE) = MFA C C --- If KNT was not reset to 2, thre is no successor of MFA C pointers are updated at statement 17. C GO TO (17,26), KNT C C --- Removal of an item from file JQ. C 5 OUT = 0.0 C C --- Update pointing system to account for removal of MLC(JQ) C MMLC = MLC(JQ) C C --- Reset out to 0 and clear column removed. C DO 32 I=1,IM NSET(I,MMLC) = 0 32 CONTINUE JL = NSET(MX,MMLC) JK = NSET(MXX,MMLC) IF (JL - KOL) 33,34,33 33 IF (JK - KLE) 35,36,35 35 NSET(MX,JK) = JL NSET(MXX,JL) = JK C C --- Update pointers. C 37 NSET(MX,MMLC) = MFA NSET(MXX,MMLC) = KLE IF (MFA - KOF) 234,235,235 234 NSET(MXX,MFA) = MMLC 235 MFA = MLC(JQ) MLC(JQ) = MFE(JQ) C C --- Update file statistaics C XNQ = NQ(JQ) ENQ(JQ) = ENQ(JQ) + XNQ * (TNOW - QTIME(JQ)) VNQ(JQ) = VNQ(JQ) + XNQ * XNQ * (TNOW - QTIME(JQ)) QTIME(JQ) = TNOW NQ(JQ) = NQ(JQ) - 1 RETURN C C --- MLC was first entry but not last entry. update pointers. C 36 NSET(MXX,JL) = KLE MFE(JQ) = JL GO TO 37 34 IF (JK - KLE) 38,39,38 C C --- MLC was last entry but not first entry. Update pointers. C 38 NSET(MX,JK) = KOL MLE(JQ) = JK GO TO 37 C C --- MLC was both the last and first entry, therefore, it is C the only entry. C 39 MFE(JQ) = 0 MLE(JQ) = 0 GO TO 37 100 CALL ERROR(88,NSET) CALL EXIT END C SUBROUTINE SUMRY(NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. SUMRY / C/ Date-written. Jan. 16th 1984 / C/ File-name. SUMRY.FOR / C/ Remarks. Subroutine SUMRY.FOR page 84. / C/ Subroutine SUMRY is the basic output / C/ routine of GASP II. It processes the / C/ the data collected in subroutine COLCT / C/ TMST, and HISTO and prints out a data / C/ summary. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C WRITE(NPRNT,21) 21 FORMAT(1H1,29X,'** GASP Summary Report ** '/) WRITE(NPRNT,102) NPROJ,NAME,MON,NDAY,NYR,NRUN 102 FORMAT(20X,'Simulation Project No.',I4,2X,'on',2X, 1 6A2//,20X,'Date',I3,'/',I3,'/',I5,12X,'Run number',I5/) IF (NPRMS) 147,147,146 146 DO 64 I=1,NPRMS 64 WRITE(NPRNT,107) I,(PARAM(I,J),J=1,4) 107 FORMAT(10X,' Parameter No.',I5,4F12.4) 147 IF (NCLCT) 5,60,66 5 WRITE(NPRNT,199) 199 FORMAT(///26X,'Error Exit, Type 98 Error.') CALL EXIT 66 WRITE(NPRNT,23) 23 FORMAT(//34X,'** Generated Data ** ',/17X,'Code',4X,'Mean',6X, 1 'STD.DEV.',5X,'Min.',7X,'Max.',5X,'OBS.'/) C C --- Compute and print statistics gathered by CLCT C DO 2 I=1,NCLCT IF (SUMA(I,3)) 5,62,61 62 WRITE(NPRNT,63) I 63 FORMAT(17X,I3,10X,'No Values Recorded ') GO TO 2 61 XS = SUMA(I,1) XSS = SUMA(I,2) XN = SUMA(I,3) AVG = XS / XN STD = (((XN * XSS) - (XS * XS))/(XN * (XN - 1.0)))**0.5 N = XN WRITE(NPRNT,24) I,AVG,STD,SUMA(I,4),SUMA(I,5),N 24 FORMAT(17X,I3,4F11.4,I7) 2 CONTINUE 60 IF (NSTAT) 5,67,4 4 WRITE(NPRNT,29) 29 FORMAT(/34X,'** Time Generated Data **'/,17X,'Code',4X,'Mean', 1 6X,'STD.DEV.',5X,'Min.',7X,'Max.',3X,'Total Time '/) C C --- Compute and print statistics gathered by TMST C DO 6 I=1,NSTAT IF (SSUMA(I,1)) 5,71,72 71 WRITE(NPRNT,63) I GO TO 6 72 XT = SSUMA(I,1) XS = SSUMA(I,2) XSS = SSUMA(I,3) AVG = XS / XT STD = (XSS/XT - AVG*AVG) ** 0.5 WRITE(NPRNT,30) I,AVG,STD,SSUMA(I,4),SSUMA(I,5),XT 30 FORMAT(17X,I3,5F11.4) 6 CONTINUE 67 IF (NHIST) 5,75,9 9 WRITE(NPRNT,25) 25 FORMAT(/27X,'** Generated Frequency Distributions **',/17X, 1 'Code',20X,'Histograms') C C --- Print histograms C DO 12 I=1,NHIST NCL = NCELS(I) + 2 12 WRITE(NPRNT,26) I,(JCELS(I,J),J=1,NCL) FORMAT(/17X,I3,5X,11I4,/(25X,11I4)) 12 CONTINUE C C --- Print files and file statistics C 75 DO 15 I=1,NOQ CALL PRNTQ(I,NSET) 15 CONTINUE RETURN END C SUBROUTINE TMST(X,T,N,NSET) C//////////////////////////////////////////////////////////////// C/ / C/ Program-id. TMST / C/ Date-written. Jan. 16th 1984 / C/ File-name. TMST.FOR / C/ Remarks. Subroutine TMST.FOR page 76. / C/ This subroutine collects sample data / C/ on observations of a variable made over / C/ a period of time. / C/ / C//////////////////////////////////////////////////////////////// C C * Default size of INTEGER = 2 bytes C INTEGER*4 NSET(6,1) C COMMON /C1/ ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST, 1 NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED, 2 TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4) C COMMON /C2/ ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4), 1 MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4), 2 QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON, 3 NDAY,NYR,JCLR C IF (N.GT.0) GO TO 20 10 CALL ERROR(91,NSET) 20 IF (N .GT. NSTAT) GO TO 10 TT = T - SSUMA(N,1) SSUMA(N,1) = SSUMA(N,1) + TT SSUMA(N,2) = SSUMA(N,2) + X*TT SSUMA(N,3) = SSUMA(N,3) + X*X*TT SSUMA(N,4) = AMIN1(SSUMA(N,4),X) SSUMA(N,5) = AMAX1(SSUMA(N,5),X) RETURN END