C FILE: LC This file contains all the subroutines that require the
C support of lower case letters for their proper functioning, including
C the master routines MCRSCP. If lower case letters are not available,
C then the file UC shoul be used instead.
C
SUBROUTINE MCRSCP(F,INPT,OUTPT,GRAPHC,HLP,RCRD,RESTRT,
X ILINES,IWIDTH,IPLT,IDATA,IPROMP)
C-----------------------------------------------------------------------
C DRIVER PROGRAM: MCRSCP.FOR
C
C PURPOSE: TO INVESTIGATE CONTINUITY PROPERTIES OF
C BIVARIATE AND TRIVARIATE INTERPOLATION
C FUNCTIONS BY GRAPHICALLY DISPLAYING
C DIRECTIONAL DERIVATIVES (UP TO SIXTH
C ORDER).
C
C WRITTEN BY: BILL HARRIS AND PETER ALFELD
C
C DATE BEGUN: 6/17/83
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C
C ARGUMENTS:
C
C INPT = INPUT DEVICE NUMBER (USUALLY THE TERMINAL)
C OUTPT = OUTPUT DEVICE NUMBER (USUALLY THE TERMINAL)
C GRAPHC = GRAPHIC DEVICE NUMBER (TERMINAL OR GRAPHICS DISPLAY)
C HLP = HELP FILE DEVICE NUMBER
C RCRD = RECORD DEVICE NUMBER (OUTPUT DATA FILE FOR RECORDING
C SCREEN IMAGES AND COMMENTS)
C RESTRT = RESTART FILE DEVICE NUMBER (UNFORMATTED OUTPUT DATA
C FILE FOR USE IN RESTARTING AT A LATER DATE)
C
C ILINES = THE TOTAL NUMBER OF LINES ON THE TERMINAL SCREEN.
C IT MUST SATISFY: 1 < ILINES < 58
C IWIDTH = THE NUMBER OF COLUMNS ON THE TERMINAL SCREEN.
C IT MUST SATISFY: 1 < IWIDTH < 136
C IPLT = THE NUMBER OF LINES ALLOCATED TO PLOTTING THE CURVES.
C IT MUST SATISFY: 1 < IPLT < 58
C IDATA = THE NUMBER OF LINES ABOVE THE SCREEN BOTTOM AT WHICH
C THE NUMERICAL DATA REGION BEGINS. IT MUST BE GREATER
C THAN IPROMP BY 6 OR MORE.
C IPROMP = THE NUMBER OF LINES ABOVE THE SCREEN BOTTOM AT WHICH
C THE PROMPTING COMMANDS ARE GIVEN (AT LEAST 2).
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C EXTERNAL REFERENCES (FUNCTION,SUBROUTINE,COMMON)
C
C EXTERNAL REFS POS, SUBAC, SGRAPH, SUBCC
C EXTERNAL REFS SUBCD, SUBCH, SUBCO, SUBCW
C EXTERNAL REFS SUBCCH, CHKCMP, BLSCRN, SUBDC
C EXTERNAL REFS SUBDG, SUBDI, SUBDM, SUBDO
C EXTERNAL REFS SUBDS, SUBDX, SUBDCH, NUMDIG
C EXTERNAL REFS SUBEG, INHELP, CHKERR, SUBFL
C EXTERNAL REFS SUBFO, SUBGO, SUBHA, SUBHE
C EXTERNAL REFS SUBID, SUBIH, SUBII, SUBIP
C EXTERNAL REFS DIALOG, SUBLC, SUBLD, SUBLI
C EXTERNAL REFS SUBLO, SUBLP, NRML, SGAMMA
C EXTERNAL REFS SUBMU, SUBNE, SUBNO, SUBOU
C EXTERNAL REFS OPCOPY, SCROLL, ZERO, SUBPA
C EXTERNAL REFS SUBPL, SUBPCH, SAMPLE, SSMPUD
C EXTERNAL REFS SUBRC, SUBRD, SUBRE, SUBRO
C EXTERNAL REFS SUBRP, SUBRS, SUBRW, MAKROM
C EXTERNAL REFS PCURSR, SUBSE, SUBSH, SUBST
C EXTERNAL REFS SUBTC, SUBTN, SUBTY, DFAULT
C EXTERNAL REFS SUBUN, SUBUSR, SCMUPD, SGRUPD
C EXTERNAL REFS SUBWA, SUBZO
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C EXTERNAL FUNCTIONS AND SUBROUTINES
C
EXTERNAL F
DOUBLE PRECISION F
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C HOLLERITH STRING VARIABLES
C
INTEGER IBLNK
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C NON-COMMON VARIABLES
C
C SETS I, J, OK, NL
C SETS LGO, MCALRD, NCALLS, OUTPTD
C SETS ITYPE, ITXT
C
DOUBLE PRECISION V1(3), V2(3), DARG
INTEGER I, J, ND, NL
INTEGER NUM, DEN, HLP, IWIDTH
INTEGER RCRD, IARG, IARGP, NCALLS
INTEGER ICOM, ILINES, IPROMP, GRAPHC
INTEGER OUTPT, OUTPTD, ITYPE, IDATA
INTEGER IPLT, INPT, RESTRT
INTEGER ITXT(72)
LOGICAL OK, LGO, LMAG, LSHIFT
LOGICAL MCALRD, LSAMPL, LCOMP, LZERO
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / CB /
C
C UNUSED CBD, ICBD, LCBD, CBDSW
C UNUSED CBDU
C
DOUBLE PRECISION CBDSW, CBD, CBDU
INTEGER ICBD
LOGICAL LCBD
COMMON / CB / CBDSW, CBD(3), CBDU(3), ICBD
COMMON / CB / LCBD
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / IO /
C
C SETS RECORD, GRAPHD, HELPD, RSTRTD
C SETS INPUTD
C
INTEGER INPUTD, GRAPHD, HELPD, RECORD
INTEGER RSTRTD
COMMON / IO / INPUTD, GRAPHD, HELPD, RECORD
COMMON / IO / RSTRTD
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / LOG /
C
INTEGER LCHN
COMMON / LOG / LCHN
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / LOGCOM /
C
C UNUSED LDF, LDEF, LPLT
C
LOGICAL LDF, LPLT, LDEF
COMMON / LOGCOM / LDF(7), LPLT(7), LDEF(5377)
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / FUNCOM /
C
C UNUSED DF, FS, XS, DFMNMX
C
DOUBLE PRECISION XS, FS, DF, DFMNMX
COMMON / FUNCOM / XS(5377), FS(5377), DF(135,7)
COMMON / FUNCOM / DFMNMX(2,7)
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / ERRCOM /
C
C SETS ERR, ERRCOD
C
INTEGER ERRCOD
LOGICAL ERR
COMMON / ERRCOM / ERRCOD, ERR
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / PLTCOM /
C
C UNUSED SCALE, IPLOT, ISCRN1, ISCRN2
C
INTEGER IPLOT, ISCRN1, ISCRN2
REAL SCALE
COMMON / PLTCOM / SCALE(7), IPLOT(135,7),ISCRN1(135,57)
COMMON / PLTCOM / ISCRN2(135,57)
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / LOADIO /
C
C UNUSED CLOAD, DLOAD, PLOAD
C
INTEGER PLOAD, DLOAD, CLOAD
COMMON / LOADIO / PLOAD, DLOAD, CLOAD
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / SCREEN /
C
C SETS ILP, LINES, IPRMPT, IDSPLA
C SETS OUTPUT, LSCRN, WIDTH
C
INTEGER OUTPUT, LINES, WIDTH, ILP
INTEGER IDSPLA, IPRMPT
LOGICAL LSCRN
COMMON / SCREEN / OUTPUT, LINES, WIDTH, ILP
COMMON / SCREEN / IDSPLA, IPRMPT, LSCRN
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / OPTION /
C
C UNUSED NH, ROPDR1, ROPDR2, ILEFT
C UNUSED IRIGHT, OPCMP, OPSPL, ROPSTW
C
C SETS IOPDM, ROPDI, ROPPNT
C
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)
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / NRMLZE /
C
C SETS NORMAL
C
LOGICAL NORMAL
COMMON / NRMLZE / NORMAL
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / ROOM /
C
C SETS ILPUSR, IDSUSR
C
INTEGER ILPUSR, IDSUSR
COMMON / ROOM / ILPUSR, IDSUSR
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / HELPER /
C
C UNUSED IHELP, JHELP
C
C SETS HELP
C
INTEGER HELP, JHELP1, JHELP2, JHELP3
INTEGER JHELP, IHELP
COMMON / HELPER / HELP, JHELP1, JHELP2, JHELP3
COMMON / HELPER / JHELP(99,2), IHELP(72,99)
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / USER /
C
C UNUSED N, ETA, ADD, IROUND
C
DOUBLE PRECISION ETA
INTEGER IROUND, N
LOGICAL ADD
COMMON / USER / ETA, IROUND, N, ADD
C
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / PLOWN /
C
C SETS BL, BR, NUMBR, TIME
C SETS DATE, FRAME, COLOR, LMARK
C SETS NUMRCL, LBLS, ITITLE, IBOTTM
C
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
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / FOOWN /
C
C SETS LFO
C
LOGICAL LFO
COMMON / FOOWN / LFO
C
DATA IBLNK /1H /
DATA MCALRD /.FALSE./
C-----------------------------------------------------------------------
C
C WRITE IDENTIFYING STENCIL
C
C-----------------------------------------------------------------------
CALL BLSCRN(OUTPT)
CALL PCURSR(OUTPT,1,1)
IF (MCALRD) WRITE (OUTPT,14000)
IF (.NOT.MCALRD) WRITE (OUTPT,16000)
WRITE (OUTPT,18000)
C-----------------------------------------------------------------------
C
C CHECK SCREEN PARAMETERS FOR CONSISTENCY AND ADMISSIBILITY
C
C-----------------------------------------------------------------------
OK = .TRUE.
IF (ILINES.GT.10) GO TO 100
WRITE (OUTPT,20000)
OK = .FALSE.
100 CONTINUE
IF (ILINES.LT.58) GO TO 200
WRITE (OUTPT,22000)
OK = .FALSE.
200 CONTINUE
IF (IWIDTH.GT.0) GO TO 300
WRITE (OUTPT,24000)
OK = .FALSE.
300 CONTINUE
IF (IWIDTH.LT.136) GO TO 400
WRITE (OUTPT,26000)
OK = .FALSE.
400 CONTINUE
IF (IPLT.GT.0) GO TO 500
WRITE (OUTPT,28000)
OK = .FALSE.
500 CONTINUE
IF (IPROMP.GT.1) GO TO 600
WRITE (OUTPT,30000)
OK = .FALSE.
600 CONTINUE
IF (IPROMP.LT.ILINES-IPLT-6) GO TO 700
WRITE (OUTPT,32000)
OK = .FALSE.
700 CONTINUE
IF (IDATA.GT.IPROMP+5) GO TO 800
WRITE (OUTPT,34000)
OK = .FALSE.
800 CONTINUE
IF (IDATA.LT.ILINES-IPLT) GO TO 900
WRITE (OUTPT,36000)
OK = .FALSE.
900 CONTINUE
IF (IPLT.LT.ILINES-8) GO TO 1000
WRITE (OUTPT,38000)
OK = .FALSE.
1000 CONTINUE
IF (OK) GO TO 1100
WRITE (OUTPT,40000) ILINES,IWIDTH,IPLT,IDATA,IPROMP
WRITE (OUTPT,42000)
GO TO 8300
1100 CONTINUE
C-----------------------------------------------------------------------
C
C COPY CHANNEL NUMBERS, SCREEN PARAMETERS, AND SET FLAGS
C
C-----------------------------------------------------------------------
INPUTD = INPT
OUTPTD = OUTPT
GRAPHD = GRAPHC
HELPD = HLP
RECORD = RCRD
RSTRTD = RESTRT
LFO = .FALSE.
LGO = .FALSE.
LSCRN = .FALSE.
LINES = ILINES
WIDTH = IWIDTH
IDSUSR = IDATA
IDSPLA = IDATA
ILPUSR = IPLT
ILP = IPLT
IPRMPT = IPROMP
HELP = HELPD
OUTPUT = OUTPTD
IF (MCALRD) GO TO 1400
MCALRD = .TRUE.
C-----------------------------------------------------------------------
C
C COMPUTE ROUND-OFF CHARACTERISTICS AND PRINT THEM
C
C-----------------------------------------------------------------------
CALL NUMDIG(ND)
WRITE (OUTPT,44000) ND
C-----------------------------------------------------------------------
C
C SET LOGICAL VARIABLES, COMMON BLOCKS, AND DEFAULT VECTORS, BEFORE
C STARTING
C
C-----------------------------------------------------------------------
NORMAL = .TRUE.
NCALLS = 0
DO 1200 I = 1,2
IOPDM(I) = 2
ROPPNT(1,I) = 0.0D0
ROPPNT(2,I) = 0.0D0
ROPPNT(3,I) = 0.0D0
ROPDI(1,I) = 1.0D0
ROPDI(2,I) = 1.0D0
ROPDI(3,I) = 0.0D0
1200 CONTINUE
CALL DFAULT
CALL NRML
C-----------------------------------------------------------------------
C
C SET PLOTTING DEFAULTS:
C
C-----------------------------------------------------------------------
DO 1300 I = 1,72
ITITLE(I) = IBLNK
IBOTTM(I) = IBLNK
BL(I) = IBLNK
BR(I) = IBLNK
1300 CONTINUE
NUMBR = 0
TIME = .FALSE.
DATE = .FALSE.
COLOR = .TRUE.
LMARK = .FALSE.
LBLS = .TRUE.
FRAME = .TRUE.
NUMRCL = .TRUE.
C-----------------------------------------------------------------------
C
C INPUT HELP DOCUMENTATION
C
C-----------------------------------------------------------------------
CALL INHELP
C PRINT TOP LINE OF THE NEWS
NL = 7+JHELP1+JHELP2+JHELP3
CALL POS(HLP,NL)
WRITE (OUTPT,10000)
READ (HLP,12000) (ITXT(J),J=1,72)
WRITE (OUTPT,12000) (ITXT(J),J=1,72)
1400 CONTINUE
C-----------------------------------------------------------------------
C
C BEGIN MAIN LOOP
C
C 'DIALOG' PROMPTS FOR INPUT, THEN READS AND RECOGNIZES THE INPUT.
C
C-----------------------------------------------------------------------
1500 CALL DIALOG(ICOM,IARG,IARGP,DARG,V1,V2,IOPDM,INPUTD)
ERR = .FALSE.
ERRCOD = 0
GO TO (1600,1700,1800,1900,2000,2100,2200,2300,2400,2500,2600,
X 2700,2800,2900,3000,3100,3200,3300,3400,3500,3600,3700,3800,
X 3900,4000,4100,4200,4300,4400,4500,4600,4700,4800,4900,5000,
X 5100,5200,5300,5400,5500,5600,5700,5800,5900,6000,6100,6200,
X 6300,6400,6500,6600,6700,6800,6900,7000,7100,7200,7300,7400,
X 7500,7600,7700,7800),ICOM
C-----------------------------------------------------------------------
C
C EXECUTE THE APPROPRIATE SUBROUTINE. MOST SUBROUTINE NAMES HAVE
C THE FORM: SUB + (FIRST TWO LETTERS OF THE COMMAND)
C
C-----------------------------------------------------------------------
1600 CALL SUBAC(ITYPE,IARG,OPDF1,OPDF2)
GO TO 7900
1700 CALL SUBCCH(ITYPE,1,DARG)
GO TO 7900
1800 CALL SUBCCH(ITYPE,2,DARG)
GO TO 7900
1900 CALL SUBCCH(ITYPE,3,DARG)
GO TO 7900
2000 CALL SUBCC(ITYPE,IARG,IARGP,INPUTD,OUTPTD,GRAPHD,RECORD,RSTRTD)
GO TO 7900
2100 CALL SUBCD(ITYPE,V1)
GO TO 7900
2200 CALL SUBCH(ITYPE,DARG)
GO TO 7900
2300 CALL SUBCO(ITYPE,IARG)
GO TO 7900
2400 CALL SUBCW(ITYPE,IARG,IOPWN)
GO TO 7900
2500 CALL SUBDCH(ITYPE,1,DARG)
GO TO 7900
2600 CALL SUBDCH(ITYPE,2,DARG)
GO TO 7900
2700 CALL SUBDCH(ITYPE,3,DARG)
GO TO 7900
2800 CALL SUBDC(ITYPE,OPDC)
GO TO 7900
2900 CALL SUBDG(ITYPE,IARG,OPDF1)
GO TO 7900
3000 CALL SUBDI(ITYPE,IARG,IOPSS,IOPWN)
GO TO 7900
3100 CALL SUBDM(ITYPE,IARG,IOPDM,ROPDI,ROPUDI,ROPPNT)
GO TO 7900
3200 CALL SUBDO(ITYPE,IOPSS,IOPWN)
GO TO 7900
3300 CALL SUBDS(ITYPE,OPDS)
GO TO 7900
3400 CALL SUBDX(ITYPE,OPDX)
GO TO 7900
3500 CALL SUBEG(ITYPE,IARG,OPDF1,OPDF2)
GO TO 7900
3600 GO TO 8300
3700 CALL SUBFL(ITYPE)
GO TO 7900
3800 CALL SUBFO(ITYPE,LGO)
GO TO 7900
3900 CALL SUBGO(ITYPE,LGO)
GO TO 7900
4000 CALL SUBHA(ITYPE,IOPSS,IOPWN)
GO TO 7900
4100 CALL SUBHE(ITYPE,IARG,2)
GO TO 7900
4200 CALL SUBHE(ITYPE,ICOM,1)
GO TO 7900
4300 CALL SUBID(ITYPE,V1,ROPDI,ROPUDI,IOPDM)
GO TO 7900
4400 CALL SUBIH(ITYPE,DARG,ROPSTS,NW)
GO TO 7900
4500 CALL SUBII(ITYPE,V1,V2)
GO TO 7900
4600 CALL SUBIP(ITYPE,V1,ROPPNT,IOPDM)
GO TO 7900
4700 CALL SUBLC(ITYPE,IARG)
GO TO 7900
4800 CALL SUBLD(ITYPE,IARG)
GO TO 7900
4900 CALL SUBLI(ITYPE)
GO TO 7900
5000 CALL SUBLO(ITYPE,IARG)
GO TO 7900
5100 CALL SUBLP(ITYPE,IARG)
GO TO 7900
5200 CALL SUBMU(ITYPE,IARG,IOPSS,IOPWN)
GO TO 7900
5300 CALL SUBNE(ITYPE)
GO TO 7900
5400 CALL SUBNO(ITYPE)
GO TO 7900
5500 CALL SUBOU(ITYPE,RECORD,NCALLS,LGO)
GO TO 7900
5600 CALL SUBPCH(ITYPE,1,DARG)
GO TO 7900
5700 CALL SUBPCH(ITYPE,2,DARG)
GO TO 7900
5800 CALL SUBPCH(ITYPE,3,DARG)
GO TO 7900
5900 CALL SUBPA(ITYPE,IARG)
GO TO 7900
6000 CALL SUBPL(ITYPE,INPUTD,NCALLS)
GO TO 7900
6100 CONTINUE
STOP
6200 CALL SUBRC(ITYPE,IARG)
GO TO 7900
6300 CALL SUBRD(ITYPE,IARG)
GO TO 7900
6400 CALL SUBRE(ITYPE,NCALLS,LGO)
IF (.NOT.LSCRN) GO TO 7900
LSCRN = .FALSE.
CALL SGRAPH(GRAPHD,NCALLS,LGO)
GO TO 7900
6500 CALL SUBRO(ITYPE,V1,ROPDI,ROPUDI,IOPDM)
GO TO 7900
6600 CALL SUBRP(ITYPE,IARG)
GO TO 7900
6700 CALL SUBRS(ITYPE,LSCRN)
GO TO 7900
6800 CALL SUBRW(ITYPE,IARG)
GO TO 7900
6900 CALL SUBSE(ITYPE)
GO TO 7900
7000 CALL SUBSH(ITYPE,IARG,IOPSH)
GO TO 7900
7100 CALL SUBST(ITYPE,NCALLS,LGO)
GO TO 7900
7200 CALL SUBTC(ITYPE,IARG,INPUTD)
GO TO 7900
7300 CALL SUBTN(ITYPE,RECORD,INPUTD,OUTPUT,GRAPHD,WIDTH,LSCRN)
GO TO 7900
7400 CALL SUBTY(ITYPE,IARG,IARGP,INPUTD,GRAPHD)
GO TO 7900
7500 CALL SUBUN(ITYPE)
GO TO 7900
7600 CALL SUBUSR
LSCRN = .FALSE.
ITYPE = 4
GO TO 7900
7700 CALL SUBWA(ITYPE)
GO TO 7900
7800 CALL SUBZO(ITYPE,IARG,IOPSS)
GO TO 7900
C-----------------------------------------------------------------------
C
C SET THE LOGICAL VARIABLE LGO TO .FALSE. IF OPTION IS OF TYPE 1.
C IF OPTION IS OF TYPE 2, CALL SGAMMA
C
C-----------------------------------------------------------------------
7900 IF ( ITYPE.EQ.1 ) LGO = .FALSE.
IF ( ITYPE.EQ.1 ) LSCRN = .FALSE.
IF ( ITYPE.EQ.2.AND.LGO ) CALL SGAMMA(LGO,NUM,DEN)
C-----------------------------------------------------------------------
C
C CHECK FOR ERROR - OUTPUT APPROPRIATE MESSAGE IF ERR = .TRUE.
C IF ERR = .TRUE. OR LGO = .FALSE. REQUEST ANOTHER COMMAND.
C
C-----------------------------------------------------------------------
CALL CHKERR
IF ( ERR ) GO TO 1500
C-----------------------------------------------------------------------
C
C IF A SCREEN UPDATE IS REQUIRED (ICOM = 52) AND GO IS PENDING,
C CALL SGRAPH TO DISPLAY THE OLD INFORMATION
C
C-----------------------------------------------------------------------
IF (.NOT.LGO.AND.ICOM.EQ.52) CALL SGRAPH(GRAPHD,NCALLS,LGO)
C-----------------------------------------------------------------------
C
C CHECK IF A GO COMMAND IS REQUIRED BEFORE FURTHER COMPUTATION
C
C-----------------------------------------------------------------------
IF (.NOT.LGO) GO TO 1500
C-----------------------------------------------------------------------
C
C THE NEXT STEP DEPENDS ON THE TYPE OF COMMAND JUST INPUT
C
C-----------------------------------------------------------------------
GO TO (1500,8000,8100,1500),ITYPE
C-----------------------------------------------------------------------
C
C CHECK TO SEE IF COMPUTATION OR SAMPLING CHANGES ARE NECESSARY
C
C-----------------------------------------------------------------------
8000 CALL CHKCMP(LCOMP,LMAG,LSHIFT,LSAMPL,LZERO,NUM,DEN)
C-----------------------------------------------------------------------
C
C IF CHKCMP() RETURNS A VALUE OF TRUE FOR LCOMP, LMAG, LSHIFT, OR
C LSAMPL, THEN CALL THE APPROPRIATE UPDATING ROUTINE.
C
C-----------------------------------------------------------------------
IF ( LMAG.OR.LSHIFT ) CALL SSMPUD(LMAG,LSHIFT,NUM,DEN)
IF ( LSAMPL ) CALL SAMPLE
IF ( LZERO ) CALL ZERO
IF ( LCOMP ) CALL SCMUPD(F,NCALLS)
8100 CONTINUE
C-----------------------------------------------------------------------
C
C IF CROSS DERIVATIVES ARE TO BE PLOTTED THEN PREY ON THE GRAPHICS
C DISPLAY AREA TO MAKE ROOM FOR THE NUMERICAL OUTPUT IF NECESSARY
C
C-----------------------------------------------------------------------
CALL MAKROM
C-----------------------------------------------------------------------
C
C SET UP THE GRAPHICS DATA WHICH IS THEN CONVERTED INTO PLOTTING
C COMMANDS BY THE SGRAPH SUBROUTINE.
C
C-----------------------------------------------------------------------
CALL SGRUPD(ICOM)
C-----------------------------------------------------------------------
C
C PLOT THE DATA, THEN RETURN TO TOP OF PROGRAM FOR NEW COMMANDS
C
C-----------------------------------------------------------------------
CALL SGRAPH(GRAPHD,NCALLS,LGO)
C-----------------------------------------------------------------------
C
C IF LOGGING IS REQUIRED WRITE DATA IN SCROLLING MODE
C
C-----------------------------------------------------------------------
IF (LCHN.EQ.0) GO TO 8200
WRITE (LCHN,46000)
CALL SCROLL(LCHN,NCALLS,LGO)
WRITE (LCHN,46000)
8200 CONTINUE
C-----------------------------------------------------------------------
C
C UPDATE OPTIONS AND FLAGS
C
C-----------------------------------------------------------------------
CALL OPCOPY
GO TO 1500
8300 CONTINUE
RETURN
X 25H Version 1.0 - 15-JUN-84//)
X 10H PLOT = ,I4/10H NUMRCL = ,I4/10H PROMPT = ,I4/)
X 24H Leaving MICROSCOPE ... //)
END
SUBROUTINE CHKERR
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C ROUTINE: CHKERR
C PURPOSE: TO OUTPUT ERROR MESSAGES TO DEVICE OUTPUT
C
INTEGER ERRCOD
LOGICAL ERR
COMMON / ERRCOM / ERRCOD, ERR
INTEGER OUTPUT, LINES, WIDTH, ILP
INTEGER IDSPLA, IPRMPT
LOGICAL LSCRN
COMMON / SCREEN / OUTPUT, LINES, WIDTH, ILP
COMMON / SCREEN / IDSPLA, IPRMPT, LSCRN
IF (.NOT.ERR) GO TO 2700
GO TO (100,200,300,400,500,600,700,800,900,1000,1100,1200,1300,
X 1400,1500,1600,1700,1800,1900,2000,2100,2200,2300,2400,2500),
X ERRCOD
100 WRITE (OUTPUT,10000)
GO TO 2600
200 WRITE (OUTPUT,12000)
GO TO 2600
300 WRITE (OUTPUT,14000)
GO TO 2600
400 WRITE (OUTPUT,16000)
GO TO 2600
500 WRITE (OUTPUT,18000)
GO TO 2600
600 WRITE (OUTPUT,20000)
GO TO 2600
700 WRITE (OUTPUT,22000)
GO TO 2600
800 WRITE (OUTPUT,24000)
GO TO 2600
900 WRITE (OUTPUT,26000)
GO TO 2600
1000 WRITE (OUTPUT,28000)
GO TO 2600
1100 WRITE (OUTPUT,30000)
GO TO 2600
1200 WRITE (OUTPUT,32000)
GO TO 2600
1300 WRITE (OUTPUT,34000)
GO TO 2600
1400 WRITE (OUTPUT,36000)
GO TO 2600
1500 WRITE (OUTPUT,38000)
GO TO 2600
1600 WRITE (OUTPUT,40000)
GO TO 2600
1700 WRITE (OUTPUT,42000)
GO TO 2600
1800 WRITE (OUTPUT,44000)
GO TO 2600
1900 WRITE (OUTPUT,46000)
GO TO 2600
2000 WRITE (OUTPUT,48000)
GO TO 2600
2100 WRITE (OUTPUT,50000)
GO TO 2600
2200 WRITE (OUTPUT,52000)
GO TO 2600
2300 WRITE (OUTPUT,56000)
GO TO 2600
2400 WRITE (OUTPUT,54000)
GO TO 2600
2500 WRITE (OUTPUT,56000)
C
2600 CONTINUE
LSCRN = .FALSE.
2700 CONTINUE
RETURN
C
C FORMAT STATEMENTS
C
END
SUBROUTINE DIALOG(ICOM,IARG,IARGP,DARG,V1,V2,IOPDM,INPUTD)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C ROUTINE: DIALOG
C PURPOSE: TO PROMPT FOR, INPUT, AND RECOGNIZE, COMMANDS TO THE
C MICROSCOPE PROGRAM.
C
C ARGUMENTS:
C
C ICOM = THE NUMBER CORRESPONDING TO THE INPUTTED COMMAND
C (THE ORDER IS DEFINED BY THE ORDER IN THE LIST
C OF OPTIONS. IT IS IN ALPHABETICAL ORDER)
C IARG = THE INTEGER ARGUMENT, IF ANY, THAT ACCOMPANIES THE
C ICOM'TH COMMAND.
C IARGP = THE SECOND INTEGER ARGUMENT IF ANY
C DARG = THE DOUBLE PRECISION ARGUMENT, IF ANY, THAT ACCOMPANIES
C THE ICOM'TH COMMAND.
C V1(3) = THE DOUBLE PRECISION VECTOR, IF ANY, THAT ACCOMPANIES
C THE ICOM'TH COMMAND. NOTE THAT THE LENGTH OF THE
C VECTOR (1,2 OR 3) WILL DEPEND ON THE CURRENT VALUE OF
C IOPDM(2).
C V2(3) = SIMILAR TO V1(3).
C IOPDM(2)= THE DIMENSION OF THE DOMAIN (1,2 OR 3)
C
C THE KTYPE() ARRAY VALUES HAVE THE FOLLOWING MEANING:
C KTYPE() = 1 : PUT DIALOG INTO HELP MODE WHERE IT RECOGNIZES THE
C THE NEXT COMMAND AS THE ONE ON WHICH FURTHER
C INFORMATION IS DESIRED.
C 2 : 1 INTEGER ARGUMENT (IARG)
C 3 : 1 DOUBLE PRECISION ARGUMENT (DARG)
C 4 : 1,2 OR 3 DOUBLE PRECISION ARGUMENTS (V1())
C 5 : 2,4 OR 6 DOUBLE PRECISION ARGUMENTS (V1(), V2())
C 6 : NO ARGUMENTS NECESSARY
C 7 : 2 INTEGER ARGUMENTS (IARG,IARGP)
C
C NOTE: THERE ARE TWO SCREEN EDITING ROUTINES WHICH ARE CALLED BY
C DIALOG. DEPENDING ON THE TYPE OF DEVICE, THE APPROPRIATE
C ROUTINES (HAVING THESE NAMES) MUST BE LOADED FROM A
C SEPARATE SOURCE FILE. THE TWO ROUTINES AND THEIR
C RESPECTIVE PURPOSES ARE:
C
C CLSCRN(U,I,J) : CLEAR THE SCREEN BELOW THE CURSOR POSITION WITH
C SCREEN COORDINATES (I,J), ON DEVICE U.
C PCURSR(U,I,J) : POSITION THE CURSOR AT SCREEN COORDINATES (I,J)
C ON DEVICE U.
C
INTEGER IQ, PLS, ICMNDS(99,2)
DOUBLE PRECISION V1(3), V2(3), DARG
INTEGER I, J, JP
INTEGER IOPDM(2), MODE, IARG, IARGP
INTEGER MHELP, ICOM, NLINES, NCMND
INTEGER IPROMT, JPROMT, KTYPE(99), CHAR1
INTEGER CHAR2, DMNSN, INPUTD
LOGICAL ERR
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 HELP, JHELP1, JHELP2, JHELP3
INTEGER JHELP, IHELP
COMMON / HELPER / HELP, JHELP1, JHELP2, JHELP3
COMMON / HELPER / JHELP(99,2), IHELP(72,99)
DATA NCMND /0/
DATA IQ /1H?/
DATA PLS /1H+/
DATA ICMNDS( 1,1),ICMNDS( 1,2),KTYPE(1) / 1HA, 1HC, 2 /
DATA ICMNDS( 2,1),ICMNDS( 2,2),KTYPE(2) / 1HC, 1H1, 3 /
DATA ICMNDS( 3,1),ICMNDS( 3,2),KTYPE(3) / 1HC, 1H2, 3 /
DATA ICMNDS( 4,1),ICMNDS( 4,2),KTYPE(4) / 1HC, 1H3, 3 /
DATA ICMNDS( 5,1),ICMNDS( 5,2),KTYPE(5) / 1HC, 1HC, 7 /
DATA ICMNDS( 6,1),ICMNDS( 6,2),KTYPE(6) / 1HC, 1HD, 4 /
DATA ICMNDS( 7,1),ICMNDS( 7,2),KTYPE(7) / 1HC, 1HH, 3 /
DATA ICMNDS( 8,1),ICMNDS( 8,2),KTYPE(8) / 1HC, 1HO, 2 /
DATA ICMNDS( 9,1),ICMNDS( 9,2),KTYPE(9) / 1HC, 1HW, 2 /
DATA ICMNDS(10,1),ICMNDS(10,2),KTYPE(10) / 1HD, 1H1, 3 /
DATA ICMNDS(11,1),ICMNDS(11,2),KTYPE(11) / 1HD, 1H2, 3 /
DATA ICMNDS(12,1),ICMNDS(12,2),KTYPE(12) / 1HD, 1H3, 3 /
DATA ICMNDS(13,1),ICMNDS(13,2),KTYPE(13) / 1HD, 1HC, 6 /
DATA ICMNDS(14,1),ICMNDS(14,2),KTYPE(14) / 1HD, 1HG, 2 /
DATA ICMNDS(15,1),ICMNDS(15,2),KTYPE(15) / 1HD, 1HI, 2 /
DATA ICMNDS(16,1),ICMNDS(16,2),KTYPE(16) / 1HD, 1HM, 2 /
DATA ICMNDS(17,1),ICMNDS(17,2),KTYPE(17) / 1HD, 1HO, 6 /
DATA ICMNDS(18,1),ICMNDS(18,2),KTYPE(18) / 1HD, 1HS, 6 /
DATA ICMNDS(19,1),ICMNDS(19,2),KTYPE(19) / 1HD, 1HX, 6 /
DATA ICMNDS(20,1),ICMNDS(20,2),KTYPE(20) / 1HE, 1HG, 2 /
DATA ICMNDS(21,1),ICMNDS(21,2),KTYPE(21) / 1HE, 1HX, 6 /
DATA ICMNDS(22,1),ICMNDS(22,2),KTYPE(22) / 1HF, 1HL, 6 /
DATA ICMNDS(23,1),ICMNDS(23,2),KTYPE(23) / 1HF, 1HO, 6 /
DATA ICMNDS(24,1),ICMNDS(24,2),KTYPE(24) / 1HG, 1HO, 6 /
DATA ICMNDS(25,1),ICMNDS(25,2),KTYPE(25) / 1HH, 1HA, 6 /
DATA ICMNDS(26,1),ICMNDS(26,2),KTYPE(26) / 1HH, 1HE, 1 /
DATA ICMNDS(27,1),ICMNDS(27,2),KTYPE(27) / 1HH, 1HS, 6 /
DATA ICMNDS(28,1),ICMNDS(28,2),KTYPE(28) / 1HI, 1HD, 4 /
DATA ICMNDS(29,1),ICMNDS(29,2),KTYPE(29) / 1HI, 1HH, 3 /
DATA ICMNDS(30,1),ICMNDS(30,2),KTYPE(30) / 1HI, 1HI, 5 /
DATA ICMNDS(31,1),ICMNDS(31,2),KTYPE(31) / 1HI, 1HP, 4 /
DATA ICMNDS(32,1),ICMNDS(32,2),KTYPE(32) / 1HL, 1HC, 2 /
DATA ICMNDS(33,1),ICMNDS(33,2),KTYPE(33) / 1HL, 1HD, 2 /
DATA ICMNDS(34,1),ICMNDS(34,2),KTYPE(34) / 1HL, 1HI, 6 /
DATA ICMNDS(35,1),ICMNDS(35,2),KTYPE(35) / 1HL, 1HO, 2 /
DATA ICMNDS(36,1),ICMNDS(36,2),KTYPE(36) / 1HL, 1HP, 2 /
DATA ICMNDS(37,1),ICMNDS(37,2),KTYPE(37) / 1HM, 1HU, 2 /
DATA ICMNDS(38,1),ICMNDS(38,2),KTYPE(38) / 1HN, 1HE, 6 /
DATA ICMNDS(39,1),ICMNDS(39,2),KTYPE(39) / 1HN, 1HO, 6 /
DATA ICMNDS(40,1),ICMNDS(40,2),KTYPE(40) / 1HO, 1HU, 6 /
DATA ICMNDS(41,1),ICMNDS(41,2),KTYPE(41) / 1HP, 1H1, 3 /
DATA ICMNDS(42,1),ICMNDS(42,2),KTYPE(42) / 1HP, 1H2, 3 /
DATA ICMNDS(43,1),ICMNDS(43,2),KTYPE(43) / 1HP, 1H3, 3 /
DATA ICMNDS(44,1),ICMNDS(44,2),KTYPE(44) / 1HP, 1HA, 2 /
DATA ICMNDS(45,1),ICMNDS(45,2),KTYPE(45) / 1HP, 1HL, 6 /
DATA ICMNDS(46,1),ICMNDS(46,2),KTYPE(46) / 1HQ, 1HU, 6 /
DATA ICMNDS(47,1),ICMNDS(47,2),KTYPE(47) / 1HR, 1HC, 2 /
DATA ICMNDS(48,1),ICMNDS(48,2),KTYPE(48) / 1HR, 1HD, 2 /
DATA ICMNDS(49,1),ICMNDS(49,2),KTYPE(49) / 1HR, 1HE, 6 /
DATA ICMNDS(50,1),ICMNDS(50,2),KTYPE(50) / 1HR, 1HO, 4 /
DATA ICMNDS(51,1),ICMNDS(51,2),KTYPE(51) / 1HR, 1HP, 2 /
DATA ICMNDS(52,1),ICMNDS(52,2),KTYPE(52) / 1HR, 1HS, 6 /
DATA ICMNDS(53,1),ICMNDS(53,2),KTYPE(53) / 1HR, 1HW, 2 /
DATA ICMNDS(54,1),ICMNDS(54,2),KTYPE(54) / 1HS, 1HE, 6 /
DATA ICMNDS(55,1),ICMNDS(55,2),KTYPE(55) / 1HS, 1HH, 2 /
DATA ICMNDS(56,1),ICMNDS(56,2),KTYPE(56) / 1HS, 1HT, 6 /
DATA ICMNDS(57,1),ICMNDS(57,2),KTYPE(57) / 1HT, 1HC, 2 /
DATA ICMNDS(58,1),ICMNDS(58,2),KTYPE(58) / 1HT, 1HN, 6 /
DATA ICMNDS(59,1),ICMNDS(59,2),KTYPE(59) / 1HT, 1HY, 7 /
DATA ICMNDS(60,1),ICMNDS(60,2),KTYPE(60) / 1HU, 1HN, 6 /
DATA ICMNDS(61,1),ICMNDS(61,2),KTYPE(61) / 1HU, 1HS, 6 /
DATA ICMNDS(62,1),ICMNDS(62,2),KTYPE(62) / 1HW, 1HA, 6 /
DATA ICMNDS(63,1),ICMNDS(63,2),KTYPE(63) / 1HZ, 1HO, 2 /
C
C
MHELP = 0
IPROMT = 1
JP = LINES-IPRMPT
JPROMT = JP - 1
IF ( .NOT.LSCRN ) GO TO 100
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
100 CONTINUE
NCMND = NCMND + 1
WRITE (OUTPUT,60000) NCMND
IF (LCHN.NE.0) WRITE (LCHN,60000) NCMND
IF (LSCRN) CALL PCURSR(OUTPUT,11,JP)
200 CONTINUE
READ (INPUTD,65000) CHAR1,CHAR2
IF (CHAR1.EQ.PLS.OR.CHAR2.EQ.PLS) GO TO 200
IF (LCHN.NE.0) WRITE (LCHN,10000) CHAR1,CHAR2
CALL LCUC(CHAR1)
CALL LCUC(CHAR2)
C
C CHECK FOR QUESTION MARKS
C
IF (CHAR1.NE.IQ.AND.CHAR2.NE.IQ) GO TO 400
IF (.NOT.LSCRN) GO TO 300
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
300 CONTINUE
WRITE (OUTPUT,15000)
IF (LSCRN) CALL PCURSR(OUTPUT,72,JP)
IF (LCHN.NE.0) WRITE (LCHN,15000)
GO TO 200
400 CONTINUE
C
C RECOGNIZE THE COMMAND BY MATCHING CHAR1 AND CHAR2 TO THE ICMNDS ARRAY
C
MODE = 6
DO 500 I = 1,JHELP3
IF ( .NOT.(CHAR1.EQ.ICMNDS(I,1).AND.CHAR2.EQ.ICMNDS(I,2)) )
X GO TO 500
ICOM = I
MODE = KTYPE(I)
GO TO 700
500 CONTINUE
C
C COMMAND NOT RECOGNIZED - OUTPUT ERROR MESSAGE AND TRY AGAIN
C
IF (.NOT.LSCRN) GO TO 600
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
600 CONTINUE
WRITE (OUTPUT,75000) CHAR1,CHAR2
IF (LSCRN) CALL PCURSR(OUTPUT,59,JP)
IF (LCHN.NE.0) WRITE (LCHN,75000) CHAR1,CHAR2
GO TO 200
C
C IF PREVIOUS COMMAND WAS HE (I.E.DETAILED HELP COMMAND) THEN SET IARG
C TO THE JUST RECOGNIZED COMMAND, AND RETURN.
C
700 CONTINUE
IF ( MHELP.NE.1 ) GO TO 800
IARG = ICOM
ICOM = 26
RETURN
C
C NOW THAT THE COMMAND IS RECOGNIZED, PROCEED TO THE NEXT STAGE
C WHICH DEPENDS ON THE MODE OF THE COMMAND. (SEE EXPLANATION AT TOP)
C
800 CONTINUE
IF (MODE.EQ.1.OR.MODE.EQ.6) GO TO 1000
IF (.NOT.LSCRN) GO TO 900
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
900 CONTINUE
WRITE (OUTPUT,70000) (IHELP(J,ICOM),J=1,72)
IF (LCHN.NE.0) WRITE (LCHN,70000) (IHELP(J,ICOM),J=1,72)
1000 CONTINUE
GO TO (1100,1300,1600,1900,2200,2900,2700),MODE
C
C PLACE IN HELP MODE
C
1100 MHELP = 1
IF (.NOT.LSCRN) GO TO 1200
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
1200 CONTINUE
WRITE (OUTPUT,85000)
IF (LSCRN) CALL PCURSR(OUTPUT,42,JP)
IF (LCHN.NE.0) WRITE (LCHN,85000)
GO TO 200
C
C INPUT SINGLE INTEGER ARGUMENT
C
1300 CONTINUE
1400 CALL SIREAD(INPUTD,IARG,ERR)
IF ( ERR ) GO TO 2900
IF ( .NOT.LSCRN ) GO TO 1500
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
1500 WRITE (OUTPUT,80000)
IF (LCHN.NE.0) WRITE (LCHN,80000)
GO TO 1400
C
C INPUT SINGLE DOUBLE PRECISION ARGUMENT
C
1600 CONTINUE
1700 CONTINUE
CALL SRREAD(INPUTD,DARG,ERR)
IF ( ERR ) GO TO 2900
IF ( .NOT.LSCRN ) GO TO 1800
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
1800 WRITE (OUTPUT,80000)
IF (LCHN.NE.0) WRITE (LCHN,80000)
GO TO 1700
C
C INPUT DOUBLE PRECISION VECTOR
C
1900 CONTINUE
2000 CONTINUE
CALL SVREAD(INPUTD,NLINES,IOPDM(2),V1,ERR)
IF ( NLINES.GT.1 ) LSCRN = .FALSE.
IF ( ERR ) GO TO 2900
IF ( .NOT.LSCRN ) GO TO 2100
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
2100 WRITE (OUTPUT,80000)
IF (LCHN.NE.0) WRITE (LCHN,80000)
GO TO 2000
C
C INPUT TWO DOUBLE PRECISION VECTORS
C
2200 CONTINUE
2300 CONTINUE
CALL SVREAD(INPUTD,NLINES,IOPDM(2),V1,ERR)
IF ( NLINES.GT.1 ) LSCRN = .FALSE.
IF ( ERR ) GO TO 2500
IF ( .NOT.LSCRN ) GO TO 2400
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
2400 WRITE (OUTPUT,80000)
IF (LCHN.NE.0) WRITE (LCHN,80000)
GO TO 2300
2500 CALL SVREAD(INPUTD,NLINES,IOPDM(2),V2,ERR)
IF ( NLINES.GT.1 ) LSCRN = .FALSE.
IF ( ERR ) GO TO 2900
IF ( .NOT.LSCRN ) GO TO 2600
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
2600 WRITE (OUTPUT,80000)
IF (LCHN.NE.0) WRITE (LCHN,80000)
GO TO 2500
C
C READ 2 INTEGER ARGUMENTS
C
2700 CALL DIREAD(INPUTD,IARG,IARGP,ERR)
IF ( ERR ) GO TO 2900
IF ( .NOT.LSCRN ) GO TO 2800
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
2800 WRITE (OUTPUT,80000)
IF (LCHN.NE.0) WRITE (LCHN,80000)
GO TO 1400
C
C NO ARGUMENTS ARE NECESSARY
C
2900 CONTINUE
IF (LCHN.EQ.0) GO TO 3000
DMNSN = IOPDM(2)
IF (KTYPE(ICOM).EQ.1) WRITE (LCHN,20000) CHAR1,CHAR2
IF (KTYPE(ICOM).EQ.2) WRITE (LCHN,25000) CHAR1,CHAR2,IARG
IF (KTYPE(ICOM).EQ.3) WRITE (LCHN,30000) CHAR1,CHAR2,DARG
IF (KTYPE(ICOM).EQ.4) WRITE (LCHN,35000) CHAR1,CHAR2,(V1(I),I=1,
X DMNSN)
IF (KTYPE(ICOM).EQ.5) WRITE (LCHN,40000) CHAR1,CHAR2,(V1(I),I=1,
X DMNSN)
IF (KTYPE(ICOM).EQ.5) WRITE (LCHN,45000) CHAR1,CHAR2,(V2(I),I=1,
X DMNSN)
IF (KTYPE(ICOM).EQ.6) WRITE (LCHN,50000) CHAR1,CHAR2
IF (KTYPE(ICOM).EQ.7) WRITE (LCHN,55000) CHAR1,CHAR2,IARG,IARGP
3000 CONTINUE
RETURN
C
C FORMAT STATEMENTS
C
X (73H Type command name, LI for list of commands, HS for summary o
Xf commands )
Xmmand:)
END
SUBROUTINE LCUC(N)
C CONVERT A LOWER CASE LETTER STORED IN N INTO AN UPPER CASE LETTER.
C IF THE COMPUTING INSTALLATION DOES NOT SUPPORT LOWER CASE CHARACTERS
C THEN THIS ROUTINE SHOULD BE REPLACED BY A DUMMY ROUTINE
C
C SEQUENCE OF LETTER CHECKING IS DETERMINED BY FREQUENCIY WITH WHICH
C LETTERS OCCUR IN THE MICROSCOPE CODE. THIS HELPS EFFICIENCY IF LCUC
C IS USED FOR PROCESSING PARTS OF THE CODE.
INTEGER LC(26), UC(26)
INTEGER I, N, LBLNK
DATA UC(1),UC(2),UC(3),UC(4),UC(5),UC(6),UC(7),UC(8),UC(9),UC(10)
X / 1HO, 1HI, 1HE, 1HT, 1HN, 1HR, 1HC, 1HP, 1HD, 1HL/
DATA UC(11),UC(12),UC(13),UC(14),UC(15),UC(16),UC(17),UC(18)
X / 1HS, 1HA, 1HM, 1HU, 1HH, 1HF, 1HG, 1HB/
DATA UC(19),UC(20),UC(21),UC(22),UC(23),UC(24),UC(25),UC(26)
X / 1HW, 1HX, 1HY, 1HV, 1HK, 1HJ, 1HQ, 1HZ/
DATA LC(1),LC(2),LC(3),LC(4),LC(5),LC(6),LC(7),LC(8),LC(9),LC(10)
X / 1Ho, 1Hi, 1He, 1Ht, 1Hn, 1Hr, 1Hc, 1Hp, 1Hd, 1Hl/
DATA LC(11),LC(12),LC(13),LC(14),LC(15),LC(16),LC(17),LC(18)
X / 1Hs, 1Ha, 1Hm, 1Hu, 1Hh, 1Hf, 1Hg, 1Hb/
DATA LC(19),LC(20),LC(21),LC(22),LC(23),LC(24),LC(25),LC(26)
X / 1Hw, 1Hx, 1Hy, 1Hv, 1Hk, 1Hj, 1Hq, 1Hz/
C FIRST CHECK FOR A BLANK - THE MOST FREQUENTLY OCCURING CASE
IF (N.EQ.LBLNK) RETURN
DO 100 I = 1,26
IF (N.NE.LC(I).AND.N.NE.UC(I)) GO TO 100
N = UC(I)
RETURN
100 CONTINUE
RETURN
END
SUBROUTINE SDDATA(DEVICE,MODE,NCALLS,LGO)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C ROUTINE: SDDATA
C PURPOSE: TO DISPLAY THE NUMERICAL DATA CORRESPONDING TO THE PLOTTED
C DATA. THE ROUTINE HAS TWO MODES:
C MODE = 1 : SCROLLING MODE
C MODE = 2 : GRAPHICS MODE, IN WHICH THE SCREEN IS
C CLEARED BELOW THE PLOT AND THE DATA
C IS THEN DISPLAYED IN THE CLEARED REGION
C
INTEGER MIN0
INTEGER NF, IEQ
DOUBLE PRECISION H, V(3), SW, DNH
DOUBLE PRECISION DSH, DNW, DMNMX(2,3)
INTEGER I, J, K, KP
INTEGER MDF(3), NDF(7), IEND, JEND
INTEGER MODE, IBEG, DEVICE, NCALLS
INTEGER NDER, NCOUNT
LOGICAL LGO
DOUBLE PRECISION CBDSW, CBD, CBDU
INTEGER ICBD
LOGICAL LCBD
COMMON / CB / CBDSW, CBD(3), CBDU(3), ICBD
COMMON / CB / LCBD
INTEGER INPUTD, GRAPHD, HELPD, RECORD
INTEGER RSTRTD
COMMON / IO / INPUTD, GRAPHD, HELPD, RECORD
COMMON / IO / RSTRTD
INTEGER LCHN
COMMON / LOG / LCHN
DOUBLE PRECISION XS, FS, DF, DFMNMX
COMMON / FUNCOM / XS(5377), FS(5377), DF(135,7)
COMMON / FUNCOM / DFMNMX(2,7)
INTEGER PLOAD, DLOAD, CLOAD
COMMON / LOADIO / PLOAD, DLOAD, CLOAD
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 DMNSN
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)
LOGICAL NORMAL
COMMON / NRMLZE / NORMAL
INTEGER ILPUSR, IDSUSR
COMMON / ROOM / ILPUSR, IDSUSR
EQUIVALENCE (DMNSN,IOPDM(2))
DATA NF /1HF/, IEQ /1H=/
C
C IF MODE = 2, CLEAR THE SCREEN BELOW PLOTTING AREA AND DISPLAY DATA
C
IF ( MODE.EQ.1 ) GO TO 100
I = 1
J = LINES-IDSPLA-1
CALL CLSCRN(DEVICE,I,J)
CALL PCURSR(DEVICE,I,J)
100 CONTINUE
C
C CHECK IF THERE IS ROOM TO SEPARATE GRAPHICAL AND NUMERICAL OUTPUT
C
NCOUNT = 0
DO 200 I = 1,7
IF (OPDF1(I,2)) NCOUNT = NCOUNT + 1
200 CONTINUE
IF (NCOUNT.GT.6.OR.(NCOUNT.GT.3.AND.ICBD.NE.0.AND.ILP.EQ.ILPUSR))
X GO TO 300
WRITE (DEVICE,80000) (IEQ,I=1,WIDTH)
300 CONTINUE
C
C NEXT, DISPLAY CROSS DIRECTION DATA IF RELEVANT
C
IF (ICBD.EQ.0) GO TO 400
IF (DMNSN.EQ.1) WRITE (DEVICE,30000) ICBD,CBDU(1),CBDSW
IF (DMNSN.EQ.2) WRITE (DEVICE,45000) ICBD,CBDU(1),CBDU(2),CBDSW
IF (DMNSN.EQ.3) WRITE (DEVICE,60000) ICBD,CBDU(1),CBDU(2),CBDU(3),
X CBDSW
400 CONTINUE
DNH = NH(2)
DNW = NW(2)
DSH = IOPSH(2)
H = ROPSTS(2)*DNH/8.0D0
SW = ROPSTS(2)*DNW/8.0D0
DO 500 I = 1,3
V(I) = ROPPNT(I,2)+DSH*H*ROPUDI(I,2)
500 CONTINUE
GO TO (600,700,800),DMNSN
600 WRITE (DEVICE,35000) V(1),H
WRITE (DEVICE,40000) ROPDI(1,2),SW
GO TO 900
700 WRITE (DEVICE,50000) V(1),V(2),H
WRITE (DEVICE,55000) (ROPDI(I,2),I=1,2),SW
GO TO 900
800 WRITE (DEVICE,65000) V(1),V(2),V(3),H
WRITE (DEVICE,70000) (ROPDI(I,2),I=1,3),SW
900 CONTINUE
C
C NEXT, DISPLAY THE MINIMUM/MAXIMUM'S OF THE PLOTTED DERIVATIVES
C
NDER = 0
DO 1000 I = 1,7
IF ( .NOT.OPDF1(I,2) ) GO TO 1000
NDER = NDER+1
NDF(NDER) = I-1
1000 CONTINUE
IF ( NDER.EQ.0 ) GO TO 1300
DO 1200 I = 1,3
IBEG = (I-1)*3+1
IEND = IBEG+2
IEND = MIN0(NDER,IEND)
IF ( IEND.LT.IBEG ) GO TO 1300
JEND = IEND - IBEG + 1
DO 1100 J = 1,JEND
K = IBEG+J-1
KP = NDF(K)+1
MDF(J) = NDF(K)
DMNMX(1,J)= DFMNMX(1,KP)
DMNMX(2,J)= DFMNMX(2,KP)
1100 CONTINUE
IEND = IEND-IBEG+1
WRITE (DEVICE,75000) (NF,MDF(J),(DMNMX(K,J),K=1,2),J=1,IEND)
1200 CONTINUE
C
C DISPLAY THE NUMBER OF CALLS TO THE INTERPOLATION FUNCTION
C
1300 CONTINUE
IF (.NOT.NORMAL.AND.LGO) WRITE (DEVICE,10000) INPUTD,OUTPUT,
X GRAPHD,HELPD,RECORD,RSTRTD,LCHN,PLOAD,DLOAD,CLOAD,NCALLS
IF (NORMAL.AND.LGO) WRITE (DEVICE,15000) INPUTD,OUTPUT,GRAPHD,
X HELPD,RECORD,RSTRTD,LCHN,PLOAD,DLOAD,CLOAD,NCALLS
IF (.NOT.NORMAL.AND..NOT.LGO) WRITE (DEVICE,20000) INPUTD,OUTPUT,
X GRAPHD,HELPD,RECORD,RSTRTD,LCHN,PLOAD,DLOAD,CLOAD,NCALLS
IF (NORMAL.AND..NOT.LGO) WRITE (DEVICE,25000) INPUTD,OUTPUT,
X GRAPHD,HELPD,RECORD,RSTRTD,LCHN,PLOAD,DLOAD,CLOAD,NCALLS
RETURN
C
C FORMAT STATEMENTS
C
X8H) ch = ,1PD12.4)
X 7H s = ,1PD12.4)
X 7H h = ,1PD12.4)
X8H) ch = ,1PD12.4)
X 7H s = ,1PD12.4)
X 7H h = ,1PD12.4)
END
SUBROUTINE SUBHE(ITYPE,ICOM,MODE)
C
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C ROUTINE: SUBHE
C PURPOSE: TO OUTPUT HELP INFORMATION. THERE ARE TWO MODES:
C (1) OUTPUT THE LIST OF COMMANDS AND BRIEF DESCRIPTIONS
C (2) OUTPUT A DETAILED DESCRIPTION OF THE ICOM'TH COMMAND
C ALONG WITH THE VALUES OF THE CORRESPONDING
C PARAMETERS
C
INTEGER ISTOP
DOUBLE PRECISION DH, ANW2
INTEGER I, J, L3, IM
INTEGER KW, NH2, NW2, LCH
INTEGER ILN, KACC, IEND, MODE
INTEGER IBEG, IWHICH(7), ITEMP, ICOM
INTEGER IDUM, ILINES, ITYPE
INTEGER CHAR(72), ICNT, KCNT, IOUT
DOUBLE PRECISION CBDSW, CBD, CBDU
INTEGER ICBD
LOGICAL LCBD
COMMON / CB / CBDSW, CBD(3), CBDU(3), ICBD
COMMON / CB / LCBD
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
DOUBLE PRECISION ROPDI, ROPPNT, ROPDR1, ROPDR2
DOUBLE PRECISION ROPSTS, ROPSTW, ROPUDI
INTEGER NH, NW, ILEFT, IRIGHT
INTEGER IOPDM, IOPSH, IOPSS, IOPWN
INTEGER DMNSN
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)
LOGICAL NORMAL
COMMON / NRMLZE / NORMAL
INTEGER HELP, JHELP1, JHELP2, JHELP3
INTEGER JHELP, IHELP
COMMON / HELPER / HELP, JHELP1, JHELP2, JHELP3
COMMON / HELPER / JHELP(99,2), IHELP(72,99)
INTEGER INPUTD, GRAPHD, HELPD, RECORD
INTEGER RSTRTD
COMMON / IO / INPUTD, GRAPHD, HELPD, RECORD
COMMON / IO / RSTRTD
INTEGER ITXT(72)
EQUIVALENCE (DMNSN,IOPDM(2))
DATA ISTOP /1H./
C
C SET LSCRN TO .FALSE. SIGNIFYING THAT THE GRAPH HAS BEEN OVERWRITTEN
C
LSCRN = .FALSE.
ITYPE = 4
C
CALL BLSCRN(OUTPUT)
CALL PCURSR(OUTPUT,1,1)
GO TO (100,400),MODE
C
C MODE 1: OUTPUT THE LIST OF COMMANDS AND THEIR BRIEF DESCRIPTIONS
C
100 CONTINUE
CALL POS(HELPD,6)
L3 = LINES - 3
ICNT = JHELP1
ILN = 0
200 CONTINUE
ILINES = ICNT
IF (ILINES.GT.L3) ILINES = L3
ICNT = ICNT - ILINES
DO 300 I = 1,ILINES
ILN = ILN+1
READ (HELPD,44000) (ITXT(J),J=1,72)
WRITE (OUTPUT,46000) (ITXT(J),J=1,72)
300 CONTINUE
IF (ICNT.EQ.0) GO TO 2700
WRITE (OUTPUT,48000)
READ (INPUTD,50000) IDUM
IF (IDUM.EQ.ISTOP) GO TO 2700
CALL PCURSR(OUTPUT,1,L3)
GO TO 200
C
C MODE 2: DETAILED DESCRIPTION OF THE ICOM'TH COMMAND
C
400 CONTINUE
C
C SET UP A LOOP FOR OUTPUTING INFORMATION - ONCE IF NO LOGGING IS
C REQUIRED, TWICE OTHERWISE
C
DO 2600 ICNT = 1,2
IF (ICNT.EQ.1) IOUT = OUTPUT
IF (ICNT.EQ.2.AND.LCHN.EQ.0) GO TO 2600
IF (ICNT.EQ.2) IOUT = LCHN
IBEG = JHELP(ICOM,1)
IEND = JHELP(ICOM,2)
NL = 5+IBEG
CALL POS(HELPD,NL)
DO 500 I = IBEG,IEND
READ (HELPD,44000) (ITXT(J),J=1,72)
WRITE (OUTPUT,46000) (ITXT(J),J=1,72)
500 CONTINUE
DH = NH(2)
ANW2 = NW(2)
DH = ANW2*ROPSTS(2)/8.0D0
WRITE (IOUT,52000)
GO TO (600,2200,2200,2200,2600,2200,2200,2200,1000,1800,1800,
X 1800,1100,1200,2100,1500,2100,1600,1700,1200,2600,1800,
X 2600,2600,2100,2600,2600,1800,2100,1900,2000,2200,1800,
X 2600,2400,2000,2100,2600,2500,2600,2000,2000,2000,2600,
X 2600,2600,2600,2600,2600,1800,2600,2600,2600,2600,2000,
X 2600,2600,2600,2600,2600,2600,2600,1000),ICOM
600 CONTINUE
C HELP FOR THE ACCENT COMMAND
KACC = 0
DO 700 I = 1,7
IF (OPDF2(I,2)) KACC = KACC+1
700 CONTINUE
IF (KACC.GT.0) GO TO 800
WRITE (IOUT,10000)
GO TO 2600
800 CONTINUE
DO 900 I = 1,7
IM = I-1
IF (OPDF2(I,2)) WRITE (IOUT,12000) IM
900 CONTINUE
IF (KACC.GT.1) WRITE (IOUT,14000)
GO TO 2600
1000 CONTINUE
C HELP FOR THE CWINDOW COMMAND
NW2 = 2*NW(2)
NH2 = NH(2)
KW = NW2/NH2
IF (KW*NH2.EQ.NW2) WRITE (IOUT,16000) KW
IF (KW*NH2.NE.NW2) WRITE (IOUT,18000) NW2,NH2
GO TO 2600
1100 CONTINUE
C Help for the DCENTER command
IF (OPDC(2)) WRITE (IOUT,20000)
IF (.NOT.OPDC(2)) WRITE (IOUT,22000)
GO TO 2600
1200 CONTINUE
C INDICATE WHICH GRAPHS ARE BEING DRAWN (ACCORDING TO OPDF1)
KCNT = 0
DO 1300 I = 1,7
IF (.NOT.OPDF1(I,2)) GO TO 1300
KCNT = KCNT+1
IWHICH(KCNT) = I-1
1300 CONTINUE
IF (KCNT.GT.0) GO TO 1400
WRITE (IOUT,24000)
GO TO 2600
1400 CONTINUE
WRITE (IOUT,26000) (IWHICH(J),J=1,KCNT)
GO TO 2600
1500 CONTINUE
C WRITE THE CURRENT DIMENSION
WRITE (IOUT,54000) IOPDM(2)
GO TO 2600
1600 CONTINUE
C INDICATE WHETHER A SCALE IS BEING DRAWN
IF (OPDS(2)) WRITE (IOUT,30000)
IF (.NOT.OPDS(2)) WRITE (IOUT,28000)
GO TO 2600
1700 CONTINUE
C INDICATE WHETHER A HORIZONTAL AXIS IS BEING DRAWN
IF (OPDX(2)) WRITE (IOUT,32000)
IF (.NOT.OPDX(2)) WRITE (IOUT,34000)
GO TO 2600
1800 CONTINUE
C DESCRIBE THE CURRENT DIRECTION OF INVESTIGATION
WRITE (IOUT,58000) (ROPDI(I,2),I=1,DMNSN)
GO TO 2600
1900 CONTINUE
C give help for IINTVL
CONTINUE
WRITE (IOUT,36000) (ROPDR1(I,2),I=1,DMNSN)
WRITE (IOUT,38000) (ROPDR2(I,2),I=1,DMNSN)
GO TO 2600
2000 CONTINUE
C Give the curren point of examination
WRITE (IOUT,60000) (ROPPNT(I,2),I=1,DMNSN)
GO TO 2600
2100 CONTINUE
C Give the current value of h
WRITE (IOUT,56000) DH
GO TO 2600
2200 CONTINUE
IF (ICBD.GT.0) GO TO 2300
WRITE (IOUT,62000)
GO TO 2600
2300 CONTINUE
WRITE (IOUT,64000) ICBD,(CBDU(J),J=1,DMNSN)
WRITE (IOUT,66000) CBDSW
GO TO 2600
2400 CONTINUE
IF (LCHN.EQ.0) WRITE (IOUT,68000)
IF (LCHN.NE.0) WRITE (IOUT,70000) LCH
GO TO 2600
2500 CONTINUE
IF (NORMAL) WRITE (IOUT,40000)
IF (.NOT.NORMAL) WRITE (IOUT,42000)
2600 CONTINUE
2700 CONTINUE
RETURN
C
C FORMAT STATEMENTS
C
X ,18H being accentuated)
X D12.4)
X16H - direction is:/3D16.6)
END
SUBROUTINE SUBLI(ITYPE)
INTEGER I, J, ITYPE
INTEGER OUTPUT, LINES, WIDTH, ILP
INTEGER IDSPLA, IPRMPT
LOGICAL LSCRN
COMMON / SCREEN / OUTPUT, LINES, WIDTH, ILP
COMMON / SCREEN / IDSPLA, IPRMPT, LSCRN
INTEGER HELP, JHELP1, JHELP2, JHELP3
INTEGER JHELP, IHELP
COMMON / HELPER / HELP, JHELP1, JHELP2, JHELP3
COMMON / HELPER / JHELP(99,2), IHELP(72,99)
ITYPE = 4
LSCRN = .FALSE.
WRITE (OUTPUT,10000) JHELP3
WRITE (OUTPUT,20000) ((IHELP(I,J),I=1,7),J=1,JHELP3)
WRITE (OUTPUT,30000)
RETURN
END
SUBROUTINE SUBNE(ITYPE)
C PRINT ANY NEWS THAT MAY BE AVAILABLE
LOGICAL OK
INTEGER HELP, JHELP1, JHELP2, JHELP3
INTEGER JHELP, IHELP
COMMON / HELPER / HELP, JHELP1, JHELP2, JHELP3
COMMON / HELPER / JHELP(99,2), IHELP(72,99)
INTEGER ISTOP
INTEGER I, J, L3, ILN
INTEGER IDUM, ILINES, ITYPE, ICNT
INTEGER INPUTD, GRAPHD, HELPD, RECORD
INTEGER RSTRTD
COMMON / IO / INPUTD, GRAPHD, HELPD, RECORD
COMMON / IO / RSTRTD
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
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
INTEGER DMNSN
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)
INTEGER ITXT(72)
EQUIVALENCE (DMNSN,IOPDM(2))
DATA ISTOP /1H./
C
C SET LSCRN TO .FALSE. SIGNIFYING THAT THE GRAPH HAS BEEN OVERWRITTEN
C
LSCRN = .FALSE.
ITYPE = 4
CONTINUE
CALL BLSCRN(OUTPUT)
CALL PCURSR(OUTPUT,1,1)
NL = 6+JHELP1+JHELP2+JHELP3
CALL POS(HELPD,NL)
CALL SIREAD(HELPD,NNEWS,OK)
IF (OK) GO TO 100
WRITE (OUTPUT,20000)
READ (INPUTD,10000) IDMY
GO TO 400
100 CONTINUE
L3 = LINES - 3
ICNT = NNEWS
ILN = 0
200 CONTINUE
ILINES = ICNT
IF (ILINES.GT.L3) ILINES = L3
ICNT = ICNT - ILINES
DO 300 I = 1,ILINES
ILN = ILN+1
READ (HELPD,30000) (ITXT(J),J=1,72)
WRITE (OUTPUT,40000) (ITXT(J),J=1,72)
300 CONTINUE
IF (ICNT.EQ.0) GO TO 400
WRITE (OUTPUT,60000)
READ (INPUTD,70000) IDUM
IF (IDUM.EQ.ISTOP) GO TO 400
CALL PCURSR(OUTPUT,1,L3)
GO TO 200
400 CONTINUE
RETURN
C
C FORMAT STATEMENTS
C
X /20H type CR to continue)
END
SUBROUTINE SUBPA(ITYPE,ICH)
C CONTINUE PROCESSING ONLY AFTER READING ANY CHARACTER ON CHANNEL ICH
C OR ON INPUTD IF ICH = 0
INTEGER J, II, ICH, IPROMT
INTEGER JPROMT, ITYPE
INTEGER INPUTD, GRAPHD, HELPD, RECORD
INTEGER RSTRTD
COMMON / IO / INPUTD, GRAPHD, HELPD, RECORD
COMMON / IO / RSTRTD
INTEGER OUTPUT, LINES, WIDTH, ILP
INTEGER IDSPLA, IPRMPT
LOGICAL LSCRN
COMMON / SCREEN / OUTPUT, LINES, WIDTH, ILP
COMMON / SCREEN / IDSPLA, IPRMPT, LSCRN
II = ICH
IF (ICH.EQ.0) II = INPUTD
ITYPE = 4
IPROMT = 1
JPROMT = LINES-IPRMPT-1
IF ( .NOT.LSCRN ) GO TO 100
CALL CLSCRN(OUTPUT,IPROMT,JPROMT)
CALL PCURSR(OUTPUT,IPROMT,JPROMT)
100 WRITE (OUTPUT,10000) II
READ (II,20000) J
RETURN
END
SUBROUTINE SUBTC(ITYPE,IARG,INPUTD)
C TYPE THE VALUE OF THE IARGTH DERIVATIVE AT THE CENTER OF THE DISPLAY
INTEGER IARG, IPROPT, JPROPT, ITYPE
INTEGER IDER, ICNTR, INPUTD
INTEGER LCHN
COMMON / LOG / LCHN
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 OUTPUT, LINES, WIDTH, ILP
INTEGER IDSPLA, IPRMPT
LOGICAL LSCRN
COMMON / SCREEN / OUTPUT, LINES, WIDTH, ILP
COMMON / SCREEN / IDSPLA, IPRMPT, LSCRN
ITYPE = 4
IPROPT = 1
JPROPT = LINES - 3
IF (.NOT.LSCRN) GO TO 100
CALL CLSCRN(OUTPUT,IPROPT,JPROPT)
CALL PCURSR(OUTPUT,IPROPT,JPROPT)
100 CONTINUE
IF (IARG.LT.0.OR.IARG.GT.6) GO TO 200
IDER = IARG+1
IF (.NOT.LDF(IDER)) GO TO 200
ICNTR = WIDTH/2+1
WRITE (OUTPUT,10000) IARG,DF(ICNTR,IDER)
IF (LCHN.NE.0) WRITE (LCHN,10000) IARG,DF(ICNTR,IDER)
GO TO 300
200 CONTINUE
WRITE (OUTPUT,20000) IARG
IF (LCHN.NE.0) WRITE (LCHN,20000) IARG
300 CONTINUE
WRITE (OUTPUT,30000)
JPROPT = JPROPT + 1
IF (LSCRN) CALL PCURSR(OUTPUT,IPROPT,JPROPT)
READ (INPUTD,40000) IPROPT
RETURN
END
C
SUBROUTINE SUBTN(ITYPE,RECORD,INPUTD,OUTPUT,GRAPHD,WIDTH,LSCRN)
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
C ROUTINE: SUBTN
C PURPOSE: TO "TAKE NOTE". THIS ROUTINE ALLOWS THE USER TO WRITE
C COMMENTS ONTO THE FILE ASSIGNED TO THE DEVICE: RECORD.
C TO END THE COMMENTS TYPE "EC" IN THE FIRST TWO COLUMNS
C OF INPUT.
C
INTEGER C, E, BLANK
INTEGER I, J, C1, C2
INTEGER WW, NWW, RECORD, GRAPHD
INTEGER OUTPUT, ITYPE, CHAR(135), WIDTH
INTEGER INPUTD
LOGICAL LSCRN
C- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C
C COMMON BLOCK / LOG /
C
INTEGER LCHN
COMMON / LOG / LCHN
C
DATA E,C,BLANK / 1HE, 1HC, 1H /
IF ( OUTPUT.EQ.GRAPHD ) LSCRN = .FALSE.
WW = WIDTH
IF (WW.LT.80) WW = 80
ITYPE = 4
WRITE (OUTPUT,10000)
100 READ (INPUTD,20000) (CHAR(I),I=1,WW)
C1 = CHAR(1)
C2 = CHAR(2)
IF ( C1.EQ.E .AND. C2.EQ.C ) GO TO 400
C STRIP TRAILING BLANKS
NWW = WW
DO 200 I = 1,WW
J = WW-I+1
IF (CHAR(J).NE.BLANK) GO TO 300
NWW = NWW-1
200 CONTINUE
300 CONTINUE
WRITE (RECORD,30000) (CHAR(I),I=1,NWW)
IF (LCHN.NE.0) WRITE (LCHN,30000) (CHAR(I),I=1,NWW)
GO TO 100
400 CONTINUE
RETURN
C
C FORMAT STATEMENTS
C
END
SUBROUTINE SUBTY(ITYPE,IARG,IARGP,INPUTD,GRAPHD)
C TYPE THE VALUE OF THE IARGTH DERIVATIVE AT THE IARGPTH POSITION IN THE
C DISPLAY
INTEGER IM(1)
INTEGER I, IARG, IARGP, IPROPT
INTEGER JPROPT, GRAPHD, ITYPE, IDER
INTEGER ICNTR, COLUMN(57), INPUTD
INTEGER LCHN
COMMON / LOG / LCHN
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
DATA IM(1) /1H!/
ITYPE = 4
IPROPT = 1
JPROPT = LINES - 3
IF (.NOT.LSCRN) GO TO 100
CALL CLSCRN(OUTPUT,IPROPT,JPROPT)
CALL PCURSR(OUTPUT,IPROPT,JPROPT)
100 CONTINUE
IF (IARG.LT.0.OR.IARG.GT.6) GO TO 400
IDER = IARG+1
IF (.NOT.LDF(IDER)) GO TO 400
ICNTR = WIDTH/2+1
ICNTR = ICNTR + IARGP
IF (ICNTR.LT.0.OR.ICNTR.GT.WIDTH) GO TO 500
WRITE (OUTPUT,10000) IARG,IARGP,DF(ICNTR,IDER)
IF (LCHN.NE.0) WRITE (LCHN,10000) IARG,IARGP,DF(ICNTR,IDER)
IF (.NOT.LSCRN) GO TO 600
DO 200 I = 1,ILP
COLUMN(I) = ISCRN2(ICNTR,I)
CALL PLCHRS(GRAPHD,ICNTR,I,1,IM)
200 CONTINUE
DO 300 I = 1,ILP
CALL PLCHRS(GRAPHD,ICNTR,I,1,COLUMN(I))
300 CONTINUE
GO TO 600
400 CONTINUE
WRITE (OUTPUT,20000) IARG
IF (LCHN.NE.0) WRITE (LCHN,20000) IARG
GO TO 600
500 CONTINUE
WRITE (OUTPUT,30000) IARGP
IF (LCHN.NE.0) WRITE (LCHN,30000) IARGP
600 CONTINUE
JPROPT = JPROPT + 1
IF (LSCRN) CALL PCURSR(OUTPUT,IPROPT,JPROPT)
WRITE (OUTPUT,40000)
IF (LSCRN) CALL PCURSR(OUTPUT,IPROPT,JPROPT)
READ (INPUTD,50000) IPROPT
RETURN
END
.
