Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-10 - 43,50521/aplib.f4
There are 2 other files named aplib.f4 in the archive. Click here to see a list.
C     THIS IS A SUBROUTINE TO ACCEPT A STRING OF CHARACTERS
C         WHICH SPECIFY INPUT AND OUTPUT DEVICES
C
C           ARGUMENTS ARE:
C             IDEV - FORTRAN DEVICE NUMBER
C             IDV  - MNEMONIC FOR THE DEVICE TO BE ASSOCIATED WITH
C                    THE FORTRAN DEVICE NUMBER
C             NOUTD- DIALOGUE OUTPUT DEVICE NUMBER
C             INP  - DIALOGUE INPUT DEVICE NUMBER
C             IORO - 0 OR 2=INPUT
C                    1 OR 3=OUTPUT
C			(2 AND 3 SUPPRESS QUESTION)
C             ICODE- 0= TTY JOB
C                   -1= PSEUDO-TELETYPE JOB
C
C                ROUTINES CALLED BY IO ARE:
C                      PRINTS    - FORTRAN LIBRARY
C                      DEVCHG    - FORTRAN LIBRARY
C                      EXISTS    - NGLIB
C                      TTYPTY    - NGLIB
C
C	MODIFIED FOR F10/FOROTS 26 SEP 74 RRB.
C
C	UPDATED TO FOROTS COMPATABLE - 11 DEC 1974 BY RUSS BARR
C	DATE:  5 FEB 75 - PATCH TO PRINT 'LPT' FILE EVERY TIME
C	'OUTPUT? IS CALLED.
C	'EOF' OR '^Z' TRAP - 1 APR 75 - RRB.
C	SEVEN CHARACTER CHECKS FOR 'SAME' & 'FINISH' -  12 DEC 76   MSL.
C
      SUBROUTINE IO(IDEV,IDV,NOUTD,INP,IORO,ICODE)
      DIMENSION IN(50),INAME(2),B(10),NAM(2)
	DOUBLE PRECISION JNAME
	EQUIVALENCE(INAME,JNAME)
	DATA L1,L2/"555004020100,"565004020100/
1     IF(IORO.EQ.0)WRITE(NOUTD,310)
310    FORMAT(' INPUT? (TYPE HELP IF NEEDED)--',$)
300	IF(IORO.EQ.1)WRITE(NOUTD,311)
311   FORMAT(' OUTPUT? (TYPE HELP IF NEEDED)--',$)
      READ(INP,10,ERR=201,END=201)IN
10    FORMAT(50A1)
      IF(IN(1).EQ.'F'.AND.IN(2).EQ.'I'.AND.IN(3).EQ.'N'.AND.IN(4).EQ.
     1'I'.AND.IN(5).EQ.'S'.AND.IN(6).EQ.'H'.AND.IN(7).EQ.' ')GO TO 201
      IF(IN(1).EQ.'S'.AND.IN(2).EQ.'A'.AND.IN(3).EQ.'M'.AND.IN(4).EQ.
     1'E'.AND.IN(5).EQ.' '.AND.IN(6).EQ.' '.AND.IN(7).EQ.' ')GO TO 212
	IF(IN(1).EQ.'H'.AND.IN(2).EQ.'E'.AND.IN(3).EQ.'L'.AND.
     1IN(4).EQ.'P'.AND.IN(5).EQ.' '.AND.IN(6).EQ.' '.AND.
     1IN(7).EQ.' ')GO TO (500,600),IORO+1
      CALL RELEAS(IDEV)
	IF((IPR.NE.1).OR.((IORO.AND.1).NE.1))GO TO 491
	CALL PRINTS(NAM,2,1,NCOPYS)
	IPR=0
491      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,10,B)(IN(I),I=ILBR+1,ILBR+12)
      DECODE(12,41,B)IPROJ,IPROG
41    FORMAT(2O)
31	IF(IDP.NE.0)GO TO 32
	DO 33 I=ICOLN+9,ICOLN+1,-1
33	IF(IN(I).NE.' ')GO TO 34
	I=6
34	IN(I+1)='.'
32    ENCODE(10,10,INAME)(IN(I),I=ICOLN+1,ICOLN+10)
      IF(ICOLN.EQ.0)GO TO 101
100   ENCODE(5,10,IDV)(IN(I),I=1,5)
101   IF(ISL.EQ.0)GO TO 24
      ENCODE(5,10,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)
D     TYPE 9998,IDV,IDEV
D9998 FORMAT(1X,A5,I6)
      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
      RETURN
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(NOUTD,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)
D       TYPE 9999,IDEV,INAME,IPROJ,IPROG
D9999   FORMAT(I3,2X,2A5,O12,2X,O12)
      RETURN
201   IF(IPR.EQ.1)CALL RELEAS(LPT)
      IF(IPR.EQ.1)CALL PRINTS(NAM,2,1,NCOPYS)
      CALL EXIT
212   REWIND IDEV
      RETURN
500	WRITE(NOUTD,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(NOUTD,502) L1,L2
502	FORMAT(' EXAMPLES:    DATA.DAT'/14X,'TEST.DAT',A1,'420,420',A1/
     1 14X,'MTA0:'/14X,'DTA2:FILE1'//' NOTE:  THE FOLLOWING RESPONSES
     2 ARE VALID AFTER THE FIRST "INPUT?"'//' (1)  SAME COMMAND.  IF THE
     3 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 (NOUTD)
	GO TO (1,300),IORO+1
600	WRITE(NOUTD,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
C
C	SUBROUTINE IOB(DATA BANK AND TTY:SAME MODIFICATION)
C
C
C	INPUT/OUTPUT DEVICE/FILENAM/PPN HANDLER FOR FORTRAN
C
C
C
C	WRITTEN BY SAM ANEMA - FEB 1972 - WMU COMPUTER CENTER
C
C	MODIFICATIONS BY RUSSELL R. BARR - WMU COMPUTER CENTER
C	DATE: 16 MAY 1973
C	DATE: 25 JUL 1973(^Z ALTERNATIVE TO "FINISH")
C	FIXED ON AUGUST 27, BY R. BARR(AFTER B. HOUCHARD) TO
C	INITIALIZE IBNK.
C	DATE: 31 JAN 1974 - 'CONTINU' OPTION AND 7 LETTER OPTION CHECK.
C	DATE: 11 DEC 1974 - MADE COMPATABLE WITH FOROTS DEFINE FILE
C	DATE:  5 FEB 75 - PATCH TO PRINT 'LPT' FILE EVERY TIME
C	'OUTPUT?' IS CALLED.
C
C	SUBROUTINES USED:	EXISTS IN FOROTS - NORM GRANT
C				PRINTS - SYSTEM
C
C	ARGUMENTS ACCEPTED:
C	IORO	- 0 = INPUT
C		  1 = OUTPUT
C	IDLG	- DIALOG OUTPUT DEVICE NUMBER
C	IRSP	- DIALOG INPUT DEVICE NUMBER
C	NDEVI	- INPUT DEVICE NUMBER
C	NDEVO	- OUTPUT DEVICE NUMBER
C	IDVI	- INPUT DEVICE NAME
C	IDVO	- OUTPUT DEVICE NAME
C	ICODE	- 0 = TTY JOB
C		- 1 = PSEUDO-TTY JOB(BATCH)
C	ITYCH	- ALTERNATE INPUT DEVICE NUMBER
C		  (USED FOR TTY: SAME OPTION. SEE NOTE(1))
C
C	ARGUMENTS RETURNED:
C
C	NDEVI	- (SEE NOTE(1))
C	IBNK	- 0 = EXTENSION IS NOT '.BNK'
C		  1 = EXTENSION IS '.BNK'
C	NAMI(2)	- ASCIZ INPUT FILE NAME
C	NAMO(2)	- ASCIZ OUTPUT FILE NAME
C	IPJ,IPG- [P,PN] FOR INPUT FILE
C	NCOPYS	- NUMBER OF COPIES TO LPT:
C
C	ADD'L OPTIONS:
C
C	'SAME   '	- REWIND DEV. AND RETURN.
C			(SEE NOTE (1) FOR USE WITH TTY:)
C	'CONTINU'	- SAME AS 'SAME' BUT DONT REWIND BEFORE RETURN.
C	'FINISH '	- CLOSE DEV., PRINT IF LPT, EXIT.
C
C
C	NOTE(1):	TO USE THE TTY:SAME OPTION - IN THE MAIN;
C		ASSIGN AN UNUSED FORTRAN DEVICE NUMBER TO ITYCH.
C		INSERT CHANGES FOR READ SIMILAR TO THE FOLLOWING:
C
C	OLD:		READ(NDEVI,IFMT)LIST...
C
C	NEW:		IF(NDEVI.EQ.ITYCH)GO TO 9998
C			READ(NDEVI,IFMT)LIST...
C			WRITE(ITYCH)LIST...
C			GO TO 9999
C		9998	READ(NDEVI)LIST...
C		9999	.........
C
C	NOTE(2):	RESPONSES ARE IN THE FORM;
C
C		DTA1:FILDAT.DAT
C		DATA1.DAT	(DSK: AND USER'S PPN ASSUMED)
C		LPT:/2
C		<CR><LF>	(STANDARD ASSUMPTIONS. SEE NOTE(3))
C
C	NOTE(3):	STANDATD ASSUMPTIONS
C
C	FOR A TTY: JOB
C		TTY: FOR INPUT
C		TTY: FOR OUTPUT
C
C	FOR A PSEUDO-TTY: JOB
C		CDR: FOR INPUT
C		LPT: FOR OUTPUT
C
C		IF NO FILE NAME IS SPECIFIED, USES:
C			INPUT.DAT FOR INPUT
C			OUTPT.DAT FOR OUTPUT
C
      SUBROUTINE IOB(IORO)
      DIMENSION IN(50),INAME(2),B(10),NAM(2)
	DOUBLE PRECISION JNAME
	COMMON/IOBLK/IDLG,IRSP,NDEVI,NDEVO,IDVI,IDVO,ICODE,IBNK,NAMI(2)
	COMMON/IOBLKA/NAMO(2),IPJ,IPG,NCOPYS,ITYCH
	EQUIVALENCE (INAME,JNAME)
	DATA L1,L2/"555004020100,"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'.AND.IN(5).EQ.'S'.AND.IN(6).EQ.'H'.AND.
     1	IN(7).EQ.' ')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.' '.AND.IN(6).EQ.' '.AND.
     1	IN(7).EQ.' ')GO TO 212
	IF(IN(1).EQ.'C'.AND.IN(2).EQ.'O'.AND.IN(3).EQ.'N'.AND.
     1	IN(4).EQ.'T'.AND.IN(5).EQ.'I'.AND.IN(6).EQ.'N'.AND.
     1	IN(7).EQ.'U')RETURN
	IF(IN(1).EQ.'H'.AND.IN(2).EQ.'E'.AND.IN(3).EQ.'L'.AND.
     1IN(4).EQ.'P'.AND.IN(5).EQ.' '.AND.IN(6).EQ.' '.AND.
     1IN(7).EQ.' ')GO TO (500,600),IORO+1
	ITYFLG=0
      CALL RELEAS(IDEV)
	IF((IPR.NE.1).OR.((IORO.AND.1).NE.1))GO TO 491
	CALL PRINTS(NAM,2,1,NCOPYS)
	IPR=0
491	IBNK=0
      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,10,B)(IN(I),I=ILBR+1,ILBR+12)
      DECODE(12,41,B)IPROJ,IPROG
41    FORMAT(2O)
31	IF(IDP.NE.0)GO TO 32
	DO 33 I=ICOLN+9,ICOLN+1,-1
33	IF(IN(I).NE.' ')GO TO 34
	I=6
34	IN(I+1)='.'
32    ENCODE(10,10,INAME)(IN(I),I=ICOLN+1,ICOLN+10)
      IF(ICOLN.EQ.0)GO TO 101
100   ENCODE(5,10,IDV)(IN(I),I=1,5)
101   IF(ISL.EQ.0)GO TO 24
      ENCODE(5,10,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)
D     TYPE 9998,IDV,IDEV
D9998 FORMAT(1X,A5,I6)
      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	IBNK=0
	DECODE(10,10,INAME)(IN(JJ),JJ=1,10)
	DO 1112 IB=10,3,-1
1112	IF(IN(IB).NE.' ')GO TO 1113
1113	IF(IN(IB-2).EQ.'B'.AND.IN(IB-1).EQ.'N'.AND.IN(IB).EQ.'K')
     1	IBNK=1
      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'/)
D	TYPE 9997,IDV,INAME,IPROJ,IPROG
D9997	FORMAT(1X,A5,1X,2A5,O13,O13)
	IF(ICODE.EQ.-1)CALL EXIT
      GO TO 1
303	CONTINUE
D     TYPE 9999,IDEV,INAME,IPROJ,IPROG
D9999 FORMAT(I3,2X,2A5,O12,2X,O12)
	ISZ=0
	IF(IBNK.EQ.1)ISZ=126
      CALL DEFINE FILE(IDEV,ISZ,NEVER,JNAME,IPROJ,IPROG)
	GO TO 213
201   IF(IPR.EQ.1)CALL RELEAS(LPT)
      IF(IPR.EQ.1)CALL PRINTS(NAM,2,1,NCOPYS)
      CALL EXIT
212	IF(ITYFLG.EQ.1)GO TO 215
	IF((IORO.AND.1).EQ.0)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)
	ISZ=0
	IF(IBNK.EQ.1)ISZ=126
	CALL DEFINE FILE(ITYCH,ISZ,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/
     1 14X,'MTA0:'/14X,'DTA2:FILE1'//' NOTE:  THE FOLLOWING RESPONSES
     2 ARE VALID AFTER THE FIRST "INPUT?"'//' (1)  SAME COMMAND.  IF THE
     3 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,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
C  
C          THIS IS A SUBROUTINE WHICH WILL ASK FOR
C          A FORMAT, ENTER THAT FORMAT AND RETURN
C          
C            THE ARGUMENTS ARE:
C
C                   IDLG - DEVICE NUMBER FOR OUTPUTTING DIALOGUE
C                   INP  - DEVICE NUMBER FOR INPUTTING  THE FORMAT
C                   IFMT - ARRAY WHICH WILL CONTAIN THE FORMAT
C                   ISTD - WILL INDICATE WHETHER STANDARD FORMAT IS 
C                          REQUESTED
C                           1 - STANDARD FORMAT IS REQUESTED
C                           0 - FORMAT TO BE USED IS CONTAINED IN IFMT
C                   N    - MAXIMUM SIZE OF THE FORMAT, NORMALLY THIS
C                          WILL BE THE NUMBER OF WORDS DIMENSIONED IN
C                          THE MAINLINE FOR IFMT
C		    ITYPE- INDICATE WHAT TYPE OF FORMAT TO USE
C		           1 - IF I-TYPE IS TO BE USED
C			   2 - IF F-TYPE IS TO BE USED
C	                   3 - IF A-TYPE IS TO BE USED
C			   4 - NEITHER ONE OF THE ABOVE 3
C
      SUBROUTINE GETFOR(IDLG,INP,IFMT,ISTD,N,ITYPE)
      DIMENSION IFMT(1),IN(80),IDUM(3)
      DATA IDUM/'I','F','A'/
      KL=0
12    ISTD=0
      L=0
      NN=80
      KOUNT=0
      IF(N.EQ.0)CALL EXIT
      IF (ITYPE.EQ.4) WRITE(IDLG,2)
2     FORMAT(' FORMAT'/)
      IF (ITYPE.LE.3) WRITE(IDLG,120) IDUM(ITYPE)
120   FORMAT(' FORMAT: (',A1,'-TYPE ONLY)'/)
      READ(INP,3)(IN(I),I=1,80)
3     FORMAT(80A1)
      IF(L.EQ.1)GO TO 13
      IF(IN(1).EQ.'S'.AND.IN(2).EQ.'A'.AND.IN(3).EQ.'M')RETURN
      DO 1 I=1,N
1     IFMT(I)=' '
      L=1
13    IF(N.LT.16)NN=N*5
      DO 4 I=1,NN
      IF(IN(I).NE.' ')GO TO 5
4     CONTINUE
6     ISTD=1
      RETURN
5     IF(IN(I).NE.'(')GO TO 6
      IBEG=1
9     ENCODE(NN,7,IFMT(IBEG))(IN(I),I=1,NN)
7     FORMAT(80A1)
      DO 8 I=1,NN
      IF(IN(I).EQ.'(')KOUNT=KOUNT+1
      IF(IN(I).EQ.')')KOUNT=KOUNT-1
8     CONTINUE
      IF(KOUNT.LT.1)RETURN
      IBEG=IBEG+16
      IF((IBEG+16).GT.N)NN=(N-IBEG+1)*5
      IF(NN.LT.1)GO TO 10
      READ(INP,3)(IN(I),I=1,80)
      GO TO 9
10    IF(KL.EQ.1)CALL EXIT
      WRITE(IDLG,11)
11    FORMAT(' ERROR IN FORMAT, TRY AGAIN.'/)
      KL=1
      GO TO 12
      END
C	FORGEN.F4 - A DIALOGUE FORMAT GENERATOR
C
C	WRITTEN BY RUSSELL R. BARR - WMU COMPUTER CENTER
C	DATE: 20 JUL 73
C
C	THE OBJECT-TIME, SAME AND STANDARD OPTIONS
C	ARE ADAPTED FROM THE SUBROUTINE GETFOR.F4
C	WRITTEN BY SAM ANEMA - FEB 1972 - WMU COMPUTER CENTER
C
C	INPUTS:
C		ISIZE	- LENGTH OF ARRAY IFT
C		MODE*	- ARRAY CONTAINING TYPE OF EACH FIELD IN ASCII
C			  (A,F OR I)
C		MSIZE*	- NUMBER OF FIELDS
C		IDLG	- DIALOGUE OUTPUT
C		IRSP	- DIALOGUE INPUT
C		NDEVI	- NOT USED
C		NDEVO	- NOT USED
C		IDVI	- NOT USED
C		IDVO	- NOT USED
C		ICODE	- 0 = TTY INPUT
C			  1 = PTY INPUT(BATCH)
C		IBNK	- NOT USED
C		NAMI	- NOT USED
C		ITYPE	- INDICATE WHAT TYPE OF FORMAT TO USE
C			   0 - IF ONLY DIALOGUE FORM IS TO BE USED
C		           1 - IF I-TYPE IS TO BE USED
C			   2 - IF F-TYPE IS TO BE USED
C	                   3 - IF A-TYPE IS TO BE USED
C			   4 - NEITHER ONE OF THE ABOVE 3
C
C	* - IF EITHER OR BOTH NOT SPECIFIED, QUESTIONS AT 7751 AND/OR
C	    800 WILL BE ASKED.
C
C	OUTPUTS:
C		IFT	- FORMAT
C		ISTD	- WILL INDICATE WHETHER STANDARD FORMAT IS
C			  REQUESTED
C                           1 - STANDARD FORMAT IS REQUESTED
C                           0 - FORMAT TO BE USED IS CONTAINED IN IFT
C		ISIZE	- LENGTH OF ARRAY IFT
C		MODE	- ARRAY CONTAINING TYPE OF EACH FIELD IN ASCII
C			  (A,F OR I)
C		MSIZE	- NUMBER OF FIELDS
C		JLEN	- CHARACTERS PER FIELD
C		IERR	-  0 NO ERRORS
C			   1 FATAL ERROR
C			  -1 RESPONSE ERROR
C
C	NOTE: ARGUMENTS NOT PASSED IN CALL STATEMENT, ARE PASSED IN
C	      COMMON - IOBLK
C
	SUBROUTINE FORGEN(IFT,ISIZE,MODE,JLEN,MSIZE,ITYPE,ISTD,IERR)
	COMMON/IOBLK/IDLG,IRSP,NDEVI,NDEVO,IDVI,IDVO,ICODE,IBNK,NAMI(2)
	DIMENSION IFT(1),MODE(1),JLEN(1),JFT(20)
	DIMENSION IDUM(3),IN(80),MESS(3,3)
	DATA IDUM/'I','F','A'/
	DATA ((MESS(I,J),J=1,3),I=1,3)/'S','A','M','S','T','D','H',
     1	'E','L'/
	KL=0
	N=ISIZE
C	INITIAL AND QUERY/RESPONSE PATH
700	IERR=0
	KOUNT=0
	ISTD=0
	L=0
	NN=80
	IF(ITYPE.EQ.0)GO TO 775
	IF(ITYPE.EQ.4)WRITE(IDLG,704)
704	FORMAT(' FORMAT')
	IF(ITYPE.LE.3)WRITE(IDLG,708)IDUM(ITYPE)
708	FORMAT(' FORMAT: (',A1,' - TYPE ONLY)')
	IF(ITYPE.LE.4)WRITE(IDLG,712)
712	FORMAT(' TYPE "HELP" FOR EXPLANATION',/)
	READ(IRSP,756,END=520,ERR=764)IN
C	CHECK FOR 'SAM','STD','HEL' OPTION
	DO 724 I=1,3
	DO 720 J=1,3
	IF(IN(J).NE.MESS(I,J))GO TO 724
720	CONTINUE
C	TO:    SAM STD HEL
	GO TO (746,744,772),I
724	CONTINUE
C	FORTRAN TYPE INPUT OR BLANKS(STD)
736	IF(L.EQ.1)GO TO 752
C	CHECK FOR LEFT PAREN AS FIRST NON BLANK CHAR(IF FIRST LINE ONLY).
	DO 740 I=1,NN
	IF(IN(I).EQ.' ')GO TO 740
	IF(IN(I).NE.'(')GO TO 764
	GO TO 748
740	CONTINUE
C	'STD' FORMAT
744	ISTD=1
	RETURN
C	'SAM' OPTION
746	RETURN
C	ENCODE 'IN' INTO 'IFT'
748	IBEG=1
	L=1
752	ENCODE(NN,756,IFT(IBEG))(IN(I),I=1,NN)
756	FORMAT(80A1)
C	THIS PAREN COUNT ASSUMES NO PARENS IN HOLLERITHS
	DO 760 I=1,NN
	IF(IN(I).EQ.'(')KOUNT=KOUNT+1
	IF(IN(I).EQ.')')KOUNT=KOUNT-1
760	CONTINUE
C	'KOUNT' DECIDES WHEN TO STOP ASKING FOR LINES
	IF(KOUNT.LT.0)GO TO 764
	IF(KOUNT.EQ.0)RETURN
	IBEG=IBEG+16
	IF((IBEG+16).GT.N)NN=(N-IBEG+1)*5
	IF(NN.LT.1)GO TO 764
	READ(IRSP,756,END=520,ERR=766)IN
	GO TO 752
C	ERROR PATH
764	IF(KL.NE.1)GO TO 766
765	WRITE(IDLG,784)
7651	IERR=-1
	RETURN
C	1ST ERROR ONLY
766	WRITE(IDLG,768)
768	FORMAT(' ERROR IN FORMAT, TRY AGAIN.',/)
	KL=1
	GO TO 700
C
C	HELP PATH
C
772	KL=0
	WRITE(IDLG,773)
773	FORMAT(' THERE ARE FOUR METHODS OF FORMAT ENTRY:',/,
     1	' 1 - STANDARD FORMAT',/,' 2 - FORTRAN OBJECT-TIME',/,
     1	' 3 - USE SAME FORMAT AS PREVIOUSLY',/,
     1	' 4 - DIALOGUE',//,' WHICH METHOD?(1,2,3 OR 4) ',$)
	READ(IRSP,780,END=520,ERR=774)METHOD
	IF(METHOD.LT.1.OR.METHOD.GT.4)GO TO 774
	GO TO (744,700,746,775),METHOD
774	IF(KL.EQ.1)GO TO 765
	KL=1
	WRITE(IDLG,784)
	GO TO 772
C	DIALOGUE PATH
775	IF(MSIZE.NE.0)GO TO 788
	KL=0
7751	WRITE(IDLG,776)
776	FORMAT(' HOW MANY FIELDS? ',$)
778	READ(IRSP,780,END=520,ERR=782)MSIZE
780	FORMAT(I)
	IF(MSIZE.GT.0.AND.MSIZE.LE.999)GO TO 788
782	IF(KL.EQ.1)GO TO 765
	KL=1
	WRITE(IDLG,784)
784	FORMAT(' RESPONSE ERROR',/)
	GO TO 7751
788	DO 796 I=1,MSIZE
	DO 792 J=1,3
	IF(MODE(I).EQ.IDUM(J))GO TO 796
792	CONTINUE
	KL=0
	GO TO 800
796	CONTINUE
	GO TO 820
800	WRITE(IDLG,804)
804	FORMAT(' ENTER TYPES OF FIELDS(A,F OR I) 10 PER LINE',/)
	READ(IRSP,808,END=520,ERR=814)(MODE(I),I=1,MSIZE)
808	FORMAT(10A1)
	DO 816 I=1,MSIZE
	DO 812 J=1,3
	IF(MODE(I).EQ.IDUM(J))GO TO 816
812	CONTINUE
814	IF(KL.EQ.1)GO TO 765
	KL=1
	WRITE(IDLG,784)
	GO TO 800
816	CONTINUE
820	X='  '
	DO 102 I=1,MSIZE
	IF(MODE(I).NE.'F')GO TO 102
	X=',D'
	GO TO 103
102	CONTINUE
103	WRITE(IDLG,104)X
104	FORMAT(' ENTER SPECIFICATIONS FOR FIELDS IN THE FOLLOWING'
     1	' FORM - A,B,C',A2,/,' WHERE:',/,'  A IS THE CARD OR RECORD',
     1	' CONTAINING THE FIELD',/,'  B IS THE STARTING COLUMN OF THE',
     1	' FIELD',/,'  C IS THE LAST COLUMN OF THE FIELD')
	IF(X.NE.'  ')WRITE(IDLG,105)
105	FORMAT('  D IS THE NUMBER OF DIGITS FOLLOWING THE DECIMAL',
     1	' POINT',/)
	WRITE(IDLG,106)
106	FORMAT(' ENTER SPECIFICATIONS IN ORDER.',/)
	DO 108 I=1,ISIZE
108	IFT(I)=0
110	IV=0
	ISIZE=300
	KHAR=1
	KHARL=0
	KOLUMN=0
	LINE=1
	JFT(KHAR)='('
117	KL=0
118	IVP=IV+1
	IF(IVP.GT.MSIZE)GO TO 500
	WRITE(IDLG,119)IVP
119	FORMAT(1X,I4,':',$)
121	READ(IRSP,122,END=520,ERR=612)KARD,INIT,LAST,IDP
122	FORMAT(4I)
	IV=IV+1
	IF(KARD.EQ.0)GO TO 610
	IF(KARD-LINE+13+KHARL.GT.ISIZE)GO TO 630
	IF(KARD.LT.LINE)GO TO 610
	IF(INIT-KOLUMN-1.GT.999)GO TO 610
	IF(LAST.LT.INIT)GO TO 610
	JLEN(IV)=LAST-INIT+1
	IF(IDP.GT.LAST-INIT+1.AND.MODE(IV).EQ.'F')
     1	GO TO 610
	IF(KARD.EQ.LINE)GO TO 200
C	/ SECTION
	DO 130 I=KHAR+1,KHAR+KARD-LINE
130	JFT(I)='/'
	KHAR=KHAR+KARD-LINE+1
	LINE=KARD
	JFT(KHAR)=','
	KOLUMN=0
	IF(INIT.EQ.0)GO TO 500
200	IF(INIT.LE.KOLUMN)GO TO 610
C	X SECTION
	JX=INIT-KOLUMN-1
	IF(JX.EQ.0)GO TO 300
	CALL NUMBER(JFT,KHAR,JX)
	KOLUMN=INIT-1
	KHAR=KHAR+1
	JFT(KHAR)='X'
	KHAR=KHAR+1
	JFT(KHAR)=','
300	IF(MODE(IV).NE.'A')GO TO 350
	CALL ALPHA(INIT,LAST,JFT,KHAR)
	GO TO 400
C	COMBINED I/F SECTION
350	KHAR=KHAR+1
	JFT(KHAR)=MODE(IV)
	LONG=LAST-INIT+1
	IF(LONG.GT.99)GO TO 610
	CALL NUMBER(JFT,KHAR,LONG)
	IF(MODE(IV).NE.'F')GO TO 400
C	F SECTION
	KHAR=KHAR+1
	JFT(KHAR)='.'
	CALL NUMBER(JFT,KHAR,IDP)
C	COMPACTING SECTION
400	ENCODE(KHAR,410,IFT(KHARL+1))(JFT(I),I=1,KHAR)
410	FORMAT(50A1)
	KHARL=KHARL+KHAR/5.+.9
	KHAR=1
	JFT(KHAR)=','
	KOLUMN=LAST
	GO TO 117
C	CLEAN UP AND FINISH
500	KL=0
501	WRITE(IDLG,502)
502	FORMAT(' HOW MANY CARDS PER OBSERVATION? ',$)
	READ(IRSP,122,END=520,ERR=504)IOBS
	IF(IOBS.GE.LINE)GO TO 508
504	IF(KL.EQ.1)GO TO 765
	KL=1
	WRITE(IDLG,784)
	GO TO 501
508	IF(IOBS.EQ.LINE)GO TO 512
	DO 510 I=KHAR+1,KHAR+IOBS-LINE
510	JFT(I)='/'
	KHAR=KHAR+IOBS-LINE+1
C	OVER WRITE COMMA
512	JFT(KHAR)=')'
	ENCODE(KHAR,410,IFT(KHARL+1))(JFT(I),I=1,KHAR)
	WRITE(IDLG,514)
514	FORMAT(' OK?(YES OR NO) ',$)
	READ(IRSP,516,END=520,ERR=520)ANS
516	FORMAT(A3)
	IF(ANS.EQ.'YES')RETURN
	IF(ICODE.NE.0)GO TO 7651
534	WRITE(IDLG,535)
535	FORMAT(' START FROM BEGINNING')
	GO TO 775
612	IF(KL.EQ.1)GO TO 765
	KL=1
610	WRITE(IDLG,784)
	WRITE(IDLG,613)
613	FORMAT(' SPECIFICATIONS MUST NOT OVERLAP OR BE OUT OF ORDER',/)
	IV=IV-1
	GO TO 118
520	WRITE(IDLG,522)
522	FORMAT(' END OF FILE OR NON RECOVERABLE INPUT ERROR')
	GO TO 537
630	WRITE(IDLG,632)
632	FORMAT(' STORAGE CAPACITY EXCEEDED FOR FORMAT')
C	FATAL ERROR
537	IERR=+1
	RETURN
	END
C
C	ALPHA FORMAT SECTION - MADE TO USE AS A STAND ALONE SUBR.
C
C
	SUBROUTINE ALPHA(INIT,LAST,JFT,KHAR)
	DIMENSION JLEN(1),JFT(1)
	IFULLS=(LAST-INIT+1)/5
	IF(IFULLS.EQ.0)GO TO 310
	IF(IFULLS.GT.1)CALL NUMBER(JFT,KHAR,IFULLS)
	KHAR=KHAR+1
	JFT(KHAR)='A'
	KHAR=KHAR+1
	JFT(KHAR)='5'
310	IDIF=LAST-INIT+1-(IFULLS*5)
	IF(IDIF.EQ.0)RETURN
	IF(IFULLS.EQ.0)GO TO 312
	KHAR=KHAR+1
	JFT(KHAR)=','
312	KHAR=KHAR+1
	JFT(KHAR)='A'
	CALL NUMBER(JFT,KHAR,IDIF)
	JLEN(IV)=IFULLS+1
	RETURN
	END
C
C
C	THIS ROUTINE TRANSLATES INTEGER(NUM) TO ASCII AND PLACES
C	IT IN THE PROPER PLACES IN ARRAY(IFT) STARTING WITH
C	LOCATION: IFT(KHAR+1).
C
	SUBROUTINE NUMBER(IFT,KHAR,NUM)
	DIMENSION IFT(1)
	INTEGER DIGIT(0/9)
	DATA DIGIT/'0','1','2','3','4','5','6','7','8','9'/
	NUMA=NUM
	ID=1000
	IFST=0
1	IR=NUMA/ID
	IF(IR.NE.0)GO TO 2
	IF(IFST.NE.0)GO TO 2
	IF(ID.EQ.1)GO TO 2
	GO TO 4
2	IFST=1
3	KHAR=KHAR+1
	IFT(KHAR)=DIGIT(IR)
4	IF(ID.EQ.1)RETURN
	NUMA=NUMA-IR*ID
	ID=ID/10
	GO TO 1
	END
	SUBROUTINE EXIT0
	CALL EXIT(0)
	END
C
C		CUMULATIVE CHI SQUARE SUBROUTINE
C		NAME:CHISQR.F4(FORMERLY CUCS)
C
C		SOURCE-CHARLES A. NAGY
C		MODIFIED FOR APPLICATIONS USE
C		BY RUSS R. BARR - 17 SEP 1973
C
	SUBROUTINE CHISQR(K,X,Y,IERR)
	IERR=0
	IF(K.LE.0.OR.K.GT.100)GO TO 14
	IF(X.GT.141)GO TO 14
	Y=0
	IF(X.LE.0)GO TO 13
	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)
	IF(P.LT.0)GO TO 14
	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)
	IF(P.LT.0)GO TO 14
	Y=(2.*S-1.)-P/(1.25331414*EXP(X/2.))
	GO TO 13
4	M=K/2
	IF(K-2*M)5,6,5
5	P=SQRT(X)
	CALL CUNO(P,S)
	IF(P.LT.0)GO TO 14
	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
	RETURN
14	IERR=-1
	RETURN
	END
C
C	NORMAL ROUTINE FOR CUCS
C
C	SOURCE CHARLES A. NAGY
C	MODIFIED BY RUSS R. BARR(17 SEP 1973)
C
	SUBROUTINE CUNO(X,Y)
	DIMENSION F(25)
	DATA (F(I),I=1,25)/.5,.598706326,.691462461,.773372648,
     1	.841344746,.894350226,.933192799,.959940843,.977249868,
     2	.987775527,.993790335,.997020237,.998650102,.999422975,
     3	.999767371,.999911583,.999968329,.999989311,.999996602,
     4	.999998983,.999999713,.999999924,.999999981,.999999996,
     5	.999999999/
	W=ABS(X)
	IF(W-6.125)2,2,1
1	Z=1
	GO TO 7
2	K=INT(4.*W)+1
	A=.25*FLOAT(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
	C1=((-A*A+10.)*A*A-15.)*A
	C2=(6.*A*A-36.)*A*A+18.
	C3=(-30.*A*A+90.)*A
	C4=120.*(A*A-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(A*A)))
7	IF(X)8,9,9
8	Y=1.-Z
	RETURN
9	Y=Z
	RETURN
10	WRITE(30,11)
11	FORMAT(' ?ERROR IN SUBROUTINE CUNO',/)
	X=-1
	RETURN
	END
C     SUBROUTINE CALCULATES PROBABILITIES FOR CHI SQUARES
C     CALLING SEQUENCE CALL CHIPRB(CHI,NF,PROB)
C     WHERE  CHI - VALUE OF CHI SQUARE
C            NF - FIXED POINT DEGREES OF FREEDOM
C            PROB - RETURNS PROBABILITY OF CHISQUARE (99 IF ERROR)
C
C     ROUTINE FROM COMMUNICATIONS OF ACM APRIL 1967, CAS
C     ALSO THE SUBROUTINE NORMCV.  MACHINE ACCURACY ON EVEN DEGREES
C     OF FREEDOM, AT LEAST 4 PLACES OF ACCURACY ON ODD DEGREES OF
C     FREEDOM.(FOR ALL TABLES COMPARED AGAINST, THE PROBABILITY
C     FROM THE PROGRAM AGREED TO ALL PLACES[BEST WAS 5])
C
C	REPRINTING PRIVILEGES WERE GRANTED BY
C	PERMISSION OF THE ASSOCIATION FOR COM-
C	PUTING MACHINERY, BUT NOT FOR PROFIT.
C
      SUBROUTINE  CHIPRB(CHI,NF,PROB)
      PROB=99
      IF((CHI.LT.0).OR.(NF.LT.1)) RETURN
      IEVEN=NF.AND.1
      A=.5*CHI
      Y=0
C     EXP(-85)(=1.216E-37) IS THE BEST WHICH CAN BE USED WITH PDP 
      IF(((IEVEN.EQ.0).OR.(NF.GT.2)).AND.(A.LT.85)) Y=EXP(-A)
      S=Y
      IF(IEVEN.EQ.0) GO TO 3
      S=-SQRT(CHI)
      CALL NORMCV(S,P)
      S=2.*P
3     IF(NF.LE.2) GO TO 5
      X=.5*(NF-1.)
      Z=1.
      IF(IEVEN.EQ.1) Z=.5
      IF(A.LT.85) GO TO 2
C
C
C
      E=0
C     .572364942925=LN(SQRT(PIE))
      IF(IEVEN.EQ.1) E=.572364942925
      C=ALOG(A)
1     E=ALOG(Z)+E
      SL=C*Z-A-E
      IF((SL.LT.-85).OR.(SL.GT.85)) GO TO 7
      S=S+EXP(SL)
7     Z=Z+1.
      IF(Z.LE.X) GO TO 1
      PROB=S
      GO TO 6
C
C
C
2     E=1
C     .564189583548=1/SQRT(PIE)
      IF(IEVEN.EQ.1) E=.564189583548/SQRT(A)
      CL=0
      C=0
4     E=E*A/Z
      CL=C+E
      IF(CL.EQ.C) GO TO 8
      C=CL
      Z=Z+1.
      IF(Z.LT.X) GO TO 4
8     PROB=C*Y+S
      GO TO 6
5     PROB=S
6     IF(PROB.LT.0) PROB=0
      IF(PROB.GT.1.) PROB=1.
      RETURN
      END
C                                                  ****  STAT PACK  ****
C     SUBROTINE USED TO FIND CUMULATIVE NORMAL PROBABILITIES FOR Z'S.
C     CALLING SEQUENCE: CALL NORMCV(X,PROB)
C     WHERE X - IS THE Z-VALUE FOR WHICH THE PROBABILITY IS TO BE FOUND
C           PROB - IS CUMULATIVE PROBABILITY FOR THE Z.
C
C     ROUTINE WRITTEN FROM SPECIFICATIONS IN ACM COMMUNICATIONS
C     (JUNE 1967), WITH THE IMPROVEMENTS NOTED IN THE ACM COMMUNICATIONS
C     FROM OCTOBER 1969.  ROUTINE USED IN CACCULATING THE CHISQUARE
C     PROBABILITIES ALSO.
C
C	REPRINTING PRIVILEGES WERE GRANTED BY
C	PERMISSION OF THE ASSOCIATION FOR COM-
C	PUTING MACHINERY, BUT NOT FOR PROFIT.
C
      SUBROUTINE NORMCV(X,PROB)
      IF(X.EQ.0) GO TO 7
      Z=ABS(X)
      X2=X*X
      Y=0
      A=.5*X2
      IF(A.GT.85) GO TO 6
C     .39894228=1/SQRT(2*PIE)
      Y=.398942280401432678*EXP(-A)
6     A=Y/Z
      IF((X.GT.0).AND.((1.0-A).EQ.1.0)) GO TO 8
      IF((X.LT.0).AND.(A.EQ.0)) GO TO 9
      IF((Z.GT.2.32).AND.(X.GT.0)) GO TO 2
      IF((Z.GT.3.5).AND.(X.LT.0)) GO TO 2
      S=Y*Z
      Z=S
      D=1.
1     D=D+2.
      T=S
      Z=Z*X2/D
      S=S+Z
      IF(S.EQ.T) GO TO 5
      GO TO 1
5     PROB=.5-S
      IF(X.GT.0) PROB=.5+S
      GO TO 10
2     A1=2.
      A2=0.
      D=X2+3.
      P1=Y
      Q1=Z
      P2=(D-1.0)*Y
      Q2=D*Z
      R=P1/Q1
      T=P2/Q2
      IF(X.LT.0) GO TO 3
      R=1.-R
      T=1.-T
3     D=D+4.
      A1=A1-8.
      A2=A1+A2
      S=A2*P1+D*P2
      P1=P2
      P2=S
      S=A2*Q1+D*Q2
      Q1=Q2
      Q2=S
      S=R
      R=T
      T=P2/Q2
      IF(X.GT.0) T=1.-T
      IF(R.EQ.T) GO TO 4
      IF(S.NE.T) GO TO 3
4     PROB=T
      GO TO 10
7     PROB=.5
      GO TO 10
8     PROB=1.0
      GO TO 10
9     PROB=0
      GO TO 10
10    RETURN
      END
C
C	REPRINTING PRIVILIEGES WERE GRANTED BY
C	PERMISSION OF THE ASSOCIATION FOR COM-
C	PUTING MACHINERY, BUT NOT FOR PROFIT.
C
      FUNCTION FISHER(M,N,X)
C
C	REFERENCE:
C		COMMUNICATIONS OF THE A.C.M.
C		FEBRUARY 1971,  PAGE 117
C
C	COMMENT:
C	    IF DF1=1 AND DF2>1000, INVERSE INTERPOLATION IS USED;
C		FISHER=(1-1000/DF2)*FISHER(INFINITY)+1000/N*FISHER(1000)
C		(PER: M. STOLINE - 28 APR 77)
C
C***** WMU-AM: #99.25.1, MOD=2, MTO, 24-OCT-77 *****
C
C	MINOR REVISION (MOD=2) BY MTO ON 24-OCT-77
C	(1) CLEANUP LOGIC & IMPROVE INTELLIGABLILITY
C	(2) ADD INFORMATIVE ERROR MESSAGES FOR BAD DATA
C	(3) ADD DOCUMENTAION WHERE CODE IS UNCLEAR
C	(4) FIX BUG WHICH CAUSES THE INPUT PARAMETER 'N'
C	    TO BE MODIFIED (SET TO 0) WHEN 'X' IS ZERO
C	(5) PAGINATE THE ENTIRE LIBRARY
C
C	INPUT PARAMETERS:
C	M = # OF DEGREES OF FREEDOM (BETWEEN)
C	N = # OF DEGREES OF FREEDOM WITHIN
C	X = 'F' VALUE TO FIND THE PROBABILITY OF
C
	LOGICAL ODD, EVEN
	ODD (N) = (N.AND.1) .NE. 0
	EVEN(N) = .NOT. ODD(N)
C**SAVE 'N' IN 'NX' SO WE CAN RESTORE IT LATER
	NX=N
      IF(X.EQ.0.0)GO TO 321
      IF(M.EQ.1)GO TO 200
C**THIS STATEMENT REMOVED BECAUSE THE ROUTINE AT
C**201 IS INCORRECT**RRB**3MAY77**
C**      IF((M+N).GT.400)GO TO 201
200	NX=N
	IF(N.GT.1000)N=1000
C** IF M,N IS ODD,  SET NA,NB TO 1
C** IF M,N IS EVEN, SET NA,NB TO 2
      NA=2*(M/2)-M+2
      NB=2*(N/2)-N+2
	IF(N.EQ.0) TYPE 1
1	FORMAT (' % FISHER: ZERO DEGREES OF FREEDOM WITHIN')
      W=X*FLOAT(M)/FLOAT(N)
      Z=1.0/(1.0+W)
	IF (ODD (M)) GOTO 10
	IF (ODD (N)) GOTO 9
C**(M EVEN, N EVEN)
      D=Z*Z
      P=W*Z
      GO TO 100
C**(M EVEN, N ODD)
9     P=SQRT(Z)
      D=0.5*Z*P
      P=1.0-P
      GO TO 100
C**(M ODD, N EVEN)
10	IF (ODD (N)) GOTO 15
      P=SQRT(W*Z)
      D=0.5*P*Z/W
      GO TO 100
C**(M ODD, N ODD)
15    P=SQRT(W)
      Y=.3183098862
      D=Y*Z/P
      P=2.0*Y*ATAN(P)
100   Y=2.0*W/Z
      IF(N.LT.(NB+2))GO TO 111
	IF (EVEN (M)) GOTO 105
      DO 101 J=NB+2,N,2
      D=(1.0+FLOAT(NA)/FLOAT(J-2))*D*Z
101   P=P+D*Y/FLOAT(J-1)
      GO TO 111
105	ZK=0
	IF((ALOG10(Z)*(N-1)/2).GE.-37) ZK=Z**((N-1)/2)
107	D=D*ZK*FLOAT(N)/FLOAT(NB)
      P=P*ZK+W*Z*(ZK-1.0)/(Z-1.0)
111   CONTINUE
      Y=W*Z
      Z=2.0/Z
      NB=N-2
	IF(M.LT.(NA+2)) GO TO 103
      DO 102 I=NA+2,M,2
      J=I+NB
      D=Y*D*FLOAT(J)/FLOAT(I-2)
      P=P-Z*D/FLOAT(J)
102   CONTINUE
103	FISHER=1-P
	IF(FISHER.LT.0)FISHER=0
	GO TO 322
321   FISHER=1.0
322	N=NX
	IF(N.LE.1000)RETURN
	IF(X.LT.0.0) TYPE 2
2	FORMAT (' % FISHER: NEGATIVE F-VALUE')
	FP2=(1.-CDFN(SQRT(X)))*2.
	FISHER=(1.-1000./N)*FP2+(1000./N)*FISHER
      RETURN
C**FROM HERE ON DOWN, CODE IS INCORRECT AND INACCESSABLE
201   IND=0
      MI=M
      NI=N
      XI=X
      IF(XI.GE.1)GO TO 203
      IND=1
      ISAVE=NI
      NI=MI
      MI=ISAVE
      XI=1.0/XI
203   Z1=2.0/FLOAT(9*MI)
      Z2=2.0/FLOAT(9*NI)
      Z=ABS((1.0-Z2)*XI**(.33333333)-1.0+Z1)
      Z=Z/SQRT(Z2*XI**(.66666667)+Z1)
C      IF(N.GE.4)GO TO 205
      IF(NI.GE.4)GO TO 205
      Z=Z*(1.0+.08*Z**4)/FLOAT(NI)**3
205   Z=(1.0+Z*(.196854+Z*(.115194+Z*(.000344+Z*.019527))))**4
      FISHER=.5/Z
      IF(IND.EQ.1)FISHER=1.0-FISHER
      RETURN
C***** WMU-AM: END=FISHER, #205+4 *****
      END
	FUNCTION CDFN(X)
C
C	CDF OF STANDARD UNIT NORMAL
C
C	THIS FUNCTION CALCULATES THE CDF
C	PROBABILITY CDFN(Y) ASSOCIATED
C	WITH THE INPUTTED VALUE Y FOR THE
C	STANDARD UNIT NORMAL DISTRIBUTION.
C
C	SOURCE:	ABRAMOWITZ, M. AND STEGUN, I.A. (1964),
C		"HANDBOOK OF MATHEMATICAL FUNCTIONS WITH
C		FORMULAS, GRAPHS, AND MATHEMATICAL TABLES"
C		(FORMULA 26.2.17, P.932)
C
      T = 1./(1.+(.231642)*ABS(X))
      TEMP = (.319382)*T-(.356564)*T**2+(1.781478)*T**3-(1.821256)*T**4
     #+ (1.330274)*T**5
      Z = (.398942)*EXP(-.5*X**2)
      CDFN = Z*TEMP
      IF(X.GT.0) CDFN = 1.-CDFN
      RETURN
      END
      FUNCTION TPCT(ALPHA,KDF)
      Z=ALPHA*ALPHA
      Q=1./Z
      T=SQRT(ALOG(Q))
      U=((.010328*T+.802853)*T+2.515517)
      V=(((.001380*T+.189269)*T+1.432788)*T+1.)
      XP=T-U/V
      X2=XP*XP
      A=XP*(X2+1.)/4.
      B=((5.*X2+16.)*X2+3.)*XP/96.
      C=(((3.*X2+19.)*X2+17.)*X2-15.)*XP/384.
      D=((((79.*X2+776.)*X2+1482.)*X2-1920.)*X2-945.)*XP/92160.
      E=(((((27.*X2+339.)*X2+930.)*X2-1782.)*X2-765.)*X2+17955.)*XP/3686
     140.
      V=1./KDF
      TPCT=XP+(A+(B+(C+(D+E*V)*V)*V)*V)*V
      RETURN
      END
      FUNCTION FPCT(ALPHA,K1,K2)
      SIG=1./K1+1./K2
      DELT=1./K1-1./K2
      Z=ALPHA*ALPHA
      Q=1./Z
      T=SQRT(ALOG(Q))
      C=((.010328*T+.802853)*T+2.515517)
      D=(((.001308*T+.189269)*T+1.432788)*T+1.)
      E=C/D
      XP=T-E
      X=XP*XP
      Z1=SQRT(SIG/2.)*XP
      Z2=DELT*(X+2.)/6.
      Z3=SQRT(SIG/2.)*(SIG*((X+3.)*XP)/24.+DELT**2*((X+11.)*XP)/(SIG*72.
     1))
      Z4=DELT*SIG*((X+9.)*X+8.)/120.-DELT**3*((3.*X+7.)*X-16.)/(SIG*3240
     1.)
      Z5=SQRT(SIG/2.)*(SIG**2*(((X+20.)*X+15.)*XP)/1920.+DELT**2*(((X+44
     1.)*X+183.)*XP)/2880.+DELT**4*(((9.*X-284.)*X-1513)*XP)/(SIG**2*155
     2520.))
      Z6=DELT*SIG**2*(((4.*X-25.)*X-177.)*X+192.)/20160.+DELT**3*(((4.*X
     1+101.)*X+117.)*X-480.)/90720.-DELT**5*(((12.*X+513.)*X+841.)*X-256
     20.)/(SIG**2*1632960.)
      Z7=SQRT(SIG/2.)*(SIG**3*((((X+7.)*X+7.)*X+105.)*XP)/21504.+DELT*SI
     1G**2*((((801.*X+10511.)*X+30151.)*X+62241.)*XP)/4838400.-DELT**4*(
     2(((477.*X+4507.)*X-82933.)*X-264363)*XP)/(SIG*43545600.)+DELT**6*(
     3(((3753.*X+55383.)*X-368897.)*X-1213927.)*XP)/(SIG**3*1175731200.)
     4)
      ZP=Z1-Z2+Z3-Z4+Z5+Z6-Z7
      AN=2.*ZP
      FPCT=EXP(AN)
      RETURN
      END
C	PROGRAM -STUDR.F4 USES SUPPORT DATA FILE STUDR.DAT ON [1,4]
C	WRITTEN BY SAM ANEMA - WMU - KALAMAZOO
C	MODIFIED FOR LIBRARY PROGRAM USE BY RUSS BARR - WMU
C	DATE: 22-MAR-74
C
C	THIS PROGRAM RETURNS A VALUE FROM THE STUDENTIZED
C	RANGE TABLES DEPENDING ON THE VALUE OF THREE PARAMETERS
C	WHICH ARE SUBMITTED BY THE USER OF THIS ROUTINE.
C
C
C	THE ARGUMENTS ARE:
C
C		VAL    - CONTAINS THE REQUESTED TABLED VALUE UPON
C			 RETURNING.
C		IA     - THIS ARGUMENT MUST BE A 1 OR A 0 
C				1 - INDICATES .01 SIGNIFICANCE LEVEL
C				0 - INDICATES .05 SIGNIFICANCE LEVEL
C		IDF    - THIS ARGUMENT MUST CONTAIN THE DEGREES OF
C			 FREEDOM.
C		IM     - CONTAINS THE NUMBER OF MEANS COMPARED
C		IER    - ERROR RETURN ARGUMENT
C				0 - NO ERROR
C				1 - INCORRECT VALUE FOR IA
C				2 - ILLEGAL VALUE FOR DEGREES OF FREEDOM
C				3 - ILLEGAL VALUE FOR NUMBER OF MEANS
C
C
	SUBROUTINE STUDR(VAL,IA,IDF,IM,IER)
	DIMENSION X(100),X1(100),X2(100)
	COMMON/START/IAO,IDFO,INIT
	IF(IA.NE.0.AND.IA.NE.1)GO TO 991
	IF(IDF.LT.1)GO TO 992
	IF(IM.LT.2.OR.IM.GT.100)GO TO 993
	IF(IA.NE.IAO)GO TO  20
	IF(IDF.EQ.IDFO)GO TO 60
20	IF(INIT.EQ.1)GO TO 40
	INIT=1
	CALL DEVCHG('DSK',9)
	CALL DEFINE FILE(9,100,NEVER,'STUDR.DAT',"1,"4)
	READ(9#121)X1
	READ(9#242)X2
40	ID=MIN0(120,IDF)
	IND=IA*121+ID
	READ(9#IND)X
60	IF(IDF.GT.120)GO TO 25
	VAL=X(IM)
	GO TO 70
25	XI=X1(IM)
	IF(IA.EQ.1)XI=X2(IM)
	C=120.*(X(IM)-XI)
	VAL=XI+C/FLOAT(IDF)
70	IAO=IA
	IDFO=IDF
	IER=0
	GO TO 80
991	IER=1
	GO TO 80
992	IER=2
	GO TO 80
993	IER=3
80	RETURN
	END
C	PROGRAM - DUNCAN.F4 USES SUPPORT DATA FILE DUNCAN.DAT ON [1,4]
C	WRITTEN BY RUSS BARR - WMU - KALAMAZOO
C	DATE: 11-OCT-74
C
C	THIS PROGRAM RETURNS A VALUE FROM THE DUNCAN MULTIPLE RANGE
C	TEST TABLES DEPENDING ON THE THREE VALUES SUBMITTED.
C	NOTE: THIS ROUTINE IS SIMILAR TO STUDR.F4, BUT USES AN 
C	UNINTERPOLATED TABLE FOR FLEXIBILITY.
C
C	THE ARGUMENTS ARE:
C
C		VAL	- RETURNS THE REQUESTED VALUE
C		IA	- 1  .01 SIGNIFICANCE LEVEL
C			- 0  .05 SIGNIFICANCE LEVEL
C		IDF	- DEGREES OF FREEDOM
C		IM	- NUMBER OF MEANS
C		IER	- 0  NO ERROR
C			- 1  IA OUT OF RANGE(0-1)
C			- 2  IDF LESS THAN 1
C			- 3  IM OUT OF RANGE(2-100)
C
	SUBROUTINE DUNCAN(VAL,IA,IDF,IM,IER)
	DIMENSION X(140),IV(26),JV(35)
	DATA IA1,IDF1,INIT1/3*0/
	DATA IV/1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
     #24,30,40,60,120,0/
	DATA JV/2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,
     #22,24,26,28,30,32,34,36,38,40,50,60,70,80,90,100/
	IF(IA.NE.0.AND.IA.NE.1)GO TO 991
	IF(IDF.LT.1)GO TO 992
	IF(IM.LT.2.OR.IM.GT.100)GO TO 993
	M=0
	IF(IA.EQ.1)M=35
	IF(IDF.EQ.IDF1)GO TO 60
20	IF(INIT1.EQ.1)GO TO 40
	INIT1=1
	CALL DEVCHG('DSK',8)
	CALL DEFINE FILE(8,72,NEVER,'DUNCAN.DAT',"1,"4)
40	DO 43 I=25,1,-1
43	IF(IDF.GE.IV(I))GO TO 44
44	I1=I+1
	READ(8#I)(X(K),K=1,70)
60	MM=0
	IF(IDF.EQ.IV(I))GO TO 45
	MM=70
	READ(8#I+1)(X(K),K=71,140)
45	DO 46 J1=35,1,-1
46	IF(IM.GE.JV(J1))GO TO 47
47	J2=J1
	FRAC=0
	IF(IM.NE.JV(J1))J2=J1+1
	IF(J1.NE.J2)FRAC=(IM-JV(J1))/FLOAT((JV(J2)-JV(J1)))
	VAL1=X(J1+M)+(X(J2+M)-X(J1+M))*FRAC
	VAL2=X(J1+MM+M)+(X(J2+MM+M)-X(J1+MM+M))*FRAC
	FRAC=0
	IF(IDF-IV(I).NE.0.AND.IDF.GE.120)FRAC=(IDF-120.)/IDF
	IF(IDF-IV(I).NE.0.AND.IDF.LT.120)FRAC=(IDF-IV(I))/FLOAT(
     1(IV(I1)-IV(I)))
	VAL=VAL1+(VAL2-VAL1)*FRAC
	IM1=IM
	IDF1=IDF
	IER=0
	GO TO 80
991	IER=1
992	IER=2
	GO TO 80
993	IER=3
80	RETURN
	END