	PROGRAM XYPLOT
C----------------MAIN--XYPLOT--------------------------------
C	CORREXCTION MADE BY MOHAN - 230386
C CORRECTION X5.03 APPLIED NSLS DATA FORMATS
C CORRECTION X5.05 APPLIED PLOT TIMING
C CORRECTION X5.09 APPLIED WINDOW FUNCTION
C	EXTENSION MADE BY UWE MAAS NYSCC, ALFRED, NY
C EXTENSION X5.091 FILE PLOTTING OPTION 01/30/90
C
C * THIS PROGRAM AND ASSOCIATED LOWER LEVEL SUBROUTINES
C * GENERATE THE COMPLETE GRAPHICAL ANALYSIS OF THE INPUT AND 
C * OUTPUT EXAFS DATA IN THE DESIRED FORM.
      COMMON /PLOT/XDEL,NEX,NXTX,YDEL,NEY,NYTX,
     1IMIN,IMAX,JMIN,JMAX
      LOGICAL*1 NAMES,BELL,KOPT,LOPT,PREV,SAVE,KP(5)
	COMMON /KEEP/IPHJ,IPHK,ESHFT,ESH,IDEGL,IDGL,IFT,IFFT,
     1JCAPX,ICAPX,JCAPY,ICAPY,ISML,XNM,XNMIN,XIFIT,XI,
     2XJFIT,XJ
      DIMENSION A(1024),B(1024,6),C(4,1024),X(1024),Y(1024),V(1024),
     1W(1024),DELTA(2048),T(8192),PHI(2048),PHJ(1024)
      DIMENSION U(4,3),NAMES(25)
      COMPLEX T
      DIMENSION IXCAP(30,4),NXCAP(4),IYCAP(30,4),NYCAP(4),NC(37),
     1IDCAP(6),ISCAP(6),MYCAP(5)
      DATA BELL,PREV,SAVE/O7,'P','S'/,KWT/' K'/,
     1KP/'0','1','2','3','M'/
      DATA NC/'EX','XP','DG','PT','IS','RP','CS','KE','SL','ES',
     1'WF','PL','EN','PR','RE','OP','KV','FT','BT','RF',
     2'LM','PM','DF','PH','PF','AF','FC','ED','TI','DI','BC',
     3'BP','EF','HE','WI','FI','  '/
      DATA IXCAP/'-S','TE','P ','NU','MB','ER',24*'  ',
     2'EN','ER','GY',' (','EV',') ',24*'  ',
     3'WA','VE',' V','EC','TO','R ',24*'  ',
     4'RA','DI','US',27*'  '/
      DATA NXCAP/12,12,12,6/
      DATA IYCAP/'RA','TI','O ',27*'  ',
     2'AB','SO','RP','TI','ON',25*'  ',
     3'CH','I ',28*'  ',
     4'MA','GN','IT','UD','E ',25*'  '/
      DATA MYCAP/'TR','AN','SF','OR','M '/
      DATA NYCAP/5,10,3,9/
      DATA IDCAP/'DI','FF','ER','EN','TI','AL'/
      DATA AMP,IAMP,IPH,IPHJ,IPHK,IDIFF,NX/0.,0,0,0,0,0,0/
C      CALL FILES(10,'TMPFIL',6,2,1,0,LUNIT)
	FLAG1=.FALSE.
      CALL INITT(10)
      GO TO 110
   10 NPTV=NPTS
      EDIF=0.
      IF(IPHK.EQ.0 .AND. IPHJ.EQ.1)GO TO 20
      GO TO 40
   20 DO 30 J=1,5
      MCAP=IYCAP(J,4)
      IYCAP(J,4)=MYCAP(J)
   30 MYCAP(J)=MCAP
      IPH=0
      IPHJ=0
   40 IF(IDIFF.EQ.0)GO TO 60
      IDIFF=0
      DO 50 I=1,6
   50 IYCAP(I,ICAPY)=ISCAP(I)
      NYCAP(ICAPY)=NSCAP
   60 IF(NC(19).EQ.IELECT)GO TO 80
      DO 70 I=1,NPTS
      V(I)=X(I)
      W(I)=Y(I)
   70 CONTINUE
   80 CALL MINMAX(V,W,XMIN,XMAX,YMIN,YMAX,NPTV)
      IF(IPHJ.EQ.1)GO TO 470
   90 XL=XMIN
      YL=YMIN
      XH=XMAX
      YH=YMAX
      DO 100 J=1,3
      U(1,J)=XL
      U(2,J)=YL
      U(3,J)=XH
      U(4,J)=YH
  100 CONTINUE
      GO TO 510
  110 CALL ALFMOD
      CALL HOME
  120 TYPE 140, BELL,BELL
      ACCEPT 150,IELECT
	IELECT=IELECT.AND.(.NOT.'  ')
	JJ=0
	DO 130, I=1,37
130	IF (IELECT.EQ.(NC(I))) JJ=I
	GOTO(640,160,190,210,220,230,250,260,270,280,290,10,
     * 300,290,350,360,380,450,490,500,290,290,330,170,   
     * 240,200,390,400,370,610,620,630,635,637,700,800),JJ
      GO TO 110
  140 FORMAT('$> ',2A1)
  150 FORMAT(A2) 
  160 CALL EXPAND(XL,YL,XH,YH,U)
      GO TO 510
170	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	CALL PHREM(X,Y,V,W,DELTA,PHI,NPTS,NPTV,IPH)
      IF(IPH.EQ.1)GO TO 90
      DO 180 I=1,100
  180 ICOUNT=I
      GO TO 110
190	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	CALL DEGLIT(X,Y,V,W,NPTS)
      IDEGL=1
      GO TO 510
200	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	CALL AMPFIT(C,T,PHJ,V,W,X,PHI,Y,DELTA,NPTV,NAMES,KOPT,LOPT,
     C  KLOG,KPW,KFIRST,SCPTS,AMP)
      IAMP=1
      GO TO 110
  210 CALL POINT(V,W,NPTV)
      GO TO 110
  220 CALL STACKN(XL,YL,XH,YH,U)
      GO TO 510
  230 CALL REPLOT(XL,YL,XH,YH,U)
      GO TO 510
  240 CALL PHAZFT(PHJ,V,W,NPTV,X,PHI,DELTA,NPTS,
     C NAMES,KOPT,LOPT,KLOG,KPW)
      GO TO 110
  250 CALL HDCOPY
      GO TO 110
  260 CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
      GO TO 110
  270 NX=0
	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
      CALL SMLFIT(C,X,Y,V,W,NPTS,NPTV,XI,XJ,XNMIN,NX)
      ISML=1
      IF(NX.EQ.0)ICAPY=3
      GO TO 80
280	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	 CALL ESHIFT(X,Y,V,W,NPTS,ESH)
      GO TO 510
290	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	 CALL WRITFL(X,Y,NPTS,NAMES,KOPT,LOPT,FORM,KLOG,ESHFT,
     C ICAPX,ICAPY,XIFIT,XJFIT,XNM,NC,IELECT,IDGL,IFFT,KPOWR,NX)
      GO TO 110
  300 JJ=0
	CALL NEWPAG
	CALL TOUTPT(24)		!SWITCH TO ANSI MODE
        IF(FORM.EQ.2.)THEN
C	   CALL FILES(10,'TMPFIL',6,0,0,0,LUNIT)
	   CALL SETUP(SPDMON,D,STEPOF,EDGNRG,FORM)
C	   CALL FILES(10,'TMPFIL',6,2,1,0,LUNIT)
	   DO 310 I=1,NPTS
310	   V(I)=X(I)-EDGNRG
	ELSE
	   CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
	   CALL ESPACE(X,Y,V,W,NPTS)
	ENDIF
320	MLOG=KLOG
	IF (KLOG .EQ. 0)THEN
	  ICAPX=2
	  ICAPY=1
	ELSE
	  ICAPX=2
	  ICAPY=2
	ENDIF
      KLOG=0
      NX=0
      GO TO 80
330	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	 CALL DIFF(X,Y,V,W,NPTS)
      IDIFF=1
      DO 340 I=1,6
      ISCAP(I)=IYCAP(I,ICAPY)
  340 IYCAP(I,ICAPY)=IDCAP(I)
      NSCAP=NYCAP(ICAPY)
      NYCAP(ICAPY)=12
      GO TO 80
  350 CALL NEWPAG
	CALL TOUTPT(24)		!SWITCH TO ANSI MODE
      CALL READAT(A,B,NDAT,CUEDGE,NCHAN,NAMES,FORM)
  	IF(FORM.EQ.7) GOTO 120
	GO TO 361
360	CALL NEWPAG
	CALL TOUTPT(24)		!SWITCH TO ANSI MODE
361   CALL OPTION(A,B,X,Y,NDAT,NCHAN,KOPT,LOPT,FORM,KLOG)
	IF ( KOPT .EQ. 0 .OR. LOPT .EQ. 0) GO TO 110
      IPHK=0
      ISML=0
      ESH=0.
      ESHFT=0.
      NX=0
      IDGL=0
      IDEGL=0
      IFT=0
      IFFT=0
      MLOG=0
      ICAPX=1
      ICAPY=1
      JCAPX=ICAPX
      JCAPY=ICAPY
      NPTS=NDAT
      GO TO 10
370	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	 CALL TINT(PHJ,PHI,X,NPTS,T,KFIRST,SCPTS)
      GO TO 110
380	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	 CALL KSPACE(X,Y,V,W,NPTS)
      ICAPX=3
      GO TO 80
390	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	 CALL FLUOR(X,Y,V,W,NPTS,NPTV,NX)
      GO TO 80
  400 IF(EDIF.NE.0.)GO TO 410
	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
      CALL EDGDIF(PHI,DELTA,V,W,NPTV,X,Y,C,NPTS,JNUM,
     C    XMIN,YMIN,XMAX,YMAX,EDIF)
  410 IF(EDIF.LT.2.)GO TO 90
      DO 420 I=1,5
      ISCAP(I)=IYCAP(I,ICAPY)
  420 IYCAP(I,ICAPY)=IDCAP(I)
      IYCAP(5,ICAPY)='CE'
      GO TO 90
  430 CALL EDGPLT(PHI,DELTA,V,NPTV,JNUM)
      IF(EDIF.LT.2.)GO TO 110
      DO 440 I=1,5
  440 IYCAP(I,ICAPY)=ISCAP(I)
      EDIF=1.
      GO TO 110
450	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	 CALL FORFFT(C,X,Y,V,W,DELTA,PHI,T,NPTS,NPTV,XKMIN,XKMAX,
     1KTALLY,IPRCNT,KNUM,KFIRST,KPOWR,SCPTS,IPH)
      IFT=1
      ICAPX=4
      ICAPY=4
      IF(IPH.EQ.0) GO TO 80
      DO 460 I=1,5
      MCAP=MYCAP(I)
      MYCAP(I)=IYCAP(I,4)
  460 IYCAP(I,4)=MCAP
      IPHJ=1
  470 CALL MINMAX(V,W,XMIN,XMAX,YMIN,YMAX,NPTV)
      IF(YMAX.GT.-YMIN)YMIN=-YMAX
      IF(YMAX.LT.-YMIN)YMAX=-YMIN
      YMIN=YMIN*1.05
      YMAX=YMAX*1.05
      GO TO 90
  480 CALL OVRPLT(V,W,PHI,NPTV)
      GO TO 110
490	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
  	 CALL BAKFFT(PHJ,V,W,X,Y,DELTA,PHI,T,NPTS,NPTV,XKMIN,XKMAX,
     1KTALLY,IPRCNT,KNUM,KFIRST,KPOWR,SCPTS)
      IF(IPHJ.EQ.1)IPHK=0
      ICAPX=3
      ICAPY=3
      KLOG=3
      IF(IPHJ.EQ.1)GO TO 20
      GO TO 80
  500 CALL READFL(V,W,NPTV,NAMES,KOPT,LOPT,FORM,KLOG,ESH,
     1ICAPX,ICAPY,XI,XJ,XNMIN,IDGL,IFT,ISML,KPOWR,NX)
	IF (NPTV .EQ. 0) GO TO 120
      MLOG=KLOG
      IDEGL=IDGL
      IFFT=IFT
      IPHK=0
	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,0)
      GO TO 10
  510 CALL NEWPAG
      IF(IELECT.EQ.NC(12))ICAPX=JCAPX
      IF(IELECT.EQ.NC(12))ICAPY=JCAPY
      IF(KLOG.EQ.3 .AND. ICAPY.EQ.4)GO TO 530
      IF(MLOG.EQ.1 .AND. ICAPY.EQ.1) KLOG=1
      IF(KLOG.NE.3)GO TO 560
      IF(KLOG.EQ.3 .AND. NYCAP(3).EQ.5)GO TO 570
      NYCAP(3)=5
      IYCAP(3,3)=IYCAP(2,3)
      IYCAP(2,3)=IYCAP(1,3)
      IYCAP(1,3)=KWT
      DO 520 I=1,4
  520 IF(KPOWR.EQ.I-1)KPW=KP(I)
      IF(KPOWR.GT.3)KPW=KP(5)
      GO TO 570
  530 KLOG=0
      NYCAP(3)=3
      IYCAP(1,3)=IYCAP(2,3)
      IYCAP(2,3)=IYCAP(3,3)
      IYCAP(3,3)=IYCAP(4,3)
      DO 550 I=1,KNUM
      IF(I.GT.NPTS) GO TO 540
      T(I)=W(I)*CEXP(CMPLX(0.,PHJ(I)))
      GO TO 550
  540 T(I)=(0.,0.)
  550 CONTINUE
  560 IF(NYCAP(3).EQ.5 .AND. KLOG.EQ.0)GO TO 530
  570 IF((JJ.EQ.15.OR.JJ.EQ.16).AND.(FORM.EQ.2.))GOTO 300
      CALL FRAME(XL,XH,YL,YH,IXCAP,NXCAP,IYCAP,NYCAP,ICAPX,ICAPY,
     CNAMES,KOPT,LOPT,KLOG,KPW)
C	CODE TO TITTLE THE FT PLOT
	IF (ICAPY .EQ. 4) THEN
	   CALL FILES(1,'CONST.HLD',9,0,1,1,NUNIT)
	   READ(NUNIT'4) XKMIN,XKMAX,IPRCNT,KPOWR,KNUM,SCPTS
	   CALL FILES(1,'CONST.HLD',9,0,0,0,NUNIT)
	   CALL MOVABS(LINWDT(1)/2,LINHGT(2))
	   CALL ALFMOD
	   TYPE 585, KPOWR,KNUM,XKMIN,XKMAX
	ENDIF
  580 CALL GRAPH(V,W,NPTV,0)
585	FORMAT(31X,'FT OF K**',I1,' OVER ',I4,' PTS FROM ',F3.1,
     1         ' TO ',F4.1,' K')
      IF(IPHJ.EQ.1)GO TO 480
      IF(EDIF.GT.0.)GO TO 430
      GO TO 110
  590 FORMAT('$?')
  600 FORMAT(A1)
610	CALL TOUTPT(24)		!SWITCH TO ANSI MODE
	CALL DIRECT
	GOTO 120
620	CALL CONHLD
	GOTO 110
630	CALL BLDPHA
	GOTO 110
C635	CALL EXAFIT
635	GOTO 120
C637	CALL NEWPAG
C	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
637	CALL TOUTPT(24)		!SWITCH TO ANSI MODE
	CALL LIB$SPAWN('HELP EXAPLT')
	GOTO 120
700	CALL KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
	CALL WINDOW(X,Y,V,W,NPTS,NPTV)
	GOTO 80
C  640 CALL FILES(10,'TMPFIL',6,2,0,0,LUNIT)
640	CALL NEWPAG
	CALL TOUTPT(24)		!SWITCH TO ANSI MODE
      CALL EXIT
800	CALL FILEPLOT(V,W,NPTS)
	GOTO 110
	END
C--------------------SUBROUTINE FILEPLOT---------------------------------
C
	SUBROUTINE FILEPLOT(V,W,NPTS)
	DIMENSION V(1024),W(1024)
	CHARACTER*20 FILENAME
	WRITE(*,110)
	READ(*,120) FILENAME
	OPEN(UNIT=99,NAME=FILENAME,STATUS='UNKNOWN')
	WRITE(*,115)
	DO 10 I=1,NPTS
	WRITE(99,130) V(I),W(I)
10	CONTINUE
	CLOSE(UNIT=99)  
110	FORMAT(' FILENAME WITH EXTENSION:')
115	FORMAT(' WRITING THE FILE ...')
120	FORMAT(A20)
130	FORMAT(E12.6,',   ',E12.6)
	END
C--------------------SUBROUTINE--AMPFIT----------------------------------
C
      SUBROUTINE AMPFIT(CC,T,U,V,W,X,Y,YY,Z,NPTS,NAMES,KOPT,LOPT,KLOG,
     1KPW,KFIRST,SCPTS,AMP)
      DIMENSION CC(4,1024),T(8192),U(1024),V(1024),W(1024),X(1024),
     1    YY(1024),Y(2048),Z(2048),ENVLOP(100,2)
      DIMENSION NAMES(25),ANS(6),TITLE(10),AP(4),CL(4),NAEL(4),NSEL(4)
      COMPLEX T
      LOGICAL*1 NAMES,KOPT,LOPT,ANS,TITLE,NAEL,NSEL,DANS,ANT,BEAT
      DIMENSION IXCAP(30,4),IYCAP(30,4),NXCAP(4),NYCAP(4),IENCAP(8)
      DATA IXCAP/'WA','VE',' V','EC','TO','R ','**','2 ',112*'  '/
      DATA IYCAP/'LO','G ','OF',' T','HE',' R','AT','IO',112*'  '/
      DATA NXCAP,NYCAP/16,0,0,0,16,0,0,0/
      DATA IENCAP/'  ','  ','EN','VE','LO','PE','  ','  '/
      DATA RFI,RSE,RDELT,RCOR1,POW,SIGM1,SIGM2/0.,0.,0.,0.,1.,1.,1./
      DSI=0.
      IEN=0
      IPR=0
      AMP=1.
      ICONT=0
      ICAPX=1
      ICAPY=1
      E0=0.
      NPTV=NPTS
      DO 10 I=1,NPTV
      KINDEX=KFIRST-1+I
      Z(2049-I)=X(I)
      Y(2049-I)=Y(I)
      U(I)=CABS(2.*T(KINDEX)/SCPTS)
   10 CONTINUE
      DO 20 I=1,6
   20 ANS(I)=' '
      NLOG=KLOG
      KLOG=0
      CALL NEWPAG
	CALL TOUTPT(24)		!SWITCH TO ANSI MODE
   30 TYPE 360
      ACCEPT 370,ANS(1)
      IF(ANS(1).EQ.'E')GO TO 310
      IF(ANS(1).EQ.'F')GO TO 50
      IF(ANS(1).EQ.'L') IPR=1
      IF(ANS(1).EQ.'L') ANS(1)='D'
      IF(ANS(1).NE.'D')GO TO 30
      ANS(2)='E'
   40 TYPE 380
      ACCEPT 370,DANS
      IF(DANS.EQ.'L')GO TO 60
      IF(DANS.NE.'E')GO TO 40
      ANS(2)='B'
      IEN=1
      GO TO 60
   50 ANS(2)='B'
      IF=1
   60 TYPE *,'DO YOU WANT TERMINAL (I)NPUT OF AMPLITUDE FUNCTION OR A '
      TYPE *,'(P)ARAMETERIZED OR (T)ABULAR AMPLITUDE FROM DISK TABLES'
      TYPE 400
      ACCEPT 370,ANS(3)
      IF(ANS(3).EQ.'I')GO TO 90
      IF(ANS(3).EQ.'T')GO TO 70
      IF(ANS(3).EQ.'A')GO TO 120
      IF(ANS(3).NE.'P')GO TO 60
      CALL PHTABL(0,V,W,X,U,Z,NPTS,ICONT,AP,ANS,R1,E0,TITLE,
     C    NAEL,NSEL)
      IF(ICONT.EQ.1)GO TO 310
      GO TO 100 
   70 CALL PHTABL(3,V,W,X,U,Z,NPTS,ICONT,AP,ANS,R1,E0,TITLE,
     C    NAEL,NSEL)
      DO 80 I=1,NPTS
   80 W(I)=Z(I)
      IF(ICONT.EQ.1)GO TO 310
      GO TO 130
   90 TYPE 410
      ACCEPT *,(AP(I),I=1,4)
      E0=AP(4)
  100 VSQDEL=.262467*E0
      DO 110 I=1,NPTS
      CAYSQ=X(I)*X(I)
      CAYN=SQRT(CAYSQ-VSQDEL)
      W(I)=AP(1)/(1.+AP(2)*AP(2)*(CAYN-AP(3))**2)
  110 CONTINUE
      GO TO 130
  120 CALL AMPRD(V,W,X,NPTS,ENVLOP,NENV)
D	TYPE *,' NOW ENTERING AMPINT ROUTINE'
      CALL AMPINT(CC,U,V,W,X,NPTS,ENVLOP,NENV)
D	TYPE *,' NOW BACK IN AMPFIT' 
  130 XN1=1.
      XR1=1.
      SI2=0.
      MXP=0
      NXP=0      
      TYPE *,'REFERENCE AMPLITUDE WEIGHTING K**N*[N1/(K*R1**2)',
     C    '*EXP(-2K**2*SI2)]**M*AMP'
      TYPE 390
      ACCEPT *, XN1,XR1,SI2,MXP,NXP
      TYPE *,'BEAT-ADJUSTMENTS?'
      ACCEPT 370,BEAT
      IF (BEAT.NE.'Y') GOTO 140
      TYPE *,'AMP(ONE SHELL)=AMP(2 SHELL)/(CORRECTION**POW)'
      TYPE *,'TYPE POW'
      ACCEPT *,POW 
      TYPE 460
      ACCEPT *,RFI,RSE
      RDELT=2.*(RSE-RFI)
      RCOR1=(2.*RFI*RFI)/(RSE*RSE)
      TYPE *,'DIFFERENT SIGMA**2?'
      ACCEPT 370,BEAT
      IF (BEAT.NE.'Y') GOTO 140
      TYPE 470
      ACCEPT *,SIGM1,SIGM2
      DSI=2.*(SIGM2-SIGM1)
  140 DO 150 I=1,NPTS
      XK=X(I)
      BEATMA=1.+RCOR1*RCOR1*.25*EXP(-2.*DSI*XK**2)+RCOR1*
     CEXP(-DSI*XK**2)*COS(RDELT*XK)
      IF (BEATMA.LT.0.01) BEATMA=.01
      V(I)=XK
      W(I)=XK**NXP*(XN1/XK/(XR1*XR1)*EXP(-2.*XK*XK*SI2))**MXP*W(I)/
     C(BEATMA**(.5*POW))
      IF(IEN.EQ.1)GO TO 150
      U(I)=ALOG(U(I)/W(I))
      V(I)=XK*XK
  150 CONTINUE      
      IF(ANS(1).EQ.'F')GO TO 160
      C0=0.
      C2=0.
      C4=0.
      IF(IEN.EQ.1) GO TO 250
      GO TO 270
  160 IANS=0
      TYPE *,'(0) INPUT OR (1) LEAST SQUARES FIT? '
      ACCEPT *,IANS
      IF(IANS.EQ.1)GO TO 170
      TYPE *,'INPUT COEFFICIENTS FOR FIT TO  LN RATIO    C0,C2,C4'
      ACCEPT *,CL(1),CL(2),CL(3)
      GO TO 220
  170 XK2MIN=V(1)
      XK2MAX=V(NPTS)
      TYPE *,'CHOOSE RANGE OF K**2 SCALE FOR LEAST SQUARES FIT'
      TYPE *,'(/) DEFAULTS TO THE MAXIMUM RANGE. '
      TYPE 420
      ACCEPT *,XK2MIN,XK2MAX
      IF(XK2MIN.LT.V(1))XK2MIN=V(1)
      IF(XK2MAX.GT.V(NPTS))XK2MAX=V(NPTS)
      K=1
      DO 180 I=1,NPTS
      IF(V(I).LT.XK2MIN .OR. V(I).GT.XK2MAX)GO TO 180
      V(K)=V(I)
      U(K)=U(I)
      K=K+1
  180 CONTINUE
      NPTS=K-1
      NBS=3
      TYPE *,'FIT WITH FIXED C0?'
      ACCEPT 370,ANT
      IF(ANT.NE.'Y') GOTO 200
      NBS=2
      TYPE *,'CHOOSE C0'
      ACCEPT *,C0
      DO 190 I=1,NPTS
  190 U(I)=U(I)-C0
  200 CONTINUE
      CALL LSQFIT(V,U,NPTS,NBS,CL)
      IF(NBS.GT.2) GOTO 220
      DO 210 I=1,NPTS
  210 U(I)=U(I)+C0      
      C2=CL(1)
      C4=CL(2)
      GOTO 230
  220 C0=CL(1)
      C2=CL(2)
      C4=CL(3)
  230 DO 240 I=1,NPTS
  240 W(I)=C0+V(I)*(C2+V(I)*C4) 
      GO TO 270
  250 DO 260 I=1,8
      IF(I.GT.6) IXCAP(I,ICAPX)='  '
      IYCAP(I,ICAPY+1)=IYCAP(I,ICAPY)
  260 IYCAP(I,ICAPY)=IENCAP(I)
  270 IF(IPR.EQ.0)GO TO 280
C      CALL FILES(6,'          ',10,0,-1,0,NUNIT)
      IF(IEN.EQ.0)WRITE(NUNIT,430)
      IF(IEN.EQ.1)WRITE(NUNIT,440)
      WRITE(NUNIT,450) (V(I),U(I),W(I),I=1,NPTS)
C      CALL FILES(6,'          ',10,0,0,0,NUNIT)
  280 CALL PHPLOT(U,V,W,X,NPTS,XMIN,XMAX,YMIN,YMAX,
     C    XT,YT,XV,YV,TITLE,NAMES,ANS,NAEL,NSEL)
      CALL LABEL(XMIN,XMAX,IXCAP,NXCAP,YMIN,YMAX,IYCAP,NYCAP,
     C    ICAPX,ICAPY,NAMES,KOPT,LOPT,KLOG,XT,YT,XV,YV,KPW)
      CALL GRAPH(V,U,NPTS,0)
      IF(DANS.EQ.'E')GO TO 290
      IF(ANS(1).NE.'F')GO TO 310
  290 CALL GRAPH(V,W,NPTS,-1)
  300 CALL PHLABL(2,0.,0.,0.,0,ANS,ICONT,C0,C2,C4)
      IF(IANS.EQ.1 .OR. ANS(1).EQ.'D')GO TO 310
      ACCEPT 370,ANS(4)
      IF(ANS(4).EQ.'E')GO TO 310
      CALL NEWPAG
      CALL IOWAIT(8)
      C0=0.
      C2=0.
      C4=0.
      GO TO 160
  310 KLOG=NLOG
  320 NPTS=NPTV
      DO 330 I=1,NPTS
      X(I)=Z(2049-I)
  330 Y(I)=Y(2049-I)
      IF(IEN.EQ.0) GO TO 350
      DO 340 I=1,8
      IYCAP(I,ICAPY)=IYCAP(I,ICAPY+1)
  340 IYCAP(I,ICAPY+1)='  '
      IXCAP(7,ICAPX)='**'
      IXCAP(8,ICAPX)='2 '
  350 RETURN
  360 FORMAT('$(D)ISPLAY ONLY OR DISPLAY AND (F)IT ? ')
  370 FORMAT(A1)
  380 FORMAT('$(E)NVELOPE OR (L)N RATIO? ')
  390 FORMAT('$INPUT  N1,R1,SI2,M,N : ')
  400 FORMAT('$OR AN EMPIRICAL (A)MPLITUDE FROM DATA FILE? ')
  410 FORMAT('$ENTER A,B,C,E0 ')
  420 FORMAT('$INPUT K2MIN,K2MAX :')
  430 FORMAT(3X,3(2X,'K**2',4X,'LN RATIO',4X,'RF LN RATIO',4X))
  440 FORMAT(3X,3(2X,' K  ',4X,'ENVELOPE',4X,'RF ENVELOPE',4X))
  450 FORMAT(1X,3(F8.4,1X,F12.6,1X,F12.6,3X))
  460 FORMAT('$ENTER FIRST,SECOND PEAK POSITION: ') 
  470 FORMAT('$ENTER SIGMA**2, FIRST,SECOND SHELL: ')
      END
C--------------------SUBROUTINE--AMPINT----------------------------------
C
      SUBROUTINE AMPINT(C,U,V,W,X,NPTS,ENVLOP,NENV)
C * SUBROUTINE TO GENERATE INTERPOLATION TO THE ENVELOP DATA READ IN
C * FROM DISK
      DIMENSION U(1024),V(1024),W(1024),X(1024),C(4,1024),ENVLOP(100,2)
      DO 10 I=1,NENV
      V(I)=ENVLOP(I,1)
      C(1,I)=ENVLOP(I,2)
      C(2,I)=0.
      C(3,I)=0.
   10 C(4,I)=0.
      CALL CUBSPL(V,C,NENV,0,0)
   20 I=1
      K=1
   30 H=X(K)-V(I)
      W(K)=C(1,I)+H*(C(2,I)+H*(C(3,I)+H*C(4,I)/3.)/2.)
      IF(K+1.GT.NPTS)GO TO 50
      IF(I+1.GT.NENV)GO TO 50
      K=K+1
   40 IF(X(K).LT.V(I+1))GO TO 30
      I=I+1
      IF(I.EQ.NENV)GO TO 30
      GO TO 40
   50 NMPTS=K
      K=1
      KK=1
   60 IF(X(K).GE.V(1))GO TO 70
      K=K+1
      KLOW=K
      GO TO 60
   70 V(KK)=X(K)
      X(KK)=X(K)
      W(KK)=W(K)
      U(KK)=U(K)
      IF(NMPTS.EQ.K)GO TO 80
      KK=KK+1
      K=K+1
      GO TO 70
   80 NPTS=KK
      RETURN
      END
C---------------------SUBROUTINE--AMPRD---------------------------------
C 
      SUBROUTINE AMPRD(V,W,X,NPTS,ENVLOP,NENV)
C * SUBROUTINE TO READ IN AN IMPIRICAL AMPLITUDE FOR LN RATIO ANALYSIS
      DIMENSION V(1024),W(1024),X(1024),NAMES(25),ENVLOP(100,2)
      LOGICAL*1 NAME(25),NAMES,ZERO,KOPT,LOPT
      DATA ZERO/O0/
      CALL NEWPAG
      GO TO 20
   10 CALL FILES(3,NAME,25,0,0,0,LUNIT)
   20 TYPE 150
      ACCEPT 160,(NAMES(I),I=1,25)
      DO 30 I=1,25
      NAME(I)=NAMES(I)
   30 IF(NAME(I).EQ.' ')NAME(I)=ZERO
      CALL FILES(3,NAME,25,0,1,0,LUNIT)
      READ(LUNIT,170,ERR=40) (NAMES(I),I=1,25)
      GO TO 50
   40 TYPE *,'FILE NOT FOUND'
      GO TO 10
   50 READ(LUNIT,180) KOPT,LOPT,IFRM,ISUM,IDGL
      IF(ISUM.EQ.9)GO TO 60
      TYPE *,'WRONG FILE FOR AMPLITUDE ENVELOPE'
      GO TO 10
   60 READ(LUNIT,190) FLINE,DSPACE,SNOFF,EEDGE,ESHFT,NX
      READ(LUNIT,200) XI,XJ,FLA
      READ(LUNIT,210) XNMIN,YNMIN,STPHGT,NEL1,NEL2,MCM,NR
      READ(LUNIT,220) XKMIN,XKMAX,KNUM,SCPTS,IPRCNT,KPOWR
      READ(LUNIT,230) XRMIN,XRMAX
      READ(LUNIT,240,END=70) (V(I),W(I),I=1,1024)
   70 CALL FILES(3,NAME,25,0,0,0,LUNIT)
D	TYPE *,' FINISHED READING THE FILE '
      NPTV=I-1
   80 IF(V(NPTV).NE.0.)GO TO 90
      NPTV=NPTV-1
      GO TO 80
   90 K=1
      DO 100 I=1,NPTV
      IF(V(I).LT.(X(1)-1.E-4))GO TO 100
      V(K)=V(I)
      W(K)=W(I)
      IF(K.EQ.NPTS)GO TO 110
      K=K+1
  100 CONTINUE
      NPTS=K-1
  110 J=1
      DO 130 L=2,NPTS-1
      IF(J.GT.100)GO TO 140
      IF(V(L).GT.V(L+1))GO TO 140
      IF(W(L).GT.W(L-1) .AND. W(L).GT.W(L+1))GO TO 120
      IF(W(L).LT.W(L-1) .AND. W(L).LT.W(L+1))GO TO 120
      GO TO 130
  120 ENVLOP(J,1)=V(L)
      ENVLOP(J,2)=ABS(W(L))
      J=J+1
  130 CONTINUE
  140 NENV=J-1
      RETURN
  150 FORMAT($'   TYPE FILE NAME FOR INPUT: ')
  160 FORMAT(25A1)
  170 FORMAT(/,21X,25A1)
  180 FORMAT(40X,/,17X,/,10X,I1,1X,I1,2X,A2,2(2X,I1))
  190 FORMAT(29X,F10.0,/,26X,F10.5,/,21X,F10.2,/,30X,F10.2,
     1/,18X,F10.2,22X,I2)
  200 FORMAT(37X,2(2PE12.4,5X),7X,1PE12.4)
  210 FORMAT(2(8X,2PE12.4),10X,1PE12.4,2(2X,I3),24X,I2,11X,I2)
  220 FORMAT(7X,1PE12.4,9X,2PE12.4,/,22X,I4,24X,0PF6.0,
     1/,20X,I2,19X,I1)
  230 FORMAT(25X,/,7X,1PE12.4,9X,1PE12.4,10X)
  240 FORMAT(4(5X,1P2E13.5))
      END
C---------------SUBROUTINE--AXES-----------------------------
C
      SUBROUTINE AXES(XMIN,XMAX,XDEL,NE,NXTX,TKT)
C * THIS SUBROUTINE COMPUTES THE NUMBER AND SCALING OF THE TICK
C * MARKS ALONG THE X-AXIS.
      INTEGER*4 IXMIN,IXMAX,IDELX
      DELX=XMAX-XMIN
      TKT=0.
      NE=0
   10 IF(DELX.GT. 5.)GO TO 20
      DELX=DELX*10.
      NE=NE+1
      GO TO 10
   20 IF(DELX.LE. 50.)GO TO 30
      DELX=DELX/10.
      NE=NE-1
      GO TO 20
   30 XMIN=XMIN*(10.**NE)
      IXMIN=XMIN-1.
      XMAX=XMAX*(10.**NE)
      IXMAX=XMAX+1.
      IDELX=IXMAX-IXMIN
      IF(IDELX.GT.10)GO TO 40
      XDEL=1.*(10.**(-NE))
      GO TO 60
   40 IF(IDELX.GT.25)GO TO 50
      XDEL=2.*(10.**(-NE))
      GO TO 60
   50 XDEL=5.*(10.**(-NE))
   60 XMIN=FLOAT(IXMIN)*(10.**(-NE))
      XMAX=FLOAT(IXMAX)*(10.**(-NE))
      NXTX=(XMAX-XMIN)/XDEL-.5
      IF(XMIN.LT.0. .AND. XMAX.GT.0.)TKT=1.
      IF(XMAX.LT.0. .AND. XMIN.GT.0.)TKT=1.
      RETURN
      END
C-----------------SUBROUTINE--BAKFFT--------------------------------------
C	CORRECTION MADE BY MOHAN -011686
C
      SUBROUTINE BAKFFT(U,V,W,X,Y,EQK,EQCHI,T,NPTS,NPTV,XKMIN,XKMAX,
     1KTALLY,IPRCNT,KNUM,KFIRST,KPOWR,SCPTS)
C * THIS SUBROUTINE TAKES AN INVERSE FAST FOURIER TRANSFORM OF A DESIRED
C * RANGE OF DATA INPUT VIA THE CURSER IN R-SPACE. THE INVERSED TRANSFORMED
C * DATA IS TRUNCATED AT THE PREVIOUSLY DETERMINED KMIN-KMAX VALUES.
      DIMENSION U(1024),V(1024),W(1024),X(1024),Y(1024),EQK(2048),
     C    EQCHI(2048),T(8192)
      COMPLEX T
	INTEGER TOL
      LOGICAL*1 PREV,NOSAVE,REP,AUTO,BELL
      DATA PREV,NOSAVE,REP,AUTO,BELL/'P','N','R','S',O7/
      TWOPI=6.28318531
      DO 10 I=1,NPTS
   10 U(I)=EQCHI(I)
   20 CALL VCURSR(KEY,XRMIN,YRMIN)
      IF(KEY.EQ.NOSAVE)GO TO 30
      CALL FILES(1,'CONST.HLD',9,0,1,1,LUNIT)
      READ(LUNIT'1) GARB
      IF(KEY.NE.PREV) GO TO 30
      READ(LUNIT'4) XKMIN,XKMAX,IPRCNT,KPOWR,KNUM,SCPTS
      READ(LUNIT'5) XRMIN,XRMAX
   30 DO 40 I=1,NPTS
   40 IF(X(I).LE.XRMIN.AND.X(I+1).GT.XRMIN)GO TO 50
      IRBEG=1
      XRMIN=X(1)
      YRMIN=Y(1)
      GO TO 60
   50 IRBEG=I
      XRMIN=X(I)
      YRMIN=Y(I)
60    IF(KEY.EQ.AUTO) THEN
        T1=I
	IF(Y(I).LT.Y(I+1)) THEN
           DO 61 I=T1,NPTS
61	   IF((Y(I).GT.Y(I+1)).AND.(Y(I).GT.Y(I+2))) GOTO 65
  	ELSE 
           DO 63 I=T1,1,-1
63	   IF((Y(I).GT.Y(I-1)).AND.(Y(I).GT.Y(I-2))) GOTO 65
65      ENDIF
        CALL CROSS(X(I),Y(I),10)
C	CALL IOWAIT(2)		!TAKEN OUT FOR SPEED -(MR)
	CALL MOVABS(2,500)	!FOR TEK	-(MR)
	CALL ALFMOD
	TYPE 200, BELL
200	FORMAT('$T% ',A1)
	ACCEPT *,TOL
	DO 66 J=I,1,-1
	TEMP1=Y(J-1)
	T1=I+I-J+1
	TEMP2=Y(T1)
	TEMP3=((ABS(TEMP1-TEMP2))*100./(TEMP1+TEMP2))
	IF (TEMP3.GE.TOL) GOTO 68
66	CONTINUE
68	IRBEG=J
	XRMIN=J
	IREND=I+(I-J)
	XRMAX=I+(I-J)
	CALL CROSS (X(IRBEG),Y(IRBEG),10)
	CALL CROSS (X(IREND),Y(IREND),10)
      ELSE
69 	CALL CROSS(XRMIN,YRMIN,10)
C	CALL IOWAIT(5)		!TAKEN OUT   -(MR)
	IF(KEY.EQ.PREV)GO TO 70
	CALL VCURSR(ANYKEY,XRMAX,YRMAX)
70	DO 80 I=1,NPTS
80	IF(X(I).LT.XRMAX.AND.X(I+1).GE.XRMAX)GO TO 90
	IREND=NPTS
	XRMAX=X(NPTS)
	YRMAX=Y(NPTS)
	GO TO 100
90	IREND=I
	XRMAX=X(I)
	YRMAX=Y(I)
100	CALL CROSS(XRMAX,YRMAX,10)
C	CALL IOWAIT(5)		!TAKEN OUT  -(MR)
	IF(KEY.EQ.PREV)GO TO 110
      ENDIF
101   CALL VCURSR(IKEY,XR,YR)
      IF(IKEY.EQ.REP) GO TO 110
      IF(KEY.EQ.NOSAVE)GO TO 120
      WRITE(LUNIT'5) XRMIN,XRMAX
  110 CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
      IF(IKEY.EQ.REP)GO TO 20
  120 DO 130 I=1,KNUM
      IF(I.GE.IRBEG.AND.I.LE.IREND)GO TO 130
      T(I)=(0.,0.)
  130 CONTINUE
      CALL NEWPAG
      DO 140 K=1,14
      IF(2**K-KNUM) 140,160,150
  140 CONTINUE
  150 K=K-1
  160 CALL FFT(T,K,-1)
      NPTV=KTALLY
      WNORM=.5*SCPTS
      YJUMP=2.
      DO 180 I=1,NPTV
      KINDEX=KFIRST+I-1
      T(KINDEX)=CONJG(T(KINDEX))
      TKR=REAL(T(KINDEX))/WNORM
      TKI=AIMAG(T(KINDEX))/WNORM
      V(I)=EQK(I)
      W(I)=TKR
      PHJ=ATAN2(TKI,TKR)
      IF(I.EQ.1)GO TO 170
      IF(PHJ.LT.-2.0 .AND. PHI.GT.2.0)YJUMP=YJUMP+1.
  170 EQCHI(I)=PHJ+(YJUMP+.25)*TWOPI
  180 PHI=PHJ
      RETURN
      END
	SUBROUTINE  BLDPHA
	
	CALL FILES(3,'TEOLEE.PHT',10,1,1,4,MUNIT)
	LASTRC=1
	DO 10 I=1,1000
	IREC=I
10	WRITE(MUNIT'IREC)LASTRC
	CALL FILES(3,'TEOLEE.PHT',10,0,0,0,MUNIT)
	CALL FILES(4,'PARAM.PHF',9,1,1,3,NUNIT)
	LSTREC=1
	DO 20 I=1,100
	IREC=I
20	WRITE(NUNIT'IREC)LSTREC
	CALL FILES(4,'PARAM.PHF',9,0,0,0,NUNIT)
	RETURN
	END
C------------------SUBROUTINE--BOXES---------------------------------
C
      SUBROUTINE BOXES(V,W,N)
C * SUBROUTINE TO DRAW BOXES
      CALL MOVEA(V,W)
      CALL MOVREL(N,N)
      CALL DRWREL(-N,0)
      CALL DRWREL(0,-N)
      CALL DRWREL(N,0)
      CALL DRWREL(0,N)
      RETURN
      END
C------------------SUBROUTINE--CODE------------------------------------
C
      SUBROUTINE CODE(XVAL,NEX,NCHAR,IADE)
C * SUBROUTINE TO ENCODE TICK LABELS
      LOGICAL*1 CHAR,ZERO(2)
      DIMENSION CHAR(10),IADE(10)
      DATA ZERO/'0','.'/
      XX=XVAL*(10.**NEX)
      NCHAR=0
   10 IF(ABS(XX).LT.1.)GO TO 20
      XX=XX/10.
      NCHAR=NCHAR+1
      GO TO 10
   20 IF(XX.LT.0.)NCHAR=NCHAR+1
      IF(XX.EQ.0.)GO TO 40
      XX=XVAL*(10.**NEX)
      ENCODE(10,70,CHAR) XX
      J=9-NCHAR
      NCHAR=NCHAR+1
      DO 30 I=1,NCHAR
   30 IADE(I)=CHAR(I+J)
      GO TO 60
   40 DO 50 I=1,2
   50 IADE(I)=ZERO(I)
      NCHAR=2
   60 RETURN
   70 FORMAT(F10.0)
      END
	SUBROUTINE CONHLD
C---------------------CONHLD-------------------------------------------
C
C * PROGRAM TO SET UP A CONST.HLD FILE FOR USE WITH THE EXAPLT PROGRAM
C * CONST.HLD SHOULD BE MAINTAINED ON THE SYSTEM DISK WITH THE EXAPLT
C * PROGRAM 
      FLINE=2000.
      DSPACE=1.92
      SNOFF=0.
      EEDGE=8978.8
      ESHFT=0.
      XI=35.
      XJ=900.
      XNMIN=-20.
      YNMIN=3.E-2
      STPHGT=1.9E-2
      NEL1=45
      NEL2=389
      MCM=0
      NR=3
      IREG=0
      XKMIN=3.5
      XKMAX=15.5
      IPRCNT=10
      KPOWR=1
      KNUM=4096
      SCPTS=4096.
      XRMIN=2.2
      XRMAX=2.8
      GARB=0.
      XMIN=0.
      XMAX=1.
      YMIN=0.
      YMAX=1.
      CALL FILES(1,'CONST.HLD',9,1,1,1,LUNIT)
      WRITE(LUNIT'1) FLINE,DSPACE,SNOFF,EEDGE
      WRITE(LUNIT'2) ESHFT,XI,XJ,XNMIN,YNMIN
      WRITE(LUNIT'3) STPHGT,NEL1,NEL2,MCM,NR,IREG
      WRITE(LUNIT'4) XKMIN,XKMAX,IPRCNT,KPOWR,KNUM,SCPTS
      WRITE(LUNIT'5) XRMIN,XRMAX
      WRITE(LUNIT'6) XMIN,XMAX,YMIN,YMAX
      WRITE(LUNIT'7) XMIN,XMAX,YMIN,YMAX
      WRITE(LUNIT'8) XMIN,XMAX,YMIN,YMAX
      WRITE(LUNIT'9) GARB
      WRITE(LUNIT'10)GARB
      CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
	RETURN
      END
C--------------SUBROUTINE--CROSS------------------------------------------
C
C	CORRECTION MADE BY MOHAN -011686
      SUBROUTINE CROSS(XIN,YIN,ISIZ)
C * DRAWS A CROSS OF SCREEN SIZE DESIRED AT POINT XIN-YIN.
      CALL MOVEA(XIN,YIN)
      CALL MOVREL(0,-ISIZ)
C      CALL IOWAIT(1)
      CALL DRWREL(0,2*ISIZ)
C      CALL IOWAIT(1)
      CALL MOVREL(-ISIZ,-ISIZ)
C      CALL IOWAIT(1)
      CALL DRWREL(2*ISIZ,0)
C      CALL IOWAIT(1)
      CALL MOVEA(XIN,YIN)
      RETURN
      END
C--------------------SUBROUTINE--CUBSP--------------------------------
C
      SUBROUTINE CUBSP(T,C,N,IBCBEG,IBCEND)
C * THIS PROGRAM CALCULATES THE POLYNOMIAL COEFFICIENTS FOR A CUBIC
C * INTERPOLATING SPLINE WITH INTERIOR KNOTS AT  T(I),T(I+1),...,T(N-1).
C * THE CUBIC SPLINE FUNCTION IS GIVEN BY
C *              F(K)=C(I,1)+H*(C(I,2)+H*(C(I,3)+H*C(I,4)/3.)/2.)
C * WHERE H=XV(K)-T(I).  THE XV(K) ARE EVENLY SPACED X VALUES.
      INTEGER IBCBEG,IBCEND,N,I,J,K,L,M
      DIMENSION T(20),C(20,4)
      L=N-1
      DO 10 M=2,N
C * COMPUTE FIRST DIFFERENCES AND STORE IN C(.,3),ALSO,COMPUTE DIVIDED
C * DIFFERENCES AND STORE IN C(.,4).
      C(M,3)=T(M)-T(M-1)
   10 C(M,4)=(C(M,1)-C(M-1,1))/C(M,3)
C * CONSTRUCT FIRST EQUATION FROM BOUNDARY CONDITIONS, OF THE FORM
C *              C(1,4)*S(1)+C(1,3)*S(2)=C(1,2)
      IF(IBCBEG-1) 20,40,50
   20 IF(N.GT.2) GO TO 30
C * NO CONDITION AT LEFT END AND N.GT.2
      C(1,4)=1.
      C(1,3)=1.
      C(1,2)=2.*C(2,4)
      GO TO 120
C * NOT-A-KNOT CONDITION AT AT LEFT END
   30 C(1,4)=C(3,3)
      C(1,3)=C(2,3)+C(3,3)
      C(1,2)=((C(2,3)+2.*C(1,3))*C(2,4)*C(3,3)+C(2,3)**2*C(3,4))/C(1,3)
      GO TO 70
C * SLOPE PRESCRIBED AT LEFT END
   40 C(1,4)=1.
      C(1,3)=0.
      GO TO 60
C * SECOND DERIVATIVE PRESCRIBED AT LEFT END
   50 C(1,4)=2.
      C(1,3)=1.
      C(1,2)=3.*C(2,4)-C(2,3)/2.*C(1,2)
   60 IF(N.EQ.2) GO TO 120
C * IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
C * CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION AFTER WHICH THE M-TH
C * EQUATION IS       C(M,4)*S(M)+C(M,3)*S(M+1)=C(M,2)
   70 DO 80 M=2,L
      G=-C(M+1,3)/C(M-1,4)
      C(M,2)=G*C(M-1,2)+3.*(C(M,3)*C(M+1,4)+ C(M+1,3)*C(M,4))
   80 C(M,4)=G*C(M-1,3)+2.*(C(M,3)+C(M+1,3))
C * CONSTRUCT LAST EQUATION FROM THE BOUNDARY CONDITIONS OF THE FORM
C *            -G*C(N-1,4)*S(N-1)+C(N,4)*S(N)=C(N,2)
C * IF THE SLOPE IS PRECRIBED AT RIGHT END, ONE CAN GO DIRECTLY
C * TO BACK-SUBSTITUTION, SINCE THE C ARRAY HAPPENS TO BE SET UP JUST
C * RIGHT FOR IT NOW.
      IF(IBCEND-1) 90,160,110
   90 IF(N.EQ.3 .AND. IBGBEG.EQ.0)GO TO 100
C * NOT-A-KNOT AND N.GE.3 ,AND EITHER N.GT.3 OR ALSO NOT-A-KNOT AT LEFT
C * END POINT.
      G=C(N-1,3)+C(N,3)
      C(N,2)=((C(N,3)+2.*G)*C(N,4)*C(N-1,3)
     C   +C(N,3)**2*(C(N-1,1)-C(N-2,1))/C(N-1,3))/G
      G=-G/C(N-1,4)
      C(N,4)=C(N-1,3)
      GO TO 150
C * EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT END) OR (N=2 AND NOT-A-KNOT
C * AT LEFT END).
  100 C(N,2)=2.*C(N,4)
      C(N,4)=1.
      GO TO 140
C * SECOND DERIVATIVE PRESCRIBED AT RIGHT END
  110 C(N,2)=3.*C(N,4)+C(N,3)/2.*C(N,2)
      C(N,4)=2.
      GO TO 140
  120 IF(IBCEND-1) 130,160,110
  130 IF(IBCBEG.GT.0) GO TO 100
C * NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N=2
      C(N,2)=C(N,4)
      GO TO 160
  140 G=-1./C(N-1,4)
C * COMPLETE THE FORWARD PASS OF GAUSS ELIMINATION
  150 C(N,4)=G*C(N-1,3)+C(N,4)
      C(N,2)=(G*C(N-1,2)+C(N,2))/C(N,4)
C * CARRY OUT BACK-SUBSTITUTION
  160 DO 170 J=L,1,-1
  170 C(J,2)=(C(J,2)-C(J,3)*C(J+1,2))/C(J,4)
C * GENERATE CUBIC COEEFICIENTS IN EACH INTERVAL, I.E., THE DERIV.S
C * AT ITS LEFT ENDPOINT, FROM VALUE AND SLOPE AT ITS ENDPOINTS.
      DO 180 I=2,N
      DTAU=C(I,3)
      DIVDF1=(C(I,1)-C(I-1,1))/DTAU
      DIVDF3=C(I-1,2)+C(I,2)-2.*DIVDF1
      C(I-1,3)=2.*(DIVDF1-C(I-1,2)-DIVDF3)/DTAU
  180 C(I-1,4)=(DIVDF3/DTAU)*(6./DTAU)
      RETURN
      END
C--------------------SUBROUTINE--CUBSPL--------------------------------
C
      SUBROUTINE CUBSPL(T,C,N,IBCBEG,IBCEND)
C * THIS PROGRAM CALCULATES THE POLYNOMIAL COEFFICIENTS FOR A CUBIC
C * INTERPOLATING SPLINE WITH INTERIOR KNOTS AT  T(I),T(I+1),...,T(N-1).
C * THE CUBIC SPLINE FUNCTION IS GIVEN BY
C *              F(K)=C(I,1)+H*(C(I,2)+H*(C(I,3)+H*C(I,4)/3.)/2.)
C * WHERE H=XV(K)-T(I).  THE XV(K) ARE EVENLY SPACED X VALUES.
      INTEGER IBCBEG,IBCEND,N,I,J,K,L,M
      DIMENSION T(1024),C(4,1024)
      L=N-1
      DO 10 M=2,N
C * COMPUTE FIRST DIFFERENCES AND STORE IN C(.,3),ALSO,COMPUTE DIVIDED
C * DIFFERENCES AND STORE IN C(.,4).
      C(3,M)=T(M)-T(M-1)
   10 C(4,M)=(C(1,M)-C(1,M-1))/C(3,M)
C * CONSTRUCT FIRST EQUATION FROM BOUNDARY CONDITIONS, OF THE FORM
C *              C(1,4)*S(1)+C(1,3)*S(2)=C(1,2)
      IF(IBCBEG-1) 20,40,50
   20 IF(N.GT.2) GO TO 30
C * NO CONDITION AT LEFT END AND N.GT.2
      C(4,1)=1.
      C(3,1)=1.
      C(2,1)=2.*C(4,2)
      GO TO 120
C * NOT-A-KNOT CONDITION AT AT LEFT END
   30 C(4,1)=C(3,3)
      C(3,1)=C(3,2)+C(3,3)
      C(2,1)=((C(3,2)+2.*C(3,1))*C(4,2)*C(3,3)+C(3,2)**2*C(4,3))/C(3,1)
      GO TO 70
C * SLOPE PRESCRIBED AT LEFT END
   40 C(4,1)=1.
      C(3,1)=0.
      GO TO 60
C * SECOND DERIVATIVE PRESCRIBED AT LEFT END
   50 C(4,1)=2.
      C(3,1)=1.
      C(2,1)=3.*C(4,2)-C(3,2)/2.*C(2,1)
   60 IF(N.EQ.2) GO TO 120
C * IF THERE ARE INTERIOR KNOTS, GENERATE THE CORRESPONDING EQUATIONS AND
C * CARRY OUT THE FORWARD PASS OF GAUSS ELIMINATION AFTER WHICH THE M-TH
C * EQUATION IS       C(M,4)*S(M)+C(M,3)*S(M+1)=C(M,2)
   70 DO 80 M=2,L
      G=-C(3,M+1)/C(4,M-1)
      C(2,M)=G*C(2,M-1)+3.*(C(3,M)*C(4,M+1)+ C(3,M+1)*C(4,M))
   80 C(4,M)=G*C(3,M-1)+2.*(C(3,M)+C(3,M+1))
C * CONSTRUCT LAST EQUATION FROM THE BOUNDARY CONDITIONS OF THE FORM
C *            -G*C(N-1,4)*S(N-1)+C(N,4)*S(N)=C(N,2)
C * IF THE SLOPE IS PRECRIBED AT RIGHT END, ONE CAN GO DIRECTLY
C * TO BACK-SUBSTITUTION, SINCE THE C ARRAY HAPPENS TO BE SET UP JUST
C * RIGHT FOR IT NOW.
      IF(IBCEND-1) 90,160,110
   90 IF(N.EQ.3 .AND. IBCBEG.EQ.0)GO TO 100
C * NOT-A-KNOT AND N.GE.3 ,AND EITHER N.GT.3 OR ALSO NOT-A-KNOT AT LEFT
C * END POINT.
      G=C(3,N-1)+C(3,N)
      C(2,N)=((C(3,N)+2.*G)*C(4,N)*C(3,N-1)
     C   +C(3,N)**2*(C(1,N-1)-C(1,N-2))/C(3,N-1))/G
      G=-G/C(4,N-1)
      C(4,N)=C(3,N-1)
      GO TO 150
C * EITHER (N=3 AND NOT-A-KNOT ALSO AT LEFT END) OR (N=2 AND NOT-A-KNOT
C * AT LEFT END).
  100 C(2,N)=2.*C(4,N)
      C(4,N)=1.
      GO TO 140
C * SECOND DERIVATIVE PRESCRIBED AT RIGHT END
  110 C(2,N)=3.*C(4,N)+C(3,N)/2.*C(2,N)
      C(4,N)=2.
      GO TO 140
  120 IF(IBCEND-1) 130,160,110
  130 IF(IBCBEG.GT.0) GO TO 100
C * NOT-A-KNOT AT RIGHT ENDPOINT AND AT LEFT ENDPOINT AND N=2
      C(2,N)=C(4,N)
      GO TO 160
  140 G=-1./C(4,N-1)
C * COMPLETE THE FORWARD PASS OF GAUSS ELIMINATION
  150 C(4,N)=G*C(3,N-1)+C(4,N)
      C(2,N)=(G*C(2,N-1)+C(2,N))/C(4,N)
C * CARRY OUT BACK-SUBSTITUTION
  160 DO 170 J=L,1,-1
  170 C(2,J)=(C(2,J)-C(3,J)*C(2,J+1))/C(4,J)
C * GENERATE CUBIC COEEFICIENTS IN EACH INTERVAL, I.E., THE DERIV.S
C * AT ITS LEFT ENDPOINT, FROM VALUE AND SLOPE AT ITS ENDPOINTS.
      DO 180 I=2,N
      DTAU=C(3,I)
      DIVDF1=(C(1,I)-C(1,I-1))/DTAU
      DIVDF3=C(2,I-1)+C(2,I)-2.*DIVDF1
      C(3,I-1)=2.*(DIVDF1-C(2,I-1)-DIVDF3)/DTAU
  180 C(4,I-1)=(DIVDF3/DTAU)*(6./DTAU)
      RETURN
      END
C----------------------SUBROUTINE--DECOMP----------------------------------
C
      SUBROUTINE DECOMP(NN,UL,IPS)
C * SUBROUTINE TO DECOMPOSE THE MATRIX
      DIMENSION UL(4,4),SCALES(4),IPS(4)
      DOUBLE PRECISION UL
      N=NN
C * INITIALIZE IPS AND SCALES
      DO 50 I=1,N
      IPS(I)=I
      ROWNRM=0.0
      DO 20 J=1,N
      IF(ROWNRM-ABS(UL(I,J))) 10,20,20
   10 ROWNRM=ABS(UL(I,J))
   20 CONTINUE
      IF(ROWNRM)30,40,30
   30 SCALES(I)=1.0/ROWNRM
      GO TO 50
   40 CALL SING(1)
      SCALES(I)=0.0
   50 CONTINUE
C * GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
      NM1=N-1
      DO 130 K=1,NM1
      BIG=0.0
      DO 70 I=K,N
      IP=IPS(I)
      SIZE=ABS(UL(IP,K))*SCALES(IP)
      IF(SIZE-BIG)70,70,60
   60 BIG=SIZE
      IDXPIV=I
   70 CONTINUE
      IF(BIG)90,80,90
   80 CALL SING(2)
      GO TO 130
   90 IF(IDXPIV-K)100,110,100
  100 J=IPS(K)
      IPS(K)=IPS(IDXPIV)
      IPS(IDXPIV)=J
  110 KP=IPS(K)
      PIVOT=UL(KP,K)
      KP1=K+1
      DO 120 I=KP1,N
      IP=IPS(I)
      EM=-UL(IP,K)/PIVOT
      UL(IP,K)=-EM
      DO 120 J=KP1,N
      UL(IP,J)=UL(IP,J)+EM*UL(KP,J)
C * INNER LOOP
  120 CONTINUE
  130 CONTINUE
      KP=IPS(N)
      IF(UL(KP,N)) 150,140,150
  140 CALL SING(2)
  150 RETURN
      END
C------------------SUBROUTINE--DEGLIT-------------------------------------
C
      SUBROUTINE DEGLIT(X,Y,V,W,NPTS)
C * THIS SUBROUTINE ALLOWS INTERACTIVE DEGLITCHING WITH THE CURSER.
      DIMENSION X(1024),Y(1024),V(1024),W(1024)
      LOGICAL*1 C1
      DATA C1/'E'/
   10 CALL VCURSR(INP,XI,YI)
      IF(INP.EQ.C1)GO TO 70
      CALL CROSS(XI,YI,10)
      CALL VCURSR(JNP,XJ,YJ)
      CALL CROSS(XJ,YJ,10)
      DO 20 I=1,NPTS
      IF(X(I).GT.XI)GO TO 30
   20 CONTINUE
   30 I=I-1
      K=I-1
      DO 40 J=1,NPTS
      IF(X(J).GT.XJ)GO TO 50
   40 CONTINUE
   50 DO 60 L=1,J-K
      W(L+K)=((Y(J)-Y(K+1))/(X(J)-X(K+1)))*(X(L+K)-X(K+1))+Y(K+1)
   60 CONTINUE
      GO TO 10
   70 CALL NEWPAG
      RETURN
      END
C-------------SUBROUTINE--DIAMND-------------------------------------
C
      SUBROUTINE DIAMND(V,W,N)
C * SUBROUTINE TO DRAW DIAMONDS FOR DATA POINTS
      CALL MOVEA(V,W)
      CALL MOVREL(0,N)
      CALL DRWREL(N,-N)
      CALL DRWREL(-N,-N)
      CALL DRWREL(-N,N)
      CALL DRWREL(N,N)
      RETURN
      END
C--------------------SUBROUTINE--DIFF----------------------------------
C
      SUBROUTINE DIFF(X,Y,V,W,NPTS)
C * SUBROUTINE TO CALCULATE DIFFERENTIAL FUNCTION OF Y DATA ARRAY
      DIMENSION X(1024),Y(1024),V(1024),W(1024)
      NP=NPTS-1
      DENOM=X(2)-X(1)
      W(1)=(Y(2)-Y(1))/DENOM
      DO 10 I=2,NP
      DENOM=X(I+1)-X(I)
   10 W(I)=(Y(I+1)-Y(I))/DENOM
      W(NPTS)=W(NP)
      RETURN
      END
C--------------------------SUBROUTINE--DIFFIT---------------------------
C 
      SUBROUTINE DIFFIT(U,V,W,X,NPTS,C0,C1)
C * SUBROUTINE TO LINEAR LEAST-SQUARES FIT A PHASE LAG DIFFERENCE
C *                 PLD=C0*X+C1*X**3
      DIMENSION U(1024),V(1024),W(1024),X(1024),A(4,4),B(4),ANSWER(4)
      DOUBLE PRECISION A,B,ANSWER
      DO 10 I=1,NPTS
   10 U(I)=W(I)-U(I)
      DO 30 J=1,2
      DO 20 I=1,2
   20 A(J,I)=0.0D0
      B(J)=0.0D0
   30 ANSWER(J)=0.0D0
      DO 40 I=1,NPTS
      XI=X(I)
      UI=U(I)
      A(1,1)=XI**2+A(1,1)
      A(2,1)=XI**4+A(2,1)
      A(1,2)=A(2,1)
      A(2,2)=XI**6+A(2,2)
      B(1)=UI*XI+B(1)
   40 B(2)=UI*XI**3+B(2)
      CALL MATINV(A,B,ANSWER,2)
      C0=ANSWER(1)
      C1=ANSWER(2)
      DO 50 I=1,NPTS
      V(I)=X(I)
   50 W(I)=C0*X(I)+C1*X(I)**3
      RETURN
      END
	subroutine direct
	character*80 cmd,pass
10	format (' Directory command: ',$)
20	format (a80)
	write (5,10)
	read (5,20) pass
	cmd(1:4)='dir '
	cmd(5:80)=pass(1:76)
	call lib$spawn(cmd)
	return
	end
C---------------------SUBROUTINE--EDGDIF---------------------------------
C 
      SUBROUTINE EDGDIF(T,U,V,W,NPTV,X,Y,CC,NPTS,J,
     C    EMIN,YMIN,EMAX,YMAX,EDIF)
C * SUBROUTINE TO READ IN MULTIPLE XANES OR EDGE DATA FILES FOR DISPLAY
C * OR DIFFERENCING 
      DIMENSION T(2048),U(2048),V(1024),W(1024),X(1024),
     C    Y(1024),Z(4,1024),NAMES(25),YDIF(4)
      LOGICAL*1 NAME(25),NAMES,ZERO,KOPT,LOPT,INPUT
      DATA ZERO/O0/
      CALL NEWPAG
      NREF=0
      J=0
      DEFALT=0.
C * LOAD CUBSPL ARRAYS WITH INPUT ARRAY DATA
      NPTV=NPTS
      DO 10 I=1,NPTV
      Z(1,I)=Y(I)
   10 W(I)=X(I)
C * SET UP RANGE OF INTERPOLATION AND DISPLAY
      TYPE 250
      ACCEPT 260,INPUT
      IF(INPUT.EQ.'Q')GO TO 230
      TYPE 280
      ACCEPT *, NUM
      IF(NUM.LT.0.OR.NUM.GT.3)NUM=0
      IF(INPUT.NE.'D')GO TO 20
      TYPE 270
      ACCEPT *,NREF
      IF(NREF.LT.0 .OR. NREF.GT.NUM) NREF=0
   20 TYPE 290
      ACCEPT *,EMIN,EMAX
      IF(EMIN.EQ.0..AND.EMAX.EQ.0.)DEFALT=1.
      IF(DEFALT.EQ.1..OR. EMIN.LT.X(1))EMIN=X(1)
      IF(DEFALT.EQ.1..OR. EMAX.GT.X(NPTS))EMAX=X(NPTS)
      NUMPTS=500
      DELTA=EMAX-EMIN
      DO 30 I=1,NUMPTS
      FAC=FLOAT(I-1)/FLOAT(NUMPTS-1)
   30 V(I)=EMIN+FAC*DELTA
      GO TO 150
C * PROMPT FOR ENERGY RANGE OF DISPLAY AND NAMES OF THREE ADDITIONAL FILES TO
C * BE DISPLAYED OR DIFFERENCED
   40 CALL FILES(3,NAME,25,0,0,0,LUNIT)
   50 TYPE 300,J+1
      ACCEPT 310,(NAMES(I),I=1,25)
      IOKAY=0
      DO 60 I=1,25
      IF(NAMES(I).NE.' ')IOKAY=1
      NAME(I)=NAMES(I)
   60 IF(NAME(I).EQ.' ')NAME(I)=ZERO
      IF(IOKAY.EQ.0)GO TO 190
      CALL FILES(3,NAME,25,0,1,0,LUNIT)
      READ(LUNIT,320,ERR=70) (NAMES(I),I=1,25)
      GO TO 80
   70 TYPE *,'FILE NOT FOUND' 
      GO TO 40
   80 READ(LUNIT,330) KOPT,LOPT,IFRM,ISUM,IDGL
      IF(ISUM.EQ.4)GO TO 90
      TYPE *,'WRONG FILE FOR EDGE OR XANES DISPLAY'
      GO TO 40
   90 READ(LUNIT,340) FLINE,DSPACE,SNOFF,EEDGE,ESHFT,NX
      IF(NX.EQ.0)GO TO 100
      READ(LUNIT,350) XI,XJ
      READ(LUNIT,360) XNMIN,YNMIN,STPHGT,NEL1,NEL2,MCM,NR
  100 READ(LUNIT,370,END=110) (W(I),Z(1,I),I=1,1024)
  110 CALL FILES(3,NAME,25,0,0,0,LUNIT)
      NPTV=I-1
      J=J+1
  120 IF(W(NPTV).NE.0.)GO TO 130
      NPTV=NPTV-1
      GO TO 120
C * SHIFT ENERGY SCALES OF INPUT FILES
  130 ENSH=0.
      TYPE 240,J
      ACCEPT *,ENSH
      IF(ENSH.GT.20. .OR. ENSH.LT. -20.)ENSH=0.
      ISTART=1
      DO 140 I=1,NPTS
  140 W(I)=W(I)-ENSH
C * INTERPOLATE INPUT DATA
  150 TYPE *,'WAIT A FEW MOMENTS FOR SPLINE COMPUTATION'
      CALL CUBSPL(W,Z,NPTV,0,0)
      I=1
      K=1
  160 H=V(K)-W(I)
      YK=Z(1,I)+H*(Z(2,I)+H*(Z(3,I)+H*Z(4,I)/3.)/2.)
      IF(V(K).LT.W(I))YK=-1.E30
      IF(J.EQ.0)U(K+1024)=YK
      IF(J.EQ.1)T(K)=YK
      IF(J.EQ.2)T(K+1024)=YK
      IF(J.EQ.3)U(K)=YK
      IF(K+1.GT.NUMPTS)GO TO 180
      IF(I.EQ.NPTV)W(NPTV)=2.E3
      IF(I.EQ.NPTV)W(NPTV+1)=W(NPTV)
      K=K+1
  170 IF(V(K).LT.W(I+1))GO TO 160
      I=I+1
      IF(I.EQ.NPTV)GO TO 160
      GO TO 170
  180 IF(J.EQ.NUM)GO TO 190
      GO TO 50
  190 NPTV=NUMPTS
      EDIF=1.
      DO 220 I=1,NUMPTS
      IF(INPUT.NE.'D')GO TO 210
C * COMPUTE EDGE DIFFERENCE CURVES IF DIFFERENCE OPTION IS SELECTED
      EDIF=2. 
      YDIF(1)=U(I+1024)
      IF(J.GT.0)YDIF(2)=T(I)
      IF(J.GT.1)YDIF(3)=T(I+1024)
      IF(J.GT.2)YDIF(4)=U(I)
      YDIFF=YDIF(NREF+1)
      J1=J+1
      DO 200 JJ=1,J1
      IF(YDIFF .GT. -1.E30) GO TO 200
      YDIF(JJ)=-1.E30
  200 IF(YDIF(JJ) .GT. -1.E30) YDIF(JJ)=YDIF(JJ)-YDIFF
      U(I+1024)=YDIF(1)
      IF(J.GT.0)T(I)=YDIF(2)
      IF(J.GT.1)T(I+1024)=YDIF(3)
      IF(J.GT.2)U(I)=YDIF(4)
      IF(I.EQ.1)YMAX=0.
      IF(I.EQ.1)YMIN=0.
C * DETERMINE PLOT SCALE
  210 W(I)=U(I+1024)
      IF(W(I).GT.YMAX)YMAX=W(I)
      IF(J.GT.0.AND.T(I).GT.YMAX)YMAX=T(I)
      IF(J.GT.1.AND.T(I+1024).GT.YMAX)YMAX=T(I+1024)
      IF(J.GT.2.AND.U(I).GT.YMAX)YMAX=U(I)
      IF(W(I).LT.YMIN)YMIN=W(I)
      IF(J.GT.0.AND.T(I).LT.YMIN)YMIN=T(I)
      IF(J.GT.1.AND.T(I+1024).LT.YMIN)YMIN=T(I+1024)
      IF(J.GT.2.AND.U(I).LT.YMIN)YMIN=U(I)
  220 CONTINUE
      IF(YMAX.EQ.YMIN)YMAX=YMIN+.1
  230 RETURN
  240 FORMAT('$TYPE EDGE SHIFT #',I1,' : ')
  250 FORMAT('$(P)LOT EDGES OR (D)IFFERENCE EDGES: ')
  260 FORMAT(A1)
  270 FORMAT('$ENTER REFERENCE FILE NUMBER (0-3) : ')
  280 FORMAT('$ENTER NUMBER OF INPUT FILES (0-3 ;DEFAULT=0) : ')
  290 FORMAT('$ENTER ENERGY RANGE  EMIN,EMAX ;DEFAULT=MAX RANGE: ')
  300 FORMAT('$TYPE INPUT FILE NAME #',I1,': ')
  310 FORMAT(25A1)
  320 FORMAT(/,21X,25A1)
  330 FORMAT(40X,/,17X,/,10X,I1,1X,I1,2X,A2,2(2X,I1))
  340 FORMAT(29X,F10.0,/,26X,F10.5,/,21X,F10.2,/,30X,F10.2,
     1/,18X,F10.2,22X,I2)
  350 FORMAT(37X,2(2PE12.4,5X))
  360 FORMAT(2(8X,2PE12.4),10X,1PE12.4,2(2X,I3),24X,I2,11X,I2)
  370 FORMAT(4(5X,1P2E13.5))
      END
C-------------------SUBROUTINE--EDGPLT------------------------------
C
      SUBROUTINE EDGPLT(T,U,V,NPTV,J)
C * SUBROUTINE TO OVERDRAW XANES EDGE SPECTRA OR DIFFERENCE SPECTRA
      DIMENSION T(2048),U(2048),V(1024)
      IF(J.EQ.0)GO TO 110
      DO 100 K=1,J
      NST=2
      N=-1
      DO 90 I=1,NPTV
      N=N+1
      VX=V(I)
      IF(K-2)10,20,30
   10 VY=T(I)
      IF(VY.EQ. -1.E30)GO TO 50
      IF(N.NE.2*NST)GO TO 90
      N=0
      GO TO 80
   20 VY=T(I+1024)
      IF(VY.EQ. -1.E30)GO TO 50
      IF(N.EQ.0)GO TO 60
      IF(N.LT.0)GO TO 90
      IF(N.EQ.(2*NST))N=-2*NST
      GO TO 70
   30 VY=U(I)
      IF(VY.EQ. -1.E30)GO TO 50
      IF(N.EQ.0)GO TO 60
      IF(N.LT.0)GO TO 40
      IF(N.EQ. 3*NST)N=-3*NST
      GO TO 70
   40 IF(N.EQ.-NST .OR. N.EQ.-2.*NST)GO TO 80
      GO TO 90
   50 N=-1
   60 CALL MOVEA(VX,VY)
      GO TO 90
   70 CALL DRAWA(VX,VY)
      GO TO 90
   80 CALL POINTA(VX,VY)
   90 CONTINUE
  100 CONTINUE
  110 RETURN
      END
C------------------SUBROUTINE--ESHIFT--------------------------------
C
      SUBROUTINE ESHIFT(X,Y,V,W,NPTS,ESH)
C * RECALIBRATES THE DATA AS REQUIRED USING THE CURSER.
      DIMENSION X(1024),Y(1024),V(1024),W(1024)
      LOGICAL*1 NOSAVE,PREV,INPUT,LOAD
      DATA PREV/'P'/,NOSAVE/'N'/,INPUT/'I'/,LOAD/'L'/
      CALL VCURSR(KEY,ESH,Y0)
      IF(KEY.EQ.NOSAVE)GO TO 10
      GO TO 30
   10 DO 20 I=1,NPTS
      V(I)=X(I)-ESH
   20 CONTINUE
      GO TO 70
   30 CALL FILES(1,'CONST.HLD',9,0,1,1,LUNIT)
      READ(LUNIT'1) GARB
      IF(KEY.EQ.PREV)GO TO 40
      IF(KEY.NE.LOAD .AND. KEY.NE.INPUT)GO TO 50
      CALL NEWPAG
      CALL ALFMOD
      TYPE 80 
      ACCEPT *,ESH
      GO TO 50
   40 READ(LUNIT'2) ESH,GARB1,GARB2,GARB3,GARB4
      GO TO 60
   50 WRITE(LUNIT'2) ESH,GARB1,GARB2,GARB3,GARB4
   60 CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
      IF(KEY.EQ.LOAD) GO TO 70
      GO TO 10
   70 RETURN
   80 FORMAT(/,'$TYPE EDGE SHIFT [IN EV"S]: ')
      END
C---------------SUBROUTINE--ESPACE-------------------------------------
C	CORRECTION MADE BY MOHAN - 011486
C
      SUBROUTINE ESPACE(X,Y,V,W,NPTS)
C * CONVERTS MONOCHROMETER STEP NUMBER TO ENERGY.
      DIMENSION X(1024),Y(1024),V(1024),W(1024)
      DATA RADEG/1.745329E-2/
C      CALL FILES(10,'TMPFIL',6,0,0,0,LUNIT)	
      CALL SETUP(SPDMON,D,STEPOF,EDGNRG,FORM)
C      CALL FILES(10,'TMPFIL',6,2,1,0,LUNIT)	
      ERGNUM=12398.52/(2.*D)
      DO 10 I=1,NPTS
      V(I)=ERGNUM/SIN(RADEG*(-X(I)-STEPOF)/SPDMON)-EDGNRG
   10 CONTINUE
      RETURN
      END
C	subroutine exafit
C	character*80 cmd,pass
C	character*6 cli
C	cli = '...DCL'
C	cmd='run/task:exafit dl1:[1,1]exafit           '
C	type *, ' EXAPLT TRANSFERING CONTROL TO EXAFIT PROGRAM'
C	call detach
C	call spawn(rad50(cli),,,1,,,,cmd,40,,,ids)
C	call waitfr(1)
C	type *,' EXAFIT IS NOW RETURNING TO EXAPLT'
C	call attach
C	return
C	end
C---------------------SUBROUTINE--EXPAND---------------------------------
C
      SUBROUTINE EXPAND(XL,YL,XH,YH,U)
C * EXPANDS THE PLOT TO THE NEW WINDOW VALUES DETERMINED BY THE CURSER.
C * STORES THE NEW VALUES IN THE REPLOT STACK, AND OPTIONALLY STORES THE
C * WINDOW VALUES ON DISK FOR LATER RECALL.
      DIMENSION U(4,3),CURNT(4)
      LOGICAL*1 KEY(4)
      DATA KEY/'1','2','3','S'/
      CALL VCURSR(LKEY,XLOW,YLOW)
      DO 10 I=1,4
   10 IF(LKEY .EQ. KEY(I))GO TO 20
      GO TO 40
   20 CALL FILES(1,'CONST.HLD',9,0,1,1,LUNIT)
      READ(LUNIT'1) GARB
      IF(LKEY .EQ. KEY(4)) GO TO 40
      DO 30 I=1,3
      J=I+5
   30 IF(LKEY .EQ. KEY(I)) READ(LUNIT'J) XLO,YLO,XHI,YHI
      XL=XLO
      YL=YLO
      XH=XHI
      YH=YHI
      GO TO 120
   40 CALL MOVEA(XLOW,YLOW)
      CALL DRWREL(10,0)
      CALL MOVREL(-10,10)
      CALL DRWREL(0,-10)
      CALL VCURSR(KKEY,XHIGH,YHIGH)
      CALL MOVEA(XHIGH,YHIGH)
      CALL DRWREL(-10,0)
      CALL MOVREL(10,-10)
      CALL DRWREL(0,10)
      IF(LKEY .NE. KEY(4))GO TO 60
      DO 50 I=1,3
      J=I+5
   50 IF(KKEY .EQ. KEY(I)) WRITE(LUNIT'J) XLOW,YLOW,XHIGH,YHIGH
   60 CURNT(1)=XLOW
      CURNT(2)=YLOW
      CURNT(3)=XHIGH
      CURNT(4)=YHIGH
      DO 70 I=1,4
      IF(U(I,1) .NE. CURNT(I))GO TO 90
   70 CONTINUE
   80 GO TO 110
   90 DO 100 J=1,4
      U(J,3)=U(J,2)
      U(J,2)=U(J,1)
  100 U(J,1)=CURNT(J)
  110 XL=CURNT(1)
      YL=CURNT(2)
      XH=CURNT(3)
      YH=CURNT(4)
      IF(LKEY .NE. KEY(4))GO TO 130
  120 CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
  130 RETURN
      END
C---------------------SUBROUTINE--FFT------------------------------------
C
      SUBROUTINE FFT(A,M,IS)
C * THIS SUBROUTINE CALCULATES THE FAST-FOURIER TRANSFORM OF THE 
C * 2**M ELEMENTS OF THE COMPLEX ARRAY A, WHERE IS=+1 OR -1 IS THE
C * SIGN OF THE COMPLEX EXPONENTIAL (NOTE THAT THE INITIAL ARRAY A
C * IS REPLACED BY ITS FOURIER TRANSFORM ARRAY).  THE FIRST PART
C * IS A BIT-REVERSED PERMUTATION USING A RECURSIVE ALGORITHM, WHICH
C * INCREMENTS A REVERSED INDEX WHEN NEEDED FOR EACH BIT POSITION.
C * THE FINAL PART, FROM STATEMENT LABEL 7, IS A BASE-2 FFT COMPUTATION,
C * WHICH REQUIRES MINIMUM DIFFERENT PHASE ADJUSTER W, GENERATED
C * RECURSIVELY.
      DIMENSION A(1),IRA(16),NR(16)
      COMPLEX A,TEMP,W,D
      INTEGER IRA,NR,SPAN,STEP
      DATA PI/3.141592653589793/
C * REVERSED INDEX SETS (FOR EACH BIT POSITION) INITIALIZED
      IF(IS.EQ.1) TYPE *,'FAST FOURIER TRANSFORMING ...'
      IF(IS.EQ.-1) TYPE *,'FAST FOURIER BACK-TRANSFORMING ...'
      N=2**M
      DO 10 J=1,M
      IRA(J)=0 
   10 NR(J)=2**(J-1)
C * THIS PREVENTS NULLIFYING THE DOUBLE SWAP
      IF=1
   20 IR=IRA(M)+1
      IF(IR.LE.IF)GO TO 30
C * REVERSED INDEX PAIR IS SWAPPED
      TEMP=A(IF)
      A(IF)=A(IR)
      A(IR)=TEMP
C * INCREMENT FORWARD INDEX IF
   30 IF=IF+1
C * ALTERNATE INCREMENT OF IRA(J), MUST GO BACK ONE BIT
      IF(IF.GT.N)GO TO 70
      J=M
   40 IF(IRA(J).LT.NR(J))GO TO 50
C * A SIMPLE ALTERNATE OF THE REVERSED INDEX
      J=J-1
      GO TO 40
   50 IRA(J)=IRA(J)+NR(J)
C * WORK FORWARD THROUGH REVERSED INDEX BIT SET
   60 IF(J.EQ.M)GO TO 20
      IRA(J+1)=IRA(J)
C * THE ARRAY IS NOW IN BIT-REVERSED ORDER,M COMPUTING PASSES FOLLOW
      J=J+1
      GO TO 60
C * SPAN BETWEEN ELEMENTS IN THE PAIR, STEP TO THE NEXT PAIR
C * WITH THE SAME W
   70 DO 90 J1=1,M
      SPAN=2**(J1-1)
      STEP=2*SPAN
C * STARTING PHASE ADJUSTER W,MODIFIER D
      W=(1.,0.)
      D=CEXP(CMPLX(0.,PI/SPAN))
      IF(IS.LT.0)D=CONJG(D)
C * INNER LOOP ARITHMETIC - TWO POINT TRANSFORMS
      DO 90 J2=1,SPAN
      DO 80 J=J2,N,STEP
      K=J+SPAN
      TEMP=A(K)*W
      A(K)=A(J)-TEMP
   80 A(J)=A(J)+TEMP
C * RECURSIVE MODIFICATION OF THE PHASE ADJUSTER W
   90 W=W*D
      RETURN 
      END
C-----------------SUBROUTINE--FILES------------------------------------
C
      SUBROUTINE FILES(L,FLNAME,N,J,K,NN,M)
C * SUBROUTINE TO HANDLE ALL OF THE FILE MANAGEMENT FOR THE EXAPLT PROGRAM
      LOGICAL*1 DEV1(4),DEV3(4),DEV10(4),ZERO
      LOGICAL*1 FLNAME(26),FILNAM(30)
      INTEGER TEMP,TEMP2,I,J,K,L,M,NN,N
      DATA DEV1/' ',' ',' ',' '/,DEV3/' ',' ',' ',' '/,
     C DEV10/' ','T','I',':'/,ZERO/O0/,FILNAM/30*O0/
C * SYSTEM DEPENDENT CONVENTIONS FOR THIS COMPUTER SYSTEM ARE:
C
C *        L=1 ******** LOGICAL UNIT #1 ; SYSTEM DISKETTE
C *        L=2            "      "   #2 ; DEFAULT DISKETTE
C *        L=3            "      "   #3 ; DEFAULT DISKETTE
C *        L=4            "      "   #4 ; DEFAULT DISKETTE
C *        L=5            "      "   #5 ; READ FROM CONSOL TERMINAL
C *        L=6            "      "   #6 ; LINE PRINTER
C *        L=7            "      "   #7 ; WRITE TO CONSOL TERMINAL
C *        L=10           "      "   #10; DEVICE FOR GRAPHIC MODE OUTPUT
C

      TEMP=0
      IF(K) 10, 20, 30
   10 M=L
      GO TO 60
   20 M=L
      CLOSE(M)
      GO TO 60
   30 M=L
      DO 40 I=1,N
      IF(FLNAME(I).EQ.' ')FLNAME(I)=ZERO
      TEMP2=FLNAME(I)
      IF(TEMP2.EQ.58) TEMP=1
   40 FILNAM(I+4)=FLNAME(I)
      DO 50 I=1,4
      IF(TEMP.EQ.1) THEN 
	FILNAM(I)=DEV3(I)
      ELSE
	FILNAM(I)=DEV1(I)
      ENDIF
      IF(L.EQ.10) FILNAM(I)=DEV10(I)
   50 CONTINUE
      NUM=N+4
      IF(NN.EQ.1) DEFINE FILE M(10,10,U,NREC)
      IF(NN.EQ.3) DEFINE FILE M(100,25,U,NREC)
      IF(NN.EQ.4) DEFINE FILE M(1000,25,U,NREC)
      IF(J.EQ.0) CALL ASSIGN(M,FILNAM,NUM,'OLD')
      IF(J.EQ.1) CALL ASSIGN(M,FILNAM,NUM,'NEW')
      IF(J.EQ.2) CALL ASSIGN(M,DEV10)
   60 RETURN 
      END
C----------------------SUBROUTINE--FLUOR-------------------------------
C
      SUBROUTINE FLUOR(X,Y,V,W,NPTS,NPTV,NX)
C * SUBPROGRAM TO ADJUST THE FLUORESCENCE SIGNAL BY A STEP CORRECTION
C * FACTOR
      DIMENSION X(1024),Y(1024),V(1024),W(1024),C(4,2)
      IF(NX.NE.1)GO TO 70
C * READ IN STORED PARAMETERS
   10 CALL FILES(1,'CONST.HLD',9,0,1,1,LUNIT)
      READ(LUNIT'1) GARB,GARB,GARB,EEDGE      
      READ(LUNIT'2) GARB,GARB,GARB,XNMIN,GARB
      READ(LUNIT'3) STPHGT,IGARB,IGARB,MCM,IGARB,IGARB
      READ(LUNIT'9) NX,FLA,GARB,GARB,GARB
      CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
C * PROMPT FOR FLUORESCENCE ADJUSTMENT PARAMETER 
      CALL NEWPAG
      CALL ALFMOD
      CALL IOWAIT(3)
      TYPE 60
      ACCEPT * ,FLA
      A=FLA
C * READ IN MCMASTER COEFFICIENTS
      IF(MCM.EQ.0)GO TO 30
      TYPE *,'MCMASTER COEFFICIENTS MUST BE DETERMINED'
      CALL IOWAIT(15)
      CALL MCMSTR(C)
C * COMPUTE MCMASTER STEP AT XNMIN
      SUM0=0.
      SUM00=0.
      HNU=.001*(EEDGE+XNMIN)
      DO 20 I=1,4
      SUM0=SUM0+C(I,1)*ALOG(HNU)**(I-1)
   20 SUM00=SUM00+C(I,2)*ALOG(HNU)**(I-1)
C * ADJUST FLUORESCENCE SIGNAL
   30 DO 50 I=1,NPTS
      V(I)=X(I)
      W(I)=Y(I)
      WSTP=STPHGT*W(I)
      IF(MCM.EQ.0)GO TO 50
      HNU=.001*(EEDGE+V(I))
      SUM1=0.
      SUM11=0.
      DO 40 J=1,4
      SUM1=SUM1+C(J,1)*ALOG(HNU)**(J-1)
   40 SUM11=SUM11+C(J,2)*ALOG(HNU)**(J-1)
      WSTP=W(I)*STPHGT*(EXP(SUM1)-EXP(SUM11))/(EXP(SUM0)-EXP(SUM00))
   50 IF(A.NE.WSTP.AND.A.NE.0.)W(I)=WSTP/(A-WSTP)
C * STORE PARAMETERS IN DISK FILE
      CALL FILES(1,'CONST.HLD',9,0,1,1,LUNIT)
      READ(LUNIT'1) GARB
      WRITE(LUNIT'9)NX,FLA,GARB,GARB,GARB
      CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
      NPTV=NPTS
   60 FORMAT('$ENTER THE FLUORESCENCE CORRECTION FACTOR "A" : ')
   70 RETURN
      END
C-----------------SUBROUTINE--FORFFT-----------------------------------------
C
      SUBROUTINE FORFFT(CC,X,Y,V,W,EQK,EQCHI,T,NPTS,NPTV,XKMIN,XKMAX,
     1KTALLY,IPRCNT,KNUM,KFIRST,KPOWR,SCPTS,IPH)
C * THIS SUBROUTINE DOES A SPLINE INTERPOLATION FOR EVENLY SPACED DATA
C * IN WAVEVECTOR SPACE AND THEN MULTIPLIES THE DATA BY A MODIFIED
C * HANNING WINDOW.  THE RESULTANT ARRAY IS FOURIER TRANSFORMED IN THE
C * LAST SECTION OF THIS SUBROUTINE.
      DIMENSION X(1024),Y(1024),V(1024),W(1024),T(8192),
     CEQCHI(2048),EQK(2048),CC(4,1024),S(1024)
      LOGICAL*1 PREV,NOSAVE,BELL
      COMPLEX T,TK
      DOUBLE PRECISION H
      DATA NOSAVE,PREV,BELL/'N','P',O7/
C * INTERACTIVE AND CURSER INPUTS OF DESIRED K-RANGE TO TRANSFORM,
C * PERCENT WINDOWING, POWER FACTOR (N) FOR A K**N WEIGHTED TRANSFORM,AND
C * LAST, THE NUMBER OF POINTS TO BE TRANSFORMED.
   10 CALL VCURSR(KEY,XKMIN,YKMIN)
      IF(KEY.EQ.PREV)GO TO 110
   20 DO 30 I=1,NPTS-1
   30 IF(X(I).LE.XKMIN.AND.X(I+1).GT.XKMIN)GO TO 40
      XKMIN=X(1)
      YKMIN=Y(1)
      GO TO 50
   40 XKMIN=X(I)
      YKMIN=Y(I)
   50 CALL CROSS(XKMIN,YKMIN,10)
      CALL VCURSR(ANYKEY,XKMAX,YKMAX)
      DO 60 I=1,NPTS-1
   60 IF(X(I).LT.XKMAX.AND.X(I+1).GE.XKMAX)GO TO 70
      XKMAX=X(NPTS)
      YKMAX=Y(NPTS)
      GO TO 80
   70 XKMAX=X(I+1)
      YKMAX=Y(I+1)
   80 CALL CROSS(XKMAX,YKMAX,10)
      CALL ALFMOD
      CALL HOME
      CALL MOVREL(0,-(LINHGT(3)))
      CALL ALFMOD
      TYPE 340,BELL
      ACCEPT *,IPRCNT
      TYPE 350
      ACCEPT *,KPOWR
      TYPE 360
      ACCEPT 370,KNUM
      IF(KNUM.EQ.0)GO TO 90
      IF(KNUM.EQ.1)GO TO 10
      SCPTS=KNUM
      GO TO 100
   90 KNUM=4096
      SCPTS=4096.
  100 IF(KEY.EQ.NOSAVE)GO TO 140
  110 CALL FILES(1,'CONST.HLD',9,0,1,1,LUNIT)
      IF(KEY.NE.PREV)GO TO 120
      READ(LUNIT'4) XKMIN,XKMAX,IPRCNT,KPOWR,KNUM,SCPTS
      GO TO 130
  120 READ(LUNIT'1) GARB
      WRITE(LUNIT'4) XKMIN,XKMAX,IPRCNT,KPOWR,KNUM,SCPTS
  130 CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
C * COMPUTES EQUALLY SPACED WAVENUMBER VALUES IN THE RANGE XKMIN-XKMAX
  140 DO 150 I=1,NPTS-1
      IF(X(I+1).GT.XKMIN .AND. X(I).LE.XKMIN) IBEG=I
      IF(X(I).GE.XKMAX)GO TO 160
  150 CONTINUE
  160 IEND=I
      IF(KEY.NE.PREV) GO TO 170
      CALL CROSS(X(IBEG),Y(IBEG),10)
      CALL CROSS(X(IEND),Y(IEND),10)
  170 IF(IEND.LE.IBEG)GO TO 10
      NUMPTS=IEND-IBEG+1
C * INITIALIZE COMPLEX ARRAY
      DO 180 I=1,8192
  180 T(I)=(0.,0.)
      SCALE=96./SCPTS
      TEST=0.
      IV=1
      KFIRST=0
      DO 190 K1=1,KNUM
      IF(TEST.GT.X(1)) IV=IV+1
      IF(TEST.GT.X(IEND))GO TO 200
      IF(TEST.LT.X(IBEG)) GO TO 190
      IF(TEST.LT.X(IBEG+1).AND.KFIRST.EQ.0)KFIRST=K1
      IF(IPH.EQ.1)PHI=EQK(IV)
      EQK(K1+1-KFIRST)=TEST
      IF(IPH.EQ.1) T(8193-K1)=CMPLX(0.,PHI)
  190 TEST=TEST+SCALE
  200 KLAST=K1-1
      KTALLY=KLAST-KFIRST+1
C * COMPUTES A SPLINE INTERPOLATION OF THE CHI DATA
      DO 210 I=1,NUMPTS
      S(I)=X(I+IBEG-1)
      CC(1,I)=Y(I+IBEG-1)
  210 CONTINUE
      CALL CUBSPL(S,CC,NUMPTS,0,0)
  220 I=1
      K=1
  230 H=EQK(K)-S(I)
      EQCHI(K)=CC(1,I)+H*(CC(2,I)+H*(CC(3,I)+H*CC(4,I)/3.)/2.)
      IF(K+1.GT.KTALLY)GO TO 250
      IF(I+1.GT.NUMPTS)GO TO 250
      K=K+1
  240 IF(EQK(K).LT.S(I+1)) GO TO 230
      I=I+1
      IF(I.EQ.NUMPTS)GO TO 230
      GO TO 240
  250 CONTINUE
C     CALL MOVEA(EQK(1),EQCHI(1))
C      DO 45 I=1,KTALLY
C45    CALL DRAWA(EQK(I),EQCHI(I))
C * MULTIPLY THE INTERPOLATED DATA BY A MODIFIED (IPRCNT)% HANNING
C * WINDOW. THE DATA IS WEIGHTED BY K**(N). THE RESULT IS LOADED INTO
C * THE FFT INPUT ARRAY.
  260 DO 270 I=1,KTALLY
      KINDEX=KFIRST+I-1
      XK=EQK(I)
      TK=1.
      IF(IPH.EQ.1) TK=CEXP(T(8193-KINDEX))
  270 T(KINDEX)=EQCHI(I)*(XK**KPOWR)*WIN(XKMIN,XKMAX,IPRCNT,XK)*TK
C * ZERO THE REST OF THE COMPLEX ARRAY, WHEN THE PHASE OPTION IS EFFECTIVE
      IF(IPH.EQ.0.)GO TO 290
      DO 280 I=1,KNUM
  280 IF(I.LT.KFIRST.OR.I.GT.KLAST) T(I)=(0.,0.)
C * COMPUTE THE FORWARD FOURIER TRANSFORM
  290 CALL NEWPAG
      DO 300 J=1,14
      IF(2**J-KNUM)300,320,310
  300 CONTINUE
  310 J=J-1
  320 CALL FFT(T,J,1)
C * CALCULATION OF THE HARMONIC RADII UP TO 10 ANGSTROMS
      RANGE=KNUM*SCALE
      TNP=RANGE*(10./3.14159)
      NPTV=TNP+1.
      DO 330 I=1,NPTV
      TI=AIMAG(T(I))
      TR=REAL(T(I))
      IRFACT=I-1
      V(I)=(3.14159/RANGE)*IRFACT
      W(I)=CABS(T(I))
  330 EQCHI(I)=ATAN2(TI,TR)
  340 FORMAT('$%',A1)
  350 FORMAT('$K**')
  360 FORMAT('$#')
  370 FORMAT(I6)
      RETURN
      END
C--------------------SUBROUTINE--FRAME----------------------------------
C	CORRECTION APPLIED BY MOHAN - 011486
C
      SUBROUTINE FRAME(XMIN,XMAX,YMIN,YMAX,IXCAP,NXCAP,
     CIYCAP,NYCAP,ICAPX,ICAPY,NAMES,KOPT,LOPT,KLOG,KPW)
C * THIS SUBROUTINE FRAMES THE PLOT, SCALES THE AXES AND
C * ESTABLISHES SCALED TICK MARKS.
      LOGICAL*1 NAMES,KOPT,LOPT
      DIMENSION NAMES(25)
      DIMENSION IXCAP(30,4),NXCAP(4),IYCAP(30,4),NYCAP(4),IDAT(5)
      COMMON /PLOT/XDEL,NEX,NXTX,YDEL,NEY,NYTX,
     CIMIN,IMAX,JMIN,JMAX
C	SUSPECTED GRAPHIC PROBLEM ON 6TH TO BE HERE - (MR) 
C      CALL DATE(IDAT)
C      DECODE(2,10,IDAT)IDAY
C      IF(IDAY .EQ. 0) IDAY=32
C      INUM=100/IDAY
C      N=5*RAN(IDAY,INUM)
	N=1			!FIXED VALUE - (MR)
      IMIN=200+N
      IMAX=1020+N
      JMIN=150+N
      JMAX=770+N
      CALL TWINDO(IMIN,IMAX,JMIN,JMAX)
      CALL AXES(XMIN,XMAX,XDEL,NEX,NXTX,XT)
      CALL AXES(YMIN,YMAX,YDEL,NEY,NYTX,YT)
      CALL DWINDO(XMIN,XMAX,YMIN,YMAX)
      CALL VECMOD
      CALL MOVEA(XMIN,YMIN)
      CALL DRAWA(XMAX,YMIN)
      CALL DRAWA(XMAX,YMAX)
      CALL DRAWA(XMIN,YMAX)
      CALL DRAWA(XMIN,YMIN)
      CALL TICKS(XMIN,XMAX,YMIN,YMAX,XDEL,YDEL,
     CNXTX,XT,XV,NYTX,YT,YV)
      CALL LABEL(XMIN,XMAX,IXCAP,NXCAP,YMIN,YMAX,IYCAP,NYCAP,
     CICAPX,ICAPY,NAMES,KOPT,LOPT,KLOG,XT,YT,XV,YV,KPW)
C      CALL IOWAIT(1)		!NOT REALLY NEEDED-(MR)
      RETURN
   10 FORMAT(I2)
      END
C--------------SUBROUTINE--GRAPH-----------------------
C
      SUBROUTINE GRAPH(V,W,NPTS,N)
C * THIS SUBROUTINE PLOTS THE DATA IN X-Y FORM
      DIMENSION V(1024),W(1024)
      CALL MOVEA(V(1),W(1))
      IF(N-0) 30,10,50
   10 DO 20 I=1,NPTS
   20 CALL DRAWA(V(I),W(I))
      GO TO 70
   30 DO 40 I=1,NPTS,5
      VI=V(I)
      WI=W(I)
   40 CALL DIAMND(VI,WI,2)
      GO TO 70
   50 DO 60 I=1,NPTS,5
      VI=V(I)
      WI=W(I)
   60 CALL BOXES(VI,WI,2)
   70 RETURN
      END
C
C---------------SUBROUTINE--ICODE-------------------------------------
C
      SUBROUTINE ICODE(I,NCHAR,IADE)
C * SUBROUTINE TO ENCODE EXPONENTS
      LOGICAL*1 CHAR
      DIMENSION CHAR(3),IADE(10)
      X=I
      NCHAR=0
   10 IF(ABS(X).LT.0.999) GO TO 20
      X=X/10.
      NCHAR=NCHAR+1
      GO TO 10
   20 IF(I.LT.0)NCHAR=NCHAR+1
      ENCODE(3,40,CHAR) I
      J=3-NCHAR
      DO 30 L=1,NCHAR
   30 IADE(L)=CHAR(L+J)
      RETURN
   40 FORMAT(I3)
      END
C----------------------SUBROUTINE--INTERP----------------------------
C
      SUBROUTINE INTERP(X,V,DELTA,C,S,NPTS,NUMPTS,KLOW,KHIGH)
C * SUBROUTINE TO INTERPOLATE THE THEORETICAL PHASE TABLE
      DIMENSION X(1024),V(1024),DELTA(2048),CC(20,4),S(20),C(20)
      DO 10 J=1,NUMPTS
   10 CC(J,1)=C(J)
      CALL CUBSP(S,CC,NUMPTS,0,0)
      KLOW=1
      I=1
      K=1
   20 H=X(K)-S(I)
      DELTA(K)=CC(I,1)+H*(CC(I,2)+H*(CC(I,3)+H*CC(I,4)/3.)/2.)
      IF(K+1.GT.NPTS) GO TO 40
      IF(I+1.GT.NUMPTS)GO TO 40
      K=K+1
   30 IF(X(K).LT.S(I+1))GO TO 20
      I=I+1
      IF(I.EQ.NUMPTS)GO TO 20
      GO TO 30
   40 NMPTS=K
      K=1
      KK=1
   50 IF(X(K).GE.S(1))GO TO 60
      K=K+1
      KLOW=K
      GO TO 50
   60 V(KK)=X(K)
      DELTA(KK)=DELTA(K)
      IF(NMPTS.EQ.K)GO TO 70
      KK=KK+1
      K=K+1
      GO TO 60
   70 NPTS=KK
      RETURN
      END
C-----------------SUBROUTINE--KEEPIT-------------------------------------
C
      SUBROUTINE KEEPIT(X,Y,V,W,NPTS,NPTV,IDIFF)
C * STORES THE CURRENT MODIFICATIONS ON THE OUTPUT FILE
C * INTO THE INPUT FILE.
      COMMON /KEEP/IPHJ,IPHK,ESHFT,ESH,IDEGL,IDGL,IFT,IFFT,
     1JCAPX,ICAPX,JCAPY,ICAPY,ISML,XNM,XNMIN,XIFIT,XI,
     2XJFIT,XJ
      DIMENSION X(1024),Y(1024),V(1024),W(1024)
      DO 10 I=1,NPTV
      X(I)=V(I)
      IF(IDIFF.EQ.1)GO TO 10
      Y(I)=W(I)
   10 CONTINUE
      NPTS=NPTV
      IF(IPHJ.EQ.1)IPHK=1
      ESHFT=ESH
      IF(IDEGL.EQ.1 .AND. IDGL.EQ.0)IDGL=1
      IF(IFT.EQ.1 .AND. IFFT.EQ.0) IFFT=1
      JCAPX=ICAPX
      JCAPY=ICAPY
      IF(ISML.EQ.0)GO TO 20
      XNM=XNMIN
      XIFIT=XI
      XJFIT=XJ
   20 RETURN
      END
C-----------------SUBROUTINE--KSPACE--------------------------------------
C
      SUBROUTINE KSPACE(X,Y,V,W,NPTS)
C * SUBROUTINE TO CONVERT FROM ENERGY TO WAVENUMBER REPRESENTATION.
      DIMENSION X(1024),Y(1024),V(1024),W(1024)
      DO 10 I=1,NPTS
      SGN=1.0
      IF(X(I).LT.0.)SGN=-1.0
   10 V(I)=SGN*SQRT(0.263*SGN*X(I))
      RETURN
      END
C-------------------SUBROUTINE--LABEL--------------------------------------
C	CORRECTION MADE BY MOHAN -011686
C
C * SUBROUTINE TO ANNOTATE X AND Y AXIS OF PLOT
      SUBROUTINE LABEL(XMIN,XMAX,IXCAP,NXCAP,YMIN,YMAX,IYCAP,
     CNYCAP,ICAPX,ICAPY,NAMES,KOPT,LOPT,KLOG,XT,YT,XV,YV,KPW)
      LOGICAL*1 CHAR1,CHAR2,CHAR3,NAME,NAMES,KOPT,LOPT,ZERO,
     CIDCHAR,LDSTR
      COMMON /PLOT/XDEL,NEX,NXTX,YDEL,NEY,NYTX,
     C    IMIN,IMAX,JMIN,JMAX
      DIMENSION NAMES(25)
      DIMENSION IXCAP(30,4),ICHAR(5),CHAR1(60),CHAR2(5),IYCAP(30,4),
     C    CHAR3(3),IADE(10),IDUM(30),NXCAP(4),NYCAP(4),IDSTR(41),
     CNAME(25),IDCHAR(10),LDSTR(41)
      EQUIVALENCE(IDUM(1),CHAR1(1)),(IDSTR(29),LDSTR(1))
      DATA CHAR2/'X','1','0','L','N'/
      DATA ZERO/O0/
      IONE=LINWDT(1)
      JONE=LINHGT(1)
C * PUT X-AXIS TICK VALUES ON PLOT
      NHGT=JMIN-2*JONE
      IF(XT.EQ.1.)GO TO 10
      CALL CODE(XMIN,NEX,NCHAR,IADE)
      CALL MOVABS(IMIN-(IONE*NCHAR/2),NHGT)
      CALL ANSTR(NCHAR,IADE)
   10 DO 20 I=1,NXTX
      XVAL=XMIN+I*XDEL
      IF(XT.EQ.1.)XVAL=XV+(I-1)*XDEL
      CALL CODE(XVAL,NEX,NCHAR,IADE)
      CALL MOVEA(XVAL,YMIN)
      CALL MOVREL(-(IONE*NCHAR/2),NHGT-JMIN)
   20 CALL ANSTR(NCHAR,IADE)
C * PUT X-AXIS LABEL ON PLOT
      IEX=6
      IF(NEX.EQ.0)IEX=0
      NWIDE=IONE*(NXCAP(ICAPX)+IEX)
      NHGT=JMIN-4*JONE
      CALL MOVABS(((IMIN+IMAX-NWIDE)/2),NHGT)
      DO 30 I=1,30
      IDUM(I)=IXCAP(I,ICAPX)
   30 CONTINUE
      CALL AOUTST(NXCAP(ICAPX),IDUM)
      IF(NEX.EQ.0)GO TO 50
      DO 40 I=1,3
   40 ICHAR(I)=CHAR2(I)
      CALL ANSTR(3,ICHAR)
      CALL ICODE(-NEX,NCHAR,IADE)
      CALL MOVREL(0,JONE/2)
      CALL ANSTR(NCHAR,IADE)
C * PUT Y-AXIS TICK VALUES ON PLOT
   50 IF(YT.EQ.1.)GO TO 60
      CALL CODE(YMIN,NEY,NCHAR,IADE)
      CALL MOVABS(IMIN-IONE*(NCHAR+1),JMIN-(JONE/2))
      CALL ANSTR(NCHAR,IADE)
   60 DO 70 I=1,NYTX
      YVAL=YMIN+I*YDEL
      IF(YT.EQ.1.)YVAL=YV+(I-1)*YDEL
      CALL CODE(YVAL,NEY,NCHAR,IADE)
      CALL MOVEA(XMIN,YVAL)
      CALL MOVREL(-IONE*(NCHAR+1),-(JONE/2))
   70 CALL ANSTR(NCHAR,IADE)
C * PUT YAXIS LABEL ON PLOT
      ILOC=IMIN-IONE*(NCHAR+5)-(IONE/2)
      IF(ILOC.LE.0) GO TO 140
      DO 80 I=1,30
   80 IDUM(I)=IYCAP(I,ICAPY)
      IEY=3
      IF(NEY.EQ.0)IEY=0
      CALL MOVABS(ILOC,(JMIN+JMAX+JONE*(NYCAP(ICAPY)+IEY))/2)
      IF(KLOG.EQ.0)GO TO 110
      IF(KLOG.EQ.3)GO TO 100
      CALL MOVREL(0,3*JONE/2)
      DO 90 I=1,2
      ICHAR(1)=CHAR2(I+3)
      CALL ANCHO(ICHAR(1))
   90 CALL MOVREL(-IONE,-JONE)
      CALL MOVREL(0,-JONE)
      GO TO 110
  100 CALL MOVREL(IONE,-JONE/2)
      CALL ANCHO(KPW)
      CALL MOVREL(-2*IONE,JONE/2)
  110 DO 120 I=1,NYCAP(ICAPY)
      ICHAR(1)=CHAR1(I)
      CALL ANCHO(ICHAR(1))
      CALL MOVREL(-IONE,-JONE)
  120 CONTINUE
      IF(NEY.EQ.0)GO TO 140
      CALL ICODE(-NEY,NCHAR,IADE)
      CALL MOVREL((-((NCHAR+2)*IONE)/2),-2*JONE)
      CALL SEELOC(IX,IY)
      IF(IY.LE.JMIN)GO TO 140
      IF(IX.LE.0)GO TO 140
      DO 130 I=1,3
  130 ICHAR(I)=CHAR2(I)
      CALL ANSTR(3,ICHAR)
      CALL MOVREL(0,JONE/2)
      CALL ANSTR(NCHAR,IADE)
C * PUT FILE NAME, RATIO OPTION AND DATE ON PLOT
  140 CALL MOVABS(IONE/2,JONE)
      CALL DATE(IDCHAR)
	I=1
	J=1
150	IF((NAMES(I).EQ.58).OR.(NAMES(I).EQ.93)) THEN
 	   J=0
	   GO TO 160
	END IF
C        IF(NAMES(I).EQ.ZERO) NAMES(I)=' '
        NAME(J)=NAMES(I)
 160	J=J+1
	I=I+1
	IF(I.LE.25) GO TO 150
      IDCHAR(10)='/'
      ENCODE (41,180,LDSTR) NAME,KOPT,IDCHAR(10),LOPT,
     C(IDCHAR(L),L=1,9)
      DO 170 I=1,41
  170 IDSTR(I)=LDSTR(I)
      CALL ANSTR(41,IDSTR)
      CALL IOWAIT(1)	
      RETURN
  180 FORMAT(25A1,2X,I1,A1,I1,2X,9A1)
      END
C-------------------SUBROUTINE--LSQFIT-----------------------------------
C
      SUBROUTINE LSQFIT(X,Y,NPTS,N,P)
C * SUBROUTINE TO PARAMETERIZE THE PHASE SHIFT FUNCTION USING A
C * LINEAR LEAST-SQUARES FITTING PROCEDURE
      DIMENSION X(1024),Y(1024),A(4,4),B(4),ANSWER(4),IEXP(4),P(4)
      DOUBLE PRECISION A,B,ANSWER
      TWOPI=6.2831853
      DO 20 J=1,N
      DO 10 I=1,N
   10 A(I,J)=0.0D0
      B(J)=0.0D0
      IEXP(J)=J
      IF(N.GT.2) IEXP(J)=J-1
   20 ANSWER(J)=0.0D0
      IF(N.EQ.4)IEXP(4)=-IEXP(4)
      DO 50 I=1,NPTS
      XI=X(I)
      YI=Y(I)
      DO 40 J=1,N
      DO 30 K=J,N
      IE=IEXP(K)+IEXP(J)
      A(K,J)=XI**IE+A(K,J)
   30 A(J,K)=A(K,J)
   40 B(J)=YI*XI**IEXP(J)+B(J)
   50 CONTINUE
      CALL MATINV(A,B,ANSWER,N)
   60 CONTINUE
      DO 70 I=1,N
   70 P(I)=ANSWER(I)
      RETURN 
      END
C-------------------SUBROUTINE--MATINV-------------------------------------
C
      SUBROUTINE MATINV(A,B,C,N)
C * SUBROUTINE TO INVERT THE COEFFICIENT MATRIX
      DIMENSION A(4,4),B(4),C(4),NAR(4),IPS(4)
      DOUBLE PRECISION A,B,C
      IF(N.EQ.1) GO TO 10
      CALL DECOMP(N,A,IPS)
      CALL SOLVE(N,B,C,A,IPS)
      GO TO 20
   10 C(1)=B(1)/A(1,1)
   20 CONTINUE
      RETURN 
      END
C-----------------SUBROUTINE--MCMSTR-----------------------------------
C
      SUBROUTINE MCMSTR(A)
C * SUBROUTINE TO RETRIEVE MCMASTER COEFFICIENTS FROM DISK TABLES
      LOGICAL*1 ATNAME(10),ANS
      DIMENSION A(4,2)
      IABS=1
      CALL NEWPAG
      DO 10 I=1,100
   10 COUNT=I*I
      TYPE *,'FOR MCMASTER TREATMENT, SPECIFY THE MCMASTER
     C COEFFICIENTS'
      TYPE *,'OF THE ABSORBER EDGE AND THE BACKGROUND EDGE.'
      TYPE *,'TYPE ATOMIC NO. OF ABSORBING ELEMENT AND EDGE NO.'
      GO TO 30
   20 TYPE *,'TYPE ATOMIC NO. OF BACKGROUND ELEMENT AND EDGE NO.'
   30 TYPE *,'(1-103),(K=0,L=1,M=2,N=3) AND RETURN'
   40 TYPE 50
   50 FORMAT('$NATOM,NEDGE ? ')
      ACCEPT *,NATOM,NEDGE
      IF(NATOM.LE.0 .OR. NATOM.GT.103)GO TO 160
      IF(NEDGE.GE.0 .AND. NEDGE.LE.3)GO TO 60
      TYPE *,'ILLEGAL EDGE NO. SPECIFIED, TRY AGAIN!'
      GO TO 40
   60 CALL FILES(1,'MCMSTR.TBL',10,0,1,4,NUNIT)
      GO TO 90
   70 TYPE *,'MCMASTER TABLE NOT FOUND ON SYSTEM DISK'
   80 CALL FILES(1,'MCMSTR.TBL',10,0,0,0,NUNIT)
      GO TO 40
   90 NLINE=4*(NATOM-9)+NEDGE
      IF(NLINE.GT.400) NLINE=NLINE-400
      IF(NLINE.LE.0) NLINE=1
      READ(NUNIT'NLINE,ERR=70) ATNAME,(A(J,IABS),J=1,4)
  100 TYPE *,'THE MCMASTER COEFFICIENTS FOR THE'
      TYPE 110, ATNAME,(A(J,IABS),J=1,4)
  110 FORMAT(1X,10A1,' ARE:',4F12.4)
      TYPE 120
  120 FORMAT('$OK? ')
      ACCEPT 130, ANS
  130 FORMAT(A1)
      IF(ANS.EQ.'Y')GO TO 180
      TYPE *,'MCMASTER TABLE ENTRY NOT SPECIFIED OR REQUIRES CHANGE' 
      TYPE 140
  140 FORMAT('$ENTER NAME SPECIFYING THE X-RAY ABSORPTION EDGE :')
      ACCEPT 150,ATNAME
  150 FORMAT(10A1)
      TYPE *,'TYPE COEFFICIENT CHANGES WITH SEPARATING COMMAS,'
      ACCEPT *, (A(I,IABS),I=1,4)
      GO TO 100
  160 DO 170 I=1,4
  170 A(I,IABS)=0.
      GO TO 190
  180 WRITE(NUNIT'NLINE) ATNAME,(A(J,IABS),J=1,4)
      CALL FILES(1,'MCMSTR.TBL',10,0,0,0,NUNIT)
      IF(IABS.EQ.2)GO TO 190
      IABS=2
      GO TO 20
  190 RETURN
      END
C---------------SUBROUTINE--MINMAX--------------------------------
C
      SUBROUTINE MINMAX(X,Y,XMIN,XMAX,YMIN,YMAX,NPTS)
C * THIS SUBROUTINE SEARCHES FOR THE MINIMUM AND MAXIMUM VALUES OF
C * THE DATA IN BOTH THE X AND Y CO-ORDINATES.
      DIMENSION X(1024),Y(1024)
      XMAX=X(1)
      DO 20 J=1,NPTS
      IF(XMAX-X(J))10,20,20
   10 XMAX=X(J)
   20 CONTINUE
      XMIN=XMAX
      DO 40 K=1,NPTS
      IF(X(K)-XMIN)30,40,40
   30 XMIN=X(K)
   40 CONTINUE
      YMAX=Y(1)
      DO 60 J=1,NPTS
      IF(YMAX-Y(J))50,60,60
   50 YMAX=Y(J)
   60 CONTINUE
      YMIN=YMAX
      DO 80 K=1,NPTS
      IF(Y(K)-YMIN)70,80,80
   70 YMIN=Y(K)
   80 CONTINUE
      RETURN
      END
C--------------------SUBROUTINE--NLSOLN----------------------------------
C
      SUBROUTINE NLSOLN(U,V,W,X,NPTS,P,E0,R1,DELR,DELY,RONE,STDEV,
     C    EZERO,IPISCL,ITER,ICONT)
C * PROGRAM TO ITERATE TOWARD A NONLINEAR LEAST-SQUARES FIT OF
C * THE PHASE TABLE DATA TO THE EXPERIMENTAL PHASE DATA
      DIMENSION U(1024),V(1024),W(1024),X(1024),A(4,4),ANSWER(4),
     C    RHS(4),PARSHL(2),P(4)
      DOUBLE PRECISION A,RHS,ANSWER,PARSHL
      TWOPI=6.28318531
      DO 20 I=1,4
      DO 10 J=1,4
   10 A(J,I)=0.0D0
   20 RHS(I)=0.0D0
      SUM1=0.
      SUM2=0.
      DESIRE=0.
      PARSHL(1)=0.0D0
      PARSHL(2)=0.0D0
      IF(E0.EQ.0.) E0=.000001
      IF(DELR.EQ.0) DELR=.000001
      RONE=R1+DELR
      EZERO=E0
      WSCALE=0.
      ISCALE=0.
      VSQDEL=.262467*E0
      DO 60 I=1,NPTS
      CAYSQ=X(I)*X(I)
      CAYN=SQRT(1.-VSQDEL/CAYSQ)
      B0=P(1)-P(3)*VSQDEL
      B1=(P(2)+2.*DELR)*CAYN
      B2=P(3)
      B3=P(4)/(CAYN**3)
      V(I)=X(I)
      W(I)=B0+(B1+B2*X(I))*X(I)+B3/X(I)**3+(VSQDEL*R1/X(I))
      IF(I.GT.1 .OR. ITER.GT.0) GO TO 30
      WSCALE=W(I)/TWOPI
      IF(WSCALE.LT.0.)WSCALE=WSCALE-1.
      ISCALE=WSCALE
      IPISCL=IPISCL-ISCALE
   30 W(I)=W(I)+IPISCL*TWOPI
      PARSHL(1)=X(I)*2.*CAYN
      PARSHL(2)=B1/CAYN+2*P(3)*CAYN*X(I)-3*B3/(CAYN*CAYSQ*CAYSQ)
      PARSHL(2)=-.1312335*(PARSHL(2)/(CAYN)-2*R1)/X(I)
      DELY=U(I)-W(I)
      DO 50 L=1,2
      DO 40 J=1,2
   40 A(J,L)=A(J,L)+PARSHL(J)*PARSHL(L)
   50 RHS(L)=RHS(L)+DELY*PARSHL(L)
      SUM1=DELY*DELY+SUM1
   60 SUM2=SUM2+1.
      STDEV=SQRT(SUM1/SUM2)
      CALL MATINV(A,RHS,ANSWER,2)
      DELR=DELR+ANSWER(1)
      E0=E0+ANSWER(2)
      IF(ABS(ANSWER(1)/R1).LE. .0001)DESIRE=DESIRE+1.
      IF(ABS(ANSWER(2)/E0).LE. .0001)DESIRE=DESIRE+1.
      IF(DESIRE.EQ.2)ICONT=1
      RETURN
      END
C----------------SUBROUTINE--OPTION--------------------------------------
C	CORRECTION MAKE BY MOHAN - 230386
C
      SUBROUTINE OPTION(A,B,X,Y,NPTS,NCHAN,KOPT,LOPT,FORM,KLOG)
C * THIS SUBROUTINE ALLOWS THE PROGRAM USER TO CHOOSE THE OPTIONS
C * DESCRIBED BELOW IN THE FORMAT STATEMENTS FOR CREATING AN OUTPUT
C * DATA ARRAY TO BE LISTED OR LATER PLOTTED AS DESIRED.
      LOGICAL*1 BELL,KOPT,LOPT,ANS,NOPT
      DIMENSION A(1024),B(1024,6),X(1024),Y(1024)
      DATA BELL/O7/
      KLOG=0
      KOPT=0
      LOPT=0
   10 TYPE 120
      TYPE 130
      DO 20 J=1,NCHAN
   20 TYPE 140,J,J
      IF(FORM.EQ.1.)GO TO 30
      TYPE 150
      TYPE 170
      TYPE 180
      TYPE 190,BELL,BELL
      ACCEPT 200 ,KOPT,LOPT
      GO TO 50
   30 TYPE 160
      TYPE 220 ,BELL,BELL
      ACCEPT 230, NOPT
      IF(NOPT.EQ.1)GO TO 40
      IF(NOPT.NE.-1)GO TO 50
      KOPT=6
      LOPT=1
      GO TO 50
   40 KOPT=1
      LOPT=6
   50 IF(KOPT.EQ.0  .OR. LOPT.EQ.0)GO TO 110
      ITEST=0
      DO 60 J=1,NCHAN
      IF(KOPT.EQ.J  .OR. LOPT.EQ.J)ITEST=ITEST+1
      IF(ITEST.EQ.2)GO TO 70
   60 IF((KOPT.EQ.6 .OR.LOPT.EQ.6) .AND. ITEST.EQ.1)GO TO 70
      TYPE *,'  ERROR- ILLEGAL OPTION SPECIFIED '
      GO TO 10
70    TYPE 210
      ACCEPT 240, ANS
      IF(ANS.EQ.'Y')THEN
	IF (FORM.EQ.2.)THEN
          DO 80 I=1,NPTS
		IF(KOPT.EQ.6) THEN
          Y(I)=ALOG(1/B(I,LOPT))
		ELSEIF(LOPT.EQ.6) THEN
          Y(I)=ALOG(B(I,KOPT))
		ELSE
          Y(I)=ALOG(B(I,KOPT)/B(I,LOPT))
		ENDIF
80        X(I)=A(I)		!ALREADY IN ENERGY
	ELSE
          DO 90 I=1,NPTS
		IF(KOPT.EQ.6) THEN
          Y(I)=ALOG(1/B(I,LOPT))
		ELSEIF(LOPT.EQ.6) THEN
          Y(I)=ALOG(B(I,KOPT))
		ELSE
          Y(I)=ALOG(B(I,KOPT)/B(I,LOPT))
		ENDIF
90        X(I)=-A(I)		!SSRL NEG STEP
        ENDIF
        KLOG=1
      ELSE
	IF (FORM.EQ.2.)THEN
           DO 100 I=1,NPTS
		IF(KOPT.EQ.6) THEN
          Y(I)=(1/B(I,LOPT))
		ELSEIF(LOPT.EQ.6) THEN
          Y(I)=(B(I,KOPT))
		ELSE
          Y(I)=(B(I,KOPT)/B(I,LOPT))
		ENDIF
100        X(I)=A(I)		
	ELSE
           DO 105 I=1,NPTS
		IF(KOPT.EQ.6) THEN
          Y(I)=(1/B(I,LOPT))
		ELSEIF(LOPT.EQ.6) THEN
          Y(I)=(B(I,KOPT))
		ELSE
          Y(I)=(B(I,KOPT)/B(I,LOPT))
		ENDIF
105        X(I)=-A(I)	
        ENDIF
      ENDIF
  110 RETURN
  120 FORMAT(10X,'OPTIONS FOR THE OUTPUT DATA ARE AS FOLLOWS: '/)
  130 FORMAT(21X,'<CR>=RETURN TO MAIN PROG.')
  140 FORMAT(23X,I2,'=INPUT CHANNEL #',I2)
  150 FORMAT(24X,'6=CHANNEL # 6;DATA IS INITIALIZED TO UNITY'/)
  160 FORMAT(23X,'-1=INVERSE OF INPUT CHANNEL #1')
  170 FORMAT(10X,' THE OUTPUT DATA WILL HAVE THE FORM')
  180 FORMAT(24X,' I(KOPT)/I(LOPT)'/)
  190 FORMAT('$ENTER [K,L] OPTIONS: ',2A1)
  200 FORMAT(I1,1X,I1)
  210 FORMAT('$DO YOU WANT TO TAKE THE LOG OF Y(I)? (Y/N) ')
  220 FORMAT('$ENTER (1/-1) OPTION: ',2A1)
  230 FORMAT(I2)
  240 FORMAT(A1)
      END
C-------------------SUBROUTINE--OVRPLT----------------------------------
C
      SUBROUTINE OVRPLT(V,W,Z,NPTS)
C * SUBROUTINE TO OVERPLOT THE IMAGINARY PART AND MAGNITUDE OF THE
C * FFT
      DIMENSION V(1024),W(1024),Z(2048)
      CALL MOVEA(V(1),-W(1))
      DO 10 I=1,NPTS
   10 CALL DRAWA(V(I),-W(I))
      ZZ=W(1)*SIN(Z(1))
      CALL MOVEA(V(1),ZZ)
      DO 20 I=1,NPTS
      ZZ=W(I)*SIN(Z(I))
   20 CALL DRAWA(V(I),ZZ)
      RETURN
      END
C--------------------SUBROUTINE--PHAZFT----------------------------------
C
      SUBROUTINE PHAZFT(U,V,W,NPTV,X,Y,Z,NPTS,NAMES,KOPT,LOPT,KLOG,KPW)
C * PROGRAM TO DISPLAY EXPERIMENTAL OR THEORETICAL PHASE FUNCTIONS
C * THEN LEAST SQUARES FIT TO REFERENCE PHASES TO DETERMINE R1 AND
C * E0 OR TO PARAMETERIZE A NON-REFERENCE PHASE RELATIVE TO A STANDARD
      DIMENSION U(1024),V(1024),W(1024),X(1024),Y(2048),Z(2048)
      DIMENSION NAMES(10),ANS(6),TITLE(10),P(4),NAEL(4),NSEL(4)
      LOGICAL*1 NAMES,KOPT,LOPT,ANS,TITLE,NAEL,NSEL
      DIMENSION IXCAP(30,4),IYCAP(30,4),NXCAP(4),NYCAP(4)
      DATA IXCAP/'WA','VE',' V','EC','TO','R ',114*'  '/
      DATA IYCAP/'PH','AS','E ','SH','IF','T ',114*'  '/
      DATA NXCAP,NYCAP/12,0,0,0,12,0,0,0/
      DO 10 I=1,10
   10 IF(NAMES(I).NE.' ')GO TO 30
      NPTS=600
      NPT=0
      DO 20 I=1,NPTS
      SCFAC=3.+96.*(I-1)/4096.
      X(I)=SCFAC
      Y(I)=0.
      V(I)=X(I)
      W(I)=Y(I)
      U(I)=Y(I)
   20 Z(I)=Z(I)
   30 IPISCL=0
      ICONT=0
      ICAPX=1
      ICAPY=1
      E0=0.
      R1=0.
      TWOPI=6.28318531
      NPTV=NPTS
      NPTS=NPTS-20
      DO 40 I=1,NPTV
      Z(2049-I)=X(I)
      Y(2049-I)=Y(I)
      IF(I.GT.NPTS)GO TO 40
      X(I)=X(I+10)
      Y(I)=Y(I+10)
   40 CONTINUE
      DO 50 I=1,6
   50 ANS(I)=' '
      NLOG=KLOG
      KLOG=0
      CALL NEWPAG
	CALL TOUTPT(24)		!SWITCH TO ANSI MODE
   60 TYPE 380
      ACCEPT 390,ANS(1)
      IF(ANS(1).EQ.'E')GO TO 350
      IF(ANS(1).EQ.'F')GO TO 90
      IF(ANS(1).EQ.'L') ANS(6)='P'
      IF(ANS(1).EQ.'L') ANS(1)='D'
      IF(ANS(1).NE.'D')GO TO 60
   70 TYPE 400
      ACCEPT 390,ANS(2)
   80 IF(ANS(2).EQ.'E')GO TO 140
      IF(ANS(2).EQ.'T')GO TO 100
      IF(ANS(2).EQ.'B')GO TO 100
      IF(ANS(2).NE.'S')GO TO 70
      TYPE 460
      ACCEPT 470,NPT
      ANS(2)='E'
      GO TO 140
   90 ANS(2)='B'
      TYPE *,'WHICH DO YOU WANT ?'
      TYPE *,'1-FIT A0+A1K+A2K**2+A3K**-3 TO THE DATA TO OBTAIN A"S OR'
      TYPE *,'2-FIT KNOWN PHASE TO THE DATA TO OBTAIN R1 AND E0 '
      TYPE *,'3-FIT A PHASE LAG DIFFERENCE'
      TYPE 410
      ACCEPT 390,ANS(5)
      IF(ANS(5).EQ.'1')GO TO 140 
  100 TYPE *,'DO YOU WANT TERMINAL (I)NPUT OF YOUR KNOWN PHASE OR A '
      TYPE 420
      ACCEPT 390,ANS(3)
      IF(ANS(3).EQ.'I')GO TO 130
      IF(ANS(3).EQ.'T')GO TO 110
      IF(ANS(3).EQ.'S')IPISCL=1
      IF(ANS(3).NE.'P')GO TO 100
      CALL PHTABL(0,V,W,X,Y,Z,NPTS,ICONT,P,ANS,R1,E0,TITLE,
     C    NAEL,NSEL)
      IF(ICONT.EQ.1)GO TO 350
      GO TO 140 
  110 CALL PHTABL(1,V,W,X,Y,Z,NPTS,ICONT,P,ANS,R1,E0,TITLE,
     C    NAEL,NSEL)
      DO 120 I=1,NPTS
  120 W(I)=Z(I)
      IF(ICONT.EQ.1)GO TO 350
      GO TO 170
  130 TYPE 430
      ACCEPT *,(P(I),I=1,4),E0
  140 IF(IPISCL.EQ.1) TYPE 450
      IF(IPISCL.EQ.1) ACCEPT *,IPISCL
      TYPE 440
      ACCEPT *,R1
      IF(ANS(5).EQ.'3')GO TO 150
      IF(ANS(1).EQ.'F' .OR. ANS(2).EQ.'E')GO TO 170 
  150 VSQDEL=.262467*E0
      DO 160 I=1,NPTS
      CAYSQ=X(I)*X(I)
      CAYN=SQRT(1.-VSQDEL/CAYSQ)
      B0=P(1)-P(3)*VSQDEL
      B1=P(2)*CAYN
      B2=P(3)
      B3=P(4)/(CAYN**3)
      V(I)=X(I)
  160 W(I)=B0+(B1+B2*X(I))*X(I)+B3/(X(I)**3)+VSQDEL*R1/X(I)
      IF(ANS(5).EQ.'1')GO TO 210
      IF(ANS(2).NE.'B')GO TO 210 
  170 YM=Y(1)-2.*R1*X(1)
      WM=W(1)
      DO 180 I=1,NPTS
      YTST=Y(I)-2.*X(I)*R1
      IF(YTST.GT.YM)YM=YTST
      IF(ANS(2).EQ.'E' .OR. ANS(5).EQ.'1')GO TO 180
      IF(W(I).GT.WM)WM=W(I)
  180 CONTINUE
      WSCALE=YM/TWOPI
      IF(WSCALE.LT.0.)WSCALE=WSCALE-1.
      ISCALE=WSCALE
      YM=YM-ISCALE*TWOPI
      IF(ISCALE.LT.0 .AND. YM.GT.5.)ISCALE=ISCALE+1
      IF(ANS(2).EQ.'E' .OR. ANS(5).EQ.'1')GO TO 190
      WSCALE=WM/TWOPI
      IF(WSCALE.LT.0.)WSCALE=WSCALE-1.
      ISC=WSCALE
      WM=WM+(IPISCL-ISC)*TWOPI
      IF(ISC.LT.0 .AND. WM.GT. 5.)ISC=ISC+1
      IF(ISC.GE.0 .AND. WM.GT. 5. .AND. YM.GT. 5.)ISC=ISC+1
  190 VAR=0.
      STDEV=0.
      DO 200 I=1,NPTS
      U(I)=Y(I)-(2.*R1*X(I))-ISCALE*TWOPI
      IF(ANS(2).EQ.'E' .OR. ANS(5).EQ.'1')GO TO 200
      W(I)=W(I)+(IPISCL-ISC)*TWOPI
      IF(ANS(2).NE.'B')GO TO 200
      VAR=VAR+(U(I)-W(I))**2
  200 CONTINUE
      STDEV=SQRT(VAR/NPTS)
      IF(ANS(5).NE.'1')GO TO 210
      CALL LSQFIT(X,U,NPTS,4,P)
      ANS(1)='D'
      ANS(2)='B'
      GO TO 150
  210 IF(ANS(1).EQ.'F' .AND. ANS(5).NE.'3')GO TO 220 
      RONE=R1
      EZERO=E0
      C0=0.
      C1=0.
      IF(ANS(5).EQ.'3')CALL DIFFIT(U,V,W,X,NPTS,C0,C1)
      GO TO 240
  220 DELR=0.
      DELY=0.
      JTER=0
  230 DO 340 ITERNO=1,10
      ITER=(ITERNO-1)+JTER*10
      CALL NLSOLN(U,V,W,X,NPTS,P,E0,R1,DELR,DELY,RONE,STDEV,
     C    EZERO,IPISCL,ITER,ICONT)
  240 CALL PHPLOT(U,V,W,X,NPTS,XMIN,XMAX,YMIN,YMAX,
     C    XT,YT,XV,YV,TITLE,NAMES,ANS,NAEL,NSEL)
      CALL LABEL(XMIN,XMAX,IXCAP,NXCAP,YMIN,YMAX,IYCAP,NYCAP,
     C    ICAPX,ICAPY,NAMES,KOPT,LOPT,KLOG,XT,YT,XV,YV,KPW)
      IF(ANS(2).EQ.'T')GO TO 270
      CALL GRAPH(X,U,NPTS,0)
      IF(ANS(2).NE.'E')GO TO 290
C ************************ WRITING PHASE IN U,V ARRAY
      IF (NPT.EQ.0) GO TO 310
      DO 250 I=1,10
  250 IF (NAMES(I).EQ.'.') NAMES(I+1)='P'
      NDEL=NPTS/NPT
      ISTOR=0
      DO 260 ISTR=1,NPTS,NDEL
      ISTOR=ISTOR+1
      V(ISTOR)=X(ISTR)
  260 W(ISTOR)=U(ISTR)
C************************* 
      GO TO 310
  270 DO 280 I=1,10
  280 NAMES(I)=TITLE(I)
  290 IF(ANS(3).EQ.'T')GO TO 300
      CALL GRAPH(V,W,NPTS,1)
      GO TO 310
  300 CALL GRAPH(V,W,NPTS,-1)
  310 IF(ANS(2).NE.'B' .OR. ANS(5).EQ.'2')GO TO 330
      DELR=0.
      DELY=0.
      DO 320 I=1,NPTS
      DELR=U(I)-W(I)
  320 DELY=DELY+DELR*DELR
      STDEV=SQRT(DELY/NPTS)
  330 CALL PHLABL(1,RONE,EZERO,STDEV,ITER,ANS,ICONT,C0,C1,0.)
      IF(ICONT.EQ.1)GO TO 350
  340 CONTINUE
      IF(ICONT.EQ.1)GO TO 350
      JTER=JTER+1
      GO TO 230
  350 KLOG=NLOG
      IPISCL=0
      IF(ANS(5).NE.'1')GO TO 360
      CALL HOME
      CALL ALFMOD
      CALL PHTABL(2,V,W,X,Y,Z,NPTS,ICONT,P,ANS,R1,E0,TITLE,
     C    NAEL,NSEL)
  360 NPTS=NPTV
      DO 370 I=1,NPTS
      X(I)=Z(2049-I)
  370 Y(I)=Y(2049-I)
      IF (ANS(2).EQ.'E' .AND. NPT.GT.0) NPTV=ISTOR
      RETURN
  380 FORMAT('$(D)ISPLAY ONLY OR DISPLAY AND (F)IT ? ')
  390 FORMAT(A1)
  400 FORMAT('$(E)XPERIMENTAL OR (T)HEORETICAL PHASE OR (B)OTH ? ')
  410 FORMAT('$? ')
  420 FORMAT('$(P)ARAMETERIZED OR (T)ABULAR PHASE FROM DISK TABLES? ')
  430 FORMAT('$ENTER A0,A1,A2,A3,E0 ')
  440 FORMAT('$ENTER R1 FOR YOUR PHASE: ')
  450 FORMAT('$TYPE NUMBER OF TWOPI SHIFTS TO REFERENCE PHASE SHIFT ')
  460 FORMAT(' STORE TOTAL PHASE (PHASE -2KR)!',/,
     C' TYPE NUMBER OF POINTS FOR INTERPOLATION')
  470 FORMAT(I3)
      END
C--------------------SUBROUTINE--PHLABL----------------------------------
C
      SUBROUTINE PHLABL(L,RONE,EZERO,STDEV,ITER,ANS,ICONT,C0,C1,C2)
C * PROGRAM TO LABEL PHASE AND AMPLITUDE PLOT WITH RELEVENT ANNOTATION
      DIMENSION ANS(6)
      LOGICAL*1 ANS,KEY,CONT,QUIT
      DATA CONT,QUIT/'C','Q'/
      CALL MOVABS(LINWDT(1)/2+25,LINHGT(1)+23)
      CALL ALFMOD
	LUNIT=5
C      CALL FILES(5,'TMPFIL',6,0,-1,0,LUNIT)
      IF(ANS(1).EQ.'F' .AND. L.EQ.2)GO TO 10
      IF(L.EQ.2)GO TO 50
      IF(ANS(5).EQ.'2')WRITE(LUNIT,60) RONE,EZERO,STDEV,ITER
      IF(ANS(2).EQ.'B'.AND.ANS(5).NE.'2')
     C    WRITE(LUNIT,60)RONE,EZERO,STDEV
      IF(ANS(2).NE.'B' .AND. ANS(5).EQ.' ')
     C    WRITE(LUNIT,60)RONE,EZERO
      IF(ANS(5).EQ.'3')GO TO 10
      GO TO 20
   10 CALL IOWAIT(5)
      CALL MOVABS(LINWDT(1)/2,LINHGT(2))
      CALL ALFMOD
      IF(L.EQ.2) TYPE 80, C0,C1,C2
      IF(L.NE.2) TYPE 70, C0,C1
   20 CALL IOWAIT(5)
      IF(ANS(5).EQ.'1')GO TO 30
      IF(ANS(5).NE.'2')GO TO 40
      CALL VCURSR(KEY,DUMX,DUMY)
      IF(ITER.EQ.9 .AND. KEY.NE.CONT) ICONT=1
      IF(KEY.EQ.QUIT)ICONT=1
      GO TO 50
   30 CALL IOWAIT(20)
   40 ICONT=1
   50 RETURN
   60 FORMAT(1X,T28,'R1=',F7.4,2X,:,'E0=',F10.4,2X,:,
     C    'STD=',F9.5,2X,:,'I=',I2)
   70 FORMAT(1X,T35,'C1=',F12.6,2X,'C3=',F12.6)
   80 FORMAT(1X,T35,'C0=',F12.6,2X,'C2=',F12.6,
     C/,1X,T36,'C4=',F12.6)
      END
C-------------------SUBROUTINE--PHPLOT-----------------------------------
C
      SUBROUTINE PHPLOT(U,V,W,X,NPTS,XMIN,XMAX,YMIN,YMAX,
     C     XT,YT,XV,YV,TITLE,NAMES,ANS,NAEL,NSEL)
C * SUBROUTINE TO SET UP THE PHASE PLOTTING AND LN RATIO PLOTTING
      DIMENSION U(1024),V(1024),W(1024),X(1024),ANS(6),NAMES(10),
     C    TITLE(10),NAEL(4),NSEL(4)
      LOGICAL*1 NAME,NAMES,ANS,TITLE,NAEL,NSEL
      COMMON /PLOT/ XDEL,NEX,NXTX,YDEL,NEY,NYTX
      CALL NEWPAG 
      XMIN=1.0E30
      XMAX=-1.0E30
      YMIN=1.0E30
      YMAX=-1.0E30
      DO 10 I=1,NPTS
      IF(ANS(2).EQ.'E')WI=U(I)
      IF(ANS(2).EQ.'E')UI=U(I)
      IF(ANS(2).EQ.'T')UI=W(I)
      IF(ANS(2).EQ.'T')WI=W(I)
      IF(ANS(2).EQ.'B')UI=U(I)
      IF(ANS(2).EQ.'B')WI=W(I)
      YMIN=AMIN1(UI,WI,YMIN)
      YMAX=AMAX1(UI,WI,YMAX)
      VI=V(I)
      IF(ANS(2).EQ.'E'.AND. ANS(3).EQ.' ')VI=X(I)
      XMIN=AMIN1(VI,XMIN)
      XMAX=AMAX1(VI,XMAX)
   10 CONTINUE
      IF(ANS(6).NE.'P') GO TO 20
	LUNIT=6
C      CALL FILES(6,'TMPFIL',6,0,-1,0,LUNIT)
      WRITE(LUNIT,60) ((X(I),U(I),W(I)),I=1,NPTS)
      REWIND LUNIT
   20 CALL TWINDO(200,1020,150,770)
      CALL AXES(XMIN,XMAX,XDEL,NEX,NXTX,XT)
      CALL AXES(YMIN,YMAX,YDEL,NEY,NYTX,YT)
      CALL DWINDO(XMIN,XMAX,YMIN,YMAX)
      CALL MOVEA(XMIN,YMIN)
      CALL DRAWA(XMAX,YMIN)
      CALL DRAWA(XMAX,YMAX)
      CALL DRAWA(XMIN,YMAX)
      CALL DRAWA(XMIN,YMIN)
      CALL TICKS(XMIN,XMAX,YMIN,YMAX,XDEL,YDEL,NXTX,XT,XV,
     C    NYTX,YT,YV)
      IF(ANS(2).EQ.'E'.OR.ANS(2).EQ.'B'.OR.ANS(2).EQ.' ')GO TO 70
      IF(ANS(3).NE.'T')GO TO 40
      DO 30 J=1,4
      TITLE(J+6)=' '
      TITLE(J)=NAEL(J)
      TITLE(J+4)=NSEL(J)
   30 CONTINUE
   40 DO 50 I=1,10
      NAME=NAMES(I)
      NAMES(I)=TITLE(I)
      TITLE(I)=NAME
   50 CONTINUE
   60 FORMAT(1X,2(3F12.4,18X))
   70 RETURN
      END
C--------------------SUBROUTINE--PHREM-----------------------------------
C
      SUBROUTINE PHREM(X,Y,V,W,DELTA,PHI,NPTS,NPTV,IPH)
C * SUBROUTINE TO REMOVE A TABULATED OR PARAMETERIZED PHASE FUNCTION
C * FROM THE EXAFS DATA IN K-SPACE
      DIMENSION X(1024),Y(1024),V(1024),U(1024),W(1024),
     C    DELTA(2048),PHI(2048),TITLE(10),ANS(6),NAEL(4),
     C    NSEL(4),P(4)
      LOGICAL*1 ANS,TITLE,NAEL,NSEL
      ICONT=0
      R1=0.
      E0=0.
      TWOPI=6.28318531
      DO 10 I=1,6
   10 ANS(I)=' '
      K=1
      SCALE=96./4096.
      DO 20 I=1,1024
      SCFAC=SCALE*(I-1)
      IF(SCFAC.LT.X(1))GO TO 20
      IF(SCFAC.GT.X(NPTS))GO TO 30
      U(K)=SCFAC
      K=K+1
   20 CONTINUE
   30 K=K-1
      NPTV=K
	CALL NEWPAG
	CALL TOUTPT(24)
   40 TYPE *,'DO YOU WANT TERMINAL (I)NPUT OF PHASE PARAMETERS OR A'
      TYPE 180
      ACCEPT 170, ANS(3)
      IF(ANS(3).EQ.'E')GO TO 160
      IF(ANS(3).EQ.'I')GO TO 60
      IF(ANS(3).EQ.'T')GO TO 50
      IF(ANS(3).NE.'P')GO TO 40
      CALL PHTABL(0,V,W,U,PHI,DELTA,NPTV,ICONT,P,ANS,R1,E0,TITLE,
     C    NAEL,NSEL)
      IF(ICONT.EQ.1)GO TO 160
      GO TO 70
   50 CALL PHTABL(1,V,W,U,PHI,DELTA,NPTV,ICONT,P,ANS,R1,E0,TITLE,
     C    NAEL,NSEL)
      IF(ICONT.EQ.1)GO TO 160
      GO TO 100
   60 TYPE 190
      ACCEPT *,(P(I),I=1,4),E0
   70 IF(E0.EQ.0.)GO TO 80
      TYPE 200
      ACCEPT *, R1
   80 VSQDEL=.262467*E0
      DO 90 I=1,NPTV
      CAYSQ=U(I)*U(I)
      CAYN=SQRT(1.-VSQDEL/CAYSQ)
      B0=P(1)-P(3)*VSQDEL
      B1=P(2)*CAYN
      B2=P(3)
      B3=P(4)/(CAYN**3)
      V(I)=U(I)
   90 DELTA(I)=B0+(B1+B2*U(I))*U(I)+B3/(U(I)**3)-VSQDEL*R1/U(I)
  100 NPTD=NPTV
      K=1
      VLOW=V(1)
      VHIGH=V(NPTV)
      DO 120 I=1,NPTS
      IF(X(I).GT.VHIGH)GO TO 130
      IF(X(I).GE.VLOW)GO TO 110
      GO TO 120
  110 V(K)=X(I)
      W(K)=Y(I)
      K=K+1
  120 CONTINUE
  130 K=K-1
      NPTV=K
      TYPE 210
      ACCEPT 170, ANS(2)
      PHSGN=1.
      IF(ANS(2).EQ.'A')PHSGN=-1.
      DO 140 I=1,NPTD
  140 DELTA(I)=PHSGN*DELTA(I)
  150 IPH=1
  160 RETURN
  170 FORMAT(A1)
  180 FORMAT('$(P)ARAMERIZED OR A (T)ABULAR
     C PHASE FROM DISK TABLES? ')
  190 FORMAT('$TYPE  A0,A1,A2,A3,E0 :')
  200 FORMAT('$TYPE R1 FOR YOUR PHASE :')
  210 FORMAT('$(A)DD OR (S)UBTRACT THE PHASE SHIFT :')
      END
C--------------------SUBROUTINE--PHTABL----------------------------------
C
      SUBROUTINE PHTABL(L,V,W,X,Y,Z,NPTS,ICONT,P,ANS,R1,E0,TITLE,
     C    NAEL,NSEL)
C * SUBPROGRAM TO RETRIEVE TABULAR PHASE AND AMPLITUDE INFORMATION FROM
C * STORED TABLES, WRITES NEW DESIRED IMPIRICALLY DETERMINED
C * PHASE SHIFTS TO THE TABLES
      DIMENSION V(1024),W(1024),X(1024),Y(2048),Z(2048),ANS(6),P(4),
     C    TITLE(10),FNCNAM(10),PHI(20),PHJ(20),NAEL(4),NSEL(4),
     C    NME(4),IEL(4),JEL(4)
      LOGICAL*1 ANS,TITLE,FNCNAM,NAEL,NSEL,NME,IEL,JEL,LQN
      DIMENSION CAY(20)
      DATA CAY/3.7795,4.2519,4.7243,5.1967,5.6692,6.1416,6.6140,
     C    7.0865,7.5589,8.5038,9.4486,10.3935,11.3384,12.2832,
     C    13.2281,14.1729,15.1178,3*0.0/
      TWOPI=6.28318531
	NUNIT=7
C      CALL FILES(7,'TMPFIL',6,0,-1,0,NUNIT)
      IF(L.GT.2)GO TO 100
      IF(L-1)10,100,10
   10 TYPE 370
      TYPE 380
      ACCEPT 390,TITLE
      CALL FILES(3,'PARAM.PHF',9,0,1,3,LUNIT)
      READ(LUNIT'1,ERR=40) LASTRC
      IF(L.EQ.2)GO TO 20
      GO TO 50
   20 TYPE 400
      WRITE(5,410)  TITLE,(P(I),I=1,4),E0
      TYPE 420
      ACCEPT 430, ANS(4)
      IF(ANS(4).NE.'Y' .AND. ANS(4).NE.'O')GO TO 30
      LASTRC=LASTRC+1
      WRITE(LUNIT'LASTRC) TITLE,(P(I),I=1,4),E0
      WRITE(LUNIT'1) LASTRC
   30 CALL FILES(3,'PARAM.PHF',9,0,0,0,LUNIT)
      ICONT=1
      GO TO 360
   40 TYPE *,'PARAMETERIZED FUNCTION TABLE NOT FOUND ON DISK'
      CALL FILES(3,'PARAM.PHF',9,0,0,0,LUNIT)
      ICONT=1
      GO TO 360
   50 DO 70 I=2,LASTRC
      NREC=I
      READ(LUNIT'NREC) FNCNAM,(P(J),J=1,4),E0
      DO 60 J=1,10
      IF(FNCNAM(J).NE.TITLE(J))GO TO 70
   60 CONTINUE
      K=I
      GO TO 80
   70 CONTINUE
      TYPE 440,TITLE
      CALL IOWAIT(600)
      CALL FILES(3,'PARAM.PHF',9,0,0,0,LUNIT)
      ICONT=1
      GO TO 360
   80 CALL FILES(3,'PARAM.PHF',9,0,0,0,LUNIT)
      WRITE(5,410) TITLE,(P(I),I=1,4),E0
      TYPE 420
      ACCEPT 430, ANS(4)
      IF(ANS(4).NE.'Y' .AND. ANS(4).NE.'O')GO TO 90
      GO TO 350
   90 ICONT=1
      GO TO 360
  100 TYPE 370
      IF(L.GT.1)GO TO 110
      TYPE 450
      ACCEPT 460,NAEL(1),NAEL(2),LQN
      IF(NAEL(2).EQ.'0'.OR.NAEL(2).EQ.'1'.OR.NAEL(2).EQ.'2')
     C GO TO 120
      GO TO 130
  110 TYPE 530
      ACCEPT 460,NAEL(1),NAEL(2)
      LQN=' '
      GO TO 130
  120 LQN=NAEL(2)
      NAEL(2)=' '
  130 NAEL(3)=LQN
      NAEL(4)=' '
      IF(L.LE.1)GO TO 150
      DO 140 I=1,4
  140 NSEL(I)=' ' 
      GO TO 160
  150 TYPE 470
      ACCEPT 480, NSEL(1),NSEL(2)
      NSEL(3)=' '
      NSEL(4)=NSEL(3)
  160 CALL FILES(3,'TEOLEE.PHT',10,0,1,4,LUNIT)
      READ(LUNIT'1,ERR=170) LASTRC
      GO TO 180
  170 TYPE *,'THEORETICAL TABLE NOT FOUND ON DISK'
      CALL FILES(3,'TEOLEE.PHT',10,0,0,0,LUNIT) 
      ICONT=1
      GO TO 360
  180 NA=0
      NS=0
      N=0
      M=0
      DO 230 I=2,LASTRC,3
      NREC=I
      READ(LUNIT'NREC)NME
      IF(NA.EQ.1)GO TO 200
      DO 190 J=1,4
      IF(NME(J).NE.NAEL(J))GO TO 200
  190 CONTINUE
      M=I
      NA=1
      IF(L.GT.1)GO TO 250
      GO TO 220
  200 IF(NS.EQ.1)GO TO 220
      DO 210 J=1,4
      IF(NME(J).NE.NSEL(J))GO TO 220
  210 CONTINUE
      N=I
      NS=1
  220 IF(NA.EQ.1.AND.NS.EQ.1)GO TO 240
  230 CONTINUE
      IF(NA.EQ.0) TYPE 490,NAEL
      IF(NS.EQ.0 .AND. L.LE.1) TYPE 490,NSEL
      CALL FILES(3,'TEOLEE.PHT',10,0,0,0,LUNIT)
      ICONT=1
      GO TO 360
  240 JJ=M
      IF(N.LT.M)JJ=N
      READ(LUNIT'JJ) IEL,(PHI(I),I=1,5)
      NREC=JJ+1
      READ(LUNIT'NREC) (PHI(I),I=6,11)
      NREC=JJ+2
      READ(LUNIT'NREC) (PHI(I),I=12,17)
      JJ=N
  250 IF(N.LT.M)JJ=M
      READ(LUNIT'JJ) JEL,(PHJ(I),I=1,5)
      NREC=JJ+1
      READ(LUNIT'NREC) (PHJ(I),I=6,11)
      NREC=JJ+2
      READ(LUNIT'NREC) (PHJ(I),I=12,17)
      CALL FILES(3,'TEOLEE.PHT',10,0,0,0,LUNIT)
      IF(L.GT.1)GO TO 270
      TYPE *,'ABSORBER :'
      IF(JJ.EQ.N) WRITE(5,500) IEL,(PHI(I),I=1,17)
      IF(JJ.EQ.M) WRITE(5,500) JEL,(PHJ(I),I=1,17)
      TYPE *,'SCATTERER :'
      IF(JJ.EQ.N) WRITE(5,500) JEL,(PHJ(I),I=1,17)
      IF(JJ.EQ.M) WRITE(5,500) IEL,(PHI(I),I=1,17)
  260 TYPE 420
      ACCEPT 430,ANS(4)
      IF(ANS(4).NE.'Y' .AND. ANS(4).NE.'O')GO TO 280
      GO TO 290
  270 TYPE *,'AMPLITUDE :'
      WRITE(5,500) JEL,(PHJ(I),I=1,17)
      GO TO 260
  280 ICONT=1
      GO TO 360
  290 IF(L.GT.1)GO TO 300 
      TYPE 510
      ACCEPT *,E0
      TYPE 520
      ACCEPT *,R1
  300 DO 310 I=1,17
      IF(L.GT.1) PHI(I)=0.
      PHI(I)=PHI(I)+PHJ(I)
      XK=CAY(I)
      PHJ(I)=XK
  310 IF(LQN.EQ.'1')PHI(I)=PHI(I)-(TWOPI/2.)
      IF(ANS(5).EQ.'2' .OR. L.GT.1)GO TO 330
      VSQDEL=.262467*E0
      DO 320 I=1,17
      CAYSQ=PHJ(I)*PHJ(I)
      IF(L.LE.1)PHI(I)=PHI(I)-VSQDEL*R1/PHJ(I)
  320 PHJ(I)=SQRT(CAYSQ+VSQDEL)
  330 NUMPTS=17
      KLOW=1
      KHIGH=NPTS
      CALL INTERP(X,V,Z,PHI,PHJ,NPTS,NUMPTS,KLOW,KHIGH)
      DO 340 I=1,NPTS
      KP=KLOW+I-1
      X(I)=X(KP)
      Y(I)=Y(KP)
  340 W(I)=W(KP)
  350 CONTINUE
  360 RETURN
  370 FORMAT(' TO READ/SAVE CALCULATED PHASE INFO ON DISK, PLEASE')
  380 FORMAT('$SPECIFY FUNCTION TITLE   XXXX-XXXX ')
  390 FORMAT(10A1)
  400 FORMAT('         ',18X,'A0',8X,'A1',8X,'A2',
     * 8X,'A3',8X,'E0')
  410 FORMAT(' MEMBER: ',10A1,2X,5F10.4)
  420 FORMAT('$OK ? ')
  430 FORMAT(A1)
  440 FORMAT(' TABLE MEMBER ',10A1,' NOT FOUND')
  450 FORMAT('$SPECIFY ABSORBING ELEMENT, QUANTUM NO. L : ')
  460 FORMAT(2A1,1X,A1)
  470 FORMAT('$SPECIFY SCATTERING ELEMENT : ')
  480 FORMAT(2A1)
  490 FORMAT(' MEMBER ',4A1,' NOT FOUND IN TABLE')
  500 FORMAT(1X,4A1,6F8.4,2(/,5X,6F8.4))
  510 FORMAT('$TYPE IN E0 FOR YOUR TABLE : ')
  520 FORMAT('$TYPE IN R1 FOR YOUR TABLE : ')
  530 FORMAT('$SPECIFY AMPLITUDE ENTRY : ')
      END
C-------------------SUBROUTINE--POINT------------------------------------
C
      SUBROUTINE POINT(V,W,NPTS)
C * LABELS COORDINATE POINTS FOUND VIA THE GRAPHIC CURSER.
      COMMON /PLOT/XDEL,NEX,NXTX,YDEL,NEY,NYTX,
     1IMIN,IMAX,JMIN,JMAX
      DIMENSION ICOORD(10)
      DIMENSION IBIT(1024),V(1024),W(1024),VA(5)
      CALL VCURSR(KEY,XPOINT,YPOINT)
      CALL CROSS(XPOINT,YPOINT,5)
      CALL SEETW(MINX,MAXX,MINY,MAXY)
      CALL SEEDW(XMN,XMX,YMN,YMX)
      XFAC=(XMX-XMN)/(MAXX-MINX)
      YFAC=(YMX-YMN)/(MAXY-MINY)
      IONE=LINWDT(1)
      JONE=LINHGT(1)
      XSPAN=(20*IONE)*XFAC
      YSPAN=JONE*YFAC
      XP=XPOINT*(10.**NEX)
      YP=YPOINT*(10.**NEY)
      YPNT=YPOINT
      ISW=0
   10 ISE=1
      YMOVD=YPOINT-(YSPAN/2.)
      YMOVU=YPOINT+(YSPAN/2.)
      NBITS=0
      MN=1
      DO 20 I=1,NPTS-1
      IF(V(I).LT.XMN .AND. V(I+1).GT.XMN)MN=I
      IF(V(I).GT.XMN .AND. V(I).LT.XMX)NBITS=NBITS+1
      IF(V(I).LE.XPOINT .AND. V(I+1).GT.XPOINT)IP=I
      IF(V(I).LE.(V(IP)+XSPAN) .AND. V(I+1).GT.(V(IP)+XSPAN))
     CK=I-IP+1
   20 CONTINUE
      DO 30 M=1,NBITS
      IBIT(M)=0
      IF(W(MN+M).GT.YMOVU)IBIT(M)=1
      IF(W(MN+M).LT.YMOVD)IBIT(M)=-1
   30 CONTINUE
      ISUM=0
      L=0
      DO 60 J=1,NBITS-1
      IF((IBIT(J)*IBIT(J+1)).LE.0)GO TO 50
      ISUM=ISUM+1
      IF(ISUM.GT.K)GO TO 40
      GO TO 60
   40 L=L+1
      VA(L)=V(MN+J)-XSPAN
   50 ISUM=0
   60 CONTINUE
      IF(L.EQ.0)GO TO 140
      DO 70 N=1,L
      XRIGHT=VA(N)-XPOINT
   70 IF(XRIGHT.GT.0.)GO TO 80
      IF(XRIGHT.LE.0.)XRIGHT=1.0E6
   80 DO 90 N=1,L
      XLEFT=XPOINT-VA(L+1-N)-XSPAN
   90 IF(XLEFT.GT.0.)GO TO 100
      IF(XLEFT.LE.0.)XLEFT=1.0E6
  100 IF(XRIGHT-XLEFT)110,110,120
  110 CALL MOVEA(XPOINT,YPNT)
      CALL DRAWA((XPOINT+XRIGHT),YPOINT)
      CALL MOVREL(0,-JONE/2)
      GO TO 130
  120 CALL MOVEA(XPOINT,YPNT)
      CALL DRAWA((XPOINT-XLEFT),YPOINT)
      CALL MOVEA((XPOINT-XLEFT-XSPAN),YPOINT)
      CALL MOVREL(0,-JONE/2)
  130 ENCODE(20,170,ICOORD) XP,YP
      CALL AOUTST(20,ICOORD)
      GO TO 160
  140 IF(ISW.EQ.1)GO TO 150
      YPOINT=YPOINT+ISE*YSPAN
      ISE=ISE+1
      ISW=1
      GO TO 10
  150 YPOINT=YPOINT-ISE*YSPAN
      ISE=ISE+1
      ISW=0
      GO TO 10
  160 RETURN
  170 FORMAT(1X,'(',F8.3,',',F8.3,')')
      END
C---------------------SUBROUTINE--POLSPL--------------------------------
C
      SUBROUTINE POLSPL(X,Y,NOB,XL,XH,NR,C,NC)
C * SUBROUTINE TO COMPUTE A MULTIPLE REGION POLYNOMIAL SPLINE FOR
C * SMOOTH BACKGROUND SUBTRACTION
      DIMENSION X(NOB),Y(NOB),A(35,36)
      DIMENSION XL(9),XH(9),C(35),NC(9),DF(25),NBS(10),XK(9)
      DOUBLE PRECISION A,DF,T,WT,XK
      DO 10 I=1,35
      C(I)=0.
      DO 10 J=1,36
      A(I,J)=0.
   10 CONTINUE
      N=0
      NBS(1)=1
      DO 20 I=1,NR
      N=N+NC(I)
      NBS(I+1)=N+1
      IF(XL(I) .LT. XH(I))GO TO 20
      T=XL(I)
      XL(I)=XH(I)
      XH(I)=T
   20 CONTINUE
      N=N+2*(NR-1)
      N1=N+1
      XL(NR+1)=0.
      XH(NR+1)=0.
      DO 60 IBL=1,NR
      XK(IBL)=.5*(XH(IBL)+XL(IBL+1))
      IF(XL(IBL) .GT. XL(IBL+1))XK(IBL)=.5*(XL(IBL)+XH(IBL+1))
      NS=NBS(IBL)
      NE=NBS(IBL+1)-1
      DO 60 I=1,NOB
      IF(X(I) .LT. XL(IBL) .OR. X(I) .GT. XH(IBL))GO TO 60
      WT=1.0D0
      DF(NS)=1.0D0
      NS1=NS+1
      DO 30 J=NS1,NE
   30 DF(J)=DF(J-1)*X(I)
      DO 50 J=NS,NE
      DO 40 K=J,NE
   40 A(J,K)=A(J,K)+DF(J)*DF(K)*WT
   50 A(J,N1)=A(J,N1)+DF(J)*Y(I)*WT
   60 CONTINUE
      NCOL=NBS(NR+1)-1
      NK=NR-1
      DO 120 IK=1,NK
      NCOL=NCOL+1
      NS=NBS(IK)
      NE=NBS(IK+1)-1
      A(NS,NCOL)=-1.0D0
      NS=NS+1
      DO 70 I=NS,NE
   70 A(I,NCOL)=A(I-1,NCOL)*XK(IK)
      NCOL=NCOL+1
      A(NS,NCOL)=-1.0D0
      NS=NS+1
      IF(NS .GT. NE)GO TO 90
      DO 80 I=NS,NE
   80 A(I,NCOL)=(NS-I-2)*XK(IK)**(I-NS+1)
   90 NCOL=NCOL-1
      NS=NBS(IK+1)
      NE=NBS(IK+2)-1
      A(NS,NCOL)=1.0D0
      NS=NS+1
      DO 100 I=NS,NE
  100 A(I,NCOL)=A(I-1,NCOL)*XK(IK)
      NCOL=NCOL+1
      A(NS,NCOL)=1.0D0
      NS=NS+1
      IF(NS .GT. NE)GO TO 120
      DO 110 I=NS,NE
  110 A(I,NCOL)=(I-NS+2)*XK(IK)**(I-NS+1)
  120 CONTINUE
      DO 130 I=1,N
      I1=I-1
      DO 130 J=1,I1
  130 A(I,J)=A(J,I)
      NM1=N-1
      DO 170 I=1,NM1
      I1=I+1
      M=I
      T=DABS(A(I,J))
      DO 140 J=I1,N
      IF(T .GE. DABS(A(J,I)))GO TO 140
      M=J
      T=DABS(A(J,I))
  140 CONTINUE
      IF(M .EQ. I)GO TO 160
      DO 150 J=I,N1
      T=A(I,J)
      A(I,J)=A(M,J)
  150 A(M,J)=T
  160 DO 170 J=I1,N
      T=A(J,I)/A(I,I)
      DO 170 K=I1,N1
      A(J,K)=A(J,K)-T*A(I,K)
  170 CONTINUE
      C(N)=A(N,N1)/A(N,N)
      DO 190 I=1,NM1
      NI=N-I
      T=A(NI,N1)
      NI1=NI+1
      DO 180 J=NI1,N
  180 T=T-C(J)*A(NI,J)
  190 C(NI)=T/A(NI,NI)
      RETURN
      END
C-----------------SUBROUTINE--READAT-------------------------------
C	CORRECTION APPLIED BY MOHAN 230386-(MR)
C	CORRECTION MADE TO ACCEPT 1024 DATA POINTS
C X5.01 CORRECTION OF PROBLEM 161085-1
C X5.04 CORRECTION OF PROBLEM 121185-1
C X5.10 CHANGE AS OF 181185-1 NSLS X11 DATA CHANGE
      SUBROUTINE READAT(A,B,NPTS,CUEDGE,NCHAN,NAMES,FORM)
C * THIS PROGRAM SIMPLY READS RAW EXAFS DATA FROM 
C * GIVEN FILES ON DISK AND CREATES AN INPUT DATA ARRAY FOR
C * LATER OPTIONS OF LISTING AND PLOTTING.
      LOGICAL*1 NAMES,ZERO,NAME(25),OLD,LINE,DZ
      DIMENSION A(1024),B(1024,6),DELTA(5),DELEND(5),SEC(5),AY(12),
     C    NAMES(25),LINE(80)
      DATA ZERO /O0/
      CALL ERRSET(29,.TRUE.,.FALSE.,.TRUE.,.FALSE.)
      CALL ERRSET(30,.TRUE.,.FALSE.,.TRUE.,.FALSE.)
   10 FORM=0.
      FLAG=0.
      CKPNT=0
	DO 11 I=1,6
11	B(1,I)=0.0
      TYPE 240
      DO 20 I=1,25
   20 NAMES(I)=ZERO
      ACCEPT 250,(NAMES(J),J=1,25)
      DO 30 I=1,25
   30 IF(NAMES(I).EQ.' ') NAMES(I)=ZERO
      IF(NAMES(1).EQ.ZERO) GO TO 220
      DO 40 I=1,25
   40 NAME(I)=NAMES(I)
      CALL FILES(3,NAME,25,0,1,0,LUNIT)
      READ(LUNIT,320,ERR=150) LINE
      READ(LUNIT,320,ERR=150) LINE
      CKPNT=1
C
C  HERE IS MODIFICATION ONE OF THE READAT SUBROUTINE--MADE 6/6/84 
C  SSRL AND CHESS FORMATS FOR EXAF DATA AND TO READ EITHER ONE.
C
      IF(LINE(3).EQ.'C')GO TO 49	! WVU X18B DATA FORMAT
      IF(LINE(1).NE.'3')GO TO 70	! IF NOT CHESS, CONTINUE ELSEWHERE.
C
C  CONSTANTS NOT FOUND ON CHESS DATA.
50	CUEDGE=42141.
	NCHAN=5
	FORM=2.				! FORM IS CHESS (LATER USE).
C
C  CHESS DATA FORMAT READ STEPS.
C
	DO 60 I=1,1024
	 IF(FLAG.EQ.3.) THEN
           READ(LUNIT,370,END=170) A(I),(B(I,J),J=1,3)
         ELSE
	   READ(LUNIT,360,END=170) A(I),FJUNK,FJUNK,B(I,2),B(I,1),B(I,3)
	   A(I)=A(I)*1000	
	ENDIF
60	CONTINUE
	IF(FLAG.EQ.3.) NCHAN=3
	GO TO 170			! IN CASE THERE ARE 501 OR MORE VALUES
49	DO 48 I=1,11
C
C DATA IS NEW NSLS X18B FORMAT
C
48	READ(LUNIT,320,ERR=150) LINE
	FLAG=7.			
	FORM=2.
	DO 47 I=1,1024
           READ(LUNIT,365,END=170) A(I),FJUNK,(B(I,J),J=1,5)
C
C FJUNK CONTAINS STEP NUMBER THAT MAY BE USED LATER
C IF SO, CORRECT FLAG LATER SO THAT ENERGY IS NOT ASSUMED.
C
47	CONTINUE   
	GO TO 170			! IN CASE THERE ARE 501 OR MORE VALUES


   70 IF(LINE(1).EQ.'N')GO TO 140
C
C DATA IS EITHER IN OLD SSRL FORMAT OR ELSE IN NEW NSLS X11 FORMAT
C 
	IF(LINE(2).EQ.'S') GOTO 80
C 
C DATA IS EITHER IN STANDARD FORMAT OR ELSE IN CHESS-PLUS FORMAT
C AN ASCII 'N' IN LINE POSITION 2 IS USED TO DIFFERENTIATE FORMATS
C
      IF(LINE(2).EQ.'N')GO TO 110
C
C DATA MUST BE IN NEW CHESS FORMAT---STRIP OF LEADING GARBAGE LINES
C OR NSLS X11, FLAG INDICATES TYPE
   80    FLAG=3.0
   90    DO 100 I=1,10
  100  READ(LUNIT,320,ERR=150) LINE
       IF(FLAG.NE.3.) READ(LUNIT,320,ERR=150) LINE
      GO TO 50
  110 READ(LUNIT,320,ERR=150) LINE
      READ(LUNIT,270) DELTA,DELEND,SEC
      READ(LUNIT,280,ERR=120) (AY(I),I=1,12)
      GO TO 130
  120 TYPE *, (AY(I),I=1,12)
      READ(LUNIT,300) 
  130 READ(LUNIT,260) DZ
      READ(LUNIT,290,END=170) (A(I),(B(I,J),J=1,5),I=1,1024)
      GO TO 170
  140 FORM=1.
      REWIND LUNIT
      READ(LUNIT,330) CUEDGE,START2,STOP2
      READ(LUNIT,340) DELTA,DELEND,SEC
      READ(LUNIT,260)DZ
      READ(LUNIT,350,END=170) (A(I),B(I,1),I=1,1024)
      GO TO 170
  150 TYPE *,'FILE NOT FOUND OR WRONG TYPE'
  160 TYPE *,'CHECK DIRECTORY FIRST, THEN TRY AGAIN.'
      IF(CKPNT.EQ.1)CALL FILES(3,NAME,10,0,0,0,LUNIT)
      FORM=7.
      GO TO 230
  170 I=I-1
      NPTS=I
  180 NCOUNT=NPTS
      DO 190 I=1,NPTS
  190 IF(A(I).EQ.0.) NCOUNT=NCOUNT-1
      NPTS=NCOUNT
      DO 200 J=1,5
      IF(B(1,J).EQ.0.)GO TO 210
  200 CONTINUE
  210 NCHAN=J-1
      TYPE *,' '
      IF(FORM.EQ.2.) THEN
	IF(FLAG .EQ.7.)THEN
	  TYPE*, ' DATA FILE CONTAINS ', NPTS,' POINTS WVU X18B FORMAT'
	ELSEIF(FLAG .EQ. 3.)THEN
          TYPE *, ' DATA FILE CONTAINS ',NPTS,' POINTS NSLS X11  FORMAT'
	ELSE
          TYPE *, ' DATA FILE CONTAINS ',NPTS,' POINTS CHESS FORMAT'
	ENDIF
      ELSE
        TYPE *, ' DATA FILE CONTAINS ',NPTS,' POINTS SSRL  FORMAT'
      END IF
      TYPE *,' '
      GO TO 230
  220 IF(NAMES(2).EQ.ZERO)GO TO 150
      TYPE *,'ERROR-ILLEGAL FILE NAME SPECIFICATION'
      GO TO 160
  230 TYPE 310
      CALL FILES(3,NAME,25,0,0,0,LUNIT)
      RETURN
  240 FORMAT('$TYPE FILE NAME: ')
  250 FORMAT(25A1)
  260 FORMAT(A1)
  270 FORMAT('  DELTA:'5F8.0/' DELEND:'5F8.0/'    SEC:'5F8.0)
  280 FORMAT(' OFFSET:'12F6.0/)
  290 FORMAT(0PF10.0,1P5E12.5)
  300 FORMAT(80X)
  310 FORMAT(//)
  320 FORMAT(80A1)
  330 FORMAT(29X,3F9.0,18X)
  340 FORMAT('  DELTA:',5F9.0/' DELEND:',5F9.0/'    SEC:',5F9.0)
  350 FORMAT(8F10.0)
  360 FORMAT(6F11.4)
  365 FORMAT(F11.4,F12.0,10F10.0)
  370 FORMAT(F9.3,7F8.0)
      END

C---------------------SUBROUTINE--READFL-------------------------------------
C
      SUBROUTINE READFL(V,W,NPTS,NAMES,KOPT,LOPT,FORM,KLOG,ESH,
     1ICAPX,ICAPY,XI,XJ,XNMIN,IDGL,IFT,ISML,KPOWR,NX)
C * THIS SUBPROGRAM READS STORED DATA FROM THE ANALYSIS PROGRAM OFF THE
C * DISK FILE AND LOADS IT INTO THE PROGRAM INPUT ARRAY. IT ALSO UPDATES
C * ALL RELEVANT CONSTANTS AND PARAMETERS.
      DIMENSION V(1024),W(1024),NAMES(25)
      LOGICAL*1 KOPT,LOPT,NAMES,NAME(25),ZERO
      DATA IOLD/'O '/,ZERO/O0/
      CALL NEWPAG
      CALL TOUTPT(24)
      CALL ERRSET(29,.TRUE.,.FALSE.,.TRUE.,.FALSE.)
      CALL ERRSET(30,.TRUE.,.FALSE.,.TRUE.,.FALSE.)
   10 TYPE 140
      ACCEPT 150, (NAMES(I),I=1,25)
      DO 20 I=1,25
      NAME(I)=NAMES(I)
C   20 IF(NAME(I).EQ.' ')NAME(I)=ZERO
   20 ISML=0
      IFT=0
      CALL FILES(3,NAME,25,0,1,0,LUNIT)
      SGN=-1.
      READ(LUNIT,160,ERR=30) (NAMES(I),I=1,25)
	DO 25 II=1,25
	   IF (NAMES(II) .EQ. ' ') NAMES(II)=ZERO
25	CONTINUE
      GO TO 40
   30 TYPE *,'FILE NOT FOUND'
      TYPE *, ' '
      TYPE *, ' WHY NOT CHECK THE DIRECTORY AND TRY AGAIN? '
	NPTS=0
      GO TO 130
   40 READ(LUNIT,170) KOPT,LOPT,IFRM,ISUM,IDGL
      IF(ISUM.LE.3)GO TO 50
      SGN=1.
      READ(LUNIT,180) FLINE,DSPACE,SNOFF,EEDGE,ESHFT,NX
      IF(ISUM.EQ.4 .AND. NX.EQ.0)GO TO 50
      ISML=1
      READ(LUNIT,190) XI,XJ,FLA
      READ(LUNIT,200) XNMIN,YNMIN,STPHGT,NEL1,NEL2,MCM,NR
      IF(MCM.NE.1)MCM=0
      IF(ISUM.LE.6)GO TO 50
      IFT=1
      READ(LUNIT,210) XKMIN,XKMAX,KNUM,SCPTS,IPRCNT,KPOWR
      IF(ISUM.LT.9)GO TO 50
      READ(LUNIT,220) XRMIN,XRMAX
   50 READ(LUNIT,230,END=60) (V(I),W(I),I=1,1024)
   60 NPTS=I-1
   70 IF(V(NPTS).NE.0.)GO TO 80
      NPTS=NPTS-1
      GO TO 70
   80 DO 90 I=1,NPTS
   90 V(I)=SGN*V(I)
      FORM=0.
      IF(IFRM.EQ.IOLD)FORM=1.
      KLOG=0
      ICAPX=1
      IF(ISUM.EQ.3)KLOG=1
      IF(ISUM.EQ.4)ICAPX=2
      IF(ISUM.EQ.5)ICAPX=2
      IF(ISUM.EQ.6)ICAPX=3
      IF(ISUM.EQ.8)ICAPX=4
      IF(ISUM.EQ.9)ICAPX=3
      IF(ISUM.EQ.9)KLOG=3
      ICAPY=ISUM-ICAPX-KLOG
      CALL FILES(3,NAME,25,0,0,0,LUNIT)
      IF(ISUM.LT.4)GO TO 130
      CALL FILES(1,'CONST.HLD',9,0,1,1,NUNIT)
      READ(NUNIT'1) GARB
      WRITE(NUNIT'1) FLINE,DSPACE,SNOFF,EEDGE
      ESH=ESHFT
      IF(NX.EQ.1)GO TO 100
      FLA=0.
  100 WRITE(NUNIT'9)NX,FLA,GARB,GARB,GARB
      WRITE(NUNIT'2) ESHFT
      IF(NX.EQ.1)GO TO 110
      IF(ISUM.LT.5)GO TO 120
  110 IREG=0
      IF(NR.EQ.3)IREG=0
      WRITE(NUNIT'2) ESHFT,XI,XJ,XNMIN,YNMIN
      WRITE(NUNIT'3) STPHGT,NEL1,NEL2,MCM,NR,IREG
      IF(ISUM.LT.8)GO TO 120
      WRITE(NUNIT'4) XKMIN,XKMAX,IPRCNT,KPOWR,KNUM,SCPTS
      IF(ISUM.LT.9)GO TO 120
      WRITE(NUNIT'5) XRMIN,XRMAX
  120 CALL FILES(1,'CONST.HLD',9,0,0,0,NUNIT)
  130 RETURN
  140 FORMAT(/,'$TYPE FILE NAME: ')
  150 FORMAT(25A1)
  160 FORMAT(/,21X,25A1)
  170 FORMAT(40X,/,17X,/,10X,I1,1X,I1,2X,A2,2(2X,I1))
  180 FORMAT(29X,F10.0,/,26X,F10.5,/,21X,F10.2,/,30X,F10.2,
     1/,18X,F10.2,22X,I2)
  190 FORMAT(37X,2(2PE12.4,5X),7X,1PE12.4)
  200 FORMAT(2(8X,2PE12.4),10X,1PE12.4,2(2X,I3),24X,I2,11X,I2)
  210 FORMAT(7X,1PE12.4,9X,2PE12.4,/,22X,I4,24X,0PF6.0,
     1/,20X,I2,19X,I1)
  220 FORMAT(25X,/,7X,1PE12.4,9X,1PE12.4,10X)
  230 FORMAT(4(5X,1P2E13.5))
      END
C------------------SUBROUTINE--REPLOT-----------------------------------
C
      SUBROUTINE REPLOT(XL,YL,XH,YH,U)
C * REPLOTS STORED WINDOW VALUES UP TO 3 RELATIVE
C * TO '*' AS CURRENT.
      LOGICAL*1 AST
      DIMENSION U(4,3),AST(3)
   10 TYPE 70
      ACCEPT 80 ,AST
      IF(AST(2).EQ.'-' .OR. AST(2).EQ.' ')GO TO 20
      GO TO 10
   20 IF(AST(1).EQ.' ' .AND. AST(3).EQ.' ')GO TO 60
      IF(AST(1).EQ.'*' .AND. AST(3).EQ.'2')GO TO 30
      IF(AST(1).EQ.'*' .AND. AST(3).EQ.'1')GO TO 40
      IF(AST(1).EQ.'*' .AND. AST(3).EQ.' ')GO TO 50
      GO TO 10
   30 XL=U(1,3)
      YL=U(2,3)
      XH=U(3,3)
      YH=U(4,3)
      GO TO 60
   40 XL=U(1,2)
      YL=U(2,2)
      XH=U(3,2)
      YH=U(4,2)
      GO TO 60
   50 XL=U(1,1)
      YL=U(2,1)
      XH=U(3,1)
      YH=U(4,1)
   60 RETURN
   70 FORMAT('$@')
   80 FORMAT(3A1)
      END
C----------------SUBROUTINE--SETUP---------------------------------
C	CORRECTION MADE BY MOHAN - 011486
C
      SUBROUTINE SETUP(FLINE,DSPACE,SNOFF,EEDGE,FORM)
C * SETS UP THE CRYSTAL MONOCHROMETER PARAMETERS FOR THE
C * CONVERSION FROM STEP NUMBER SPACE TO ENERGY SPACE.
      LOGICAL*1 ANS,Q(10)
      CALL FILES(1,'CONST.HLD',9,0,1,1,LUNIT)
      READ(LUNIT'1) FLINE,DSPACE,SNOFF,EEDGE
      IF(SNOFF.EQ.' ')SNOFF=0.
      IF(EEDGE.EQ.' ')EEDGE=0.
      IF(FORM.EQ.2. .OR. FORM .EQ. 3.) THEN	!INCLUDED (MR)
      TYPE 60, EEDGE
      ELSE 
      CALL NEWPAG
      TYPE 50, FLINE,DSPACE,SNOFF,EEDGE
      END IF
      TYPE 70
      ACCEPT 80,ANS
      IF(ANS.NE.'Y')GO TO 40
      IF(FORM.EQ.2. .OR. FORM .EQ. 3.) GO TO 30	!INCLUDED (MR)
      TYPE 90
      ACCEPT 100, Q
      IF(Q(1).EQ.' ')GO TO 10
      DECODE(10,140,Q) SPDMON
      FLINE=SPDMON
   10 TYPE 110
      ACCEPT 100 ,Q
      IF(Q(1).EQ.' ')GO TO 20
      DECODE(10,120,Q) D
      DSPACE=D
   20 TYPE 130
      ACCEPT 100 ,Q
      IF(Q(1).EQ.' ')GO TO 30
      DECODE(10,140,Q) STEPOF
      SNOFF=STEPOF
   30 TYPE 150
      ACCEPT 100,Q
      IF(Q(1).EQ.' ')GO TO 40
      DECODE(10,140,Q) EDGNRG
      EEDGE=EDGNRG
   40 WRITE(LUNIT'1) FLINE,DSPACE,SNOFF,EEDGE
   50 FORMAT(' PRESENT MONOCHROMETER STEPS/DEGREE ',F10.2,
     1/,' PRESENT CRYSTAL LATTICE SPACING(ANGSTROMS) ',F10.6,
     2/,' STEP NUMBER OFFSET ',F10.2,
     3/,' EDGE ENERGY (EV) ',F10.2)
   60 FORMAT(' PRESENT EDGE ENERGY (EV) ',F10.2)
   70 FORMAT('$ANY CHANGES? (Y/N) ')
   80 FORMAT(A1)
   90 FORMAT('$ENTER STEPS/DEGREE: ')
  100 FORMAT(10A1)
  110 FORMAT('$ENTER LATTICE SPACING: ')
  120 FORMAT(F10.5)
  130 FORMAT('$ENTER STEP NUMBER OFFSET: ')
  140 FORMAT(F10.2)
  150 FORMAT('$ENTER EDGE ENERGY IN EV"S: ')
      CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
      RETURN 
      END
C--------------------SUBROUTINE--SING------------------------------
C
      SUBROUTINE SING(IWHY)
C * SUBROUTINE TO CALL OUT THE MATRIX INVERSION ERRORS
   10 FORMAT('0MATRIX WITH ZERO ROW IN DECOMPOSE. ')
   20 FORMAT('0SINGULAR MATRIX IN DECOMPOSE.  ZERO DIVIDE IN SOLVE.')
   30 FORMAT('0NO CONVERGENCE IN IMPRUV. MATRIX IS NEARLY SINGULAR.')
      GO TO (40,50,60),IWHY
   40 TYPE 10
      GO TO 70
   50 TYPE 20
      GO TO 70
   60 TYPE 30
   70 RETURN
      END
C--------------------SUBROUTINE--SMLFIT----------------------------------
C	CORRECTION MADE BY MOHAN -011686
C
      SUBROUTINE SMLFIT(CC,X,Y,EQX,EQY,NPTS,NPTV,XI,XJ,XNMIN,NX)
C * THIS SUBROUTINE CALCULATES AND SUBTRACTS A SMOOTHLINE FIT
C * TO THE DATA USING A NONLINEAR AND UP TO 3RD ORDER
C * REGRESSIVE FIT.   THE RANGE TO FIT IS OBTAINED INTERACTIVELY
C * VIA THE CURSER.
      DIMENSION X(1024),Y(1024),EQX(1024),EQY(1024),TX(1024),
     C    T(1024),CC(4,1024),C(35),NC(9),XL(9),XH(9),IN(9),A(4,2)
      LOGICAL*1 PREV,NOSAVE,END,REGION,LAST,MCMAST,XANES 
      DATA N/1023/
      DATA PREV,NOSAVE,END,REGION,LAST,MCMAST,XANES/'P','N',
     C    'E','R','L','M','X'/
C * INITIALIZE VARIABLES AND FLAGS
      MCM=0
      MSAV=0
      NX=0
      NXSAV=0
      IREG=0
      NR=3
      NREG=3
      DO 10 I=1,9
   10 NC(I)=3
      PRE=0.
      SAV=0.
C * SELECT CUT POINTS AND SMOOTHLINE CHARACTERISTICS WITH GRAPHIC CURSERS
      CALL VCURSR(ICHAR,VX,VY)
C * READ STORED PARAMETERS FROM DISK
      CALL FILES(1,'CONST.HLD',9,0,1,1,LUNIT)
      READ(LUNIT'1) GARB,GARB,GARB,EEDGE
      READ(LUNIT'2) GARB1,XI,XJ,XNMIN,YNMIN
      READ(LUNIT'3) STPHGT,NEL1,NEL2,MCM,NREG,IREG
      READ(LUNIT'9) NX,G1,G2,G3,G4
      IF(NX.EQ.1 .AND. ICHAR.EQ.PREV) GO TO 30
	NX=0
C     IF(NX.EQ.1) GO TO 20
      GO TO 40
C   20 NX=0
   30 NXSAV=1
   40 IF(MCM.EQ.1.AND. ICHAR.EQ.PREV) GO TO 60
      IF(MCM.EQ.0)GO TO 70
   50 MCM=0
      MSAV=1
   60 MSAV=MSAV+1
   70 IF(ICHAR.EQ.PREV)GO TO 80
      IF(ICHAR.EQ.NOSAVE)GO TO 90
      SAV=1.
      GO TO 100
   80 NR=NREG
      N=NR*(1024/NR)
      PRE=1.
      GO TO 170
   90 CALL VCURSR(ICHAR,VX,VY)
  100 IF(ICHAR.NE.REGION)GO TO 120
      CALL VCURSR(KEY,VX,VY)
      DECODE(1,110,KEY)IKEY
  110 FORMAT(I1)
      NR=IKEY
      N=NR*(1024/NR)
      GO TO 90
  120 DO 130 I=1,NPTS
      IF(X(I).GE.VX)GO TO 140
  130 CONTINUE
  140 NEL1=I-1
      IF((X(I)-VX).LT.(VX-X(I-1)))NEL1=I
      XI=X(NEL1)
      YI=Y(NEL1)
      CALL CROSS(XI,YI,10)
      IF(ICHAR.EQ.LAST)GO TO 160
      CALL VCURSR(ICHAR,VX,VY)
      DO 150 I=1,NPTS
      IF(X(I).GE.VX)GO TO 180
  150 CONTINUE
  160 NEL2=NPTS
      XJ=X(NEL2)
      YJ=Y(NEL2)
      GO TO 190
  170 XI=X(NEL1)
      YI=Y(NEL1)
      IF(NEL2.GT.NPTS) NEL2=NPTS
      XJ=X(NEL2)
      YJ=Y(NEL2)
      CALL CROSS(XI,YI,10)
      GO TO 190
  180 NEL2=I-1
      IF((X(I)-VX).LT.(VX-X(I-1)))NEL2=I
      XJ=X(NEL2)
      YJ=Y(NEL2)
  190 CALL CROSS(XJ,YJ,10)
      XDLT=XJ-XI
C * SET UP AND COMPUTE CUBIC SPLINE INTERPOLATION BETWEEN IFIT AND JFIT
      DO 200 I=1,N
      FAC=FLOAT(I-1)/FLOAT(N-1)
  200 EQX(I)=XI+FAC*XDLT
      NUMPTS=NEL2-NEL1+1
      DO 210 I=1,NUMPTS
      T(I)=X(I+NEL1-1)
  210 CC(1,I)=Y(I+NEL1-1)
      CALL CUBSPL(T,CC,NUMPTS,0,0)
      I=1
      K=1
  220 H=EQX(K)-T(I)
      EQY(K)=CC(1,I)+H*(CC(2,I)+H*(CC(3,I)+H*CC(4,I)/3.)/2.)
      IF(K+1.GT.N)GO TO 240
      IF(I+1.GT.NUMPTS)GO TO 240
      K=K+1
  230 IF(EQX(K).LT.T(I+1)) GO TO 220
      I=I+1
      IF(I.EQ.NUMPTS)GO TO 220
      GO TO 230
C * OVERDRAW INTERPOLATION
  240 CONTINUE				!
C      CALL MOVEA(EQX(1),EQY(1))	!NOT SURE ?
C      DO 250 I=1,N			!
C  250 CALL DRAWA(EQX(I),EQY(I))	!
C * SET UP AND COMPUTE MULTI-REGION POLYNOMIAL SMOOTHLINE
      DO 260 I=1,35
  260 C(I)=0.
      XDLT=EQX(N)-EQX(1)
      X1=EQX(1)
      DO 270 I=1,N
  270 TX(I)=(EQX(I)-X1)/XDLT
      DO 280 I=2,NR
      XL(I)=TX((N/NR)*(I-1))
  280 XH(I)=TX((N/NR)*I)
      XL(1)=TX(1)
      XH(1)=XL(2)
      CALL POLSPL(TX,EQY,N,XL,XH,NR,C,NC)
      IN(1)=1
      DO 290 I=2,NR
  290 IN(I)=IN(I-1)+NC(I-1)
      DO 310 II=1,NR
      JF1=(N/NR)*(II-1)+1
      JL1=(N/NR)*II
      DO 310 JJ=JF1,JL1
      BB=C(IN(II))
      INI=IN(II)+1
      NCN=NC(II)+IN(II)-1
      DO 300 J=INI,NCN
  300 BB=BB+C(J)*TX(JJ)**(J-IN(II))
C * PLOT SMOOTHLINE FUNCTION
      IF(JJ.EQ.1) CALL MOVEA(EQX(1),BB)
      CALL DRAWA(EQX(JJ),BB)
  310 EQY(JJ)=EQY(JJ)-BB
  320 IF(PRE.EQ.1.)GO TO 330
C * SELECT MINIMUM FOR STEPHEIGHT CALCULATION
      CALL VCURSR(ICHAR,VX,VY)
      GO TO 340
  330 VX=XNMIN
  340 DO 350 I=1,NPTS
      IF(X(I).GE.VX) GO TO 360
  350 CONTINUE
  360 NMIN=I-1
      IF((X(I)-VX).LT.(VX-X(NMIN)))NMIN=I
      XNMIN=X(NMIN)
      YNMIN=Y(NMIN)
  370 TX1=(XNMIN-X1)/XDLT
C * EXTRAPOLATE SMOOTH LINE FOR STEPHEIGHT CALCULATION
      EXTRP=C(1)+TX1*(C(2)+(TX1*C(3)))
      CALL CROSS(XNMIN,YNMIN,10)
      CALL CROSS(XNMIN,EXTRP,10)
      STP=EXTRP-YNMIN
C      CALL MOVABS(1024-LINWDT(30),45)
      CALL MOVABS(0,45)      !SUB FOR ABOVE CALL
      CALL ALFMOD
      CALL IOWAIT(5)		
C * DISPLAY STEPHEIGHT DETERMINATION 
      TYPE 530, STP
  530 FORMAT(40X,' STEP HEIGHT: ',E12.4)
      CALL IOWAIT(5)		
      IF(PRE.EQ.1.)GO TO 380
C * TEST FOR SELECTION OF MCMASTER TREATMENT
      MCM=0
      IF(ICHAR.EQ.MCMAST)MCM=1
  380 IF(MCM.EQ.1) MSAV=1
      IF(PRE.EQ.1.)GO TO 390
      CALL VCURSR(ICHAR,VX,VY)
C * TEST FOR SELECTION OF XANES OUTPUT
      NX=0
      IF(ICHAR.EQ.XANES)NX=1
  390 IF(NX.EQ.1)NXSAV=1
      IF(NX.EQ.0 .AND. NXSAV.EQ.1)GO TO 400
      STPHGT=STP
      IF(PRE.EQ.1.)GO TO 420
  400 IF(ICHAR.NE.END.AND. ICHAR.NE.XANES)GO TO 320
C * WRITE PARAMETERS TO DISK FILE UNLESS NOSAVE OPTION WAS SPECIFIED
  410 IF(SAV.NE.1.)GO TO 430
      WRITE(LUNIT'2) GARB1,XI,XJ,XNMIN,YNMIN
  420 WRITE(LUNIT'3) STPHGT,NEL1,NEL2,MSAV,NR,IREG
      WRITE(LUNIT'9) NXSAV,G1,G2,G3,G4
  430 CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
C * INITIALIZE MCMASTER COEFFICIENT ARRAY
  440 DO 460 J=1,2
      DO 450 I=1,4
  450 A(I,J)=0.0
  460 CONTINUE
C * MCMASTER COEFFICIENTS OBTAINED IF MCMASTER TREATMENT SPECIFIED
      IF(MCM.EQ.1)CALL MCMSTR(A)
C * COMPUTE MCMASTER JUMP AT EXTRAPOLATED STEP
      SUM0=0.
      SUM00=0.
      ALNXM=ALOG(.001*(EEDGE+XNMIN))
      DO 470 L=1,4
      SUM0=SUM0+A(L,1)*ALNXM**(L-1)
  470 SUM00=SUM00+A(L,2)*ALNXM**(L-1)
C * LOOP TO COMPUTE NORMALIZED CHI FUNCTION
      ISTART=NEL1-1
      J=1
      K=1
      NPTV=NUMPTS
      IF(NX.EQ.1)NPTV=NEL2
      IF(NX.EQ.1)ISTART=0
      DO 520 I=1,NPTV
      XIS=X(I+ISTART)
      YIS=Y(I+ISTART)
C * COMPUTE BACKGROUND FOR SMOOTHLINE SUBTRACTION
      IF(XIS.LE.EQX(J*(N/NR)))GO TO 480
      K=K+3
      J=J+1
  480 TT=(XIS-X1)/XDLT
      BB=C(K)+TT*(C(K+1)+TT*C(K+2))
C * COMPUTE MCMASTER JUMP AS A FUNCTION OF ENERGY
      SUM1=0.
      SUM2=0.
      ALNX=ALOG(.001*(EEDGE+XIS))
      DO 490 L=1,4
      SUM1=SUM1+A(L,1)*ALNX**(L-1)
  490 SUM2=SUM2+A(L,2)*ALNX**(L-1)
      SUM=1.
      IF(SUM0.EQ.SUM00)GO TO 500
      SUM=(EXP(SUM1)-EXP(SUM2))/(EXP(SUM0)-EXP(SUM00))
C * NORMALIZATION FOR XANES, IF CHOSEN
  500 IF(NX.EQ.0)GO TO 510
      IF(XIS.LT.XNMIN)BB=YIS
      IF(XIS.GE.XNMIN)BB=BB-(STP*SUM)
C * NORMALIZED CHI FUNCTION CALCULATED OR NORMALIZED XANES CALCULATED
  510 EQX(I)=XIS
  520 EQY(I)=(YIS-BB)/(STP*SUM)
      RETURN
      END
C----------------------SUBROUTINE--SOLVE-------------------------------
C
      SUBROUTINE SOLVE(NN,B,X,UL,IPS)
C * SUBROUTINE TO SOLVE THE LINEAR SYSTEM OF EQUATIONS
      DIMENSION UL(4,4),B(4),X(4),IPS(4)
      DOUBLE PRECISION UL,B,X
      N=NN
      NP1=N+1
      IP=IPS(1)
      X(1)=B(IP)
      DO 20 I=2,N
      IP=IPS(I)
      IM1=I-1
      SUM=0.0
      DO 10 J=1,IM1
   10 SUM=SUM+UL(IP,J)*X(J)
   20 X(I)=B(IP)-SUM
      IP=IPS(N)
      X(N)=X(N)/UL(IP,N)
      DO 40 IBACK=2,N
      I=NP1-IBACK
C *        I GOES (N-1),...,1
      IP=IPS(I)
      IP1=I+1
      SUM=0.0
      DO 30 J=IP1,N
   30 SUM=SUM+UL(IP,J)*X(J)
   40 X(I)=(X(I)-SUM)/UL(IP,I)
      RETURN
      END
C--------------SUBROUTINE--STACKN-------------------------------------
C
      SUBROUTINE STACKN(XL,YL,XH,YH,U)
C * ALLOWS INPUT TO REPLOT STACK.
      DIMENSION U(4,3),CURNT(4)
      LOGICAL*1 ANS2
      FINISH=0.
   10 CURNT(1)=XL
      CURNT(2)=YL
      CURNT(3)=XH
      CURNT(4)=YH
      DO 20 I=1,4
      IF(U(I,1).NE.CURNT(I))GO TO 30
   20 CONTINUE
      GO TO 50
   30 DO 40 I=1,4
      U(I,3)=U(I,2)
      U(I,2)=U(I,1)
      U(I,1)=CURNT(I)
   40 CONTINUE
   50 CALL NEWPAG
      IF(FINISH.EQ.1)GO TO 100
      TYPE 110
      TYPE 120 ,CURNT(1)
      TYPE 160
      ACCEPT *,CHANGE
      IF(CHANGE.EQ.0.)GO TO 60
      XL=CHANGE
   60 XL=XL
      TYPE 130 ,CURNT(2)
      TYPE 160
      ACCEPT *,CHANGE
      IF(CHANGE.EQ.0.)GO TO 70
      YL=CHANGE
   70 YL=YL
      TYPE 140, CURNT(3)
      TYPE 160
      ACCEPT *,CHANGE
      IF(CHANGE.EQ.0.)GO TO 80
      XH=CHANGE
   80 XH=XH
      TYPE 150, CURNT(4)
      TYPE 160
      ACCEPT *,CHANGE
      IF(CHANGE.EQ.0.)GO TO 90
      YH=CHANGE
   90 YH=YH
      TYPE 170
      ACCEPT 180,ANS2
      IF(ANS2.NE.'Y')FINISH=1.
      GO TO 10
  100 RETURN
  110 FORMAT(///)
  120 FORMAT(' THE CURRENT VALUE OF XMIN IS: ',E13.5)
  130 FORMAT(' THE CURRENT VALUE OF YMIN IS: ',E13.5)
  140 FORMAT(' THE CURRENT VALUE OF XMAX IS: ',E13.5)
  150 FORMAT(' THE CURRENT VALUE OF YMAX IS: ',E13.5)
  160 FORMAT('$ENTER THE VALUE YOU WANT ')
  170 FORMAT('$MORE CHANGES? (Y/N) ')
  180 FORMAT(A1)
      END
C---------------SUBROUTINE--TICKS------------------------------------
C
      SUBROUTINE TICKS(XMIN,XMAX,YMIN,YMAX,XDEL,YDEL,
     CNXTX,XT,XV,NYTX,YT,YV)
C * THIS SUBROUTINE DRAWS ALL OF THE TICK-MARKS ON EACH 
C * OF THE FOUR AXES OF THE FRAME SURROUNDING THE PLOT.
C * THIS EDITION HAS A PROVISION FOR A ZERO TICK-MARK SEARCH.
      XV=XMIN
      YV=YMIN
      IF(XT.EQ.0.)GO TO 30
      DO 10 I=1,NXTX
      J=I-NXTX
      IF(J*XDEL.GT.XMIN)GO TO 20
   10 CONTINUE
   20 XV=J*XDEL
      CALL MOVEA(XV,YMIN)
      CALL DRWREL(0,15)
      CALL MOVEA(XV+(XDEL/2),YMIN)
      CALL DRWREL(0,7)
      CALL MOVEA(XV,YMAX)
      CALL DRWREL(0,-15)
      NXTX=NXTX-1
   30 DO 40 I=1,NXTX
      XVAL=XV+I*XDEL
      CALL MOVEA(XVAL,YMIN)
      CALL DRWREL(0,15)
      CALL MOVEA(XVAL,YMAX)
      CALL DRWREL(0,-15)
      CALL MOVEA(XVAL+(XDEL/2),YMIN)
   40 CALL DRWREL(0,7)
      IF(YT.EQ.0.)GO TO 70
      DO 50 I=1,NYTX
      K=I-NYTX
      IF(K*YDEL.GT.YMIN)GO TO 60
   50 CONTINUE
   60 YV=K*YDEL
      CALL MOVEA(XMIN,YV)
      CALL DRWREL(15,0)
      CALL MOVEA(XMIN,YV+(YDEL/2))
      CALL DRWREL(7,0)
      CALL MOVEA(XMAX,YV)
      CALL DRWREL(-15,0)
      NYTX=NYTX-1
   70 DO 80 I=1,NYTX
      YVAL=YV+I*YDEL
      CALL MOVEA(XMIN,YVAL)
      CALL DRWREL(15,0)
      CALL MOVEA(XMAX,YVAL)
      CALL DRWREL(-15,0)
      CALL MOVEA(XMIN,YVAL+(YDEL/2))
      CALL DRWREL(7,0)
   80 CONTINUE
      IF(XT.EQ.0.)GO TO 90
      NXTX=NXTX+1
   90 IF(YT.EQ.0.)GO TO 100
      NYTX=NYTX+1
  100 RETURN
      END
C---------------------------SUBROUTINE--TINT-----------------------------
C
      SUBROUTINE TINT(AMP,PH,X,NPTS,T,KFIRST,SCPTS)
C * SUBROUTINE TO INTERPOLATE PHASE OR AMPLITUDE FOR ENTRY INTO
C * TABULAR PHASE TABLE
      DIMENSION AMP(1024),PH(2048),T(8192),X(1024),IEL(4),NME(4),
     1    PHI(20)
      COMPLEX T
      DIMENSION CAY(20)
      LOGICAL*1 ANS,IEL,NME,LQN,CH,UN(4)
      DATA CAY/3.7795,4.2519,4.7243,5.1967,5.6692,6.1416,6.6140,
     C    7.0865,7.5589,8.5038,9.4486,10.3935,11.3384,12.2832,
     C    13.2281,14.1729,15.1178,3*0.0/
      DATA UN/'U','N',' ',' '/
      DATA RFI,RSE,RDELT,RCOR1,POW,SIGM1,SIGM2/0.,0.,0.,0.,1.,1.,1./
      DSI=0.
      TWOPI=6.28318531
C      CALL FILES(7,'TMPFIL',6,0,-1,0,NUNIT)
      CALL NEWPAG
   10 TYPE 250
      ACCEPT 340,CH
      IF(CH.NE.'P'.AND. CH.NE.'A')GO TO 10
      IF(CH.EQ.'A') GO TO 20
      R1=0.
      E0=0.
      TYPE *,'PHASE SHIFT(K") = TOTAL PHASE(K) - 2KR1'
      TYPE *,'WHERE K"=SQRT[K**2-.262467*E0]'
      TYPE 300
      ACCEPT *, R1,E0
      GO TO 50
   20 DO 30 I=1,NPTS
      KINDEX=KFIRST-1+I
      AMP(I)=CABS(2.*T(KINDEX)/SCPTS)
   30 CONTINUE
      XN1=1.
      R1=1.
      SI2=0.
      N=0
      M=0
      E0=0.
      TYPE *,'AMPLITUDE(K") = K*N*[N1/(K*R1**2)',
     C    '*EXP(-2K**2*SI2)]**M*AMP(K)'
      TYPE *,'WHERE K"=SQRT[K**2-.262467*E0]'
      TYPE 310
      ACCEPT *,XN1,R1,SI2,M,N,E0
      TYPE *,'BEAT-ANALYSIS?'
      ACCEPT 340,ANS
      IF (ANS.NE.'Y') GOTO 50
      TYPE *,'AMP(ONE SHELL)=AMP(2 SHELL)/CORRECTION**POW'  
      TYPE*,'ENTER POW'
      ACCEPT *,POW
      TYPE 320
      ACCEPT *,RFI,RSE
   40 RDELT=2.*(RSE-RFI)
      RCOR1=2.*RFI*RFI/(RSE*RSE)
      TYPE *,'DIFFERENT SIGMA**2?'
      ACCEPT 340,ANS
      IF (ANS.NE.'Y') GOTO 50
      TYPE 330
      ACCEPT *,SIGM1,SIGM2
      DSI=(SIGM2-SIGM1)*2.
   50 J=1
      FAC=40
      VSQDEL=.262467*E0
      DO 110 L=1,NPTS-1
      XL=X(L)
      XL1=X(L+1)
      AL=AMP(L)
      AL1=AMP(L+1)
      PL=PH(L)
      PL1=PH(L+1)
      XDEL=FAC*(XL1-XL)
      ADEL=FAC*(AL1-AL)
      PDEL=FAC*(PL1-PL)
      IF(CAY(J).GE.XL.AND.CAY(J).LT.XL1)GO TO 80
      IF(J.EQ.1 .AND. (XL-CAY(J)).LE.XDEL)GO TO 60
      IF(J.EQ.17 .AND.(CAY(J)-XL1).LE.XDEL)GO TO 70
      GO TO 110
   60 XL1=XL
      XL=XL-XDEL
      AL1=AL
      AL=AL-ADEL
      PL1=PL
      PL=PL-PDEL
      GO TO 80
   70 XL=XL1
      XL1=XL1+XDEL
      AL=AL1
      AL1=AL1+ADEL
      PL=PL1
      PL1=PL1+PDEL
   80 XMAX=SQRT(XL1*XL1-VSQDEL)
      XMIN=SQRT(XL*XL-VSQDEL)
      IF(CH.EQ.'P')GO TO 90
      ARGMAX=-2.*XMAX*XMAX*SI2
      ARGMIN=-2.*XMIN*XMIN*SI2
      AMPFAC=XN1/(R1*R1)
      BEATMA=1.+RCOR1*RCOR1*.25*EXP(-2.*DSI*XMAX**2)+
     CRCOR1*EXP(-DSI*XMAX**2)*COS(RDELT*XMAX)
      BEATMI=1.+RCOR1*RCOR1*.25*EXP(-2.*DSI*XMIN**2)+
     CRCOR1*EXP(-DSI*XMIN**2)*COS(RDELT*XMIN)
      IF (BEATMA.LT.0.01) BEATMA=.01
      IF (BEATMI.LT.0.01) BEATMI=.01
      YMAX=(AL1*(XMAX**N)*(AMPFAC/XMAX*EXP(ARGMAX))**M)/(BEATMA**
     C(.5*POW))
      YMIN=(AL*(XMIN**N)*(AMPFAC/XMIN*EXP(ARGMIN))**M)/(BEATMI**
     C(.5*POW))
      GO TO 100
   90 YMAX=PL1-2.*XMAX*R1
      YMIN=PL-2.*XMIN*R1
  100 PHI(J)=(YMAX-YMIN)*(CAY(J)-XMIN)/(XMAX-XMIN)+YMIN
      IF(J.EQ.17)GO TO 130
      J=J+1
  110 CONTINUE
  120 TYPE *,'INTERPOLATION RANGE NOT COINCIDENT WITH DATA RANGE'
      GO TO 380
  130 TYPE 260
      ACCEPT 350,IEL(1),IEL(2)
  140 IF(CH.EQ.'A')GO TO 150
      TYPE 270
      ACCEPT 340,LQN
      IF(LQN.GE."60 .AND. LQN.LE."62) GO TO 160
  150 LQN=' '
  160 IEL(3)=LQN
      IEL(4)=' '
      CALL FILES(3,'TEOLEE.PHT',10,0,1,4,LUNIT)
      READ(LUNIT'1,ERR=170) LASTRC
      GO TO 190 
  170 TYPE *,'TABLE NOT FOUND ON DISK'
  180 CALL FILES(3,'TEOLEE.PHT',10,0,0,0,LUNIT)
      TYPE 290
      ACCEPT 340,ANS
      IF(ANS.NE.'Y')GO TO 130
      GO TO 380
  190 JJ=0
      DO 210 I=2,LASTRC,3
      NREC=I
      READ(LUNIT'NREC)NME
      IF(NME(1).EQ.UN(1).AND.NME(2).EQ.UN(2).AND.JJ.EQ.0)JJ=I
      DO 200 J=1,4
  200 IF(NME(J).NE.IEL(J))GO TO 210
      GO TO 220
  210 CONTINUE  
      GO TO 230
  220 JJ=I
      TYPE 280
      ACCEPT 340, ANS
      IF(ANS.NE.'Y')GO TO 180
  230 IF(JJ.EQ.0)JJ=LASTRC+1
  240 WRITE(NUNIT,360) IEL,(PHI(I),I=1,17)
      TYPE 370
      ACCEPT 340, ANS
      IF(ANS.NE.'Y')GO TO 180
      WRITE(LUNIT'JJ) IEL,(PHI(I),I=1,5)
      JJ=JJ+1
      WRITE(LUNIT'JJ) (PHI(I),I=6,11)
      JJ=JJ+1
      WRITE(LUNIT'JJ) (PHI(I),I=12,17)
      IF(JJ.GT.LASTRC) WRITE(LUNIT'1) JJ
      CALL FILES(3,'TEOLEE.PHT',10,0,0,0,LUNIT)
  250 FORMAT(/,'$INTERPOLATE (P)HASE OR (A)MPLITUDE ?  ')
  260 FORMAT('$SPECIFY 2-LETTER TABLE ENTRY NAME : ')
  270 FORMAT('$SPECIFY QUANTUM NO. L; <RET> FOR BACKSCATTERER: ')
  280 FORMAT('$TABLE ENTRY NAME ALREADY USED!   REPLACE ? ')
  290 FORMAT('$DO YOU WANT TO EXIT INTERPOLATION OPTION ? ')
  300 FORMAT('$ENTER  R1,E0; DEFAULT IS (/)SLASH: ')
  310 FORMAT('$ENTER  N1,R1,SI2,M,N,E0; DEFAULT IS (/)SLASH: ')
  320 FORMAT('$ENTER FIRST,SECOND PEAK POSITION: ') 
  330 FORMAT('$ENTER SIGMA**2,FIRST,SECOND SHELL: ')
  340 FORMAT(A1)
  350 FORMAT(2A1)
  360 FORMAT(1X,4A1,6(F8.4),2(/,5X,6(F8.4)))
  370 FORMAT('$OK ? ')
  380 RETURN
      END
C----------------FUNCTION--WIN-----------------------------------------
C
      FUNCTION WIN(XK1,XK2,ID,XK)
C * THIS FUNCTION CALCULATES THE MODIFIED HANNING WINDOW WHERE ID IS
C * THE PERCENT COSINE WINDOW.
      PI=3.141593
      IF(XK.LT.XK1 .OR. XK.GT.XK2)GO TO 20
      IF(ID.EQ.0)GO TO 10
      DK=ID*(XK2-XK1)/100.
      IF(XK.LE.(XK1+DK))GO TO 30
      IF(XK.GE.(XK2-DK))GO TO 40
   10 WIN=1.
      RETURN
   20 WIN=0.
      RETURN
   30 WIN=(1.-COS(PI*(XK-XK1)/DK))/2.
      RETURN
   40 WIN=(1.+COS(PI*(XK-(XK2-DK))/DK))/2.
      RETURN
      END
C-----------------SUBROUTINE--WINDOW--------------------------------------
C
	SUBROUTINE WINDOW(X,Y,V,W,NPTS,NPTV)
	DIMENSION V(1024),W(1024),X(1024),Y(1024)
	LOGICAL*1 KEY
	INTEGER LOWER,UPPER
	REAL XMIN,XMAX,YMIN,YMAX
	CALL VCURSR(KEY,XMIN,YMIN)
           DO 10 I=1,NPTS
10	   IF(X(I).GT.XMIN) GOTO 20
20	LOWER=I-1
C 	CALL INTRO		!NOT FOR TEK
	CALL CROSS(X(LOWER),Y(LOWER),10)
C	CALL TERMIT		!NOT FOR TEK
	CALL IOWAIT(2)
	CALL VCURSR(KEY,XMAX,YMAX)
           DO 30 I=1,NPTS
30	   IF(X(I).GT.XMAX) GOTO 40
40	UPPER=I-1
C	CALL INTRO		!NOT FOR TEK
	CALL CROSS(X(UPPER),Y(UPPER),10)
C	CALL TERMIT		!NOT FOR TEK
	CALL IOWAIT(2)
	J=1
	DO 50 I=LOWER,UPPER
	V(J)=X(I)
	W(J)=Y(I)
	J=J+1
50	CONTINUE
	NPTV=J-1
	RETURN
	END

C--------------------SUBROUTINE--WRITE-------------------------
C
      SUBROUTINE WRITFL(X,Y,NPTS,NAMES,KOPT,LOPT,FORM,KLOG,ESHFT,
     CICAPX,ICAPY,XIFIT,XJFIT,XNMIN,NC,INPUT,IDGL,IFFT,KPOWR,NIX)
C * GENERATES DISK FILE OR PRINT OUTPUT.
      DIMENSION X(1024),Y(1024),NAMES(25)
	LOGICAL*1 ONAME(25)
      LOGICAL*1 NAMES,NAME(25),NNAME(25),KOPT,LOPT,ZERO,IDATE
      DIMENSION IHEADR(15,8),NC(30),IDAT(5),IDATE(10)
      DATA ZERO /O0/
      DATA IHEADR/'RA','TI','O ','VS',' S','TE','P ','NU','MB',
     C    'ER',5*'  ','LN','  ','RA','TI','O ','VS',' S','TE',
     C    'P ','NU','MB','ER',3*'  ','AB','SO','RP','TI','ON',
     C    ' V','S ','EN','ER','GY',5*'  ','CH','I ','VS',' E',
     C    'NE','RG','Y ',8*'  ','CH','I ','VS',' W','AV','E ',
     C    'VE','CT','OR',6*'  ',15*'  ','MA','GN','IT','UD','E ',
     C    'VS',' R',8*'  ','BT',' K','**','M ','CH','I ','VS',
     C    ' W','AV','E ','VE','CT','OR',2*'  '/
	I=1
	J=1
C10	IF((NAMES(I).EQ.58).OR.(NAMES(I).EQ.93)) THEN
C 	   J=0
C	   GO TO 20
C	END IF
10	CONTINUE
C	IF(NAMES(I).EQ.ZERO) NAMES(I)=' '
        NAME(J)=NAMES(I)
	ONAME(I)=NAMES(I)
        IF(NAME(J).EQ.'.')IP=J+1
	J=J+1
	I=I+1
	IF(I.LE.25) GO TO 10
C	IT=NAME(IP)
      ISUM=ICAPX+ICAPY+KLOG
      IF(NAME(IP).EQ.'P') GOTO 30
      IF(ISUM.EQ.2) NAME(IP)='R'
      IF(ISUM.EQ.3) NAME(IP)='L'
      IF(ISUM.EQ.4) NAME(IP)='A'
      IF(ISUM.EQ.5) NAME(IP)='E'
      IF(ISUM.EQ.6) NAME(IP)='K'
      IF(ISUM.EQ.8) NAME(IP)='F'
      IF(ISUM.EQ.9) NAME(IP)='B'
   30 N=0
	IF ( ISUM .EQ. 3 .AND. NIX .EQ. 1) ISUM=4
      IF(ISUM.LE.3 .OR. ISUM.GT.9)GO TO 40
      CALL FILES(1,'CONST.HLD',9,0,1,1,LUNIT)
      READ(LUNIT'1) FLINE,DSPACE,SNOFF,EEDGE
      READ(LUNIT'2) ESH,XI,XJ,XNMIN,YNMIN
      READ(LUNIT'3) STPHGT,NEL1,NEL2,MCM,NR,IREG
      READ(LUNIT'4) XKMIN,XKMAX,IPRCNT,KPOWR,KNUM,SCPTS
      READ(LUNIT'5) XRMIN,XRMAX
      READ(LUNIT'9) NX,FLA
      CALL FILES(1,'CONST.HLD',9,0,0,0,LUNIT)
      NX=0
      IF(NIX.EQ.1)NX=1
      IF(ISUM.EQ.4.AND.NX.EQ.1)NAME(IP)='X'
   40 IF(INPUT.EQ.NC(14)) GO TO 80
      IF(INPUT.EQ.NC(22))GO TO 80
      IF(INPUT.EQ.NC(21))GO TO 90
	CALL TOUTPT(24)
      WRITE (5,50) (NAME(I),I=1,25)
   50 FORMAT ('0 STORED NAME IS ',25A1,' ENTER NEW NAME TO CHANGE,
     C OTHERWISE CR ')  
      READ (5,310) (NNAME(I),I=1,25)
      IF (NNAME(1) .EQ. ' ') GOTO 70
      DO 60 I=1,25
   60 NAME(I)=NNAME(I)
   70 CALL FILES(3,NAME,25,1,1,0,NUNIT)
      GO TO 110
C   80 CALL FILES(5,'TMPFIL',6,0,-1,0,NUNIT)
80      GO TO 110
C   90 CALL FILES(5,'TMPFIL',6,0,-1,0,NUNIT)
C90      TYPE 100, 27,91,53,105
90      N=7
  100 FORMAT (1X,4A1)
C      CALL NEWPAG
  110 IFRM=IHEADR(5,4)
      IF(FORM.EQ.1.)IFRM=IHEADR(5,2)
      IF(N.EQ.7) TYPE 300
      CALL DATE(IDAT)
      DECODE(10,310,IDAT) IDATE
      IDATE(10)=ZERO
C	NAME(IP)=IT
      WRITE(NUNIT,200) (ONAME(I),I=1,25)
      JSUM=ISUM-1
      WRITE(NUNIT,210) (IHEADR(I,JSUM),I=1,15)
      WRITE(NUNIT,220) IDATE,KOPT,LOPT,IFRM,ISUM,IDGL
      IF(ISUM.LE.3 .OR. ISUM.GT.9)GO TO 120
      WRITE(NUNIT,230) FLINE,DSPACE,SNOFF,EEDGE,ESHFT,NX
  120 IF(ISUM.LT.5 .AND. NX.EQ.0) GO TO 130
      WRITE(NUNIT,240) XIFIT,XJFIT,FLA
      IF(MCM.NE.1)MCM=0
      WRITE(NUNIT,250) XNMIN,YNMIN,STPHGT,NEL1,NEL2,MCM,NR
  130 IF(IFFT.EQ.0) GO TO 140
      WRITE(NUNIT,260) XKMIN,XKMAX,KNUM,SCPTS,IPRCNT,KPOWR
      IF(ISUM.LT.9)GO TO 140
      WRITE(NUNIT,270) XRMIN,XRMAX,KPOWR
  140 IF(INPUT.EQ.NC(22))GO TO 160
      IF(INPUT.EQ.NC(21))GO TO 180
      SGN=1.
      IF(ISUM.LT.4) SGN=-1.
      WRITE(NUNIT,280) (I,(SGN*X(I)),Y(I),I=1,NPTS)
  150 IF(INPUT.EQ.NC(14))GO TO 160
      CALL IOWAIT(5)
      ENDFILE NUNIT
      CALL FILES(3,NAME,25,1,0,0,NUNIT)
      GO TO 170
  160 WRITE(NUNIT,290)
      REWIND NUNIT
  170 CONTINUE
  180 CALL IOWAIT(2)
	CALL HOME
C      TYPE 190, 27,91,52,105
  190 FORMAT (1X,4A1)
      RETURN
  200 FORMAT(/,' RAW DATA FILE NAME: ',25A1)
  210 FORMAT(1X,15A2)
  220 FORMAT(' DATE: ',10A1,/,' CHANNELS:',I1,'/',I1,2X,A2,2(2X,I1))
  230 FORMAT(' MONOCHROMETER STEPS/DEGREE: ',F10.0,
     1/,' CRYSTAL LATTICE SPACING: ',F10.5,
     2/,' STEP NUMBER OFFSET: ',F10.2,
     3/,' ABSORPTION EDGE ENERGY (EV): ',F10.2,
     4/,' EDGE SHIFT (EV): ',F10.2,'  XANES(1=YES,0=NO): ',I2)
  240 FORMAT(' SMOOTHLINE SUBTRACTION BETWEEN PTS: ',
     1 2(2PE12.4,'(EV)',1X),'  FLA: ',1PE12.4)
  250 FORMAT(' XNMIN: ',2PE12.4,1X,'YNMIN: ',2PE12.4,'  STPHGT: ',
     11PE12.4,2(2X,I3),3X,'MCMASTER(1=YES,0=NO):',I2,' # REGIONS:',I2)
  260 FORMAT(' KMIN: ',1PE12.4,3X,'KMAX: ',2PE12.4,
     1/,' FOURIER TRANSFORM OF ',I4,' PTS. IN INCREMENTS 96./',0PF6.0,
     2/,' PERCENT WINDOWING: ',I2,'    WEIGHTED BY K**',I1)
  270 FORMAT(' BACKTRANSFORM PARAMETERS',
     1/,' RMIN: ',1PE12.4,3X,'RMAX: '1PE12.4,6X,' M=',I1)
  280 FORMAT(4(1X,0PI4,1P2E13.5))
  290 FORMAT('1',/,'1')
  300 FORMAT(/)
  310 FORMAT(25A1)
      END
