C
C   TRANSFORMATION SUBROUTINE
C
      SUBROUTINE TRAN(NTZ)
      LOGICAL B(3),LTPEN,F
      REAL DM2(110),DME(110),DUR(10)
      INTEGER SDUR(10),NTZ(7)
      INTEGER MP1(75,2),MP2(75,2),MP3(75,2),MP4(75,2)
      INTEGER THM1(200,3),THM2(200,3),THM3(200,3),OUTP(200,3)
      CHARACTER*3 ZZ,AA,BB,CC,AD,END/'END'/,MSG*30
      CHARACTER*3 NUR(10),NME(110),TRG(5)
      CHARACTER FOR*2(2)/'(I','4)'/
      CHARACTER TWO*3(2)/'(A3','0)'/
      COMMON DME,DUR
      COMMON/AAA/SDUR,NB,NGB
      COMMON/BBB/NME,NUR,TRG
      COMMON/CCC/ITAG,LTPEN,IX,IY
      COMMON/DDD/THM3,NST2
      COMMON/EEE/THM1,THM2,OUTP
      COMMON/FFF/MP1,MP2,MP3,MP4,DM2
      COMMON/HHH/TIN,BIN
      F=.FALSE.
      GO TO 73
C   COPY THM1 TO THM2
  550 CALL MOV(THM1,MP1,THM2,MP2)
   73 CONTINUE
      IF(NR.EQ.2)GO TO 579
  500 NMAX=16
      NNV=0
      NNU=0
      NTF=0
      ZZ='CHF'
      CALL NCRT(ZZ,NTF,NMAX)
      WRITE(7)F,F,F
C   SET COUNTER TO GO THROUGH LIST TWICE IF WE NEED TWO MOTIVES
      IF(NTF.EQ.11)NNU=1
      IF(NTF.EQ.16)GO TO 550
      IF(NTF.EQ.15)GO TO 80
C   ROUTINE TO SET UP VARIABLE SIZED CRT REQUEST
  579 WRITE(7)F,F,F
      CALL CLEAR(.TRUE.)
      IX=100
      IY=1010
      NAS=MP2(75,1)
C   PUT MOTIVE NUMBERS ON CRT
      DO 593 I=1,NAS
      CALL TEXT(2,I,IX,IY,7,1,FOR,I)
  593 IY=IY-35
      NS=I
      MSG='     ALL'
      CALL TEXT(2,I,IX,IY,7,1,TWO,MSG)
      I=I+1
      NT=I
      MSG='NEW TRANSFORMATION (EXIT)'
      IY=IY-35
      CALL TEXT(2,I,IX,IY,7,1,TWO,MSG)
      I=I+1
      MSG='  WHICH MOTIVE?'
      IY=IY-60
      CALL TEXT(2,I,IX,IY,7,2,TWO,MSG)
      I=I+1
      MSG='  (INDICATE WITH LIGHT PEN)'
      IY=IY-60
      CALL TEXT(2,I,IX,IY,7,2,TWO,MSG)
      N=99
      CALL NCRT(ZZ,N,NT)
      NMO=N
      IF(N.EQ.NT)GO TO 73
      IF(N.NE.NS)GO TO 554
C   CHECK IF 'ALL' OPTION IS VALID FOR THIS TRANSFORMATION
C   NTZ CONTAINS A LIST OF TRANSFORMATIONS FOR WHICH
C   OPTION 'ALL' IS NOT VALID
      DO 210 I=1,7
  210 IF(NTZ(I).EQ.NTF)GO TO 579
      NTB=1
      NTE=MP2(75,2)
      GO TO 555
  554 NTB=MP2(NMO,1)
      NTE=MP2(NMO,1)+MP2(NMO,2)-1
  555 IF(NNU.EQ.1)GO TO 663
  662 IF(NTF.GT.7)GO TO 553
      GO TO(501,502,503,504,505,508,507),NTF
  553 NTD=NTF-7
      GO TO (508,509,511,512,513,515,514),NTD
C   BRING IN 2ND MOTIVE POINTERS
  663 IF(NNV.NE.0)GO TO 664
      NTB1=NTB
      NTE1=NTE
      NNV=1
      GO TO 579
  664 NNV=0
      GO TO 662
C
C   TRANSPOSE UP OR DOWN AND PUT IN THM3
C
  501 NMAX=11
      N=0
      ZZ='CHE'
      CALL NCRT(ZZ,N,NMAX)
      NTRN=N-6
      CALL MOV(THM2,MP2,THM3,MP3)
      DO 143 I=NTB,NTE
      IF(THM2(I,1).EQ.1)GO TO 143
      THM3(I,1)=THM2(I,1)+NTRN
  143 CONTINUE
      GO TO 980
C
C   EXPANSION AND CONTRACTION
C
  502 NE=1
      GO TO 556
  503 NE=-1
  556 NAV=0
      CALL MOV(THM2,MP2,THM3,MP3)
      NX=0
C   FIND AVERAGE OF TONES
      DO 557 I=NTB,NTE
      IF(THM3(I,1).EQ.1)GO TO 557
      NX=NX+1
      NAV=NAV+THM3(I,1)
  557 CONTINUE
      NAV=NAV/NX
      NMAX=4
      ME=0
      ZZ='CHG'
      IF(NE.EQ.-1)ZZ='CHH'
      CALL NCRT(ZZ,ME,NMAX)
      IF(ME.EQ.4)GO TO 500
C   READ # OF SEMITONES
      NMAX=15
      N=777
      ZZ='CHJ'
      CALL NCRT(ZZ,N,NMAX)
      MSG='  # OF SEMITONES?'
      I=40
      IX=100
      IY=400
      CALL TEXT(2,I,IX,IY,7,2,TWO,MSG)
      I=50
      IY=300
      MSG='  (USE LIGHT PEN)'
      CALL TEXT(2,I,IX,IY,7,2,TWO,MSG)
      NST=99
      CALL NCRT(ZZ,NST,NMAX)
      IF(ME.EQ.2)GO TO 559
      DO 558 I=NTB,NTE
      IF(THM3(I,1).EQ.1)GO TO 558
      IF(THM3(I,1).GT.NAV)THM3(I,1)=THM3(I,1)+NST*NE
  558 CONTINUE
      IF(ME.EQ.1)GO TO 561
  559 DO 560 I=NTB,NTE
      IF(THM3(I,1).EQ.1)GO TO 560
      IF(THM3(I,1).LT.NAV)THM3(I,1)=THM3(I,1)-NST*NE
  560 CONTINUE
  561 CONTINUE
      GO TO 980
C
C   AUGMENTATION AND DIMINUTION
C
C   AUGMENT
  504 CALL MOV(THM2,MP2,THM3,MP3)
      NE=1
      DO 721 I=NTB,NTE
      NNA=THM3(I,2)
      IF((NNA.LT.4).OR.(NNA.GT.8))GO TO 693
      NS=-2
      GO TO 721
  693 IF(NNA.GT.1)GO TO 694
      NS=0
      GO TO 721
  694 NS=-1
  721 THM3(I,2)=THM3(I,2)+NS
      GO TO 695
C   DIMINISH
  505 CALL MOV(THM2,MP2,THM3,MP3)
      NE=4
      DO 594 I=NTB,NTE
      NNA=THM3(I,2)
      IF((NNA.GT.6).OR.(NNA.LT.2))GO TO 696
      NS=2
      GO TO 594
  696 IF(NNA.LT.10)GO TO 697
      NS=1
      GO TO 594
  697 NS=0
  594 THM3(I,2)=THM3(I,2)+NS
  695 DO 573 I=1,NTE
      DO 573 J=1,3
  573 OUTP(I,J)=THM3(I,J)
      NRY=MP3(75,2)
      IF(NE.NE.1)GO TO 577
      NRZ=NTE+1
      GO TO 578
  577 NRZ=NTE+1
      OUTP(NRZ,1)=1
      NRX=NB/4
      NRX=NRX*DUR(NGB)
      DO 574 I=1,10
  574 IF(NRX.EQ.DUR(I))GO TO 575
C   NOTE NAME NOT FOUND
      GO TO 80
  575 OUTP(NRZ,2)=I
      OUTP(NRZ,3)=3
  578 DO 576 I=NRZ,NRY
      K=I+1
      IF(NE.EQ.1)K=I
      DO 576 J=1,3
  576 OUTP(K,J)=THM3(I,J)
      NAS=MP3(75,2)
      IF(NE.EQ.4)NAS=NAS+1
      CALL TRM(NAS,OUTP,THM3,MP3)
      GO TO 980
C
C   OMIT ONE NOTE IN MOTIVE
C
  507 CALL MOV(THM2,MP2,THM3,MP3)
      NMAX=0
      N=777
      CALL NCRT('CHP',N,NMAX)
      IX=100
      IY=800
      IN=MP2(NMO,2)+10
      DO 211 I=11,IN
      IS=I-10
      CALL TEXT(2,I,IX,IY,7,2,FOR,IS)
  211 IY=IY-60
      N=99
      NMAX=I
      CALL NCRT('CHP',N,NMAX)
      N=N-10
      IF(N.LT.0)GO TO 507
      NMA=MP2(NMO,1)-1+N
      THM3(NMA,1)=1
      GO TO 980
C
C   REPETITION OR CHANGE OF ORDER OF TONES
C
  508 CALL MOV(THM2,MP2,THM3,MP3)
      IN=MP2(NMO,2)
      IM=IN+50
      DO 215 I=1,IN
      NMAX=0
      N=777
      CALL NCRT('CHQ',N,NMAX)
      ITAG=50
      CALL TEXT(2,ITAG,200,700,7,3,FOR,I)
      IY=400
      DO 212 J=51,IM
      JS=J-50
      CALL TEXT(2,J,100,IY,7,2,FOR,JS)
  212 IY=IY-55
  213 N=99
      NMAX=70
      CALL NCRT('CHQ',N,NMAX)
      IF(N.LT.51)GO TO 213
      N=N-51
      INT=MP2(NMO,1)-1+I
      INS=MP2(NMO,1)+N
      DO 214 J=1,3
  214 THM3(INT,J)=THM2(INS,J)
  215 CONTINUE
      GO TO 980
C
C   REVERSE ORDER OF TONES WITHOUT CHANGING ORDER OF DURATIONS
C
  509 CALL MOV(THM2,MP2,THM3,MP3)
      DO 540 I=NTB,NTE
      N1=NTE+NTB-I
      THM3(I,1)=THM2(N1,1)
      THM3(I,2)=THM2(I,2)
  540 THM3(I,3)=THM2(I,3)
      GO TO 980
C
C   INVERSION
C
  511 CALL MOV(THM2,MP2,THM3,MP3)
      DO 930 I=NTB,NTE
C   CONSIDER THE CASE WHEN ONE OF THE NOTES IS A REST
      IF(THM2(I+1,1).EQ.1)GO TO 930
      IF(THM2(I,1).EQ.1)GO TO 930
      NNS=THM2(I+1,1)-THM2(I,1)
      NO=I+1
      IF(NO.GT.NTE)GO TO 930
      THM3(I+1,1)=THM3(I,1)-NNS
  930 CONTINUE
      GO TO 980
C
C   INTERCHANGE TWO MOTIVES
C
C   FIND WHICH IS FIRST IN THE PERIOD
  512 NIB=NTB1
      NIE=NTE1
      N2B=NTB
      N2E=NTE
      IF(NTB.GT.NTB1)GO TO 665
      NIB=NTB
      NIE=NTE
      N2B=NTB1
      N2E=NTE1
  665 NX=NIB-1
      L1=NIE-NIB+1
      L2=N2E-N2B+1
      I=1
      IF(NX.EQ.0)GO TO 10
C   COPY UP TO FIRST MOTIVE
      DO 666 I=1,NX
      DO 666 J=1,3
  666 THM3(I,J)=THM2(I,J)
C   COPY IN 2ND MOTIVE
   10 DO 667 K=N2B,N2E
      DO 921 J=1,3
  921 THM3(I,J)=THM2(K,J)
  667 I=I+1
      NX=N2B-1
      NY=NIE+1
C   COPY UP TO 2ND MOTIVE
      DO 668 K=NY,NX
      DO 922 J=1,3
  922 THM3(I,J)=THM2(K,J)
  668 I=I+1
C   COPY IN 1ST MOTIVE
      DO 669 K=NIB,NIE
      DO 923 J=1,3
  923 THM3(I,J)=THM2(K,J)
  669 I=I+1
      NY=MP2(75,2)
      NX=N2E+1
C   COPY TO END OF PERIOD
      DO 670 K=NX,NY
      DO 924 J=1,3
  924 THM3(I,J)=THM2(K,J)
  670 I=I+1
      NX=I-1
      CALL TRM(NX,THM3,OUTP,MP4)
      CALL MOV(OUTP,MP4,THM3,MP3)
      GO TO 980
C
C   ELIMINATE A MOTIVE
C
  513 NX=NTB-1
      DO 660 I=1,NX
      DO 660 J=1,3
  660 THM3(I,J)=THM2(I,J)
      NY=NTE+1
      NAS=MP2(75,2)
      DO 661 K=NY,NAS
      DO 920 J=1,3
  920 THM3(I,J)=THM2(K,J)
  661 I=I+1
      NZ=I-1
      CALL TRM(NZ,THM3,OUTP,MP4)
      CALL MOV(OUTP,MP4,THM3,MP3)
      GO TO 980
C
C   EDIT A MOTIVE
C
  514 NMAX=0
      N=777
      CALL NCRT('CHS',N,NMAX)
      NSU=0
      IX=100
      IY=800
      IN=MP2(NMO,2)+10
      DO 800 I=11,IN
      IS=I-10
      CALL TEXT(2,I,IX,IY,7,2,FOR,IS)
  800 IY=IY-60
      N=99
      NMAX=I
      CALL NCRT('CHS',N,NMAX)
      N=N-10
      IF(N.LT.0)GO TO 807
      NMA=MP2(NMO,1)-1+N
  804 AA=NME(THM2(NMA,1))
      CC=TRG(THM2(NMA,3))
      BB=NUR(THM2(NMA,2))
      CALL CLEAR(.TRUE.)
      NMAX=0
      N=777
      CALL NCRT('CHT',N,NMAX)
      IX=100
      IY=700
      I=11
      CALL TEXT(2,I,IX,IY,7,2,TWO,AA)
      IY=IY-60
      I=12
      CALL TEXT(2,I,IX,IY,7,2,TWO,BB)
      IY=IY-60
      I=13
      CALL TEXT(2,I,IX,IY,7,2,TWO,CC)
      NMAX=13
      N=99
      CALL NCRT('CHT',N,NMAX)
      IF(N.LT.11)GO TO 514
      N=N-10
      GO TO (801,802,803),N
C   COMPOSER WANTS TO CHANGE NOTE PITCH VALUE
  801 NMAX=0
      N=777
      CALL NCRT('CHU',N,NMAX)
      READ(4,*)AD
      DO 805 I=1,98
      IF(AD.EQ.NME(I))GO TO 806
  805 IF(AD.EQ.END)GO TO 804
C   NOTE NAME NOT FOUND IN NME
      GO TO 804
  806 THM2(NMA,1)=I
      GO TO 804
C   COMPOSER WANTS TO CHANGE NOTE DURATION
  802 NMAX=12
      N=0
      CALL NCRT('CHV',N,NMAX)
      IF(N.GT.10)GO TO 804
      THM2(NMA,2)=N
C   NSU LETS YOU KNOW IF ANY CHANGES WERE MADE TO DURATION
      NSU=99
      GO TO 804
C   COMPOSER WANTS TO CHANGE NOTE MODIFIER
  803 NMAX=6
      N=0
      CALL NCRT('CHW',N,NMAX)
      IF(N.GT.4)GO TO 804
      THM2(NMA,3)=N
       GO TO 804
C   CHECK IF MOTIVES HAVE TO BE RECALCULATED BEFORE EXITING
  807 IF(NSU.NE.99)GO TO 808
      NXR=MP2(75,2)
      CALL TRM(NXR,THM2,THM3,MP3)
      CALL MOV(THM3,MP3,THM2,MP2)
  808 GO TO 579
C
C   LIST MOTIVE
C
  515 WRITE(4,*)'MOTIVE # ',NMO
      DO 516 I=NTB,NTE
  516 WRITE(4,206)NME(THM2(I,1)),NUR(THM2(I,2)),TRG(THM2(I,3))
      GO TO 500
C
C   CHECK TRANSFORMED THEME BEFORE COPYING BACK TO THM2
C
C   THIS WILL CONTINUE PLAYING UNTIL A DECISION IS MADE
C   CHECK IF IT IS INSIDE INSTRUMENT RANGE
  980 NAS=MP3(75,2)
      DO 644 I=1,NAS
      IF(THM3(I,1).GT.TIN)GO TO 902
      IF(THM3(I,1).LT.BIN)GO TO 902
  644 CONTINUE
C   CHECK IF TRANSFORMATION IS OK
  645 NMAX=2
      N=777
      LTPEN=.FALSE.
      ZZ='CHK'
      CALL CLEAR(.TRUE.)
      CALL NCRT(ZZ,N,NMAX)
  562 CALL BACK(NAS,THM3)
      IF(LTPEN)GO TO 722
      GO TO 562
  722 IF(ITAG.GT.NMAX)GO TO 645
      IF(ITAG.EQ.2)GO TO 579
  563 CALL MOV(THM3,MP3,THM2,MP2)
      GO TO 579
  902 NMAX=2
      N=0
      ZZ='CHM'
      CALL NCRT(ZZ,N,NMAX)
      IF(N.EQ.1)GO TO 645
      GO TO 579
  206 FORMAT(3(1X,A3))
   80 RETURN
      END