You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
360 lines
11 KiB
360 lines
11 KiB
C Copyright(C) 1999-2020 National Technology & Engineering Solutions
|
|
C of Sandia, LLC (NTESS). Under the terms of Contract DE-NA0003525 with
|
|
C NTESS, the U.S. Government retains certain rights in this software.
|
|
C
|
|
C See packages/seacas/LICENSE for details
|
|
|
|
C -*- Mode: fortran -*-
|
|
C=======================================================================
|
|
SUBROUTINE SETSTA (PROMPT, ERRMSG, NITEM1, NITEM2, IDS, ISTAT, *)
|
|
C=======================================================================
|
|
|
|
C --*** SETSTA *** (GJOIN) Set status of items
|
|
C -- Written by Amy Gilkey - revised 02/23/88
|
|
C -- Revised by Greg Sjaardema -
|
|
C -- 06/12/90 - Delete multiple occurrences of ID in list
|
|
C --
|
|
C --SETSTA sets the status of a list of items from user-supplied
|
|
C --instructions.
|
|
C --
|
|
C --Parameters:
|
|
C -- PROMPT - IN - the prompt string
|
|
C -- ERRMSG - IN - the item type for error messages, end with 'number'
|
|
C -- NITEM1 - IN - the number of items in the first set
|
|
C -- NITEM2 - IN - the number of items in the second set
|
|
C -- IDS - IN - the IDs of the items in both sets
|
|
C -- ISTAT - IN/OUT - the status of each item (from both sets):
|
|
C -- 0 = same
|
|
C -- - = delete
|
|
C -- n = combine with block n
|
|
C -- * - return statement for print items with status
|
|
|
|
include 'gj_filnum.blk'
|
|
PARAMETER (MAXFLD=80)
|
|
|
|
CHARACTER*(*) PROMPT
|
|
CHARACTER*(*) ERRMSG
|
|
INTEGER ISTAT(*)
|
|
INTEGER IDS(*)
|
|
|
|
LOGICAL MATSTR, FFEXST, FOUND
|
|
CHARACTER*8 WORD, VERB
|
|
CHARACTER*5 STRA
|
|
INTEGER INTYP(MAXFLD+1)
|
|
CHARACTER*8 CFIELD(MAXFLD)
|
|
INTEGER IFIELD(MAXFLD)
|
|
REAL RFIELD(MAXFLD)
|
|
|
|
CHARACTER*8 CMDTBL(11)
|
|
SAVE CMDTBL
|
|
C --CMDTBL - the valid commands table
|
|
|
|
C --Command table follows. Remember to change the dimensioned size when
|
|
C --changing the table.
|
|
DATA CMDTBL /
|
|
1 'ID ', 'DELETE ', 'COMBINE ', 'RESET ', 'CHANGE ',
|
|
2 'LIST ', 'HELP ', 'UP ', 'EXIT ', 'INCREMEN',
|
|
3 ' ' /
|
|
|
|
MATCH = 0
|
|
NITEMS = NITEM1 + NITEM2
|
|
IF (NITEMS .LE. 0) RETURN
|
|
|
|
100 CONTINUE
|
|
|
|
WRITE (*, *)
|
|
CALL FREFLD (0, 0, PROMPT, MAXFLD,
|
|
& IOSTAT, NUMFLD, INTYP, CFIELD, IFIELD, RFIELD)
|
|
IF (IOSTAT .LT. 0) GOTO 160
|
|
IF (NUMFLD .EQ. 0) GOTO 100
|
|
INTYP(MIN(MAXFLD,NUMFLD)+1) = -999
|
|
|
|
IFLD = 1
|
|
CALL FFCHAR (IFLD, INTYP, CFIELD, ' ', WORD)
|
|
CALL ABRSTR (VERB, WORD, CMDTBL)
|
|
IF (VERB .EQ. ' ') VERB = WORD
|
|
CFIELD(IFLD-1) = VERB
|
|
INTYP(IFLD-1) = 0
|
|
CALL OUTLOG (KLOG, MIN(MAXFLD,NUMFLD), INTYP,
|
|
$ CFIELD, IFIELD, RFIELD)
|
|
|
|
IF (VERB .EQ. 'ID') THEN
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
|
& 'block/set number', 0, ITEM, *150)
|
|
IF ((ITEM .LE. 0) .OR. (ITEM .GT. NITEMS)) THEN
|
|
CALL PRTERR ('CMDERR', 'Invalid block/set number')
|
|
GOTO 150
|
|
END IF
|
|
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
|
& 'new ID', 0, ID, *150)
|
|
IDS(ITEM) = ID
|
|
|
|
RETURN 1
|
|
|
|
ELSE IF (VERB .EQ. 'CHANGE') THEN
|
|
MATCH = 3
|
|
98 CONTINUE
|
|
FOUND = .FALSE.
|
|
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
|
& 'block/set ID', 0, ID, *150)
|
|
IF (ID .LE. 0) RETURN 1
|
|
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
|
& 'new ID', 0, IDNEW, *150)
|
|
|
|
IF (FFEXST (IFLD, INTYP)) THEN
|
|
CALL FFCHAR (IFLD, INTYP, CFIELD, 'ALL', WORD)
|
|
IF (MATSTR(WORD, 'FIRST', 1)) THEN
|
|
MATCH = 1
|
|
ELSE IF (MATSTR(WORD, 'SECOND', 1)) THEN
|
|
MATCH = 2
|
|
ELSE IF (MATSTR(WORD, 'BOTH', 1)) THEN
|
|
MATCH = 3
|
|
ELSE IF (MATSTR(WORD, 'ALL', 1)) THEN
|
|
MATCH = 3
|
|
ELSE
|
|
CALL PRTERR ('CMDERR',
|
|
* 'Invalid CHANGE identifier: ' // WORD)
|
|
GOTO 98
|
|
END IF
|
|
END IF
|
|
|
|
if (match .eq. 1 .or. match .eq. 3) then
|
|
ITEM = LOCINT (ID, NITEM1, IDS)
|
|
IF ((ITEM .GT. 0) .AND. (ITEM .LE. NITEM1)) THEN
|
|
FOUND = .TRUE.
|
|
IDS(ITEM) = IDNEW
|
|
END IF
|
|
end if
|
|
|
|
C ... Check for same ID in second set of IDs
|
|
if (match .eq. 2 .or. match .eq. 3) then
|
|
IF (NITEM2 .GT. 0) THEN
|
|
ITEM = LOCINT (ID, NITEM2, IDS(NITEM1+1))
|
|
IF ((ITEM .GT. 0) .AND. (ITEM .LE. NITEM2)) THEN
|
|
FOUND = .TRUE.
|
|
IDS(NITEM1 + ITEM) = IDNEW
|
|
END IF
|
|
END IF
|
|
end if
|
|
|
|
if (FOUND .EQV. .FALSE.) then
|
|
WRITE (STRA, '(I5)') ID
|
|
CALL SQZSTR (STRA, LSTRA)
|
|
CALL PRTERR ('CMDERR',
|
|
* 'Invalid block/set ID ' // STRA(:LSTRA))
|
|
end if
|
|
|
|
GO TO 98
|
|
|
|
ELSE IF (VERB .EQ. 'DELETE') THEN
|
|
99 CONTINUE
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
|
& 'block/set ID', 0, ID, *150)
|
|
IF (ID .LE. 0) RETURN 1
|
|
ITEM = LOCINT (ID, NITEMS, IDS)
|
|
IF ((ITEM .LE. 0) .OR. (ITEM .GT. NITEMS)) THEN
|
|
WRITE (STRA, '(I5)') ID
|
|
CALL SQZSTR (STRA, LSTRA)
|
|
CALL PRTERR ('CMDERR',
|
|
* 'Invalid block/set ID ' // STRA(:LSTRA))
|
|
GOTO 99
|
|
END IF
|
|
|
|
IOLD = ISTAT(ITEM)
|
|
ISTAT(ITEM) = -1
|
|
|
|
C ... Check and Remove any combines with deleted ID
|
|
|
|
IF (IOLD .GT. 0) THEN
|
|
NCOMB = INTCNT (IOLD, ISTAT, NITEMS)
|
|
IF (NCOMB .EQ. 1) THEN
|
|
INEW = LOCINT (IOLD, NITEMS, ISTAT)
|
|
ISTAT(INEW) = 0
|
|
ELSE IF ((NCOMB .GT. 1) .AND. (IOLD .EQ. ITEM)) THEN
|
|
INEW = LOCINT (IOLD, NITEMS, ISTAT)
|
|
CALL CHGINT (IOLD, INEW, ISTAT, NITEMS)
|
|
END IF
|
|
END IF
|
|
|
|
C ... Check for same ID in second set of IDs
|
|
|
|
IF (NITEM2 .GT. 0) THEN
|
|
ITEM = LOCINT (ID, NITEM2, IDS(NITEM1+1))
|
|
IF (ITEM .GT. 0 .AND. ITEM .LE. NITEM2) THEN
|
|
ISTAT(NITEM1 + ITEM) = -1
|
|
END IF
|
|
END IF
|
|
GO TO 99
|
|
|
|
ELSE IF (VERB .EQ. 'COMBINE') THEN
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
|
& 'block/set ID', 0, ID1, *150)
|
|
IFIRST = LOCINT (ID1, NITEMS, IDS)
|
|
IF ((IFIRST .LE. 0) .OR. (IFIRST .GT. NITEMS)) THEN
|
|
WRITE (STRA, '(I5)') ID
|
|
CALL SQZSTR (STRA, LSTRA)
|
|
CALL PRTERR ('CMDERR',
|
|
& 'Invalid block/set ID ' // STRA(:LSTRA))
|
|
GOTO 150
|
|
END IF
|
|
110 CONTINUE
|
|
IF (FFEXST (IFLD, INTYP)) THEN
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
|
& 'block/set ID', 0, ID2, *120)
|
|
if (id1 .eq. id2 .and. ifirst .le. nitem1) then
|
|
C ... If the two ids match (combine 2 2) then user probably
|
|
C has done a reset and now wants to recombine items from
|
|
C each database.
|
|
ITEM = LOCINT (ID2, NITEM2, IDS(NITEM1+1)) + NITEM1
|
|
else
|
|
ITEM = LOCINT (ID2, NITEMS, IDS)
|
|
end if
|
|
IF ((ITEM .LE. 0) .OR. (ITEM .GT. NITEMS)) THEN
|
|
WRITE (STRA, '(I5)') ID
|
|
CALL SQZSTR (STRA, LSTRA)
|
|
CALL PRTERR ('CMDERR',
|
|
& 'Invalid block/set ID ' // STRA(:LSTRA))
|
|
GOTO 120
|
|
END IF
|
|
ISTAT(IFIRST) = IFIRST
|
|
ISTAT(ITEM) = IFIRST
|
|
120 CONTINUE
|
|
GOTO 110
|
|
END IF
|
|
|
|
INEW = IFIRST
|
|
DO 130 IOLD = 1, NITEMS
|
|
IF (ISTAT(IOLD) .EQ. INEW) THEN
|
|
CALL CHGINT (IOLD, INEW, ISTAT, NITEMS)
|
|
END IF
|
|
130 CONTINUE
|
|
|
|
RETURN 1
|
|
|
|
ELSE IF (VERB .EQ. 'RESET') THEN
|
|
IF (.NOT. FFEXST (IFLD, INTYP)) THEN
|
|
C --Reset all items
|
|
DO 140 ITEM = 1, NITEMS
|
|
ISTAT(ITEM) = 0
|
|
140 CONTINUE
|
|
|
|
ELSE
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
|
& 'block/set ID', 0, ID, *150)
|
|
ITEM = LOCINT (ID, NITEMS, IDS)
|
|
IF ((ITEM .LE. 0) .OR. (ITEM .GT. NITEMS)) THEN
|
|
CALL PRTERR ('CMDERR', 'Invalid block/set ID')
|
|
GOTO 150
|
|
END IF
|
|
|
|
IOLD = ISTAT(ITEM)
|
|
ISTAT(ITEM) = 0
|
|
|
|
IF (IOLD .GT. 0) THEN
|
|
NCOMB = INTCNT (IOLD, ISTAT, NITEMS)
|
|
IF (NCOMB .EQ. 1) THEN
|
|
INEW = LOCINT (IOLD, NITEMS, ISTAT)
|
|
ISTAT(INEW) = 0
|
|
ELSE IF ((NCOMB .GT. 1) .AND. (IOLD .EQ. ITEM)) THEN
|
|
INEW = LOCINT (IOLD, NITEMS, ISTAT)
|
|
CALL CHGINT (IOLD, INEW, ISTAT, NITEMS)
|
|
END IF
|
|
END IF
|
|
END IF
|
|
|
|
RETURN 1
|
|
|
|
C ----------------------------------------------------------------------
|
|
C SYNTAX: INCREMENT FIRST|SECOND|BOTH|ALL increment
|
|
ELSE IF (VERB .EQ. 'INCREMEN') THEN
|
|
DO 142 ITEM = 1, NITEMS
|
|
ISTAT(ITEM) = 0
|
|
142 CONTINUE
|
|
|
|
C ... See if incrementing 'first', 'second', 'both', or 'all'
|
|
IF (FFEXST (IFLD, INTYP)) THEN
|
|
CALL FFCHAR (IFLD, INTYP, CFIELD, 'ALL', WORD)
|
|
IF (MATSTR(WORD, 'FIRST', 1)) THEN
|
|
MATCH = 1
|
|
ELSE IF (MATSTR(WORD, 'SECOND', 1)) THEN
|
|
MATCH = 2
|
|
ELSE IF (MATSTR(WORD, 'BOTH', 1)) THEN
|
|
MATCH = 3
|
|
ELSE IF (MATSTR(WORD, 'ALL', 1)) THEN
|
|
MATCH = 3
|
|
ELSE
|
|
CALL PRTERR ('CMDERR',
|
|
* 'Invalid INCREMENT identifier: ' // WORD)
|
|
GOTO 149
|
|
END IF
|
|
END IF
|
|
|
|
C ... At this point, have type of match specified. Now get increment
|
|
IF (FFEXST (IFLD, INTYP)) THEN
|
|
CALL FFINTG (IFLD, INTYP, IFIELD,
|
|
& 'block/set ID increment', 0, INC, *149)
|
|
ELSE
|
|
call prterr ('CMDERR', 'ID Increment not specified')
|
|
go to 149
|
|
END IF
|
|
|
|
C ... Do the increment
|
|
if (match .eq. 1 .or. match .eq. 3) then
|
|
do 143 item = 1, nitem1
|
|
ids(item) = ids(item) + inc
|
|
143 continue
|
|
end if
|
|
if (match .eq. 2 .or. match .eq. 3) then
|
|
do 144 item = nitem1+1, nitems
|
|
ids(item) = ids(item) + inc
|
|
144 continue
|
|
end if
|
|
|
|
C ... Redo the combinations if any match
|
|
DO 145 ITEM = 1, NITEMS
|
|
I = LOCINT (IDS(ITEM), NITEMS, IDS)
|
|
IF (I .LT. ITEM) THEN
|
|
ISTAT(ITEM) = I
|
|
ISTAT(I) = I
|
|
END IF
|
|
145 CONTINUE
|
|
|
|
return 1
|
|
149 continue
|
|
ELSE IF (VERB .EQ. 'HELP') THEN
|
|
WRITE (*, 10000)
|
|
10000 FORMAT (
|
|
& /,1X,'Valid Commands:',
|
|
& /,4X,'ID n newid ',
|
|
& '- change the block/set ID'
|
|
& /,4X,' ("n" is the block/set NUMBER, not the ID)'
|
|
& /,4X,'CHANGE id idnew [FIRST|SECOND|BOTH]'
|
|
& /,4x,' - change the ID from id to idnew'
|
|
& /,4X,'DELETE id - delete a block/set'
|
|
& /,4X,'COMBINE id1 id2 ... - combine blocks/sets'
|
|
& /,4X,'INCREMENT FIRST|SECOND|BOTH increment - increment ids'
|
|
& /,4X,'RESET id - reset the block/set'
|
|
& /,4X,'LIST - list information about the blocks/sets'
|
|
& /,4X,'UP/EXIT - go up a command level'
|
|
& )
|
|
|
|
ELSE IF (VERB .EQ. 'LIST') THEN
|
|
RETURN 1
|
|
|
|
ELSE IF (VERB .EQ. 'UP' .OR. VERB .EQ. 'EXIT') THEN
|
|
GOTO 160
|
|
|
|
ELSE
|
|
CALL PRTERR ('CMDERR', '"' // VERB(:LENSTR(VERB))
|
|
& // '" is an invalid command')
|
|
END IF
|
|
|
|
150 CONTINUE
|
|
GOTO 100
|
|
|
|
160 CONTINUE
|
|
RETURN
|
|
END
|
|
|