1C     MUSIC V, Max Mathews
2C
3C     typed in from old XGP output
4C     file last written 19Jun75 MUSIC5[M5,GM] (I believe GM = George McKee)
5C     SAIL
6C
7C     The main typos are 'I' vs 1 -- the printout is so old and faded that
8C       I can barely make out which is correct sometimes.  And there are space
9C       characters that were dropped by the printer.  Also I haven't used
10C       fortran since the early '80s -- I scarcely remember how this is supposed
11C       to look.
12C
13C     Mus11 says ifile(n,rnam) is the same as open(n,rnam,0,'RDO',,,'UNF')
14C
15C     Bill Schottstaedt, 26-Apr-08
16C
17C     [page 1-1] -- these are the original XGP pages to help me find my place
18
19
20C     PASS1 PASS 1 MAIN PROGRAM
21C     PASS1   *** MUSIC V ***   THIS VERSION RUNS ON THE PDP10, JULY 14,1971
22      COMMON P(100),IP(10),D(2000),IPDP
23      DATA IPDP/0/
24C*****PDP *****  IPDP WAS ADDED TO COMMON LIST IN PLACE OF ENTRY FEATURE.
25 99   FORMAT(' TYPE FILE NAME'/)
26 999  FORMAT(A5)
27      TYPE 99
28      ACCEPT 999,FLNM
29      CALL IFILE(1,FLNM)
30C*****ABOVE 5 LINES FOR PDP10 ********
31
32C     INITIALIZATION
33C     NOMINAL SAMPLING RATE.
34      D(4) = 10000.0
35C     ERROR FLAG
36      IP(2)=0
37      P(2)=0.0
38C     C   NWRITE = 2
39      NWRITE=20
40C**** PDP DSK0=DEVICE 20 ******
41CC    REWIND NWRITE
42CC    CALL READ0
43      CALL READ1
44C********PDP ********
45C     MAIN LOOP
46 100  CALL READ1
47      I1=P(1)
48      IF (I1.GE.1.AND.I1.LE.12) GO TO 103
49      IP(2)=1
50CC    WRITE (6,200)
51      PRINT 200
52C********PDP ********
53 200  FORMAT(' NON-EXISTENT OPCODE ON DATA STATEMENT')
54      GO TO 100
55 103  GO TO (1,1,1,1,5,6,7,1,9,1,1,12),I1
56 1    CALL WRITE1 (NWRITE)
57      GO TO 100
58 5    PRINT 110
59CC 5 WRITE (6, 110)
60C********PDP ********
61 110  FORMAT(' END OF SECTION IN PASS 1')
62      GO TO 1
63 6    CALL WRITE1 (NWRITE)
64C     C	  WRITE (6, 111)
65      PRINT 111
66C********PDP ********
67 111  FORMAT (' END OF PASS 1')
68      IF(IP(2).EQ.1) CALL HARVEY
69      CALL EXIT
70C     SET VARIABLES IN PASS 1
71 7    I2=P(3)
72      I3=I2+IP(1)-4
73      DO 104 I4=I2,I3
74 104     D(14)=P(14-I2+4)
75         GO TO 100
76 9       I6=P(3)
77         IF (I6.GE.1.AND.I6.LE.5) GO TO 107
78         IP(2)=1
79CC    WRITE (6,201)
80
81C     [page 1-2]
82
83         PRINT 201
84C********PDP ********
85 201     FORMAT(' NON-EXISTENT PLF SUBROUTINE CALLED')
86         GO TO 100
87 12      CALL WRITE1 (NWRITE)
88         GO TO 7
89 107     GO TO (21,22,23,24,25),I6
90 21      CALL PLF1
91         GO TO 100
92 22      CALL PLF2
93         GO TO 100
94 23      CALL PLF3
95         GO TO 100
96 24      CALL PLF4
97         GO TO 100
98 25      CALL PLF5
99         GO TO 100
100         END
101C     WRITE1 PASS 1 DATA-WRITING ROUTINE
102C     *** MUSIC V ***
103      SUBROUTINE WRITE1(N)
104      COMMON P(100),IP(10)
105      K=IP(1)
106      WRITE(N )K,(P(J),J=1,K)
107      RETURN
108      END
109      SUBROUTINE PLF
110      COMMON P(100),IP(10),D(2000)
111CC    ENTRY PLF1
112CC    ENTRY PLF2
113CC    ENTRY PLF3
114CC    ENTRY PLF4
115CC    ENTRY PLF5
116      END
117C     ERRO1    GENERAL ERROR ROUTINE
118C     ***MUSIC V ***
119      SUBROUTINE ERROR(I)
120      PRINT 100,I
121 100  FORMAT(13HERROR OF TYPEI5)
122      RETURN
123      END
124      SUBROUTINE HARVEY
125CC    WRITE (6,1)
126      PRINT 1
127C********PDP *********
128 1    FORMAT(' WHERE IS HARVEY')
129      CALL EXIT
130      END
131      SUBROUTINE MOVR(IBCD,LA,LB)
132      DIMENSION IBCD(300)
133      DO 1 J=LA,LB
134CC  1 IBCD(J)=I5-(IBCD(J))/16777216
135C********PDP ********
136 1       IBCD(J)=IBCD(J)/536870912-48
137 2       DUMMY=0
138C     TO SET BREAKPOINT.
139         RETURN
140         END
141
142
143C     [page 2-1]
144
145C     READ1 INTERPRETATIVE READING ROUTINE
146C**** MUSIC V ****
147      SUBROUTINE READ1
148      COMMON P(100),IP(10),D(2000),IPDP
149C*****PDP ***** IPDP WAS ADDED TO COMMON LIST IN PLACE OF ENTRY FEATURE
150      DIMENSION CARD(129),ICAR(128),IBCD(300),LOP(3,30)
151      DIMENSION BCD(300)
152      DIMENSION IBC(12),IVT(4)
153      EQUIVALENCE(CARD,ICAR)
154      EQUIVALENCE(BCD,IBCD)
155      DATA NOPS,NBC,NC/26,3,72/
156      DATA IDEC,ISTAR/'.','*'/
157CCC   DATA IBC(1),IBC(2),IBC(3),IBC(4)/'=',' ',',','-'/
158      DATA IBC(1),IBC(2),IBC(3),IBC(4)/';',' ',',','-'/
159C********NO!!!!! THE CHARACTER = HAS BEEN SUBSTITUTED FOR
160C     THE SEMICOLON AS THE END OF STATEMENT DELIMITER
161      DATA IVT/'P','F','B','V'/
162      DATA LOP/'N','O','T','I','N','S','G','E','N','S','V','3',
163      1 'S','E','C','T','E','R','S','V','1','S','V','2','P','L','F',
164      2 'P','L','S','S','I','3','S','I','A','C','O','M','E','N','D',
165      3 'O','U','T','O','S','C','A','D','2','R','A','N','E','N','V',
166      4 'S','T','R','A','D','3','A','D','4','M','L','T','F','L','T',
167      5 'R','A','H','S','E','T',0,0,0,0,0,0,0,0,0,0,0,0/
168C********LAST 12 LOCATIONS NOT YET USED. **** PDP ********
169      EQUIVALENCE (JSEMI,IBC(1)), (JBLANK,IBC(2))
170
171C     TO SCAN INPUT DATA TO #, ORGANIZE FIELDS AND PRINT
172      IF(IPDP.EQ.0) GO TO 99
173C********PDP ********
174      IF (END+SNA8-1.) 10,10,90
175 10   IBK=2
176      END=0
177      ERR=0
178      NUMU=0
179      ISEMI=1
180      L=3
181      J=0
182 11   I=I+1
183      IF(I.GT.NC) GO TO 15
184      IF(J.EQ.299) GO TO 21
185      DO 13 N=1,NBC
186         IF(ICAR(I)-IBC(N)) 13,12,13
187 12      GO TO (20,16,18),N
188C     ; BLA ,
189 13   CONTINUE
190      J=J+1
191      IBCD(J)=ICAR(I)
192      IBK=1
193      GO TO 11
194 14   IBK=N
195      GO TO 11
196CC   15 READ (5,1,ERR=95,END=95) (CARD(I),I=1,NC)
197C********PDP ********
198 15   READ (1,1,ERR=95,END=95) I, (CARD(I),I=1,NC)
199C*****PDP ***** FIRST 'I' IS FOR PDP LINE NUMBERS!
200 1    FORMAT(I,128A1)
201CC 1 FORMAT(128A1)
202      PRINT 2,(CARD(I),I=1,NC)
203 2    FORMAT(1H 128A1)
204      I=0
205
206C     [page 2-2]
207
208      GO TO 11
209 16   GO TO (17,11,11),IBK
210 17   IBK=N
211      J=J+1
212      IBCD(J)=JBLANK
213      GO TO (11,21),ISEMI
214 18   GO TO (17,14,19),IBK
215 19   J=J+1
216      IBCD(J)=0
217      GO TO 17
218 20   ISEMI=2
219      GO TO (17,21,19),IBK
220 21   J=J+1
221      IBCD(J)=JSEMI
222C     TO SCAN FOR OP CODE
223      DO 24 N=1,NOPS
224         M=N
225         DO 23 K=1,3
226            IF (IBCD(K)-LOP(K,N)) 24,23,24
227 23      CONTINUE
228         GO TO 26
229 24   CONTINUE
230      GO TO 40
231 26   NP=1
232 27   L=L+1
233      IF (IBCD(L)-JBLANK) 27,29,27
234 29   GO TO (100,200,300,400,500,600,700,800,900,10000,1100,1200,1300,
235      1217 ,201,202,203,204,205,206,207,208,209,210,211,212),M
236C     OP CODE 1 TO PLAY NOTE
237 100  P(1)=1.
238      GO TO 30
239C     OP CODE 2 TO DEFINE INSTRUMENT
240 200  P(1)=2.
241      IDEF=1
242      N1=1
243      GO TO 70
244 2000 P(2)=XN
245      N1=2
246      GO TO 70
247 2001 P(3)=XN
248      IP(1)=3
249      GO TO 50
250C     OUT BOX
251 201  P(3)=101.
252      NPW=2
253      IF (STER) 220,220,2011
254 2011 SNA8=1.
255      STER=0
256      GO TO 220
257C     OSCILLATOR
258 202  P(3)=102.
259      NPW=5
260      GO TO 220
261C     ADD 2
262 203  P(3)=103.
263      NPW=3
264      GO TO 220
265C     RANDOM AND INTERPOLATE
266 204  P(3)=104.
267      NPW=6
268
269C     [page 2-3]
270
271      GO TO 220
272C     LINEAR ENVELOPE GENERATOR
273 205  P(3)=105.
274      NPW=7
275      GO TO 220
276C     STEREO OUT BOX
277 206  P(3)=106.
278      NPW=3
279      IF(STER)220,2061,220
280 2061 SNA8=1.
281      STER=1.
282      GO TO 220
283C     THREE INPUT ADDER
284 207  P(3)=107.
285      NPW=4
286      GO TO 220
287C     FOUR INPUT ADDER
288 208  P(3)=108.
289      NPW=5
290      GO TO 220
291C     MULTIPLIER
292 209  P(3)=109.
293      NPW=3
294      GO TO 220
295C     FILTER
296 210  P(3)=112.
297      NPW=4
298      GO TO 220
299C     RANDOM AND HOLD
300 211  P(3)=111.
301      NPW=5
302      GO TO 220
303C     SET NEW FUNCTION
304 212  P(3)=110.
305      NPW=1
306      GO TO 220
307C     END OF INSTRUMENT
308 217  IP(1)=2
309      IDEF=0
310      END=1.
311      GO TO 50
312C     UNNAMED UNIT - NUMERICAL NAME ASSUMED
313 218  N1=8
314      NUMU=1
315      L=0
316      GO TO 70
317 219  M=XN+14.
318      IF(XN.LT.11.)GO TO 29
319      P(3)=XN
320C     TO INTERPRET VARS IN UNIT DEFS
321 220  NP=3
322 221  IF(IBCD(L+1)-JSEMI) 222,240,222
323 222  NP=NP+1
324      L=L+1
325      DO 223 N=1,4
326         IF(IBCD(L)-IVT(N))223,225,223
327 223  CONTINUE
328 224  L=L+1
329      IF(IBCD(L).EQ.JBLANK)GO TO 46
330      GO TO 224
331
332C     [page 2-4]
333
334 225  GO TO (231,232,233,234),N
335C     P TYPE
336 231  N1=3
337      GO TO 70
338 2311 P(NP)=XN
339      GO TO 221
340C     F TYPE
341 232  N1=4
342      GO TO 70
343 2321 P(NP)=-(XN+100.)
344      GO TO 221
345C     B TYPE
346 233  N1=5
347      GO TO 70
348 2331 P(NP)=-XN
349      GO TO 221
350C     V TYPE
351 234  N1=6
352      GO TO 70
353 2341 P(NP)=XN+100.
354      GO TO 221
355 240  IF(NUMU.EQ.1)GO TO 242
356 241  IF(NPW+3-NP)42,242,42
357 242  IP(1)=NP
358      GO TO 50
359C     OP CODE 3 - TO GENERATE FUNCTION
360 300  P(1)=3.
361      GO TO 30
362C     OP CODE 4 -- TO SET PARAM 3RD PASS
363 400  P(1)=4.
364      GO TO 30
365C     OP CODE 5 TO END SEC
366 500  P(1)=5.
367      GO TO 30
368C     OP CODE 6 TO TERMINATE PIECE
369 600  P(1)=6.
370      GO TO 30
371C     OP CODE 7 TO SET PARAM 1ST PASS
372 700  P(1)=7.
373      GO T0 30
374C     OP CODE 8 TO SET PARAM 2ND PASS
375 800  P(1)=8.
376      GO TO 30
377C     OP CODE 9 TO EXECUTE SUB 1ST PASS
378 900  P(1)=9.
379      GO TO 30
380C     OP CODE 10 TO EXECUTE SUB 2ND PASS
381 1000 P(1)=10.
382      GO TO 30
383C     OP CODE 11 TO SET INTEGER 3RD PASS
384 1100 P(1)=11.
385      GO TO 30
386C     OP CODE 12 TO SET INTEGER ALL PASSES
387 1200 P(1)=12.
388      GO TO 30
389C     OP CODE 13 FOR COMMENTS
390 1300 IF(IBCD(L)-JSEMI)1301,10,1301
391 1301 L=L+1
392      GO TO 1300
393C     TO STORE PFIELDS
394
395C     [page 2-5]
396
397 30   IF(IDEF)32,32,43
398 32   IF(IBCD(L+1)-JSEMI)33,34,33
399 33   NP=NP+1
400      N1=7
401      GO TO 70
402 331  P(NP)=XN
403      GO TO 32
404 34   IP(1)=NP
405      IF(NP-1)47,47,50
406C     ERRORS
407 40   IF(IDEF)41,41,218
408 41   L=L+1
409      IF(IBCD(L).NE.JSEMI)GO TO 41
410      PRINT 3
411 3    FORMAT(26H    OP CODE NOT UNDERSTOOD)
412      GO TO 49
413 42   PRINT 4
414 4    FORMAT(44H    UNIT CONTAINS WRONG NUMBER OF PARAMETERS)
415      GO TO 49
416 43   PRINT 5
417 5    FORMAT(36H    INSTRUMENT DEFINITION INCOMPLETE)
418      ERR=1.
419      IDEF=0
420      GO TO 32
421 44   PRINT 6
422 6    FORMAT(25H    ERROR IN NUMERIC DATA)
423      ERR=1.
424      IF(NUMU.EQ.1)GO TO 45
425      GO TO 30
426 45   PRINT 7
427 7    FORMAT(46H+                          FOR UNIT DESIGNATION)
428      P(3)=0.
429      GO TO 220
430 46   PRINT 8
431 8    FORMAT(40H    IMPROPER VARIABLE IN UNIT DEFINITION)
432      ERR=1.
433      GO TO 221
434 47   PRINT 9
435 9    FORMAT(24H    STATEMENT INCOMPLETE)
436 49   IP(2)=1
437      GO TO 10
438 50   IF(ERR.EQ.1.) GO TO 49
439      RETURN
440C     CONVERSION OF NUMERIC FIELD TO FLOATING POINT
441 70   SGN=1.
442      IF (IBCD(L+1).NE.IBC(4)) GO TO 79
443      SGN=-1.
444      L=L+1
445 79   L1=L+1
446      LD=L1
447      XN=0.
448 71   L=L+1
449C     *** I DON'T UNDERSTAND THIS PART OF THE SCANNER!
450CC          IF(IBCD(L).EQ.JBLANK) GO TO 77
451      IF (IBCD(L)-JBLANK)72,77,72
452C     THIS LOOKS FOR #S, LETTERS, BLANKS, DECI.PTS, & *S. OTHERWISE=ERROR!?
453C     ******** PDP ********
454 72   IF(IBCD(L).LT.10)GO TO 71
455      IF(IBCD(L)-IDEC)74,71,74
456 74   IF(IBCD(L)-ISTAR)76,71,76
457
458C     [page 2-6]
459
460 76   GO TO 71
461C     ERROR CHECK IS REMOVED!
462C**   NEXT 2 LINES BY-PASSED*** 76 L=L+1
463      IF(IBCD(L).EQ.JBLANK) GO TO 44
464      GO TO 76
465 77   IF(IBCD(L1)-ISTAR)80,78,80
466 78   XN=P(NP)
467      GO TO 89
468 80   DO 81 LL=L1,L
469         LD=LL
470         IF (IBCD(LL)-IDEC)81,82,81
471 81   CONTINUE
472 82   IEX=0
473      LA=L1
474      LB=LD-1
475      IF(LD-L1)86,86,83
476 83   IEX=LD-LA
477 84   CALL MOVR (IBCD,LA,LB)
478      DO 85 LL=LA,LB
479         IEX=IEX-1
480         X1=IBCD(LL)
481 85      XN=XN+XI*10.**IEX
482 86   IF(L-LB-2)88,88,87
483 87   LA=LD+1
484      LB=L-1
485      GO TO 84
486 88   XN=XN*SGN
487 89   GO TO (2000,2001,2311,2321,2331,2341,331,219),N1
488C     TO WRITE S1A8 FOR MONO STEREO CONTROL
489 90   P(1)=12.
490      P(3)=8.
491      P(4)=STER
492      IP(1)=4
493      END=0.
494      SNA8=0.
495      GO TO 50
496C     FOR PREMATURE END OF FILE ON INPUT
497 95   NP=2
498      IP(2)=1
499      L=0
500      IBCD(1)=JSEMI
501      GO TO 600
502C     TO INITIALIZE
503CC ENTRY READ0
504CC READ (5,1,ERR=95,END=95) (CARD(I),I=1,NC)
505C********PDP ********
506 99   READ (1,1,ERR=95,END=95) I,(CARD(I),I=1,NC)
507C*****PDP ***** FIRST 'I' IS FOR PDP LINE NUMBERS!
508CC WRITE (6,2) (CARD(I),I=1,NC)
509      PRINT 2,(CARD(I),I=1,NC)
510C********PDP ********
511      IPDP=1
512      I=0
513      IDEF=0
514      IBK=2
515      STER=0.
516      END=0.
517      SNA8=0.
518      RETURN
519      END
520
521C     [page 3-1]
522
523C     PASS 2 MAIN PROGRAM
524C     *** MUSIC V ***
525      DIMENSION G(1000),I(1000),T(1000),D(10000),P(100),IP(10)
526      COMMON IP,P,G,I,T,D,IXJQ,TLAST,BLAST
527C     INITIALIZING PROGRAM
528C     NOMINAL SAMPLING RATE, NOTE PARAMETER LENGTH, NUMBER OF CARDS
529C     NO OF OP CODES, PASS 11 REPORT PRINT PARAMETER
530      G(1)=0.
531      G(2)=0.
532      G(4)=10000.0
533      NPAR=10000
534      NCAR=1000
535      NOPC=12
536      IXJQ=0
537      IEND=0
538C     C*****  NREAD=2
539C     C*****  NWRITE=3
540      NREAD=20
541      NWRITE=21
542      REWIND NREAD
543      REWIND NWRITE
544C     INITIALIZE SECTION
545 150  ID=1
546      IN=1
547      TLAST=0.
548      BLAST=0.
549C     READ SECTION OF DATA
550 106  CALL READ2 (NREAD)
551      I1=IP(1)
552      D(ID)=I1
553      I(IN)=ID
554      T(IN)=P(2)
555      DO 100 I2=1,I1
556         I3=ID+I2
557 100     D(I3)=P(I2)
558      ID=ID+I1+1
559      IF(ID-NPAR)102,102,101
560 101  CALL ERROR(20)
561      STOP
562 102  IN=IN+1
563      IF (IN-NCAR)103,103,101
564 103  IF (P(1)-5.0)104,110,104
565 104  IF (P(1)-6.0)106,105,106
566 105  IEND=1
567      GO TO 110
568C     SORT SECTION
569C***  NOT USED ****** 110 CALL SORTFL
570 110  IN=IN-1
571      CALL SORT(T(1),T(2),IN,I)
572C     EXECUTE OP CODES M SECTION
573 120  DO 1 I4=1,IN
574         I5=I(I4)
575         I6=D(I5+1)
576         IF(I6)121,121,122
577 121     CALL ERROR(21)
578         GO TO 1
579 122     IF (I6-NOPC)123,123,121
580 123     GO TO (2,2,2,2,2,2,7,8,7,10,2,8),I6
581 7       CALL ERROR(22)
582         GO TO 1
583
584C     [page 3-2]
585
586 8       I7=D(I5)
587         I8=I5+4
588         I9=I5+I7
589         I10=IFIX(D(15+3))-I8
590         DO 124 I11=I8,I9
591            I12=I10+I11
592 124     G(I12)=D(I11)
593         IF(I6-I2)1,2,1
594 10      I13=D(I5+3)
595         IP(2)=I5
596         IF(I13)125,125,126
597 125     CALL ERROR(23)
598         GO TO 1
599 126     IF(I13-5)127,127,125
600 127     GO TO (21,22,23,24,25),I13
601 21      CALL PLS1
602         GO TO 1
603 22      CALL PLS2
604         GO TO 1
605 23      CALL PLS3
606         GO TO 1
607 24      CALL PLS4
608         GO TO 1
609 25      CALL PLS5
610         GO TO 1
611C     WRITE OUT SECTION
612 2       IP(1)=D(I5)
613         I18=IP(1)
614         DO 133 I19=1,I18
615            I20=I19+I5
616 133        P(I19)=D(I20)
617         CALL WRITE2 (NWRITE)
618 1       CONTINUE
619C     END OF SECTION OR PASS
620 140  IF(IEND)141,141,143
621 141  PRINT 142
622 142  FORMAT (' END OF SECTION PASS II')
623      GO TO 150
624 143  PRINT 144
625 144  FORMAT (' END OF PASS II')
626      STOP
627      END
628C     READ2 PASS 2 DATA INPUT ROUTINE
629C     *** MUSIC V ***
630      SUBROUTINE READ2(N)
631      DIMENSION IP(10),P(100)
632      COMMON IP,P
633      READ(N)K,(P(J),J=1,K)
634      IP(1)=K
635      RETURN
636      END
637C     SORT SORTING PROGRAM
638C     *** MUSIC V ***
639      SUBROUTINE SORT(A,B,N,L)
640      DIMENSION A(N),L(N)
641C
642C     SORT SORTS THE A ARRAY INTO ASCENDING NUMERICAL ORDER, PERFORMING
643C     THE SAME OPERATIONS ON ARRAY L AS ON A
644C
645      N1=N-1
646
647C     [page 3-3]
648
649      DO 10 I=1,N1
650         IN=I+1
651         DO 20 J=IN,N
652            IF(A(I).LE.A(J))GO TO 20
653            T=A(I)
654            A(I)=A(J)
655            A(J)=T
656            NT=L(I)
657            L(I)=L(J)
658            L(J)=NT
659 20      CONTINUE
660 10   CONTINUE
661      RETURN
662C     C***********  ENTRY SORTFL
663C     C***********  RETURN
664      END
665C     WRIT2 DATA OUTPUTING ROUTINE FOR PASS 2
666C     *** MUSIC V ***
667      SUBROUTINE WRITE2(N)
668      COMMON IP(10),P(100),G(1000),I(1000),T(1000),D(10000),IXJQ,TLAST,BLAST
669      IF(G(2).EQ.0.)GO TO 150
670      X=P(2)
671      Y=P(4)
672      ILOC=G(2)
673      IF(P(1).NE.1.)GO TO 50
674      P(4)=P(4)*60./CON(G,ILOC,P(2))
675 50   P(2)=TLAST+(P(2)-BLAST)*60./CON(G,ILOC,P(2))
676      TLAST=P(2)
677      BLAST=X
678 150  CALL CONVT
679      K=IP(1)
680      WRITE(N)K,(P(J),J=1,K)
681C     *** PASS II REPORT IS OPTIONAL ***
682      IF(G(1).NE.0.) RETURN
683      IF(IXJQ.EQ.0) PRINT 100
684      IXJQ=10
685 100  FORMAT(15H1PASS II REPORT/11H0(WORD CNT))
686      PRINT 101,K,(P(J),J=1,K)
687      IF(G(2).NE.0.) PRINT 102,X,Y
688 101  FORMAT(I8,10(F9.3))
689 102  FORMAT(1H+,110X,2HB=,F7.4,2HD=,F7.4)
690      RETURN
691      END
692C     CON2 PASS 2 FUNCTION INTERPOLATOR
693C     *** MUSIC V ***
694      FUNCTION CON(G,I,T)
695      DIMENSION G(1)
696      DO 10 J=1,1000,2
697         IF (G(J)-T) 10,20,30
698 30      CON = G(J-1)+((T-G(J-2))/(G(J)-G(J-2)))*(G(J+1)-G(J-1))
699         RETURN
700 10   CONTINUE
701 20   CON = G(J+1)
702      RETURN
703      END
704C     CONVT FOR UNIT GENERATORS CHECK
705C
706C     DUMMY NO OPERATION ACTUALLY PERFORMED
707C******WHEN DUMMY IS REMOVED ANOTHER CONVT MUST!!!! BE LOADED!!!*****
708
709C     [page 3-4]
710
711C***  SUBROUTINE CONVT
712C***  COMMON IP(10),P(100),G(1000)
713C***  RETURN
714C***  END
715C     ERRO1 GENERAL ERROR ROUTINE
716C     *** MUSIC V ***
717      SUBROUTINE ERROR(I)
718      PRINT 100,I
719 100  FORMAT(' ERROR OF TYPE',I5)
720      RETURN
721      END
722C     C***** SUBROUTINE PLS
723C     C***** ENTRY PLS1
724C     C***** ENTRY PLS2
725C     C***** ENTRY PLS3
726C     C***** ENTRY PLS4
727C     C***** ENTRY PLS5
728      SUBROUTINE PLS1
729      RETURN
730      END
731      SUBROUTINE PLS2
732      RETURN
733      END
734      SUBROUTINE PLS3
735      RETURN
736      END
737      SUBROUTINE PLS4
738      RETURN
739      END
740      SUBROUTINE PLS5
741      RETURN
742      END
743
744C     [page 4-1]
745
746C     PASS3   PASS 3 MAIN PROGRAM
747C     *** MUSIC V ***
748C     DATA SPECIFICATION
749      INTEGER PEAK
750      DIMENSION T(50),TI(50),ITI(50)
751      COMMON I(15000),P(100)/PARM/IP(20)/FINOUT/PEAK,NRSOR
752C     C******** DATA IIIRD/Z5EECE66D/
753      DATA IIIRD/976545367/
754C     SET I ARRAY =0 (7/10/69)
755      DATA I/15000*0/
756C*****************
757C     INITIALIZATION OF PIECE
758C     ARBITRARY STARTING NUMBER FOR SUBROUTINE RANDU
759      I(7)=IIIRD
760      IP9=IP(9)
761      PEAK=0
762      NRSOR=0
763C********NREAD=3
764C********NWRITE=2
765      NREAD=21
766C     PDP DSK1=DEV.21
767      NWRITE=1
768C     PDP DSK=DEV.1
769      REWIND NREAD
770      REWIND NWRITE
771      TYPE 10001
772      ACCEPT 10002,FLNM,IDSK
773C     TYPE 'PASS2' OR FILENAME + ANY POS.NUMB. TO WRITE SMPLS ON DSK.
774      IF(FLNM.EQ.' '.OR.FLNM.EQ.'PASS2')FLNM='FOR21'
775      CALL IFILE(21,FLNM)
776      IF(IDSK.LE.0) GO TO 10003
777      J='MUSAA'
778      CALL PUTFILE(J)
779C     IF IDSK>=1, SAMPLES WILL BE WRITTEN ON DSK (MUSAA.DMD)
780      IDSK=0
781      GO TO 10002
78210003 IDSK=-1
78310001 FORMAT(' TYPE FILE NAME'/)
78410002 FORMAT(A5,I)
785C**** ABOVE FOR PDP 10 ******
786      SCLFT=IP(12)
787      I(2)=IP(4)
788      MS1=IP(7)
789      MS3=MS1+(IP(8)*IP(9))-1
790      MS2=IP(8)
791      I(4)=IP(3)
792      MOUT=IP(10)
793C     INITIALIZATION OF SECTION
794 5    T(1)=0.0
795      DO 220 N1=MS1,MS3,MS2
796 220     I(N1)=-1
797      DO 221 N1=1,IP9
798 221     TI(N1)=1000000.
799C     MAIN CARD READING LOOP
800 204  CALL DATA (NREAD)
801      IF(P(2)-T(1))200,200,244
802 200  IOP=P(1)
803      IF(IOP)201,201,202
804 201  CALL ERROR(1)
805      GO TO 204
806
807C     [page 4-2]
808
809 202  IF(IP(1)-IOP)201,203,203
810 203  GO TO (1,2,3,4,5,6,201,201,201,201,11,11),IOP
811 11   IVAR=P(3)
812      IVARE=IVAR+I(1)-4
813      DO 297 N1=IVAR,IVARE
814         IVARP=N1-IVAR+4
815 297     I(N1)=P(IVARP)
816      GO TO 204
817 3    IGEN=P(3)
818      GO TO (281,282,283,284,285),IGEN
819 281  CALL GEN1
820      GO TO 204
821 282  CALL GEN2
822      GO TO 204
823 283  CALL GEN3
824      GO TO 204
825 284  CALL GEN4
826      GO TO 204
827 285  CALL GEN5
828      GO TO 204
829 4    IVAR=P(3)
830      IVARE=IVAR+I(1)-4
831      DO 296 N1=IVAR,IVARE
832         IVARP=N1-IVAR+4
833 296     I(N1+100)=P(IVARP)*SCLFT
834      GO TO 204
835 6    CALL FROUT3(IDSK)
836      STOP
837C     ENTER NOTE TO BE PLAYED
838 1    DO 230 N1=MS1,MS3,MS2
839         IF(I(N1)+1)230,231,230
840 230  CONTINUE
841      CALL ERROR(2)
842      GO TO 204
843 231  M1=N1
844      M2=N1+I(1)-1
845      M3=M2+1
846      M4=N1+IP(8)-1
847      DO 232 N1=M1,M2
848         M5=N1-M1+1
849 232     I(N1)=P(M5)*SCLFT
850      I(M1)=P(3)
851      DO 233 N1=M3,M4
852 233     I(N1)=0
853      DO 235 N1=1,IP9
854         IF(TI(N1)-1000000.)235,234,235
855 234     TI(N1)=P(2)+P(4)
856         ITI(N1)=M1
857         GO TO 204
858 235  CONTINUE
859      CALL ERROR(3)
860      GO TO 204
861C     DEFINE INSTRUMENT
862 2    M1=I(2)
863      M2=IP(5)+IFIX(P(3))
864      I(M2)=M1
865 218  CALL DATA (NREAD)
866      IF(I(1)-2)210,210,211
867 210  I(M1)=0
868      I(2)=M1+1
869
870C     [page 4-3]
871
872      GO TO 204
873 211  I(M1)=P(3)
874      M3=I(1)
875      I(M1+1)=M1+M3-1
876      M1=M1+2
877      DO 217 N1=4,M3
878         M5=P(N1)
879         IF(M5)212,213,213
880 212     IF(M5+100)300,301,301
881 300     I(M1)=-IP(2)+(M5+101)*IP(6)
882         GO TO 216
883 301     I(M1)=-IP(13)+(M5+1)*IP(14)
884         GO TO 216
885 213     IF(M5-100)214,214,215
886 214     I(M1)=M5
887         GO TO 216
888 215     I(M1)=M5+262144
889 216     M1=M1+1
890 217  CONTINUE
891      GO TO 218
892C     PLAY TO ACTION TIME
893 244  T(2)=P(2)
894 250  TMIN=1000000.
895      IREST=1
896      DO 241 N1=1,IP9
897         IF(TMIN-TI(N1))241,241,240
898 240     TMIN=TI(N1)
899         MNOTE=N1
900 241  CONTINUE
901      IF(1000000.-TMIN)251,251,243
902 243  IF(TMIN-T(2))245,245,246
903 245  T(3)=TMIN
904      GO TO 260
905 246  T(3)=T(2)
906      GO TO 260
907 247  IF(T(1)-T(2))249,200,200
908 249  TI(MNOTE)=1000000.
909      M2=ITI(MNOTE)
910      I(M2)=-1
911      GO TO 250
912C     SETUP REST
913 251  T(3)=T(2)
914      IREST=2
915      GO TO 260
916C     PLAY
917 260  ISAM=(T(3)-T(1))*FLOAT(I(4))+.5
918      T(1)=T(3)
919      IF(ISAM)247,247,266
920 266  IF(ISAM-IP(14))262,262,263
921 262  I(5)=ISAM
922      ISAM=0
923      GO TO 264
924 263  I(5)=IP(14)
925      ISAM=ISAM-IP(14)
926 264  IF(I(8))290,290,291
927 290  M3=MOUT+I(5)-1
928      MSAMP=I(5)
929      GO TO 292
930 291  M3=MOUT+(2*I(5))-1
931      MSAMP=2*I(5)
932
933C     [page 4-4]
934
935 292  DO 267 N1=MOUT,M3
936 267     I(N1)=0
937         GO TO (268,265),IREST
938 268     DO 270 NS1=MS1,MS3,MS2
939            IF(I(NS1)+1)271,270,271
940C     GO THROUGH UNIT GENERATORS IN INSTRUMENT
941 271        I(3)=NS1
942            IGEN=IP(5)+I(NS1)
943            IGEN=I(IGEN)
944 272        I(6)=IGEN
945CC***** IF((IGEN)-101)293,294,294
946CC***** 293 CALL SAMGEN(I)
947CC***** ABOVE FOR MACHINE LANG. UNIT GENERATORS ******
948CC***** GO TO 295
949 294        CALL FORSAM
950 295        IGEN=I(IGEN+1)
951            IF(I(IGEN))270,270,272
952 270     CONTINUE
953 265     CALL SAMOUT(IDSK,MSAMP)
954      IF(ISAM)247,247,266
955      END
956
957
958C     [page 5-1]
959
960C     FORS3        FORTRAN UNIT GENERATOR ROUTINE
961C     *** MUSIC V ***
962      SUBROUTINE FORSAM
963      DIMENSION I(15000),P(100),IP(20),L(8),M(8)
964      COMMON I,P/PARM/IP
965      EQUIVALENCE (M1,M(1)),(M2,M(2)),(M3,M(3)),(M4,M(4)),(M5,M(5)),(M6,M(6)),(M7,M(7)),(M8,M(8)),(L1,L(1)),(L2,L(2)),(L3,L(3)),(L4,L(4)),(L5,L(5)),(L6,L(6)),(L7,L(7)),(L8,L(8)),(RN1,IRN1),(RN3,IRN3),(RN,IRN)
966C     C***** DATA IMULT/Z5EECE66D/
967      DATA IIIRD/976545367/
968      SFI=1./FLOAT(IP(12))
969      SFF=1./FLOAT(IP(15))
970      SFID=FLOAT(IP(12))
971      SFXX=FLOAT(IP(12))/FLOAT(IP(15))
972      XNFUN=IP(6)-1
973C     COMMON INITIALIZATION OF GENERATORS
974      N1=I(6)+2
975      N2=I(N1-1)-1
976      DO 204 J1=N1,N2
977         J2=J1-N1+1
978         IF(I(J1))200,201,201
979 200     L(J2)=-I(J1)
980         M(J2)=1
981         GO TO 204
982 201     M(J2)=0
983         IF(I(J1)-262144)202,202,203
984C*****WHAT DOES THE BIG NUMBER DO?????
985 202     L(J2)=I(J1)+I(3)-1
986         GO TO 204
987 203     L(J2)=I(J1)-262144
988 204  CONTINUE
989      NSAM=I(5)
990      N3=I(N1-2)
991      NGEN=N3-100
992      GO TO (101,102,103,104,105,106,107,108,109,110,111,112),NGEN
993 112  RETURN
994C     UNIT GENERATORS
995C     OUTPUT BOX
996 101  IF(M1)260,260,261
997 260  IN1=I(L1)
998 261  CONTINUE
999      DO 270 J3=1,NSAM
1000         IF(M1)265,265,264
1001 264     J4=L1+J3-1
1002         IN1=I(J4)
1003 265     J5=L2+J3-1
1004         I(J5)=IN1+I(J5)
1005 270  CONTINUE
1006      RETURN
1007C     OSCILLATOR
1008 102  SUM=FLOAT(I(L5))*SFI
1009      IF(M1)280,280,281
1010 280  AMP=FLOAT(I(L1))*SFI
1011 281  IF(M2)282,282,283
1012 282  FREQ=FLOAT(I(L2))*SFI
1013 283  CONTINUE
1014      DO 293 J3=1,NSAM
1015         J4=INT(SUM)+L4
1016         F=FLOAT(I(J4))
1017
1018C     [page 5-2]
1019
1020         IF(M2)285,285,286
1021 285     SUM=SUM+FREQ
1022         GO TO 290
1023 286     J4=L2+J3-1
1024         SUM=SUM+FLOAT(I(J4))*SFI
1025CC 290 IF(SUM-XNFUN)288,287,287
1026 290     IF(SUM.GE.XNFUN)GO TO 287
1027CC 287 SUM=SUM-XNFUN
1028         IF(SUM.LT.0.0)GO TO 289
1029 288     J5=L3+J3-1
1030         IF(M1)291,291,292
1031 291     I(J5)=IFIX(AMP*F*SFXX)
1032         GO TO 293
1033C************
1034 287     SUM=SUM-XNFUN
1035         GO TO 288
1036 289     SUM=SUM+XNFUN
1037         GO TO 288
1038C**********ABOVE FOR FM (NEG. FREQ. TO OSCIL)
1039 292     J6=L1+J3-1
1040         I(J5)=IFIX(FLOAT(I(J6))*F*SFF)
1041 293  CONTINUE
1042      I(L5)=IFIX(SUM*SFID)
1043      RETURN
1044C     ADD TWO BOX
1045 103  IF(M1)250,250,251
1046 250  IN1=I(L1)
1047 251  IF(M2)252,252,253
1048 252  IN2=I(L2)
1049 253  DO 258 J3=1,NSAM
1050         IF(M1)255,255,254
1051 254     J4=L1+J3-1
1052         IN1=I(J4)
1053 255     IF(M2)257,257,256
1054 256     J5=L2+J3-1
1055         IN2=I(J5)
1056 257     J6=L3+J3-1
1057         I(J6)=IN1+IN2
1058 258  CONTINUE
1059      RETURN
1060C     RANDOM INTERPOLATING GENERATOR
1061 104  SUM=FLOAT(I(L4))*SFI
1062      IF(M1)310,310,311
1063 310  XIN1=FLOAT(I(L1))*SFI
1064 311  IF(M2)312,312,313
1065 312  XIN2=FLOAT(I(L2))*SFI
1066 313  IRN1=I(L5)
1067      IRN3=I(L6)
1068      DO 340 J3=1,NSAM
1069         IF(M1)316,316,315
1070 315     J4=L1+J3-1
1071         XIN1=FLOAT(I(J4))*SFI
1072 316     IF(M2)318,318,317
1073 317     J5=L2+J3-1
1074         XIN2=FLOAT(I(J5))*SFI
1075 318     IF(SUM-XNFUN)320,319,319
1076 319     SUM=SUM-XNFUN
1077         I(7)=IABS(I(7)*IMULT)
1078         RN4=(2.*FLOAT(I(7))*SFF-1.)
1079         RN2=RN4-RN3
1080
1081C     [page 5-3]
1082
1083         RN1=RN3
1084         RN3=RN4
1085         GO TO 321
1086 320     RN2=RN3-RN1
1087 321     J7=L3+J3-1
1088         I(J7)=XIN1*(RN1+(RN2*SUM)/XNFUN)*SFID
1089         SUM=SUM+XIN2
1090 340  CONTINUE
1091      I(L4)=IFIX(SUM*SFID)
1092      I(L5)=IRN1
1093      I(L6)=IRN3
1094      RETURN
1095C     ENVELOPE GENERATOR
1096 105  SUM=FLOAT(I(L7))*SFI
1097      IF(M1)380,380,381
1098 380  XIN1=FLOAT(I(L1))*SFI
1099 381  IF(M4)382,382,383
1100 382  XIN4=FLOAT(I(L4))*SFI
1101 383  IF(M5)384,384,385
1102 384  XIN5=FLOAT(I(L5))*SFI
1103 385  IF(M6)386,386,387
1104 386  XIN6=FLOAT(I(L6))*SFI
1105 387  X1=XNFUN/4.
1106      X2=2.*X1
1107      X3=3.*X1
1108      DO 403 J3=1,NSAM
1109         J4=INT(SUM)+L2
1110         F=FLOAT(I(J4))
1111         IF(M1)405,405,404
1112 404     J8=L1+J3-1
1113         XIN1=FLOAT(I(J8))*SFI
1114 405     IF(SUM-XNFUN)389,388,388
1115 388     SUM=SUM-XNFUN
1116 389     IF(SUM-X1)390,390,393
1117 390     IF(M4)392,392,391
1118 391     J4=L4+J3-1
1119         XIN4=FLOAT(I(J4))*SFI
1120 392     SUM=SUM+XIN4
1121         GO TO 402
1122 393     IF(SUM-X2)394,394,397
1123 394     IF(M5)396,396,395
1124 395     J5=L5+J3-1
1125         XIN5=FLOAT(I(J5))*SFI
1126 396     SUM=SUM+XIN5
1127         GO TO 402
1128 397     IF(M6)400,400,399
1129 399     J6=L6+J3-1
1130         XIN6=FLOAT(I(J6))*SFI
1131 400     SUM=SUM+XIN6
1132 402     J7=L3+J3-1
1133         I(J7)=IFIX(XIN1*F*SFXX)
1134 403  CONTINUE
1135      I(L7)=IFIX(SUM*SFID)
1136      RETURN
1137C     STEREO OUTPUT BOX
1138 106  IF(M1)500,500,501
1139 500  IN1=I(L1)
1140 501  IF(M2)502,502,503
1141 502  IN2=I(L2)
1142 503  NSSAM=2*NSAM
1143
1144C     [page 5-4]
1145
1146C     6/29/70 L.C.SMITH
1147      ICT=0
1148      DO 510 J3=1,NSSAM,2
1149         IF(M1) 505,505,504
1150C     C*** 504 J4=L1+J3-1
1151 504     J4=L1+ICT
1152         IN1=I(J4)
1153 505     J5=L3+J3-1
1154         I(J5)=IN1+I(J5)
1155         IF(M2)507,507,506
1156C     C*** 506 J4=L2+J3-1
1157 506     J4=L2+ICT
1158         IN2=I(J4)
1159 507     J5=L3+J3
1160         I(J5)=IN2+I(J5)
1161 510  CONTINUE
1162      RETURN
1163C     ADD 3 BOX
1164 107  IF(M1)750,750,751
1165 750  IN1=I(L1)
1166 751  IF(M2)752,752,753
1167 752  IN2=I(L2)
1168 753  IF(M3)754,754,755
1169 754  IN3=I(L3)
1170 755  DO 780 J3=1,NSAM
1171         IF(M1)757,757,756
1172 756     J4=L1+J3-1
1173         IN1=I(J4)
1174 757     IF(M2)759,759,758
1175 758     J5=L2+J3-1
1176         IN2=I(J5)
1177 759     IF(M3)761,761,760
1178 760     J6=L3+J3-1
1179         IN3=I(J6)
1180 761     J7=L4+J3-1
1181         I(J7)=IN1+IN2+IN3
1182 780  CONTINUE
1183      RETURN
1184C     ADD 4 BOX
1185 108  IF(M1)850,850,851
1186 850  IN1=I(L1)
1187 851  IF(M2)852,852,853
1188 852  IN2=I(L2)
1189 853  IF(M3)854,854,855
1190 854  IN3=I(L3)
1191 855  IF(M4)856,856,857
1192 856  IN4=I(L4)
1193 857  DO 880 J3=1,NSAM
1194         IF(M1)859,859,858
1195 858     J4=L1+J3-1
1196         IN1=I(J4)
1197 859     IF(M2)861,861,860
1198 860     J5=L2+J3-1
1199         IN2=I(J5)
1200 861     IF(M3)863,863,862
1201 862     J6=L3+J3-1
1202         IN3=I(J6)
1203 863     IF(M4)865,865,864
1204 864     J7=L4+J3-1
1205         IN4=I(J7)
1206
1207C     [page 5-5]
1208
1209 865     J8=L5+J3-1
1210         I(J8)=IN1+IN2+IN3+IN4
1211 880  CONTINUE
1212      RETURN
1213C     MULTIPLIER
1214 109  IF(M1)900,900,901
1215 900  XIN1=FLOAT(I(L1))*SFI
1216 901  IF(M2)902,902,903
1217 902  XIN2=FLOAT(I(L2))*SFI
1218 903  DO 908 J=1,NSAM
1219         IF(M1)905,905,904
1220 904     J4=L1+J3-1
1221         XIN1=FLOAT(I(J4))*SFI
1222 905     IF(M2)907,907,906
1223 906     J5=L2+J3-1
1224         XIN2=FLOAT(I(J5))*SFI
1225 907     J6=L3+J3-1
1226         I(J6)=XIN1*XIN2*SFID
1227 908  CONTINUE
1228      RETURN
1229C     SET NEW FUNCTION IN OSC OR ENV
1230 110  ILOC=N1+6
1231      IF(I(N1+1).EQ.105) ILOC=N1+4
1232      IN1=I(3)+I(N1)-1
1233      IIN1=I(IN1)/IP(12)
1234      IF(IIN1)960,960,955
1235 955  I(ILOC)=-IP(2)-(IIN1-1)*IP(6)
1236 960  RETURN
1237C     RANDOM AND HOLD GENERATOR
1238 111  SUM=FLOAT(I(L4))*SFI
1239      IF(M1)910,910,911
1240 910  XIN1=FLOAT(I(L1))*SFI
1241 911  IF(M2)912,912,913
1242 912  XIN2=FLOAT(I(L2))*SFI
1243 913  IRN=I(L5)
1244      DO 940 J3=1,NSAM
1245         IF(M1)916,916,915
1246 915     J4=L1+J3-1
1247         XIN1=FLOAT(I(J4))*SFI
1248 916     IF(M2)918,918,917
1249 917     J5=L2+J3-1
1250         XIN2=FLOAT(I(J5))*SFI
1251 918     IF(SUM-XNFUN)920,919,919
1252 919     SUM=SUM-XNFUN
1253         I(7)=IABS(I(7)*IMULT)
1254         RN=(2.*FLOAT(I(7))*SFF-1.)
1255 920     J7=L3+J3-1
1256         I(J7)=XIN1*RN*SFID
1257         SUM=SUM+XIN2
1258 940  CONTINUE
1259      I(L4)=IFIX(SUM*SFID)
1260      I(L5)=IRN
1261      RETURN
1262      END
1263
1264C     [page 6-1]
1265
1266C     GEN1 FUNCTION GENERATOR 1
1267C     *** MUSIC V ***
1268      SUBROUTINE GEN1
1269      DIMENSION I(15000),P(100),IP(20)
1270      COMMON I,P/PARM/IP
1271      N1=IP(2)+(IFIX(P(4))-1)*IP(6)
1272      M1=7
1273      SCLFT=IP(15)
1274 102  IF(P(M1+1))103,103,100
1275 100  V1=P(M1-2)*SCLFT
1276      V2=(P(M1)-P(M1-2))/(P(M1+1)-P(M1-1))*SCLFT
1277      MA=N1+IFIX(P(M1-1))
1278      MB=N1+IFIX(P(M1+1))-1
1279      DO 101 J=MA,MB
1280         XJ=J-MA
1281 101     I(J)=V1+V2*XJ
1282      IF(IFIX(P(M1+1)).EQ.(IP(6)-1))GO TO 103
1283      M1=M1+2
1284      GO TO 102
1285 103  I(MB+1)=P(M1)*SCLFT
1286      RETURN
1287      END
1288C     GEN2 FUNCTION GENERATOR 2
1289c     *** MUSIC V ***
1290      SUBROUTINE GEN2
1291      DIMENSION I(15000),P(100),IP(20),A(7000)
1292      COMMON I,P/PARM/IP
1293      EQUIVALENCE(I,A)
1294      SCLFT=IP(15)
1295      N1=IP(2)+(IFIX(P(4))-1)*IP(6)
1296      N2=N1+IP(6)-1
1297      DO 101 K1=N1,N2
1298 101     A(K1)=0.0
1299      FAC=6.283185/(FLOAT(IP(6))-1.0)
1300      NMAX=I(1)
1301      N3=5+INT(ABS(P(NMAX)))-1
1302      IF(N3-5)104,100,100
1303 100  DO 103 J=5,N3
1304         FACK=FAC*FLOAT(J-4)
1305         DO 102 K=N1,N2
1306 102        A(K)=A(K)+SIN(FACK*FLOAT(K-N1))*P(J)
1307 103     CONTINUE
1308 104  N4=N3+1
1309      N5=I(1)-1
1310      IF(N5-N4)114,105,105
1311 105  DO 107 J1=N4,N5
1312         FACK=FAC*FLOAT(J1-N4)
1313         DO 106 K1=N1,N2
1314 106        A(K1)=A(K1)+COS(FACK*FLOAT(K1-N1))*P(J1)
1315 107     CONTINUE
1316 114  CONTINUE
1317      IF(P(NMAX))112,112,108
1318 108  FMAX=0.0
1319      DO 110 K2=N1,N2
1320         IF(ABS(A(K2))-FMAX)110,110,109
1321 109     FMAX=ABS(A(K2))
1322 110  CONTINUE
1323 113  DO 111 K3=N1,N2
1324 111     I(K3)=(A(K3)*SCLFT*.99999)/FMAX
1325      RETURN
1326
1327C     [page 6-2]
1328
1329 112  FMAX=.99999
1330      GO TO 113
1331      END
1332C     GEN3 FUNCTION GENERATOR 3
1333C     *** MUSIC V ***
1334C     ASSUMPTIONS--P(4) = THE NUMBER OF THE FUNCTION TO BE GENERATED,
1335C     I(1) = WORD COUNT FOR CURRENT DATA RECORD
1336C     P(5) = THE BEGINNING THE THE LIST OF DESCRIPTION NUMBERS
1337C     IP(2) = THE BEGINNING SUBSCRIPT FOR FUNCTIONS IN THE I ARRAY,
1338C     IP(6) = THE LENGTH OF THE FUNCTIONS
1339C     IP(15) = SCALE FACTOR FOR STORED FUNCTIONS
1340C
1341      SUBROUTINE GEN3
1342      COMMON I(15000),P(100) /PARM/ IP(20)
1343      N=I(1)-5
1344      NL=5
1345      SCLFT=IP(15)
1346      LL=IP(6)
1347      RMIN=0
1348      RMAX=0
1349      NR=NL+N
1350      DO 10 J=NL,NR
1351         IF(P(J).GT.RMAX) RMAX=P(J)
1352 10      IF(P(J).LT.RMIN) RMIN=P(J)
1353      DIV=AMAX1(ABS(RMIN),ABS(RMAX))
1354      N1 = IP(2) + (IFIX(P(4))-1)*IP(6)
1355      I(N1)=(P(NL)/DIV)*SCLFT
1356      LAST=N1
1357      DO 100 J=1,N
1358         LL = LL-LL/(N-J+1)
1359         IX = N1+IP(6)-LL-1
1360         IX2 = NL+J
1361         I(IX)=(P(IX2)/DIV)*SCLFT
1362         DELTA=FLOAT(I(IX))-FLOAT(I(LAST))
1363         NR = IX-LAST-1
1364         SEG = NR+1
1365         HNCR=DELTA/SEG
1366         DO 50 K=1,NR
1367            IX2 = LAST+K
1368 50         I(IX2)=FLOAT(I(IX2-1))+HNCR
1369 100     LAST=IX
1370      RETURN
1371      END
1372C     DATA3 PASS 3 DATA INPUTING ROUTINE
1373C     *** MUSIC V ***
1374      SUBROUTINE DATA(N)
1375      COMMON I(15000),P(100)
1376      READ(N) K,(P(J),J=1,K)
1377      I(1)=K
1378      RETURN
1379      END
1380C     PARM CONTROL DATA SPECIFICATION FOR PASS 3
1381C     *** MUSIC V ***
1382C
1383C     IP(1) = NUMBER OF OP CODES
1384C     IP(2) = BEGINNING SUBSCRIPT OF FIRST FUNCTION
1385C     IP(3) = STANDARD SAMPLING RATE
1386C     IP(4) = BEGINNING SUBSCRIPT OF INSTRUMENT DEFINITIONS
1387C     IP(5) = BEGINNING OF LOCATION TABLE FOR INSTRUMENT DEFINITIONS
1388C     IP(6) = LENGTH OF FUNCTIONS
1389
1390C     [page 6-3]
1391
1392C     IP(7) = BEGINNING OF NOTE CARD PARAMETERS
1393C     IP(8) = LENGTH OF NOTE CARD PARAMETER BLOCKS
1394C     IP(9) = NUMBER OF NOTE CARD PARAMETER BLOCKS
1395C     IP(10) = BEGINNING OF OUTPUT DATA BLOCK
1396C     IP(11) = SOUND ZERO (SILENCE VALUE)
1397C     IP(12) = SCALE FACTOR FOR NOTE CARD PARAMETERS
1398C     IP(13) = BEGINNING OF GENERATOR INPUT-OUTPUT BLOCKS
1399C     IP(14) = LENGTH OF GENERATOR INPUT-OUTPUT BLOCKS
1400C     IP(15) = SCALE FACTOR FOR FUNCTIONS
1401C
1402      BLOCK DATA
1403      COMMON /PARM/IP(20)
1404      DATA IP/12,512,10000,14500,14400,512,13000,35,40,6657,2048,
1405     1     "1000000,6657,512,"377777777777,5*0/
1406C**** BIG NUMB. IS IBM360'S BIGGEST. 1  65536,6657,512,Z7FFFFFFF/
1407      END
1408C**** SUBROUTINE DUM
1409C**** ENTRY SAMGEN
1410C**** ENTRY GEN4
1411C**** ENTRY GEN5
1412C**** END
1413      SUBROUTINE SAMGEN
1414      RETURN
1415      END
1416      SUBROUTINE GEN4
1417      END
1418      SUBROUTINE GEN5
1419      END
1420C     **** DUMMY SUBROUTINES ****
1421
1422
1423      SUBROUTINE FROUT3(IDSK)
1424C     TERMINATE OUTPUT
1425      INTEGER PEAK
1426      COMMON I(15000),P(100)/PARM/IP(20)/FINOUT/PEAK,NRSOR
1427      K=IP(10)
1428      L=IP(10)+IP(14)-1
1429      DO 1 J=K,L
1430 1       I(J)=0
1431      CALL SAMOUT(IDSK,IP(14))
1432C     REWIND NWRITE
1433C     WRITE(6,10) PEAK,NRSOR
1434      TYPE 10,PEAK,NRSOR
1435C     CALL EXIT
1436      IF(IDSK.LT.0)CALL EXIT
1437      J=IP(10)
1438      L=J+1024
1439      DO 2 K=J,L
1440 2       I(K)=0
1441C     WILL WRITE 1024 0'S ON DSK.
1442      CALL FASTOUT(I(J),1024)
1443      CALL FINFILE
1444      CALL EXIT
1445 10   FORMAT ('0PEAK AMPLITUDE WAS',I8/'0NUMBER OF SAMPLES OUT OF RANGE WAS',I8)
1446      END
1447
1448
1449C     DSMOUT DEBUG SAMOUT
1450C     *** MUSIC V ***
1451
1452C     [page 6-4]
1453
1454C     DEBUG SAMOUT
1455      SUBROUTINE SAMOUT(IDSK,N)
1456      DIMENSION IDBUF(2000),MS(3)
1457C***  IDSK IS FLAG TO WRITE SAMPLES ON DSK -- PDP ****
1458C***  IDBUF WILL STORE PACKED SAMPLES. ****
1459      DIMENSION I(15000),T(10),P(100),IP(20)
1460      COMMON I,P/PARM/IP/FINOUT/PEAK,NRSOR
1461      INTEGER PEAK
1462      IF(IDSK.GE.0) GO TO 99
1463      N1=N
1464      PRINT 100,N1
1465 100  FORMAT(7H OUTPUTI6,8H SAMPLES)
1466      N2=IP(10)-1
1467      N3=10
1468      GO TO 104
1469 106  DO 101 L=1,10
1470         J=N2+L
1471 101     T(L)=FLOAT(I(J))/FLOAT(IP(12))
1472      PRINT 102, (T(K),K=1,N3)
1473 102  FORMAT(1H 10F11.4)
1474      N2=N2+10
1475      N1=N1-10
1476      IF(N1)103,103,104
1477 103  RETURN
1478 104  IF(N1-10)105,106,106
1479 105  N3=N1
1480      GO TO 106
1481
1482 99   J=IDSK+1
1483      M1=IP(10)
1484      M2=0
1485      ISC=IP(12)
1486      IDSK=IDSK+N
1487C     COUNTS SAMPLES TO DATE
1488      DO 1 K=J,IDSK
1489         N1=I(M1+M2)/ISC
1490         IF(N1.GT.PEAK)PEAK=N1
1491         IDBUF(K)=N1
1492 1       M2=M2+1
1493      IF(IDSK.LT.768)RETURN
1494
1495      KL=0
1496      DO 2 K=1,768,3
1497         KL=KL+1
1498         KJ=K-1
1499         MS(1)=IDBUF(K)
1500         IF(MS(1).EQ.2048) MS(1)=2047
1501C     A 2048 IN THE 12 LEFT HAND BITS CREATES PROBLEMS
1502         DO 3 L=2,3
1503            MS(L)=IDBUF(KJ+L)
1504 3          IF(MS(L).LT.0) MS(L)=4096+MS(L)
1505 2       IDBUF(KL)=MS(3)+MS(2)*4096+MS(1)*16777216
1506C     PACKS 3 SMPLS TO A 36-BIT WORD. 4096=2**12, 16---=2**24.
1507C     MS(1) HAS LEFT HAND 12 BITS; MS(2), MIDDLE 12 BITS; MS(3), RIGHT 12.
1508C     NEGATIVE NUMBERS RUN FROM 4096(I.E. -1) TO 2049(I.E. -2048).
1509      CALL FASTOUT(IDBUF(1),256)
1510      J=IDSK-768
1511      IF(J.LT.1) GO TO 4
1512      DO 5 K=1,J
1513 5       IDBUF(K)=IDBUF(768+K)
1514
1515C     [page 6-5]
1516
1517 4    IDSK=J
1518      RETURN
1519      END
1520
1521C     ERROR1 GENERAL ERROR ROUTINE
1522C     *** MUSIC V ***
1523      SUBROUTINE ERROR(I)
1524      PRINT 100,I
1525 100  FORMAT(' ERROR OF TYPE',I5)
1526      RETURN
1527      END
1528
1529
1530
1531
1532
1533