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=======================================================================
SUBROUTINE GRPEND (MAYQUI, MAYTXT, NDONE, NTOTAL, GOBCK, *, *)
C=======================================================================
C --*** GRPEND *** (GRPLIB) End a plot by requesting quit, hardcopy (PLT)
C -- Written by Amy Gilkey - revised 01/22/88
C --
C --GRPEND is called at the end of a plot. It may prompt the user for
C --a response and take the appropriate alternate returns for special
C --responses.
C --
C --If a single hardcopy plot is requested, the hardcopy device is
C --selected and an internal flag is set and an alternate return is taken.
C --If the internal flag is set upon entry to the routine, the terminal
C --device is selected and the flag is reset. Be sure to call this
C --routine at the normal end of the each plot (even a single hardcopy plot).
C --The internal flag is reset whenever the terminal device is selected.
C --
C --If the plot may be annotated with text, be sure that the color of the
C --text to be displayed is set before this routine is called.
C --
C --If no response is possible and AUTO is set, the number of plots
C --completed is displayed.
C --
C --Parameters:
C -- MAYQUI - IN - true if QUIT is a possible alternative
C -- MAYTXT - IN - true if TEXT is a possible alternative
C -- NDONE - IN - the number of plots completed
C -- NTOTAL - IN - the total number of plots
C -- GOBCK - in/out - on entry, true if go back supported,
C -- - on output, true if go back selected
C -- * - the alternate return if hardcopy requested
C -- * - the alternate return if quit requested
C --
C --Common Variables:
C -- Sets and uses IHARD of /GRPCOM/
C -- Uses ICURDV, DEVOK, DEVCOD, AUTOPL of /GRPCOM/
C --Routines Called:
C -- FREFLD - (SUPES) Free-field reader
C -- SQZSTR - (STRLIB) Compress extra blanks
C -- PLTBEL - (PLT) Ring bell
C -- PLTFLU - (PLT) Flush buffer
C -- PLTMOV - (PLT) Move cursor
C -- PLTWAI - (PLT) Wait until key is pressed
C -- GRABRT - (GRPLIB) Check for plot set abort
C -- GRIKEY - (GRPLIB) Select cursor position
C -- GRSDEV - (GRPLIB) Select device
C -- GRSNAP - (GRPLIB) Handle device frame snapping
PARAMETER (MXTEXT = 80)
COMMON /GRPCOC/ DEVNAM(2), DEVCOD(2)
CHARACTER*3 DEVNAM
CHARACTER*8 DEVCOD
COMMON /GRPCOM/ ICURDV, ISHARD, DEVOK(2), TALKOK(2),
& NSNAP(2), IFONT(2), SOFTCH(2), AUTOPL(2),
& MAXCOL(2), NUMCOL(0:1,2), MAPALT(2), MAPUSE(2)
LOGICAL ISHARD, DEVOK, TALKOK, SOFTCH, AUTOPL
LOGICAL MAYQUI, MAYTXT, GOBCK
LOGICAL GRABRT
LOGICAL REQWAI, ASKQUI, ASKHRD, ASKTXT, REPEAT
CHARACTER*80 PROMPT
CHARACTER REPLY
LOGICAL LSTERR
INTEGER NTEXT
LOGICAL CTEXT(MXTEXT)
REAL XTEXT(MXTEXT), YTEXT(MXTEXT)
CHARACTER*80 TEXT(MXTEXT)
SAVE NTEXT, CTEXT, XTEXT, YTEXT, TEXT
C --If end of hardcopy plot, add any text
IF (ISHARD) THEN
DO 100 I = 1, NTEXT
IF (CTEXT(I)) THEN
CALL GRTEXC (XTEXT(I), YTEXT(I), TEXT(I))
ELSE
CALL GRTEXT (XTEXT(I), YTEXT(I), TEXT(I))
END IF
100 CONTINUE
END IF
C --End plot and snap frames
CALL GRSNAP ('STOP', 0)
C --Flush the buffer and ring bell and (on some devices) wait for key
IF (GRABRT ()) RETURN 2
CALL PLTMOV (0.0, 0.0)
CALL PLTFLU
CALL PLTBEL
CALL PLTFLU
REQWAI = (.NOT. AUTOPL(ICURDV)) .AND. (DEVCOD(ICURDV) .EQ. 'WAIT')
IF (REQWAI) THEN
CALL PLTWAI
CALL PLTFLU
END IF
C --If end of hardcopy plot, reselect terminal device and return
IF (ISHARD) THEN
CALL GRSDEV (0)
ISHARD = .FALSE.
RETURN
END IF
C --Reset the text lines
NTEXT = 0
DX = 1.0 / 2
DY = 0.75 / 2
C.. If a single plot, or the last plot in the set, don't prompt,
C return immediately to prompt.
ASKQUI = NDONE .LT. NTOTAL .AND. MAYQUI
ASKHRD = DEVOK(2) .AND. (ICURDV .NE. 2)
C.. Only ask for text if the hardcopy or multiple plot prompting enabled
ASKTXT = (ASKHRD .OR. ASKQUI) .AND. MAYTXT
IF ((.NOT. AUTOPL(ICURDV))
& .AND. (ASKQUI .OR. ASKHRD .OR. ASKTXT)) THEN
C --Check if user wants to quit or get hardcopy
LSTERR = .FALSE.
PROMPT = 'Enter'
LPR = LENSTR (PROMPT) + 1
IF (ASKQUI) THEN
PROMPT(LPR+1:) = '"Q" to quit,'
LPR = LENSTR (PROMPT) + 1
END IF
IF (gobck) THEN
gobck = .false.
if (ndone .gt. 1) then
PROMPT(LPR+1:) = '"P" for previous,'
LPR = LENSTR (PROMPT) + 1
end if
END IF
IF (ASKHRD) THEN
PROMPT(LPR+1:) = '"H" for hardcopy,'
LPR = LENSTR (PROMPT) + 1
END IF
IF (ASKTXT) THEN
PROMPT(LPR+1:) = '"T" for text,'
LPR = LENSTR (PROMPT) + 1
END IF
PROMPT(LPR+1:) = '" " to continue'
LPR = LENSTR (PROMPT) + 1
110 CONTINUE
C --Prompt for response, print trailing bell only if last response
C --was in error
IF (LSTERR) THEN
PROMPT(LPR+1:LPR+1) = CHAR(7)
LPR = LPR + 1
END IF
CALL FREFLD (0, 0, PROMPT(:LPR), 1,
& IOSTAT, NUMFLD, INTYP, REPLY, IDUM, RDUM)
IF (LSTERR) LPR = LPR - 1
LSTERR = .FALSE.
REPEAT = .FALSE.
IF (REPLY .EQ. 'Q') THEN
IF (ASKQUI) THEN
C --Quit
RETURN 2
END IF
ELSE IF (REPLY .EQ. 'H') THEN
IF (ASKHRD) THEN
C --Request hardcopy, select hardcopy, set flag, and return
CALL GRSDEV (2)
ISHARD = .TRUE.
RETURN 1
ELSE
REPEAT = .TRUE.
END IF
ELSE IF (REPLY .EQ. 'P') THEN
GOBCK = .TRUE.
RETURN
ELSE IF (REPLY .EQ. 'T') THEN
IF (ASKTXT .AND. (NTEXT .LT. MXTEXT)) THEN
C --Input position and text string
CALL GRIKEY (
& ' Select text position ("C" to center) ...',
& DX, DY, REPLY, *120)
C --Write line to correct problem with cursor input followed
C --by GETINP or FREFLD
WRITE (*, *)
IF (REPLY .EQ. 'C') THEN
CALL GETINP (0, 0, ' Text to center> ',
& TEXT(NTEXT+1), IOSTAT)
ELSE
CALL GETINP (0, 0, ' Text> ',
& TEXT(NTEXT+1), IOSTAT)
END IF
WRITE (*, *)
IF (TEXT(NTEXT+1) .NE. ' ') THEN
NTEXT = NTEXT + 1
CTEXT(NTEXT) = (REPLY .EQ. 'C')
XTEXT(NTEXT) = DX
YTEXT(NTEXT) = DY
C --Display text string on device
IF (CTEXT(NTEXT)) THEN
CALL GRTEXC (XTEXT(NTEXT), YTEXT(NTEXT),
& TEXT(NTEXT))
ELSE
CALL GRTEXT (XTEXT(NTEXT), YTEXT(NTEXT),
& TEXT(NTEXT))
END IF
CALL PLTFLU
END IF
END IF
REPEAT = .TRUE.
ELSE IF (REPLY .NE. ' ') THEN
LSTERR = .TRUE.
REPEAT = .TRUE.
END IF
IF (REPEAT) GOTO 110
ELSE
if (gobck) gobck = .false.
END IF
IF (AUTOPL(ICURDV) .AND. (NTOTAL .GT. 0)) THEN
WRITE (PROMPT, 10000, IOSTAT=IDUM) NDONE, NTOTAL
10000 FORMAT (4X, 'Plot ', I5, ' of ', I5)
CALL SQZSTR (PROMPT, LSTR)
WRITE (*, '(1X, A)') PROMPT(:LSTR)
END IF
RETURN
120 CONTINUE
return 2
END