SUBROUTINE CDATE (BUFFER) *********************************************************************** * THIS SUBROUTINE WILL FILL THE THE VARIABLE "BUFFER" WITH TODAY'S * DATE IN THE FORMAT "MM/DD/YY". IT WAS WRITTEN ON JULY 15TH, 1987 * BY ROGER G. RUCKERT. * * *********************************************************************** CHARACTER*(*) BUFFER, WORK*9, PRGMNM*6, MONTHS*36 DATA PRGMNM /' CDATE'/ DATA MONTHS /'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC'/ ** INITIALIZATION I = LEN (BUFFER) IF (I .NE. 8) THEN PRINT 100, PRGMNM, I 100 FORMAT (T2, A6, ': BUFFER LENGTH IS NOT 8 BUT ', I10) STOP 100 END IF CALL DATE (WORK) ** NOW, CONVERT THE DAY AND YEAR BUFFER(3:3) = '/' BUFFER(4:5) = WORK(1:2) BUFFER(6:6) = '/' BUFFER(7:8) = WORK(8:9) IF (BUFFER(4:4) .EQ. ' ') BUFFER(4:4) = '0' ** FINALLY, CONVERT THE MONTH J = -2 DO 110 I = 1,12 J = J + 3 K = J + 2 IF (MONTHS(J:K) .EQ. WORK(4:6)) THEN CALL I2DSP (I, BUFFER, 1, 2, 'RJZFSL') RETURN END IF 110 CONTINUE ** MONTH WAS NOT FOUND PRINT 115, PRGMNM, WORK, MONTHS 115 FORMAT (T2, A6, ': MONTH IN STRING "', A9, '" NOT FOUND IN ARRAY ', 2 A36) STOP 115 END SUBROUTINE CTIME (BUFFER) *********************************************************************** * THIS SUBROUTINE WILL RETRIEVE THE CURRENT TIME IN THE FORMAT * "HH:MM:SS". IT WAS WRITTEN ON NOVEMBER 19TH, 1986. * * *********************************************************************** CHARACTER*(*) BUFFER, PRGMNM*6 DATA PRGMNM /' CTIME'/ I = LEN (BUFFER) IF (I .NE. 8) THEN PRINT 100, PRGMNM, I 100 FORMAT (T2, A6, ': BUFFER LENGTH IS NOT 8 BUT ', I10) STOP 100 END IF CALL TIME (BUFFER) RETURN END SUBROUTINE DAYOFWEEK (INDATE, OUTDAY, OPTION) *********************************************************************** This subroutine will convert an input day in standard "MM-DDD-YYYY" * format into the day of the week. The option field is either "LC" * or "lc" for lower case or "UC" or "uc" for upper case. * *********************************************************************** CHARACTER INDATE*(*), OUTDAY*(*), DAY_OF_WEEK*9, DAYWORK*23 CHARACTER OPTION*2 INTEGER*4 STATUS, SYS$BINTIM, LIB$DAY_OF_WEEK, DAYNUMBER, ILEN REAL*8 TIMBUF FIRST, CONVERT THE STRING TO 64 BIT FORMAT DAYWORK = ' ' ILEN = LEN(INDATE) IF (ILEN .GT. 23) THEN DAYWORK(1:23) = INDATE(1:23) ELSE DAYWORK(1:ILEN) = INDATE(1:ILEN) ENDIF STATUS = SYS$BINTIM (DAYWORK, TIMBUF) ILEN = LEN(OUTDAY) IF (.NOT. STATUS) THEN ERROR - SIGNAL ONE AND EXIT DO 100 I = 1, ILEN 100 OUTDAY(I:I) = '*' RETURN END IF STATUS = LIB$DAY_OF_WEEK (TIMBUF, DAYNUMBER) OUTDAY(1:ILEN) = ' ' IF (OPTION .EQ. 'LC' .OR. OPTION .EQ. 'lc') THEN IF (DAYNUMBER .EQ. 1) THEN DAY_OF_WEEK = 'Monday' ELSE IF (DAYNUMBER .EQ. 2) THEN DAY_OF_WEEK = 'Tuesday' ELSE IF (DAYNUMBER .EQ. 3) THEN DAY_OF_WEEK = 'Wednesday' ELSE IF (DAYNUMBER .EQ. 4) THEN DAY_OF_WEEK = 'Thursday' ELSE IF (DAYNUMBER .EQ. 5) THEN DAY_OF_WEEK = 'Friday' ELSE IF (DAYNUMBER .EQ. 6) THEN DAY_OF_WEEK = 'Saturday' ELSE IF (DAYNUMBER .EQ. 7) THEN DAY_OF_WEEK = 'Sunday' ELSE DAY_OF_WEEK = '*********' ENDIF ELSE IF (DAYNUMBER .EQ. 1) THEN DAY_OF_WEEK = 'MONDAY' ELSE IF (DAYNUMBER .EQ. 2) THEN DAY_OF_WEEK = 'TUESDAY' ELSE IF (DAYNUMBER .EQ. 3) THEN DAY_OF_WEEK = 'WEDNESDAY' ELSE IF (DAYNUMBER .EQ. 4) THEN DAY_OF_WEEK = 'THURSDAY' ELSE IF (DAYNUMBER .EQ. 5) THEN DAY_OF_WEEK = 'FRIDAY' ELSE IF (DAYNUMBER .EQ. 6) THEN DAY_OF_WEEK = 'SATURDAY' ELSE IF (DAYNUMBER .EQ. 7) THEN DAY_OF_WEEK = 'SUNDAY' ELSE DAY_OF_WEEK = '*********' ENDIF ENDIF IF (ILEN .GE. 9) THEN OUTDAY(1:9) = DAY_OF_WEEK ELSE DO 110 I = 1, ILEN 110 OUTDAY(I:I) = DAY_OF_WEEK(I:I) END IF RETURN END SUBROUTINE DAYOFWEEK_YMD (INDATE, OUTDAY, OPTION) *********************************************************************** This subroutine will convert an input day in standard "YYYY-MM-DD" * format into the day of the week. The option field is either "LC" * or "lc" for lower case or "UC" or "uc" for upper case. * *********************************************************************** CHARACTER INDATE*(*), OUTDAY*(*), DAY_OF_WEEK*9, DAYWORK*23 CHARACTER OPTION*2 INTEGER*4 STATUS, SYS$BINTIM, LIB$DAY_OF_WEEK, DAYNUMBER, ILEN, I4 LOGICAL ERROR REAL*8 TIMBUF FIRST, CONVERT THE STRING TO 64 BIT FORMAT DAYWORK = ' ' ILEN = LEN(INDATE) IF (ILEN .NE. 10) THEN PRINT *, 'DAYOFWEEK_YMD, input length must be 10' CALL EXIT (4) END IF ILEN = LEN(OUTDAY) CALL I4BIN (I4, INDATE, 9, 10, 'SL', ERROR) IF (ERROR) GO TO 95 CALL I4DSP (I4, DAYWORK, 1, 2, 'RJZFSL') DAYWORK(3:3) = '-' CALL I4BIN (I4, INDATE, 6, 7, 'SL', ERROR) IF (ERROR) GO TO 95 IF (I4 .EQ. 1) THEN DAYWORK(4:6) = 'JAN' ELSE IF (I4 .EQ. 2) THEN DAYWORK(4:6) = 'FEB' ELSE IF (I4 .EQ. 3) THEN DAYWORK(4:6) = 'MAR' ELSE IF (I4 .EQ. 4) THEN DAYWORK(4:6) = 'APR' ELSE IF (I4 .EQ. 5) THEN DAYWORK(4:6) = 'MAY' ELSE IF (I4 .EQ. 6) THEN DAYWORK(4:6) = 'JUN' ELSE IF (I4 .EQ. 7) THEN DAYWORK(4:6) = 'JUL' ELSE IF (I4 .EQ. 8) THEN DAYWORK(4:6) = 'AUG' ELSE IF (I4 .EQ. 9) THEN DAYWORK(4:6) = 'SEP' ELSE IF (I4 .EQ. 10) THEN DAYWORK(4:6) = 'OCT' ELSE IF (I4 .EQ. 11) THEN DAYWORK(4:6) = 'NOV' ELSE IF (I4 .EQ. 12) THEN DAYWORK(4:6) = 'DEC' ELSE GO TO 95 END IF DAYWORK(7:7) = '-' DAYWORK(8:11) = INDATE (1:4) STATUS = SYS$BINTIM (DAYWORK, TIMBUF) IF (.NOT. STATUS) THEN ERROR - SIGNAL ONE AND EXIT 95 DO 100 I = 1, ILEN 100 OUTDAY(I:I) = '*' RETURN END IF STATUS = LIB$DAY_OF_WEEK (TIMBUF, DAYNUMBER) OUTDAY(1:ILEN) = ' ' IF (OPTION .EQ. 'LC' .OR. OPTION .EQ. 'lc') THEN IF (DAYNUMBER .EQ. 1) THEN DAY_OF_WEEK = 'Monday' ELSE IF (DAYNUMBER .EQ. 2) THEN DAY_OF_WEEK = 'Tuesday' ELSE IF (DAYNUMBER .EQ. 3) THEN DAY_OF_WEEK = 'Wednesday' ELSE IF (DAYNUMBER .EQ. 4) THEN DAY_OF_WEEK = 'Thursday' ELSE IF (DAYNUMBER .EQ. 5) THEN DAY_OF_WEEK = 'Friday' ELSE IF (DAYNUMBER .EQ. 6) THEN DAY_OF_WEEK = 'Saturday' ELSE IF (DAYNUMBER .EQ. 7) THEN DAY_OF_WEEK = 'Sunday' ELSE DAY_OF_WEEK = '*********' ENDIF ELSE IF (DAYNUMBER .EQ. 1) THEN DAY_OF_WEEK = 'MONDAY' ELSE IF (DAYNUMBER .EQ. 2) THEN DAY_OF_WEEK = 'TUESDAY' ELSE IF (DAYNUMBER .EQ. 3) THEN DAY_OF_WEEK = 'WEDNESDAY' ELSE IF (DAYNUMBER .EQ. 4) THEN DAY_OF_WEEK = 'THURSDAY' ELSE IF (DAYNUMBER .EQ. 5) THEN DAY_OF_WEEK = 'FRIDAY' ELSE IF (DAYNUMBER .EQ. 6) THEN DAY_OF_WEEK = 'SATURDAY' ELSE IF (DAYNUMBER .EQ. 7) THEN DAY_OF_WEEK = 'SUNDAY' ELSE DAY_OF_WEEK = '*********' ENDIF ENDIF IF (ILEN .GE. 9) THEN OUTDAY(1:9) = DAY_OF_WEEK ELSE DO 110 I = 1, ILEN 110 OUTDAY(I:I) = DAY_OF_WEEK(I:I) END IF RETURN END SUBROUTINE DTIMEA (INTIME1A, INTIME2A, OUTTIMEA, OUTTIMEB) *********************************************************************** This subroutine will determine what the time difference is between * 2 submitted times in the standard system ASCII format: * DD-MMM-YYYY HH:MM:SS.SS * The delta time is returned in 2 formats: the standard system * DDDD HH:MM:SS.SS * and in its binary equivalent. INTIME1A is assumed to be the ear- * lier time. * * DTIMEA was written on October 14th, 1988 by Roger G. Ruckert. * *********************************************************************** CHARACTER*23 INTIME1A, INTIME2A, OUTTIMEA INTEGER*4 OUTTIMEB (2), INTIME1B (2), INTIME2B (2), ZERO (2) INTEGER*4 STATUS, SYS$BINTIM, LIB$SUBX, SYS$ASCTIM LOGICAL ERROR, NEG DATA ZERO /0, 0/ ERROR = .FALSE. ** DO SOME BASIC CHECKING OF THE INPUT TIMES IF (INTIME1A(3:3) .NE. '-' .OR. INTIME1A(7:7) .NE. '-' .OR. 2 INTIME1A(12:12) .NE. ' ' .OR. INTIME1A(15:15) .NE. ':' .OR. 3 INTIME1A(18:18) .NE. ':' .OR. INTIME1A(21:21) .NE. '.') THEN PRINT *, ' DTIMEA: INTIME1 IS NOT IN THE STANDARD FORMAT ', 2 'OF DD-MMM-YYYY HH:MM:SS.SS BUT IS' PRINT *, ' ', INTIME1A ERROR = .TRUE. END IF IF (INTIME2A(3:3) .NE. '-' .OR. INTIME2A(7:7) .NE. '-' .OR. 2 INTIME2A(12:12) .NE. ' ' .OR. INTIME2A(15:15) .NE. ':' .OR. 3 INTIME2A(18:18) .NE. ':' .OR. INTIME2A(21:21) .NE. '.') THEN PRINT *, ' DTIMEA: INTIME2 IS NOT IN THE STANDARD FORMAT ', 2 'OF DD-MMM-YYYY HH:MM:SS.SS BUT IS' PRINT *, ' ', INTIME2A ERROR = .TRUE. END IF IF (ERROR) CALL EXIT (4) ** CONVERT THE NUMBERS TO BINARY FORMAT STATUS = SYS$BINTIM (INTIME1A, INTIME1B) IF (.NOT. STATUS) THEN PRINT *, ' DTIMEA: INTIME1 CONVERSION ERROR' CALL LIB$SIGNAL (%VAL(STATUS)) ERROR = .TRUE. END IF STATUS = SYS$BINTIM (INTIME2A, INTIME2B) IF (.NOT. STATUS) THEN PRINT *, ' DTIMEA: INTIME2 CONVERSION ERROR' CALL LIB$SIGNAL (%VAL(STATUS)) ERROR = .TRUE. END IF IF (ERROR) CALL EXIT (4) ** NOW SUBTRACT THE 2 TIMES STATUS = LIB$SUBX (INTIME2B, INTIME1B, OUTTIMEB) IF (.NOT. STATUS) THEN PRINT *, ' DTIMEA: LIB$SUBX CONVERSION ERROR' CALL LIB$SIGNAL (%VAL(STATUS)) CALL EXIT (4) END IF ** IF TIME DIFFERENCE IS POSITIVE, INTIMEA > INTIMEB IF (.NOT. (BTEST (OUTTIMEB(2),31))) THEN STATUS = LIB$SUBX (ZERO, OUTTIMEB, OUTTIMEB) NEG = .TRUE. ELSE NEG = .FALSE. END IF ** NOW FORMAT THE TIME STATUS = SYS$ASCTIM (, OUTTIMEA, OUTTIMEB, ) IF (.NOT. NEG) OUTTIMEA(5:5) = '-' RETURN END SUBROUTINE F4BIN (F4, CHARAR, IBEG, IEND, OPTNS, ERROR) *********************************************************************** * THIS SUBROUTINE WILL CHANGE A DISPLAY NUMBER INTO A REAL*4 NUMBER. * THE PARAMETERS ARE AS FOLLOWS: * * F4 THE REAL NUMBER PASSED BACK TO THE CALLING PROGRAM * CHARAR THE INPUT CHARACTER ARRAY (THE NUMBER MAY INCLUDE PLUS * AND MINUS SIGNS, SPACES, COMMAS, AND UP TO ONE PERIOD IN * ADDITION TO THE INTEGERS; OTHER CHARACTERS ARE CONSID- * ERED AN ERROR CONDITION) * IBEG THE BEGINNING POSITION IN CHARAR THAT THE CONVERSION IS * TO TAKE PLACE * IEND THE ENDING POSITION IN CHARAR THAT THE CONVERSION IS TO * TAKE PLACE * OPTNS A 2 CHARACTER ARRAY WITH VALID OPTIONS OF "SL" (SIGN * LEADING), "ST" (SIGN TRAILING), OR "SO" (SIGN OVER- * PUNCHED IN THE COBOL TRADITION) * ERROR IF ERRORS ARE DETECTED IN CHARAR, 'ERROR' IS SET TO TRUE. * * THIS SUBROUTINE WAS WRITTEN ON SEPTEMBER 29TH, 1987 BY ROGER G. * RUCKERT. * * *********************************************************************** REAL*4 F4, FTEMP LOGICAL ERROR, NEG CHARACTER CHARAR*(*), WORK*4, OPTNS*2, PRGMNM*6 INTEGER*2 IWORK EQUIVALENCE (WORK, IWORK) DATA PRGMNM/' F4BIN'/ ERROR = .FALSE. NEG = .FALSE. F4 = 0.0 FIRST, LOCATE THE PERIOD IN THE STRING (IF NOT PRESENT, ASSUME IT'S 1 TO THE RIGHT OF IEND) DO 100 IPER = IBEG, IEND 100 IF (CHARAR(IPER:IPER) .EQ. '.') GO TO 110 IPER = IEND + 1 ** NOW CONVERT THE NUMBERS TO THE LEFT OF THE DECIMAL 110 EXP = 0.0 I = IPER - 1 120 IF (I .LT. IBEG) GO TO 150 WORK(1:1) = CHARAR(I:I) IGNORE BLANKS, PLUS SIGNS, AND COMMAS IF (WORK(1:1) .EQ. ' ' .OR. WORK(1:1) .EQ. '+' .OR. WORK(1:1) .EQ. 2 ',') GO TO 145 CHECK FOR RIGHTMOST POSITION AND ITS SPECIAL CASES IF (I .EQ. IEND) THEN IF (OPTNS(1:2) .EQ. 'ST') THEN IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 145 ELSE IF (WORK(1:1) .EQ. ' ') THEN GO TO 145 ELSE GO TO 200 END IF ELSE IF (OPTNS(1:2) .EQ. 'SO') THEN IF (WORK(1:1) .EQ . '}') THEN NEG = .TRUE. GO TO 140 ELSE IF (WORK(1:1) .GE. 'J' .AND. WORK(1:1) .LE. 'R') 2 THEN NEG = .TRUE. IWORK = IWORK - 73 GO TO 135 ELSE IF (WORK(1:1) .GE. '0' .AND. WORK(1:1) .LE. '9') 2 THEN GO TO 130 ELSE GO TO 200 END IF END IF END IF IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 145 ELSE IF (WORK(1:1) .LT. '0' .OR. WORK(1:1) .GT. '9') THEN INVALID CHARACTER GO TO 200 END IF ALL TESTS HAVE BEEN PERFORMED, SO CONVERT THE NUMBER 130 IWORK = IWORK - 48 135 F4 = F4 + (FLOAT(IWORK) * (10.0 ** EXP)) 140 EXP = EXP + 1.0 145 I = I - 1 GO TO 120 ** NOW CONVERT THE NUMBERS TO THE RIGHT OF THE DECIMAL 150 EXP = -1.0 I = IPER + 1 160 IF (I .GT. IEND) GO TO 190 WORK(1:1) = CHARAR(I:I) IGNORE BLANKS, PLUS SIGNS, AND COMMAS IF (WORK(1:1) .EQ. ' ' .OR. WORK(1:1) .EQ. '+' .OR. WORK(1:1) .EQ. 2 ',') GO TO 185 CHECK FOR RIGHTMOST POSITION AND ITS SPECIAL CASES IF (I .EQ. IEND) THEN IF (OPTNS(1:2) .EQ. 'ST') THEN IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 185 ELSE IF (WORK(1:1) .EQ. ' ') THEN GO TO 185 ELSE GO TO 200 END IF ELSE IF (OPTNS(1:2) .EQ. 'SO') THEN IF (WORK(1:1) .EQ . '}') THEN NEG = .TRUE. GO TO 180 ELSE IF (WORK(1:1) .GE. 'J' .AND. WORK(1:1) .LE. 'R') 2 THEN NEG = .TRUE. IWORK = IWORK - 73 GO TO 175 ELSE IF (WORK(1:1) .GE. '0' .AND. WORK(1:1) .LE. '9') 2 THEN GO TO 170 ELSE GO TO 200 END IF END IF END IF IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 185 ELSE IF (WORK(1:1) .LT. '0' .OR. WORK(1:1) .GT. '9') THEN INVALID CHARACTER GO TO 200 END IF ALL TESTS HAVE BEEN PERFORMED, SO CONVERT THE NUMBER 170 IWORK = IWORK - 48 175 F4 = F4 + (FLOAT(IWORK) * (10.0 ** EXP)) 180 EXP = EXP - 1.0 185 I = I + 1 GO TO 160 ** ALL DONE, SO CHECK FOR NEGATIVE AND EXIT 190 IF (NEG) F4 = F4 * -1.0 RETURN ** ERROR EXIT 200 ERROR = .TRUE. RETURN END SUBROUTINE F4DSP (REALNO, CHARAR, IBEG, IEND, IACC, OPTNS) *********************************************************************** * THIS SUBROUTINE WILL CONVERT A REAL*4 NUMBER INTO A DISPLAY NUMBER. * THE FIELDS PASSED ARE: (1) INNUM, THE NUMBER TO BE CONVERTED; (2) * CHARAR, THE OUTPUT CHARACTER ARRAY; (3) IBEG AND (4) IEND, THE * BEGINNING AND ENDING POSITIONS OF THE OUTPUT NUMBER WITHIN THE * ARRAY; (5) THE ACCURACY (NUMBER OF POSITIONS TO THE RIGHT OF THE * DECIMAL); AND (6) THE CONVERSION OPTIONS, A 6 CHARACTER ARRAY WITH * THE FOLLOWING FORMAT (DEFAULT IS "LJSFSL"): * * CHARACTERS 1-2: "LJ", LEFT JUSTIFIED; "RJ", RIGHT JUSTIFIED * 3-4: "SF", SPACE FILLED; "ZF", ZERO FILLED * 5-6: "SL", SIGN LEADING; "ST", SIGN TRAILING; "SO", * SIGN OVERPUNCHED (IN THE COBOL TRADITION) * * OUTPUT NUMBERS UP TO 18 CHARACTER POSITIONS (WITH OVERPUNCH) OR 19 * (WITH SIGN LEADING OR TRAILING) WILL BE SUPPORTED. (THIS IS THE * ANSI STANSARD FOR COBOL NUMERIC FIELDS.) IF THE SUBROUTINE DETECTS * THAT THERE WILL BE AN OVERFLOW IN THE OUTPUT FIELD, THE ENTIRE * FIELD WILL BE FILLED WITH ASTERISKS. THIS IS ALSO TRUE IF CERTAIN * INVALID ARGUMENTS ARE PASSED TO THE SUBROUTINE. * * THIS SUBROUTINE WAS WRITTEN ON SEPTEMBER 29TH, 1987 BY ROGER G. * RUCKERT. * * *********************************************************************** PARAMETER (MAXLEN = 18) LOGICAL NEG REAL*4 REALNO, TEMPNO, FTEMP, TEMP CHARACTER SPACES*19, OVERFL*19, ZEROES*19, WORK*4 CHARACTER CHARAR*(*), OPTNS*6, PRGMNM*6 EQUIVALENCE (WORK, IWORK) DATA SPACES/' '/, PRGMNM/' F4DSP'/ DATA OVERFL/'*******************'/ DATA ZEROES/'0000000000000000000'/ ** SEE IF INPUT PARAMETERS ARE VALID IF (IBEG .LT. 1) THEN PRINT 100, PRGMNM, IBEG 100 FORMAT (T2, A6, ': INVALID BEGINNING POSITION OF ', I10) STOP 100 END IF IF (IEND .LT. 1) THEN PRINT 105, PRGMNM, IEND 105 FORMAT (T2, A6, ': INVALID ENDING POSITION OF ', I10) STOP 105 END IF ILEN = (IEND - IBEG) + 1 IF (ILEN .LT. 1) THEN PRINT 110, PRGMNM, IBEG, IEND 110 FORMAT (T2, A6, ': INVALID RANGE OF ', I10, ' TO ', I10) STOP 110 END IF IF ((OPTNS(5:6) .EQ. 'SO') .AND. (ILEN .GT. MAXLEN)) THEN PRINT 115, PRGMNM, ILEN, MAXLEN 115 FORMAT (T2, A6, ': DESIRED LENGTH OF ', I5, ' IS GREATER ', 2 'THAN CURRENT MAXIMUM OF ', I5) STOP 115 ELSE IF (ILEN .GT. MAXLEN + 1) THEN PRINT 115, PRGMNM, ILEN, MAXLEN STOP 120 END IF IF (IEND .GT. LEN(CHARAR)) THEN PRINT 125, PRGMNM, IEND, LEN(CHARAR) 125 FORMAT (T2, A6, ': LAST CHARACTER POSITION (', I10, 2 ') EXCEEDS LENGTH OF ARRAY (', I10,')') STOP 125 END IF IF (LEN(OPTNS) .NE. 6) THEN PRINT 130, PRGMNM, LEN(OPTNS) 130 FORMAT (T2, A6, ': LENGTH OF OPTIONS ARRAY IS NOT 6 BUT ', 2 I10) STOP 130 END IF IF ((IACC .LT. 0) .OR. (IACC .GT. MAXLEN-1)) THEN PRINT 132, PRGMNM, IACC, MAXLEN - 1 132 FORMAT (T2, A6, ': ACCURACY TO RIGHT OF DECIMAL (', I10, 2 ') IS NOT BETWEEN 0 AND ', I10) STOP 132 END IF ** NOW CHECK FOR OVERFLOW IF (REALNO .LT. 0.0) THEN NEG = .TRUE. TEMPNO = -REALNO ELSE NEG = .FALSE. TEMPNO = REALNO END IF ** NOW, ROUND THE NUMBER FTEMP = 0.0 - FLOAT (IACC) TEMPNO = TEMPNO + (0.5 * (10.0 ** FTEMP)) ** GET NUMBER OF DIGITS TO LEFT OF DECIMAL FTEMP = 10.0 DO 140 NLEFT = 1, MAXLEN IF (TEMPNO .LT. FTEMP) GO TO 150 FTEMP = FTEMP * 10.0 140 CONTINUE OVERFLOW CONDITION, SO ASTERISK FILL AND EXIT CHARAR(IBEG:IEND) = OVERFL(1:ILEN) RETURN 150 IF ((NEG .AND. OPTNS(5:6) .EQ. 'SL') .OR. OPTNS(5:6) .EQ. 2 'ST') THEN NDTEMP = NLEFT + IACC + 2 ELSE NDTEMP = NLEFT + IACC + 1 END IF IF (NDTEMP .GT. ILEN) THEN CHARAR(IBEG:IEND) = OVERFL(1:ILEN) RETURN END IF ** LOOKS OK, SO START THE PROCESS 1. SPACE- OR ZERO-FILL THE ARRAY IF (OPTNS(3:4) .EQ. 'ZF') THEN CHARAR(IBEG:IEND) = ZEROES(1:ILEN) ELSE ASSUME SPACE FILLED CHARAR(IBEG:IEND) = SPACES(1:ILEN) END IF ** 2. DETERMINE THE LEFT-MOST POSITION IF (OPTNS(1:2) .EQ. 'RJ') THEN IF (OPTNS(5:6) .EQ. 'ST') THEN IPOS = IEND - NDTEMP + 1 ELSE IF (OPTNS(5:6) .EQ. 'SO') THEN IPOS = IEND - NDTEMP + 1 ELSE IF (NEG) THEN IPOS = IEND - NDTEMP + 2 IMINUS = IPOS - 1 ELSE IPOS = IEND - NDTEMP + 1 END IF ELSE LJ IF (OPTNS(5:6) .EQ. 'SL' .AND. NEG) THEN IPOS = IBEG + 1 IMINUS = IBEG ELSE IPOS = IBEG END IF END IF 3. CONVERT THE NUMBER TO THE LEFT OF THE DECIMAL POINT EXP = FLOAT (NLEFT) DO 160 I = 1, NLEFT EXP = EXP - 1.0 TEMP = TEMPNO / (10.0 ** EXP) IWORK = INT (TEMP) TEMP = FLOAT (IWORK) TEMPNO = TEMPNO - (TEMP * (10.0 ** EXP)) IWORK = IWORK + 48 CHARAR(IPOS:IPOS) = WORK(1:1) ILAST = IPOS IPOS = IPOS + 1 160 CONTINUE 4. INSERT THE DECIMAL POINT CHARAR(IPOS:IPOS) = '.' IPOS = IPOS + 1 5. CONVERT THE NUMBER TO THE RIGHT OF THE DECIMAL POINT (IF NECESSARY) IF (IACC .GT. 0) THEN DO 170 I = 1, IACC EXP = EXP - 1.0 TEMP = TEMPNO / (10.0 ** EXP) IWORK = INT (TEMP) TEMP = FLOAT (IWORK) TEMPNO = TEMPNO - (TEMP* (10.0 ** EXP)) IWORK = IWORK + 48 CHARAR(IPOS:IPOS) = WORK(1:1) ILAST = IPOS IPOS = IPOS + 1 170 CONTINUE END IF 6. FINALLY, INSERT A MINUS SIGN IF NECESSARY IF (OPTNS(5:6) .EQ. 'ST') ILAST = ILAST + 1 IF (NEG) THEN IF (OPTNS(5:6) .EQ. 'SO') THEN CONVERT NUMBER TO '}' FOR ZERO AND 'J-R' FOR 1-9 IWORK = 0 WORK(1:1) = CHARAR(ILAST:ILAST) IF (WORK(1:1) .EQ. '0') THEN WORK (1:1) = '}' ELSE IWORK = IWORK + 25 END IF CHARAR(ILAST:ILAST) = WORK(1:1) ELSE IF (OPTNS(5:6) .EQ. 'ST') THEN CHARAR(ILAST:ILAST) = '-' ELSE CHARAR(IMINUS:IMINUS) = '-' END IF ELSE IF (OPTNS(5:6) .EQ. 'ST') THEN CHARAR(ILAST:ILAST) = ' ' END IF RETURN END SUBROUTINE F8BIN (F8, CHARAR, IBEG, IEND, OPTNS, ERROR) *********************************************************************** * THIS SUBROUTINE WILL CHANGE A DISPLAY NUMBER INTO A REAL*8 NUMBER. * THE PARAMETERS ARE AS FOLLOWS: * * F8 THE REAL NUMBER PASSED BACK TO THE CALLING PROGRAM * CHARAR THE INPUT CHARACTER ARRAY (THE NUMBER MAY INCLUDE PLUS * AND MINUS SIGNS, SPACES, AND COMMAS IN ADDITION TO THE * INTEGERS; OTHER CHARACTERS ARE CONSIDERED AN ERROR CON- * DITION) * IBEG THE BEGINNING POSITION IN CHARAR THAT THE CONVERSION IS * TO TAKE PLACE * IEND THE ENDING POSITION IN CHARAR THAT THE CONVERSION IS TO * TAKE PLACE * OPTNS A 2 CHARACTER ARRAY WITH VALID OPTIONS OF "SL" (SIGN * LEADING), "ST" (SIGN TRAILING), OR "SO" (SIGN OVER- * PUNCHED IN THE COBOL TRADITION) * ERROR IF ERRORS ARE DETECTED IN CHARAR, 'ERROR' IS SET TO TRUE. * * THIS SUBROUTINE WAS WRITTEN ON SEPTEMBER 29TH, 1987 BY ROGER G. * RUCKERT. * * *********************************************************************** REAL*8 F8 LOGICAL ERROR, NEG CHARACTER CHARAR*(*), WORK*4, OPTNS*2, PRGMNM*6 INTEGER*2 IWORK EQUIVALENCE (WORK, IWORK) DATA PRGMNM/' F8BIN'/ ERROR = .FALSE. NEG = .FALSE. F8 = 0.0 FIRST, LOCATE THE PERIOD IN THE STRING (IF NOT PRESENT, ASSUME IT'S 1 TO THE RIGHT OF IEND) DO 100 IPER = IBEG, IEND 100 IF (CHARAR(IPER:IPER) .EQ. '.') GO TO 110 IPER = IEND + 1 ** NOW CONVERT THE NUMBERS TO THE LEFT OF THE DECIMAL 110 EXP = 0.0 I = IPER - 1 120 IF (I .LT. IBEG) GO TO 150 WORK(1:1) = CHARAR(I:I) IGNORE BLANKS, PLUS SIGNS, AND COMMAS IF (WORK(1:1) .EQ. ' ' .OR. WORK(1:1) .EQ. '+' .OR. WORK(1:1) .EQ. 2 ',') GO TO 145 CHECK FOR RIGHTMOST POSITION AND ITS SPECIAL CASES IF (I .EQ. IEND) THEN IF (OPTNS(1:2) .EQ. 'ST') THEN IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 145 ELSE IF (WORK(1:1) .EQ. ' ') THEN GO TO 145 ELSE GO TO 200 END IF ELSE IF (OPTNS(1:2) .EQ. 'SO') THEN IF (WORK(1:1) .EQ . '}') THEN NEG = .TRUE. GO TO 140 ELSE IF (WORK(1:1) .GE. 'J' .AND. WORK(1:1) .LE. 'R') 2 THEN NEG = .TRUE. IWORK = IWORK - 73 GO TO 135 ELSE IF (WORK(1:1) .GE. '0' .AND. WORK(1:1) .LE. '9') 2 THEN GO TO 130 ELSE GO TO 200 END IF END IF END IF IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 145 ELSE IF (WORK(1:1) .LT. '0' .OR. WORK(1:1) .GT. '9') THEN INVALID CHARACTER GO TO 200 END IF ALL TESTS HAVE BEEN PERFORMED, SO CONVERT THE NUMBER 130 IWORK = IWORK - 48 135 F8 = F8 + (FLOAT(IWORK) * (10.0 ** EXP)) 140 EXP = EXP + 1.0 145 I = I - 1 GO TO 120 ** NOW CONVERT THE NUMBERS TO THE RIGHT OF THE DECIMAL 150 EXP = -1.0 I = IPER + 1 160 IF (I .GT. IEND) GO TO 190 WORK(1:1) = CHARAR(I:I) IGNORE BLANKS, PLUS SIGNS, AND COMMAS IF (WORK(1:1) .EQ. ' ' .OR. WORK(1:1) .EQ. '+' .OR. WORK(1:1) .EQ. 2 ',') GO TO 185 CHECK FOR RIGHTMOST POSITION AND ITS SPECIAL CASES IF (I .EQ. IEND) THEN IF (OPTNS(1:2) .EQ. 'ST') THEN IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 185 ELSE IF (WORK(1:1) .EQ. ' ') THEN GO TO 185 ELSE GO TO 200 END IF ELSE IF (OPTNS(1:2) .EQ. 'SO') THEN IF (WORK(1:1) .EQ . '}') THEN NEG = .TRUE. GO TO 180 ELSE IF (WORK(1:1) .GE. 'J' .AND. WORK(1:1) .LE. 'R') 2 THEN NEG = .TRUE. IWORK = IWORK - 73 GO TO 175 ELSE IF (WORK(1:1) .GE. '0' .AND. WORK(1:1) .LE. '9') 2 THEN GO TO 170 ELSE GO TO 200 END IF END IF END IF IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 185 ELSE IF (WORK(1:1) .LT. '0' .OR. WORK(1:1) .GT. '9') THEN INVALID CHARACTER GO TO 200 END IF ALL TESTS HAVE BEEN PERFORMED, SO CONVERT THE NUMBER 170 IWORK = IWORK - 48 175 F8 = F8 + (FLOAT(IWORK) * (10.0 ** EXP)) 180 EXP = EXP - 1.0 185 I = I + 1 GO TO 160 ** ALL DONE, SO CHECK FOR NEGATIVE AND EXIT 190 IF (NEG) F8 = F8 * -1.0 RETURN ** ERROR EXIT 200 ERROR = .TRUE. RETURN END SUBROUTINE F8DSP (REALNO, CHARAR, IBEG, IEND, IACC, OPTNS) *********************************************************************** * THIS SUBROUTINE WILL CONVERT A REAL*4 NUMBER INTO A DISPLAY NUMBER. * THE FIELDS PASSED ARE: (1) INNUM, THE NUMBER TO BE CONVERTED; (2) * CHARAR, THE OUTPUT CHARACTER ARRAY; (3) IBEG AND (4) IEND, THE * BEGINNING AND ENDING POSITIONS OF THE OUTPUT NUMBER WITHIN THE * ARRAY; (5) THE ACCURACY (NUMBER OF POSITIONS TO THE RIGHT OF THE * DECIMAL); AND (6) THE CONVERSION OPTIONS, A 6 CHARACTER ARRAY WITH * THE FOLLOWING FORMAT (DEFAULT IS "LJSFSL"): * * CHARACTERS 1-2: "LJ", LEFT JUSTIFIED; "RJ", RIGHT JUSTIFIED * 3-4: "SF", SPACE FILLED; "ZF", ZERO FILLED * 5-6: "SL", SIGN LEADING; "ST", SIGN TRAILING; "SO", * SIGN OVERPUNCHED (IN THE COBOL TRADITION) * * OUTPUT NUMBERS UP TO 18 CHARACTER POSITIONS (WITH OVERPUNCH) OR 19 * (WITH SIGN LEADING OR TRAILING) WILL BE SUPPORTED. (THIS IS THE * ANSI STANSARD FOR COBOL NUMERIC FIELDS.) IF THE SUBROUTINE DETECTS * THAT THERE WILL BE AN OVERFLOW IN THE OUTPUT FIELD, THE ENTIRE * FIELD WILL BE FILLED WITH ASTERISKS. THIS IS ALSO TRUE IF CERTAIN * INVALID ARGUMENTS ARE PASSED TO THE SUBROUTINE. * * THIS SUBROUTINE WAS WRITTEN ON SEPTEMBER 29TH, 1987 BY ROGER G. * RUCKERT. * * *********************************************************************** PARAMETER (MAXLEN = 18) LOGICAL NEG REAL*8 REALNO, TEMPNO, FTEMP, TEMP CHARACTER SPACES*19, OVERFL*19, ZEROES*19, WORK*4 CHARACTER CHARAR*(*), OPTNS*6, PRGMNM*6 EQUIVALENCE (WORK, IWORK) DATA SPACES/' '/, PRGMNM/' F8DSP'/ DATA OVERFL/'*******************'/ DATA ZEROES/'0000000000000000000'/ ** SEE IF INPUT PARAMETERS ARE VALID IF (IBEG .LT. 1) THEN PRINT 100, PRGMNM, IBEG 100 FORMAT (T2, A6, ': INVALID BEGINNING POSITION OF ', I10) STOP 100 END IF IF (IEND .LT. 1) THEN PRINT 105, PRGMNM, IEND 105 FORMAT (T2, A6, ': INVALID ENDING POSITION OF ', I10) STOP 105 END IF ILEN = (IEND - IBEG) + 1 IF (ILEN .LT. 1) THEN PRINT 110, PRGMNM, IBEG, IEND 110 FORMAT (T2, A6, ': INVALID RANGE OF ', I10, ' TO ', I10) STOP 110 END IF IF ((OPTNS(5:6) .EQ. 'SO') .AND. (ILEN .GT. MAXLEN)) THEN PRINT 115, PRGMNM, ILEN, MAXLEN 115 FORMAT (T2, A6, ': DESIRED LENGTH OF ', I5, ' IS GREATER ', 2 'THAN CURRENT MAXIMUM OF ', I5) STOP 115 ELSE IF (ILEN .GT. MAXLEN + 1) THEN PRINT 115, PRGMNM, ILEN, MAXLEN STOP 120 END IF IF (IEND .GT. LEN(CHARAR)) THEN PRINT 125, PRGMNM, IEND, LEN(CHARAR) 125 FORMAT (T2, A6, ': LAST CHARACTER POSITION (', I10, 2 ') EXCEEDS LENGTH OF ARRAY (', I10,')') STOP 125 END IF IF (LEN(OPTNS) .NE. 6) THEN PRINT 130, PRGMNM, LEN(OPTNS) 130 FORMAT (T2, A6, ': LENGTH OF OPTIONS ARRAY IS NOT 6 BUT ', 2 I10) STOP 130 END IF IF ((IACC .LT. 0) .OR. (IACC .GT. MAXLEN-1)) THEN PRINT 132, PRGMNM, IACC, MAXLEN - 1 132 FORMAT (T2, A6, ': ACCURACY TO RIGHT OF DECIMAL (', I10, 2 ') IS NOT BETWEEN 0 AND ', I10) STOP 132 END IF ** NOW CHECK FOR OVERFLOW IF (REALNO .LT. 0.0) THEN NEG = .TRUE. TEMPNO = -REALNO ELSE NEG = .FALSE. TEMPNO = REALNO END IF ** NOW, ROUND THE NUMBER FTEMP = 0.0 - FLOAT (IACC) TEMPNO = TEMPNO + (0.5 * (10.0 ** FTEMP)) ** GET NUMBER OF DIGITS TO LEFT OF DECIMAL FTEMP = 10.0 DO 140 NLEFT = 1, MAXLEN IF (TEMPNO .LT. FTEMP) GO TO 150 FTEMP = FTEMP * 10.0 140 CONTINUE OVERFLOW CONDITION, SO ASTERISK FILL AND EXIT CHARAR(IBEG:IEND) = OVERFL(1:ILEN) RETURN 150 IF ((NEG .AND. OPTNS(5:6) .EQ. 'SL') .OR. OPTNS(5:6) .EQ. 2 'ST') THEN NDTEMP = NLEFT + IACC + 2 ELSE NDTEMP = NLEFT + IACC + 1 END IF IF (NDTEMP .GT. ILEN) THEN CHARAR(IBEG:IEND) = OVERFL(1:ILEN) RETURN END IF ** LOOKS OK, SO START THE PROCESS 1. SPACE- OR ZERO-FILL THE ARRAY IF (OPTNS(3:4) .EQ. 'ZF') THEN CHARAR(IBEG:IEND) = ZEROES(1:ILEN) ELSE ASSUME SPACE FILLED CHARAR(IBEG:IEND) = SPACES(1:ILEN) END IF ** 2. DETERMINE THE LEFT-MOST POSITION IF (OPTNS(1:2) .EQ. 'RJ') THEN IF (OPTNS(5:6) .EQ. 'ST') THEN IPOS = IEND - NDTEMP + 1 ELSE IF (OPTNS(5:6) .EQ. 'SO') THEN IPOS = IEND - NDTEMP + 1 ELSE IF (NEG) THEN IPOS = IEND - NDTEMP + 2 IMINUS = IPOS - 1 ELSE IPOS = IEND - NDTEMP + 1 END IF ELSE LJ IF (OPTNS(5:6) .EQ. 'SL' .AND. NEG) THEN IPOS = IBEG + 1 IMINUS = IBEG ELSE IPOS = IBEG END IF END IF 3. CONVERT THE NUMBER TO THE LEFT OF THE DECIMAL POINT EXP = FLOAT (NLEFT) DO 160 I = 1, NLEFT EXP = EXP - 1.0 TEMP = TEMPNO / (10.0 ** EXP) IWORK = INT (TEMP) TEMP = FLOAT (IWORK) TEMPNO = TEMPNO - (TEMP * (10.0 ** EXP)) IWORK = IWORK + 48 CHARAR(IPOS:IPOS) = WORK(1:1) ILAST = IPOS IPOS = IPOS + 1 160 CONTINUE 4. INSERT THE DECIMAL POINT CHARAR(IPOS:IPOS) = '.' IPOS = IPOS + 1 5. CONVERT THE NUMBER TO THE RIGHT OF THE DECIMAL POINT (IF NECESSARY) IF (IACC .GT. 0) THEN DO 170 I = 1, IACC EXP = EXP - 1.0 TEMP = TEMPNO / (10.0 ** EXP) IWORK = INT (TEMP) TEMP = FLOAT (IWORK) TEMPNO = TEMPNO - (TEMP* (10.0 ** EXP)) IWORK = IWORK + 48 CHARAR(IPOS:IPOS) = WORK(1:1) ILAST = IPOS IPOS = IPOS + 1 170 CONTINUE END IF 6. FINALLY, INSERT A MINUS SIGN IF NECESSARY IF (OPTNS(5:6) .EQ. 'ST') ILAST = ILAST + 1 IF (NEG) THEN IF (OPTNS(5:6) .EQ. 'SO') THEN CONVERT NUMBER TO '}' FOR ZERO AND 'J-R' FOR 1-9 IWORK = 0 WORK(1:1) = CHARAR(ILAST:ILAST) IF (WORK(1:1) .EQ. '0') THEN WORK (1:1) = '}' ELSE IWORK = IWORK + 25 END IF CHARAR(ILAST:ILAST) = WORK(1:1) ELSE IF (OPTNS(5:6) .EQ. 'ST') THEN CHARAR(ILAST:ILAST) = '-' ELSE CHARAR(IMINUS:IMINUS) = '-' END IF ELSE IF (OPTNS(5:6) .EQ. 'ST') THEN CHARAR(ILAST:ILAST) = ' ' END IF RETURN END SUBROUTINE GETJOBNAME (JOBNAME) *********************************************************************** This subroutine will get the job name of the current batch job. * The job name is passed back as an output parameter, left justified * and space filled. * * This program was written by Roger G. Ruckert on December 11th, 1988.* *********************************************************************** INTEGER*4 STATUS, LIB$SIGNAL, SYS$GETQUIW INTEGER*4 IOSB, ZERO, SEARCH_FLAGS INTEGER*2 GETQUI_LIST (18), JOB_NAME_LEN, NULLI CHARACTER JOBNAME*(*), JOB_NAME*39, NULL*2 INCLUDE '($QUIDEF)' INCLUDE '($JBCMSGDEF)' DATA ZERO /0/, GETQUI_LIST /18*0/, NULLI /0/ EQUIVALENCE (NULLI, NULL) ** USE THE SPECIAL GETQUI CALL FOR THE CURRENT BATCH JOB SEARCH_FLAGS = (ZERO .OR. QUI$M_SEARCH_THIS_JOB) GETQUI_LIST( 1 ) = 39 GETQUI_LIST( 2 ) = QUI$_JOB_NAME GETQUI_LIST( 3 ) = %LOC (JOB_NAME) JOB_NAME_LEN = LEN (JOB_NAME) GETQUI_LIST( 5 ) = %LOC (JOB_NAME_LEN) GETQUI_LIST( 7 ) = 4 GETQUI_LIST( 8 ) = QUI$_SEARCH_FLAGS GETQUI_LIST( 9 ) = %LOC (SEARCH_FLAGS) GETQUI_LIST( 11 ) = 0 STATUS = SYS$GETQUIW (,%VAL(QUI$_DISPLAY_JOB),,GETQUI_LIST, 1 IOSB,,) IF (IOSB .NE. JBC$_NORMAL) THEN PRINT *, 'GETJOBNAME: INVALID STATUS OF ', IOSB STATUS = LIB$SIGNAL (%VAL (IOSB)) CALL EXIT(4) END IF I = LEN(JOBNAME) IF (I .GT. 39) I = 39 JOBNAME = ' ' JOBNAME(1:I) = JOB_NAME(1:I) DO 150 J = 1, I 150 IF (JOBNAME(J:J) .EQ. NULL(1:1)) JOBNAME(J:J) = ' ' RETURN END SUBROUTINE I2DSP (INNUM, CHARAR, IBEG, IEND, OPTNS) *********************************************************************** * THIS SUBROUTINE WILL CONVERT AN INTEGER*2 BINARY NUMBER INTO A DIS- * PLAY NUMBER. THE FIELDS PASSED ARE: (1) INNUM, THE NUMBER TO BE * CONVERTED; (2) CHARAR, THE OUTPUT CHARACTER ARRAY; (3) IBEG AND (4) * IEND, THE BEGINNING AND ENDING POSITIONS OF THE OUTPUT NUMBER WITH- * IN THE ARRAY; AND (5) THE CONVERSION OPTIONS, A 6 CHARACTER ARRAY * WITH THE FOLLOWING FORMAT (DEFAULT IS "LJSFSL"): * * CHARACTERS 1-2: "LJ", LEFT JUSTIFIED; "RJ", RIGHT JUSTIFIED * 3-4: "SF", SPACE FILLED; "ZF", ZERO FILLED * 5-6: "SL", SIGN LEADING; "ST", SIGN TRAILING; "SO", * SIGN OVERPUNCHED (IN THE COBOL TRADITION) * * OUTPUT NUMBERS UP TO 18 CHARACTER POSITIONS (WITH OVERPUNCH) OR 19 * (WITH SIGN LEADING OR TRAILING) WILL BE SUPPORTED. (THIS IS THE * ANSI STANSARD FOR COBOL NUMERIC FIELDS. NOTE, HOWEVER, THAT I*2 * FIELDS ARE ONLY VALID UP TO +/- 32,767.) IF THE SUBROU- * TINE DETECTS THAT THERE WILL BE AN OVERFLOW IN THE OUTPUT FIELD, * THE ENTIRE FIELD WILL BE FILLED WITH ASTERISKS. THIS IS ALSO TRUE * IF INVALID ARGUMENTS ARE PASSED TO THE SUBROUTINE. * * THIS SUBROUTINE WAS WRITTEN ON JULY 15TH, 1987 BY ROGER G. * RUCKERT. * * *********************************************************************** PARAMETER (MAXLEN=18) LOGICAL NEG INTEGER*2 NUMBER, INNUM, IBEG, IEND, IDIV1, IDIV2, IPOS, IWORK CHARACTER SPACES*19, OVERFL*19, ZEROES*19, WORK*4 CHARACTER CHARAR*(*), OPTNS*6, PRGMNM*6 EQUIVALENCE (WORK, IWORK) DATA SPACES/' '/, PRGMNM/' I2DSP'/ DATA OVERFL/'*******************'/ DATA ZEROES/'0000000000000000000'/ ** SEE IF INPUT PARAMETERS ARE VALID IF (IBEG .LT. 1) THEN PRINT 100, PRGMNM, IBEG 100 FORMAT (T2, A6, ': INVALID BEGINNING LENGTH OF ', I10) STOP 100 END IF IF (IEND .LT. 1) THEN PRINT 105, PRGMNM, IEND 105 FORMAT (T2, A6, ': INVALID ENDING LENGTH OF ', I10) STOP 105 END IF ILEN = (IEND - IBEG) + 1 IF (ILEN .LT. 1) THEN PRINT 110, PRGMNM, IBEG, IEND 110 FORMAT (T2, A6, ': INVALID RANGE OF ', I10, ' TO ', I10) STOP 110 END IF IF ((OPTNS(5:6) .EQ. 'SO') .AND. (ILEN .GT. MAXLEN)) THEN PRINT 115, PRGMNM, ILEN, MAXLEN 115 FORMAT (T2, A6, ': DESIRED LENGTH OF ', I5, ' IS GREATER ', 2 'THAN CURRENT MAXIMUM OF ', I5) STOP 115 ELSE IF (ILEN .GT. MAXLEN + 1) THEN PRINT 115, PRGMNM, ILEN, MAXLEN STOP 120 END IF IF (IEND .GT. LEN(CHARAR)) THEN PRINT 125, PRGMNM, IEND, LEN(CHARAR) 125 FORMAT (T2, A6, ': LAST CHARACTER POSITION (', I10, 2 ') EXCEEDS LENGTH OF ARRAY (', I10,')') STOP 125 END IF IF (LEN(OPTNS) .NE. 6) THEN PRINT 130, PRGMNM, LEN(OPTNS) 130 FORMAT (T2, A6, ': LENGTH OF OPTIONS ARRAY IS NOT 6 BUT ', 2 I10) STOP 130 END IF ** NOW CHECK FOR OVERFLOW IF (INNUM .LT. 0) THEN NEG = .TRUE. NUMBER = -INNUM ELSE NEG = .FALSE. NUMBER = INNUM END IF I = 10 DO 140 NDGTS = 1, 4 IF (NUMBER .LT. I) GO TO 145 I = I * 10 140 CONTINUE NDGTS = 5 145 IF ((NEG .AND. OPTNS(5:6) .EQ. 'SL') .OR. OPTNS(5:6) .EQ. 2 'ST') THEN NDTEMP = NDGTS + 1 ELSE NDTEMP = NDGTS END IF IF (NDTEMP .GT. ILEN) THEN CHARAR(IBEG:IEND) = OVERFL(1:ILEN) RETURN END IF ** LOOKS OK, SO START THE PROCESS IF (OPTNS(3:4) .EQ. 'ZF') THEN CHARAR(IBEG:IEND) = ZEROES(1:ILEN) ELSE ASSUME SPACE FILLED CHARAR(IBEG:IEND) = SPACES(1:ILEN) END IF IF (OPTNS(1:2) .EQ. 'RJ') THEN IF (OPTNS(5:6) .EQ. 'ST') THEN IPOS = IEND - 1 ELSE IPOS = IEND END IF ELSE LJ IF (NEG .AND. OPTNS(5:6) .EQ. 'SL') THEN IPOS = IBEG + NDGTS ELSE IPOS = IBEG + NDGTS - 1 END IF END IF IDIV1 = 1 ILAST = IPOS ** MAIN LOOP: CONVERT 1 INTEGER AT A TIME, RIGHT TO LEFT DO 150 I = 1, NDGTS IDIV2 = IDIV1 IDIV1 = IDIV1 * 10 IWORK = IMOD (NUMBER, IDIV1) IWORK = IWORK / IDIV2 IWORK = IWORK + 48 CHARAR(IPOS:IPOS) = WORK(1:1) IPOS = IPOS - 1 150 CONTINUE ** NOW, INSERT MINUS SIGN IF NECESSARY IF (OPTNS(5:6) .EQ. 'ST') ILAST = ILAST + 1 IF (NEG) THEN IF (OPTNS(5:6) .EQ. 'SO') THEN CONVERT NUMBER TO '}' FOR ZERO AND 'J-R' FOR 1-9 IWORK = 0 WORK(1:1) = CHARAR(ILAST:ILAST) IF (WORK(1:1) .EQ. '0') THEN WORK(1:1) = '}' ELSE IWORK = IWORK + 25 END IF CHARAR(ILAST:ILAST) = WORK(1:1) ELSE IF (OPTNS(5:6) .EQ. 'ST') THEN CHARAR(ILAST:ILAST) = '-' ELSE CHARAR(IPOS:IPOS) = '-' END IF ELSE IF (OPTNS(5:6) .EQ. 'ST') THEN CHARAR(ILAST:ILAST) = ' ' END IF RETURN END SUBROUTINE I4BIN (I4, CHARAR, IBEG, IEND, OPTNS, ERROR) *********************************************************************** * THIS SUBROUTINE WILL CHANGE A DISPLAY NUMBER INTO A INTEGER*4 NUM- * BER. THE PARAMETERS ARE AS FOLLOWS: * * I4 THE INTEGER PASSED BACK TO THE CALLING PROGRAM * CHARAR THE INPUT CHARACTER ARRAY (THE NUMBER MAY INCLUDE PLUS * AND MINUS SIGNS, SPACES, AND COMMAS IN ADDITION TO THE * INTEGERS; OTHER CHARACTERS ARE CONSIDERED AN ERROR CON- * DITION) * IBEG THE BEGINNING POSITION IN CHARAR THAT THE CONVERSION IS * TO TAKE PLACE * IEND THE ENDING POSITION IN CHARAR THAT THE CONVERSION IS TO * TAKE PLACE * OPTNS A 2 CHARACTER ARRAY WITH VALID OPTIONS OF "SL" (SIGN * LEADING), "ST" (SIGN TRAILING), OR "SO" (SIGN OVER- * PUNCHED IN THE COBOL TRADITION) * ERROR IF ERRORS ARE DETECTED IN CHARAR, 'ERROR' IS SET TO TRUE. * * THIS SUBROUTINE WAS WRITTEN ON SEPTEMBER 29TH, 1987 BY ROGER G. * RUCKERT. * * *********************************************************************** INTEGER*4 I4, ITEMP LOGICAL ERROR, NEG CHARACTER CHARAR*(*), WORK*4, OPTNS*2, PRGMNM*6 INTEGER*2 IWORK EQUIVALENCE (WORK, IWORK) DATA PRGMNM/' I4BIN'/ ERROR = .FALSE. NEG = .FALSE. I4 = 0 ** NOW CONVERT THE NUMBERS TO THE LEFT OF THE DECIMAL IEXP = 0 I = IEND 120 IF (I .LT. IBEG) GO TO 190 WORK(1:1) = CHARAR(I:I) IGNORE BLANKS, PLUS SIGNS, AND COMMAS IF (WORK(1:1) .EQ. ' ' .OR. WORK(1:1) .EQ. '+' .OR. WORK(1:1) .EQ. 2 ',') GO TO 145 CHECK FOR RIGHTMOST POSITION AND ITS SPECIAL CASES IF (I .EQ. IEND) THEN IF (OPTNS(1:2) .EQ. 'ST') THEN IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 145 ELSE IF (WORK(1:1) .EQ. ' ') THEN GO TO 145 ELSE GO TO 200 END IF ELSE IF (OPTNS(1:2) .EQ. 'SO') THEN IF (WORK(1:1) .EQ . '}') THEN NEG = .TRUE. GO TO 140 ELSE IF (WORK(1:1) .GE. 'J' .AND. WORK(1:1) .LE. 'R') 2 THEN NEG = .TRUE. IWORK = IWORK - 73 GO TO 135 ELSE IF (WORK(1:1) .GE. '0' .AND. WORK(1:1) .LE. '9') 2 THEN GO TO 130 ELSE GO TO 200 END IF END IF END IF IF (WORK(1:1) .EQ. '-') THEN NEG = .TRUE. GO TO 145 ELSE IF (WORK(1:1) .LT. '0' .OR. WORK(1:1) .GT. '9') THEN INVALID CHARACTER GO TO 200 END IF ALL TESTS HAVE BEEN PERFORMED, SO CONVERT THE NUMBER 130 IWORK = IWORK - 48 135 I4 = I4 + (IWORK * (10.0 ** IEXP)) 140 IEXP = IEXP + 1 145 I = I - 1 GO TO 120 ** ALL DONE, SO CHECK FOR NEGATIVE AND EXIT 190 IF (NEG) I4 = I4 * -1 RETURN ** ERROR EXIT 200 ERROR = .TRUE. RETURN END SUBROUTINE I4DSP (INNUM, CHARAR, IBEG, IEND, OPTNS) *********************************************************************** * THIS SUBROUTINE WILL CONVERT AN INTEGER*4 BINARY NUMBER INTO A DIS- * PLAY NUMBER. THE FIELDS PASSED ARE: (1) INNUM, THE NUMBER TO BE * CONVERTED; (2) CHARAR, THE OUTPUT CHARACTER ARRAY; (3) IBEG AND (4) * IEND, THE BEGINNING AND ENDING POSITIONS OF THE OUTPUT NUMBER WITH- * IN THE ARRAY; AND (5) THE CONVERSION OPTIONS, A 6 CHARACTER ARRAY * WITH THE FOLLOWING FORMAT (DEFAULT IS "LJSFSL"): * * CHARACTERS 1-2: "LJ", LEFT JUSTIFIED; "RJ", RIGHT JUSTIFIED * 3-4: "SF", SPACE FILLED; "ZF", ZERO FILLED * 5-6: "SL", SIGN LEADING; "ST", SIGN TRAILING; "SO", * SIGN OVERPUNCHED (IN THE COBOL TRADITION) * * OUTPUT NUMBERS UP TO 18 CHARACTER POSITIONS (WITH OVERPUNCH) OR 19 * (WITH SIGN LEADING OR TRAILING) WILL BE SUPPORTED. (THIS IS THE * ANSI STANSARD FOR COBOL NUMERIC FIELDS. NOTE, HOWEVER, THAT I*4 * FIELDS ARE ONLY VALID UP TO +/- 2.15 BILLION.) IF THE SUBROU- * TINE DETECTS THAT THERE WILL BE AN OVERFLOW IN THE OUTPUT FIELD, * THE ENTIRE FIELD WILL BE FILLED WITH ASTERISKS. THIS IS ALSO TRUE * IF INVALID ARGUMENTS ARE PASSED TO THE SUBROUTINE. * * THIS SUBROUTINE WAS WRITTEN ON JULY 15TH, 1987 BY ROGER G. RUCKERT. * * *********************************************************************** PARAMETER (MAXLEN=18) LOGICAL NEG INTEGER*4 NUMBER, INNUM, IBEG, IEND, IDIV1, IDIV2, IPOS, IWORK, I CHARACTER SPACES*19, OVERFL*19, ZEROES*19, WORK*4 CHARACTER CHARAR*(*), OPTNS*6, PRGMNM*6 EQUIVALENCE (WORK, IWORK) DATA SPACES/' '/, PRGMNM/' I4DSP'/ DATA OVERFL/'*******************'/ DATA ZEROES/'0000000000000000000'/ ** SEE IF INPUT PARAMETERS ARE VALID IF (IBEG .LT. 1) THEN PRINT 100, PRGMNM, IBEG 100 FORMAT (T2, A6, ': INVALID BEGINNING LENGTH OF ', I10) STOP 100 END IF IF (IEND .LT. 1) THEN PRINT 105, PRGMNM, IEND 105 FORMAT (T2, A6, ': INVALID ENDING LENGTH OF ', I10) STOP 105 END IF ILEN = (IEND - IBEG) + 1 IF (ILEN .LT. 1) THEN PRINT 110, PRGMNM, IBEG, IEND 110 FORMAT (T2, A6, ': INVALID RANGE OF ', I10, ' TO ', I10) STOP 110 END IF IF ((OPTNS(5:6) .EQ. 'SO') .AND. (ILEN .GT. MAXLEN)) THEN PRINT 115, PRGMNM, ILEN, MAXLEN 115 FORMAT (T2, A6, ': DESIRED LENGTH OF ', I5, ' IS GREATER ', 2 'THAN CURRENT MAXIMUM OF ', I5) STOP 115 ELSE IF (ILEN .GT. MAXLEN + 1) THEN PRINT 115, PRGMNM, ILEN, MAXLEN STOP 120 END IF IF (IEND .GT. LEN(CHARAR)) THEN PRINT 125, PRGMNM, IEND, LEN(CHARAR) 125 FORMAT (T2, A6, ': LAST CHARACTER POSITION (', I10, 2 ') EXCEEDS LENGTH OF ARRAY (', I10,')') STOP 125 END IF IF (LEN(OPTNS) .NE. 6) THEN PRINT 130, PRGMNM, LEN(OPTNS) 130 FORMAT (T2, A6, ': LENGTH OF OPTIONS ARRAY IS NOT 6 BUT ', 2 I10) STOP 130 END IF ** NOW CHECK FOR OVERFLOW IF (INNUM .LT. 0) THEN NEG = .TRUE. NUMBER = -INNUM ELSE NEG = .FALSE. NUMBER = INNUM END IF I = 10 DO 140 NDGTS = 1, 9 IF (NUMBER .LT. I) GO TO 145 I = I *10 140 CONTINUE NDGTS = 10 145 IF ((NEG .AND. OPTNS(5:6) .EQ. 'SL') .OR. OPTNS(5:6) .EQ. 2 'ST') THEN NDTEMP = NDGTS + 1 ELSE NDTEMP = NDGTS END IF IF (NDTEMP .GT. ILEN) THEN CHARAR(IBEG:IEND) = OVERFL(1:ILEN) RETURN END IF ** LOOKS OK, SO START THE PROCESS IF (OPTNS(3:4) .EQ. 'ZF') THEN CHARAR(IBEG:IEND) = ZEROES(1:ILEN) ELSE ASSUME SPACE FILLED CHARAR(IBEG:IEND) = SPACES(1:ILEN) END IF IF (OPTNS (1:2) .EQ. 'RJ') THEN IF (OPTNS(5:6) .EQ. 'ST') THEN IPOS = IEND - 1 ELSE IPOS = IEND END IF ELSE LJ IF (NEG .AND. OPTNS(5:6) .EQ. 'SL') THEN IPOS = IBEG + NDGTS ELSE IPOS = IBEG + NDGTS -1 END IF END IF IDIV1 = 1 ILAST = IPOS ** MAIN LOOP: CONVERT 1 INTEGER AT A TIME, RIGHT TO LEFT DO 150 I = 1, NDGTS IDIV2 = IDIV1 IDIV1 = IDIV1 * 10 IWORK = JMOD (NUMBER, IDIV1) IWORK = IWORK / IDIV2 IWORK = IWORK + 48 CHARAR(IPOS:IPOS) = WORK(1:1) IPOS = IPOS - 1 150 CONTINUE ** NOW, INSERT MINUS SIGN IF NECESSARY IF (OPTNS(5:6) .EQ. 'ST') ILAST = ILAST + 1 IF (NEG) THEN IF (OPTNS(5:6) .EQ. 'SO') THEN CONVERT NUMBER TO '}' FOR ZERO AND 'J-R' FOR 1-9 IWORK = 0 WORK(1:1) = CHARAR(ILAST:ILAST) IF (WORK(1:1) .EQ. '0') THEN WORK(1:1) = '}' ELSE IWORK = IWORK + 25 END IF CHARAR(ILAST:ILAST) = WORK(1:1) ELSE IF (OPTNS(5:6) .EQ. 'ST') THEN CHARAR(ILAST:ILAST) = '-' ELSE CHARAR(IPOS:IPOS) = '-' END IF ELSE IF (OPTNS(5:6) .EQ. 'ST') THEN CHARAR(ILAST:ILAST) = ' ' END IF RETURN END SUBROUTINE LCHARS (INARR, INBEG, INEND, OUTARR, OUTRL, OUTWID, 2 OUTBEG, OUTEND, MAGNIF, LOCATION) *********************************************************************** * THIS SUBROUTINE WILL CONVERT AN INPUT STRING INTO LARGE CHARACTERS. * POSSIBLE APPLICATIONS OF THIS INCLUDE 'SYNTHETIC' BANNER PAGES AND * OTHER OCCASIONS WHEN LARGE CHARACTERS ARE DESIRED. THE BASIC CHAR- * ACTERS ARE 5 WIDE BY 7 HIGH. A MAGNIFICATION FACTOR CAN BE USED TO * INCREASE THESE CHARACTERS IN THE SAME PROPORTION (E.G., A FACTOR OF * 2 WILL PRODUCE CHARACTERS THAT ARE 10*14). THE PROGRAM WILL SET UP * THE OUTPUT CHARACTERS INTO AN ARRAY. IT CHECKS FOR SEVERAL THINGS, * INCLUDING BEING SURE THE OUTPUT CAN FIT INTO THE ARRAY, VALID PLACE-* MENT OPTIONS (LEFT/RIGHT JUSTIFY OR CENTER, DENOTED "LJ", "RJ", AND * "CE", RESPECTIVELY), AND VALID BEGINNING AND ENDING LOCATIONS. * VALID CHARACTERS ARE UPPERCASE A-Z, LOWERCASE A-Z (WHICH WILL BE * TRANSLATED TO UPPERCASE), NUMBERS 0-9, AND THE SPECIAL CHARACTERS * "_#$-.*&;:". ANY OTHER INPUT CHARACTERS ARE CONVERTED TO SPACES. * * ALL OF THE PARAMETERS ARE EXPLAINED BELOW. THE RELATIONSHIP BETWEEN * OUTRL (OUTPUT RECORD LENGTH) AND OUTWID (OUTPUT WIDTH) IS DEFINED * BY THE PARTICULAR APPLICATION. I HAD A CASE WHERE THE ARRAY RECORD * LENGTH NEEDED TO BE 133 BUT I ONLY WANTED TO PRINT ON THE FIRST 80 * CHARACTERS (THE FICHE TAPE NEEDED TO BE A CONSTANT 133 CHARACTERS) * IN THIS CASE, OUTRL WAS 133 AND OUTWID WAS 80. TYPICALLY, HOWEVER, * THEY ARE EQUAL. * * THIS PROGRAM WAS WRITTEN ON FEBRUARY 3RD, 1988 BY ROGER G. RUCKERT. * *********************************************************************** PARAMETER (MAXSPC = 9, ! MAXIMUM SPECIAL CHARACTERS 2 MAXCHR = 46) ! MAXIMUM DIFFERENT CHARACTERS CHARACTER INARR*(*), ! INPUT ARRAY 2 OUTARR*(*), ! OUTPUT ARRAY 3 CHAR*2, ! TEMP WORK CHARACTER 4 SAVCHR*25, ! CHAR STORAGE 5 LOCATION*2 ! CHARACTER LOCATION (CENTER, ! LEFT JUSTIFY, OR RIGHT JUSTIFY) INTEGER*2 INBEG, ! INPUT BEGINNING CHARACTER 2 INEND, ! INPUT ENDING CHARACTER 3 OUTRL, ! OUTPUT RECORD LENGTH 4 OUTWID, ! OUTPUT WIDTH (MAY = OUTRL) 5 CHARAC(138), ! CHARACTER PATTERNS - 3 WD/CHAR 6 BITSEL(15), ! BIT SELECT ARRAY 7 ICHAR, ! TEMPORARY (REDEFINES CHAR) 8 INDEX1,INDEX2,INDEX3,INDEX4,INDEX5, ! WORK INDICES 9 BITPTR, ! BIT POSITION IN CHAR PATTERN + BUFPOS, ! POSITION IN OUTPUT ARRAY 1 MAXSTR, ! MAXIMUM # OF CAHARCTERS 2 STRBUF(25), ! PATTERN POINTER, PROPER CHAR 3 SPCHAR(MAXSPC), ! SPECIAL CHARACTERS 4 PATPTR, ! PATTERN WORD POINTER 5 WORDNM, ! WORD NUMBER IN CHARACTER PATTERN 6 BITSAV, ! BIT POINTER IN PATTERN 7 INENDT, ! TEMPORARY END POINTER 8 MAGNIF, ! SIZE OF OUTPUT CHARACTERS 9 OUTSTART, ! OUTPUT STARTING WORK POSITION + MINCHAR, ! MINIMUM SIZE FOR OUTPUT CHARS. 1 OUTBEG, ! OUTPUT BEGINNING POSITION 2 OUTEND, ! OUTPUT ENDING POSITION 3 OUTENDT ! OUTPUT ENDING WORK VARIABLE DATA BITSEL/-32768, 16384, 8192, 4096, + 2048, 1024, 512, 256, + 128, 64, 32, 16, + 8, 4, 2/ DATA SPCHAR/ 95, 35, 36, 45, 46, 42, 38, 59, 58/ DATA CHARAC/ + 29794, -926, -30720, -2974, -2974, -4096, ! A,B + 29792, -31710, 28672, -2974, -29598, -4096, ! C,D + -992, -3040, -2048, -992, -3040, -32768, ! E,F + 29792, -31518, 30720, -29598, -926, -30720, ! G,H + 28936, 8456, 28672, 14468, 5284, 24576, ! I,J + -29528, -14556, -30720, -31712, -31712, -2048,! K,L + -28950,-21406, -30720, -29078, -21146, -30720,! M,N + 29794, -29598, 28672, -2974, -3040, -32768, ! O,P + 29794, -29338, 28672, -2974, -2780, -30720, ! Q,R + 29792, 28770, 28672, -1784, 8456, 8192, ! S,T + -29598, -29598, 28672, -29598, -29612, 8192, ! U,V + -29590, -21130, -30720, -29612, 8866,-30720, ! W,X + -29612, 8456, 8192, -1980, 8736, -2048, ! Y,Z + 29794, -21406, 28672, 8968, 8456, 28672, ! 0,1 + 29762, 4368, -2048, 29762, 12386, 28672, ! 2,3 + -31580, -1916, 4096, -964, 2146, 28672, ! 4,5 + 14880, -2974, 28672, -1980, 8736, -32768, ! 6,7 + 29794, 29794, 28672, 29794, 30788, -8192, ! 8,9 + 0, 0, -2048, 702, 22484, 0, ! _# + 9192, 29052, 8192, 0, -2048, 0, ! $- + 0, 12, 12288, 1372, -1110, 0, ! .* + 25768, 17252, -6144, 12672, 12676, 8192, ! &; + 12672, 12, 12288, 0, 0, 0/ ! : SPACE EQUIVALENCE (CHAR, ICHAR) *********************************************************************** * ** V A L I D A T E I N P U T *** * *********************************************************************** ** CHECK INPUT ARRAY IF (INBEG .LT. 1) THEN PRINT *, 'INPUT CHARACTER BEGINNING POSITION OF ', INBEG, 2 ' IS NOT GREATER THAN ZERO' RETURN END IF INENDT = INEND - INBEG + 1 IF (INENDT .LE. 0) THEN PRINT *, 'INPUT CHARACTER STRING LENGTH OF ', INENDT, 2 ' IS NOT GREATER THAN ZERO' RETURN END IF IEND = LEN (INARR) IF (INEND .GT. IEND) THEN PRINT *, 'INPUT CHARACTER ENDING POSITION OF ', INEND, 2 ' IS GREATER THAN THE STRING LENGTH OF ', IEND RETURN END IF ** CHECK OUTPUT ARRAY IF (OUTWID .GT. OUTRL) THEN PRINT *, 'OUTPUT PRINTING WIDTH OF ', OUTWID, 2 ' IS GREATER THAN THE RECORD LENGTH OF ', OUTRL RETURN END IF IF (INBEG .LT. 1) THEN PRINT *, 'OUTPUT CHARACTER BEGINNING POSITION OF ', OUTBEG, 2 ' IS NOT GREATER THAN ZERO' RETURN END IF OUTENDT = OUTEND - OUTBEG + 1 IF (OUTENDT .LE. 0) THEN PRINT *, 'OUTPUT CHARACTER STRING LENGTH OF ', OUTENDT, 2 ' IS NOT GREATER THAN ZERO' RETURN END IF IEND = LEN (OUTARR) IF (OUTEND .GT. IEND) THEN PRINT *, 'OUTPUT CHARACTER ENDING POSITION OF ', OUTEND, 2 ' IS GREATER THAN THE STRING LENGTH OF ', IEND RETURN END IF ** VERIFY MAGNIFICATION IF (MAGNIF .LE. 0) THEN PRINT *, 'MAGNIFICATION OF ', MAGNIF, ' IS NOT GREATER THAN ', 2 'ZERO' RETURN END IF MINCHAR = (((MAGNIF * 7) - 1) * OUTRL) + OUTWID IF (MINCHAR .GT. OUTENDT) THEN PRINT *, 'REQUESTED MAGNIFICATION OF ', MAGNIF, ' REQUIRES ', 2 'AT LEAST ', MINCHAR, ' CHARACTERS' RETURN END IF ** VERIFY LOCATION IF (LOCATION .NE. 'CE' .AND. LOCATION .NE. 'LJ' .AND. LOCATION 2 .NE. 'RJ') THEN PRINT *, 'INVALID LOCATION OPTION OF ', LOCATION, 2 ' SUBMITTED; ONLY CE, LJ, AND RJ ARE VALID' RETURN END IF *********************************************************************** * ** S E T U P I N P U T S T R I N G BLOCK 100 *** * *********************************************************************** ** TRUNCATE INPUT CHARACTERS TO BE DISPLAYED, IF NECESSARY MAXSTR = IMIN0 ((OUTWID/(6 * MAGNIF)), INENDT) IPTR = INBEG ** SET UP ONE CHARACTER AT A TIME DO 195 INDEX1 = 1, MAXSTR ICHAR = 0 CHAR (1:1) = INARR (IPTR:IPTR) IF (ICHAR .GE. 65 .AND. ICHAR .LE. 90) THEN CHARACTER IS A-Z STRBUF (INDEX1) = ICHAR - 64 SAVCHR (INDEX1:INDEX1) = CHAR (1:1) GO TO 190 ELSE IF (ICHAR .GE. 97 .AND. ICHAR .LE. 122) THEN CHARACTER IS a-z: CONVERT IT TO UPPERCASE STRBUF (INDEX1) = ICHAR - 96 ICHAR = ICHAR - 32 SAVCHR (INDEX1:INDEX1) = CHAR (1:1) GO TO 190 ELSE IF (ICHAR .GE. 48 .AND. ICHAR .LE. 57) THEN CHARACTER IS 0-9 STRBUF (INDEX1) = ICHAR - 21 SAVCHR (INDEX1:INDEX1) = CHAR (1:1) GO TO 190 END IF TEST FOR SPECIAL CHARACTER DO 150 INDEX2 = 1, MAXSPC IF (ICHAR .EQ. SPCHAR (INDEX2)) THEN STRBUF (INDEX1) = INDEX2 + 36 SAVCHR (INDEX1:INDEX1) = CHAR (1:1) GO TO 190 END IF 150 CONTINUE SPACE FILL THIS CHARACTER STRBUF (INDEX1) = MAXCHR SAVCHR (INDEX1:INDEX1) = ' ' 190 IPTR = IPTR + 1 195 CONTINUE *********************************************************************** * ** S E T U P L A R G E C H A R S . BLOCK 200 *** * *********************************************************************** GET OUTPUT STARTING LOCATION MINUS OUTRL IF (LOCATION .EQ. 'LJ') THEN OUTSTART = OUTBEG - OUTRL ELSE IF (LOCATION .EQ. 'CE') THEN OUTSTART = OUTBEG + (OUTWID / 2) - (3 * MAGNIF * MAXSTR) - 2 OUTRL ELSE LOCATION = RJ OUTSTART = OUTBEG + OUTWID - (6 * MAGNIF * MAXSTR) - 2 OUTRL END IF WORDNM = 1 BITSAV = 1 OUTARR (OUTBEG:OUTEND) = ' ' DO 290 INDEX1 = 1, 7 ! LOOP FOR STANDARD CHARACTER HEIGHT DO 285 INDEX2 = 1, MAGNIF ! LOOP FOR HEIGHT MAGNIFICATION OUTSTART = OUTSTART + OUTRL BUFPOS = OUTSTART DO 280 INDEX3 = 1,MAXSTR ! LOOP FOR EACH INPUT CHARACTER BITPTR = BITSAV ! START AT SAME RELATIVE POSITION IN EACH ! CHARACTER PATTERN ON THIS LINE PATPTR = STRBUF(INDEX3)*3 - 3 + WORDNM ! INDEX INTO CHAR PATT DO 270 INDEX4 = 1, 5 ! LOOP FOR STANDARD CHAR. WIDTH DO 265 INDEX5 = 1, MAGNIF ! LOOP FOR WIDTH MAGNIFICATION IF (IAND (CHARAC(PATPTR),BITSEL(BITPTR)) .NE. 0) THEN BIT SET, SO MOVE IN THE SAVED CHARACTER OUTARR (BUFPOS:BUFPOS) = SAVCHR(INDEX3:INDEX3) END IF BUFPOS = BUFPOS + 1 265 CONTINUE BITPTR = BITPTR + 1 270 CONTINUE DO 275 INDEX4 = 1, MAGNIF ! MOVE IN SPACES BETWEEN CHARS. 275 BUFPOS = BUFPOS + 1 280 CONTINUE 285 CONTINUE WORDNM = WORDNM + BITSAV/10 ! INCREMENT WORD POINTER BITSAV = MOD(BITSAV + 5, 15) ! INCREMENT BIT POINTER IN PATTERN 290 CONTINUE RETURN ! THAT'S ALL, FOLKS END SUBROUTINE SNDOPR (MESSAGE, REPLY, REPLYTXT) *********************************************************************** This subroutine will send a message to the operator's console. The * message can be up to 80 characters in length. In addition, the * calling process can request that a reply be necessary from the * operator. * * SNDOPR (SeND to the OPeRator) was written on November 27th, 1988 by * Roger G. Ruckert. * *********************************************************************** STRUCTURE /OPLOG_MESSAGE_STRUCTURE/ UNION MAP BYTE TYPE, ENABLE(3) INTEGER*4 REQUEST_ID CHARACTER*80 MESSAGE_TEXT END MAP MAP CHARACTER*88 SEND_ITEMS END MAP END UNION END STRUCTURE RECORD /OPLOG_MESSAGE_STRUCTURE/ OPLOG_RECORD LOGICAL REPLY INTEGER*4 SYS$CREMBX, SYS$SNDOPR, STATUS, LEN, LENGTH INTEGER*4 REPLYLEN, SYS$QIOW, FOURNULLS, SYS$DASSGN INTEGER*2 CHANNEL, IOSTAT, READ_CODE, ZERO CHARACTER MESSAGE*(*), REPLYTXT*(*), FOURNULLA*4, LF*2, CR*2 INCLUDE '($IODEF)' INCLUDE '($OPCDEF)' DATA REPLYLEN /88/, ZERO /0/, FOURNULLS /0/, ILF /10/, ICR /13/ EQUIVALENCE (FOURNULLS, FOURNULLA) EQUIVALENCE (CR, ICR) EQUIVALENCE (LF, ILF) ** FIRST SET UP THE MESSAGE REPLYTXT = ' ' OPLOG_RECORD.TYPE = OPC$_RQ_RQST OPLOG_RECORD.ENABLE(1) = OPC$M_NM_CENTRL OPLOG_RECORD.ENABLE(2) = 0 OPLOG_RECORD.ENABLE(3) = 0 OPLOG_RECORD.REQUEST_ID = 0 OPLOG_RECORD.MESSAGE_TEXT = ' ' LENGTH = LEN (MESSAGE) IF (LENGTH .LE. 80) THEN OPLOG_RECORD.MESSAGE_TEXT(1:LENGTH) = MESSAGE(1:LENGTH) ELSE OPLOG_RECORD.MESSAGE_TEXT(1:80) = MESSAGE(1:80) END IF ** NOW SEND THE MESSAGE (SEE IF A REPLY IS NEEDED OR NOT) IF (REPLY) THEN ** REPLY IS NEEDED; FIRST, CREATE A MAILBOX STATUS = SYS$CREMBX (,CHANNEL,,,,,) IF (.NOT. STATUS) THEN PRINT *, 'SNDOPR: Cannot create mailbox; status = ', 2 STATUS CALL EXIT (4) END IF ** NEXT, SEND THE MESSAGE STATUS = SYS$SNDOPR (OPLOG_RECORD.SEND_ITEMS, %VAL(CHANNEL)) IF (.NOT. STATUS) THEN PRINT *, 'SNDOPR: Cannot send message; status = ', STATUS CALL EXIT (4) END IF OPLOG_RECORD.SEND_ITEMS = ' ' ** NOW READ THE OPERATOR'S REPLY READ_CODE = IO$_READVBLK .OR. ZERO STATUS = SYS$QIOW ( ,%VAL(CHANNEL), %VAL(READ_CODE), IOSTAT,,, 2 %REF(OPLOG_RECORD.SEND_ITEMS), %VAL(REPLYLEN),,,, ) IF (.NOT. STATUS) THEN PRINT *, 'SNDOPR: Cannot perform QIO - STATUS error' CALL LIB$SIGNAL(%VAL(STATUS)) CALL EXIT(4) ELSE IF (.NOT. IOSTAT) THEN PRINT *, 'SNDOPR: Cannot perform QIO - IOSTAT error' CALL LIB$SIGNAL(%VAL(IOSTAT)) CALL EXIT(4) END IF ** EXTRACT OUT THE RETURNED MESSAGE IBEG = INDEX(OPLOG_RECORD.SEND_ITEMS, FOURNULLA) IF (IBEG .EQ. 0) THEN PRINT *, 'SNDOPR: Cannot locate 4 nulls in returned ', 2 'string of ', OPLOG_RECORD.SEND_ITEMS CALL EXIT(4) END IF IBEG = IBEG + 4 IEND = INDEX(OPLOG_RECORD.SEND_ITEMS, CR(1:1)) IF (IEND .EQ. 0) THEN PRINT *, 'SNDOPR: Cannot locate CR in returned ', 2 'string of ', OPLOG_RECORD.SEND_ITEMS CALL EXIT(4) END IF I = IEND - 1 IF (OPLOG_RECORD.SEND_ITEMS(I:I) .EQ. LF(1:1)) THEN IEND = IEND - 2 ELSE IEND = IEND - 1 END IF IF (IEND .GE. IBEG) THEN SEE IF MESSAGE NEEDS TO BE TRUNCATED ILEN = LEN(REPLYTXT) JLEN = IEND - IBEG + 1 IF (JLEN .GT. ILEN) IEND = ILEN + IBEG - 1 REPLYTXT(1:JLEN) = OPLOG_RECORD.SEND_ITEMS(IBEG:IEND) END IF ** FINALLY, DEASSIGN THE CHANNEL STATUS = SYS$DASSGN(%VAL(CHANNEL)) IF (.NOT. STATUS) THEN PRINT *, 'SNDOPR: Cannot deassign channel; status = ', 2 STATUS CALL EXIT (4) END IF ELSE ** NO REPLY NEEDED, JUST SEND THE MESSAGE STATUS = SYS$SNDOPR (OPLOG_RECORD.SEND_ITEMS,) IF (.NOT. STATUS) THEN PRINT *, 'SNDOPR: Cannot send message; status = ', STATUS CALL EXIT (4) END IF END IF RETURN END