PROGRAM NUMGEN IMPLICIT NONE C****************************************************************************** C*** C*** This program generates integer numbers and imbeds them in a string then C*** outputs the string to the terminal, a file, or to DCL for processing. C*** C*** This program uses the following routines : C*** C*** RT_ERROR.FOR C*** GET_PID.FOR C*** LENGTH.FOR C*** UPCASE.FOR C*** C*** Author : Jeff Cameron C*** C*** Modification history : C*** C*** Programmer Date Description C*** ---------------------------------------------------------------------- C*** Jeff Cameron 08-AUG-1994 Initially written C*** Jeff Cameron 30-SEP-1998 Added optional output file with C*** DCL execution option. C*** ---------------------------------------------------------------------- C*** C****************************************************************************** C C*** Constants INCLUDE '($SSDEF)' INCLUDE '($STRDEF)' INCLUDE '($SYSSRVNAM)' C INTEGER*1 TEMPORARY PARAMETER (TEMPORARY = 0) INTEGER*4 NOWAIT PARAMETER (NOWAIT = 1) C C*** Common blocks C C*** Local declarations C INTEGER*1 COMPLETION_EVENT_FLAG INTEGER*4 RESERVED_EVENT_FLAG C INTEGER*4 TYO /6/, OUT /9/ CHARACTER*255 COMMANDLINE CHARACTER*255 OUTFILE CHARACTER*132 OUTSTRING CHARACTER*80 FMTSTR CHARACTER*15 PARAM (0:3) CHARACTER*20 MBX_NAME CHARACTER*4 BOLD_ON /'E[1m'/ CHARACTER*3 BOLD_OFF /'E[m'/ INTEGER*4 LCL, LFS, LOS, LOF, LP (0:3) INTEGER*4 I,J,K INTEGER*4 JSIZ INTEGER*4 MY_PID, HIS_PID INTEGER*4 MBX_CHAN INTEGER*4 ISTAT INTEGER*4 IQSTART, IQEND INTEGER*4 ISTART,IEND,INC,IZPAD INTEGER*4 IVALUE C CHARACTER*10 SVALUE INTEGER*4 LSV C LOGICAL*4 DCL LOGICAL*4 COMERROR C C*** Externals INTEGER*4 LENGTH,STR$ELEMENT,ISIZ INTEGER*4 LIB$SPAWN,LIB$GET_EF,LIB$FREE_EF EXTERNAL LENGTH,STR$ELEMENT,ISIZ EXTERNAL LIB$SPAWN,LIB$GET_EF,LIB$FREE_EF C C*** Formats 1 FORMAT (A) 2 FORMAT (I.) 3 FORMAT (A7,Z8.8,A5) 5 FORMAT ('WRITE SYS$OUTPUT "',A4,A,A3,'"') C------------------------------------------------------------------------------ BOLD_ON (1:1) = CHAR (27) BOLD_OFF (1:1) = CHAR (27) C C*** OPEN SYS$OUTPUT OPEN ( UNIT=TYO, 1 FILE='SYS$OUTPUT', 2 CARRIAGECONTROL='LIST', 3 TYPE='NEW', 4 IOSTAT=ISTAT) C IF (ISTAT .NE. 0) THEN TYPE *,'%NUMGEN-F-OUTOPENFAIL, failed to open SYS$OUTPUT.' CALL RT_ERROR (0,ISTAT) CALL EXIT (1) ELSE ENDIF C C*** GET THE COMMAND LINE CALL LIB$GET_FOREIGN (COMMANDLINE,,LCL,) IF (LCL .LE. 0) THEN CALL DOC_NUMGEN CALL EXIT ELSE ENDIF C C*** Load the parameters DO I = 0,3 ISTAT = STR$ELEMENT (PARAM(I),I,' ',COMMANDLINE(1:LCL)) IF (ISTAT .EQ. SS$_NORMAL) THEN LP (I) = LENGTH (PARAM(I)) ELSE IF (ISTAT .EQ. STR$_NOELEM) THEN WRITE (TYO,1) '%NUMGEN-E-INSUFPAR, insufficient parameters.' CALL DOC_NUMGEN CALL EXIT ELSE WRITE (TYO,1) '%NUMGEN-E-PARSERR, parsing error.' CALL SYS_SIGNAL (ISTAT) CALL DOC_NUMGEN CALL EXIT ENDIF END DO C COMERROR = .FALSE. C C*** Decode input integer values READ (PARAM(0)(1:LP(0)),*,ERR=11) ISTART GO TO 12 C 11 WRITE (TYO,1) '%NUMGEN-E-INVSTART, invalid integer specification for start.' COMERROR = .TRUE. C 12 READ (PARAM(1)(1:LP(1)),*,ERR=13) IEND GO TO 14 C 13 WRITE (TYO,1) '%NUMGEN-E-INVEND, invalid integer specification for end.' COMERROR = .TRUE. C 14 READ (PARAM(2)(1:LP(2)),*,ERR=15) INC GO TO 16 C 15 WRITE (TYO,1) '%NUMGEN-E-INVINC, invalid integer specification for increment.' COMERROR = .TRUE. C 16 READ (PARAM(3)(1:LP(3)),*,ERR=17) IZPAD IF ((IZPAD .LT. 0) .OR. (IZPAD .GT. 10)) GO TO 17 GO TO 20 C 17 WRITE (TYO,1) '%NUMGEN-E-INVZPAD, invalid integer specification for zpad.' COMERROR = .TRUE. C 20 IF (COMERROR) THEN CALL DOC_NUMGEN CALL EXIT ELSE ENDIF C C*** Extract quoted string IQSTART = INDEX (COMMANDLINE(1:LCL),'"') IF ((IQSTART .LE. 0) .OR. (IQSTART .EQ. LCL)) THEN WRITE (TYO,1) '%NUMGEN-E-MSNGSTRING, missing required quoted string.' COMERROR = .TRUE. ELSE IQEND = IQSTART + 1 DO WHILE ((COMMANDLINE(IQEND:IQEND) .NE. '"') .AND. (IQEND .LT. LCL)) IQEND = IQEND + 1 END DO IF (IQEND-IQSTART .LE. 1) THEN WRITE (TYO,1) '%NUMGEN-E-MSNGSTRING, missing required quoted string.' COMERROR = .TRUE. ELSE FMTSTR = COMMANDLINE (IQSTART+1:IQEND-1) LFS = LENGTH (FMTSTR) IF (LFS .LE. 0) THEN WRITE (TYO,1) '%NUMGEN-E-MSNGSTRING, missing required quoted string.' COMERROR = .TRUE. ELSE IF (INDEX(FMTSTR(1:LFS),'#') .LE. 0) THEN WRITE (TYO,1) '%NUMGEN-E-MSNGPOUND, missing at least one pound (#) in format string.' COMERROR = .TRUE. ELSE ENDIF ENDIF ENDIF ENDIF C C*** Is there an optional output file name ! LEFT OFF HERE OUTFILE = ' ' IF (IQEND .NE. LCL) THEN I = IQEND + 1 DO WHILE ((I .LT. LCL) .AND. (COMMANDLINE(I:I) .EQ. ' ')) I = I + 1 END DO IF (I .LT. LCL) THEN OUTFILE = COMMANDLINE (I:LCL) ELSE OUTFILE = 'SYS$OUTPUT' ENDIF ELSE OUTFILE = 'SYS$OUTPUT' ENDIF CALL UPCASE (OUTFILE) LOF = LENGTH (OUTFILE) C DCL = (LOF .EQ. 3) .AND. (OUTFILE(1:3) .EQ. 'DCL') C C*** Test reliability of increment, start, and end. IF (INC .LT. 0) THEN IF (ISTART .LT. IEND) THEN WRITE (TYO,1) '%NUMGEN-E-BADINC, for negative increment start must be greater than' WRITE (TYO,1) ' or equal to end.' COMERROR = .TRUE. ELSE ENDIF ELSE IF (INC .GT. 0) THEN IF (ISTART .GT. IEND) THEN WRITE (TYO,1) '%NUMGEN-E-BADINC, for positive increment start must be less than' WRITE (TYO,1) ' or equal to end.' COMERROR = .TRUE. ELSE ENDIF ELSE ! (INC .EQ. 0) WRITE (TYO,1) '%NUMGEN-E-INVINC, increment must be non-zero.' COMERROR = .TRUE. ENDIF C IF (COMERROR) THEN CALL DOC_NUMGEN CALL EXIT ELSE ENDIF C C*** All values are good, Open Output file IF (DCL) THEN C C*** Create a mailbox, name then a mail box CALL GET_PID (MY_PID) WRITE (MBX_NAME,3) 'NUMGEN_', MY_PID, '_MBOX' ISTAT = SYS$CREMBX (%VAL(TEMPORARY),MBX_CHAN,,,,,MBX_NAME,,) IF (.NOT. ISTAT) THEN WRITE (TYO,1) ' %NUMGEN-F-MBXCRE8FAIL, failed to create DCL command mailbox.' CALL LIB$STOP (%VAL(ISTAT)) ELSE ENDIF C C*** Get a process completion eventflag number ISTAT = LIB$GET_EF (RESERVED_EVENT_FLAG) IF (.NOT. ISTAT) THEN WRITE (TYO,1) ' %NUMGEN-F-COMPEFALOCFAIL, failed to allocate DCL completion event flag.' CALL LIB$STOP (%VAL(ISTAT)) ELSE ENDIF C ISTAT = SYS$CLREF (%VAL(RESERVED_EVENT_FLAG)) IF (.NOT. ISTAT) THEN WRITE (TYO,1) ' %NUMGEN-F-COMPEFALOCFAIL, failed to allocate DCL completion event flag.' CALL LIB$STOP (%VAL(ISTAT)) ELSE COMPLETION_EVENT_FLAG = RESERVED_EVENT_FLAG ENDIF C C*** Spawn a DCL subprocess ISTAT = LIB$SPAWN (,MBX_NAME,'SYS$OUTPUT',NOWAIT,,HIS_PID,,COMPLETION_EVENT_FLAG,,,,,) IF (.NOT. ISTAT) THEN WRITE (TYO,1) ' %NUMGEN-F-SPAWNFAIL, failed to spawn DCL subprocess.' CALL LIB$STOP (%VAL(ISTAT)) ELSE ENDIF C OUTFILE = MBX_NAME LOF = 20 ELSE ENDIF C C*** Open output file OPEN ( UNIT=OUT, 1 FILE=OUTFILE(1:LOF), 2 STATUS='NEW', 3 CARRIAGECONTROL='LIST', 4 IOSTAT=ISTAT) C IF (ISTAT .NE. 0) THEN WRITE (TYO,1) ' %NUMGEN-F-OPENOUTFAIL, failed to open output file ' // OUTFILE (1:LOF) CALL RT_ERROR (TYO,ISTAT) IF (DCL) THEN ISTAT = SYS$DELMBX (MBX_CHAN) ELSE ENDIF CALL EXIT ELSE ENDIF C C*** Do the Generation DO IVALUE = ISTART,IEND,INC SVALUE = ' ' OUTSTRING = ' ' JSIZ = JMAX0 (IZPAD,ISIZ(IVALUE)) WRITE (SVALUE,2) IVALUE LSV = LENGTH (SVALUE) J = 1 DO I = 1,LFS IF (FMTSTR(I:I) .EQ. '#') THEN DO K = 1,LSV OUTSTRING (J:J) = SVALUE (K:K) J = J + 1 END DO ELSE OUTSTRING (J:J) = FMTSTR (I:I) J = J + 1 ENDIF END DO LOS = LENGTH (OUTSTRING) C IF (DCL) THEN IF (OUTSTRING(1:1) .NE. '$') OUTSTRING = '$' // OUTSTRING(1:LOS) LOS = LOS + 1 WRITE (OUT,5) BOLD_ON,OUTSTRING (1:LOS),BOLD_OFF ELSE ENDIF C WRITE (OUT,1) OUTSTRING (1:LOS) END DO C CLOSE (UNIT=OUT) C IF (DCL) THEN ISTAT = SYS$DELMBX (MBX_CHAN) ISTAT = SYS$WAITFR (%VAL(RESERVED_EVENT_FLAG)) ISTAT = LIB$FREE_EF (RESERVED_EVENT_FLAG) ELSE ENDIF C C*** All done 9000 CALL EXIT END SUBROUTINE DOC_NUMGEN IMPLICIT NONE C****************************************************************************** C*** C*** This routine documents the NUMGEN usage C*** C*** Author : Jeff Cameron C*** C*** Modification history : C*** C*** Programmer Date Description C*** ---------------------------------------------------------------------- C*** Jeff Cameron 08-AUG-1994 Initially written C*** ---------------------------------------------------------------------- C*** C****************************************************************************** C C*** Constants C C*** Common blocks C C*** Local declarations INTEGER*4 TYO /6/, TYI /5/ CHARACTER*1 RESP C C*** Externals C C*** Formats 1 FORMAT (A) C------------------------------------------------------------------------------ C C*** Begining of executable code. WRITE (TYO,1) ' NUMGEN usage :' WRITE (TYO,1) ' $NUMGEN start end inc zpad "string" [outfile|DCL]' WRITE (TYO,1) ' ' WRITE (TYO,1) ' This program generates a series of strings, one per line with integer' WRITE (TYO,1) ' values imbedded.' WRITE (TYO,1) ' Parameters :' WRITE (TYO,1) ' start Starting integer value.' WRITE (TYO,1) ' end Ending integer value.' WRITE (TYO,1) ' inc Integer increment.' WRITE (TYO,1) ' zpad Number of leading zero padding.' WRITE (TYO,1) ' string String format.' WRITE (TYO,1) ' outfile|DCL Optional output file or DCL execution. If no file' WRITE (TYO,1) ' is specified, output is listed to SYS$OUTPUT.' WRITE (TYO,1) ' Example :' WRITE (TYO,1) ' The command : $NUMGEN 20 1220 300 3 "FILE # A#B.DAT"' WRITE (TYO,1) ' will generate :' WRITE (TYO,1) ' FILE 020 A020B.DAT' WRITE (TYO,1) ' FILE 320 A320B.DAT' WRITE (TYO,1) ' FILE 620 A620B.DAT' WRITE (TYO,1) ' FILE 920 A920B.DAT' WRITE (TYO,1) ' FILE 1220 A1220B.DAT' WRITE (TYO,1) ' for more' READ (TYI,1,END=1000) RESP WRITE (TYO,1) ' Second Example :' WRITE (TYO,1) ' The command : $NUMGEN 0 100 10 3 "CREATE/DIR SYS$DISK:[DATA.GROUP#]" DCL' WRITE (TYO,1) ' will generate 11 directories : [DATA.GROUP000], [DATA.GROUP010] through' WRITE (TYO,1) ' [DATA.GROUP100] by passing off each generated command to DCL.' WRITE (TYO,1) ' ' WRITE (TYO,1) ' Additional information.' WRITE (TYO,1) ' ' WRITE (TYO,1) ' The values for start, end, inc, and zpad must all be integers. Zpad' WRITE (TYO,1) ' must be a value from 0 to 10. The string specification must be enclosed' WRITE (TYO,1) ' in double quotes, and must contain at least one pound sign indicating' WRITE (TYO,1) ' where the integer numbers are to be substituted.' WRITE (TYO,1) ' ' C C*** All done 1000 RETURN END