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