PDP-10 Archive: 43,50521/bnklib.d20 from decuslib10-10

Trailing-Edge - PDP-10 Archives - decuslib10-10 - 43,50521/bnklib.d20

There are 3 other files named bnklib.d20 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
C AAR ================================================================
C AAR
C AAR    	*** ASSOCIATION OF AMERICAN R.R. UPDATES ***
C AAR    	*** MADE 10/10/77 BY W.E.BARKER TO RUN   ***
C AAR    	***         ON DECSYSTEM-20		 ***			
C AAR
C AAR    	CHANGES MADE:
C AAR
C AAR    	1) FOR ALL LINEPRINTER OUTPUT, REPLACE CALL 
C AAR    	   TO "PRINTS" ROUTINE (WHICH HANGS UP) BY
C AAR    	   PRINTING THE FILE WHEN IT IS CLOSED. THIS
C AAR    	   IS ACCOMPLISHED WITH THE DISPOSE='LIST'
C AAR    	   OPTION.
C AAR
C AAR    	2) CALL A MACRO ROUTINE, "EXPUNG", TO CLEAN
C AAR    	   UP DELETED FILES BEFORE EXITING, OR 
C AAR    	   BEFORE RUNNING ANOTHER BANK PROGRAM.
C AAR
C AAR		3) CHANGE TEMPORARY OUTPUT FILE NAME FOR
C AAR		   OUTPUT FROM 'WMU1%%.JJJ' WHERE JJJ IS
C AAR		   THE JOB NUMBER+100 TO 'WMU1%%.DAT'
C AAR		   SO THAT THE FILE WILL BE PRINTED WITH
C AAR		   CARRIAGE CONTROL CHARACTERS RECOGNIZED.
C AAR
C AAR
C AAR
C AAR    NOTE: CHANGES MADE BY THE AAR ARE NUMBERED, AND ARE 
C AAR          SURROUNDED BY COMMENTS WITH "AAR" IN THE LEFT
C AAR          MARGIN. STATEMENTS WHICH WERE IN THE ORIGINAL
C AAR          VERSION AND HAVE BEEN COMMENTED OUT HAVE A
C AAR          "WMU" IN THE LEFT MARGIN.
C AAR
C AAR
C AAR =================================================================
C
C
C
C
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
C
C WMU
C WMU
C WMU      CALL JOBNUM (K)
C WMU      K=K+100
C WMU      ENCODE(10,24,FILNAM) J,K
C WMU24    FORMAT('WMU',I3,'.',I3)
C WMU
C WMU
C
C AAR
C AAR		*** AAR CHANGE 3 ***
C AAR
C AAR ----
C AAR    !
	ENCODE(10,24,FILNAM) J
24	FORMAT('WMU',I3,'.DAT')
C AAR    !
C AAR ----
C AAR
C
      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 switch'/)
      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
C WMU
C WMU
C WMU      CLOSE(UNIT=IDEV)
C WMU
C WMU
      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
C WMU
C WMU
C WMU      IF(IPAGCT.GT.0)CALL PRINTS(FILNM(IDEV),2,1,ICOPS,NPAGES)
C WMU      IF(IPAGCT.LT.0) CALL PRINTS(FILNM(IDEV),2,1,ICOPS)
C WMU
C WMU
C
C AAR
C AAR
C AAR	   		*** AAR CHANGE 1A ***
C AAR      GET RID OF CALLS TO PRINTS; DO PRINTING BY CLOSING
C AAR      FILE WITH DISPOSE='LIST'
C AAR
C AAR ----
C AAR    !
	IF(IPAGCT.NE.0)CLOSE(UNIT=IDEV,DISPOSE='LIST')
	IF(IPAGCT.EQ.0)CLOSE(UNIT=IDEV,DISPOSE='DELETE')
C AAR    !
C AAR ----
C AAR
C AAR
      IPAGCT=0
89    OPEN(UNIT=IDEV,FILE=FILNAM,ACCESS='SEQOUT',DEVICE='DSK')
      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
C WMU
C WMU
C WMU      CLOSE(UNIT=IDEV)
C WMU
C WMU
      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
C WMU
C WMU      IF(IPAGCT.GT.0) CALL PRINTS(FILNM(IDEV),2,1,ICOPS,NPAGES)
C WMU      IF(IPAGCT.LT.0) CALL PRINTS(FILNM(IDEV),2,1,ICOPS)
C WMU
C WMU
C
C AAR
C AAR      		*** AAR CHANGE 1B ***
C AAR
C AAR       DONT CALL PRINTS (IT HANGS!!!!). PRINT BY CLOSE OPTION.
C AAR
C AAR
C AAR ----
C AAR    !
	IF(IPAGCT.NE.0)CLOSE (UNIT=IDEV,DISPOSE='LIST')
	IF(IPAGCT.EQ.0)CLOSE(UNIT=IDEV,DISPOSE='DELETE')
C AAR    !
C AAR ____
C AAR
C AAR
      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
C WMU
C WMU
C WMU      CLOSE(UNIT=J)
C WMU      IF(DEVN(J).NE.'LPT') GO TO 82
C WMU
C WMU
C
C AAR
C AAR ----
C AAR    !
	IF(DEVN(J).NE.'LPT')GO TO 8111
C AAR    !
C AAR ----
C AAR 
C AAR
      ICOPS=-DEST(J)
      IF(ICOPS.GT.100) ICOPS=ICOPS-100
      NPAGES=IPAGCT*ICOPS+3
C WMU
C WMU
C WMU      IF(IPAGCT.GT.0) CALL PRINTS(FILNM(J),2,1,ICOPS,NPAGES)
C WMU      IF(IPAGCT.LT.0) CALL PRINTS(FILNM(J),2,1,ICOPS)
C WMU
C WMU
C
C AAR
C AAR			*** AAR CHANGE 1C ***
C AAR      DONT CALL "PRINTS". PRINT BY CLOSE OPTION.
C AAR ----
C AAR    !
	IF(IPAGCT.EQ.0)CLOSE(UNIT=J,DISPOSE='DELETE')
	IF(IPAGCT.NE.0)CLOSE(UNIT=J,DISPOSE='LIST')
	GO TO 82
8111	CLOSE(UNIT=J)
C AAR    !
C AAR ----
C AAR
C AAR
C
82    CONTINUE
C
C AAR
C AAR
C AAR			*** AAR CHANGE 2A ***
C AAR      CALL "EXPUNG" TO DELETE DELETED FILES.
C AAR ----
C AAR    !
	CALL EXPUNG
C AAR    !
C AAR ----
C AAR
C AAR
      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
C WMU
C WMU
C WMU      CLOSE(UNIT=J)
C WMU      IF(DEVN(J).NE.'LPT') GO TO 99
C WMU
C WMU
C
C AAR ----
C AAR    !
	IF(DEVN(J).NE.'LPT')GO TO 9888
C AAR    !
C AAR ----
C
      ICOPS=-DEST(J)
      IF(ICOPS.GT.100) ICOPS=ICOPS-100
      NPAGES=IPAGCT*ICOPS+3
C WMU
C WMU
C WMU      IF(IPAGCT.GT.0) CALL PRINTS(FILNM(J),2,1,ICOPS,NPAGES)
C WMU      IF(IPAGCT.LT.0) CALL PRINTS(FILNM(J),2,1,ICOPS)
C WMU
C WMU
C
C AAR
C AAR			*** AAR CHANGE 1D ***
C AAR	   DONT CALL "PRINTS". PRINT BY CLOSE OPTION.
C AAR
C AAR ----
C AAR    !
	IF(IPAGCT.EQ.0)CLOSE(UNIT=J,DISPOSE='DELETE')
	IF(IPAGCT.NE.0)CLOSE(UNIT=J,DISPOSE='LIST')
	GO TO 99
9888	CLOSE(UNIT=J)
C AAR    !
C AAR ----
C AAR
C AAR
C
99    CONTINUE
C
C AAR
C AAR			*** AAR CHANGE 2B ***
C AAR	   CALL "EXPUNG" TO DELETE DELETED FILES.
C AAR
C AAR ----
C AAR    !
	CALL EXPUNG
C AAR    !
C AAR ----
C AAR
C AAR
      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 specified and no /COPEIS switch is used,'/
     1'       1 copy is assumed.'/'0EXAMPLES:'/
     1'  DSK:SAM.F4'/'  LPT:/COPIES:3'/'  MTA:'/)
      GO TO 1

      END
*
**************************************************************************
*
	SUBROUTINE GETID
C
C	THIS SUBROUTINE WAS WRITTEN BY BERENICE HOUCHARD ON 1974
C	TO BE USED BY SOME OF THE PROGRAMS IN THE BANK SYSTEM.  IT
C	ACCEPTS A 80 COLUMN INPUT FROM THE USER TO BE USED AS A HEADER
C	FOR OUTPUT PURPOSES.
C
C	THE HEADER INFORMATION IS STORED IN VECTOR ID SITUATED
C	IN THE COMMON BLOCK SID.
C
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SID/ID(16),ISTOP
	DOUBLE PRECISION NAMO,NAMI
C
C
	WRITE(IDLG,10)
10	FORMAT(' ENTER HEADER')
	READ(ICC,11) ID
11	FORMAT(16A5)
	DO 12 ISTOP=16,1,-1
	IF (ID(ISTOP).NE.' ') RETURN
12	CONTINUE
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE GETMOD(NV,NF,NOTF)
C
C	THIS IS A MODIFICATION OF DICK HOUCHARD'S PROGRAM IN WHICH
C	THE MODE OF EACH VARIABLE IS EXTRACTED FROM THE FORMAT SUBMITTED
C	BY THE USER.  THIS MODIFICATION WAS DONE ON 1974 BY BERENICE
C	HOUCHARD.
C
C
C	NV-----NUMBER OF VARIABLES
C	NF-----5*DIMENSION OF NOTF
C	NOTF---VECTOR CONTAINING THE FORMAT IN A5
C	ITYPE--VECTOR TO CONTAIN THE MODE OF EACH VARIABLE
C
	DIMENSION NOTF(1),ITYPE(800),FMTT(400),FT(400),XX(9),SAV(5)
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	EQUIVALENCE (ITEMP(1),FMTT),(ITEMP(401),FT),(ITEMP(801),SAV),
     1 (ITEMP(4201),ITYPE)
	DATA XX/'A','I','F','G','E','(',')','D','O'/
	DECODE(NF,2,NOTF) (FMTT(I),I=1,NF)

2	FORMAT(400A1)
	DO 20 N=NF,1,-1
	IF (FMTT(N).NE.' ')GO TO 21
20	CONTINUE
	PAUSE 'PROBLEM'
21      I=0
500   I=I+1
508   IF(I.GT.N) GO TO 512
      DO 501 J=1,9
      IF(FMTT(I).EQ.XX(J)) GO TO 500
501   CONTINUE
      IF((FMTT(I).LT.'0').OR.(FMTT(I).GT.'9')) GO TO 504
      DO 502 K=1,4
      IF((K+I).GT.N) GO TO 504
      DO 503 J=1,9
      IF(FMTT(K+I).NE.XX(J)) GO TO 503
      IF(J.EQ.7) GO TO 504
      GO TO 500
503   CONTINUE
      IF((FMTT(K+I).LT.'0').OR.(FMTT(K+I).GT.'9')) GO TO 504
502   CONTINUE
C     GET RID OF CHARACTER
504   DO 505 J=I+1,N
505   FMTT(J-1)=FMTT(J)
      N=N-1
      GO TO 508
C
C     GET RID OF PARANTHESES
512   ISW=0
      I=0
      M=1
513   I=I+1
      IF(I.GT.N) GO TO 530
      IF(FMTT(I).EQ.XX(6)) GO TO 513
      IF(FMTT(I).EQ.XX(7)) GO TO 513
      IF((FMTT(I).GE.'0').AND.(FMTT(I).LE.'9')) GO TO 514
      FT(M)=FMTT(I)
      M=M+1
      IF(M.LT.NF) GO TO 513
      GO TO 541
514   ISW=1
      DO 515 K=1,5
515   SAV(K)=' '
      J=1
516   SAV(J)=FMTT(I)
      I=I+1
      J=J+1
      IF((FMTT(I).GE.'0').AND.(FMTT(I).LE.'9')) GO TO 516
517   IF(SAV(5).NE.' ') GO TO 519
      DO 518   J=4,1,-1
518   SAV(J+1)=SAV(J)
      SAV(1)=' '
      GO TO 517
519   ENCODE(5,2,WORD) SAV
      DECODE (5,520,WORD) LOOP
520   FORMAT(I5)
      IF(FMTT(I).EQ.XX(6)) GO TO 525
      DO 521 J=1,LOOP
      FT(M)=FMTT(I)
      M=M+1
      IF(M.GT.NF) GO TO 541
521   CONTINUE
      GO TO 513
525   L=I+1
      KOUNT=1
526   IF(FMTT(L).EQ.XX(6)) KOUNT=KOUNT+1
      IF(FMTT(L).EQ.XX(7)) KOUNT=KOUNT-1
      IF(KOUNT.EQ.0) GO TO 527
      L=L+1
      GO TO 526
527   IF((I+1).GT.(L-1)) GO TO 532
      DO 528 J=1,LOOP
      DO 529 K=I+1,L-1
      FT(M)=FMTT(K)
      M=M+1
      IF(M.GT.NF) GO TO 541
529   CONTINUE
528   CONTINUE
532   I=L
      GO TO 513
530   N=M-1
      IF(ISW.EQ.0) GO TO 540
      DO 531 I=1,N
531   FMTT(I)=FT(I)
      GO TO 512
541   PAUSE 'PROBLEM SEE DICK HOUCHARD'
      RETURN
540   K=1
      DO 542 I=1,NV
      ITYPE(I)=0
      IF(FT(K).EQ.'A') ITYPE(I)=1
      IF(FT(K).EQ.'O') ITYPE(I)=2
      IF(FT(K).EQ.'I') ITYPE(I)=2
      K=K+1
      IF(K.GT.N) K=1
C
C     FORMAT BROKEN DOWN
C
542   CONTINUE
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE BNKNAM(ITYPE,NSIZE)
	DIMENSION M(72),NNS(18,6),ISAVE(5),L1(2),MSAVE(5),NAME(800),
     1 NUM(800),MODE(800),IV(1000),IDUM(125),IT(0/2),NOGOOD(800),
     2 NOMAT(800)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON/IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	DOUBLE PRECISION NAMO,NAMI
	EQUIVALENCE (ITEMP,NOGOOD),(ITEMP(801),IV,NOMAT),(ITEMP(2601),
     1 NAME),(ITEMP(3401),NUM),(ITEMP(4201),MODE)
	EQUIVALENCE (IDUM,NNS)
	DATA IGRT/'$'/
	DATA IT/'F','A','I'/
	ISET=800
	NSET=1000
	IZ=(NOBNK+124)/125*NVBNK+1
	NT=(NVBNK+5)/6
1	ISIZE=0
	NSIZE=0
	NBAD=0
	DO 102 I=1,ISET
	NUM(I)=0

102	ITEMP(I)=0
	DO 103 J=1,NSET
103	IV(J)=0
10	WRITE(IDLG,100)
100	FORMAT(' WHICH VARIABLES FROM THE BANK?'/)
101	NPT=1
	CALL GES(M,72,IEND)
C
C	IEND=-1  IF ALTMODE IS ENCOUNTERED
C	    = 1  IF CARRIAGE RETURN IS ENCOUNTERED
C	    = 2  IF END OF FILE IS ENCOUNTERED
C
	IF (IEND.EQ.2) CALL EXIT
C
C

C
	IF ((M(1).EQ.'H').AND.(M(2).EQ.'E').AND.(M(3).EQ.'L').AND.
     1(M(4).EQ.'P')) GO TO 70
	DO 110 ILAST=72,1,-1
	IF (M(ILAST).NE.' ') GO TO 11
110	CONTINUE
	GO TO 301
11	IEND=-1
	IF(M(ILAST).EQ.',') IEND=1
	IF((M(ILAST-1).EQ.',').AND.((M(ILAST).EQ.IALT)
     .	.OR.(M(ILAST).EQ.IGRT))) GOTO 2112
	GOTO 2111
2112	ILAST=ILAST-1
	M(ILAST)=IALT
2111	DO 12 I=1,5
12	ISAVE(I)=' '
	N=0
	DO 13 I=1,ILAST
	L=M(I)
	IF (L.EQ.' ') GO TO 13
	IF ((L.EQ.',').OR.(L.EQ.'-').OR.(L.EQ.IALT).OR.(L.EQ.IGRT))
     1 GO TO 14
	IF (N.GE.5) GO TO 13
	N=N+1
	ISAVE(N)=L
	GO TO 13
C
C
C
14	IF ((I.EQ.1).AND.((L.EQ.IALT).OR.(L.EQ.IGRT))) GO TO 301
	ISIZE=ISIZE+1
	ITEMP(ISIZE)=' '
	DO 777 KK=1,N
	IF ((ISAVE(KK).GT.'9').OR.(ISAVE(KK).LT.'0')) GO TO 15
777	CONTINUE
140	IF (ISAVE(5).NE.' ') GO TO 142
	DO 141 J=4,1,-1
141	ISAVE(J+1)=ISAVE(J)
	ISAVE(1)=' '
	GO TO 140
142	ENCODE(5,143,K) ISAVE
143	FORMAT(5A1)

	DECODE(5,144,K) IV(ISIZE)
144	FORMAT(I5)
	IF (L.EQ.'-')  GO TO 18
	GO TO (130,30), NPT
C
C
C
15	IV(ISIZE)=0
	ENCODE(5,143,ITEMP(ISIZE)) ISAVE
	IF ((ITEMP(ISIZE).EQ.'*').OR.(ITEMP(ISIZE).EQ.'ALL')) GO TO 20
16	IF (L.NE.'-') GO TO (130,30), NPT
C
C	'-'
C
18	ISIZE=ISIZE+1
	ITEMP(ISIZE)='-'
	IV(ISIZE)=-2
	GO TO (130,30), NPT
C
C
130	N=0
	DO 131 J=1,5
131	ISAVE(J)=' '
13	CONTINUE
	IF (N.LE.0) GO TO 30
	NPT=2
	GO TO 14
C
C	ALL OR *
C
20	IS=NVBNK
	IF (NVBNK.GT.ISET) IS=ISET
	NSIZE=0
	MATCH=0
	LEFT=6
	DO 21 I=1,NT
	I1=IZ+I
	READ(INP#I1) IDUM
	II=(I-1)*6
	IF (I.EQ.NT) LEFT=NVBNK-II
	DO 22 J=1,LEFT
	L=NNS(10,J)
	IF (ITYPE.GE.3) GO TO 200
	IF ((L.EQ.ITYPE).OR.((ITYPE.EQ.0).AND.(L.EQ.2))) GO TO 200
	MATCH=MATCH+1
	NOMAT(MATCH)=NNS(1,J)
	GO TO 22
200	IF (NSIZE.EQ.IS) GO TO 23
	NSIZE=NSIZE+1
	NAME(NSIZE)=NNS(1,J)
	MODE(NSIZE)=L
	NUM(NSIZE)=J+II
22	CONTINUE

21	CONTINUE
231	IF (MATCH-1) 65,63,64
C
C
C
23	IF (IS.NE.NVBNK) WRITE(IDLG,230) NVBNK,ISET
230	FORMAT('-ERROR:  There are',I7,' variables in the BANK and
     1 limit is set at',I7/9X,'Program proceeds, ignoring the excess'/)
	GO TO 231
C
C
C
30	IF(IEND.EQ.1)GOTO 101
301	IF (ISIZE.LE.ISET) GO TO 31
	WRITE(IDLG,300)
300	FORMAT('-ERROR: Variable string too long, Contact computer
     1 center staff'/9X,'for help'/)
	CALL EXIT
C
C
C
31	IF (ISIZE.GT.0) GO TO 32
	WRITE(IDLG,310)
310	FORMAT('-ERROR:  Picking up 0 variables from the BANK, Try again
     .'/)
	IF (ICODE.GE.0) GO TO 10
311	CALL EXIT
C
C
C
32	DO 320 I=1,ISIZE
	IF (IV(I).NE.-2) GO TO 322
	IF ((IV(I-1).GE.0).AND.(IV(I+1).GE.0)) GO TO 320
	WRITE(IDLG,321) (ITEMP(J),J=I-1,I+1)
321	FORMAT('-ERROR:  Illegal entry for range    "',3A5,'",'/
     1 ' Re-enter the entire list')
3210	IF (ICODE.GE.0) GO TO 1
	CALL EXIT
322	IF (IV(I).LE.NVBNK) GO TO 320
	WRITE(IDLG,323) IV(I)
323	FORMAT('-ERROR:  Variable number',I6,' does not exist, Try
     1 again'/)
	GO TO 3210
320	CONTINUE
C
C
C
	I1=IZ+1
	READ(INP#I1) IDUM
	I=1
	LEFT=6
	IF (NVBNK.LT.LEFT) LEFT=NVBNK
330	IF (IV(I).NE.0) GO TO 35
	L=ITEMP(I)
	DO 34 J=1,LEFT
	IF (L.NE.NNS(1,J)) GO TO 34
	NSIZE=NSIZE+1
	NAME(NSIZE)=L
	NUM(NSIZE)=J
	MODE(NSIZE)=NNS(10,J)
	GO TO 33
34	CONTINUE
	NSIZE=NSIZE+1
	NAME(NSIZE)=L
	NUM(NSIZE)=IV(I)
	GO TO 33
C
C
C
35	IF (IV(I).LT.0) GO TO 38

C
C	A POSITIVE # IN IV(I)
C
36	NSIZE=NSIZE+1
	NAME(NSIZE)=' '
	NUM(NSIZE)=IV(I)
	IF (IV(I).GT.LEFT) GO TO 33
	NAME(NSIZE)=NNS(1,IV(I))
	MODE(NSIZE)=NNS(10,IV(I))
	GO TO 33
C
C
C	-
C
38	LN=NUM(NSIZE)
	LIV=IV(I+1)
	IF ((LN.GE.1).AND.(LN.LE.LEFT)) GO TO 381
	IF (LIV.NE.0) GO TO 3803
	DO 3801 J=1,LEFT
	IF (ITEMP(J+1).EQ.NNS(1,J)) GO TO 3802
3801	CONTINUE
3800	NSIZE=NSIZE+1
	NAME(NSIZE)=' '
	NUM(NSIZE)=-2
	NSIZE=NSIZE+1
	I=I+1
	NAME(NSIZE)=ITEMP(I)
	NUM(NSIZE)=IV(I)
	GO TO 33
C
C
C
3802	IF ((LN.EQ.0).OR.(LN.GT.LEFT)) GO TO 486
	IST=LN+1
	LAST=LIV
	GO TO 3811
C
C
C
3803	IF (LIV.LE.LEFT) GO TO 486
	IF (LN-LIV) 3800,486,486
C
C
C
381	IST=LN+1
	IF (LIV.EQ.0) GO TO 385
	IF (LIV.GT.LEFT) GO TO 384
	LAST=LIV
3811	IF (LAST.LT.IST) GO TO 486
3810	NS=NSIZE
	NSIZE=NSIZE+LAST-IST+1
C
C
C
382	I=I+2
3820	DO 383 J1=IST,LAST
	NS=NS+1
	NAME(NS)=NNS(1,J1)
	MODE(NS)=NNS(10,J1)
383	NUM(NS)=J1
	GO TO 331
C
C
C
385	L=ITEMP(I+1)
	DO 386 J1=1,LEFT
	IF (L.NE.NNS(1,J1)) GO TO 386
	LAST=J1
	GO TO 3811
386	CONTINUE
C
C
C
384	LAST=LEFT
	NS=NSIZE
	NSIZE=NSIZE+LAST-IST+3
	NAME(NSIZE-1)=' '
	NUM(NSIZE-1)=-2
	NAME(NSIZE)=ITEMP(I+1)
	NUM(NSIZE)=IV(I+1)
	GO TO 382
C
C
C
33	I=I+1
331	IF (I.LE.ISIZE) GO TO 330
	IF (LEFT.EQ.NVBNK) GO TO 50
C
C
40	K2=6
	DO 41 K=2,NT
	I1=IZ+K
	READ(INP#I1) IDUM
	K1=K2
	K2=K*6
	IF (K2.GT.NVBNK) K2=NVBNK
	LEFT=K2-K1
	I=1
410	NI=NUM(I)
42	IF (NI) 47,44,43
43	IF ((NI.GT.K2).OR.(NI.LE.K1)) GO TO 46
	K3=NI-K1
	NAME(I)=NNS(1,K3)
	MODE(I)=NNS(10,K3)
	GO TO 46
C
C
C
44	L=NAME(I)
	DO 45 J=1,LEFT
	IF (L.NE.NNS(1,J)) GO TO 45
	NAME(I)=NNS(1,J)
	NUM(I)=K1+J
	MODE(I)=NNS(10,J)
	GO TO 46
45	CONTINUE
	GO TO 46
C
C
C
C
C
C
47	IF ((NUM(I-1).EQ.0).OR.(NUM(I-1).GE.K2)) GO TO 485
	NPT=1
	IST=NUM(I-1)+1-K1
	IF (NUM(I+1).EQ.0) GO TO 490
	IF (NUM(I+1).GT.K2) GO TO 49
	IF (NUM(I+1).LT.NUM(I-1)) GO TO 486
	LAST=NUM(I+1)-K1
483	J3=LAST-IST-1
	IF (J3.LT.0) GO TO 493
4830	I2=I+2
484	IF (I2.GT.NSIZE) GO TO 482
C
C
C
4800	DO 480 J=NSIZE,I2,-1
	NS=J+J3
	NAME(NS)=NAME(J)
	MODE(NS)=MODE(J)
480	NUM(NS)=NUM(J)
C
C
C
482	II=NUM(I-1)+1
	DO 481 J=IST,LAST
	NAME(I)=NNS(1,J)
	MODE(I)=NNS(10,J)
	NUM(I)=II
	II=II+1
481	I=I+1
	NSIZE=NSIZE+J3
	IF (NPT.EQ.2) I=I+2
	IF (I-NSIZE)410,41,41
C
C
C
485	IF ((NUM(I+1).EQ.0).OR.(NUM(I+1).GT.K2)) GO TO 46
486	WRITE(IDLG,487)
487	FORMAT('-ERROR:  Illegal range specification, Try again'/)
	IF (ICODE.GE.0) GO TO 1
	CALL EXIT
C
C
C
490	L=NAME(I+1)
	DO 491 J=1,LEFT
	IF (L.EQ.NNS(1,J)) GO TO 492
491	CONTINUE
	IF (IST.LE.LEFT) GO TO 49
	I=I+2
	GO TO 460
C
C
C
49	LAST=LEFT
	J3=LAST-IST+1
	I2=I
	NPT=2
	GO TO 4800
C
C
C
492	LAST=J
	IF (LAST.LT.IST) GO TO 486
	NPT=1
	J3=LAST-IST-1
	IF (J3.GE.0) GO TO 4830
493	NAME(I)=NNS(1,LAST)
	MODE(I)=NNS(10,LAST)
	NUM(I)=K1+LAST
	NSIZE=NSIZE-1
	IF (I.GE.NSIZE) GO TO 41
	IJ=I
	DO 4860 J=I+2,NSIZE+1
	IJ=IJ+1
	NAME(IJ)=NAME(J)
	MODE(IJ)=MODE(J)
4860	NUM(IJ)=NUM(J)
C
C
C
46	I=I+1
460	IF (I.LE.NSIZE) GO TO 410
41	CONTINUE
C
C	CHECK FOR INVALID ENTRIES AND MODES
C
50	IF (NSIZE.GT.0) GO TO 500
5010	WRITE(IDLG,501)
501	FORMAT('-ERROR:  No variable selected from BANK, Try again'/
     1 )
	IF (ICODE) 311,1,1
C
C
500	NBAD=0
	MATCH=0
	IST=1
51	DO 52 I=IST,NSIZE
	L=NUM(I)
	IF (L.GT.0) GO TO (55,55,55,52,52),ITYPE+1
	IF (L.EQ.-2) GO TO 53
	NBAD=NBAD+1
	NOGOOD(NBAD)=NAME(I)
53	NSIZE=NSIZE-1
	IF (NSIZE.GT.0) GO TO 540
	WRITE(IDLG,600) NOGOOD(1)
	GO TO 5010
540	IF (I.GT.NSIZE) GO TO 6
	DO 54 J=I,NSIZE
	NAME(J)=NAME(J+1)
	MODE(J)=MODE(J+1)
54	NUM(J)=NUM(J+1)
	IST=I
	IF (NSIZE) 6,6,51
55	IF ((MODE(I).EQ.ITYPE).OR.((ITYPE.EQ.0).AND.(MODE(I).EQ.2)))
     1 GO TO 52
	MATCH=MATCH+1
	NOMAT(MATCH)=NAME(I)
	GO TO 53
52	CONTINUE
6	IF (NBAD-1) 62,60,61
60	WRITE(IDLG,600) NOGOOD(1)
600	FORMAT('-ERROR:  Variable "',A5,'" does not exist, program
     1 continues'/9X,'ignoring it'/)
	GO TO 62
61	WRITE(IDLG,610) NBAD,(NOGOOD(I),I=1,NBAD)
610	FORMAT('-ERROR:  The following',I6,' variable names do not
     1 exist,'/9X,'Program continues ignoring them:'/(10(1X,A5)))
	WRITE(IDLG,641)
C
C
C
62	IF (MATCH-1) 65,63,64
63	WRITE(IDLG,630) NOMAT(1),IT(ITYPE)
630	FORMAT('-ERROR:  Variable "',A5,'" is not of the required ',A1,
     1 '-Type,'/9X,'It will be excluded in all analysis'/)
	GO TO 650
64	WRITE(IDLG,640) IT(ITYPE),(NOMAT(I),I=1,MATCH)
640	FORMAT('-ERROR:  The following variables are not of the required
     1 ',A1,'-Type,'/9X,'They will be excluded in all analysis:'/
     2 (9X,10(A5,1X)))
650	WRITE(IDLG,641)
641	FORMAT(' ')
C
C	CHECK FOR DUPLICATE ENTRIES
C
65	IF (NSIZE.LE.1) RETURN
	IDUP=0
	LAST=NSIZE
	I=1
651	IST=I+1
6500	IF (IST.EQ.LAST) GO TO 654
	DO 6504 J=IST,LAST
	IF (NAME(I).EQ.NAME(J)) GO TO 652
6504	CONTINUE
6501	NSIZE=LAST
	IF (I.GE.NSIZE) GO TO 654
	I=I+1
	GO TO 651
C
C
C
652	IDUP=IDUP+1
	NOGOOD(IDUP)=NAME(I)
	IF (J.EQ.LAST) GO TO 6502
	LAST=LAST-1
	DO 653 K=J,LAST
	NAME(K)=NAME(K+1)
	NUM(K)=NUM(K+1)
653	MODE(K)=MODE(K+1)
	IST=J
	GO TO 6500
C
C
C
6502	LAST=LAST-1
	GO TO 6501
C
C
C
654	IF (IDUP-1) 68,66,67
66	WRITE(IDLG,660) NOGOOD(1)
660	FORMAT('-ERROR: Variable "',A5,'" is used more than once,'/
     1 9X,'Program proceeds ignoring the duplicate'/)
	GO TO 680
67	WRITE(IDLG,670) IDUP,(NOGOOD(I),I=1,IDUP)
670	FORMAT('-ERROR:  The following',I5,' variables appear more
     1 than once,'/9X,'Program proceeds ignoring the duplicates'/
     2 (9X,10(A5,1X)))
680	WRITE(IDLG,641)
68	RETURN
C
C	HELP
C
70	WRITE(IDLG,700)
700	FORMAT('-All or some of the variables located in a structured
     1 data BANK may be'/' used for the analysis.  A "ALL" or "*" may
     2 be entered if all of the'/' variables are to be used.  Otherwise,
     3 enter the variables by either'/' their NAMES (as previously
     4 defined in the data BANK) or by their'/' variable numbers
     5 separated by commas.  Ranges of variables may also'/' be
     6 specified by typing the extremes of the range separated
     7 by a "-".'/'-Multiple lines are available to enter the list
     8 provided the'/' last character in the line is a comma.'/'
     9 The list should be terminated by an altmode or a carriage 
     1return.'//)
	GO TO 1
	END
*
**************************************************************************
*
	SUBROUTINE SELECT(M)
C
C	ARGUMENT FROM THE CALLING PROGRAM:
C
C	M------NUMBER OF VARIABLES
C
C
C	ARGUMENTS RETURN TO THE CALLING PROGRAM
C
C	N------NUMBER OF QUALIFIERS
C	NVAR---VARIABLE  NUMBER WITH THE SELECT
C	NCON---CONDITIONS IN THE SELECT
C	VALUE--VALUE ASSOCIATED WITH SELECT
C	NVAL---NUMBER OF VALUES AFTER THE EQUAL SIGN
C	NOR---NUMBER OF 'OR' STATEMENTS
C
C
C
	DIMENSION NAME(800),NUM(800),MODE(800),IDUM(72),ISYM(3),ICON(3),
     1 DUM(72),IVEC(125),NNS(18,6),V(15),IV(15),WORD(3),IWORD(3),
     2 IVALUE(20,20),ISAVE(5)
C
C
C
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/SELEC/N,NVAR(20),NCON(20),VALUE(20,20),NVAL(20),NOR(20)
C
	DOUBLE PRECISION NAMO,NAMI
	EQUIVALENCE (ITEMP(1),IDUM,DUM), (ITEMP(73),IV,V),
     1 (ITEMP(88),IVEC,NNS), (ITEMP(2601),NAME),(ITEMP(3401),NUM),
     2 (ITEMP(4201),MODE), (IVALUE,VALUE)
C
	DATA ISYM/'=','>','<'/
	DATA ICON/1,2,4/
C
	IF (IDEVO.NE.'TTY') WRITE(IOUT,101)
101	FORMAT('-',29X,'SELECT OPTION:'/)
1000	WRITE(IDLG,10)
10	FORMAT('  SELECT OPTION:'/'  ?',$)
100	READ(ICC,11,END=8)IDUM
11	FORMAT(72A1)
	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')) GO TO 95
1	N=0
	LINE=0
122	LINE=LINE+1
120	NR=0
	DO 12 LAST=72,1,-1
	IF (IDUM(LAST).NE.' ') GO TO 201
12	CONTINUE
	GO TO 8
C
C
C
201	I=1
2	DO 20 J=1,5
20	ISAVE(J)=' '
	DO 210 J=1,15
210	IV(J)=' '
	ICOND=0
	IS=0
200	L=IDUM(I)
	IF (L.EQ.' ') GO TO 22
	DO 21 JJ=1,3
	IF (L.EQ.ISYM(JJ)) GO TO 25
21	CONTINUE
	IS=IS+1
	IF (IS.LE.5) ISAVE(IS)=L
22	I=I+1
	IF (I.LE.LAST) GO TO 200
230	WRITE(IDLG,23)
23	FORMAT('-ERROR:  Invalid entry, Re-enter the line'//)
231	IF (ICODE.LT.0) CALL EXIT
232	LINE=LINE-1
	N=N-NR
240	WRITE(IDLG,24)
24	FORMAT('+ ?',$)
	READ(ICC,11,END=8) IDUM
	GO TO 122
C
C
C
25	ISTORE=' '
	IF ((ISAVE(1).GE.'0').AND.(ISAVE(1).LE.'9')) GO TO 28
	ENCODE(5,11,ISTORE)ISAVE
	DO 26 J=1,M
	IF (ISTORE.EQ.NAME(J)) GO TO 40
26	CONTINUE
	IF (IBNK.EQ.1) GO TO 41
270	WRITE(IDLG,27) ISTORE
27	FORMAT('-ERROR:  Variable "',A5,'" does not exist, Re-enter
     1 the line'//)
	IF (ICODE.GE.0) GO TO 232
	CALL EXIT
C
C	A NUMBER WAS USED
C
28	IF (ISAVE(5).NE.' ') GO TO 30
	DO 29 J=4,1,-1
29	ISAVE(J+1)=ISAVE(J)
	ISAVE(1)=' '
	GO TO 28
30	NSTORE=' '
	ENCODE(5,11,NSTORE) ISAVE
	DECODE(5,31,NSTORE) ISTORE
31	FORMAT(I5)
	IF (ISTORE.LE.0) GO TO 230
	IF (N.GE.20) GO TO 80
	IF (IBNK.NE.0) GO TO 32
C
C
C
	IF (ISTORE.GT.M) GO TO 230
	N=N+1
	NVAR(N)=ISTORE
	MO=MODE(ISTORE)
	GO TO 5
C
C
C
32	IF (ISTORE.GT.NVBNK) GO TO 230
	I1=(ISTORE+5)/6
	I2=I1+1+(NOBNK+124)/125*NVBNK
	READ(INP#I2) IVEC
	N=N+1
	NVAR(N)=ISTORE
	I1=ISTORE-(I1-1)*6
	MO=NNS(10,I1)
	GO TO 5
C
C	A NAME IS USED AND IS FOUND IN VECTOR NAME
C
40	IF (N.GE.20) GO TO 80
	N=N+1
	NVAR(N)=NUM(J)
	MO=MODE(J)
	GO TO 5
C
C	NAME IS IN THE BANK
C
41	I1=(NOBNK+124)/125*NVBNK+1
	NT=(NVBNK+5)/6
	DO 42 J=1,NT
	I2=I1+J
	READ(INP#I2) IVEC
	DO 42 J1=1,6
	IF (ISTORE.EQ.NNS(1,J1)) GO TO 43
42	CONTINUE
	GO TO 270
C
C
C
43	IF (N.GE.20) GO TO 80
	N=N+1
	NVAR(N)=(J-1)*6+J1
	MO=NNS(10,J1)
C
C	CHECK FOR CONDITION
C
5	NOR(N)=LINE
	NR=NR+1
	NV=0
50	ICOND=ICOND+ICON(JJ)
	IF (ICOND.GT.6) GO TO 230
	IF ((I+1).GT.LAST) GO TO 230
	IF (IDUM(I+1).EQ.IDUM(I)) GO TO 230
52	I=I+1
	DO 53 JJ=1,3
	IF (IDUM(I).EQ.ISYM(JJ)) GO TO 50
53	CONTINUE
C
C	CHECK VALUE
C
	NCON(N)=ICOND
602	IS=0
	L=IDUM(I)
	IF (MO.NE.1) GO TO 60
	IF (L.EQ.1H') GO TO 6
601	WRITE(IDLG,600)
600	FORMAT('-ERROR:  Missing '' in an A-type variable'/9X,'Re-enter
     1 the line'//)
	GO TO 231
C
C
6	I=I+1
	L=IDUM(I)
	GO TO 61
C
C
60	IF ((L.LT.'0').OR.(L.GT.'9')) GO TO 230
61	IS=IS+1
	IF (IS.LE.15) IV(IS)=L
	I=I+1
	IF (I.GT.LAST) GO TO 62
	L=IDUM(I)
	IF ((L.NE.';').AND.(L.NE.',')) GO TO 61
62	NV=NV+1
	IF (NV.LE.20) GO TO 621
	WRITE(IDLG,620)
620	FORMAT('-ERROR:  Too many values in the string'/9X,'Re-enter
     1 the line'//)
	GO TO 231
C
C
C
621	IF ((L.NE.',').OR.((L.EQ.',').AND.(ICOND.EQ.1))) GO TO
     1 (66,63,66), MO+1
	WRITE(IDLG,623)
623	FORMAT('-ERROR:  Multiple values can only be performed on a
     1 ''EQUAL'' CONDITION'/9X,'Re-enter the line'//)
	GO TO 231
C
C
C
C
C	A-TYPE
C
63	IF (IS.LE.6) GO TO 65
	WRITE(IDLG,64) IV
64	FORMAT('-ERROR:  ',15A1,' Is too long for A-type variable,'/
     1 9X,'Re-enter the line'//)
	GO TO 231
65	IF (IV(IS).NE.1H') GO TO 601
	IS=IS-1
	IVALUE(NV,N)=' '
	ENCODE(IS,11,IVALUE(NV,N)) (IV(J),J=1,IS)
C
C
652	I=I+1
	NVAL(N)=NV
	IF (I.GT.LAST) GO TO 651
	IF (L.EQ.';') GO TO 2
	IF (L.EQ.',') GO TO 602
651	IF (IDEVO.NE.'TTY') WRITE(IOUT,650) IDUM
650	FORMAT(37X,72A1)
	GO TO 240
C
C	CHECK FOR DECIMAL POINT
C
66	IF ((IV(1).EQ.'-').AND.(IV(2).EQ.'-')) GO TO 230
	DO 67 J=1,IS
	IF (IV(J).EQ.'.') GO TO (670,693,693), MO+1
67	CONTINUE
670	I1=16
	DO 68 J=IS,1,-1
	I1=I1-1
68	IV(I1)=IV(J)
	DO 69 J=1,IS
69	IV(J)=' '
	DO 6900 J=1,3
6900	WORD(J)=' '
	IF (MO.EQ.2) GO TO 691
	ENCODE(15,11,WORD) IV
	DECODE(15,690,WORD) VALUE(NV,N)
690	FORMAT(G15.0)
	GO TO 652
C
C
C
691	ENCODE(15,11,IWORD) IV
	DECODE(15,692,IWORD) IVALUE(NV,N)
692	FORMAT(I15)
	GO TO 652
C
C
693	WRITE(IDLG,694)
694	FORMAT('-ERROR:  Cannot have a decimal point in a I-type
     1 variable'/9X,'Re-enter the line'//)
	GO TO 231
C
C
C
8	IF (N.GT.0) RETURN
	WRITE(IDLG,81)
81	FORMAT('-ERROR:  No qualifier accepted, Try again'//)
	IF (ICODE.GE.0) GO TO 1000
	CALL EXIT
82	RETURN
C
C
80	WRITE(IDLG,83)
83	FORMAT('-ERROR:  Too many qualifiers requested'/9X,'Program will
     1 ignore the last SELECT statement'//)
	N=N-NR
	RETURN

C
C
C
90	WRITE(IDLG,91)
91	FORMAT('-SELECT option allows the program to consider only those
     1 observations'/' meeting user specified criteria.  Instructions to
     2 the SELECT option'/' (QUALIFIERS) are entered on a line or on
     3 separate lines.  Each'/' QUALIFIER contains 3 basic parts:
     4  VARIABLE, CONDITION, and VALUE or'/' VALUES to be compared
     5 against.  The variable may be specified by'/' either the variable
     6 NAME (if previously defined), or the variable'/' number (in the
     7 case of data BANK file, this is the number associated'/' with the
     8 BANK).  The CONDITION may be one of the following:'//6X,
     9 'CONDITION',5X,'MEANING'/6X,9('-'),5X,7('-')/9X,'=',10X,'equal
     1 to'/9X,'<',10X,'less than'/9X,'>',10X,'greater than'/6X,'<= or =<
     2',6X,'less than or equal to'/6X,'>= or =>',6X,'greater than or
     3 equal to'/6X,'<> or ><',6X,'not equal'//)
	WRITE(IDLG,92)
92	FORMAT(' The value to be compared against must be of the same
     1 type as the'/' variable it is compared with.'//' Enter each
     2 QUALIFIER immediately after the ? is typed out by the program'/
     3 ' Several QUALIFIERS may be ''OR'' together by entering the
     4 QUALIFIERS on'/' a line separated by semi-colons (;).  Enter a
     5 ^Z, a carriage return or'/' a blank line immediately after the ?
     6 to signify the end of all'/' QUALIFIERS.  Up to 20 Qualifiers may
     7 be specified.'//' EXAMPLE: To consider all those observations in
     8 which variable 3 is'/11X,'not ZERO, and variable 5 is less than 4
     9 or greater than 8.'//11X,'SELECT OPTION:'/11X,'?3<>0'/11X,
     1'?5<4;5>8'/11X,'?^Z'//)
	IF (ICODE.GE.0) GO TO 1000
	CALL EXIT
95	IF (IDEVO.NE.'TTY') WRITE(IOUT,950)
950	FORMAT(37X,'SAME AS THE PRECEEDING RUN'/)
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE INFO(N)
C
C
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON/IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
	COMMON/FMT/NOTF(80)	!MSL: CHANGED FROM 48, 11-1-76
	COMMON/SID/ID(16),ISTOP
	COMMON/SINFO/CALNAM,PROG(12)
	COMMON/SINFO1/ITIME,IDATE(2)
C
C
	DOUBLE PRECISION NAMO,NAMI
C
C
	CALL DATE(IDATE)
	CALL TIME(ITIME)
	WRITE(IOUT,11) PROG,CALNAM,ITIME,IDATE,ID,NOTF
11	FORMAT('1'/'-'/'-',29X,'WESTERN  MICHIGAN  UNIVERSITY'//
     1 30X,12A5///30X,'CALLING NAME:  ',A5/30X,'TIME-DATE   :  ',A5,2X
     2 2A5/30X,'TITLE',7X,':  ',16A5/30X,'FORMAT',6X,':  ',16A5/
     3 4(43X,16A5/))
C
C
	IF (IBNK.NE.1) GO TO 300
	WRITE(IOUT,20) NAMI,NDBNK,LFBR,NPBNK,IRTBR,NVBNK,NOBNK
20	FORMAT(30X,'DATA FILE   :  ',A10/30X,'CREATED ON  :  ',2A5/
     1 30X,'BY PROJ-PROG:  ',A1,O6,',',O6,A1/30X,'NUMBER OF VARIABLES IN
     2 THE BANK.',5(' .'),I7/30X,'NUMBER OF OBSERVATIONS IN THE BANK',
     3 4(' .'),I7)
	IF (N.NE.0) WRITE(IOUT,21) N
21	FORMAT(30X,'NUMBER OF VARIABLES USED',9(' .'),I7)
300	IF ((IDEVI.EQ.'DSK').AND.(IBNK.NE.1)) WRITE(IOUT,30) NAMI,LFBR,
     1 IPROJ,IPROG,IRTBR
30	FORMAT('-',29X,'DATA FILE   :  ',A10,A1,O6,',',O6,A1)
	RETURN
	END
*
**************************************************************************
*
      FUNCTION FISHER(M,N,X)
      IF(X.EQ.0.0)GO TO 321
      IF(M.EQ.1)GO TO 200
      IF((M+N).GT.400)GO TO 201
200   NA=2*(M/2)-M+2
      NB=2*(N/2)-N+2
      W=X*FLOAT(M)/FLOAT(N)
      Z=1.0/(1.0+W)
      IF(NA.EQ.1)GO TO 10
      IF(NB.EQ.1)GO TO 9
      D=Z*Z
      P=W*Z
      GO TO 100
9     P=SQRT(Z)
      D=0.5*Z*P
      P=1.0-P
      GO TO 100
10    IF(NB.EQ.1)GO TO 15
      P=SQRT(W*Z)
      D=0.5*P*Z/W
      GO TO 100
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(NA.NE.1)GO TO 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=Z**((N-1)/2)
      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 102
      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
      FISHER=1-P
      RETURN
321   FISHER=1.0
      RETURN
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)
      IF(N.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
      END
*
**************************************************************************
*
	SUBROUTINE PAGE
*********************************************************************
*
*	THIS SUBROUTINE OUTPUTS HEADER AT TOP OF PAGE FOR NON-TTY DEVICE
*	IF OUTPUT DEVICE IS 'TTY' PROGRAM RETURNS
*
*	SINFO1 IS IN COMMON WITH SUBROUTINE "INFO" WHICH OBTAINS DATE
*	SINFO IS IN COMMON WITH MAIN WHICH OBTAINS PROGRAM TITLE
*
*	IPAGE COUNTS LINES IN EACH PAGE
*	IPAGCT IS PAGE COUNTER BOTH A ZERO IN MAINLINE
*
************************************************************************
	COMMON /IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON /SINFO/CALNAM,PROG(12)
	COMMON/SINFO1/ITIME,IDATE(2)
	COMMON /SID/ID(16),ISTOP
	DOUBLE PRECISION NAMO,NAMI
	IF(IDEVO.EQ.'TTY') RETURN
	IPAGE=2
	CALL TIME(ITIME)
	IPAGCT=IPAGCT+1
	IF(ISTOP.EQ.0) GOTO 1
	WRITE(IOUT,100) CALNAM,IDATE,ID,ITIME,IPAGCT
100	FORMAT('1',A5,'  W.M.U.   ',2A5,4X,16A5,3X,A5,4X,'PAGE:',I4/)
	RETURN
1	WRITE(IOUT,101) CALNAM,IDATE,PROG,ITIME,IPAGCT
101	FORMAT('1',A5,'  W.M.U.   ',2A5,9X,12A5,18X,A5,4X,'PAGE:',I4/)
	RETURN
	END
*
**************************************************************************
*
	SUBROUTINE GETFR1(ISEL,NCHAR,IFMT)
	DIMENSION IFMT(1),ITYPE(0/2),NAM(2),IN(80)
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON /SGETFR/ISTD,LTYPE
	DOUBLE PRECISION NAME
	EQUIVALENCE (NAME,NAM)
	DATA ITYPE/'F','A','I'/
C
C
99	IBEG=1
	ISTD=0
	NPT=0
	IPAREN=0
	IF(NCHAR.EQ.0) PAUSE 'SYSTEM ERROR CONTACT COMPUTER CENTER'
C
C	WRITE HEADER
C
	IF((LTYPE.EQ.3).OR.(ISEL.EQ.1)) WRITE(IDLG,100)
100	FORMAT(' ENTER FORMAT ENCLOSED IN PARENTHESES'/)
	IF((LTYPE.LT.3).AND.(ISEL.EQ.0)) WRITE(IDLG,101) ITYPE(LTYPE)
101	FORMAT(' ENTER FORMAT ENCLOSED IN PARENTHESES: (',A1,
     .	'-TYPE ONLY)'/)
98	IF(NPT.LT.2) CALL GES(IN,80,IERR)
	IF(NPT.EQ.2) READ(29,102) IN
C
C	FIND # OF CHARACTERS
C
	DO 10 I=80,1,-1
	IF(IN(I).NE.' ') GOTO 20
10	CONTINUE
	ISTD=1
	RETURN
C
C	STANDARD FORMAT REQUESTED; RETURN
C
20	LAST=I
C
C	GET RID OF EXTRA SPACES
C
	I=0
25	I=I+1
	IF(I.GT.LAST) GOTO 30
	IF(IN(I).NE.' ') GOTO 25
	DO 15 J=I,LAST
15	IN(J)=IN(J+1)
	LAST=LAST-1
	GOTO 25
C
C
30	IF(NPT.NE.0) GOTO 300
	IF(IN(1).EQ.'H'.AND.IN(2).EQ.'E'.AND.IN(3).EQ.'L'.AND.IN(4)
     .	.EQ.'P') GOTO 999
	IF(IN(1).EQ.'S'.AND.IN(2).EQ.'A'.AND.IN(3).EQ.'M'.AND.IN(4).EQ.
     .	'E') RETURN
	IF((IN(1).NE.'(').AND.(IN(1).NE."401004020100)) GOTO 9999
	NPT=1
	DO 35 I=1,NCHAR
35	IFMT(I)=' '
	IF(IN(1).EQ.'(') GOTO 300
C
C	COMMAND FILE
C
	NPT=2
	DO 40 I=2,LAST
	IF(IN(I).EQ.'.') GOTO 45
40	CONTINUE
	LAST=LAST+1
	IN(LAST)='.'
45	J=LAST-1
	ENCODE(J,102,NAM(1)) (IN(I),I=2,LAST)
102	FORMAT(80A1)
	CLOSE(UNIT=29)
	OPEN(UNIT=29,DEVICE='DSK',FILE=NAME,ACCESS='SEQIN')
	GOTO 98
C
C	READ FORMAT
C
300	DO 50 I=1,LAST
	IF(IN(I).EQ.'(') IPAREN=IPAREN+1
	IF(IN(I).EQ.')') IPAREN=IPAREN-1
50	CONTINUE
	IF(IBEG+((LAST+4)/5).GT.NCHAR) GOTO 9999
	ENCODE (LAST,102,IFMT(IBEG)) (IN(I),I=1,LAST)
	IBEG=IBEG+(LAST+4)/5
	IF(IPAREN.LT.1) GOTO (200,201),NPT
	GOTO 98
C
C	RETURN
C
201	CLOSE (UNIT=29)
200	RETURN
C
C	ERROR AND HELP
C
9999	WRITE(IDLG,103)
103	FORMAT('-ERROR:  Format incorrectly specified'/)
	GOTO 99
999	I=NCHAR*5
	WRITE(IDLG,104) I
104	FORMAT(' Any FORMAT specification must comply with the FORTRAN-1
     .0 Format'/' requirement. The FORMAT must also be enclosed 
     .in parentheses'/' and be no more than ',I3,' characters in length'
     .	//' Example:  ENTER FORMAT ENCLOSED IN PARENTHESES'
     .	/11X,'(I2,F3.0,1X,F2.0,I1)'/)
	GOTO 99
	END
*
**************************************************************************
*
	SUBROUTINE VARLST(NSIZE)
C
C	THIS SUBROUTINE WAS WRITTEN BY BERENICE HOUCHARD ON 1974 FOR
C	SOME OF THE PROGRAMS IN THE BANK SYSTEM, SPECIFICALLY, FREQ.FRE,
C	CORL.COR,TAB.TAB AND REGR.REG.
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
	DIMENSION NAME(800),NUM(800),IDUM(72),ISAVE(5),IRSYM(9),IRWRD(5)
	COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
	COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
	COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
C
C
C
	DOUBLE PRECISION NAMO,NAMI
	EQUIVALENCE (ITEMP(1),ISAVE),(ITEMP(6),IDUM),(ITEMP(2601),NAME),
     1 (ITEMP(3401),NUM)
C
C
C
	DATA IRSYM/' ','-','.','*','/','?','"','+',';'/
	DATA IRWRD/'ALL','HELP','EMPTY','STOP','OBS'/
	DATA IGRT/'$'/
C
C
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
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(J).EQ.IALT).OR.(IDUM(J).EQ.IDOL)) J=J-1
C
C	CHECK IF VALID NUMBER
C
	DO 777 I=1,J
	IF((IDUM(I).LT.'0').OR.(IDUM(I).GT.'9')) GOTO 20
777	CONTINUE
C
C
	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.800) 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	IF((IDUM(LAST-1).NE.',').OR.(IDUM(LAST).NE.IALT).OR.(IDUM(LAST)
     .	.OR.IGRT)) GOTO 2201
	LAST=LAST-1
	IDUM(LAST)=IALT
2201	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.800) 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
	NUM(NSIZE)=NSIZE
	IF(NPT.EQ.2) GOTO 40
330	N=0
	DO 33 I=1,5
33	ISAVE(I)=' '
	IF ((L.EQ.IALT).OR.(L.EQ.IGRT)) GO TO 40
21	CONTINUE
	IF(L.EQ.',') GOTO 11
	IF (N.LE.0) GO TO 40
	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	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.  If more than
     7 1 line'/6X,'is needed the last character in the line must 
     . be a comma.'/6x,'The list must be terminated with a
     . carriage return or an altmode.'//
     8' (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
*
**************************************************************************
*
	FUNCTION RNORM(XMEAN,STDEV)
C
C	THIS ROUTINE FINDS A RANDOM NORMAL NUMBER
C	WITH A GIVEN MEAN AND ST. DEVIATION
C
	RNORM=0.
	DO 1 I=1,12
1	RNORM=RNORM+RAN(X)
	RNORM=RNORM-6.
	RNORM=RNORM*STDEV+XMEAN
	RETURN
	END