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 10000 FORMAT(//24H Type NEWS to read://) 12000 FORMAT(72A1//) 14000 FORMAT(//12H Reentering ) 16000 FORMAT(//10H Entering ) 18000 FORMAT(/11H MICROSCOPE/ X 25H Version 1.0 - 15-JUN-84//) 20000 FORMAT(39H The value of LINES must be at least 11) 22000 FORMAT(39H The value of LINES must not exceed 57 ) 24000 FORMAT(37H The value of WIDTH must be positive ) 26000 FORMAT(40H The value of WIDTH must not exceed 135 ) 28000 FORMAT(36H The value of PLOT must be positive ) 30000 FORMAT(39H The value of PROMPT must be at least 2) 32000 FORMAT(33H The value of PROMPT is too large) 34000 FORMAT(33H The value of NUMRCL is too small) 36000 FORMAT(34H The value of NUMRCL is too LARGE ) 38000 FORMAT(32H The value of PLOT is too large ) 40000 FORMAT(//15H Values given: /10H LINES = ,I4/10H WIDTH = ,I4/ X 10H PLOT = ,I4/10H NUMRCL = ,I4/10H PROMPT = ,I4/) 42000 FORMAT(52H See section 3 of the MICROSCOPE manual for details / X 24H Leaving MICROSCOPE ... //) 44000 FORMAT(27H Computations carry at most,I4,7H digits/) 46000 FORMAT(/) 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 10000 FORMAT(54H Error- AC: number of derivative not between 0 and 6) 12000 FORMAT(44H Error- CW: cannot have zero stencil-width) 14000 FORMAT(52H Error- P-I-: i is greater than current dimension) 16000 FORMAT(54H Error- DG: number of derivative not between 0 and 6) 18000 FORMAT(37H Error- DI: number must be non-zero) 20000 FORMAT(50H Error- DM: dimension of domain must be 1,2 or 3) 22000 FORMAT(54H Error- EG: number of derivative not between 0 and 6) 24000 FORMAT(48H Error- cannot accomodate desired sampling) 26000 FORMAT(44H Error- cannot find suitable h/s ratio) 28000 FORMAT(44H Error- cannot find suitable h/s ratio) 30000 FORMAT(49H Error- IS: step-size must be strictly positive) 32000 FORMAT(48H Error- ID: trivial direction vector was input) 34000 FORMAT(37H Error- MU: number must be non-zero) 36000 FORMAT(51H Error- II: beginning and end points are the same) 38000 FORMAT(37H Error- ZO: number must be non-zero) 40000 FORMAT(55H Error- CC: channel reference number must be in [1,5]) 42000 FORMAT(39H Error- CO: order not between 0 and 6) 44000 FORMAT(40H Error- CD: zero cross direction given) 46000 FORMAT(38H Error- CS: zero stencil-width given) 48000 FORMAT(52H Error- D-I-: i is greater than current dimension) 50000 FORMAT(52H Error- C-I-: i is greater than current dimension) 52000 FORMAT(31H Error- LP: cannot load point) 54000 FORMAT(41H Error- LC: cannot load cross direction) 56000 FORMAT(35H Error- LD: cannot load direction) 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 10000 FORMAT(1H ,2A1) 15000 FORMAT X (73H Type command name, LI for list of commands, HS for summary o Xf commands ) 20000 FORMAT(10H HELP on: ,2A1) 25000 FORMAT(10H command: ,2A1,11H argument: ,I6) 30000 FORMAT(10H command: ,2A1,11H argument: ,D16.8) 35000 FORMAT(10H command: ,2A1,11H argument: ,3D16.8) 40000 FORMAT(10H command: ,2A1,15H 1st argument: ,3D16.8) 45000 FORMAT(10H command: ,2A1,15H 2nd argument: ,3D16.8) 50000 FORMAT(10H command: ,2A1,14H no argument: ) 55000 FORMAT(10H command: ,2A1,12H arguments: ,2I6) 60000 FORMAT(I6,3H >>) 65000 FORMAT(2A1) 70000 FORMAT(1H ,72A1) 75000 FORMAT(1H ,2A1,54H (No such command) Type HS for summary. Input co Xmmand:) 80000 FORMAT(1H ,49H Error in numerical input - input number(s) again) 85000 FORMAT(1H ,39H Input command you want information on:) 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 10000 FORMAT(6H I/O: ,10I3,9H NRML off,10H current ,9H CALLS = ,I7) 15000 FORMAT(6H I/O: ,10I3,9H NRML on ,10H current ,9H CALLS = ,I7) 20000 FORMAT(6H I/O: ,10I3,9H NRML off,10H GO pndng ,9H CALLS = ,I7) 25000 FORMAT(6H I/O: ,10I3,9H NRML on ,10H GO pndng ,9H CALLS = ,I7) 30000 FORMAT(11H CD: deg = ,I2,8H dir = ,1PD14.6,7H ch = ,1PD12.4) 35000 FORMAT(21H Point = ,1PD14.6,7H s = ,1PD12.4) 40000 FORMAT(21H Direction = ,1PD14.6,7H h = ,1PD12.4) 45000 FORMAT(11H CD: deg = ,I2,8H dir = (,1PD14.6,1H,,1PD14.6, X8H) ch = ,1PD12.4) 50000 FORMAT(21H Point = (,1PD14.6,1H,,1PD14.6,1H), X 7H s = ,1PD12.4) 55000 FORMAT(21H Direction = (,1PD14.6,1H,,1PD14.6,1H), X 7H h = ,1PD12.4) 60000 FORMAT(11H CD: deg = ,I2,8H dir = (,D11.4,1H,,D11.4,1H,,D11.4, X8H) ch = ,1PD12.4) 65000 FORMAT(21H Point = (,D11.4,1H,,D11.4,1H,,D11.4,1H), X 7H s = ,1PD12.4) 70000 FORMAT(21H Direction = (,D11.4,1H,,D11.4,1H,,D11.4,1H), X 7H h = ,1PD12.4) 75000 FORMAT(3(1H ,A1,I1,2H (,1PD9.2,1H,,1PD9.2,1H))) 80000 FORMAT(1H ,135A1) 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 10000 FORMAT(38H no tangential derivative is currently X ,18H being accentuated) 12000 FORMAT(5H The ,I1,35H-th derivative is being accentuated) 14000 FORMAT(37H some graphs may be indistinguishable) 16000 FORMAT(33H The current window width 2h/s = ,I3) 18000 FORMAT(33H The current window width 2h/s = ,I3,1H/,I3) 20000 FORMAT(38H Currently, the center is being marked) 22000 FORMAT(39H Currently, the center is left unmarked) 24000 FORMAT(37H Currently no derivatives are plotted) 26000 FORMAT(40H The following derivatives are plotted: ,7I3) 28000 FORMAT(29H Currently, no scale is drawn) 30000 FORMAT(28H Currently, a scale is drawn) 32000 FORMAT(44H Currently, a horizontal axis is being drawn) 34000 FORMAT(45H Currently, no horizontal axis is being drawn) 36000 FORMAT(20H The endpoints are: /3D16.8) 38000 FORMAT(4H and/3D16.8) 40000 FORMAT(34H The normalization is currently on) 42000 FORMAT(35H The normalization is currently off) 44000 FORMAT(72A1) 46000 FORMAT(1H ,72A1) 48000 FORMAT(54H >>>> input CR to continue - . to stop summary) 50000 FORMAT(A1) 52000 FORMAT() 54000 FORMAT(40H The current dimension of the domain is ,I1) 56000 FORMAT(55H The current value of the discretization parameter is: , X D12.4) 58000 FORMAT(44H The current direction of investigation is: /3D16.8) 60000 FORMAT(38H The current point of examination is: /3D16.8) 62000 FORMAT(49H currently no cross derivative is being evaluated) 64000 FORMAT(I3,40H -th order derivative is being evaluated, X16H - direction is:/3D16.6) 66000 FORMAT(26H current stencil-width is:,D12.4) 68000 FORMAT(31H logging is currently inactive ) 70000 FORMAT(42H logging currently takes place on channel ,I3) 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 10000 FORMAT(14H the following,I4,34H commands are currently available:) 20000 FORMAT(9(1H ,7A1)) 30000 FORMAT(/50H NOTE: only the first two letters are significant) 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 10000 FORMAT(A1) 20000 FORMAT(34H did not locate news in help file X /20H type CR to continue) 30000 FORMAT(72A1) 40000 FORMAT(1H ,72A1) 60000 FORMAT(54H >>>> input CR to continue - . to stop summary) 70000 FORMAT(A1) 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 10000 FORMAT(20H pausing on channel ,I4) 20000 FORMAT(A1) 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 10000 FORMAT(I5,27H-th derivative at center = ,1PD29.20) 20000 FORMAT(I5,29H-th derivative not calculated) 30000 FORMAT(28H type for next command ) 40000 FORMAT(A1) 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 10000 FORMAT(46H Input comments (reenter program by typing EC)) 20000 FORMAT(135A1) 30000 FORMAT(1H ,135A1) 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 10000 FORMAT(I5,24H-th derivative at point ,I3,3H = ,1PD29.20) 20000 FORMAT(I5,29H-th derivative not calculated) 30000 FORMAT(I12,26H-th value is not in range ) 40000 FORMAT(28H type for next command ) 50000 FORMAT(A1) END