Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/bmd/bmd01t.for
There is 1 other file named bmd01t.for in the archive. Click here to see a list.
CBD01T        AMPLITUDE AND PHASE ANALYSIS          AUGUST  9, 1965
C        THIS IS A SIFTED VERSION OF BMD01T ORIGINALLY WRITTEN IN
C        FORTRAN II. SOME MODIFICATIONS WERE MADE TO MAKE IT OPERABLE
C        AND SLIGHTLY MORE EFFICIENT THAN THE SIFTED VERSION.
          DIMENSION X(350),FMT(36),YSQ(80),Y(80),SYM(15),YP(15),
     1A(350),B(350),XX(350),YY(350)
      COMMON  X      , FMT    , YSQ    , Y      , SYM    , YP
      COMMON  A      , B      , XX     , YY     , AMPL   , PHASE
      COMMON  TG     , FILTER , KPROB  , NDATA  , FTRI   , NTRI
      COMMON  M      , FM     , NPOINT , POINT  , WO     , ANS
      COMMON  PI     , H
C         DIMENSION X(800),FMT(120),YSQ(500),Y(500),SYM(15),YP(15),
C    1A(800),B(800),XX(800),YY(800)
C     COMMON X,FMT,YSQ,Y,SYM,YP,A,B,XX,YY,AMPL,PHASE,TG,FILTER,KPROB,
C    1NDATA,FTRI,NTRI,M,FM,NPOINT,POINT,WO,ANS,PI,H
C
  305 FORMAT(52H1BMD01T - AMPLITUDE AND PHASE ANALYSIS - VERSION OF ,
     115HAUGUST  9, 1965/
     2 40H HEALTH SCIENCES COMPUTING FACILITY,UCLA/
     314H PROBLEM CODE A6,/
     423H NUMBER OF DATA POINTS I5,///)
C
	DOUBLE PRECISION A123,B123,TODE,CODE
      DATA A123/'FINISH  '/,B123/'PROBLM  '/
      DATA Q002HL/4HYES /
      DATA Q003HL/4H*000/
      YES =(+Q002HL)
      NTAPE=5
	CALL USAGEB('BMD01T')
  304 FORMAT('0CONTROL CARD WAS INCORRECTLY ORDERED OR PUNCHED. IT IS '
     1 'PRINTED BELOW AND PROGRAM HAS BEEN TERMINATED.')
 5001 FORMAT(2A6,4A3,I3,I4,I3,I4,I3,F5.0,22X,2I2)
 5002 FORMAT (1H0,2A6,4A3,I3,I4,I3,I4,I3,F5.0,22X,2I2)
  500 READ (5,5001)TODE,CODE,XG,XDATA,ELTER,XOOL,KPROB,NDATA,NTRI,M,
     1NPOINT,WO,INFORM,KVR
      IF(TODE.EQ.B123) GO TO 20
      IF(TODE.EQ.A123) GO TO 303
  302 CONTINUE
      WRITE (6,3040)
 3040 FORMAT ( '0A ''PROBLM'' OR ''FINISH'' CARD WAS EXPECTED.' )
      WRITE (6,304)
      WRITE (6,5002) TODE,CODE,XG,XDATA,ELTER,XOOL,KPROB,NDATA,NTRI,M,
     1 NPOINT,WO,INFORM,KVR
  303 IF(NTAPE-5)372,372,371
  371 REWIND NTAPE
  372 WRITE(6,3722)
 3722 FORMAT (1H0 / / '0 FINISH CARD ENCOUNTERED.' )
      STOP
   20 CALL TPWD(INFORM,NTAPE)
      WRITE (6,305)CODE,NDATA
      IF(-NTRI)25,302,302
   25 FTRI=NTRI
      IF(M-350)255,255,302
  255 FM=M
      PI=3.14159265
      CRIT=(FM-2.0)/2.0
      IF(CRIT-FTRI)  11,11,12
   11 DO 90 I=1,6
   90 WRITE (6,2000)
      WRITE (6,1011)KPROB
 1011 FORMAT(10X,5H* * */10X,28HBANDWIDTH CHOSEN IN PROBLEM I3,
     1 50H LARGER THAN PI, PROGRAM GOES TO NEXT PROBLEM CARD/10X,5H* * *
     2)
      PI=-4000
   12 IF(KVR.GT.0.AND.KVR.LE.2) GO TO 210
      WRITE (6,4000)
 4000 FORMAT(1H0,23X,71HNUMBER OF VARIABLE FORMAT CARDS INCORRECTLY SPEC
     XIFIED, ASSUMED TO BE 1.)
      KVR = 1
  210 KVR=KVR*18
      READ (5,5003)(FMT(I),I=1,KVR)
 5003 FORMAT(18A4)
      WRITE (6,5005) (FMT(I),I=1,KVR)
 5005 FORMAT ('0VARIABLE FORMAT USED IS PRINTED BELOW.'/(1H0, 18A4))
      IF((NDATA-49)*(NDATA-351))215,302,302
  215 MISTAK=0
      READ (NTAPE,FMT)(X(I),I=1,NDATA)
      IF(-PI)40,500,500
   40 IF(XG.NE.YES) GO TO 30
   45 CALL TRANS( MISTAK)
      IF( MISTAK) 500,30,500
   30 IF(XDATA.NE.YES) GO TO 60
   65 WRITE (6,2000)
      WRITE (6,1017)KPROB
 1017 FORMAT(10X,25HORIGINAL DATA OF PROBLEM I3//)
      WRITE (6,1018)(X(I),I=1,NDATA)
 1018 FORMAT(10F12.6)
   60 IF(ELTER.NE.YES) GO TO 126
   95 POINT=NPOINT
      IF(50-NPOINT)951,951,302
  951 IF(WO*(WO-PI))955,955,96
  955 H=PI/POINT
      G=(FTRI+1.0)*2.0*PI/FM
      BONE=WO-.5*G
      IF(BONE) 96,96,97
   96 WRITE (6,1019)KPROB
 1019 FORMAT(10X,49H*****THE MAIN LOBE OF THE FILTER OF THIS PROBLEM(I3,
     166H) IS NOT BETWEEN 0 AND PI,PROGRAM GOES TO THE NEXT PROBLEM, IF 
     2ANY)
      GO TO 500
   97 NONE=(BONE/H)+0.5
      WRITE (6,800)
  800 FORMAT(1H1)
      CALL LANAI (NONE,0.0,0)
      AA=ANS
  100 WRITE (6,2000)
 2000 FORMAT(1H0)
      ZERO=0.0
      WRITE (6,1002)ZERO,BONE,AA
 1002 FORMAT(10X,38HVALUE OF INTEGRAL OF F(X) SQUARE FROM F10.5,
     14H TO F10.5,3H = F10.5//)
      BTWO=WO+.5*G
      IF(BTWO-PI) 101,101,102
  102 WRITE (6,1019)KPROB
      GO TO 500
  101 NTWO=(G/H)+0.5
      CALL LANAI (NTWO,BONE,NONE)
      BB=ANS
  105 WRITE (6,2000)
      WRITE (6,1002)BONE,BTWO,BB
      NTHREE=((PI-BTWO)/H)+0.5
      KK=NONE+NTWO
      CALL LANAI(NTHREE,BTWO,KK)
      CC=ANS
  110 WRITE (6,2000)
      WRITE (6,1002)BTWO,PI,CC
      PC=(AA+CC)*100.0/(AA+BB+CC)
      WRITE (6,1006)
 1006 FORMAT(1H0,9X,10HRESOLUTION7X,16HNO. OF TRIANGLES9X,11HCENTERED AT
     18X,9HBANDWIDTH,10X,19HLEAKAGE IN PER CENT//)
      WRITE (6,1008)M,NTRI,WO,G,PC
 1008 FORMAT(13X,I3,18X,I3,15X,F11.8,8X,F10.7,12X,F12.8)
  115 WRITE (6,2000)
      WRITE (6,1005)
 1005 FORMAT(1H0,9X,34HTHESE ARE THE VALUES OF THE FILTER//)
      NPOINT=NONE+NTWO+NTHREE
      POINT=NPOINT-1
      WRITE (6,1007)(Y(I),I=1,NPOINT)
 1007 FORMAT(7F12.6)
      WRITE (6,1010)
 1010 FORMAT(1H1,20X,19HGRAPH OF THE FILTER//)
      YMAX=-10**10
      YMIN=10**10
      DO 120 I=1,NPOINT
      YMAX=AMAX1(Y(I),YMAX)
  120 YMIN=AMIN1(Y(I),YMIN)
      SYM(1)=(+Q003HL)
      DO 125 I=1,NPOINT
      FI=I-1
      XX(1)=FI*PI/POINT
      YP(1)=Y(I)
  125 CALL PLOTR (XX,0.0,PI,YP,SYM,YMIN,YMAX,1,-1)
      CALL PLOTR (XX,0.0,PI,YP,SYM,YMIN,YMAX,-1,-1)
  126 IF(XOOL.NE.YES) GO TO 131
  127 CALL COEVV
      BZERO=2.0*FTRI/FM
      WRITE (6,1003)
 1003 FORMAT(1H1,9X47HB IS THE COEFFICIENT OF COS J.OMEGA IN C(OMEGA)/
     1 10X,75HAND A IS THE COEFFICIENT OF SIN J.OMEGA IN S(OMEGA) IN SEC
     2TION FOUR STEP 2 ///)
      WRITE (6,1009)BZERO
 1009 FORMAT(10X16HA(   0) =    0.024X9HB(   0) =F11.5)
      DO 130 I=1,M
  130 WRITE (6,1004)I,A(I),I,B(I)
 1004 FORMAT (10X,2HA(I4,4H) = F10.5,20X,2HB(I4,4H) = F10.5)
  131 DO 140 K=1,NDATA
      XX(K)=0.0
      YY(K)=0.0
      DO 155 J=1,M
      JS=K+M+J
      KS=K+M-J+1
      IF((JS+1)-NDATA) 145,145,150
  145 YY(K)=YY(K)+A(J)*(X(JS)-X(KS))
  155 XX(K)=XX(K)+B(J)*(X(JS+1)+X(KS-1))
      IS=M+K+1
      XX(K)=BZERO*(X(IS)+X(IS-1))+XX(K)
  140 CONTINUE
  150 WRITE (6,1020)
 1020 FORMAT(1H1,31X,56HGRAPH OF THE FILTERED INPUT AT THE INDICATED DAT
     1A POINTS//)
      K=K-1
      YMAX=-10.0**10
      YMIN= 10.0**10
      DO 157 I=1,K
      YMAX=AMAX1(XX(I),YMAX)
  157 YMIN=AMIN1(XX(I),YMIN)
      IF(YMAX-YMIN-1.0)1575,1575,158
 1575 DIV=(YMAX-YMIN)/3.0
      YMAX=YMAX+DIV
      YMIN=YMIN-DIV
  158 FK=M
      FMAX=NDATA-M
      DO 159 I=1,K
      FK=FK+1.0
      YP(1)=XX(I)
  159 CALL PLOTR(FK,FM,FMAX,YP,SYM,YMIN,YMAX, 1,-1)
      CALL PLOTR(FK,FM,FMAX,YP,SYM,YMIN,YMAX,-1,-1)
      WRITE (6,1023)KPROB
 1023 FORMAT(1H1,20X,72HAVERAGE FREQUENCY, AMPLITUDE, PHASE AND FINITE M
     1OVING AVERAGES OF SERIES I4/32X,53H(FREQUENCY IN RADIANS/UNIT TIME
     2 AND PHASE IN RADIANS)//)
      WRITE (6,1025)
 1025 FORMAT(2X,4HDATA,7X,9HFREQUENCY,11X,9HAMPLITUDE,13X,5HPHASE,7X,38H
     1FINITE MOVING AVERAGES USING CONSTANTS/1X,5HPOINT,68X,4HB(J),16X,
     24HA(J)//)
      CALL PHAZE(XX(1),YY(1),Z1)
      J=M+1
      DO 165 I=2,K
      J=J+1
      AMPL =SQRT(XX(I)**2+YY(I)**2)
      CALL PHAZE(XX(I),YY(I),Z2)
      FREQ=Z2-Z1
      IF(FREQ)160,164,164
  160 DIV= FREQ+(2.0*PI)
      FREQ=-FREQ
      FREQ=AMIN1(DIV,FREQ)
      IF(FREQ-DIV)163,164,164
  163 FREQ=-FREQ
  164 WRITE (6,1024)J,FREQ,AMPL,Z2,XX(I),YY(I)
 1024 FORMAT(1H I5,4XF12.6,4(8X,F12.6))
  165 Z1=Z2
      GO TO 500
      END
CCOEVV        SUBROUTINE COEVV FOR BMD01T           AUGUST  9, 1965
      SUBROUTINE COEVV
          DIMENSION X(350),FMT(36),YSQ(80),Y(80),SYM(15),YP(15),
     1A(350),B(350),XX(350),YY(350)
      DIMENSION S(350)
      COMMON  X      , FMT    , YSQ    , Y      , SYM    , YP
      COMMON  A      , B      , XX     , YY     , AMPL   , PHASE
      COMMON  TG     , FILTER , KPROB  , NDATA  , FTRI   , NTRI
      COMMON  M      , FM     , NPOINT , POINT  , WO     , ANS
      COMMON  PI     , H
C     DIMENSION X(800),FMT(120),YSQ(500),Y(500),SYM(15),YP(15),
C    1A(800),B(800),XX(800),YY(800)
C     DIMENSION S(800)
C     COMMON X,FMT,YSQ,Y,SYM,YP,A,B,XX,YY,AMPL,PHASE,TG,FILTER,KPROB,
C    1NDATA,FTRI,NTRI,M,FM,NPOINT,POINT,WO,ANS,PI,H
      MMO=M-1
      ARG=FM*WO
      AA=2.0*FTRI*(.54+.46*COS(PI))*SIN(ARG)/FM
      BB=2.0*FTRI*(.54+.46*COS(PI))*COS(ARG)/FM
      KT=NTRI/2
      IF(NTRI-KT*2)20,10,20
   20 A(M)=-AA
      B(M)=BB
      GO TO 30
   10 A(M)=AA
      B(M)=-BB
   30 DO 105 J=1,MMO
      FJ=J
      ARGA=FJ*PI/FM
      ARGB=FJ*FTRI*PI/FM
  105 S(J)=4.0*(.54+.46*COS(ARGA))*SIN(ARGB)/(FM*SIN(ARGA))
      DO 120 J=1,MMO
      FJ=J
      ARG=FJ*WO
      A(J)=-S(J)*SIN(ARG)
  120 B(J)=S(J)*COS(ARG)
      RETURN
      END
CDINT    SUBROUTINE DINT FOR BMD01T                  MARCH 13, 1964
      SUBROUTINE DINT(YSQ,NN,H,ANS)
      DIMENSION YSQ(80),CONS(4)
C     DIMENSION YSQ(200),CONS(4)
C
      CONS(1)=0.34861111
      CONS(2)=1.24583333
      CONS(3)=0.87916667
      CONS(4)=1.02638889
      X=0.0
      J=NN
      DO 10 I=1,4
      X=X+(YSQ(I)+YSQ(J))*CONS(I)
      J=J-1
 10   CONTINUE
      DO 20 I=5,J
      X=X+YSQ(I)
 20   CONTINUE
      ANS=X*H
      RETURN
      END
CLANAI        SUBROUTINE LANAI FOR BMD01T           AUGUST  9, 1965
      SUBROUTINE LANAI (NN,BASE,KIT)
          DIMENSION X(350),FMT(36),YSQ(80),Y(80),SYM(15),YP(15),
     1A(350),B(350),XX(350),YY(350)
      COMMON  X      , FMT    , YSQ    , Y      , SYM    , YP
      COMMON  A      , B      , XX     , YY     , AMPL   , PHASE
      COMMON  TG     , FILTER , KPROB  , NDATA  , FTRI   , NTRI
      COMMON  M      , FM     , NPOINT , POINT  , WO     , ANS
      COMMON  PI     , H
C     DIMENSION X(800),FMT(120),YSQ(500),Y(500),SYM(15),YP(15),
C    1A(800),B(800),XX(800),YY(800)
C     COMMON X,FMT,YSQ,Y,SYM,YP,A,B,XX,YY,AMPL,PHASE,TG,FILTER,KPROB,
C    1NDATA,FTRI,NTRI,M,FM,NPOINT,POINT,WO,ANS,PI,H
      DO 100 I=1,NN
      FI=I
      OMEGA=FI*H+BASE
      CALL TABBY(OMEGA)
      L=I+KIT
      Y(L)=YY(1)
  100 YSQ(I)=YY(1)**2
      WRITE (6,800)
  800 FORMAT(1H0,21HVALUES OF F(X) SQUARE//)
      WRITE (6,1001)(YSQ(I),I=1,NN)
 1001 FORMAT(7F12.6)
      CALL DINT (YSQ,NN,H,ANS)
      RETURN
      END
CTABBY   SUBROUTINE TABBY FOR BMD01T               AUGUST  2, 1963
      SUBROUTINE TABBY(OMEGA)
          DIMENSION X(350),FMT(36),YSQ(80),Y(80),SYM(15),YP(15),
     1A(350),B(350),XX(350),YY(350)
      COMMON  X      , FMT    , YSQ    , Y      , SYM    , YP
      COMMON  A      , B      , XX     , YY     , AMPL   , PHASE
      COMMON  TG     , FILTER , KPROB  , NDATA  , FTRI   , NTRI
      COMMON  M      , FM     , NPOINT , POINT  , WO     , ANS
      COMMON  PI     , H
C     DIMENSION X(800),FMT(120),YSQ(500),Y(500),SYM(15),YP(15),
C    1A(800),B(800),XX(800),YY(800)
C     COMMON X,FMT,YSQ,Y,SYM,YP,A,B,XX,YY,AMPL,PHASE,TG,FILTER,KPROB,
C    1NDATA,FTRI,NTRI,M,FM,NPOINT,POINT,WO,ANS,PI,H
      SUM=0.0
      MMO=M-1
      DO 100 J=1,MMO
      FJ=J
      P=FJ*PI/FM
      Q=FJ*WO
      R=FTRI*FJ*PI/FM
      ARG=FJ*OMEGA
  100 SUM=SUM+(.54+.46*COS(P))*COS(Q)*SIN(R)*COS(ARG)/SIN(P)
      SUM=4.0*SUM/FM
      S=FM*WO
      T=FM*OMEGA
      NIT=NTRI/2
      IF(NTRI-NIT*2) 200,300,200
  200 YY(1)= (2.0*FTRI/FM)+SUM+2.0*FTRI*(.54+.46*COS(PI))*COS(S)*COS(T)/
     1FM
      GO TO 400
  300 YY(1)= (2.0*FTRI/FM)+SUM-2.0*FTRI*(.54+.46*COS(PI))*COS(S)*COS(T)/
     1FM
  400 RETURN
      END
CTPWD    SUBROUTINE TPWD FOR BMD01T         VERSION OF SEPT. 26, 1963
      SUBROUTINE TPWD(NT1,NT2)
      IF(NT1)40,10,12
 10   NT1=5
 12   IF(NT1-NT2)14,19,14
   14 IF(NT2.EQ.5) GO TO 19
      REWIND NT2
   19 IF(NT1-5)18,24,18
 18   IF(NT1-6)22,40,22
 22   REWIND NT1
 24   NT2=NT1
 28   RETURN
 40   WRITE (6,49)
      STOP
 49   FORMAT(25H ERROR ON TAPE ASSIGNMENT)
      END
CTRANS        SUBROUTINE TRANS FOR BMD01T             JUNE 2, 1964
      SUBROUTINE TRANS (MISTAK)
          DIMENSION X(350),FMT(36),YSQ(80),Y(80),SYM(15),YP(15),
     1A(350),B(350),XX(350),YY(350)
      DIMENSION IBIN (10),CON(10)
      COMMON  X      , FMT    , YSQ    , Y      , SYM    , YP
      COMMON  A      , B      , XX     , YY     , AMPL   , PHASE
      COMMON  TG     , FILTER , KPROB  , NDATA  , FTRI   , NTRI
      COMMON  M      , FM     , NPOINT , POINT  , WO     , ANS
      COMMON  PI     , H
C     DIMENSION X(800),FMT(120),YSQ(500),Y(500),SYM(15),YP(15),
C    1A(800),B(800),XX(800),YY(800)
C     DIMENSION IBIN (10),CON(10)
C     COMMON X,FMT,YSQ,Y,SYM,YP,A,B,XX,YY,AMPL,PHASE,TG,FILTER,KPROB,
C    1NDATA,FTRI,NTRI,M,FM,NPOINT,POINT,WO,ANS,PI,H
      EQUIVALENCE(ITG,SPECTG)
      ASN(Q000FL)=ATAN(Q000FL)/SQRT(1.0-Q000FL**2)
	DOUBLE PRECISION SPECTG,KODE
      DATA SPECTG/'SPECTG  '/
      READ (5,1002)KODE,NTRAN,(IBIN(I),CON(I),I=1,NTRAN)
 1002 FORMAT(A6,I1,8(I2,F6.0))
      IF(KODE-ITG)900,400,900
  400 DO 500 I=1,NTRAN
      IF(IBIN(I)-17) 605,600,605
  605 JESUS=IBIN(I)
      IF(JESUS-6)610,905,610
  600 JESUS=6
  610 CC=CON(I)
      IF(JESUS*(JESUS-11)) 620,905,905
  620 DO 150 K=1,NPOINT
      GO TO (10,20,30,40,50,60,70,80,90,100) ,JESUS
   10 IF(X(K))200,150,14
   14 X(K)=SQRT(X(K))
      GO TO 150
   20 IF(X(K))200,22,23
   22 X(K)=1.0
      GO TO 150
   23 X(K)=SQRT(X(K))+SQRT(X(K)+1.0)
      GO TO 150
   30 IF(X(K))200,200,31
   31 X(K)=.434294481E+00*ALOG(X(K))
      GO TO 150
   40 X(K)=EXP(X(K))
      GO TO 150
   50 IF(X(K))200,150,53
   53 IF (X(K)-1.0) 54,55,200
  54  ARG =SQRT(X(K))
      X(K)=ASN(ARG)
      GO TO 150
   55 X(K)=PI/2.0
      GO TO 150
   60 IF(X(K))200,200,61
   61 X(K)=ALOG(X(K))
      GO TO 150
   70 IF(X(K))71,200,71
   71 X(K)=1.0/X(K)
      GO TO 150
   80 X(K)=X(K)+CC
      GO TO 150
   90 X(K)=X(K)*CC
      GO TO 150
  100 IF(X(K))200,200,101
  101 X(K)=X(K)**CC
      GO TO 150
  200 WRITE (6,1001)K,IBIN(I)
 1001 FORMAT(11H0DATA POINT I5,57H VIOLATES THE RESTRICTION FOR TRANSGEN
     1ERATION OF THE TYPEI3,52H. THE PROGRAM CONTINUES LEAVING THE VALUE
     2 UNCHANGED.)
  150 CONTINUE
  500 CONTINUE
  300 RETURN
  900 WRITE (6,1003)KODE
      WRITE (6,1006) KODE,NTRAN,(IBIN(I),CON(I),I=1,NTRAN)
 1006 FORMAT(1H0,A6,I1,8(I2,F6.0))
  901 WRITE (6,1004)
      MISTAK=17
      GO TO 300
 1003 FORMAT(58H0CONTROL CARD ERROR. PROGRAM EXPECTED A SPECTG CARD BUT 
     1A A6,16H CARD WAS FOUND.)
 1004 FORMAT(42H0PROGRAM WILL GO TO THE NEXT PROBLEM CARD.)
  905 WRITE(6,1005) KODE, NTRAN, (IBIN(I), CON(I), I=1,NTRAN)
 1005 FORMAT('0ILLEGAL TRANSGENERATION CODE SPECIFIED. CARD IS PRINTED'
     1 ' BELOW.' / (1H0, A6, I1, 8(I2,F6.0)))
      GO TO 901
      END
CPHAZE        SUBROUTINE PHAZE FOR BMD01T           AUGUST  9, 1965
      SUBROUTINE PHAZE(X,Y,Z)
      PI=3.14159265
      PI2=2.0*PI
      AB=ABS(Y/X)
      PHI=ATAN(AB)
      IF(X)11,12,13
   11 IF(Y)17,30,18
   17 Z=PI+PHI
      GO TO 50
   30 Z=PI
      GO TO 50
   18 Z=PI-PHI
      GO TO 50
   12 IF(Y)35,15,40
   35 Z=0.75*PI2
      GO TO 50
   15 Z=0.0
      GO TO 50
   40 Z=PI/2.0
      GO TO 50
   13 IF(Y)14,15,16
   14 Z=PI2-PHI
      GO TO 50
   16 Z=PHI
   50 RETURN
      END
C             SUBROUTINE PLOTR (IBM 360)              AUGUST 13, 1966
      SUBROUTINE PLOTR(X,ZMIN,ZMAX,Y,SYM,WMIN,WMAX,NC,NP)
C
      DIMENSION Y(15),CLAB(12),SYM(15),GF(10),FMT(12),XY(51,101)
	INTEGER XY, BLANKS
      INTEGER SYM,SYMB
      DATA NCC/2/
	DATA TC,TP,BLANKS/'.','+','     '/
      DATA GF/            4H 1X,,4H 2X,,4H 3X,,4H 4X,,4H 5X,,4H 6X,,
     14H 7X,,4H 8X,,4H 9X,,4H 10X/
      DATA FMT/'(17X',' ','5(F1','2.3,','8X)/','7X, ',' ','4(F1','2.3,',
     1'8X),','F12.','3)  '/
C
 100   FORMAT(1H 6X5(F12.3,8X),F12.3/17X,5(F12.3,8X))
 101  FORMAT(1H F12.3,1X,103A1,F12.3)
  102 FORMAT(1H 13X,103A1)
  800 FORMAT(1H  14X,101A1)
 1001 FORMAT(15X,20(5H+....),1H+)
C
C        NCC ON THE INITIAL ENTRY TO PLOTR IS ASSUMED TO BE SOMETHING
C        OTHER THAN ZERO.
C
      IF(NCC) 50,48,50
   50 KL=0
      CALL SCALE(WMIN,WMAX,100.0,JY,YMIN,YMAX,YIJ)
      YR=YMAX-YMIN
  230 J=JY
      IF(J*(J-10))204,201,201
  201 IF(KL)220,220,231
  231 WRITE (6,1001)
      IF(KL)250,250,220
  220 CLAB(1)= YMIN
      DO 222 I=2,11
  222 CLAB(I)=CLAB(I-1)+YIJ
      WRITE (6,100)(CLAB(I),I=1,11,2),(CLAB(J),J=2,10,2)
      IF(KL)231,231,14
  204 IF(J-5)205,221,207
  207 J=J-5
  205 JYT=5-J
  221 CONTINUE
  226 FMT(2)=GF(JY)
      IF (KL) 225,225,227
  225 FMT(7)=GF(JY)
      TT=JY
      TT=TT*YIJ/10.0
      CLAB(1)= YMIN+TT
      DO 223 I=2,10
  223 CLAB(I)=CLAB(I-1) +YIJ
      WRITE (6,FMT) (CLAB(I),I=2,10,2),(CLAB(JJJ),JJJ=1,9,2)
      IF(KL)227,227,14
  227 IF(JY-5)208,209,208
 208  WRITE (6,800)(TC,I=1,J),(TP,(TC ,I=1,4),K=1,19),TP,(TC,I=1,JYT)
      IF(KL) 250,250,225
  209 WRITE (6,1001)
      IF(KL) 250,250,225
  250 CONTINUE
      NCC=0
      IC=0
      IF(NP)80,11,11
   11 DO 1 I=1,51
       DO 1 J=1,101
   1  XY(I,J)=BLANKS
      CALL SCALE (ZMIN,ZMAX,50.0,JX,XMIN,XMAX,XIJ)
      XR=XMAX-XMIN
C      ENTRY PLOTS
   48 IF(NC)52,13,49
   49 IF(NP)80,10,10
   10 DO 9 N=1,NC
      SYMB=SYM(N)
      XDIFFR=XMAX-X
      IF(XDIFFR)105,106,106
  105 XDIFFR=0.0
  106 YDIFFR=YMAX-Y(N)
      IF(YDIFFR)107,108,108
  107 YDIFFR=0.0
  108 L=51.0-(50.0*XDIFFR)/XR+.5
      K=101.0-(100.0*YDIFFR)/YR+.5
      CALL FORM2(SYMB,XY(L,K))
 9     CONTINUE
      GO TO 15
   80 DO 86 I=1,101
   86 XY(1,I)=BLANKS
       L=1
      DO 95 N=1,NC
      SYMB=SYM(N)
      YDIFFR=YMAX-Y(N)
      IF(YDIFFR)860,865,865
  860 YDIFFR=0.0
  865 K=101.0-(100.0*YDIFFR)/YR+.5
   95 CALL FORM2(SYMB,XY(L,K))
      IF(MOD(IC,5))97,96,97
   96 W=TP
      GO TO 98
   97 W=TC
   98 WRITE (6,101)X,W,(XY(1,N),N=1,101),W,X
      IC=IC+1
      GO TO 15
   13 M=6-JX
      LL=50+M
      T=JX
      IF(5-JX)131,131,135
  131 T=0.0
  135 RLAB=XMAX-(T*XIJ)/5.0
      W=TC
      K=52
      DO 31 L=M,LL
      K=K-1
      I=MOD(L,5)
      IF(I-1)2,3,2
    3 W=TP
      WRITE (6,101)RLAB,W,(XY(K,N),N=1,101),W,RLAB
      RLAB=RLAB-XIJ
      W=TC
      GO TO 31
    2 WRITE (6,102)W,(XY(K,N),N=1,101),W
   31 CONTINUE
   52 KL=1
      GO TO 230
   14 NCC=1
   15 RETURN
      END
C             SUBROUTINE SCALE FOR PLOTR              JUNE 21, 1966
      SUBROUTINE SCALE(YMIN,YMAX,YINT,JY,TYMIN,TYMAX,YIJ)
      DIMENSION C(10)
      DATA C           /1.0,1.5,2.0,3.0,4.0,5.0,7.5,10.0,15.0,20.0/
      TEST=1.0/(2.0**20)
   50 YR=YMAX-YMIN
      TT=YR/YINT
      J = ALOG10(TT)+TEST
      E=10.0**J
      TT=TT/E
      I=0
      IF(TT-1.0+TEST)205,201,201
  205 TT=TT*10.0
      E=E/10.0
 201  I=I+1
      IF(9-I)1,2,2
    1 E=E*10.0
      I=1
    2 IF(TT-C(I))233,202,201
  233 YIJ=C(I)*E
      GO TO 203
  202 Y=YMIN/C(I)
      J=Y
      T=J
      IF(0.0001-ABS(T-Y))204,233,233
  204 YIJ=C(I+1)*E
  203 X=((YMAX+YMIN)/YIJ-YINT )/2.0+.00001
      K=X
      IF(K)235,240,240
  235 Y=K
      IF(X-Y)236,240,236
  236 K=K-1
  240 TYMIN=K
      TYMIN=YIJ*TYMIN
      TYMAX=TYMIN+YINT*YIJ
      IF(YMAX-TYMAX-TEST)10,10,201
   10 TT=YINT/10.0
      JY=TT+.000001
      YIJ=YINT*(YIJ/10.0)
      J=TYMIN/ YIJ
      IF (K)242,241,241
  242 J=J-1
  241 J=J*JY+JY-K
      JY=J
      RETURN
      END
      SUBROUTINE FORM2(SYMB,XY)
C        SUBROUTINE FORM2 FOR PLOTR (IBM 360)         JUNE 21, 1966
	DIMENSION TEST(18)
       INTEGER XY,SYMB,BLANK,TEST
	DATA BLANK/'     '/
	DATA TEST/'2','3','4','5','6','7','8','9','A',
     1 'B','C','D','E','F','G','H','I','/'/
      IF(XY.EQ.BLANK)GO TO 50
      DO 30 I=1,17
      IF(XY.NE.TEST(I))GO TO 30
C        PUT IN NEXT SYMBOL OF ARRAY FOR MULTIPLE POINTS
      XY=TEST(I+1)
      GO TO 100
   30 CONTINUE
      IF(XY.EQ.TEST(18))GO TO 100
C        IF OTHER THAN CHARACTERS IN ARRAY TEST PUT IN CHARACTER 2.
      XY=TEST(1)
      GO TO 100
C        IF BLANK, PUT IN SYMBOL
   50 XY=SYMB
  100 RETURN
      END