Trailing-Edge
-
PDP-10 Archives
-
decuslib10-10
-
43,50521/aplb10.for
There are 4 other files named aplb10.for in the archive. Click here to see a list.
C APPLICATIONS MODIFICATION HISTORY -- APLB10.FOR
C
C #1
C #2 24-OCT-77 MTO
C #3 27-NOV-78 WG
C #4 12-JAN-79 RRB
C #5 2-FEB-79 MSL (CALC,DSKSRT)
C
C*******************************************************
C
C SUBROUTINE IO. ORIGINALLY WRITTEN BY SAM ANEMA.
C MODIFIED BY RUSS BARR, AND BERENICE HOUCHARD.
C
C REWRITTEN BY DICK HOUCHARD JAN 1976
C
C CALL SEQUENCE CALL IO(KNOUT,IDEV,DEVNAM,REALDV,FILNAM,IPROJ,IPROG,IBNK)
C WHERE:
C KNOUT - IS A SINGLE WORD QUANTITY USED TO INDICATE WHETHER
C THE USER IS REQUESTING AN INPUT OR OUTPUT.
C 1 = OUTPUT ROUTINE ASKS QUESTION.
C 0 = INPUT , ROUTINE ASKS QUESTION
C -1 = OUTPUT MAINLINE ASKS QUESTION.
C -2 = INPUT, MAINLINES ASKS QUESTION.
C IDEV - DEVICE NUMBER (MUST BE BETWEEN 1 AND 30
C DEVNAM - TWO WORD QUANTITY RETURNED FROM SUBROUTINE
C CONTAINING THE DEVICE NAME INDICATED BY USER.
C REALDV - SINGLE WORD QUANTITY RETURNED BY SUBROUTINE CONTAINING
C "TTY" IF THE DEVICE IS A TELETYPE
C "DSK" IF THE DEVICE IS A DISK
C " " IF THE DEVICE IS OTHER THAN A TELETYPE AND DISK
C FILNAM - TWO WORD VARIABLE CONTAINING THE FILENAME(IF NEEDED)
C OF THE FILE REQUESTED BY THE USER.
C IPROJ - 1 WORD QUANTITY RETURNED BY THE KPROGRAM
C CONTAINING THE PROJECT NUMBER WHERE THE FILE IS FOUND.
C IPRG - 1 WORD QUANTITY RETURNED BY THE PROGRAM TO INDICATED
C PROGRAMMER NUMBER WHERE THE FILE EXISTS.
C IBNK - 1 WORD KVARIABLE RETURNED FROM THE SUBROUTINE
C INDICATING WHETHER THE FILE IS A
C BANK FILE OR NOT (0= IS NOT, 1= IS)
C
C IN RESPONDING TO THE SUBROUTINE THE USER MAY TERMINATE WITH
C A CARRIAGE RETURN OR ALTMODE.
C
C ADDITION ROUTINE NEEDED ARE:
C GES - ROUTINE READS INPUT FROM THE TELETYPE WITH AN A1 FORMAT
C ALSO ALLOWS THE TERMINATION OF A LINE WITH AND ALTMODE.
C DEVCHR - RETURNS THE DEVICE CHARASTICS OF A SPECIFED
C DEVICE
C GETPPN - RETURNS PROJECT PROGRAMMER NUMBER OF USER.
C EXISTS - CHECKS FOR THE EXISTANCE OF A FILE.
C RUNUUO - ENTERS A RUN CLASS COMMAND FROM THE PROGRAM.
C PRINTS - ALLOWS THE PROGRAM TO ENTER A FILE INTO THE
C LINEPRINTER SPOOLER.
C JOBNUM - RETURN JOB NUMBER OF USER.
C
C
C
SUBROUTINE IO(KNOUT,IDEV,DEVNAM,REALDV,FILNAM,IPROJ,IPROG,IBNK)
COMMON /INIO/ IFTR,IFTW,DEVN(30),FILNM(30),IPP(30),DEST(30)
COMMON/IOB/LEFBK,IRTBK,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,II,OUTDV
DIMENSION IN(80),INN(10),IPN(3)
DOUBLE PRECISION FILNAM,FILNM,TMP,DEVNAM,DEVN
INOUT=KNOUT
IF(INOUT.LT.0) INOUT=INOUT+2
SETSW=0
IALT="155004020100
IRTBK="565004020100
LEFBK="555004020100
IPN(3)=0
1 DEVNAM='TTY'
CALL DEVCHR(DEVNAM,IDCHAR)
FILNAM=' '
CALL GETPPN(IPROJ,IPROG)
IBNK=0
ICOPS=1
IF(KNOUT.LT.0) GO TO 7
IF(INOUT.EQ.1) GO TO 4
IF(IFTR.EQ.0)WRITE(IDLG,2)
2 FORMAT('+INPUT? (for help type HELP) '$)
IF(IFTR.NE.0) WRITE(IDLG,3)
3 FORMAT('+INPUT? ',$)
IFTR=1
GO TO 7
4 IF(IFTW.EQ.0) WRITE(IDLG,5)
5 FORMAT('+OUTPUT? (for help type HELP) ',$)
IF(IFTW.NE.0) WRITE(IDLG,6)
6 FORMAT('+OUTPUT? ',$)
IFTW=1
C
C CALL GES DOES SAME THING AS READ WITH FORMAT OF 80A1,
C EXCEPT IT WILL ALSO TERMINATE WITH AN ALTMODE.
C ICHECK+2 IMPLIES CONTROL Z WAS HIT
C
7 CALL GES(IN,80,ICHECK)
IF(ICHECK.EQ.2) GO TO 90
C
C COMPRESS OUT BLANKS
C
J=1
DO 8 I=1,80
IF(IN(I).EQ.' ') GO TO 8
C CHANGE ALL LOWER CASE TO UPPER CASE LETTERS
IF((IN(I).GE."605004020100).AND.(IN(I).LE."751004020100))
1IN(I)=IN(I).AND."577777777777
IN(J)=IN(I)
J=J+1
8 CONTINUE
IF(J.EQ.81) GO TO 10
DO 9 I=J,80
9 IN(I)=' '
IF(J.EQ.1) GO TO 71
IF(IN(1).EQ.IALT) GO TO 71
C
C DEVICE (PICK UP UNTIL SPACE, ALTMODE, OR <CR>)
C
10 DO 11 I=1,10
11 INN(I)=' '
I=1
J=1
12 IF(IN(I).EQ.' ') GO TO 40
IF(IN(I).EQ.':') GO TO 15
IF(IN(I).EQ.IALT) GO TO 40
IF(IN(I).EQ.LEFBK) GO TO 40
IF(J.GT.10) GO TO 13
INN(J)=IN(I)
J=J+1
I=I+1
GO TO 12
13 WRITE(IDLG,14)
14 FORMAT('+Either a colon was missing or the file name',
1' is too long'/)
GO TO 1
15 ENCODE(10,16,DEVNAM) (INN(J),J=1,10)
16 FORMAT(80A1)
CALL DEVCHR(DEVNAM,IDCHAR)
IF(IDCHAR.NE.0) GO TO 18
WRITE(IDLG,17) DEVNAM
17 FORMAT('+Device ',A6,' does not exist'/)
GO TO 1
18 IF(INOUT.EQ.1) GO TO 20
IF((IDCHAR.AND."000002000000).NE.0) GO TO 35
WRITE(IDLG,19) DEVNAM
19 FORMAT('+Device 'A6,' cannot do input'/)
GO TO 1
20 IF((IDCHAR.AND."000001000000).NE.0) GO TO 22
WRITE(IDLG,21) DEVNAM
21 FORMAT('+Device ',A6,' cannot do output.'/)
GO TO 1
22 IF((IDCHAR.AND."040000000000).EQ.0) GO TO 35
C
C
C *************************************************************
C
C LINE PRINTER SECTION (ONLY HERE IF LPT: SPECIFIED)
C
161 J=100
23 J=J+1
CALL JOBNUM (K)
K=K+100
ENCODE(10,24,FILNAM) J,K
24 FORMAT('WMU',I3,'.',I3)
CALL EXIST(FILNAM,IERR,0,0)
IF(IERR.EQ.0) GO TO 23
I=I+1
IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 130
IF(IN(I).EQ.'/') GO TO 27
25 WRITE(IDLG,26)
26 FORMAT('+Only a /COPIES switch may follow a LPT:'/)
GO TO 1
27 IF((IN(I+1).NE.'C').OR.(IN(I+2).NE.'O').OR.
1(IN(I+3).NE.'P').OR.(IN(I+4).NE.'I').OR.
1(IN(I+5).NE.'E').OR.(IN(I+6).NE.'S').OR.(IN(I+7).NE.':'))
1 GO TO 160
I=I+7
160 INN(1)=' '
INN(2)=' '
J=1
I=I+1
28 IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 33
IF((IN(I).LT.'0').OR.(IN(I).GT.'9')) GO TO 29
IF(J.GT.2) GO TO 31
INN(J)=IN(I)
J=J+1
I=I+1
GO TO 28
29 WRITE(IDLG,30) IN(I)
30 FORMAT('+Illegal character "',A1,'" in COPIES swicth'/)
GO TO 1
31 WRITE(IDLG,32)
32 FORMAT('+Copies must be between 1 and 63.'/)
GO TO 1
33 IF(J.EQ.1) GO TO 162
IF(INN(2).NE.' ') GO TO 162
INN(2)=INN(1)
INN(1)=' '
162 ENCODE(2,16,ATMP)(INN(J),J=1,2)
DECODE(2,34,ATMP) ICOPS
34 FORMAT(I2)
IF((ICOPS.LT.1).OR.(ICOPS.GT.63)) GO TO 31
130 IF(DEVN(IDEV).EQ.0) GO TO 89
CLOSE(UNIT=IDEV)
CALL DEVCHR(DEVN(IDEV),LCHAR)
IF(DEST(IDEV).LT.-100) IFTW=1
IF((LCHAR.AND."040000000000).EQ.0) GO TO 89
ICOPS=-DEST(IDEV)
IF(ICOPS.GT.100) ICOPS=ICOPS-100
NPAGES=IPAGCT*ICOPS+3
IF(IPAGCT.GT.0)CALL PRINTS(FILNM(IDEV),2,1,ICOPS,NPAGES)
IF(IPAGCT.LT.0) CALL PRINTS(FILNM(IDEV),2,1,ICOPS)
IPAGCT=0
89 OPEN(UNIT=IDEV,DEVICE='DSK',FILE=FILNAM,ACCESS='SEQOUT')
GO TO 76
C
C *************************************************************
C
C
C ##############################################################
C
C ALL OTHER DEVICES ARE CHANNELED THROUGH HERE
C
C FIRST A CHECK IS MADE TO SEE IF IT IS A DIRECTORY DEVICE
C OR NOT (DTA AND DSK ARE DIRECTORY DEVICES).
C
35 IF((IDCHAR.AND."000004000000).EQ.0) GO TO 36
FILNAM='INPUT.DAT'
IF(INOUT.EQ.1) FILNAM='OUTPUT.DAT'
36 I=I+1
IF(IN(I).NE.'/') GO TO 38
WRITE(IDLG,37)
37 FORMAT('+Only switch available if for the LPT'/)
GO TO 1
38 IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 71
IF((IDCHAR.AND."000004000000).NE.0) GO TO 41
WRITE(IDLG,39)
39 FORMAT('+Non-directory devices require no additional information'
1/)
GO TO 1
C
C ############################################################
C
C
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!h
C
C DEVICE HAS BEEN HANDLED. AT THIS POINT IT IS A
C DIRECTORY DEVICE. NOW GET THE FILENAME AND
C PROJECT-PROGRAMMER NUMBER (IF THEY EXIST)
C
41 DO 42 J=1,10
42 INN(J)=' '
J=1
43 IF(IN(I).EQ.' ') GO TO 46
IF(IN(I).EQ.LEFBK) GO TO 46
IF(IN(I).EQ.IALT) GO TO 46
IF(J.GT.10) GO TO 44
INN(J)=IN(I)
J=J+1
I=I+1
GO TO 43
44 WRITE(IDLG,45)
45 FORMAT('+File name too long'/)
GO TO 1
C
C !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
C
40 DEVNAM='DSK'
FILNAM='INPUT.DAT'
IF(INOUT.EQ.1) FILNAM='OUTPUT.DAT'
CALL DEVCHR(DEVNAM,IDCHAR)
C
C =============================================================
C
C FILE NAME? CHECK FOR ALL OTHER POSSIBILITIES FIRST
C
46 ENCODE(10,16,TMP) INN
IF(TMP.EQ.' ') GO TO 112
IF(TMP.EQ.'/STP ') GO TO 80
IF(TMP.EQ.'/BANK ') GOTO 80
IF(TMP.EQ.'/REGR ') GO TO 80
IF(TMP.EQ.'/TAB ') GO TO 80
IF(TMP.EQ.'/FREQ ') GO TO 80
IF(TMP.EQ.'/CORL ') GO TO 80
IF(TMP.EQ.'SAME ') GO TO 83
IF(TMP.EQ.'CONTINUE ') GO TO 140
IF(TMP.EQ.'/OUT ') GO TO 100
IF(TMP.EQ.'/OUTPUT ') GO TO 100
IF(TMP.EQ.'END ') GO TO 90
IF(TMP.EQ.'FINI ') GO TO 90
IF(TMP.EQ.'FINISH ') GO TO 90
IF(TMP.EQ.'HELP ') GO TO 150
C
C ===============================================================
C
C
C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C IT IS A FILE NAME. IS IT A BANK? IS THER A PROJECT-
C PROGRAMMER NUMBER?
C
C
IDP=0
DO 113 J=1,10
IF(INN(J).EQ.' ') GO TO 113
IF(INN(J).EQ.'.') GO TO 115
IF((INN(J).GE.'0').AND.(INN(J).LE.'9')) GO TO 113
IF((INN(J).LE.'Z').AND.(INN(J).GE.'A')) GO TO 113
WRITE(IDLG,114) INN(J)
114 FORMAT('+Character"',a1,'" is not valid in a file name'/)
GO TO 1
115 IDP=IDP+1
IF(IDP.EQ.1) GO TO 113
WRITE(IDLG,116)
116 FORMAT('+Only one period is allowed in the file name.'/)
GO TO 1
113 CONTINUE
IF(IDP.EQ.1) GO TO 117
J=1
118 IF(INN(J).EQ.' ') GO TO 119
J=J+1
IF(J.LE.7) GO TO 118
GO TO 44
119 INN(J)='.'
ENCODE(10,16,TMP) INN
117 J=1
47 J=J+1
IF(J.GT.7) GO TO 49
IF(INN(J).NE.'.') GO TO 47
IF((INN(J+1).NE.'B').OR.(INN(J+2).NE.'N').OR.
1(INN(J+3).NE.'K')) GO TO 49
IBNK=1
IF((IDCHAR.AND."200000000000).NE.0) GO TO 110
WRITE(IDLG,48)
48 FORMAT('+BANK files must be read from the disk'/)
GO TO 1
110 IF(INOUT.EQ.0) GO TO 49
WRITE(IDLG,111)
111 FORMAT('+Bank files can not be used for output.'/)
GO TO 1
49 FILNAM=TMP
112 IF(IN(I).NE.LEFBK) GO TO 71
C %%%%%%%%%%%%%%%%%%%%%%%i( PROJECT NUMBER )%%%%%%%%%%%%%%%%%%%%%
DO 50 J=1,10
50 INN(J)=' '
J=1
I=I+1
51 IF(IN(I).EQ.IRTBK) GO TO 56
IF(IN(I).EQ.',') GO TO 58
IF((IN(I).LT.'0').OR.(IN(I).GT.'7')) GO TO 54
IF(J.GT.6) GO TO 52
INN(J)=IN(I)
J=J+1
I=I+1
GO TO 51
52 WRITE(IDLG,53)
53 FORMAT('+PROJECT or PROGRAMMER number cannont be longer'/
1' than 6 characters'/)
GO TO 1
54 WRITE(IDLG,55) IN(I)
55 FORMAT('+Illegal character "',a1,'" in PROJECT-PROGRAMMMER',
1' number'/)
GO TO 1
56 WRITE(IDLG,57)
57 FORMAT('+ Comma missing between PROJECT and PROGRAMMER number'/)
GO TO 1
58 IF(J.EQ.1) GO TO 65
60 IF(INN(10).NE.' ') GO TO 61
DO 59 J=9,1,-1
59 INN(J+1)=INN(J)
INN(1)=' '
GO TO 60
61 ENCODE(10,16,TMP) INN
DECODE(10,62,TMP) IPROJ
62 FORMAT(O10)
C %%%%%%%%%%%%%%%%%%%%%%%%%%%%i( PROGRAMMER NUMBER )%%%%%%%%%%%%%%i
65 DO 63 J=1,10
63 INN(J)=' '
J=1
I=I+1
64 IF(IN(I).EQ.IRTBK) GO TO 66
IF(IN(I).EQ.' ') GO TO 66
IF(IN(I).EQ.IALT) GO TO 66
IF((IN(I).LT.'0').OR.(IN(I).GT.'7')) GO TO 54
IF(J.GT.6) GO TO 52
INN(J)=IN(I)
J=J+1
I=I+1
GO TO 64
66 IF(J.EQ.1) GO TO 92
67 IF(INN(10).NE.' ') GO TO 68
DO 69 J=9,1,-1
69 INN(J+1)=INN(J)
INN(1)=' '
GO TO 67
68 ENCODE(10,16,TMP) INN
DECODE(10,62,TMP) IPROG
92 IF(IN(I).NE.IRTBK) GO TO 91
I=I+1
91 IF((IN(I).EQ.' ').OR.(IN(I).EQ.IALT)) GO TO 71
WRITE(IDLG,70)
70 FORMAT('+Nothing should follow the closing bracket for the',
1' PROJECT-PROGRAMMER number'/)
GO TO 1
C
C @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
C
C
C $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
C
C THIS PORTION DOES THE ACTUAL OPEN ALL PERTINENT DATA IS AVAILABLE
C IF PROBLEMS EXIST THEY ARE IRONED OUT HERE.
C
71 IPN(1)=IPROJ
IPN(2)=IPROG
IERR=0
IF(INOUT.EQ.0) CALL EXISTS(DEVNAM,FILNAM,IERR,IPROJ,IPROG)
IF(IERR.EQ.0) GO TO 131
WRITE(IDLG,72)
72 FORMAT('+File not found or protected'/)
GO TO 1
131 IF(DEVN(IDEV).EQ.0) GO TO 73
CLOSE(UNIT=IDEV)
CALL DEVCHR(DEVN(IDEV),LCHAR)
IF(DEST(IDEV).LT.-100) IFTW=1
IF((LCHAR.AND."040000000000).EQ.0) GO TO 73
ICOPS=-DEST(IDEV)
IF(ICOPS.GT.100) ICOPS=ICOPS-100
NPAGES=IPAGCT*ICOPS+3
IF(IPAGCT.GT.0) CALL PRINTS(FILNM(IDEV),2,1,ICOPS,NPAGES)
IF(IPAGCT.LT.0) CALL PRINTS(FILNM(IDEV),2,1,ICOPS)
IPAGCT=0
73 IF(IBNK.EQ.1) GO TO 75
IF(INOUT.EQ.0) OPEN(UNIT=IDEV,DEVICE=DEVNAM,FILE=FILNAM,
1ACCESS='SEQIN',DIRECTORY=IPN)
IF(INOUT.EQ.1) OPEN(UNIT=IDEV,DEVICE=DEVNAM,FILE=FILNAM,
1ACCESS='SEQOUT',DIRECTORY=IPN)
GO TO 76
75 OPEN(UNIT=IDEV,DEVICE=DEVNAM,FILE=FILNAM,ACCESS='RANDIN',
1DIRECTORY=IPN,MODE='BINARY',RECORD SIZE=126)
76 DEVN(IDEV)=DEVNAM
FILNM(IDEV)=FILNAM
IPP(IDEV)=IPROJ*8**6+IPROG
DEST(IDEV)=IBNK
REALDV=' '
IF((IDCHAR.AND."000010000000).NE.0) REALDV='TTY'
IF((IDCHAR.AND."200000000000).NE.0) REALDV='DSK'
IF(INOUT.EQ.0) GO TO 77
DEST(IDEV)=-ICOPS
IF(IFTW.EQ.1) DEST(IDEV)=-ICOPS-100
IF(IFTW.EQ.1) OUTDV=REALDV
IF((DEVN(IDEV).EQ.'LPT').AND.(IFTW.EQ.1)) OUTDV='LPT'
IFTW=IFTW+1
77 IF(SETSW.EQ.1) GO TO 105
RETURN
C
C ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C RUN TO ANOTHER BANK PROGRAM
C CLOSE ALL OUTPUT FILES PRIOR TO THE RUN.
C
80 ENCODE(10,81,IN)(INN(J),J=2,5)
81 FORMAT('R ',4A1,4X)
IN(3)=0
DO 82 J=1,30
IF(DEST(J).GE.0) GO TO 82
CLOSE(UNIT=J)
IF(DEVN(J).NE.'LPT') GO TO 82
ICOPS=-DEST(J)
IF(ICOPS.GT.100) ICOPS=ICOPS-100
NPAGES=IPAGCT*ICOPS+3
IF(IPAGCT.GT.0) CALL PRINTS(FILNM(J),2,1,ICOPS,NPAGES)
IF(IPAGCT.LT.0) CALL PRINTS(FILNM(J),2,1,ICOPS)
82 CONTINUE
CALL RUNUUO (IN)
C
C +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>_
C
C SAME WAS USED.
C
C
C
83 IF(DEVN(IDEV).NE.0) GO TO 87
WRITE(IDLG,86)
86 FORMAT('+You must have answered this question in this',
1' program previously to use "SAME" now.'/)
GO TO 1
87 DEVNAM=DEVN(IDEV)
FILNAM=FILNM(IDEV)
IPROJ=IPP(IDEV)/8**6
IPROG=IPP(IDEV)-IPROJ*8**6
IBNK=0
IF(DEST(IDEV).EQ.1) IBNK=1
ICOPS=-DEST(IDEV)
IF(ICOPS.GT.100) ICOPS=ICOPS-100
CALL DEVCHR(DEVNAM,IDCHAR)
IF(INOUT.EQ.1) CLOSE(UNIT=IDEV)
IF((IDCHAR.AND."040000000000).NE.0) GO TO 130
IF((IDCHAR.AND."000020000000).NE.0) BACKFILE IDEV
GO TO 71
C
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>_>>>>>>>>_>>>>_
C
C
C
C ///////////////////////////////////////////////////////////////
C
C FINI. FINISH, END OR CONTROL Z WAS USED. CLOSE FILES AND
C REOPEN
C
C
90 DO 99 J=1,30
IF(DEST(J).GE.0) GO TO 99
CLOSE(UNIT=J)
IF(DEVN(J).NE.'LPT') GO TO 99
ICOPS=-DEST(J)
IF(ICOPS.GT.100) ICOPS=ICOPS-100
NPAGES=IPAGCT*ICOPS+3
IF(IPAGCT.GT.0) CALL PRINTS(FILNM(J),2,1,ICOPS,NPAGES)
IF(IPAGCT.LT.0) CALL PRINTS(FILNM(J),2,1,ICOPS)
99 CONTINUE
CALL EXIT
C
C /////////////////////////////////////////////////////////////
C
C
C <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<^<<<<<<^
C
C /OUTPUT OR /OUT USED.
C
C
100 IF(SETSW.EQ.0) GO TO 106
WRITE(IDLG,107)
107 FORMAT('+You cannot do a /OUT while answering a /OUT'/)
GO TO 1
106 DO 101 J=1,30
IF(DEST(J).LT.-100) GO TO 103
101 CONTINUE
WRITE(IDLG,102)
102 FORMAT(' No output defined yet'/)
GO TO 1
103 LDEV=IDEV
IDEV=J
LNOUT=INOUT
INOUT=1
SETSW=1
GO TO 1
105 SETSW=0
IDEV=LDEV
INOUT=LNOUT
GO TO 1
C
C >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
C
C ::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::]
C
C CONTINUE WAS USED.
C
C
140 IF(DEVN(IDEV).NE.0) GO TO 142
WRITE(IDLG,141)
141 FORMAT('+To use the CONTINUE an input must have already been',
1' defined.'/)
GO TO 1
142 FILNAM=FILNM(IDEV)
DEVNAM=DEVN(IDEV)
IPROJ=IPP(IDEV)/8**6
IPROG=IPP(IDEV)-IPROJ*8**6
IBNK=0
IF(DEST(IDEV).EQ.1) IBNK=1
ICOPS=-DEST(IDEV)
IF(ICOPS.GT.100) ICOPS=ICOPS-100
CALL DEVCHR(DEVNAM,IDCHAR)
IF(INOUT.EQ.1) GO TO 77
GO TO 71
C
C :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::]
C
C
C ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
C
C HELP
C
150 IF(INOUT.EQ.1) GO TO 155
WRITE(IDLG,151)
151 FORMAT(
1' The answer to this question defines where the program is'/
1' to find the data. It usually consists of a device, and'/
1' possibly a file name with or without a PROJECT-PROGRAMMER'/
1' number. Devices may be specified by their physical'/
1' or logical name followed by a colon (:). If the'/
1' device is a directory device (DSK, DTA), then a filename,'/
1' extension and PROJECT-PROGRAMMER number may follow it.'/
1' If the device used is a magtape or dectape, the tape'/
1' must be mounted, and in the case of a magtape it must'/
1' be positioned.'/'0DEFAULTS:'/
1' (1) If no input devices is specified but a filename is'/
1' given, the default device will be DSK:.'/
1' (2) If a device which requires a filename and extension'/
1' is specified, but no filename is given INPUT.DAT'/
1' will be used.'/
1' (3) If no response is given (CARRIAGE RETURN is entered)'/
1' the default is TTY:.'/
1' (4) If DSK: is specified as the input device, but no')
WRITE(IDLG,152)
152 FORMAT(
1' PROJECT-PROGRAMMER number is used, the PROJECT-'/
1' PROGRAMMER number of the job is used.'/
1'0EXAMPLES:'/' DSK:DATA.DAT'/' TEST.DAT[220,220]'/
1' MTA:'/
1'0The following responses may also be used after the first'/
1' response to this question.'/
1' "CONTINUE" - (For MAGTAPE) Use the next set of data'/
1' "SAME" - Use same device specifications as used before.'/
1' "FINI" - End of run.'/
1' "/PROG" - User may initiate the run of a bank program'/
1' (STP, BANK, TAB, FREQ, CORL, or REGR) from'/
1' this program.'/
1' "/OUTPUT" - Redefine the output device, the program will'/
1' respond with "OUTPUT? ".'/)
GO TO 1
155 WRITE(IDLG,157)
157 FORMAT(
1'0The answer to this question defines the destination'/
1' for the program''s results. It usually consists of a device'/
1' and possibly a filename with or without an extension.'/
1' Devices may be indicated by their physical or'/
1' logical name followed by a colon (:). If the device is'/
1' a directory device (DSK, DTA), then a filename,'/
1' extension and PROJECT-PROGRAMMER number may follow it.'/
1' If the device used is a magtape or dectape, the tape'/
1' must be mounted, and in the case of the magtape, it must'/
1' be positioned. If the device is a lineprinter, the user'/
1' may request multiple copies by following the "LPT:" with'/
1' a "/COPIES:" and the number of copies desired (1-63).'/
1'0DEFAULTS:'/
1' (1) - If no input device is specified but a filename is'/
1' given, the default device will be DSK:')
WRITE(IDLG,156)
156 FORMAT(
1' (2) - If a device which requires a filename and extension"'/
1' is specified but no filename is given OUTPUT.DAT is'/
1' used.'/
1' (3) - If no response is given (a CARRIAGE RETURN is entered),'/
1' the default is TTY:.'/
1' (4) - If LPT: is spedified and no /COPEIS switch is used,'/
1' 1 copy is assumed.'/'0EXAMPLES:'/
1' DSK:SAM.F4'/' LPT:/COPIES:3'/' MTA:'/)
GO TO 1
END
C
C SUBROUTINE IOB(DATA BANK AND TTY:SAME MODIFICATION)
C
C
C INPUT/OUTPUT DEVICE/FILENAM/PPN HANDLER FOR FORTRAN
C
C
C
C WRITTEN BY SAM ANEMA - FEB 1972 - WMU COMPUTER CENTER
C
C MODIFICATIONS BY RUSSELL R. BARR - WMU COMPUTER CENTER
C DATE: 16 MAY 1973
C DATE: 25 JUL 1973(^Z ALTERNATIVE TO "FINISH")
C FIXED ON AUGUST 27, BY R. BARR(AFTER B. HOUCHARD) TO
C INITIALIZE IBNK.
C DATE: 31 JAN 1974 - 'CONTINU' OPTION AND 7 LETTER OPTION CHECK.
C DATE: 11 DEC 1974 - MADE COMPATABLE WITH FOROTS DEFINE FILE
C DATE: 5 FEB 75 - PATCH TO PRINT 'LPT' FILE EVERY TIME
C 'OUTPUT?' IS CALLED.
C
C SUBROUTINES USED: EXISTS IN FOROTS - NORM GRANT
C PRINTS - SYSTEM
C
C ARGUMENTS ACCEPTED:
C IORO - 0 = INPUT
C 1 = OUTPUT
C IDLG - DIALOG OUTPUT DEVICE NUMBER
C IRSP - DIALOG INPUT DEVICE NUMBER
C NDEVI - INPUT DEVICE NUMBER
C NDEVO - OUTPUT DEVICE NUMBER
C IDVI - INPUT DEVICE NAME
C IDVO - OUTPUT DEVICE NAME
C ICODE - 0 = TTY JOB
C - 1 = PSEUDO-TTY JOB(BATCH)
C ITYCH - ALTERNATE INPUT DEVICE NUMBER
C (USED FOR TTY: SAME OPTION. SEE NOTE(1))
C
C ARGUMENTS RETURNED:
C
C NDEVI - (SEE NOTE(1))
C IBNK - 0 = EXTENSION IS NOT '.BNK'
C 1 = EXTENSION IS '.BNK'
C NAMI(2) - ASCIZ INPUT FILE NAME
C NAMO(2) - ASCIZ OUTPUT FILE NAME
C IPJ,IPG- [P,PN] FOR INPUT FILE
C NCOPYS - NUMBER OF COPIES TO LPT:
C
C ADD'L OPTIONS:
C
C 'SAME ' - REWIND DEV. AND RETURN.
C (SEE NOTE (1) FOR USE WITH TTY:)
C 'CONTINU' - SAME AS 'SAME' BUT DONT REWIND BEFORE RETURN.
C 'FINISH ' - CLOSE DEV., PRINT IF LPT, EXIT.
C
C
C NOTE(1): TO USE THE TTY:SAME OPTION - IN THE MAIN;
C ASSIGN AN UNUSED FORTRAN DEVICE NUMBER TO ITYCH.
C INSERT CHANGES FOR READ SIMILAR TO THE FOLLOWING:
C
C OLD: READ(NDEVI,IFMT)LIST...
C
C NEW: IF(NDEVI.EQ.ITYCH)GO TO 9998
C READ(NDEVI,IFMT)LIST...
C WRITE(ITYCH)LIST...
C GO TO 9999
C 9998 READ(NDEVI)LIST...
C 9999 .........
C
C NOTE(2): RESPONSES ARE IN THE FORM;
C
C DTA1:FILDAT.DAT
C DATA1.DAT (DSK: AND USER'S PPN ASSUMED)
C LPT:/2
C <CR><LF> (STANDARD ASSUMPTIONS. SEE NOTE(3))
C
C NOTE(3): STANDATD ASSUMPTIONS
C
C FOR A TTY: JOB
C TTY: FOR INPUT
C TTY: FOR OUTPUT
C
C FOR A PSEUDO-TTY: JOB
C CDR: FOR INPUT
C LPT: FOR OUTPUT
C
C IF NO FILE NAME IS SPECIFIED, USES:
C INPUT.DAT FOR INPUT
C OUTPT.DAT FOR OUTPUT
C
SUBROUTINE IOB(IORO)
DIMENSION IN(50),INAME(2),B(10),NAM(2)
DOUBLE PRECISION JNAME
COMMON/IOBLK/IDLG,IRSP,NDEVI,NDEVO,IDVI,IDVO,ICODE,IBNK,NAMI(2)
COMMON/IOBLKA/NAMO(2),IPJ,IPG,NCOPYS,ITYCH
EQUIVALENCE (INAME,JNAME)
DATA L1,L2/"555004020100,"565004020100/
IF(JONCE.EQ.0)ITMP=NDEVI
NDEVI=ITMP
IF((IORO.AND.1).EQ.0)IDV=IDVI
IF((IORO.AND.1).EQ.1)IDV=IDVO
1 GO TO(401,403,402,404),IORO+1
401 WRITE(IDLG,310)
310 FORMAT(' INPUT? (TYPE HELP IF NEEDED)--',$)
402 IDEV=NDEVI
GO TO 405
403 WRITE(IDLG,311)
311 FORMAT(' OUTPUT? (TYPE HELP IF NEEDED)--',$)
404 IDEV=NDEVO
405 READ(IRSP,10,END=201)IN
10 FORMAT(50A1)
IF(IN(1).EQ.'F'.AND.IN(2).EQ.'I'.AND.IN(3).EQ.'N'.AND.
1 IN(4).EQ.'I'.AND.IN(5).EQ.'S'.AND.IN(6).EQ.'H'.AND.
1 IN(7).EQ.' ')GO TO 201
IF(IN(1).EQ.'S'.AND.IN(2).EQ.'A'.AND.IN(3).EQ.'M'.AND.
1 IN(4).EQ.'E'.AND.IN(5).EQ.' '.AND.IN(6).EQ.' '.AND.
1 IN(7).EQ.' ')GO TO 212
IF(IN(1).EQ.'C'.AND.IN(2).EQ.'O'.AND.IN(3).EQ.'N'.AND.
1 IN(4).EQ.'T'.AND.IN(5).EQ.'I'.AND.IN(6).EQ.'N'.AND.
1 IN(7).EQ.'U')RETURN
IF(IN(1).EQ.'H'.AND.IN(2).EQ.'E'.AND.IN(3).EQ.'L'.AND.
1IN(4).EQ.'P'.AND.IN(5).EQ.' '.AND.IN(6).EQ.' '.AND.
1IN(7).EQ.' ')GO TO (500,600),IORO+1
ITYFLG=0
CALL RELEAS(IDEV)
IF((IPR.NE.1).OR.((IORO.AND.1).NE.1))GO TO 491
CALL PRINTS(NAM,2,1,NCOPYS)
IPR=0
491 IBNK=0
NEVER=0
ICOLN=0
ILBR=0
ISL=0
IPROJ=0
IPROG=0
INAME(1)=' '
INAME(2)=' '
IDV=' '
K=0
IDP=0
12 K=K+1
IF(K.GT.50)GO TO 15
IF(IN(K).EQ.'.')IDP=1
IF(IN(K).EQ.':')GO TO 13
IF(IN(K).EQ."555004020100)GO TO 14
IF(IN(K).EQ.'/')GO TO 23
GO TO 12
13 ICOLN=K+4
DO 20 I=50,K+4,-1
20 IN(I)=IN(I-4)
DO 27 I=0,3
27 IN(K+I)=' '
K=K+4
GO TO 12
14 ILBR=K+9
DO 21 I=50,K+9,-1
21 IN(I)=IN(I-9)
DO 22 I=K,K+8
22 IN(I)=' '
K=K+9
GO TO 12
23 ISL=K
GO TO 12
15 IF(ILBR.EQ.0)GO TO 31
30 ENCODE(12,10,B)(IN(I),I=ILBR+1,ILBR+12)
DECODE(12,41,B)IPROJ,IPROG
41 FORMAT(2O)
31 IF(IDP.NE.0)GO TO 32
DO 33 I=ICOLN+9,ICOLN+1,-1
33 IF(IN(I).NE.' ')GO TO 34
I=6
34 IN(I+1)='.'
32 ENCODE(10,10,INAME)(IN(I),I=ICOLN+1,ICOLN+10)
IF(ICOLN.EQ.0)GO TO 101
100 ENCODE(5,10,IDV)(IN(I),I=1,5)
101 IF(ISL.EQ.0)GO TO 24
ENCODE(5,10,B)(IN(I),I=ISL+1,ISL+5)
DECODE(5,46,B)NCOPYS
46 FORMAT(I)
24 IF(IDV.NE.' ')GO TO 124
IF(INAME(1).EQ.' ')GO TO 28
IDV='DSK'
GO TO 124
28 IF(ICODE.EQ.-1)GO TO 125
IDV='TTY'
GO TO 124
125 IF((IORO.AND.1).EQ.0)IDV='CDR'
IF((IORO.AND.1).EQ.1)IDV='LPT'
124 CALL DEVCHG(IDV,IDEV)
D TYPE 9998,IDV,IDEV
D9998 FORMAT(1X,A5,I6)
IF(IDV.EQ.'DSK')GO TO 102
IF(IDV.EQ.'LPT')GO TO 104
IF(IDV.LE."422510134500.AND.IDV.GE."422510130100)GO TO 102
213 IF(IDV.EQ.'TTY'.AND.(IORO.AND.1).EQ.0)GO TO 214
GO TO 410
104 INAME(1)='OUTAA'
INAME(2)='A.AAA'
IPR=1
LPT=IDEV
CALL DEVCHG('DSK',IDEV)
105 CALL EXISTS(IDEV,INAME,MRK)
IF(MRK.EQ.1)GO TO 211
INAME(2)=INAME(2)+2
GO TO 105
211 NAM(1)=INAME(1)
NAM(2)=INAME(2)
102 IBNK=0
DECODE(10,10,INAME)(IN(JJ),JJ=1,10)
DO 1112 IB=10,3,-1
1112 IF(IN(IB).NE.' ')GO TO 1113
1113 IF(IN(IB-2).EQ.'B'.AND.IN(IB-1).EQ.'N'.AND.IN(IB).EQ.'K')
1 IBNK=1
IF(INAME(1).NE.' ')GO TO 302
IF((IORO.AND.1).EQ.0)INAME(1)='INPUT'
IF((IORO.AND.1).EQ.1)INAME(1)='OUTPT'
INAME(2)='.DAT'
302 IF((IORO.AND.1).EQ.1)GO TO 303
CALL EXISTS(IDEV,INAME,MRK,IPROJ,IPROG)
IF(MRK.EQ.0)GO TO 303
WRITE(IDLG,305)
305 FORMAT(' FILE DOES NOT EXIST'/)
D TYPE 9997,IDV,INAME,IPROJ,IPROG
D9997 FORMAT(1X,A5,1X,2A5,O13,O13)
IF(ICODE.EQ.-1)CALL EXIT
GO TO 1
303 CONTINUE
D TYPE 9999,IDEV,INAME,IPROJ,IPROG
D9999 FORMAT(I3,2X,2A5,O12,2X,O12)
ISZ=0
IF(IBNK.EQ.1)ISZ=126
CALL DEFINE FILE(IDEV,ISZ,NEVER,JNAME,IPROJ,IPROG)
GO TO 213
201 IF(IPR.EQ.1)CALL RELEAS(LPT)
IF(IPR.EQ.1)CALL PRINTS(NAM,2,1,NCOPYS)
CALL EXIT
212 IF(ITYFLG.EQ.1)GO TO 215
IF((IORO.AND.1).EQ.0)REWIND IDEV
GO TO 410
C NO TTY: SAME OPTION IF NO CHANNEL PROVIDED IN ITYCH
214 IF(ITYCH.LT.1)GO TO 410
IF(IONCE.NE.1)CALL DEVCHG('DSK',ITYCH)
IONCE=1
IF(ITYFLG.EQ.1)GO TO 215
ITYFLG=1
CALL RELEAS(ITYCH)
ISZ=0
IF(IBNK.EQ.1)ISZ=126
CALL DEFINE FILE(ITYCH,ISZ,NV,'TTYDAT.TMP',0,0)
410 IOROA=IORO.AND.1
IF(IOROA.EQ.1)GO TO 411
IPJ=IPROJ
IPG=IPROG
IDVI=IDV
NDEVI=IDEV
NAMI(1)=INAME(1)
NAMI(2)=INAME(2)
GO TO 412
411 NAMO(1)=INAME(1)
NAMO(2)=INAME(2)
IDVO=IDV
412 CONTINUE
JONCE=1
RETURN
215 REWIND ITYCH
IDEV=ITYCH
GO TO 410
500 WRITE(IDLG,501)
501 FORMAT('-THIS ANSWER DEFINES WHERE THE PROGRAM IS TO FIND THE
1 INPUT DATA. IT'/' USUALLY CONSISTS OF A DEVICE, POSSIBLY A
2 FILENAME WITH OR WITHOUT AN'/' EXTENSION, AND A PROJECT-
3PROGRAMMER NUMBER.'//' POSSIBLE DEVICES ARE:'//6X,'DEVICES',3X,
4 'DESCRIPTION'/6X,7('-'),3X,11('-')/6X,'TTY:',6X,'TERMINAL'/
5 6X,'DSK:',6X,'DISK (FILENAME AND EXTENSION, PROJECT-PROGRAMMER
6 NUMBER'/22X,'MAY BE USED)'/6X,'CDR:',6X,'CARD READER (THIS
7 DEVICE IS NOT APPLICABLE ON TERMINAL'/30X,'JOBS)'/6X,'DTA#:',5X,
8 'DECTAPE UNIT (USER''S DECTAPE SHOULD ALREADY BE MOUNTED)'/6X,
9 'MTA#:',5X,'MAGTAPE UNIT (USER''S MAGTAPE SHOULD ALREADY BE
1 MOUNTED'/30X,'AND POSITIONED)'///' DEFAULTS:'//' (1) IF NO INPUT
2 DEVICE IS SPECIFIED BUT A FILENAME IS GIVEN, THE'/6X,'DEFAULT
3 DEVICE WILL BE DSK:'//' (2) IF A DEVICE WHICH REQUIRES A
4 FILENAME AND EXTENSION IS SPECIFIED,'/6X,'BUT NO FILENAME IS
5 GIVEN, THE DEFAULT NAME WILL BE INPUT.DAT'//' (3) IF NO RESPONSE
6 IS GIVEN, I.E. A CARRIAGE RETURN <CR> IS ENTERED,'/6X,'THE
7 DEFAULT DEVICE IS TTY: ON JOBS RUN FROM TERMINALS; AND'/28X,'CDR:
8 ON BATCH JOBS'//' (4) IF DSK: IS SPECIFIED AS THE INPUT DEVICE
9 AND NO PROJECT-PROGRAMMER'/6X,'NUMBER IS GIVEN, THE USER''S
1 PROJECT-PROGRAMMER NUMBER WILL BE'/6X,'ASSUMED.'///)
WRITE(IDLG,502) L1,L2
502 FORMAT(' EXAMPLES: DATA.DAT'/14X,'TEST.DAT',A1,'420,420',A1/
1 14X,'MTA0:'/14X,'DTA2:FILE1'//' NOTE: THE FOLLOWING RESPONSES
2 ARE VALID AFTER THE FIRST "INPUT?"'//' (1) SAME COMMAND. IF THE
3 DATA FILE TO BE USED IS THE SAME AS THE'/6X,'PRECEEDING ONE, THE
5 USER MAY SIMPLY ENTER "SAME"'//' (2) FINISH COMMAND. THE USER
6 MUST ENTER "FINISH" TO EXIT FROM THE'/6X,'PROGRAM. THIS ENSURES
7 THAT OUTPUT ASSIGNED TO LPT: WILL BE'/6X,'PRINTED. FAILURE TO
8 USE THE "FINISH" COMMAND MAY RESULT IN'/6X,'LOSING THE ENTIRE
9 OUTPUT FILE.'//' (3) A ^Z (CONTROL Z) WILL RESULT IN THE SAME
1 ACTION AS THE "FINISH"'/6X,'COMMAND.'///)
503 CALL RELEAS (IDLG)
GO TO (401,403,401,403),IORO+1
600 WRITE(IDLG,601)
601 FORMAT('-THE ANSWER DEFINES WHERE THE OUTPUT FROM THE PROGRAM
1 IS TO BE PLACED.'/' IT USUALLY CONSISTS OF A DEVICE AND POSSIBLY
2 A FILENAME WITH OR WITH-'/' OUT AN EXTENSION.'//' POSSIBLE
3 DEVICES ARE:'//6X,'DEVICE',3X,'DESCRIPTION'/6X,6('-'),3X,
4 11('-')/6X,'TTY:',5X,'TERMINAL'/6X,'DSK:',5X,'DISK (FILENAME
5 AND EXTENSION MAY BE USED)'/6X,'LPT:',5X,'LINEPRINTER (MULTIPLE
6 COPIES MAY BE REQUESTED BY USE OF'/29X,'THE "/COPIES" COMMAND)'/
7 6X,'DTA#:',4X,'DECTAPE UNIT (USER''S DECTAPE SHOULD ALREADY
8 BE MOUNTED;'/29X,'FILENAME AND EXTENSION MAY BE USED.)'/
9 6X,'MTA#:',4X,'MAGTAPE UNIT (USER''S MAGTAPE SHOULD ALREADY
1 BE MOUNTED'/29X,'AND POSITIONED)'///' DEFAULTS:'//' (1) IF NO
2 OUTPUT DEVICE IS SPECIFIED BUT A FILENAME IS GIVEN, THE'/6X,
3 'DEFAULT DEVICE WILL BE DSK:'//' (2) IF A DEVICE WHICH REQUIRES
4 A FILENAME AND EXTENSION IS SPECIFIED,'/6X,'BUT NO FILENAME IS
5 GIVEN, THE DEFAULT NAME WILL BE OUTPT.DAT'//' (3) IF NO RESPONSE
6 IS GIVEN, I.E. A CARRIAGE RETURN <CR> IS ENTERED,'/6X,'THE
7 DEFAULT DEVICE IS TTY: ON JOBS RUN FROM TERMINALS; AND'/28X,'LPT:
8 ON BATCH JOBS'//' (4) IF LPT: IS LISTED AS THE OUTPUT DEVICE,
9 THE NUMBER OF COPIES WILL'/6X,'DEFAULT TO 1.'///
1 ' EXAMPLES: LPT:/2'/14X,'RPT.DAT'/14X,'DTA0:NAME.DAT'///)
GO TO 503
END
C
C THIS IS A SUBROUTINE WHICH WILL ASK FOR
C A FORMAT, ENTER THAT FORMAT AND RETURN
C
C THE ARGUMENTS ARE:
C
C IDLG - DEVICE NUMBER FOR OUTPUTTING DIALOGUE
C INP - DEVICE NUMBER FOR INPUTTING THE FORMAT
C IFMT - ARRAY WHICH WILL CONTAIN THE FORMAT
C ISTD - WILL INDICATE WHETHER STANDARD FORMAT IS
C REQUESTED
C 1 - STANDARD FORMAT IS REQUESTED
C 0 - FORMAT TO BE USED IS CONTAINED IN IFMT
C N - MAXIMUM SIZE OF THE FORMAT, NORMALLY THIS
C WILL BE THE NUMBER OF WORDS DIMENSIONED IN
C THE MAINLINE FOR IFMT
C ITYPE- INDICATE WHAT TYPE OF FORMAT TO USE
C 1 - IF I-TYPE IS TO BE USED
C 2 - IF F-TYPE IS TO BE USED
C 3 - IF A-TYPE IS TO BE USED
C 4 - NEITHER ONE OF THE ABOVE 3
C
SUBROUTINE GETFOR(IDLG,INP,IFMT,ISTD,N,ITYPE)
DIMENSION IFMT(1),IN(80),IDUM(3)
DATA IDUM/'I','F','A'/
KL=0
12 ISTD=0
L=0
NN=80
KOUNT=0
IF(N.EQ.0)CALL EXIT
IF (ITYPE.EQ.4) WRITE(IDLG,2)
2 FORMAT(' FORMAT'/)
IF (ITYPE.LE.3) WRITE(IDLG,120) IDUM(ITYPE)
120 FORMAT(' FORMAT: (',A1,'-TYPE ONLY)'/)
READ(INP,3)(IN(I),I=1,80)
3 FORMAT(80A1)
IF(L.EQ.1)GO TO 13
IF(IN(1).EQ.'S'.AND.IN(2).EQ.'A'.AND.IN(3).EQ.'M')RETURN
DO 1 I=1,N
1 IFMT(I)=' '
L=1
13 IF(N.LT.16)NN=N*5
DO 4 I=1,NN
IF(IN(I).NE.' ')GO TO 5
4 CONTINUE
6 ISTD=1
RETURN
5 IF(IN(I).NE.'(')GO TO 6
IBEG=1
9 ENCODE(NN,7,IFMT(IBEG))(IN(I),I=1,NN)
7 FORMAT(80A1)
DO 8 I=1,NN
IF(IN(I).EQ.'(')KOUNT=KOUNT+1
IF(IN(I).EQ.')')KOUNT=KOUNT-1
8 CONTINUE
IF(KOUNT.LT.1)RETURN
IBEG=IBEG+16
IF((IBEG+16).GT.N)NN=(N-IBEG+1)*5
IF(NN.LT.1)GO TO 10
READ(INP,3)(IN(I),I=1,80)
GO TO 9
10 IF(KL.EQ.1)CALL EXIT
WRITE(IDLG,11)
11 FORMAT(' ERROR IN FORMAT, TRY AGAIN.'/)
KL=1
GO TO 12
END
FUNCTION TPCT(ALPHA,KDF)
Z=ALPHA*ALPHA
Q=1./Z
T=SQRT(ALOG(Q))
U=((.010328*T+.802853)*T+2.515517)
C****WMU-AM:APLB10.FOR, MOD=3, WG,27-NOV-78 ****
V=(((.001308*T+.189269)*T+1.432788)*T+1.)
C**** END(FUNCTION TPCT), MOD=3
XP=T-U/V
X2=XP*XP
A=XP*(X2+1.)/4.
B=((5.*X2+16.)*X2+3.)*XP/96.
C=(((3.*X2+19.)*X2+17.)*X2-15.)*XP/384.
D=((((79.*X2+776.)*X2+1482.)*X2-1920.)*X2-945.)*XP/92160.
E=(((((27.*X2+339.)*X2+930.)*X2-1782.)*X2-765.)*X2+17955.)*XP/3686
140.
V=1./KDF
TPCT=XP+(A+(B+(C+(D+E*V)*V)*V)*V)*V
RETURN
END
FUNCTION FPCT(ALPHA,K1,K2)
SIG=1./K1+1./K2
DELT=1./K1-1./K2
Z=ALPHA*ALPHA
Q=1./Z
T=SQRT(ALOG(Q))
C=((.010328*T+.802853)*T+2.515517)
D=(((.001308*T+.189269)*T+1.432788)*T+1.)
E=C/D
XP=T-E
X=XP*XP
Z1=SQRT(SIG/2.)*XP
Z2=DELT*(X+2.)/6.
Z3=SQRT(SIG/2.)*(SIG*((X+3.)*XP)/24.+DELT**2*((X+11.)*XP)/(SIG*72.
1))
Z4=DELT*SIG*((X+9.)*X+8.)/120.-DELT**3*((3.*X+7.)*X-16.)/(SIG*3240
1.)
Z5=SQRT(SIG/2.)*(SIG**2*(((X+20.)*X+15.)*XP)/1920.+DELT**2*(((X+44
1.)*X+183.)*XP)/2880.+DELT**4*(((9.*X-284.)*X-1513)*XP)/(SIG**2*155
2520.))
Z6=DELT*SIG**2*(((4.*X-25.)*X-177.)*X+192.)/20160.+DELT**3*(((4.*X
1+101.)*X+117.)*X-480.)/90720.-DELT**5*(((12.*X+513.)*X+841.)*X-256
20.)/(SIG**2*1632960.)
Z7=SQRT(SIG/2.)*(SIG**3*((((X+7.)*X+7.)*X+105.)*XP)/21504.+DELT*SI
1G**2*((((801.*X+10511.)*X+30151.)*X+62241.)*XP)/4838400.-DELT**4*(
2(((477.*X+4507.)*X-82933.)*X-264363)*XP)/(SIG*43545600.)+DELT**6*(
3(((3753.*X+55383.)*X-368897.)*X-1213927.)*XP)/(SIG**3*1175731200.)
4)
ZP=Z1-Z2+Z3-Z4+Z5+Z6-Z7
AN=2.*ZP
FPCT=EXP(AN)
RETURN
END
C SUBROUTINE CALCULATES PROBABILITIES FOR CHI SQUARES
C CALLING SEQUENCE CALL CHIPRB(CHI,NF,PROB)
C WHERE CHI - VALUE OF CHI SQUARE
C NF - FIXED POINT DEGREES OF FREEDOM
C PROB - RETURNS PROBABILITY OF CHISQUARE (99 IF ERROR)
C
C ROUTINE FORM COMMUNICATIONS OF ACM APRIL 1967, CAS
C ALSO THE SUBROUTINE NORMCV. MACHINE ACCURACY ON EVEN DEGREES
C OF FREEDOM, AT LEAST 4 PLACES OF ACCURACY ON ODD DEGREES OF
C FREEDOM.(FOR ALL TABLES COMPARED AGAINST, THE PROBABILITY
C FROM THE PROGRAM AGREED TO ALL PLACES[BEST WAS 5])
C
SUBROUTINE CHIPRB(CHI,NF,PROB)
PROB=99
IF((CHI.LT.0).OR.(NF.LT.1)) RETURN
IEVEN=NF.AND.1
A=.5*CHI
Y=0
C EXP(-85)(=1.216E-37) IS THE BEST WHICH CAN BE USED WITH PDP
IF(((IEVEN.EQ.0).OR.(NF.GT.2)).AND.(A.LT.85)) Y=EXP(-A)
S=Y
IF(IEVEN.EQ.0) GO TO 3
S=-SQRT(CHI)
CALL NORMCV(S,P)
S=2.*P
3 IF(NF.LE.2) GO TO 5
X=.5*(NF-1.)
Z=1.
IF(IEVEN.EQ.1) Z=.5
IF(A.LT.85) GO TO 2
C
C
C
E=0
C .572364942925=LN(SQRT(PIE))
IF(IEVEN.EQ.1) E=.572364942925
C=ALOG(A)
1 E=ALOG(Z)+E
SL=C*Z-A-E
IF((SL.LT.-85).OR.(SL.GT.85)) GO TO 7
S=S+EXP(SL)
7 Z=Z+1.
IF(Z.LE.X) GO TO 1
PROB=S
GO TO 6
C
C
C
2 E=1
C .564189583548=1/SQRT(PIE)
IF(IEVEN.EQ.1) E=.564189583548/SQRT(A)
CL=0
C=0
4 E=E*A/Z
CL=C+E
IF(CL.EQ.C) GO TO 8
C=CL
Z=Z+1.
IF(Z.LT.X) GO TO 4
8 PROB=C*Y+S
GO TO 6
5 PROB=S
6 IF(PROB.LT.0) PROB=0
IF(PROB.GT.1.) PROB=1.
RETURN
END
C **** STAT PACK ****
C SUBROTINE USED TO FIND CUMULATIVE NORMAL PROBABILITIES FOR Z'S.
C CALLING SEQUENCE: CALL NORMCV(X,PROB)
C WHERE X - IS THE Z-VALUE FOR WHICH THE PROBABILITY IS TO BE FOUND
C PROB - IS CUMULATIVE PROBABILITY FOR THE Z.
C
C ROUTINE WRITTEN FROM SPECIFICATIONS IN ACM COMMUNICATIONS
C (JUNE 1967), WITH THE IMPROVEMENTS NOTED IN THE ACM COMMUNICATIONS
C FROM OCTOBER 1969. ROUTINE USED IN CACCULATING THE CHISQUARE
C PROBABILITIES ALSO.
C
SUBROUTINE NORMCV(X,PROB)
IF(X.EQ.0) GO TO 7
Z=ABS(X)
X2=X*X
Y=0
A=.5*X2
IF(A.GT.85) GO TO 6
C .39894228=1/SQRT(2*PIE)
Y=.398942280401432678*EXP(-A)
6 A=Y/Z
IF((X.GT.0).AND.((1.0-A).EQ.1.0)) GO TO 8
IF((X.LT.0).AND.(A.EQ.0)) GO TO 9
IF((Z.GT.2.32).AND.(X.GT.0)) GO TO 2
IF((Z.GT.3.5).AND.(X.LT.0)) GO TO 2
S=Y*Z
Z=S
D=1.
1 D=D+2.
T=S
Z=Z*X2/D
S=S+Z
IF(S.EQ.T) GO TO 5
GO TO 1
5 PROB=.5-S
IF(X.GT.0) PROB=.5+S
GO TO 10
2 A1=2.
A2=0.
D=X2+3.
P1=Y
Q1=Z
P2=(D-1.0)*Y
Q2=D*Z
R=P1/Q1
T=P2/Q2
IF(X.LT.0) GO TO 3
R=1.-R
T=1.-T
3 D=D+4.
A1=A1-8.
A2=A1+A2
S=A2*P1+D*P2
P1=P2
P2=S
S=A2*Q1+D*Q2
Q1=Q2
Q2=S
S=R
R=T
T=P2/Q2
IF(X.GT.0) T=1.-T
IF(R.EQ.T) GO TO 4
IF(S.NE.T) GO TO 3
4 PROB=T
GO TO 10
7 PROB=.5
GO TO 10
8 PROB=1.0
GO TO 10
9 PROB=0
GO TO 10
10 RETURN
END
FUNCTION FISHER(M,N,X)
C
C REFERENCE:
C COMMUNICATIONS OF THE A.C.M.
C FEBRUARY 1971, PAGE 117
C
C COMMENT:
C IF DF1=1 AND DF2>1000, INVERSE INTERPOLATION IS USED;
C FISHER=(1-1000/DF2)*FISHER(INFINITY)+1000/N*FISHER(1000)
C (PER: M. STOLINE - 28 APR 77)
C
C***** WMU-AM: #99.24.1, MOD=2, MTO, 24-OCT-77 *****
C
C MINOR REVISION (MOD=2) BY MTO ON 24-OCT-77
C (1) CLEANUP LOGIC & IMPROVE INTELLIGABLILITY
C (2) ADD INFORMATIVE ERROR MESSAGES FOR BAD DATA
C (3) ADD DOCUMENTAION WHERE CODE IS UNCLEAR
C (4) FIX BUG WHICH CAUSES THE INPUT PARAMETER 'N'
C TO BE MODIFIED (SET TO 0) WHEN 'X' IS ZERO
C (5) PAGINATE THE ENTIRE LIBRARY
C
C INPUT PARAMETERS:
C M = # OF DEGREES OF FREEDOM (BETWEEN)
C N = # OF DEGREES OF FREEDOM WITHIN
C X = 'F' VALUE TO FIND THE PROBABILITY OF
C
LOGICAL ODD, EVEN
ODD (N) = (N.AND.1) .NE. 0
EVEN(N) = .NOT. ODD(N)
C**SAVE 'N' IN 'NX' SO WE CAN RESTORE IT LATER
NX=N
IF(X.EQ.0.0)GO TO 321
IF(M.EQ.1)GO TO 200
C**THIS STATEMENT REMOVED BECAUSE THE ROUTINE AT
C**201 IS INCORRECT**RRB**3MAY77**
C** IF((M+N).GT.400)GO TO 201
200 NX=N
IF(N.GT.1000)N=1000
C** IF M,N IS ODD, SET NA,NB TO 1
C** IF M,N IS EVEN, SET NA,NB TO 2
NA=2*(M/2)-M+2
NB=2*(N/2)-N+2
IF(N.EQ.0) TYPE 1
1 FORMAT (' % FISHER: ZERO DEGREES OF FREEDOM WITHIN')
W=X*FLOAT(M)/FLOAT(N)
Z=1.0/(1.0+W)
IF (ODD (M)) GOTO 10
IF (ODD (N)) GOTO 9
C**(M EVEN, N EVEN)
D=Z*Z
P=W*Z
GO TO 100
C**(M EVEN, N ODD)
9 P=SQRT(Z)
D=0.5*Z*P
P=1.0-P
GO TO 100
C**(M ODD, N EVEN)
10 IF (ODD (N)) GOTO 15
P=SQRT(W*Z)
D=0.5*P*Z/W
GO TO 100
C**(M ODD, N ODD)
15 P=SQRT(W)
Y=.3183098862
D=Y*Z/P
P=2.0*Y*ATAN(P)
100 Y=2.0*W/Z
IF(N.LT.(NB+2))GO TO 111
IF (EVEN (M)) GOTO 105
DO 101 J=NB+2,N,2
D=(1.0+FLOAT(NA)/FLOAT(J-2))*D*Z
101 P=P+D*Y/FLOAT(J-1)
GO TO 111
105 ZK=0
IF((ALOG10(Z)*(N-1)/2).GE.-37) ZK=Z**((N-1)/2)
107 D=D*ZK*FLOAT(N)/FLOAT(NB)
P=P*ZK+W*Z*(ZK-1.0)/(Z-1.0)
111 CONTINUE
Y=W*Z
Z=2.0/Z
NB=N-2
IF(M.LT.(NA+2)) GO TO 103
DO 102 I=NA+2,M,2
J=I+NB
D=Y*D*FLOAT(J)/FLOAT(I-2)
P=P-Z*D/FLOAT(J)
102 CONTINUE
103 FISHER=1-P
IF(FISHER.LT.0)FISHER=0
GO TO 322
321 FISHER=1.0
322 N=NX
IF(N.LE.1000)RETURN
IF(X.LT.0.0) TYPE 2
2 FORMAT (' % FISHER: NEGATIVE F-VALUE')
FP2=(1.-CDFN(SQRT(X)))*2.
FISHER=(1.-1000./N)*FP2+(1000./N)*FISHER
RETURN
C**FROM HERE ON DOWN, CODE IS INCORRECT AND INACCESSABLE
201 IND=0
MI=M
NI=N
XI=X
IF(XI.GE.1)GO TO 203
IND=1
ISAVE=NI
NI=MI
MI=ISAVE
XI=1.0/XI
203 Z1=2.0/FLOAT(9*MI)
Z2=2.0/FLOAT(9*NI)
Z=ABS((1.0-Z2)*XI**(.33333333)-1.0+Z1)
Z=Z/SQRT(Z2*XI**(.66666667)+Z1)
C IF(N.GE.4)GO TO 205
IF(NI.GE.4)GO TO 205
Z=Z*(1.0+.08*Z**4)/FLOAT(NI)**3
205 Z=(1.0+Z*(.196854+Z*(.115194+Z*(.000344+Z*.019527))))**4
FISHER=.5/Z
IF(IND.EQ.1)FISHER=1.0-FISHER
RETURN
C***** WMU-AM: END=FISHER, #205+4 *****
END
FUNCTION CDFN(X)
C
C CDF OF STANDARD UNIT NORMAL
C
C THIS FUNCTION CALCULATES THE CDF
C PROBABILITY CDFN(Y) ASSOCIATED
C WITH THE INPUTTED VALUE Y FOR THE
C STANDARD UNIT NORMAL DISTRIBUTION.
C
C SOURCE: ABRAMOWITZ, M. AND STEGUN, I.A. (1964),
C "HANDBOOK OF MATHEMATICAL FUNCTIONS WITH
C FORMULAS, GRAPHS, AND MATHEMATICAL TABLES"
C (FORMULA 26.2.17, P.932)
C
T = 1./(1.+(.231642)*ABS(X))
TEMP = (.319382)*T-(.356564)*T**2+(1.781478)*T**3-(1.821256)*T**4
#+ (1.330274)*T**5
Z = (.398942)*EXP(-.5*X**2)
CDFN = Z*TEMP
IF(X.GT.0) CDFN = 1.-CDFN
RETURN
END
C FORGEN.F4 - A DIALOGUE FORMAT GENERATOR
C
C WRITTEN BY RUSSELL R. BARR - WMU COMPUTER CENTER
C DATE: 20 JUL 73
C
C THE OBJECT-TIME, SAME AND STANDARD OPTIONS
C ARE ADAPTED FROM THE SUBROUTINE GETFOR.F4
C WRITTEN BY SAM ANEMA - FEB 1972 - WMU COMPUTER CENTER
C
C INPUTS:
C ISIZE - LENGTH OF ARRAY IFT
C MODE* - ARRAY CONTAINING TYPE OF EACH FIELD IN ASCII
C (A,F OR I)
C MSIZE* - NUMBER OF FIELDS
C IDLG - DIALOGUE OUTPUT
C IRSP - DIALOGUE INPUT
C NDEVI - NOT USED
C NDEVO - NOT USED
C IDVI - NOT USED
C IDVO - NOT USED
C ICODE - 0 = TTY INPUT
C 1 = PTY INPUT(BATCH)
C IBNK - NOT USED
C NAMI - NOT USED
C ITYPE - INDICATE WHAT TYPE OF FORMAT TO USE
C 0 - IF ONLY DIALOGUE FORM IS TO BE USED
C 1 - IF I-TYPE IS TO BE USED
C 2 - IF F-TYPE IS TO BE USED
C 3 - IF A-TYPE IS TO BE USED
C 4 - NEITHER ONE OF THE ABOVE 3
C
C * - IF EITHER OR BOTH NOT SPECIFIED, QUESTIONS AT 7751 AND/OR
C 800 WILL BE ASKED.
C
C OUTPUTS:
C IFT - FORMAT
C ISTD - WILL INDICATE WHETHER STANDARD FORMAT IS
C REQUESTED
C 1 - STANDARD FORMAT IS REQUESTED
C 0 - FORMAT TO BE USED IS CONTAINED IN IFT
C ISIZE - LENGTH OF ARRAY IFT
C MODE - ARRAY CONTAINING TYPE OF EACH FIELD IN ASCII
C (A,F OR I)
C MSIZE - NUMBER OF FIELDS
C JLEN - CHARACTERS PER FIELD
C IERR - 0 NO ERRORS
C 1 FATAL ERROR
C -1 RESPONSE ERROR
C
C NOTE: ARGUMENTS NOT PASSED IN CALL STATEMENT, ARE PASSED IN
C COMMON - IOBLK
C
SUBROUTINE FORGEN(IFT,ISIZE,MODE,JLEN,MSIZE,ITYPE,ISTD,IERR)
COMMON/IOBLK/IDLG,IRSP,NDEVI,NDEVO,IDVI,IDVO,ICODE,IBNK,NAMI(2)
DIMENSION IFT(1),MODE(1),JLEN(1),JFT(20)
DIMENSION IDUM(3),IN(80),MESS(3,3)
DATA IDUM/'I','F','A'/
DATA ((MESS(I,J),J=1,3),I=1,3)/'S','A','M','S','T','D','H',
1 'E','L'/
KL=0
N=ISIZE
C INITIAL AND QUERY/RESPONSE PATH
700 IERR=0
KOUNT=0
ISTD=0
L=0
NN=80
IF(ITYPE.EQ.0)GO TO 775
IF(ITYPE.EQ.4)WRITE(IDLG,704)
704 FORMAT(' FORMAT')
IF(ITYPE.LE.3)WRITE(IDLG,708)IDUM(ITYPE)
708 FORMAT(' FORMAT: (',A1,' - TYPE ONLY)')
IF(ITYPE.LE.4)WRITE(IDLG,712)
712 FORMAT(' TYPE "HELP" FOR EXPLANATION',/)
READ(IRSP,756,END=520,ERR=764)IN
C CHECK FOR 'SAM','STD','HEL' OPTION
DO 724 I=1,3
DO 720 J=1,3
IF(IN(J).NE.MESS(I,J))GO TO 724
720 CONTINUE
C TO: SAM STD HEL
GO TO (746,744,772),I
724 CONTINUE
C FORTRAN TYPE INPUT OR BLANKS(STD)
736 IF(L.EQ.1)GO TO 752
C CHECK FOR LEFT PAREN AS FIRST NON BLANK CHAR(IF FIRST LINE ONLY).
DO 740 I=1,NN
IF(IN(I).EQ.' ')GO TO 740
IF(IN(I).NE.'(')GO TO 764
GO TO 748
740 CONTINUE
C 'STD' FORMAT
744 ISTD=1
RETURN
C 'SAM' OPTION
746 RETURN
C ENCODE 'IN' INTO 'IFT'
748 IBEG=1
L=1
752 ENCODE(NN,756,IFT(IBEG))(IN(I),I=1,NN)
756 FORMAT(80A1)
C THIS PAREN COUNT ASSUMES NO PARENS IN HOLLERITHS
DO 760 I=1,NN
IF(IN(I).EQ.'(')KOUNT=KOUNT+1
IF(IN(I).EQ.')')KOUNT=KOUNT-1
760 CONTINUE
C 'KOUNT' DECIDES WHEN TO STOP ASKING FOR LINES
IF(KOUNT.LT.0)GO TO 764
IF(KOUNT.EQ.0)RETURN
IBEG=IBEG+16
IF((IBEG+16).GT.N)NN=(N-IBEG+1)*5
IF(NN.LT.1)GO TO 764
READ(IRSP,756,END=520,ERR=766)IN
GO TO 752
C ERROR PATH
764 IF(KL.NE.1)GO TO 766
765 WRITE(IDLG,784)
7651 IERR=-1
RETURN
C 1ST ERROR ONLY
766 WRITE(IDLG,768)
768 FORMAT(' ERROR IN FORMAT, TRY AGAIN.',/)
KL=1
GO TO 700
C
C HELP PATH
C
772 KL=0
WRITE(IDLG,773)
773 FORMAT(' THERE ARE FOUR METHODS OF FORMAT ENTRY:',/,
1 ' 1 - STANDARD FORMAT',/,' 2 - FORTRAN OBJECT-TIME',/,
1 ' 3 - USE SAME FORMAT AS PREVIOUSLY',/,
1 ' 4 - DIALOGUE',//,' WHICH METHOD?(1,2,3 OR 4) ',$)
READ(IRSP,780,END=520,ERR=774)METHOD
IF(METHOD.LT.1.OR.METHOD.GT.4)GO TO 774
GO TO (744,700,746,775),METHOD
774 IF(KL.EQ.1)GO TO 765
KL=1
WRITE(IDLG,784)
GO TO 772
C DIALOGUE PATH
775 IF(MSIZE.NE.0)GO TO 788
KL=0
7751 WRITE(IDLG,776)
776 FORMAT(' HOW MANY FIELDS? ',$)
778 READ(IRSP,780,END=520,ERR=782)MSIZE
780 FORMAT(I)
IF(MSIZE.GT.0.AND.MSIZE.LE.999)GO TO 788
782 IF(KL.EQ.1)GO TO 765
KL=1
WRITE(IDLG,784)
784 FORMAT(' RESPONSE ERROR',/)
GO TO 7751
788 DO 796 I=1,MSIZE
DO 792 J=1,3
IF(MODE(I).EQ.IDUM(J))GO TO 796
792 CONTINUE
KL=0
GO TO 800
796 CONTINUE
GO TO 820
800 WRITE(IDLG,804)
804 FORMAT(' ENTER TYPES OF FIELDS(A,F OR I) 10 PER LINE',/)
READ(IRSP,808,END=520,ERR=814)(MODE(I),I=1,MSIZE)
808 FORMAT(10A1)
DO 816 I=1,MSIZE
DO 812 J=1,3
IF(MODE(I).EQ.IDUM(J))GO TO 816
812 CONTINUE
814 IF(KL.EQ.1)GO TO 765
KL=1
WRITE(IDLG,784)
GO TO 800
816 CONTINUE
820 X=' '
DO 102 I=1,MSIZE
IF(MODE(I).NE.'F')GO TO 102
X=',D'
GO TO 103
102 CONTINUE
103 WRITE(IDLG,104)X
104 FORMAT(' ENTER SPECIFICATIONS FOR FIELDS IN THE FOLLOWING'
1 ' FORM - A,B,C',A2,/,' WHERE:',/,' A IS THE CARD OR RECORD',
1 ' CONTAINING THE FIELD',/,' B IS THE STARTING COLUMN OF THE',
1 ' FIELD',/,' C IS THE LAST COLUMN OF THE FIELD')
IF(X.NE.' ')WRITE(IDLG,105)
105 FORMAT(' D IS THE NUMBER OF DIGITS FOLLOWING THE DECIMAL',
1 ' POINT',/)
WRITE(IDLG,106)
106 FORMAT(' ENTER SPECIFICATIONS IN ORDER.',/)
DO 108 I=1,ISIZE
108 IFT(I)=0
110 IV=0
ISIZE=300
KHAR=1
KHARL=0
KOLUMN=0
LINE=1
JFT(KHAR)='('
117 KL=0
118 IVP=IV+1
IF(IVP.GT.MSIZE)GO TO 500
WRITE(IDLG,119)IVP
119 FORMAT(1X,I4,':',$)
121 READ(IRSP,122,END=520,ERR=612)KARD,INIT,LAST,IDP
122 FORMAT(4I)
IV=IV+1
IF(KARD.EQ.0)GO TO 610
IF(KARD-LINE+13+KHARL.GT.ISIZE)GO TO 630
IF(KARD.LT.LINE)GO TO 610
IF(INIT-KOLUMN-1.GT.999)GO TO 610
IF(LAST.LT.INIT)GO TO 610
JLEN(IV)=LAST-INIT+1
IF(IDP.GT.LAST-INIT+1.AND.MODE(IV).EQ.'F')
1 GO TO 610
IF(KARD.EQ.LINE)GO TO 200
C / SECTION
DO 130 I=KHAR+1,KHAR+KARD-LINE
130 JFT(I)='/'
KHAR=KHAR+KARD-LINE+1
LINE=KARD
JFT(KHAR)=','
KOLUMN=0
IF(INIT.EQ.0)GO TO 500
200 IF(INIT.LE.KOLUMN)GO TO 610
C X SECTION
JX=INIT-KOLUMN-1
IF(JX.EQ.0)GO TO 300
CALL NUMBER(JFT,KHAR,JX)
KOLUMN=INIT-1
KHAR=KHAR+1
JFT(KHAR)='X'
KHAR=KHAR+1
JFT(KHAR)=','
300 IF(MODE(IV).NE.'A')GO TO 350
CALL ALPHA(INIT,LAST,JFT,KHAR)
GO TO 400
C COMBINED I/F SECTION
350 KHAR=KHAR+1
JFT(KHAR)=MODE(IV)
LONG=LAST-INIT+1
IF(LONG.GT.99)GO TO 610
CALL NUMBER(JFT,KHAR,LONG)
IF(MODE(IV).NE.'F')GO TO 400
C F SECTION
KHAR=KHAR+1
JFT(KHAR)='.'
CALL NUMBER(JFT,KHAR,IDP)
C COMPACTING SECTION
400 ENCODE(KHAR,410,IFT(KHARL+1))(JFT(I),I=1,KHAR)
410 FORMAT(50A1)
KHARL=KHARL+KHAR/5.+.9
KHAR=1
JFT(KHAR)=','
KOLUMN=LAST
GO TO 117
C CLEAN UP AND FINISH
500 KL=0
501 WRITE(IDLG,502)
502 FORMAT(' HOW MANY CARDS PER OBSERVATION? ',$)
READ(IRSP,122,END=520,ERR=504)IOBS
IF(IOBS.GE.LINE)GO TO 508
504 IF(KL.EQ.1)GO TO 765
KL=1
WRITE(IDLG,784)
GO TO 501
508 IF(IOBS.EQ.LINE)GO TO 512
DO 510 I=KHAR+1,KHAR+IOBS-LINE
510 JFT(I)='/'
KHAR=KHAR+IOBS-LINE+1
C OVER WRITE COMMA
512 JFT(KHAR)=')'
ENCODE(KHAR,410,IFT(KHARL+1))(JFT(I),I=1,KHAR)
WRITE(IDLG,514)
514 FORMAT(' OK?(YES OR NO) ',$)
READ(IRSP,516,END=520,ERR=520)ANS
516 FORMAT(A3)
IF(ANS.EQ.'YES')RETURN
IF(ICODE.NE.0)GO TO 7651
534 WRITE(IDLG,535)
535 FORMAT(' START FROM BEGINNING')
GO TO 775
612 IF(KL.EQ.1)GO TO 765
KL=1
610 WRITE(IDLG,784)
WRITE(IDLG,613)
613 FORMAT(' SPECIFICATIONS MUST NOT OVERLAP OR BE OUT OF ORDER',/)
IV=IV-1
GO TO 118
520 WRITE(IDLG,522)
522 FORMAT(' END OF FILE OR NON RECOVERABLE INPUT ERROR')
GO TO 537
630 WRITE(IDLG,632)
632 FORMAT(' STORAGE CAPACITY EXCEEDED FOR FORMAT')
C FATAL ERROR
537 IERR=+1
RETURN
END
C
C ALPHA FORMAT SECTION - MADE TO USE AS A STAND ALONE SUBR.
C
C
SUBROUTINE ALPHA(INIT,LAST,JFT,KHAR)
DIMENSION JLEN(1),JFT(1)
IFULLS=(LAST-INIT+1)/5
IF(IFULLS.EQ.0)GO TO 310
IF(IFULLS.GT.1)CALL NUMBER(JFT,KHAR,IFULLS)
KHAR=KHAR+1
JFT(KHAR)='A'
KHAR=KHAR+1
JFT(KHAR)='5'
310 IDIF=LAST-INIT+1-(IFULLS*5)
IF(IDIF.EQ.0)RETURN
IF(IFULLS.EQ.0)GO TO 312
KHAR=KHAR+1
JFT(KHAR)=','
312 KHAR=KHAR+1
JFT(KHAR)='A'
CALL NUMBER(JFT,KHAR,IDIF)
JLEN(IV)=IFULLS+1
RETURN
END
C
C
C THIS ROUTINE TRANSLATES INTEGER(NUM) TO ASCII AND PLACES
C IT IN THE PROPER PLACES IN ARRAY(IFT) STARTING WITH
C LOCATION: IFT(KHAR+1).
C
SUBROUTINE NUMBER(IFT,KHAR,NUM)
DIMENSION IFT(1)
INTEGER DIGIT(0/9)
DATA DIGIT/'0','1','2','3','4','5','6','7','8','9'/
NUMA=NUM
ID=1000
IFST=0
1 IR=NUMA/ID
IF(IR.NE.0)GO TO 2
IF(IFST.NE.0)GO TO 2
IF(ID.EQ.1)GO TO 2
GO TO 4
2 IFST=1
3 KHAR=KHAR+1
IFT(KHAR)=DIGIT(IR)
4 IF(ID.EQ.1)RETURN
NUMA=NUMA-IR*ID
ID=ID/10
GO TO 1
END
SUBROUTINE GETVAR(N,NAME,IVAR,IERR)
COMMON /IOBLK/IDLG,IRSP,NDEVI,NDEVO,IDVI,IDVO,ICODE,IBNK,NAMI(2)
COMMON /VARTMP/IDUM(72),ISAVE(5)
DIMENSION NAME(1)
C
C
C SUBROUTINE TO GET VARIABLE NAME OR NUMBER FROM TTY
C
C N IS NUMBER OF VARIABLES
C NAME IS VECTOR CONTAINING VARIABLES NAMES
C IVAR IS VARIABLE NUMBER RETURNED
C IERR IS: 0 OK
C : 1 ILLEGAL VARIABLE NAME
C :-1 ILLEAGEL VARIABLE NUMBER
C
C
IERR=0
READ(IDLG,100) (IDUM(I),I=1,10)
100 FORMAT(10A1)
IF((IDUM(1).LT.'0').OR.(IDUM(1).GT.'9')) GOTO 1
C
C INPUT IS VARIABLE NUMBER
C
REREAD 101,IVAR
101 FORMAT(I)
IF((IVAR.GE.1).AND.(IVAR.LE.N)) GOTO 999
IERR=-1
GOTO 999
C
C INPUT IS VARIABLE NAME
C
1 IS=0
DO 2 I=1,5
2 ISAVE(I)=' '
I=0
3 I=I+1
IF(I.GT.10) GOTO 4
IF(IDUM(I).EQ.' ') GOTO 3
IS=IS+1
IF(IS.LE.5) ISAVE(IS)=IDUM(I)
GOTO 3
C
C
4 IVAR=' '
ENCODE(5,100,IVAR) ISAVE
DO 5 I=1,N
IF(NAME(I).NE.IVAR) GOTO 5
IVAR=I
GOTO 999
5 CONTINUE
IERR=1
999 RETURN
END
SUBROUTINE GETLAB(NSIZE,NAME,NUM)
C
C THIS SUBROUTINE WAS WRITTEN BY BERENICE HOUCHARD ON 1974
C
C THE SUBROUTINE ACCEPTS EITHER THE TOTAL NUMBER OF VARIABLES IN
C THE ANALYSIS OR A STRING OF VARIABLE NAMES TO BE ASSIGNED TO
C THE VARIABLES AND HENCE IMPLICITLY DETERMINE THE TOTAL NUMBER OF
C VARIABLES IN THE ANALYSIS.
C
C A VARIABLE NAME CONSISTS OF ONE TO FIVE ALPHANUMERIC CHARACTERS
C THE FIRST BEING NON-NUMERIC. IT MAY NOT CONTAIN ANY OF THE
C FOLLOWING SYMBOLS:
C
C * ? - / , + ' . BLANK
C
C SEVERAL RESERVED WORDS MAY NOT BE USED AS VARIABLE NAMES, THEY
C ARE: ALL HELP EMPTY STOP OBS
C
C
C
C NSIZE=MAXIMUM NUMBER OF VARIABLES WHEN THIS ROUTINE
C IS CALLED AND NSIZE= NUMBER OF VARIABLES ON RETURNING
C
C NAME CONTAINS ASCII NAMES OF VARIABLES (A5)
C NUM CONTAINS NUMBER OF POSTION IN LIST
C
C
DIMENSION NAME(1),NUM(1),IRSYM(9),IRWRD(5)
COMMON/IOBLK/IDLG,ICC,INP,IOUT,IO2,IO3,ICODE,IBNK,NAMI(2)
COMMON /VARTMP/IDUM(72),ISAVE(5)
C
C
C
C
C
C
DATA IRSYM/' ','-','.','*','/','?','"','+',';'/
DATA IRWRD/'ALL','HELP','EMPTY','STOP','OBS'/
DATA IALT,IGRT/"155004020100,'$'/
C
C
MAX=NSIZE
DO 1122 I=1,MAX
1122 NUM(I)=I
C
1 WRITE(IDLG,10)
10 FORMAT(' ENTER # OF VARIABLES OR VARIABLE NAMES'/)
NSIZE=0
11 DO 110 I=1,5
110 ISAVE(I)=' '
CALL GES(IDUM,72,IEND)
NPT=1
IF (IEND.NE.2) GO TO 111
112 IF (ICODE) 1,1,901
111 IF ((IDUM(1).EQ.'H').AND.(IDUM(2).EQ.'E').AND.(IDUM(3).EQ.'L')
1 .AND.(IDUM(4).EQ.'P')) GO TO 90
L=IDUM(1)
IF ((L.LT.'0').OR.(L.GT.'9')) GO TO 20
C
C # OF VARIABLES ENTERED
C
DO 1230 I=10,1,-1
IF (IDUM(I).NE.' ') GO TO 124
1230 CONTINUE
124 J=I
IF ((IDUM(I).EQ.IALT).OR.(IDUM(I).EQ.IGRT)) J=I-1
DO 123 I=1,J
123 ISAVE(I)=IDUM(I)
12 IF (ISAVE(5).NE.' ') GO TO 121
DO 120 I=4,1,-1
120 ISAVE(I+1)=ISAVE(I)
ISAVE(1)=' '
GO TO 12
121 ENCODE(5,151,L) ISAVE
DECODE(5,122,L) NSIZE
122 FORMAT(I5)
C
C GENERATE VARIABLE NUMBERS
C
IF (NSIZE.LE.0) GO TO 19
IF (NSIZE.GT.MAX) GO TO 191
DO 13 I=1,NSIZE
DO 14 J=1,5
14 ISAVE(J)=' '
ENCODE(5,150,NAME(I)) I
150 FORMAT(I5)
DECODE(5,151,NAME(I)) ISAVE
151 FORMAT(5A1)
16 IF (ISAVE(1).NE.' ') GO TO 18
DO 17 K=1,4
17 ISAVE(K)=ISAVE(K+1)
ISAVE(5)=' '
GO TO 16
18 ENCODE(5,151,NAME(I)) ISAVE
NUM(I)=I
13 CONTINUE
RETURN
C
C
C
19 WRITE(IDLG,190) NSIZE
190 FORMAT('-ERROR: NUMBER OF VARIABLES ',I6,' OUTSIDE ALLOWABLE
1 RANGE,'/9X,'TRY AGAIN'/)
IF (ICODE.GE.0) GO TO 1
CALL EXIT
191 WRITE(IDLG,192)
192 FORMAT('-ERROR: VARIABLE NAME LIST TOO LONG, CONTACT COMPUTER
1 CENTER STAFF'/9X,'FOR HELP'/)
CALL EXIT
C
C VARIABLE NAMES ENTERED
C
20 DO 200 LAST=72,1,-1
IF (IDUM(LAST).NE.' ') GO TO 201
200 CONTINUE
GO TO 40
201 ISUB=0
N=0
DO 21 K=1,LAST
L=IDUM(K)
IF ((L.EQ.',').OR.(L.EQ.IALT).OR.(L.EQ.IGRT)) GO TO 30
IF (L.EQ.' ') GO TO 21
DO 22 I=2,9
IF (L.EQ.IRSYM(I)) GO TO 23
22 CONTINUE
IF (N.GE.5) GO TO 21
N=N+1
ISAVE(N)=L
GO TO 21
C
C
C
23 WRITE(IDLG,230) L
230 FORMAT('-ERROR: RESERVED CHARACTER "',A1,'" IN VARIABLE NAME'/)
GO TO 25
24 WRITE(IDLG,240) NAME(NSIZE)
240 FORMAT('-ERROR: VARIABLE NAME "',A5,'" IS RESERVED'/)
25 IF (ICODE.LT.0) CALL EXIT
WRITE(IDLG,250)
250 FORMAT('+RE-ENTER THE LINE'/)
NSIZE=NSIZE-ISUB
GO TO 11
C
C
C
30 IF ((K.EQ.1).AND.((L.EQ.IALT).OR.(L.EQ.IGRT))) GO TO 40
IF (N.LE.0) GO TO 21
301 IF ((ISAVE(1).LT.'0').OR.(ISAVE(1).GT.'9')) GO TO 31
WRITE(IDLG,300) ISAVE
300 FORMAT('-ERROR: VARIABLE NAME "',5A1,'" STARTS WITH A NUMBER'/)
GO TO 25
C
C
C
31 NSIZE=NSIZE+1
IF (NSIZE.GT.MAX) GO TO 191
ISUB=ISUB+1
NAME(NSIZE)=0
ENCODE(5,151,NAME(NSIZE)) ISAVE
DO 32 I=1,5
IF (NAME(NSIZE).EQ.IRWRD(I)) GO TO 24
32 CONTINUE
GO TO (330,1111),NPT
330 N=0
DO 33 I=1,5
33 ISAVE(I)=' '
NUM(NSIZE)=NSIZE
IF ((L.EQ.IALT).OR.(L.EQ.IGRT)) GO TO 40
21 CONTINUE
IF (N.LE.0) GO TO 1111
NPT=2
GO TO 301
C
C
C
40 IF (NSIZE-1) 19,411,410
410 DO 41 I=1,NSIZE-1
DO 41 J=I+1,NSIZE
IF (NAME(I).EQ.NAME(J)) GO TO 42
41 CONTINUE
411 RETURN
C
C
C
42 WRITE(IDLG,420) NAME(I),I,J
420 FORMAT('-ERROR: VARIABLE NAME "',A5,'" IS USED IN VARIABLES ',
1 I5,' AND ',I5)
IF (ICODE.LT.0) CALL EXIT
WRITE(IDLG,421)
421 FORMAT('-ENTER CORRECTION IN THE ORDER: VARIABLE #, COMMA,
1 VARIABLE NAME OR A - TO DELETE'/)
READ(ICC,422) I,L
422 FORMAT(I,A5)
IF (L.EQ.'- ') GO TO 43
NAME(I)=L
NUM(I)=I
GO TO 40
43 DO 44 J=I+1,NSIZE
NAME(J-1)=NAME(J)
44 NUM(J-1)=NUM(J)
NSIZE=NSIZE-1
GO TO 40
C
C ONLY EXPECT MORE NAMES IF LAST CHARACTER IS COMMA
C
1111 IF(IDUM(LAST).NE.',') RETURN
GOTO 11
C
C HELP
C
90 WRITE(IDLG,900)
900 FORMAT('-THIS LINE DEFINES DIRECTLY AND INDIRECTLY THE NUMBER OF
1 VARIABLES TO'/' BE USED IN THE ANALYSIS. IF A NUMBER IS ENTERED,
2 IT IS ASSUMED TO BE'/' THE NUMBER OF VARIABLES AND VARIABLE NAME
3 OPTION IS NOT SELECTED.'//' IF A VARIABLE NAME LIST IS ENTERED,
4 THE NUMBER OF VARIABLES IS'/' COUNTED FROM THE LIST. VARIABLE
5 NAME LIST SHOULD CONFORM TO THE'/' FOLLOWING RULES:'//
6 ' (1) THE LIST IS COMPOSED OF 1 OR MORE LINES. AN ALTMODE OR
7 BLANK'/6X,'LINE MUST FOLLOW IMMEDIATELY AFTER THE LAST VARIABLE
8 NAME'/6X,'IS ENTERED.'//' (2) VARIABLE NAME IS MADE OF 1 TO 5
9 ALPHANUMERIC CHARACTERS, THE'/6X,'FIRST BEING NON-NUMERIC.'//6X,
1 'THE NAMES MAY NOT CONTAIN ANY OF THE FOLLOWING SYMBOLS:'// 6X,
2 '* ? - / , + '' . BLANK'/
4/ 6X,'NOR MAY BE ANY OF THE RESERVED WORDS:'//
5 6X,'ALL HELP EMPTY STOP OBS'/)
IF (ICODE.GE.0) GO TO 1
901 CALL EXIT
END
SUBROUTINE GETLST(N,NLST,NAME,INDEX)
DIMENSION NAME(1),INDEX(1)
COMMON/IOBLK/IDLG,ICC,INP,IOUT,IO2,IO3,ICODE,IBNK,NAMI(2)
COMMON /VARTMP/IDUM(72),ISAVE(5)
DATA IALT,IDOL/"155004020100, '$'/
C
C
100 CALL GES(IDUM,72,IRET)
IF(IRET.EQ.2) CALL EXIT
IF ((IDUM(1).EQ.'H').AND.(IDUM(2).EQ.'E').AND.(IDUM(3).EQ.'L')
1.AND.(IDUM(4).EQ.'P')) GO TO 90
IF ((IDUM(1).EQ.'S').AND.(IDUM(2).EQ.'A').AND.(IDUM(3).EQ.'M')
1.AND.(IDUM(4).EQ.'E')) RETURN
C
C
NLST=0
IDASH=1
12 NF=0
DO 13 LAST=72,1,-1
IF (IDUM(LAST).NE.' ') GO TO 20
13 CONTINUE
14 RETURN
C
C
20 I=0
21 DO 210 J=1,5
210 ISAVE(J)=' '
IS=0
C
22 I=I+1
IF (I.LE.LAST) GO TO 220
L=' '
IF (IS) 321,321,230
C
C
220 L=IDUM(I)
IF (L.EQ.' ') GO TO 22
IF ((L.EQ.',').OR.(L.EQ.'-').OR.(L.EQ.IALT).OR.(L.EQ.IDOL))
1 GO TO 23
IS=IS+1
IF (IS.LE.5) ISAVE(IS)=L
GO TO 22
C
C
23 IF (IS.LE.0) GO TO 22
230 IF ((ISAVE(1).LE.'0').OR.(ISAVE(1).GT.'9')) GO TO 40
C
C #'S
C
24 IF (ISAVE(5).NE.' ') GO TO 26
DO 25 J=4,1,-1
25 ISAVE(J+1)=ISAVE(J)
ISAVE(1)=' '
GO TO 24
C
C
26 ENCODE(5,11,K) ISAVE
11 FORMAT(72A1)
DECODE(5,260,K) NUM
260 FORMAT(I5)
IF ((NUM.GE.1).AND.(NUM.LE.N)) GO TO 30
WRITE(IDLG,27) NUM
27 FORMAT('-ERROR: VARIABLE NUMBER ',I5,' OUTSIDE ALLOWABLE
1 RANGE, RE-ENTER THE LINE'//)
IF (ICODE.GE.0) GO TO 33
CALL EXIT
C
C '-'
C
30 IF (L.NE.'-') GO TO (31,34),IDASH
IDASH=2
NF=NF+1
INDEX(NF)=NUM
GO TO 21
C
C
31 NF=NF+1
INDEX(NF)=NUM
32 IF ((I.LT.LAST).AND.(L.NE.IALT).AND.(L.NE.IDOL)) GO TO 21
321 NLST=NLST+NF
IF ((L.EQ.IALT).OR.(L.EQ.IDOL).OR.(L.NE.',')) RETURN
C
C
33 READ(ICC,11,END=14) IDUM
GO TO 12
C
C
34 DO 35 J=INDEX(NLST+NF)+1,NUM
NF=NF+1
35 INDEX(NF)=J
IDASH=1
GO TO 32
C
C NAMES
C
40 K=' '
ENCODE(5,11,K) ISAVE
IF ((K.EQ.'ALL').OR.(K.EQ.'*')) GO TO 42
DO 41 J=1,N
IF (NAME(J).NE.K) GO TO 41
NUM=J
GO TO 30
41 CONTINUE
WRITE(IDLG,410) K
410 FORMAT('-ERROR: VARIABLE ',A5,' DOES NOT EXIST, RE-ENTER
1 THE LINE'/)
IF (ICODE.GE.0) GO TO 33
CALL EXIT
C
C
42 DO 43 I=1,N
43 INDEX(I)=I
NLST=N
RETURN
C
C HELP
C
90 WRITE(IDLG,91)
91 FORMAT('-EITHER VARIABLE NAMES OR VARIABLE NUMBERS MAY BE USED
1 TO ENTER THE'/' VARIABLES. MORE
2 THAN ONE NAME OR'/' NUMBER MAY OCCUPY A LINE AND ARE SEPARATED
3 BY COMMAS. AN ALTMODE,'/' DOLLAR SIGN, CONTROL Z OR BLANK LINE
4 MUST BE USED TO TERMINATE THE'/' ENTRIES. RANGES MAY BE
5 SPECIFIED BY ENTERING THE TWO EXTREMES'/' SEPARATED BY A MINUS
6 SIGN ("-"). FOR EXAMPLE:'/
7 ' 1,AGE,10-12$'//)
IF (ICODE.GE.0) GO TO 100
CALL EXIT
END
SUBROUTINE CALC(ANS,MODE,IERR)
C
C THIS SUBROUTINE IS DESIGNED TO PROVIDE
C BOTH AN IMMEDIATE CALCULATOR AND VARIABLE STORAGE TO
C ANY PROGRAM THAT CAN HANDLE REAL SCALAR VALUES.
C
C IT IS A COMBINATION OF SAM ANEMA'S CALCULATOR AND RUSS
C BARR'S STORAGE PACKAGE.
C
C ALL EXTERNAL ROUTINES CALLED BY THIS PACKAGE ARE IN
C THE FILE - APLB10.FOR
C
C FINAL MODIFICATIONS FOR NSTORE
C DATE: 21-OCT-75 - RRB.
C
C PARAMETERS:
C
C ANS ANSWER RETURNED
C
C MODE=0 ANSWER IS TO BE PRINTED
C =1 ANSWER IS NOT TO BE PRINTED
C
C IERR=0 IMMEDIATE CALCULATION, ANSWER PRINTED.
C =1 ASSIGNMENT MADE
C =2 INPUT OR EVAL ERROR, MESSAGE PRINTED.
C =3 UNDEFINED NAME, NO MESSAGE.
C =4 EOF ON INPUT, MESSAGE.
C
C COMMON/CALDAT/ (OPTIONAL IN CALLING ROUTINES)
C
C IN 80 WORD VECTOR FOR TELETYPE INPUT LINE (FORMAT=80A1)
C
C WORDS 4 WORD VECTOR (2 DOUBLE PRECISION WORDS) IN WHICH
C KEYWORDS ARE RETURNED TO CALLING ROUTINE
C
C RESULT DOUBLE PRECISION VALUE USED TO STORE VARIABLE NAME
C
C LPASS TTY INPUT FLAG
C
C = 0 READ TTY INPUT LINE IN CALC
C # 0 USE TTY INPUT LINE IN COMMON/CALDAT/
C
C MSGLVL ERROR MESSAGE LEVEL FLAG
C
C = 0 PRINT ALL ERROR MESSAGES
C = 1 PRINT ONLY INTERNAL ERROR MESSAGES
C = 2 PRINT NO ERROR MESSAGES
C
DOUBLE PRECISION B,FUN,WORDS(2),RESULT
DIMENSION IC(10),IN(80),ITY(50),IV(50)
DIMENSION V(0/9),IW(12),FUN(16),L1(50),L2(50),CONST(50),IH(21)
DOUBLE PRECISION ALLOC
DIMENSION HLLOC(1)
COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
EQUIVALENCE (ALLOC,HLLOC)
C**AM APLB10 #5 MSL 2-FEB-79
C
C CHANGED FORMAT OF /CALDAT/ COMMON
C CHECK MSGLVL BEFORE TYPING ERRORS
C CHECK LPASS BEFORE READING INPUT LINE
COMMON/CALDAT/IN,WORDS,RESULT,LPASS,MSGLVL
DATA LPASS,MSGLVL/0,0/
C**END CALC @ 36 - 14
DATA IC/'(','+','-','/','*',' ',')','.','=','&'/
DATA V/0.0,1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0/
DATA FUN/'ATAN ','TANH ','COSH ','SINH ','COS ',
1'SIN ','SQRT ','ALOG10 ','ALOG ','EXP ','ACOS ',
2'ASIN ','ABS ','INT ','RAN ','SETRAN '/
DATA IH/6,5,5,4,4,3,2,2,2,2,2,2,2,2,2,2,2,2,2,2,7/
DATA IDLG,IRSP,NC,NF/-1,-4,10,16/
ANS=0
NA=0
IERR=0
IF(LPASS.NE.0)GO TO 38
C WRITE(IDLG,34)
C34 FORMAT('0*',$)
READ(IRSP,36,END=998)IN
36 FORMAT(80A1)
38 IR=0
K=0
I=0
IDP=0
XM1=1.
NW=0
C=0.
K=0
NF=16
N1=0
N2=0
10 I=I+1
IF(I.GT.80)GO TO 501
IF(IN(I).EQ.IC(6))GO TO 10
DO 50 J=1,NC
IF(IC(J).EQ.IN(I))GO TO 1000
50 CONTINUE
IF(IN(I).LT.'0'.OR.IN(I).GT.'9')GO TO 51
J=NC+1
GO TO 1000
51 IF(IN(I).LT.'A'.OR.IN(I).GT.'Z')GO TO 99
J=NC+2
1000 IF(IDP.NE.3)GO TO 1001
IF(J.EQ.1.OR.J.GT.NC)GO TO 1001
1002 ENCODE(11,2000,WORDS)(IW(KK),KK=1,NW),(IC(6),KK=NW+1,12)
2000 FORMAT(12A1)
NW=0
IF(J.EQ.9)GO TO 2001
LOC=LOCNAM(WORDS,KIND,KLAS,NROW,NCOL)
IF(LOC.EQ.0)GO TO 992
C** AM#99.24.1-4 RRB/12-JAN-79
IF(LOC.LT.0)GO TO 986
C**END CALC,APLB10.FOR,@2000+5
C**AM APLB10 #5 MSL 2-FEB-79
IF(KIND.NE.2.OR.KLAS.NE.0)GO TO 994
C**END CALC @ 2001 - 4
C=HLLOC(LOC)
IDP=2
GO TO 1001
2001 IR=1
C NOT AN ERROR, AN ASSIGNMENT FLAG.
IERR=1
RESULT=WORDS(1)
IDP=0
GO TO 10
1001 IF(I.GT.80)GO TO 501
GO TO (1100,102,102,102,102,10,101,103,99,1007,104,105),J
GO TO 10
C
C READ ADDITIONAL LINE OF TTY INPUT IF "&" WAS FOUND
C
1007 READ(IRSP,36,END=998)IN
I=0
GO TO 10
1100 IF(IDP.NE.0)GO TO 440
K=K+1
ITY(K)=1
GO TO 10
101 IF(IDP.NE.0)GO TO 440
K=K+1
ITY(K)=2
GO TO 10
102 IF(IDP.NE.0)GO TO 440
IF(ITY(K).NE.3)GO TO 1102
IF(J.EQ.5)GO TO 1103
IF(J.EQ.4)GO TO 99
K=K+1
ITY(I)=3
IV(K)=J+5
GO TO 10
1103 IF(IV(K).NE.5)GO TO 99
IV(K)=6
GO TO 10
1102 K=K+1
ITY(K)=3
IV(K)=J
GO TO 10
103 IDP=2
GO TO 10
104 IF(IDP.GT.2)GO TO 105
IF(IDP.EQ.2)GO TO 106
IDP=1
C=C*10.+V((IN(I).AND."74000000000)/"4000000000)
GO TO 10
106 XM1=XM1*.1
9123 FORMAT(I)
C=C+V((IN(I).AND."74000000000)/"4000000000)*XM1
GO TO 10
105 NW=NW+1
IF(NW.GT.10)NW=11
IW(NW)=IN(I)
IDP=3
GO TO 10
440 IF(IDP.GT.2)GO TO 441
IDP=0
NA=NA+1
CONST(NA)=C
XM1=1.
C=0.
K=K+1
ITY(K)=4
IV(K)=NA
GO TO 1001
441 B=' '
IF(NW.GT.10)NW=10
ENCODE(10,442,B)(IW(L),L=1,NW)
442 FORMAT(10A1)
NW=0
DO 443 L=1,NF
IF(B.EQ.FUN(L))GO TO 444
443 CONTINUE
GO TO 99
444 K=K+1
ITY(K)=3
IV(K)=L+8
IDP=0
GO TO 1001
891 IF(MSGLVL.LT.2)WRITE(IDLG,892)
892 FORMAT(/,' PROBLEM WITH SUBROUTINE EVAL.',/)
IERR=2
GO TO 131
C** AM#9.24.1-4 RRB/12-JAN-79
986 IF(MSGLVL.LT.2)WRITE(IDLG,989)
989 FORMAT(/,' ?BAD STORAGE AREA IN NSTORE.',/)
IERR=2
GO TO 131
C**END CALC,APLB10.FOR,@892+3
99 IF(MSGLVL.LT.1)WRITE(IDLG,991)
991 FORMAT(' BAD STATEMENT.',/)
IERR=2
GO TO 131
992 CONTINUE
C WRITE(IDLG,993)WORDS(1)
C993 FORMAT(/,1X,A10,' IS NOT DEFINED',/)
IERR=3
GO TO 131
994 IF(MSGLVL.LT.2)WRITE(IDLG,995)KIND,KLAS,WORDS(1)
995 FORMAT(/,' WRONG KIND(',I2,') OR KLAS(',I1,') FOR ',A10,/)
IERR=2
GO TO 131
996 IF(MSGLVL.LT.2)WRITE(IDLG,997)RESULT
997 FORMAT(/,' ERROR ATTEMPTING TO STORE ',A10,/)
IERR=2
GO TO 131
998 IF(MSGLVL.LT.1)WRITE(IDLG,999)
999 FORMAT(/,' END OF FILE ON INPUT IN CALC.',/)
IERR=4
GO TO 131
501 IF(IDP.GT.2)GO TO 1002
IF(IDP.NE.0)GO TO 440
D WRITE(IDLG,9898)(ITY(II),II=1,10),(IV(II),II=1,10)
D9898 FORMAT(1X,10I2)
K=K+1
ITY(K)=3
IV(K)=21
DO 110 I=1,K
GO TO (100,120,140,160),ITY(I)
100 N1=N1+1
L1(N1)=1
GO TO 110
120 IOP=L1(N1)
N1=N1-1
IF(IOP.EQ.1)GO TO 110
IF(IOP.GT.6)GO TO 122
C=CONST(L2(N2))
N2=N2-1
122 IF(IOP.EQ.1)GO TO 891
CALL EVAL(IOP,C,ANS)
GO TO 120
140 IF(N1.EQ.0)GO TO 141
IF(IH(L1(N1)).GT.IH(IV(I)))GO TO 141
IOP=L1(N1)
N1=N1-1
IF(IOP.GT.6)GO TO 142
C=CONST(L2(N2))
N2=N2-1
142 IF(IOP.EQ.1)GO TO 891
CALL EVAL(IOP,C,ANS)
GO TO 140
141 N1=N1+1
L1(N1)=IV(I)
IF(IV(I).GT.6)GO TO 110
N2=N2+1
NA=NA+1
CONST(NA)=ANS
L2(N2)=NA
GO TO 110
160 ANS=CONST(IV(I))
110 CONTINUE
IF(N1.GT.1.OR.N2.GT.1)GO TO 99
IF(IR.EQ.0)GO TO 111
LOC=INCLRS(RESULT,2,0,1,1)
IF(LOC.LE.0)GO TO 996
HLLOC(LOC)=ANS
GO TO 131
C**AM APLB10 #5 MSL 2-FEB-79
111 IF(MODE.NE.0)GO TO 116
ABSANS=ABS(ANS)
I=2
IF(ABSANS.GE.100000000.0.OR.ABSANS.LT.0.00100)I=1
GO TO(112,114),I
112 WRITE(IDLG,113)ANS
113 FORMAT(1X,1PE)
GO TO 116
114 WRITE(IDLG,115)ANS
115 FORMAT(1X,F15.5)
116 LOC=INCLRS('ANSWER ',2,0,1,1)
C**END CALC @ 131 - 3
IF(LOC.LE.0)GO TO 996
HLLOC(LOC)=ANS
131 RETURN
GO TO 131
END
SUBROUTINE EVAL(IOP,C,ANS)
GO TO (40,2,3,4,5,6,40,8,9,10,11,12,13,14,15,16,17,18,19,20,
#21,22,23,24),IOP
2 ANS=ANS+C ; GO TO 40
3 ANS=C-ANS ; GO TO 40
4 ANS=C/ANS ; GO TO 40
5 ANS=C*ANS ; GO TO 40
6 ANS=C**ANS ; GO TO 40
8 ANS=-ANS ; GO TO 40
9 ANS=ATAN(ANS) ; GO TO 40
10 ANS=TANH(ANS) ; GO TO 40
11 ANS=COSH(ANS) ; GO TO 40
12 ANS=SINH(ANS) ; GO TO 40
13 ANS=COS(ANS) ; GO TO 40
14 ANS=SIN(ANS) ; GO TO 40
15 ANS=SQRT(ANS) ; GO TO 40
16 ANS=ALOG10(ANS) ; GO TO 40
17 ANS=ALOG(ANS) ; GO TO 40
18 ANS=EXP(ANS) ; GO TO 40
19 ANS=ACOS(ANS) ; GO TO 40
20 ANS=ASIN(ANS) ; GO TO 40
21 ANS=ABS(ANS) ; GO TO 40
22 ANS=INT(ANS) ; GO TO 40
23 ANS=RAN(0) ; GO TO 40
24 CALL SETRAN(INT(ANS)) ; ANS=0 ; GO TO 40
40 RETURN
END
C NSTORE
C ======
C
C A SIMPLIFIED NAMED STORAGE(*) PACKAGE FOR THE PDP-10
C ----------------------------------------------------
C
C WRITTEN BY RUSSELL R. BARR III, WESTERN MICHIGAN UNIVERSITY
C COMPUTER CENTER, DATE: 9-OCT-75.
C (*) PORTIONS OF THIS PACKAGE ARE BASED ON "NAMED STORAGE-360",
C WRITTEN BY STANLEY COHEN OF ARGONNE NATIONAL LABORATORIES.
C
C PURPOSE
C -------
C TO PROVIDE A METHOD OF STORING AND RETRIEVING (IN CORE) DATA GROUPS
C DURING THE COURSE OF A PROGRAM RUN IN A MANNER WHICH A USER MAY ASSIGN
C MNEMONIC LABELS RATHER THAN ABSOLUTE OR RELATIVE ADDRESSES.
C FURTHER, DECRIPTIVE DATA IS STORED IN A MANNER WHICH IS TRANSPARENT
C TO THE USER.
C
C ROUTINES
C --------
C
C SUBROUTINE SETSTR - 'SET UP STORAGE'
C FUNCTION LOCNAM - 'LOCATE NAMED OBJECT'
C FUNCTION INCLRS - 'I NOT CLEAR, RESERVE'
C FUNCTION IFREE - 'I FREE SPACE'
C SUBROUTINE SDUMP - 'FORMATTED STORAGE DUMP'
C
C FORM OF DATA "CHUNKS"
C --------------------
C
C
C EVEN NUMBERED ******** \
C WORDS------------------>* NWDS * \ ;SIZE OF ("CHUNK"-1)
C ODD NUMBERED *************** \
C WORDS----------->* ANAME * \ ;ANY NON-ZERO 72BIT CONFIG.
C *************** \
C * KIND * KLAS * \ ;SEE NOTE (1)
C *************** \
C * NROW * NCOL * \
C *************** \
C LOCA OR LOCI---->* * \
C (AS APPROP. TO * DATA WORDS * >NWDS(# OF S.P. WORDS NOT
C DATA TYPE) * * / INCLUDING SECOND NWDS)
C *************** /
C * NWDS *
C ********
C
C FLOW CHARTS
C -----------
C
C ********************************************
C * USER ROUTINES *
C ********************************************
C : : : : :
C ********** ********** : : *********
C * SETSTR * * INCLRS * : : * SDUMP *
C ********** ********** : : *********
C : : :
C ********* :
C * IFREE * :
C ********* :
C : :
C **********
C * LOCNAM *
C **********
C
C
C NOTE (1) KIND = 1 - INTEGER*4
C 2 - REAL*4
C 3 - REAL*8
C
C KLAS = 0 - SCALAR
C 1 - VECTOR
C 2 - MATRIX
C*ID*SETSTR
SUBROUTINE SETSTR(NWDS)
C SETUP STORAGE
C
C NWDS IS THE NUMBER OF SINGLE PRECISION WORDS ALLOWED IN THE
C COMMON - "ALLOCS" IN THE MAIN PROGRAM.
C
DOUBLE PRECISION ANAME,ALLOC
DIMENSION ILLOC(1)
COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
EQUIVALENCE(ILLOC,ALLOC)
C
INIT=2
NEXT=2
LAST=(NWDS-1).OR.1
NWDSP=LAST-INIT
ILLOC(INIT)=NWDSP
ILLOC(LAST)=NWDSP
RETURN
END
C** AM#99.24.1-4 RRB/12-JAN-79(MOVED ROUTINE "LOCNAM" TO FOLLOW "IFREE")
C*ID*INCLRS
FUNCTION INCLRS(ANAME,KIND,KLAS,NROW,NCOL)
C
C MAKE NEW OBJECT(DELETE OBJECT OF SAME NAME FIRST)
C
C FUNC. RETURN VALUES: >0 LOC OF DATA
C =0 NOT ENOUGH SPACE
C <0 DEFECTIVE STORAGE
C
DOUBLE PRECISION ANAME,ALLOC
DIMENSION ILLOC(1)
COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
EQUIVALENCE (ILLOC,ALLOC)
C
IDP=2
IF(KIND.LT.3)IDP=1
NWDSP=(NROW*NCOL*IDP+1).OR.1
C EXIST?
LOC=IFREE(ANAME)
IF(LOC.LT.0)GO TO 9001
NLEFT=ILLOC(NEXT)
110 IF(NLEFT.LT.NWDSP+7)GO TO 9002
C CREATE AREA REQUESTED
NWDSP6=NWDSP+6
ILLOC(NEXT)=NWDSP6
ILLOC(NEXT+NWDSP6)=NWDSP6
LOCNA=NEXT/2+1
ALLOC(LOCNA)=ANAME
ILLOC(NEXT+3)=KIND
ILLOC(NEXT+4)=KLAS
ILLOC(NEXT+5)=NROW
ILLOC(NEXT+6)=NCOL
INCLRS=NEXT+7
IF(IDP.EQ.2)INCLRS=LOCNA+3
C CLEAN UP THE FREE CHUNK
NEXT=NEXT+NWDSP+7
NLEFT=LAST-NEXT
ILLOC(NEXT)=NLEFT
ILLOC(LAST)=NLEFT
190 RETURN
C DEFECTIVE STORAGE
9001 INCLRS=-1
GO TO 190
C NOT ENOUGH SPACE
9002 INCLRS=0
GO TO 190
END
C*ID*IFREE
FUNCTION IFREE(ANAME)
C
C DELETE NAMED OBJECT AND RESTORE SPACE TO POOL
C
C FUNC. RETURN VALUES: >=0 TOTAL FREE SPACE
C (LAST-NEXT)
C <0 DEFECTIVE STORAGE
C
C IF(ANAME=0)RETURN FREE SPACE SIZE ONLY
DOUBLE PRECISION ANAME,ALLOC
DIMENSION ILLOC(1)
COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
EQUIVALENCE (ILLOC,ALLOC)
C
IF(ANAME.EQ.0.D0)GO TO 200
LOC=LOCNAM(ANAME,KIND,KLAS,NROW,NCOL)
IF(LOC)9001,200,100
C EXISTS
100 IF(KIND.LE.2)LOC=LOC-7
IF(KIND.GE.3)LOC=LOC*2-8
C DOWN SHIFT
NWDS=ILLOC(LOC)
C TOP OF LIST?
IF(NEXT.EQ.LOC+NWDS+1)GO TO 190
DO 110 I=LOC,NEXT-2-NWDS
110 ILLOC(I)=ILLOC(I+NWDS+1)
190 NEXT=NEXT-NWDS-1
IFREE=LAST-NEXT
ILLOC(NEXT)=IFREE
ILLOC(LAST)=IFREE
NEXTA=(NEXT+2)/2
ALLOC(NEXTA)=0
RETURN
200 IFREE=LAST-NEXT
201 RETURN
C DEFECTIVE STORAGE
9001 IFREE=-1
GO TO 201
END
C** AM#99.24.1-4 RRB/12-JAN-79(MOVE ROUTINE "LOCNAM" FROM BEFORE "INCLRS")
C*ID*LOCNAM
FUNCTION LOCNAM(ANAME,KIND,KLAS,NROW,NCOL)
C
C FIND NAMED OBJECT, RETURN ITS PARAMETERS AND LOCATION
C
C FUNC. RETURN VALUES: >0 LOC OF DATA
C =0 NOT FOUND
C <0 DEFECTIVE STORAGE
C
DOUBLE PRECISION ANAME,ALLOC
DIMENSION ILLOC(1)
COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
EQUIVALENCE (ILLOC,ALLOC)
C
I=INIT
LOCNAM=0
C STORAGE EMPTY?
IF(INIT.EQ.NEXT)GO TO 190
100 NWDS=ILLOC(I)
IF(NWDS.LE.0)GO TO 9001
IF(ILLOC(I+NWDS).NE.NWDS)GO TO 9001
LOCNA=I/2+1
IF(ANAME.NE.ALLOC(LOCNA))GO TO 200
KIND=ILLOC(I+3)
KLAS=ILLOC(I+4)
NROW=ILLOC(I+5)
NCOL=ILLOC(I+6)
IF(KIND.LE.2)LOCNAM=I+7
IF(KIND.GE.3)LOCNAM=I/2+4
190 RETURN
C KEEP SEARCHING
200 I=I+NWDS+1
IF(I.LT.NEXT)GO TO 100
C CAN'T FIND IT
GO TO 190
C DEFECTIVE STORAGE
9001 LOCNAM=-1
GO TO 190
END
C*ID*SDUMP
SUBROUTINE SDUMP(IERR)
C
C FORMATED DUMP OF STORAGE
C
C IERR RETURNED AS: =0 NO ERROR
C >0 DEFECTIVE STORAGE AT IERR
C
DOUBLE PRECISION ANAME,ALLOC
DIMENSION ILLOC(1),HLLOC(1)
COMMON/ALLOCS/INIT,NEXT,LAST,ALLOC(1)
EQUIVALENCE (ALLOC,HLLOC,ILLOC)
C
IERR=0
IF(INIT.EQ.NEXT)GO TO 300
I=INIT
100 NWDS=ILLOC(I)
IF(NWDS.LE.0)GO TO 9001
IF(ILLOC(I+NWDS).NE.NWDS)GO TO 9001
KIND=ILLOC(I+3)
KLAS=ILLOC(I+4)
NROW=ILLOC(I+5)
NCOL=ILLOC(I+6)
LOCNA=I/2+1
IF(KIND.GE.3)GO TO 140
LOCDAT=I+6
IF(KIND.NE.1)GO TO 120
TYPE 102,ALLOC(LOCNA),(ILLOC(LOCDAT+J),J=1,NROW*NCOL)
102 FORMAT(1X,A10,1X,3I15,/,(12X,3I15))
GO TO 200
120 TYPE 122,ALLOC(LOCNA),(HLLOC(LOCDAT+J),J=1,NROW*NCOL)
122 FORMAT(1X,A10,1X,3F,/(12X,3F))
GO TO 200
140 LOCDAT=I/2+3
TYPE 142,ALLOC(LOCNA),(ALLOC(LOCDAT+J),J=1,NROW*NCOL)
142 FORMAT(1X,A10,1X,2D25.15,/,(12X,2D25.15))
200 I=I+NWDS+1
IF(I.LT.NEXT)GO TO 100
RETURN
300 TYPE 302
302 FORMAT(' STORAGE EMPTY')
RETURN
9001 TYPE 9002,I
9002 FORMAT(' ERROR IN STORAGE AT LOC ',I5)
IERR=I
RETURN
END
SUBROUTINE DSKSRT(UNITI,UNITO,MODE,SCRTCH,ISIZE,RECSIZ,KEYPOS,
+ KEYSIZ,KEYORD,NKEY,IERR)
C
C DSKSRT IS A FORTRAN SUBROUTINE TO SORT ASCII OR
C BINARY DISK FILES INTO ASCENDING OR DESCENDING ORDER
C
C ARGUMENTS:
C UNITI - UNIT # OF OPEN INPUT CHANNEL
C IF UNITI = 0, INPUT RECORDS ARE READ FROM
C RECBUF COMMON VIA SRTIN ENTRY POINT
C UNITO - UNIT # OF OPEN OUTPUT CHANNEL
C IF UNITO = 0, OUTPUT RECORDS ARE WRITTEN TO
C RECBUF COMMON VIA SRTOUT ENTRY POINT
C MODE - MODE OF INPUT/OUTPUT FILES(RECORDS)
C = 1 ASCII (CHARACTER MODE)
C = 2 BINARY OR IMAGE (WORD MODE)
C SCRTCH - SCRATCH VECTOR FOR INTERNAL WORK SPACE
C ISIZE - SIZE IN WORDS OF SCRTCH
C > 0 DO NOT ALLOCATE, USE SCRTCH
C = 0 ALLOCATE AS MUCH CORE AS NEEDED
C < 0 ALLOCATE UP TO -ISIZE WORDS OF CORE
C RECSIZ - NUMBER OF CHARACTERS(WORDS) PER RECORD
C KEYPOS - VECTOR OF KEY STARTING CHARACTER(WORD) POSITIONS
C KEYSIZ - VECTOR OF KEY SIZES, IN CHARACTERS(WORDS)
C KEYORD - VECTOR OF SORT ORDER FLAGS
C = 0 ASCENDING ORDER FOR KEY
C # 0 DESCENDING ORDER FOR KEY
C NKEY - NUMBER OF KEYS (KEYS LISTED MAJOR-TO-MINOR)
C IERR - ERROR RETURN
C < 0 ERROR, SORT NOT COMPLETE
C >,= 0 NUMBER OF RECORDS SORTED
C
C RECBUF - NAMED COMMON AREA
C USED IF EITHER UNITI OR UNITO = 0
C MUST BE LARGE ENOUGH TO CONTAIN RECSIZE
C CHARACTERS(MODE=1) OR WORDS(MODE=2)
C
C ENTRY POINTS:
C
C NOTE: NO FILES SHOULD BE OPENED IN THE CALLING PROGRAM
C WHILE INPUT AND OUTPUT PROCEDURES ARE IN PROGRESS
C
C ENTRY SRTIN(IFLAG)
C
C IFLAG VALUES:
C = 0 NEXT RECORD IS IN RECBUF
C # 0 EOF - TERMINATE INPUT PROCEDURE
C IF UNITI = 0 AND UNITO NOT = 0
C IFLAG WILL BE RETURNED WITH FINAL RECORD COUNT
C
C ENTRY SRTOUT(OFLAG)
C
C OFLAG VALUES RETURNED:
C = 0 NEXT RECORD RETURNED IN RECBUF
C > 0 SORT FINISHED, OFLAG = COUNT OF RECORDS RETURNED
C -1 EMPTY INPUT FILE
C
C NOTE: SRTOUT SHOULD BE CALLED UNTIL OFLAG NOT = 0. IF SORT MUST
C BE PREMATURELY TERMINATED, CALL SRTOUT WITH OFLAG NOT = 0. THIS
C WILL RELEASE ALL SORT CHANNELS AND DELETE TEMP FILES.
C
IMPLICIT INTEGER(A-Z)
PARAMETER FMTLIM=100, KEYLIM=100, CHNLIM=13
COMMON/RECBUF/RECORD(1)
DOUBLE PRECISION SCRFIL(0/CHNLIM),MRGFIL
DIMENSION SCRTCH(1),KEYPOS(1),KEYSIZ(1),KEYORD(1),
+ FRMT(FMTLIM),ISORT(KEYLIM),KSORT(KEYLIM),
+ EOF(CHNLIM),MRGPT(CHNLIM),CHANNL(0/CHNLIM),
+ IDESC(4),NUMSA5(3),NUMSA1(11)
EQUIVALENCE(SCRFIL(0),MRGFIL),(CHANNL(0),MRGCHN)
C
DATA BUFCNT/4/
DATA PAGE,MAXCOR/512,10240/
DATA IDESC/'R','5',',','R'/
DATA SCRDEV,AFILE,AEXT/'DSK','FSRT','.TMP'/
DATA BIGNUM/"377777777777/
C
C CHECK SOME PARAMETERS, KEYS CHECKED LATER
C
IERR=0
IF(UNITI.EQ.0)GO TO 20
CALL CHKCHN(UNITI,J)
IF(J.NE.0)GO TO 9110 !ERROR-ILLEGAL INPUT UNIT
20 IF(UNITO.EQ.0)GO TO 30
CALL CHKCHN(UNITO,J)
IF(J.NE.0)GO TO 9110 !ERROR-ILLEGAL OUTPUT UNIT
30 IF(MODE.LT.1.OR.MODE.GT.2)GO TO 9120 !ERROR-ILLEGAL MODE
IF(RECSIZ.LE.0)GO TO 9130 !ERROR-ILLEGAL RECORD SIZE
C
C DETERMINE APPROXIMATE MAXIMUM OF FREE DSK CHANNELS
C
UNIT=0
MAXCHN=CHNLIM
40 UNIT=UNIT+1
CALL CHKCHN(UNIT,J)
IF(J.LT.0)GO TO 45
IF(J.EQ.0)MAXCHN=MAXCHN-1
GO TO 40
45 IF(MAXCHN.LT.2)GO TO 9190 !ERROR-TOO FEW CHANNELS
C
C GENERATE TEMP FILE NAMES, INITIALZE TEMP FILE FLAGS
C
DO 90 I=0,MAXCHN
CHANNL(I)=0
N2=I-((I/10)*10)
N1=(I-N2)/10
ENCODE(10,80,SCRFIL(I))AFILE,N1,N2,AEXT
80 FORMAT(A4,2I1,A4)
90 CONTINUE
C
C ******************************
C * CORE ALLOCATION *
C ******************************
C
BUFWRD=(MAXCHN+1)*(BUFCNT*(128+3)+3)
BUFSIZ=((BUFWRD+PAGE-1)/PAGE)*PAGE
ICORE=ISIZE
IF(ISIZE.LT.0)ICORE=-ISIZE+BUFSIZ
IREL=1
IF(ISIZE.LT.0)GO TO 130
IF(ISIZE.GT.0)GO TO 200
110 ICORE=MAXCOR+BUFSIZ
CALL ALLCOR(ICORE,JERR,IREL,SCRTCH)
IF(JERR.GE.0)GO TO 150
120 ICORE=ICORE-PAGE
130 CALL ALLCOR(ICORE,JERR,IREL,SCRTCH)
IF(JERR.LT.0)GO TO 120
C
C BUFFER AREA MUST BE UNALLOCATED
C
150 ICORE=ICORE-BUFSIZ
CALL ALLCOR(ICORE,JERR,IREL,SCRTCH)
C
C ******************************
C * SORT KEY VALIDATION *
C ******************************
C
200 DO 210 I=1,KEYLIM
ISORT(I)=0
210 KSORT(I)=0
IF(NKEY.LT.1)GO TO 9140 !ERROR-KEY SPECIFICATION
C
C CHECK THAT ALL KEYS ARE IN RECORD BOUNDS
C
DO 220 I=1,NKEY
IF(KEYPOS(I).LE.0.OR.KEYPOS(I).GT.RECSIZ)
+ GO TO 9140 !ERROR-KEY SPECIFICATION
IF(KEYSIZ(I).LE.0.OR.KEYPOS(I)+KEYSIZ(I)-1.GT.RECSIZ)
+ GO TO 9140 !ERROR-KEY SPECIFICATION
220 CONTINUE
IF(NKEY.EQ.1)GO TO 250
C
C CHECK FOR ILLEGAL KEY OVERLAP
C
DO 240 I=1,NKEY-1
IMIN=KEYPOS(I)
IMAX=IMIN+KEYSIZ(I)-1
DO 240 J=I+1,NKEY
JMIN=KEYPOS(J)
JMAX=JMIN+KEYSIZ(J)-1
IF(JMIN.GE.IMIN.AND.JMIN.LE.IMAX)
+ GO TO 9140 !ERROR-KEY SPECIFICATION
IF(JMAX.GE.IMIN.AND.JMAX.LE.IMAX)
+ GO TO 9140 !ERROR-KEY SPECIFICATION
240 CONTINUE
C
250 IF(MODE.EQ.2)GO TO 405
C
C ******************************
C * FORMAT GENERATION *
C ******************************
C
300 DO 305 I=1,FMTLIM
305 FRMT(I)=0
FRMT(1)='('
BYTLIM=FMTLIM*5
IBYTE=1
SRTSIZ=0
KEYNUM=0
MINOLD=0
MINNEW=BIGNUM
C
C FIND START OF NEXT KEY (LEFT TO RIGHT)
C
310 INDEX=0
DO 320 I=1,NKEY
MINTMP=KEYPOS(I)
IF(MINTMP.LE.MINOLD.OR.MINTMP.GT.MINNEW)GO TO 320
MINNEW=MINTMP
INDEX=I
320 CONTINUE
IF(INDEX.EQ.0)MINNEW=RECSIZ+1
C
C PASS1 - GET FILLER FORMAT
C CHARACTERS BETWEEN LAST KEY AND CURRENT KEY
C PASS2 - GET KEY FORMAT
C
IPASS=1
ICHARS=MINNEW-MINOLD-1
IF(ICHARS.EQ.0)GO TO 385
330 IWORDS=ICHARS/5
IREM=ICHARS-(IWORDS*5)
IF(IPASS.EQ.2)ISORT(INDEX)=SRTSIZ+1
SRTSIZ=SRTSIZ+IWORDS
IF(IREM.GT.0)SRTSIZ=SRTSIZ+1
ENCODE(11,340,NUMSA5)IWORDS,IREM
340 FORMAT(I10,I1)
IF(IWORDS.EQ.0)GO TO 365
DECODE(11,350,NUMSA5)NUMSA1
350 FORMAT(11A1)
C
C FORMAT FOR FULL WORD PORTION OF STRING (#R5)
C
IF(IWORDS.EQ.1)GO TO 365
IBEGIN=9
IF(IWORDS.GT.99)IBEGIN=1
ZFLAG=0
DO 360 I=IBEGIN,10
JCHR=NUMSA1(I)
IF((JCHR.EQ.'0'.OR.JCHR.EQ.' ').AND.ZFLAG.EQ.0)GO TO 360
ZFLAG=1
IBYTE=IBYTE+1
IF(IBYTE.GT.BYTLIM)GO TO 9160 !ERROR-FORMAT
CALL PUTCHR(FRMT,IBYTE,JCHR)
360 CONTINUE
C
365 IBEGIN=1
LIM=4
IF(IWORDS.EQ.0)IBEGIN=4
IF(IREM.EQ.0)LIM=2
IF(IBEGIN.GT.LIM)GO TO 375
DO 370 I=IBEGIN,LIM
J=I
IBYTE=IBYTE+1
IF(IBYTE.GT.BYTLIM)GO TO 9160 !ERROR-FORMAT
370 CALL PUTCHR(FRMT,IBYTE,IDESC(J))
375 IF(IREM.EQ.0)GO TO 380
C
C FORMAT OF PARTIAL WORD PORTION (R#)
C
IBYTE=IBYTE+1
IF(IBYTE.GT.BYTLIM)GO TO 9160 !ERROR-FORMAT
CALL PUTCHR(FRMT,IBYTE,NUMSA5(3))
380 IBYTE=IBYTE+1
IF(IBYTE.GT.BYTLIM)GO TO 9160 !ERROR-FORMAT
CALL PUTCHR(FRMT,IBYTE,',')
385 IF(INDEX.EQ.0)GO TO 400
IPASS=IPASS+1
IF(IPASS.GT.2)GO TO 390
ICHARS=KEYSIZ(INDEX)
GO TO 330
390 MINOLD=MINNEW+KEYSIZ(INDEX)-1
MINNEW=BIGNUM
GO TO 310
400 CALL PUTCHR(FRMT,IBYTE,')') !END OF FORMAT, CLOSE WITH )
C
C COUNT KEYS AND SETUP TABLE OF KEY INDEXES RELATIVE TO
C START OF EXPANDED WORD-ALIGNED RECORD
C
405 KEYS=0
IF(MODE.EQ.2)SRTSIZ=RECSIZ
DO 410 I=1,NKEY
IF(MODE.EQ.1)KWORD=(KEYSIZ(I)+4)/5
IF(MODE.EQ.2)KWORD=KEYSIZ(I)
DO 410 J=0,KWORD-1
KEYS=KEYS+1
IF(KEYS.GT.KEYLIM)GO TO 9150 !ERROR-TOO MANY KEYS
IF(MODE.EQ.1)KSORT(KEYS)=ISORT(I)+J
IF(MODE.EQ.2)KSORT(KEYS)=KEYPOS(I)+J
IF(KEYORD(I).NE.0)KSORT(KEYS)=-KSORT(KEYS)
410 CONTINUE
DO 420 I=1,KEYS
ISORT(I)=KSORT(I)
IF(ISORT(I).LT.0)ISORT(I)=-KSORT(I)
420 CONTINUE
C
C ******************************
C * SORT / MERGE *
C ******************************
C
INTSRT=0
CHNCNT=0
INPEOF=0
OUTYPE=0
IFLAG1=0
OFLAG1=0
KNTIN=0
KNTOUT=0
C
C SPLIT UP SCRATCH AREA INTO DATA AND WORK ARRAYS
C
NCOLS=SRTSIZ
NROWS=ICORE/(NCOLS+1)
430 JCORE=NCOLS*NROWS+NCOLS+NROWS
IF(JCORE.LE.ICORE)GO TO 440
NROWS=NROWS-1
GO TO 430
440 IF(NROWS.LT.MAXCHN-1)GO TO 9170 !ERROR-NO ROOM FOR MERGE
C
C CALCULATE OFFSETS INTO SCRATCH AREA
C
DO 441 I=1,MAXCHN
441 MRGPT(I)=IREL+NCOLS*(I-1)
INDXR=IREL
INDXC=IREL+NROWS
INDXS=INDXC+NCOLS
IEND=INDXS+NROWS*NCOLS-1
C
C GET NEXT TEMP FILE CHANNEL (UNIT #) IF AVAILABLE
C
444 CALL CHKCHN(0,MRGCHN)
IF(MRGCHN.LE.0)GO TO 9190 !ERROR-NOT ENOUGH CHANNELS
OPEN(UNIT=MRGCHN,FILE=MRGFIL,DEVICE=SCRDEV,
+ ACCESS='SEQOUT',MODE='IMAGE',BUFFER COUNT=BUFCNT)
C
450 IF(CHNCNT.GE.MAXCHN)GO TO 520 !MERGE
CALL CHKCHN(0,CURCHN)
IF(CHNCNT.LT.2.AND.CURCHN.LE.0)GO TO 9190 !ERROR-TOO FEW CHANNELS
IF(CURCHN.LE.0)GO TO 520 !MERGE
C
C READ INPUT FILE INTO SCRATCH AREA
C
460 CHNCNT=CHNCNT+1
CHANNL(CHNCNT)=CURCHN
OPEN(UNIT=CHANNL(CHNCNT),FILE=SCRFIL(CHNCNT),DEVICE=SCRDEV,
+ ACCESS='SEQOUT',MODE='IMAGE',BUFFER COUNT=BUFCNT)
KNT=0
461 ISTART=INDXS+KNT
IF(UNITI.NE.0)GO TO 465
RETURN
C
ENTRY SRTIN(IFLAG)
C
IFLAG1=IFLAG
IF(IFLAG1.NE.0)GO TO 500
IF(MODE.EQ.2)GO TO 462
DECODE(RECSIZ,FRMT,RECORD)(SCRTCH(J),J=ISTART,IEND,NROWS)
GO TO 467
462 JJ=0
DO 463 J=ISTART,IEND,NROWS
JJ=JJ+1
463 SCRTCH(J)=RECORD(JJ)
GO TO 467
465 IF(MODE.EQ.1)
+ READ(UNITI,FRMT,END=500)(SCRTCH(J),J=ISTART,IEND,NROWS)
IF(MODE.EQ.2)
+ READ(UNITI,END=500)(SCRTCH(J),J=ISTART,IEND,NROWS)
C
C COMPLIMENT DESCENDING KEY WORDS
C
467 DO 470 K=1,KEYS
IF(KSORT(K).GE.0)GO TO 470
J=ISTART+((-KSORT(K)-1)*NROWS)
SCRTCH(J)=.NOT.SCRTCH(J)
470 CONTINUE
KNT=KNT+1
IF(KNT.LT.NROWS)GO TO 461
C
C INTERNAL SORT
C
500 IF(KNT.LT.NROWS)INPEOF=1
IF(KNT.EQ.0)CHNCNT=CHNCNT-1
IF(KNT.EQ.0)GO TO 520
INTSRT=INTSRT+1
KNTIN=KNTIN+KNT
CALL SSORT(NCOLS,KNT,NCOLS,NROWS,SCRTCH(INDXS),ISORT,
+ KEYS,SCRTCH(INDXR),SCRTCH(INDXC))
IF(INTSRT.EQ.1.AND.INPEOF.EQ.1)GO TO 515 !NO MERGE NEEDED
C
C OUTPUT TEMP FILE
C
DO 510 I=0,KNT-1
ISTART=INDXS+I
510 WRITE(CURCHN)(SCRTCH(J),J=ISTART,IEND,NROWS)
IF(INPEOF.EQ.0)GO TO 450
C
C MERGE TEMP FILES INTO OUTPUT FILE OR NEW TEMP FILE
C
515 IF(UNITO.NE.0)GO TO 520
RETURN
C
ENTRY SRTOUT(OFLAG)
C
C OUTYPE = 0 ON FIRST PASS, FALL THRU COMPUTED GOTO
C AFTER FIRST PASS:
C = 1 IF MERGE WAS REQUIRED
C = 2 IF NO MERGE REQUIRED, ONLY ONE INTERNAL SORT
C
OFLAG1=OFLAG
GO TO (640,850) OUTYPE
C
520 IF(KNTIN.EQ.0)GO TO 9000
EOFCNT=0
IF(INTSRT.EQ.1.AND.INPEOF.EQ.1)GO TO 800
OUTYPE=1
C
C INITIALIZE TEMP FILE BUFFERS WITH FIRST RECORD
C
DO 550 I=1,CHNCNT
CLOSE(UNIT=CHANNL(I))
OPEN(UNIT=CHANNL(I),FILE=SCRFIL(I),DEVICE=SCRDEV,
+ ACCESS='SEQIN',MODE='IMAGE',BUFFER COUNT=BUFCNT)
EOF(I)=0
READ(CHANNL(I))(SCRTCH(J),J=MRGPT(I),MRGPT(I)+NCOLS-1)
550 CONTINUE
C
555 IF(OFLAG1.NE.0)GO TO 9000
IF(EOFCNT.EQ.CHNCNT)GO TO 700
C
C LOCATE NEXT RECORD FOR OUTPUT
C EOF(I), I=1,CHNCNT
C -1 EOF ON CHANNEL
C 0 RECORD NOT ELIMINATED AS NEXT FOR OUTPUT
C 1 RECORD ELIMINATED ON BASIS OF KEY VALUE
C
DO 590 IKY=1,KEYS
SELCNT=0
DESEL=1
MINKEY=BIGNUM
DO 580 ICH=1,CHNCNT
IF(EOF(ICH).NE.0)GO TO 580
C
C CHECK FOR NEW MIN VALUE OF KEY
C
CURKEY=SCRTCH(MRGPT(ICH)+ISORT(IKY)-1)
IF(CURKEY.LT.MINKEY)GO TO 560
IF(CURKEY.EQ.MINKEY)GO TO 570
EOF(ICH)=1
GO TO 580
560 IF(ICH.EQ.1)GO TO 570
DO 565 I=DESEL,ICH-1
565 IF(EOF(I).EQ.0)EOF(I)=1
DESEL=ICH
SELCNT=0
570 SELCNT=SELCNT+1
SELCHN=ICH
MINKEY=CURKEY
580 CONTINUE
IF(SELCNT.LT.1)GO TO 9180 !ERROR-CANNOT FIND NEXT RECORD
IF(SELCNT.EQ.1)GO TO (610,620)INPEOF+1
590 CONTINUE
GO TO (610,620)INPEOF+1
C
C OUTPUT SELECTED RECORD TO TEMP FILE
C
610 WRITE(MRGCHN)(SCRTCH(I),I=MRGPT(SELCHN),MRGPT(SELCHN)+NCOLS-1)
GO TO 640
C
C OUTPUT SELECTED RECORD TO OUTPUT FILE
C COMPLIMENT DESCENDING KEY WORDS FIRST
C
620 KNTOUT=KNTOUT+1
DO 625 K=1,KEYS
IF(KSORT(K).GE.0)GO TO 625
J=MRGPT(SELCHN)-KSORT(K)-1
SCRTCH(J)=.NOT.SCRTCH(J)
625 CONTINUE
JSTART=MRGPT(SELCHN)
JEND=JSTART+NCOLS-1
IF(UNITO.NE.0)GO TO 635
IF(MODE.EQ.2)GO TO 630
ENCODE(RECSIZ,FRMT,RECORD)(SCRTCH(I),I=JSTART,JEND)
GO TO 634
630 J=0
DO 632 I=JSTART,JEND
J=J+1
632 RECORD(J)=SCRTCH(I)
634 OFLAG1=0
RETURN
635 IF(MODE.EQ.1)WRITE(UNITO,FRMT)(SCRTCH(I),I=JSTART,JEND)
IF(MODE.EQ.2)WRITE(UNITO)(SCRTCH(I),I=JSTART,JEND)
C
C REFILL BUFFER JUST WRITTEN
C
640 READ(CHANNL(SELCHN),END=650)
+ (SCRTCH(I),I=MRGPT(SELCHN),MRGPT(SELCHN)+NCOLS-1)
GO TO 660
650 EOF(SELCHN)=-1
EOFCNT=EOFCNT+1
660 DO 670 I=1,CHNCNT
IF(EOF(I).GT.0)EOF(I)=0
670 CONTINUE
GO TO 555
C
C DONE MERGE PHASE, DELETE TEMP FILES
C
700 IF(INPEOF.EQ.1)GO TO 9000
DO 710 I=1,CHNCNT
CLOSE(UNIT=CHANNL(I),DISPOSE='DELETE')
710 CHANNL(I)=0
CLOSE(UNIT=MRGCHN,FILE=SCRFIL(1))
CHNCNT=1
CHANNL(1)=MRGCHN
MRGCHN=0
OPEN(UNIT=CHANNL(1),FILE=SCRFIL(1),DEVICE=SCRDEV,
+ ACCESS='APPEND',MODE='IMAGE',BUFFER COUNT=BUFCNT)
GO TO 444
C
C WRITE OUTPUT FILE IF NO MERGE NEEDED
C
800 OUTYPE=2
801 ISTART=INDXS+KNTOUT
C
C COMPLIMENT DESCENDING KEY WORDS
C
DO 810 K=1,KEYS
IF(KSORT(K).GE.0)GO TO 810
J=ISTART+((-KSORT(K)-1)*NROWS)
SCRTCH(J)=.NOT.SCRTCH(J)
810 CONTINUE
IF(UNITO.NE.0)GO TO 840
IF(MODE.EQ.2)GO TO 820
ENCODE(RECSIZ,FRMT,RECORD)(SCRTCH(J),J=ISTART,IEND,NROWS)
GO TO 835
820 JJ=0
DO 830 J=ISTART,IEND,NROWS
JJ=JJ+1
830 RECORD(JJ)=SCRTCH(J)
835 OFLAG=0
RETURN
840 IF(MODE.EQ.1)WRITE(UNITO,FRMT)(SCRTCH(J),J=ISTART,IEND,NROWS)
IF(MODE.EQ.2)WRITE(UNITO)(SCRTCH(J),J=ISTART,IEND,NROWS)
850 KNTOUT=KNTOUT+1
IF(KNTOUT.LT.KNTIN)GO TO 801
C
9000 IERR=KNTOUT
IFLAG=KNTOUT
OFLAG=KNTOUT
IF(OFLAG.EQ.0)OFLAG=-1
GO TO 9900
C
C ERROR RETURNS
C
C ILLEGAL UNIT NUMBER, INPUT OR OUTPUT
9110 IERR=-1
GO TO 9900
C ILLEGAL MODE
9120 IERR=-2
GO TO 9900
C ILLEGAL RECORD SIZE PARAMETER (RECSIZ)
9130 IERR=-3
GO TO 9900
C KEY SPECIFICATION ERROR
9140 IERR=-4
GO TO 9900
C TOO MANY KEYS
9150 IERR=-5
GO TO 9900
C FORMAT ROOM EXCEEDED
9160 IERR=-6
GO TO 9900
C NO ROOM FOR INTERNAL SORT
9170 IERR=-7
GO TO 9900
C INTERNAL ERROR - MERGE
9180 IERR=-8
GO TO 9900
C NOT ENOUGH CHANNELS AVAILABLE
9190 IERR=-9
C
C DELETE ALL OPEN TEMP FILES
C
9900 DO 9990 I=0,MAXCHN
IF(CHANNL(I).EQ.0)GO TO 9990
CLOSE(UNIT=CHANNL(I),DISPOSE='DELETE')
CHANNL(I)=0
9990 CONTINUE
C
9999 IF(ISIZE.LE.0)CALL ALLCOR(0,JERR,IREL,SCRTCH)
RETURN
END