C FILE: PLTLC C This file contains the interface between MICRSOCOPE and C to be used if lower case letters are available. SUBROUTINE SUBPL(ITYPE,INPUT,NCALLS) INTEGER I, J, NN INTEGER ICHAR(72), NCALLS, ITEMP(9), ITYPE INTEGER IOUT, INPUT LOGICAL OK, LOGCNT REAL W, X, FR, SZ REAL DSZ INTEGER LCHN COMMON / LOG / LCHN INTEGER OUTPUT, LINES, WIDTH, ILP INTEGER IDSPLA, IPRMPT LOGICAL LSCRN COMMON / SCREEN / OUTPUT, LINES, WIDTH, ILP COMMON / SCREEN / IDSPLA, IPRMPT, LSCRN INTEGER ITITLE, IBOTTM, NUMBR, BL INTEGER BR LOGICAL FRAME, COLOR, NUMRCL, LMARK LOGICAL LBLS, DATE, TIME COMMON / PLOWN / ITITLE(72), IBOTTM(72), NUMBR, FRAME COMMON / PLOWN / COLOR, NUMRCL, LMARK, LBLS COMMON / PLOWN / DATE, TIME, BL(72), BR(72) C DATA SZ /0.018/ DATA FR /0.93/ C INDICATE THAT SCREEN HAS BEEN OVERWRITTEN LSCRN = .FALSE. ITYPE = 3 C INITIALIZE CONTROL OF LOGGING - IF LOGGING IS REQUIRED, THEN ONLY C THE FINAL DESCRIPTION OF PLOT OPTIONS IS PRINTED INTO THE LOG CHANNEL C IOUT = OUTPUT LOGCNT = .FALSE. 100 CONTINUE CALL BLSCRN(OUTPUT) CALL PCURSR(OUTPUT,1,1) 200 CONTINUE WRITE (IOUT,18000) WRITE (IOUT,20000) (ITITLE(I),I=1,72) WRITE (IOUT,22000) (IBOTTM(I),I=1,72) IF (LBLS) WRITE (IOUT,24000) IF (.NOT.LBLS) WRITE (IOUT,26000) IF (LMARK) WRITE (IOUT,28000) IF (.NOT.LMARK) WRITE (IOUT,30000) IF (COLOR) WRITE (IOUT,32000) IF (.NOT.COLOR) WRITE (IOUT,34000) IF (NUMBR.EQ.0) WRITE (IOUT,36000) IF (NUMBR.NE.0) WRITE (IOUT,38000) NUMBR WRITE (IOUT,40000) (BL(I),I=1,20) WRITE (IOUT,42000) (BR(I),I=1,20) IF (DATE) WRITE (IOUT,44000) IF (.NOT.DATE) WRITE (IOUT,46000) IF (TIME) WRITE (IOUT,50000) IF (.NOT.TIME) WRITE (IOUT,48000) IF (NUMRCL) WRITE (IOUT,52000) IF (.NOT.NUMRCL) WRITE (IOUT,54000) IF (.NOT.FRAME) WRITE (IOUT,56000) IF (FRAME) WRITE (IOUT,58000) IF (LOGCNT) GO TO 2900 300 CONTINUE WRITE (OUTPUT,60000) 400 CONTINUE CALL SIREAD(INPUT,NN,OK) IF (OK) GO TO 500 WRITE (OUTPUT,62000) GO TO 400 500 CONTINUE IF (NN.EQ.0) GO TO 2000 IF (NN.LT.0) GO TO 2800 IF (NN.GT.12) GO TO 300 GO TO (600,700,800,900,1000,1100,1400,1500,1600,1700,1800,1900),NN 600 CONTINUE WRITE (OUTPUT,64000) READ (INPUT,66000) (ITITLE(J),J=1,72) GO TO 100 700 CONTINUE WRITE (OUTPUT,68000 ) READ (INPUT,66000) (IBOTTM(J),J=1,72) GO TO 100 800 CONTINUE LBLS = .NOT.LBLS GO TO 100 900 CONTINUE LMARK = .NOT.LMARK GO TO 100 1000 CONTINUE COLOR = .NOT.COLOR GO TO 100 1100 CONTINUE WRITE (OUTPUT,12000) 1200 CONTINUE CALL SIREAD(INPUT,NN,OK) IF (OK) GO TO 1300 WRITE (OUTPUT,62000) GO TO 1200 1300 CONTINUE NUMBR = NN GO TO 100 1400 CONTINUE WRITE (OUTPUT,14000) READ (INPUT,66000) (BL(I),I=1,20) GO TO 100 1500 CONTINUE WRITE (OUTPUT,16000) READ (INPUT,66000) (BR(I),I=1,20) GO TO 100 1600 CONTINUE DATE = .NOT.DATE GO TO 100 1700 CONTINUE TIME = .NOT.TIME GO TO 100 1800 CONTINUE NUMRCL = .NOT.NUMRCL GO TO 100 1900 CONTINUE FRAME = .NOT.FRAME GO TO 100 2000 CONTINUE CALL PLT00 IF (.NOT.FRAME) GO TO 2100 CALL PLTVF GO TO 2200 2100 CONTINUE W = 8.5/11. CALL SETVP2(0.5/11.,8./11.,0.5/11.,10.5/11.) 2200 CONTINUE CALL SYMSF(5HUCCR1,1H;) IF (COLOR) CALL SETPEN(1) CALL SYMJU(6HCENTER,6HBOTTOM) IF (NUMBR.EQ.0) GO TO 2300 X = 0.5 DSZ = 2.0*SZ CALL SYMSZ(1.4,DSZ) CALL DRWINT(NUMBR,X,0.01,.FALSE.) 2300 CONTINUE CALL MOVA2(0.5,0.08) CALL SYMSZ(1.4,SZ) CALL KARPAK(ICHAR,1,IBOTTM,72) CALL SYMEX(ICHAR,1,72,W) IF (W.LE.FR) GO TO 2400 W = SZ/W*FR CALL SYMSZ(1.4,W) 2400 CONTINUE CALL SYMTX(ICHAR,1,72) CALL MOVA2(0.5,0.93) CALL SYMSZ(1.4,SZ) CALL KARPAK(ICHAR,1,ITITLE,72) CALL SYMEX(ICHAR,1,72,W) IF (W.LE.FR) GO TO 2500 W = SZ/W*FR CALL SYMSZ(1.4,W) 2500 CONTINUE CALL SYMTX(ICHAR,1,72) CALL PLT(NCALLS,LBLS,LMARK,COLOR,NUMRCL) CALL SETVP2(0.385/11.,8.115/11.,0.385/11.,10.615/11.) CALL SYMSZ(1.4,SZ*0.6) CALL SYMJU(4HLAST,3HTOP) IF (.NOT.DATE) GO TO 2600 CALL UTIDA(ITEMP) CALL KARPAK(ICHAR,1,ITEMP,9) CALL MOVA2(1.,1.) CALL SYMTX(ICHAR,1,9) 2600 CONTINUE IF (.NOT.TIME) GO TO 2700 CALL MOVA2(0.,1.) CALL SYMJU(5HFIRST,3HTOP) CALL UTITI(ITEMP) CALL KARPAK(ICHAR,1,ITEMP,8) CALL SYMTX(ICHAR,1,8) 2700 CONTINUE CALL MOVA2(0.,0.) CALL KARPAK(ICHAR,1,BL,20) CALL SYMJU(5HFIRST,6HBOTTOM) CALL SYMTX(ICHAR,1,20) CALL MOVA2(1.,0.) CALL KARPAK(ICHAR,1,BR,20) CALL SYMJU(4HLAST,6HBOTTOM) CALL SYMTX(ICHAR,1,20) CALL PLTEJ 2800 CONTINUE IF (LCHN.EQ.0) GO TO 2900 IOUT = LCHN LOGCNT = .TRUE. WRITE (IOUT,10000) GO TO 200 2900 CONTINUE RETURN 10000 FORMAT(/40H leaving PLOT79 interface - parameters: ) 12000 FORMAT(21H give new page number) 14000 FORMAT(28H give new bottom left label:) 16000 FORMAT(29H give new bottom right label:) 18000 FORMAT X(/20X,15H Preparing Plot/) 20000 FORMAT(15H 1: Title is:/1H ,72A1) 22000 FORMAT(16H 2: Legend is:/1H ,72A1) 24000 FORMAT(30H 3: Graphs are being labeled) 26000 FORMAT(34H 3: Graphs are not being labeled) 28000 FORMAT(29H 4: Graphs are being marked) 30000 FORMAT(33H 4: Graphs are not being marked) 32000 FORMAT(50H 5: The plot is in color (if hardware supported)) 34000 FORMAT(36H 5: The plot is in black and white) 36000 FORMAT(39H 6: Currently no page number is drawn) 38000 FORMAT(29H 6: Current page number is ,I15) 40000 FORMAT(27H 7: Bottom left label is:/1H ,20A1) 42000 FORMAT(28H 8: Bottom right label is:/1H ,20A1) 44000 FORMAT(39H 9: Date is shown in top right corner) 46000 FORMAT(22H 9: No date is shown) 48000 FORMAT(23H 10: Time is not shown) 50000 FORMAT(38H 10: Time is shown in top left corner) 52000 FORMAT(36H 11: Numerical information is drawn) 54000 FORMAT(38H 11: Numerical information is omitted) 56000 FORMAT(39H 12: No frame is drawn around the plot) 58000 FORMAT(38H 12: A frame is drawn around the plot) 60000 FORMAT(//36H Write reference number for changes, X /50H 0 for plot generation, or negative number to exit) 62000 FORMAT(35H Number not recognized - try again ) 64000 FORMAT(13H Give Title: ) 66000 FORMAT(72A1) 68000 FORMAT(13H Give Legend ) END SUBROUTINE CHKHLS(LFOUND,GRID,X1,X2,Y1,X,Y) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C ROUTINE: CHKHLS C PURPOSE: TO CHECK THE HORIZONTAL LINE SEGMENT BEGINNING AT (X1,Y1) C AND ENDING AT (X2,Y1) IN THE GRID()ARRAY TO FIND THE FIRST C AVAILABLE BLANK REGION. IF FOUND, THE LOGICAL VARIABLE C LFOUND HAS VALUE .TRUE. AND THE COORDINATES OF THE LOWER C LEFT HAND CORNER OF THE BLANK SQUARE REGION IS RETURNED C IN (X,Y). C LOGICAL CHKSQR INTEGER I, X, Y, X1 INTEGER Y1, X2, IP INTEGER GRID(139,59) LOGICAL LFOUND LFOUND = .FALSE. DO 100 I = X1,X2 IP = I IF ( CHKSQR(GRID,IP,Y1) ) GO TO 100 X = IP Y = Y1 LFOUND = .TRUE. GO TO 200 100 CONTINUE 200 RETURN END C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C ROUTINE: CHKSQR C PURPOSE: A LOGICAL FUNCTION TO CHECK IF THE 4 ELEMENT SQUARE REGION C IN THE GRID() ARRAY WITH LOWER LEFT CORNER (X,Y) IS ALL C BLANKS. C LOGICAL FUNCTION CHKSQR(GRID,X,Y) INTEGER GRID(139,59), X, Y, BLANK DATA BLANK / 1H / CHKSQR = .FALSE. IF (GRID(X,Y).NE.BLANK .OR. GRID(X+1,Y).NE.BLANK .OR.GRID(X,Y+1) X .NE.BLANK .OR. GRID(X+1,Y+1).NE.BLANK ) CHKSQR = .TRUE. RETURN END SUBROUTINE CHKVLS(LFOUND,GRID,X1,Y1,Y2,X,Y) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C ROUTINE: CHKVLS C PURPOSE: TO CHECK THE VERTICAL LINE SEGMENT BEGINNING AT (X1,Y1) AND C ENDING AT (X1,Y2) IN THE GRID() ARRAY TO FIND THE FIRST C AVAILABLE BLANK REGION. IF FOUND, THE LOGICAL VARIABLE C LFOUND HAS VALUE .TRUE. AND THE COORDINATES OF THE LOWER C LEFT HAND CORNER OF THE BLANK SQUARE REGION IS RETURNED C IN (X,Y). C LOGICAL CHKSQR INTEGER I, X, Y, X1 INTEGER Y1, Y2, IP INTEGER GRID(139,59) LOGICAL LFOUND LFOUND = .FALSE. DO 100 I = Y1,Y2 IP = I IF ( CHKSQR(GRID,X1,IP) ) GO TO 100 X = X1 Y = IP LFOUND = .TRUE. GO TO 200 100 CONTINUE 200 RETURN END SUBROUTINE CONLIN(X,Y,DX,DY,X2,Y2,HEIGHT) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C ROUTINE: CONLIN C PURPOSE: TO DETERMINE THE END COORDINATES OF THE CONNECTING LINE C BETWEEN THE PLOTTED CURVE AND ITS LABEL. C REAL SQRT REAL X, Y, X2, Y2 REAL DX, UX, DY, UY REAL HEIGHT, DIST DIST = SQRT(DX*DX+DY*DY) UX = DX/DIST UY = DY/DIST X2 = X-HEIGHT*UX Y2 = Y-HEIGHT*UY RETURN END SUBROUTINE DRWINT(M,X,Y,BLANK) C Draw the integer M at the point (X,Y), add a blank if BLANK.EQ..TRUE C and increase x as needed INTEGER M REAL X,Y LOGICAL BLANK INTEGER CHAR(72),N CALL INUMBR(N,CHAR,M) CALL DRWSTR(CHAR,N,X,Y,BLANK) RETURN END SUBROUTINE DRWRL(F,NDEC,X,Y,BLANK) C Draw the real number F with NDEC digits, at the point (X,Y), adding a C blank if appropriate, and increase x REAL F,X,Y LOGICAL BLANK INTEGER CHAR(72),N,NDEC CALL FNUMBR(N,CHAR,NDEC,F) CALL DRWSTR(CHAR,N,X,Y,BLANK) RETURN END SUBROUTINE DRWRLB(F,NDEC,X,Y,BLANK) C Draw the real number F with NDEC digits, at the point (X,Y), adding a C blank if appropriate, and decrease x REAL F,X,Y LOGICAL BLANK INTEGER CHAR(72),N,NDEC CALL FNUMBR(N,CHAR,NDEC,F) CALL DRWSTB(CHAR,N,X,Y,BLANK) RETURN END SUBROUTINE DRWSTB(STRING,LENGTH,X,Y,BLANK) C Draw the STRING of LENGTH at the point (X,Y), add a BLANK if appropria C and decrease x INTEGER STRING(72),LENGTH,CHAR(72) REAL X,Y,W LOGICAL BLANK CALL MOVA2(X,Y) CALL SYMTX(STRING,1,LENGTH) CALL SYMEX(STRING,1,LENGTH,W) W = -W CALL MOVR2(W,0.) IF (BLANK) CALL PBLNKB(X) X = X + W RETURN END SUBROUTINE DRWSTR(STRING,LENGTH,X,Y,BLANK) C Draw the STRING of LENGTH at the point (X,Y), add a BLANK if appropria C and increase x INTEGER STRING(72),LENGTH,CHAR(72) REAL X,Y,W LOGICAL BLANK CALL MOVA2(X,Y) CALL SYMTX(STRING,1,LENGTH) CALL SYMEX(STRING,1,LENGTH,W) CALL MOVR2(W,0.) IF (BLANK) CALL PBLNK(X) X = X + W RETURN END SUBROUTINE FNDSPT(IGRID,JGRID,GRID,X,Y,IX,IY) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C ROUTINE: FNDSPT C PURPOSE: TO SEARCH THE GRID() ARRAY ABOUT THE (X'TH, Y'TH) ELEMENT C FOR THE FIRST AVAILABLE BLANK REGION FOR WHICH A NUMERICAL C LABEL CAN BE PLACED. THE LOWER LEFT HAND CORNER OF THIS C REGION IS RETURNED IN THE VARIABLES (IX,IY). C C NOTE: IF NO REGION CAN BE FOUND THE RETURN POSITION: (IX,IY) IS C THE POSITION: (X,Y). THAT IS, THE LABEL WILL PLOT C DIRECTLY ON TOP OF THE CURVE. C INTEGER MIN0, MAX0 INTEGER X, Y, IC, JC INTEGER IX, IY, IXP, JXP INTEGER GRID(139,59),ILEFT, IRIGHT, IGRID INTEGER IGRIDP, JGRID, JGRIDP, JTOP INTEGER JBOT LOGICAL LFOUND C IX = X IY = Y IGRIDP = IGRID-1 JGRIDP = JGRID-1 IC = X-1 JC = Y-1 ILEFT = MAX0(IC-3,1) IRIGHT = MIN0(IC+4,IGRIDP) JTOP = MIN0(JC+3,JGRIDP) JBOT = MAX0(JC-3,1) C C START SEARCH AT LOWER RIGHT HAND CORNER. SPIRAL OUTWARD FROM THERE. C 100 IF ( JTOP.LT.JGRIDP ) JTOP = JTOP+1 CALL CHKVLS(LFOUND,GRID,IRIGHT,JBOT,JTOP,IX,IY) IF ( LFOUND ) GO TO 200 IF ( ILEFT.GT.1 ) ILEFT = ILEFT-1 IXP = IRIGHT-1 CALL CHKHLS(LFOUND,GRID,ILEFT,IXP,JTOP,IX,IY) IF ( LFOUND ) GO TO 200 IF ( JBOT.GT.1 ) JBOT = JBOT-1 JXP = JTOP-1 CALL CHKVLS(LFOUND,GRID,ILEFT,JBOT,JXP,IX,IY) IF ( LFOUND ) GO TO 200 IF ( IRIGHT.LT.IGRIDP ) IRIGHT = IRIGHT+1 IXP = ILEFT+1 CALL CHKHLS(LFOUND,GRID,IXP,IRIGHT,JBOT,IX,IY) IF ( LFOUND ) GO TO 200 GO TO 100 200 RETURN END SUBROUTINE FNUMBR(N,CHAR,NDEC,F) C Transform the real number F into a string CHAR of length N. Incorpora C NDEC digits. REAL ABS INTEGER IABS INTEGER IPERD, IZERO REAL F, FA INTEGER N, ND, NDD, ONE INTEGER TCHAR(25), NDEC, CHAR(1), NBASE DATA IZERO /1H0/,IPERD /1H./ DATA ONE /1/ IF (F.EQ.0.0) GO TO 300 ND = IABS(NDEC) FA = ABS(F) IF (FA.LT.0.01.OR.FA.GT.100.) GO TO 100 NDD = -(ND+1) IF (FA.GT.0.1) NDD = NDD + 1 IF (FA.GT.1.) NDD = NDD + 1 IF (FA.GT.10.) NDD = NDD + 1 IF (FA.GT.0.0D0) FA = 0 GO TO 200 100 CONTINUE NDD = ND-1 200 CONTINUE IF (NDD.LT.0) N = NDEC+4 IF (NDD.GT.0) N = NDEC+8 NBASE = 10 ONE = 1 CALL UTICF(TCHAR,F,N,NDD,NBASE) GO TO 400 300 CONTINUE TCHAR(1) = IZERO TCHAR(2) = IPERD TCHAR(3) = IZERO N = 3 400 CONTINUE CALL KARPAK(CHAR,ONE,TCHAR,N) RETURN END SUBROUTINE INUMBR(N,CHAR,M) C Transform the integer M into a packed string CHAR of length M REAL ALOG10 INTEGER INT, IABS REAL FLOAT INTEGER I, M, N, ONE INTEGER TCHAR(20), CHAR(1), IZERO, NBASE LOGICAL PAD DATA IZERO /1H0/ DATA ONE /1/ IF (M.EQ.0) GO TO 100 IF (M.NE.0) N = INT(ALOG10(FLOAT(IABS(M))))+2 PAD = .FALSE. NBASE = 10 CALL UTICI(TCHAR,M,PAD,N,NBASE) GO TO 200 100 CONTINUE TCHAR(1) = IZERO N = 1 200 CONTINUE CALL KARPAK(CHAR,ONE,TCHAR,N) RETURN END SUBROUTINE MARKA2(L,X,Y) C Mark point (x,y) if L .EQ..TRUE. LOGICAL L REAL X,Y IF (L) CALL MRKA2(X,Y) RETURN END SUBROUTINE PBLNK(X) C Draw a blank and increase x REAL BLNK,ZERO,X DATA ZERO /0.0/ CALL SYMEX(1HZ,1,1,BLNK) CALL MOVR2(BLNK,ZERO) X = X + BLNK RETURN END SUBROUTINE PBLNKB(X) C Draw a blank and decrease x REAL BLNK,ZERO,X DATA ZERO /0.0/ CALL SYMEX(1HZ,1,1,BLNK) BLNK = -BLNK CALL MOVR2(BLNK,ZERO) X = X + BLNK RETURN END SUBROUTINE PLMXMN(NDER,XX,Y,LMARK) C C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C ROUTINE: PLMXMN C PURPOSE: TO PLOT A SINGLE MINIMUM AND MAXIMUM, CORRESPONDING TO THE C (NDER-1)'TH DERIVATIVE, STARTING AT POSITION (X,Y). C REAL SNGL INTEGER K, N, I1, NDEC INTEGER CHAR(10), NDER LOGICAL LMARK REAL F, X, Y, X1 REAL X2, X3, X4, X5 REAL X6, XX DOUBLE PRECISION XS, FS, DF, DFMNMX COMMON / FUNCOM / XS(5377), FS(5377), DF(135,7) COMMON / FUNCOM / DFMNMX(2,7) DOUBLE PRECISION ROPDI, ROPPNT, ROPDR1, ROPDR2 DOUBLE PRECISION ROPSTS, ROPSTW, ROPUDI INTEGER NH, NW, ILEFT, IRIGHT INTEGER IOPDM, IOPSH, IOPSS, IOPWN LOGICAL OPDC, OPDS, OPDX, OPCMP LOGICAL OPSPL, OPDF1, OPDF2 COMMON / OPTION / ROPDI(3,2), ROPPNT(3,2), ROPDR1(3,2) COMMON / OPTION / ROPDR2(3,2), ROPSTS(2), ROPSTW(2) COMMON / OPTION / ROPUDI(3,2), NH(2), NW(2) COMMON / OPTION / ILEFT(2), IRIGHT(2), IOPDM(2) COMMON / OPTION / IOPSH(2), IOPSS(2), IOPWN(2), OPDC(2) COMMON / OPTION / OPDS(2), OPDX(2), OPCMP(2) COMMON / OPTION / OPSPL(2), OPDF1(7,2), OPDF2(7,2) DATA I1 / 1 / NDEC = 4 X = XX CALL DRWSTR(1HF,1,X,Y,.FALSE.) K = NDER-1 CALL DRWINT(K,X,Y,.TRUE.) CALL PBLNK(X) IF (.NOT.LMARK) GO TO 100 CALL SETMS(NDER) IF (OPDF2(NDER,2)) CALL SETMSZ(1.0) CALL MRKR2(0.,0.008) CALL PBLNK(X) CALL SETMSZ(0.5) 100 CONTINUE CALL DRWSTR(1H(,1,X,Y,.FALSE.) F = SNGL(DFMNMX(1,NDER)) CALL DRWRL(F,NDEC,X,Y,.FALSE.) CALL DRWSTR(1H,,1,X,Y,.TRUE.) F = SNGL(DFMNMX(2,NDER)) CALL DRWRL(F,NDEC,X,Y,.FALSE.) CALL DRWSTR(1H),1,X,Y,.TRUE.) RETURN END SUBROUTINE PLT(NCALLS,LBLS,LMARK,COLOR,NUMRCL) C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C C ROUTINE: PLT C PURPOSE: THIS ROUTINE IS CALLED BY THE SUBPL ROUTINE. C IT PLOTS THE SPECIFIED DERIVATIVES AND DISPLAYS THE C NUMERICAL DATA AT THE BOTTOM OF THE PLOT. IT USES THE C IPLOT() AND ISCRN2() ARRAYS SET UP BY THE SGRUPD ROUTINE. C C OUTLINE OF ALGORITHM: C C (1) SET UP THE GRID() ARRAY (IT IS USED TO FIND THE PLACES FOR C LABELS TO THE CURVES) BY COPYING THE ISCRN2() ARRAY INTO C ITS INTERIOR AND SETTING THE BORDER (2 ELEMENTS THICK) C AROUND THE LEFT, TOP, AND RIGHT, TO BLANKS. C C (2) INITIALIZE THE PLOTTING, DRAW A UNIT BOX, AND DRAW THE C WINDOW. C C (3) DEAL WITH THE FOLLOWING PLOTTING OPTIONS IN ORDER: C OPDX DRAW X-AXIS C OPDS DRAW SCALE ALONG X-AXIS C OPDC MARK THE CENTER OF THE PLOT C C (4) SCALE UP AND PLOT THE SPECIFIED CURVES, MARKING THE DATA C POINTS WITH SMALL CIRCLES. IF ANY CURVES ARE TO BE C ACCENTUATED, MARK THE CORRESPONDING DATA POINTS WITH C ASTERISKS (MARKNO = 3). C C (5) FIND THE BEST PLACES AT WHICH TO LABEL THE VARIOUS CURVES. C DO THIS BY FINDING THE ABSCISSA AT WHICH THE DERIVATIVE C TO BE PLOTTED IS SEPARATED THE MOST FROM THE OTHER C DERIVATIVES TO BE PLOTTED. (DO THIS BY LOOKING AT THE C IPLOT() ARRAY) C C (6) ONCE FOUND, SEARCH THE GRID() ARRAY FOR AN UNUSED REGION C IN WHICH TO PLACE THE NUMERICAL LABEL OF THE CURVE. USE C FNDSPT (FIND SPOT) TO LOCATE THIS REGION. ONCE IT IS C FOUND, DETERMINE THE ENDPOINTS OF THE LINE SEGMENT CON- C NECTING THE CURVE TO THE NUMERICAL LABEL, PLOT THIS C 'CONNECTOR' AND THE LABEL. THEN MARK THE CORRESPONDING C REGION IN THE GRID() ARRAY SO THAT OTHER LABELS ARE NOT C WRITTEN OVER IT. C C (7) DISPLAY THE DATA AT THE BOTTOM OF THE PLOT C C INTEGER IABS REAL FLOAT, SNGL INTEGER BLANK INTEGER I, J, K, I1 INTEGER JP, KP, IX, IY INTEGER IP1, MSI, IFN, NDEC INTEGER GRID(139,59),IGRID, JGRID, NCALLS INTEGER ISEP, JSEP, KSEP, ILPP1 INTEGER NDER, NDERP1, MAXSEP(7), IPLTJI INTEGER IPLTKI, NCNT LOGICAL COLOR, LMARK, NUMRCL, LBLS REAL A, H, X, Y REAL X0, Y0, X1, Y1 REAL X2, Y2, Y3, XR REAL DX, XX(8), DY, YY(8) REAL XF1, YF1, XF2, YF2 REAL ONE, XSCAL, YSCAL, DTIC REAL USEDUP, XLEFT, HALFWN, HEIGHT REAL XRIGHT, RANGE, DFMIN, SCAL(7) REAL XTEMP, XNUM, XCENTR, ALINE REAL ZERO, YTOP, YBOT, DXNUM DOUBLE PRECISION CBDSW, CBD, CBDU INTEGER ICBD LOGICAL LCBD COMMON / CB / CBDSW, CBD(3), CBDU(3), ICBD COMMON / CB / LCBD LOGICAL LDF, LPLT, LDEF COMMON / LOGCOM / LDF(7), LPLT(7), LDEF(5377) DOUBLE PRECISION XS, FS, DF, DFMNMX COMMON / FUNCOM / XS(5377), FS(5377), DF(135,7) COMMON / FUNCOM / DFMNMX(2,7) INTEGER IPLOT, ISCRN1, ISCRN2 REAL SCALE COMMON / PLTCOM / SCALE(7), IPLOT(135,7),ISCRN1(135,57) COMMON / PLTCOM / ISCRN2(135,57) INTEGER OUTPUT, LINES, WIDTH, ILP INTEGER IDSPLA, IPRMPT LOGICAL LSCRN COMMON / SCREEN / OUTPUT, LINES, WIDTH, ILP COMMON / SCREEN / IDSPLA, IPRMPT, LSCRN DOUBLE PRECISION ROPDI, ROPPNT, ROPDR1, ROPDR2 DOUBLE PRECISION ROPSTS, ROPSTW, ROPUDI INTEGER NH, NW, ILEFT, IRIGHT INTEGER IOPDM, IOPSH, IOPSS, IOPWN INTEGER NDIM LOGICAL OPDC, OPDS, OPDX, OPCMP LOGICAL OPSPL, OPDF1, OPDF2 COMMON / OPTION / ROPDI(3,2), ROPPNT(3,2), ROPDR1(3,2) COMMON / OPTION / ROPDR2(3,2), ROPSTS(2), ROPSTW(2) COMMON / OPTION / ROPUDI(3,2), NH(2), NW(2) COMMON / OPTION / ILEFT(2), IRIGHT(2), IOPDM(2) COMMON / OPTION / IOPSH(2), IOPSS(2), IOPWN(2), OPDC(2) COMMON / OPTION / OPDS(2), OPDX(2), OPCMP(2) COMMON / OPTION / OPSPL(2), OPDF1(7,2), OPDF2(7,2) EQUIVALENCE(IOPDM(2),NDIM) DATA BLANK / 1H / DATA I1 / 1 / DATA XLEFT, XRIGHT, YTOP, YBOT / 0.05, 0.95, 0.9, 0.35 / DATA HEIGHT, DTIC / 0.016, 0.011 / DATA ONE, ZERO / 1.0, 0.0 / DATA Y0,ALINE,X0,XR /0.2831,0.0333,0.05,0.95/ DATA XX(1),XX(2),XX(3),XX(4),XX(5),XX(6),XX(7),XX(8) X /0.05, 0.5, 0.05, 0.5, 0.05, 0.5, 0.05, 0.5/ DATA YY(1), YY(2), YY(3), YY(4), YY(5), YY(6), YY(7), YY(8) X /0.1499,0.1499,0.1166,0.1166,0.0833,0.0833,0.05, 0.05/ C C (1) DETERMINE THE PORTION OF THE GRID() ARRAY WHICH IS TO BE USED. C SET THE OUTER RIM TO BLANKS. C IGRID = WIDTH+4 JGRID = ILP+2 DO 100 I = 1,2 K = IGRID+1-I DO 100 J = 1,JGRID GRID(I,J) = BLANK GRID(K,J) = BLANK 100 CONTINUE K = JGRID-1 DO 200 I = 1,IGRID GRID(I,JGRID) = BLANK GRID(I,K) = BLANK 200 CONTINUE C C COPY THE ISCRN2() ARRAY INTO THE CENTRAL PORTION OF THE GRID() ARRAY C ILPP1 = ILP+1 DO 300 I = 1,WIDTH K = I+2 DO 300 J = 1,ILP JP = ILPP1-J GRID(K,J) = ISCRN2(I,JP) 300 CONTINUE C C (2) SET UP THE PLOTTING BY CALLING PLT00, DRAWING A FRAME ABOUT C THE PLOTTING REGION, AND DRAWING THE WINDOW. C XF1 = 0.75/11.0 XF2 = 7.75/11.0 YF1 = 2.0/11.0 YF2 = 9.0/11.0 CALL SETMSZ(0.5) CALL SETVP2(XF1,XF2,YF1,YF2) CALL SYMSF(5HUCSR1,1H;) CALL SYMSZ(ONE,HEIGHT) HALFWN = FLOAT(NW(2))/FLOAT(NH(2))*(XRIGHT-XLEFT)/FLOAT(WIDTH-1) XCENTR = (XLEFT+XRIGHT)/2.0 X = XCENTR Y = YTOP CALL MOVA2(X,Y) Y = YBOT CALL LINA2(X,Y) X = XCENTR+HALFWN CALL MOVA2(X,Y) Y = YTOP CALL LINA2(X,Y) X = XCENTR-HALFWN CALL MOVA2(X,Y) Y = YBOT CALL LINA2(X,Y) C C (3) DRAW THE X-AXIS IN IF OPDX(2) = .TRUE. C IF ( .NOT.OPDX(2) ) GO TO 400 X = XLEFT Y = YBOT+(YTOP-YBOT)/2.0 CALL MOVA2(X,Y) X = XRIGHT CALL LINA2(X,Y) C C DRAW A SCALED AXIS ALONG THE BASE OF THE PLOT IF OPDS(2) = .TRUE. C 400 IF ( .NOT.OPDS(2) ) GO TO 700 Y1 = YBOT-DTIC/2.0-HEIGHT Y2 = Y1+DTIC X = XLEFT Y = YBOT-HEIGHT CALL MOVA2(X,Y) X = XRIGHT CALL LINA2(X,Y) DX = (XRIGHT-XLEFT)/4.0 X = XLEFT DO 500 I = 1,5 CALL MOVA2(X,Y1) CALL LINA2(X,Y2) X = X+DX 500 CONTINUE X = XLEFT Y = YBOT-2.5*HEIGHT H = SNGL(ROPSTS(2)) DXNUM = FLOAT(WIDTH-1)*H*FLOAT(NH(2))/32.0 XNUM = -2.0*DXNUM DO 600 I = 1,5 IF (I.EQ.1) CALL SYMJU(5HFIRST,6HCENTER) IF (I.GE.2.AND.I.LE.4) CALL SYMJU(6HCENTER,6HCENTER) IF (I.EQ.5) CALL SYMJU(4HLAST,6HCENTER) XTEMP = X CALL DRWRL(XNUM,3,XTEMP,Y,.FALSE.) XNUM = XNUM+DXNUM X = X+DX 600 CONTINUE CALL SYMJU(5HFIRST,3HOFF) C C DRAW A HORIZONTAL LINE SEGMENT THROUGH THE ORIGIN IF OPDC(2) = .TRUE. C 700 IF ( .NOT.OPDC(2) ) GO TO 800 X1 = (XLEFT+XRIGHT)/2.0-0.02 X2 = X1 + 0.04 Y = (YBOT+YTOP)/2.0D0 CALL MOVA2(X1,Y) CALL LINA2(X2,Y) C C (4) SCALE AND PLOT THE CURVES C 800 CONTINUE DX = (XRIGHT-XLEFT)/FLOAT(WIDTH-1) DO 1200 I = 1,7 IF ( .NOT.OPDF1(I,2) ) GO TO 1200 IF (OPDF2(I,2)) CALL SETMSZ(1.0) IP1 = I+1 IF (COLOR) CALL SETPEN(IP1) CALL SETMS(I) RANGE = SNGL(DFMNMX(2,I)-DFMNMX(1,I)) DFMIN = SNGL(DFMNMX(1,I)) IF ( RANGE.NE.0.0 ) GO TO 900 SCAL(I) = 0.0 GO TO 1000 900 SCAL(I)= (YTOP-YBOT)/RANGE 1000 CONTINUE X = XLEFT IF (RANGE.EQ.0.0) Y = (YTOP+YBOT)/2. IF (RANGE.NE.0.) Y = YBOT+(DF(1,I)-DFMIN)*SCAL(I) CALL MOVA2(X,Y) CALL MARKA2(LMARK,X,Y) DO 1100 J = 2,WIDTH IF (RANGE.EQ.0.) Y = (YBOT+YTOP)/2. IF (RANGE.NE.0.) Y = YBOT+(DF(J,I)-DFMIN)*SCAL(I) X = X+DX CALL LINA2(X,Y) CALL MARKA2(LMARK,X,Y) 1100 CONTINUE CALL SETMSZ(0.5) 1200 CONTINUE CALL SETMSZ(0.5) C C CHECK IF LABELS ARE REQUESTED C IF (.NOT.LBLS) GO TO 1800 C C (5) FIND THE BEST PLACES AT WHICH TO LABEL THE VARIOUS CURVES. C IF (COLOR) CALL SETPEN(1) DO 1500 I = 1,7 IF ( .NOT.OPDF1(I,2) .OR. SCAL(I).EQ.0.0 ) GO TO 1500 ISEP = 0 MAXSEP(I) = WIDTH/2+1 DO 1400 J = 1,WIDTH IPLTJI = IPLOT(J,I) KSEP = ILP DO 1300 K = 1,7 IF ( K.EQ.I .OR. .NOT.OPDF1(K,2) ) GO TO 1300 JSEP = IABS(IPLTJI-IPLOT(J,K)) IF ( JSEP.GT.KSEP ) GO TO 1300 KSEP = JSEP 1300 CONTINUE IF ( KSEP.LE.ISEP ) GO TO 1400 ISEP = KSEP MAXSEP(I) = J 1400 CONTINUE 1500 CONTINUE C C (6) FOR EACH CURVE TO BE PLOTTED, FIND A BLANK REGION FOR LABELLING C XSCAL = (XRIGHT-XLEFT)/FLOAT(IGRID-5) YSCAL = (YTOP-YBOT)/FLOAT(JGRID-3) CALL SYMJU(5HFIRST,6HCENTER) DO 1700 I = 1,7 IF ( .NOT.OPDF1(I,2) .OR. SCAL(I).EQ.0.0 ) GO TO 1700 IFN = I-1 K = MAXSEP(I) KP = K+2 IPLTKI = ILPP1-IPLOT(K,I) CALL FNDSPT(IGRID,JGRID,GRID,KP,IPLTKI,IX,IY) X = XLEFT+FLOAT(IX-3)*XSCAL+HEIGHT/2.0 Y = YBOT +FLOAT(IY-1)*YSCAL+HEIGHT/2.0 CALL DRWINT(IFN,X,Y,.FALSE.) X1 = XLEFT+FLOAT(MAXSEP(I)-1)*XSCAL MSI = MAXSEP(I) Y1 = YBOT+(DF(MSI,I)-DFMNMX(1,I))*SCAL(I) DX = X-X1 DY = Y-Y1 CALL CONLIN(X,Y,DX,DY,X2,Y2,HEIGHT) CALL MOVA2(X1,Y1) CALL LINA2(X2,Y2) DO 1600 J = 1,2 JP = IX+J-1 DO 1600 K = 1,2 KP = IY+K-1 GRID(JP,KP) = USEDUP 1600 CONTINUE 1700 CONTINUE 1800 CONTINUE CALL SYMJU(5HFIRST,3HOFF) C C (7) DISPLAY THE NUMERICAL DATA AT THE BOTTOM OF THE PLOT C IF (.NOT.NUMRCL) GO TO 2400 IF (COLOR) CALL SETPEN(1) Y = Y0 - ALINE NDEC = 3 C C DISPLAY CROSS-BOUNDARY DERIVATIVE DATA IF REQUIRED C IF (ICBD.EQ.0) GO TO 2000 X = X0 CALL DRWSTR(3HCD:,3,X,Y,.TRUE.) CALL DRWINT(ICBD,X,Y,.TRUE.) IF (NDIM.EQ.1) CALL DRWSTR(7HIR =,7,X,Y,.TRUE.) IF (NDIM.GT.1) CALL DRWSTR(9HIR = (,9,X,Y,.FALSE.) DO 1900 I = 1,NDIM H = SNGL(CBDU(I)) CALL DRWRL(H,NDEC,X,Y,.FALSE.) IF (NDIM.GT.1.AND.I.EQ.NDIM) CALL DRWSTR(1H),1,X,Y,.TRUE.) IF (I.LT.NDIM) CALL DRWSTR(1H,,1,X,Y,.TRUE.) 1900 CONTINUE X = XR CALL SYMJU(4HLAST,3HOFF) H = SNGL(CBDSW) CALL DRWRLB(H,NDEC,X,Y,.TRUE.) CALL DRWSTB(5H>CH =,5,X,Y,.TRUE.) CALL SYMJU(5HFIRST,3HOFF) 2000 CONTINUE C C DISPLAY THE POINT VECTOR AND THE STEP-SIZE BETWEEN PLOTTED POINTS C Y = Y - ALINE X = X0 IF (NDIM.GT.1) CALL DRWSTR(11H

OINT = (,11,X,Y,.FALSE.) IF (NDIM.EQ.1) CALL DRWSTR(9H

OINT =,9,X,Y,.TRUE.) DO 2100 I = 1,NDIM H = SNGL(ROPPNT(I,2)) CALL DRWRL(H,NDEC,X,Y,.FALSE.) IF (NDIM.GT.1.AND.I.EQ.NDIM) CALL DRWSTR(1H),1,X,Y,.TRUE.) IF (I.LT.NDIM) CALL DRWSTR(1H,,1,X,Y,.TRUE.) 2100 CONTINUE X = XR CALL SYMJU(4HLAST,3HOFF) H = SNGL(ROPSTS(2))*FLOAT(NH(2))/8.0 CALL DRWRLB(H,NDEC,X,Y,.TRUE.) CALL DRWSTB(4H>S =,4,X,Y,.TRUE.) CALL SYMJU(5HFIRST,3HOFF) C C DISPLAY THE DIRECTION VECTOR AND THE STENCIL-WIDTH C Y = Y - ALINE X = X0 IF (NDIM.GT.1) CALL DRWSTR(15HIRECTION = (,15,X,Y,.FALSE.) IF (NDIM.EQ.1) CALL DRWSTR(13HIRECTION =,13,X,Y,.TRUE.) DO 2200 I = 1,NDIM H = SNGL(ROPDI(I,2)) CALL DRWRL(H,NDEC,X,Y,.FALSE.) IF (NDIM.GT.1.AND.I.EQ.NDIM) CALL DRWSTR(1H),1,X,Y,.TRUE.) IF (I.LT.NDIM) CALL DRWSTR(1H,,1,X,Y,.TRUE.) 2200 CONTINUE CALL SYMJU(4HLAST,3HOFF) X = XR H = SNGL(ROPSTW(2))/2. CALL DRWRLB(H,NDEC,X,Y,.TRUE.) CALL DRWSTB(4H>H =,4,X,Y,.TRUE.) CALL SYMJU(5HFIRST,3HOFF) C C DISPLAY THE MINIMUMS AND MAXIMUMS C NCNT = 0 DO 2300 NDER = 1,7 IF (.NOT.OPDF1(NDER,2)) GO TO 2300 NDERP1 = NDER + 1 IF (COLOR) CALL SETPEN(NDERP1) NCNT = NCNT + 1 X = XX(NCNT) Y = YY(NCNT) CALL PLMXMN(NDER,X,Y,LMARK) 2300 CONTINUE C C DISPLAY THE NUMBER OF FUNCTION EVALUATIONS C IF (COLOR) CALL SETPEN(1) NCNT = NCNT + 1 X = XX(NCNT) Y = YY(NCNT) CALL DRWSTR(26HUMBER OF VALUATIONS:,26,X,Y,.TRUE.) CALL DRWINT(NCALLS,X,Y,.TRUE.) 2400 CONTINUE RETURN END SUBROUTINE STPEN(I) INTEGER ICURR,I COMMON /SPOWN/ ICURR IF (I.EQ.ICURR) GO TO 100 ICURR = I CALL SETPN(ICURR) 100 RETURN END