Google
 

Trailing-Edge - PDP-10 Archives - decuslib20-05 - decus/20-0137/tscd/tscd.for
There are 2 other files named tscd.for in the archive. Click here to see a list.
C	WESTERN MICHIGAN UNIVERSITY
C	TSCD.FOR (FILE NAME ON LIBRARY DECTAPE)
C	TSCD, 1.13.1 (CALLING NAME, SUBLST NO.)
C	TIME SERIES CHANGE DETECTION
C	THE TEST PROCEDURES UTILIZED IN THIS PROGRAM ARE
C	 MODIFICATIONS OF THE METHODS AND PROGRAMMING SHOWN IN
C	 "CHANGE DETECTION MODEL FOR SERIALLY CORRELATED DATA"
C	 BY JONES, CROWELL, AND KAPUNIANI IN 
C	 PSYCHOLOGICAL BULLETIN, 1969, VOL. 71, NO. 5, 352-358.
C	PROGRAMMED BY B. HOUCHARD, ACADEMIC COMPUTER CENTER, WMU.
C	LIBRARY DECTAPE PROGS. USED:  USAGE.MAC
C	FORWMU PROGS. USED:  TTYPTY, EXISTS, PRINTS, DEVCHG
C	BNKLIB PROGS. USED:  GETID, GETFR1, FISHER
C	INTERNAL SUBR. USED:   TCHAN, PLOT, CHIPRB, CUNO, IOTS
C	ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
C	LIMITATIONS:
C
C	(1)  # OF POST DATA IS BETWEEN 1 AND 2000
C	(2)  # OF POST DATA + # OF PRE DATA SHOULD BE BETWEEN 1 AND 4000
C	(3)  ONLY 1 LINE ALLOTED FOR OBJECT TIME FORMAT
C	(4)  ONLY F-TYPE FORMAT ALLOWED
C
C***********************************************************************
C
	DIMENSION X(4000),POST(2000),IDATE(2),AVE(2),S(2),B(2),SP(2),
     1 SS(2),PP(2),T(2),NOTF(16)
	COMMON/IOBLK/IDLG,ICC,INP,IOUT,IO2,IO3,ICODE,IPLT,NAMI(2),ITYCH
	COMMON/IOBLKA/NAMO(2),IPJ,IPG,NCOPYS
	COMMON/SGETFR/ISTD,ITYPE
	COMMON/SID/ID(16),ISTOP
	COMMON/BLOCK1/N,MA,X,POST
	DOUBLE PRECISION NAMM
	EQUIVALENCE (NAMM,NAMO)
	DATA PP/'PRE ','POST'/
C
C*********************************************************************
C	DEVICES USED:
C	IDLG--DEVICE USED TO COMMUNICATE WITH USER
C	      IT IS ALWAYS SET TO -1
C	ICC---DEVICE USED TO ACCEPT USER'S RESPONSES
C	      IT IS ALWAYS SET TO -4
C	INP---DEVICE USED TO READ IN THE DATA
C	      ITS LOGICAL NUMBER IS ASSIGNED BY SUBRUTINE IOTS
C	IOUT--DEVICE USED TO WRITE OUT THE REPORT
C	      ITS LOGICAL NUMBER IS ASSIGNED BY SUBROUTINE IOTS
C	NOUT--DEVICE USED TO PLOT THE GRAPH
C	      NOUT= 1     IF IO3 IS NOT 'TTY'
C	          = IOUT  OTHERWISE
C***********************************************************************
C
	IDLG=-1
	ICC=-4
	INP=2
	IOUT=3
C
C***********************************************************************
C	ADD ONE TO LIBRARY PROGRAM USAGE COUNTER
C***********************************************************************
C
C	CALL USAGE('TSCD')
C
C***********************************************************************
C	CHECK IF JOB IS FROM TELETYPE OR PSEUDO-TELETYPE
C	IF ICODE =  0   JOB IS FROM TELETYPE
C	         = -1   JOB IS FROM PSUEDO-TELETYPE
C***********************************************************************
C
	CALL TTYPTY(ICODE)
C
C***********************************************************************
C	GATHER ALL INPUT/OUTPUT INFORMATION
C	OUTPUT OPTION IS AVAILABLE ONLY ONCE IN THE PROGRAM
C***********************************************************************
C
	CALL IOTS(1)
	IPLT=0
	IDUM=0
	NOUT=IOUT
10	CALL IOTS(0)
C
C***********************************************************************
C	FORMAT SUBROUTINE, ITYPE = 0 MEANS F-TYPE ONLY
C***********************************************************************
C
	ITYPE=0
C---------------NOTF IS RETURNED.
	CALL GETFR2(0,16,NOTF)
C
C***********************************************************************
C	GATHER ALL OTHER PROBLEM INFORMATON
C***********************************************************************
C
C****** WMU AM: 1.13.1-1, MTO, 2-FEB-78
	WRITE (IDLG,36)
36	FORMAT (' ENTER HEADER')
	READ (ICC,37) ID
37	FORMAT (16A5)
	DO 38 ISTOP = 16, 1, -1
38	IF (ID(ISTOP).NE.' ') GOTO 39
39	CONTINUE
C****** END = MAIN, STMT #30-1
C
C
C
30	WRITE(IDLG,31)
31	FORMAT(' # OF PRE DATA AND # OF POST DATA, SEPARATED BY COMMA--'
     1,$)
	READ(ICC,32) N,MA
32	FORMAT(2I)
	IF ((MA.GE.1).AND.(MA.LE.2000)) GO TO 330
	WRITE(IDLG,331) MA
331	FORMAT(' PROGRAM RESTRICTION:  # OF POST DATA SHOULD BE
     1 BETWEEN 1 AND 2000'/23X,'INCLUSIVE.  USER ENTERED ',I7,
     2 ' TRY AGAIN.'/)
	GO TO 332
330	NMA=N+MA
	IF ((NMA.GT.0).AND.(NMA.LE.4000)) GO TO 40
	WRITE(IDLG,33) NMA
33	FORMAT(' PROGRAM RESTRICTION:  # OF PRE DATA + # OF POST DATA
     1 SHOULD BE'/23X,'BETWEEN 1 AND 4000 INCLUSIVE.  USER ENTERED'/
     2 23X,I7,', TRY AGAIN.'/)
332	IF (ICODE.GE.0) GO TO 30
34	WRITE(IDLG,35)
35	FORMAT('+JOB TERMINATES'/)
	CALL EXIT
40	WRITE(IDLG,41) 
41	FORMAT(' LINEAR TRENDS IN THE PRE AND POST DATA? (YES OR NO)--',
     1 $)
	READ(ICC,42) ITREND
42	FORMAT(A3)
	WRITE(IDLG,44)
44	FORMAT(' MODEL ADEQUACY CHECK?  (YES OR NO)--',$)
	READ(ICC,42) IMAC
	WRITE(IDLG,43)
43	FORMAT(' PLOT OF THE PRE, POST AND PREDICTED POST DATA? (YES
     1 OR NO)--',$)
	READ(ICC,42) IPLOT
	IF (IPLOT.NE.'YES') GO TO 500
	IF (IO3.NE.'TTY') GO TO 500
	IDUM=IDUM+1
	IF (IDUM.GT.1) GO TO 500
	WRITE(IDLG,432)
432	FORMAT('-THE GRAPH WILL BE AT THE OUTPUT WINDOW AFTER THIS
     1 RUN'/)
	NOUT=1
	IPLT=1
	NAMO(1)='TSGRP'
	NAMO(2)='.DAT'
	CALL DEFINE FILE(NOUT,0,NV,NAMM,0,0)
C
C************************************************************************
C	ADJUST FORMAT IF NECESSARY 
C	START READING DATA
C***********************************************************************
C
500	IF (ISTD.EQ.0) GO TO 51
	NOTF(1)='(10F)'
	DO 50 I=2,16
50	NOTF(I)=' '
51	IF (IO2.EQ.'TTY') GO TO 520
	WRITE(IDLG,521)
521	FORMAT(' PLEASE WAIT, YOUR DATA IS BEING PROCESSED'/)
	GO TO 54
520	WRITE(IDLG,52)
52	FORMAT(' ENTER PRE DATA'/)
	IF (ISTD.NE.0) WRITE(IDLG,53)
53	FORMAT('+10 NUMBERS PER LINE, SEPARATED BY COMMAS'/)
54	READ(INP,NOTF)(X(I),I=1,N)
	IF (IO2.NE.'TTY') GO TO 56
	WRITE(IDLG,55)
55	FORMAT(' ENTER POST DATA'/)
	IF (ISTD.NE.0) WRITE(IDLG,53)
56	READ(INP,NOTF)(X(I),I=N+1,NMA)
C
C***********************************************************************
C	START WRITING OUT THE REPORT
C***********************************************************************
C
	IF (IO3.EQ.'TTY') GO TO 65
	CALL DATE (IDATE)
	WRITE(IOUT,60) IDATE,ID,NOTF,N,MA,ITREND,IMAC,IPLOT
60	FORMAT('1'/'3WESTERN  MICHIGAN  UNIVERSITY'/' TIME SERIES
     1 TEST FOR CHANGE DETECTION PROGRAM'/'-CALLING NAME:  TSCD'/
     2 ' DATE RUN:  ',2A5/'-TITLE:  ',16A5/' FORMAT:  ',16A5//
     3 '-NUMBER OF PRE DATA',25('.'),I5/' NUMBER OF POST DATA',
     4 24('.'),I5/' LINEAR TRENDS?',29('.'),2X,A3/
     5 ' MODEL ADEQUACY CHECKS?',21('.'),2X,A3/
     6 ' PLOT OF THE PRE, POST AND PREDICTED DATA?..  ',A3)
	WRITE(IOUT,610)
610	FORMAT('1')
	GO TO 70
65	WRITE(IOUT,66) (ID(I),I=1,ISTOP)
66	FORMAT('1',16A5)
	WRITE(IOUT,660) N,MA
660	FORMAT(' NUMBER OF PRE DATA  =',I6/' NUMBER OF POST DATA =',I6)
70	CALL TCHAN(IMAC,AVE(1),S(1))
C
C***********************************************************************
C	LINEAR TRENDS TESTS OPTION
C***********************************************************************
C
	IF (ITREND.NE.'YES') GO TO 90
	S(2)=0
	AVE(2)=0
	DO 81 I=N+1,NMA
81	AVE(2)=AVE(2)+X(I)
	AVE(2)=AVE(2)/MA
	K=0
	IEND=N
	SS(1)=FLOAT((N-1)*N*(N+1))/12
	SS(2)=FLOAT((MA-1)*MA*(MA+1))/12
	DO 83 I=1,2
	SP(I)=0
	DO 84 J=1,IEND
84	SP(I)=SP(I)+(X(J+K)-AVE(I))*J
	B(I)=SP(I)/SS(I)
	WRITE(IOUT,85) PP(I),AVE(I),PP(I),B(I)
85	FORMAT('-AVERAGE OF ',A4,'-DATA =',F12.4/' ESTIMATED LINEAR
     1 SLOPE OF ',A4,'-DATA =',G12.4)
	K=N
	IEND=MA
83	 CONTINUE
	WRITE(IOUT,88)
88	FORMAT('-NOTE:  IF EITHER ONE OF THE TRENDS IS DIFFERENT FROM
     1 ZERO, THEN THE'/8X,'DATA IS PERHAPS NOT STATIONARY, AND THE MODEL
     2 ADEQUACY OPTION'/8X,'SHOULD BE USED TO CHECK THE VALIDITY OF THE
     3 FIRST ORDER MARKOV'/8X,'MODEL.')
C
C*************************************************************************
C	PLOT OPTION
C	CREATE A DISK FILE FOR TELETYPE OUTPUT JOBS
C***********************************************************************
C
90	IF (IPLOT.EQ.'YES') CALL PLOT(NOUT,ID)
	WRITE(IDLG,91)
91	FORMAT('-')
	GO TO 10
	END
C
C	SUBROUTINE TCHAN TEST FOR CHANGE USING FIRST-ORDER
C	     AUTOREGRESSIVE MODEL
C
C
C	THIS SUBROUTINE WAS ORIGINALLY TAKEN FROM THE ARTICLE
C	"CHANGE DETECTION MODEL FOR SERIALLY CORRELATED DATA"
C	BY RICHARD H. JONES, DAVID H. CROWELL AND LINDA KAPUNIAI,
C	PSYCHOLOGICAL BULLETINE 1969, VOL. 71, NO.5, PAGES 352-358.
C
C
C	THE ABOVE SUBROUTINE IS COMPLETELY REWRITTEN.  THE CHANGES ARE:
C
C	(1)  REPLACE AND ADD MORE VECTORS,
C	(2)  PRESERVE PRE AND POST DATA VECTOR FOR FUTURE USE,
C	(3)  MORE CALCULATIONS ADDED,
C	(4)  REPORT ON RESULTS ARE WRITTEN IN THE SUBROUTINE.
C
C	SOME OF THE ABOVE CHANGES ARE RECOMMENDED BY DR. MICHAEL
C	STOLINE, STATISTICAL CONSULTANT,WMU COMPUTER CENTER.
C
C	WRITTEN BY BERENICE G. HOUCHARD
C	           WMU COMPUTER CENTER
C	           MAY, 1973
C
C
C---------------IMAC IS INPUT.  OTHER ARGS. ARE RETURNED.  IOUT
C--------------- IS INUT THRU COMMON /IOBLK/.  W, MA, X ARE INPUT THRU
C--------------- /BLOCK1/. POST IS RETURNED THRU COMMON /BLOCK1/.
C	SUBROUTINE TCHAN(IMAC,AVE,R1)
C	ARGUMENTS RETURNED TO THE CALLING PROGRAM:
C	     AVE-------MEAN OF PRE-DATA
C	   R(1)-----
C
C
C
	SUBROUTINE TCHAN(IMAC,AVE,R1)
	DIMENSION X(4000),POST(2000),RR(2000),T(2000),TR(1898),
     1 FRR(2000),R(2000),E(2000),EX(1998),M(3),MD(3),CH(3),P(3)
C
C
C	TR(N-2)--T TEST ON PARTIAL SERIAL CORRELATION COEFFICIENTS LAGS
C	         2 TO N-1
C	T(MA)----T TEST ON POST DIFFERENCES
C	EX(N-2)--PARTIAL SERIAL CORRELATION COEFFICIENTS
C	RR(N)----SERIAL CORRELATIONS
C	R(N)-----WORKING STORAGE VECTOR
C
	COMMON/IOBLK/IDLG,ICC,INP,IOUT,IO2,IO3,ICODE,IPLT,NAMI(2),ITYCH
	COMMON/BLOCK1/N,MA,X,POST
	EQUIVALENCE (RR,T,TR),(FRR,R)
	DATA STAR/'*'/
C
C	CALCULATION OF PRE-MEAN
C
	AVE=0
	DO 10 I=1,N
10	AVE=AVE+X(I)
	AVE=AVE/N
C
C	ESTIMATE COVARIANCE FUNCTION OF PRE
C
	DO 20 I=1,N
	R(I)=0
	L=I-1
	DO 19 J=1,N-L
19	R(I)=R(I)+(X(J+L)-AVE)*(X(J)-AVE)
20	RR(I)=R(I)/R(1)
C
C	ESTIMATE PARAMETERS
C
	R1=R(1)
	A=R(2)/R(1)
	V=R(1)-A*R(2)
	N2=N-2
	SD=SQRT(V/N2)
	NEND=82
	IF (N.LT.5) NEND=N*11+27
	WRITE(IOUT,50) AVE,A,SD,(STAR,I=1,NEND)
50	FORMAT('-MEAN OF PRE DATA =',F12.4/
     1 ' ESTIMATED AUTOREGRESSION COEFFICIENTS =',F12.4/
     2 ' ESTIMATED ONE STEP PREDICTION STANDARD DEVIATION =',F12.4//
     3 '-',13A1/' * L  A  G   *'/
     4 ' * FROM- TO  *',9X,'S E R I A L',5X,'CORRELATIONS'/
     5 ' ',69A1)
	IEND=1
51	IST=IEND+1
	IEND=IST+4
	IF (IEND.GT.N) IEND=N
	IST1=IST-1
	IEND1=IEND-1
	WRITE(IOUT,52) IST1,IEND1,(RR(I),I=IST,IEND)
52	FORMAT(' *',I4,' -',I4,' *',5F11.4)
	IF (IEND.NE.N) GO TO 51
	WRITE(IOUT,53)
53	FORMAT(' *',11X,'*')
	IF (IMAC.NE.'YES') GO TO 40
C
C	CALCULATE PARTIAL CORRELATION FUNCTION T-TEST
C
	M(1)=N/3
	M(2)=N/2
	M(3)=2*N/3
	DO 100 I=3,M(3)
	FN=N+1-I
	EX(I-2)=(R(I)-A*R(I-1))/V
	EE=EX(I-2)*EX(I-2)
100	TR(I-2)=EX(I-2)*SQRT(FN/(1-EE))
C
C	CALCULATE RESIDUES OF PRE-DATA FIRST ORDER AUTOREGRESSIVE MODEL
C	AND CALCULATE AUTOCORRELATION OF FITTED RESIDUALS AND BOX-PIERCE
C	TEST
C
	E(1)=X(1)-AVE
	AVV=E(1)
	DO 101 I=2,N
	E(I)=(X(I)-AVE)-A*(X(I-1)-AVE)
101	AVV=AVV+E(I)
	AVV=AVV/N
	FR1=0
	DO 102 I=1,N
102	FR1=FR1+(E(I)-AVV)**2
	DO 104 I=2,N
	FR=0
	L=I-1
	DO 103 J=1,N-L
103	FR=FR+(E(J+L)-AVV)*(E(J)-AVV)
104	FRR(I)=FR/FR1
	DO 200 I=1,3
	MD(I)=M(I)-2
200	CH(I)=0
	DO 201 I=2,M(1)+1
201	CH(1)=CH(1)+FRR(I)**2
	CH(1)=N*CH(1)
	DO 202 I=M(1)+2,M(2)+1
202	CH(2)=CH(2)+FRR(I)**2
	CH(2)=N*CH(2)+CH(1)
	DO 203 I=M(2)+2,M(3)+1
203	CH(3)=CH(3)+FRR(I)**2
	CH(3)=N*CH(3)+CH(2)
	DO 210 I=1,3
	CALL CHIPRB(MD(I),CH(I),P(I),IERR)
	IF (IERR.EQ.1) P(I)=9999E-20
210	CONTINUE
C
C	STANDARD ERROR AND CONFIDENCE LIMITS FOR AUTOREGRESSIVE
C	COEFFICIENT
C
	SEE=SQRT((1-A*A)/N)
	CLL=A-2*SEE
	CLU=A+2*SEE
C
C
C
	WRITE(IOUT,300) (STAR,I=1,NEND)
300	FORMAT('-',13A1/' * L  A  G   *'/' * FROM- TO  *',9X,'SERIAL
     1  CORRELATIONS  OF  RESIDUALS'/1X,69A1)
	IEND=1
301	IST=IEND+1
	IEND=IST+4
	IF (IEND.GT.N) IEND=N
	IST1=IST-1
	IEND1=IEND-1
	WRITE(IOUT,52) IST1,IEND1, (FRR(I),I=IST,IEND)
	IF (IEND.NE.N) GO TO 301
	WRITE(IOUT,302)
302	FORMAT(' *',11X,'*'/'-BOX-PIERCE CHI-SQUARE TESTS FOR RESIDUAL
     1 CORRELATION IN THE FITTED MODEL'//2X,'CHI-SQUARE',3X,'DEGREES
     2 OF'/4X,'VALUES',6X,'FREEDOM',5X,'PROBABILITY'/2X,10('-'),
     3 3X,10('-'),3X,11('-')/)
	DO 303 I=1,3
303	WRITE(IOUT,304) CH(I),MD(I),P(I)
304	FORMAT(1X,F11.3,I8,9X,F6.4)
	WRITE(IOUT,305) A,SEE,CLL,CLU,N2
305	FORMAT('-ESTIMATED AUTOREGRESSION COEFFICIENT =',F12.3/
     1 ' STANDARD ERROR OF AUTOREGRESSION COEFFICIENT =',F12.3/
     2 '-95% CONFIDENCE LIMITS FOR THE AUTOREGRESSION COEFFICIENT'/
     3 ' LOWER LIMIT =',F12.3,8X,'UPPER LIMIT =',F12.3/
     4 '-T-TESTS FOR PARTIAL SERIAL CORRELATION COEFFICIENT'/
     5' (EACH T-TEST IS BASED ON ',I7,' DEGREES OF FREEDOM)'/
     6 '-',5X,'* PARTIAL SERIAL'/2X,'LAG *',3X,'CORR COEFF',8X,'T VALUE'
     7 /1X,35('*'))
	DO 306 I=2,M(3)
306	WRITE(IOUT,307) I,EX(I-1),TR(I-1)
307	FORMAT(1X,I4,' *',2F13.4)
	WRITE(IOUT,308)
308	FORMAT(6X,'*'/'-NOTE:  IF THE BOX-PIERCE CHI-SQUARE TEST(S) ARE
     1 SIGNIFICANT (LARGE)'/8X,'THEN THE FIRST ORDER AUTOREGRESSIVE
     2 MODEL DOES NOT FIT THE'/8X,'PRE-TEST DATA AND SOME OTHER MODEL
     3 SHOULD BE USED.'//8X,'IF THE 95% CONFIDENCE INTERVAL FOR THE
     4 AUTOREGRESSIVE'/8X,'COEFFICIENT CONTAINS ONE, THEN THIS IS
     5 EVIDENCE THAT THE'/8X,'PRE-TEST DATA IS NON-STATIONARY.  THE
     6 NEW SPECIFIED MODEL'/8X,'SHOULD BE BASED ON AT LEAST FIRST
     7 DIFFERENCES OF THE PRE-TEST'/8X,'DATA.'//8X,'IF SOME OF T-TESTS
     8 FOR PARTIAL SERIAL CORRELATIONS ARE'/8X,'SIGNIFICANTLY
     9 DIFFERENT FROM ZERO, THEN THIS IS EVIDENCE THAT'/8X,'THE NEW
     1 MODEL BE BASED ON EITHER MORE AUTOREGRESSIVE PARAMETERS'/8X,
     2 'OR A MOVING AVERAGE STRUCTURE.'/)
C
40	F=0
	DO 41 J=1,MA
	K=MA+1-J
	POST(K)=AVE+A*(X(N+K-1)-AVE)
	T(K)=(X(N+K)-POST(K))/SD
41	F=F+T(K)**2
	F=F/MA
	MEND=82
	IF (MA.LT.5) MEND=MA*11+27
	WRITE(IOUT,60) (STAR,I=1,MEND)
60	FORMAT(//'-',13A1/
     1 ' *OBSERVATION*'/
     2 ' * FROM- TO  *',9X,'PREDICTED  POST  DATA'/
     3 ' ',69A1)
	IEND=0
61	IST=IEND+1
	IEND=IST+4
	IF (IEND.GT.MA) IEND=MA
	WRITE(IOUT,52) IST,IEND,(POST(I),I=IST,IEND)
	IF (IEND.NE.MA) GO TO 61
	WRITE(IOUT,53)
	N2=N-2
	PROB=FISHER(MA,N2,F)
	WRITE(IOUT,70) F,MA,N2,PROB,N2,(STAR,I=1,MEND)
70	FORMAT(//'-F TEST ON ENTIRE POST INTERVAL HAS F-VALUE =',F12.4/
     1 ' WITH ',I6,' AND',I6,' DEGREES OF FREEDOM'/
     2 ' PROBABILITY VALUE =',F10.5/
     3 '-NOTE:  A SIGNIFICANT F-VALUE IS EVIDENCE THAT A CHANGE
     4 IN MEAN'/8X,'RESPONSE HAS OCCURRED BETWEEN PRE AND POST
     5 CONDITIONS.'/8X,'THE T-VALUES BELOW CAN BE USED TO IDENTIFY
     6 SPECIFIC SIGNIFICANT'/8X,'DEVIANT POST OBSERVATIONS'///
     7 '-T TESTS ON POSTDIFFERENCES'/
     8 ' (EACH T-VALUE HAS',I6,' DEGREES OF FREEDOM)'/
     9 '-',13A1/' *POST OBSER.*'/
     1 ' * FROM- TO  *',9X,'T',5X,'V A L U E S'/1X,69A1)
	IEND=0
71	IST=IEND+1
	IEND=IST+4
	IF (IEND.GT.MA) IEND=MA
	WRITE(IOUT,52) IST,IEND, (T(I),I=IST,IEND)
	IF (IEND.NE.MA) GO TO 71
	WRITE(IOUT,53)
	RETURN
	END
C
C---------------BOTH ARGS. ARE INPUT.  N, MA, X, POST ARE INPUT
C--------------- THRU COMMON /BLOCK1/.
C	SUBROUTINE PLOT(NOUT,ID)
C
C	THIS SUBROUTINE PLOTS THE PRE, POST AND PREDICTED POST DATA.
C
C	ALL ARGUMENTS ARE PASSED FROM THE MAIN PROGRAM:
C
C	NOUT--OUTPUT DEVICE
C	ID----PROBLEM IDENTICATION VECTOR OR HEADER VECTOR
C
	SUBROUTINE PLOT(NOUT,ID)
	DIMENSION X(4000),POST(1),ID(1),CUTPT(11),ROW(0/100)
	COMMON/BLOCK1/N,MA,X,POST
	DATA DOT,CROSS,CIRCLE,STAR/'.','X','O','*'/
C
C***********************************************************************
C	DETERMINE THE MAXIMUM AND MINIMUM OF THE DATA POINTS
C*************************************************************************
C
	NMA=N+MA
	XMIN=X(1)
	XMAX=X(1)
	DO 10 I=2,NMA
	IF (X(I).LT.XMIN) XMIN=X(I)
	IF (X(I).GT.XMAX) XMAX=X(I)
10	CONTINUE
	DO 11 I=1,MA
	IF (POST(I).LT.XMIN) XMIN=POST(I)
	IF (POST(I).GT.XMAX) XMAX=POST(I)
11	CONTINUE
	DELTA=(XMAX-XMIN)/100.
C
C***********************************************************************
C	WRITE OUT HEADING FOR THE GRAPH
C***********************************************************************
C
	DO 20 I=1,11
20	CUTPT(I)=XMIN+DELTA*(I-1)*10
	WRITE(NOUT,21) (ID(I),I=1,16),DELTA,(CUTPT(I),I=1,11,2),
     1 (CUTPT(I),I=2,11,2)
21	FORMAT('1TIME SERIES GRAPH ON PRE, POST AND PREDICTED POST
     1 DATA'//1X,16A5/'-GRAPH INTERVAL =',G12.4/' NOTE:  . = PRE
     2 DATA'/8X,'X = POST DATA'/8X,'O = PREDICTED POST DATA'/
     3 8X,'* = INTERSECTION OF POST AND PREDICTED POST DATA'/
     4 '-',6(G10.4,10X)/7X,6('^',19X)/7X,5('^',3X,G10.4,6X),'^  ',
     5 'PRE & POST   PREDICTED'/7X,10('^',9X),'^   D A T A',5X,
     6 'POST DATA'/7X,10('+---------'),'+')
C
C***********************************************************************
C	CALCULATE THE INDICES AND PRINT OUT ONE ROW AT A TIME
C***********************************************************************
C
	ROUND=DELTA/2
	DO 30 I=1,N
	Y=X(I)
	DO 31 J=0,100
31	ROW(J)=' '
	I1=(Y-XMIN)/DELTA+ROUND
	ROW(I1)=DOT
30	WRITE(NOUT,32) I,ROW,Y
32	FORMAT(1X,I4,2X,101A1,2X,G10.4,2X,G10.4)
	DO 40 I=N+1,NMA
	Y=X(I)
	Z=POST(I-N)
	DO 41 J=0,100
41	ROW(J)=' '
	I1=(Y-XMIN)/DELTA+ROUND
	I2=(Z-XMIN)/DELTA+ROUND
	ROW(I1)=CROSS
	ROW(I2)=CIRCLE
	IF (I1.EQ.I2) ROW(I1)=STAR
	I1=I-N
40	WRITE(NOUT,32) I1,ROW,Y,Z
	RETURN
	END
C	THIS SUBROUTINE AND SUBROUTINE CUNO ARE TAKEN FROM STP.
C
C
C                                    *** STAT PACK ***
C     SUBROUTINE USED FOR DETERMINING CHI SQUARE PROBABILITIES
C     CALLING SEQUENCE: CALL CHIPRB(K,X,Y,IERR)
C     WHERE K - NUMBER OF DEGREES OF FREEDOM
C           X - CHI SQUARE VALUE
C           Y - PROBABILITY ASSOCIATED WITH CHI SQUARE
C           IERR - ERROR WAS ENCOUNTERED WHEN ATTEMPTING TO CALCULATE
C                  PROBABILITY
C
C     ROUTINE WAS WRITTEN BY CHARLES NAGY OF WESTERN, AND ADAPTED
C     TO STP BECAUSE THE FISHER ROUTINE WOULD NOT GIVE ENOUGH 
C     ACCURACY FOR THE PSYCHOLOGISTS.  CALLS SUBROUTINE CUNO.
C
C---------------K, X ARE INPUT. Y, IERR ARE OUTPUT.
      SUBROUTINE CHIPRB(K,X,Y,IERR)
      DIMENSION F(25)
      F(1)=.5
      F(2)=.598706326
      F(3)=.691462461
      F(4)=.773372648
      F(5)=.841344746
      F(6)=.894350226
      F(7)=.933192799
      F(8)=.959940843
      F(9)=.977249868
      F(10)=.987775527
      F(11)=.993790335
      F(12)=.997020237
      F(13)=.998650102
      F(14)=.999422975
      F(15)=.999767371
      F(16)=.999911583
      F(17)=.999968329
      F(18)=.999989311
      F(19)=.999996602
      F(20)=.999998983
      F(21)=.999999713
      F(22)=.999999924
      F(23)=.999999981
      F(24)=.999999996
      F(25)=.999999999
      IERR=0
      Y=0
      IF((K.LE.0).OR.(K.GT.100)) IERR=1
      IF(X.GT.141) IERR=1
      IF(IERR.EQ.1) RETURN
      IF(X.LE.0) GO TO 13
      IF(K.GE.4) GO TO 4
      GO TO (1,2,3),K
1     P=SQRT(X)
      CALL CUNO(P,S,IERR,F)
      IF(IERR.EQ.1) RETURN
      Y=2.*S-1
      GO TO 13
2      Y=1.-(1./EXP(X/2.))
      GO TO 13
3     P=SQRT(X)
      CALL CUNO(P,S,IERR,F)
      IF(IERR.EQ.1) RETURN
      Y=(2.*S-1)-P/(1.25331414*EXP(X/2.))
      GO TO 13
4     M=K/2
      IF(K.EQ.2*M) GO TO 6
      P=SQRT(X)
      CALL CUNO(P,S,IERR,F)
      IF(IERR.EQ.1) RETURN
      Y=2.*S-1.
      S=X/2.
      C=1./(.62665707*P*EXP(S))
      P=S
      T=.5
      GO TO 7
6     C=1./EXP(X/2.)
      Y=1.-C
      S=0
      P=1
      T=0
7     DO 8 I=1,M-1
      T=T+1
      P=P*(X/(T*2.))
8     S=S+P
      Y=Y-C*S
13    Y=1.-Y
      END
C                                      *** STAT PACK ***
C     SUBROUTINE USED IN FINDING PROB FOR CHI SQUARE
C     CALLING SEQUENCE: CALL CUNO(X,Y,IERR,F)
C     ORIGINALLY WRITTEN BY CHARLES NAGY OF WMU.
C
C---------------X, F ARE INPUT.  Y, IERR ARE RETURNED.
      SUBROUTINE CUNO(X,Y,IERR,F)
      DIMENSION F(1)
      W=X
      IF(W.LT.0) W=-W
      IF(W.LE.6.125) GO TO 2
1      Z=1
      GO TO 7
2     K=INT(4.*W)+1
      A=.25*(K-1.)
      IF(W-A) 10,3,4
3     Z=F(K)
      GO TO 7
4     IF(W-(A+.125))6,6,5
5     K=K+1
      A=A+.25
6     H=W-A
      ASQ=A*A
      C1=((-ASQ+10.)*ASQ-15.)*A
      C2=(6.*ASQ-36.)*ASQ+18.
      C3=(-30.*ASQ+90.)*A
      C4=120.*(ASQ-1.)
      C5=-360.*A
      C6=(((((C1*H+C2)*H+C3)*H+C4)*H+C5)*H+720.)*H
      Z=F(K)+C6/(720.*SQRT(6.28318531*EXP(ASQ)))
7     Y=Z
      IF(X.LT.0.) Y=1.-Z
      RETURN
10    IERR=1
      RETURN
      END
C****** WMU AM: 1.13.1, #1, MTO, 25-JAN-78
C------ FISHER ROUTINE REMOVED ------
C****** END 
C---------------IORO IS INPUT.  IDLG, NDEVI, NDEVO, IDVI, IDVO, IPLT,
C--------------- ITYCH ARE INPUT THRU COMMON /IOBLK/.  NDEVI, IDVI, 
C--------------- IDVO ARE MODIFIED.  NAMI IS RETURNED THRU COMMON /IOBLK/.
C---------------NAMO, IPJ, IPG, NCOPYS ARE RETURNED THRU COMMON 
C--------------- /IOBLKA/.
      SUBROUTINE IOTS(IORO)
      DIMENSION IN(50),INAME(2),B(10),NAM(2)
	COMMON/IOBLK/IDLG,IRSP,NDEVI,NDEVO,IDVI,IDVO,ICODE,IPLT,NAMI(2),
     1 ITYCH
	COMMON/IOBLKA/NAMO(2),IPJ,IPG,NCOPYS
	DOUBLE PRECISION JNAME
	EQUIVALENCE (JNAME,INAME)
	L1="555004020100
	L2="565004020100
	IF(JONCE.EQ.0)ITMP=NDEVI
	NDEVI=ITMP
	IF ((IORO.AND.1).EQ.0)IDV=IDVI
	IF ((IORO.AND.1).EQ.1)IDV=IDVO
1	GO TO(401,403,402,404),IORO+1
401	WRITE(IDLG,310)
310    FORMAT(' INPUT? (TYPE HELP IF NEEDED)--',$)
402	IDEV=NDEVI
	GO TO 405
403	WRITE(IDLG,311)
311   FORMAT(' OUTPUT? (TYPE HELP IF NEEDED)--',$)
404	IDEV=NDEVO
405      READ(IRSP,10,END=201)IN
10    FORMAT(50A1)
	IF ((IN(1).EQ.'F').AND.(IN(2).EQ.'I').AND.(IN(3).EQ.'N').AND.
     1(IN(4).EQ.'I')) GO TO 201
	IF ((IN(1).EQ.'S').AND.(IN(2).EQ.'A').AND.(IN(3).EQ.'M').AND.
     1(IN(4).EQ.'E').AND.(IN(5).EQ.' ')) GO TO 212
	IF ((IN(1).EQ.'H').AND.(IN(2).EQ.'E').AND.(IN(3).EQ.'L').AND.
     1 (IN(4).EQ.'P')) GO TO (500,600),IORO+1
	ITYFLG=0
      CALL RELEAS(IDEV)
      NEVER=0
      ICOLN=0
      ILBR=0
      ISL=0
      IPROJ=0
      IPROG=0
      INAME(1)=' '
      INAME(2)=' '
      IDV=' '
      K=0
	IDP=0
12    K=K+1
      IF(K.GT.50)GO TO 15
	IF (IN(K).EQ.'.') IDP=1
      IF(IN(K).EQ.':')GO TO 13
      IF(IN(K).EQ."555004020100)GO TO 14
      IF(IN(K).EQ.'/')GO TO 23
      GO TO 12
13    ICOLN=K+4
      DO 20 I=50,K+4,-1
 20   IN(I)=IN(I-4)
      DO 27 I=0,3
27    IN(K+I)=' '
      K=K+4
      GO TO 12
14    ILBR=K+9
      DO 21 I=50,K+9,-1
21    IN(I)=IN(I-9)
      DO 22 I=K,K+8
22    IN(I)=' '
      K=K+9
      GO TO 12
23    ISL=K
      GO TO 12
15    IF(ILBR.EQ.0)GO TO 31
30    ENCODE(12,40,B)(IN(I),I=ILBR+1,ILBR+12)
40    FORMAT(12A1)
      DECODE(12,41,B)IPROJ,IPROG
41    FORMAT(2O)
31	IF (IDP.NE.0) GO TO 32
	DO 33 I=ICOLN+9,ICOLN+1,-2
	IF (IN(I).NE.' ') GO TO 34
33	CONTINUE
	I=6
34	IN(I+1)='.'
32    ENCODE(10,42,INAME)(IN(I),I=ICOLN+1,ICOLN+10)
42    FORMAT(10A1)
	IF ((INAME(1).EQ.'FINIS').OR.(INAME(1).EQ.'FINI')) GO TO 201
      IF(ICOLN.EQ.0)GO TO 101
100   ENCODE(5,44,IDV)(IN(I),I=1,5)
44    FORMAT(5A1)
101   IF(ISL.EQ.0)GO TO 24
      ENCODE(5,44,B)(IN(I),I=ISL+1,ISL+5)
      DECODE(5,46,B)NCOPYS
46    FORMAT(I)
24    IF(IDV.NE.' ')GO TO 124
      IF(INAME(1).EQ.' ')GO TO 28
      IDV='DSK'
      GO TO 124
28    IF(ICODE.EQ.-1)GO TO 125
      IDV='TTY'
      GO TO 124
125   IF((IORO.AND.1).EQ.0)IDV='CDR'
      IF((IORO.AND.1).EQ.1)IDV='LPT'
124   CALL DEVCHG(IDV,IDEV)
      IF(IDV.EQ.'DSK')GO TO 102
      IF(IDV.EQ.'LPT')GO TO 104
      IF(IDV.LE."422510134500.AND.IDV.GE."422510130100)GO TO 102
213	IF(IDV.EQ.'TTY'.AND.(IORO.AND.1).EQ.0)GO TO 214
      GO TO 410
104   INAME(1)='OUTAA'
      INAME(2)='A.AAA'
      IPR=1
      LPT=IDEV
      CALL DEVCHG('DSK',IDEV)
105   CALL EXISTS(IDEV,INAME,MRK)
      IF(MRK.EQ.1)GO TO 211
      INAME(2)=INAME(2)+2
      GO TO 105
211	NAM(1)=INAME(1)
	NAM(2)=INAME(2)
102      IF(INAME(1).NE.' ')GO TO 302
      IF((IORO.AND.1).EQ.0)INAME(1)='INPUT'
      IF((IORO.AND.1).EQ.1)INAME(1)='OUTPT'
      INAME(2)='.DAT'
302   IF((IORO.AND.1).EQ.1)GO TO 303
      CALL EXISTS(IDEV,INAME,MRK,IPROJ,IPROG)
      IF(MRK.EQ.0)GO TO 303
      WRITE(IDLG,305)
305   FORMAT(' FILE DOES NOT EXIST'/)
	IF(ICODE.EQ.-1)CALL EXIT
      GO TO 1
303	CALL DEFINE FILE(IDEV,0,NEVER,JNAME,IPROJ,IPROG)
	GO TO 213
201	IF (IPR.EQ.0) GO TO 2010
	CALL RELEAS(LPT)
	CALL PRINTS(NAM,2,1,NCOPYS)
	CALL EXIT
2010	IF (IPLT.NE.1) CALL EXIT
	ENDFILE 1
	CALL PRINTS(NAMO,2,1,1)
	CALL EXIT
212	IF(ITYFLG.EQ.1)GO TO 215
	IF ((IORO.AND.1).EQ.O)REWIND IDEV
	GO TO 410
C	NO TTY: SAME OPTION IF NO CHANNEL PROVIDED IN ITYCH
214	IF(ITYCH.LT.1)GO TO 410
	IF(IONCE.NE.1)CALL DEVCHG('DSK',ITYCH)
	IONCE=1
	IF(ITYFLG.EQ.1)GO TO 215
	ITYFLG=1
	CALL RELEAS(ITYCH)
	CALL DEFINE FILE(ITYCH,0,NV,'TTYDAT.TMP',0,0)
410	IOROA=IORO.AND.1
	IF(IOROA.EQ.1)GO TO 411
	IPJ=IPROJ
	IPG=IPROG
	IDVI=IDV
	NDEVI=IDEV
	NAMI(1)=INAME(1)
	NAMI(2)=INAME(2)
	GO TO 412
411	NAMO(1)=INAME(1)
	NAMO(2)=INAME(2)
	IDVO=IDV
412	CONTINUE
	JONCE=1
	RETURN
215	REWIND ITYCH
	IDEV=ITYCH
	GO TO 410
500	WRITE(IDLG,501)
501	FORMAT('-THIS ANSWER DEFINES WHERE THE PROGRAM IS TO FIND THE
     1 INPUT DATA.  IT'/' USUALLY CONSISTS OF A DEVICE, POSSIBLY A
     2 FILENAME WITH OR WITHOUT AN'/' EXTENSION, AND A PROJECT-
     3PROGRAMMER NUMBER.'//' POSSIBLE DEVICES ARE:'//6X,'DEVICES',3X,
     4 'DESCRIPTION'/6X,7('-'),3X,11('-')/6X,'TTY:',6X,'TERMINAL'/
     5 6X,'DSK:',6X,'DISK (FILENAME AND EXTENSION, PROJECT-PROGRAMMER
     6 NUMBER'/22X,'MAY BE USED)'/6X,'CDR:',6X,'CARD READER  (THIS
     7 DEVICE IS NOT APPLICABLE ON TERMINAL'/30X,'JOBS)'/6X,'DTA#:',5X,
     8 'DECTAPE UNIT (USER''S DECTAPE SHOULD ALREADY BE MOUNTED)'/6X,
     9 'MTA#:',5X,'MAGTAPE UNIT (USER''S MAGTAPE SHOULD ALREADY BE
     1 MOUNTED'/30X,'AND POSITIONED)'///' DEFAULTS:'//' (1)  IF NO INPUT
     2 DEVICE IS SPECIFIED BUT A FILENAME IS GIVEN, THE'/6X,'DEFAULT
     3 DEVICE WILL BE DSK:'//' (2)  IF A DEVICE WHICH REQUIRES A
     4 FILENAME AND EXTENSION IS SPECIFIED,'/6X,'BUT NO FILENAME IS
     5 GIVEN, THE DEFAULT NAME WILL BE INPUT.DAT'//' (3)  IF NO RESPONSE
     6 IS GIVEN, I.E. A CARRIAGE RETURN <CR> IS ENTERED,'/6X,'THE
     7 DEFAULT DEVICE IS TTY: ON JOBS RUN FROM TERMINALS; AND'/28X,'CDR:
     8 ON BATCH JOBS'//' (4)  IF DSK: IS SPECIFIED AS THE INPUT DEVICE
     9 AND NO PROJECT-PROGRAMMER'/6X,'NUMBER IS GIVEN, THE USER''S
     1 PROJECT-PROGRAMMER NUMBER WILL BE'/6X,'ASSUMED.'///)
	WRITE(IDLG,502) L1,L2
502	FORMAT(' EXAMPLES:    DATA.DAT'/14X,'TEST.DAT',A1,'420,420',A1/
     2 14X,'MTA0:'/14X,'DTA2:FILE1'//' NOTE:  THE FOLLOWING RESPONSES
     3 ARE VALID AFTER THE FIRST "INPUT?"'//' (1)  SAME COMMAND.  IF THE
     4 DATA FILE TO BE USED IS THE SAME AS THE'/6X,'PRECEEDING ONE, THE
     5 USER MAY SIMPLY ENTER "SAME"'//' (2)  FINISH COMMAND.  THE USER
     6 MUST ENTER "FINISH" TO EXIT FROM THE'/6X, 'PROGRAM.  THIS ENSURES
     7 THAT OUTPUT ASSIGNED TO LPT: WILL BE'/6X,'PRINTED.  FAILURE TO
     8 USE THE "FINISH" COMMAND MAY RESULT IN'/6X,'LOSING THE ENTIRE
     9 OUTPUT FILE.'//' (3)  A ^Z (CONTROL Z) WILL RESULT IN THE SAME
     1 ACTION AS THE "FINISH"'/6X,'COMMAND.'///)
503	CALL RELEAS(IDLG)
	GO TO (401,403), IORO+1
600	WRITE(IDLG,601)
601	FORMAT('-THE ANSWER DEFINES WHERE THE OUTPUT FROM THE PROGRAM
     1 IS TO BE PLACED.'/' IT USUALLY CONSISTS OF A DEVICE AND POSSIBLY
     2 A FILENAME WITH OR WITH-'/' OUT AN EXTENSION.'//' POSSIBLE
     3 DEVICES ARE:'//6X,'DEVICE',3X,'DESCRIPTION'/6X,6('-'),3X,
     4 11('-')/6X,'TTY:',5X,'TERMINAL'/6X,'DSK:',5X,'DISK (FILENAME
     5 AND EXTENSION MAY BE USED)'/6X,'LPT:',5X,'LINEPRINTER  (MULTIPLE
     6 COPIES MAY BE REQUESTED BY USE OF'/29X,'THE "/COPIES" COMMAND)'/
     7 6X,'DTA#:',4X,'DECTAPE UNIT (USER''S DECTAPE SHOULD ALREADY
     8 BE MOUNTED;'/29X,'FILENAME AND EXTENSION MAY BE USED.)'/
     9 6X,'MTA#:',4X,'MAGTAPE UNIT (USER''S MAGTAPE SHOULD ALREADY
     1 BE MOUNTED'/29X,'AND POSITIONED)'///' DEFAULTS:'//' (1)  IF NO
     2 OUTPUT DEVICE IS SPECIFIED BUT A FILENAME IS GIVEN, THE'/6X,
     3 'DEFAULT DEVICE WILL BE DSK:'//' (2)  IF A DEVICE WHICH REQUIRES
     4 A FILENAME AND EXTENSION IS SPECIFIED,'/6X,'BUT NO FILENAME IS
     5 GIVEN, THE DEFAULT NAME WILL BE OUTPT.DAT'//' (3)  IF NO RESPONSE
     6 IS GIVEN, I.E. A CARRIAGE RETURN <CR> IS ENTERED,'/6X,'THE
     7 DEFAULT DEVICE IS TTY: ON JOBS RUN FROM TERMINALS; AND'/28X,'LPT:
     8 ON BATCH JOBS'//' (4)  IF LPT: IS LISTED AS THE OUTPUT DEVICE,
     9 THE NUMBER OF COPIES WILL'/6X,'DEFAULT TO 1.'///
     1' EXAMPLES:    LPT:/2'/14X,'RPT.DAT'/14X,'DTA0:NAME.DAT'///)
	GO TO 503
	END
	SUBROUTINE GETFR2(ISEL,NCHAR,IFMT)
	DIMENSION IFMT(1),ITYPE(0/2),NAM(2),IN(80)
C****** WMU AM: 1.13.1-1, MTO, 2-FEB-78
	COMMON /IOBLK/ IDLG
C****** END = GETFR2, STMT #99-5
	COMMON /SGETFR/ISTD,LTYPE
	DOUBLE PRECISION NAME
	EQUIVALENCE (NAME,NAM)
	DATA ITYPE/'F','A','I'/
C
C
99	IBEG=1
	ISTD=0
	NPT=0
	IPAREN=0
	IF(NCHAR.EQ.0) PAUSE 'SYSTEM ERROR CONTACT COMPUTER CENTER'
C
C	WRITE HEADER
C
	IF((LTYPE.EQ.3).OR.(ISEL.EQ.1)) WRITE(IDLG,100)
100	FORMAT(' ENTER FORMAT ENCLOSED IN PARENTHESES'/)
	IF((LTYPE.LT.3).AND.(ISEL.EQ.0)) WRITE(IDLG,101) ITYPE(LTYPE)
101	FORMAT(' ENTER FORMAT ENCLOSED IN PARENTHESES: (',A1,
     .	'-TYPE ONLY)'/)
98	IF(NPT.LT.2) CALL GES(IN,80,IERR)
	IF(NPT.EQ.2) READ(29,102) IN
C
C	FIND # OF CHARACTERS
C
	DO 10 I=80,1,-1
	IF(IN(I).NE.' ') GOTO 20
10	CONTINUE
	ISTD=1
	RETURN
C
C	STANDARD FORMAT REQUESTED; RETURN
C
20	LAST=I
C
C	GET RID OF EXTRA SPACES
C
	I=0
25	I=I+1
	IF(I.GT.LAST) GOTO 30
	IF(IN(I).NE.' ') GOTO 25
	DO 15 J=I,LAST
15	IN(J)=IN(J+1)
	LAST=LAST-1
	GOTO 25
C
C
30	IF(NPT.NE.0) GOTO 300
	IF(IN(1).EQ.'H'.AND.IN(2).EQ.'E'.AND.IN(3).EQ.'L'.AND.IN(4)
     .	.EQ.'P') GOTO 999
	IF(IN(1).EQ.'S'.AND.IN(2).EQ.'A'.AND.IN(3).EQ.'M'.AND.IN(4).EQ.
     .	'E') RETURN
	IF((IN(1).NE.'(').AND.(IN(1).NE."401004020100)) GOTO 9999
	NPT=1
	DO 35 I=1,NCHAR
35	IFMT(I)=' '
	IF(IN(1).EQ.'(') GOTO 300
C
C	COMMAND FILE
C
	NPT=2
	DO 40 I=2,LAST
	IF(IN(I).EQ.'.') GOTO 45
40	CONTINUE
	LAST=LAST+1
	IN(LAST)='.'
45	J=LAST-1
	ENCODE(J,102,NAM(1)) (IN(I),I=2,LAST)
102	FORMAT(80A1)
	CLOSE(UNIT=29)
	OPEN(UNIT=29,DEVICE='DSK',FILE=NAME,ACCESS='SEQIN')
	GOTO 98
C
C	READ FORMAT
C
300	DO 50 I=1,LAST
	IF(IN(I).EQ.'(') IPAREN=IPAREN+1
	IF(IN(I).EQ.')') IPAREN=IPAREN-1
50	CONTINUE
	IF(IBEG+((LAST+4)/5).GT.NCHAR) GOTO 9999
	ENCODE (LAST,102,IFMT(IBEG)) (IN(I),I=1,LAST)
	IBEG=IBEG+(LAST+4)/5
	IF(IPAREN.LT.1) GOTO (200,201),NPT
	GOTO 98
C
C	RETURN
C
201	CLOSE (UNIT=29)
200	RETURN
C
C	ERROR AND HELP
C
9999	WRITE(IDLG,103)
103	FORMAT('-ERROR:  Format incorrectly specified'/)
	GOTO 99
999	I=NCHAR*5
	WRITE(IDLG,104) I
104	FORMAT(' Any FORMAT specification must comply with the FORTRAN-1
     .0 Format'/' requirement. The FORMAT must also be enclosed 
     .in parentheses'/' and be no more than ',I3,' characters in length'
     .	//' Example:  ENTER FORMAT ENCLOSED IN PARENTHESES'
     .	/11X,'(I2,F3.0,1X,F2.0,I1)'/)
	GOTO 99
	END