Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-10 - 43,50521/aplb10.for
There are 4 other files named aplb10.for in the archive. Click here to see a list.
C	APPLICATIONS MODIFICATION HISTORY -- APLB10.FOR
C
C	#1
C	#2	24-OCT-77	MTO
C	#3	27-NOV-78	WG
C	#4	12-JAN-79	RRB
C	#5	2-FEB-79	MSL	(CALC,DSKSRT)
C
C*******************************************************
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)
C****WMU-AM:APLB10.FOR, MOD=3, WG,27-NOV-78 ****
      V=(((.001308*T+.189269)*T+1.432788)*T+1.)
C**** END(FUNCTION TPCT), MOD=3
      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
      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
      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
      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 SUBROUTINE 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 - APLB10.FOR
C
C	FINAL MODIFICATIONS FOR NSTORE
C	DATE: 21-OCT-75 - RRB.
C
C	PARAMETERS:
C
C	ANS	ANSWER RETURNED
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
C	COMMON/CALDAT/	(OPTIONAL IN CALLING ROUTINES)
C
C	IN	80 WORD VECTOR FOR TELETYPE INPUT LINE (FORMAT=80A1)
C
C	WORDS	4 WORD VECTOR (2 DOUBLE PRECISION WORDS) IN WHICH
C		KEYWORDS ARE RETURNED TO CALLING ROUTINE
C
C	RESULT	DOUBLE PRECISION VALUE USED TO STORE VARIABLE NAME
C
C	LPASS	TTY INPUT FLAG
C
C		= 0	READ TTY INPUT LINE IN CALC
C		# 0	USE TTY INPUT LINE IN COMMON/CALDAT/
C
C	MSGLVL	ERROR MESSAGE LEVEL FLAG
C
C		= 0	PRINT ALL ERROR MESSAGES
C		= 1	PRINT ONLY INTERNAL ERROR MESSAGES
C		= 2	PRINT NO ERROR MESSAGES
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)
C**AM	APLB10 #5	MSL	2-FEB-79
C
C	CHANGED FORMAT OF /CALDAT/ COMMON
C	CHECK MSGLVL BEFORE TYPING ERRORS
C	CHECK LPASS BEFORE READING INPUT LINE
	COMMON/CALDAT/IN,WORDS,RESULT,LPASS,MSGLVL
	DATA LPASS,MSGLVL/0,0/
C**END	CALC	@ 36 - 14
	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
	IF(LPASS.NE.0)GO TO 38
C	WRITE(IDLG,34)
C34	FORMAT('0*',$)
	READ(IRSP,36,END=998)IN
36	FORMAT(80A1)
38	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
C**		AM#99.24.1-4 RRB/12-JAN-79
	IF(LOC.LT.0)GO TO 986
C**END		CALC,APLB10.FOR,@2000+5
C**AM	APLB10 #5	MSL	2-FEB-79
	IF(KIND.NE.2.OR.KLAS.NE.0)GO TO 994
C**END	CALC	@ 2001 - 4
	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
C
C	READ ADDITIONAL LINE OF TTY INPUT IF "&" WAS FOUND
C
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	IF(MSGLVL.LT.2)WRITE(IDLG,892)
892	FORMAT(/,' PROBLEM WITH SUBROUTINE EVAL.',/)
	IERR=2
	GO TO 131
C**		AM#9.24.1-4 RRB/12-JAN-79
986	IF(MSGLVL.LT.2)WRITE(IDLG,989)
989	FORMAT(/,' ?BAD STORAGE AREA IN NSTORE.',/)
	IERR=2
	GO TO 131
C**END		CALC,APLB10.FOR,@892+3
99	IF(MSGLVL.LT.1)WRITE(IDLG,991)
991	FORMAT(' BAD STATEMENT.',/)
	IERR=2
	GO TO 131
992	CONTINUE
C	WRITE(IDLG,993)WORDS(1)
C993	FORMAT(/,1X,A10,' IS NOT DEFINED',/)
	IERR=3
	GO TO 131
994	IF(MSGLVL.LT.2)WRITE(IDLG,995)KIND,KLAS,WORDS(1)
995	FORMAT(/,' WRONG KIND(',I2,') OR KLAS(',I1,') FOR ',A10,/)
	IERR=2
	GO TO 131
996	IF(MSGLVL.LT.2)WRITE(IDLG,997)RESULT
997	FORMAT(/,' ERROR ATTEMPTING TO STORE ',A10,/)
	IERR=2
	GO TO 131
998	IF(MSGLVL.LT.1)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
C**AM	APLB10 #5	MSL	2-FEB-79
111	IF(MODE.NE.0)GO TO 116
	ABSANS=ABS(ANS)
	I=2
	IF(ABSANS.GE.100000000.0.OR.ABSANS.LT.0.00100)I=1
	GO TO(112,114),I
112	WRITE(IDLG,113)ANS
113	FORMAT(1X,1PE)
	GO TO 116
114	WRITE(IDLG,115)ANS
115	FORMAT(1X,F15.5)
116	LOC=INCLRS('ANSWER  ',2,0,1,1)
C**END	CALC	@ 131 - 3
	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 METHOD 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
C
C	NWDS IS THE NUMBER OF SINGLE PRECISION WORDS ALLOWED IN THE
C	COMMON - "ALLOCS" IN THE MAIN PROGRAM.
C
	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**		AM#99.24.1-4 RRB/12-JAN-79(MOVED ROUTINE "LOCNAM" TO FOLLOW "IFREE")
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**		AM#99.24.1-4 RRB/12-JAN-79(MOVE ROUTINE "LOCNAM" FROM BEFORE "INCLRS")
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*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
	SUBROUTINE DSKSRT(UNITI,UNITO,MODE,SCRTCH,ISIZE,RECSIZ,KEYPOS,
     +   KEYSIZ,KEYORD,NKEY,IERR)
C
C	DSKSRT IS A FORTRAN SUBROUTINE TO SORT ASCII OR
C	BINARY DISK FILES INTO ASCENDING OR DESCENDING ORDER
C
C	ARGUMENTS:
C		UNITI	- UNIT # OF OPEN INPUT CHANNEL
C			   IF UNITI = 0, INPUT RECORDS ARE READ FROM
C			   RECBUF COMMON VIA SRTIN ENTRY POINT
C		UNITO	- UNIT # OF OPEN OUTPUT CHANNEL
C			   IF UNITO = 0, OUTPUT RECORDS ARE WRITTEN TO
C			   RECBUF COMMON VIA SRTOUT ENTRY POINT
C		MODE	- MODE OF INPUT/OUTPUT FILES(RECORDS)
C			   = 1	ASCII (CHARACTER MODE)
C			   = 2	BINARY OR IMAGE (WORD MODE)
C		SCRTCH	- SCRATCH VECTOR FOR INTERNAL WORK SPACE
C		ISIZE	- SIZE IN WORDS OF SCRTCH
C			   > 0	DO NOT ALLOCATE, USE SCRTCH
C			   = 0	ALLOCATE AS MUCH CORE AS NEEDED
C			   < 0	ALLOCATE UP TO -ISIZE WORDS OF CORE
C		RECSIZ	- NUMBER OF CHARACTERS(WORDS) PER RECORD
C		KEYPOS	- VECTOR OF KEY STARTING CHARACTER(WORD) POSITIONS
C		KEYSIZ	- VECTOR OF KEY SIZES, IN CHARACTERS(WORDS)
C		KEYORD	- VECTOR OF SORT ORDER FLAGS
C			   = 0	ASCENDING ORDER FOR KEY
C			   # 0	DESCENDING ORDER FOR KEY
C		NKEY	- NUMBER OF KEYS (KEYS LISTED MAJOR-TO-MINOR)
C		IERR	- ERROR RETURN
C			  < 0	ERROR, SORT NOT COMPLETE
C			  >,= 0	NUMBER OF RECORDS SORTED
C
C		RECBUF	- NAMED COMMON AREA
C			   USED IF EITHER UNITI OR UNITO = 0
C			   MUST BE LARGE ENOUGH TO CONTAIN RECSIZE
C			   CHARACTERS(MODE=1) OR WORDS(MODE=2)
C
C	ENTRY POINTS:
C
C	NOTE:  NO FILES SHOULD BE OPENED IN THE CALLING PROGRAM
C	WHILE INPUT AND OUTPUT PROCEDURES ARE IN PROGRESS
C
C	ENTRY SRTIN(IFLAG)
C
C	IFLAG VALUES:
C		= 0  NEXT RECORD IS IN RECBUF
C		# 0  EOF - TERMINATE INPUT PROCEDURE
C			IF UNITI = 0 AND UNITO NOT = 0
C			IFLAG WILL BE RETURNED WITH FINAL RECORD COUNT
C
C	ENTRY SRTOUT(OFLAG)
C
C	OFLAG VALUES RETURNED:
C		= 0  NEXT RECORD RETURNED IN RECBUF
C		> 0  SORT FINISHED, OFLAG = COUNT OF RECORDS RETURNED
C		 -1  EMPTY INPUT FILE
C
C	NOTE:  SRTOUT SHOULD BE CALLED UNTIL OFLAG NOT = 0. IF SORT MUST
C	BE PREMATURELY TERMINATED, CALL SRTOUT WITH OFLAG NOT = 0. THIS
C	WILL RELEASE ALL SORT CHANNELS AND DELETE TEMP FILES.
C
	IMPLICIT INTEGER(A-Z)
	PARAMETER FMTLIM=100, KEYLIM=100, CHNLIM=13
	COMMON/RECBUF/RECORD(1)
	DOUBLE PRECISION SCRFIL(0/CHNLIM),MRGFIL
	DIMENSION SCRTCH(1),KEYPOS(1),KEYSIZ(1),KEYORD(1),
     +   FRMT(FMTLIM),ISORT(KEYLIM),KSORT(KEYLIM),
     +   EOF(CHNLIM),MRGPT(CHNLIM),CHANNL(0/CHNLIM),
     +   IDESC(4),NUMSA5(3),NUMSA1(11)
	EQUIVALENCE(SCRFIL(0),MRGFIL),(CHANNL(0),MRGCHN)
C
	DATA BUFCNT/4/
	DATA PAGE,MAXCOR/512,10240/
	DATA IDESC/'R','5',',','R'/
	DATA SCRDEV,AFILE,AEXT/'DSK','FSRT','.TMP'/
	DATA BIGNUM/"377777777777/
C
C	CHECK SOME PARAMETERS, KEYS CHECKED LATER
C
	IERR=0
	IF(UNITI.EQ.0)GO TO 20
	CALL CHKCHN(UNITI,J)
	IF(J.NE.0)GO TO 9110 		!ERROR-ILLEGAL INPUT UNIT
20	IF(UNITO.EQ.0)GO TO 30
	CALL CHKCHN(UNITO,J)
	IF(J.NE.0)GO TO 9110 		!ERROR-ILLEGAL OUTPUT UNIT
30	IF(MODE.LT.1.OR.MODE.GT.2)GO TO 9120 	!ERROR-ILLEGAL MODE
	IF(RECSIZ.LE.0)GO TO 9130 	!ERROR-ILLEGAL RECORD SIZE
C
C	DETERMINE APPROXIMATE MAXIMUM OF FREE DSK CHANNELS
C
	UNIT=0
	MAXCHN=CHNLIM
40	UNIT=UNIT+1
	CALL CHKCHN(UNIT,J)
	IF(J.LT.0)GO TO 45
	IF(J.EQ.0)MAXCHN=MAXCHN-1
	GO TO 40
45	IF(MAXCHN.LT.2)GO TO 9190	!ERROR-TOO FEW CHANNELS
C
C	GENERATE TEMP FILE NAMES, INITIALZE TEMP FILE FLAGS
C
	DO 90 I=0,MAXCHN
	  CHANNL(I)=0
	  N2=I-((I/10)*10)
	  N1=(I-N2)/10
	  ENCODE(10,80,SCRFIL(I))AFILE,N1,N2,AEXT
80	  FORMAT(A4,2I1,A4)
90	  CONTINUE
C
C	******************************
C	* CORE ALLOCATION            *
C	******************************
C
	BUFWRD=(MAXCHN+1)*(BUFCNT*(128+3)+3)
	BUFSIZ=((BUFWRD+PAGE-1)/PAGE)*PAGE
	ICORE=ISIZE
	IF(ISIZE.LT.0)ICORE=-ISIZE+BUFSIZ
	IREL=1
	IF(ISIZE.LT.0)GO TO 130
	IF(ISIZE.GT.0)GO TO 200
110	ICORE=MAXCOR+BUFSIZ
	CALL ALLCOR(ICORE,JERR,IREL,SCRTCH)
	IF(JERR.GE.0)GO TO 150
120	ICORE=ICORE-PAGE
130	CALL ALLCOR(ICORE,JERR,IREL,SCRTCH)
	IF(JERR.LT.0)GO TO 120
C
C	BUFFER AREA MUST BE UNALLOCATED
C
150	ICORE=ICORE-BUFSIZ
	CALL ALLCOR(ICORE,JERR,IREL,SCRTCH)
C
C	******************************
C	* SORT KEY VALIDATION        *
C	******************************
C
200	DO 210 I=1,KEYLIM
	  ISORT(I)=0
210	  KSORT(I)=0
	IF(NKEY.LT.1)GO TO 9140 		!ERROR-KEY SPECIFICATION
C
C	CHECK THAT ALL KEYS ARE IN RECORD BOUNDS
C
	DO 220 I=1,NKEY
	  IF(KEYPOS(I).LE.0.OR.KEYPOS(I).GT.RECSIZ)
     +     GO TO 9140 				!ERROR-KEY SPECIFICATION
	  IF(KEYSIZ(I).LE.0.OR.KEYPOS(I)+KEYSIZ(I)-1.GT.RECSIZ)
     +     GO TO 9140			 	!ERROR-KEY SPECIFICATION
220	  CONTINUE
	IF(NKEY.EQ.1)GO TO 250
C
C	CHECK FOR ILLEGAL KEY OVERLAP
C
	DO 240 I=1,NKEY-1
	  IMIN=KEYPOS(I)
	  IMAX=IMIN+KEYSIZ(I)-1
	  DO 240 J=I+1,NKEY
	    JMIN=KEYPOS(J)
	    JMAX=JMIN+KEYSIZ(J)-1
	    IF(JMIN.GE.IMIN.AND.JMIN.LE.IMAX)
     +       GO TO 9140 			!ERROR-KEY SPECIFICATION
	    IF(JMAX.GE.IMIN.AND.JMAX.LE.IMAX)
     +       GO TO 9140				!ERROR-KEY SPECIFICATION
240	    CONTINUE
C
250	IF(MODE.EQ.2)GO TO 405
C
C	******************************
C	* FORMAT GENERATION          *
C	******************************
C
300	DO 305 I=1,FMTLIM
305	  FRMT(I)=0
	FRMT(1)='('
	BYTLIM=FMTLIM*5
	IBYTE=1
	SRTSIZ=0
	KEYNUM=0
	MINOLD=0
	MINNEW=BIGNUM
C
C	FIND START OF NEXT KEY (LEFT TO RIGHT)
C
310	INDEX=0
	DO 320 I=1,NKEY
	  MINTMP=KEYPOS(I)
	  IF(MINTMP.LE.MINOLD.OR.MINTMP.GT.MINNEW)GO TO 320
	  MINNEW=MINTMP
	  INDEX=I
320	  CONTINUE
	IF(INDEX.EQ.0)MINNEW=RECSIZ+1
C
C	PASS1 - GET FILLER FORMAT
C		CHARACTERS BETWEEN LAST KEY AND CURRENT KEY
C	PASS2 - GET KEY FORMAT
C
	IPASS=1
	ICHARS=MINNEW-MINOLD-1
	IF(ICHARS.EQ.0)GO TO 385
330	IWORDS=ICHARS/5
	IREM=ICHARS-(IWORDS*5)
	IF(IPASS.EQ.2)ISORT(INDEX)=SRTSIZ+1
	SRTSIZ=SRTSIZ+IWORDS
	IF(IREM.GT.0)SRTSIZ=SRTSIZ+1
	ENCODE(11,340,NUMSA5)IWORDS,IREM
340	FORMAT(I10,I1)
	IF(IWORDS.EQ.0)GO TO 365
	DECODE(11,350,NUMSA5)NUMSA1
350	FORMAT(11A1)
C
C	FORMAT FOR FULL WORD PORTION OF STRING (#R5)
C
	IF(IWORDS.EQ.1)GO TO 365
	IBEGIN=9
	IF(IWORDS.GT.99)IBEGIN=1
	ZFLAG=0
	DO 360 I=IBEGIN,10
	  JCHR=NUMSA1(I)
	  IF((JCHR.EQ.'0'.OR.JCHR.EQ.' ').AND.ZFLAG.EQ.0)GO TO 360
	  ZFLAG=1
	  IBYTE=IBYTE+1
	  IF(IBYTE.GT.BYTLIM)GO TO 9160 	!ERROR-FORMAT
	  CALL PUTCHR(FRMT,IBYTE,JCHR)
360	  CONTINUE
C
365	IBEGIN=1
	LIM=4
	IF(IWORDS.EQ.0)IBEGIN=4
	IF(IREM.EQ.0)LIM=2
	IF(IBEGIN.GT.LIM)GO TO 375
	DO 370 I=IBEGIN,LIM
	  J=I
	  IBYTE=IBYTE+1
	  IF(IBYTE.GT.BYTLIM)GO TO 9160 	!ERROR-FORMAT
370	  CALL PUTCHR(FRMT,IBYTE,IDESC(J))
375	IF(IREM.EQ.0)GO TO 380
C
C	FORMAT OF PARTIAL WORD PORTION (R#)
C
	IBYTE=IBYTE+1
	IF(IBYTE.GT.BYTLIM)GO TO 9160 		!ERROR-FORMAT
	CALL PUTCHR(FRMT,IBYTE,NUMSA5(3))
380	IBYTE=IBYTE+1
	IF(IBYTE.GT.BYTLIM)GO TO 9160 		!ERROR-FORMAT
	CALL PUTCHR(FRMT,IBYTE,',')
385	IF(INDEX.EQ.0)GO TO 400
	IPASS=IPASS+1
	IF(IPASS.GT.2)GO TO 390
	ICHARS=KEYSIZ(INDEX)
	GO TO 330
390	MINOLD=MINNEW+KEYSIZ(INDEX)-1
	MINNEW=BIGNUM
	GO TO 310
400	CALL PUTCHR(FRMT,IBYTE,')') 	!END OF FORMAT, CLOSE WITH )
C
C	COUNT KEYS AND SETUP TABLE OF KEY INDEXES RELATIVE TO
C	START OF EXPANDED WORD-ALIGNED RECORD
C
405	KEYS=0
	IF(MODE.EQ.2)SRTSIZ=RECSIZ
	DO 410 I=1,NKEY
	  IF(MODE.EQ.1)KWORD=(KEYSIZ(I)+4)/5
	  IF(MODE.EQ.2)KWORD=KEYSIZ(I)
	  DO 410 J=0,KWORD-1
	    KEYS=KEYS+1
	    IF(KEYS.GT.KEYLIM)GO TO 9150 	!ERROR-TOO MANY KEYS
	    IF(MODE.EQ.1)KSORT(KEYS)=ISORT(I)+J
	    IF(MODE.EQ.2)KSORT(KEYS)=KEYPOS(I)+J
	    IF(KEYORD(I).NE.0)KSORT(KEYS)=-KSORT(KEYS)
410	    CONTINUE
	DO 420 I=1,KEYS
	  ISORT(I)=KSORT(I)
	  IF(ISORT(I).LT.0)ISORT(I)=-KSORT(I)
420	  CONTINUE
C
C	******************************
C	* SORT / MERGE               *
C	******************************
C
	INTSRT=0
	CHNCNT=0
	INPEOF=0
	OUTYPE=0
	IFLAG1=0
	OFLAG1=0
	KNTIN=0
	KNTOUT=0
C
C	SPLIT UP SCRATCH AREA INTO DATA AND WORK ARRAYS
C
	NCOLS=SRTSIZ
	NROWS=ICORE/(NCOLS+1)
430	JCORE=NCOLS*NROWS+NCOLS+NROWS
	IF(JCORE.LE.ICORE)GO TO 440
	NROWS=NROWS-1
	GO TO 430
440	IF(NROWS.LT.MAXCHN-1)GO TO 9170 	!ERROR-NO ROOM FOR MERGE
C
C	CALCULATE OFFSETS INTO SCRATCH AREA
C
	DO 441 I=1,MAXCHN
441	MRGPT(I)=IREL+NCOLS*(I-1)
	INDXR=IREL
	INDXC=IREL+NROWS
	INDXS=INDXC+NCOLS
	IEND=INDXS+NROWS*NCOLS-1
C
C	GET NEXT TEMP FILE CHANNEL (UNIT #) IF AVAILABLE
C
444	CALL CHKCHN(0,MRGCHN)
	IF(MRGCHN.LE.0)GO TO 9190 		!ERROR-NOT ENOUGH CHANNELS
	OPEN(UNIT=MRGCHN,FILE=MRGFIL,DEVICE=SCRDEV,
     +   ACCESS='SEQOUT',MODE='IMAGE',BUFFER COUNT=BUFCNT)
C
450	IF(CHNCNT.GE.MAXCHN)GO TO 520 		!MERGE
	CALL CHKCHN(0,CURCHN)
	IF(CHNCNT.LT.2.AND.CURCHN.LE.0)GO TO 9190 	!ERROR-TOO FEW CHANNELS
	IF(CURCHN.LE.0)GO TO 520 			!MERGE
C
C	READ INPUT FILE INTO SCRATCH AREA
C
460	CHNCNT=CHNCNT+1
	CHANNL(CHNCNT)=CURCHN
	OPEN(UNIT=CHANNL(CHNCNT),FILE=SCRFIL(CHNCNT),DEVICE=SCRDEV,
     +   ACCESS='SEQOUT',MODE='IMAGE',BUFFER COUNT=BUFCNT)
	KNT=0
461	  ISTART=INDXS+KNT
	  IF(UNITI.NE.0)GO TO 465
	    RETURN
C
	    ENTRY SRTIN(IFLAG)
C
	    IFLAG1=IFLAG
	    IF(IFLAG1.NE.0)GO TO 500
	    IF(MODE.EQ.2)GO TO 462
	    DECODE(RECSIZ,FRMT,RECORD)(SCRTCH(J),J=ISTART,IEND,NROWS)
	    GO TO 467
462	    JJ=0
	    DO 463 J=ISTART,IEND,NROWS
	      JJ=JJ+1
463	      SCRTCH(J)=RECORD(JJ)
	    GO TO 467
465	  IF(MODE.EQ.1)
     +     READ(UNITI,FRMT,END=500)(SCRTCH(J),J=ISTART,IEND,NROWS)
	  IF(MODE.EQ.2)
     +     READ(UNITI,END=500)(SCRTCH(J),J=ISTART,IEND,NROWS)
C
C	COMPLIMENT DESCENDING KEY WORDS
C
467	  DO 470 K=1,KEYS
	    IF(KSORT(K).GE.0)GO TO 470
	    J=ISTART+((-KSORT(K)-1)*NROWS)
	    SCRTCH(J)=.NOT.SCRTCH(J)
470	    CONTINUE
	  KNT=KNT+1
	  IF(KNT.LT.NROWS)GO TO 461
C
C	INTERNAL SORT
C
500	IF(KNT.LT.NROWS)INPEOF=1
	IF(KNT.EQ.0)CHNCNT=CHNCNT-1
	IF(KNT.EQ.0)GO TO 520
	INTSRT=INTSRT+1
	KNTIN=KNTIN+KNT
	CALL SSORT(NCOLS,KNT,NCOLS,NROWS,SCRTCH(INDXS),ISORT,
     +   KEYS,SCRTCH(INDXR),SCRTCH(INDXC))
	IF(INTSRT.EQ.1.AND.INPEOF.EQ.1)GO TO 515 	!NO MERGE NEEDED
C
C	OUTPUT TEMP FILE
C
	DO 510 I=0,KNT-1
	  ISTART=INDXS+I
510	  WRITE(CURCHN)(SCRTCH(J),J=ISTART,IEND,NROWS)
	IF(INPEOF.EQ.0)GO TO 450
C
C	MERGE TEMP FILES INTO OUTPUT FILE OR NEW TEMP FILE
C
515	IF(UNITO.NE.0)GO TO 520
	RETURN
C
	ENTRY SRTOUT(OFLAG)
C
C	OUTYPE = 0 ON FIRST PASS, FALL THRU COMPUTED GOTO
C		AFTER FIRST PASS:
C		 = 1	IF MERGE WAS REQUIRED
C		 = 2	IF NO MERGE REQUIRED, ONLY ONE INTERNAL SORT
C
	OFLAG1=OFLAG
	GO TO (640,850) OUTYPE
C
520	IF(KNTIN.EQ.0)GO TO 9000
	EOFCNT=0
	IF(INTSRT.EQ.1.AND.INPEOF.EQ.1)GO TO 800
	OUTYPE=1
C
C	INITIALIZE TEMP FILE BUFFERS WITH FIRST RECORD
C
	DO 550 I=1,CHNCNT
	  CLOSE(UNIT=CHANNL(I))
	  OPEN(UNIT=CHANNL(I),FILE=SCRFIL(I),DEVICE=SCRDEV,
     +     ACCESS='SEQIN',MODE='IMAGE',BUFFER COUNT=BUFCNT)
	  EOF(I)=0
	  READ(CHANNL(I))(SCRTCH(J),J=MRGPT(I),MRGPT(I)+NCOLS-1)
550	  CONTINUE
C
555	IF(OFLAG1.NE.0)GO TO 9000
	IF(EOFCNT.EQ.CHNCNT)GO TO 700
C
C	LOCATE NEXT RECORD FOR OUTPUT
C	EOF(I), I=1,CHNCNT
C		-1  EOF ON CHANNEL
C		 0  RECORD NOT ELIMINATED AS NEXT FOR OUTPUT
C		 1  RECORD ELIMINATED ON BASIS OF KEY VALUE
C
	DO 590 IKY=1,KEYS
	  SELCNT=0
	  DESEL=1
	  MINKEY=BIGNUM
	  DO 580 ICH=1,CHNCNT
	    IF(EOF(ICH).NE.0)GO TO 580
C
C	    CHECK FOR NEW MIN VALUE OF KEY
C
	    CURKEY=SCRTCH(MRGPT(ICH)+ISORT(IKY)-1)
	    IF(CURKEY.LT.MINKEY)GO TO 560
	    IF(CURKEY.EQ.MINKEY)GO TO 570
	    EOF(ICH)=1
	    GO TO 580
560	    IF(ICH.EQ.1)GO TO 570
	    DO 565 I=DESEL,ICH-1
565	      IF(EOF(I).EQ.0)EOF(I)=1
	    DESEL=ICH
	    SELCNT=0
570	    SELCNT=SELCNT+1
	    SELCHN=ICH
	    MINKEY=CURKEY
580	    CONTINUE
	  IF(SELCNT.LT.1)GO TO 9180 	!ERROR-CANNOT FIND NEXT RECORD
	  IF(SELCNT.EQ.1)GO TO (610,620)INPEOF+1
590	  CONTINUE
	GO TO (610,620)INPEOF+1
C
C	OUTPUT SELECTED RECORD TO TEMP FILE
C
610	WRITE(MRGCHN)(SCRTCH(I),I=MRGPT(SELCHN),MRGPT(SELCHN)+NCOLS-1)
	GO TO 640
C
C	OUTPUT SELECTED RECORD TO OUTPUT FILE
C	COMPLIMENT DESCENDING KEY WORDS FIRST
C
620	KNTOUT=KNTOUT+1
	DO 625 K=1,KEYS
	  IF(KSORT(K).GE.0)GO TO 625
	  J=MRGPT(SELCHN)-KSORT(K)-1
	  SCRTCH(J)=.NOT.SCRTCH(J)
625	  CONTINUE
	JSTART=MRGPT(SELCHN)
	JEND=JSTART+NCOLS-1
	IF(UNITO.NE.0)GO TO 635
	  IF(MODE.EQ.2)GO TO 630
	  ENCODE(RECSIZ,FRMT,RECORD)(SCRTCH(I),I=JSTART,JEND)
	  GO TO 634
630	  J=0
	  DO 632 I=JSTART,JEND
	    J=J+1
632	    RECORD(J)=SCRTCH(I)
634	  OFLAG1=0
	  RETURN
635	IF(MODE.EQ.1)WRITE(UNITO,FRMT)(SCRTCH(I),I=JSTART,JEND)
	IF(MODE.EQ.2)WRITE(UNITO)(SCRTCH(I),I=JSTART,JEND)
C
C	REFILL BUFFER JUST WRITTEN
C
640	READ(CHANNL(SELCHN),END=650)
     +   (SCRTCH(I),I=MRGPT(SELCHN),MRGPT(SELCHN)+NCOLS-1)
	GO TO 660
650	EOF(SELCHN)=-1
	EOFCNT=EOFCNT+1
660	DO 670 I=1,CHNCNT
	  IF(EOF(I).GT.0)EOF(I)=0
670	  CONTINUE
	GO TO 555
C
C	DONE MERGE PHASE, DELETE TEMP FILES
C
700	IF(INPEOF.EQ.1)GO TO 9000
	DO 710 I=1,CHNCNT
	  CLOSE(UNIT=CHANNL(I),DISPOSE='DELETE')
710	  CHANNL(I)=0
	CLOSE(UNIT=MRGCHN,FILE=SCRFIL(1))
	CHNCNT=1
	CHANNL(1)=MRGCHN
	MRGCHN=0
	OPEN(UNIT=CHANNL(1),FILE=SCRFIL(1),DEVICE=SCRDEV,
     +   ACCESS='APPEND',MODE='IMAGE',BUFFER COUNT=BUFCNT)
	GO TO 444
C
C	WRITE OUTPUT FILE IF NO MERGE NEEDED
C
800	OUTYPE=2
801	ISTART=INDXS+KNTOUT
C
C	COMPLIMENT DESCENDING KEY WORDS
C
	  DO 810 K=1,KEYS
	    IF(KSORT(K).GE.0)GO TO 810
	    J=ISTART+((-KSORT(K)-1)*NROWS)
	    SCRTCH(J)=.NOT.SCRTCH(J)
810	    CONTINUE
	  IF(UNITO.NE.0)GO TO 840
	    IF(MODE.EQ.2)GO TO 820
	    ENCODE(RECSIZ,FRMT,RECORD)(SCRTCH(J),J=ISTART,IEND,NROWS)
	    GO TO 835
820	    JJ=0
	    DO 830 J=ISTART,IEND,NROWS
	      JJ=JJ+1
830	      RECORD(JJ)=SCRTCH(J)
835	    OFLAG=0
	    RETURN
840	  IF(MODE.EQ.1)WRITE(UNITO,FRMT)(SCRTCH(J),J=ISTART,IEND,NROWS)
	  IF(MODE.EQ.2)WRITE(UNITO)(SCRTCH(J),J=ISTART,IEND,NROWS)
850	  KNTOUT=KNTOUT+1
	  IF(KNTOUT.LT.KNTIN)GO TO 801
C
9000	IERR=KNTOUT
	IFLAG=KNTOUT
	OFLAG=KNTOUT
	IF(OFLAG.EQ.0)OFLAG=-1
	GO TO 9900
C
C	ERROR RETURNS
C
C	  ILLEGAL UNIT NUMBER, INPUT OR OUTPUT
9110	IERR=-1
	GO TO 9900
C	  ILLEGAL MODE
9120	IERR=-2
	GO TO 9900
C	  ILLEGAL RECORD SIZE PARAMETER (RECSIZ)
9130	IERR=-3
	GO TO 9900
C	  KEY SPECIFICATION ERROR
9140	IERR=-4
	GO TO 9900
C	  TOO MANY KEYS
9150	IERR=-5
	GO TO 9900
C	  FORMAT ROOM EXCEEDED
9160	IERR=-6
	GO TO 9900
C	  NO ROOM FOR INTERNAL SORT
9170	IERR=-7
	GO TO 9900
C	  INTERNAL ERROR - MERGE
9180	IERR=-8
	GO TO 9900
C	  NOT ENOUGH CHANNELS AVAILABLE
9190	IERR=-9
C
C	DELETE ALL OPEN TEMP FILES
C
9900	DO 9990 I=0,MAXCHN
	  IF(CHANNL(I).EQ.0)GO TO 9990
	  CLOSE(UNIT=CHANNL(I),DISPOSE='DELETE')
	  CHANNL(I)=0
9990	  CONTINUE
C
9999	IF(ISIZE.LE.0)CALL ALLCOR(0,JERR,IREL,SCRTCH)
	RETURN
	END