Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/bank/bnklib.for
There are 4 other files named bnklib.for in the archive. Click here to see a list.
C
C SUBROUTINE IO. ORIGINALLY WRITTEN BY SAM ANEMA.
C MODIFIED BY RUSS BARR, AND BERENICE HOUCHARD.
C
C REWRITTEN BY DICK HOUCHARD JAN 1976
C
C CALL SEQUENCE CALL IO(KNOUT,IDEV,DEVNAM,REALDV,FILNAM,IPROJ,IPROG,IBNK)
C WHERE:
C KNOUT - IS A SINGLE WORD QUANTITY USED TO INDICATE WHETHER
C THE USER IS REQUESTING AN INPUT OR OUTPUT.
C 1 = OUTPUT ROUTINE ASKS QUESTION.
C 0 = INPUT , ROUTINE ASKS QUESTION
C -1 = OUTPUT MAINLINE ASKS QUESTION.
C -2 = INPUT, MAINLINES ASKS QUESTION.
C IDEV - DEVICE NUMBER (MUST BE BETWEEN 1 AND 30
C DEVNAM - TWO WORD QUANTITY RETURNED FROM SUBROUTINE
C CONTAINING THE DEVICE NAME INDICATED BY USER.
C REALDV - SINGLE WORD QUANTITY RETURNED BY SUBROUTINE CONTAINING
C "TTY" IF THE DEVICE IS A TELETYPE
C "DSK" IF THE DEVICE IS A DISK
C " " IF THE DEVICE IS OTHER THAN A TELETYPE AND DISK
C FILNAM - TWO WORD VARIABLE CONTAINING THE FILENAME(IF NEEDED)
C OF THE FILE REQUESTED BY THE USER.
C IPROJ - 1 WORD QUANTITY RETURNED BY THE KPROGRAM
C CONTAINING THE PROJECT NUMBER WHERE THE FILE IS FOUND.
C IPRG - 1 WORD QUANTITY RETURNED BY THE PROGRAM TO INDICATED
C PROGRAMMER NUMBER WHERE THE FILE EXISTS.
C IBNK - 1 WORD KVARIABLE RETURNED FROM THE SUBROUTINE
C INDICATING WHETHER THE FILE IS A
C BANK FILE OR NOT (0= IS NOT, 1= IS)
C
C IN RESPONDING TO THE SUBROUTINE THE USER MAY TERMINATE WITH
C A CARRIAGE RETURN OR ALTMODE.
C
C ADDITION ROUTINE NEEDED ARE:
C GES - ROUTINE READS INPUT FROM THE TELETYPE WITH AN A1 FORMAT
C ALSO ALLOWS THE TERMINATION OF A LINE WITH AND ALTMODE.
C DEVCHR - RETURNS THE DEVICE CHARASTICS OF A SPECIFED
C DEVICE
C GETPPN - RETURNS PROJECT PROGRAMMER NUMBER OF USER.
C EXISTS - CHECKS FOR THE EXISTANCE OF A FILE.
C RUNUUO - ENTERS A RUN CLASS COMMAND FROM THE PROGRAM.
C PRINTS - ALLOWS THE PROGRAM TO ENTER A FILE INTO THE
C LINEPRINTER SPOOLER.
C JOBNUM - RETURN JOB NUMBER OF USER.
C
C
C
SUBROUTINE IO(KNOUT,IDEV,DEVNAM,REALDV,FILNAM,IPROJ,IPROG,IBNK)
COMMON /INIO/ IFTR,IFTW,DEVN(30),FILNM(30),IPP(30),DEST(30)
COMMON/IOB/LEFBK,IRTBK,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,II,OUTDV
DIMENSION IN(80),INN(10),IPN(3)
DOUBLE PRECISION FILNAM,FILNM,TMP,DEVNAM,DEVN
INOUT=KNOUT
IF(INOUT.LT.0) INOUT=INOUT+2
SETSW=0
IALT="155004020100
IRTBK="565004020100
LEFBK="555004020100
IPN(3)=0
1 DEVNAM='TTY'
CALL DEVCHR(DEVNAM,IDCHAR)
FILNAM=' '
CALL GETPPN(IPROJ,IPROG)
IBNK=0
ICOPS=1
IF(KNOUT.LT.0) GO TO 7
IF(INOUT.EQ.1) GO TO 4
IF(IFTR.EQ.0)WRITE(IDLG,2)
2 FORMAT('+INPUT? (for help type HELP) '$)
IF(IFTR.NE.0) WRITE(IDLG,3)
3 FORMAT('+INPUT? ',$)
IFTR=1
GO TO 7
4 IF(IFTW.EQ.0) WRITE(IDLG,5)
5 FORMAT('+OUTPUT? (for help type HELP) ',$)
IF(IFTW.NE.0) WRITE(IDLG,6)
6 FORMAT('+OUTPUT? ',$)
IFTW=1
C
C CALL GES DOES SAME THING AS READ WITH FORMAT OF 80A1,
C EXCEPT IT WILL ALSO TERMINATE WITH AN ALTMODE.
C ICHECK+2 IMPLIES CONTROL Z WAS HIT
C
7 CALL GES(IN,80,ICHECK)
IF(ICHECK.EQ.2) GO TO 90
C
C COMPRESS OUT BLANKS
C
J=1
DO 8 I=1,80
IF(IN(I).EQ.' ') GO TO 8
C CHANGE ALL LOWER CASE TO UPPER CASE LETTERS
IF((IN(I).GE."605004020100).AND.(IN(I).LE."751004020100))
1IN(I)=IN(I).AND."577777777777
IN(J)=IN(I)
J=J+1
8 CONTINUE
IF(J.EQ.81) GO TO 10
DO 9 I=J,80
9 IN(I)=' '
IF(J.EQ.1) GO TO 71
IF(IN(1).EQ.IALT) GO TO 71
C
C DEVICE (PICK UP UNTIL SPACE, ALTMODE, OR <CR>)
C
10 DO 11 I=1,10
11 INN(I)=' '
I=1
J=1
12 IF(IN(I).EQ.' ') GO TO 40
IF(IN(I).EQ.':') GO TO 15
IF(IN(I).EQ.IALT) GO TO 40
IF(IN(I).EQ.LEFBK) GO TO 40
IF(J.GT.10) GO TO 13
INN(J)=IN(I)
J=J+1
I=I+1
GO TO 12
13 WRITE(IDLG,14)
14 FORMAT('+Either a colon was missing or the file name',
1' is too long'/)
GO TO 1
15 ENCODE(10,16,DEVNAM) (INN(J),J=1,10)
16 FORMAT(80A1)
CALL DEVCHR(DEVNAM,IDCHAR)
IF(IDCHAR.NE.0) GO TO 18
WRITE(IDLG,17) DEVNAM
17 FORMAT('+Device ',A6,' does not exist'/)
GO TO 1
18 IF(INOUT.EQ.1) GO TO 20
IF((IDCHAR.AND."000002000000).NE.0) GO TO 35
WRITE(IDLG,19) DEVNAM
19 FORMAT('+Device 'A6,' cannot do input'/)
GO TO 1
20 IF((IDCHAR.AND."000001000000).NE.0) GO TO 22
WRITE(IDLG,21) DEVNAM
21 FORMAT('+Device ',A6,' cannot do output.'/)
GO TO 1
22 IF((IDCHAR.AND."040000000000).EQ.0) GO TO 35
C
C
C *************************************************************
C
C LINE PRINTER SECTION (ONLY HERE IF LPT: SPECIFIED)
C
161 J=100
23 J=J+1
CALL JOBNUM (K)
K=K+100
ENCODE(10,24,FILNAM) J,K
24 FORMAT('WMU',I3,'.',I3)
CALL EXIST(FILNAM,IERR,0,0)
IF(IERR.EQ.0) GO TO 23
I=I+1
IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 130
IF(IN(I).EQ.'/') GO TO 27
25 WRITE(IDLG,26)
26 FORMAT('+Only a /COPIES switch may follow a LPT:'/)
GO TO 1
27 IF((IN(I+1).NE.'C').OR.(IN(I+2).NE.'O').OR.
1(IN(I+3).NE.'P').OR.(IN(I+4).NE.'I').OR.
1(IN(I+5).NE.'E').OR.(IN(I+6).NE.'S').OR.(IN(I+7).NE.':'))
1 GO TO 160
I=I+7
160 INN(1)=' '
INN(2)=' '
J=1
I=I+1
28 IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 33
IF((IN(I).LT.'0').OR.(IN(I).GT.'9')) GO TO 29
IF(J.GT.2) GO TO 31
INN(J)=IN(I)
J=J+1
I=I+1
GO TO 28
29 WRITE(IDLG,30) IN(I)
30 FORMAT('+Illegal character "',A1,'" in COPIES 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
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 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(ILAST.EQ.1)GO TO 2111
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.LT.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
*
**************************************************************************
*
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
C
C REPRINTING PRIVILEGES WERE GRANTED BY
C PERMISSION OF THE ASSOCIATION FOR COM-
C PUTING MACHINERY, BUT NOT FOR PROFIT.
C
FUNCTION FISHER(M,N,X)
C
C REFERENCE:
C COMMUNICATIONS OF THE A.C.M.
C FEBRUARY 1971, PAGE 117
C
C COMMENT:
C IF DF1=1 AND DF2>1000, INVERSE INTERPOLATION IS USED;
C FISHER=(1-1000/DF2)*FISHER(INFINITY)+1000/N*FISHER(1000)
C (PER: M. STOLINE - 28 APR 77)
C
C***** WMU-AM: #99.25.1, MOD=2, MTO, 24-OCT-77 *****
C
C MINOR REVISION (MOD=2) BY MTO ON 24-OCT-77
C (1) CLEANUP LOGIC & IMPROVE INTELLIGABLILITY
C (2) ADD INFORMATIVE ERROR MESSAGES FOR BAD DATA
C (3) ADD DOCUMENTAION WHERE CODE IS UNCLEAR
C (4) FIX BUG WHICH CAUSES THE INPUT PARAMETER 'N'
C TO BE MODIFIED (SET TO 0) WHEN 'X' IS ZERO
C (5) PAGINATE THE ENTIRE LIBRARY
C
C INPUT PARAMETERS:
C M = # OF DEGREES OF FREEDOM (BETWEEN)
C N = # OF DEGREES OF FREEDOM WITHIN
C X = 'F' VALUE TO FIND THE PROBABILITY OF
C
LOGICAL ODD, EVEN
ODD (N) = (N.AND.1) .NE. 0
EVEN(N) = .NOT. ODD(N)
C**SAVE 'N' IN 'NX' SO WE CAN RESTORE IT LATER
NX=N
IF(X.EQ.0.0)GO TO 321
IF(M.EQ.1)GO TO 200
C**THIS STATEMENT REMOVED BECAUSE THE ROUTINE AT
C**201 IS INCORRECT**RRB**3MAY77**
C** IF((M+N).GT.400)GO TO 201
200 NX=N
IF(N.GT.1000)N=1000
C** IF M,N IS ODD, SET NA,NB TO 1
C** IF M,N IS EVEN, SET NA,NB TO 2
NA=2*(M/2)-M+2
NB=2*(N/2)-N+2
IF(N.EQ.0) TYPE 1
1 FORMAT (' % FISHER: ZERO DEGREES OF FREEDOM WITHIN')
W=X*FLOAT(M)/FLOAT(N)
Z=1.0/(1.0+W)
IF (ODD (M)) GOTO 10
IF (ODD (N)) GOTO 9
C**(M EVEN, N EVEN)
D=Z*Z
P=W*Z
GO TO 100
C**(M EVEN, N ODD)
9 P=SQRT(Z)
D=0.5*Z*P
P=1.0-P
GO TO 100
C**(M ODD, N EVEN)
10 IF (ODD (N)) GOTO 15
P=SQRT(W*Z)
D=0.5*P*Z/W
GO TO 100
C**(M ODD, N ODD)
15 P=SQRT(W)
Y=.3183098862
D=Y*Z/P
P=2.0*Y*ATAN(P)
100 Y=2.0*W/Z
IF(N.LT.(NB+2))GO TO 111
IF (EVEN (M)) GOTO 105
DO 101 J=NB+2,N,2
D=(1.0+FLOAT(NA)/FLOAT(J-2))*D*Z
101 P=P+D*Y/FLOAT(J-1)
GO TO 111
105 ZK=0
IF((ALOG10(Z)*(N-1)/2).GE.-37) ZK=Z**((N-1)/2)
107 D=D*ZK*FLOAT(N)/FLOAT(NB)
P=P*ZK+W*Z*(ZK-1.0)/(Z-1.0)
111 CONTINUE
Y=W*Z
Z=2.0/Z
NB=N-2
IF(M.LT.(NA+2)) GO TO 103
DO 102 I=NA+2,M,2
J=I+NB
D=Y*D*FLOAT(J)/FLOAT(I-2)
P=P-Z*D/FLOAT(J)
102 CONTINUE
103 FISHER=1-P
IF(FISHER.LT.0)FISHER=0
GO TO 322
321 FISHER=1.0
322 N=NX
IF(N.LE.1000)RETURN
IF(X.LT.0.0) TYPE 2
2 FORMAT (' % FISHER: NEGATIVE F-VALUE')
FP2=(1.-CDFN(SQRT(X)))*2.
FISHER=(1.-1000./N)*FP2+(1000./N)*FISHER
RETURN
C**FROM HERE ON DOWN, CODE IS INCORRECT AND INACCESSABLE
201 IND=0
MI=M
NI=N
XI=X
IF(XI.GE.1)GO TO 203
IND=1
ISAVE=NI
NI=MI
MI=ISAVE
XI=1.0/XI
203 Z1=2.0/FLOAT(9*MI)
Z2=2.0/FLOAT(9*NI)
Z=ABS((1.0-Z2)*XI**(.33333333)-1.0+Z1)
Z=Z/SQRT(Z2*XI**(.66666667)+Z1)
C IF(N.GE.4)GO TO 205
IF(NI.GE.4)GO TO 205
Z=Z*(1.0+.08*Z**4)/FLOAT(NI)**3
205 Z=(1.0+Z*(.196854+Z*(.115194+Z*(.000344+Z*.019527))))**4
FISHER=.5/Z
IF(IND.EQ.1)FISHER=1.0-FISHER
RETURN
END