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 ) 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 (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 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 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