Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-09 - 43,50466/aplb10.for
There are 4 other files named aplb10.for in the archive. Click here to see a list.
C
C      SUBROUTINE IO.  ORIGINALLY WRITTEN BY SAM ANEMA.
C     MODIFIED BY RUSS BARR, AND BERENICE HOUCHARD.
C
C     REWRITTEN BY DICK HOUCHARD JAN 1976
C
C      CALL SEQUENCE CALL IO(KNOUT,IDEV,DEVNAM,REALDV,FILNAM,IPROJ,IPROG,IBNK)
C     WHERE:
C      KNOUT - IS A SINGLE WORD QUANTITY USED TO INDICATE WHETHER
C           THE USER IS REQUESTING  AN INPUT OR OUTPUT.
C           1 = OUTPUT ROUTINE ASKS QUESTION.
C           0 = INPUT , ROUTINE ASKS QUESTION
C           -1 = OUTPUT  MAINLINE ASKS QUESTION.
C           -2 = INPUT, MAINLINES ASKS QUESTION.
C     IDEV - DEVICE NUMBER (MUST BE BETWEEN 1 AND 30
C     DEVNAM - TWO WORD QUANTITY RETURNED FROM  SUBROUTINE
C           CONTAINING THE DEVICE NAME INDICATED BY USER.
C     REALDV - SINGLE WORD QUANTITY  RETURNED BY SUBROUTINE CONTAINING
C           "TTY" IF THE DEVICE IS A TELETYPE
C          "DSK" IF THE DEVICE IS A DISK
C          "  " IF THE DEVICE IS OTHER THAN A TELETYPE AND DISK
C     FILNAM - TWO WORD VARIABLE CONTAINING THE FILENAME(IF NEEDED)
C           OF THE FILE REQUESTED BY THE USER.
C     IPROJ - 1 WORD QUANTITY  RETURNED BY THE KPROGRAM 
C           CONTAINING THE PROJECT NUMBER WHERE THE FILE IS FOUND.
C      IPRG - 1 WORD QUANTITY RETURNED BY THE PROGRAM TO INDICATED
C           PROGRAMMER NUMBER WHERE THE FILE EXISTS.
C      IBNK - 1 WORD KVARIABLE  RETURNED FROM THE SUBROUTINE 
C          INDICATING WHETHER THE FILE IS A 
C          BANK FILE OR NOT (0= IS NOT, 1= IS)
C
C     IN RESPONDING TO THE SUBROUTINE THE USER MAY TERMINATE WITH
C     A CARRIAGE RETURN OR ALTMODE.
C
C     ADDITION ROUTINE NEEDED ARE:
C      GES - ROUTINE READS INPUT FROM THE TELETYPE WITH AN A1 FORMAT
C            ALSO ALLOWS THE TERMINATION OF A LINE WITH AND ALTMODE.
C      DEVCHR - RETURNS THE DEVICE CHARASTICS OF A SPECIFED
C               DEVICE
C      GETPPN - RETURNS PROJECT PROGRAMMER NUMBER OF USER.
C      EXISTS - CHECKS FOR THE EXISTANCE OF A FILE.
C      RUNUUO - ENTERS A RUN CLASS COMMAND FROM THE PROGRAM.
C      PRINTS - ALLOWS THE PROGRAM TO ENTER A FILE INTO THE
C               LINEPRINTER SPOOLER.
C      JOBNUM - RETURN JOB NUMBER OF USER.
C
C
C
      SUBROUTINE IO(KNOUT,IDEV,DEVNAM,REALDV,FILNAM,IPROJ,IPROG,IBNK)
      COMMON /INIO/ IFTR,IFTW,DEVN(30),FILNM(30),IPP(30),DEST(30)
      COMMON/IOB/LEFBK,IRTBK,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,II,OUTDV
      DIMENSION IN(80),INN(10),IPN(3)
      DOUBLE PRECISION FILNAM,FILNM,TMP,DEVNAM,DEVN
      INOUT=KNOUT
      IF(INOUT.LT.0) INOUT=INOUT+2
      SETSW=0
      IALT="155004020100
      IRTBK="565004020100
      LEFBK="555004020100
      IPN(3)=0
1     DEVNAM='TTY'
      CALL DEVCHR(DEVNAM,IDCHAR)
      FILNAM='     '
      CALL GETPPN(IPROJ,IPROG)
      IBNK=0
      ICOPS=1
      IF(KNOUT.LT.0) GO TO 7
      IF(INOUT.EQ.1) GO TO 4
      IF(IFTR.EQ.0)WRITE(IDLG,2)
2     FORMAT('+INPUT? (for help type HELP) '$)
      IF(IFTR.NE.0) WRITE(IDLG,3)
3     FORMAT('+INPUT? ',$)
      IFTR=1
      GO TO 7
4     IF(IFTW.EQ.0) WRITE(IDLG,5)
5     FORMAT('+OUTPUT? (for help type HELP) ',$)
      IF(IFTW.NE.0) WRITE(IDLG,6)
6     FORMAT('+OUTPUT? ',$)
      IFTW=1
C
C     CALL GES DOES SAME THING AS READ WITH FORMAT OF 80A1,
C     EXCEPT IT WILL ALSO TERMINATE WITH AN ALTMODE.
C     ICHECK+2 IMPLIES CONTROL Z WAS HIT
C
7     CALL GES(IN,80,ICHECK)
      IF(ICHECK.EQ.2) GO TO 90
C
C     COMPRESS OUT BLANKS
C
      J=1
      DO 8 I=1,80
      IF(IN(I).EQ.' ') GO TO 8
C     CHANGE ALL LOWER CASE TO UPPER CASE LETTERS
      IF((IN(I).GE."605004020100).AND.(IN(I).LE."751004020100))
     1IN(I)=IN(I).AND."577777777777
      IN(J)=IN(I)
      J=J+1
8     CONTINUE
      IF(J.EQ.81) GO TO 10
      DO 9 I=J,80
9     IN(I)=' '
      IF(J.EQ.1) GO TO 71
      IF(IN(1).EQ.IALT) GO TO 71
C
C     DEVICE (PICK UP UNTIL SPACE, ALTMODE, OR <CR>)
C
10    DO 11 I=1,10
11    INN(I)=' '
      I=1
      J=1
12    IF(IN(I).EQ.' ') GO TO 40
      IF(IN(I).EQ.':') GO TO 15
      IF(IN(I).EQ.IALT) GO TO 40
      IF(IN(I).EQ.LEFBK) GO TO 40
      IF(J.GT.10) GO TO 13
      INN(J)=IN(I)
      J=J+1
      I=I+1
      GO TO 12
13    WRITE(IDLG,14)
14    FORMAT('+Either a colon was missing or the file name',
     1' is too long'/)
      GO TO 1
15    ENCODE(10,16,DEVNAM) (INN(J),J=1,10)
16    FORMAT(80A1)
      CALL DEVCHR(DEVNAM,IDCHAR)
      IF(IDCHAR.NE.0) GO TO 18
      WRITE(IDLG,17) DEVNAM
17    FORMAT('+Device ',A6,' does not exist'/)
      GO TO 1
18    IF(INOUT.EQ.1) GO TO 20
      IF((IDCHAR.AND."000002000000).NE.0) GO TO 35
      WRITE(IDLG,19) DEVNAM
19    FORMAT('+Device  'A6,' cannot do input'/)
      GO TO 1
20    IF((IDCHAR.AND."000001000000).NE.0) GO TO 22
      WRITE(IDLG,21) DEVNAM
21    FORMAT('+Device ',A6,' cannot do output.'/)
      GO TO 1
22    IF((IDCHAR.AND."040000000000).EQ.0) GO TO 35
C
C
C     *************************************************************
C
C     LINE PRINTER SECTION (ONLY HERE IF LPT: SPECIFIED)
C
161   J=100
23    J=J+1
      CALL JOBNUM (K)
      K=K+100
      ENCODE(10,24,FILNAM) J,K
24    FORMAT('WMU',I3,'.',I3)
      CALL EXIST(FILNAM,IERR,0,0)
      IF(IERR.EQ.0) GO TO 23
      I=I+1
      IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 130
      IF(IN(I).EQ.'/') GO TO 27
25    WRITE(IDLG,26)
26    FORMAT('+Only a /COPIES switch may follow a LPT:'/)
      GO TO 1
27    IF((IN(I+1).NE.'C').OR.(IN(I+2).NE.'O').OR.
     1(IN(I+3).NE.'P').OR.(IN(I+4).NE.'I').OR.
     1(IN(I+5).NE.'E').OR.(IN(I+6).NE.'S').OR.(IN(I+7).NE.':')) 
     1 GO TO 160
      I=I+7
160   INN(1)=' '
      INN(2)=' '
      J=1
      I=I+1
28    IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 33
      IF((IN(I).LT.'0').OR.(IN(I).GT.'9')) GO TO 29
      IF(J.GT.2) GO TO 31
      INN(J)=IN(I)
      J=J+1
      I=I+1
      GO TO 28
29    WRITE(IDLG,30) IN(I)
30    FORMAT('+Illegal character "',A1,'" in COPIES swicth'/)
      GO TO 1
31    WRITE(IDLG,32)
32    FORMAT('+Copies must be between 1 and 63.'/)
      GO TO 1
33    IF(J.EQ.1) GO TO 162
      IF(INN(2).NE.' ') GO TO 162
      INN(2)=INN(1)
      INN(1)=' '
162   ENCODE(2,16,ATMP)(INN(J),J=1,2)
      DECODE(2,34,ATMP) ICOPS
34    FORMAT(I2)
      IF((ICOPS.LT.1).OR.(ICOPS.GT.63)) GO TO 31
130   IF(DEVN(IDEV).EQ.0) GO TO 89
      CLOSE(UNIT=IDEV)
      CALL DEVCHR(DEVN(IDEV),LCHAR)
      IF(DEST(IDEV).LT.-100) IFTW=1
      IF((LCHAR.AND."040000000000).EQ.0) GO TO 89
      ICOPS=-DEST(IDEV)
      IF(ICOPS.GT.100) ICOPS=ICOPS-100
      NPAGES=IPAGCT*ICOPS+3
      IF(IPAGCT.GT.0)CALL PRINTS(FILNM(IDEV),2,1,ICOPS,NPAGES)
      IF(IPAGCT.LT.0) CALL PRINTS(FILNM(IDEV),2,1,ICOPS)
      IPAGCT=0
89    OPEN(UNIT=IDEV,DEVICE='DSK',FILE=FILNAM,ACCESS='SEQOUT')
      GO TO 76
C
C     *************************************************************
C
C
C     ##############################################################
C
C      ALL OTHER DEVICES ARE CHANNELED THROUGH HERE
C
C     FIRST A CHECK IS MADE TO SEE IF IT IS A DIRECTORY DEVICE
C     OR NOT (DTA AND DSK ARE DIRECTORY DEVICES).
C
35    IF((IDCHAR.AND."000004000000).EQ.0) GO TO 36
      FILNAM='INPUT.DAT'
      IF(INOUT.EQ.1) FILNAM='OUTPUT.DAT'
36    I=I+1
      IF(IN(I).NE.'/') GO TO 38
      WRITE(IDLG,37)
37    FORMAT('+Only switch available if for the LPT'/)
      GO TO 1
38    IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 71
      IF((IDCHAR.AND."000004000000).NE.0) GO TO 41
      WRITE(IDLG,39)
39    FORMAT('+Non-directory devices require no additional information'
     1/)
      GO TO 1
C
C     ############################################################
C
C
C     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!h
C
C     DEVICE HAS BEEN HANDLED. AT THIS POINT IT IS A 
C     DIRECTORY DEVICE.  NOW GET THE FILENAME AND
C     PROJECT-PROGRAMMER NUMBER (IF THEY EXIST)
C
41    DO 42 J=1,10
42    INN(J)=' '
      J=1
43    IF(IN(I).EQ.' ') GO TO 46
      IF(IN(I).EQ.LEFBK) GO TO 46
      IF(IN(I).EQ.IALT) GO TO 46
      IF(J.GT.10) GO TO 44
      INN(J)=IN(I)
      J=J+1
      I=I+1
      GO TO 43
44    WRITE(IDLG,45)
45    FORMAT('+File name too long'/)
      GO TO 1
C
C     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
40    DEVNAM='DSK'
      FILNAM='INPUT.DAT'
      IF(INOUT.EQ.1) FILNAM='OUTPUT.DAT'
      CALL DEVCHR(DEVNAM,IDCHAR)
C
C     =============================================================
C
C     FILE NAME?  CHECK FOR ALL OTHER POSSIBILITIES FIRST
C
46    ENCODE(10,16,TMP) INN
      IF(TMP.EQ.'          ') GO TO 112
      IF(TMP.EQ.'/STP      ') GO TO 80
      IF(TMP.EQ.'/BANK     ') GOTO 80
      IF(TMP.EQ.'/REGR     ') GO TO 80
      IF(TMP.EQ.'/TAB      ') GO TO 80
      IF(TMP.EQ.'/FREQ     ') GO TO 80
      IF(TMP.EQ.'/CORL     ') GO TO 80
      IF(TMP.EQ.'SAME      ') GO TO 83
      IF(TMP.EQ.'CONTINUE  ') GO TO 140
      IF(TMP.EQ.'/OUT      ') GO TO 100
      IF(TMP.EQ.'/OUTPUT   ') GO TO 100
      IF(TMP.EQ.'END       ') GO TO 90
      IF(TMP.EQ.'FINI      ') GO TO 90
      IF(TMP.EQ.'FINISH    ') GO TO 90
      IF(TMP.EQ.'HELP      ') GO TO 150
C
C     ===============================================================
C
C
C     @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C     IT IS A FILE NAME.   IS IT A BANK?  IS THER A PROJECT-
C     PROGRAMMER NUMBER?
C
C
      IDP=0
      DO 113 J=1,10
      IF(INN(J).EQ.' ') GO TO 113
      IF(INN(J).EQ.'.') GO TO 115
      IF((INN(J).GE.'0').AND.(INN(J).LE.'9')) GO TO 113
      IF((INN(J).LE.'Z').AND.(INN(J).GE.'A')) GO TO 113
      WRITE(IDLG,114) INN(J)
114   FORMAT('+Character"',a1,'" is not valid in a file name'/)
      GO TO 1
115   IDP=IDP+1
      IF(IDP.EQ.1) GO TO 113
      WRITE(IDLG,116)
116   FORMAT('+Only one period is allowed in the file name.'/)
      GO TO 1
113   CONTINUE
      IF(IDP.EQ.1) GO TO 117
      J=1
118   IF(INN(J).EQ.' ') GO TO 119
      J=J+1
      IF(J.LE.7) GO TO 118
       GO TO 44
119   INN(J)='.'
       ENCODE(10,16,TMP) INN
117   J=1
47    J=J+1
      IF(J.GT.7) GO TO 49
      IF(INN(J).NE.'.') GO TO 47
      IF((INN(J+1).NE.'B').OR.(INN(J+2).NE.'N').OR.
     1(INN(J+3).NE.'K')) GO TO 49
      IBNK=1
      IF((IDCHAR.AND."200000000000).NE.0) GO TO 110
      WRITE(IDLG,48)
48    FORMAT('+BANK files must be read from the disk'/)
      GO TO 1
110   IF(INOUT.EQ.0) GO TO 49
      WRITE(IDLG,111)
111   FORMAT('+Bank files can not be used for output.'/)
      GO TO 1
49    FILNAM=TMP
112   IF(IN(I).NE.LEFBK) GO TO 71
C     %%%%%%%%%%%%%%%%%%%%%%%i( PROJECT NUMBER )%%%%%%%%%%%%%%%%%%%%%
      DO 50 J=1,10
50    INN(J)=' '
      J=1
      I=I+1
51    IF(IN(I).EQ.IRTBK) GO TO 56
      IF(IN(I).EQ.',') GO TO 58
      IF((IN(I).LT.'0').OR.(IN(I).GT.'7')) GO TO 54
      IF(J.GT.6) GO TO 52
      INN(J)=IN(I)
      J=J+1
      I=I+1
      GO TO 51
52    WRITE(IDLG,53)
53    FORMAT('+PROJECT or PROGRAMMER number cannont be longer'/
     1'  than 6 characters'/)
      GO TO 1
54    WRITE(IDLG,55) IN(I)
55    FORMAT('+Illegal character "',a1,'" in PROJECT-PROGRAMMMER',
     1' number'/)
      GO TO 1
56    WRITE(IDLG,57)
57    FORMAT('+ Comma missing between PROJECT and PROGRAMMER number'/)
      GO TO 1
58    IF(J.EQ.1) GO TO 65
60    IF(INN(10).NE.' ') GO TO 61
      DO 59 J=9,1,-1
59    INN(J+1)=INN(J)
      INN(1)=' '
      GO TO 60
61    ENCODE(10,16,TMP) INN
      DECODE(10,62,TMP) IPROJ
62    FORMAT(O10)
C     %%%%%%%%%%%%%%%%%%%%%%%%%%%%i( PROGRAMMER NUMBER )%%%%%%%%%%%%%%i
65    DO 63 J=1,10
63    INN(J)=' '
      J=1
      I=I+1
64    IF(IN(I).EQ.IRTBK) GO TO 66
      IF(IN(I).EQ.' ') GO TO 66
      IF(IN(I).EQ.IALT) GO TO 66
      IF((IN(I).LT.'0').OR.(IN(I).GT.'7')) GO TO 54
      IF(J.GT.6) GO TO 52
      INN(J)=IN(I)
      J=J+1
      I=I+1
      GO TO 64
66    IF(J.EQ.1) GO TO 92
67    IF(INN(10).NE.' ') GO TO 68
      DO 69 J=9,1,-1
69    INN(J+1)=INN(J)
      INN(1)=' '
      GO TO 67
68    ENCODE(10,16,TMP) INN
      DECODE(10,62,TMP) IPROG
92    IF(IN(I).NE.IRTBK) GO TO 91
      I=I+1
91    IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 71
      WRITE(IDLG,70)
70    FORMAT('+Nothing should follow the closing bracket for the',
     1' PROJECT-PROGRAMMER number'/)
      GO TO 1
C
C     @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C
C     $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
C
C     THIS PORTION DOES THE ACTUAL OPEN ALL PERTINENT DATA IS AVAILABLE
C     IF PROBLEMS EXIST THEY ARE IRONED OUT HERE.
C
71    IPN(1)=IPROJ
      IPN(2)=IPROG
      IERR=0
      IF(INOUT.EQ.0) CALL EXISTS(DEVNAM,FILNAM,IERR,IPROJ,IPROG)
      IF(IERR.EQ.0) GO TO 131
      WRITE(IDLG,72)
72    FORMAT('+File not found or protected'/)
      GO TO 1
131   IF(DEVN(IDEV).EQ.0) GO TO 73
      CLOSE(UNIT=IDEV)
      CALL DEVCHR(DEVN(IDEV),LCHAR)
      IF(DEST(IDEV).LT.-100) IFTW=1
      IF((LCHAR.AND."040000000000).EQ.0) GO TO 73
      ICOPS=-DEST(IDEV)
      IF(ICOPS.GT.100) ICOPS=ICOPS-100
      NPAGES=IPAGCT*ICOPS+3
      IF(IPAGCT.GT.0) CALL PRINTS(FILNM(IDEV),2,1,ICOPS,NPAGES)
      IF(IPAGCT.LT.0) CALL PRINTS(FILNM(IDEV),2,1,ICOPS)
      IPAGCT=0
73    IF(IBNK.EQ.1) GO TO 75
      IF(INOUT.EQ.0) OPEN(UNIT=IDEV,DEVICE=DEVNAM,FILE=FILNAM,
     1ACCESS='SEQIN',DIRECTORY=IPN)
      IF(INOUT.EQ.1) OPEN(UNIT=IDEV,DEVICE=DEVNAM,FILE=FILNAM,
     1ACCESS='SEQOUT',DIRECTORY=IPN)
      GO TO 76
75    OPEN(UNIT=IDEV,DEVICE=DEVNAM,FILE=FILNAM,ACCESS='RANDIN',
     1DIRECTORY=IPN,MODE='BINARY',RECORD SIZE=126)
76    DEVN(IDEV)=DEVNAM
      FILNM(IDEV)=FILNAM
      IPP(IDEV)=IPROJ*8**6+IPROG
      DEST(IDEV)=IBNK
      REALDV=' '
      IF((IDCHAR.AND."000010000000).NE.0) REALDV='TTY'
      IF((IDCHAR.AND."200000000000).NE.0) REALDV='DSK'
      IF(INOUT.EQ.0) GO TO 77
      DEST(IDEV)=-ICOPS
      IF(IFTW.EQ.1) DEST(IDEV)=-ICOPS-100
      IF(IFTW.EQ.1) OUTDV=REALDV
      IF((DEVN(IDEV).EQ.'LPT').AND.(IFTW.EQ.1)) OUTDV='LPT'
      IFTW=IFTW+1
77    IF(SETSW.EQ.1) GO TO 105
      RETURN
C
C     ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C     RUN TO ANOTHER BANK PROGRAM
C           CLOSE ALL OUTPUT FILES PRIOR TO THE RUN.
C
80    ENCODE(10,81,IN)(INN(J),J=2,5)
81    FORMAT('R ',4A1,4X)
      IN(3)=0
      DO 82 J=1,30
      IF(DEST(J).GE.0) GO TO 82
      CLOSE(UNIT=J)
      IF(DEVN(J).NE.'LPT') GO TO 82
      ICOPS=-DEST(J)
      IF(ICOPS.GT.100) ICOPS=ICOPS-100
      NPAGES=IPAGCT*ICOPS+3
      IF(IPAGCT.GT.0) CALL PRINTS(FILNM(J),2,1,ICOPS,NPAGES)
      IF(IPAGCT.LT.0) CALL PRINTS(FILNM(J),2,1,ICOPS)
82    CONTINUE
      CALL RUNUUO (IN)
C
C     +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C     >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>_
C
C     SAME WAS USED.
C
C
C
83    IF(DEVN(IDEV).NE.0) GO TO 87
      WRITE(IDLG,86)
86    FORMAT('+You must have answered this question in this',
     1' program previously to use "SAME" now.'/)
      GO TO 1
87    DEVNAM=DEVN(IDEV)
      FILNAM=FILNM(IDEV)
      IPROJ=IPP(IDEV)/8**6
      IPROG=IPP(IDEV)-IPROJ*8**6
      IBNK=0
      IF(DEST(IDEV).EQ.1) IBNK=1
      ICOPS=-DEST(IDEV)
      IF(ICOPS.GT.100) ICOPS=ICOPS-100
      CALL DEVCHR(DEVNAM,IDCHAR)
      IF(INOUT.EQ.1) CLOSE(UNIT=IDEV)
      IF((IDCHAR.AND."040000000000).NE.0) GO TO 130
      IF((IDCHAR.AND."000020000000).NE.0) BACKFILE IDEV
      GO TO 71
C
C     >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>_>>>>>>>>_>>>>_
C
C
C
C     ///////////////////////////////////////////////////////////////
C
C     FINI. FINISH, END OR CONTROL Z WAS USED.  CLOSE FILES AND 
C     REOPEN
C
C
90    DO 99 J=1,30
      IF(DEST(J).GE.0) GO TO 99
      CLOSE(UNIT=J)
      IF(DEVN(J).NE.'LPT') GO TO 99
      ICOPS=-DEST(J)
      IF(ICOPS.GT.100) ICOPS=ICOPS-100
      NPAGES=IPAGCT*ICOPS+3
      IF(IPAGCT.GT.0) CALL PRINTS(FILNM(J),2,1,ICOPS,NPAGES)
      IF(IPAGCT.LT.0) CALL PRINTS(FILNM(J),2,1,ICOPS)
99    CONTINUE
      CALL EXIT
C
C     /////////////////////////////////////////////////////////////
C
C
C     <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<^<<<<<<^
C
C     /OUTPUT OR /OUT USED.
C
C
100   IF(SETSW.EQ.0) GO TO 106
      WRITE(IDLG,107)
107   FORMAT('+You cannot do a /OUT while answering a /OUT'/)
      GO TO 1
106   DO 101 J=1,30
      IF(DEST(J).LT.-100) GO TO 103
101   CONTINUE
      WRITE(IDLG,102)
102   FORMAT(' No output defined yet'/)
      GO TO 1
103   LDEV=IDEV
      IDEV=J
      LNOUT=INOUT
      INOUT=1
      SETSW=1
      GO TO 1
105   SETSW=0
      IDEV=LDEV
      INOUT=LNOUT
      GO TO 1
C
C     >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C
C     ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::]
C
C     CONTINUE WAS USED.
C
C
140   IF(DEVN(IDEV).NE.0) GO TO 142
      WRITE(IDLG,141)
141   FORMAT('+To use the CONTINUE an input must have already been',
     1' defined.'/)
      GO TO 1
142   FILNAM=FILNM(IDEV)
      DEVNAM=DEVN(IDEV)
      IPROJ=IPP(IDEV)/8**6
      IPROG=IPP(IDEV)-IPROJ*8**6
      IBNK=0
      IF(DEST(IDEV).EQ.1) IBNK=1
      ICOPS=-DEST(IDEV)
      IF(ICOPS.GT.100) ICOPS=ICOPS-100
      CALL DEVCHR(DEVNAM,IDCHAR)
      IF(INOUT.EQ.1) GO TO 77
      GO TO 71
C
C     :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::]
C
C
C     ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
C
C     HELP
C
150   IF(INOUT.EQ.1) GO TO 155
      WRITE(IDLG,151)
151   FORMAT(
     1' The answer to this question defines where the program is'/
     1' to find the data.  It usually consists of a device, and'/
     1' possibly a file name with or without a PROJECT-PROGRAMMER'/
     1' number.  Devices may be specified by their physical'/
     1' or logical name followed by a colon (:).  If the'/
     1' device is a directory device (DSK, DTA), then a filename,'/
     1' extension and PROJECT-PROGRAMMER number may follow it.'/
     1' If the device used is a magtape or dectape, the tape'/
     1' must be mounted, and in the case of a magtape it must'/
     1' be positioned.'/'0DEFAULTS:'/
     1' (1) If no input devices is specified but a filename is'/
     1'     given, the default device will be DSK:.'/
     1' (2) If a device which requires a filename and extension'/
     1'     is specified, but no filename is given INPUT.DAT'/
     1'     will be used.'/
     1' (3) If no response is given (CARRIAGE RETURN is entered)'/
     1'     the default is TTY:.'/
     1' (4) If DSK: is specified as the input device, but no')
      WRITE(IDLG,152)
152   FORMAT(
     1'     PROJECT-PROGRAMMER number is used, the PROJECT-'/
     1'     PROGRAMMER number of the job is used.'/
     1'0EXAMPLES:'/'  DSK:DATA.DAT'/'  TEST.DAT[220,220]'/
     1'   MTA:'/
     1'0The following responses may also be used after the first'/
     1' response to this question.'/
     1' "CONTINUE" - (For MAGTAPE) Use the next set of data'/
     1' "SAME" - Use same device specifications as used before.'/
     1' "FINI" - End of run.'/
     1' "/PROG" - User may initiate the run of a bank program'/
     1'          (STP, BANK, TAB, FREQ, CORL, or REGR) from'/
     1'          this program.'/
     1' "/OUTPUT" - Redefine the output device, the program will'/
     1'             respond with "OUTPUT? ".'/)
      GO TO 1
155   WRITE(IDLG,157)
157    FORMAT(
     1'0The answer to this question defines the destination'/
     1' for the program''s results.  It usually consists of a device'/
     1' and possibly a filename with or without an extension.'/
     1' Devices may be indicated by their physical or'/
     1' logical name followed by a colon (:).  If the device is'/
     1' a directory device (DSK, DTA), then a filename,'/
     1' extension and PROJECT-PROGRAMMER number may follow it.'/
     1' If the device used is a magtape or dectape, the tape'/
     1' must be mounted, and in the case of the magtape, it must'/
     1' be positioned.  If the device is a lineprinter, the user'/
     1' may request multiple copies by following the "LPT:" with'/
     1' a "/COPIES:" and the number of copies desired (1-63).'/
     1'0DEFAULTS:'/
     1' (1) - If no input device is specified but a filename is'/
     1'       given, the default device will be DSK:')
      WRITE(IDLG,156)
156   FORMAT(
     1' (2) - If a device which requires a filename and extension"'/
     1'       is specified but no filename is given OUTPUT.DAT is'/
     1'       used.'/
     1' (3) - If no response is given (a CARRIAGE RETURN is entered),'/
     1'       the default is TTY:.'/
     1' (4) - If LPT: is spedified and no /COPEIS switch is used,'/
     1'       1 copy is assumed.'/'0EXAMPLES:'/
     1'  DSK:SAM.F4'/'  LPT:/COPIES:3'/'  MTA:'/)
      GO TO 1

      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
      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     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 FORM 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 PRIVILEGES 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.24.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
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 GETVAR(N,NAME,IVAR,IERR)
	COMMON /IOBLK/IDLG,IRSP,NDEVI,NDEVO,IDVI,IDVO,ICODE,IBNK,NAMI(2)
	COMMON /VARTMP/IDUM(72),ISAVE(5)
	DIMENSION NAME(1)
C
C
C	SUBROUTINE TO GET VARIABLE NAME OR NUMBER FROM TTY
C
C	N IS NUMBER OF VARIABLES
C	NAME IS VECTOR CONTAINING VARIABLES NAMES
C	IVAR IS VARIABLE NUMBER RETURNED
C	IERR IS: 0  OK
C	       : 1  ILLEGAL VARIABLE NAME
C	       :-1  ILLEAGEL VARIABLE NUMBER
C
C
	IERR=0
	READ(IDLG,100) (IDUM(I),I=1,10)
100	FORMAT(10A1)
	IF((IDUM(1).LT.'0').OR.(IDUM(1).GT.'9')) GOTO 1
C
C	INPUT IS VARIABLE NUMBER
C
	REREAD 101,IVAR
101	FORMAT(I)
	IF((IVAR.GE.1).AND.(IVAR.LE.N)) GOTO 999
	IERR=-1
	GOTO 999
C
C	INPUT IS VARIABLE NAME
C
1	IS=0
	DO 2 I=1,5
2	ISAVE(I)=' '
	I=0
3	I=I+1
	IF(I.GT.10) GOTO 4
	IF(IDUM(I).EQ.' ') GOTO 3
	IS=IS+1
	IF(IS.LE.5) ISAVE(IS)=IDUM(I)
	GOTO 3
C
C
4	IVAR=' '
	ENCODE(5,100,IVAR) ISAVE
	DO 5 I=1,N
	IF(NAME(I).NE.IVAR) GOTO 5
	IVAR=I
	GOTO 999
5	CONTINUE
	IERR=1
999	RETURN
	END
	SUBROUTINE GETLAB(NSIZE,NAME,NUM)
C
C	THIS SUBROUTINE WAS WRITTEN BY BERENICE HOUCHARD ON 1974
C
C	THE SUBROUTINE ACCEPTS EITHER THE TOTAL NUMBER OF VARIABLES IN
C	THE ANALYSIS OR A STRING OF VARIABLE NAMES TO BE ASSIGNED TO
C	THE VARIABLES AND HENCE IMPLICITLY DETERMINE THE TOTAL NUMBER OF
C	VARIABLES IN THE ANALYSIS.
C
C	A VARIABLE NAME CONSISTS OF ONE TO FIVE ALPHANUMERIC CHARACTERS
C	THE FIRST BEING NON-NUMERIC.  IT MAY NOT CONTAIN ANY OF THE
C	FOLLOWING SYMBOLS:
C
C		*  ?  -  /  ,  +  '  .  BLANK
C
C	SEVERAL RESERVED WORDS MAY NOT BE USED AS VARIABLE NAMES, THEY
C	ARE:  ALL  HELP  EMPTY  STOP  OBS
C
C
C
C	NSIZE=MAXIMUM NUMBER OF VARIABLES WHEN THIS ROUTINE
C	IS CALLED AND NSIZE= NUMBER OF VARIABLES ON RETURNING
C
C	NAME CONTAINS ASCII NAMES OF VARIABLES (A5)
C	NUM CONTAINS NUMBER OF POSTION IN LIST
C
C
	DIMENSION NAME(1),NUM(1),IRSYM(9),IRWRD(5)
	COMMON/IOBLK/IDLG,ICC,INP,IOUT,IO2,IO3,ICODE,IBNK,NAMI(2)
	COMMON /VARTMP/IDUM(72),ISAVE(5)
C
C
C
C
C
C
	DATA IRSYM/' ','-','.','*','/','?','"','+',';'/
	DATA IRWRD/'ALL','HELP','EMPTY','STOP','OBS'/
	DATA IALT,IGRT/"155004020100,'$'/
C
C
	MAX=NSIZE
	DO 1122 I=1,MAX
1122	NUM(I)=I
C
1	WRITE(IDLG,10)
10	FORMAT(' ENTER # OF VARIABLES OR VARIABLE NAMES'/)
	NSIZE=0
11	DO 110 I=1,5
110	ISAVE(I)=' '
	CALL GES(IDUM,72,IEND)
	NPT=1
	IF (IEND.NE.2) GO TO 111
112	IF (ICODE) 1,1,901
111	IF ((IDUM(1).EQ.'H').AND.(IDUM(2).EQ.'E').AND.(IDUM(3).EQ.'L')
     1 .AND.(IDUM(4).EQ.'P')) GO TO 90
	L=IDUM(1)
	IF ((L.LT.'0').OR.(L.GT.'9')) GO TO 20
C
C	# OF VARIABLES ENTERED
C
	DO 1230 I=10,1,-1
	IF (IDUM(I).NE.' ') GO TO 124
1230	CONTINUE
124	J=I
	IF ((IDUM(I).EQ.IALT).OR.(IDUM(I).EQ.IGRT)) J=I-1
	DO 123 I=1,J
123	ISAVE(I)=IDUM(I)
12	IF (ISAVE(5).NE.' ') GO TO 121
	DO 120 I=4,1,-1
120	ISAVE(I+1)=ISAVE(I)
	ISAVE(1)=' '
	GO TO 12
121	ENCODE(5,151,L) ISAVE
	DECODE(5,122,L) NSIZE
122	FORMAT(I5)
C
C	GENERATE VARIABLE NUMBERS
C
	IF (NSIZE.LE.0) GO TO 19
	IF (NSIZE.GT.MAX) GO TO 191
	DO 13 I=1,NSIZE
	DO 14 J=1,5
14	ISAVE(J)=' '
	ENCODE(5,150,NAME(I)) I
150	FORMAT(I5)
	DECODE(5,151,NAME(I)) ISAVE
151	FORMAT(5A1)
16	IF (ISAVE(1).NE.' ')  GO TO 18
	DO 17 K=1,4
17	ISAVE(K)=ISAVE(K+1)
	ISAVE(5)=' '
	GO TO 16
18	ENCODE(5,151,NAME(I)) ISAVE
	NUM(I)=I
13	CONTINUE
	RETURN
C
C
C
19	WRITE(IDLG,190) NSIZE
190	FORMAT('-ERROR:  NUMBER OF VARIABLES ',I6,' OUTSIDE ALLOWABLE
     1 RANGE,'/9X,'TRY AGAIN'/)
	IF (ICODE.GE.0) GO TO 1
	CALL EXIT
191	WRITE(IDLG,192)
192	FORMAT('-ERROR:  VARIABLE NAME LIST TOO LONG, CONTACT COMPUTER
     1 CENTER STAFF'/9X,'FOR HELP'/)
	CALL EXIT
C
C	VARIABLE NAMES ENTERED
C
20	DO 200 LAST=72,1,-1
	IF (IDUM(LAST).NE.' ') GO TO 201
200	CONTINUE
	GO TO 40
201	ISUB=0
	N=0
	DO 21 K=1,LAST
	L=IDUM(K)
	IF ((L.EQ.',').OR.(L.EQ.IALT).OR.(L.EQ.IGRT)) GO TO 30
	IF (L.EQ.' ') GO TO 21
	DO 22 I=2,9
	IF (L.EQ.IRSYM(I)) GO TO 23
22	CONTINUE
	IF (N.GE.5) GO TO 21
	N=N+1
	ISAVE(N)=L
	GO TO 21
C
C
C
23	WRITE(IDLG,230) L
230	FORMAT('-ERROR:  RESERVED CHARACTER "',A1,'" IN VARIABLE NAME'/)
	GO TO 25
24	WRITE(IDLG,240) NAME(NSIZE)
240	FORMAT('-ERROR:  VARIABLE NAME "',A5,'" IS RESERVED'/)
25	IF (ICODE.LT.0) CALL EXIT
	WRITE(IDLG,250)
250	FORMAT('+RE-ENTER THE LINE'/)
	NSIZE=NSIZE-ISUB
	GO TO 11
C
C
C
30	IF ((K.EQ.1).AND.((L.EQ.IALT).OR.(L.EQ.IGRT))) GO TO 40
	IF (N.LE.0) GO TO 21
301	IF ((ISAVE(1).LT.'0').OR.(ISAVE(1).GT.'9')) GO TO 31
	WRITE(IDLG,300) ISAVE
300	FORMAT('-ERROR:  VARIABLE NAME "',5A1,'" STARTS WITH A NUMBER'/)
	GO TO 25
C
C
C
31	NSIZE=NSIZE+1
	IF (NSIZE.GT.MAX) GO TO 191
	ISUB=ISUB+1
	NAME(NSIZE)=0
	ENCODE(5,151,NAME(NSIZE)) ISAVE
	DO 32 I=1,5
	IF (NAME(NSIZE).EQ.IRWRD(I)) GO TO 24
32	CONTINUE
	GO TO (330,1111),NPT
330	N=0
	DO 33 I=1,5
33	ISAVE(I)=' '
	NUM(NSIZE)=NSIZE
	IF ((L.EQ.IALT).OR.(L.EQ.IGRT)) GO TO 40
21	CONTINUE
	IF (N.LE.0) GO TO 1111
	NPT=2
	GO TO 301
C
C
C
40	IF (NSIZE-1) 19,411,410
410	DO 41 I=1,NSIZE-1
	DO 41 J=I+1,NSIZE
	IF (NAME(I).EQ.NAME(J)) GO TO 42
41	CONTINUE
411	RETURN
C
C
C
42	WRITE(IDLG,420) NAME(I),I,J
420	FORMAT('-ERROR:  VARIABLE NAME "',A5,'" IS USED IN VARIABLES ',
     1 I5,' AND ',I5)
	IF (ICODE.LT.0) CALL EXIT
	WRITE(IDLG,421)
421	FORMAT('-ENTER CORRECTION IN THE ORDER:  VARIABLE #, COMMA,
     1 VARIABLE NAME OR A - TO DELETE'/)
	READ(ICC,422) I,L
422	FORMAT(I,A5)
	IF (L.EQ.'-    ') GO TO 43
	NAME(I)=L
	NUM(I)=I
	GO TO 40
43	DO 44 J=I+1,NSIZE
	NAME(J-1)=NAME(J)
44	NUM(J-1)=NUM(J)
	NSIZE=NSIZE-1
	GO TO 40
C
C	ONLY EXPECT MORE NAMES IF LAST CHARACTER IS COMMA
C
1111	IF(IDUM(LAST).NE.',') RETURN
	GOTO 11
C
C	HELP
C
90	WRITE(IDLG,900)
900	FORMAT('-THIS LINE DEFINES DIRECTLY AND INDIRECTLY THE NUMBER OF
     1 VARIABLES TO'/' BE USED IN THE ANALYSIS.  IF A NUMBER IS ENTERED,
     2 IT IS ASSUMED TO BE'/' THE NUMBER OF VARIABLES AND VARIABLE NAME
     3 OPTION IS NOT SELECTED.'//' IF A VARIABLE NAME LIST IS ENTERED,
     4 THE NUMBER OF VARIABLES IS'/' COUNTED FROM THE LIST.  VARIABLE
     5 NAME LIST SHOULD CONFORM TO THE'/' FOLLOWING RULES:'//
     6 ' (1)  THE LIST IS COMPOSED OF 1 OR MORE LINES.  AN ALTMODE OR
     7 BLANK'/6X,'LINE MUST FOLLOW IMMEDIATELY AFTER THE LAST VARIABLE
     8 NAME'/6X,'IS ENTERED.'//' (2)  VARIABLE NAME IS MADE OF 1 TO 5
     9 ALPHANUMERIC CHARACTERS, THE'/6X,'FIRST BEING NON-NUMERIC.'//6X,
     1 'THE NAMES MAY NOT CONTAIN ANY OF THE FOLLOWING SYMBOLS:'// 6X,
     2 '*      ?      -      /      ,      +      ''      .      BLANK'/
     4/ 6X,'NOR MAY BE ANY OF THE RESERVED WORDS:'//
     5 6X,'ALL    HELP   EMPTY  STOP   OBS'/)
	IF (ICODE.GE.0) GO TO 1
901	CALL EXIT
	END
	SUBROUTINE GETLST(N,NLST,NAME,INDEX)
	DIMENSION NAME(1),INDEX(1)
	COMMON/IOBLK/IDLG,ICC,INP,IOUT,IO2,IO3,ICODE,IBNK,NAMI(2)
	COMMON /VARTMP/IDUM(72),ISAVE(5)
	DATA IALT,IDOL/"155004020100, '$'/
C
C
100	CALL GES(IDUM,72,IRET)
	IF(IRET.EQ.2) CALL EXIT
	IF ((IDUM(1).EQ.'H').AND.(IDUM(2).EQ.'E').AND.(IDUM(3).EQ.'L')
     1.AND.(IDUM(4).EQ.'P')) GO TO 90
	IF ((IDUM(1).EQ.'S').AND.(IDUM(2).EQ.'A').AND.(IDUM(3).EQ.'M')
     1.AND.(IDUM(4).EQ.'E')) RETURN
C
C
	NLST=0
	IDASH=1
12	NF=0
	DO 13 LAST=72,1,-1
	IF (IDUM(LAST).NE.' ') GO TO 20
13	CONTINUE
14	RETURN
C
C
20	I=0
21	DO 210 J=1,5
210	ISAVE(J)=' '
	IS=0
C
22	I=I+1
	IF (I.LE.LAST) GO TO 220
	L=' '
	IF (IS) 321,321,230
C
C
220	L=IDUM(I)
	IF (L.EQ.' ') GO TO 22
	IF ((L.EQ.',').OR.(L.EQ.'-').OR.(L.EQ.IALT).OR.(L.EQ.IDOL))
     1  GO TO 23
	IS=IS+1
	IF (IS.LE.5) ISAVE(IS)=L
	GO TO 22
C
C
23	IF (IS.LE.0) GO TO 22
230	IF ((ISAVE(1).LE.'0').OR.(ISAVE(1).GT.'9')) GO TO 40
C
C	#'S
C
24	IF (ISAVE(5).NE.' ') GO TO 26
	DO 25 J=4,1,-1
25	ISAVE(J+1)=ISAVE(J)
	ISAVE(1)=' '
	GO TO 24
C
C
26	ENCODE(5,11,K) ISAVE
11	FORMAT(72A1)
	DECODE(5,260,K) NUM
260	FORMAT(I5)
	IF ((NUM.GE.1).AND.(NUM.LE.N)) GO TO 30
	WRITE(IDLG,27) NUM
27	FORMAT('-ERROR:  VARIABLE NUMBER ',I5,' OUTSIDE ALLOWABLE
     1 RANGE, RE-ENTER THE LINE'//)
	IF (ICODE.GE.0) GO TO 33
	CALL EXIT
C
C	'-'
C
30	IF (L.NE.'-') GO TO (31,34),IDASH
	IDASH=2
	NF=NF+1
	INDEX(NF)=NUM
	GO TO 21
C
C
31	NF=NF+1
	INDEX(NF)=NUM
32	IF ((I.LT.LAST).AND.(L.NE.IALT).AND.(L.NE.IDOL)) GO TO 21
321	NLST=NLST+NF
	IF ((L.EQ.IALT).OR.(L.EQ.IDOL).OR.(L.NE.',')) RETURN
C
C
33	READ(ICC,11,END=14) IDUM
	GO TO 12
C
C
34	DO 35 J=INDEX(NLST+NF)+1,NUM
	NF=NF+1
35	INDEX(NF)=J
	IDASH=1
	GO TO 32
C
C	NAMES
C
40	K=' '
	ENCODE(5,11,K) ISAVE
	IF ((K.EQ.'ALL').OR.(K.EQ.'*')) GO TO 42
	DO 41 J=1,N
	IF (NAME(J).NE.K) GO TO 41
	NUM=J
	GO TO 30
41	CONTINUE
	WRITE(IDLG,410) K
410	FORMAT('-ERROR:  VARIABLE ',A5,' DOES NOT EXIST, RE-ENTER
     1 THE LINE'/)
	IF (ICODE.GE.0) GO TO 33
	CALL EXIT
C
C
42	DO 43 I=1,N
43	INDEX(I)=I
	NLST=N
	RETURN
C
C	HELP
C
90	WRITE(IDLG,91)
91	FORMAT('-EITHER VARIABLE NAMES OR VARIABLE NUMBERS MAY BE USED
     1 TO ENTER THE'/' VARIABLES.  MORE
     2 THAN ONE NAME OR'/' NUMBER MAY OCCUPY A LINE AND ARE SEPARATED
     3 BY COMMAS.  AN ALTMODE,'/' DOLLAR SIGN, CONTROL Z OR BLANK LINE
     4 MUST BE USED TO TERMINATE THE'/' ENTRIES.  RANGES MAY BE
     5 SPECIFIED BY ENTERING THE TWO EXTREMES'/' SEPARATED BY A MINUS
     6 SIGN ("-").  FOR EXAMPLE:'/
     7 ' 1,AGE,10-12$'//)
	IF (ICODE.GE.0) GO TO 100
	CALL EXIT
	END
	SUBROUTINE CALC(ANS,MODE,IERR)
C
C	THIS PROGRAM - CALCF.F4 - IS DESIGNED TO PROVIDE
C	BOTH AN IMMEDIATE CALCULATOR AND VARIABLE STORAGE TO
C	ANY PROGRAM THAT CAN HANDLE REAL SCALAR VALUES.
C
C	IT IS A COMBINATION OF SAM ANEMA'S CALCULATOR AND RUSS
C	BARR'S STORAGE PACKAGE.
C
C	ALL EXTERNAL ROUTINES CALLED BY THIS PACKAGE ARE IN
C	THE FILE - NSTORE.F4
C
C	FINAL MODIFICATIONS FOR NSTORE
C	DATE: 21-OCT-75 - RRB.
C
C	MODE=0	ANSWER IS TO BE PRINTED
C	    =1	ANSWER IS NOT TO BE PRINTED
C
C	IERR=0	IMMEDIATE CALCULATION, ANSWER PRINTED.
C	    =1	ASSIGNMENT MADE
C	    =2	INPUT OR EVAL ERROR, MESSAGE PRINTED.
C	    =3	UNDEFINED NAME, NO MESSAGE.
C	    =4	EOF ON INPUT, MESSAGE.
C
	DOUBLE PRECISION B,FUN,WORDS(2),RESULT
	DIMENSION IC(10),IN(80),ITY(50),IV(50)
	DIMENSION V(0/9),IW(12),FUN(16),L1(50),L2(50),CONST(50),IH(21)
	DOUBLE PRECISION ALLOC
	DIMENSION HLLOC(1)
	COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
	EQUIVALENCE (ALLOC,HLLOC)
	COMMON/CALDAT/IN,WORDS,RESULT,NR
	DATA IC/'(','+','-','/','*',' ',')','.','=','&'/
	DATA V/0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0/
	DATA FUN/'ATAN   ','TANH   ','COSH   ','SINH   ','COS   ',
     1'SIN   ','SQRT   ','ALOG10   ','ALOG   ','EXP   ','ACOS   ',
     2'ASIN   ','ABS   ','INT   ','RAN   ','SETRAN   '/
	DATA IH/6,5,5,4,4,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2,7/
	DATA IDLG,IRSP,NC,NF/-1,-4,10,16/
	ANS=0
	NA=0
	IERR=0
C	WRITE(IDLG,34)
34	FORMAT('0*',$)
	READ(IRSP,36,END=998)IN
36	FORMAT(80A1)
	IR=0
	K=0
	I=0
	IDP=0
	XM1=1.
	NW=0
	C=0.
	K=0
	NF=16
	N1=0
	N2=0
10	I=I+1
	IF(I.GT.80)GO TO 501
	IF(IN(I).EQ.IC(6))GO TO 10
	DO 50 J=1,NC
	IF(IC(J).EQ.IN(I))GO TO 1000
50	CONTINUE
	IF(IN(I).LT.'0'.OR.IN(I).GT.'9')GO TO 51
	J=NC+1
	GO TO 1000
51	IF(IN(I).LT.'A'.OR.IN(I).GT.'Z')GO TO 99
	J=NC+2
1000	IF(IDP.NE.3)GO TO 1001
	IF(J.EQ.1.OR.J.GT.NC)GO TO 1001
1002	ENCODE(11,2000,WORDS)(IW(KK),KK=1,NW),(IC(6),KK=NW+1,12)
2000	FORMAT(12A1)
	NW=0
	IF(J.EQ.9)GO TO 2001
	LOC=LOCNAM(WORDS,KIND,KLAS,NROW,NCOL)
	IF(LOC.EQ.0)GO TO 992
	IF(KIND.NE.1.OR.KLAS.NE.0)GO TO 994
	C=HLLOC(LOC)
	IDP=2
	GO TO 1001
2001	IR=1
C	NOT AN ERROR, AN ASSIGNMENT FLAG.
	IERR=1
	RESULT=WORDS(1)
	IDP=0
	GO TO 10
1001	IF(I.GT.80)GO TO 501
	GO TO (1100,102,102,102,102,10,101,103,99,1007,104,105),J
	GO TO 10
1007	READ(IRSP,36,END=998)IN
	I=0
	GO TO 10
1100	IF(IDP.NE.0)GO TO 440
	K=K+1
	ITY(K)=1
	GO TO 10
101	IF(IDP.NE.0)GO TO 440
	K=K+1
	ITY(K)=2
	GO TO 10
102	IF(IDP.NE.0)GO TO 440
	IF(ITY(K).NE.3)GO TO 1102
	IF(J.EQ.5)GO TO 1103
	IF(J.EQ.4)GO TO 99
	K=K+1
	ITY(I)=3
	IV(K)=J+5
	GO TO 10
1103	IF(IV(K).NE.5)GO TO 99
	IV(K)=6
	GO TO 10
1102	K=K+1
	ITY(K)=3
	IV(K)=J
	GO TO 10
103	IDP=2
	GO TO 10
104	IF(IDP.GT.2)GO TO 105
	IF(IDP.EQ.2)GO TO 106
	IDP=1
	C=C*10.+V((IN(I).AND."74000000000)/"4000000000)
	GO TO 10
106	XM1=XM1*.1
9123	FORMAT(I)
	C=C+V((IN(I).AND."74000000000)/"4000000000)*XM1
	GO TO 10
105	NW=NW+1
	IF(NW.GT.10)NW=11
	IW(NW)=IN(I)
	IDP=3
	GO TO 10
440	IF(IDP.GT.2)GO TO 441
	IDP=0
	NA=NA+1
	CONST(NA)=C
	XM1=1.
	C=0.
	K=K+1
	ITY(K)=4
	IV(K)=NA
	GO TO 1001
441	B=' '
	IF(NW.GT.10)NW=10
	ENCODE(10,442,B)(IW(L),L=1,NW)
442	FORMAT(10A1)
	NW=0
	DO 443 L=1,NF
	IF(B.EQ.FUN(L))GO TO 444
443	CONTINUE
	GO TO 99
444	K=K+1
	ITY(K)=3
	IV(K)=L+8
	IDP=0
	GO TO 1001
891	WRITE(IDLG,892)
892	FORMAT(/,' PROBLEM WITH SUBROUTINE EVAL.',/)
	IERR=2
	GO TO 131
99	WRITE(IDLG,991)
991	FORMAT(' BAD STATEMENT.',/)
	IERR=2
	GO TO 131
992	CONTINUE
C	WRITE(IDLG,993)WORDS(1)
993	FORMAT(/,1X,A10,' IS NOT DEFINED',/)
	IERR=3
	GO TO 131
994	WRITE(IDLG,995)KIND,KLAS,WORDS(1)
995	FORMAT(/,' WRONG KIND(',I2,') OR KLAS(',I1,') FOR ',A10,/)
	IERR=2
	GO TO 131
996	WRITE(IDLG,997)RESULT
997	FORMAT(/,' ERROR ATTEMPTING TO STORE ',A10,/)
	IERR=2
	GO TO 131
998	WRITE(IDLG,999)
999	FORMAT(/,' END OF FILE ON INPUT IN CALC.',/)
	IERR=4
	GO TO 131
501	IF(IDP.GT.2)GO TO 1002
	IF(IDP.NE.0)GO TO 440
D	WRITE(IDLG,9898)(ITY(II),II=1,10),(IV(II),II=1,10)
D9898	FORMAT(1X,10I2)
	K=K+1
	ITY(K)=3
	IV(K)=21
	DO 110 I=1,K
	GO TO (100,120,140,160),ITY(I)
100	N1=N1+1
	L1(N1)=1
	GO TO 110
120	IOP=L1(N1)
	N1=N1-1
	IF(IOP.EQ.1)GO TO 110
	IF(IOP.GT.6)GO TO 122
	C=CONST(L2(N2))
	N2=N2-1
122	IF(IOP.EQ.1)GO TO 891
	CALL EVAL(IOP,C,ANS)
	GO TO 120
140	IF(N1.EQ.0)GO TO 141
	IF(IH(L1(N1)).GT.IH(IV(I)))GO TO 141
	IOP=L1(N1)
	N1=N1-1
	IF(IOP.GT.6)GO TO 142
	C=CONST(L2(N2))
	N2=N2-1
142	IF(IOP.EQ.1)GO TO 891
	CALL EVAL(IOP,C,ANS)
	GO TO 140
141	N1=N1+1
	L1(N1)=IV(I)
	IF(IV(I).GT.6)GO TO 110
	N2=N2+1
	NA=NA+1
	CONST(NA)=ANS
	L2(N2)=NA
	GO TO 110
160	ANS=CONST(IV(I))
110	CONTINUE
	IF(N1.GT.1.OR.N2.GT.1)GO TO 99
	IF(IR.EQ.0)GO TO 111
	LOC=INCLRS(RESULT,2,0,1,1)
	IF(LOC.LE.0)GO TO 996
	HLLOC(LOC)=ANS
	GO TO 131
111	IF(MODE.EQ.0)WRITE(IDLG,20)ANS
20	FORMAT(1X,1PE)
	LOC=INCLRS('ANSWER  ',2,0,1,1)
	IF(LOC.LE.0)GO TO 996
	HLLOC(LOC)=ANS
131	RETURN
	GO TO 131
	END
	SUBROUTINE EVAL(IOP,C,ANS)
	GO TO (40,2,3,4,5,6,40,8,9,10,11,12,13,14,15,16,17,18,19,20,
     #21,22,23,24),IOP
2	ANS=ANS+C ; GO TO 40
3	ANS=C-ANS ; GO TO 40
4	ANS=C/ANS ; GO TO 40
5	ANS=C*ANS ; GO TO 40
6	ANS=C**ANS ; GO TO 40
8	ANS=-ANS ; GO TO 40
9	ANS=ATAN(ANS) ; GO TO 40
10	ANS=TANH(ANS) ; GO TO 40
11	ANS=COSH(ANS) ; GO TO 40
12	ANS=SINH(ANS) ; GO TO 40
13	ANS=COS(ANS) ; GO TO 40
14	ANS=SIN(ANS) ; GO TO 40
15	ANS=SQRT(ANS) ; GO TO 40
16	ANS=ALOG10(ANS) ; GO TO 40
17	ANS=ALOG(ANS) ; GO TO 40
18	ANS=EXP(ANS) ; GO TO 40
19	ANS=ACOS(ANS) ; GO TO 40
20	ANS=ASIN(ANS) ; GO TO 40
21	ANS=ABS(ANS) ; GO TO 40
22	ANS=INT(ANS) ; GO TO 40
23	ANS=RAN(0) ; GO TO 40
24	CALL SETRAN(INT(ANS)) ; ANS=0 ; GO TO 40
40	RETURN
	END
C	NSTORE
C	======
C
C	A SIMPLIFIED NAMED STORAGE(*) PACKAGE FOR THE PDP-10
C	----------------------------------------------------
C
C	WRITTEN BY RUSSELL R. BARR III, WESTERN MICHIGAN UNIVERSITY
C	COMPUTER CENTER, DATE: 9-OCT-75.
C	(*) PORTIONS OF THIS PACKAGE ARE BASED ON "NAMED STORAGE-360",
C	WRITTEN BY STANLEY COHEN OF ARGONNE NATIONAL LABORATORIES.
C
C	PURPOSE
C	-------
C	TO PROVIDE A METOD OF STORING AND RETRIEVING (IN CORE) DATA GROUPS
C	DURING THE COURSE OF A PROGRAM RUN IN A MANNER WHICH A USER MAY ASSIGN
C	MNEMONIC LABELS RATHER THAN ABSOLUTE OR RELATIVE ADDRESSES.
C	FURTHER, DECRIPTIVE DATA IS STORED IN A MANNER WHICH IS TRANSPARENT
C	TO THE USER.
C
C	ROUTINES
C	--------
C
C	SUBROUTINE SETSTR - 'SET UP STORAGE'
C	FUNCTION LOCNAM - 'LOCATE NAMED OBJECT'
C	FUNCTION INCLRS - 'I NOT CLEAR, RESERVE'
C	FUNCTION IFREE - 'I FREE SPACE'
C	SUBROUTINE SDUMP - 'FORMATTED STORAGE DUMP'
C
C	FORM OF DATA "CHUNKS"
C	--------------------
C
C
C	EVEN NUMBERED           ********  \
C  	WORDS------------------>* NWDS *  \  ;SIZE OF ("CHUNK"-1)
C	ODD NUMBERED     ***************  \
C	WORDS----------->*    ANAME    *  \  ;ANY NON-ZERO 72BIT CONFIG.
C	                 ***************  \
C	                 * KIND * KLAS *  \  ;SEE NOTE (1)
C	                 ***************  \
C	                 * NROW * NCOL *  \
C	                 ***************  \
C	LOCA OR LOCI---->*             *   \
C	(AS APPROP. TO   * DATA WORDS  *    >NWDS(# OF S.P. WORDS NOT
C	DATA TYPE)       *             *   /  INCLUDING SECOND NWDS)
C	                 ***************  /
C	                 * NWDS *
C	                 ********
C
C	FLOW CHARTS
C	-----------
C
C                ********************************************
C                *                USER ROUTINES             *
C                ********************************************
C                 :     :            :      :	      :
C         **********   **********    :      :     *********
C         * SETSTR *   * INCLRS *    :      :     * SDUMP *
C         **********   **********    :      :     *********
C                              :     :      :
C                             *********     :
C                             * IFREE *     :
C                             *********     :
C                                    :      :
C                                   **********
C                                   * LOCNAM *
C                                   **********
C
C
C	NOTE (1)	KIND =	1 - INTEGER*4
C				2 - REAL*4
C				3 - REAL*8
C
C			KLAS =	0 - SCALAR
C				1 - VECTOR
C				2 - MATRIX
C*ID*SETSTR
	SUBROUTINE SETSTR(NWDS)
C	SETUP STORAGE
	DOUBLE PRECISION ANAME,ALLOC
	DIMENSION ILLOC(1)
	COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
	EQUIVALENCE(ILLOC,ALLOC)
C
	INIT=2
	NEXT=2
	LAST=(NWDS-1).OR.1
	NWDSP=LAST-INIT
	ILLOC(INIT)=NWDSP
	ILLOC(LAST)=NWDSP
	RETURN
	END
C*ID*LOCNAM
	FUNCTION LOCNAM(ANAME,KIND,KLAS,NROW,NCOL)
C
C	FIND NAMED OBJECT, RETURN ITS PARAMETERS AND LOCATION
C
C	FUNC. RETURN VALUES:	>0 LOC OF DATA
C				=0 NOT FOUND
C				<0 DEFECTIVE STORAGE
C
	DOUBLE PRECISION ANAME,ALLOC
	DIMENSION ILLOC(1)
	COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
	EQUIVALENCE (ILLOC,ALLOC)
C
	I=INIT
	LOCNAM=0
C	STORAGE EMPTY?
	IF(INIT.EQ.NEXT)GO TO 190
100	NWDS=ILLOC(I)
	IF(NWDS.LE.0)GO TO 9001
	IF(ILLOC(I+NWDS).NE.NWDS)GO TO 9001
	LOCNA=I/2+1
	IF(ANAME.NE.ALLOC(LOCNA))GO TO 200
	KIND=ILLOC(I+3)
	KLAS=ILLOC(I+4)
	NROW=ILLOC(I+5)
	NCOL=ILLOC(I+6)
	IF(KIND.LE.2)LOCNAM=I+7
	IF(KIND.GE.3)LOCNAM=I/2+4
190	RETURN
C	KEEP SEARCHING
200	I=I+NWDS+1
	IF(I.LT.NEXT)GO TO 100
C	CAN'T FIND IT
	GO TO 190
C	DEFECTIVE STORAGE
9001	LOCNAM=-1
	GO TO 190
	END
C*ID*INCLRS
	FUNCTION INCLRS(ANAME,KIND,KLAS,NROW,NCOL)
C
C	MAKE NEW OBJECT(DELETE OBJECT OF SAME NAME FIRST)
C
C	FUNC. RETURN VALUES:	>0 LOC OF DATA
C				=0 NOT ENOUGH SPACE
C				<0 DEFECTIVE STORAGE
C
	DOUBLE PRECISION ANAME,ALLOC
	DIMENSION ILLOC(1)
	COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
	EQUIVALENCE (ILLOC,ALLOC)
C
	IDP=2
	IF(KIND.LT.3)IDP=1
	NWDSP=(NROW*NCOL*IDP+1).OR.1
C	EXIST?
	LOC=IFREE(ANAME)
	IF(LOC.LT.0)GO TO 9001
	NLEFT=ILLOC(NEXT)
110	IF(NLEFT.LT.NWDSP+7)GO TO 9002
C	CREATE AREA REQUESTED
	NWDSP6=NWDSP+6
	ILLOC(NEXT)=NWDSP6
	ILLOC(NEXT+NWDSP6)=NWDSP6
	LOCNA=NEXT/2+1
	ALLOC(LOCNA)=ANAME
	ILLOC(NEXT+3)=KIND
	ILLOC(NEXT+4)=KLAS
	ILLOC(NEXT+5)=NROW
	ILLOC(NEXT+6)=NCOL
	INCLRS=NEXT+7
	IF(IDP.EQ.2)INCLRS=LOCNA+3
C	CLEAN UP THE FREE CHUNK
	NEXT=NEXT+NWDSP+7
	NLEFT=LAST-NEXT
	ILLOC(NEXT)=NLEFT
	ILLOC(LAST)=NLEFT
190	RETURN
C	DEFECTIVE STORAGE
9001	INCLRS=-1
	GO TO 190
C	NOT ENOUGH SPACE
9002	INCLRS=0
	GO TO 190
	END
C*ID*IFREE
	FUNCTION IFREE(ANAME)
C
C	DELETE NAMED OBJECT AND RESTORE SPACE TO POOL
C
C	FUNC. RETURN VALUES:	>=0 TOTAL FREE SPACE
C				    (LAST-NEXT)
C				<0  DEFECTIVE STORAGE
C
C	IF(ANAME=0)RETURN FREE SPACE SIZE ONLY
	DOUBLE PRECISION ANAME,ALLOC
	DIMENSION ILLOC(1)
	COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
	EQUIVALENCE (ILLOC,ALLOC)
C
	IF(ANAME.EQ.0.D0)GO TO 200
	LOC=LOCNAM(ANAME,KIND,KLAS,NROW,NCOL)
	IF(LOC)9001,200,100
C	EXISTS
100	IF(KIND.LE.2)LOC=LOC-7
	IF(KIND.GE.3)LOC=LOC*2-8
C	DOWN SHIFT
	NWDS=ILLOC(LOC)
C	TOP OF LIST?
	IF(NEXT.EQ.LOC+NWDS+1)GO TO 190
	DO 110 I=LOC,NEXT-2-NWDS
110	ILLOC(I)=ILLOC(I+NWDS+1)
190	NEXT=NEXT-NWDS-1
	IFREE=LAST-NEXT
	ILLOC(NEXT)=IFREE
	ILLOC(LAST)=IFREE
	NEXTA=(NEXT+2)/2
	ALLOC(NEXTA)=0
	RETURN
200	IFREE=LAST-NEXT
201	RETURN
C	DEFECTIVE STORAGE
9001	IFREE=-1
	GO TO 201
	END
C*ID*SDUMP
	SUBROUTINE SDUMP(IERR)
C
C	FORMATED DUMP OF STORAGE
C
C	IERR RETURNED AS:	=0	NO ERROR
C				>0	DEFECTIVE STORAGE AT IERR
C
	DOUBLE PRECISION ANAME,ALLOC
	DIMENSION ILLOC(1),HLLOC(1)
	COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
	EQUIVALENCE (ALLOC,HLLOC,ILLOC)
C
	IERR=0
	IF(INIT.EQ.NEXT)GO TO 300
	I=INIT
100	NWDS=ILLOC(I)
	IF(NWDS.LE.0)GO TO 9001
	IF(ILLOC(I+NWDS).NE.NWDS)GO TO 9001
	KIND=ILLOC(I+3)
	KLAS=ILLOC(I+4)
	NROW=ILLOC(I+5)
	NCOL=ILLOC(I+6)
	LOCNA=I/2+1
	IF(KIND.GE.3)GO TO 140
	LOCDAT=I+6
	IF(KIND.NE.1)GO TO 120
	TYPE 102,ALLOC(LOCNA),(ILLOC(LOCDAT+J),J=1,NROW*NCOL)
102	FORMAT(1X,A10,1X,3I15,/,(12X,3I15))
	GO TO 200
120	TYPE 122,ALLOC(LOCNA),(HLLOC(LOCDAT+J),J=1,NROW*NCOL)
122	FORMAT(1X,A10,1X,3F,/(12X,3F))
	GO TO 200
140	LOCDAT=I/2+3
	TYPE 142,ALLOC(LOCNA),(ALLOC(LOCDAT+J),J=1,NROW*NCOL)
142	FORMAT(1X,A10,1X,2D25.15,/,(12X,2D25.15))
200	I=I+NWDS+1
	IF(I.LT.NEXT)GO TO 100
	RETURN
300	TYPE 302
302	FORMAT(' STORAGE EMPTY')
	RETURN
9001	TYPE 9002,I
9002	FORMAT(' ERROR IN STORAGE AT LOC ',I5)
	IERR=I
	RETURN
	END