C C C SUBROUTINE PROPLT I (MESSFL,ICHK,BWNNAM, O WNDFLG) C C + + + PURPOSE + + + C Perform interactive modifications to plot specifications C such as device type, axes, titles, curves, plot size, C legends, axis scales, extra text as determined by ICHK array. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL,ICHK(7),WNDFLG CHARACTER*8 BWNNAM(2) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C ICHK - flag (0=needs input, 1= ok to change, 2= no change) C 1 - for graphics device C 2 - for axes types C 3 - for titles C 4 - for specs on curves and legends C 5 - for axes scales C 6 - for extra text, blank space, and letter style C 7 - size of plot and characters C BWNNAM - window name and path C (1) window name, usually Modify C (2) path, usually GM C WNDFLG - flag for change in device type or device code C 0 - no change C 1 - changed, need to close and reopen workstation C C + + + LOCAL VARIABLES + + + INTEGER I,J,I0,I1,SCLU,SGRP,IPAR,INIT,LEN,LPTH, & ILOC(7), WNDW1, WNDW2 CHARACTER*1 BLNK,PBUFF(49) CHARACTER*7 PATHS(8) CHARACTER*8 PTHNAM(3) C C + + + EXTERNALS + + + EXTERNAL QRESP, PRNTXT, PMXCNW, ZBLDWR EXTERNAL GETTXT, CARVAR, ZWNSOP, PINAXT, PINSPC, ZSTCMA EXTERNAL PINEXA, PINSCL, PINDEV, PINTTL, PINSIZ C C + + + END SPECIFICATIONS + + + C I0 = 0 I1 = 1 BLNK= ' ' PTHNAM(2) = BWNNAM(2) SCLU= 32 C C get names of parameter groups SGRP= 2 LEN = 49 CALL GETTXT (MESSFL,SCLU,SGRP,LEN,PBUFF) LEN = 7 J = 1 DO 5 I = 1, 7 CALL CARVAR ( LEN, PBUFF(J), LEN, PATHS(I) ) J = J + 7 5 CONTINUE PATHS(8) = 'Return' C C see if any specs need defining IPAR= 0 I = 0 10 CONTINUE I = I + 1 IF (ICHK(I).EQ.0) THEN C needs defining, set as default for menu IPAR = I END IF IF (I.LT.7 .AND. IPAR.EQ.0) GO TO 10 IF (IPAR.EQ.0) THEN C no undefined parts, default to first part which may be modified I= 0 20 CONTINUE I= I+ 1 IF (ICHK(I).EQ.1) THEN C this one is ok to modify, make default for menu IPAR= I END IF IF (I.LT.7 .AND. IPAR.EQ.0) GO TO 20 END IF C C Initialize local variable with ICHK DO 30 I = 1,7 ILOC(I) = ICHK(I) 30 CONTINUE C WNDFLG = 0 40 CONTINUE C Modify: 1-Device, 2-Axes, 3-Titles, 4-Curves, 5-Min/Max, C 6-Extra, 7-Size, 8-Return LPTH = 2 CALL ZWNSOP ( LPTH, BWNNAM ) SGRP = 1 CALL QRESP (MESSFL,SCLU,SGRP,IPAR) IF (IPAR.LT.8) THEN C wants to modify something PTHNAM(1) = PATHS(IPAR) PTHNAM(3) = PATHS(IPAR)(1:1) IF (ICHK(IPAR) .EQ. 2) THEN C option not available to user LPTH = 3 CALL ZWNSOP ( LPTH, PTHNAM ) SGRP = 3 CALL PRNTXT (MESSFL,SCLU,SGRP) ELSE C ok to modify, allow previous command I= 4 CALL ZSTCMA (I,I1) GO TO (100,200,300,400,500,600,700) IPAR C 100 CONTINUE C device type? CALL PINDEV (MESSFL,SCLU,PTHNAM(2), WNDW1) IF (WNDW1 .EQ. 1) WNDFLG = 1 ILOC(1) = 1 GO TO 800 C 200 CONTINUE C axes types CALL PINAXT (MESSFL,SCLU,PTHNAM(2)) ILOC(2) = 1 GO TO 800 C 300 CONTINUE C titles CALL PINTTL (MESSFL,SCLU,PTHNAM(2)) ILOC(3) = 1 GO TO 800 C 400 CONTINUE C specs on the curves CALL PINSPC (MESSFL,SCLU,PTHNAM(2)) ILOC(4) = 1 GO TO 800 C 500 CONTINUE C scales CALL PINSCL (MESSFL,SCLU,PTHNAM(2)) ILOC(5) = 1 GO TO 800 C 600 CONTINUE C extra conditions CALL PINEXA (MESSFL,SCLU,PTHNAM(2)) ILOC(6) = 1 GO TO 800 C 700 CONTINUE C sizes of plot CALL PINSIZ (MESSFL,SCLU,PTHNAM(2), WNDW2) IF (WNDW2 .EQ. 1) WNDFLG = 1 ILOC(7) = 1 GO TO 800 C 800 CONTINUE END IF ELSE C user wants out, check for any specs which need defining INIT= 1 I = 0 900 CONTINUE I= I+ 1 IF (ILOC(I).EQ.0) THEN C this part still undefined IF (INIT.EQ.1) THEN C first undefined group, write header LPTH = 3 PTHNAM(1) = PATHS(8) PTHNAM(3) = PATHS(8)(1:1) CALL ZWNSOP ( LPTH, PTHNAM ) SGRP= 4 CALL PMXCNW (MESSFL,SCLU,SGRP,I1,INIT,I1,J) INIT= -1 J= I END IF LEN = 7 CALL ZBLDWR (LEN,PATHS(I),I0,-I1,J) END IF IF (I.LT.7) GO TO 900 IF (INIT.EQ.-1) THEN C messages written, hold for user C turn off previous command I= 4 CALL ZSTCMA (I,I0) CALL ZBLDWR (I0,BLNK,I0,I0,J) C set IPAR for next screen to do IPAR= J END IF END IF C C turn off previous command I= 4 CALL ZSTCMA (I,I0) C IF (IPAR.NE.8) GO TO 40 C RETURN END C C C SUBROUTINE PINDEV I (MESSFL,SCLU,WNDNAM, O WNDW) C C + + + PURPOSE + + + C This routine is called from PROPLT and will allow the user to C select graphics output device. For DG AVIION, a file name C will be requested for all devices but the screen (X window). C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL,SCLU,WNDW CHARACTER*8 WNDNAM(1) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C SCLU - cluster number on message file C WNDNAM - keystrokes C WNDW - flag for change in device type or device code C 0 - no change C 1 - changed, need to close and reopen workstatio C C + + + PARAMETERS + + + INCLUDE 'ptsmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' C C + + + LOCAL VARIABLES + + + INTEGER SGRP1(5), SGRP2(4), SGRP, OLDCOD, OLDTYP, IND, $ INDEX(4), CPU, IRET, RETCOD, LPTH CHARACTER*8 PTH(3), PTHNAM(3) C C + + + EXTERNALS + + + EXTERNAL QRESP, ANPRGT, PRNTXT, ZWNSOP, ZGTRET, QFOPEN C C + + + DATA INITIALIZATIONS + + + C pc prime vax unix aviion DATA SGRP1 / 142, 143, 144, 145, 146 / C screen laser plotter meta DATA SGRP2 / 150, 151, 152, 153 / DATA INDEX / 40, 41, 42, 43 / DATA PTH / 'Laser', 'Plotter', 'Meta' / C C + + + END SPECIFICATIONS + + + C C find computer type (1-pc,2-prime,3-vax,4-unix,5-aviion) IND = 1 CALL ANPRGT (IND,CPU) IF (CPU .LT. 1 .OR. CPU .GT. 5) THEN C unknown cpu type, default to pc CPU = 1 END IF C OLDCOD = DEVCOD OLDTYP = DEVTYP 100 CONTINUE C DEVTYP: pc: 142: 1-Screen, 2-Laser, 3-Plotter C prime: 143: 1-Screen, 2-Laser, 3-Plotter, 4-Meta/DIS C vax: 144: 1-Screen, 2-Laser, 3-Plotter, 4-Meta/gks C unix: 145: 1-Screen, 2-Laser, 3-Plotter, 4-Meta/cgm C aviion: 146: 1-Screen, 2-Laser, 3-Plotter, 4-Meta/cgm LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) SGRP = SGRP1(CPU) CALL QRESP (MESSFL,SCLU,SGRP,DEVTYP) IF (DEVTYP .LT. 1 .OR. DEVTYP .GT. 4) THEN C unknown device type, default to screen DEVTYP = 1 END IF C get device code CALL ANPRGT ( INDEX(DEVTYP), DEVCOD ) IF (DEVCOD .LE. 0) THEN C user specification file has no device code LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) SGRP = SGRP2(DEVTYP) CALL PRNTXT (MESSFL,SCLU,SGRP) CALL ZGTRET (IRET) ELSE IF (CPU.EQ.5 .AND. DEVTYP.GT.1) THEN C need a file name for graphics meta output for Aviion LPTH = 3 PTHNAM(2) = WNDNAM(1) PTHNAM(1) = PTH(1) PTHNAM(3) = PTH(1)(1:1) CALL ZWNSOP ( LPTH, PTHNAM ) SGRP = 149 CALL QFOPEN (MESSFL, SCLU, SGRP, MTPLUT, RETCOD) CALL ZGTRET (IRET) ELSE C no other action required IRET = 1 END IF C if "Prev"ious, go back to menu for device type IF (IRET .EQ. 2) GO TO 100 IF (OLDCOD .NE. DEVCOD .OR. OLDTYP .NE. DEVTYP) THEN C new device for output WNDW = 1 ELSE C no change WNDW = 0 END IF C RETURN END C C C SUBROUTINE PINAXT I (MESSFL,SCLU,WNDNAM) C C + + + PURPOSE + + + C This routine is called from PROPLT and will allow the user to C set the specifications for the types of axes. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL,SCLU CHARACTER*8 WNDNAM(1) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C SCLU - cluster number on message file C WNDNAM - keystrokes C C + + + PARAMETERS + + + INCLUDE 'ptsmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' C C + + + LOCAL VARIABLES + + + INTEGER SGRP,IDUM(3),IRET,IC,LPTH,AGAIN,I,RESCLE(3),I1 REAL MMIN(3), MMAX(3) C C + + + EXTERNALS + + + EXTERNAL ZWNSOP, Q1INIT, QSETCO, Q1EDIT, QGETCO, PRNTXT EXTERNAL SCALIT C C + + + END SPECIFICATIONS + + + C I1 = 1 C IF (XTYPE.EQ.0) THEN C time-series plots 100 CONTINUE C Type for axes: left y-axis, right y-axis, aux axis (1-n,2-y) IDUM(1)= YTYPE(1) IF (YTYPE(2).GT.0) THEN IDUM(2)= YTYPE(2)+ 1 ELSE IDUM(2)= 1 END IF IF (ALEN.GT.0.00001) THEN IDUM(3)= 2 ELSE IDUM(3) = 1 END IF IC = 3 SGRP= 10 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL Q1INIT ( MESSFL, SCLU, SGRP ) CALL QSETCO ( IC, IDUM ) CALL Q1EDIT ( IRET ) IF (IRET .EQ. 1) THEN C process input CALL QGETCO ( IC, IDUM ) C RESCLE(1) = 0 RESCLE(2) = 0 RESCLE(3) = 0 IF (YTYPE(1) .NE. IDUM(1) .OR. $ YTYPE(2) .NE. IDUM(2)-1) THEN C type of axis has changed DO 110 I = 1,3 C initialize limits MMIN(I) = 1.0E10 MMAX(I) = -1.0E10 110 CONTINUE C DO 120 I = 1,NVAR C set transformation array IF (WHICH(I) .EQ. 1) THEN C left y axis TRANSF(I) = IDUM(1) IF (YMAX(I) .GT. MMAX(1)) MMAX(1) = YMAX(I) IF (YMIN(I) .LT. MMIN(1)) MMIN(1) = YMIN(I) RESCLE(1) = 1 ELSE IF (WHICH(I) .EQ. 2) THEN C right y axis TRANSF(I) = IDUM(2) - 1 IF (YMAX(I) .GT. MMAX(2)) MMAX(2) = YMAX(I) IF (YMIN(I) .LT. MMIN(2)) MMIN(2) = YMIN(I) RESCLE(2) = 1 ELSE IF (WHICH(I) .EQ. 3) THEN C aux axis TRANSF(I) = 1 IF (YMAX(I) .GT. MMAX(3)) MMAX(3) = YMAX(I) IF (YMIN(I) .LT. MMIN(3)) MMIN(3) = YMIN(I) RESCLE(3) = 1 ELSE C shouldn't be an option, set ot 0 TRANSF(I) = 0 END IF 120 CONTINUE END IF C YTYPE(1)= IDUM(1) YTYPE(2)= IDUM(2) - 1 IF (RESCLE(1) .EQ. 1) THEN CALL SCALIT (YTYPE(1),MMIN(1),MMAX(1),PLMN(1),PLMX(1)) IF (YTYPE(1) .EQ. 1) TICS(1) = 10 END IF IF (RESCLE(2) .EQ. 1) THEN CALL SCALIT (YTYPE(2),MMIN(2),MMAX(2),PLMN(2),PLMX(2)) IF (YTYPE(2) .EQ. 1) TICS(2) = 10 END IF IF (RESCLE(3) .EQ. 1) THEN CALL SCALIT (I1, MMIN(3),MMAX(3),PLMN(3),PLMX(3)) TICS(3) = 2 END IF IF (IDUM(3).EQ.2) THEN ALEN = 1.0 ELSE ALEN = 0.0 END IF AGAIN = 0 ELSE IF (IRET .EQ. -1) THEN C "Oops" try again AGAIN = 1 ELSE C assume "Prev" back to modify AGAIN = 0 END IF IF (AGAIN .EQ. 1) GO TO 100 C IF ((YTYPE(2) .GT. 0 .AND. RESCLE(2) .EQ. 0) .OR. $ (ALEN .GT. 0.0001 .AND. RESCLE(3) .EQ. 0)) THEN C warning to select curves to put curve on right y-axis SGRP = 15 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL PRNTXT (MESSFL,SCLU,SGRP) END IF C ELSE C X-Y plot 200 CONTINUE C type for x and y axes IDUM(1)= XTYPE IDUM(2)= YTYPE(1) IDUM(3)= YTYPE(2) + 1 IC = 3 SGRP = 11 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL Q1INIT ( MESSFL, SCLU, SGRP ) CALL QSETCO ( IC, IDUM ) CALL Q1EDIT ( IRET ) IF (IRET .EQ. 1) THEN C process input CALL QGETCO ( IC, IDUM ) C RESCLE(1) = 0 RESCLE(2) = 0 RESCLE(3) = 0 IF (XTYPE .NE. IDUM(1) .OR. $ YTYPE(1) .NE. IDUM(2) .OR. $ YTYPE(2) .NE. IDUM(3)-1) THEN C type of axis has changed DO 210 I = 1,3 C initialize limits MMIN(I) = 1.0E10 MMAX(I) = -1.0E10 210 CONTINUE C DO 220 I = 1,NVAR C set transformation array IF (WHICH(I) .EQ. 1) THEN C left y axis TRANSF(I) = IDUM(2) IF (YMAX(I) .GT. MMAX(1)) MMAX(1) = YMAX(I) IF (YMIN(I) .LT. MMIN(1)) MMIN(1) = YMIN(I) RESCLE(1) = 1 ELSE IF (WHICH(I) .EQ. 2) THEN C right y axis TRANSF(I) = IDUM(3) - 1 IF (YMAX(I) .GT. MMAX(2)) MMAX(2) = YMAX(I) IF (YMIN(I) .LT. MMIN(2)) MMIN(2) = YMIN(I) RESCLE(2) = 1 ELSE IF (WHICH(I) .EQ. 4) THEN C x axis TRANSF(I) = IDUM(1) IF (YMAX(I) .GT. MMAX(3)) MMAX(3) = YMAX(I) IF (YMIN(I) .LT. MMIN(3)) MMIN(3) = YMIN(I) RESCLE(3) = 1 ELSE C shouldn't be an option, set ot 0 TRANSF(I) = 0 END IF 220 CONTINUE END IF C XTYPE = IDUM(1) YTYPE(1) = IDUM(2) YTYPE(2) = IDUM(3) - 1 IF (RESCLE(1) .EQ. 1) THEN CALL SCALIT (YTYPE(1),MMIN(1),MMAX(1),PLMN(1),PLMX(1)) IF (YTYPE(1) .EQ. 1) TICS(1) = 10 END IF IF (RESCLE(2) .EQ. 1) THEN CALL SCALIT (YTYPE(2),MMIN(2),MMAX(2),PLMN(2),PLMX(2)) IF (YTYPE(2) .EQ. 1) TICS(2) = 10 END IF IF (RESCLE(3) .EQ. 1) THEN CALL SCALIT (XTYPE,MMIN(3),MMAX(3),PLMN(4),PLMX(4)) IF (XTYPE .EQ. 1) TICS(4) = 10 END IF ALEN = 0.0 AGAIN = 0 ELSE IF (IRET .EQ. -1) THEN C "Oops" try again AGAIN = 1 ELSE C assume "Prev" back to modify AGAIN = 0 END IF IF (AGAIN .EQ. 1) GO TO 200 C IF (YTYPE(2) .GT. 0 .AND. RESCLE(2) .EQ. 0) THEN C warning to select curves to put curve on right y-axis SGRP = 16 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL PRNTXT (MESSFL,SCLU,SGRP) END IF END IF C RETURN END C C C SUBROUTINE PINTTL I ( MESSFL, SCLU, WNDNAM ) C C + + + PURPOSE + + + C Allow user to set or modify the plot and axis titles. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL, SCLU CHARACTER*8 WNDNAM(1) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number of the message file C SCLU - cluster number on message file C WNDNAM - keystrokes C C + + + PARAMETERS + + + INTEGER OPTS, TTLS PARAMETER ( OPTS=6, TTLS=5 ) INCLUDE 'ptsmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' C C + + + LOCAL VARIABLES + + + INTEGER SGRP(OPTS), NFLD(OPTS), LENT(OPTS), LFLD(11,OPTS), $ BLEN(TTLS), BROW(TTLS), BLOC(TTLS,OPTS), BLNT(TTLS), $ OPT, RTCMND, LPTH CHARACTER*1 TITLES(468), BLNK C C + + + LOCAL DEFINITIONS + + + C OPT - option for titles C 1 - plot title and left y-axis C 2 - plot title, left y-axis and aux axis C 3 - plot title, left and right y-axis, and aux axis C 4 - plot title and left and right y-axis C 5 - plot title, left y-axis, and x-axis C 6 - plot title, left and right y-axis, and x-axis C NFLD - number of fields for each option C LENT - total length of titles required for each option C LFLD - length of each field for each option C BLEN - length of each row of a title or axis C BROW - number of rows for each title or axis C BLOC - location of the title in the screen buffer C 0 indicates that title not included for the option C C + + + EXTERNALS + + + EXTERNAL PLTITI, PLTITO, OPTNAX EXTERNAL ZIPC EXTERNAL Q1INIT, QSETCT, Q1EDIT, QGETCT, ZWNSOP C C + + + DATA INITIALIZATIONS + + + C DATA SGRP / 101, 102, 103, 104, 105, 106 / DATA NFLD / 5, 9, 11, 7, 7, 9 / DATA LENT / 312, 360, 438, 390, 390, 468 / DATA LFLD / 3*78, 2*39, 6*0, $ 3*78, 2*39, 4*12, 2*0, $ 3*78, 2*39, 2*39, 4*12, $ 3*78, 2*39, 2*39, 4*0, $ 3*78, 2*39, 2*39, 4*0, $ 3*78, 2*39, 2*39, 2*39, 2*0 / C title, left, aux, right, x DATA BLEN / 78, 39, 12, 39, 39 / DATA BROW / 3, 2, 4, 2, 2 / DATA BLNT / 240, 80, 80, 80, 80 / DATA BLOC / 1, 235, 0, 0, 0, $ 1, 235, 313, 0, 0, $ 1, 235, 391, 313, 0, $ 1, 235, 0, 313, 0, $ 1, 235, 0, 0, 313, $ 1, 235, 0, 313, 391 / C C + + + END SPECIFICATIONS + + + C C get option for axis to determine required titles CALL OPTNAX ( XTYPE, YTYPE, ALEN, OPT ) IF (OPT .LT. 1 .OR. OPT .GT. 6) THEN C unknown option, default to most fields OPT = 3 END IF C clean out titles buffer BLNK = ' ' CALL ZIPC ( LENT(5), BLNK, TITLES ) C 100 CONTINUE C stuff current titles into titles buffer, as appropriate C always include plot title and left axis title CALL PLTITI ( BLOC(1,OPT), BROW(1), BLEN(1), BLNT(1), TITL, M TITLES ) CALL PLTITI ( BLOC(2,OPT), BROW(2), BLEN(2), BLNT(2), YLABL, M TITLES ) C include other titles as appropriate for the option IF (BLOC(3,OPT) .NE. 0) THEN C auxilary axis included CALL PLTITI ( BLOC(3,OPT), BROW(3), BLEN(3), BLNT(3), YALABL, M TITLES ) END IF IF (BLOC(4,OPT) .NE. 0) THEN C right axis included CALL PLTITI ( BLOC(4,OPT), BROW(4), BLEN(4), BLNT(4), YXLABL, M TITLES ) END IF IF (BLOC(5,OPT) .NE. 0) THEN C x-axis include CALL PLTITI ( BLOC(5,OPT), BROW(5), BLEN(5), BLNT(5), XLABL, M TITLES ) END IF C C initialize the question and fill in titles LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL Q1INIT ( MESSFL, SCLU, SGRP(OPT) ) CALL QSETCT ( NFLD(OPT), LFLD(1,OPT), LENT(OPT), TITLES ) C C edit the screen CALL Q1EDIT ( RTCMND ) C re-set titles if user OOPSed IF (RTCMND .EQ. -1) GO TO 100 C IF (RTCMND .EQ. 1) THEN C user "Accept"ed screen, get values CALL QGETCT ( NFLD(OPT), LFLD(1,OPT), LENT(OPT), TITLES ) C always include plot title and left axis title CALL PLTITO ( BLOC(1,OPT), BROW(1), BLEN(1), BLNT(1), TITLES, O TITL ) CALL PLTITO ( BLOC(2,OPT), BROW(2), BLEN(2), BLNT(2), TITLES, O YLABL ) C retrieve other titles as appropriate for the option IF (BLOC(3,OPT) .NE. 0) THEN C auxilary axis included CALL PLTITO ( BLOC(3,OPT), BROW(3), BLEN(3), BLNT(3), TITLES, O YALABL ) END IF IF (BLOC(4,OPT) .NE. 0) THEN C right axis included CALL PLTITO ( BLOC(4,OPT), BROW(4), BLEN(4), BLNT(4), TITLES, O YXLABL ) END IF IF (BLOC(5,OPT) .NE. 0) THEN C x-axis include CALL PLTITO ( BLOC(5,OPT), BROW(5), BLEN(5), BLNT(5), TITLES, O XLABL ) ENDIF END IF C RETURN END C C C SUBROUTINE PINSPC I (MESSFL,SCLU,WNDNAM) C C + + + PURPOSE + + + C This routine is called from PROPLT and will allow the user to C input or modify the specifications for each curve including C line type, symbol, pattern, color, and labels for the legend. C Mean or point is included if the plot is a time-series. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL,SCLU CHARACTER*8 WNDNAM(3) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C SCLU - cluster number on message file C WNDNAM - window name C C + + + PARAMETERS + + + INCLUDE 'ptsmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' C C + + + EXTERNALS + + + EXTERNAL PINCTM, PINCXY C C + + + END SPECIFICATIONS + + + C IF (XTYPE .EQ. 0) THEN C time series plot CALL PINCTM ( MESSFL, SCLU, WNDNAM ) ELSE C x-y plot CALL PINCXY ( MESSFL, SCLU, WNDNAM ) END IF C RETURN END C C C SUBROUTINE PINCTM I ( MESSFL, SCLU, WNDNAM ) C C + + + PURPOSE + + + C Allows user to input or modify the specifications for each curve C in a time series plot, including line type, symbol, pattern, color, C mean or point, and labels for the legend. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL,SCLU CHARACTER*8 WNDNAM(1) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C SCLU - cluster number on message file C WNDNAM - KEYSTROKES C C + + + PARAMETERS INCLUDE 'ptsmax.inc' INCLUDE 'pbfmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' INCLUDE 'cplotb.inc' C C + + + LOCAL VARIABLES + + + INTEGER SGRP, AGAIN, INIT, IWRT, IRET, MAXL, SCNFG, $ FLGVT, FLGLS, FLGAY, FLGAN, FLGRY, FLGRN, $ I, J, K, M, L, L1, L20, L80, IC, LPTH, LD(1), $ IDUM(7,3,TSMAX), RESP, TYPE, SCLE REAL R(1,TSMAX) CHARACTER*1 BLNK, BUFF(80,TSMAX), OV(20) C C + + + EXTERNALS + + + EXTERNAL SCALEM EXTERNAL Q1INIT, QSETCO, Q1EDIT, QGETCO, QRESCX, QRESP EXTERNAL ZWNSOP, ZMNSST, ZGTRET, PMXCNW, CHRCHR, ZIPC C C + + + DATA INITIALIZATIONS + + + DATA L1, L20, L80, MAXL, SCNFG, BLNK $ / 1, 20, 80, 10, 1, ' ' / DATA OV /'O','n','l','y',' ','v','a','r','i','a','b','l','e', $ ' ',' ',' ',' ',' ',' ',' '/ C C + + + END SPECIFICATIONS + + + C 100 CONTINUE C legend, line type, color, symbol, shade, mean/point, which axis NCRV = NVAR DO 115 K = 1,NVAR C legend CALL ZIPC (L80,BLNK,BUFF(1,K)) DO 110 I = 1,20 J = I + 42 LBC(I,K) = LBV(I,K) BUFF(J,K) = LBC(I,K) 110 CONTINUE C IDUM(1,1,K) = LNTYP(K)+ 1 IDUM(2,1,K) = COLOR(K)+ 1 IDUM(3,1,K) = SYMBL(K)+ 1 IDUM(4,1,K) = PATTRN(K)+ 1 M = DTYPE(K) IF (M.LT.1 .OR. M.GT.2) M = 1 IDUM(5,1,K) = M M = WHICH(K) IF (M .LT. 1 .OR. M .GT. 3) M = 1 IDUM(6,1,K) = M 115 CONTINUE C 200 CONTINUE LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) IF (NVAR .EQ. 1) THEN C only 1 curve, use prm1 screen (don't need axis & legend) IC = 5 SGRP = 20 CALL Q1INIT ( MESSFL, SCLU, SGRP ) CALL QSETCO ( IC, IDUM ) CALL Q1EDIT ( IRET ) CALL QGETCO ( IC, IDUM ) ELSE C more than 1 curve, use prm2 table screen IC = 7 SGRP = 21 CALL QRESCX (MESSFL,SCLU,SGRP,L1,L1,IC,NVAR,SCNFG, M LD,R,IDUM,BUFF) CALL ZGTRET (IRET) END IF IF (IRET .EQ. -1) THEN C "Oops", try again AGAIN = 2 ELSE IF (IRET .NE. 1) THEN C probably "Prev" (2), back to Modify menu AGAIN = 0 ELSE C user wants to continue, initialize flags FLGVT = 0 FLGLS = 0 FLGAY = 1 FLGAN = 0 FLGRY = 1 FLGRN = 0 DO 225 K = 1,NVAR C convert sequence numbers to match TERM.DAT file LNTYP(K) = IDUM(1,1,K)- 1 COLOR(K) = IDUM(2,1,K)- 1 SYMBL(K) = IDUM(3,1,K)- 1 PATTRN(K)= IDUM(4,1,K)- 1 DTYPE(K) = IDUM(5,1,K) IF (NVAR.GT.1) THEN WHICH(K) = IDUM(6,1,K) IF (WHICH(K) .EQ. 1) THEN C left y-axis TRANSF(K) = YTYPE(1) ELSE IF (WHICH(K) .EQ. 2) THEN C right y-axis TRANSF(K) = YTYPE(2) ELSE IF (WHICH(K) .EQ. 3) THEN C auxiliary axis, always arith TRANSF(K) = 1 END IF DO 220 I=1,20 C legend J = I - 1 + IDUM(7,2,K) LBV(I,K) = BUFF(J,K) LBC(I,K)= BUFF(J,K) 220 CONTINUE ELSE C one variable WHICH(1) = 1 TRANSF(1) = YTYPE(1) CALL CHRCHR (L20,OV,LBV) END IF C set up type of curve IF (CTYPE(K) .NE. 5) THEN C not variable time IF (NVAR .GT. 1) THEN IF (WHICH(K).EQ.3) THEN C for auxilary axis IF (PATTRN(K) .EQ. 1) THEN CTYPE(K)= 4 ELSE CTYPE(K)= 3 END IF ELSE IF (PATTRN(K) .EQ. 1) THEN C bar graph on main axes CTYPE(K)= 2 ELSE C regular plot with lines or symbols CTYPE(K)= 1 END IF ELSE IF (PATTRN(K) .EQ. 1) THEN C bar graph on main axes CTYPE(1)= 2 ELSE C regular plot with lines or symbols CTYPE(1)= 1 END IF END IF ELSE C variable time IF (WHICH(K) .EQ. 3) THEN C variable time can only be plotted on main plot FLGVT = 1 WHICH(K) = 1 CTYPE(K) = 1 END IF END IF C check that values for curve K are ok IF (LNTYP(K).EQ.0 .AND. SYMBL(K).EQ.0) THEN C no line or symbol drawn FLGLS = 1 END IF IF (WHICH(K) .EQ. 3) THEN C there is a variable for the auxilary axis FLGAY = 0 If (ALEN .LT. 0.001) THEN C aux not selected, REVISE TITLES before PLOTTING. FLGAN = 1 END IF ELSE IF (WHICH(K) .EQ. 2) THEN C there is a variable for the right y-axis FLGRY = 0 IF (YTYPE(2) .LT. 1) THEN C right y-axis not previously selected FLGRN = 1 END IF END IF 225 CONTINUE C check for warning and error flags INIT = 1 IWRT = -1 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) IF (FLGVT .EQ. 1) THEN C variable time can only be plotted on main plot SGRP = 30 CALL PMXCNW (MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L) CALL ZMNSST INIT = 0 END IF IF (FLGLS .EQ. 1) THEN C no line or symbol drawn SGRP = 31 CALL PMXCNW (MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L) CALL ZMNSST INIT = 0 END IF IF (FLGAY .EQ. 1 .AND. ALEN .GT. 0.001) THEN C aux axis selected, but no variables SGRP = 32 CALL PMXCNW (MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L) CALL ZMNSST INIT = 0 END IF IF (FLGAN .EQ. 1) THEN C variable for aux axis, but not previously selected SGRP = 33 CALL PMXCNW (MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L) CALL ZMNSST INIT = 0 END IF IF (FLGRY .EQ. 1 .AND. YTYPE(2) .GT. 0) THEN C right y-axis selected, but no variable SGRP = 34 CALL PMXCNW (MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L) CALL ZMNSST INIT = 0 END IF IF (FLGRN .EQ. 1) THEN C variable for right y, but not previously selected SGRP = 35 CALL PMXCNW (MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L) CALL ZMNSST INIT = 0 END IF IF (INIT .EQ. 0) THEN C does the user want to 1-change curves 2-accept defaults SGRP = 36 RESP = 2 CALL QRESP (MESSFL,SCLU,SGRP,RESP) IF (RESP .EQ. 1) THEN C look at curves window again AGAIN = 1 ELSE C go with defaults IF (FLGAY .EQ. 1 .AND. ALEN .GT. 0.001) THEN C don't include aux axis ALEN = 0.0 ELSE IF (FLGAN .EQ. 1) THEN C do include aux axis ALEN = 1.0 TYPE = 1 SCLE = 3 CALL SCALEM ( TYPE, SCLE, NVAR, WHICH, YMIN, YMAX, O PLMN(3), PLMX(3) ) TICS(3) = 2 END IF IF (FLGRY .EQ. 1) THEN C don't include right y-axis YTYPE(2) = 0 ELSE IF (FLGRN .EQ. 1) THEN C do include an arithmetic right y-axis YTYPE(2) = 1 SCLE = 2 CALL SCALEM ( YTYPE(2), SCLE, NVAR, I WHICH, YMIN, YMAX, O PLMN(2), PLMX(2) ) TICS(2) = 10 END IF AGAIN = 0 END IF ELSE C no warning or error messages AGAIN = 0 END IF END IF IF (AGAIN .EQ. 2) GO TO 200 IF (AGAIN .EQ. 1) GO TO 100 C RETURN END C C C SUBROUTINE PINCXY I ( MESSFL, SCLU, WNDNAM ) C C + + + PURPOSE + + + C Allows user to input or mofdify the specifications for each curve C in an x-y plot, including line type, symbol, pattern, color, and C labels for the legend. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL,SCLU CHARACTER*8 WNDNAM(1) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C SCLU - cluster number on message file C WNDNAM - keystrokes C C + + + PARAMETERS INCLUDE 'ptsmax.inc' INCLUDE 'pbfmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' INCLUDE 'cplotb.inc' C C + + + LOCAL VARIABLES + + + INTEGER SGRP, AGAIN, IRET, SCNFG, JUST, LSTAT, $ I, J, K, K1, K2, L, M, LPTH, OLEN, $ C, L0, L1, L2, L3, L8, L20, L40, L78, L80, $ IDUM5(5,3,TSMAX), NX(2,TSMAX) REAL R(2,TSMAX) CHARACTER*1 BLNK, BUFF(80,TSMAX) CHARACTER*78 C78, B78 C C + + + INTRINSICS + + + INTRINSIC MOD C C + + + EXTERNALS + + + EXTERNAL INTCHR, CARVAR, CHRCHR, ZIPC EXTERNAL Q1INIT, QSETI, QSTCOB, Q1EDIT, QGETI, QGTCOB EXTERNAL QRESPI, QRESCX, ZGTRET, ZSTADD, ZSTADQ EXTERNAL ZWNSOP, ZQUIET C C + + + DATA INITIALIZATIONS + + + DATA SCNFG, JUST, BLNK $ / 1, 0, ' ' / DATA L0, L1, L2, L3, L8, L20, L40, L78, L80 $ / 0, 1, 2, 3, 8, 20, 40, 78, 80 / C C + + + END SPECIFICATIONS + + + C IF (NCRV .EQ. 0) THEN C Number of curves? SGRP= 40 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL QRESPI (MESSFL,SCLU,SGRP,NCRV) END IF C 100 CONTINUE C variable on which axes not known, create status block LSTAT = 0 L = 1 DO 140 J= 1,NVAR IF (MOD(J,2) .EQ. 0) THEN K1 = 40 K2 = 54 ELSE K1 = 1 K2 = 14 END IF CALL ZIPC (L40,BLNK,BUFF(K1,1)) CALL INTCHR (J,L8,JUST,OLEN,BUFF(K1,1)) CALL CHRCHR (L20,LBV(1,J),BUFF(K2,1)) CALL CARVAR (L78,BUFF,L78,C78) IF (J .GT. 10) THEN C do nothing L = 10 ELSE IF (J .EQ. NVAR .OR. J .EQ. 10) THEN CALL ZSTADD (L, C78) ELSE IF (MOD(J,2) .EQ. 0) THEN CALL ZSTADQ (L,C78,L0) L = L + 1 END IF 140 CONTINUE LSTAT = L C C # x-axis,# y-axis, left or right, line type, color, C symbol, legend DO 150 K = 1,NCRV CALL ZIPC (L80,BLNK,BUFF(1,K)) C set which variable for which axis IF (WCHVR(1,K).LT.0 .OR. WCHVR(1,K).GT.TSMAX) THEN C not defined, set to defaults WCHVR(1,K)= 1 END IF IF (WCHVR(2,K).LT.0 .OR. WCHVR(2,K).GT.TSMAX) THEN C not defined, set to defaults WCHVR(2,K)= 2 END IF NX(1,K) = WCHVR(2,K) NX(2,K) = WCHVR(1,K) C IF (WHICH(WCHVR(1,K)) .EQ. 2) THEN C right y-axis IDUM5(1,1,K) = 2 ELSE C left y-axis IDUM5(1,1,K) = 1 END IF CALL CHRCHR ( L20, LBC(1,K), BUFF(43,K) ) IDUM5(2,1,K) = LNTYP(K)+ 1 IDUM5(3,1,K) = COLOR(K)+ 1 IDUM5(4,1,K) = SYMBL(K)+ 1 150 CONTINUE C 200 CONTINUE LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) IF (NCRV .EQ. 1) THEN C only 1 curve, use prm1 screen SGRP = 41 CALL Q1INIT (MESSFL, SCLU, SGRP) CALL QSETI (L2,NX) CALL QSTCOB (L1,L1,IDUM5(2,1,1)) CALL QSTCOB (L1,L2,IDUM5(3,1,1)) CALL QSTCOB (L1,L3,IDUM5(4,1,1)) CALL Q1EDIT (IRET) IF (IRET .EQ. 1) THEN CALL QGETI (L2,NX) CALL QGTCOB (L1,L1,IDUM5(2,1,1)) CALL QGTCOB (L1,L2,IDUM5(3,1,1)) CALL QGTCOB (L1,L3,IDUM5(4,1,1)) END IF ELSE C more than 1 curve, use prm2 table screen I = 2 C = 5 SGRP = 42 CALL QRESCX (MESSFL,SCLU,SGRP,I,L1,C,NCRV,SCNFG, M NX,R,IDUM5,BUFF) C get user exit command CALL ZGTRET (IRET) END IF IF (IRET .EQ. -1) THEN C "Oops", try again AGAIN = 2 ELSE IF (IRET .NE. 1) THEN C probably "Prev" (2), back to Modify menu AGAIN = 0 ELSE C user wants to continue AGAIN = 0 DO 260 K = 1,NCRV C L= variable # for x-axis, C M = variable # for y-axis WCHVR(2,K) = NX(1,K) WCHVR(1,K) = NX(2,K) L= WCHVR(2,K) M= WCHVR(1,K) WHICH(L) = 4 TRANSF(WCHVR(2,K)) = XTYPE IF (IDUM5(1,1,K) .EQ.1) THEN C left y-axis WHICH(M) = 1 TRANSF(WCHVR(1,K)) = YTYPE(1) ELSE C right y-axis WHICH(M) = 2 TRANSF(WCHVR(1,K)) = YTYPE(2) END IF LNTYP(K)= IDUM5(2,1,K)- 1 COLOR(K)= IDUM5(3,1,K)- 1 SYMBL(K)= IDUM5(4,1,K)- 1 CTYPE(K)= 6 C IF (NCRV .GT. 1) THEN C uses curve names CALL CHRCHR (L20,BUFF(43,K),LBC(1,K)) END IF 260 CONTINUE C IF (LSTAT .GT. 0) THEN C delete status block CALL ZIPC ( L78, BLNK, B78 ) DO 275 I = 1,LSTAT CALL ZSTADQ(I,B78,L0) 275 CONTINUE CALL ZQUIET END IF END IF IF (AGAIN .EQ. 2) GO TO 200 C go to 100 is here to allow for later addion of checking kmf C such as checking that a curve has a line type or a symbol. IF (AGAIN .EQ. 1) GO TO 100 C RETURN END C C C SUBROUTINE PINSCL I ( MESSFL, SCLU, WNDNAM ) C C + + + PURPOSE + + + C Allow the user to set or modify the scales and the action to be C taken if any points will be off the scale. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL,SCLU CHARACTER*8 WNDNAM(1) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C SCLU - cluster number on message file C WNDNAM - keystrokes C C + + + PARAMETERS + + + INTEGER OPTS PARAMETER ( OPTS=6 ) INCLUDE 'ptsmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' C C + + + LOCAL VARIABLES + + + INTEGER SGRP(OPTS), NFLD(OPTS), LENR(OPTS), LENT(OPTS), $ LENB(OPTS), LNAN(OPTS), LNAL(OPTS), CBAS, $ LENC(OPTS), BLOC(12,OPTS), POS(8,OPTS), BUFC(4), $ IMIN(3), IMAX(3), IDEF(3), DNUM, $ VLINFG(22,OPTS), UCCNT(22,OPTS), UCDEF(7,OPTS), $ USTRLN(22,OPTS), $ AGAIN, LPTH, OPT, CLEN(3), L, K, LEN, LEN20, $ BUFI(3), TYPE, RTCMND REAL RMIN(12), RMAX(12), RDEF(12), MMIN(4), MMAX(4), $ BUFR(12) DOUBLE PRECISION DMIN(1), DMAX(1), DDEF(1) CHARACTER*1 BUFA(60), URSPST(960), BLNK CHARACTER*20 DESCY(2,3), DESCX(3) CHARACTER*48 VBAD C C + + + LOCAL DEFINITIONS + + + C OPT - option for axis included C 1 - left 4 - left & right C 2 - left & aux 5 - left & bottom C 3 - left, right & aux 6 - left, right & bottom C NFLD - number of fields for each option (LENT+LENR+LENC) C LENR - number of real fields for scale and data ranges C LENT - number of fields for tic marks C LENB - number of fields for handling off-scale (bad) values C LNAN - number of fields for axis description C LENC - total number of character fields (LENB+LNAN) C LNAL - total number of characters in axis descriptions C BLOC - location in buffers for scale ranges, tics, and off-scale C POS - location in buffers for data range and axis descriptions C C + + + EXTERNALS + + + EXTERNAL OPTNAX, PLSCLI, SCALIT EXTERNAL ZWNSOP, QSCSET, Q1INIT, Q1EDIT EXTERNAL QSETR, QSETI, QSETCO, QSTCTB EXTERNAL QGETR, QGETI, QGETCO EXTERNAL COPYI, CVARAR, ZIPC C C + + + DATA INITIALIZATIONS + + + DATA SGRP / 111, 112, 113, 114, 115, 116 / DATA NFLD / 8, 14, 20, 14, 16, 22 / DATA LENR / 4, 8, 12, 8, 8, 12 / DATA LENT / 1, 2, 3, 2, 2, 3 / DATA LENB / 2, 2, 2, 2, 4, 4 / DATA LNAN / 1, 2, 3, 2, 2, 3 / DATA LENC / 3, 4, 5, 4, 6, 7 / DATA LNAL / 20, 40, 60, 40, 40, 60 / C <--- plmn ----> <--- tics ----> <--- bvalfg --> C (1) (2) (3) (4) (1) (2) (3) (4) (1) (2) (3) (4) DATA BLOC / 1, 0, 0, 0, 1, 0, 0, 0, 1, 2, 0, 0, $ 1, 0, 3, 0, 1, 0, 2, 0, 1, 2, 0, 0, $ 1, 3, 5, 0, 1, 2, 3, 0, 1, 2, 0, 0, $ 1, 3, 0, 0, 1, 2, 0, 0, 1, 2, 0, 0, $ 1, 0, 0, 3, 1, 0, 0, 2, 1, 2, 3, 4, $ 1, 3, 0, 5, 1, 2, 0, 3, 1, 2, 3, 4 / C <--- mmin ----> <--- desc ----> C (1) (2) (3) (4) (1) (2) (3) (4) DATA POS / 3, 0, 0, 0, 1, 0, 0, 0, $ 5, 0, 7, 0, 1, 0, 21, 0, $ 7, 9, 11, 0, 1, 21, 41, 0, $ 5, 7, 0, 0, 1, 21, 0, 0, $ 5, 0, 0, 7, 1, 0, 0, 21, $ 7, 9, 0, 11, 1, 21, 0, 41 / DATA IMIN, IMAX, IDEF, DNUM, DMIN, DMAX, DDEF $ / 3*0, 3*0, 3*0, 1, 0, 0, 0 / DATA CLEN, LEN20, BLNK $ / 3*20, 20, ' ' / DATA DESCY / '<-- Left-Y arith -->', '<--- Left-Y log --->', $ '<- Right-Y arith -->', '<--- Right-Y log -->', $ '<---- Auxiliary --->', '<---- Auxiliary --->' / DATA DESCX / '<-- X arithmetic -->', '<- X logarithmic -->', $ '<- X probability -->' / DATA VBAD / 'CLIP SKIP ARROW IGNORECLIP SKIP ARROW IGNORE' / C scale tic bound desc range DATA VLINFG / 2*0, 0, 2*1, 0, 2*0, 14*0, $ 4*0, 2*0, 2*1, 2*0, 4*0, 8*0, $ 6*0, 3*0, 2*1, 3*0, 6*0, 2*0, $ 4*0, 2*0, 2*1, 2*0, 4*0, 8*0, $ 4*0, 2*0, 4*1, 2*0, 4*0, 6*0, $ 6*0, 3*0, 4*1, 3*0, 6*0 / C bound desc bound desc DATA UCDEF / 2*4, 0, 4*0, 2*4, 2*0, 3*0, $ 2*4, 3*0, 2*0, 2*4, 2*0, 3*0, $ 4*4, 2*0, 0, 4*4, 3*0 / C bound bound DATA UCCNT / 3*0, 2*4, 17*0, 6*0, 2*4, 14*0, $ 9*0, 2*4, 11*0, 6*0, 2*4, 14*0, $ 6*0, 4*4, 12*0, 9*0, 4*4, 9*0 / C bound bound DATA USTRLN / 3*0, 2*6, 17*0, 6*0, 2*6, 14*0, $ 9*0, 2*6, 11*0, 6*0, 2*6, 14*0, $ 6*0, 4*6, 12*0, 9*0, 4*6, 9*0 / C C + + + END SPECIFICATIONS + + + C C get option for axis to determine required scales CALL OPTNAX ( XTYPE, YTYPE, ALEN, OPT ) C C determine minimum and maximum of all curves on axis DO 150 L = 1, 4 IF (BLOC(L,OPT) .NE. 0) THEN C this axis is include, initialize limits MMIN(L) = 1.0E10 MMAX(L) = -1.0E10 DO 100 K = 1, NVAR IF (WHICH(K) .EQ. L) THEN C variable K is on axis L IF (YMAX(K) .GT. MMAX(L)) MMAX(L) = YMAX(K) IF (YMIN(K) .LT. MMIN(L)) MMIN(L) = YMIN(K) END IF 100 CONTINUE END IF 150 CONTINUE C 200 CONTINUE C handling for off-scale values (1-clip,2-skip,3-arrow,4-ignore) LEN = 960 CALL ZIPC ( LEN, BLNK, URSPST ) LEN = 48 CBAS = 3 CALL CVARAR ( LEN, VBAD, LEN, URSPST ) IF (LENB(OPT) .EQ. 4) THEN C include left and right bounds CBAS = 5 CALL CVARAR ( LEN, VBAD, LEN, URSPST(LEN+1) ) END IF CALL COPYI ( LENB(OPT), BVALFG, BUFC(BLOC(9,OPT)) ) C C always include left y-axis IF (YTYPE(1) .EQ. 1) THEN C arithmatic axis, include tic marks CALL CVARAR ( LEN20, DESCY(1,1), LEN20, BUFA(POS(5,OPT)) ) BUFI(BLOC(5,OPT)) = TICS(1) ELSE C log axis, tic marks not applicable CALL CVARAR ( LEN20, DESCY(2,1), LEN20, BUFA(POS(5,OPT)) ) BUFI(BLOC(5,OPT)) = 0 END IF CALL PLSCLI ( YTYPE(1), BLOC(5,OPT), BLOC(1,OPT), POS(1,OPT), O IMIN, IMAX, IDEF, RMIN, RMAX, RDEF ) C calcualte recommended scale CALL SCALIT ( YTYPE(1), MMIN(1), MMAX(1), PLMN(1), PLMX(1) ) C put recommended scale and actual limits BUFR(BLOC(1,OPT)) = PLMN(1) BUFR(BLOC(1,OPT)+1) = PLMX(1) BUFR(POS(1,OPT)) = MMIN(1) BUFR(POS(1,OPT)+1) = MMAX(1) C IF (BLOC(2,OPT) .NE. 0) THEN C right y-axis is included IF (YTYPE(2) .EQ. 1) THEN C arithmatic axis, includes tic marks CALL CVARAR ( LEN20, DESCY(1,2), LEN20, BUFA(POS(6,OPT)) ) BUFI(BLOC(6,OPT)) = TICS(2) ELSE C log axis, tic marks not applicable CALL CVARAR ( LEN20, DESCY(2,2), LEN20, BUFA(POS(6,OPT)) ) BUFI(BLOC(6,OPT)) = 0 END IF CALL PLSCLI ( YTYPE(2), BLOC(6,OPT), BLOC(2,OPT), POS(2,OPT), O IMIN, IMAX, IDEF, RMIN, RMAX, RDEF ) C calculate recommended scale CALL SCALIT ( YTYPE(2), MMIN(2), MMAX(2), PLMN(2), PLMX(2) ) C put recommended scale and actual limits BUFR(BLOC(2,OPT)) = PLMN(2) BUFR(BLOC(2,OPT)+1) = PLMX(2) BUFR(POS(2,OPT)) = MMIN(2) BUFR(POS(2,OPT)+1) = MMAX(2) END IF C IF (BLOC(3,OPT) .NE. 0) THEN C auxiliary axis is included, always arithmatic CALL CVARAR ( LEN20, DESCY(1,3), LEN20, BUFA(POS(7,OPT)) ) BUFI(BLOC(7,OPT)) = TICS(3) TYPE = 1 CALL PLSCLI ( TYPE, BLOC(7,OPT), BLOC(3,OPT), POS(3,OPT), O IMIN, IMAX, IDEF, RMIN, RMAX, RDEF ) C calculate recommended scale CALL SCALIT ( TYPE, MMIN(3), MMAX(3), PLMN(3), PLMX(3) ) C put recommended scale and actual limits BUFR(BLOC(3,OPT)) = PLMN(3) BUFR(BLOC(3,OPT)+1) = PLMX(3) BUFR(POS(3,OPT)) = MMIN(3) BUFR(POS(3,OPT)+1) = MMAX(3) END IF C IF (BLOC(4,OPT) .NE. 0) THEN C x axis is included IF (XTYPE .EQ. 1) THEN C arithmatic axis, includes tic marks CALL CVARAR ( LEN20, DESCX(1), LEN20, BUFA(POS(8,OPT)) ) BUFI(BLOC(8,OPT)) = TICS(4) ELSE IF (XTYPE .EQ. 2) THEN C log axis, tic marks not applicable CALL CVARAR ( LEN20, DESCX(2), LEN20, BUFA(POS(8,OPT)) ) BUFI(BLOC(8,OPT)) = 0 ELSE C assume probability axis, tic marks not applicable CALL CVARAR ( LEN20, DESCX(3), LEN20, BUFA(POS(8,OPT)) ) BUFI(BLOC(8,OPT)) = 0 END IF CALL PLSCLI ( XTYPE, BLOC(8,OPT), BLOC(4,OPT), POS(4,OPT), O IMIN, IMAX, IDEF, RMIN, RMAX, RDEF ) C calculate recommended scale CALL SCALIT ( XTYPE, MMIN(4), MMAX(4), PLMN(4), PLMX(4) ) C put recommended scale and actual limits BUFR(BLOC(4,OPT)) = PLMN(4) BUFR(BLOC(4,OPT)+1) = PLMX(4) BUFR(POS(4,OPT)) = MMIN(4) BUFR(POS(4,OPT)+1) = MMAX(4) END IF C C set the valid min, max, def for the responses LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL QSCSET ( LENT(OPT), LENR(OPT), DNUM, LENC(OPT), NFLD(OPT), I IMIN, IMAX, IDEF, RMIN, RMAX, RDEF, I DMIN, DMAX, DDEF, I VLINFG(1,OPT), UCCNT(1,OPT), UCDEF(1,OPT), I USTRLN(1,OPT), URSPST ) C C initialize question and fill in current values CALL Q1INIT ( MESSFL, SCLU, SGRP(OPT) ) CALL QSETR ( LENR(OPT), BUFR ) CALL QSETI ( LENT(OPT), BUFI ) CALL QSETCO ( LENB(OPT), BUFC ) CALL QSTCTB ( LNAN(OPT), CLEN, LNAL(OPT), I CBAS, BUFA(POS(5,OPT)) ) C edit the screen CALL Q1EDIT ( RTCMND ) C IF (RTCMND .EQ. -1) THEN C user "Oops"ed, try again AGAIN = 1 ELSE IF (RTCMND .EQ. 1) THEN C user "Accept"ed screen, get user's responses CALL QGETR ( LENR(OPT), BUFR ) CALL QGETI ( LENT(OPT), BUFI ) CALL QGETCO ( LENB(OPT), BUFC ) C C handling for off-scale (bad) values CALL COPYI ( LENB(OPT), BUFC(BLOC(9,OPT)), BVALFG ) C left y-axis is always included TICS(1) = BUFI(BLOC(5,OPT)) PLMN(1) = BUFR(BLOC(1,OPT)) PLMX(1) = BUFR(BLOC(1,OPT)+1) C IF (BLOC(2,OPT) .NE. 0) THEN C right y-axis is included TICS(2) = BUFI(BLOC(6,OPT)) PLMN(2) = BUFR(BLOC(2,OPT)) PLMX(2) = BUFR(BLOC(2,OPT)+1) END IF C IF (BLOC(3,OPT) .NE. 0) THEN C auxiliary axis is included TICS(3) = BUFI(BLOC(7,OPT)) PLMN(3) = BUFR(BLOC(3,OPT)) PLMX(3) = BUFR(BLOC(3,OPT)+1) END IF C IF (XTYPE .GT. 0) THEN C x axis is include TICS(4) = BUFI(BLOC(8,OPT)) PLMN(4) = BUFR(BLOC(4,OPT)) PLMX(4) = BUFR(BLOC(4,OPT)+1) END IF AGAIN = 0 ELSE C user did not "Accept" or "Oops", probably "Prev" AGAIN = 0 END IF IF (AGAIN .EQ. 1) GO TO 200 C RETURN END C C C SUBROUTINE PINEXA I (MESSFL,SCLU,WNDNAM) C C + + + PURPOSE + + + C This routine contains the Extra options to allow the user to add C a block of text to a plot, positon the legend on the plot, and C designate a window to be blanked out so that text can be written C to the plot. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL,SCLU CHARACTER*8 WNDNAM(1) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C SCLU - cluster number on message file C WNDNAM - keystrokes C C + + + PARAMETERS + + + INCLUDE 'ptsmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' C C + + + LOCAL VARIABLES + + + INTEGER RESP, OPT, IDUM(2), SGRP, AGAIN, IRET, LPTH, $ L2, L4, LMAX, LL(2), NL, L1, LGDOPT REAL RDUM(2), TLCLGD(2) C C + + + INTRINSICS + + + INTRINSIC ABS C C + + + EXTERNALS + + + EXTERNAL Q1INIT, QSETR, QSETI, QSETCT EXTERNAL Q1EDIT, QGETR, QGETI, QGETCT, QSETCO, QGETCO EXTERNAL ZWNSOP, QRESP, PRNTXT C C + + + DATA INITIALIZATIONS + + + DATA L1, L2, L4, LMAX, LL $ / 1, 2, 4, 120, 60,60 / C C + + + END SPECIFICATIONS + + + C 50 CONTINUE C Extra option: 1-return,2-text,3-legend,4-blanking LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) IF (XTYPE .GT. 0 .AND. NCRV .GT. 1) THEN C not time plot, include all options SGRP = 70 CALL QRESP ( MESSFL, SCLU, SGRP, RESP ) OPT = RESP ELSE IF (NCRV .GT. 1 .AND. XTYPE .EQ. 0) THEN C time plot, include options 1, 2, and 3, but no blanking SGRP = 71 CALL QRESP ( MESSFL, SCLU, SGRP, RESP ) OPT = RESP ELSE IF (NCRV .LE. 1 .AND. XTYPE .EQ. 1) THEN C include options 1, 2, and 4, but no legend SGRP = 72 CALL QRESP ( MESSFL, SCLU, SGRP, RESP ) OPT = RESP IF (OPT .EQ. 3) OPT = 4 ELSE IF (NCRV .LE. 1 .AND. XTYPE .EQ. 0) THEN C include options 1 and 2, but no legend or blanking SGRP = 73 CALL QRESP ( MESSFL, SCLU, SGRP, OPT ) OPT = RESP END IF IF (OPT .EQ. 2) THEN 200 CONTINUE C adding text, get location and text RDUM(1) = FXT RDUM(2) = FYT IDUM(1) = CPR IF (CPR .NE. 0) THEN IDUM(2) = NCHR/CPR ELSE IDUM(2) = -999 END IF SGRP = 75 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL Q1INIT ( MESSFL, SCLU, SGRP ) CALL QSETR ( L2, RDUM ) CALL QSETI ( L2, IDUM ) CALL QSETCT ( L2, LL, LMAX, CTXT ) CALL Q1EDIT ( IRET ) IF (IRET .EQ. -1) THEN C "Oops", try again AGAIN = 1 ELSE IF (IRET .EQ. 1) THEN C user wants the values CALL QGETR ( L2, RDUM ) CALL QGETI ( L2, IDUM ) NL = IDUM(2) CPR = IDUM(1) NCHR= NL*CPR FXT = RDUM(1) FYT = RDUM(2) CALL QGETCT ( L2, LL, LMAX, CTXT ) C now check it out IF (NCHR .GT. LMAX ) THEN C too many characters, maximum is 120 SGRP = 76 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL PRNTXT ( MESSFL, SCLU, SGRP ) AGAIN = 1 END IF ELSE C assume "Prev"ious AGAIN = 0 END IF IF (AGAIN .EQ. 1) GO TO 200 ELSE IF (OPT .EQ. 3) THEN C set location of legend 300 CONTINUE IF (LOCLGD(1) .LT. -1.9) THEN C legend not to be used so set to default TLCLGD(1)= 0.05 TLCLGD(2)= 0.95 LGDOPT = 3 ELSE IF (LOCLGD(1) .LT. -0.999) THEN C use default legend TLCLGD(1)= 0.05 TLCLGD(2)= 0.95 LGDOPT = 2 ELSE C use current values TLCLGD(1) = LOCLGD(1) TLCLGD(2) = LOCLGD(2) IF (ABS(TLCLGD(1)-0.05).LT. 0.0001 .AND. & ABS(TLCLGD(2)-0.95).LT. 0.0001) THEN C must be default LGDOPT = 2 ELSE C must be custom LGDOPT = 1 END IF END IF SGRP = 77 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL Q1INIT ( MESSFL, SCLU, SGRP ) CALl QSETR ( L2, TLCLGD ) CALL QSETCO ( L1, LGDOPT ) CALL Q1EDIT ( IRET ) IF (IRET .EQ. -1) THEN C "Oops", try again AGAIN = 1 ELSE IF (IRET .EQ. 1) THEN C user wants the values CALL QGETCO (L1, LGDOPT) IF (LGDOPT .EQ. 1) THEN C custom CALL QGETR ( L2, LOCLGD ) ELSE IF (LGDOPT .EQ. 2) THEN C default LOCLGD(1) = 0.05 LOCLGD(2) = 0.95 ELSE C no legend LOCLGD(1) = -2.0 LOCLGD(2) = -2.0 END IF AGAIN = 0 ELSE C assume "Prev"ious AGAIN = 0 END IF IF (AGAIN .EQ. 1) GO TO 300 ELSE IF (OPT .EQ. 4) THEN C define window for blanking 400 CONTINUE SGRP = 78 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL Q1INIT ( MESSFL, SCLU, SGRP ) CALL QSETR ( L4, BLNKIT ) CALL Q1EDIT ( IRET ) IF (IRET .EQ. -1) THEN C "Oops", try again AGAIN = 1 ELSE IF (IRET .EQ. 1) THEN C user wants the values CALL QGETR ( L4, BLNKIT ) AGAIN = 0 ELSE C assume "Prev"ious AGAIN = 0 END IF IF (AGAIN .EQ. 1) GO TO 400 END IF IF (OPT .NE. 1) GO TO 50 C RETURN END C C C SUBROUTINE PINSIZ I (MESSFL,SCLU,WNDNAM, O WNDW) C C + + + PURPOSE + + + C This routine is called from PROPLT and will allow the user to C modify page size, axis lengths, location of origin, and C letter sizes and checks that the sizes are reasonable. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL,SCLU,WNDW CHARACTER*8 WNDNAM(1) C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C SCLU - cluster number on message file C WNDNAM - keystrokes C WNDW - flag for change in size of graphics window C 0 - no change C 1 - changed, need to close and reopen workstatio C C + + + PARAMETERS + + + INCLUDE 'ptsmax.inc' C C + + + COMMOMS + + + INCLUDE 'cplot.inc' C C + + + LOCAL VARIABLES + + + INTEGER SGRP, RESP, RFLG, IR, LPTH, IRET, INIT, AGAIN, MAXL, $ L, NLT, NLX, NLY, L1, L4, L80, L240, CPT, $ K, IWRT REAL RDUM(8), TEMP, YMLEN, OLDWND(4) CHARACTER*1 NXTLNE(1) C C + + + FUNCTIONS + + + INTEGER STRFND C C + + + INTRINSICS + + + INTRINSIC REAL, ABS C C + + + EXTERNALS + + + EXTERNAL STRFND, COPYR EXTERNAL SIZAXE EXTERNAL ZWNSOP, PMXCNW, ZMNSST, QRESP EXTERNAL Q1INIT, QSETR, Q1EDIT, QGETR, ANPRGT C C DATA INITIALIZATIONS DATA L1,L4,L80,L240,NXTLNE,MAXL $ / 1, 4, 80, 240, '&', 10 / C C + + + END SPECIFICATIONS + + + C IF (XLEN .LE. 0.0) THEN C compute default sizes if XLEN not set NLT= 1 NLY= 1 NLX= 1 K = STRFND(L240,TITL,L1,NXTLNE) IF (K.GT.0) NLT= NLT+ 1 K = STRFND(L240-K,TITL(K+1),L1,NXTLNE) IF (K.GT.0) NLT= NLT+ 1 K = STRFND(L80,YXLABL,L1,NXTLNE) IF (K.GT.0) NLX= NLX+ 1 K = STRFND(L80,YLABL,L1,NXTLNE) IF (K.GT.0) NLY= NLY+ 1 CALL SIZAXE (XPAGE,YPAGE,NCRV,CTYPE,YTYPE, M NLT,NLX,NLY, O XLEN,YLEN,SIZEL,XPHYS,YPHYS) END IF C CALL COPYR ( L4, XWINLC, OLDWND ) WNDW = 0 100 CONTINUE C Get axes length, letter size and location of origin. RFLG = 0 RDUM(1) = YPAGE RDUM(2) = XPAGE RDUM(3) = YLEN RDUM(4) = XLEN RDUM(7) = SIZEL RDUM(5) = YPHYS RDUM(6) = XPHYS RDUM(8) = ALEN 150 CONTINUE AGAIN = 0 IF (ALEN .GT. 0.0001) THEN C include auxilary axis IR = 8 SGRP = 80 ELSE C don't include aux axis IR = 7 SGRP = 81 END IF LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL Q1INIT ( MESSFL, SCLU, SGRP ) CALL QSETR ( IR, RDUM ) CALL Q1EDIT ( IRET ) IF (IRET .EQ. -1) THEN C user "Oops"ed, try again AGAIN = 1 ELSE IF (IRET .NE. 1) THEN C user wants out and back to "Prev" AGAIN = 0 ELSE C user has accepted, get the values CALL QGETR ( IR, RDUM ) YPAGE = RDUM(1) XPAGE = RDUM(2) YLEN = RDUM(3) XLEN = RDUM(4) SIZEL = RDUM(7) YPHYS = RDUM(5) XPHYS = RDUM(6) IF (ALEN .GT. 0.0001) ALEN = RDUM(8) C check that values are ok INIT = 1 IWRT = -1 RFLG = 0 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) IF (YLEN+YPHYS .GT. YPAGE) THEN C Origin plus y-axis length too big SGRP = 82 CALL PMXCNW ( MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L ) INIT = -1 RFLG = 1 END IF IF (XLEN+XPHYS .GT. XPAGE) THEN C Origin plus x-axis length too big SGRP = 83 CALL PMXCNW ( MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L ) INIT = -1 RFLG = 1 END IF C estimate space required for y-axis label YMLEN = YPAGE- 1.0- 10.0* SIZEL DO 175 K = 1, NCRV C account for aux axis if appropriate IF (CTYPE(K).EQ.3) YMLEN= YPAGE- ALEN- 1.5* SIZEL 175 CONTINUE IF (SIZEL*40.0.GT.YMLEN) THEN C letter size may be too big for y-axis SGRP = 84 CALL PMXCNW ( MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L ) INIT = -1 END IF IF (ALEN .GT. 0.0001) THEN C check number of tics against aux axis length TEMP = 2.0*SIZEL*REAL(TICS(3)) IF (TEMP .GT. ALEN) THEN C letter size to big for # of tics, reduce size or # tics SGRP = 85 CALL PMXCNW ( MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L ) INIT = -1 END IF END IF C any problems or warnings? IF (RFLG .EQ. 1) THEN C problems with axis lengths must be fixed SGRP = 86 IWRT = 0 CALL PMXCNW ( MESSFL, SCLU, SGRP, MAXL, INIT, IWRT, L ) AGAIN = 1 ELSE IF (INIT .NE. 1) THEN C letter size problems fix them 1-no, 2-yes SGRP = 87 RESP = 1 CALL ZMNSST CALL QRESP ( MESSFL, SCLU, SGRP, RESP ) IF (RESP .EQ. 1) THEN C no, don't fix letters AGAIN = 0 IRET = 1 ELSE C yes, fix letter size AGAIN = 1 END IF END IF END IF IF (AGAIN .EQ. 1) GO TO 150 C IF (IRET .EQ. 1) THEN C set window position if running under X11 CALL ANPRGT (L1, CPT) IF (CPT .EQ. 5 .AND. DEVCOD .EQ. 1100) THEN 200 CONTINUE SGRP = 90 LPTH = 1 CALL ZWNSOP ( LPTH, WNDNAM ) CALL Q1INIT (MESSFL, SCLU, SGRP) CALL QSETR (L4, XWINLC) CALL Q1EDIT (IRET) IF (IRET .EQ. -1) THEN C "Oops", try again AGAIN = 1 ELSE IF (IRET .EQ. 1) THEN C make the change CALL QGETR (L4, XWINLC) AGAIN = 0 ELSE C "Prev" or unknown, presume "Prev" AGAIN = 2 END IF IF (AGAIN .EQ. 1) GO TO 200 END IF END IF IF (AGAIN .EQ. 2) GO TO 100 C C check for change in location of graphics window DO 300 K = 1, 4 IF (ABS(XWINLC(K)-OLDWND(K)) .GE. 0.0001) WNDW = 1 300 CONTINUE C RETURN END C C C SUBROUTINE PSETUP O (RETCOD) C C + + + PURPOSE + + + C This routine, called by DOPLOT, does the level one and two C calls for GKS to set the scales, establish the plotting space, C set the origin, and allow the axes to be labeled by special C routines. The information is read from the users TERM.DAT file C (or uses AIDE system defaults) and call the non-AIDE routine C GSTUPW. Assumes the workstation id is 1. C C + + + KEYWORDS + + + C GKS C C + + + DUMMY ARGUMENTS + + + INTEGER RETCOD C C + + + ARGUMENT DEFINITIONS + + + C RETCOD - return code 0 = everything ok, C 1 = device not setup to plot C C + + + LOCAL VARIABLES + + + INTEGER WSID C C + + + EXTERNALS + + + EXTERNAL PSTUPW C C + + + END SPECIFICATIONS + + + C WSID = 1 C CALL PSTUPW (WSID, RETCOD) C RETURN END C C SUBROUTINE PSTUPW I (WSID, O RETCOD) C C + + + PURPOSE + + + C This routine, called by DOPLOT, does the level one and two C calls for GKS to set the scales, establish the plotting space, C set the origin, and allow the axes to be labeled by special C routines. The information is read from the users TERM.DAT file C (or uses AIDE system defaults) and call the non-AIDE routine C GSTUPW. C C + + + KEYWORDS + + + C GKS C C + + + DUMMY ARGUMENTS + + + INTEGER RETCOD, WSID C C + + + ARGUMENT DEFINITIONS + + + C WSID - workstation (Xwindow) identification number C RETCOD - return code 0 = everything ok, C 1 = device not setup to plot C C + + + PARAMETERS + + + INCLUDE 'ptsmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' C C + + + LOCAL VARIABLES + + + INTEGER IC, PRMIND, FONT, PREC, IMET, I, CLRFRC, & JR, IBLUE, IGREEN, IRED, ICHSP, ICHXP, & BCOLOR, L1, FCOLOR REAL CHXP, CHSP REAL RR, RED(2), GREEN(2), BLUE(2), BCB, BCG, BCR REAL CR,CG,CB, FCR,FCG,FCB CHARACTER*8 CLRSTR logical LTF C C + + + INTRINSICS + + + INTRINSIC REAL, FLOAT, MOD C C + + + EXTERNALS + + + EXTERNAL ANPRGT, GSTUPW, GGTGLA, GSCR, GGDVCD C C + + + DATA INITIALIZATIONS + + + DATA RED,GREEN,BLUE/0.0,1.0,0.0,1.0,0.0,1.0/, L1/1/ C C + + + END SPECIFICATIONS + + + C write(*,*)'PSTUPW: Start' write(*,*)'PSTUPW: TSMAX',TSMAX write(*,*)' NCRV',NCRV write(*,*)' NVAR',NVAR write(*,*)' TICS',TICS write(*,*)' WHICH',WHICH write(*,*)' FE',FE write(*,*)' WCHVR',WCHVR LTF = .FALSE. INQUIRE (UNIT=FE, OPENED=LTF) IF (LTF .EQV. .FALSE.) THEN C file not already open write(*,*)'PSTUPW: FE = ',FE,' NOT OPEN!' ELSE write(*,*)'PSTUPW: FE = ',FE,' IS OPEN!' END IF C find computer type PRMIND = 1 CALL ANPRGT (PRMIND, IC) write(*,*)'PSTUPW: IC ',IC LTF = .FALSE. INQUIRE (UNIT=FE, OPENED=LTF) IF (LTF .EQV. .FALSE.) THEN C file not already open write(*,*)'PSTUPW: FE = ',FE,' NOT OPEN!' ELSE write(*,*)'PSTUPW: FE = ',FE,' IS OPEN!' END IF C C Check for meta files C initialize IMET to 0 (no meta files) IMET = 0 IF (IC.EQ.2 .AND. DEVTYP.EQ.4) THEN C set GKS or CGM meta file code number for Prime IMET = 1 END IF IF (IC.EQ.2 .AND. DEVCOD.EQ.5) THEN C set DISSPLA meta file flags IMET = 1 END IF C C get text font and precision PRMIND = 47 CALL ANPRGT (PRMIND, PREC) PREC = PREC - 1 IF (DEVTYP .EQ. 3) THEN C plotter PRMIND = 48 ELSE IF (DEVTYP .EQ. 2) THEN C printer PRMIND = 49 ELSE C screen PRMIND = 50 END IF CALL ANPRGT (PRMIND, FONT) C C get expansion factor/char spacing from TERM.DAT PRMIND = 103 CALL ANPRGT (PRMIND, ICHXP) PRMIND = 104 CALL ANPRGT (PRMIND, ICHSP) IF (IC .EQ. 2) THEN C spacing and expansion for PRIME with GKS bug CHXP = 1.0 CHSP = 0.2 ELSE C use values from TERM.DAT file for all other systems CHSP = REAL(ICHSP)/100.0 CHXP = REAL(ICHXP)/100.0 END IF C C set background color PRMIND = 101 CALL ANPRGT (PRMIND, BCOLOR) IF (BCOLOR .EQ. 1 .OR. BCOLOR .EQ. 2) THEN C 1 is black, 2 is white, check device code CALL GGDVCD ( DEVCOD) IF (IC .EQ. 5 .AND. BCOLOR .EQ. 1 .AND. DEVCOD .NE. 1100) THEN C special case, DG, non-window device, use white for background BCOLOR = 2 WRITE (99,*) ' Black Background color for non-Xwindow' WRITE (99,*) ' Black background changed to white.' END IF BCR = RED(BCOLOR) BCG = GREEN(BCOLOR) BCB = BLUE(BCOLOR) ELSE C input colors from TERM.DAT file for 'other' color PRMIND = 105 CALL ANPRGT (PRMIND, IRED) PRMIND = 106 CALL ANPRGT (PRMIND, IGREEN) PRMIND = 107 CALL ANPRGT (PRMIND, IBLUE) BCR = REAL(IRED)/100.0 BCG = REAL(IGREEN)/100.0 BCB = REAL(IBLUE)/100.0 END IF C C Set symbol size ratio PRMIND = 102 CALL ANPRGT(PRMIND,JR) RR = REAL(JR)/100.0 C write(*,*)'PSTUPW: calling GSTUPW' LTF = .FALSE. INQUIRE (UNIT=FE, OPENED=LTF) IF (LTF .EQV. .FALSE.) THEN C file not already open write(*,*)'PSTUPW: FE = ',FE,' NOT OPEN!' ELSE write(*,*)'PSTUPW: FE = ',FE,' IS OPEN!' END IF CALL GSTUPW (IC,IMET,PREC,FONT,CHXP,CHSP,BCR,BCG,BCB,RR, & WSID,RETCOD) write(*,*)'PSTUPW: called GSTUPW, RETCOD',RETCOD C C color table (values in table start with index of 0 which C is for the background which is set in GSTUPW C C set axes and label color as index 1 PRMIND = 109 CALL ANPRGT (PRMIND, FCOLOR) C check that don't have white on white or black on black IF (BCOLOR .EQ. 1 .AND. FCOLOR .EQ. 1) THEN C black on black, change index 1 to white FCOLOR = 2 ELSE IF (BCOLOR .EQ. 2 .AND. FCOLOR .EQ. 2) THEN C white on white, change index 1 to black FCOLOR = 1 C ELSE C background is some color other than white or black, C so do nothing END IF C set index 1 FCR = RED(FCOLOR) FCG = GREEN(FCOLOR) FCB = BLUE(FCOLOR) CALL GSCR(WSID,L1,FCR,FCG,FCB) C set LBCOLR to color index 1 LBCOLR = 1 C CLRSTR= 'COLOR ' I= 0 10 CONTINUE C reads term.dat color values and ignores the first two C since they are forground and background previously C defined above I= I+ 1 CALL GGTGLA (CLRSTR,I, O CLRFRC) IF (CLRFRC .GT. 0 .AND. I.GT.2) THEN C update color fraction CR= FLOAT (CLRFRC/65536) /256.0 CG= FLOAT(MOD((CLRFRC/256 ),256))/256.0 CB= FLOAT(MOD( CLRFRC ,256))/256.0 CALL GSCR(WSID,I-1,CR,CG,CB) C WRITE(99,*) 'color:',I-1,' fracs:',CR,CG,CB END IF IF (CLRFRC .GE. 0) GO TO 10 C RETURN END C C C SUBROUTINE DOPLOT I (MESSFL) C C + + + PURPOSE + + + C This routine calls PSETUP to open and activate the workstation, C calls PLTONE to make the plot, and calls PDNPLT to deactivate C and close the workstation. This routine should only be called when C using the interactive AIDE routines. For the PRIME with DISSPLA, C GKS is closed and opened because of bugs in that implementation. C C + + + DUMMY ARGUMENTS + + + INTEGER MESSFL C C + + + ARGUMENT DEFINITIONS + + + C MESSFL - Fortran unit number for message file C C + + + LOCAL VARIABLES + + + INTEGER RETCOD,IWAIT,SCLU,SGRP,ICLOS,WSID C C + + + EXTERNALS + + + EXTERNAL PSETUP, PLTONE, PRNTXT, PDNPLT C C + + + END SPECIFICATIONS + + + C SCLU= 32 C C set up the plotting area, open workstation CALL PSETUP (RETCOD) C IF (RETCOD .EQ. 0) THEN C make a plot CALL PLTONE ELSE C couldn't accept device C Could not get GKS or device, review ERROR.FIL SGRP = 140 CALL PRNTXT (MESSFL, SCLU, SGRP) END IF C C close work stations ICLOS = 1 IWAIT = 1 WSID = 1 CALL PDNPLT (WSID,ICLOS,IWAIT) C RETURN END C C C SUBROUTINE PDNPLT I (WSID, ICLOS, M IWAIT) C C + + + PURPOSE + + + C This routine deactivates a workstation and closes a workstation C depending on the value of ICLOS. It checks for computer type C (AIDE dependent) and does additional shutdowns necessary for C the PC and PRIME with DISSPLA. C C + + + DUMMY ARGUMENTS + + + INTEGER IWAIT, WSID, ICLOS C C + + + ARGUMENT DEFINITIONS + + + C WSID - workstation id number (usually 1 unless multiple C Xwindows are used C ICLOS - flag to close workstation. Not used for PRIME or PC's C 0 - do not close the workstation C 1 - close the workstation C IWAIT - set to 1 to require the user to press return before C plot device deactivated (and closed depending on ICLOS), C else set to 0. C C + + + PARAMETERS + + + INCLUDE 'ptsmax.inc' C C + + + COMMONS + + + INCLUDE 'cplot.inc' C C + + + LOCAL VARIABLES + + + INTEGER I1, IC, IMET C C + + + EXTERNALS + + + EXTERNAL ANPRGT, DNPLTW C C + + + END SPECIFICATIONS + + + C C find computer type I1 = 1 CALL ANPRGT (I1, IC) C IMET = 0 IF (IC .EQ. 2 .AND. DEVTYP .GE. 4) IMET = 1 C C force IWAIT IF (IC .LE. 3 .AND. DEVTYP .EQ. 1) IWAIT = 1 C CALL DNPLTW (IWAIT,WSID,ICLOS,IC,IMET) C RETURN END C C C SUBROUTINE GPOPEN O (FE) C C + + + PURPOSE + + + C This routine calls the routine to open the GKS error file, C 'error fil', and opens GKS. It also calls routines to set C AIDE global variables. C C + + + DUMMY ARGUMENTS + + + INTEGER FE C C + + + ARGUMENT DEFINITIONS + + + C FE - Fortran unit number of GKS error file C C + + + LOCAL VARIABLES + + + INTEGER*4 APRMGP C C + + + EXTERNALS + + + EXTERNAL GBOPEN, GLVINI C C + + + END SPECIFICATIONS + + + C C call base gks open routine CALL GBOPEN O (FE) C C get global info on colors APRMGP= 120 CALL GLVINI (APRMGP) C get global info on line types APRMGP= 121 CALL GLVINI (APRMGP) C get global info on symbols APRMGP= 122 CALL GLVINI (APRMGP) C get global info on fills APRMGP= 123 CALL GLVINI (APRMGP) C RETURN END