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