1      SUBROUTINE DPSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2     1                MAXNXT,ISEED,
3     1                ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
4C
5C     PURPOSE--GENERATE A STATISTIC PLOT FOR ONE OF DATAPLOT'S--
6C              SUPPORTED STATISTICS.
7C
8C     WRITTEN BY--JAMES J. FILLIBEN
9C                 STATISTICAL ENGINEERING DIVISION
10C                 INFORMATION TECHNOLOGY LABORATORY
11C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12C                 GAITHERSBURG, MD 20899-8980
13C                 PHONE--301-975-2855
14C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16C     LANGUAGE--ANSI FORTRAN (1977)
17C     VERSION NUMBER--88/1
18C     ORIGINAL VERSION--JANUARY   1988.
19C     UPDATED         --MARCH     1988.  LINEAR INTERCEPT & SLOPE PLOTS
20C     UPDATED         --MARCH     1988.  LINEAR RESSD AND CORRELATION PLOTS
21C     UPDATED         --AUGUST    1988.  TAGUCHI SIGNAL-TO-NOISE PLOTS
22C     UPDATED         --MAY       1989.  CAN OMIT 'TAGUCHI' IN SN.. PLOTS
23C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
24C     UPDATED         --SEPTEMBER 1992. FIX DEBUG SECTION AT EXIT
25C     UPDATED         --SEPTEMBER 1993. CP PLOT
26C     UPDATED         --SEPTEMBER 1993. CPK PLOT
27C     UPDATED         --SEPTEMBER 1993. PERCENT DEFECTIVE PLOT
28C     UPDATED         --SEPTEMBER 1993. EXPECTED LOSS PLOT
29C     UPDATED         --DECEMBER  1993. SYNONYMS FOR TAGUCHI S/N PLOTS
30C     UPDATED         --FEBRUARY  1994. CHANGE ICASPL: SDM => SDME
31C     UPDATED         --FEBRUARY  1994. CHANGE ICASPL: VM => VAME
32C     UPDATED         --FEBRUARY  1994. CHANGE ICASPL: RSD => RESD
33C     UPDATED         --FEBRUARY  1994. CHANGE ICASPL: RVAR => REVA
34C     UPDATED         --FEBRUARY  1994. ALLOW SD MEAN
35C     UPDATED         --FEBRUARY  1994. ADD VARI OF MEAN
36C     UPDATED         --FEBRUARY  1994. ADD EXTREME
37C     UPDATED         --FEBRUARY  1994. ADD NORMAL PPCC
38C     UPDATED         --MARCH     1994. WINSORIZED MEAN AS SYNONYM TO
39C                                       WINDSORIZED MEAN.
40C     UPDATED         --MARCH     1995. ADD AAD AND MAD
41C     UPDATED         --JANUARY   1998. NAME CONFLICT FOR MINIMUM AND
42C                                       MAXIMUM WITH BLOCK PLOT
43C     UPDATED         --NOVEMBER  1998. ADD PERCENTILE PLOT
44C     UPDATED         --NOVEMBER  1998. ADD CPM PLOT, CC PLOT
45C     UPDATED         --MARCH     1999. ADD GEOMETRIC MEAN PLOT
46C     UPDATED         --MARCH     1999. ADD GEOMETRIC STANDARD DEVIATION PLOT
47C     UPDATED         --MARCH     1999. ADD HARMONIC MEAN PLOT
48C     UPDATED         --OCTOBER   1999. SAVE INTERNAL PARAMETER
49C                                       ALOWHIGH
50C     UPDATED         --APRIL     2001. ADD CPL PLOT, CPU PLOT
51C     UPDATED         --SEPTEMBER 2001. ADD IQ RANGE PLOT
52C     UPDATED         --NOVEMBER  2001. ADD BIWEIGHT LOCATION PLOT
53C     UPDATED         --NOVEMBER  2001. ADD BIWEIGHT SCALE PLOT
54C     UPDATED         --JULY      2002. ADD WINSORIZED VARIANCE PLOT
55C     UPDATED         --JULY      2002. ADD WINSORIZED SD PLOT
56C     UPDATED         --JULY      2002. ADD WINSORIZED COVARIANCE PLOT
57C     UPDATED         --JULY      2002. ADD WINSORIZED CORRELATION PLOT
58C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDVARIANCE PLOT
59C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCOVARIANCE PLOT
60C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCORRELATION PLOT
61C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND MIDVARIANCE
62C                                           PLOT
63C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND CORRELATION
64C                                           PLOT
65C     UPDATED         --JULY      2002. ADD HODGES LEHMAN PLOT
66C     UPDATED         --JULY      2002. ADD QUANTILE PLOT
67C     UPDATED         --JULY      2002. ADD QUANTILE STANDARD ERROR PLOT
68C     UPDATED         --JULY      2002. ADD TRIMMED MEAN STANDARD ERROR
69C                                           PLOT
70C     UPDATED         --MARCH     2003. ADD 35 "DIFFERENCE OF" STATISTICS
71C     UPDATED         --MARCH     2003. ADD WEIGHTED MEAN, WEIGHTED SD,
72C                                       WEIGHTED VARIANCE
73C     UPDATED         --APRIL     2003. ADD SN AND QN (AND DIFFERENCE
74C                                       OF), REQUIRED ADDITIONAL
75C                                       SCRATCH ARRAYS
76C     UPDATED         --MAY       2003. ADD WEIGHTED TRIMMED MEAN
77C     UPDATED         --OCTOBER   2004. ADD KENDELL TAU
78C     UPDATED         --FEBRUARY  2005. ADD REPEATABILITY SD
79C     UPDATED         --FEBRUARY  2005. ADD REPRODUCABILITY SD
80C     UPDATED         --SEPTEMBER 2005. ADD RATIO (SUM1/SUM2)
81C     UPDATED         --MARCH     2007. ADD RELATIVE RISK
82C     UPDATED         --MARCH     2007. ADD CRAMER CONTINGENCY COEFFICIENT
83C     UPDATED         --MARCH     2007. ADD PEARSON CONTINGENCY COEFFICIENT
84C     UPDATED         --MARCH     2007. ADD FALSE POSITIVE
85C     UPDATED         --MARCH     2007. ADD FALSE NEGATIVE
86C     UPDATED         --MARCH     2007. ADD TRUE POSITIVE
87C     UPDATED         --MARCH     2007. ADD TRUE NEGATIVE
88C     UPDATED         --MARCH     2007. ADD TEST SENSITIVITY
89C     UPDATED         --MARCH     2007. ADD TEST SPECIFICITY
90C     UPDATED         --APRIL     2007. ADD POSITIVE PREDICTIVE VALUE
91C     UPDATED         --APRIL     2007. ADD NEGATIVE PREDICTIVE VALUE
92C     UPDATED         --APRIL     2007. ADD LOG ODDS RATIO
93C     UPDATED         --APRIL     2007. ADD LOG ODDS RATIO
94C                                           STANDARD ERROR
95C     UPDATED         --MAY       2007. ADD TRIMMED STANDARD DEVIATION
96C     UPDATED         --AUGUST    2007. MOVE STORAGE OF SEVERAL
97C                                       ARRAYS FROM MAINGR TO COMMON
98C     UPDATED         --NOVEMBER  2007. DOUBLE PRECISION ARRAYS FOR
99C                                       CMPSTA
100C     UPDATED         --NOVEMBER  2007. ADD LP LOCATION
101C     UPDATED         --NOVEMBER  2007. ADD VARIANCE OF LP LOCATION
102C     UPDATED         --NOVEMBER  2007. ADD SD OF LP LOCATION
103C     UPDATED         --NOVEMBER  2007. ADD DIFFERENCE OF LP LOCATION
104C     UPDATED         --NOVEMBER  2007. ADD DIFFERENCE OF VARIANCE OF
105C                                           LP LOCATION
106C     UPDATED         --NOVEMBER  2007. ADD DIFFERENCE OF SD OF
107C                                           LP LOCATION
108C     UPDATED         --SEPTEMBER 2008. ADD BINOMIAL PROBABILITY
109C     UPDATED         --SEPTEMBER 2008. ADD DIFFERENCE OF BINOMIAL
110C                                           PROBABILITY
111C     UPDATED         --FEBRUARY  2009. ADD INDEX MINIMUM
112C     UPDATED         --FEBRUARY  2009. ADD INDEX MAXIMUM
113C     UPDATED         --FEBRUARY  2009. ADD INDEX EXTREME
114C     UPDATED         --FEBRUARY  2009. ADD GRUBB
115C     UPDATED         --FEBRUARY  2009. ADD GRUBB CDF
116C     UPDATED         --FEBRUARY  2009. ADD GRUBB DIRECTION
117C     UPDATED         --FEBRUARY  2009. ADD GRUBB INDEX
118C     UPDATED         --FEBRUARY  2009. ADD:
119C                                       ONE SAMPLE T-TEST,
120C                                       ONE SAMPLE T-TEST CDF,
121C                                       CHI-SQUARE SD TEST,
122C                                       CHI-SQUARE SD TEST CDF,
123C                                       FREQUENCY TEST,
124C                                       FREQUENCY TEST CDF,
125C                                       FREQUENCY WITHIN A BLOCK TEST,
126C                                       FREQUENCY WITHIN A BLOCK TEST CDF
127C     UPDATED         --MARCH     2009. SUPPORT FOR MULTIPLE RESPONSE
128C                                       VARIABLES
129C     UPDATED         --MARCH     2009. UPDATE PARSING:
130C                                       1) USE "EXTSTA"
131C                                       2) USE DPPARS
132C     UPDATED         --MARCH     2009. "Z-SCORE" AND "U-SCORE"
133C                                       OPTIONS
134C     UPDATED         --JUNE      2010. CMPSTA SUPPORTS 3-VARIABLE
135C                                       STATISTICS
136C     UPDATED         --JANUARY   2013. CHECK FOR "PPCC STAT" CASE
137C     UPDATED         --FEBRUARY  2015. CHECK FOR "AD STAT" CASE
138C     UPDATED         --FEBRUARY  2018. "TAG PLOT" CASE
139C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE
140C
141C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
142C
143      CHARACTER*4 ICASPL
144      CHARACTER*4 IAND1
145      CHARACTER*4 IAND2
146      CHARACTER*4 ICONT
147      CHARACTER*4 ISUBRO
148      CHARACTER*4 IBUGG2
149      CHARACTER*4 IBUGG3
150      CHARACTER*4 IBUGQ
151      CHARACTER*4 IFOUND
152      CHARACTER*4 IERROR
153C
154      CHARACTER*4 IHWUSE
155      CHARACTER*4 MESSAG
156      CHARACTER*4 IERRO2
157      CHARACTER*4 IH
158      CHARACTER*4 IH2
159      CHARACTER*4 IGROUP
160C
161      PARAMETER (MAXSPN=30)
162      CHARACTER*4 IVARN1(MAXSPN)
163      CHARACTER*4 IVARN2(MAXSPN)
164      CHARACTER*4 IVARTY(MAXSPN)
165      REAL PVAR(MAXSPN)
166      INTEGER ILIS(MAXSPN)
167      INTEGER NRIGHT(MAXSPN)
168      INTEGER ICOLR(MAXSPN)
169C
170      CHARACTER*40 INAME
171      CHARACTER*60 ISTANM
172      CHARACTER*4  ISTADF
173C
174      CHARACTER*4 ISUBN0
175      CHARACTER*4 ISUBN1
176      CHARACTER*4 ISUBN2
177      CHARACTER*4 ISTEPN
178C
179C---------------------------------------------------------------------
180C
181      INCLUDE 'DPCOPA.INC'
182C
183      DIMENSION XTEMP3(MAXOBV)
184C
185      DIMENSION TEMP(MAXOBV)
186      DIMENSION TEMP2(MAXOBV)
187      DIMENSION TEMP3(MAXOBV)
188      DIMENSION TEMP4(MAXOBV)
189      DIMENSION XTEMP1(MAXOBV)
190      DIMENSION XTEMP2(MAXOBV)
191      DIMENSION TAG(MAXOBV)
192C
193      PARAMETER (MAXRES=25)
194      DIMENSION Z(MAXOBV,MAXRES)
195C
196      INCLUDE 'DPCOZZ.INC'
197      EQUIVALENCE (GARBAG(IGARB1),XTEMP3(1))
198      EQUIVALENCE (GARBAG(IGARB2),TEMP(1))
199      EQUIVALENCE (GARBAG(IGARB3),TEMP2(1))
200      EQUIVALENCE (GARBAG(IGARB4),TEMP3(1))
201      EQUIVALENCE (GARBAG(IGARB5),XTEMP1(1))
202      EQUIVALENCE (GARBAG(IGARB6),XTEMP2(1))
203      EQUIVALENCE (GARBAG(IGARB7),TEMP4(1))
204      EQUIVALENCE (GARBAG(IGARB8),TAG(1))
205      EQUIVALENCE (GARBAG(IGARB9),Z(1,1))
206C
207CCCCC JULY 2002. ADD INTEGER ARRAYS FOR HODGES-LEHMAN PLOT.
208      INCLUDE 'DPCOZI.INC'
209      INCLUDE 'DPCOZD.INC'
210C
211      INTEGER ITEMP1(MAXOBV)
212      INTEGER ITEMP2(MAXOBV)
213      INTEGER ITEMP3(MAXOBV)
214      INTEGER ITEMP4(MAXOBV)
215      INTEGER ITEMP5(MAXOBV)
216      INTEGER ITEMP6(MAXOBV)
217      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
218      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
219      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
220      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
221      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
222      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
223C
224      DOUBLE PRECISION DTEMP1(MAXOBV)
225      DOUBLE PRECISION DTEMP2(MAXOBV)
226      DOUBLE PRECISION DTEMP3(MAXOBV)
227      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
228      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
229      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
230C
231C-----COMMON----------------------------------------------------------
232C
233      INCLUDE 'DPCOHK.INC'
234      INCLUDE 'DPCODA.INC'
235      INCLUDE 'DPCOHO.INC'
236      INCLUDE 'DPCOST.INC'
237      INCLUDE 'DPCOP2.INC'
238C
239C-----START POINT-----------------------------------------------------
240C
241      IERROR='NO'
242      ISUBN1='DPSP'
243      ISUBN2='    '
244      IGROUP='OFF'
245C
246      MAXCP1=MAXCOL+1
247      MAXCP2=MAXCOL+2
248      MAXCP3=MAXCOL+3
249      MAXCP4=MAXCOL+4
250      MAXCP5=MAXCOL+5
251      MAXCP6=MAXCOL+6
252C
253      MINN2=2
254      IMAXIN=0
255      IMININ=0
256C
257C               ************************************
258C               **  TREAT THE STATISTIC PLOT CASE  **
259C               ************************************
260C
261      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP')THEN
262        WRITE(ICOUT,999)
263  999   FORMAT(1X)
264        CALL DPWRST('XXX','BUG ')
265        WRITE(ICOUT,51)
266   51   FORMAT('***** AT THE BEGINNING OF DPSP--')
267        CALL DPWRST('XXX','BUG ')
268        WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ
269   52   FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',
270     1         4(A4,2X),A4)
271        CALL DPWRST('XXX','BUG ')
272        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,NUMARG
273   53   FORMAT('ICASPL,IAND1,IAND2,NUMARG = ',3(A4,2X),I8)
274        CALL DPWRST('XXX','BUG ')
275        DO55I=1,NUMARG
276          WRITE(ICOUT,57)I,IHARG(I),IHARG2(I)
277   57     FORMAT('I,IHARG(I),IHARG2(I) = ',I8,2(2X,A4))
278          CALL DPWRST('XXX','BUG ')
279   55   CONTINUE
280      ENDIF
281C
282C               ***************************
283C               **  STEP 1--             **
284C               **  EXTRACT THE COMMAND  **
285C               ***************************
286C
287      ISTEPN='1'
288      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP')
289     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
290C
291      IF(NUMARG.LE.1)GOTO9000
292C
293C     EXTRACT THE DESIRED STATISTIC
294C
295C       2013/04: CHECK FOR CONFLICT BETWEEN "QUANTILE PLOT" AND
296C                "QUANTILE-QUANTILE PLOT".
297C
298      IF(ICOM.EQ.'QUAN' .AND. IHARG(1).EQ.'QUAN')GOTO9000
299C
300      JMIN=0
301      JMAX=NUMARG
302      IFLAGZ=0
303      IFLAGU=0
304C
305      DO200I=1,NUMARG
306        IF((IHARG(I).EQ.'TAG '.OR.IHARG(I).EQ.'CHAR').AND.
307     1      IHARG(I+1).EQ.'PLOT')THEN
308          IF(JMAX.EQ.NUMARG)JMAX=I-1
309          ILASTC=I+1
310          IGROUP='ON'
311          GOTO209
312        ELSEIF(IHARG(I).EQ.'PLOT')THEN
313          IF(JMAX.EQ.NUMARG)JMAX=I-1
314          ILASTC=I
315          GOTO209
316C
317C       2013/01: NOTE THE COMMANDS
318C
319C                  TUKEY LAMBDA PPCC STATISTIC PLOT
320C                  WEIBULL      PPCC STATISTIC PLOT
321C
322C                NEED TO INCLUDE THE "STATISTIC" IN ORDER TO
323C                DISTINGUISH THEM FROM THE STANDARD PPCC PLOT
324C                CASE.  SO CHECK FOR THE WORD "PPCC".
325C
326C       2015/02: SIMILAR CHECK FOR "ANDERSON DARLING" OR "AD"
327C
328C       2015/02: SIMILAR CHECK FOR "JSCORE STATISTIC"
329C
330C       2013/04: CHECK FOR CONFLICT BETWEEN "QUANTILE PLOT" AND
331C                "QUANTILE-QUANTILE PLOT".
332C
333        ELSEIF(I.LT.NUMARG.AND.IHARG(I).EQ.'STAT'.AND.
334     1         IHARG(I+1).EQ.'PLOT')THEN
335          IF(IHARG(I-1).EQ.'PPCC')THEN
336            IF(JMAX.EQ.NUMARG)JMAX=I
337          ELSEIF(IHARG(I-1).EQ.'AD')THEN
338            IF(JMAX.EQ.NUMARG)JMAX=I
339          ELSEIF(IHARG(I-2).EQ.'ANDE' .AND. IHARG(I-1).EQ.'DARL')THEN
340            IF(JMAX.EQ.NUMARG)JMAX=I
341          ELSEIF(ICOM.EQ.'JSCO')THEN
342            JMAX=I
343          ELSE
344            IF(JMAX.EQ.NUMARG)JMAX=I-1
345          ENDIF
346          ILASTC=I+1
347          GOTO209
348        ELSEIF(I.LT.NUMARG-1.AND.IHARG(I).EQ.'STAT'.AND.
349     1         IHARG(I+1).EQ.'TAG '.AND.IHARG(I+2).EQ.'PLOT')THEN
350          IF(IHARG(I-1).EQ.'PPCC')THEN
351            IF(JMAX.EQ.NUMARG)JMAX=I
352          ELSEIF(IHARG(I-1).EQ.'AD')THEN
353            IF(JMAX.EQ.NUMARG)JMAX=I
354          ELSEIF(IHARG(I-2).EQ.'ANDE' .AND. IHARG(I-1).EQ.'DARL')THEN
355            IF(JMAX.EQ.NUMARG)JMAX=I
356          ELSEIF(ICOM.EQ.'JSCO')THEN
357            JMAX=I
358          ELSE
359            IF(JMAX.EQ.NUMARG)JMAX=I-1
360          ENDIF
361          ILASTC=I+2
362          GOTO209
363        ELSEIF(IHARG(I).EQ.'ZSCO')THEN
364          JMAX=I-1
365          IFLAGZ=1
366        ELSEIF(I.LT.NUMARG.AND.IHARG(I).EQ.'Z   '.AND.
367     1         IHARG(I+1).EQ.'SCOR')THEN
368          JMAX=I-1
369          IFLAGZ=1
370        ELSEIF(IHARG(I).EQ.'USCO')THEN
371          JMAX=I-1
372          IFLAGU=1
373        ELSEIF(I.LT.NUMARG.AND.IHARG(I).EQ.'U   '.AND.
374     1         IHARG(I+1).EQ.'SCOR')THEN
375          JMAX=I-1
376          IFLAGU=1
377        ELSEIF(I.GT.1 .AND. IHARG(I).EQ.'QUAN'.AND.
378     1         IHARG(I-1).EQ.'QUAN')THEN
379          GOTO9000
380        ENDIF
381  200 CONTINUE
382      GOTO9000
383  209 CONTINUE
384C
385      CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
386     1            ICASPL,ISTANM,ISTANR,ISTADF,IFOUND,ILOCV,
387     1            ISUBRO,IBUGG3,IERROR)
388C
389      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP')THEN
390        WRITE(ICOUT,999)
391        CALL DPWRST('XXX','BUG ')
392        WRITE(ICOUT,251)
393  251   FORMAT('***** AFTER CALL EXTSTA--')
394        CALL DPWRST('XXX','BUG ')
395        WRITE(ICOUT,252)ICASPL,IFOUND,ISTANR,ILOCV
396  252   FORMAT('ICASPL,IFOUND,ISTANR,ILOCV = ',2(A4,2X),2I8)
397        CALL DPWRST('XXX','BUG ')
398      ENDIF
399C
400      IF(IFOUND.EQ.'NO')GOTO9000
401      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
402C
403C               *********************************
404C               **  STEP 2--                   **
405C               **  EXTRACT THE VARIABLE LIST  **
406C               *********************************
407C
408      INAME='STATISTIC PLOT'
409      MINNA=1
410      MAXNA=100
411      MINN2=2
412      IFLAGE=1
413      IFLAGM=0
414      IFLAGP=0
415      JMIN=1
416      JMAX=NUMARG
417      MINNVA=-99
418      MAXNVA=-99
419      IF(IGROUP.EQ.'ON')THEN
420        MINNA=2
421      ENDIF
422C
423      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
424     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
425     1            JMIN,JMAX,
426     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
427     1            IVARN1,IVARN2,IVARTY,PVAR,
428     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
429     1            MINNVA,MAXNVA,
430     1            IFLAGM,IFLAGP,
431     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
432      IF(IERROR.EQ.'YES')GOTO9000
433C
434      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP')THEN
435        WRITE(ICOUT,999)
436        CALL DPWRST('XXX','BUG ')
437        WRITE(ICOUT,281)
438  281   FORMAT('***** AFTER CALL DPPARS--')
439        CALL DPWRST('XXX','BUG ')
440        WRITE(ICOUT,282)NQ,NUMVAR
441  282   FORMAT('NQ,NUMVAR = ',2I8)
442        CALL DPWRST('XXX','BUG ')
443        IF(NUMVAR.GT.0)THEN
444          DO285I=1,NUMVAR
445            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
446     1                      ICOLR(I)
447  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
448     1             'ICOLR(I) = ',I8,2X,2A4,2X,3I8)
449            CALL DPWRST('XXX','BUG ')
450  285     CONTINUE
451        ENDIF
452      ENDIF
453C
454C     NEED FOLLOWING VARIABLES:
455C     1) GROUP-ID VARIABLE
456C     2) AT LEAST ONE RESPONSE VARIABLE FOR STATISTICS
457C        THAT REQUIRE ONE VARIABLE
458C     3) AT LEAST TWO RESPONSE VARIABLES FOR STATISTICS
459C        THAT REQUIRE TWO VARIABLES
460C     4) AT LEAST THREE RESPONSE VARIABLES FOR STATISTICS
461C        THAT REQUIRE THREE VARIABLES
462C     5) IF
463C     IF THE PARAMETER "NI" IS SPECIFIED, THEN IF NUMVAR = MINVAR - 1,
464C     THEN WE CAN AUTOMATICALLY CREATE THE GROUP-ID VARIABLE.
465C
466      ISIZE=-99
467      ITGVAR=0
468      IF(IGROUP.EQ.'ON')ITGVAR=1
469      MINVAR=1+ISTANR+ITGVAR
470      IF(NUMVAR.LT.MINVAR)THEN
471C
472        IF(NUMVAR.EQ.MINVAR-1)THEN
473          IH='NI  '
474          IH2='    '
475          IHWUSE='P'
476          MESSAG='NO'
477          CALL CHECKN(IH,IH2,IHWUSE,
478     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
479     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
480          IF(IERROR.EQ.'NO')THEN
481            ISIZE=INT(VALUE(ILOCP)+0.5)
482            GOTO219
483          ENDIF
484        ENDIF
485C
486        WRITE(ICOUT,999)
487        CALL DPWRST('XXX','BUG ')
488        WRITE(ICOUT,211)ISTANA
489  211   FORMAT('***** ERROR IN ',A60,'PLOT COMMAND--')
490        CALL DPWRST('XXX','BUG ')
491        WRITE(ICOUT,212)MINVAR
492  212   FORMAT('      AT LEAST ',I5,' VARIABLES REQUIRED, BUT ONLY')
493        CALL DPWRST('XXX','BUG ')
494        WRITE(ICOUT,213)NUMVAR
495  213   FORMAT('      ',I8,' VARIABLES WERE GIVEN.')
496        CALL DPWRST('XXX','BUG ')
497        WRITE(ICOUT,215)
498  215   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
499        CALL DPWRST('XXX','BUG ')
500        IF(IWIDTH.GE.1)THEN
501          WRITE(ICOUT,216)(IANS(J),J=1,MIN(80,IWIDTH))
502  216     FORMAT('      ',80A1)
503          CALL DPWRST('XXX','BUG ')
504          IERROR='YES'
505          GOTO9000
506        ENDIF
507      ENDIF
508C
509  219 CONTINUE
510C
511      NTEMP=NUMVAR-1-ITGVAR
512      IF(ISTANR.EQ.2 .AND. MOD(NTEMP,2).EQ.1)THEN
513        WRITE(ICOUT,999)
514        CALL DPWRST('XXX','BUG ')
515        WRITE(ICOUT,211)ISTANA
516        CALL DPWRST('XXX','BUG ')
517        WRITE(ICOUT,222)
518  222   FORMAT('      THE NUMBER OF RESPONSE VARIABLES IS EVEN, BUT')
519        CALL DPWRST('XXX','BUG ')
520        WRITE(ICOUT,223)
521  223   FORMAT('      IT SHOULD BE ODD WHEN THE STATISTIC REQUIRES')
522        CALL DPWRST('XXX','BUG ')
523        WRITE(ICOUT,224)
524  224   FORMAT('      TWO VARIABLES TO COMPUTE (2*NUMBER OF PAIRS + ',
525     1         'GROUP-ID VARIABLE)')
526        CALL DPWRST('XXX','BUG ')
527        WRITE(ICOUT,215)
528        CALL DPWRST('XXX','BUG ')
529        IF(IWIDTH.GE.1)THEN
530          WRITE(ICOUT,216)(IANS(J),J=1,MIN(80,IWIDTH))
531          CALL DPWRST('XXX','BUG ')
532          IERROR='YES'
533          GOTO9000
534        ENDIF
535      ENDIF
536C
537      IF(ISTANR.EQ.3 .AND. MOD(NTEMP,3).GT.0)THEN
538        WRITE(ICOUT,999)
539        CALL DPWRST('XXX','BUG ')
540        WRITE(ICOUT,211)ISTANA
541        CALL DPWRST('XXX','BUG ')
542        WRITE(ICOUT,232)
543  232   FORMAT('      THE NUMBER OF RESPONSE VARIABLES IS NOT')
544        CALL DPWRST('XXX','BUG ')
545        WRITE(ICOUT,233)
546  233   FORMAT('      DIVISIBLE BY 3 WHEN THE STATISTIC REQUIRES')
547        CALL DPWRST('XXX','BUG ')
548        WRITE(ICOUT,234)
549  234   FORMAT('      THREE VARIABLES TO COMPUTE')
550        CALL DPWRST('XXX','BUG ')
551        WRITE(ICOUT,215)
552        CALL DPWRST('XXX','BUG ')
553        IF(IWIDTH.GE.1)THEN
554          WRITE(ICOUT,216)(IANS(J),J=1,MIN(80,IWIDTH))
555          CALL DPWRST('XXX','BUG ')
556          IERROR='YES'
557          GOTO9000
558        ENDIF
559      ENDIF
560C               *********************************
561C               **  STEP 3--                   **
562C               **  EXTRACT THE DATA           **
563C               *********************************
564C
565      NTEMP=NRIGHT(1)
566      DO300K=1,NUMVAR
567C
568        J=0
569        IMAX=NTEMP
570        IF(NQ.LT.NTEMP)IMAX=NQ
571        DO310I=1,IMAX
572          IF(ISUB(I).EQ.1)THEN
573            J=J+1
574            IJ=MAXN*(ICOLR(K)-1)+I
575C
576            IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP')THEN
577              WRITE(ICOUT,311)I,J,MAXN,ICOLR(K),IJ,NRIGHT(K),NQ,IMAX
578  311         FORMAT('I,J,MAXN,ICOLR(K),IJ,NRIGHT(K),NQ,IMAX = ',8I8)
579              CALL DPWRST('XXX','BUG ')
580            ENDIF
581C
582            IF(ICOLR(K).LE.MAXCOL)Z(J,K)=V(IJ)
583            IF(ICOLR(K).EQ.MAXCP1)Z(J,K)=PRED(I)
584            IF(ICOLR(K).EQ.MAXCP2)Z(J,K)=RES(I)
585            IF(ICOLR(K).EQ.MAXCP3)Z(J,K)=YPLOT(I)
586            IF(ICOLR(K).EQ.MAXCP4)Z(J,K)=XPLOT(I)
587            IF(ICOLR(K).EQ.MAXCP5)Z(J,K)=X2PLOT(I)
588            IF(ICOLR(K).EQ.MAXCP6)Z(J,K)=TAGPLO(I)
589          ENDIF
590  310   CONTINUE
591        IF(K.EQ.1)NLOCAL=J
592  300   CONTINUE
593C
594C               ********************************************************
595C               **  STEP 27--                                         **
596C               **  CREATE A GROUP-ID VARIABLE BASED ON NI IF NEEDED  **
597C               ********************************************************
598C
599      ISTEPN='3B'
600      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP')
601     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
602C
603      IF(ISIZE.GT.0)THEN
604        IF(IGROUP.EQ.'OFF')THEN
605          NUMVAR=NUMVAR+1
606          DO360J=1,NLOCAL
607            ITEMP=MOD(J,ISIZE)
608            IF(ITEMP.EQ.0)ITEMP=ISIZE
609            Z(J,NUMVAR)=REAL(ITEMP)
610  360     CONTINUE
611        ELSE
612          NUMVAR=NUMVAR+1
613          DO363J=1,NLOCAL
614            ITEMP=MOD(J,ISIZE)
615            IF(ITEMP.EQ.0)ITEMP=ISIZE
616            Z(J,NUMVAR)=Z(J,NUMVAR-1)
617            Z(J,NUMVAR-1)=REAL(ITEMP)
618  363     CONTINUE
619        ENDIF
620      ENDIF
621C
622C               ********************************************************
623C               **  STEP 4--                                          **
624C               **  COMPUTE THE APPROPRIATE STATISTIC PLOT STATISTIC--**
625C               **  (MEAN, STANDARD DEVIATION, RANGE, OR CUSUM).      **
626C               **  COMPUTE CONFIDENCE LINES.                         **
627C               **  FORM THE VERTICAL AND HORIZONTAL AXIS             **
628C               **  VALUES Y(.) AND X(.) FOR THE PLOT.                **
629C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S       **
630C               **  FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, **
631C               **  AND THE UPPER CONFIDENCE LINE.                    **
632C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).     **
633C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).     **
634C               ********************************************************
635C
636      ISTEPN='4'
637      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP')
638     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
639C
640      CALL DPSP2(Z,MAXOBV,MAXRES,NLOCAL,NUMVAR,ISTANR,IFLAGZ,IFLAGU,
641     1           ICASPL,ISIZE,ICONT,
642     1           TEMP,TEMP2,TEMP3,TEMP4,TAG,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
643     1           ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
644     1           DTEMP1,DTEMP2,DTEMP3,
645     1           IQUAME,IQUASE,PSTAMV,ISTAFO,ISTASM,ISPLRL,IGROUP,
646     1           Y,X,D,NPLOTP,NPLOTV,NUMSET,GRAND,
647     1           ISUBRO,IBUGG3,IERROR)
648C
649C
650C               *************************************************
651C               **  STEP 29--                                  **
652C               **  SAVE DIFFERENCE BETWEEN HIGHEST VALUE AND  **
653C               **  LOWEST VALUE OF STATISTIC IN INTERNAL      **
654C               **  PARAMETER ALOWHIGH                         **
655C               *************************************************
656      AMINS=CPUMAX
657      AMAXS=CPUMIN
658      ANUMSE=1.0
659      IF(IGROUP.EQ.'ON')ANUMSE=REAL(NUMSET)
660      DO2910I=1,NPLOTP
661        IF(D(I).GT.ANUMSE)GOTO2910
662        IF(Y(I).GT.AMAXS)THEN
663          AMAXS=Y(I)
664          IMAXIN=I
665        ENDIF
666        IF(Y(I).LT.AMINS)THEN
667          AMINS=Y(I)
668          IMININ=I
669        ENDIF
670 2910 CONTINUE
671      ADIFF=AMAXS-AMINS
672      IF(IMAXIN.GT.IMININ)ADIFF=-ADIFF
673C
674      ISUBN0='DPSP'
675C
676      IH='ALOW'
677      IH2='HIGH'
678      VALUE0=ADIFF
679      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
680     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
681     1IANS,IWIDTH,IBUGG3,IERROR)
682C
683      IF(GRAND.NE.CPUMIN)THEN
684        IH='GRAN'
685        IH2='DSTA'
686        VALUE0=GRAND
687        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
688     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
689     1              IANS,IWIDTH,IBUGG3,IERROR)
690      ENDIF
691C
692C               *****************
693C               **  STEP 90--  **
694C               **  EXIT       **
695C               *****************
696C
697 9000 CONTINUE
698      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPSP')THEN
699        WRITE(ICOUT,999)
700        CALL DPWRST('XXX','BUG ')
701        WRITE(ICOUT,9011)
702 9011   FORMAT('***** AT THE END       OF DPSP--')
703        CALL DPWRST('XXX','BUG ')
704        WRITE(ICOUT,9013)IFOUND,IERROR
705 9013   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
706        CALL DPWRST('XXX','BUG ')
707        IF(IFOUND.EQ.'NO')GOTO9099
708        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
709 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
710        CALL DPWRST('XXX','BUG ')
711        WRITE(ICOUT,9016)NUMVAR,ISIZE
712 9016   FORMAT('NUMVAR,ISIZE = ',2I8)
713        CALL DPWRST('XXX','BUG ')
714        IF(IFOUND.EQ.'NO'.OR.NPLOTP.LE.0)THEN
715          DO9025I=1,NPLOTP
716            WRITE(ICOUT,9026)I,Y(I),X(I),D(I)
717 9026       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
718            CALL DPWRST('XXX','BUG ')
719 9025     CONTINUE
720        ENDIF
721      ENDIF
722 9099 CONTINUE
723C
724      RETURN
725      END
726      SUBROUTINE DPSP2(Z,MAXOBV,MAXRES,N,NUMV2,ISTANR,IFLAGZ,IFLAGU,
727     1                 ICASPL,ISIZE,ICONT,
728     1                 TEMP,TEMPZ,TEMPZ2,XIDTEM,TAG,
729     1                 XTEMP1,XTEMP2,XTEMP3,MAXNXT,
730     1                 ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
731     1                 DTEMP1,DTEMP2,DTEMP3,
732     1                 IQUAME,IQUASE,PSTAMV,ISTAFO,ISTASM,ISPLRL,IGROUP,
733     1                 Y2,X2,D2,N2,NPLOTV,NUMSET,GRAND,
734     1                 ISUBRO,IBUGG3,IERROR)
735C
736C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
737C              THAT WILL DEFINE A <STAT> PLOT
738C     WRITTEN BY--JAMES J. FILLIBEN
739C                 STATISTICAL ENGINEERING DIVISION
740C                 INFORMATION TECHNOLOGY LABORATORY
741C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
742C                 GAITHERSBURG, MD 20899-8980
743C                 PHONE--301-975-2855
744C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
745C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
746C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
747C     LANGUAGE--ANSI FORTRAN (1977)
748C     VERSION NUMBER--82/7
749C     ORIGINAL VERSION--JANUARY   1988.
750C     UPDATED         --MARCH     1988.   LINEAR INTERCEPT & SLOPE PLOTS
751C     UPDATED         --MARCH     1988.   LINEAR RESSD & CORRELATION PLOTS
752C     UPDATED         --AUGUST    1988.   TAGUCHI SIGNAL TO NOISE PLOTS
753C     UPDATED         --SEPTEMBER 1988.   4 MISSING CHARACTER*4 STATEMENTS
754C     UPDATED         --MAY       1989.   CHANGE TAGUCHI S/N DESIGNATIONS
755C     UPDATED         --SEPTEMBER 1993. CP PLOT
756C     UPDATED         --SEPTEMBER 1993. CPK PLOT
757C     UPDATED         --SEPTEMBER 1993. PERCENT DEFECTIVE PLOT
758C     UPDATED         --SEPTEMBER 1993. EXPECTED LOSS PLOT
759C     UPDATED         --DECEMBER  1993. LINFIT ARGS
760C     UPDATED         --DECEMBER  1993. LINFIT ARGS; PROTECT RESSD/DF
761C     UPDATED         --FEBRUARY  1994. IFLAG='ACTU'
762C     UPDATED         --FEBRUARY  1994. CHANGE ICASPL: SDM => SDME
763C     UPDATED         --FEBRUARY  1994. CHANGE ICASPL: VM => VAME
764C     UPDATED         --FEBRUARY  1994. CHANGE ICASPL: RSD => RESD
765C     UPDATED         --FEBRUARY  1994. CHANGE ICASPL: RVAR => REVA
766C     UPDATED         --FEBRUARY  1994. ALLOW SD MEAN
767C     UPDATED         --FEBRUARY  1994. ADD VARI OF MEAN
768C     UPDATED         --FEBRUARY  1994. ADD VARI OF MEAN
769C     UPDATED         --FEBRUARY  1994. ADD NORMAL PPCC
770C     UPDATED         --NOVEMBER  1998. ADD PERCENTILE
771C     UPDATED         --NOVEMBER  1998. ADD CPM, CC
772C     UPDATED         --MARCH     1999. ADD CNPK
773C     UPDATED         --MARCH     1999. ADD GEOMETRIC MEAN
774C     UPDATED         --MARCH     1999. ADD GEOMETRIC STANDARD DEVIATION
775C     UPDATED         --APRIL     2001. ARGUMENT LIST TO CP, CPK, CPM
776C     UPDATED         --SEPTEMBER 2001. ADD IQ RANGE
777C     UPDATED         --NOVEMBER  2001. ADD BIWEIGHT LOCATION
778C     UPDATED         --NOVEMBER  2001. ADD BIWEIGHT SCALE
779C     UPDATED         --JULY      2002. ADD WINSORIZED VARIANCE
780C     UPDATED         --JULY      2002. ADD WINSORIZED SD
781C     UPDATED         --JULY      2002. ADD WINSORIZED COVARIANCE PLOT
782C     UPDATED         --JULY      2002. ADD WINSORIZED CORRELATION PLOT
783C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDVARIANCE PLOT
784C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCOVARIANCE PLOT
785C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCORRELATION PLOT
786C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND MIDVARIANCE
787C                                           PLOT
788C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND CoRRELATION
789C                                           PLOT
790C     UPDATED         --JULY      2002. ADD HODGES LEHMAN PLOT
791C     UPDATED         --AUGUST    2002. USE "CMPSTA" TO COMPUTE THE
792C                                       STATISTIC
793C     UPDATED         --APRIL     2003. ADD SN AND QN (AND DIFFERENCE
794C                                       OF), REQUIRED ADDITIONAL
795C                                       SCRATCH ARRAY
796C     UPDATED         --OCTOBER   2004. ADD KENDELL TAU
797C     UPDATED         --FEBRUARY  2005. ADD REPEATABILITY SD
798C     UPDATED         --FEBRUARY  2005. ADD REPRODUCABILITY SD
799C     UPDATED         --SEPTEMBER 2005. ADD RATIO
800C     UPDATED         --MARCH     2007. ADD ODDS RATIO
801C     UPDATED         --MARCH     2007. ADD ODDS RATIO STANDARD ERROR
802C     UPDATED         --MARCH     2009. SUPPORT FOR MULTIPLE RESPONSE
803C                                       VARIABLES
804C     UPDATED         --MARCH     2009. ZSCORE/USCORE OPTIONS
805C     UPDATED         --APRIL     2015. ISPLRL (REFERENCE LINE)
806C     UPDATED         --FEBRUARY  2018. SUPPORT FOR "TAG" VARIABLE
807C     UPDATED         --OCTOBER   2018. RETURN STATISTIC VALUE FOR
808C                                       FULL DATA SET
809C
810C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
811C
812      CHARACTER*4 ICASPL
813      CHARACTER*4 ICONT
814      CHARACTER*4 ISPLRL
815      CHARACTER*4 ISUBRO
816      CHARACTER*4 IBUGG3
817      CHARACTER*4 IERROR
818C
819      CHARACTER*4 IWRITE
820      CHARACTER*4 IQUAME
821      CHARACTER*4 IQUASE
822      CHARACTER*4 ISTAFO
823      CHARACTER*4 ISTAFZ
824      CHARACTER*4 ISTASM
825      CHARACTER*4 IGROUP
826C
827      CHARACTER*4 ISUBN1
828      CHARACTER*4 ISUBN2
829      CHARACTER*4 ISTEPN
830C
831C---------------------------------------------------------------------
832C
833      DIMENSION Z(MAXOBV,MAXRES)
834      DIMENSION Y2(*)
835      DIMENSION X2(*)
836      DIMENSION D2(*)
837C
838      DIMENSION TEMP(*)
839      DIMENSION TEMPZ(*)
840      DIMENSION TEMPZ2(*)
841      DIMENSION XIDTEM(*)
842      DIMENSION TAG(*)
843      DIMENSION XTEMP1(*)
844      DIMENSION XTEMP2(*)
845      DIMENSION XTEMP3(*)
846C
847      INTEGER ITEMP1(*)
848      INTEGER ITEMP2(*)
849      INTEGER ITEMP3(*)
850      INTEGER ITEMP4(*)
851      INTEGER ITEMP5(*)
852      INTEGER ITEMP6(*)
853C
854      DOUBLE PRECISION DTEMP1(*)
855      DOUBLE PRECISION DTEMP2(*)
856      DOUBLE PRECISION DTEMP3(*)
857C
858C-----COMMON----------------------------------------------------------
859C
860C-----COMMON VARIABLES (GENERAL)--------------------------------------
861C
862      INCLUDE 'DPCOP2.INC'
863C
864C-----START POINT-----------------------------------------------------
865C
866      ISUBN1='DPSP'
867      ISUBN2='2   '
868      IWRITE='OFF'
869C
870      GRAND=CPUMIN
871      I2=0
872      ISIZE2=0
873      ITAG=0
874      IF(IGROUP.EQ.'ON')ITAG=1
875      AGROUP=0.0
876C
877C     CHECK THE INPUT ARGUMENTS FOR ERRORS
878C
879      IF(N.LT.1)THEN
880        WRITE(ICOUT,999)
881  999   FORMAT(1X)
882        CALL DPWRST('XXX','BUG ')
883        WRITE(ICOUT,31)
884   31   FORMAT('***** ERROR IN <STATISTIC> PLOT--')
885        CALL DPWRST('XXX','BUG ')
886        WRITE(ICOUT,32)
887   32   FORMAT('      THE NUMBER OF OBSERVATIONS IS NON-POSITIVE.')
888        CALL DPWRST('XXX','BUG ')
889        WRITE(ICOUT,34)N
890   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
891        CALL DPWRST('XXX','BUG ')
892        WRITE(ICOUT,999)
893        CALL DPWRST('XXX','BUG ')
894        IERROR='YES'
895        GOTO9000
896      ENDIF
897C
898      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2')THEN
899        WRITE(ICOUT,70)
900   70   FORMAT('AT THE BEGINNING OF DPSP2--')
901        CALL DPWRST('XXX','BUG ')
902        WRITE(ICOUT,71)IBUGG3,ISUBRO,ICASPL,ICONT
903   71   FORMAT('IBUGG3,ISUBRO,ICASPL,ICONT = ',3(A4,2X),A4)
904        CALL DPWRST('XXX','BUG ')
905        WRITE(ICOUT,72)N,NUMV2,ISIZE,ITAG
906   72   FORMAT('N,NUMV2,ISIZE,ITAG = ',4I8)
907        CALL DPWRST('XXX','BUG ')
908        DO73I=1,N
909          WRITE(ICOUT,74)I,(Z(I,J),J=1,NUMV2)
910   74     FORMAT('I, (Z(I,J),J=1,NUMV2) = ',I8,25F15.7)
911          CALL DPWRST('XXX','BUG ')
912   73   CONTINUE
913        WRITE(ICOUT,78)IQUAME,IQUASE,PSTAMV
914   78   FORMAT('IQUAME,IQUASE,PSTAMV = ',2(A4,2X),G15.7)
915        CALL DPWRST('XXX','BUG ')
916      ENDIF
917C
918C               ********************************************************
919C               **  STEP 1--                                          **
920C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
921C               **  FOR THE GROUP VARIABLE (USUALLY VAR. 2)           **
922C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
923C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
924C               **  WHICH IS AN ERROR CONDITION FOR A PLOT.           **
925C               ********************************************************
926C
927      ISTEPN='1'
928      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2')
929     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
930C
931      IF(ITAG.EQ.1)THEN
932        DO103II=1,N
933          TEMP(II)=Z(II,NUMV2)
934  103   CONTINUE
935        CALL CODE(TEMP,N,IWRITE,TAG,TEMPZ,MAXOBV,IBUGG3,IERROR)
936C
937        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2')THEN
938          WRITE(ICOUT,104)
939  104     FORMAT('TAG CASE AFTER CALL CODE')
940          CALL DPWRST('XXX','BUG ')
941          DO105II=1,N
942            WRITE(ICOUT,106)II,Z(II,NUMV2),TAG(II)
943  106       FORMAT('II,Z(II,NUMV2),TAG(II) = ',I8,2F10.2)
944            CALL DPWRST('XXX','BUG ')
945  105     CONTINUE
946        ENDIF
947C
948      ELSE
949        DO107II=1,N
950          TAG(II)=1.0
951  107   CONTINUE
952      ENDIF
953C
954      NUMSET=0
955      NCOL=NUMV2-ITAG
956      DO111I=1,N
957        IF(NUMSET.GE.1)THEN
958          DO112J=1,NUMSET
959            IF(Z(I,NCOL).EQ.XIDTEM(J))GOTO111
960  112     CONTINUE
961        ENDIF
962        NUMSET=NUMSET+1
963        XIDTEM(NUMSET)=Z(I,NCOL)
964  111 CONTINUE
965      CALL SORT(XIDTEM,NUMSET,XIDTEM)
966C
967      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2')THEN
968        DO115II=1,NUMSET
969          WRITE(ICOUT,114)II,XIDTEM(II)
970  114     FORMAT('II,XIDTEM(II) = ',I8,F10.2)
971          CALL DPWRST('XXX','BUG ')
972  115   CONTINUE
973      ENDIF
974C
975      IF(NUMSET.LT.1)THEN
976        WRITE(ICOUT,999)
977        CALL DPWRST('XXX','BUG ')
978        WRITE(ICOUT,31)
979        CALL DPWRST('XXX','BUG ')
980        WRITE(ICOUT,122)
981  122   FORMAT('      NUMBER OF SETS    NUMSET = 0 ')
982        CALL DPWRST('XXX','BUG ')
983        IERROR='YES'
984        GOTO9000
985C
986CCCC    JANUARY 2005.  IF NUMBER OF SETS EQUAL NUMBER OF OBSERVATIONS
987CCCCC                  (I.E., ALL GROUPS HAVE 1 OBSERVATION), TREAT AS
988CCCCC                  A WARNING RATHER THAN AN ERROR.  NOTE THAT SOME
989CCCCC                  STATISTICS MAY SUBSEQUENTLY GENERATE AN ERROR
990CCCCC                  MESSAGE FOR EACH GROUP.
991C
992      ELSEIF(NUMSET.EQ.N)THEN
993        WRITE(ICOUT,999)
994        CALL DPWRST('XXX','BUG ')
995        WRITE(ICOUT,135)
996  135   FORMAT('***** WARNING IN <STAT> PLOT--')
997        CALL DPWRST('XXX','BUG ')
998        WRITE(ICOUT,136)NUMSET
999  136   FORMAT('      THE NUMBER OF SETS ',I8,' IS IDENTICAL TO ')
1000        CALL DPWRST('XXX','BUG ')
1001        WRITE(ICOUT,137)N
1002  137   FORMAT('      THE NUMBER OF OBSERVATIONS  ',I8,'.')
1003        CALL DPWRST('XXX','BUG ')
1004CCCCC   IERROR='YES'
1005CCCCC   GOTO9000
1006      ENDIF
1007C
1008      AN=N
1009      ANUMSE=NUMSET
1010C
1011C               ********************************************************
1012C               **  STEP 1B--                                         **
1013C               **  SCALE BY Z-SCORE OR U-SCORE IF REQUESTED          **
1014C               ********************************************************
1015C
1016      ISTEPN='1B'
1017      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2')
1018     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1019C
1020      IF(IFLAGZ.EQ.1)THEN
1021        DO160K=1,NUMV2-1-ITAG
1022          CALL MEAN(Z(1,K),N,IWRITE,XMEAN,IBUGG3,IERROR)
1023          CALL SD(Z(1,K),N,IWRITE,XSD,IBUGG3,IERROR)
1024          IF(XSD.GT.0.0)THEN
1025            DO165I=1,N
1026              Z(I,K)=(Z(I,K)-XMEAN)/XSD
1027  165       CONTINUE
1028          ELSE
1029            WRITE(ICOUT,999)
1030            CALL DPWRST('XXX','BUG ')
1031            WRITE(ICOUT,135)
1032            CALL DPWRST('XXX','BUG ')
1033            WRITE(ICOUT,166)K
1034  166       FORMAT('      UNABLE TO STANDARDIZE RESPONSE VARIABLE ',
1035     1             I8)
1036            CALL DPWRST('XXX','BUG ')
1037          ENDIF
1038  160   CONTINUE
1039      ELSEIF(IFLAGU.EQ.1)THEN
1040        DO170K=1,NUMV2-1-ITAG
1041          CALL MINIM(Z(1,K),N,IWRITE,XMIN,IBUGG3,IERROR)
1042          CALL MAXIM(Z(1,K),N,IWRITE,XMAX,IBUGG3,IERROR)
1043          IF(XMIN.NE.XMAX)THEN
1044            DO175I=1,N
1045              Z(I,K)=(Z(I,K)-XMIN)/(XMAX-XMIN)
1046  175       CONTINUE
1047          ELSE
1048            WRITE(ICOUT,999)
1049            CALL DPWRST('XXX','BUG ')
1050            WRITE(ICOUT,135)
1051            CALL DPWRST('XXX','BUG ')
1052            WRITE(ICOUT,176)K
1053  176       FORMAT('      UNABLE TO STANDARDIZE RESPONSE VARIABLE ',
1054     1             I8)
1055            CALL DPWRST('XXX','BUG ')
1056          ENDIF
1057  170   CONTINUE
1058      ENDIF
1059C
1060C               ******************************************
1061C               **  STEP 1C--                           **
1062C               **  COMPUTE THE SPECIFIED STATISTIC     **
1063C               **  FOR EACH SUBSET OF THE DATA, AND    **
1064C               **  THEN FOR THE FULL DATA SET          **
1065C               ******************************************
1066C
1067      ISTEPN='1C'
1068      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2')
1069     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1070C
1071C     MARCH 2009: IF NUMBER OF RESPONSE VARIABLES IS > 1,
1072C                 THEN CODE THE GROUP-ID VARIABLE.  ALSO,
1073C                 SUPPORT BOTH AN "OVERLAY" AND A "DEX"
1074C                 FORMAT FOR MULTIPLE RESPONSE CASE.
1075C
1076C                 FOR SUMMARY STATISTIC AND MULTIPLE RESPONSES,
1077C                 SUPPORT EITHER "GROUP" OR "COLUMNS" OPTION.
1078C                 COLUMN OPTION SUMMARIZES BY VARIABLE (OVER
1079C                 ALL GROUPS) WHILE GROUP OPTION SUMMARIZES BY
1080C                 VALUE OF GROUP-ID VARIABLE.
1081C
1082      NCURV=(NUMV2-1-ITAG)/ISTANR
1083      IF(NCURV.GT.1)THEN
1084        CALL CODE(XIDTEM,NUMSET,IWRITE,XTEMP1,XTEMP2,MAXOBV,
1085     1            IBUGG3,IERROR)
1086        DO200I=1,N
1087          HOLD=Z(I,NUMV2-ITAG)
1088          DO210J=1,NUMSET
1089            IF(HOLD.EQ.XIDTEM(J))Z(I,NUMV2-ITAG)=XTEMP1(J)
1090  210     CONTINUE
1091  200   CONTINUE
1092        DO220I=1,NUMSET
1093          XIDTEM(I)=XTEMP1(I)
1094  220   CONTINUE
1095        ISTAFZ=ISTAFO
1096      ELSE
1097        ISTAFZ='OVER'
1098      ENDIF
1099C
1100      IF(NCURV.EQ.1)THEN
1101        ASTRT=0.0
1102        AINC=0.0
1103      ELSE
1104        ASTRT=0.4
1105        AINC=0.8/REAL(NCURV-1)
1106      ENDIF
1107C
1108      J2=0
1109      DO10000KK=1,NCURV
1110C
1111        NV1=(KK-1)*ISTANR + 1
1112        J=0
1113        ISETMX=NUMSET+1
1114        IF(NCURV.GT.1 .AND. ISTASM.EQ.'GROU')THEN
1115          ISETMX=NUMSET
1116CCCCC   ELSEIF(ICASPL.EQ.'REPE' .OR. ICASPL.EQ.'REPR' .AND.
1117CCCCC1         ISPLRL.EQ.'OVER')THEN
1118CCCCC     ISETMX=NUMSET
1119CCCCC   ELSEIF(ISPLRL.EQ.'MEAN' .OR. ISPLRL.EQ.'MEDI')THEN
1120CCCCC     ISETMX=NUMSET
1121        ENDIF
1122C
1123        DO11000ISET=1,ISETMX
1124C
1125          IF(ISET.LE.NUMSET)THEN
1126            K=0
1127            DO11011I=1,N
1128              IF(Z(I,NUMV2-ITAG).EQ.XIDTEM(ISET))THEN
1129                K=K+1
1130                TEMP(K)=Z(I,NV1)
1131                IF(ISTANR.EQ.1)THEN
1132                  TEMPZ(K)=Z(I,NV1)
1133                  TEMPZ2(K)=Z(I,NV1)
1134                ELSEIF(ISTANR.EQ.2)THEN
1135                  TEMPZ(K)=Z(I,NV1+1)
1136                  TEMPZ2(K)=Z(I,NV1+1)
1137                ELSEIF(ISTANR.EQ.3)THEN
1138                  TEMPZ(K)=Z(I,NV1+1)
1139                  TEMPZ2(K)=Z(I,NV1+2)
1140                ENDIF
1141                IF(ITAG.EQ.1)THEN
1142                  IF(K.EQ.1)THEN
1143                    AGROUP=TAG(I)
1144                  ENDIF
1145                ELSE
1146                  AGROUP=1.0
1147                ENDIF
1148              ENDIF
114911011       CONTINUE
1150            NS2=K
1151          ELSE
1152C
1153CCCCC       FEBRUARY 2005: FOR REPEATABILITY SD AND REPRODUCABILITY
1154CCCCC                      SD, OMIT FULL SAMPLE COMPUTATION (SINCE
1155CCCCC                      FULL SAMPLE STATISTIC IS NOT MEANINGFUL
1156CCCCC                      AND DISTORTS THE PLOT).
1157C
1158            IF(ISPLRL.EQ.'MEAN' .OR. ISPLRL.EQ.'MEDI')THEN
1159              IF(ISPLRL.EQ.'MEAN')THEN
1160                 CALL MEAN(Y2,NUMSET,IWRITE,RIGHT2,IBUGG3,IERROR)
1161              ELSEIF(ISPLRL.EQ.'MEDI')THEN
1162                 CALL MEDIAN(Y2,NUMSET,IWRITE,XTEMP1,MAXNXT,RIGHT2,
1163     1                       IBUGG3,IERROR)
1164              ENDIF
1165              GOTO11013
1166            ELSE
1167              DO11021I=1,N
1168                TEMP(I)=Z(I,NV1)
1169                IF(ISTANR.EQ.1)THEN
1170                  TEMPZ(I)=Z(I,NV1)
1171                  TEMPZ2(I)=Z(I,NV1)
1172                ELSEIF(ISTANR.EQ.2)THEN
1173                  TEMPZ(I)=Z(I,NV1+1)
1174                  TEMPZ2(I)=Z(I,NV1+1)
1175                ELSEIF(ISTANR.EQ.3)THEN
1176                  TEMPZ(I)=Z(I,NV1+1)
1177                  TEMPZ2(I)=Z(I,NV1+2)
1178                ENDIF
117911021         CONTINUE
1180              NS2=N
1181            ENDIF
1182          ENDIF
1183C
1184          IF(NS2.LT.1)THEN
1185            WRITE(ICOUT,999)
1186            CALL DPWRST('XXX','BUG ')
1187            WRITE(ICOUT,11081)
118811081       FORMAT('***** INTERNAL ERROR IN DPSP2--')
1189            CALL DPWRST('XXX','BUG ')
1190            WRITE(ICOUT,11082)
119111082       FORMAT('NS FOR SOME CLASS = 0')
1192            CALL DPWRST('XXX','BUG ')
1193            WRITE(ICOUT,11083)ISET,XIDTEM(ISET),NS
119411083       FORMAT('ISET,XIDTEM(ISET),NS = ',I8,G15.7,I8)
1195            CALL DPWRST('XXX','BUG ')
1196            IERROR='YES'
1197            GOTO9000
1198          ENDIF
1199C
1200CCCCC     AUGUST 2002: USE SUBROUTINE TO COMPUTE THE STATISTIC
1201CCCCC                  RATHER THAN CODING HERE.
1202C
1203          CALL CMPSTA(TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
1204     1                NS2,NS2,NS2,ISTANR,ICASPL,ISEED,
1205     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
1206     1                DTEMP1,DTEMP2,DTEMP3,
1207CCCCC1                IQUAME,IQUASE,PSTAMV,
1208     1                RIGHT,
1209     1                ISUBRO,IBUGG3,IERROR)
1210C
1211           GRAND=RIGHT
1212C
1213C         ---------------------------
1214C
1215CCCCC     NOTE: FOR DEX MODE, MAKE "OVERALL PLOT" CONTAIN 4
1216CCCCC           POINTS: AT X = XIDTEM(1) AND X = XIDTEM(NUMSET)
1217CCCCC           AND AT X = XIDTEM(1) - ASTRT AND
1218CCCCC           X = XIDTEM(NUMSET) + ASTRT.  THIS IS SO THAT
1219CCCCC           THE DPDEDL ROUTINE WILL INCLUDE THESE POINTS
1220CCCCC           WHEN COMPUTING THE DATA/FRAME LIMITS WHEN THE
1221CCCCC           XLIMITS ARE SET TO X = XIDTEM(1) AND X = XIDTEM(NUMSET)
1222CCCCC           (WHICH WILL BE FREQUENT FOR THIS COMMAND).
1223C
122411013     CONTINUE
1225C
1226          IF(ISET.LE.NUMSET)THEN
1227            J2=J2+1
1228            Y2(J2)=RIGHT
1229            IF(ISTAFZ.EQ.'DEX')THEN
1230              X2(J2)=XIDTEM(ISET) - ASTRT + REAL(KK-1)*AINC
1231C
1232C             TAG CASE NOT SUPPORTED FOR SYNTAX WITH MULTIPLE RESPONSE
1233C             VARIABLES, SO DON'T ADJUST D2 FOR THIS CASE.
1234C
1235              D2(J2)=REAL(ISET)
1236            ELSE
1237              X2(J2)=XIDTEM(ISET)
1238C
1239C             TAG CASE NOT SUPPORTED FOR SYNTAX WITH MULTIPLE RESPONSE
1240C             VARIABLES, SO IF TAG ON WILL GET UNPREDICTABLE RESULTS
1241C             FOR D2.
1242C
1243              IF(ITAG.EQ.0 .OR. KK.GT.1)THEN
1244                D2(J2)=REAL(KK)
1245              ELSE
1246                D2(J2)=AGROUP
1247              ENDIF
1248            ENDIF
1249          ELSE
1250C
1251C           CHECK IF MEAN OR MEDIAN BEING USED FOR REFERENCE LINE
1252C
1253            IF(ISPLRL.EQ.'MEAN' .OR. ISPLRL.EQ.'MEDI')THEN
1254              RIGHT=RIGHT2
1255            ENDIF
1256C
1257            IF(ISTAFZ.EQ.'DEX')THEN
1258              J2=J2+1
1259              Y2(J2)=RIGHT
1260              X2(J2)=XIDTEM(1) - ASTRT
1261              D2(J2)=REAL(NUMSET+KK)
1262              J2=J2+1
1263              Y2(J2)=RIGHT
1264              X2(J2)=XIDTEM(1)
1265              D2(J2)=REAL(NUMSET+KK)
1266              J2=J2+1
1267              Y2(J2)=RIGHT
1268              X2(J2)=XIDTEM(NUMSET)
1269              D2(J2)=REAL(NUMSET+KK)
1270              J2=J2+1
1271              Y2(J2)=RIGHT
1272              X2(J2)=XIDTEM(NUMSET) + ASTRT
1273              D2(J2)=REAL(NUMSET+KK)
1274            ELSE
1275              J2=J2+1
1276              Y2(J2)=RIGHT
1277              X2(J2)=XIDTEM(1)
1278              IF(ITAG.EQ.0)THEN
1279                D2(J2)=REAL(NCURV+KK)
1280              ELSE
1281                D2(J2)=AGROUP+1.0
1282              ENDIF
1283              J2=J2+1
1284              Y2(J2)=RIGHT
1285              X2(J2)=XIDTEM(NUMSET)
1286              IF(ITAG.EQ.0)THEN
1287                D2(J2)=REAL(NCURV+KK)
1288              ELSE
1289                D2(J2)=AGROUP+1.0
1290              ENDIF
1291            ENDIF
1292          ENDIF
1293C
129411000 CONTINUE
129510000 CONTINUE
1296C
1297C     FOR MULTIPLE RESPONSES, IF "STAT PLOT SUMMARY" = "GROUP",
1298C     THEN COMPUTE STATISTIC FOR ALL VALUES OF EACH GROUP.
1299C
1300C     NOTE THAT TAG VARIABLE NOT SUPPORTED FOR THIS CASE, SO
1301C     DON'T MODIFY THIS CODE.
1302C
1303      IF(NCURV.GT.1 .AND. ISTASM.EQ.'GROU')THEN
1304        K=0
1305        DO2000ISET=1,NUMSET
1306          DO2100I=1,N
1307            IF(Z(I,NUMV2).EQ.XIDTEM(ISET))THEN
1308              DO2200KK=1,NCURV
1309                NV1=(KK-1)*ISTANR + 1
1310                K=K+1
1311                IF(K.LE.MAXOBV)THEN
1312                  TEMP(K)=Z(I,NV1)
1313                  IF(ISTANR.EQ.1)THEN
1314                    TEMPZ(K)=Z(I,NV1)
1315                    TEMPZ2(K)=Z(I,NV1)
1316                  ELSEIF(ISTANR.EQ.2)THEN
1317                    TEMPZ(K)=Z(I,NV1+1)
1318                    TEMPZ2(K)=Z(I,NV1+1)
1319                  ELSEIF(ISTANR.EQ.3)THEN
1320                    TEMPZ(K)=Z(I,NV1+1)
1321                    TEMPZ2(K)=Z(I,NV1+2)
1322                  ENDIF
1323                ELSE
1324                  WRITE(ICOUT,999)
1325                  CALL DPWRST('XXX','BUG ')
1326                  WRITE(ICOUT,2201)
1327 2201             FORMAT('***** WARNING IN <STAT> PLOT--')
1328                  CALL DPWRST('XXX','BUG ')
1329                  WRITE(ICOUT,2203)
1330 2203             FORMAT('      UNABLE TO GENERATE SUMMARY STATISTICS',
1331     1                   'FOR GROUPS.')
1332                  CALL DPWRST('XXX','BUG ')
1333                  GOTO9000
1334                ENDIF
1335 2200         CONTINUE
1336            ENDIF
1337 2100     CONTINUE
1338C
1339          NS2=K
1340          CALL CMPSTA(TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
1341     1                NS2,NS2,NS2,ISTANR,ICASPL,ISEED,
1342     1                ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
1343     1                DTEMP1,DTEMP2,DTEMP3,
1344CCCCC1                IQUAME,IQUASE,PSTAMV,
1345     1                RIGHT,
1346     1                ISUBRO,IBUGG3,IERROR)
1347          IF(ISTAFZ.EQ.'DEX')THEN
1348            J2=J2+1
1349            Y2(J2)=RIGHT
1350            X2(J2)=XIDTEM(ISET) - ASTRT
1351            D2(J2)=REAL(NUMSET+ISET)
1352            J2=J2+1
1353            Y2(J2)=RIGHT
1354            X2(J2)=XIDTEM(ISET) + ASTRT
1355            D2(J2)=REAL(NUMSET+ISET)
1356          ELSE
1357            J2=J2+1
1358            Y2(J2)=RIGHT
1359            X2(J2)=XIDTEM(ISET)
1360            D2(J2)=REAL(NCURV+1)
1361            J2=J2+1
1362            Y2(J2)=RIGHT
1363            X2(J2)=XIDTEM(ISET)
1364            D2(J2)=REAL(NCURV+1)
1365          ENDIF
1366C
1367 2000   CONTINUE
1368      ENDIF
1369C
1370      N2=J2
1371      NPLOTV=3
1372      GOTO9000
1373C
1374C               ******************
1375C               **   STEP 90--  **
1376C               **   EXIT       **
1377C               ******************
1378C
1379 9000 CONTINUE
1380      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'PSP2')THEN
1381        WRITE(ICOUT,999)
1382        CALL DPWRST('XXX','BUG ')
1383        WRITE(ICOUT,9011)
1384 9011   FORMAT('***** AT THE END       OF DPSP2--')
1385        CALL DPWRST('XXX','BUG ')
1386        WRITE(ICOUT,9012)IBUGG3,ISUBRO
1387 9012   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4)
1388        CALL DPWRST('XXX','BUG ')
1389        WRITE(ICOUT,9013)ICASPL,N,NUMSET,N2,IERROR
1390 9013   FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4)
1391        CALL DPWRST('XXX','BUG ')
1392        WRITE(ICOUT,9014)NUMV2,ISIZE
1393 9014   FORMAT('NUMV2,ISIZE = ',2I8)
1394        CALL DPWRST('XXX','BUG ')
1395        DO9020I=1,N2
1396          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
1397 9021     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
1398          CALL DPWRST('XXX','BUG ')
1399 9020   CONTINUE
1400      ENDIF
1401C
1402      RETURN
1403      END
1404      SUBROUTINE DPSPAC(IHARG,NUMARG,
1405     1IDEFSP,
1406     1ITEXSP,
1407     1IBUGD2,ISUBRO,IFOUND,IERROR)
1408C
1409C     PURPOSE--DEFINE THE SPACING TYPE (FIXED OR PROPORTIONAL) FOR
1410C              TITLE, LABEL, AND LEGEND SCRIPT
1411C              ON A PLOT.
1412C              THE SPACING FOR THE SCRIPT WILL BE PLACED
1413C              IN THE CHARACTER VARIABLE ITEXSP.
1414C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
1415C                     --NUMARG
1416C                     --IDEFSP
1417C                     --IBUGD2
1418C     OUTPUT ARGUMENTS--ITEXSP
1419C                     --IERROR ('YES' OR 'NO' )
1420C     WRITTEN BY--JAMES J. FILLIBEN
1421C                 STATISTICAL ENGINEERING DIVISION
1422C                 INFORMATION TECHNOLOGY LABORATORY
1423C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1424C                 GAITHERSBURG, MD 20899-8980
1425C                 PHONE--301-975-2855
1426C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1427C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1428C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
1429C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
1430C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
1431C     LANGUAGE--ANSI FORTRAN (1977)
1432C     VERSION NUMBER--82/7
1433C     ORIGINAL VERSION--SEPTEMBER 1980.
1434C     UPDATED         --APRIL     1981.
1435C     UPDATED         --MAY       1982.
1436C
1437C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1438C
1439      CHARACTER*4 IHARG
1440      CHARACTER*4 IDEFSP
1441      CHARACTER*4 ITEXSP
1442      CHARACTER*4 IBUGD2
1443      CHARACTER*4 ISUBRO
1444      CHARACTER*4 IFOUND
1445      CHARACTER*4 IERROR
1446C
1447C---------------------------------------------------------------------
1448C
1449      DIMENSION IHARG(*)
1450C
1451C-----COMMON----------------------------------------------------------
1452C
1453      INCLUDE 'DPCOP2.INC'
1454C
1455C-----START POINT-----------------------------------------------------
1456C
1457      IFOUND='NO'
1458      IERROR='NO'
1459C
1460      IF(IBUGD2.EQ.'OFF')GOTO90
1461      WRITE(ICOUT,999)
1462  999 FORMAT(1X)
1463      CALL DPWRST('XXX','BUG ')
1464      WRITE(ICOUT,51)
1465   51 FORMAT('***** AT THE BEGINNING OF DPSPAC--')
1466      CALL DPWRST('XXX','BUG ')
1467      WRITE(ICOUT,53)IDEFSP
1468   53 FORMAT('IDEFSP = ',A4)
1469      CALL DPWRST('XXX','BUG ')
1470      WRITE(ICOUT,54)NUMARG
1471   54 FORMAT('NUMARG = ',I8)
1472      CALL DPWRST('XXX','BUG ')
1473      DO55I=1,NUMARG
1474      WRITE(ICOUT,56)I,IHARG(I)
1475   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
1476      CALL DPWRST('XXX','BUG ')
1477   55 CONTINUE
1478   90 CONTINUE
1479C
1480C               ***************************
1481C               **  TREAT THE SPACING CASE  **
1482C               ***************************
1483C
1484      IF(NUMARG.LE.0)GOTO1120
1485      IF(IHARG(NUMARG).EQ.'ON')GOTO1120
1486      IF(IHARG(NUMARG).EQ.'OFF')GOTO1120
1487      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1120
1488      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1120
1489      GOTO1140
1490C
1491 1120 CONTINUE
1492      ITEXSP=IDEFSP
1493      GOTO1180
1494C
1495 1140 CONTINUE
1496      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'EQUA')GOTO1141
1497      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'FIXE')GOTO1141
1498      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'PROP')GOTO1142
1499C
1500      IERROR='YES'
1501      WRITE(ICOUT,1131)
1502 1131 FORMAT('***** ERROR IN DPSPAC--')
1503      CALL DPWRST('XXX','BUG ')
1504      WRITE(ICOUT,1132)
1505 1132 FORMAT('      ILLEGAL ENTRY FOR SPACING ',
1506     1'COMMAND.')
1507      CALL DPWRST('XXX','BUG ')
1508      WRITE(ICOUT,1133)
1509 1133 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
1510     1'PROPER FORM--')
1511      CALL DPWRST('XXX','BUG ')
1512      WRITE(ICOUT,1134)
1513 1134 FORMAT('      SUPPOSE THE THE ANALYST WISHES ')
1514      CALL DPWRST('XXX','BUG ')
1515      WRITE(ICOUT,1135)
1516 1135 FORMAT('      TO SET THE SPACING TO PROPORTIONAL ')
1517      CALL DPWRST('XXX','BUG ')
1518      WRITE(ICOUT,1136)
1519 1136 FORMAT('      FOR PLOT TITLES, LABELS, ETC.,')
1520      CALL DPWRST('XXX','BUG ')
1521      WRITE(ICOUT,1137)
1522 1137 FORMAT('      THEN 2 ALLOWABLE FORMS ARE--')
1523      CALL DPWRST('XXX','BUG ')
1524      WRITE(ICOUT,1138)
1525 1138 FORMAT('            SPACING PROPORTIONAL ')
1526      CALL DPWRST('XXX','BUG ')
1527      WRITE(ICOUT,1139)
1528 1139 FORMAT('            SPACING PROP ')
1529      CALL DPWRST('XXX','BUG ')
1530      GOTO9000
1531C
1532 1141 CONTINUE
1533      ITEXSP='FIXE'
1534      GOTO1180
1535C
1536 1142 CONTINUE
1537      ITEXSP='PROP'
1538      GOTO1180
1539C
1540 1180 CONTINUE
1541      IFOUND='YES'
1542C
1543      IF(IFEEDB.EQ.'OFF')GOTO1189
1544      WRITE(ICOUT,999)
1545      CALL DPWRST('XXX','BUG ')
1546      WRITE(ICOUT,1181)
1547 1181 FORMAT('THE SPACING (FIXED OR PROPORTIONAL)')
1548      CALL DPWRST('XXX','BUG ')
1549      WRITE(ICOUT,1182)
1550 1182 FORMAT('FOR PLOT SCRIPT AND TEXT')
1551      CALL DPWRST('XXX','BUG ')
1552      WRITE(ICOUT,1183)ITEXSP
1553 1183 FORMAT('HAS JUST BEEN SET TO ',A4)
1554      CALL DPWRST('XXX','BUG ')
1555 1189 CONTINUE
1556      GOTO9000
1557C
1558C               *****************
1559C               **  STEP 90--  **
1560C               **  EXIT       **
1561C               *****************
1562C
1563 9000 CONTINUE
1564      IF(IBUGD2.EQ.'OFF')GOTO9090
1565      WRITE(ICOUT,999)
1566      CALL DPWRST('XXX','BUG ')
1567      WRITE(ICOUT,9011)
1568 9011 FORMAT('***** AT THE END       OF DPSPAC--')
1569      CALL DPWRST('XXX','BUG ')
1570      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
1571 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
1572      CALL DPWRST('XXX','BUG ')
1573      WRITE(ICOUT,9013)IDEFSP,ITEXSP
1574 9013 FORMAT('IDEFSP,ITEXSP = ',A4,2X,A4)
1575      CALL DPWRST('XXX','BUG ')
1576 9090 CONTINUE
1577C
1578      RETURN
1579      END
1580      SUBROUTINE DPSPBA(ADEFSB,MAXSPI,ASPIBA,
1581CCCCC SUBROUTINE DPSPBA(IHARG,IARGT,ARG,NUMARG,ADEFSB,MAXSPI,ASPIBA,
1582     1                  IBUGP2,IFOUND,IERROR)
1583C
1584C     PURPOSE--DEFINE THE SPIKE BASES.
1585C              THESE ARE LOCATED IN THE VECTOR ASPIBA(.).
1586C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
1587C                     --IARGT  (A  CHARACTER VECTOR)
1588C                     --ARG
1589C                     --NUMARG
1590C                     --ADEFSB
1591C                     --MAXSPI
1592C                     --IBUGP2 ('ON' OR 'OFF' )
1593C     OUTPUT ARGUMENTS--ASPIBA (A FLOATING POINT VECTOR)
1594C                     --IFOUND ('YES' OR 'NO' )
1595C                     --IERROR ('YES' OR 'NO' )
1596C     WRITTEN BY--JAMES J. FILLIBEN
1597C                 STATISTICAL ENGINEERING DIVISION
1598C                 INFORMATION TECHNOLOGY LABORATORY
1599C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1600C                 GAITHERSBURG, MD 20899-8980
1601C                 PHONE--301-975-2855
1602C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1603C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1604C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
1605C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
1606C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
1607C     LANGUAGE--ANSI FORTRAN (1977)
1608C     VERSION NUMBER--82/7
1609C     ORIGINAL VERSION--DECEMBER  1983.
1610C     UPDATED         --APRIL     2008. SPIKE BASE AUTOMATIC
1611C
1612C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1613C
1614CCCCC CHARACTER*4 IHARG
1615CCCCC CHARACTER*4 IARGT
1616C
1617      CHARACTER*4 IBUGP2
1618      CHARACTER*4 IFOUND
1619      CHARACTER*4 IERROR
1620C
1621      CHARACTER*4 IHOLD1
1622C
1623      CHARACTER*4 ISUBN1
1624      CHARACTER*4 ISUBN2
1625      CHARACTER*4 ISTEPN
1626C
1627      CHARACTER*4 IHLEFT
1628      CHARACTER*4 IHLEF2
1629      CHARACTER*4 IHWUSE
1630      CHARACTER*4 MESSAG
1631      CHARACTER*4 ICASEQ
1632      CHARACTER*4 IWRITE
1633      CHARACTER*4 IBUGQ
1634C
1635CCCCC DIMENSION IHARG(*)
1636CCCCC DIMENSION IARGT(*)
1637CCCCC DIMENSION ARG(*)
1638      DIMENSION ASPIBA(*)
1639C
1640C-----COMMON----------------------------------------------------------
1641C
1642      INCLUDE 'DPCOPA.INC'
1643      INCLUDE 'DPCOHK.INC'
1644      INCLUDE 'DPCODA.INC'
1645      INCLUDE 'DPCOP2.INC'
1646C
1647C-----START POINT-----------------------------------------------------
1648C
1649      IFOUND='NO'
1650      IERROR='NO'
1651      ISUBN1='DPSP'
1652      ISUBN2='BA  '
1653C
1654      NUMSPI=0
1655      IHOLD1='-999'
1656      HOLD1=-999.0
1657      HOLD2=-999.0
1658C
1659      IF(IBUGP2.EQ.'ON')THEN
1660        WRITE(ICOUT,999)
1661  999   FORMAT(1X)
1662        CALL DPWRST('XXX','BUG ')
1663        WRITE(ICOUT,51)
1664   51   FORMAT('***** AT THE BEGINNING OF DPSPBA--')
1665        CALL DPWRST('XXX','BUG ')
1666        WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
1667   52   FORMAT('IBUGP2,IFOUND,IERROR = ',2(A4,2X),A4)
1668        CALL DPWRST('XXX','BUG ')
1669        WRITE(ICOUT,53)MAXSPI,NUMSPI,NUMARG,ADEFSB,ASPIBA(1)
1670   53   FORMAT('MAXSPI,NUMSPI,NUMARG,ADEFSB,ASPIBA(1) = ',3I8,2G15.7)
1671        CALL DPWRST('XXX','BUG ')
1672        WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
1673   54   FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2G15.7)
1674        CALL DPWRST('XXX','BUG ')
1675        DO65I=1,NUMARG
1676          WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
1677   66     FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
1678          CALL DPWRST('XXX','BUG ')
1679   65   CONTINUE
1680        DO75I=1,10
1681          WRITE(ICOUT,76)I,ASPIBA(I)
1682   76     FORMAT('I,ASPIBA(I) = ',I8,2X,E15.7)
1683          CALL DPWRST('XXX','BUG ')
1684   75   CONTINUE
1685      ENDIF
1686C
1687C               **************************************
1688C               **  STEP 1--                        **
1689C               **  BRANCH TO THE APPROPRIATE CASE  **
1690C               **************************************
1691C
1692      ISTEPN='1'
1693      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1694C
1695      IF(NUMARG.LE.0)GOTO9000
1696CCCCC APRIL 2008.  ADD SPIKE BASE AUTOMATIC <VAR>
1697      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000
1698      IF(NUMARG.GE.4.AND.IHARG(3).EQ.'AUTO')GOTO3000
1699C
1700      IF(NUMARG.EQ.1)GOTO1110
1701      IF(NUMARG.EQ.2)GOTO1120
1702      IF(NUMARG.EQ.3)GOTO1130
1703      GOTO1140
1704C
1705 1110 CONTINUE
1706      GOTO1200
1707C
1708 1120 CONTINUE
1709      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
1710      IF(IHARG(2).EQ.'ALL')HOLD1=ADEFSB
1711      IF(IHARG(2).EQ.'ALL')GOTO1300
1712      GOTO1200
1713C
1714 1130 CONTINUE
1715      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
1716      IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3)
1717      IF(IHARG(2).EQ.'ALL')GOTO1300
1718      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
1719      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2)
1720      IF(IHARG(3).EQ.'ALL')GOTO1300
1721      GOTO1200
1722C
1723 1140 CONTINUE
1724      GOTO1200
1725C
1726C               *************************************************
1727C               **  STEP 2--                                   **
1728C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
1729C               *************************************************
1730C
1731 1200 CONTINUE
1732      ISTEPN='2'
1733      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1734C
1735      IF(NUMARG.LE.1)GOTO1210
1736      GOTO1220
1737C
1738 1210 CONTINUE
1739      NUMSPI=1
1740      ASPIBA(1)=ADEFSB
1741      GOTO1270
1742C
1743 1220 CONTINUE
1744      NUMSPI=NUMARG-1
1745      IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI
1746      DO1225I=1,NUMSPI
1747        J=I+1
1748        IHOLD1=IHARG(J)
1749        HOLD1=ARG(J)
1750        HOLD2=HOLD1
1751        IF(IHOLD1.EQ.'ON')HOLD2=ADEFSB
1752        IF(IHOLD1.EQ.'OFF')HOLD2=ADEFSB
1753        IF(IHOLD1.EQ.'AUTO')HOLD2=ADEFSB
1754        IF(IHOLD1.EQ.'DEFA')HOLD2=ADEFSB
1755        ASPIBA(I)=HOLD2
1756 1225 CONTINUE
1757      GOTO1270
1758C
1759 1270 CONTINUE
1760      IF(IFEEDB.EQ.'ON')THEN
1761        WRITE(ICOUT,999)
1762        CALL DPWRST('XXX','BUG ')
1763        DO1278I=1,NUMSPI
1764          WRITE(ICOUT,1276)I,ASPIBA(I)
1765 1276     FORMAT('SPIKE BASE ',I6,' HAS JUST BEEN SET TO ',G15.7)
1766          CALL DPWRST('XXX','BUG ')
1767 1278   CONTINUE
1768      ENDIF
1769      IFOUND='YES'
1770      GOTO9000
1771C
1772C               **************************
1773C               **  STEP 2--            **
1774C               **  TREAT THE ALL CASE  **
1775C               **************************
1776C
1777 1300 CONTINUE
1778      ISTEPN='3'
1779      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1780C
1781      NUMSPI=MAXSPI
1782      HOLD2=HOLD1
1783      IF(IHOLD1.EQ.'ON')HOLD2=ADEFSB
1784      IF(IHOLD1.EQ.'OFF')HOLD2=ADEFSB
1785      IF(IHOLD1.EQ.'AUTO')HOLD2=ADEFSB
1786      IF(IHOLD1.EQ.'DEFA')HOLD2=ADEFSB
1787      DO1315I=1,NUMSPI
1788        ASPIBA(I)=HOLD2
1789 1315 CONTINUE
1790      GOTO1370
1791C
1792 1370 CONTINUE
1793      IF(IFEEDB.EQ.'ON')THEN
1794        WRITE(ICOUT,999)
1795        CALL DPWRST('XXX','BUG ')
1796        I=1
1797        WRITE(ICOUT,1316)ASPIBA(I)
1798 1316   FORMAT('ALL SPIKE BASES HAVE JUST BEEN SET TO ',A4)
1799        CALL DPWRST('XXX','BUG ')
1800      ENDIF
1801      IFOUND='YES'
1802      GOTO9000
1803C
1804C               ******************************************************
1805C               **  STEP 30--                                       **
1806C               **  TREAT THE SPIKE BASE AUTOMATIC <VARIABLE>   CASE**
1807C               ******************************************************
1808C
1809 3000 CONTINUE
1810C
1811C               **********************************************
1812C               **  STEP 31--                               **
1813C               **  CHECK THE VALIDITY OF ARGUMENT 2 (OR 3) **
1814C               **  (THIS WILL BE THE RESPONSE VARIABLE)    **
1815C               **********************************************
1816C
1817      ISTEPN='31'
1818      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1819C
1820      IHLEFT=IHARG(3)
1821      IHLEF2=IHARG2(3)
1822      IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')THEN
1823        IHLEFT=IHARG(4)
1824        IHLEF2=IHARG2(4)
1825      ENDIF
1826      IHWUSE='V'
1827      MESSAG='YES'
1828      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
1829     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1830     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
1831      IF(IERROR.EQ.'YES')GOTO9000
1832      ICOLL=IVALUE(ILOCV)
1833      NLEFT=IN(ILOCV)
1834C
1835C               *****************************************
1836C               **  STEP 32--                          **
1837C               **  CHECK TO SEE THE TYPE CASE--       **
1838C               **    1) UNQUALIFIED (THAT IS, FULL);  **
1839C               **    2) SUBSET/EXCEPT; OR             **
1840C               **    3) FOR.                          **
1841C               *****************************************
1842C
1843      ISTEPN='32'
1844      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1845C
1846      ICASEQ='FULL'
1847      ILOCQ=NUMARG+1
1848      IF(NUMARG.LT.1)GOTO3290
1849      DO3200J=1,NUMARG
1850      J1=J
1851      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO3210
1852      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO3210
1853      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO3220
1854 3200 CONTINUE
1855      GOTO3290
1856 3210 CONTINUE
1857      ICASEQ='SUBS'
1858      ILOCQ=J1
1859      GOTO3290
1860 3220 CONTINUE
1861      ICASEQ='FOR'
1862      ILOCQ=J1
1863      GOTO3290
1864 3290 CONTINUE
1865      IF(IBUGP2.EQ.'OFF')GOTO3295
1866      WRITE(ICOUT,3291)NUMARG,ILOCQ
1867 3291 FORMAT('NUMARG,ILOCQ = ',2I8)
1868      CALL DPWRST('XXX','BUG ')
1869 3295 CONTINUE
1870C
1871C               *********************************************
1872C               **  STEP 33--                              **
1873C               **  TEMPORARILY FORM THE VARIABLE Y(.)     **
1874C               **  WHICH WILL HOLD THE RESPONSE VARIABLE. **
1875C               **  FORM THIS VARIABLE BY                  **
1876C               **  BRANCHING TO THE APPROPRIATE SUBCASE   **
1877C               **  (FULL, SUBSET, OR FOR).                **
1878C               *********************************************
1879C
1880      ISTEPN='33'
1881      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1882C
1883      IF(ICASEQ.EQ.'FULL')GOTO3310
1884      IF(ICASEQ.EQ.'SUBS')GOTO3320
1885      IF(ICASEQ.EQ.'FOR')GOTO3330
1886C
1887 3310 CONTINUE
1888      DO3315I=1,NLEFT
1889        ISUB(I)=1
1890 3315 CONTINUE
1891      NQ=NLEFT
1892      GOTO3350
1893C
1894 3320 CONTINUE
1895      NIOLD=NLEFT
1896      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
1897      NQ=NIOLD
1898      GOTO3350
1899C
1900 3330 CONTINUE
1901      NIOLD=NLEFT
1902      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
1903     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
1904      NQ=NFOR
1905      GOTO3350
1906C
1907 3350 CONTINUE
1908      MINN2=1
1909      IF(NQ.LT.MINN2)THEN
1910        WRITE(ICOUT,999)
1911        CALL DPWRST('XXX','BUG ')
1912        WRITE(ICOUT,3351)
1913 3351   FORMAT('***** ERROR IN SPIKE BASE AUTOMATIC--')
1914        CALL DPWRST('XXX','BUG ')
1915        WRITE(ICOUT,3352)
1916 3352   FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
1917     1         'EXTRACTED,')
1918        CALL DPWRST('XXX','BUG ')
1919        WRITE(ICOUT,3353)IHLEFT,IHLEF2
1920 3353   FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
1921     1         'FROM VARIABLE ',A4,A4)
1922        CALL DPWRST('XXX','BUG ')
1923        WRITE(ICOUT,3354)
1924 3354   FORMAT('      (FOR WHICH SPIKE BASE DEFINITIONS ')
1925        CALL DPWRST('XXX','BUG ')
1926        WRITE(ICOUT,3355)
1927 3355   FORMAT('      ARE TO BE GENERATED)')
1928        CALL DPWRST('XXX','BUG ')
1929        WRITE(ICOUT,3356)MINN2
1930 3356   FORMAT('      MUST BE ',I8,' OR LARGER;')
1931        CALL DPWRST('XXX','BUG ')
1932        WRITE(ICOUT,3357)
1933 3357   FORMAT('      SUCH WAS NOT THE CASE HERE.')
1934        CALL DPWRST('XXX','BUG ')
1935        WRITE(ICOUT,3358)
1936 3358   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
1937        CALL DPWRST('XXX','BUG ')
1938        IF(IWIDTH.GE.1)THEN
1939          WRITE(ICOUT,3359)(IANS(I),I=1,MIN(80,IWIDTH))
1940 3359     FORMAT('      ',80A1)
1941          CALL DPWRST('XXX','BUG ')
1942        ENDIF
1943        IERROR='YES'
1944      ENDIF
1945C
1946      MAXCP1=MAXCOL+1
1947      MAXCP2=MAXCOL+2
1948      MAXCP3=MAXCOL+3
1949      MAXCP4=MAXCOL+4
1950      MAXCP5=MAXCOL+5
1951      MAXCP6=MAXCOL+6
1952      J=0
1953      IMAX=NLEFT
1954      IF(NQ.LT.NLEFT)IMAX=NQ
1955      DO3370I=1,IMAX
1956        IF(ISUB(I).EQ.0)GOTO3370
1957        J=J+1
1958C
1959        IJ=MAXN*(ICOLL-1)+I
1960        IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ)
1961        IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I)
1962        IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I)
1963        IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I)
1964        IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I)
1965        IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I)
1966        IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I)
1967C
1968 3370 CONTINUE
1969      NS=J
1970      NY=J
1971C
1972C               *****************************************
1973C               **  STEP 34--                          **
1974C               **  IF HAVE THE FORM--                 **
1975C               **  SPIKE BASE AUTOMATIC DISTINCT X    **
1976C               **  EXTRACT THE DISTINCT VALUES        **
1977C               **  FROM THE TARGET VARIABLE Y(.)   .  **
1978C               **  STORE THEM IN X(.)   .             **
1979C               **  IF HAVE THE FORM--                 **
1980C               **  SPIKE BASE AUTOMATIC X             **
1981C               **  DO NOTHING                         **
1982C               *****************************************
1983C
1984      IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')THEN
1985        IWRITE='OFF'
1986        CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR)
1987      ELSE
1988        DO3411I=1,NY
1989          X(I)=Y(I)
1990 3411   CONTINUE
1991        NX=NY
1992      ENDIF
1993C
1994C               ******************************************
1995C               **  STEP 36--                           **
1996C               **  COPY VALUES IN X(.) TO ASPIBA       **
1997C               **        MAX NUMBER OF BARS    = 100   **
1998C               ******************************************
1999C
2000      IMAX=NX
2001      IF(IMAX.GT.MAXSPI)IMAX=MAXSPI
2002      DO3650I=1,IMAX
2003        ASPIBA(I)=X(I)
2004 3650 CONTINUE
2005C
2006      IF(IFEEDB.EQ.'ON')THEN
2007        WRITE(ICOUT,999)
2008        CALL DPWRST('XXX','BUG ')
2009        DO3675I=1,IMAX
2010          WRITE(ICOUT,3676)I,ASPIBA(I)
2011 3676     FORMAT('SPIKE BASE ',I6,' HAS JUST BEEN SET TO ',G15.7)
2012          CALL DPWRST('XXX','BUG ')
2013 3675   CONTINUE
2014      ENDIF
2015      IFOUND='YES'
2016      GOTO9000
2017C
2018C               *****************
2019C               **  STEP 90--  **
2020C               **  EXIT       **
2021C               *****************
2022C
2023 9000 CONTINUE
2024      IF(IBUGP2.EQ.'ON')THEN
2025        WRITE(ICOUT,9011)
2026 9011   FORMAT('***** AT THE END       OF DPSPBA--')
2027        CALL DPWRST('XXX','BUG ')
2028        WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
2029 9012   FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
2030        CALL DPWRST('XXX','BUG ')
2031        WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
2032 9014   FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
2033        CALL DPWRST('XXX','BUG ')
2034        DO9025I=1,NUMARG
2035          WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
2036 9026     FORMAT('IHARG(I),IARGT(I),ARG(I) = ',2(A4,2X),I8)
2037         CALL DPWRST('XXX','BUG ')
2038 9025   CONTINUE
2039        DO9035I=1,10
2040          WRITE(ICOUT,9036)I,ASPIBA(I)
2041 9036     FORMAT('I,ASPIBA(I) = ',I8,2X,G15.7)
2042          CALL DPWRST('XXX','BUG ')
2043 9035   CONTINUE
2044      ENDIF
2045C
2046      RETURN
2047      END
2048      SUBROUTINE DPSPCO(IHARG,NUMARG,IDEFSC,MAXSPI,ISPICO,
2049     1IBUGP2,IFOUND,IERROR)
2050C
2051C     PURPOSE--DEFINE THE SPIKE COLORS.
2052C              THESE ARE LOCATED IN THE VECTOR ISPICO(.).
2053C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
2054C                     --NUMARG
2055C                     --IDEFSC
2056C                     --MAXSPI
2057C                     --IBUGP2 ('ON' OR 'OFF' )
2058C     OUTPUT ARGUMENTS--ISPICO (A CHARACTER VECTOR)
2059C                     --IFOUND ('YES' OR 'NO' )
2060C                     --IERROR ('YES' OR 'NO' )
2061C     WRITTEN BY--JAMES J. FILLIBEN
2062C                 STATISTICAL ENGINEERING DIVISION
2063C                 INFORMATION TECHNOLOGY LABORATORY
2064C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2065C                 GAITHERSBURG, MD 20899-8980
2066C                 PHONE--301-975-2855
2067C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2068C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2069C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
2070C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
2071C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
2072C     LANGUAGE--ANSI FORTRAN (1977)
2073C     VERSION NUMBER--82/7
2074C     ORIGINAL VERSION--DECEMBER  1983.
2075C
2076C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2077C
2078      CHARACTER*4 IHARG
2079      CHARACTER*4 IDEFSC
2080      CHARACTER*4 ISPICO
2081C
2082      CHARACTER*4 IBUGP2
2083      CHARACTER*4 IFOUND
2084      CHARACTER*4 IERROR
2085C
2086      CHARACTER*4 IHOLD1
2087      CHARACTER*4 IHOLD2
2088C
2089      CHARACTER*4 ISUBN1
2090      CHARACTER*4 ISUBN2
2091      CHARACTER*4 ISTEPN
2092C
2093      DIMENSION IHARG(*)
2094      DIMENSION ISPICO(*)
2095C
2096C-----COMMON----------------------------------------------------------
2097C
2098      INCLUDE 'DPCOP2.INC'
2099C
2100C-----START POINT-----------------------------------------------------
2101C
2102      IFOUND='NO'
2103      IERROR='NO'
2104      ISUBN1='DPSP'
2105      ISUBN2='CO  '
2106C
2107      NUMSPI=0
2108      IHOLD1='-999'
2109      IHOLD2='-999'
2110C
2111      IF(IBUGP2.EQ.'OFF')GOTO90
2112      WRITE(ICOUT,999)
2113  999 FORMAT(1X)
2114      CALL DPWRST('XXX','BUG ')
2115      WRITE(ICOUT,51)
2116   51 FORMAT('***** AT THE BEGINNING OF DPSPCO--')
2117      CALL DPWRST('XXX','BUG ')
2118      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
2119   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
2120      CALL DPWRST('XXX','BUG ')
2121      WRITE(ICOUT,53)MAXSPI,NUMSPI
2122   53 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
2123      CALL DPWRST('XXX','BUG ')
2124      WRITE(ICOUT,54)IHOLD1,IHOLD2
2125   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
2126      CALL DPWRST('XXX','BUG ')
2127      WRITE(ICOUT,55)IDEFSC
2128   55 FORMAT('IDEFSC = ',A4)
2129      CALL DPWRST('XXX','BUG ')
2130      WRITE(ICOUT,60)NUMARG
2131   60 FORMAT('NUMARG = ',I8)
2132      CALL DPWRST('XXX','BUG ')
2133      DO65I=1,NUMARG
2134      WRITE(ICOUT,66)IHARG(I)
2135   66 FORMAT('IHARG(I) = ',A4)
2136      CALL DPWRST('XXX','BUG ')
2137   65 CONTINUE
2138      WRITE(ICOUT,70)ISPICO(1)
2139   70 FORMAT('ISPICO(1) = ',A4)
2140      CALL DPWRST('XXX','BUG ')
2141      DO75I=1,10
2142      WRITE(ICOUT,76)I,ISPICO(I)
2143   76 FORMAT('I,ISPICO(I) = ',I8,2X,A4)
2144      CALL DPWRST('XXX','BUG ')
2145   75 CONTINUE
2146   90 CONTINUE
2147C
2148C               **************************************
2149C               **  STEP 1--                        **
2150C               **  BRANCH TO THE APPROPRIATE CASE  **
2151C               **************************************
2152C
2153      ISTEPN='1'
2154      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2155C
2156      IF(NUMARG.LE.0)GOTO9000
2157      IF(NUMARG.EQ.1)GOTO1110
2158      IF(NUMARG.EQ.2)GOTO1120
2159      IF(NUMARG.EQ.3)GOTO1130
2160      GOTO1140
2161C
2162 1110 CONTINUE
2163      GOTO1200
2164C
2165 1120 CONTINUE
2166      IF(IHARG(2).EQ.'ALL')IHOLD1=IDEFSC
2167      IF(IHARG(2).EQ.'ALL')GOTO1300
2168      GOTO1200
2169C
2170 1130 CONTINUE
2171      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
2172      IF(IHARG(2).EQ.'ALL')GOTO1300
2173      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
2174      IF(IHARG(3).EQ.'ALL')GOTO1300
2175      GOTO1200
2176C
2177 1140 CONTINUE
2178      GOTO1200
2179C
2180C               *************************************************
2181C               **  STEP 2--                                   **
2182C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
2183C               *************************************************
2184C
2185 1200 CONTINUE
2186      ISTEPN='2'
2187      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2188C
2189      IF(NUMARG.LE.1)GOTO1210
2190      GOTO1220
2191C
2192 1210 CONTINUE
2193      NUMSPI=1
2194      ISPICO(1)=IDEFSC
2195      GOTO1270
2196C
2197 1220 CONTINUE
2198      NUMSPI=NUMARG-1
2199      IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI
2200      DO1225I=1,NUMSPI
2201      J=I+1
2202      IHOLD1=IHARG(J)
2203      IHOLD2=IHOLD1
2204      IF(IHOLD1.EQ.'ON')IHOLD2=IDEFSC
2205      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFSC
2206      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSC
2207      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSC
2208      ISPICO(I)=IHOLD2
2209 1225 CONTINUE
2210      GOTO1270
2211C
2212 1270 CONTINUE
2213      IF(IFEEDB.EQ.'OFF')GOTO1279
2214      WRITE(ICOUT,999)
2215      CALL DPWRST('XXX','BUG ')
2216      DO1278I=1,NUMSPI
2217      WRITE(ICOUT,1276)I,ISPICO(I)
2218 1276 FORMAT('SPIKE COLOR ',I6,' HAS JUST BEEN SET TO ',
2219     1A4)
2220      CALL DPWRST('XXX','BUG ')
2221 1278 CONTINUE
2222 1279 CONTINUE
2223      IFOUND='YES'
2224      GOTO9000
2225C
2226C               **************************
2227C               **  STEP 2--            **
2228C               **  TREAT THE ALL CASE  **
2229C               **************************
2230C
2231 1300 CONTINUE
2232      ISTEPN='3'
2233      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2234C
2235      NUMSPI=MAXSPI
2236      IHOLD2=IHOLD1
2237      IF(IHOLD1.EQ.'ON')IHOLD2=IDEFSC
2238      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFSC
2239      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSC
2240      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSC
2241      DO1315I=1,NUMSPI
2242      ISPICO(I)=IHOLD2
2243 1315 CONTINUE
2244      GOTO1370
2245C
2246 1370 CONTINUE
2247      IF(IFEEDB.EQ.'OFF')GOTO1319
2248      WRITE(ICOUT,999)
2249      CALL DPWRST('XXX','BUG ')
2250      I=1
2251      WRITE(ICOUT,1316)ISPICO(I)
2252 1316 FORMAT('ALL SPIKE COLORS HAVE JUST BEEN SET TO ',
2253     1A4)
2254      CALL DPWRST('XXX','BUG ')
2255 1319 CONTINUE
2256      IFOUND='YES'
2257      GOTO9000
2258C
2259C               *****************
2260C               **  STEP 90--  **
2261C               **  EXIT       **
2262C               *****************
2263C
2264 9000 CONTINUE
2265      IF(IBUGP2.EQ.'OFF')GOTO9090
2266      WRITE(ICOUT,9011)
2267 9011 FORMAT('***** AT THE END       OF DPSPCO--')
2268      CALL DPWRST('XXX','BUG ')
2269      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
2270 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
2271      CALL DPWRST('XXX','BUG ')
2272      WRITE(ICOUT,9013)MAXSPI,NUMSPI
2273 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
2274      CALL DPWRST('XXX','BUG ')
2275      WRITE(ICOUT,9014)IHOLD1,IHOLD2
2276 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
2277      CALL DPWRST('XXX','BUG ')
2278      WRITE(ICOUT,9015)IDEFSC
2279 9015 FORMAT('IDEFSC = ',A4)
2280      CALL DPWRST('XXX','BUG ')
2281      WRITE(ICOUT,9020)NUMARG
2282 9020 FORMAT('NUMARG = ',I8)
2283      CALL DPWRST('XXX','BUG ')
2284      DO9025I=1,NUMARG
2285      WRITE(ICOUT,9026)IHARG(I)
2286 9026 FORMAT('IHARG(I) = ',A4)
2287      CALL DPWRST('XXX','BUG ')
2288 9025 CONTINUE
2289      WRITE(ICOUT,9030)ISPICO(1)
2290 9030 FORMAT('ISPICO(1) = ',A4)
2291      CALL DPWRST('XXX','BUG ')
2292      DO9035I=1,10
2293      WRITE(ICOUT,9036)I,ISPICO(I)
2294 9036 FORMAT('I,ISPICO(I) = ',I8,2X,A4)
2295      CALL DPWRST('XXX','BUG ')
2296 9035 CONTINUE
2297 9090 CONTINUE
2298C
2299      RETURN
2300      END
2301      SUBROUTINE DPSPDI(IHARG,NUMARG,IDEFSD,MAXSPI,ISPIDI,
2302     1IBUGP2,IFOUND,IERROR)
2303C
2304C     PURPOSE--DEFINE THE SPIKE DIRECTION--
2305C              VERT = VERTICAL
2306C              HORI = HORIZONTAL
2307C              HOR2 = HORIZONTAL TOWARD X2-X3 PLANE (FOR 3D PLOTS)
2308C              THESE ARE LOCATED IN THE VECTOR ISPIDI(.).
2309C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
2310C                     --NUMARG
2311C                     --IDEFSD
2312C                     --MAXSPI
2313C                     --IBUGP2 ('ON' OR 'OFF' )
2314C     OUTPUT ARGUMENTS--ISPIDI (A CHARACTER VECTOR)
2315C                     --IFOUND ('YES' OR 'NO' )
2316C                     --IERROR ('YES' OR 'NO' )
2317C     WRITTEN BY--JAMES J. FILLIBEN
2318C                 STATISTICAL ENGINEERING DIVISION
2319C                 INFORMATION TECHNOLOGY LABORATORY
2320C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2321C                 GAITHERSBURG, MD 20899-8980
2322C                 PHONE--301-975-2855
2323C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2324C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2325C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
2326C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
2327C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
2328C     LANGUAGE--ANSI FORTRAN (1977)
2329C     VERSION NUMBER--87/5
2330C     ORIGINAL VERSION--MAY       1987.
2331C
2332C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2333C
2334      CHARACTER*4 IHARG
2335      CHARACTER*4 IDEFSD
2336      CHARACTER*4 ISPIDI
2337C
2338      CHARACTER*4 IBUGP2
2339      CHARACTER*4 IFOUND
2340      CHARACTER*4 IERROR
2341C
2342      CHARACTER*4 IHOLD1
2343      CHARACTER*4 IHOLD2
2344C
2345      CHARACTER*4 ISUBN1
2346      CHARACTER*4 ISUBN2
2347      CHARACTER*4 ISTEPN
2348C
2349      DIMENSION IHARG(*)
2350      DIMENSION ISPIDI(*)
2351C
2352C-----COMMON----------------------------------------------------------
2353C
2354      INCLUDE 'DPCOP2.INC'
2355C
2356C-----START POINT-----------------------------------------------------
2357C
2358      IFOUND='NO'
2359      IERROR='NO'
2360      ISUBN1='DPSP'
2361      ISUBN2='DI  '
2362C
2363      NUMSPI=0
2364      IHOLD1='-999'
2365      IHOLD2='-999'
2366C
2367      IF(IBUGP2.EQ.'OFF')GOTO90
2368      WRITE(ICOUT,999)
2369  999 FORMAT(1X)
2370      CALL DPWRST('XXX','BUG ')
2371      WRITE(ICOUT,51)
2372   51 FORMAT('***** AT THE BEGINNING OF DPSPDI--')
2373      CALL DPWRST('XXX','BUG ')
2374      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
2375   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
2376      CALL DPWRST('XXX','BUG ')
2377      WRITE(ICOUT,53)MAXSPI,NUMSPI
2378   53 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
2379      CALL DPWRST('XXX','BUG ')
2380      WRITE(ICOUT,54)IHOLD1,IHOLD2
2381   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
2382      CALL DPWRST('XXX','BUG ')
2383      WRITE(ICOUT,55)IDEFSD
2384   55 FORMAT('IDEFSD = ',A4)
2385      CALL DPWRST('XXX','BUG ')
2386      WRITE(ICOUT,60)NUMARG
2387   60 FORMAT('NUMARG = ',I8)
2388      CALL DPWRST('XXX','BUG ')
2389      DO65I=1,NUMARG
2390      WRITE(ICOUT,66)IHARG(I)
2391   66 FORMAT('IHARG(I) = ',A4)
2392      CALL DPWRST('XXX','BUG ')
2393   65 CONTINUE
2394      WRITE(ICOUT,70)ISPIDI(1)
2395   70 FORMAT('ISPIDI(1) = ',A4)
2396      CALL DPWRST('XXX','BUG ')
2397      DO75I=1,10
2398      WRITE(ICOUT,76)I,ISPIDI(I)
2399   76 FORMAT('I,ISPIDI(I) = ',I8,2X,A4)
2400      CALL DPWRST('XXX','BUG ')
2401   75 CONTINUE
2402   90 CONTINUE
2403C
2404C               **************************************
2405C               **  STEP 1--                        **
2406C               **  BRANCH TO THE APPROPRIATE CASE  **
2407C               **************************************
2408C
2409      ISTEPN='1'
2410      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2411C
2412      IF(NUMARG.LE.0)GOTO9000
2413      IF(NUMARG.EQ.1)GOTO1110
2414      IF(NUMARG.EQ.2)GOTO1120
2415      IF(NUMARG.EQ.3)GOTO1130
2416      GOTO1140
2417C
2418 1110 CONTINUE
2419      GOTO1200
2420C
2421 1120 CONTINUE
2422      IF(IHARG(2).EQ.'ALL')IHOLD1='VERT'
2423      IF(IHARG(2).EQ.'ALL')GOTO1300
2424      GOTO1200
2425C
2426 1130 CONTINUE
2427      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
2428      IF(IHARG(2).EQ.'ALL')GOTO1300
2429      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
2430      IF(IHARG(3).EQ.'ALL')GOTO1300
2431      GOTO1200
2432C
2433 1140 CONTINUE
2434      GOTO1200
2435C
2436C               *************************************************
2437C               **  STEP 2--                                   **
2438C               **  TREAT THE SINGLE     SPECIFICATION   CASE  **
2439C               *************************************************
2440C
2441 1200 CONTINUE
2442      ISTEPN='2'
2443      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2444C
2445      IF(NUMARG.LE.1)GOTO1210
2446      GOTO1220
2447C
2448 1210 CONTINUE
2449      NUMSPI=1
2450      ISPIDI(1)='VERT'
2451      GOTO1270
2452C
2453 1220 CONTINUE
2454      NUMSPI=NUMARG-1
2455      IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI
2456      DO1225I=1,NUMSPI
2457      J=I+1
2458      IHOLD1=IHARG(J)
2459      IHOLD2=IHOLD1
2460C???? IF(IHOLD1.EQ.'VERT')IHOLD2='VERT'
2461C???? IF(IHOLD1.EQ.'3')IHOLD2='3'
2462CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSD
2463CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSD
2464      ISPIDI(I)=IHOLD2
2465 1225 CONTINUE
2466      GOTO1270
2467C
2468 1270 CONTINUE
2469      IF(IFEEDB.EQ.'OFF')GOTO1279
2470      WRITE(ICOUT,999)
2471      CALL DPWRST('XXX','BUG ')
2472      DO1278I=1,NUMSPI
2473      WRITE(ICOUT,1276)I,ISPIDI(I)
2474 1276 FORMAT('SPIKE DIRECTION ',I6,
2475     1' HAS JUST BEEN SET TO ',A4)
2476      CALL DPWRST('XXX','BUG ')
2477 1278 CONTINUE
2478 1279 CONTINUE
2479      IFOUND='YES'
2480      GOTO9000
2481C
2482C               **************************
2483C               **  STEP 3--            **
2484C               **  TREAT THE ALL CASE  **
2485C               **************************
2486C
2487 1300 CONTINUE
2488      ISTEPN='3'
2489      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2490C
2491      NUMSPI=MAXSPI
2492      IHOLD2=IHOLD1
2493C???? IF(IHOLD1.EQ.'2')IHOLD2='2'
2494C???? IF(IHOLD1.EQ.'3')IHOLD2='3'
2495CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSD
2496CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSD
2497      DO1315I=1,NUMSPI
2498      ISPIDI(I)=IHOLD2
2499 1315 CONTINUE
2500      GOTO1370
2501C
2502 1370 CONTINUE
2503      IF(IFEEDB.EQ.'OFF')GOTO1319
2504      WRITE(ICOUT,999)
2505      CALL DPWRST('XXX','BUG ')
2506      I=1
2507      WRITE(ICOUT,1316)ISPIDI(I)
2508 1316 FORMAT('ALL SPIKE DIRECTIONS',
2509     1'HAVE JUST BEEN SET TO ',A4)
2510      CALL DPWRST('XXX','BUG ')
2511 1319 CONTINUE
2512      IFOUND='YES'
2513      GOTO9000
2514C
2515C               *****************
2516C               **  STEP 90--  **
2517C               **  EXIT       **
2518C               *****************
2519C
2520 9000 CONTINUE
2521      IF(IBUGP2.EQ.'OFF')GOTO9090
2522      WRITE(ICOUT,9011)
2523 9011 FORMAT('***** AT THE END       OF DPSPDI--')
2524      CALL DPWRST('XXX','BUG ')
2525      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
2526 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
2527      CALL DPWRST('XXX','BUG ')
2528      WRITE(ICOUT,9013)MAXSPI,NUMSPI
2529 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
2530      CALL DPWRST('XXX','BUG ')
2531      WRITE(ICOUT,9014)IHOLD1,IHOLD2
2532 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
2533      CALL DPWRST('XXX','BUG ')
2534      WRITE(ICOUT,9015)IDEFSD
2535 9015 FORMAT('IDEFSD = ',A4)
2536      CALL DPWRST('XXX','BUG ')
2537      WRITE(ICOUT,9020)NUMARG
2538 9020 FORMAT('NUMARG = ',I8)
2539      CALL DPWRST('XXX','BUG ')
2540      DO9025I=1,NUMARG
2541      WRITE(ICOUT,9026)IHARG(I)
2542 9026 FORMAT('IHARG(I) = ',A4)
2543      CALL DPWRST('XXX','BUG ')
2544 9025 CONTINUE
2545      WRITE(ICOUT,9030)ISPIDI(1)
2546 9030 FORMAT('ISPIDI(1) = ',A4)
2547      CALL DPWRST('XXX','BUG ')
2548      DO9035I=1,10
2549      WRITE(ICOUT,9036)I,ISPIDI(I)
2550 9036 FORMAT('I,ISPIDI(I) = ',I8,2X,A4)
2551      CALL DPWRST('XXX','BUG ')
2552 9035 CONTINUE
2553 9090 CONTINUE
2554C
2555      RETURN
2556      END
2557      SUBROUTINE DPSPE2(Y1,Y2,N,NCURVE,ICASPL,NUMLAG,MAXN,
2558     1                  COV11,COV22,COV12,COV21,
2559     1                  Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
2560C
2561C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
2562C              THAT WILL DEFINE
2563C              1) AUTOSPECTRUM
2564C              2) CO-SPECTRUM;
2565C              3) QUADRATURE SPECTRUM;
2566C              4) CROSS-SPECTRUM (CO-SPECTRUM AND CROSS-SPECTRUM);
2567C              5) COHERENCY DIAGRAM;
2568C              6) AMPLITUDE DIAGRAM;
2569C              7) PHASE DIAGRAM;
2570C              8) GAIN DIAGRAM;
2571C              9) ARGAND DIAGRAM.
2572C      NOTE--FOR THE AUTOSPECTRAL PLOT, IN ORDER THAT THE RESULTS OF
2573C            THE TIME SERIES ANALYSIS BE VALID AND PROPERLY INTERPRETED,
2574C            THE INPUT DATA IN Y1 SHOULD BE EQUI-SPACED IN TIME
2575C            (OR WHATEVER VARIABLE CORRESPONDS TO TIME).
2576C
2577C              THE HORIZONTAL AXIS OF THE SPECTRA PRODUCED
2578C              BY THIS SUBROUTINE IS FREQUENCY.
2579C              THIS FREQUENCY IS MEASURED IN UNITS OF
2580C              CYCLES PER 'DATA POINT' OR, MORE PRECISELY, IN
2581C              CYCLES PER UNIT TIME WHERE
2582C              'UNIT TIME' IS DEFINED AS THE
2583C              ELAPSED TIME BETWEEN ADJACENT OBSERVATIONS.
2584C              THE RANGE OF THE FREQUENCY AXIS IS 0.0 TO 0.5.
2585C
2586C     INPUT ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR OF
2587C                               (UNSORTED) OBSERVATIONS
2588C                               FOR THE FIRST  VARIABLE.
2589C                    --Y2     = THE SINGLE PRECISION VECTOR OF
2590C                               (UNSORTED) OBSERVATIONS.
2591C                               FOR THE SECOND VARIABLE.
2592C                      N      = THE INTEGER NUMBER OF OBSERVATIONS
2593C                               IN THE VECTOR X.
2594C     PRINTING--YES.
2595C     RESTRICTIONS--THE SAMPLE SIZE N MUST BE
2596C                   SMALLER THAN OR EQUAL TO 1000.
2597C                 --THE SAMPLE SIZE N MUST BE GREATER
2598C                   THAN OR EQUAL TO 3.
2599C     OTHER DATAPAC   SUBROUTINES NEEDED--PLOTC0, PLOTSP, AND CHSPPF.
2600C     FORTRAN LIBRARY SUBROUTINES NEEDED--SQRT.
2601C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
2602C     LANGUAGE--ANSI FORTRAN (1977)
2603C     COMMENT--THE 'FAST FOURIER TRANSFORM' IS NOT USED IN THIS VERSION,
2604C              BUT MAY BE IMPLEMENTED IN A FUTURE VEERSION.
2605C            --THE USUAL MAXIMUM NUMBER OF LAGS FOR WHICH THE
2606C              SPECTRUM IS COMPUTED IS N/4 WHERE N IS THE SAMPLE SIZE.
2607C              THIS RULE IS OVERRIDDEN IN LARGE DATA SETS AND IS
2608C              REPLACED BY THE RULE THAT THE MAXIMUM NUMBER OF
2609C              LAGS = 500.  IF MORE LAGS ARE DESIRED, CHANGE THE VALUE
2610C              OF THE VARIABLE     MAXLAG   WITHIN THIS SUBROUTINE
2611C              FROM 500 TO WHATEVER DESIRED, AND ALSO CHANGE THE
2612C              DIMENSION OF THE VECTOR R FROM ITS PRESENT 500 TO HOWEVER
2613C              MANY LAGS ARE DESIRED.
2614C            --IF THE INPUT OBSERVATIONS IN X ARE CONSIDERED
2615C              TO HAVE BEEN COLLECTED 1 SECOND APART IN TIME,
2616C              THEN THE FREQUENCY AXIS OF THE RESULTING
2617C              SPECTRA WOULD BE IN UNITS OF HERTZ
2618C              (= CYCLES PER SECOND).
2619C            --THE FREQUENCY OF 0.0 CORRESPONDS TO A CYCLE IN THE DATA
2620C              OF INFINITE (= 1/(0.0)) LENGTH OR PERIOD.
2621C              THE FREQUENCY OF 0.5 CORRESPONDS TO A CYCLE
2622C              IN THE DATA OF LENGTH = 1/(0.5) = 2 DATA POINTS.
2623C            --ANY EQUI-SPACED TIME SERIES ANALYSIS IS
2624C              INTRINSICALLY LIMITED TO DETECTING FREQUENCIES
2625C              NO LARGER THAN 0.5 CYCLES PER DATA POINT;
2626C              THIS CORRESPONDS TO THE FACT THAT THE
2627C              SMALLEST DETECTABLE CYCLE IN THE DATA
2628C              IS 2 DATA POINTS PER CYCLE.
2629C     REFERENCES--JENKINS AND WATTS, ESPECIALLY PAGE 290.
2630C     WRITTEN BY--JAMES J. FILLIBEN
2631C                 STATISTICAL ENGINEERING DIVISION
2632C                 INFORMATION TECHNOLOGY LABORATORY
2633C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2634C                 GAITHERSBURG, MD 20899-8980
2635C                 PHONE--301-975-2855
2636C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2637C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2638C     LANGUAGE--ANSI FORTRAN (1966)
2639C               EXCEPTION--HOLLERITH STRINGS IN FORMAT STATEMENTS
2640C                          DENOTED BY QUOTES RATHER THAN NH.
2641C     VERSION NUMBER--82/7
2642C     ORIGINAL VERSION--MAY       1978.
2643C     UPDATED         --JULY      1979.
2644C     UPDATED         --JANUARY   1981.
2645C     UPDATED         --NOVEMBER  1981.
2646C     UPDATED         --DECEMBER  1981.
2647C     UPDATED         --MARCH     1982.
2648C     UPDATED         --MAY       1982.
2649C     UPDATED         --JANUARY   1988. (SPECTRUM POINTS FROM 120 TO
2650C                                       N/2 TO 1000
2651C
2652C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2653C
2654      CHARACTER*4 ICASPL
2655      CHARACTER*4 IBUGG3
2656      CHARACTER*4 ISUBRO
2657      CHARACTER*4 IERROR
2658C
2659      CHARACTER*4 ISUBN1
2660      CHARACTER*4 ISUBN2
2661C
2662C---------------------------------------------------------------------
2663C
2664      DIMENSION Y1(*)
2665      DIMENSION Y2(*)
2666      DIMENSION Y(*)
2667      DIMENSION X(*)
2668      DIMENSION D(*)
2669C
2670      DIMENSION COV11(*)
2671      DIMENSION COV22(*)
2672      DIMENSION COV12(*)
2673      DIMENSION COV21(*)
2674C
2675C-----COMMON----------------------------------------------------------
2676C
2677      INCLUDE 'DPCOP2.INC'
2678C
2679C-----DATA STATEMENTS-------------------------------------------------
2680C
2681      DATA PI/3.14159265359/
2682C
2683C-----START POINT-----------------------------------------------------
2684C
2685      ISUBN1='DPSP'
2686      ISUBN2='E2  '
2687      IERROR='NO'
2688C
2689      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'SPE2')THEN
2690        WRITE(ICOUT,999)
2691        CALL DPWRST('XXX','BUG ')
2692        WRITE(ICOUT,70)
2693   70   FORMAT('***** AT THE BEGINNING OF DPSPE2--')
2694        CALL DPWRST('XXX','BUG ')
2695        WRITE(ICOUT,71)ICASPL,N,NUMLAG,MAXN
2696   71   FORMAT('ICASPL,N,NUMLAG,MAXN = ',A4,2X,3I8)
2697        CALL DPWRST('XXX','BUG ')
2698        DO73I=1,N
2699          WRITE(ICOUT,74)I,Y1(I),Y2(I)
2700   74     FORMAT('I, Y1(I), Y2(I) = ',I8,2G15.7)
2701          CALL DPWRST('XXX','BUG ')
2702   73   CONTINUE
2703      ENDIF
2704C
2705      KMAX=0
2706      Y2BAR=0.0
2707      VARBY2=0.0
2708      COVB12=0.0
2709      ALK=0.0
2710      QK=0.0
2711      AMPLIT=0.0
2712C
2713C               ********************************************
2714C               **  STEP 1--                              **
2715C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
2716C               ********************************************
2717C
2718      IF(N.LT.3)THEN
2719        WRITE(ICOUT,999)
2720  999   FORMAT(1X)
2721        CALL DPWRST('XXX','BUG ')
2722        WRITE(ICOUT,31)
2723   31   FORMAT('***** ERROR IN SPECTRAL PLOT--')
2724        CALL DPWRST('XXX','BUG ')
2725        WRITE(ICOUT,32)
2726   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
2727        CALL DPWRST('XXX','BUG ')
2728        WRITE(ICOUT,34)N
2729   34   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
2730        CALL DPWRST('XXX','BUG ')
2731        WRITE(ICOUT,999)
2732        CALL DPWRST('XXX','BUG ')
2733        IERROR='YES'
2734        GOTO9000
2735      ENDIF
2736C
2737      HOLD=Y1(1)
2738      DO60I=1,N
2739        IF(Y1(I).NE.HOLD)GOTO69
2740   60 CONTINUE
2741      WRITE(ICOUT,999)
2742      CALL DPWRST('XXX','BUG ')
2743      WRITE(ICOUT,31)
2744      CALL DPWRST('XXX','BUG ')
2745      WRITE(ICOUT,62)HOLD
2746   62 FORMAT('      ALL ELEMENTS IN Y1 ARE IDENTICALLY EQUAL TO ',G15.7)
2747      CALL DPWRST('XXX','BUG ')
2748      WRITE(ICOUT,999)
2749      CALL DPWRST('XXX','BUG ')
2750      IERROR='YES'
2751      GOTO9000
2752   69 CONTINUE
2753C
2754C
2755C               ************************************************
2756C               **  STEP 1--                                  **
2757C               **  COMPUTE THE SAMPLE MEAN, VARIANCE AND     **
2758C               **  SUM OF SQUARED DEVIATIONS.                **
2759C               ************************************************
2760C
2761      AN=N
2762      SUM=0.0
2763      DO100I=1,N
2764       SUM=SUM+Y1(I)
2765  100 CONTINUE
2766      Y1BAR=SUM/AN
2767      SUM=0.0
2768      DO200I=1,N
2769        SUM=SUM+(Y1(I)-Y1BAR)*(Y1(I)-Y1BAR)
2770  200 CONTINUE
2771      SSQY1=SUM
2772      VARBY1=SSQY1/AN
2773      VARY1=SSQY1/(AN-1.0)
2774      SDY1=0.0
2775      IF(VARY1.GT.0.0)SDY1=SQRT(VARY1)
2776C
2777      IF(IBUGG3.EQ.'ON')THEN
2778        WRITE(ICOUT,203)Y1BAR,SDY1
2779  203   FORMAT('SAMPLE 1: Y1BAR,SDY1 = ',2G15.7)
2780        CALL DPWRST('XXX','BUG ')
2781      ENDIF
2782C
2783      IF(ICASPL.NE.'AUSP' .AND. ICASPL.NE.'AUPE')THEN
2784        SUM=0.0
2785        DO110I=1,N
2786          SUM=SUM+Y2(I)
2787  110   CONTINUE
2788        Y2BAR=SUM/AN
2789        SUM=0.0
2790        DO210I=1,N
2791          SUM=SUM+(Y2(I)-Y2BAR)*(Y2(I)-Y2BAR)
2792  210   CONTINUE
2793        SSQY2=SUM
2794        VARBY2=SSQY2/AN
2795        VARY2=SSQY2/(AN-1.0)
2796        SDY2=0.0
2797        IF(VARY2.GT.0.0)SDY2=SQRT(VARY2)
2798C
2799        SUM=0.0
2800        DO220I=1,N
2801          SUM=SUM+(Y1(I)-Y1BAR)*(Y2(I)-Y2BAR)
2802  220   CONTINUE
2803        SSQ12=SUM
2804        COVB12=SSQ12/AN
2805        COVB21=COVB12
2806C
2807        IF(IBUGG3.EQ.'ON')THEN
2808          WRITE(ICOUT,223)Y2BAR,SDY2,COVB12,COVB21
2809  223     FORMAT('SAMPLE 2: Y2BAR,SDY2,COVB12,COVB21 = ',4G15.7)
2810          CALL DPWRST('XXX','BUG ')
2811        ENDIF
2812C
2813      ENDIF
2814C
2815C               *********************************************
2816C               **  STEP 3--                               **
2817C               **  IF NECESSARY, COMPUTE THE MAXIMUM LAG  **
2818C               *********************************************
2819C
2820      MAXLAG=MAXN
2821      IF(NUMLAG.GE.1)KMAX=NUMLAG
2822      IF(NUMLAG.LE.0)KMAX=N/4
2823      IF(NUMLAG.LE.0.AND.N.LE.32)KMAX=N/2
2824      IF(NUMLAG.LE.0.AND.N.LE.16)KMAX=N
2825      IF(KMAX.GT.MAXLAG)KMAX=MAXLAG
2826      NM1=N-1
2827      IF(KMAX.GT.NM1)KMAX=NM1
2828      KMAXM1=KMAX-1
2829      AKMAXM=KMAXM1
2830C
2831C               *****************************************************
2832C               **  STEP 3--                                       **
2833C               **  COMPUTE THE AUTOCORRELATIONS FOR THE Y1 DATA.  **
2834C               **  REFERENCE--JENKINS AND WATTS, PAGE 382 (9.3.1) **
2835C               **  IF NECESSRY,                                   **
2836C               **  COMPUTE THE AUTOCORRELATIONS FOR THE Y2 DATA.  **
2837C               **  REFERENCE--JENKINS AND WATTS, PAGE 382 (9.3.3) **
2838C               **  IF NECESSRY,                                   **
2839C               **  COMPUTE THE SAMPLE CROSS-CORRELATIONS          **
2840C               **  REFERENCE--JENKINS AND WATTS, PAGE 383 (9.3.5) **
2841C               *****************************************************
2842C
2843      COV110=VARBY1
2844      COV220=VARBY2
2845      COV120=COVB12
2846      COV210=COVB12
2847      DO340K=1,KMAXM1
2848        SUM11=0.0
2849        SUM22=0.0
2850        SUM12=0.0
2851        SUM21=0.0
2852        NMK=N-K
2853        DO350I=1,NMK
2854          J=I+K
2855          SUM11=SUM11+(Y1(I)-Y1BAR)*(Y1(J)-Y1BAR)
2856          IF(ICASPL.NE.'AUSP' .AND. ICASPL.NE.'AUPE')THEN
2857            SUM22=SUM22+(Y2(I)-Y2BAR)*(Y2(J)-Y2BAR)
2858            SUM12=SUM12+(Y1(I)-Y1BAR)*(Y2(J)-Y2BAR)
2859            SUM21=SUM21+(Y2(I)-Y2BAR)*(Y1(J)-Y1BAR)
2860          ENDIF
2861  350   CONTINUE
2862        COV11(K)=SUM11/AN
2863        IF(ICASPL.NE.'AUSP' .AND. ICASPL.NE.'AUPE')THEN
2864          COV22(K)=SUM22/AN
2865          COV12(K)=SUM12/AN
2866          COV21(K)=SUM21/AN
2867        ENDIF
2868  340 CONTINUE
2869C
2870C               **************************************
2871C               **  STEP 4--                        **
2872C               **  BRANCH TO THE APPROPRIATE CASE  **
2873C               **  AND DETERMINE PLOT COORDINATES  **
2874C               **************************************
2875C
2876C               ********************************************************
2877C               **  STEP 4.1--                                        **
2878C               **  COMPUTE AUTOSPECTRA FOR Y1                        **
2879C               **  REFERENCE--JENKINS AND WATTS--PAGES 382 AND 383   **
2880C               **             (9.3.2 AND 9)                          **
2881C               ********************************************************
2882C
2883      IMAX=(N/2)
2884      IF(IMAX.LT.120)IMAX=120
2885      IF(IMAX.GT.1000)IMAX=1000
2886      AIMAX=IMAX
2887      NUMFRE=IMAX+1
2888C
2889      IF(ICASPL.EQ.'AUSP')THEN
2890C
2891        J=0
2892        DO1110IP1=2,NUMFRE
2893          J=J+1
2894          I=IP1-1
2895          AI=I
2896          SUM11=0.0
2897C
2898          DO1120K=1,KMAXM1
2899            AK=K
2900            ARG1=PI*AK/AKMAXM
2901            ARG2=PI*AI*AK/AIMAX
2902            WK=0.5*(1.0+COS(ARG1))
2903            AFACT=WK*COS(ARG2)
2904            SUM11=SUM11+COV11(K)*AFACT
2905 1120     CONTINUE
2906C
2907          FREQJ=0.5*AI/AIMAX
2908          SP11J=2.0*(COV110+2.0*SUM11)
2909          IF(SP11J.LE.0.0)SP11J=0.000001
2910C
2911          Y(J+NPLOTP)=SP11J
2912          X(J+NPLOTP)=FREQJ
2913          D(J+NPLOTP)=REAL(NCURVE)
2914C
2915 1110   CONTINUE
2916        NPLOTP=NPLOTP+J
2917        NPLOTV=2
2918C
2919C               ******************************************************
2920C               **  STEP 4.1--                                      **
2921C               **  COMPUTE AUTOPERIODOGRAM FOR Y1                  **
2922C               **  REFERENCE--JUNKINS AND WATTS--PAGES 21 AND 22   **
2923C               **             (2.1.12)                             **
2924C               ******************************************************
2925C
2926      ELSEIF(ICASPL.EQ.'AUPE')THEN
2927        NHALF=N/2
2928        NHALFP=NHALF+1
2929        IMAX=NHALFP
2930        IF(NHALFP.GT.MAXN)IMAX=MAXN
2931        IEVODD=N-2*(N/2)
2932        DEL=(AN+1.0)/2.0
2933        IF(IEVODD.EQ.0)DEL=(AN+2.0)/2.0
2934C
2935        J=0
2936        DO1610IP1=2,IMAX
2937          J=J+1
2938          I=IP1-1
2939          AI=I
2940          FREQI=AI/AN
2941          SUMA=0.0
2942          SUMB=0.0
2943C
2944          DO1620K=1,N
2945            AK=K
2946            OMEGA=2.0*PI*(AI/AN)
2947            SUMA=SUMA+Y1(K)*COS(OMEGA*(AK-DEL))
2948            SUMB=SUMB+Y1(K)*SIN(OMEGA*(AK-DEL))
2949            Z=AK-DEL
2950 1620     CONTINUE
2951          AICOEF=SUMA/AN
2952          BICOEF=SUMB/AN
2953          RSQ=AICOEF*AICOEF+BICOEF*BICOEF
2954          POWERI=2.0*RSQ
2955          IF(I.EQ.0)POWERI=POWERI/2.0
2956          IF(I.EQ.NHALF.AND.IEVODD.EQ.0)POWERI=POWERI/2.0
2957C
2958          IF(IBUGG3.EQ.'ON')THEN
2959            WRITE(ICOUT,1621)J,I,AI,AICOEF,BICOEF,RSQ,POWERI
2960 1621       FORMAT('J,I,AI,AICOEF,BICOEF,RSQ,POWERI = ',2I8,5G15.7)
2961            CALL DPWRST('XXX','BUG ')
2962          ENDIF
2963C
2964          Y(NPLOTP+J)=POWERI
2965          X(NPLOTP+J)=FREQI
2966          D(NPLOTP+J)=REAL(NCURVE)
2967C
2968 1610   CONTINUE
2969        NPLOTP=NPLOTP+J
2970        NPLOTV=2
2971      ELSE
2972C
2973C               *******************************************************
2974C               **  COMPUTE COSPECTRUM AND QUADRATURE SPECTRUM.      **
2975C               **  REFERENCE--JENKINS AND WATTS--PAGE 383           **
2976C               **             (9.3.8,9.3.9, 9.3.10, 9.3.11)         **
2977C               **  REFERENCE--GRANGER AND HATANAKA, PAGE 77-79.     **
2978C               **  COMPUTE COHERENCY PLOT.                          **
2979C               **  COMPUTE AMPLITUDE PLOT.                          **
2980C               **  COMPUTE PHASE PLOT.                              **
2981C               **  COMPUTE GAIN PLOT.                               **
2982C               **  COMPUTE ARGAND PLOT.                             **
2983C               *******************************************************
2984C
2985        J=0
2986        JPF=0
2987        DO2010IP1=1,NUMFRE
2988          J=J+1
2989          I=IP1-1
2990          AI=I
2991          SUM11=0.0
2992          SUM22=0.0
2993          SUM12=0.0
2994          SUM21=0.0
2995          AL0=(COV120+COV210)/2.0
2996          Q0=(COV120-COV210)/2.0
2997C
2998          DO2020K=1,KMAXM1
2999            AK=K
3000            ARG1=PI*AK/AKMAXM
3001            ARG2=PI*AI*AK/AIMAX
3002            WK=0.5*(1.0+COS(ARG1))
3003            AFACTC=WK*COS(ARG2)
3004            AFACTS=WK*SIN(ARG2)
3005            SUM11=SUM11+COV11(K)*AFACTC
3006            SUM22=SUM22+COV22(K)*AFACTC
3007            ALK=(COV12(K)+COV21(K))/2.0
3008            QK=(COV12(K)-COV21(K))/2.0
3009            SUM12=SUM12+ALK*AFACTC
3010            SUM21=SUM21+QK*AFACTS
3011 2020     CONTINUE
3012C
3013          FREQJ=0.5*AI/AIMAX
3014          SP11J=2.0*(COV110+2.0*SUM11)
3015          SP22J=2.0*(COV220+2.0*SUM22)
3016          COSPJ=2.0*(AL0+2.0*SUM12)
3017          QUSPJ=2.0*(Q0+2.0*SUM21)
3018C
3019          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'SPE2')THEN
3020            WRITE(ICOUT,2121)IP1,ALK,QK,SP11J,SP22J,COSPJ,QUSPJ
3021 2121       FORMAT('IP1,ALK,QK,SP11J,SP22J,COSPJ,QUSPJ = ',I8,6F10.5)
3022            CALL DPWRST('XXX','BUG ')
3023          ENDIF
3024C
3025          IF(ICASPL.EQ.'COSP')THEN
3026            Y(NPLOTP+J)=COSPJ
3027            X(NPLOTP+J)=FREQJ
3028            D(NPLOTP+J)=REAL(NCURVE)
3029          ELSEIF(ICASPL.EQ.'QUSP')THEN
3030            Y(NPLOTP+J)=QUSPJ
3031            X(NPLOTP+J)=FREQJ
3032            D(NPLOTP+J)=REAL(NCURVE)
3033          ELSEIF(ICASPL.EQ.'CRSP')THEN
3034            Y(NPLOTP+J)=COSPJ
3035            X(NPLOTP+J)=FREQJ
3036            IVAL=(NCURVE-1)*2+1
3037            D(NPLOTP+J)=REAL(IVAL)
3038            JPF=J+NUMFRE
3039            Y(JPF)=QUSPJ
3040            X(JPF)=FREQJ
3041            D(JPF)=REAL(IVAL+1)
3042          ELSEIF(ICASPL.EQ.'COHE')THEN
3043            ARG=(COSPJ**2)+(QUSPJ**2)
3044            AMPLIT=0.0
3045            IF(ARG.GT.0.0)AMPLIT=SQRT(ARG)
3046            Y(NPLOTP+J)=AMPLIT*AMPLIT/(SP11J*SP22J)
3047            X(NPLOTP+J)=FREQJ
3048            D(NPLOTP+J)=REAL(NCURVE)
3049          ELSEIF(ICASPL.EQ.'AMPL')THEN
3050            ARG=(COSPJ**2)+(QUSPJ**2)
3051            Y(NPLOTP+J)=0.0
3052            IF(ARG.GT.0.0)Y(NPLOTP+J)=SQRT(ARG)
3053            X(NPLOTP+J)=FREQJ
3054            D(NPLOTP+J)=REAL(NCURVE)
3055          ELSEIF(ICASPL.EQ.'PHAS')THEN
3056            ARG=-QUSPJ/COSPJ
3057            Y(NPLOTP+J)=ATAN(ARG)
3058            X(NPLOTP+J)=FREQJ
3059            D(NPLOTP+J)=REAL(NCURVE)
3060          ELSEIF(ICASPL.EQ.'GAIN')THEN
3061            ARG=(COSPJ**2)+(QUSPJ**2)
3062            AMPLIT=0.0
3063            IF(ARG.GT.0.0)AMPLIT=SQRT(ARG)
3064            Y(NPLOTP+J)=AMPLIT/SP11J
3065            X(NPLOTP+J)=FREQJ
3066            D(NPLOTP+J)=REAL(NCURVE)
3067          ELSEIF(ICASPL.EQ.'ARGA')THEN
3068            Y(NPLOTP+J)=COSPJ/SP11J
3069            X(NPLOTP+J)=QUSPJ/SP22J
3070            D(NPLOTP+J)=REAL(NCURVE)
3071          ELSE
3072            WRITE(ICOUT,999)
3073            CALL DPWRST('XXX','BUG ')
3074            WRITE(ICOUT,31)
3075            CALL DPWRST('XXX','BUG ')
3076            WRITE(ICOUT,2312)
3077 2312       FORMAT('      AT BRANCH POINT 681--ICASPL NOT EQUAL TO')
3078            CALL DPWRST('XXX','BUG ')
3079            WRITE(ICOUT,2314)
3080 2314       FORMAT('      ONE OF THE ALLOWABLE 9--AUSP, COSP, QUSP,')
3081            CALL DPWRST('XXX','BUG ')
3082            WRITE(ICOUT,2315)
3083 2315       FORMAT('      CRSP, COHE, AMPL, PHAS, GAIN, ARGA.')
3084            CALL DPWRST('XXX','BUG ')
3085            WRITE(ICOUT,2316)ICASPL
3086 2316       FORMAT('      ICASPL = ',A4)
3087            CALL DPWRST('XXX','BUG ')
3088            IERROR='YES'
3089            GOTO9000
3090          ENDIF
3091C
3092 2010   CONTINUE
3093C
3094        NPLOTP=J
3095        IF(ICASPL.EQ.'CRSP')NPLOTP=JPF
3096        NPLOTV=2
3097        IF(ICASPL.EQ.'CRSP')NPLOTV=3
3098      ENDIF
3099C
3100C               ******************
3101C               **   STEP 90--  **
3102C               **   EXIT       **
3103C               ******************
3104C
3105 9000 CONTINUE
3106      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'SPE2')THEN
3107        WRITE(ICOUT,999)
3108        CALL DPWRST('XXX','BUG ')
3109        WRITE(ICOUT,9011)
3110 9011   FORMAT('***** AT THE END       OF DPSPE2--')
3111        CALL DPWRST('XXX','BUG ')
3112        WRITE(ICOUT,9012)ICASPL,IERROR,NPLOTP,NPLOTV
3113 9012   FORMAT('ICASPL,IERROR,NPLOTP,NPLOTV = ',2(A4,2X),2I8)
3114        CALL DPWRST('XXX','BUG ')
3115        DO9015I=1,NPLOTP
3116          WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
3117 9016     FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
3118          CALL DPWRST('XXX','BUG ')
3119 9015   CONTINUE
3120      ENDIF
3121C
3122      RETURN
3123      END
3124      SUBROUTINE DPSPEC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
3125     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
3126C
3127C     PURPOSE--FORM
3128C              1) AUTOSPECTRUM
3129C              2) CO-SPECTRUM;
3130C              3) QUADRATURE SPECTRUM;
3131C              4) CROSS-SPECTRUM (CO-SPECTRUM AND CROSS-SPECTRUM);
3132C              5) COHERENCY DIAGRAM;
3133C              6) AMPLITUDE DIAGRAM;
3134C              7) PHASE DIAGRAM;
3135C              8) GAIN DIAGRAM;
3136C              9) ARGAND DIAGRAM.
3137C             10) PERIODOGRAM
3138C     WRITTEN BY--JAMES J. FILLIBEN
3139C                 STATISTICAL ENGINEERING DIVISION
3140C                 INFORMATION TECHNOLOGY LABORATORY
3141C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3142C                 GAITHERSBURG, MD 20899-8980
3143C                 PHONE--301-975-2855
3144C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3145C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3146C     LANGUAGE--ANSI FORTRAN (1977)
3147C     VERSION NUMBER--82/7
3148C     ORIGINAL VERSION--MAY       1978.
3149C     UPDATED         --JUNE      1978.
3150C     UPDATED         --JULY      1979.
3151C     UPDATED         --JANUARY   1981.
3152C     UPDATED         --DECEMBER  1981.
3153C     UPDATED         --MAY       1982.
3154C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
3155C     UPDATED         --JANUARY   2012. USE DPPARS
3156C     UPDATED         --JANUARY   2012. SUPPORT FOR MULTIPLE AND
3157C                                       REPLICATION OPTIONS
3158C     UPDATED         --JANUARY   2012. ADD PERIODOGRAM HERE
3159C     UPDATED         --OCTOBER   2014. SPECTRAL PLOT AS SYNONYM FOR
3160C                                       SPECTRUM
3161C
3162C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3163C
3164      CHARACTER*4 ICASPL
3165      CHARACTER*4 IAND1
3166      CHARACTER*4 IAND2
3167      CHARACTER*4 IBUGG2
3168      CHARACTER*4 IBUGG3
3169      CHARACTER*4 IBUGQ
3170      CHARACTER*4 ISUBRO
3171      CHARACTER*4 IFOUND
3172      CHARACTER*4 IERROR
3173C
3174      CHARACTER*4 IHWUSE
3175      CHARACTER*4 MESSAG
3176      CHARACTER*4 IH
3177      CHARACTER*4 IH2
3178      CHARACTER*4 ISUBN1
3179      CHARACTER*4 ISUBN2
3180      CHARACTER*4 ISTEPN
3181      CHARACTER*4 IFOUN1
3182      CHARACTER*4 IFOUN2
3183      CHARACTER*4 CARG0
3184      CHARACTER*4 CARG1
3185      CHARACTER*4 CARG12
3186      CHARACTER*4 CARG2
3187      CHARACTER*4 CARG3
3188C
3189      CHARACTER*4 IREPL
3190      CHARACTER*4 IMULT
3191      CHARACTER*4 ICASE
3192      CHARACTER*40 INAME
3193      PARAMETER (MAXSPN=30)
3194      CHARACTER*4 IVARN1(MAXSPN)
3195      CHARACTER*4 IVARN2(MAXSPN)
3196      CHARACTER*4 IVARTY(MAXSPN)
3197      REAL PVAR(MAXSPN)
3198      INTEGER ILIS(MAXSPN)
3199      INTEGER NRIGHT(MAXSPN)
3200      INTEGER ICOLR(MAXSPN)
3201C
3202C---------------------------------------------------------------------
3203C
3204      INCLUDE 'DPCOPA.INC'
3205      INCLUDE 'DPCOZZ.INC'
3206C
3207      DIMENSION Y1(MAXOBV)
3208      DIMENSION Y2(MAXOBV)
3209      DIMENSION COV11(MAXOBV)
3210      DIMENSION COV22(MAXOBV)
3211      DIMENSION COV12(MAXOBV)
3212      DIMENSION COV21(MAXOBV)
3213      DIMENSION XIDTEM(MAXOBV)
3214      DIMENSION XIDTE2(MAXOBV)
3215      DIMENSION XIDTE3(MAXOBV)
3216      DIMENSION XTEMP1(MAXOBV)
3217      DIMENSION XTEMP2(MAXOBV)
3218      DIMENSION ZY1(MAXOBV)
3219      DIMENSION ZY2(MAXOBV)
3220      DIMENSION XDESGN(MAXOBV,2)
3221C
3222      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
3223      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
3224      EQUIVALENCE (GARBAG(IGARB3),COV11(1))
3225      EQUIVALENCE (GARBAG(IGARB4),COV22(1))
3226      EQUIVALENCE (GARBAG(IGARB5),COV12(1))
3227      EQUIVALENCE (GARBAG(IGARB6),COV21(1))
3228      EQUIVALENCE (GARBAG(IGARB7),XTEMP1(1))
3229      EQUIVALENCE (GARBAG(IGARB8),XTEMP2(1))
3230      EQUIVALENCE (GARBAG(IGARB9),XIDTEM(1))
3231      EQUIVALENCE (GARBAG(IGAR10),XIDTE2(1))
3232      EQUIVALENCE (GARBAG(JGAR11),XIDTE3(1))
3233      EQUIVALENCE (GARBAG(JGAR12),ZY1(1))
3234      EQUIVALENCE (GARBAG(JGAR13),ZY2(1))
3235      EQUIVALENCE (GARBAG(JGAR14),XDESGN(1,1))
3236C
3237C-----COMMON----------------------------------------------------------
3238C
3239      INCLUDE 'DPCOHK.INC'
3240      INCLUDE 'DPCODA.INC'
3241      INCLUDE 'DPCOP2.INC'
3242C
3243C-----START POINT-----------------------------------------------------
3244C
3245      IFOUND='NO'
3246      IERROR='NO'
3247      IMULT='OFF'
3248      IREPL='OFF'
3249      ISUBN1='DPSP'
3250      ISUBN2='EC  '
3251C
3252      MAXCP1=MAXCOL+1
3253      MAXCP2=MAXCOL+2
3254      MAXCP3=MAXCOL+3
3255      MAXCP4=MAXCOL+4
3256      MAXCP5=MAXCOL+5
3257      MAXCP6=MAXCOL+6
3258C
3259C               *********************************************************
3260C               **  TREAT THE FOLLOWING CASES--                         *
3261C               **        1) AUTOSPECTRUM                               *
3262C               **        2) CO-SPECTRUM;                               *
3263C               **        3) QUADRATURE SPECTRUM;                       *
3264C               **        4) CROSS-SPECTRUM (CO-SPECTRUM AND            *
3265C               **           CROSS-SPECTRUM);                           *
3266C               **        5) COHERENCY DIAGRAM;                         *
3267C               **        6) PHASE DIAGRAM;                             *
3268C               **        7) GAIN DIAGRAM;                              *
3269C               **        8) ARGAND DIAGRAM.                            *
3270C               *********************************************************
3271C
3272      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SPEC')THEN
3273        WRITE(ICOUT,999)
3274  999   FORMAT(1X)
3275        CALL DPWRST('XXX','BUG ')
3276        WRITE(ICOUT,51)
3277   51   FORMAT('***** AT THE BEGINNING OF DPSPEC--')
3278        CALL DPWRST('XXX','BUG ')
3279        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,MAXCOL
3280   52   FORMAT('ICASPL,IAND1,IAND2,MAXCOL = ',3(A4,2X),I8)
3281        CALL DPWRST('XXX','BUG ')
3282        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
3283   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
3284        CALL DPWRST('XXX','BUG ')
3285      ENDIF
3286C
3287C               ***************************
3288C               **  STEP 1--             **
3289C               **  EXTRACT THE COMMAND  **
3290C               ***************************
3291C
3292      ISTEPN='1'
3293      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')
3294     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3295C
3296C               ******************************************************
3297C               **  STEP 1--                                        **
3298C               **  EXTRACT THE COMMAND                             **
3299C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:         **
3300C               **    1) SPECTRAL PLOT Y                            **
3301C               **    2) MULTIPLE SPECTRAL PLOT Y1 ... YK           **
3302C               **    3) REPLICATED SPECTAL PLOT Y X1  X2           **
3303C               ******************************************************
3304C
3305C
3306      ISTEPN='1'
3307      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')
3308     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3309C
3310      ILASTC=-9999
3311      ISTOP=MIN(5,NUMARG-1)
3312      DO90I=1,NUMARG
3313        IF(IHARG(I).EQ.'PLOT' .OR. IHARG(1).EQ.'DIAG')THEN
3314          ISTOP=I
3315          GOTO99
3316        ELSEIF(IHARG(I).EQ.'SUBS' .AND. IHARG2(I).EQ.'ET  ')THEN
3317          ISTOP=I
3318          GOTO99
3319        ELSEIF(IHARG(I).EQ.'EXCE' .AND. IHARG2(I).EQ.'PT  ')THEN
3320          ISTOP=I
3321          GOTO99
3322        ELSEIF(IHARG(I).EQ.'FOR ')THEN
3323          ISTOP=I
3324          GOTO99
3325        ENDIF
3326   90 CONTINUE
3327   99 CONTINUE
3328C
3329      IFOUND='NO'
3330      DO100I=0,ISTOP
3331        IF(I.EQ.0)THEN
3332          CARG0='    '
3333          CARG1=ICOM
3334          CARG12=ICOM2
3335          CARG2=IHARG(I+1)
3336          CARG3=IHARG(I+2)
3337        ELSE
3338          IF(I.EQ.1)THEN
3339            CARG0=ICOM
3340          ELSE
3341            CARG0=IHARG(I-1)
3342          ENDIF
3343          CARG1=IHARG(I)
3344          CARG12=IHARG2(I)
3345          CARG2=IHARG(I+1)
3346          CARG3=IHARG(I+2)
3347        ENDIF
3348C
3349        IF(IHARG(I).EQ.'=')THEN
3350          IFOUND='NO'
3351          GOTO9000
3352        ELSEIF(CARG1.EQ.'AUTO' .AND. CARG2.EQ.'SPEC')THEN
3353          IFOUN1='YES'
3354          IFOUN2='YES'
3355          ILASTC=MAX(ILASTC,I+1)
3356          ICASPL='AUSP'
3357        ELSEIF(CARG1.EQ.'AUTO' .AND. CARG2.EQ.'PERI')THEN
3358          IFOUN1='YES'
3359          IFOUN2='YES'
3360          ILASTC=MAX(ILASTC,I+1)
3361          ICASPL='AUPE'
3362        ELSEIF(CARG1.EQ.'PERI')THEN
3363          IFOUN1='YES'
3364          IFOUN2='YES'
3365          ILASTC=MAX(ILASTC,I)
3366          ICASPL='AUPE'
3367        ELSEIF(CARG1.EQ.'AUTO')THEN
3368          IFOUN1='YES'
3369          IFOUN2='YES'
3370          ILASTC=MAX(ILASTC,I)
3371          ICASPL='AUSP'
3372        ELSEIF(CARG1.EQ.'CO  ' .AND. CARG2.EQ.'SPEC')THEN
3373          IFOUN1='YES'
3374          IFOUN2='YES'
3375          ILASTC=MAX(ILASTC,I+1)
3376          ICASPL='COSP'
3377        ELSEIF(CARG1.EQ.'COSP')THEN
3378          IFOUN1='YES'
3379          IFOUN2='YES'
3380          ILASTC=MAX(ILASTC,I)
3381          ICASPL='COSP'
3382        ELSEIF(CARG1.EQ.'QUAD' .AND. CARG2.EQ.'SPEC')THEN
3383          IFOUN1='YES'
3384          IFOUN2='YES'
3385          ILASTC=MAX(ILASTC,I+1)
3386          ICASPL='QUSP'
3387        ELSEIF(CARG1.EQ.'QUAD'.AND.CARG12.EQ.'RATU')THEN
3388          IFOUN1='YES'
3389          IFOUN2='YES'
3390          ILASTC=MAX(ILASTC,I)
3391          ICASPL='QUSP'
3392        ELSEIF(CARG1.EQ.'CROS' .AND. CARG2.EQ.'SPEC')THEN
3393          IFOUN1='YES'
3394          IFOUN2='YES'
3395          ILASTC=MAX(ILASTC,I+1)
3396          ICASPL='CRSP'
3397        ELSEIF(CARG1.EQ.'CROS' .AND. CARG12.EQ.'SSPE')THEN
3398          IFOUN1='YES'
3399          IFOUN2='YES'
3400          ILASTC=MAX(ILASTC,I)
3401          ICASPL='CRSP'
3402        ELSEIF(CARG1.EQ.'COHE' .AND. CARG2.EQ.'SPEC')THEN
3403          IFOUN1='YES'
3404          IFOUN2='YES'
3405          ILASTC=MAX(ILASTC,I+1)
3406          ICASPL='COHE'
3407        ELSEIF(CARG1.EQ.'COHE')THEN
3408          IFOUN1='YES'
3409          IFOUN2='YES'
3410          ILASTC=MAX(ILASTC,I)
3411          ICASPL='COHE'
3412        ELSEIF(CARG1.EQ.'AMPL' .AND. CARG2.EQ.'SPEC')THEN
3413          IFOUN1='YES'
3414          IFOUN2='YES'
3415          ILASTC=MAX(ILASTC,I+1)
3416          ICASPL='AMPL'
3417        ELSEIF(CARG1.EQ.'AMPL')THEN
3418          IFOUN1='YES'
3419          IFOUN2='YES'
3420          ILASTC=MAX(ILASTC,I)
3421          ICASPL='AMPL'
3422        ELSEIF(CARG1.EQ.'PHAS' .AND. CARG2.EQ.'SPEC')THEN
3423          IFOUN1='YES'
3424          IFOUN2='YES'
3425          ILASTC=MAX(ILASTC,I+1)
3426          ICASPL='PHAS'
3427        ELSEIF(CARG1.EQ.'PHAS')THEN
3428          IFOUN1='YES'
3429          IFOUN2='YES'
3430          ILASTC=MAX(ILASTC,I)
3431          ICASPL='PHAS'
3432        ELSEIF(CARG1.EQ.'GAIN' .AND. CARG2.EQ.'SPEC')THEN
3433          IFOUN1='YES'
3434          IFOUN2='YES'
3435          ILASTC=MAX(ILASTC,I+1)
3436          ICASPL='GAIN'
3437        ELSEIF(CARG1.EQ.'GAIN')THEN
3438          IFOUN1='YES'
3439          IFOUN2='YES'
3440          ILASTC=MAX(ILASTC,I)
3441          ICASPL='GAIN'
3442        ELSEIF(CARG1.EQ.'ARGA' .AND. CARG2.EQ.'SPEC')THEN
3443          IFOUN1='YES'
3444          IFOUN2='YES'
3445          ILASTC=MAX(ILASTC,I+1)
3446          ICASPL='ARGA'
3447        ELSEIF(CARG1.EQ.'ARGA')THEN
3448          IFOUN1='YES'
3449          IFOUN2='YES'
3450          ILASTC=MAX(ILASTC,I)
3451          ICASPL='ARGA'
3452        ELSEIF(CARG1.EQ.'SPEC' .AND. CARG0.NE.'CO  ' .AND.
3453     1         CARG0.NE.'QUAD' .AND. CARG0.NE.'CROS' .AND.
3454     1         CARG0.NE.'COHE' .AND. CARG0.NE.'AMPL' .AND.
3455     1         CARG0.NE.'PHAS' .AND. CARG0.NE.'GAIN' .AND.
3456     1         CARG0.NE.'ARGA')THEN
3457          IFOUN1='YES'
3458          IFOUN2='YES'
3459          ILASTC=MAX(ILASTC,I)
3460          ICASPL='AUSP'
3461        ELSEIF(CARG1.EQ.'PLOT' .OR. CARG1.EQ.'DIAG')THEN
3462          IFOUN2='YES'
3463          ILASTC=MAX(ILASTC,I)
3464        ELSEIF(CARG1.EQ.'REPL')THEN
3465          IREPL='ON'
3466        ELSEIF(CARG1.EQ.'MULT')THEN
3467          IMULT='ON'
3468        ENDIF
3469  100 CONTINUE
3470C
3471      IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')IFOUND='YES'
3472      IF(IFOUND.EQ.'NO')GOTO9000
3473C
3474      IF(IMULT.EQ.'ON')THEN
3475        IF(IREPL.EQ.'ON')THEN
3476          WRITE(ICOUT,999)
3477          CALL DPWRST('XXX','BUG ')
3478          WRITE(ICOUT,101)
3479  101     FORMAT('***** ERROR IN SPECTRAL/PERIODOGRAM PLOT--')
3480          CALL DPWRST('XXX','BUG ')
3481          WRITE(ICOUT,102)
3482  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
3483     1           '"REPLICATION" FOR THE SPECTRAL PLOT.')
3484          CALL DPWRST('XXX','BUG ')
3485          IERROR='YES'
3486          GOTO9000
3487        ENDIF
3488        IF(ICASPL.NE.'AUSP' .AND. ICASPL.NE.'AUPE')THEN
3489          WRITE(ICOUT,999)
3490          CALL DPWRST('XXX','BUG ')
3491          WRITE(ICOUT,101)
3492          CALL DPWRST('XXX','BUG ')
3493          WRITE(ICOUT,107)
3494  107     FORMAT('      THE "MULTIPLE" OPTION IS ONLY SUPPORTED FOR')
3495          CALL DPWRST('XXX','BUG ')
3496          WRITE(ICOUT,109)
3497  109     FORMAT('      AUTO SPECTRAL PLOT.')
3498          CALL DPWRST('XXX','BUG ')
3499          IERROR='YES'
3500          GOTO9000
3501        ENDIF
3502      ENDIF
3503C
3504      IF(ILASTC.GE.1)THEN
3505        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
3506        ILASTC=0
3507      ENDIF
3508C
3509      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SPEC')THEN
3510        WRITE(ICOUT,112)ICASPL,IMULT,IREPL
3511  112   FORMAT('ICASPL,IMULT,IREPL = ',2(A4,2X),A4)
3512        CALL DPWRST('XXX','BUG ')
3513      ENDIF
3514C
3515C               ****************************************
3516C               **  STEP 2--                          **
3517C               **  EXTRACT THE VARIABLE LIST         **
3518C               ****************************************
3519C
3520      ISTEPN='2'
3521      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')
3522     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3523C
3524      INAME='SPECTRAL PLOT'
3525      IF(ICASPL.EQ.'AUPE')INAME='PERIODOGRAM'
3526      MINNA=1
3527      MAXNA=100
3528      MINN2=1
3529      IFLAGE=1
3530      IF(IMULT.EQ.'ON')IFLAGE=0
3531      IFLAGM=1
3532      IFLAGP=0
3533      JMIN=1
3534      JMAX=NUMARG
3535      IF(ICASPL.EQ.'AUSP' .OR. ICASPL.EQ.'AUPE')THEN
3536        MINNVA=1
3537        MAXNVA=1
3538      ELSE
3539        MINNVA=2
3540        MAXNVA=2
3541      ENDIF
3542      IF(IREPL.EQ.'ON')THEN
3543        MINNVA=MINNVA+1
3544        MAXNVA=MAXNVA+2
3545      ELSEIF(IMULT.EQ.'ON')THEN
3546        MINNVA=1
3547        MAXNVA=MAXSPN
3548      ENDIF
3549C
3550      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
3551     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
3552     1            JMIN,JMAX,
3553     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
3554     1            IVARN1,IVARN2,IVARTY,PVAR,
3555     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
3556     1            MINNVA,MAXNVA,
3557     1            IFLAGM,IFLAGP,
3558     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
3559      IF(IERROR.EQ.'YES')GOTO9000
3560C
3561      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')THEN
3562        WRITE(ICOUT,999)
3563        CALL DPWRST('XXX','BUG ')
3564        WRITE(ICOUT,281)
3565  281   FORMAT('***** AFTER CALL DPPARS--')
3566        CALL DPWRST('XXX','BUG ')
3567        WRITE(ICOUT,282)NQ,NUMVAR
3568  282   FORMAT('NQ,NUMVAR = ',2I8)
3569        CALL DPWRST('XXX','BUG ')
3570        IF(NUMVAR.GT.0)THEN
3571          DO285I=1,NUMVAR
3572            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
3573     1                      ICOLR(I)
3574  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
3575     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
3576            CALL DPWRST('XXX','BUG ')
3577  285     CONTINUE
3578        ENDIF
3579      ENDIF
3580C
3581      NRESP=0
3582      NREPL=0
3583      IF(ICASPL.EQ.'AUSP' .OR. ICASPL.EQ.'AUPE')THEN
3584        IF(IREPL.EQ.'OFF' .AND. NUMVAR.GT.1)IMULT='ON'
3585      ENDIF
3586      IF(IMULT.EQ.'ON')THEN
3587        NRESP=NUMVAR
3588      ELSEIF(IREPL.EQ.'ON')THEN
3589        NRESP=1
3590        NREPL=NUMVAR-NRESP
3591        IF(NREPL.LT.1 .OR. NREPL.GT.2)THEN
3592          WRITE(ICOUT,999)
3593          CALL DPWRST('XXX','BUG ')
3594          WRITE(ICOUT,101)
3595          CALL DPWRST('XXX','BUG ')
3596          WRITE(ICOUT,511)
3597  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
3598     1           'REPLICATION VARIABLES')
3599          CALL DPWRST('XXX','BUG ')
3600          WRITE(ICOUT,512)
3601  512     FORMAT('      MUST BE BETWEEN 1 AND 2;  SUCH WAS NOT THE ',
3602     1           'CASE HERE.')
3603          CALL DPWRST('XXX','BUG ')
3604          WRITE(ICOUT,513)NREPL
3605  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
3606          CALL DPWRST('XXX','BUG ')
3607          IERROR='YES'
3608          GOTO9000
3609        ENDIF
3610      ELSE
3611        NRESP=1
3612      ENDIF
3613C
3614C               **********************************************************
3615C               **  STEP 3--                                            **
3616C               **  DETERMINE IF THE ANALYST HAS SPECIFIED THE NUMBER   **
3617C               **  OF LAGS DESIRED FOR THE CROSS-SPECTRAL ANALYSIS.    **
3618C               **  SEARCH FOR THE USER DEFINED PARAMETERS LAGS, LAG,   **
3619C               **  INTERNAL TABLE FOR THE PARAMETER NAMES              **
3620C               **  OR NUMLAG (WITH THE SEARCH CONDUCTED IN THAT ORDER  **
3621C               **  AND WITH THE FIRST FIND TERMINATING THE SEARCH.     **
3622C               **  IF FOUND, USE THE SPECIFIED VALUE (WHICH MUST BE    **
3623C               **  BETWEEN 1 AND 1000, INCLUSIVE);  IF NOT FOUUND, USE **
3624C               **  THE DEFAULT VALUE (USUALLY NS/4) WHICH WILL BE      **
3625C               **  DEFINED IN THE SUBROUTINE DPSPE2.                   **
3626C               **********************************************************
3627C
3628      ISTEPN='3'
3629      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')
3630     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3631C
3632      NUMLAG=0
3633      IF(ICASPL.EQ.'AUPE')GOTO390
3634C
3635      IH='LAGS'
3636      IH2='    '
3637      IHWUSE='P'
3638      MESSAG='NO'
3639      CALL CHECKN(IH,IH2,IHWUSE,
3640     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
3641     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
3642      IF(IERROR.EQ.'NO')THEN
3643        NUMLAG=INT(VALUE(ILOCV)+0.5)
3644        GOTO390
3645      ENDIF
3646C
3647      IH='LAG '
3648      IH2='    '
3649      IHWUSE='P'
3650      MESSAG='NO'
3651      CALL CHECKN(IH,IH2,IHWUSE,
3652     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
3653     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
3654      IF(IERROR.EQ.'NO')THEN
3655        NUMLAG=INT(VALUE(ILOCV)+0.5)
3656        GOTO390
3657      ENDIF
3658C
3659      IH='NUML'
3660      IH2='AG  '
3661      IHWUSE='P'
3662      MESSAG='NO'
3663      CALL CHECKN(IH,IH2,IHWUSE,
3664     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
3665     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
3666      IF(IERROR.EQ.'NO')NUMLAG=INT(VALUE(ILOCV)+0.5)
3667C
3668  390 CONTINUE
3669C
3670C               ********************************************
3671C               **  STEP 6--                              **
3672C               **  GENERATE THE SPECTRAL       PLOTS FOR **
3673C               **  THE VARIOUS CASES.                    **
3674C               ********************************************
3675C
3676      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')THEN
3677        ISTEPN='6'
3678        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3679        WRITE(ICOUT,601)NRESP,NREPL
3680  601   FORMAT('NRESP,NREPL = ',2I5)
3681        CALL DPWRST('XXX','BUG ')
3682      ENDIF
3683C
3684      IF(NREPL.EQ.0)THEN
3685        ISTEPN='8A'
3686        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')
3687     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3688C
3689C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
3690C
3691        NPLOTP=0
3692        DO810IRESP=1,NRESP
3693          NCURVE=IRESP
3694C
3695          IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')THEN
3696            WRITE(ICOUT,999)
3697            CALL DPWRST('XXX','BUG ')
3698            WRITE(ICOUT,811)IRESP,NCURVE
3699  811       FORMAT('IRESP,NCURVE = ',2I5)
3700            CALL DPWRST('XXX','BUG ')
3701          ENDIF
3702C
3703          ICOL=IRESP
3704          NUMVA2=2
3705          IF(ICASPL.EQ.'AUSP' .OR. ICASPL.EQ.'AUPE')NUMVA2=1
3706          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
3707     1                INAME,IVARN1,IVARN2,IVARTY,
3708     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
3709     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
3710     1                MAXCP4,MAXCP5,MAXCP6,
3711     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
3712     1                Y1,Y2,XTEMP2,NS,NS,NS,ICASE,
3713     1                IBUGG3,ISUBRO,IFOUND,IERROR)
3714          IF(IERROR.EQ.'YES')GOTO9000
3715C
3716C               *****************************************************
3717C               **  STEP 8B--                                      **
3718C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
3719C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
3720C               *****************************************************
3721C
3722          CALL DPSPE2(Y1,Y2,NS,NCURVE,ICASPL,NUMLAG,MAXN,
3723     1                COV11,COV22,COV12,COV21,
3724     1                Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
3725C
3726  810   CONTINUE
3727C
3728C               *****************************************************
3729C               **  STEP 9A--                                      **
3730C               **  CASE 3: ONE OR TWO  REPLICATION VARIABLES.     **
3731C               **          FOR THIS CASE, THE NUMBER OF RESPONSE  **
3732C               **          VARIABLES MUST BE EXACTLY 1.           **
3733C               *****************************************************
3734C
3735      ELSEIF(NREPL.GE.1)THEN
3736        ISTEPN='9A'
3737        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')
3738     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3739C
3740        J=0
3741        IMAX=NRIGHT(1)
3742        IF(NQ.LT.NRIGHT(1))IMAX=NQ
3743        DO910I=1,IMAX
3744          IF(ISUB(I).EQ.0)GOTO910
3745          J=J+1
3746C
3747C         RESPONSE VARIABLE IN Y1
3748C
3749          IJ=MAXN*(ICOLR(1)-1)+I
3750          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
3751          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
3752          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
3753          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
3754          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
3755          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
3756          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
3757          ICOLC=1
3758C
3759C         SECOND RESPONSE VARIABLE IN Y2
3760C
3761          IF(ICASPL.NE.'AUSP' .AND. ICASPL.NE.'AUPE')THEN
3762            IJ=MAXN*(ICOLR(2)-1)+I
3763            IF(ICOLR(2).LE.MAXCOL)Y2(J)=V(IJ)
3764            IF(ICOLR(2).EQ.MAXCP1)Y2(J)=PRED(I)
3765            IF(ICOLR(2).EQ.MAXCP2)Y2(J)=RES(I)
3766            IF(ICOLR(2).EQ.MAXCP3)Y2(J)=YPLOT(I)
3767            IF(ICOLR(2).EQ.MAXCP4)Y2(J)=XPLOT(I)
3768            IF(ICOLR(2).EQ.MAXCP5)Y2(J)=X2PLOT(I)
3769            IF(ICOLR(2).EQ.MAXCP6)Y2(J)=TAGPLO(I)
3770            ICOLC=2
3771          ENDIF
3772C
3773          DO920IR=1,MIN(NREPL,2)
3774            ICOLC=ICOLC+1
3775            ICOLT=ICOLR(ICOLC)
3776            IJ=MAXN*(ICOLT-1)+I
3777            IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
3778            IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
3779            IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
3780            IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
3781            IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
3782            IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
3783            IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
3784  920     CONTINUE
3785C
3786  910   CONTINUE
3787        NLOCAL=J
3788C
3789C       *****************************************************
3790C       **  STEP 9B--                                      **
3791C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
3792C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
3793C       **                                                 **
3794C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
3795C       **  VARIOUS REPLICATIONS.                          **
3796C       *****************************************************
3797C
3798        ISTEPN='9B'
3799        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPEC')THEN
3800          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3801          WRITE(ICOUT,999)
3802          CALL DPWRST('XXX','BUG ')
3803          WRITE(ICOUT,931)
3804  931     FORMAT('***** FROM THE MIDDLE  OF DPSPEC--')
3805          CALL DPWRST('XXX','BUG ')
3806          WRITE(ICOUT,932)ICASPL,NUMVAR,NLOCAL
3807  932     FORMAT('ICASPL,NUMVAR,NQ = ',A4,2I8)
3808          CALL DPWRST('XXX','BUG ')
3809          IF(NLOCAL.GE.1)THEN
3810            DO935I=1,NLOCAL
3811              WRITE(ICOUT,936)I,Y1(I),XDESGN(I,1),XDESGN(I,2)
3812  936         FORMAT('I,Y1(I),XDESGN(I,1),XDESGN(I,2) = ',I8,3F12.5)
3813              CALL DPWRST('XXX','BUG ')
3814  935       CONTINUE
3815          ENDIF
3816        ENDIF
3817C
3818C       *****************************************************
3819C       **  STEP 9C--                                      **
3820C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
3821C       **  REPLICATION VARIABLES.                         **
3822C       *****************************************************
3823C
3824        CALL DPFRE5(XDESGN(1,1),XDESGN(1,2),
3825     1             NREPL,NLOCAL,MAXOBV,
3826     1             XIDTEM,XIDTE2,
3827     1             XTEMP1,XTEMP2,
3828     1             NUMSE1,NUMSE2,
3829     1             IBUGG3,ISUBRO,IERROR)
3830C
3831C       *****************************************************
3832C       **  STEP 9D--                                      **
3833C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
3834C       *****************************************************
3835C
3836        NPLOTP=0
3837        NCURVE=0
3838        IF(NREPL.EQ.1)THEN
3839          J=0
3840          DO1110ISET1=1,NUMSE1
3841            K=0
3842            DO1130I=1,NLOCAL
3843              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
3844                K=K+1
3845                ZY1(K)=Y1(I)
3846                ZY2(K)=Y2(I)
3847              ENDIF
3848 1130       CONTINUE
3849            NTEMP=K
3850            NCURVE=NCURVE+1
3851            IF(NTEMP.GT.0)THEN
3852              CALL DPSPE2(ZY1,ZY2,NTEMP,NCURVE,ICASPL,NUMLAG,MAXN,
3853     1                    COV11,COV22,COV12,COV21,
3854     1                    Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
3855            ENDIF
3856 1110     CONTINUE
3857        ELSEIF(NREPL.EQ.2)THEN
3858          J=0
3859          NTOT=NUMSE1*NUMSE2
3860          DO1210ISET1=1,NUMSE1
3861          DO1220ISET2=1,NUMSE2
3862            K=0
3863            DO1290I=1,NLOCAL
3864              IF(
3865     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
3866     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
3867     1          )THEN
3868                K=K+1
3869                ZY1(K)=Y1(I)
3870                ZY2(K)=Y2(I)
3871              ENDIF
3872 1290       CONTINUE
3873            NTEMP=K
3874            NCURVE=NCURVE+1
3875            IF(NTEMP.GT.0)THEN
3876              CALL DPSPE2(ZY1,ZY2,NTEMP,NCURVE,ICASPL,NUMLAG,MAXN,
3877     1                    COV11,COV22,COV12,COV21,
3878     1                    Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
3879            ENDIF
3880 1220     CONTINUE
3881 1210     CONTINUE
3882        ENDIF
3883      ENDIF
3884C
3885C               *****************
3886C               **  STEP 90--  **
3887C               **  EXIT       **
3888C               *****************
3889C
3890 9000 CONTINUE
3891      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SPEC')THEN
3892        WRITE(ICOUT,999)
3893        CALL DPWRST('XXX','BUG ')
3894        WRITE(ICOUT,9011)
3895 9011   FORMAT('***** AT THE END       OF DPSPEC--')
3896        CALL DPWRST('XXX','BUG ')
3897        WRITE(ICOUT,9012)IFOUND,IERROR,NUMLAG,MAXN
3898 9012   FORMAT('IFOUND,IERROR,NUMLAG,MAXN = ',2(A4,2X),2I8)
3899        CALL DPWRST('XXX','BUG ')
3900        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
3901 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
3902        CALL DPWRST('XXX','BUG ')
3903        IF(NPLOTP.GE.1)THEN
3904          DO9015I=1,NPLOTP
3905            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
3906 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
3907            CALL DPWRST('XXX','BUG ')
3908 9015     CONTINUE
3909        ENDIF
3910      ENDIF
3911C
3912      RETURN
3913      END
3914      SUBROUTINE DPSPL(IBUGA2,IBUGA3,IBUGQ,ISUBRO,
3915     1                 ICASAN,ICAPSW,IFORSW,
3916     1                 IFOUND,IERROR)
3917C
3918C     PURPOSE--CARRY OUT A SPLINE FIT (ANY DEGREE FROM 1 TO 10).
3919C     NOTE--FOR A GIVEN DEGREE, ALL LOW-ORDER DERIVATIVES WILL BE SET
3920C           SO THAT THE FUNCTION WILL BE SMOOTH AT THE KNOTS.
3921C     WRITTEN BY--JAMES J. FILLIBEN
3922C                 STATISTICAL ENGINEERING DIVISION
3923C                 INFORMATION TECHNOLOGY LABORATORY
3924C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3925C                 GAITHERSBURG, MD 20899-8980
3926C                 PHONE--301-975-2855
3927C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3928C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3929C     LANGUAGE--ANSI FORTRAN (1977)
3930C     VERSION NUMBER--82/7
3931C     ORIGINAL VERSION--DECEMBER  1978.
3932C     UPDATED         --JUNE      1978.
3933C     UPDATED         --JULY      1978.
3934C     UPDATED         --OCTOBER   1978.
3935C     UPDATED         --NOVEMBER  1978.
3936C     UPDATED         --MARCH     1981.
3937C     UPDATED         --JULY      1981.
3938C     UPDATED         --AUGUST    1981.
3939C     UPDATED         --SEPTEMBER 1981.
3940C     UPDATED         --NOVEMBER  1981.
3941C     UPDATED         --MARCH     1982.
3942C     UPDATED         --MAY       1982.
3943C     UPDATED         --MARCH     1988. ADD LOFCDF
3944C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE
3945C                                       COMMON
3946C                                       MOVE SOME DIMENSIONS TO DPSPL
3947C     UPDATED         --MAY       2009. REPLACE USE OF DPSWAP WITH
3948C                                       BUILT-IN SWAP SPACE
3949C     UPDATED         --JULY      2019. TWEAK STORAGE SPACE
3950C
3951C
3952C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3953C
3954      CHARACTER*4 ICASAN
3955      CHARACTER*4 ICAPSW
3956      CHARACTER*4 IFORSW
3957      CHARACTER*4 IBUGA2
3958      CHARACTER*4 IBUGA3
3959      CHARACTER*4 IBUGQ
3960      CHARACTER*4 ISUBRO
3961      CHARACTER*4 IFOUND
3962      CHARACTER*4 IERROR
3963C
3964      CHARACTER*4 ICASSF
3965      CHARACTER*4 IHWUSE
3966      CHARACTER*4 MESSAG
3967      CHARACTER*4 IH
3968      CHARACTER*4 IH2
3969      CHARACTER*4 IREPU
3970      CHARACTER*4 IRESU
3971      CHARACTER*4 IBUGJU
3972      CHARACTER*4 ISUBN1
3973      CHARACTER*4 ISUBN2
3974      CHARACTER*4 ISTEPN
3975C
3976      CHARACTER*4 ICASE
3977      CHARACTER*40 INAME
3978      PARAMETER (MAXSPN=10)
3979      CHARACTER*4 IVARN1(MAXSPN)
3980      CHARACTER*4 IVARN2(MAXSPN)
3981      CHARACTER*4 IVARTY(MAXSPN)
3982      REAL PVAR(MAXSPN)
3983      INTEGER ILIS(MAXSPN)
3984      INTEGER NRIGHT(MAXSPN)
3985      INTEGER ICOLR(MAXSPN)
3986C
3987C---------------------------------------------------------------------
3988C
3989      INCLUDE 'DPCOPA.INC'
3990      INCLUDE 'DPCOZZ.INC'
3991C
3992      DIMENSION B(100)
3993      DIMENSION SDB(100)
3994      DIMENSION B2(100)
3995      DIMENSION SDB2(100)
3996      DIMENSION BTEMP(100)
3997      DIMENSION EKNOT(200)
3998      DIMENSION XPY(50)
3999      DIMENSION RIGHT(50)
4000      DIMENSION XPX(50,50)
4001      DIMENSION SSQ(50,50)
4002      DIMENSION A(50,50)
4003C
4004      DIMENSION PRED2(MAXOBV)
4005      DIMENSION RES2(MAXOBV)
4006      DIMENSION XKNOT(MAXOBV)
4007      DIMENSION W(MAXOBV)
4008      DIMENSION VSCRT(10*MAXOBV)
4009      DIMENSION V1(MAXOBV)
4010      DIMENSION V2(MAXOBV)
4011      DIMENSION DUM1(MAXOBV)
4012      DIMENSION DUM2(MAXOBV)
4013      DIMENSION AJUNK(MAXOBV)
4014C
4015      EQUIVALENCE (XKNOT(1),X3D(1))
4016      EQUIVALENCE (W(1),D(1))
4017      EQUIVALENCE (GARBAG(IGARB1),PRED2(1))
4018      EQUIVALENCE (GARBAG(IGARB2),RES2(1))
4019      EQUIVALENCE (GARBAG(IGARB3),V1(1))
4020      EQUIVALENCE (GARBAG(IGARB4),V2(1))
4021      EQUIVALENCE (GARBAG(IGARB5),DUM1(1))
4022      EQUIVALENCE (GARBAG(IGARB6),DUM2(1))
4023      EQUIVALENCE (GARBAG(IGARB7),AJUNK(1))
4024      EQUIVALENCE (GARBAG(IGARB8),SDB(1))
4025      EQUIVALENCE (GARBAG(IGARB8+100),SDB2(1))
4026      EQUIVALENCE (GARBAG(IGARB8+200),B(1))
4027      EQUIVALENCE (GARBAG(IGARB8+300),B2(1))
4028      EQUIVALENCE (GARBAG(IGARB8+400),XPY(1))
4029      EQUIVALENCE (GARBAG(IGARB8+500),RIGHT(1))
4030      EQUIVALENCE (GARBAG(IGARB8+600),BTEMP(1))
4031      EQUIVALENCE (GARBAG(IGARB8+700),EKNOT(1))
4032      EQUIVALENCE (GARBAG(IGARB9),XPX(1,1))
4033      EQUIVALENCE (GARBAG(IGARB9+5000),SSQ(1,1))
4034      EQUIVALENCE (GARBAG(IGARB9+10000),A(1,1))
4035      EQUIVALENCE (GARBAG(IGAR10),VSCRT(1))
4036C
4037C-----COMMON----------------------------------------------------------
4038C
4039      INCLUDE 'DPCOMC.INC'
4040      INCLUDE 'DPCOHK.INC'
4041      INCLUDE 'DPCOSU.INC'
4042      INCLUDE 'DPCODA.INC'
4043      INCLUDE 'DPCOST.INC'
4044      INCLUDE 'DPCOP2.INC'
4045C
4046C-----START POINT-----------------------------------------------------
4047C
4048      ISUBN1='DPSP'
4049      ISUBN2='L   '
4050      IERROR='NO'
4051C
4052      MAXCP1=MAXCOL+1
4053      MAXCP2=MAXCOL+2
4054      MAXCP3=MAXCOL+3
4055      MAXCP4=MAXCOL+4
4056      MAXCP5=MAXCOL+5
4057      MAXCP6=MAXCOL+6
4058C
4059C               *********************************
4060C               **  TREAT THE SPLINE FIT CASE  **
4061C               *********************************
4062C
4063      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PSPL')THEN
4064        WRITE(ICOUT,999)
4065  999   FORMAT(1X)
4066        CALL DPWRST('XXX','BUG ')
4067        WRITE(ICOUT,51)
4068   51   FORMAT('***** AT THE BEGINNING OF DPSPL--')
4069        CALL DPWRST('XXX','BUG ')
4070        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ,ISUBRO,ICASAN
4071   53   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO,ICASAN = ',4(A4,2X),A4)
4072        CALL DPWRST('XXX','BUG ')
4073      ENDIF
4074C
4075C               ***************************
4076C               **  STEP 1--             **
4077C               **  EXTRACT THE COMMAND  **
4078C               ***************************
4079C
4080      ISTEPN='1'
4081      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PSPL')
4082     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4083C
4084C               *********************************
4085C               **  STEP 1.1--                 **
4086C               **  SEARCH FOR SPLINE FIT      **
4087C               **  (WITH UNSPECIFIED DEGREE)  **
4088C               *********************************
4089C
4090C
4091      IF(ICOM.EQ.'SPLI'.AND.NUMARG.GE.1.AND.IHARG(1).EQ.'FIT')THEN
4092        ICASSF='SF'
4093        ILASTC=1
4094C
4095C               *********************************************
4096C               **  STEP 1.21--                            **
4097C               **  SEARCH FOR 1-ST DEGREE SPLINE FITTING  **
4098C               *********************************************
4099C
4100      ELSEIF(NUMARG.GE.4.AND.
4101     1       ICOM.EQ.'1'.AND.IHARG(1).EQ.'ST'.AND.
4102     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4103     1       IHARG(4).EQ.'FIT')THEN
4104        ICASSF='1SF'
4105        ILASTC=4
4106      ELSEIF(NUMARG.GE.3.AND.
4107     1      (ICOM.EQ.'1ST' .OR. ICOM.EQ.'FIRS' .OR. ICOM.EQ.'1' .OR.
4108     1       ICOM.EQ.'ONE').AND.
4109     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4110     1       IHARG(3).EQ.'FIT')THEN
4111        ICASSF='1SF'
4112        ILASTC=3
4113      ELSEIF(NUMARG.GE.3.AND.
4114     1       ICOM.EQ.'DEGR'.AND.
4115     1       (IHARG(1).EQ.'1' .OR. IHARG(1).EQ.'ONE').AND.
4116     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4117        ICASSF='1SF'
4118        ILASTC=3
4119      ELSEIF(NUMARG.GE.2.AND.
4120     1       ICOM.EQ.'LINE'.AND.IHARG(1).EQ.'SPLI'.AND.
4121     1       IHARG(2).EQ.'FIT')THEN
4122        ICASSF='1SF'
4123        ILASTC=2
4124C
4125C               *********************************************
4126C               **  STEP 1.22--                            **
4127C               **  SEARCH FOR 2-ND DEGREE SPLINE FITTING  **
4128C               *********************************************
4129C
4130      ELSEIF(NUMARG.GE.4.AND.
4131     1       ICOM.EQ.'2'.AND.IHARG(1).EQ.'ND'.AND.
4132     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4133     1       IHARG(4).EQ.'FIT')THEN
4134        ICASSF='2SF'
4135        ILASTC=4
4136      ELSEIF(NUMARG.GE.3.AND.
4137     1      (ICOM.EQ.'2ND' .OR. ICOM.EQ.'SECO' .OR. ICOM.EQ.'2' .OR.
4138     1       ICOM.EQ.'TWO').AND.
4139     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4140     1       IHARG(3).EQ.'FIT')THEN
4141        ICASSF='2SF'
4142        ILASTC=3
4143      ELSEIF(NUMARG.GE.3.AND.
4144     1       ICOM.EQ.'DEGR'.AND.
4145     1       (IHARG(1).EQ.'2' .OR. IHARG(1).EQ.'SECO').AND.
4146     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4147        ICASSF='2SF'
4148        ILASTC=3
4149      ELSEIF(NUMARG.GE.2.AND.
4150     1       ICOM.EQ.'QUAD'.AND.IHARG(1).EQ.'SPLI'.AND.
4151     1       IHARG(2).EQ.'FIT')THEN
4152        ICASSF='2SF'
4153        ILASTC=2
4154C
4155C               *********************************************
4156C               **  STEP 1.23--                            **
4157C               **  SEARCH FOR 3-RD DEGREE SPLINE FITTING  **
4158C               *********************************************
4159C
4160C
4161      ELSEIF(NUMARG.GE.4.AND.
4162     1       ICOM.EQ.'3'.AND.IHARG(1).EQ.'RD'.AND.
4163     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4164     1       IHARG(4).EQ.'FIT')THEN
4165        ICASSF='3SF'
4166        ILASTC=4
4167      ELSEIF(NUMARG.GE.3.AND.
4168     1      (ICOM.EQ.'3RD' .OR. ICOM.EQ.'THIR' .OR. ICOM.EQ.'3' .OR.
4169     1       ICOM.EQ.'THRE').AND.
4170     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4171     1       IHARG(3).EQ.'FIT')THEN
4172        ICASSF='3SF'
4173        ILASTC=3
4174      ELSEIF(NUMARG.GE.3.AND.
4175     1       ICOM.EQ.'DEGR'.AND.
4176     1       (IHARG(1).EQ.'3' .OR. IHARG(1).EQ.'THIR').AND.
4177     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4178        ICASSF='3SF'
4179        ILASTC=3
4180      ELSEIF(NUMARG.GE.2.AND.
4181     1       ICOM.EQ.'CUBI'.AND.IHARG(1).EQ.'SPLI'.AND.
4182     1       IHARG(2).EQ.'FIT')THEN
4183        ICASSF='3SF'
4184        ILASTC=2
4185C
4186C               *********************************************
4187C               **  STEP 1.24--                            **
4188C               **  SEARCH FOR 4-TH DEGREE SPLINE FITTING  **
4189C               *********************************************
4190C
4191      ELSEIF(NUMARG.GE.4.AND.
4192     1       ICOM.EQ.'4'.AND.IHARG(1).EQ.'TH'.AND.
4193     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4194     1       IHARG(4).EQ.'FIT')THEN
4195        ICASSF='4SF'
4196        ILASTC=4
4197      ELSEIF(NUMARG.GE.3.AND.
4198     1      (ICOM.EQ.'4TH' .OR. ICOM.EQ.'FOUR' .OR. ICOM.EQ.'4').AND.
4199     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4200     1       IHARG(3).EQ.'FIT')THEN
4201        ICASSF='4SF'
4202        ILASTC=3
4203      ELSEIF(NUMARG.GE.3.AND.
4204     1       ICOM.EQ.'DEGR'.AND.
4205     1       (IHARG(1).EQ.'4' .OR. IHARG(1).EQ.'FOUR').AND.
4206     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4207        ICASSF='4SF'
4208        ILASTC=3
4209      ELSEIF(NUMARG.GE.2.AND.
4210     1       ICOM.EQ.'QUAR'.AND.IHARG(1).EQ.'SPLI'.AND.
4211     1       IHARG(2).EQ.'FIT')THEN
4212        ICASSF='4SF'
4213        ILASTC=2
4214C
4215C               *********************************************
4216C               **  STEP 1.25--                            **
4217C               **  SEARCH FOR 5-TH DEGREE SPLINE FITTING  **
4218C               *********************************************
4219C
4220      ELSEIF(NUMARG.GE.4.AND.
4221     1       ICOM.EQ.'5'.AND.IHARG(1).EQ.'TH'.AND.
4222     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4223     1       IHARG(4).EQ.'FIT')THEN
4224        ICASSF='5SF'
4225        ILASTC=4
4226      ELSEIF(NUMARG.GE.3.AND.
4227     1      (ICOM.EQ.'5TH' .OR. ICOM.EQ.'FIVE' .OR. ICOM.EQ.'5').AND.
4228     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4229     1       IHARG(3).EQ.'FIT')THEN
4230        ICASSF='5SF'
4231        ILASTC=3
4232      ELSEIF(NUMARG.GE.3.AND.
4233     1       ICOM.EQ.'DEGR'.AND.
4234     1       (IHARG(1).EQ.'5' .OR. IHARG(1).EQ.'FIVE').AND.
4235     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4236        ICASSF='5SF'
4237        ILASTC=3
4238      ELSEIF(NUMARG.GE.2.AND.
4239     1       ICOM.EQ.'QUIN'.AND.IHARG(1).EQ.'SPLI'.AND.
4240     1       IHARG(2).EQ.'FIT')THEN
4241        ICASSF='5SF'
4242        ILASTC=2
4243C
4244C               *********************************************
4245C               **  STEP 1.26--                            **
4246C               **  SEARCH FOR 6-TH DEGREE SPLINE FITTING  **
4247C               *********************************************
4248C
4249      ELSEIF(NUMARG.GE.4.AND.
4250     1       ICOM.EQ.'6'.AND.IHARG(1).EQ.'TH'.AND.
4251     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4252     1       IHARG(4).EQ.'FIT')THEN
4253        ICASSF='6SF'
4254        ILASTC=4
4255      ELSEIF(NUMARG.GE.3.AND.
4256     1      (ICOM.EQ.'6TH' .OR. ICOM.EQ.'SIX ' .OR. ICOM.EQ.'6').AND.
4257     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4258     1       IHARG(3).EQ.'FIT')THEN
4259        ICASSF='6SF'
4260        ILASTC=3
4261      ELSEIF(NUMARG.GE.3.AND.
4262     1       ICOM.EQ.'DEGR'.AND.
4263     1       (IHARG(1).EQ.'6' .OR. IHARG(1).EQ.'SIX').AND.
4264     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4265        ICASSF='6SF'
4266        ILASTC=3
4267      ELSEIF(NUMARG.GE.2.AND.
4268     1       ICOM.EQ.'SEXT'.AND.IHARG(1).EQ.'SPLI'.AND.
4269     1       IHARG(2).EQ.'FIT')THEN
4270        ICASSF='6SF'
4271        ILASTC=2
4272C
4273C               *********************************************
4274C               **  STEP 1.27--                            **
4275C               **  SEARCH FOR 7-TH DEGREE SPLINE FITTING  **
4276C               *********************************************
4277C
4278      ELSEIF(NUMARG.GE.4.AND.
4279     1       ICOM.EQ.'7'.AND.IHARG(1).EQ.'TH'.AND.
4280     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4281     1       IHARG(4).EQ.'FIT')THEN
4282        ICASSF='7SF'
4283        ILASTC=4
4284      ELSEIF(NUMARG.GE.3.AND.
4285     1      (ICOM.EQ.'7TH' .OR. ICOM.EQ.'SEVE' .OR. ICOM.EQ.'7').AND.
4286     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4287     1       IHARG(3).EQ.'FIT')THEN
4288        ICASSF='7SF'
4289        ILASTC=3
4290      ELSEIF(NUMARG.GE.3.AND.
4291     1       ICOM.EQ.'DEGR'.AND.
4292     1       (IHARG(1).EQ.'7' .OR. IHARG(1).EQ.'SEVE').AND.
4293     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4294        ICASSF='7SF'
4295        ILASTC=3
4296      ELSEIF(NUMARG.GE.2.AND.
4297     1       ICOM.EQ.'SEPT'.AND.IHARG(1).EQ.'SPLI'.AND.
4298     1       IHARG(2).EQ.'FIT')THEN
4299        ICASSF='7SF'
4300        ILASTC=2
4301C
4302C               *********************************************
4303C               **  STEP 1.28--                            **
4304C               **  SEARCH FOR 8-TH DEGREE SPLINE FITTING  **
4305C               *********************************************
4306C
4307      ELSEIF(NUMARG.GE.4.AND.
4308     1       ICOM.EQ.'8'.AND.IHARG(1).EQ.'TH'.AND.
4309     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4310     1       IHARG(4).EQ.'FIT')THEN
4311        ICASSF='8SF'
4312        ILASTC=4
4313      ELSEIF(NUMARG.GE.3.AND.
4314     1      (ICOM.EQ.'8TH' .OR. ICOM.EQ.'EIGH' .OR. ICOM.EQ.'8').AND.
4315     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4316     1       IHARG(3).EQ.'FIT')THEN
4317        ICASSF='8SF'
4318        ILASTC=3
4319      ELSEIF(NUMARG.GE.3.AND.
4320     1       ICOM.EQ.'DEGR'.AND.
4321     1       (IHARG(1).EQ.'8' .OR. IHARG(1).EQ.'EIGH').AND.
4322     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4323        ICASSF='8SF'
4324        ILASTC=3
4325      ELSEIF(NUMARG.GE.2.AND.
4326     1       ICOM.EQ.'OCTI'.AND.IHARG(1).EQ.'SPLI'.AND.
4327     1       IHARG(2).EQ.'FIT')THEN
4328        ICASSF='8SF'
4329        ILASTC=2
4330C
4331C               *********************************************
4332C               **  STEP 1.29--                            **
4333C               **  SEARCH FOR 9-TH DEGREE SPLINE FITTING  **
4334C               *********************************************
4335C
4336      ELSEIF(NUMARG.GE.4.AND.
4337     1       ICOM.EQ.'9'.AND.IHARG(1).EQ.'TH'.AND.
4338     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4339     1       IHARG(4).EQ.'FIT')THEN
4340        ICASSF='9SF'
4341        ILASTC=4
4342      ELSEIF(NUMARG.GE.3.AND.
4343     1      (ICOM.EQ.'9TH' .OR. ICOM.EQ.'NINE' .OR. ICOM.EQ.'9' .OR.
4344     1       ICOM.EQ.'NINT').AND.
4345     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4346     1       IHARG(3).EQ.'FIT')THEN
4347        ICASSF='9SF'
4348        ILASTC=3
4349      ELSEIF(NUMARG.GE.3.AND.
4350     1       ICOM.EQ.'DEGR'.AND.
4351     1       (IHARG(1).EQ.'9' .OR. IHARG(1).EQ.'NINE').AND.
4352     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4353        ICASSF='9SF'
4354        ILASTC=3
4355      ELSEIF(NUMARG.GE.2.AND.
4356     1       ICOM.EQ.'NONI'.AND.IHARG(1).EQ.'SPLI'.AND.
4357     1       IHARG(2).EQ.'FIT')THEN
4358        ICASSF='9SF'
4359        ILASTC=2
4360C
4361C               *********************************************
4362C               **  STEP 1.30--                            **
4363C               **  SEARCH FOR 10-TH DEGREE SPLINE FITTING **
4364C               *********************************************
4365C
4366      ELSEIF(NUMARG.GE.4.AND.
4367     1       ICOM.EQ.'10'.AND.IHARG(1).EQ.'TH'.AND.
4368     1       IHARG(2).EQ.'DEGR'.AND.IHARG(3).EQ.'SPLI'.AND.
4369     1       IHARG(4).EQ.'FIT')THEN
4370        ICASSF='10SF'
4371        ILASTC=4
4372      ELSEIF(NUMARG.GE.3.AND.
4373     1      (ICOM.EQ.'10TH' .OR. ICOM.EQ.'TENT' .OR. ICOM.EQ.'10') .AND.
4374     1       IHARG(1).EQ.'DEGR'.AND.IHARG(2).EQ.'SPLI'.AND.
4375     1       IHARG(3).EQ.'FIT')THEN
4376        ICASSF='10SF'
4377        ILASTC=3
4378      ELSEIF(NUMARG.GE.3.AND.
4379     1       ICOM.EQ.'DEGR'.AND.
4380     1       (IHARG(1).EQ.'10' .OR. IHARG(1).EQ.'TEN ').AND.
4381     1       IHARG(2).EQ.'SPLI'.AND.IHARG(3).EQ.'FIT')THEN
4382        ICASSF='10SF'
4383        ILASTC=3
4384      ELSEIF(NUMARG.GE.2.AND.
4385     1       ICOM.EQ.'DEXI'.AND.IHARG(1).EQ.'SPLI'.AND.
4386     1       IHARG(2).EQ.'FIT')THEN
4387        ICASSF='10SF'
4388C
4389C               ********************************************
4390C               **  STEP 1.31--                           **
4391C               **  SINCE VALID COMMAND NOT FOUND, EXIT.  **
4392C               ********************************************
4393C
4394      ELSE
4395        ICASSF='    '
4396        IFOUND='NO'
4397        GOTO9000
4398      ENDIF
4399C
4400      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
4401      IFOUND='YES'
4402C
4403C               *********************************
4404C               **  STEP 2--                   **
4405C               **  EXTRACT THE VARIABLE LIST  **
4406C               *********************************
4407C
4408      ISTEPN='2'
4409      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PSPL')
4410     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4411C
4412      INAME='SPLINE FIT'
4413      MINN2=2
4414      MINNA=1
4415      MAXNA=100
4416      MINNVA=2
4417      MAXNVA=3
4418      IFLAGE=99
4419      IFLAGM=0
4420      IFLAGP=0
4421      JMIN=1
4422      JMAX=NUMARG
4423C
4424      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
4425     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
4426     1            JMIN,JMAX,
4427     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
4428     1            IVARN1,IVARN2,IVARTY,PVAR,
4429     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
4430     1            MINNVA,MAXNVA,
4431     1            IFLAGM,IFLAGP,
4432     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
4433      IF(IERROR.EQ.'YES')GOTO9000
4434C
4435      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PSPL')THEN
4436        WRITE(ICOUT,999)
4437        CALL DPWRST('XXX','BUG ')
4438        WRITE(ICOUT,181)
4439  181   FORMAT('***** AFTER CALL DPPARS--')
4440        CALL DPWRST('XXX','BUG ')
4441        WRITE(ICOUT,182)IFOUND,IERROR,NQ,NUMVAR
4442  182   FORMAT('IFOUND,IERROR,NQ,NUMVAR = ',2(A4,2X),2I8)
4443        CALL DPWRST('XXX','BUG ')
4444        IF(NUMVAR.GT.0)THEN
4445          DO185I=1,NUMVAR
4446            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
4447     1                      ICOLR(I)
4448  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
4449     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
4450            CALL DPWRST('XXX','BUG ')
4451  185     CONTINUE
4452        ENDIF
4453      ENDIF
4454C
4455C               **********************************************
4456C               **  STEP 33--                               **
4457C               **  FORM THE SUBSETTED VARIABLES            **
4458C               **       Y(.)                               **
4459C               **       X(.)                               **
4460C               **********************************************
4461C
4462      ISTEPN='33'
4463      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PSPL')
4464     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4465C
4466      ICOL=1
4467      NUMVA2=2
4468      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
4469     1            INAME,IVARN1,IVARN2,IVARTY,
4470     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
4471     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
4472     1            MAXCP4,MAXCP5,MAXCP6,
4473     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
4474     1            Y,X,AJUNK,NS,NS,NS,ICASE,
4475     1            IBUGA3,ISUBRO,IFOUND,IERROR)
4476      IF(IERROR.EQ.'YES')GOTO9000
4477C
4478      N34=0
4479      IF(NUMVAR.EQ.3)THEN
4480        ICOL=3
4481        NUMVA2=1
4482        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
4483     1              INAME,IVARN1,IVARN2,IVARTY,
4484     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
4485     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
4486     1              MAXCP4,MAXCP5,MAXCP6,
4487     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
4488     1              XKNOT,AJUNK,AJUNK,N34,NTEMP,NTEMP,ICASE,
4489     1              IBUGA3,ISUBRO,IFOUND,IERROR)
4490        IF(IERROR.EQ.'YES')GOTO9000
4491      ELSE
4492        IF(IKNOT1.NE.'    ')THEN
4493          IHWUSE='V'
4494          MESSAG='NO'
4495          CALL CHECKN(IKNOT1,IKNOT2,IHWUSE,
4496     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
4497     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
4498C
4499          IF(IERROR.EQ.'NO')THEN
4500            ICOLT=IVALUE(ILOCV)
4501            N34=IN(ILOCV)
4502            ICNT=0
4503            DO210I=1,N34
4504              IJ=MAXN*(ICOLT-1)+I
4505              ICNT=ICNT+1
4506              IF(ICOLT.LE.MAXCOL)XKNOT(ICNT)=V(IJ)
4507              IF(ICOLT.EQ.MAXCP1)XKNOT(ICNT)=PRED(I)
4508              IF(ICOLT.EQ.MAXCP2)XKNOT(ICNT)=RES(I)
4509              IF(ICOLT.EQ.MAXCP3)XKNOT(ICNT)=YPLOT(I)
4510              IF(ICOLT.EQ.MAXCP4)XKNOT(ICNT)=XPLOT(I)
4511              IF(ICOLT.EQ.MAXCP5)XKNOT(ICNT)=X2PLOT(I)
4512              IF(ICOLT.EQ.MAXCP6)XKNOT(ICNT)=TAGPLO(I)
4513              ICNT=ICNT-1
4514  210       CONTINUE
4515          ENDIF
4516        ENDIF
4517C
4518        IF(N34.LE.0)THEN
4519          WRITE(ICOUT,999)
4520          CALL DPWRST('XXX','BUG ')
4521          WRITE(ICOUT,301)
4522  301     FORMAT('***** ERROR IN SPLINE FIT--')
4523          CALL DPWRST('XXX','BUG ')
4524          WRITE(ICOUT,303)
4525  303     FORMAT('      THE KNOTS VARIABLE WAS NOT SPECIFIED ON EITHER')
4526          CALL DPWRST('XXX','BUG ')
4527          WRITE(ICOUT,305)
4528  305     FORMAT('      THE SPLINE FIT COMMAND OR THE KNOTS COMMAND.')
4529          CALL DPWRST('XXX','BUG ')
4530          IERROR='YES'
4531          GOTO9000
4532        ENDIF
4533      ENDIF
4534C
4535C               ***************************************************
4536C               **  STEP 7--                                     **
4537C               **  EXTRACT THE DEGREE OF THE SPLINE FUNCTION.   **
4538C               **  CHECK THAT THE DEGREE IS IN THE VALID RANGE  **
4539C               **  (1 TO 10).                                   **
4540C               ***************************************************
4541C
4542      ISTEPN='7'
4543      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PSPL')
4544     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4545C
4546      MINDEG=1
4547      MAXDEG=10
4548      IDEGRE=3
4549      IF(ICASSF.EQ.'SF'.AND.IDEG.GE.MINDEG.AND.IDEG.LE.MAXDEG)
4550     1IDEGRE=IDEG
4551      IF(ICASSF.EQ.'0SF')IDEGRE=0
4552      IF(ICASSF.EQ.'1SF')IDEGRE=1
4553      IF(ICASSF.EQ.'2SF')IDEGRE=2
4554      IF(ICASSF.EQ.'3SF')IDEGRE=3
4555      IF(ICASSF.EQ.'4SF')IDEGRE=4
4556      IF(ICASSF.EQ.'5SF')IDEGRE=5
4557      IF(ICASSF.EQ.'6SF')IDEGRE=6
4558      IF(ICASSF.EQ.'7SF')IDEGRE=7
4559      IF(ICASSF.EQ.'8SF')IDEGRE=8
4560      IF(ICASSF.EQ.'9SF')IDEGRE=9
4561      IF(ICASSF.EQ.'10FI')IDEGRE=10
4562      IF(ICASSF.EQ.'10SF')IDEGRE=10
4563C
4564      IF(IDEGRE.LT.MINDEG .OR. IDEGRE.GT.MAXDEG)THEN
4565        WRITE(ICOUT,999)
4566        CALL DPWRST('XXX','BUG ')
4567        WRITE(ICOUT,301)
4568        CALL DPWRST('XXX','BUG ')
4569        WRITE(ICOUT,703)
4570  703   FORMAT('      THE DEGREE FOR A SPLINE FIT MUST BE BETWEEN ',
4571     1         I8,' AND ',I8)
4572        CALL DPWRST('XXX','BUG ')
4573        WRITE(ICOUT,705)
4574  705   FORMAT('      (INCLUSIVELY);  SUCH WAS NOT THE CASE HERE.')
4575        CALL DPWRST('XXX','BUG ')
4576        WRITE(ICOUT,707)IDEGRE
4577  707   FORMAT('      THE SPECIFIED DEGREE = ',I8)
4578        CALL DPWRST('XXX','BUG ')
4579        WRITE(ICOUT,709)
4580  709   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
4581        CALL DPWRST('XXX','BUG ')
4582        IF(IWIDTH.GE.1)THEN
4583          WRITE(ICOUT,711)(IANS(I),I=1,MIN(IWIDTH,80))
4584  711     FORMAT('      ',80A1)
4585          CALL DPWRST('XXX','BUG ')
4586        ENDIF
4587        IERROR='YES'
4588        GOTO9000
4589      ENDIF
4590C
4591      NKNOT=N34
4592      K=IDEGRE+NKNOT+1
4593C
4594      IF(NS.LT.K)THEN
4595        WRITE(ICOUT,999)
4596        CALL DPWRST('XXX','BUG ')
4597        WRITE(ICOUT,301)
4598        CALL DPWRST('XXX','BUG ')
4599        WRITE(ICOUT,902)
4600  902   FORMAT('      FOR A SPLINE FIT, THE NUMBER OF ELEMENTS IN THE')
4601        CALL DPWRST('XXX','BUG ')
4602        WRITE(ICOUT,904)
4603  904   FORMAT('      FIRST VARIABLE (THAT IS, THE NUMBER OF POINTS')
4604        CALL DPWRST('XXX','BUG ')
4605        WRITE(ICOUT,905)
4606  905   FORMAT('      TO BE FITTED) MUST BE EQUAL TO OR GREATER THAN')
4607        CALL DPWRST('XXX','BUG ')
4608        WRITE(ICOUT,906)
4609  906   FORMAT('      THE NUMBER OF COEFFICIENTS TO BE ESTIMATED')
4610        CALL DPWRST('XXX','BUG ')
4611        WRITE(ICOUT,907)
4612  907   FORMAT('      (THAT IS, MUST BE EQUAL TO OR GREATER THAN')
4613        CALL DPWRST('XXX','BUG ')
4614        WRITE(ICOUT,908)
4615  908   FORMAT('      (SPLINE DEGREE + NUMBER OF KNOTS + 1));')
4616        CALL DPWRST('XXX','BUG ')
4617        WRITE(ICOUT,909)
4618  909   FORMAT('      SUCH WAS NOT THE CASE HERE.')
4619        CALL DPWRST('XXX','BUG ')
4620        WRITE(ICOUT,999)
4621        CALL DPWRST('XXX','BUG ')
4622        WRITE(ICOUT,910)NS
4623  910   FORMAT('      NUMBER OF FIT POINTS FROM FIRST VARIABLE = ',I8)
4624        CALL DPWRST('XXX','BUG ')
4625        WRITE(ICOUT,911)K
4626  911   FORMAT('      NUMBER OF ESTIMATED COEFFICIENTS         = ',I8)
4627        CALL DPWRST('XXX','BUG ')
4628        WRITE(ICOUT,912)IDEGRE
4629  912   FORMAT('      DEGREE OF SPLINE                         = ',I8)
4630        CALL DPWRST('XXX','BUG ')
4631        WRITE(ICOUT,913)NKNOT
4632  913   FORMAT('      NUMBER OF KNOTS                          = ',I8)
4633        CALL DPWRST('XXX','BUG ')
4634        WRITE(ICOUT,999)
4635        CALL DPWRST('XXX','BUG ')
4636        WRITE(ICOUT,709)
4637        CALL DPWRST('XXX','BUG ')
4638        IF(IWIDTH.GE.1)THEN
4639          WRITE(ICOUT,711)(IANS(I),I=1,MIN(IWIDTH,80))
4640          CALL DPWRST('XXX','BUG ')
4641        ENDIF
4642        IERROR='YES'
4643        GOTO9000
4644      ENDIF
4645C
4646C               ******************************************************
4647C               **  STEP 9--                                        **
4648C               **  CHECK THAT THE PRODUCT OF THE NUMBER OF POINTS  **
4649C               **  TO BE FITTED (NS) AND THE NUMBER OF B-SPLINE    **
4650C               **  COEFFICIENTS TO BE ESTIMATED (K)                **
4651C               **  DOES NOT EXCEED MAXNK--THUS THE ARRAY Z2(.)     **
4652C               **  IN THE SUBROUTINE DPSPL2 WILL NOT OVERFLOW.     **
4653C               ******************************************************
4654C
4655      INK=NS*K
4656      IF(INK.GT.MAXNK)THEN
4657        WRITE(ICOUT,999)
4658        CALL DPWRST('XXX','BUG ')
4659        WRITE(ICOUT,301)
4660        CALL DPWRST('XXX','BUG ')
4661        WRITE(ICOUT,922)
4662  922   FORMAT('      AN INTERNAL ARRAY WILL OVERFLOW IF THE PRODUCT')
4663        CALL DPWRST('XXX','BUG ')
4664        WRITE(ICOUT,924)
4665  924   FORMAT('      OF THE NUMBER OF POINTS TO BE FITTED AND THE')
4666        CALL DPWRST('XXX','BUG ')
4667        WRITE(ICOUT,925)
4668  925   FORMAT('      NUMBER OF B-SPLINE COEFFICIENTS TO BE ESTIMATED')
4669        CALL DPWRST('XXX','BUG ')
4670        WRITE(ICOUT,927)MAXNK
4671  927   FORMAT('      EXCEEDS ',I8,'.  SUCH WOULD BE THE CASE HERE.')
4672        CALL DPWRST('XXX','BUG ')
4673        WRITE(ICOUT,928)NS,K,INK
4674  928   FORMAT('      N = ',I8,' K = ',I8,' N*K = ',I8)
4675        CALL DPWRST('XXX','BUG ')
4676        IERROR='YES'
4677        GOTO9000
4678      ENDIF
4679C
4680C               **************************************************
4681C               **  STEP 10--                                   **
4682C               **  PREPARE FOR ENTRANCE INTO DPSPL2--          **
4683C               **  SET THE WEIGHT VECTOR TO UNITY THROUGHOUT.  **
4684C               **************************************************
4685C
4686      ISTEPN='10'
4687      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PSPL')
4688     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4689C
4690      DO970I=1,NS
4691        W(I)=1.0
4692  970 CONTINUE
4693C
4694C               *********************
4695C               **  STEP 12-       **
4696C               **  ENTER DPSPL2.  **
4697C               *********************
4698C
4699      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PSPL')THEN
4700        ISTEPN='12'
4701        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4702        WRITE(ICOUT,999)
4703        CALL DPWRST('XXX','BUG ')
4704        WRITE(ICOUT,6081)
4705 6081   FORMAT('***** FROM DPSPL, AS WE ARE ABOUT TO CALL DPSPL2--')
4706        CALL DPWRST('XXX','BUG ')
4707        WRITE(ICOUT,6082)MAXN,NS,NKNOT
4708 6082   FORMAT('NUMCHA,MAXN,NKNOT = ',3I8)
4709        CALL DPWRST('XXX','BUG ')
4710        DO6083I=1,NS
4711          WRITE(ICOUT,6084)I,Y(I),X(I),W(I)
4712 6084     FORMAT('I,Y(I),X(I),W(I) = ',I8,3G15.7)
4713          CALL DPWRST('XXX','BUG ')
4714 6083   CONTINUE
4715      ENDIF
4716C
4717CCCCC JUNE, 1990.  MOVE SOME DIMENSIONS FROM DPSPL2 TO DPSPL
4718CCCCC CALL DPSPL2(Y,X,W,NS,XKNOT,NKNOT,IDEGRE,V,
4719      CALL DPSPL2(Y,X,W,NS,XKNOT,NKNOT,IDEGRE,VSCRT,
4720     1            B,SDB,B2,SDB2,PRED2,RES2,
4721     1            REPSD,REPDF,RESSD,RESDF,ALFCDF,
4722     1            V1,V2,DUM1,DUM2,AJUNK,
4723     1            XPX,SSQ,A,XPY,RIGHT,BTEMP,EKNOT,
4724     1            ICAPSW,ICAPTY,IFORSW,
4725     1            IBUGA3,ISUBRO,IERROR)
4726C
4727      IF(IERROR.EQ.'YES')GOTO9000
4728C
4729C               ***************************************
4730C               **  STEP 14--                        **
4731C               **  UPDATE INTERNAL DATAPLOT TABLES  **
4732C               ***************************************
4733C
4734      ISTEPN='14'
4735      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PSPL')
4736     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4737C
4738      ICOLPR=MAXCP1
4739      ICOLRE=MAXCP2
4740      IREPU='ON'
4741      IRESU='ON'
4742      CALL UPDAPR(ICOLPR,ICOLRE,PRED2,RES2,PRED,RES,ISUB,NS,
4743     1IREPU,REPSD,REPDF,IRESU,RESSD,RESDF,ALFCDF,
4744     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
4745     1IANS,IWIDTH,ILOCN,IBUGA3,IERROR)
4746C
4747      ISTEPN='14B'
4748      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PSPL')
4749     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4750C
4751      IBUGJU='OFF'
4752C
4753      L=0
4754      IKNMAX=NKNOT+1
4755      JMAX=IDEGRE+1
4756      DO7500IKN=1,IKNMAX
4757        DO7600J=1,JMAX
4758          L=L+1
4759          JM1=J-1
4760          CALL COENAM(IKN,JM1,IH,IH2,IBUGJU,IERROR)
4761C
4762          DO7650I=1,NUMNAM
4763            I2=I
4764            IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
4765     1         IUSE(I).EQ.'P')THEN
4766              VALUE(I2)=B2(L)
4767              GOTO7600
4768            ENDIF
4769 7650     CONTINUE
4770C
4771          IF(NUMNAM.GT.MAXNAM)THEN
4772            WRITE(ICOUT,301)
4773            CALL DPWRST('XXX','BUG ')
4774            WRITE(ICOUT,7652)
4775 7652       FORMAT('      THE TOTAL NUMBER OF (VARIABLE + PARAMETER)')
4776            CALL DPWRST('XXX','BUG ')
4777            WRITE(ICOUT,7653)MAXNAM
4778 7653       FORMAT('      NAMES MUST BE AT MOST ',I8)
4779            CALL DPWRST('XXX','BUG ')
4780            WRITE(ICOUT,7654)
4781 7654       FORMAT('      SUCH WAS NOT THE CASE HERE--THE MAXIMUM')
4782            CALL DPWRST('XXX','BUG ')
4783            WRITE(ICOUT,7655)
4784 7655       FORMAT('      ALLOWABLE NUMBER OF NAMES WAS JUST EXCEEDED.')
4785            CALL DPWRST('XXX','BUG ')
4786            WRITE(ICOUT,7657)
4787 7657       FORMAT('      SUGGESTED ACTION--ENTER  STAT  TO DETERMINE')
4788            CALL DPWRST('XXX','BUG ')
4789            WRITE(ICOUT,7659)
4790 7659       FORMAT('      THE IMPORTANT (VERSUS UNIMPORTANT) VARIABLES')
4791            CALL DPWRST('XXX','BUG ')
4792            WRITE(ICOUT,7660)
4793 7660       FORMAT('      AND PARAMETERS, AND THEN REUSE SOME OF THE ',
4794     1             'NAMES.')
4795            CALL DPWRST('XXX','BUG ')
4796            WRITE(ICOUT,709)
4797            CALL DPWRST('XXX','BUG ')
4798            IF(IWIDTH.GE.1)THEN
4799              WRITE(ICOUT,711)(IANS(I),I=1,MIN(IWIDTH,80))
4800              CALL DPWRST('XXX','BUG ')
4801            ENDIF
4802            IERROR='YES'
4803            GOTO9000
4804          ELSE
4805            NUMNAM=NUMNAM+1
4806            ILOC=NUMNAM
4807            IHNAME(ILOC)=IH
4808            IHNAM2(ILOC)=IH2
4809            IUSE(ILOC)='P'
4810            VALUE(ILOC)=B2(L)
4811          ENDIF
4812C
4813 7600   CONTINUE
4814 7500 CONTINUE
4815C
4816C               ***************************************
4817C               **  STEP 15--                        **
4818C               **  ENTER A NOTE IN MODEL(.)         **
4819C               **  STATING THAT THE LAST FIT        **
4820C               **  WAS A SPLINE FIT                 **
4821C               **  OF WHATEVER DEGREE.              **
4822C               ***************************************
4823C
4824      ISTEPN='15'
4825      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PSPL')
4826     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4827C
4828      DO8100I=1,IWIDTH
4829        MODEL(I)=IANS(I)
4830 8100 CONTINUE
4831      NUMCHA=IWIDTH
4832C
4833C               *****************
4834C               **  STEP 90--  **
4835C               **  EXIT       **
4836C               *****************
4837C
4838 9000 CONTINUE
4839      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'PSPL')THEN
4840        WRITE(ICOUT,999)
4841        CALL DPWRST('XXX','BUG ')
4842        WRITE(ICOUT,9011)
4843 9011   FORMAT('***** AT THE END       OF DPSPL--')
4844        CALL DPWRST('XXX','BUG ')
4845        WRITE(ICOUT,9014)NS,NKNOT,IDEGRE,ICASSF
4846 9014   FORMAT('NS,NKNOT,IDEGRE,ICASSF = ',3I8,2X,A4)
4847        CALL DPWRST('XXX','BUG ')
4848        WRITE(ICOUT,9016)IFOUND,IERROR
4849 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
4850        CALL DPWRST('XXX','BUG ')
4851      ENDIF
4852C
4853      RETURN
4854      END
4855      SUBROUTINE DPSPL2(Y,X,W,N,XKNOT,NKNOT,IDEGRE,Z2,
4856     1                  B,SDB,B2,SDB2,PRED2,RES2,
4857     1                  REPSD,REPDF,RESSD,RESDF,ALFCDF,
4858     1                  V1,V2,DUM1,DUM2,AJUNK,
4859     1                  XPX,SSQ,A,XPY,RIGHT,BTEMP,EKNOT,
4860     1                  ICAPSW,ICAPTY,IFORSW,
4861     1                  IBUGA3,ISUBRO,IERROR)
4862C
4863C     PURPOSE--THIS SUBROUTINE COMPUTES A LEAST SQUARES SPLINE FIT
4864C              FOR ANY DEGREE--LINEAR, QUADRATIC, CUBIC, ETC.
4865C     ALGORITHM USED--B-SPLINES (MODIFIED SO THAT SOME ELEMENTS
4866C                   SET = 0 RATHER THAN COMPUTED AS 0)
4867C     REFERENCE--WOLD, TECHNOMETRICS, 1974, PAGE 2
4868C     INPUT  ARGUMENTS--Y      = SINGLE PRECISION VECTOR OF
4869C                                RESPONSE DATA (THAT IS, THE
4870C                                DEPENDENT VARIABLE).
4871C                       X      = SINGLE PRECISION MATRIX OF
4872C                                THE DEPENDENT VARIABLE.
4873C                       W      = THE SINGLE PRECISION VECTOR
4874C                                OF WEIGHTS FOR THE RESPONSE
4875C                                VARIABLE.
4876C                       N      = THE INTEGER VALUE OF THE SAMPLE SIZE.
4877C                       XKNOT  = THE SINGLE PRECISION VECTOR OF KNOTS.
4878C                       NKNOT  = THE INTEGER NUMBER OF SPECIFIED KNOTS.
4879C                       IDEGRE = THE INTEGER DEGREE OF THE SPLINE.
4880C     OUTPUT ARGUMENTS--B      = THE SINGLE PRECISION VECTOR OF
4881C                                ESTIMATED REGRESSION COEFFICIENTS.
4882C                       SDB    = THE SINGLE PRECISION VECTOR OF
4883C                                ESTIMATED STANDARD DEVIATIONS OF THE
4884C                                ESTIMATED REGRESSION COEFFICIENTS.
4885C                       RESSD  = THE ESTIMATED RESIDUAL STANDARD
4886C                                DEVIATION.
4887C                       PRED2  = THE SINGLE PRECISION VECTOR OF
4888C                                PREDICTED VALUES.
4889C                       RES2   = THE SINGLE PRECISION VECTOR OF
4890C                                RESIDUALS FROM THE LEAST SQUARES FIT.
4891C     SUBROUTINES NEEDED--DECOMP, INVXWX, AND DOT.
4892C     NOTE--CODE MODIFIED SO THAT NUMBER OF KNOTS SHOULD NOT
4893C           EXCEED 50
4894C     WRITTEN BY--JAMES J. FILLIBEN
4895C                 STATISTICAL ENGINEERING DIVISION
4896C                 INFORMATION TECHNOLOGY LABORATORY
4897C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4898C                 GAITHERSBURG, MD 20899-8980
4899C                 PHONE--301-975-2855
4900C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4901C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4902C     LANGUAGE--ANSI FORTRAN (1977)
4903C     VERSION NUMBER--82/7
4904C     ORIGINAL VERSION--MARCH     1975.
4905C     UPDATED         --NOVEMBER  1975.
4906C     UPDATED         --MAY       1976.
4907C     UPDATED         --DECEMBER  1978.
4908C     UPDATED         --AUGUST    1979.
4909C     UPDATED         --MARCH     1981.
4910C     UPDATED         --JULY      1981.
4911C     UPDATED         --AUGUST    1981.
4912C     UPDATED         --NOVEMBER  1981.
4913C     UPDATED         --MAY       1982.
4914C     UPDATED         --MARCH     1988. ADD LOFCDF
4915C     UPDATED         --JANUARY   1989. DECLARE AJUNK AS ARRAY (DIM. 1) (ALAN)
4916C     UPDATED         --MAY       1989. INCREACED DIMENSION FOR V1 AND V2
4917C                                       MOVE SOME DIMENSIONS
4918C     UPDATED         --FEBRUARY  2012. USE DPDTA1 TO PRINT OUTPUT
4919C     UPDATED         --JULY      2019. CALL LIST TO DPREPS
4920C
4921C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4922C
4923      CHARACTER*4 ICAPSW
4924      CHARACTER*4 ICAPTY
4925      CHARACTER*4 IFORSW
4926      CHARACTER*4 IBUGA3
4927      CHARACTER*4 ISUBRO
4928      CHARACTER*4 IERROR
4929C
4930      CHARACTER*4 IREP
4931      CHARACTER*4 IBUGJU
4932      CHARACTER*4 IH
4933      CHARACTER*4 IH2
4934C
4935      CHARACTER*4 ISUBN1
4936      CHARACTER*4 ISUBN2
4937      CHARACTER*4 ISTEPN
4938C
4939C---------------------------------------------------------------------
4940C
4941      DIMENSION Y(*)
4942      DIMENSION X(*)
4943      DIMENSION W(*)
4944      DIMENSION XKNOT(*)
4945C
4946      DIMENSION B(*)
4947      DIMENSION SDB(*)
4948      DIMENSION PRED2(*)
4949      DIMENSION RES2(*)
4950      DIMENSION B2(*)
4951      DIMENSION SDB2(*)
4952      DIMENSION Z2(*)
4953      DIMENSION V1(*)
4954      DIMENSION V2(*)
4955      DIMENSION DUM1(*)
4956      DIMENSION DUM2(*)
4957      DIMENSION AJUNK(*)
4958C
4959      DIMENSION XPX(50,50)
4960      DIMENSION SSQ(50,50)
4961      DIMENSION A(50,50)
4962      DIMENSION XPY(*)
4963      DIMENSION RIGHT(*)
4964      DIMENSION BTEMP(*)
4965      DIMENSION EKNOT(*)
4966C
4967      PARAMETER(NUMCLI=4)
4968      PARAMETER(MAXLIN=3)
4969      PARAMETER (MAXROW=60)
4970      CHARACTER*40 ITITLE
4971      CHARACTER*40 ITITLZ
4972      CHARACTER*40 ITITL9
4973      CHARACTER*40 ITEXT(MAXROW)
4974      CHARACTER*4  ALIGN(NUMCLI)
4975      CHARACTER*4  VALIGN(NUMCLI)
4976      REAL         AVALUE(MAXROW)
4977      INTEGER      NCTEXT(MAXROW)
4978      INTEGER      IDIGIT(MAXROW)
4979      INTEGER      IDIGI2(MAXROW,NUMCLI)
4980      INTEGER      ROWSEP(MAXROW)
4981      INTEGER      NTOT(MAXROW)
4982      CHARACTER*40 ITITL2(MAXLIN,NUMCLI)
4983      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
4984      CHARACTER*4  ITYPCO(MAXROW,NUMCLI)
4985      CHARACTER*4  ITYPC2(NUMCLI)
4986      INTEGER      NCTIT2(MAXLIN,NUMCLI)
4987      INTEGER      NCOLSP(MAXLIN,NUMCLI)
4988      INTEGER      NCVALU(MAXROW,NUMCLI)
4989      INTEGER      IWHTML(NUMCLI)
4990      INTEGER      IWRTF(NUMCLI)
4991      REAL         AMAT(MAXROW,NUMCLI)
4992      LOGICAL IFRST
4993      LOGICAL ILAST
4994      LOGICAL IFLAGS
4995      LOGICAL IFLAGE
4996C
4997C-----COMMON----------------------------------------------------------
4998C
4999      INCLUDE 'DPCOP2.INC'
5000C
5001C-----START POINT-----------------------------------------------------
5002C
5003      ISUBN1='DPSP'
5004      ISUBN2='L2  '
5005C
5006      CDF2=CPUMIN
5007C
5008      NUMDIG=7
5009      IF(IFORSW.EQ.'1')NUMDIG=1
5010      IF(IFORSW.EQ.'2')NUMDIG=2
5011      IF(IFORSW.EQ.'3')NUMDIG=3
5012      IF(IFORSW.EQ.'4')NUMDIG=4
5013      IF(IFORSW.EQ.'5')NUMDIG=5
5014      IF(IFORSW.EQ.'6')NUMDIG=6
5015      IF(IFORSW.EQ.'7')NUMDIG=7
5016      IF(IFORSW.EQ.'8')NUMDIG=8
5017      IF(IFORSW.EQ.'9')NUMDIG=9
5018      IF(IFORSW.EQ.'0')NUMDIG=0
5019      IF(IFORSW.EQ.'E')NUMDIG=-2
5020      IF(IFORSW.EQ.'-2')NUMDIG=-2
5021      IF(IFORSW.EQ.'-3')NUMDIG=-3
5022      IF(IFORSW.EQ.'-4')NUMDIG=-4
5023      IF(IFORSW.EQ.'-5')NUMDIG=-5
5024      IF(IFORSW.EQ.'-6')NUMDIG=-6
5025      IF(IFORSW.EQ.'-7')NUMDIG=-7
5026      IF(IFORSW.EQ.'-8')NUMDIG=-8
5027      IF(IFORSW.EQ.'-9')NUMDIG=-9
5028C
5029      IERROR='NO'
5030      K2=0
5031      DIJ=0.0
5032C
5033      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5034        WRITE(ICOUT,999)
5035  999   FORMAT(1X)
5036        CALL DPWRST('XXX','BUG ')
5037        WRITE(ICOUT,51)
5038   51   FORMAT('***** AT THE BEGINNING OF DPSPL2--')
5039        CALL DPWRST('XXX','BUG ')
5040        WRITE(ICOUT,52)IBUGA3,ISUBRO,N,NKNOT,IDEGRE,AJUNK(1)
5041   52   FORMAT('IBUGA3,ISUBRO,N,NKNOT,IDEGRE,AJUNK(1) = ',
5042     1         2(A4,2X),3I8,G15.7)
5043        CALL DPWRST('XXX','BUG ')
5044        DO55I=1,N
5045          WRITE(ICOUT,56)I,Y(I),X(I),W(I),XKNOT(I)
5046   56     FORMAT('I,Y(I),X(I),W(I),XKNOT(I) = ',I8,4G15.7)
5047          CALL DPWRST('XXX','BUG ')
5048   55   CONTINUE
5049      ENDIF
5050C
5051      AN=N
5052      K=NKNOT+IDEGRE+1
5053      AK=K
5054      DEG=IDEGRE
5055      KMAX=50
5056C
5057C               ***************************
5058C               **  STEP 1--             **
5059C               **  WRITE OUT THE TITLE  **
5060C               ***************************
5061C
5062      ISTEPN='1'
5063      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5064     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5065C
5066C               *****************************************
5067C               **  STEP 2--                           **
5068C               **  CHECK THE INPUT ARGUMENTS N AND K  **
5069C               *****************************************
5070C
5071      ISTEPN='2'
5072      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5073     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5074C
5075      IF(K.LT.1 .OR. K.GT.KMAX)THEN
5076        WRITE(ICOUT,999)
5077        CALL DPWRST('XXX','BUG ')
5078        WRITE(ICOUT,151)
5079  151   FORMAT('***** ERROR IN SPLINE FIT--')
5080        CALL DPWRST('XXX','BUG ')
5081        WRITE(ICOUT,152)
5082  152   FORMAT('      THE NUMBER OF SPLINE COEFFICIENTS (K = NDEG+1)')
5083        CALL DPWRST('XXX','BUG ')
5084        WRITE(ICOUT,153)
5085  153   FORMAT('      IS NON-POSITIVE OR LARGER THAN ALLOWABLE MAX')
5086        CALL DPWRST('XXX','BUG ')
5087        WRITE(ICOUT,154)K,KMAX
5088  154   FORMAT('      K,KMAX = ',I8,I8)
5089        CALL DPWRST('XXX','BUG ')
5090        IERROR='YES'
5091        GOTO9000
5092      ENDIF
5093C
5094      IF(K.GT.N)THEN
5095        WRITE(ICOUT,999)
5096        CALL DPWRST('XXX','BUG ')
5097        WRITE(ICOUT,151)
5098        CALL DPWRST('XXX','BUG ')
5099        WRITE(ICOUT,162)
5100  162   FORMAT('      THE NUMBER OF SPLINE COEFFICIENTS (K = NDEG+1)')
5101        CALL DPWRST('XXX','BUG ')
5102        WRITE(ICOUT,163)
5103  163   FORMAT('      IS LARGER THAN THE NUMBER OF DATA POINTS (N).')
5104        CALL DPWRST('XXX','BUG ')
5105        WRITE(ICOUT,164)K,N
5106  164   FORMAT('      K,N = ',I8,I8)
5107        CALL DPWRST('XXX','BUG ')
5108        IERROR='YES'
5109        GOTO9000
5110      ENDIF
5111C
5112      IF(NKNOT.GT.50)THEN
5113        WRITE(ICOUT,999)
5114        CALL DPWRST('XXX','BUG ')
5115        WRITE(ICOUT,151)
5116        CALL DPWRST('XXX','BUG ')
5117        WRITE(ICOUT,172)NKNOT
5118  172   FORMAT('      THE NUMBER OF KNOTS (= ',I8,') HAS JUST EXCEEDED')
5119        CALL DPWRST('XXX','BUG ')
5120        WRITE(ICOUT,174)
5121  174   FORMAT('      THE ALLOWABLE MAXIMUM (= 50).')
5122        CALL DPWRST('XXX','BUG ')
5123        IERROR='YES'
5124        GOTO9000
5125      ENDIF
5126C
5127C               ********************************************************
5128C               **  STEP 3--                                          **
5129C               **  INSPECT THE WEIGHT VECTOR W--IF ALL ELEMENTS ARE  **
5130C               **  IDENTICAL, THEN RESET ALL ELEMENTS TO 1.0.  THIS  **
5131C               **  AVOIDS THE PROBLEM OF AN UNDEFINED EMPTY WEIGHT   **
5132C               **  VECTOR W WHEN IN FACT AN EQUAL WEIGHTING SCHEME   **
5133C               **  IS DESIRED.                                       **
5134C               ********************************************************
5135C
5136      ISTEPN='3'
5137      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5138     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5139C
5140      IWFLAG=0
5141      WHOLD=W(1)
5142      DO600I=1,N
5143        IF(W(I).EQ.WHOLD)GOTO600
5144        GOTO850
5145  600 CONTINUE
5146      IWFLAG=1
5147  850 CONTINUE
5148C
5149      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5150         IF(IWFLAG.EQ.0)THEN
5151            WRITE(ICOUT,851)
5152  851       FORMAT('      UNEQUAL WEIGHTS CASE')
5153            CALL DPWRST('XXX','BUG ')
5154         ENDIF
5155         IF(IWFLAG.EQ.1)THEN
5156            WRITE(ICOUT,852)
5157  852       FORMAT('      EQUAL WEIGHTS CASE')
5158            CALL DPWRST('XXX','BUG ')
5159         ENDIF
5160      ENDIF
5161C
5162C               ********************************************************
5163C               **  STEP 3.5--                                        **
5164C               **  CHECK FOR REPLICATION AND IF EXISTENT COMPUTE A   **
5165C               **  (MODEL-FREE) REPLICATION STANDARD DEVIATION.      **
5166C               ********************************************************
5167C
5168      ISTEPN='3.5'
5169      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5170     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5171C
5172      NUMVAR=1
5173C
5174      IREP='NO'
5175      REPSD=0.0
5176      REPDF=0.0
5177      IREPDF=INT(REPDF+0.5)
5178      RESSD=0.0
5179      RESDF=0.0
5180      ALFCDF=(-999.99)
5181      CALL DPREPS(Y,X,N,N,NUMVAR,DUM1,DUM2,
5182     1            IREP,REPSS,REPMS,REPSD,REPDF,NUMSET,IBUGA3,IERROR)
5183      IREPDF=INT(REPDF+0.5)
5184C
5185C               *********************************************************
5186C               **  STEP 4--                                           **
5187C               **  FORM THE MATRIX X2 (WHICH CORRESPONDS TO THE USUAL **
5188C               **  X MATRIX IN THE FIT SUBROUTINE BUT IS HERE CALLED  **
5189C               **  X2 BECAUSE OF A CONFLICT DUE TO THE INPUT VECTOR   **
5190C               **  X).  B-SPLINES ARE USED HEREIN.                    **
5191C               **  REFERENCE--WOLD, TECHNOMETRICS, 1974, PAGE 2.      **
5192C               *********************************************************
5193C
5194      ISTEPN='4'
5195      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5196     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5197C
5198C               **********************************
5199C               **  STEP 4.1--                  **
5200C               **  DETERMINE THE MIN X VALUE.  **
5201C               **  DETERMINE THE MAX X VALUE.  **
5202C               **********************************
5203C
5204      ISTEPN='4.1'
5205      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5206     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5207C
5208      XMIN=X(1)
5209      XMAX=X(1)
5210      DO900I=1,N
5211        IF(X(I).LT.XMIN)XMIN=X(I)
5212        IF(X(I).GT.XMAX)XMAX=X(I)
5213  900 CONTINUE
5214C
5215C               ************************************
5216C               **  STEP 4.2--                    **
5217C               **  DEFINE EXTENDED KNOTS         **
5218C               **  (ON EITHER END OF THE DATA).  **
5219C               **  THE NUMBER OF SUCH KNOTS      **
5220C               **  ON EACH SIDE WILL BE          **
5221C               **  DEGREE + 1.                   **
5222C               ************************************
5223C
5224      ISTEPN='4.2'
5225      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5226     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5227C
5228      CALL SORT(XKNOT,NKNOT,XKNOT)
5229C
5230      IF(XKNOT(1).EQ.XMIN)THEN
5231        RANGE=XMAX-XMIN
5232        DEL=RANGE/100.0
5233      ELSE
5234        DEL=XKNOT(1)-XMIN
5235        DEL=ABS(DEL)
5236      ENDIF
5237C
5238      L=0
5239C
5240      IMAX=IDEGRE+1
5241      DO940I=1,IMAX
5242        L=L+1
5243        AIREV=IMAX-I+1
5244        EKNOT(L)=XKNOT(1)-AIREV*DEL
5245  940 CONTINUE
5246C
5247      DO950I=1,NKNOT
5248        L=L+1
5249        EKNOT(L)=XKNOT(I)
5250  950 CONTINUE
5251C
5252      IF(XKNOT(NKNOT).EQ.XMAX)THEN
5253        RANGE=XMAX-XMIN
5254        DEL=RANGE/100.0
5255      ELSE
5256        DEL=XMAX-XKNOT(NKNOT)
5257        DEL=ABS(DEL)
5258      ENDIF
5259C
5260      IMAX=IDEGRE+1
5261      DO990I=1,IMAX
5262        L=L+1
5263        AI=I
5264        EKNOT(L)=XKNOT(NKNOT)+AI*DEL
5265  990 CONTINUE
5266C
5267      NKNOT2=L
5268C
5269      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5270        WRITE(ICOUT,999)
5271        CALL DPWRST('XXX','BUG ')
5272        WRITE(ICOUT,991)NKNOT,NKNOT2
5273  991   FORMAT('NKNOT,NKNOT2 = ',2I8)
5274        CALL DPWRST('XXX','BUG ')
5275        WRITE(ICOUT,992)XMIN,XKNOT(1),XKNOT(NKNOT),XMAX,DEL
5276  992   FORMAT('XMIN,XKNOT(1),XKNOT(NKNOT),XMAX,DEL = ',5G15.7)
5277        CALL DPWRST('XXX','BUG ')
5278        DO993I=1,NKNOT2
5279          WRITE(ICOUT,994)I,EKNOT(I)
5280  994     FORMAT('I, EKNOT(I) = ',I8,G15.7)
5281          CALL DPWRST('XXX','BUG ')
5282  993   CONTINUE
5283      ENDIF
5284C
5285C               *******************************************
5286C               **  STEP 4.4--                           **
5287C               **  FORM THE LINEAR REGRESSION X MATRIX  **
5288C               **  (HERE CALLED X2)                     **
5289C               **  WHICH WILL CONTAIN THE B-SPLINE      **
5290C               **  REPRESENTATION OF THE SPLINE         **
5291C               **  PROBLEM.                             **
5292C               **  NOTE THAT K = THE NUMBER             **
5293C               **  OF ORIGINAL KNOTS + IDEGRE + 1.      **
5294C               *******************************************
5295C
5296      ISTEPN='4.4'
5297      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5298     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5299C
5300      DO1500I=1,N
5301        DO1600J=1,K
5302C
5303          IJ=(I-1)*K+J
5304          Z2(IJ)=0.0
5305          LMAX=IDEGRE+J+1
5306          IF(X(I).LT.EKNOT(J).OR.X(I).GT.EKNOT(LMAX))GOTO1600
5307C
5308          SUM=0.0
5309          DO1700L=J,LMAX
5310            IF(X(I).LE.EKNOT(L))GOTO1700
5311            XI=X(I)
5312            EKNOL=EKNOT(L)
5313            ANUM=(XI-EKNOL)**DEG
5314            PROD=1.0
5315            DO1800M=J,LMAX
5316              IF(M.EQ.L)GOTO1800
5317              EKNOL=EKNOT(L)
5318              EKNOM=EKNOT(M)
5319              PROD=PROD*(EKNOL-EKNOM)
5320 1800       CONTINUE
5321            ADEN=PROD
5322C
5323            RATIO=ANUM/ADEN
5324            SUM=SUM+RATIO
5325C
5326            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5327              WRITE(ICOUT,1811)ANUM,ADEN,RATIO,SUM
5328 1811         FORMAT('ANUM,ADEN,RATIO,SUM = ',4G15.7)
5329              CALL DPWRST('XXX','BUG ')
5330            ENDIF
5331C
5332 1700     CONTINUE
5333          IJ=(I-1)*K+J
5334          Z2(IJ)=SUM
5335C
5336          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5337            WRITE(ICOUT,1711)I,J,Z2(IJ)
5338 1711       FORMAT('I, J, Z2(IJ) = ',2I8,G15.7)
5339            CALL DPWRST('XXX','BUG ')
5340          ENDIF
5341C
5342 1600   CONTINUE
5343 1500 CONTINUE
5344C
5345      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5346        WRITE(ICOUT,1901)
5347 1901   FORMAT('AFTER STEP 4.4 IN DPSPL2--')
5348        CALL DPWRST('XXX','BUG ')
5349        WRITE(ICOUT,1902)
5350 1902   FORMAT('Z2(.,.) = ')
5351        CALL DPWRST('XXX','BUG ')
5352        DO1910I=1,N
5353          IJMIN=(I-1)*K+1
5354          IJMAX=I*K
5355          WRITE(ICOUT,1911)(Z2(IJ),IJ=IJMIN,IJMAX)
5356 1911     FORMAT(8G15.7)
5357          CALL DPWRST('XXX','BUG ')
5358 1910   CONTINUE
5359      ENDIF
5360C
5361C               *******************************
5362C               **  STEP 5--                 **
5363C               **  FORM THE X'X MATRIX      **
5364C               **  (HERE CALLED XPX)        **
5365C               **  THIS WILL HAVE K ROWS    **
5366C               **  AND K COLUMNS            **
5367C               **  WHERE K = THE NUMBER OF  **
5368C               **  ORIGINAL KNOTS + 4.      **
5369C               *******************************
5370C
5371      ISTEPN='5'
5372      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5373     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5374C
5375      DO2100I=1,K
5376        DO2200J=1,K
5377          DO2300L=1,N
5378            LI=(L-1)*K+I
5379            V1(L)=Z2(LI)
5380            LJ=(L-1)*K+J
5381            V2(L)=Z2(LJ)
5382 2300     CONTINUE
5383          CALL DOTPRO(V1,V2,N,RESULT)
5384          XPX(I,J)=RESULT
5385          IJ=(I-1)*K+J
5386 2200   CONTINUE
5387 2100 CONTINUE
5388C
5389      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5390        WRITE(ICOUT,2301)
5391 2301   FORMAT('AFTER STEP 5 IN DPSPL2--')
5392        CALL DPWRST('XXX','BUG ')
5393        WRITE(ICOUT,2302)
5394 2302   FORMAT('Z2(.,.) = ')
5395        CALL DPWRST('XXX','BUG ')
5396        DO2310I=1,N
5397          JMIN=(I-1)*K+1
5398          JMAX=I*K
5399          WRITE(ICOUT,2311)(Z2(IJ),IJ=JMIN,JMAX)
5400 2311     FORMAT(8E15.7)
5401          CALL DPWRST('XXX','BUG ')
5402 2310   CONTINUE
5403        WRITE(ICOUT,2342)
5404 2342   FORMAT('XPX(.,.) = ')
5405        CALL DPWRST('XXX','BUG ')
5406        DO2350I=1,N
5407          WRITE(ICOUT,2351)(XPX(I,J),J=1,K)
5408 2351     FORMAT(8G15.7)
5409          CALL DPWRST('XXX','BUG ')
5410 2350   CONTINUE
5411      ENDIF
5412C
5413C               *****************************************
5414C               **  STEP 6--                           **
5415C               **  FORM THE INVERSE MATRIX (X'X)**-1  **
5416C               **  (HERE CALLED SSQ).                **
5417C               **  THIS WILL HAVE K ROWS              **
5418C               **  AND K COLUMNS                      **
5419C               **  WHERE K = THE NUMBER OF            **
5420C               **  ORIGINAL KNOTS + 4.                **
5421C               *****************************************
5422C
5423      ISTEPN='6'
5424      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')THEN
5425        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5426        DO2610I=1,K
5427          DO2620J=1,K
5428            WRITE(ICOUT,2621)I,J,XPX(I,J)
5429 2621       FORMAT('I,J,XPX(I,J) = ',2I8,G15.7)
5430            CALL DPWRST('XXX','BUG ')
5431 2620     CONTINUE
5432 2610   CONTINUE
5433      ENDIF
5434C
5435      CALL MATI50(XPX,K,SSQ)
5436C
5437      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')THEN
5438        WRITE(ICOUT,999)
5439        CALL DPWRST('XXX','BUG ')
5440        DO2710I=1,K
5441          DO2720J=1,K
5442            WRITE(ICOUT,2721)I,J,SSQ(I,J)
5443 2721       FORMAT('I,J,SSQ(I,J) = ',2I8,G15.7)
5444            CALL DPWRST('XXX','BUG ')
5445 2720     CONTINUE
5446 2710   CONTINUE
5447      ENDIF
5448C
5449C               *********************************************
5450C               **  STEP 7--                               **
5451C               **  COMPUTE THE K REGRESSION COEFFICIENTS. **
5452C               *********************************************
5453C
5454      ISTEPN='7'
5455      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5456     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5457C
5458      DO3100I=1,K
5459        DO3200L=1,N
5460          LI=(L-1)*K+I
5461          V1(L)=Z2(LI)
5462          V2(L)=Y(L)
5463 3200   CONTINUE
5464        CALL DOTPRO(V1,V2,N,XPY(I))
5465 3100 CONTINUE
5466C
5467      DO3600I=1,K
5468        DO3700L=1,K
5469          V1(L)=SSQ(L,I)
5470          V2(L)=XPY(L)
5471 3700   CONTINUE
5472        CALL DOTPRO(V1,V2,K,B(I))
5473 3600 CONTINUE
5474C
5475C               *********************************
5476C               **  STEP 8--                   **
5477C               **  COMPUTE PREDICTED VALUES.  **
5478C               **  COMPUTE RESIDUALS.         **
5479C               *********************************
5480C
5481      ISTEPN='8'
5482      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5483     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5484C
5485      DO4100I=1,N
5486        DO4200L=1,K
5487          IL=(I-1)*K+L
5488          V1(L)=Z2(IL)
5489          V2(L)=B(L)
5490 4200   CONTINUE
5491        CALL DOTPRO(V1,V2,K,PRED2(I))
5492 4100 CONTINUE
5493C
5494      DO4600I=1,N
5495        RES2(I)=Y(I)-PRED2(I)
5496 4600 CONTINUE
5497C
5498C               ********************************************
5499C               **  STEP 9--                              **
5500C               **  COMPUTE RESIDUAL STANDARD DEVIATION.  **
5501C               ********************************************
5502C
5503      ISTEPN='9'
5504      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5505     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5506C
5507      SUM=0.0
5508      DO5100I=1,N
5509        SUM=SUM+RES2(I)**2
5510 5100 CONTINUE
5511      RESSS=SUM
5512      IRESDF=N-K
5513      RESDF=IRESDF
5514      IF(IRESDF.LE.0)THEN
5515        RESSS=0.0
5516        RESVAR=0.0
5517        RESSD=0.0
5518      ELSE
5519        RESVAR=RESSS/RESDF
5520        RESSD=0.0
5521        IF(RESVAR.GT.0.0)RESSD=SQRT(RESVAR)
5522      ENDIF
5523C
5524C               **************************************
5525C               **  STEP 10--                       **
5526C               **  COMPUTE THE COVARIANCE MATRIX   **
5527C               **  OF THE COEFFICIENTS.            **
5528C               **  COMPUTE THE CORRELATION MATRIX  **
5529C               **  OF THE COEFFICIENTS.            **
5530C               **************************************
5531C
5532      ISTEPN='10'
5533      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5534     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5535C
5536CCCCC DO6100I=1,K
5537CCCCC DO6200J=1,K
5538CCCCC COV(I,J)=SSQ(I,J)*RESSD*RESSD
5539C6200 CONTINUE
5540C6100 CONTINUE
5541C
5542CCCCC DO6600I=1,K
5543CCCCC DO6700J=1,K
5544CCCCC ANUM=SSQ(I,J)
5545CCCCC ADEN=SQRT(SSQ(I,I)*SSQ(J,J))
5546CCCCC CORR(I,J)=ANUM/ADEN
5547C6700 CONTINUE
5548C6600 CONTINUE
5549C
5550C               ***************************************************
5551C               **  STEP 11--                                    **
5552C               **  COMPUTE STANDARD DEVIATION OF COEFFICIENTS.  **
5553C               ***************************************************
5554C
5555      ISTEPN='11'
5556      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5557     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5558C
5559      DO7100I=1,K
5560        SDB(I)=0.0
5561        IF(SSQ(I,I).GT.0.0)SDB(I)=RESSD*SQRT(SSQ(I,I))
5562 7100 CONTINUE
5563C
5564      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5565        WRITE(ICOUT,999)
5566        CALL DPWRST('XXX','BUG ')
5567        WRITE(ICOUT,7205)RESSD
5568 7205   FORMAT('S = ',E15.7)
5569        CALL DPWRST('XXX','BUG ')
5570        WRITE(ICOUT,999)
5571        CALL DPWRST('XXX','BUG ')
5572        DO7210I=1,K
5573          WRITE(ICOUT,7211)I,B(I),SDB(I)
5574 7211     FORMAT('I, B(I), SDB(I) = ',I8,2E15.7)
5575          CALL DPWRST('XXX','BUG ')
5576 7210   CONTINUE
5577      ENDIF
5578C
5579C               ******************************************************
5580C               **  STEP 12--                                       **
5581C               **  COMPUTE COEFFICIENTS FOR THE SPLINE POLYNOMIAL  **
5582C               **  OVER EACH INDIVIDUAL REGION (BETWEEN KNOTS).    **
5583C               ******************************************************
5584C
5585      ISTEPN='12'
5586      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
5587     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5588C
5589C               ******************************************
5590C               **  STEP 12.1--                         **
5591C               **  LOOP THROUGH THE NKNOT+1 INTERVALS  **
5592C               ******************************************
5593C
5594      L3=0
5595      IKNMAX=NKNOT+1
5596      IMAX=IDEGRE+1
5597      DO8100IKN=1,IKNMAX
5598        IKN2=IKN+(IDEGRE+1)
5599        IKN2M1=IKN2-1
5600C
5601C               **************************************************
5602C               **  STEP 12.2--                                 **
5603C               **  FOR A GIVEN INTERVAL,                       **
5604C               **  FORM THE MATRIX OF COEFFICIENTS             **
5605C               **  FOR THE POLYNOMIALS IN THE INTERVAL         **
5606C               **  AND FOR THE DERIVATIVES OF THE POLYNOMIALS  **
5607C               **  WE ARE MERELY EXTRACTING COEFFICIENTS       **
5608C               **  OF POLYNOMIALS VIA DIFFERENTIATION.         **
5609C               **  EVALUATE THE DERIVATIVES AT THE MIDPOINTS   **
5610C               **  BETWEEN KNOTS.                              **
5611C               **************************************************
5612C
5613        DO8200I=1,IMAX
5614          IM1=I-1
5615          DO8300J=1,IMAX
5616            A(I,J)=0.0
5617            IF(I.GT.J)GOTO8300
5618            PROD=1.0
5619            IF(IM1.LT.1)GOTO8450
5620            AJ=J
5621            DO8400L=1,IM1
5622              AL=L
5623              PROD=PROD*(AJ-AL)
5624 8400       CONTINUE
5625C
5626 8450       CONTINUE
5627            CIJ=PROD
5628            XI=(EKNOT(IKN2)+EKNOT(IKN2M1))/2.0
5629            IF(I.EQ.J)DIJ=1.0
5630            IF(I.NE.J)DIJ=XI**(J-I)
5631            A(I,J)=CIJ*DIJ
5632 8300     CONTINUE
5633 8200   CONTINUE
5634C
5635        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5636          WRITE(ICOUT,8201)IKN
5637 8201     FORMAT('IN THE MIDDLE OF STEP 12 IN SPLINE. IKN = ',I8)
5638          CALL DPWRST('XXX','BUG ')
5639          WRITE(ICOUT,8202)
5640 8202     FORMAT('A(.,.) = ')
5641          CALL DPWRST('XXX','BUG ')
5642          IDEGP1=IDEGRE+1
5643          DO8210I=1,IDEGP1
5644            WRITE(ICOUT,8211)(A(I,J),J=1,IDEGP1)
5645 8211       FORMAT(8E15.7)
5646            CALL DPWRST('XXX','BUG ')
5647 8210     CONTINUE
5648        ENDIF
5649C
5650        I=IKN
5651CCCCC   XI=EKNOT(IKN2)
5652        XI=(EKNOT(IKN2)+EKNOT(IKN2M1))/2.0
5653C
5654C       IF I = 1, MAKE ALL EVALUATIONS BETWEEN KNOT 0 AND KNOT 1;
5655C       IF I = 2, MAKE ALL EVALUATIONS BETWEEN KNOT 1 AND KNOT 2;
5656C       IF I = 3, MAKE ALL EVALUATIONS BETWEEN KNOT 2 AND KNOT 3; ETC.
5657C
5658C               ********************************************************
5659C               **  STEP 12.3--                                       **
5660C               **  COMPUTE THE RIGHT SIDE OF THE MATRIX EQUATION.    **
5661C               **  COMPUTE PREDICTED VALUES AND DERIVATIES OF        **
5662C               **  PREDICTED VALUES AT SELECTED POINTS (HALF WAY     **
5663C               **  BETWEEN KNOTS).                                   **
5664C               ********************************************************
5665C
5666        IROWMX=IDEGRE+1
5667        DO8500IROW=1,IROWMX
5668C
5669C         IF IROW = 1, EVALUATE S(X);
5670C         IF IROW = 2, EVALUATE S'(X);
5671C         IF IROW = 3, EVALUATE S''(X); ETC.
5672C         FOR DEGREE K, STOP (INCLUSIVELY) AT THE K-TH DERIVATIVE.
5673C
5674          RIGHT(IROW)=0.0
5675          DO8600J=1,K
5676C
5677            LMAX=IDEGRE+J+1
5678            IF(XI.LT.EKNOT(J).OR.XI.GT.EKNOT(LMAX))GOTO8600
5679C
5680            SUM=0.0
5681            DO8700L=J,LMAX
5682              IF(XI.LE.EKNOT(L))GOTO8700
5683              EKNOL=EKNOT(L)
5684C
5685              PROD=1.0
5686              NUMTER=IROW-1
5687              IF(NUMTER.LT.1)GOTO8770
5688              DO8760L2=1,NUMTER
5689                AL2=L2
5690                PROD=PROD*(DEG-AL2+1.0)
5691 8760         CONTINUE
5692 8770       CONTINUE
5693            CIJ=PROD
5694            IPOWER=IDEGRE-(IROW-1)
5695            DPOWER=IPOWER
5696            DIJ=(XI-EKNOL)**DPOWER
5697            ANUM=CIJ*DIJ
5698C
5699            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5700              WRITE(ICOUT,8771)IROW,DEG,IPOWER,XI,CIJ,DIJ,ANUM
5701 8771         FORMAT('XI,IROW,DEG,IPOWER,XI,CIJ,DIJ,ANUM = ',I8,E15.7,
5702     1               I8,4E15.7)
5703              CALL DPWRST('XXX','BUG ')
5704            ENDIF
5705C
5706            PROD=1.0
5707            DO8800M=J,LMAX
5708              IF(M.EQ.L)GOTO8800
5709              EKNOL=EKNOT(L)
5710              EKNOM=EKNOT(M)
5711              PROD=PROD*(EKNOL-EKNOM)
5712 8800       CONTINUE
5713            ADEN=PROD
5714            RATIO=ANUM/ADEN
5715            SUM=SUM+RATIO
5716C
5717            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5718              WRITE(ICOUT,8811)ANUM,ADEN,RATIO,SUM
5719 8811         FORMAT('ANUM,ADEN,RATIO,SUM = ',4E15.8)
5720              CALL DPWRST('XXX','BUG ')
5721            ENDIF
5722C
5723 8700     CONTINUE
5724C
5725          RIGHT(IROW)=RIGHT(IROW)+B(J)*SUM
5726C
5727          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5728            WRITE(ICOUT,8812)IROW,J,RIGHT(IROW),B(J),SUM
5729 8812       FORMAT('IROW,J,RIGHT(IROW),B(J),SUM = ',2I8,3E15.7)
5730            CALL DPWRST('XXX','BUG ')
5731            WRITE(ICOUT,8812)IROW,J,RIGHT(IROW),B(J),SUM
5732            CALL DPWRST('XXX','BUG ')
5733          ENDIF
5734C
5735 8600   CONTINUE
5736 8500 CONTINUE
5737C
5738      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
5739        WRITE(ICOUT,8901)
5740 8901   FORMAT('AFTER STEP 12 IN DPSPL2--')
5741        CALL DPWRST('XXX','BUG ')
5742        WRITE(ICOUT,8902)
5743 8902   FORMAT('A(.,.), RIGHT(.) = ')
5744        CALL DPWRST('XXX','BUG ')
5745        DO8910I=1,IDEGP1
5746          WRITE(ICOUT,8911) (A(I,J),J=1,IDEGP1),RIGHT(I)
5747 8911     FORMAT(8E15.7)
5748          CALL DPWRST('XXX','BUG ')
5749 8910   CONTINUE
5750      ENDIF
5751C
5752      IDEGP1=IDEGRE+1
5753      CALL BACK50(A,IDEGP1,IDEGP1,RIGHT,BTEMP,IBUGA3)
5754C
5755      DO8950I=1,IDEGP1
5756        L3=L3+1
5757        B2(L3)=BTEMP(I)
5758 8950 CONTINUE
5759C
5760 8100 CONTINUE
5761      K2=L3
5762C
5763C               *********************************************
5764C               **  STEP 13--                              **
5765C               **  PRINT OUT GOODNESS OF FIT INFORMATION  **
5766C               *********************************************
5767C
5768      IFITDF=IRESDF-IREPDF
5769      IF(IREP.EQ.'YES')THEN
5770        FITDF=IFITDF
5771        FITSS=RESSS-REPSS
5772        FITMS=FITSS/FITDF
5773        FSTAT=FITMS/REPMS
5774        CALL FCDF(FSTAT,IFITDF,IREPDF,CDF)
5775        CDF2=100.0*CDF
5776CCCCC   THE FOLLOWING LINE WAS INSERTED MARCH 1988.
5777        ALFCDF=CDF
5778      ENDIF
5779C
5780      IF(IPRINT.EQ.'ON')THEN
5781        ITITLE='Least Squares Spline Fit'
5782        NCTITL=24
5783        ITITLZ=' '
5784        NCTITZ=0
5785C
5786        ICNT=1
5787        IF(IDEGRE.EQ.1)THEN
5788          ITEXT(ICNT)='Model--Linear Spline'
5789          NCTEXT(ICNT)=20
5790        ELSEIF(IDEGRE.EQ.2)THEN
5791          ITEXT(ICNT)='Model--Quadratic Spline'
5792          NCTEXT(ICNT)=23
5793        ELSEIF(IDEGRE.EQ.3)THEN
5794          ITEXT(ICNT)='Model--Cubic Spline'
5795          NCTEXT(ICNT)=19
5796        ELSEIF(IDEGRE.EQ.4)THEN
5797          ITEXT(ICNT)='Model--4-th Degree Spline'
5798          NCTEXT(ICNT)=25
5799        ELSEIF(IDEGRE.EQ.5)THEN
5800          ITEXT(ICNT)='Model--5-th Degree Spline'
5801          NCTEXT(ICNT)=25
5802        ELSEIF(IDEGRE.EQ.6)THEN
5803          ITEXT(ICNT)='Model--6-th Degree Spline'
5804          NCTEXT(ICNT)=25
5805        ELSEIF(IDEGRE.EQ.7)THEN
5806          ITEXT(ICNT)='Model--7-th Degree Spline'
5807          NCTEXT(ICNT)=25
5808        ELSEIF(IDEGRE.EQ.8)THEN
5809          ITEXT(ICNT)='Model--8-th Degree Spline'
5810          NCTEXT(ICNT)=25
5811        ELSEIF(IDEGRE.EQ.9)THEN
5812          ITEXT(ICNT)='Model--9-th Degree Spline'
5813          NCTEXT(ICNT)=25
5814        ELSEIF(IDEGRE.EQ.10)THEN
5815          ITEXT(ICNT)='Model--10-th Degree Spline'
5816          NCTEXT(ICNT)=26
5817        ENDIF
5818        AVALUE(ICNT)=0.0
5819        IDIGIT(ICNT)=-1
5820C
5821        ICNT=ICNT+1
5822        ITEXT(ICNT)='Sample Size:'
5823        NCTEXT(ICNT)=12
5824        AVALUE(ICNT)=REAL(N)
5825        IDIGIT(ICNT)=0
5826        ICNT=ICNT+1
5827        ITEXT(ICNT)='Number of Knots:'
5828        NCTEXT(ICNT)=16
5829        AVALUE(ICNT)=REAL(NKNOT)
5830        IDIGIT(ICNT)=0
5831        ICNT=ICNT+1
5832        ITEXT(ICNT)=' '
5833        NCTEXT(ICNT)=0
5834        AVALUE(ICNT)=0.0
5835        IDIGIT(ICNT)=-1
5836C
5837        ICNT=ICNT+1
5838        ITEXT(ICNT)='Residual Standard Deviation:'
5839        NCTEXT(ICNT)=28
5840        AVALUE(ICNT)=RESSD
5841        IDIGIT(ICNT)=NUMDIG
5842        ICNT=ICNT+1
5843        ITEXT(ICNT)='Residual Degrees of Freedom:'
5844        NCTEXT(ICNT)=28
5845        AVALUE(ICNT)=REAL(IRESDF)
5846        IDIGIT(ICNT)=0
5847C
5848        IF(IREP.EQ.'NO')THEN
5849          ICNT=ICNT+1
5850          ITEXT(ICNT)=' '
5851          NCTEXT(ICNT)=0
5852          AVALUE(ICNT)=0.0
5853          IDIGIT(ICNT)=-1
5854          ICNT=ICNT+1
5855          ITEXT(ICNT)='No Replication Case'
5856          NCTEXT(ICNT)=19
5857          AVALUE(ICNT)=0.0
5858          IDIGIT(ICNT)=-1
5859        ELSEIF(IREP.EQ.'YES')THEN
5860          ICNT=ICNT+1
5861          ITEXT(ICNT)='Replication Standard Deviation:'
5862          NCTEXT(ICNT)=31
5863          AVALUE(ICNT)=REPSD
5864          IDIGIT(ICNT)=NUMDIG
5865          ICNT=ICNT+1
5866          ITEXT(ICNT)='Replication Degrees of Freedom:'
5867          NCTEXT(ICNT)=31
5868          AVALUE(ICNT)=REAL(IREPDF)
5869          IDIGIT(ICNT)=0
5870          ICNT=ICNT+1
5871          ITEXT(ICNT)='Number of Distinct Subsets:'
5872          NCTEXT(ICNT)=27
5873          AVALUE(ICNT)=REAL(NUMSET)
5874          IDIGIT(ICNT)=0
5875C
5876          IFITDF=IRESDF-IREPDF
5877          IF(IFITDF.LT.1)THEN
5878            ICNT=ICNT+1
5879            ITEXT(ICNT)='The Lack of Fit F Test cannot be done'
5880            NCTEXT(ICNT)=37
5881            AVALUE(ICNT)=0.0
5882            IDIGIT(ICNT)=-1
5883            ICNT=ICNT+1
5884            ITEXT(ICNT)='because there are 0 degrees of freedom'
5885            NCTEXT(ICNT)=38
5886            AVALUE(ICNT)=0.0
5887            IDIGIT(ICNT)=-1
5888            ICNT=ICNT+1
5889            ITEXT(ICNT)='in the numerator of the F ratio.  This'
5890            NCTEXT(ICNT)=38
5891            AVALUE(ICNT)=0.0
5892            IDIGIT(ICNT)=-1
5893            ICNT=ICNT+1
5894            ITEXT(ICNT)='This happens when the number of'
5895            NCTEXT(ICNT)=31
5896            AVALUE(ICNT)=0.0
5897            IDIGIT(ICNT)=-1
5898            ICNT=ICNT+1
5899            ITEXT(ICNT)='parameters fitted is identical to the'
5900            NCTEXT(ICNT)=37
5901            AVALUE(ICNT)=0.0
5902            IDIGIT(ICNT)=-1
5903            ICNT=ICNT+1
5904            ITEXT(ICNT)='number of distinct subsets.'
5905            NCTEXT(ICNT)=27
5906            AVALUE(ICNT)=0.0
5907            IDIGIT(ICNT)=-1
5908          ELSE
5909            ICNT=ICNT+1
5910            ITEXT(ICNT)='Lack of Fit F Ratio:'
5911            NCTEXT(ICNT)=20
5912            AVALUE(ICNT)=FSTAT
5913            IDIGIT(ICNT)=NUMDIG
5914            ICNT=ICNT+1
5915            ITEXT(ICNT)='Lack of Fit F CDF (%):'
5916            NCTEXT(ICNT)=22
5917            AVALUE(ICNT)=CDF2
5918            IDIGIT(ICNT)=NUMDIG
5919            ICNT=ICNT+1
5920            ITEXT(ICNT)='Lack of Fit Degrees of Freedom 1:'
5921            NCTEXT(ICNT)=33
5922            AVALUE(ICNT)=REAL(IFITDF)
5923            IDIGIT(ICNT)=0
5924            ICNT=ICNT+1
5925            ITEXT(ICNT)='Lack of Fit Degrees of Freedom 2:'
5926            NCTEXT(ICNT)=33
5927            AVALUE(ICNT)=REAL(IREPDF)
5928            IDIGIT(ICNT)=0
5929          ENDIF
5930        ENDIF
5931C
5932        NUMROW=ICNT
5933        DO5410I=1,NUMROW
5934          NTOT(I)=15
5935 5410   CONTINUE
5936C
5937        IFRST=.TRUE.
5938        ILAST=.TRUE.
5939        CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,
5940     1              NCTEXT,AVALUE,IDIGIT,
5941     1              NTOT,NUMROW,
5942     1              ICAPSW,ICAPTY,ILAST,IFRST,
5943     1              ISUBRO,IBUGA3,IERROR)
5944C
5945        ITITLE=' '
5946        NCTITL=0
5947        ITITL9='Intervals'
5948        NCTIT9=9
5949C
5950        ITITL2(1,1)=' '
5951        NCTIT2(1,1)=0
5952        ITITL2(1,2)=' '
5953        NCTIT2(1,2)=0
5954        ITITL2(1,3)=' '
5955        NCTIT2(1,3)=0
5956        ITITL2(1,4)='Number of'
5957        NCTIT2(1,4)=9
5958C
5959        ITITL2(2,1)='Interval'
5960        NCTIT2(2,1)=8
5961        ITITL2(2,2)='Lower'
5962        NCTIT2(2,2)=5
5963        ITITL2(2,3)='Upper'
5964        NCTIT2(2,3)=5
5965        ITITL2(2,4)='Observations'
5966        NCTIT2(2,4)=12
5967C
5968        ITITL2(3,1)='Number'
5969        NCTIT2(3,1)=6
5970        ITITL2(3,2)='Knot'
5971        NCTIT2(3,2)=4
5972        ITITL2(3,3)='Knot'
5973        NCTIT2(3,3)=4
5974        ITITL2(3,4)='in Interval'
5975        NCTIT2(3,4)=11
5976C
5977        NMAX=0
5978        NUMCOL=4
5979        DO4210I=1,NUMCOL
5980          VALIGN(I)='b'
5981          ALIGN(I)='r'
5982          NTOT(I)=15
5983          IF(I.EQ.1)NTOT(I)=12
5984          NMAX=NMAX+NTOT(I)
5985          DO4211J=1,MAXROW
5986            ITYPCO(J,I)='NUME'
5987 4211     CONTINUE
5988          IDIGIT(I)=NUMDIG
5989          IF(I.EQ.1)THEN
5990            IDIGIT(I)=0
5991          ELSEIF(I.EQ.4)THEN
5992            IDIGIT(I)=0
5993          ENDIF
5994          IWHTML(1)=125
5995          IWHTML(2)=150
5996          IWHTML(3)=150
5997          IWHTML(4)=150
5998          IINC=1400
5999          IINC3=2200
6000          IWRTF(1)=IINC
6001          IWRTF(2)=IWRTF(1)+IINC3
6002          IWRTF(3)=IWRTF(2)+IINC3
6003          IWRTF(4)=IWRTF(3)+IINC3
6004 4210   CONTINUE
6005C
6006        L=1
6007        ISUM=0
6008        DO1100I=1,N
6009          IF(X(I).LT.XKNOT(1))ISUM=ISUM+1
6010 1100   CONTINUE
6011C
6012        ITYPCO(1,2)='ALPH'
6013        AMAT(L,1)=REAL(L)
6014        AMAT(L,2)=0.0
6015        AMAT(L,3)=XKNOT(L)
6016        AMAT(L,4)=REAL(ISUM)
6017        IVALUE(L,1)=' '
6018        NCVALU(L,1)=0
6019        IVALUE(L,2)='-Infinity'
6020        NCVALU(L,2)=9
6021        IVALUE(L,3)=' '
6022        NCVALU(L,3)=0
6023        IVALUE(L,4)=' '
6024        NCVALU(L,4)=0
6025C
6026        IF(NKNOT.GE.2)THEN
6027          DO1200L=2,NKNOT
6028            LM1=L-1
6029            ISUM=0
6030            DO1300I=1,N
6031              IF(XKNOT(LM1).LE.X(I).AND.X(I).LT.XKNOT(L))ISUM=ISUM+1
6032 1300       CONTINUE
6033            ITYPCO(L,2)='NUME'
6034            AMAT(L,1)=REAL(L)
6035            AMAT(L,2)=XKNOT(LM1)
6036            AMAT(L,3)=XKNOT(L)
6037            AMAT(L,4)=REAL(ISUM)
6038            IVALUE(L,1)=' '
6039            NCVALU(L,1)=0
6040            IVALUE(L,2)=' '
6041            NCVALU(L,2)=0
6042            IVALUE(L,3)=' '
6043            NCVALU(L,3)=0
6044            IVALUE(L,4)=' '
6045            NCVALU(L,4)=0
6046 1200     CONTINUE
6047        ENDIF
6048C
6049        L=NKNOT+1
6050        ISUM=0
6051        DO1400I=1,N
6052          IF(XKNOT(NKNOT).LE.X(I))ISUM=ISUM+1
6053 1400   CONTINUE
6054C
6055        ITYPCO(L,2)='NUME'
6056        ITYPCO(L,3)='ALPH'
6057        AMAT(L,1)=REAL(L)
6058        AMAT(L,2)=XKNOT(NKNOT)
6059        AMAT(L,3)=0.0
6060        AMAT(L,4)=REAL(ISUM)
6061        IVALUE(L,1)=' '
6062        NCVALU(L,1)=0
6063        IVALUE(L,2)=' '
6064        NCVALU(L,2)=0
6065        IVALUE(L,3)='+Infinity'
6066        NCVALU(L,3)=9
6067        IVALUE(L,4)=' '
6068        NCVALU(L,4)=0
6069C
6070        ICNT=L
6071        NUMLIN=3
6072        NUMCOL=4
6073        IFRST=.TRUE.
6074        ILAST=.TRUE.
6075        IFLAGS=.TRUE.
6076        IFLAGE=.TRUE.
6077        CALL DPDT5C(ITITLE,NCTITL,
6078     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
6079     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
6080     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
6081     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
6082     1              ICAPSW,ICAPTY,IFRST,ILAST,
6083     1              IFLAGS,IFLAGE,
6084     1              ISUBRO,IBUGA3,IERROR)
6085C
6086C       **********************************
6087C       **  STEP 14--                   **
6088C       **  WRITE OUT THE COEFFICIENTS  **
6089C       **********************************
6090C
6091        ISTEPN='13'
6092        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SPL2')
6093     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6094C
6095        IBUGJU='OFF'
6096C
6097        ITITLE=' '
6098        NCTITL=0
6099        ITITL9='Estimation'
6100        NCTIT9=10
6101C
6102        ITITL2(1,1)='Interval'
6103        NCTIT2(1,1)=8
6104        NCOLSP(1,1)=1
6105        ITITL2(1,2)='Parameter'
6106        NCTIT2(1,2)=9
6107        NCOLSP(1,2)=1
6108        ITITL2(1,3)='Estimate'
6109        NCTIT2(1,3)=8
6110        NCOLSP(1,3)=1
6111C
6112        NMAX=0
6113        NUMCOL=3
6114        DO5210I=1,NUMCOL
6115          VALIGN(I)='b'
6116          ALIGN(I)='r'
6117          NTOT(I)=15
6118          IF(I.EQ.1)NTOT(I)=12
6119          NMAX=NMAX+NTOT(I)
6120          ITYPC2(I)='NUME'
6121          IF(I.EQ.2)ITYPC2(I)='ALPH'
6122          IWHTML(1)=125
6123          IWHTML(2)=150
6124          IWHTML(3)=150
6125          IINC=1400
6126          IINC3=2200
6127          IWRTF(1)=IINC
6128          IWRTF(2)=IWRTF(1)+IINC3
6129          IWRTF(3)=IWRTF(2)+IINC3
6130 5210   CONTINUE
6131C
6132        NUMLIN=1
6133        NUMCOL=3
6134        ICNT2=0
6135        L=0
6136        IKNMAX=NKNOT+1
6137        JMAX=IDEGRE+1
6138        DO7500IKN=1,IKNMAX
6139C
6140          IF(L+JMAX+1.GT.MAXROW)THEN
6141            IFRST=.TRUE.
6142            ILAST=.TRUE.
6143            IFLAGS=.TRUE.
6144            IF(ICNT2.GT.0)IFLAGS=.FALSE.
6145            IFLAGE=.TRUE.
6146            ICNT=L
6147            CALL DPDT5B(ITITLE,NCTITL,
6148     1                  ITITL9,NCTIT9,ITITL2,NCTIT2,
6149     1                  MAXLIN,NUMLIN,NUMCLI,NUMCOL,
6150     1                  IVALUE,NCVALU,AMAT,ITYPC2,MAXROW,ICNT,
6151     1                  IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
6152     1                  NCOLSP,ROWSEP,
6153     1                  ICAPSW,ICAPTY,IFRST,ILAST,
6154     1                  IFLAGS,IFLAGE,
6155     1                  ISUBRO,IBUGA3,IERROR)
6156          ENDIF
6157C
6158          DO7600J=1,JMAX
6159            L=L+1
6160            JM1=J-1
6161            CALL COENAM(IKN,JM1,IH,IH2,IBUGJU,IERROR)
6162            AMAT(L,1)=REAL(IKN)
6163            AMAT(L,2)=0.0
6164            AMAT(L,3)=B2(L)
6165            IVALUE(L,1)=' '
6166            NCVALU(L,1)=0
6167            IVALUE(L,2)(1:4)=IH(1:4)
6168            IVALUE(L,2)(5:8)=IH2(1:4)
6169            NCVALU(L,2)=8
6170            IVALUE(L,3)=' '
6171            NCVALU(L,3)=0
6172            IDIGI2(L,1)=0
6173            IDIGI2(L,2)=0
6174            IDIGI2(L,3)=NUMDIG
6175            ROWSEP(L)=0
6176 7600     CONTINUE
6177          L=L+1
6178          ROWSEP(L)=0
6179          DO7620JJ=1,3
6180            AMAT(L,JJ)=0.0
6181            IVALUE(L,JJ)=' '
6182            NCVALU(L,JJ)=0
6183            IDIGI2(L,JJ)=-1
6184 7620     CONTINUE
6185 7500   CONTINUE
6186C
6187        ICNT=L
6188        IF(ICNT.GT.0)THEN
6189          IFRST=.TRUE.
6190          ILAST=.TRUE.
6191          IFLAGS=.TRUE.
6192          IF(ICNT2.GT.0)IFLAGS=.FALSE.
6193          IFLAGE=.TRUE.
6194          CALL DPDT5B(ITITLE,NCTITL,
6195     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
6196     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
6197     1                IVALUE,NCVALU,AMAT,ITYPC2,MAXROW,ICNT,
6198     1                IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
6199     1                NCOLSP,ROWSEP,
6200     1                ICAPSW,ICAPTY,IFRST,ILAST,
6201     1                IFLAGS,IFLAGE,
6202     1                ISUBRO,IBUGA3,IERROR)
6203        ENDIF
6204      ENDIF
6205C
6206C               *****************
6207C               **  STEP 90--  **
6208C               **  EXIT       **
6209C               *****************
6210C
6211 9000 CONTINUE
6212      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SPL2')THEN
6213        WRITE(ICOUT,999)
6214        CALL DPWRST('XXX','BUG ')
6215        WRITE(ICOUT,9011)
6216 9011   FORMAT('***** AT THE END       OF DPSPL2--')
6217        CALL DPWRST('XXX','BUG ')
6218        WRITE(ICOUT,9013)IERROR,N,NKNOT,IDEGRE,K2
6219 9013   FORMAT('IERROR,N,NKNOT,IDEGRE,K2 = ',A4,2X,4I8)
6220        CALL DPWRST('XXX','BUG ')
6221        DO9015I=1,K2
6222          WRITE(ICOUT,9016)I,B2(I),SDB2(I)
6223 9016     FORMAT('I,B2(I),SDB2(I) = ',I8,2G15.7)
6224          CALL DPWRST('XXX','BUG ')
6225 9015   CONTINUE
6226        WRITE(ICOUT,9021)IREP,NUMVAR
6227 9021   FORMAT('IREP,NUMVAR = ',A4,2X,I8)
6228        CALL DPWRST('XXX','BUG ')
6229        WRITE(ICOUT,9023)REPSS,REPMS,REPSD,REPDF,NUMSET
6230 9023   FORMAT('REPSS,REPMS,REPSD,REPDF,NUMSET = ',4G15.7,I8)
6231        CALL DPWRST('XXX','BUG ')
6232        DO9025I=1,N
6233          WRITE(ICOUT,9026)I,Y(I),X(I),W(I),PRED2(I),RES2(I)
6234 9026     FORMAT('I,Y(I),X(I),W(I),PRED2(I),RES2(I) = ',I8,5G15.7)
6235          CALL DPWRST('XXX','BUG ')
6236 9025   CONTINUE
6237      ENDIF
6238C
6239      RETURN
6240      END
6241      SUBROUTINE DPSPLC(IANS,IWIDTH,ITERCH,
6242     1IANSV,IWIDSV,IBUGGC,IERROR)
6243C
6244C     PURPOSE--SEARCH THE VECTOR IANS(.) FOR THE
6245C              SEPARATOR CHARACTOR.
6246C              REFORM IANS(.) AND IWIDTH BY OMITTING
6247C              FROM IANS(.) ALL CHARACTERS
6248C              FROM THE FIRST SEPARATOR CHARACTOR TO THE END
6249C              (THE SEPARATOR CHARACTOR ITSELF WILL BE OMITTED).
6250C              FORM IANSV(.) AND IWIDSV BY
6251C              SAVING ALL CHARACTERS IN THE ORIGINAL IANS(.)
6252C              AFTER THE FIRST SEPARATOR CHARACTOR.
6253C              THE ORIGINAL COMMAND LINE HAS THUS BEEN SPLIT INTO
6254C              2 PARTS WITH THE FIRST SEPARATOR CHARACTOR AS THE PARTITION.
6255C              THE FIRST PART WILL REMAIN IN IANS(.);
6256C              THE SECOND PART WILL BE SAVED IN IANSV(.).
6257C     NOTE--IANS AND IWIDTH ARE BOTH INPUT AND OUTPUT ARGUMENTS.
6258C           THE INPUT ARGUMENTS IANS AND IWIDTH BOTH GET CHANGED
6259C           DURING THE EXECUTION OF THIS SUBROUTINE.
6260C     INPUT  ARGUMENTS--IANS   (A  HOLLERITH VECTOR WHOSE
6261C                              I-TH ELEMENT CONTAINS THE
6262C                              I-TH CHARACTER OF THE
6263C                              ORIGINAL INPUT COMMAND LINE.
6264C                     --IWIDTH (AN INTEGER VARIABLE WHICH
6265C                              CONTAINS THE NUMBER OF CHARACTERS
6266C                              IN THE ORIGINAL COMMAND LINE.
6267C                     --ITERCH (A  HOLLERITH VARIABLE WHICH
6268C                              CONTAINS THE TERMINATORCHARACTER.
6269C     OUTPUT ARGUMENTS--IANS   (A  HOLLERITH VECTOR WHOSE
6270C                              I-TH ELEMENT CONTAINS THE
6271C                              I-TH CHARACTER OF THE
6272C                              FIRST PART OF THE ORIGINAL COMMAND LINE
6273C                              (UP TO BUT EXCLUDING THE TERMINATORCHARACTOR).
6274C                     --IWIDTH (AN INTEGER VARIABLE WHICH
6275C                              CONTAINS THE NUMBER OF CHARACTERS
6276C                              IN THE FIRST PART OF THE ORIGINAL COMMAND LINE.
6277C                     --IANSV  (A  HOLLERITH VECTOR WHOSE
6278C                              I-TH ELEMENT CONTAINS THE
6279C                              I-TH CHARACTER OF THE
6280C                              SECOND PART OF THE COMMAND LINE
6281C                              (STARTING WITH THE CHARACTER AFTER
6282C                              THE TERMINATORCHARACTER).
6283C                     --IWIDSV (AN INTEGER VARIABLE WHICH
6284C                              CONTAINS THE NUMBER OF CHARACTERS
6285C                              IN THE SECOND PART OF THE ORIGINAL COMMAND LINE.
6286C                     --IBUGGC   (A HOLLERITH VARIABLE
6287C                              FOR DEBUGGING
6288C                     --IERROR ('YES' OR 'NO' )
6289C     WRITTEN BY--JAMES J. FILLIBEN
6290C                 STATISTICAL ENGINEERING DIVISION
6291C                 INFORMATION TECHNOLOGY LABORATORY
6292C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6293C                 GAITHERSBURG, MD 20899-8980
6294C                 PHONE--301-975-2855
6295C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6296C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6297C     LANGUAGE--ANSI FORTRAN (1977)
6298C     VERSION NUMBER--82/7
6299C     ORIGINAL VERSION--NOVEMBER  1980.
6300C     UPDATED         --MAY       1982.
6301C
6302C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6303C
6304      CHARACTER*4 IANS
6305      CHARACTER*4 ITERCH
6306      CHARACTER*4 IANSV
6307      CHARACTER*4 IBUGGC
6308      CHARACTER*4 IERROR
6309C
6310      CHARACTER*4 IBLANK
6311C
6312C---------------------------------------------------------------------
6313C
6314      DIMENSION IANS(*)
6315      DIMENSION IANSV(*)
6316C
6317C-----COMMON----------------------------------------------------------
6318C
6319      INCLUDE 'DPCOP2.INC'
6320C
6321C-----START POINT-----------------------------------------------------
6322C
6323      IERROR='NO'
6324C
6325      IF(IBUGGC.EQ.'ON')THEN
6326        WRITE(ICOUT,999)
6327  999   FORMAT(1X)
6328        CALL DPWRST('XXX','BUG ')
6329        WRITE(ICOUT,101)
6330  101   FORMAT('AT THE BEGINNING OF DPSPLC--')
6331        CALL DPWRST('XXX','BUG ')
6332        WRITE(ICOUT,102)(IANS(I),I=1,MIN(120,IWIDTH))
6333  102   FORMAT('IANS(.) = ',120A1)
6334        CALL DPWRST('XXX','BUG ')
6335        WRITE(ICOUT,103)IWIDTH,IWIDSV,ITERCH
6336  103   FORMAT('IWIDTH,IWIDSV,ITERCH = ',2I8,2X,A4)
6337        CALL DPWRST('XXX','BUG ')
6338        WRITE(ICOUT,105)(IANSV(I),I=1,MIN(120,IWIDSV))
6339  105   FORMAT('IANSV(.) = ',120A1)
6340        CALL DPWRST('XXX','BUG ')
6341      ENDIF
6342C
6343C               *************************************
6344C               **  STEP 1--                       **
6345C               **  TRIM THE VALUE OF IWIDTH       **
6346C               **  BY IGNORING BLANKS ON THE END  **
6347C               **  OF IANS(.)                     **
6348C               *************************************
6349C
6350      DO150I=1,IWIDTH
6351      IREV=IWIDTH-I+1
6352      IF(IANS(IREV).NE.' ')GOTO160
6353  150 CONTINUE
6354      IWIDTH=0
6355      IWIDSV=0
6356      GOTO900
6357  160 CONTINUE
6358      IWIDTH=IREV
6359C
6360C               *************************************
6361C               **  STEP 2--                       **
6362C               **  BLANK OUT THE IANSV(.) VECTOR. **
6363C               **  NOTE THAT THIS NEED ONLY BE    **
6364C               **  DONE OUT TO IWIDTH ELEMENTS    **
6365C               **  SINCE IANSV(.) WILL NEVER      **
6366C               **  BE LARGER THAN IANS(.)         **
6367C               *************************************
6368C
6369      IBLANK=' '
6370      DO200I=1,IWIDTH
6371      IANSV(I)=IBLANK
6372  200 CONTINUE
6373C
6374C               **********************************
6375C               **  STEP 3--                    **
6376C               **  SCAN THE IANS(.) VECTOR TO  **
6377C               **  SEARCH FOR THE TERMINATOR   **
6378C               **********************************
6379C
6380      DO300I=1,IWIDTH
6381      ILOCSP=I
6382      IF(IANS(I).EQ.ITERCH)GOTO390
6383  300 CONTINUE
6384      ILOCSP=IWIDTH+1
6385  390 CONTINUE
6386C
6387C               ***********************************
6388C               **  STEP 4--                     **
6389C               **  COMPUTE IANSV(.) AND IWIDSV  **
6390C               ***********************************
6391C
6392      J=0
6393      IMIN=ILOCSP+1
6394      IMAX=IWIDTH
6395      IF(IMIN.GT.IMAX)GOTO450
6396      DO400I=IMIN,IMAX
6397      J=J+1
6398      IANSV(J)=IANS(I)
6399  400 CONTINUE
6400  450 CONTINUE
6401      IWIDSV=J
6402C
6403C               *****************************************************
6404C               **  STEP 5--                                       **
6405C               **  RECOMPUTE THE VALUE OF IWIDTH--                **
6406C               **  FIRST BY DEFINING IT TO BE                     **
6407C               **  IMMEDIATELY BEFORE THE TERMINATOR CHARACTOR,   **
6408C               **  AND THEN TRIMMING IT FURTHER BY                **
6409C               **  IGNORING ANY BLANKS AT THE NEW END OF IANS(.)  **
6410C               *****************************************************
6411C
6412      IWIDTH=ILOCSP-1
6413C
6414      DO510I=1,IWIDTH
6415        IREV=IWIDTH-I+1
6416        IF(IANS(IREV).NE.' ')GOTO520
6417  510 CONTINUE
6418      IREV=0
6419  520 CONTINUE
6420      IWIDTH=IREV
6421C
6422C               ****************
6423C               **  STEP 9--  **
6424C               **  EXIT      **
6425C               ****************
6426C
6427  900 CONTINUE
6428      IF(IBUGGC.EQ.'ON')THEN
6429        WRITE(ICOUT,999)
6430        CALL DPWRST('XXX','BUG ')
6431        WRITE(ICOUT,901)
6432  901   FORMAT('AT THE END OF DPSPLC--')
6433        CALL DPWRST('XXX','BUG ')
6434        WRITE(ICOUT,902)(IANS(I),I=1,MIN(120,IWIDTH))
6435  902   FORMAT('IANS(.) = ',120A1)
6436        CALL DPWRST('XXX','BUG ')
6437        WRITE(ICOUT,903)IWIDTH,IWIDSV,ITERCH
6438  903   FORMAT('IWIDTH,IWIDSV,ITERCH = ',2I8,2X,A4)
6439        CALL DPWRST('XXX','BUG ')
6440        WRITE(ICOUT,905)(IANSV(I),I=1,MIN(120,IWIDSV))
6441  905   FORMAT('IANSV(.) = ',120A1)
6442        CALL DPWRST('XXX','BUG ')
6443      ENDIF
6444C
6445      RETURN
6446      END
6447      SUBROUTINE DPSPLI(IHARG,IHARG2,NUMARG,IDEFSL,MAXSPI,ISPILI,
6448CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
6449CCCCC SUBROUTINE DPSPLI(IHARG,NUMARG,IDEFSL,MAXSPI,ISPILI,
6450     1IBUGP2,IFOUND,IERROR)
6451C
6452C     PURPOSE--DEFINE THE SPIKE LINE TYPES.
6453C              THESE ARE LOCATED IN THE VECTOR ISPILI(.).
6454C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
6455C                     --NUMARG
6456C                     --IDEFSL
6457C                     --MAXSPI
6458C                     --IBUGP2 ('ON' OR 'OFF' )
6459C     OUTPUT ARGUMENTS--ISPILI (A CHARACTER VECTOR)
6460C                     --IFOUND ('YES' OR 'NO' )
6461C                     --IERROR ('YES' OR 'NO' )
6462C     WRITTEN BY--JAMES J. FILLIBEN
6463C                 STATISTICAL ENGINEERING DIVISION
6464C                 INFORMATION TECHNOLOGY LABORATORY
6465C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6466C                 GAITHERSBURG, MD 20899-8980
6467C                 PHONE--301-975-2855
6468C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6469C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6470C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
6471C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
6472C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
6473C     LANGUAGE--ANSI FORTRAN (1977)
6474C     VERSION NUMBER--82/7
6475C     ORIGINAL VERSION--DECEMBER  1983.
6476C     UPDATED         --AUGUST    1995.  DASH2 BUG
6477C
6478C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6479C
6480      CHARACTER*4 IHARG
6481CCCCC AUGUST 1995.  ADD FOLLOWING LINE
6482      CHARACTER*4 IHARG2
6483      CHARACTER*4 IDEFSL
6484      CHARACTER*4 ISPILI
6485C
6486      CHARACTER*4 IBUGP2
6487      CHARACTER*4 IFOUND
6488      CHARACTER*4 IERROR
6489C
6490      CHARACTER*4 IHOLD1
6491      CHARACTER*4 IHOLD2
6492C
6493      CHARACTER*4 ISUBN1
6494      CHARACTER*4 ISUBN2
6495      CHARACTER*4 ISTEPN
6496C
6497      DIMENSION IHARG(*)
6498CCCCC AUGUST 1995.  ADD FOLLOWING LINE
6499      DIMENSION IHARG2(*)
6500      DIMENSION ISPILI(*)
6501C
6502C-----COMMON----------------------------------------------------------
6503C
6504      INCLUDE 'DPCOP2.INC'
6505C
6506C-----START POINT-----------------------------------------------------
6507C
6508      IFOUND='NO'
6509      IERROR='NO'
6510      ISUBN1='DPSP'
6511      ISUBN2='LI  '
6512C
6513      NUMSPI=0
6514      IHOLD1='-999'
6515      IHOLD2='-999'
6516C
6517      IF(IBUGP2.EQ.'OFF')GOTO90
6518      WRITE(ICOUT,999)
6519  999 FORMAT(1X)
6520      CALL DPWRST('XXX','BUG ')
6521      WRITE(ICOUT,51)
6522   51 FORMAT('***** AT THE BEGINNING OF DPSPLI--')
6523      CALL DPWRST('XXX','BUG ')
6524      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
6525   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
6526      CALL DPWRST('XXX','BUG ')
6527      WRITE(ICOUT,53)MAXSPI,NUMSPI
6528   53 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
6529      CALL DPWRST('XXX','BUG ')
6530      WRITE(ICOUT,54)IHOLD1,IHOLD2
6531   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
6532      CALL DPWRST('XXX','BUG ')
6533      WRITE(ICOUT,55)IDEFSL
6534   55 FORMAT('IDEFSL = ',A4)
6535      CALL DPWRST('XXX','BUG ')
6536      WRITE(ICOUT,60)NUMARG
6537   60 FORMAT('NUMARG = ',I8)
6538      CALL DPWRST('XXX','BUG ')
6539      DO65I=1,NUMARG
6540      WRITE(ICOUT,66)IHARG(I)
6541   66 FORMAT('IHARG(I) = ',A4)
6542      CALL DPWRST('XXX','BUG ')
6543   65 CONTINUE
6544      WRITE(ICOUT,70)ISPILI(1)
6545   70 FORMAT('ISPILI(1) = ',A4)
6546      CALL DPWRST('XXX','BUG ')
6547      DO75I=1,10
6548      WRITE(ICOUT,76)I,ISPILI(I)
6549   76 FORMAT('I,ISPILI(I) = ',I8,2X,A4)
6550      CALL DPWRST('XXX','BUG ')
6551   75 CONTINUE
6552   90 CONTINUE
6553C
6554C               **************************************
6555C               **  STEP 1--                        **
6556C               **  BRANCH TO THE APPROPRIATE CASE  **
6557C               **************************************
6558C
6559      ISTEPN='1'
6560      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6561C
6562      IF(NUMARG.LE.0)GOTO9000
6563      IF(NUMARG.EQ.1)GOTO1110
6564      IF(NUMARG.EQ.2)GOTO1120
6565      IF(NUMARG.EQ.3)GOTO1130
6566      GOTO1140
6567C
6568 1110 CONTINUE
6569      GOTO1200
6570C
6571 1120 CONTINUE
6572      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
6573      IF(IHARG(2).EQ.'ALL')GOTO1300
6574      GOTO1200
6575C
6576 1130 CONTINUE
6577CCCCC IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
6578CCCCC IF(IHARG(2).EQ.'ALL')GOTO1300
6579CCCCC IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
6580CCCCC IF(IHARG(3).EQ.'ALL')GOTO1300
6581CCCCC APRIL 1996.  CHANGE IHOLD TO IHOLD1 BELOW
6582      IF(IHARG(2).EQ.'ALL')THEN
6583        IHOLD1=IHARG(3)
6584        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(3).EQ.'2')IHOLD1='DA2'
6585        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(3).EQ.'3')IHOLD1='DA3'
6586        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(3).EQ.'4')IHOLD1='DA4'
6587        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(3).EQ.'5')IHOLD1='DA5'
6588        GOTO1300
6589      ENDIF
6590      IF(IHARG(3).EQ.'ALL')THEN
6591        IHOLD1=IHARG(2)
6592        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'2')IHOLD1='DA2'
6593        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'3')IHOLD1='DA3'
6594        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'4')IHOLD1='DA4'
6595        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'5')IHOLD1='DA5'
6596        GOTO1300
6597      ENDIF
6598      GOTO1200
6599C
6600 1140 CONTINUE
6601      GOTO1200
6602C
6603C               *************************************************
6604C               **  STEP 2--                                   **
6605C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
6606C               *************************************************
6607C
6608 1200 CONTINUE
6609      ISTEPN='2'
6610      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6611C
6612      IF(NUMARG.LE.1)GOTO1210
6613      GOTO1220
6614C
6615 1210 CONTINUE
6616      NUMSPI=1
6617      ISPILI(1)='    '
6618      GOTO1270
6619C
6620 1220 CONTINUE
6621      NUMSPI=NUMARG-1
6622      IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI
6623      DO1225I=1,NUMSPI
6624      J=I+1
6625      IHOLD1=IHARG(J)
6626      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2'
6627      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3'
6628      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4'
6629      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5'
6630      IHOLD2=IHOLD1
6631      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
6632      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
6633      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSL
6634      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSL
6635      ISPILI(I)=IHOLD2
6636 1225 CONTINUE
6637      GOTO1270
6638C
6639 1270 CONTINUE
6640      IF(IFEEDB.EQ.'OFF')GOTO1279
6641      WRITE(ICOUT,999)
6642      CALL DPWRST('XXX','BUG ')
6643      DO1278I=1,NUMSPI
6644      WRITE(ICOUT,1276)I,ISPILI(I)
6645 1276 FORMAT('SPIKE LINE ',I6,' HAS JUST BEEN SET TO ',
6646     1A4)
6647      CALL DPWRST('XXX','BUG ')
6648 1278 CONTINUE
6649 1279 CONTINUE
6650      IFOUND='YES'
6651      GOTO9000
6652C
6653C               **************************
6654C               **  STEP 2--            **
6655C               **  TREAT THE ALL CASE  **
6656C               **************************
6657C
6658 1300 CONTINUE
6659      ISTEPN='3'
6660      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6661C
6662      NUMSPI=MAXSPI
6663      IHOLD2=IHOLD1
6664      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
6665      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
6666      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSL
6667      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSL
6668      DO1315I=1,NUMSPI
6669      ISPILI(I)=IHOLD2
6670 1315 CONTINUE
6671      GOTO1370
6672C
6673 1370 CONTINUE
6674      IF(IFEEDB.EQ.'OFF')GOTO1319
6675      WRITE(ICOUT,999)
6676      CALL DPWRST('XXX','BUG ')
6677      I=1
6678      WRITE(ICOUT,1316)ISPILI(I)
6679 1316 FORMAT('ALL SPIKE LINES HAVE JUST BEEN SET TO ',
6680     1A4)
6681      CALL DPWRST('XXX','BUG ')
6682 1319 CONTINUE
6683      IFOUND='YES'
6684      GOTO9000
6685C
6686C               *****************
6687C               **  STEP 90--  **
6688C               **  EXIT       **
6689C               *****************
6690C
6691 9000 CONTINUE
6692      IF(IBUGP2.EQ.'OFF')GOTO9090
6693      WRITE(ICOUT,9011)
6694 9011 FORMAT('***** AT THE END       OF DPSPLI--')
6695      CALL DPWRST('XXX','BUG ')
6696      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
6697 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
6698      CALL DPWRST('XXX','BUG ')
6699      WRITE(ICOUT,9013)MAXSPI,NUMSPI
6700 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
6701      CALL DPWRST('XXX','BUG ')
6702      WRITE(ICOUT,9014)IHOLD1,IHOLD2
6703 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
6704      CALL DPWRST('XXX','BUG ')
6705      WRITE(ICOUT,9015)IDEFSL
6706 9015 FORMAT('IDEFSL = ',A4)
6707      CALL DPWRST('XXX','BUG ')
6708      WRITE(ICOUT,9020)NUMARG
6709 9020 FORMAT('NUMARG = ',I8)
6710      CALL DPWRST('XXX','BUG ')
6711      DO9025I=1,NUMARG
6712      WRITE(ICOUT,9026)IHARG(I)
6713 9026 FORMAT('IHARG(I) = ',A4)
6714      CALL DPWRST('XXX','BUG ')
6715 9025 CONTINUE
6716      WRITE(ICOUT,9030)ISPILI(1)
6717 9030 FORMAT('ISPILI(1) = ',A4)
6718      CALL DPWRST('XXX','BUG ')
6719      DO9035I=1,10
6720      WRITE(ICOUT,9036)I,ISPILI(I)
6721 9036 FORMAT('I,ISPILI(I) = ',I8,2X,A4)
6722      CALL DPWRST('XXX','BUG ')
6723 9035 CONTINUE
6724 9090 CONTINUE
6725C
6726      RETURN
6727      END
6728      SUBROUTINE DPSPMA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
6729     1                  IANGLU,MAXNPP,MAXNXT,
6730     1                  CLLIMI,CLWIDT,
6731     1                  ICONT,NUMHPP,NUMVPP,IMANUF,
6732     1                  XMATN,YMATN,XMITN,YMITN,
6733     1                  ISQUAR,IVGMSW,IHGMSW,
6734     1                  IMPSW,IMPNR,IMPNC,IMPCO,
6735     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
6736CCCCC1                  TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,
6737     1                  ALOWFR,ALOWDG,IFORSW,ICAPSW,
6738     1                  ANOPL1,ANOPL2,ISEED,IBOOSS,BARHEF,BARWEF,
6739     1                  IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
6740     1                  IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
6741     1                  IFOUND,IERROR)
6742C
6743C     PURPOSE--GENERATE A SCATTER PLOT MATRIX
6744C     WRITTEN BY--ALAN HECKERT
6745C                 STATISTICAL ENGINEERING DIVISION
6746C                 INFORMATION TECHNOLOGY LABORATORY
6747C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6748C                 GAITHERSBURG, MD 20899-8980
6749C                 PHONE--301-975-2899
6750C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6751C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6752C     LANGUAGE--ANSI FORTRAN (1977)
6753C     VERSION NUMBER--99/9
6754C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--SEPTEMBER 1999.
6755C     UPDATED--AUGUST      2007. CALL LIST TO MAINGR
6756C     UPDATED--AUGUST      2011. USE DPPARS TO PARSE COMMAND LINE
6757C     UPDATED--AUGUST      2011. USE DPAUFI TO OPEN/CLOSE TEMPORARY FILES
6758C     UPDATED--AUGUST      2011. SAVE/RESTORE PLOT CONTROL SETTINGS
6759C                                USING DPSPM5
6760C     UPDATED--JUNE        2014. WRITE YPLOT, XPLOT, TAGPLOT TO
6761C                                FILE
6762C     UPDATED--OCTOBER     2018. ISSUE WITH "TO" SYNTAX
6763C
6764C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
6765C
6766      REAL CLLIMI(*)
6767      REAL CLWIDT(*)
6768C
6769      INCLUDE 'DPCOPA.INC'
6770C
6771      CHARACTER*4 ICASPL
6772      CHARACTER*4 ICAPSW
6773      CHARACTER*4 ICONT
6774      CHARACTER*4 IPOWE
6775      CHARACTER*4 IAND1
6776      CHARACTER*4 IAND2
6777      CHARACTER*4 IANGLU
6778      CHARACTER*4 IFORSW
6779C
6780      CHARACTER*4 IBUGG2
6781      CHARACTER*4 IBUGG3
6782      CHARACTER*4 IBUGUG
6783      CHARACTER*4 IBUGU2
6784      CHARACTER*4 IBUGU3
6785      CHARACTER*4 IBUGU4
6786      CHARACTER*4 IBUGCO
6787      CHARACTER*4 IBUGEV
6788      CHARACTER*4 IBUGQ
6789C
6790      CHARACTER*4 ISUBRO
6791      CHARACTER*4 IFOUND
6792      CHARACTER*4 IERROR
6793C
6794      CHARACTER*4 ISQUAR
6795      CHARACTER*4 IVGMSW
6796      CHARACTER*4 IHGMSW
6797      CHARACTER*4 IREPCH
6798      CHARACTER*4 IMPSW
6799C
6800      CHARACTER*4 IPLOTT
6801      CHARACTER*4 ICT
6802      CHARACTER*4 IC2T
6803      CHARACTER*4 IHT(5)
6804      CHARACTER*4 IH2T(5)
6805      CHARACTER*4 ICBT
6806      CHARACTER*4 IC2BT
6807      CHARACTER*4 IHBT(5)
6808      CHARACTER*4 IH2BT(5)
6809C
6810      CHARACTER*4 ISPMTZ
6811      CHARACTER*4 ISPMFZ
6812      CHARACTER*4 ISPMPZ
6813      CHARACTER*4 ISPMLZ
6814      CHARACTER*4 ISPML2
6815      CHARACTER*4 ISPMZT
6816      CHARACTER*4 ISPMZ2
6817      CHARACTER*4 ISPMZ3
6818      CHARACTER*4 ISPMZ4
6819      CHARACTER*4 ISPMXZ
6820      CHARACTER*4 ISPMYZ
6821      CHARACTER*4 ISPMDZ
6822      CHARACTER*4 ISUBSZ
6823C
6824      CHARACTER*4 ISUBZZ
6825      CHARACTER*4 IREFZZ
6826C
6827      CHARACTER*4 IFEED9
6828      CHARACTER*4 IMANUF
6829      CHARACTER*4 IEMPTY
6830      CHARACTER*4 IHRIGH
6831      CHARACTER*4 IHRIG2
6832C
6833      PARAMETER(MAXY=25)
6834      CHARACTER*40 INAME
6835      CHARACTER*4 IVARN1(MAXY)
6836      CHARACTER*4 IVARN2(MAXY)
6837      CHARACTER*4 IVARTY(MAXY)
6838      DIMENSION ILIS(MAXY)
6839      DIMENSION PVAR(MAXY)
6840      DIMENSION NRIGHT(MAXY)
6841      DIMENSION ICOLL(MAXY)
6842C
6843      CHARACTER*4 IHWUSE
6844      CHARACTER*4 MESSAG
6845      CHARACTER*4 ISTEPN
6846      CHARACTER*4 ISUBN1
6847      CHARACTER*4 ISUBN2
6848      CHARACTER*4 IOP
6849      CHARACTER*4 IFITA2
6850C
6851      DIMENSION TEMP(MAXOBV)
6852      DIMENSION TEMP2(MAXOBV)
6853      DIMENSION TEMP3(MAXOBV)
6854      DIMENSION XTEMP1(MAXOBV)
6855      DIMENSION XTEMP2(MAXOBV)
6856C
6857C-----COMMON------------------------------------------------------
6858C
6859      INCLUDE 'DPCOZ3.INC'
6860CCCCC INCLUDE 'DPCOZZ.INC'
6861      INCLUDE 'DPCOPC.INC'
6862      INCLUDE 'DPCOHK.INC'
6863      INCLUDE 'DPCODA.INC'
6864      INCLUDE 'DPCOST.INC'
6865      INCLUDE 'DPCOSP.INC'
6866C
6867      EQUIVALENCE (G3RBAG(KGARB1),TEMP(1))
6868      EQUIVALENCE (G3RBAG(KGARB2),TEMP2(1))
6869      EQUIVALENCE (G3RBAG(KGARB3),TEMP3(1))
6870      EQUIVALENCE (G3RBAG(KGARB4),XTEMP1(1))
6871      EQUIVALENCE (G3RBAG(KGARB5),XTEMP2(1))
6872C
6873C-----COMMON VARIABLES (GENERAL)----------------------------------
6874C
6875      INCLUDE 'DPCOP2.INC'
6876C
6877C-----START POINT-------------------------------------------------
6878C
6879      IFOUND='YES'
6880      IERROR='NO'
6881      ISUBN1='DPSP'
6882      ISUBN2='    '
6883      ICASPL='SPMA'
6884      NDONE=0
6885      IPOS1=0
6886      IPOS2=0
6887C
6888C     WRITE XPLOT, YPLOT, TAGPLOT TO "dpst5f.dat"
6889C
6890      IOP='OPEN'
6891      IFLG11=0
6892      IFLG21=0
6893      IFLG31=0
6894      IFLAG4=0
6895      IFLAG5=1
6896      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
6897     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
6898     1            IBUGG2,ISUBRO,IERROR)
6899      ICNTPL=0
6900      IFITA2=IFITAU
6901      IFITAU='OFF'
6902      IF(IERROR.EQ.'YES')GOTO9000
6903C
6904C               *****************************************
6905C               **  TREAT THE SCATTER PLOT MATRIX CASE **
6906C               *****************************************
6907C
6908      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SPMA')THEN
6909        WRITE(ICOUT,999)
6910  999   FORMAT(1X)
6911        CALL DPWRST('XXX','BUG ')
6912        WRITE(ICOUT,51)
6913   51   FORMAT('***** AT THE BEGINNING OF DPSPMA--')
6914        CALL DPWRST('XXX','BUG ')
6915        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,NUMARG
6916   52   FORMAT('ICASPL,IAND1,IAND2,NUMARG = ',3(A4,2X),I8)
6917        CALL DPWRST('XXX','BUG ')
6918        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
6919   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
6920        CALL DPWRST('XXX','BUG ')
6921        IF(NUMARG.GT.0)THEN
6922          DO61I=1,NUMARG
6923            WRITE(ICOUT,62)I,IHARG(I),IARGT(I)
6924   62       FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4)
6925            CALL DPWRST('XXX','BUG ')
6926   61     CONTINUE
6927        ENDIF
6928        WRITE(ICOUT,71)CLLIMI(1),CLWIDT(1)
6929   71   FORMAT('CLLIMI(1),CLWIDT(1) = ',2G15.7)
6930        CALL DPWRST('XXX','BUG ')
6931      ENDIF
6932C
6933C               *******************************************************
6934C               **  STEP 1--                                         **
6935C               **  SHIFT COMMAND LINE ARGMENTS                      **
6936C               *******************************************************
6937C
6938      ISTEPN='1'
6939      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPMA')
6940     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6941C
6942      ISHIFT=0
6943      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'PLOT'.AND.
6944     1   IHARG(2).EQ.'MATR')THEN
6945        ISHIFT=2
6946      ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
6947        ISHIFT=1
6948      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'YOUD'.AND.IHARG(1).EQ.'MATR'.AND.
6949     1   IHARG(2).EQ.'PLOT')THEN
6950        ISHIFT=2
6951        ISPMPZ=ISPMPT
6952        ISPMPT='YOUD'
6953      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'DEX '.AND.IHARG(1).EQ.'INTE'.AND.
6954     1   IHARG2(1).EQ.'RACT'.AND.IHARG(2).EQ.'PLOT')THEN
6955        ISHIFT=2
6956        ISPMPZ=ISPMPT
6957        ISPMPT='DEXI'
6958        ISPMTZ=ISPMTA
6959        ISPMTA='OFF'
6960      ELSEIF(NUMARG.GE.4.AND.ICOM.EQ.'DEX '.AND.IHARG(2).EQ.'INTE'.AND.
6961     1   IHARG(3).EQ.'EFFE'.AND.IHARG(4).EQ.'PLOT')THEN
6962        ISHIFT=4
6963        ISPMPZ=ISPMPT
6964        ISPMPT='DEXS'
6965        ISPMTZ=ISPMTA
6966        ISPMTA='OFF'
6967        ISPMZT=ISPMST
6968        ISPMZ2=ISPMS2
6969        ISPMZ3=ISPMS3
6970        ISPMZ4=ISPMS4
6971        ISPMST=IHARG(1)
6972        ISPMS2=IHARG2(1)
6973        ISPMS3='    '
6974        ISPMS4='    '
6975      ELSEIF(NUMARG.GE.3.AND.ICOM.EQ.'DEX '.AND.IHARG(2).EQ.'INTE'.AND.
6976     1   IHARG(3).EQ.'PLOT')THEN
6977        ISHIFT=3
6978        ISPMPZ=ISPMPT
6979        ISPMPT='DEXS'
6980        ISPMTZ=ISPMTA
6981        ISPMTA='OFF'
6982        ISPMZT=ISPMST
6983        ISPMZ2=ISPMS2
6984        ISPMZ3=ISPMS3
6985        ISPMZ4=ISPMS4
6986        ISPMST=IHARG(1)
6987        ISPMS2=IHARG2(1)
6988        ISPMS3='    '
6989        ISPMS4='    '
6990      ELSEIF(NUMARG.GE.5.AND.ICOM.EQ.'DEX '.AND.IHARG(3).EQ.'INTE'.AND.
6991     1   IHARG(4).EQ.'EFFE'.AND.IHARG(5).EQ.'PLOT')THEN
6992        ISHIFT=5
6993        ISPMPZ=ISPMPT
6994        ISPMPT='DEXS'
6995        ISPMTZ=ISPMTA
6996        ISPMTA='OFF'
6997        ISPMZT=ISPMST
6998        ISPMZ2=ISPMS2
6999        ISPMZ3=ISPMS3
7000        ISPMZ4=ISPMS4
7001        ISPMST=IHARG(1)
7002        ISPMS2=IHARG2(1)
7003        ISPMS3=IHARG(2)
7004        ISPMS4=IHARG2(2)
7005      ELSEIF(NUMARG.GE.4.AND.ICOM.EQ.'DEX '.AND.IHARG(3).EQ.'INTE'.AND.
7006     1   IHARG(4).EQ.'PLOT')THEN
7007        ISHIFT=4
7008        ISPMPZ=ISPMPT
7009        ISPMPT='DEXS'
7010        ISPMTZ=ISPMTA
7011        ISPMTA='OFF'
7012        ISPMZT=ISPMST
7013        ISPMZ2=ISPMS2
7014        ISPMZ3=ISPMS3
7015        ISPMZ4=ISPMS4
7016        ISPMST=IHARG(1)
7017        ISPMS2=IHARG2(1)
7018        ISPMS3=IHARG(2)
7019        ISPMS4=IHARG2(2)
7020      ENDIF
7021C
7022      IF(ISHIFT.GT.0)THEN
7023        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7024     1              IBUGG2,IERROR)
7025        IF(IERROR.EQ.'YES')GOTO9000
7026      ENDIF
7027C
7028      ICOM='PLOT'
7029      ICOM2='    '
7030      IFOUND='YES'
7031C
7032C               *******************************************************
7033C               **  STEP 2--                                         **
7034C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
7035C               *******************************************************
7036C
7037      ISTEPN='2'
7038      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPMA')
7039     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7040C
7041      INAME='SCATTER PLOT MATRIX'
7042      MINNA=1
7043      MAXNA=100
7044      MINN2=2
7045      IFLAGE=1
7046      IF(ISPMPT.EQ.'BIHI')IFLAGE=0
7047      IF(ISPMPT.EQ.'QQPL')IFLAGE=0
7048      IF(ISPMPT.EQ.'DEXC')IFLAGE=99
7049      IFLAGM=1
7050      IFLAGP=0
7051      JMIN=1
7052      JMAX=NUMARG
7053      MINNVA=2
7054      MAXNVA=MAXY
7055C
7056C     2018/10: CHECK IF "TO" SYNTAX IS USED.  IDENTIFY POSITION
7057C              (AND ASSUME THERE IS ONLY ONE OCCURENCE.
7058C
7059      IPOSTO=-1
7060      DO110II=2,NUMARG-1
7061        IF(IHARG(II).EQ.'TO' .AND. IHARG2(II).EQ.'    ')THEN
7062          IPOSTO=II
7063          GOTO119
7064        ENDIF
7065  110 CONTINUE
7066  119 CONTINUE
7067C
7068      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
7069     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
7070     1            JMIN,JMAX,
7071     1            MINN2,MINNA,MAXNA,MAXY,IFLAGE,INAME,
7072     1            IVARN1,IVARN2,IVARTY,PVAR,
7073     1            ILIS,NRIGHT,ICOLL,ISUB,NQ,ILOCQ,NUMVAR,
7074     1            MINNVA,MAXNVA,
7075     1            IFLAGM,IFLAGP,
7076     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
7077      IF(IERROR.EQ.'YES')GOTO9000
7078C
7079C     IF(IPOSTO.GT.0)THEN
7080        IHRIGH=IHARG(IPOSTO-1)
7081        IHRIG2=IHARG2(IPOSTO-1)
7082        DO120II=1,NUMVAR
7083          IF(IHRIGH.EQ.IVARN1(II) .AND. IHRIG2.EQ.IVARN2(II))THEN
7084            IPOS1=II
7085            GOTO129
7086           ENDIF
7087  120   CONTINUE
7088  129   CONTINUE
7089C
7090        IHRIGH=IHARG(IPOSTO+1)
7091        IHRIG2=IHARG2(IPOSTO+1)
7092        DO130II=1,NUMVAR
7093          IF(IHRIGH.EQ.IVARN1(II) .AND. IHRIG2.EQ.IVARN2(II))THEN
7094            IPOS2=II
7095            GOTO139
7096           ENDIF
7097  130   CONTINUE
7098  139   CONTINUE
7099C
7100        IDIFF=IPOS2-IPOS1
7101        IF(IDIFF.EQ.2)THEN
7102          IHARG(IPOSTO)=IVARN1(IPOS1+1)
7103          IHARG2(IPOSTO)=IVARN2(IPOS1+1)
7104        ELSEIF(IDIFF.EQ.1)THEN
7105          IHARG(IPOSTO)=IVARN1(IPOS2)
7106          IHARG2(IPOSTO)=IVARN2(IPOS2)
7107          IF(IPOSTO+1.EQ.NUMARG)THEN
7108            NUMARG=NUMARG-1
7109          ELSEIF(IPOSTO+1.LT.NUMARG)THEN
7110            DO140II=IPOSTO+1,NUMARG
7111              IHARG(II-1)=IHARG(II)
7112              IHARG2(II-1)=IHARG2(II)
7113  140       CONTINUE
7114            NUMARG=NUMARG-1
7115        ELSEIF(IDIFF.GT.2)THEN
7116          NINS=IPOS2-IPOS1-1
7117          NADD=NINS-1
7118          DO150II=NUMARG,IPOSTO+1,-1
7119            IHARG(II+NADD)=IHARG(II)
7120            IHARG2(II+NADD)=IHARG2(II)
7121  150     CONTINUE
7122          DO160II=IPOSTO,IPOSTO+NADD
7123            IHARG(II+NADD)=IVARN1(IPOS1+II-1)
7124            IHARG2(II+NADD)=IVARN2(IPOS1+II-1)
7125  160     CONTINUE
7126        ENDIF
7127      ENDIF
7128C
7129      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPMA')THEN
7130        WRITE(ICOUT,999)
7131        CALL DPWRST('XXX','BUG ')
7132        WRITE(ICOUT,281)
7133  281   FORMAT('***** AFTER CALL DPPARS--')
7134        CALL DPWRST('XXX','BUG ')
7135        WRITE(ICOUT,282)NQ,NUMVAR
7136  282   FORMAT('NQ,NUMVAR = ',2I8)
7137        CALL DPWRST('XXX','BUG ')
7138        IF(NUMVAR.GT.0)THEN
7139          DO285I=1,NUMVAR
7140            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
7141     1                      ICOLL(I)
7142  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
7143     1             'ICOLL(I) = ',I8,2X,A4,A4,2X,3I8)
7144            CALL DPWRST('XXX','BUG ')
7145  285     CONTINUE
7146        ENDIF
7147      ENDIF
7148C
7149C               **************************************************
7150C               **   STEP 1--                                   **
7151C               **   SAVE INITIAL SETTINGS                      **
7152C               **************************************************
7153C
7154      ISTEPN='1'
7155      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SPMA')
7156     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7157C
7158      IFLAG=1
7159      CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC,
7160     1            IBUGG2,ISUBRO,IFOUND,IERROR)
7161      IF(IERROR.EQ.'YES')GOTO9000
7162      ISPMTZ=ISPMTA
7163      ISPMFZ=ISPMFR
7164      ISPMPZ=ISPMPT
7165      ISPMLZ=ISPMLD
7166      ISPML2=ISPMLA
7167      ISPMZT=ISPMST
7168      ISPMZ2=ISPMS2
7169      ISPMZ3=ISPMS3
7170      ISPMZ4=ISPMS4
7171      ISPMXZ=ISPMXA
7172      ISPMYZ=ISPMYA
7173      ISPMDZ=ISPMDI
7174C
7175      IF(ISPMLA.EQ.'BOX'.AND.ISPMPT.EQ.'BIHI')ISPMLA='ON'
7176      IF(ISPMFR.EQ.'USER'.AND.ISPMLA.EQ.'BOX')ISPMLA='ON'
7177      IF(ISPMFR.EQ.'CONN')ISPMFR='DEFA'
7178      IF(ISPMLA.EQ.'BOX ')THEN
7179        ISPMLD='ON'
7180CCCCC   ISPMXA='BOTT'
7181CCCCC   ISPMYA='LEFT'
7182        IF(ISPMDI.EQ.'BLAN')ISPMDI='LINE'
7183      ENDIF
7184C
7185      IOPTN=1
7186      IDX=0
7187      IDY=0
7188      CALL DPSPM4(ICASPL,IOPTN,IDX,IDY,
7189     1            ISUBNU,ISUBSW,
7190     1            ASUBXL,ASUBXU,ASUBYL,ASUBYU,
7191     1            ISUBN9,ISUBSZ,
7192     1            ASBXL2,ASBXU2,ASBYL2,ASBYU2,
7193     1            PSPLSL,PSPLSU,PSPLSL,PSPLSU,
7194     1            IBUGG2,ISUBRO,IERROR)
7195C
7196      IFEED9=IFEEDB
7197C
7198      IF(ISPMPT.EQ.'YOUD'.OR.ISPMPT.EQ.'DEXC')THEN
7199        ISPMTA='ON'
7200      ENDIF
7201C
7202      IF(ISPMTA.EQ.'ON')THEN
7203        ISHIFT=ILOCQ-1
7204        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7205     1              IBUGG2,IERROR)
7206        IF(IERROR.EQ.'YES')GOTO9000
7207        ISHIFT=NUMVAR-1
7208        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7209     1              IBUGG2,IERROR)
7210        IF(IERROR.EQ.'YES')GOTO9000
7211        DO1509I=1,NUMVAR-1
7212          IHARG(I)=IVARN1(I)
7213          IHARG2(I)=IVARN2(I)
7214 1509   CONTINUE
7215        NUMVAR=NUMVAR-1
7216        IF(NUMVAR.LT.2)GOTO9000
7217      ENDIF
7218C
7219      IMPSW3=IMPSW
7220      IMPCO2=IMPCO
7221      IMPNR2=IMPNR
7222      IMPNC2=IMPNC
7223      IMPSW='ON'
7224      IMPCO=1
7225      IMPCO9=IMPCO
7226      IMPNR=NUMVAR
7227      IMPNC=NUMVAR
7228      NPLOTS=IMPNR*IMPNC
7229C
7230C               *************************************
7231C               **   STEP 21--                     **
7232C               **   GENERATE THE SCATTER PLOTS    **
7233C               *************************************
7234C
7235      ISTEPN='21'
7236      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPSPMA')
7237     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7238C
7239      ISHIFT=NUMVAR
7240      CALL ADJUST(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
7241      ISHIFT=2
7242      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7243     1IBUGG2,IERROR)
7244      IF(IERROR.EQ.'YES')GOTO9000
7245      IHARG(1)=IVARN1(1)
7246      IHARG2(1)=IVARN2(1)
7247      IHARG(2)=IVARN1(1)
7248      IHARG2(2)=IVARN2(1)
7249C
7250      IF(ISPMLA.EQ.'BOX')THEN
7251        IMPNR=NUMVAR+1
7252        IMPNC=NUMVAR+1
7253      ENDIF
7254C
7255      IF(ISPMPT.EQ.'BIHI')THEN
7256        ICT='RELA'
7257        IC2T='TIVE'
7258        IHT(1)='BIHI'
7259        IH2T(1)='STOG'
7260        NCCOMM=1
7261        ICBT='RELA'
7262        IC2BT='TIVE'
7263        IHBT(1)='HIST'
7264        IH2BT(1)='OGRA'
7265        NCCOM2=1
7266        IPLOTT='BIHI'
7267        GOTO5000
7268      ELSEIF(ISPMPT.EQ.'DEXI')THEN
7269        ICT='INTE'
7270        IC2T='RACT'
7271        NCCOMM=1
7272        IHT(NCCOMM)='PLOT'
7273        IH2T(NCCOMM)='    '
7274        ICBT=ICT
7275        IC2BT=IC2T
7276        NCCOM2=NCCOMM
7277        DO2105II=1,NCCOMM
7278          IHBT(II)=IHT(II)
7279          IH2BT(II)=IH2T(II)
7280 2105   CONTINUE
7281        IPLOTT='DEXI'
7282        IRESP=1
7283        GOTO6599
7284      ELSEIF(ISPMPT.EQ.'DEXS')THEN
7285        IF(ISPMST.NE.'    ')THEN
7286          ICT=ISPMST
7287          IC2T=ISPMS2
7288          NCCOMM=0
7289          IF(ISPMS3.NE.'    ')THEN
7290            IHT(1)=ISPMS3
7291            IH2T(1)=ISPMS4
7292            NCCOMM=1
7293          ENDIF
7294        ELSE
7295          ICT='MEAN'
7296          IC2T='    '
7297          NCCOMM=0
7298        ENDIF
7299        NCCOMM=NCCOMM+1
7300        IHT(NCCOMM)='INTE'
7301        IH2T(NCCOMM)='RACT'
7302        NCCOMM=NCCOMM+1
7303        IHT(NCCOMM)='PLOT'
7304        IH2T(NCCOMM)='    '
7305        ICBT=ICT
7306        IC2BT=IC2T
7307        NCCOM2=NCCOMM
7308        DO2108II=1,NCCOMM
7309          IHBT(II)=IHT(II)
7310          IH2BT(II)=IH2T(II)
7311 2108   CONTINUE
7312        IPLOTT='DEXS'
7313        IRESP=1
7314        GOTO6599
7315      ELSEIF(ISPMPT.EQ.'CROS')THEN
7316        IF(ISPMST.NE.'    ')THEN
7317          ICT='CROS'
7318          IC2T='S   '
7319          IHT(1)='TABU'
7320          IH2T(1)='LATE'
7321          IHT(2)=ISPMST
7322          IH2T(2)=ISPMS2
7323          NCCOMM=2
7324          IF(ISPMS3.NE.'    ')THEN
7325            IHT(3)=ISPMS3
7326            IH2T(3)=ISPMS4
7327            NCCOMM=3
7328          ENDIF
7329          NCCOMM=NCCOMM+1
7330          IHT(NCCOMM)='PLOT'
7331          IH2T(NCCOMM)='    '
7332          ICBT=ISPMST
7333          IC2BT=ISPMS2
7334          NCCOM2=0
7335          IF(ISPMS3.NE.'    ')THEN
7336            IHT(1)=ISPMS3
7337            IH2T(1)=ISPMS4
7338            NCCOM2=1
7339          ENDIF
7340          NCCOM2=NCCOM2+1
7341          IHBT(NCCOM2)='PLOT'
7342          IH2BT(NCCOM2)='    '
7343          IPLOTT='CRO2'
7344          IRESP=1
7345        ELSE
7346          ICT='CROS'
7347          IC2T='S   '
7348          IHT(1)='TABU'
7349          IH2T(1)='LATE'
7350          IHT(2)='PLOT'
7351          IH2T(2)='    '
7352          NCCOMM=2
7353          ICBT='PLOT'
7354          IC2BT='    '
7355          NCCOM2=0
7356          IPLOTT='CROS'
7357          IRESP=0
7358        ENDIF
7359        GOTO6599
7360      ELSEIF(ISPMPT.EQ.'DEXC')THEN
7361        ICT='DEX '
7362        IC2T='    '
7363        IHT(1)='CONT'
7364        IH2T(1)='OUR '
7365        IHT(2)='PLOT'
7366        IH2T(2)='    '
7367        NCCOMM=2
7368        ICBT='DEX '
7369        IC2BT='    '
7370        IHBT(1)='CONT'
7371        IH2BT(1)='OUR '
7372        IHBT(2)='PLOT'
7373        IH2BT(2)='    '
7374        NCCOM2=2
7375        IPLOTT='DEXC'
7376        IRESP=1
7377        GOTO6599
7378      ELSEIF(ISPMPT.EQ.'QQPL')THEN
7379        ICT='QUAN'
7380        IC2T='TILE'
7381        IHT(1)='QUAN'
7382        IH2T(1)='TILE'
7383        IHT(2)='PLOT'
7384        IH2T(2)='    '
7385        NCCOMM=2
7386        ICBT='PERC'
7387        IC2BT='ENT '
7388        IHBT(1)='POIN'
7389        IH2BT(1)='    '
7390        IHBT(2)='PLOT'
7391        IH2BT(2)='    '
7392        NCCOM2=2
7393        IPLOTT='QQSP'
7394        IPPTBI='UNBI'
7395        GOTO5000
7396      ELSEIF(ISPMPT.EQ.'CORR')THEN
7397        ICT='CROS'
7398        IC2T='S   '
7399        IHT(1)='CORR'
7400        IH2T(1)='ELAT'
7401        IHT(2)='PLOT'
7402        IH2T(2)='    '
7403        NCCOMM=2
7404        ICBT='AUTO'
7405        IC2BT='CORR'
7406        IHBT(1)='PLOT'
7407        IH2BT(1)='    '
7408        NCCOM2=1
7409        IPLOTT='CCOR'
7410        GX1MIN=0.0
7411        IX1MIN='FIXE'
7412        GOTO5000
7413      ELSEIF(ISPMPT.EQ.'SPEC')THEN
7414        ICT='CROS'
7415        IC2T='S   '
7416        IHT(1)='SPEC'
7417        IH2T(1)='TRAL'
7418        IHT(2)='PLOT'
7419        IH2T(2)='    '
7420        NCCOMM=2
7421        ICBT='SPEC'
7422        IC2BT='TRAL'
7423        IHBT(1)='PLOT'
7424        IH2BT(1)='    '
7425        NCCOM2=1
7426        IPLOTT='CSPE'
7427        ISPMFZ=ISPMFR
7428        IF(IY1MIN.NE.'FIXE'.OR.IY1MAX.NE.'FIXE'.OR.
7429     1     IY2MIN.NE.'FIXE'.OR.IY2MAX.NE.'FIXE')THEN
7430           ISPMFR='USER'
7431        ENDIF
7432        GOTO5000
7433      ELSEIF(ISPMPT.EQ.'LAG ')THEN
7434        ICT='CROS'
7435        IC2T='S   '
7436        IHT(1)='LAG '
7437        IH2T(1)='    '
7438        IHT(2)='PLOT'
7439        IH2T(2)='    '
7440        NCCOMM=2
7441        ICBT='LAG '
7442        IC2BT='    '
7443        IHBT(1)='PLOT'
7444        IH2BT(1)='    '
7445        NCCOM2=1
7446        IPLOTT='CLAG'
7447        GOTO5000
7448      ENDIF
7449C
7450C               *************************************
7451C               **   SCATTER PLOT CASE             **
7452C               *************************************
7453C
7454      IF(ISPMTA.EQ.'ON')THEN
7455        ISHIFT=1
7456        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7457     1              IBUGG2,IERROR)
7458        IF(IERROR.EQ.'YES')GOTO9000
7459        IHARG(3)=IVARN1(NUMVAR+1)
7460        IHARG2(3)=IVARN2(NUMVAR+1)
7461      ENDIF
7462C
7463      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPSPMA')THEN
7464        WRITE(ICOUT,1720)NUMVAR
7465 1720 FORMAT('      NUMVAR = ',I8)
7466        CALL DPWRST('XXX','BUG ')
7467      ENDIF
7468C
7469      NARGT=NUMARG
7470      DO3000IROW=1,IMPNR
7471        DO4000ITEMP1=1,IMPNC
7472C
7473          IF(IROW.LE.NUMVAR)THEN
7474            IHARG(1)=IVARN1(IROW)
7475            IHARG2(1)=IVARN2(IROW)
7476            IDX=IROW
7477          ELSE
7478            IHARG(1)=IVARN1(NUMVAR)
7479            IHARG2(1)=IVARN2(NUMVAR)
7480            IDX=NUMVAR
7481          ENDIF
7482          ICOL=ITEMP1
7483          IEMPTY='NO'
7484          IF(ISPMLA.EQ.'BOX')THEN
7485            ICOL=ITEMP1-1
7486            IF(ICOL.EQ.0)IEMPTY='YES'
7487            IF(IROW.EQ.IMPNR)IEMPTY='YES'
7488          ENDIF
7489C
7490          IF(IROW.GT.ICOL.AND.ISPMLD.EQ.'OFF')THEN
7491            IMPCO=IMPCO+1
7492            GOTO4000
7493          ENDIF
7494C
7495          IF(ICOL.EQ.0)THEN
7496            IHARG(2)=IVARN1(1)
7497            IHARG2(2)=IVARN2(1)
7498            IDY=1
7499          ELSE
7500            IHARG(2)=IVARN1(ICOL)
7501            IHARG2(2)=IVARN2(ICOL)
7502            IDY=ICOL
7503          ENDIF
7504C
7505          IF(IEMPTY.EQ.'YES')THEN
7506            DO3104I=1,MAXSUB
7507              ISU2SW(I)=ISUBSW(I)
7508              ISUBSW(I)='OFF'
7509 3104       CONTINUE
7510          ENDIF
7511          IOPTN=3
7512          CALL DPSPM4(ICASPL,IOPTN,IDX,IDY,
7513     1                ISUBNU,ISUBSW,
7514     1                ASUBXL,ASUBXU,ASUBYL,ASUBYU,
7515     1                ISUBN9,ISUBSZ,
7516     1                ASBXL2,ASBXU2,ASBYL2,ASBYU2,
7517     1                PSPLSL,PSPLSU,PSPLSL,PSPLSU,
7518     1                IBUGG2,ISUBRO,IERROR)
7519C
7520          ICASPL='SPMA'
7521          CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL,
7522     1                IMPNR,IMPNC,IROW,ICOL,IROW,ICOL,IPLOT,
7523     1                NPLOTS,NUMVAR,
7524     1                ICHAP2,ILINP2,
7525     1                GY1MNS,GY1MXS,GY2MNS,GY2MXS,
7526     1                GX1MNS,GX1MXS,GX2MNS,GX2MXS,
7527     1                IY1MNS,IY1MXS,IY2MNS,IY2MXS,
7528     1                IX1MNS,IX1MXS,IX2MNS,IX2MXS,
7529     1                IX1TSV,IX2TSV,IY1TSV,IY2TSV,
7530     1                IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
7531     1                PX1LD2,PX2LD2,
7532     1                IY1LJ2,IY1LD2,PY1LD2,PY1LA2,
7533     1                IX1LT2,IX2LT2,IY1LT2,IY2LT2,
7534     1                NCX1L2,NCX2L2,NCY1L2,NCY2L2,
7535     1                PSPLLL,PSPLUL,PSPLLL,PSPLUL,ICOL,
7536     1                ISPMLA,ISPMLD,ISPMPT,ISPMFR,ISPMXA,ISPMYA,
7537     1                ISPMDI,ISPX1L,
7538     1                ISPMXT,ISPMXL,ISPMYT,ISPMYL,
7539     1                ISPMTD,PSPMTD,IVNMEX,
7540     1                IBUGG2,ISUBRO)
7541          IERROR='NO'
7542C
7543          IF(IEMPTY.EQ.'YES')THEN
7544            DO3106I=1,100
7545              ICHAPA(I)='BLAN'
7546              ILINPA(I)='BLAN'
7547              ISPISW(I)='OFF'
7548              IBARSW(I)='OFF'
7549 3106        CONTINUE
7550             CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
7551     1                   MAXNPP,ISEED,IBOOSS,
7552     1                   IX1TSV,IX2TSV,IY1TSV,IY2TSV,
7553     1                   IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
7554     1                   BARHEF,BARWEF,
7555     1                   IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,
7556     1                   IHSTMC,IHSTOP,
7557     1                   ICAPSW,IFORSW,
7558     1                   IGUIFL,IERRFA,
7559     1                   IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
7560CCCCC1                   TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
7561     1                   MAXNXT,
7562     1                   ISUBRO,IFOUND,IERROR)
7563             GOTO4089
7564          ENDIF
7565C
7566          IF(IROW.EQ.ICOL)THEN
7567            IF(ISPMDI.NE.'LINE')THEN
7568               DO3110I=1,100
7569                 ICHAPA(I)='BLAN'
7570                 ILINPA(I)='BLAN'
7571                 ISPISW(I)='OFF'
7572                 IBARSW(I)='OFF'
7573 3110          CONTINUE
7574            ENDIF
7575            CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
7576     1                   MAXNPP,ISEED,IBOOSS,
7577     1                   IX1TSV,IX2TSV,IY1TSV,IY2TSV,
7578     1                   IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
7579     1                   BARHEF,BARWEF,
7580     1                   IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,
7581     1                   IHSTMC,IHSTOP,
7582     1                   ICAPSW,IFORSW,
7583     1                   IGUIFL,IERRFA,
7584     1                   IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
7585CCCCC1                   TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
7586     1                   MAXNXT,
7587     1                   ISUBRO,IFOUND,IERROR)
7588            IF(IERROR.EQ.'YES')GOTO4000
7589            ICONT=IDCONT(1)
7590            IPOWE=IDPOWE(1)
7591            NUMHPP=IDNHPP(1)
7592            IMPARG=2
7593            CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
7594     1                  XMATN,YMATN,XMITN,YMITN,
7595     1                  ISQUAR,
7596     1                  IVGMSW,IHGMSW,
7597     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
7598     1                  IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
7599     1                  YPLOT,XPLOT,X2PLOT,TAGPLO,
7600     1                  IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
7601     1                  IMPARG,
7602     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
7603     1                  MAXCOL,
7604     1                  DSIZE,DSYMB,DCOLOR,DFILL,
7605     1                  ICAPSW,
7606     1                  IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
7607     1                  IERROR)
7608C
7609            ICNTPL=ICNTPL+1
7610            IF(N.GT.0)THEN
7611              DO3115II=1,N
7612                WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
7613 3115         CONTINUE
7614 3118         FORMAT(I12,3E15.7)
7615            ENDIF
7616C
7617            IF(IERROR.EQ.'NO')IAND1=IAND2
7618            DO3120I=1,100
7619              ICHAPA(I)=ICHAP2(I)
7620              ILINPA(I)=ILINP2(I)
7621              ISPISW(I)=ISPIS2(I)
7622              IBARSW(I)=IBARS2(I)
7623 3120       CONTINUE
7624            IERASW='OFF'
7625            IF(ISPMDI.EQ.'LINE'.OR.ISPMDI.EQ.'BLAN')GOTO4000
7626            IX1TSW='OFF'
7627            IX1ZSW='OFF'
7628            IX2TSW='OFF'
7629            IX2ZSW='OFF'
7630            IY1TSW='OFF'
7631            IY1ZSW='OFF'
7632            IY2TSW='OFF'
7633            IY2ZSW='OFF'
7634C
7635            IF(ISPMDI.EQ.'BOXP'.AND.ISPMTA.EQ.'ON')THEN
7636              IMPCO=IMPCO-1
7637              DO3130I=1,100
7638                ICHAPA(I)='BLAN'
7639                ILINPA(I)='BLAN'
7640                IBARSW(I)='OFF'
7641                ISPISW(I)='OFF'
7642 3130         CONTINUE
7643              ICHAPA(1)='X'
7644              ICHAPA(4)='X'
7645              ICHAPA(7)='X'
7646              ICHAPA(21)='CIRC'
7647              ICHAPA(22)='CIRC'
7648              ICHAPA(23)='CIRC'
7649              ICHAPA(24)='CIRC'
7650              ILINPA(8)='SOLI'
7651              ILINPA(13)='SOLI'
7652              ILINPA(14)='SOLI'
7653              ILINPA(15)='SOLI'
7654              ILINPA(16)='SOLI'
7655              ILINPA(20)='SOLI'
7656              IFENSW='ON'
7657              GY1MIN=FY1MNZ
7658              GY1MAX=FY1MXZ
7659              GY2MIN=GY1MIN
7660              GY2MAX=GY1MAX
7661              IY1MIN='FIXE'
7662              IY1MAX='FIXE'
7663              IY2MIN='FIXE'
7664              IY2MAX='FIXE'
7665              IX1MIN='FLOA'
7666              IX1MAX='FLOA'
7667              IX2MIN='FLOA'
7668              IX2MAX='FLOA'
7669              IX1TSW='OFF'
7670              IX1ZSW='OFF'
7671              IX2TSW='OFF'
7672              IX2ZSW='OFF'
7673              IY1TSW='OFF'
7674              IY1ZSW='OFF'
7675              IY2TSW='OFF'
7676              IY2ZSW='OFF'
7677              ICOM='BOX '
7678              ICOM2='    '
7679              IHARG(1)='PLOT'
7680              IHARG2(1)='    '
7681              IHARG(2)=IVARN1(IROW)
7682              IHARG2(2)=IVARN2(IROW)
7683              IHARG(3)=IVARN1(NUMVAR+1)
7684              IHARG2(3)=IVARN2(NUMVAR+1)
7685              CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
7686     1                   MAXNPP,ISEED,IBOOSS,
7687     1                   IX1TSV,IX2TSV,IY1TSV,IY2TSV,
7688     1                   IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
7689     1                   BARHEF,BARWEF,
7690     1                   IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,
7691     1                   IHSTMC,IHSTOP,
7692     1                   ICAPSW,IFORSW,
7693     1                   IGUIFL,IERRFA,
7694     1                   IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
7695CCCCC1                   TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
7696     1                   MAXNXT,
7697     1                   ISUBRO,IFOUND,IERROR)
7698              ISHIFT=1
7699              CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7700     1                    IBUGG2,IERROR)
7701              ICOM='PLOT'
7702              ICOM2='    '
7703              IHARG(1)=IVARN1(IROW)
7704              IHARG2(1)=IVARN2(IROW)
7705              IHARG(2)=IVARN1(ICOL)
7706              IHARG2(2)=IVARN2(ICOL)
7707              IHARG(3)=IVARN1(NUMVAR+1)
7708              IHARG2(3)=IVARN2(NUMVAR+1)
7709              GOTO4089
7710            ELSEIF(ISPMDI.EQ.'HIST')THEN
7711              IMPCO=IMPCO-1
7712              ICOM='HIST'
7713              ICOM2='    '
7714              ISHIFT=1
7715              IF(ISPMTA.EQ.'ON')ISHIFT=2
7716              CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7717     1                    IBUGG2,IERROR)
7718              IHARG(1)=IVARN1(IROW)
7719              IHARG2(1)=IVARN2(IROW)
7720              CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
7721     1                   MAXNPP,ISEED,IBOOSS,
7722     1                   IX1TSV,IX2TSV,IY1TSV,IY2TSV,
7723     1                   IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
7724     1                   BARHEF,BARWEF,
7725     1                   IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,
7726     1                   IHSTMC,IHSTOP,
7727     1                   ICAPSW,IFORSW,
7728     1                   IGUIFL,IERRFA,
7729     1                   IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
7730CCCCC1                   TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
7731     1                   MAXNXT,
7732     1                   ISUBRO,IFOUND,IERROR)
7733              ISHIFT=1
7734              IF(ISPMTA.EQ.'ON')ISHIFT=2
7735              CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7736     1                    IBUGG2,IERROR)
7737              ICOM='PLOT'
7738              ICOM2='    '
7739              IHARG(1)=IVARN1(ICOL)
7740              IHARG2(1)=IVARN2(ICOL)
7741              IHARG(2)=IVARN1(ICOL)
7742              IHARG2(2)=IVARN2(ICOL)
7743              IF(ISPMTA.EQ.'ON')THEN
7744                IHARG(3)=IVARN1(NUMVAR+1)
7745                IHARG2(3)=IVARN2(NUMVAR+1)
7746              ENDIF
7747              IY1MIN='FLOA'
7748              IY1MAX='FLOA'
7749              IY2MIN='FLOA'
7750              IY2MAX='FLOA'
7751              IX1MIN='FLOA'
7752              IX1MAX='FLOA'
7753              IX2MIN='FLOA'
7754              IX2MAX='FLOA'
7755              GOTO4089
7756            ENDIF
7757            GOTO4000
7758          ENDIF
7759C
7760          CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
7761     1                   MAXNPP,ISEED,IBOOSS,
7762     1                   IX1TSV,IX2TSV,IY1TSV,IY2TSV,
7763     1                   IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
7764     1                   BARHEF,BARWEF,
7765     1                   IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,
7766     1                   IHSTMC,IHSTOP,
7767     1                   ICAPSW,IFORSW,
7768     1                   IGUIFL,IERRFA,
7769     1                   IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
7770CCCCC1                   TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
7771     1                   MAXNXT,
7772     1                   ISUBRO,IFOUND,IERROR)
7773          IF(IEMPTY.EQ.'NO')THEN
7774            IF(
7775     1       (IROW.NE.ICOL.AND.(ISPX2L.EQ.'CORR'.OR.ISPX2L.EQ.'PCOR'))
7776     1       .OR.ISPX2L.EQ.'PACC'.OR.
7777     1       ISPX2L.EQ.'NACC'.OR.ISPX2L.EQ.'ATP '.OR.
7778     1       ISPX2L.EQ.'AT  ')
7779     1       CALL DPSPM3(ICASPL,IOUNI5,
7780     1                   IROW,ICOL,
7781     1                   PX2LD2,NPLOTP,
7782     1                   IFORSW,
7783     1                   ISPX2L,ISPX2P,ISPX2S,
7784     1                   IHRIGH,IHRIG2,IHWUSE,
7785     1                   ISUBN1,ISUBN2,MESSAG,
7786     1                   IBUGG2,ISUBRO,IERROR)
7787          ENDIF
7788C
7789          IF(IERROR.EQ.'YES')THEN
7790            IMPCO=IMPCO+1
7791            GOTO4000
7792          ENDIF
7793C
7794 4089     CONTINUE
7795          ICONT=IDCONT(1)
7796          IPOWE=IDPOWE(1)
7797          NUMHPP=IDNHPP(1)
7798          IMPARG=2
7799          CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
7800     1                XMATN,YMATN,XMITN,YMITN,
7801     1                ISQUAR,
7802     1                IVGMSW,IHGMSW,
7803     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
7804     1                IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
7805     1                YPLOT,XPLOT,X2PLOT,TAGPLO,
7806     1                IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
7807     1                IMPARG,
7808     1                PMXMIN,PMXMAX,PMYMIN,PMYMAX,
7809     1                MAXCOL,
7810     1                DSIZE,DSYMB,DCOLOR,DFILL,
7811     1                ICAPSW,
7812     1                IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
7813     1                IERROR)
7814C
7815            ICNTPL=ICNTPL+1
7816            IF(N.GT.0)THEN
7817              DO33115II=1,N
7818                WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
781933115         CONTINUE
7820            ENDIF
7821C
7822          IF(IERROR.EQ.'NO')IAND1=IAND2
7823          IF(ISPMFI.EQ.'NONE')GOTO4090
7824          IF(IEMPTY.EQ.'YES')GOTO4090
7825          IF(IROW.EQ.ICOL)GOTO4090
7826          IMPCO=IMPCO-1
7827          IF(IMPCO.LE.1)IERASW='OFF'
7828          IF(IERROR.EQ.'YES')GOTO4000
7829C
7830          CALL DPSPM2(ICASPL,IVARN1,IVARN2,ICOLL,NUMVAR,NPLOTP,
7831     1                IROW,ICOL,
7832     1                TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
7833     1                ALOWFR,ALOWDG,
7834     1                IANGLU,MAXNPP,IAND1,IAND2,
7835     1                ISPMFI,ISPMTA,
7836     1                XMATN,YMATN,XMITN,YMITN,
7837     1                ISQUAR,
7838     1                IVGMSW,IHGMSW,
7839     1                IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
7840     1                IREPCH,
7841     1                PMXMIN,PMXMAX,PMYMIN,PMYMAX,
7842     1                ICNTPL,IOUNI5,
7843     1                IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
7844     1                IBUGUG,IBUGU2,IBUGU3,IBUGU4,
7845     1                ISUBRO,IFOUND,IERROR)
7846C
7847 4090     CONTINUE
7848          PX1LDS=PX1LD2
7849          GX1MIN=GX1MNS
7850          GX1MAX=GX1MXS
7851          GX2MIN=GX2MNS
7852          GX2MAX=GX2MXS
7853          GY1MIN=GY1MNS
7854          GY1MAX=GY1MXS
7855          GY2MIN=GY2MNS
7856          GY2MAX=GY2MXS
7857          IX1MIN=IX1MNS
7858          IX1MAX=IX1MXS
7859          IX2MIN=IX2MNS
7860          IX2MAX=IX2MXS
7861          IY1MIN=IY1MNS
7862          IY1MAX=IY1MXS
7863          IY2MIN=IY2MNS
7864          IY2MAX=IY2MXS
7865          PX1ZDS=PX1ZD2
7866          PX2ZDS=PX2ZD2
7867          PY1ZDS=PY1ZD2
7868          PY2ZDS=PY2ZD2
7869          IF(IEMPTY.EQ.'YES')THEN
7870            DO4907I=1,MAXSUB
7871              ISUBSW(I)=ISU2SW(I)
7872 4907       CONTINUE
7873          ENDIF
7874          DO4098I=1,100
7875            ICHAPA(I)=ICHAP2(I)
7876            ILINPA(I)=ILINP2(I)
7877            ISPISW(I)=ISPIS2(I)
7878            IBARSW(I)=IBARS2(I)
7879 4098     CONTINUE
7880          ISHIFT=NARGT-NUMARG
7881          IF(ISHIFT.GT.0)THEN
7882            CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7883     1                IBUGG2,IERROR)
7884          ELSEIF(ISHIFT.LT.0)THEN
7885            ISHIFT=-ISHIFT
7886            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7887     1                IBUGG2,IERROR)
7888          ENDIF
7889          ICOM='PLOT'
7890          ICOM2='    '
7891          IHARG(1)=IVARN1(ICOL)
7892          IHARG2(1)=IVARN2(ICOL)
7893          IHARG(2)=IVARN1(ICOL)
7894          IHARG2(2)=IVARN2(ICOL)
7895          IF(ISPMTA.EQ.'ON')THEN
7896            IHARG(3)=IVARN1(NUMVAR+1)
7897            IHARG2(3)=IVARN2(NUMVAR+1)
7898          ENDIF
7899C
7900 4000   CONTINUE
7901 3000 CONTINUE
7902      GOTO8000
7903C
7904C               *********************************************
7905C               **   BIHISTOGRAM           CASE            **
7906C               **   QUANTILE-QUANTILE     CASE            **
7907C               **   CROSS-CORRELATION     CASE            **
7908C               **   CROSS-SPECTRUM        CASE            **
7909C               **   CROSS-LAG             CASE            **
7910C               **   FOLLOWING ALL USE A SIMILAR STRUCTURE **
7911C               *********************************************
7912 5000 CONTINUE
7913      NARGT=NUMARG
7914      DO5100IROW=1,IMPNR
7915        DO5200ITEMP1=1,IMPNC
7916C
7917          ICOL=ITEMP1
7918          IEMPTY='NO'
7919          IF(ISPMLA.EQ.'BOX')THEN
7920            ICOL=ITEMP1-1
7921            IF(ICOL.EQ.0)IEMPTY='YES'
7922            IF(IROW.EQ.IMPNR)IEMPTY='YES'
7923          ENDIF
7924C
7925          IF(IROW.GT.ICOL.AND.ISPMLD.EQ.'OFF')THEN
7926            IMPCO=IMPCO+1
7927            GOTO5200
7928          ENDIF
7929C
7930          IF(IROW.LE.NUMVAR)THEN
7931            IHARG(1)=IVARN1(IROW)
7932            IHARG2(1)=IVARN2(IROW)
7933            IDX=IROW
7934          ELSE
7935            IHARG(1)=IVARN1(NUMVAR)
7936            IHARG2(1)=IVARN2(NUMVAR)
7937            IDX=NUMVAR
7938          ENDIF
7939          IF(ICOL.EQ.0)THEN
7940            IHARG(2)=IVARN1(1)
7941            IHARG2(2)=IVARN2(1)
7942            IDY=1
7943          ELSE
7944            IHARG(2)=IVARN1(ICOL)
7945            IHARG2(2)=IVARN2(ICOL)
7946            IDY=ICOL
7947          ENDIF
7948C
7949          IF(IEMPTY.EQ.'YES')THEN
7950            DO5104I=1,MAXSUB
7951              ISU2SW(I)=ISUBSW(I)
7952              ISUBSW(I)='OFF'
7953 5104       CONTINUE
7954          ENDIF
7955          IOPTN=3
7956          CALL DPSPM4(ICASPL,IOPTN,IDX,IDY,
7957     1                ISUBNU,ISUBSW,
7958     1                ASUBXL,ASUBXU,ASUBYL,ASUBYU,
7959     1                ISUBN9,ISUBSZ,
7960     1                ASBXL2,ASBXU2,ASBYL2,ASBYU2,
7961     1                PSPLSL,PSPLSU,PSPLSL,PSPLSU,
7962     1                IBUGG2,ISUBRO,IERROR)
7963C
7964          ICASPL='SPMA'
7965          CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL,
7966     1                IMPNR,IMPNC,IROW,ICOL,IROW,ICOL,IPLOT,
7967     1                NPLOTS,NUMVAR,
7968     1                ICHAP2,ILINP2,
7969     1                GY1MNS,GY1MXS,GY2MNS,GY2MXS,
7970     1                GX1MNS,GX1MXS,GX2MNS,GX2MXS,
7971     1                IY1MNS,IY1MXS,IY2MNS,IY2MXS,
7972     1                IX1MNS,IX1MXS,IX2MNS,IX2MXS,
7973     1                IX1TSV,IX2TSV,IY1TSV,IY2TSV,
7974     1                IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
7975     1                PX1LD2,PX2LD2,
7976     1                IY1LJ2,IY1LD2,PY1LD2,PY1LA2,
7977     1                IX1LT2,IX2LT2,IY1LT2,IY2LT2,
7978     1                NCX1L2,NCX2L2,NCY1L2,NCY2L2,
7979     1                PSPLLL,PSPLUL,PSPLLL,PSPLUL,ICOL,
7980     1                ISPMLA,ISPMLD,IPLOTT,ISPMFR,ISPMXA,ISPMYA,
7981     1                ISPMDI,ISPX1L,
7982     1                ISPMXT,ISPMXL,ISPMYT,ISPMYL,
7983     1                ISPMTD,PSPMTD,IVNMEX,
7984     1                IBUGG2,ISUBRO)
7985C
7986          IF(IEMPTY.EQ.'YES')THEN
7987            DO5106I=1,100
7988              ICHAPA(I)='BLAN'
7989              ILINPA(I)='BLAN'
7990              ISPISW(I)='OFF'
7991              IBARSW(I)='OFF'
7992 5106       CONTINUE
7993          ENDIF
7994          IF(IROW.EQ.ICOL)THEN
7995            ISHIFT=1
7996            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
7997     1                  IBUGG2,IERROR)
7998            ISHIFT=NCCOM2
7999            IF(NCCOM2.GT.0)
8000     1      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8001     1                  IBUGG2,IERROR)
8002            ICOM=ICBT
8003            ICOM2=IC2BT
8004            IF(NCCOM2.GT.0)THEN
8005              DO5120II=1,NCCOM2
8006                IHARG(II)=IHBT(II)
8007                IHARG2(II)=IH2BT(II)
8008 5120         CONTINUE
8009            ENDIF
8010          ELSE
8011            ISHIFT=NCCOMM
8012            IF(NCCOMM.GT.0)
8013     1      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8014     1                  IBUGG2,IERROR)
8015            ICOM=ICT
8016            ICOM2=IC2T
8017            IF(NCCOMM.GT.0)THEN
8018              DO5130II=1,NCCOMM
8019                IHARG(II)=IHT(II)
8020                IHARG2(II)=IH2T(II)
8021 5130         CONTINUE
8022            ENDIF
8023          ENDIF
8024          CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
8025     1                MAXNPP,ISEED,IBOOSS,
8026     1                IX1TSV,IX2TSV,IY1TSV,IY2TSV,
8027     1                IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
8028     1                BARHEF,BARWEF,
8029     1                IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,
8030     1                IHSTMC,IHSTOP,
8031     1                ICAPSW,IFORSW,
8032     1                IGUIFL,IERRFA,
8033     1                IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
8034CCCCC1                TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
8035     1                MAXNXT,
8036     1                ISUBRO,IFOUND,IERROR)
8037          IF(IEMPTY.EQ.'NO')THEN
8038            IF(
8039     1         ISPX2L.EQ.'PACC'.OR.
8040     1         ISPX2L.EQ.'NACC'.OR.ISPX2L.EQ.'ATP '.OR.
8041     1         ISPX2L.EQ.'AT  ')
8042     1         CALL DPSPM3(ICASPL,IOUNI5,
8043     1                     IROW,ICOL,
8044     1                     PX2LD2,NPLOTP,
8045     1                     IFORSW,
8046     1                     ISPX2L,ISPX2P,ISPX2S,
8047     1                     IHRIGH,IHRIG2,IHWUSE,
8048     1                     ISUBN1,ISUBN2,MESSAG,
8049     1                     IBUGG2,ISUBRO,IERROR)
8050          ENDIF
8051C
8052          ISHIFT=NARGT-NUMARG
8053          IF(ISHIFT.GT.0)THEN
8054            CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8055     1                IBUGG2,IERROR)
8056          ELSEIF(ISHIFT.LT.0)THEN
8057            ISHIFT=-ISHIFT
8058            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8059     1                IBUGG2,IERROR)
8060          ENDIF
8061          ICOM='PLOT'
8062          ICOM2='    '
8063          IHARG(1)=IVARN1(ICOL)
8064          IHARG2(1)=IVARN2(ICOL)
8065          IHARG(2)=IVARN1(ICOL)
8066          IHARG2(2)=IVARN2(ICOL)
8067C
8068C               **************************************************
8069C               **   STEP 25--                                  **
8070C               **   PLOT THE CURRENT PLOT                      **
8071C               **************************************************
8072          ICONT=IDCONT(1)
8073          IPOWE=IDPOWE(1)
8074          NUMHPP=IDNHPP(1)
8075          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SPMA')THEN
8076            WRITE(ICOUT,5107)IMANUF,NUMDEV,IDMANU(1)
8077 5107       FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4)
8078            CALL DPWRST('XXX','BUG ')
8079          ENDIF
8080          IMPARG=2
8081          CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
8082     1                XMATN,YMATN,XMITN,YMITN,
8083     1                ISQUAR,
8084     1                IVGMSW,IHGMSW,
8085     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
8086     1                IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
8087     1                YPLOT,XPLOT,X2PLOT,TAGPLO,
8088     1                IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
8089     1                IMPARG,
8090     1                PMXMIN,PMXMAX,PMYMIN,PMYMAX,
8091     1                MAXCOL,
8092     1                DSIZE,DSYMB,DCOLOR,DFILL,
8093     1                ICAPSW,
8094     1                IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
8095     1                IERROR)
8096C
8097            ICNTPL=ICNTPL+1
8098            IF(N.GT.0)THEN
8099              DO5217II=1,N
8100                WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
8101 5217         CONTINUE
8102            ENDIF
8103C
8104          IF(IERROR.EQ.'NO')IAND1=IAND2
8105          IF(IEMPTY.EQ.'YES')THEN
8106            DO5207I=1,MAXSUB
8107              ISUBSW(I)=ISU2SW(I)
8108 5207       CONTINUE
8109          ENDIF
8110          PX1LDS=PX1LD2
8111          GX1MIN=GX1MNS
8112          GX1MAX=GX1MXS
8113          GX2MIN=GX2MNS
8114          GX2MAX=GX2MXS
8115          GY1MIN=GY1MNS
8116          GY1MAX=GY1MXS
8117          GY2MIN=GY2MNS
8118          GY2MAX=GY2MXS
8119          IX1MIN=IX1MNS
8120          IX1MAX=IX1MXS
8121          IX2MIN=IX2MNS
8122          IX2MAX=IX2MXS
8123          IY1MIN=IY1MNS
8124          IY1MAX=IY1MXS
8125          IY2MIN=IY2MNS
8126          IY2MAX=IY2MXS
8127          PX1ZDS=PX1ZD2
8128          PX2ZDS=PX2ZD2
8129          PY1ZDS=PY1ZD2
8130          PY2ZDS=PY2ZD2
8131C
8132 5200   CONTINUE
8133 5100 CONTINUE
8134      GOTO8000
8135C
8136C               *********************************************
8137C               **   CROSS TABULATE <STAT> PLOTS  CASE     **
8138C               **   DEX <STAT> PLOTS             CASE     **
8139C               **   DEX <STAT> INTERACTION PLOTS CASE     **
8140C               **   3D-PLOT                PLOTS CASE     **
8141C               **   DEX CONTOUR            PLOTS CASE     **
8142C               **   ALL OF THESE USE SIMILAR STRUCTURE    **
8143C               *********************************************
8144C
8145 6599 CONTINUE
8146C
8147      IF(IRESP.EQ.1)THEN
8148        ISHIFT=1
8149        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8150     1              IBUGG2,IERROR)
8151        IHARG(1)=IVARN1(1)
8152        IHARG2(1)=IVARN2(1)
8153        IMPNR=IMPNR-1
8154        IMPNC=IMPNC-1
8155      ENDIF
8156C
8157      IF(ISPMPT.EQ.'DEXC')THEN
8158        GY1MIN=-2.0
8159        GY1MAX=2.0
8160        GY2MIN=-2.0
8161        GY2MAX=2.0
8162        IY1MIN='FIXE'
8163        IY1MAX='FIXE'
8164        IY2MIN='FIXE'
8165        IY2MAX='FIXE'
8166        GX1MIN=-2.0
8167        GX1MAX=2.0
8168        GX2MIN=-2.0
8169        GX2MAX=2.0
8170        IX1MIN='FIXE'
8171        IX1MAX='FIXE'
8172        IX2MIN='FIXE'
8173        IX2MAX='FIXE'
8174        ISHIFT=1
8175        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8176     1              IBUGG2,IERROR)
8177        IHARG(4)=IVARN1(NUMVAR+1)
8178        IHARG2(4)=IVARN2(NUMVAR+1)
8179        IF(IERROR.EQ.'YES')GOTO9000
8180      ENDIF
8181C
8182      NARGT=NUMARG
8183C
8184      NPLOTS=IMPNR
8185      NPLOT2=IMPNR*IMPNC
8186      DO6600IROW=1,NPLOTS
8187        DO6700ITEMP1=1,NPLOTS
8188C
8189          ICOL=ITEMP1
8190          IFACT=ICOL+IRESP
8191          IEMPTY='NO'
8192          IF(ISPMLA.EQ.'BOX')THEN
8193            ICOL=ITEMP1-1
8194            IF(ICOL.EQ.0)IEMPTY='YES'
8195            IF(IROW.EQ.IMPNR)IEMPTY='YES'
8196          ENDIF
8197C
8198          IF(IROW.EQ.ICOL.AND.ISPMPT.NE.'DEXC')THEN
8199            ISHIFT=1
8200            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8201     1                  IBUGG2,IERROR)
8202          ENDIF
8203C
8204          IFRST=0
8205          IF(IRESP.EQ.1)THEN
8206            IHARG(1)=IVARN1(1)
8207            IHARG2(1)=IVARN2(1)
8208            IFRST=1
8209          ENDIF
8210C
8211          IRES=IROW+IRESP
8212          IFRST=IFRST+1
8213          IF(IRES.LE.NUMVAR)THEN
8214            IHARG(IFRST)=IVARN1(IRES)
8215            IHARG2(IFRST)=IVARN2(IRES)
8216          ELSE
8217            IHARG(IFRST)=IVARN1(NUMVAR)
8218            IHARG2(IFRST)=IVARN2(NUMVAR)
8219          ENDIF
8220C
8221          IF(IROW.GT.ICOL.AND.ISPMLD.EQ.'OFF')THEN
8222            IMPCO=IMPCO+1
8223            GOTO6700
8224          ENDIF
8225C
8226          IF(IROW.NE.ICOL.OR.ISPMPT.EQ.'DEXC')THEN
8227            IFRST=IFRST+1
8228            IF(ICOL.EQ.0)THEN
8229              IHARG(IFRST)=IVARN1(2)
8230              IHARG2(IFRST)=IVARN2(2)
8231            ELSE
8232              IHARG(IFRST)=IVARN1(IFACT)
8233              IHARG2(IFRST)=IVARN2(IFACT)
8234            ENDIF
8235          ENDIF
8236C
8237          IF(ISPMPT.EQ.'DEXC')THEN
8238            IFRST=IFRST+1
8239            IHARG(IFRST)=IVARN1(NUMVAR+1)
8240            IHARG2(IFRST)=IVARN2(NUMVAR+1)
8241          ENDIF
8242C
8243          IF(ISPMPT.EQ.'DEXC'.AND.IROW.EQ.ICOL)IEMPTY='YES'
8244          IF(IEMPTY.EQ.'YES')THEN
8245            DO6604I=1,MAXSUB
8246              ISU2SW(I)=ISUBSW(I)
8247              ISUBSW(I)='OFF'
8248 6604       CONTINUE
8249          ENDIF
8250          IOPTN=3
8251          IDY=1
8252          IDX=2
8253          CALL DPSPM4(ICASPL,IOPTN,IDX,IDY,
8254     1                ISUBNU,ISUBSW,
8255     1                ASUBXL,ASUBXU,ASUBYL,ASUBYU,
8256     1                ISUBN9,ISUBSZ,
8257     1                ASBXL2,ASBXU2,ASBYL2,ASBYU2,
8258     1                PSPLSL,PSPLSU,PSPLSL,PSPLSU,
8259     1                IBUGG2,ISUBRO,IERROR)
8260C
8261C         2015/03: OPTION FOR SHADING DIAGONAL ELEMENTS OF SCATTER
8262C                  PLOT MATRIX.
8263C
8264          ISUBZZ=ISUBSW(1)
8265          IREFZZ=IREFSW(1)
8266          IF(ISPMDS.EQ.'ON')THEN
8267            IF(IROW.NE.ITEMP1)THEN
8268              ISUBSW(1)='OFF'
8269              IREFSW(1)='OFF'
8270            ELSE
8271              ISUBSW(1)='ON'
8272              IREFSW(1)='ON'
8273            ENDIF
8274          ENDIF
8275C
8276          CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL,
8277     1                IMPNR,IMPNC,IROW,ICOL,IRES,IFACT,IPLOT,
8278     1                NPLOT2,NUMVAR,
8279     1                ICHAP2,ILINP2,
8280     1                GY1MNS,GY1MXS,GY2MNS,GY2MXS,
8281     1                GX1MNS,GX1MXS,GX2MNS,GX2MXS,
8282     1                IY1MNS,IY1MXS,IY2MNS,IY2MXS,
8283     1                IX1MNS,IX1MXS,IX2MNS,IX2MXS,
8284     1                IX1TSV,IX2TSV,IY1TSV,IY2TSV,
8285     1                IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
8286     1                PX1LD2,PX2LD2,
8287     1                IY1LJ2,IY1LD2,PY1LD2,PY1LA2,
8288     1                IX1LT2,IX2LT2,IY1LT2,IY2LT2,
8289     1                NCX1L2,NCX2L2,NCY1L2,NCY2L2,
8290     1                PSPLLL,PSPLUL,PSPLLL,PSPLUL,ICOL,
8291     1                ISPMLA,ISPMLD,IPLOTT,ISPMFR,ISPMXA,ISPMYA,
8292     1                ISPMDI,ISPX1L,
8293     1                ISPMXT,ISPMXL,ISPMYT,ISPMYL,
8294     1                ISPMTD,PSPMTD,IVNMEX,
8295     1                IBUGG2,ISUBRO)
8296C
8297          IF(IEMPTY.EQ.'YES')THEN
8298            DO6606I=1,100
8299              ICHAPA(I)='BLAN'
8300              ILINPA(I)='BLAN'
8301              ISPISW(I)='OFF'
8302              IBARSW(I)='OFF'
8303 6606        CONTINUE
8304          ENDIF
8305          IF(IROW.EQ.ICOL.AND.ISPMPT.EQ.'CROS'.AND.ISPMST.EQ.'    ')
8306     1    THEN
8307            ILINPA(1)='BLAN'
8308            ICHAPA(1)='BLAN'
8309            ISPISW(1)='OFF'
8310            IBARSW(1)='OFF'
8311          ENDIF
8312          IF(IROW.EQ.ICOL)THEN
8313            ISHIFT=NCCOM2
8314            IF(NCCOM2.GT.0)
8315     1      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8316     1                  IBUGG2,IERROR)
8317            ICOM=ICBT
8318            ICOM2=IC2BT
8319            IF(NCCOM2.GT.0)THEN
8320              DO6620II=1,NCCOM2
8321                IHARG(II)=IHBT(II)
8322                IHARG2(II)=IH2BT(II)
8323 6620         CONTINUE
8324            ENDIF
8325          ELSE
8326            ISHIFT=NCCOMM
8327            IF(NCCOMM.GT.0)
8328     1      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8329     1                  IBUGG2,IERROR)
8330            ICOM=ICT
8331            ICOM2=IC2T
8332            IF(NCCOMM.GT.0)THEN
8333              DO6630II=1,NCCOMM
8334                IHARG(II)=IHT(II)
8335                IHARG2(II)=IH2T(II)
8336 6630         CONTINUE
8337            ENDIF
8338          ENDIF
8339          IF(IEMPTY.EQ.'YES'.AND.ISPMPT.EQ.'DEXC')THEN
8340            ISHIFT=NUMARG-2
8341            IF(ISHIFT.GT.0)THEN
8342              CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8343     1                    IBUGG2,IERROR)
8344            ENDIF
8345            ICOM='PLOT'
8346            ICOM2='    '
8347            IHARG(1)=IVARN1(IRES)
8348            IHARG2(1)=IVARN2(IRES)
8349            IHARG(2)=IVARN1(IFACT)
8350            IHARG2(2)=IVARN2(IFACT)
8351          ENDIF
8352          CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
8353     1                MAXNPP,ISEED,IBOOSS,
8354     1                IX1TSV,IX2TSV,IY1TSV,IY2TSV,
8355     1                IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
8356     1                BARHEF,BARWEF,
8357     1                IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,
8358     1                IHSTMC,IHSTOP,
8359     1                ICAPSW,IFORSW,
8360     1                IGUIFL,IERRFA,
8361     1                IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
8362CCCCC1                TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
8363     1                MAXNXT,
8364     1                ISUBRO,IFOUND,IERROR)
8365          IF(IEMPTY.EQ.'NO')THEN
8366            CALL DPSPM3(ICASPL,IOUNI5,
8367     1                  IROW,ICOL,
8368     1                  PX2LD2,NPLOTP,
8369     1                  IFORSW,
8370     1                  ISPX2L,ISPX2P,ISPX2S,
8371     1                  IHRIGH,IHRIG2,IHWUSE,
8372     1                  ISUBN1,ISUBN2,MESSAG,
8373     1                  IBUGG2,ISUBRO,IERROR)
8374          ENDIF
8375C
8376          ISHIFT=NARGT-NUMARG
8377          IF(ISHIFT.GT.0)THEN
8378            CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8379     1                IBUGG2,IERROR)
8380          ELSEIF(ISHIFT.LT.0)THEN
8381            ISHIFT=-ISHIFT
8382            CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8383     1                IBUGG2,IERROR)
8384          ENDIF
8385          IF(IERROR.EQ.'YES')GOTO6699
8386          ICOM='PLOT'
8387          ICOM2='    '
8388          IF(IRESP.EQ.0)THEN
8389            IHARG(1)=IVARN1(ICOL)
8390            IHARG2(1)=IVARN2(ICOL)
8391            IHARG(2)=IVARN1(ICOL)
8392            IHARG2(2)=IVARN2(ICOL)
8393          ELSE
8394            IHARG(1)=IVARN1(1)
8395            IHARG2(1)=IVARN2(1)
8396            IHARG(2)=IVARN1(ICOL)
8397            IHARG2(2)=IVARN2(ICOL)
8398            IHARG(3)=IVARN1(ICOL)
8399            IHARG2(3)=IVARN2(ICOL)
8400          ENDIF
8401          IF(ISPMPT.EQ.'DEXC')THEN
8402            IHARG(4)=IVARN1(NUMVAR+1)
8403            IHARG2(4)=IVARN2(NUMVAR+1)
8404          ENDIF
8405          GOTO6690
8406C
8407 6690     CONTINUE
8408          ICONT=IDCONT(1)
8409          IPOWE=IDPOWE(1)
8410          NUMHPP=IDNHPP(1)
8411          IMPARG=2
8412          CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
8413     1                XMATN,YMATN,XMITN,YMITN,
8414     1                ISQUAR,
8415     1                IVGMSW,IHGMSW,
8416     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
8417     1                IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
8418     1                YPLOT,XPLOT,X2PLOT,TAGPLO,
8419     1                IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
8420     1                IMPARG,
8421     1                PMXMIN,PMXMAX,PMYMIN,PMYMAX,
8422     1                MAXCOL,
8423     1                DSIZE,DSYMB,DCOLOR,DFILL,
8424     1                ICAPSW,
8425     1                IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
8426     1                IERROR)
8427C
8428          ICNTPL=ICNTPL+1
8429          IF(N.GT.0)THEN
8430            DO6671II=1,N
8431              WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
8432 6671       CONTINUE
8433          ENDIF
8434C
8435 6699     CONTINUE
8436          IF(IERROR.EQ.'NO')IAND1=IAND2
8437          IF(IEMPTY.EQ.'YES')THEN
8438            DO6207I=1,MAXSUB
8439              ISUBSW(I)=ISU2SW(I)
8440 6207       CONTINUE
8441          ENDIF
8442          PX1LDS=PX1LD2
8443          GX1MIN=GX1MNS
8444          GX1MAX=GX1MXS
8445          GX2MIN=GX2MNS
8446          GX2MAX=GX2MXS
8447          GY1MIN=GY1MNS
8448          GY1MAX=GY1MXS
8449          GY2MIN=GY2MNS
8450          GY2MAX=GY2MXS
8451          IX1MIN=IX1MNS
8452          IX1MAX=IX1MXS
8453          IX2MIN=IX2MNS
8454          IX2MAX=IX2MXS
8455          IY1MIN=IY1MNS
8456          IY1MAX=IY1MXS
8457          IY2MIN=IY2MNS
8458          IY2MAX=IY2MXS
8459          PX1ZDS=PX1ZD2
8460          PX2ZDS=PX2ZD2
8461          PY1ZDS=PY1ZD2
8462          PY2ZDS=PY2ZD2
8463C
8464          ISUBSW(1)=ISUBZZ
8465          IREFSW(1)=IREFZZ
8466C
8467 6700   CONTINUE
8468 6600 CONTINUE
8469      GOTO8000
8470C
8471C               **************************************************
8472C               **   STEP 25--                                  **
8473C               **   PLOT THE CURRENT PLOT                      **
8474C               **************************************************
8475          ICONT=IDCONT(1)
8476          IPOWE=IDPOWE(1)
8477          NUMHPP=IDNHPP(1)
8478          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'SPMA')THEN
8479            WRITE(ICOUT,7907)IMANUF,NUMDEV,IDMANU(1)
8480 7907       FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4)
8481            CALL DPWRST('XXX','BUG ')
8482          ENDIF
8483          IMPARG=2
8484          CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
8485     1                XMATN,YMATN,XMITN,YMITN,
8486     1                ISQUAR,
8487     1                IVGMSW,IHGMSW,
8488     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
8489     1                IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
8490     1                YPLOT,XPLOT,X2PLOT,TAGPLO,
8491     1                IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
8492     1                IMPARG,
8493     1                PMXMIN,PMXMAX,PMYMIN,PMYMAX,
8494     1                MAXCOL,
8495     1                DSIZE,DSYMB,DCOLOR,DFILL,
8496     1                ICAPSW,
8497     1                IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
8498     1                IERROR)
8499C
8500          ICNTPL=ICNTPL+1
8501          IF(N.GT.0)THEN
8502            DO7917II=1,N
8503              WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
8504 7917       CONTINUE
8505          ENDIF
8506C
8507          IF(IERROR.EQ.'NO')IAND1=IAND2
8508          IF(IERROR.EQ.'YES')GOTO7900
8509          PX1LDS=PX1LD2
8510          GX1MIN=GX1MNS
8511          GX1MAX=GX1MXS
8512          GX2MIN=GX2MNS
8513          GX2MAX=GX2MXS
8514          GY1MIN=GY1MNS
8515          GY1MAX=GY1MXS
8516          GY2MIN=GY2MNS
8517          GY2MAX=GY2MXS
8518          IX1MIN=IX1MNS
8519          IX1MAX=IX1MXS
8520          IX2MIN=IX2MNS
8521          IX2MAX=IX2MXS
8522          IY1MIN=IY1MNS
8523          IY1MAX=IY1MXS
8524          IY2MIN=IY2MNS
8525          IY2MAX=IY2MXS
8526          PX1ZDS=PX1ZD2
8527          PX2ZDS=PX2ZD2
8528          PY1ZDS=PY1ZD2
8529          PY2ZDS=PY2ZD2
8530C
8531 7900   CONTINUE
8532        ISPMFR=ISPMFZ
8533C
8534C               **************************************************
8535C               **   STEP 28--                                  **
8536C               **   REINSTATE INITIAL SETTINGS                 **
8537C               **************************************************
8538C
8539 8000 CONTINUE
8540C
8541      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'4PLO')THEN
8542        ISTEPN='28'
8543        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8544        WRITE(ICOUT,8807)IMANUF,NUMDEV,IDMANU(1)
8545 8807   FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4)
8546        CALL DPWRST('XXX','BUG ')
8547      ENDIF
8548C
8549      IFLAG=2
8550      CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC,
8551     1            IBUGG2,ISUBRO,IFOUND,IERROR)
8552      ISPMTA=ISPMTZ
8553      ISPMFR=ISPMFZ
8554      ISPMPT=ISPMPZ
8555      ISPMLD=ISPMLZ
8556      ISPMLA=ISPML2
8557      ISPMXA=ISPMXZ
8558      ISPMYA=ISPMYZ
8559      ISPMDI=ISPMDZ
8560      ISPMST=ISPMZT
8561      ISPMS2=ISPMZ2
8562      ISPMS3=ISPMZ3
8563      ISPMS4=ISPMZ4
8564C
8565      IOPTN=2
8566      IDX=0
8567      IDY=0
8568      CALL DPSPM4(ICASPL,IOPTN,IDX,IDY,
8569     1            ISUBNU,
8570     1            ISUBSW,
8571     1            ASUBXL,ASUBXU,ASUBYL,ASUBYU,
8572     1            ISUBN9,
8573     1            ISUBSZ,
8574     1            ASBXL2,ASBXU2,ASBYL2,ASBYU2,
8575     1            PSPLSL,PSPLSU,PSPLSL,PSPLSU,
8576     1            IBUGG2,ISUBRO,IERROR)
8577      IF(IERROR.EQ.'YES')GOTO9000
8578C
8579      IFEEDB=IFEED9
8580C
8581C               *****************
8582C               **  STEP 90--  **
8583C               **  EXIT       **
8584C               *****************
8585C
8586 9000 CONTINUE
8587C
8588      IOP='CLOS'
8589      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
8590     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
8591     1            IBUGG2,ISUBRO,IERROR)
8592      IFITAU=IFITA2
8593C
8594      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SPMA')THEN
8595        WRITE(ICOUT,999)
8596        CALL DPWRST('XXX','BUG ')
8597        WRITE(ICOUT,9011)
8598 9011   FORMAT('***** AT THE END       OF DPSPMA--')
8599        CALL DPWRST('XXX','BUG ')
8600        WRITE(ICOUT,9012)IFOUND,IERROR
8601 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
8602        CALL DPWRST('XXX','BUG ')
8603        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
8604 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
8605        CALL DPWRST('XXX','BUG ')
8606      ENDIF
8607C
8608      RETURN
8609      END
8610      SUBROUTINE DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL,
8611     1                  IMPNR,IMPNC,IROW,ICOL,IRES,
8612     1                  IFACT,IPLOT,NPLOTS,NUMVAR,
8613     1                  ICHAP2,ILINP2,
8614     1                  GY1MNS,GY1MXS,GY2MNS,GY2MXS,
8615     1                  GX1MNS,GX1MXS,GX2MNS,GX2MXS,
8616     1                  IY1MNS,IY1MXS,IY2MNS,IY2MXS,
8617     1                  IX1MNS,IX1MXS,IX2MNS,IX2MXS,
8618     1                  IX1TSV,IX2TSV,IY1TSV,IY2TSV,
8619     1                  IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
8620     1                  PX1LD2,PX2LD2,
8621     1                  IY1LJ2,IY1LD2,PY1LD2,PY1LA2,
8622     1                  IX1LT2,IX2LT2,IY1LT2,IY2LT2,
8623     1                  NCX1L2,NCX2L2,NCY1L2,NCY2L2,
8624     1                  PSPXLL,PSPXUL,PSPYLL,PSPYUL,IXLIST,
8625     1                  ISPMLA,ISPMLD,ISPMPT,ISPMFR,ISPMXA,
8626     1                  ISPMYA,ISPMDI,ISPX1L,
8627     1                  ISPMXT,ISPMXL,ISPMYT,ISPMYL,
8628     1                  ISPMTD,PSPMTD,IVNMEX,
8629     1                  IBUGG2,ISUBRO)
8630C
8631C     PURPOSE--UTILTY ROUTINE FOR SCATTER PLOT MATRIX.  GENERATE
8632C              TIC MARKS, TIC MARK LABELS, AXIS LABELS.  ALSO
8633C              USED BY FACTOR AND CONDITIONING PLOTS.
8634C     WRITTEN BY--ALAN HECKERT
8635C                 STATISTICAL ENGINEERING DIVISION
8636C                 INFORMATION TECHNOLOGY LABORATORY
8637C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8638C                 GAITHERSBURG, MD 20899-8980
8639C                 PHONE--301-975-2899
8640C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8641C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8642C     LANGUAGE--ANSI FORTRAN (1977)
8643C     VERSION NUMBER--99/11
8644C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--NOVEMBER 1999.
8645C     UPDATED       --JUNE       2002.  UPDATES FOR PARTIAL REGRESSION
8646C     UPDATED       --JUNE       2002.  UPDATES FOR PARTIAL RESIDUAL
8647C     UPDATED       --JUNE       2002.  UPDATES FOR PARTIAL LEVERAGE
8648C     UPDATED       --MAY        2007.  UPDATES FOR BINARY TABULATION
8649C
8650C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
8651C
8652      INCLUDE 'DPCOPA.INC'
8653      INCLUDE 'DPCOPC.INC'
8654      INCLUDE 'DPCOHK.INC'
8655C
8656      CHARACTER*4 ICASPL
8657      CHARACTER*4 IBUGG2
8658C
8659      CHARACTER*4 ISUBRO
8660C
8661      CHARACTER*4 ISPMLA
8662      CHARACTER*4 ISPMLD
8663      CHARACTER*4 ISPMPT
8664      CHARACTER*4 ISPMFR
8665      CHARACTER*4 ISPMXA
8666      CHARACTER*4 ISPMYA
8667      CHARACTER*4 ISPMDI
8668      CHARACTER*4 ISPMTD
8669      CHARACTER*4 IVNMEX
8670      CHARACTER*4 ISPX1L
8671      CHARACTER*4 ISPMXT
8672      CHARACTER*4 ISPMXL
8673      CHARACTER*4 ISPMYT
8674      CHARACTER*4 ISPMYL
8675C
8676      CHARACTER*105 IXT
8677      CHARACTER*52 IX2T
8678      CHARACTER*52 IY1T
8679      CHARACTER*4 IXLABT(52)
8680      CHARACTER*4 IXLAB2(52)
8681      CHARACTER*4 IYLABT(52)
8682C
8683      CHARACTER*24 ICHAP2(100)
8684      CHARACTER*4 ILINP2(100)
8685      CHARACTER*4 IY1MNS
8686      CHARACTER*4 IY1MXS
8687      CHARACTER*4 IY2MNS
8688      CHARACTER*4 IY2MXS
8689      CHARACTER*4 IY1LJ2
8690      CHARACTER*4 IY1LD2
8691      CHARACTER*4 IX1MNS
8692      CHARACTER*4 IX1MXS
8693      CHARACTER*4 IX2MNS
8694      CHARACTER*4 IX2MXS
8695      CHARACTER*4 IX1TSV
8696      CHARACTER*4 IX2TSV
8697      CHARACTER*4 IY1TSV
8698      CHARACTER*4 IY2TSV
8699      CHARACTER*4 IX1ZSV
8700      CHARACTER*4 IX2ZSV
8701      CHARACTER*4 IY1ZSV
8702      CHARACTER*4 IY2ZSV
8703      CHARACTER*4 IX1LT2(*)
8704      CHARACTER*4 IX2LT2(*)
8705      CHARACTER*4 IY1LT2(*)
8706      CHARACTER*4 IY2LT2(*)
8707C
8708      CHARACTER*4 IVARN1
8709      CHARACTER*4 IVARN2
8710C
8711      DIMENSION ICOLL(*)
8712      DIMENSION IVARN1(*)
8713      DIMENSION IVARN2(*)
8714      DIMENSION PSPXLL(*)
8715      DIMENSION PSPXUL(*)
8716      DIMENSION PSPYLL(*)
8717      DIMENSION PSPYUL(*)
8718C
8719C-----COMMON------------------------------------------------------
8720C
8721C-----COMMON VARIABLES (GENERAL)----------------------------------
8722C
8723      INCLUDE 'DPCOP2.INC'
8724C
8725C-----START POINT-------------------------------------------------
8726C
8727      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM1')THEN
8728        WRITE(ICOUT,999)
8729        CALL DPWRST('XXX','BUG ')
8730        WRITE(ICOUT,1011)
8731 1011   FORMAT('***** AT THE BEGINNING OF DPSPM1--')
8732        CALL DPWRST('XXX','BUG ')
8733        WRITE(ICOUT,1013)IX1MNS,IX1MXS,IX2MNS,IX2MXS
8734 1013   FORMAT('IX1MNS,IX1MXS,IX2MNS,IX2MXS = ',3(A4,2X),A4)
8735        CALL DPWRST('XXX','BUG ')
8736        WRITE(ICOUT,1015)IY1MNS,IY1MXS,IY2MNS,IY2MXS
8737 1015   FORMAT('IY1MNS,IY1MXS,IY2MNS,IY2MXS = ',3(A4,2X),A4)
8738        CALL DPWRST('XXX','BUG ')
8739      ENDIF
8740C
8741      ITEMP=0
8742C
8743C               ***************************************
8744C               **  STEP 1--                         **
8745C               **  TURN EVERYTHING OFF IF DATAPLOT  **
8746C               **  DETERMINES AXIS APPEARANCE AND   **
8747C               **  RESET DEFAULTS WHERE APPROPRIATE **
8748C               ***************************************
8749C
8750C
8751      DO10I=1,52
8752        IXLABT(I)=' '
8753        IXLAB2(I)=' '
8754        IYLABT(I)=' '
8755   10 CONTINUE
8756      DO15I=1,MAXCH
8757        IX1LTE(I)=IX1LT2(I)
8758        IX2LTE(I)=IX2LT2(I)
8759        IY1LTE(I)=IY1LT2(I)
8760        IY2LTE(I)=IY2LT2(I)
8761   15 CONTINUE
8762      IXT=' '
8763      IX2T=' '
8764      IY1T=' '
8765      NCX1LA=NCX1L2
8766      NCX2LA=NCX2L2
8767      NCY1LA=NCY1L2
8768      NCY2LA=NCY2L2
8769C
8770      IF(ISPMFR.EQ.'DEFA')THEN
8771        IX1TSW='OFF'
8772        IX1ZSW='OFF'
8773        IX2TSW='OFF'
8774        IX2ZSW='OFF'
8775        IY1TSW='OFF'
8776        IY1ZSW='OFF'
8777        IY2TSW='OFF'
8778        IY2ZSW='OFF'
8779        DO105I=1,MAXCH
8780          IX1LTE(I)='    '
8781          IX2LTE(I)='    '
8782          IY1LTE(I)='    '
8783          IY2LTE(I)='    '
8784  105   CONTINUE
8785        NCX1LA=0
8786        NCY1LA=0
8787        NCY2LA=0
8788        PX1LDS=PX1LD2
8789        PY1LDS=PY1LD2
8790        PY1LAN=PY1LA2
8791        IY1LJU=IY1LJ2
8792        IY1LDI=IY1LD2
8793      ELSE
8794        IX1TSW=IX1TSV
8795        IX1ZSW=IX1ZSV
8796        IX2TSW=IX2TSV
8797        IX2ZSW=IX2ZSV
8798        IY1TSW=IY1TSV
8799        IY1ZSW=IY1ZSV
8800        IY2TSW=IY2TSV
8801        IY2ZSW=IY2ZSV
8802      ENDIF
8803C
8804      DO110I=1,100
8805        ICHAPA(I)=ICHAP2(I)
8806        ILINPA(I)=ILINP2(I)
8807  110 CONTINUE
8808C
8809C               ***************************************
8810C               **  STEP 2--                         **
8811C               **  DETERMINE Y AXIS LIMITS (I.E.,   **
8812C               **  DEFAULT OR USER SPECIFIED)       **
8813C               ***************************************
8814C
8815      IF(IRES.GT.0)THEN
8816        YLOWL=PSPYLL(IRES)
8817        YUPPL=PSPYUL(IRES)
8818      ELSE
8819        YLOWL=CPUMIN
8820        YUPPL=CPUMIN
8821      ENDIF
8822      IF(IXLIST.GT.0)THEN
8823        XLOWL=PSPXLL(IXLIST)
8824        XUPPL=PSPXUL(IXLIST)
8825      ELSE
8826        XLOWL=CPUMIN
8827        XUPPL=CPUMIN
8828      ENDIF
8829      IF(YLOWL.NE.CPUMIN.AND.YUPPL.NE.CPUMIN)THEN
8830        GY1MIN=YLOWL
8831        GY1MAX=YUPPL
8832        GY2MIN=YLOWL
8833        GY2MAX=YUPPL
8834        IY1MIN='FIXE'
8835        IY1MAX='FIXE'
8836        IY2MIN='FIXE'
8837        IY2MAX='FIXE'
8838      ELSE
8839        IF(IY1MIN.NE.'FIXE')GY1MIN=GY1MNS
8840        IF(IY2MIN.NE.'FIXE')GY2MIN=GY2MNS
8841        IF(IY1MAX.NE.'FIXE')GY1MAX=GY1MXS
8842        IF(IY2MAX.NE.'FIXE')GY2MAX=GY2MXS
8843      ENDIF
8844C
8845C               ***************************************
8846C               **  STEP 3--                         **
8847C               **  DETERMINE X AXIS LIMITS (I.E.,   **
8848C               **  DEFAULT OR USER SPECIFIED)       **
8849C               ***************************************
8850C
8851      IF(XLOWL.NE.CPUMIN.AND.XUPPL.NE.CPUMIN)THEN
8852        GX1MIN=XLOWL
8853        GX1MAX=XUPPL
8854        GX2MIN=XLOWL
8855        GX2MAX=XUPPL
8856        IX1MIN='FIXE'
8857        IX1MAX='FIXE'
8858        IX2MIN='FIXE'
8859        IX2MAX='FIXE'
8860      ELSE
8861        IF(IX1MIN.NE.'FIXE')GX1MIN=GX1MNS
8862        IF(IX2MIN.NE.'FIXE')GX2MIN=GX2MNS
8863        IF(IX1MAX.NE.'FIXE')GX1MAX=GX1MXS
8864        IF(IX2MAX.NE.'FIXE')GX2MAX=GX2MXS
8865      ENDIF
8866C
8867C               ***************************************
8868C               **  STEP 4--                         **
8869C               **  DETERMINE TEXT FOR X AND Y AXIS  **
8870C               **  LABELS.  DO ONCE HERE TO SIMPLIFY**
8871C               **  CODE BELOW.                      **
8872C               ***************************************
8873C
8874      IF(ISPMLA.EQ.'OFF')GOTO9000
8875CCCCC IF(ISPMLA.EQ.'ROSE')GOTO9000
8876CCCCC IF(ISPMLA.EQ.'ROS2')GOTO9000
8877C
8878      IF(ISPMPT.EQ.'PLOT'.OR.ISPMPT.EQ.'QQSP'.OR.ISPMPT.EQ.'CROS')THEN
8879        IXT=' '
8880        NX1=-1
8881        IX1DS=1
8882        IX2T=' '
8883        NX2=0
8884        IX2DS=0
8885        IY1T=' '
8886        NY1=-1
8887      ELSEIF(ISPMPT.EQ.'BITA' .OR. ISPMPT.EQ.'BIPL')THEN
8888        IXT=' '
8889        NX1=0
8890        IX1DS=0
8891        IX2T=' '
8892        NX2=0
8893        IX2DS=0
8894        IY1T=' '
8895        NY1=0
8896      ELSEIF(ISPMPT.EQ.'PREG')THEN
8897        IXT=' '
8898        IXT='Res: '
8899        NX1=5
8900        NX1=NX1+1
8901        IXT(NX1:NX1+3)=IVARN1(IPLOT+1)(1:4)
8902        IXT(NX1+4:NX1+7)=IVARN2(IPLOT+1)(1:4)
8903        DO140I=NX1+7,NX1,-1
8904          NXTEMP=I
8905          IF(IXT(I:I).NE.'    ')GOTO145
8906  140   CONTINUE
8907  145   CONTINUE
8908        NX1=NXTEMP
8909        NX1=NX1+1
8910        NXTEMP=NX1+14
8911        IXT(NX1:NXTEMP)=' versus other X'
8912        NX1=NXTEMP
8913C
8914        IX1DS=1
8915        IX2T=' '
8916        NX2=0
8917        IX2DS=0
8918C
8919        NY1=5
8920        IY1T(1:NY1)='Res: '
8921        NY1=NY1+1
8922        IY1T(NY1:NY1+3)=IVARN1(IPLOT+1)(1:4)
8923        IY1T(NY1+4:NY1+7)=IVARN2(IPLOT+1)(1:4)
8924        DO130I=NY1+7,NY1,-1
8925          NYTEMP=I
8926          IF(IY1T(I:I).NE.'    ')GOTO135
8927  130   CONTINUE
8928  135   CONTINUE
8929        NY1=NYTEMP
8930        NY1=NY1+1
8931        NYTEMP=NY1+7
8932        IY1T(NY1:NYTEMP)=' Removed'
8933        NY1=NYTEMP
8934      ELSEIF(ISPMPT.EQ.'PLEV')THEN
8935        IXT=' '
8936        NX1=5
8937        IXT(1:NX1)='Index'
8938C
8939        IX1DS=1
8940        IX2T=' '
8941        NX2=0
8942        IX2DS=0
8943C
8944        IY1T=' '
8945        IY1T='Partial Leverage: '
8946        NY1=18
8947        NY1=NY1+1
8948        IY1T(NY1:NY1+3)=IVARN1(IPLOT+1)(1:4)
8949        IY1T(NY1+4:NY1+7)=IVARN2(IPLOT+1)(1:4)
8950        DO170I=NY1+7,NY1,-1
8951          NYTEMP=I
8952          IF(IY1T(I:I).NE.'    ')GOTO175
8953  170   CONTINUE
8954  175   CONTINUE
8955        NY1=NYTEMP
8956      ELSEIF(ISPMPT.EQ.'PRES'.OR.ISPMPT.EQ.'CCPR')THEN
8957        NX1=1
8958        IXT(NX1:NX1+3)=IVARN1(IPLOT+1)(1:4)
8959        IXT(NX1+4:NX1+7)=IVARN2(IPLOT+1)(1:4)
8960        DO150I=NX1+7,NX1,-1
8961          NXTEMP=I
8962          IF(IXT(I:I).NE.'    ')GOTO155
8963  150   CONTINUE
8964  155   CONTINUE
8965        NX1=NXTEMP
8966C
8967        IX1DS=1
8968        IX2T=' '
8969        NX2=0
8970        IX2DS=0
8971C
8972        IY1T=' '
8973        IY1T='Residuals + A'
8974        NY1=13
8975        IF(IPLOT.LE.9)THEN
8976          NY1=NY1+1
8977          WRITE(IY1T(NY1:NY1),'(I1)')IPLOT
8978        ELSE
8979          NY1=NY1+1
8980          NYTEMP=NY1+1
8981          WRITE(IY1T(NY1:NYTEMP),'(I2)')IPLOT
8982          NY1=NYTEMP
8983        ENDIF
8984        NY1=NY1+1
8985        IY1T(NY1:NY1)='*'
8986        NY1=NY1+1
8987        IY1T(NY1:NY1+3)=IVARN1(IPLOT+1)(1:4)
8988        IY1T(NY1+4:NY1+7)=IVARN2(IPLOT+1)(1:4)
8989        DO160I=NY1+7,NY1,-1
8990          NYTEMP=I
8991          IF(IY1T(I:I).NE.'    ')GOTO165
8992  160   CONTINUE
8993  165   CONTINUE
8994        NY1=NYTEMP
8995      ELSEIF(ISPMPT.EQ.'DEXS'.OR.ISPMPT.EQ.'DEXI'.OR.
8996     1       ISPMPT.EQ.'CRO2')THEN
8997        IXT=' '
8998        NX1=-2
8999        IF(ISPMXA.EQ.'TOP' .OR. ISPMXA.EQ.'TORI')NX1=-1
9000        IF(ISPX1L.EQ.'FILL')NX1=-3
9001        IX1DS=-1
9002        IX2T=' '
9003        NX2=0
9004        IX2DS=0
9005        IY1T=' '
9006        NY1=-1
9007      ELSEIF(ISPMPT.EQ.'DEXC')THEN
9008        IXT=' '
9009        NX1=-2
9010        IF(ISPX1L.EQ.'FILL')NX1=-3
9011        IX1DS=-1
9012        IX2T=' '
9013        NX2=0
9014        IX2DS=0
9015        IY1T=' '
9016        NY1=0
9017      ELSEIF(ISPMPT.EQ.'BIHI')THEN
9018        IXT=' '
9019        NX1=-1
9020        IX1DS=-1
9021        IX2T=' '
9022        NX2=-1
9023        IX2DS=-2
9024        IY1T='Frequency'
9025        NY1=9
9026      ELSEIF(ISPMPT.EQ.'CCOR')THEN
9027        IXT='Lag'
9028        NX1=3
9029        IX1DS=1
9030        IX2T=' '
9031        NX2=-2
9032        IX2DS=-1
9033        IY1T='Correlation'
9034        NY1=11
9035      ELSEIF(ISPMPT.EQ.'CSPE')THEN
9036        IXT='Frequency'
9037        NX1=9
9038        IX1DS=1
9039        IX2T=' '
9040        NX2=-2
9041        IX2DS=-1
9042        IY1T='Power'
9043        NY1=5
9044      ELSEIF(ISPMPT.EQ.'CLAG')THEN
9045        IXT='I+1'
9046        NX1=3
9047        IX1DS=1
9048        IX2T=' '
9049        NX2=-2
9050        IX2DS=-1
9051        IY1T='I'
9052        NY1=1
9053      ELSEIF(ISPMPT.EQ.'FPLO'.OR.ISPMPT.EQ.'QQFP'.OR.
9054     1       ISPMPT.EQ.'STAT')THEN
9055        IXT=' '
9056        NX1=-1
9057        IX1DS=-1
9058        IX2T=' '
9059        NX2=0
9060        IX2DS=0
9061        IY1T=' '
9062        NY1=-1
9063      ELSEIF(ISPMPT.EQ.'BOXC')THEN
9064        IXT='Alpha'
9065        NX1=5
9066        IX1DS=1
9067        IX2T=' '
9068        NX2=-1
9069        IX2DS=-1
9070        IY1T='Correlation'
9071        NY1=11
9072      ELSEIF(ISPMPT.EQ.'CBXC')THEN
9073        IXT='Alpha'
9074        NX1=5
9075        IX1DS=1
9076        IX2T=' '
9077        NX2=-2
9078        IX2DS=-1
9079        IY1T='Correlation'
9080        NY1=11
9081      ELSEIF(ISPMPT.EQ.'HIST')THEN
9082        IXT=' '
9083        NX1=-1
9084        IX1DS=-1
9085        IX2T=' '
9086        NX2=0
9087        IX2DS=-1
9088        IY1T='Frequency'
9089        NY1=9
9090      ELSEIF(ISPMPT.EQ.'CDEN' .OR. ISPMPT.EQ.'KERN')THEN
9091        IXT=' '
9092        NX1=-1
9093        IX1DS=-1
9094        IX2T=' '
9095        NX2=0
9096        IX2DS=-1
9097        IY1T='Density'
9098        NY1=7
9099      ELSEIF(ISPMPT.EQ.'RUNS')THEN
9100        IXT='Sequence'
9101        NX1=8
9102        IX1DS=1
9103        IX2T=' '
9104        NX2=-1
9105        IX2DS=-1
9106        IY1T=' '
9107        NY1=0
9108      ELSEIF(ISPMPT.EQ.'LAG ')THEN
9109        IXT='I+1'
9110        NX1=3
9111        IX1DS=1
9112        IX2T=' '
9113        NX2=0
9114        IX2DS=-1
9115        IY1T='I'
9116        NY1=1
9117      ELSEIF(ISPMPT.EQ.'PERC')THEN
9118        IXT='Percentile'
9119        NX1=10
9120        IX1DS=1
9121        IX2T=' '
9122        NX2=-1
9123        IX2DS=-1
9124        IY1T=' '
9125        NY1=0
9126      ELSEIF(ISPMPT.EQ.'CPER')THEN
9127        IXT='Percentile'
9128        NX1=10
9129        IX1DS=1
9130        IX2T=' '
9131        NX2=0
9132        IX2DS=-1
9133        IY1T=' '
9134        NY1=-1
9135      ELSEIF(ISPMPT.EQ.'AUTO')THEN
9136        IXT='Lag'
9137        NX1=3
9138        IX1DS=1
9139        IX2T=' '
9140        NX2=-1
9141        IX2DS=-1
9142        IY1T='Frequency'
9143        NY1=9
9144      ELSEIF(ISPMPT.EQ.'SPEC')THEN
9145        IXT='Frequency'
9146        NX1=9
9147        IX1DS=1
9148        IX2T=' '
9149        NX2=-1
9150        IX2DS=-1
9151        IY1T='Power'
9152        NY1=5
9153      ELSEIF(ISPMPT.EQ.'PROB')THEN
9154        IXT='Theoretical'
9155        NX1=11
9156        IX1DS=1
9157        IX2T=' '
9158        NX2=-1
9159        IX2DS=-1
9160        IY1T='Data'
9161        NY1=4
9162      ELSEIF(ISPMPT.EQ.'PPCC')THEN
9163        IXT='Parameter'
9164        NX1=9
9165        IX1DS=1
9166        IX2T=' '
9167        NX2=-1
9168        IX2DS=-1
9169        IY1T='Correlation'
9170        NY1=11
9171      ELSEIF(ISPMPT.EQ.'ROSE' .OR. ISPMPT.EQ.'ROS2')THEN
9172        IXT=' '
9173        NX1=1
9174        IX1DS=1
9175        IX2T=' '
9176        NX2=1
9177        IX2DS=-1
9178        IY1T=' '
9179        NY1=1
9180      ELSE
9181        IXT=' '
9182        NX1=-1
9183        IX1DS=1
9184        IX2T=' '
9185        NX2=0
9186        IX2DS=0
9187        IY1T=' '
9188        NY1=1
9189      ENDIF
9190C
9191      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM1')THEN
9192        WRITE(ICOUT,999)
9193        CALL DPWRST('XXX','BUG ')
9194        WRITE(ICOUT,1012)
9195 1012   FORMAT('***** FINISH SECTION 1--')
9196        CALL DPWRST('XXX','BUG ')
9197      ENDIF
9198C
9199C  X1LABEL
9200C
9201C  1) IF NX1 > 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED,
9202C     OTHERWISE, DEFAULT TO A DATAPLOT SPECIFIED LABEL.
9203C  2) IF NX1 = 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED,
9204C     BUT NO DEFAULT PROVIDED.
9205C  3) IF NX1 = -1, USE VARIABLE NAME (AND SUBSTITUTE VARIABLE
9206C     LABEL IF PROVIDED).
9207C  4) IF NX1 = -2, USE: VARIABLE1 * VARIABLE2 (AND SUBSTITUTE
9208C     VARIABLE LABEL IF PROVIDED).
9209C  5) IF NX1 = -3, USE: 1*2 (AND SUBSTITUTE
9210C     VARIABLE LABEL IF PROVIDED).
9211C
9212      IF(ICOL.EQ.0)THEN
9213        NCXLA=0
9214        GOTO299
9215      ENDIF
9216C
9217      IF(NX1.GE.0)THEN
9218        IF(NCX1L2.GT.0)THEN
9219          DO210I=1,NCX1L2
9220            IXLABT(I)=IX1LT2(I)
9221  210     CONTINUE
9222          NCXLA=NCX1L2
9223        ELSE
9224          NCXLA=0
9225          IF(NX1.GT.0)THEN
9226            DO220I=1,NX1
9227              IXLABT(I)(1:1)=IXT(I:I)
9228  220       CONTINUE
9229            NCXLA=NX1
9230          ENDIF
9231        ENDIF
9232      ELSEIF(NX1.LT.0)THEN
9233        ITEMP=IFACT
9234        IF(NX1.EQ.-2 .OR. NX2.EQ.-2)ITEMP=IRES
9235        IF(ISPMPT.EQ.'BIHI')ITEMP=IRES
9236        ICOLID=ICOLL(ITEMP)
9237        IF(IVARLB(ICOLID).EQ.' '.OR.IVNMEX.EQ.'OFF')THEN
9238          DO230I=1,4
9239            IXLABT(I)=IVARN1(ITEMP)(I:I)
9240            IXLABT(I+4)=IVARN2(ITEMP)(I:I)
9241  230     CONTINUE
9242          NCXLA=8
9243          DO240I=8,1,-1
9244            NCXLA=I
9245            IF(IXLABT(I).NE.'    ')GOTO245
9246  240     CONTINUE
9247  245     CONTINUE
9248        ELSE
9249          ILAST=40
9250          DO250I=40,1,-1
9251            IF(IVARLB(ICOLID)(I:I).NE.' ')THEN
9252              ILAST=I
9253              GOTO259
9254            ENDIF
9255  250     CONTINUE
9256  259     CONTINUE
9257          DO270I=1,ILAST
9258            IXLABT(I)(1:1)=IVARLB(ICOLID)(I:I)
9259  270     CONTINUE
9260          NCXLA=ILAST
9261        ENDIF
9262        IF(NX1.EQ.-1 .OR. IRES.EQ.IFACT)GOTO299
9263        NCXLA=NCXLA+1
9264        IXLABT(NCXLA)='*'
9265        ITEMP=IFACT
9266        ICOLID=ICOLL(ITEMP)
9267        IF(IVARLB(ICOLID).EQ.' ')THEN
9268          DO280I=1,4
9269            IXLABT(NCXLA+I)=IVARN1(ITEMP)(I:I)
9270            IXLABT(NCXLA+I+4)=IVARN2(ITEMP)(I:I)
9271  280     CONTINUE
9272          ILAST=NCXLA+8
9273          DO285I=ILAST,1,-1
9274            NCXLA=I
9275            IF(IXLABT(I).NE.'    ')GOTO288
9276  285     CONTINUE
9277  288     CONTINUE
9278        ELSE
9279          ILAST=40
9280          DO290I=40,1,-1
9281            IF(IVARLB(ICOLID)(I:I).NE.' ')THEN
9282              ILAST=I
9283              GOTO293
9284            ENDIF
9285  290     CONTINUE
9286  293     CONTINUE
9287          DO295I=1,ILAST
9288            NCXLA=NCXLA+1
9289            IXLABT(NCXLA)(1:1)=IVARLB(ICOLID)(I:I)
9290  295     CONTINUE
9291        ENDIF
9292      ENDIF
9293  299 CONTINUE
9294C
9295C  X2LABEL
9296C
9297C  1) IF NX2 > 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED,
9298C     OTHERWISE, DEFAULT TO A DATAPLOT SPECIFIED LABEL.
9299C  2) IF NX2 = 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED,
9300C     BUT NO DEFAULT PROVIDED.
9301C  3) IF NX2 = -1, USE VARIABLE NAME (AND SUBSTITUTE VARIABLE
9302C     LABEL IF PROVIDED).
9303C  4) IF NX2 = -2, USE: VARIABLE1 * VARIABLE2 (AND SUBSTITUTE
9304C     VARIABLE LABEL IF PROVIDED).
9305C
9306      IF(ICOL.EQ.0)THEN
9307        NCXLA2=0
9308        GOTO399
9309      ENDIF
9310C
9311      IF((NX1.EQ.-1.AND.NX2.EQ.-1).AND.IRES.EQ.IFACT)THEN
9312         NCXLA2=0
9313         GOTO399
9314      ENDIF
9315      IF(NX2.GE.0)THEN
9316        IF(NCX2L2.GT.0)THEN
9317          DO310I=1,NCX2L2
9318            IXLAB2(I)=IX2LT2(I)
9319  310     CONTINUE
9320          NCXLA2=NCX2L2
9321        ELSE
9322          NCXLA2=0
9323          IF(NX2.GT.0)THEN
9324            DO320I=1,NX2
9325              IXLAB2(I)(1:1)=IX2T(I:I)
9326  320       CONTINUE
9327            NCXLA2=NX2
9328          ENDIF
9329        ENDIF
9330      ELSEIF(NX2.LT.0)THEN
9331        ITEMP=IFACT
9332        IF(NX2.EQ.-2)ITEMP=IRES
9333        IF(ISPMPT.EQ.'BIHI')ITEMP=IFACT
9334        ICOLID=ICOLL(ITEMP)
9335        IF(IVARLB(ICOLID).EQ.' '.OR.IVNMEX.EQ.'OFF')THEN
9336          DO330I=1,4
9337            IXLAB2(I)=IVARN1(ITEMP)(I:I)
9338            IXLAB2(I+4)=IVARN2(ITEMP)(I:I)
9339  330     CONTINUE
9340          NCXLA2=8
9341          DO340I=8,1,-1
9342            NCXLA2=I
9343            IF(IXLAB2(I).NE.'    ')GOTO345
9344  340     CONTINUE
9345  345     CONTINUE
9346        ELSE
9347          ILAST=40
9348          DO350I=40,1,-1
9349            IF(IVARLB(ICOLID)(I:I).NE.' ')THEN
9350              ILAST=I
9351              GOTO359
9352            ENDIF
9353  350     CONTINUE
9354  359     CONTINUE
9355          DO370I=1,ILAST
9356            IXLAB2(I)(1:1)=IVARLB(ICOLID)(I:I)
9357  370     CONTINUE
9358          NCXLA2=ILAST
9359        ENDIF
9360        IF(NX2.EQ.-1.OR.IRES.EQ.IFACT)GOTO399
9361        NCXLA2=NCXLA2+1
9362        IXLAB2(NCXLA2)='*'
9363        ITEMP=IFACT
9364        ICOLID=ICOLL(ITEMP)
9365        IF(IVARLB(ICOLID).EQ.' ')THEN
9366          DO380I=1,4
9367            IXLAB2(NCXLA2+I)=IVARN1(ITEMP)(I:I)
9368            IXLAB2(NCXLA2+I+4)=IVARN2(ITEMP)(I:I)
9369  380     CONTINUE
9370          ILAST=NCXLA2+8
9371          DO385I=ILAST,1,-1
9372            NCXLA2=I
9373            IF(IXLAB2(I).NE.'    ')GOTO388
9374  385     CONTINUE
9375  388     CONTINUE
9376        ELSE
9377          ILAST=40
9378          DO390I=40,1,-1
9379            IF(IVARLB(ICOLID)(I:I).NE.' ')THEN
9380              ILAST=I
9381              GOTO393
9382            ENDIF
9383  390     CONTINUE
9384  393     CONTINUE
9385          DO395I=1,ILAST
9386            NCXLA2=NCXLA2+1
9387            IXLAB2(NCXLA2)(1:1)=IVARLB(ICOLID)(I:I)
9388  395     CONTINUE
9389        ENDIF
9390      ENDIF
9391  399 CONTINUE
9392C
9393C  Y1LABEL
9394C
9395C  1) IF NY1 > 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED,
9396C     OTHERWISE, DEFAULT TO A DATAPLOT SPECIFIED LABEL.
9397C  2) IF NY1 = 0, USE USER SPECIFIED LABEL IF ALREADY DEFINED,
9398C     BUT NO DEFAULT PROVIDED.
9399C  3) IF NY1 = -1, USE VARIABLE NAME (AND SUBSTITUTE VARIABLE
9400C     LABEL IF PROVIDED).
9401C
9402      IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IMPNR)THEN
9403        NCYLA=0
9404        GOTO599
9405      ENDIF
9406C
9407      IF(NY1.GE.0)THEN
9408        IF(NCY1L2.GT.0)THEN
9409          DO510I=1,NCY1L2
9410            IYLABT(I)=IY1LT2(I)
9411  510     CONTINUE
9412          NCYLA=NCY1L2
9413        ELSE
9414          NCYLA=0
9415          IF(NY1.GT.0)THEN
9416            DO520I=1,NY1
9417              IYLABT(I)(1:1)=IY1T(I:I)
9418  520       CONTINUE
9419            NCYLA=NY1
9420          ENDIF
9421        ENDIF
9422      ELSEIF(NY1.LT.0)THEN
9423        ITEMP=IRES
9424        IF(ISPMPT.EQ.'DEXI'.OR.ISPMPT.EQ.'DEXS')ITEMP=1
9425        ICOLID=ICOLL(ITEMP)
9426        IF(IVARLB(ICOLID).EQ.' '.OR.IVNMEX.EQ.'OFF')THEN
9427          DO530I=1,4
9428            IYLABT(I)=IVARN1(ITEMP)(I:I)
9429            IYLABT(I+4)=IVARN2(ITEMP)(I:I)
9430  530     CONTINUE
9431          NCYLA=8
9432          DO540I=8,1,-1
9433            NCYLA=I
9434            IF(IYLABT(I).NE.'    ')GOTO545
9435  540     CONTINUE
9436  545     CONTINUE
9437        ELSE
9438          ILAST=40
9439          DO560I=40,1,-1
9440            IF(IVARLB(ICOLID)(I:I).NE.' ')THEN
9441              ILAST=I
9442              GOTO569
9443            ENDIF
9444  560     CONTINUE
9445  569     CONTINUE
9446          DO570I=1,ILAST
9447            IYLABT(I)(1:1)=IVARLB(ICOLID)(I:I)
9448  570     CONTINUE
9449          NCYLA=ILAST
9450        ENDIF
9451      ENDIF
9452  599 CONTINUE
9453C
9454C               ***************************************
9455C               **  STEP 5--                         **
9456C               **  USER SPECIFIES AXIS ATTRIBUTES,  **
9457C               **  BUT DATAPLOT MAY SUBSTITUTE      **
9458C               **  VARIABLE NAME (OR LABEL) FOR     **
9459C               **  X1LABEL AND Y1LABEL              **
9460C               ***************************************
9461C
9462      IF(ISPMFR.EQ.'USER')THEN
9463        NCX1LA=NCXLA
9464        IF(NCX1LA.LE.0)GOTO1119
9465        DO1110I=1,NCX1LA
9466          IX1LTE(I)=IXLABT(I)
9467 1110   CONTINUE
9468 1119   CONTINUE
9469        IF(IX1DS.LT.0)PX1LDS=-((PYMAX-PYMIN)-PX1LD2)
9470        NCY1LA=NCYLA
9471        IF(NCY1LA.LE.0)GOTO1129
9472        DO1120I=1,NCY1LA
9473          IY1LTE(I)=IYLABT(I)
9474 1120   CONTINUE
9475 1129   CONTINUE
9476        NCX2LA=NCXLA2
9477        IF(NCX2LA.LE.0)GOTO1139
9478        DO1130I=1,NCX2LA
9479          IX2LTE(I)=IXLAB2(I)
9480 1130   CONTINUE
9481        PX2LDS=-((PYMAX-PYMIN)-PX2LD2)
9482        IF(IX2DS.EQ.-2)PX2LDS=-PX2LD2
9483 1139   CONTINUE
9484C
9485C               *******************************************
9486C               **  STEP 6--                             **
9487C               **  DATAPLOT SPECIFIES AXIS ATTRIBUTES   **
9488C               *******************************************
9489C
9490      ELSEIF(ISPMFR.EQ.'DEFA')THEN
9491C
9492        ITEMP1=MOD(ICOL,2)
9493        ITEMP2=MOD(IROW,2)
9494        IROWL=IMPNR
9495        IF(ISPMLA.EQ.'BOX'.AND.ICASPL.EQ.'SPMA')IROWL=NUMVAR+1
9496        ICOLF=1
9497        ICOLLA=IMPNC
9498        IF(ISPMLA.EQ.'BOX')ICOLF=0
9499C
9500C  IX1DS < 0 OR IX2DS < 0 SPECIFIES THAT THIS LABEL IS DRAWN
9501C  ON ALL PLOTS (AND DISPLACEMENT IS DISTANCE FROM TOP FRAME)
9502C
9503        IF(IX1DS.LT.0.AND.ISPMLA.NE.'BOX')THEN
9504          NCX1LA=NCXLA
9505          IF(NCX1LA.GT.0)THEN
9506            DO1505I=1,NCX1LA
9507              IX1LTE(I)=IXLABT(I)
9508 1505       CONTINUE
9509          ENDIF
9510          PX1LDS=-((PYMAX-PYMIN)-PX1LD2)
9511        ENDIF
9512        IF(IX2DS.LT.0.AND.ISPMLA.NE.'BOX')THEN
9513          NCX2LA=NCXLA2
9514          IF(NCX2LA.GT.0)THEN
9515            DO1508I=1,NCX2LA
9516              IX2LTE(I)=IXLAB2(I)
9517 1508       CONTINUE
9518          ENDIF
9519          PX2LDS=-((PYMAX-PYMIN)-PX2LD2)
9520          IF(IX2DS.EQ.-2)PX2LDS=-PX1LD2
9521        ENDIF
9522C
9523        IF(ISPMXA.EQ.'YON')GOTO1499
9524        IF(ISPMXA.EQ.'ALTE')THEN
9525          IF((IROW.EQ.IROWL.AND.ITEMP1.EQ.1).OR.
9526     1       (ISPMLD.EQ.'OFF'.AND.ITEMP1.EQ.1.AND.IROW.EQ.ICOL).OR.
9527     1       (IROW.EQ.IMPNR-1.AND.ICOL.EQ.IMPNC.AND.ITEMP.EQ.1.AND.
9528     1       NPLOTS.LT.IMPNR*IMPNC).OR.
9529     1       (ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL)
9530     1       )THEN
9531            IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.0)GOTO1519
9532            IF(ISPMLA.EQ.'BOX'.AND.ITEMP1.EQ.0)GOTO1512
9533            IF(ISPMLA.EQ.'YON')THEN
9534              IX1TSW='OFF'
9535              IX1ZSW='OFF'
9536            ELSE
9537              IX1TSW='ON'
9538              IX1ZSW='ON'
9539            ENDIF
9540            IX2TSW='OFF'
9541            IX2ZSW='OFF'
9542 1512       CONTINUE
9543            IFLAG=0
9544            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9545     1        ISPMDI.EQ.'BLAN')IFLAG=1
9546            IF(IX1DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG=1
9547            IFLAG2=0
9548            IF(IX2DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG2=1
9549            IF(IFLAG.EQ.0)THEN
9550              NCX1LA=NCXLA
9551              IF(NCX1LA.GT.0)THEN
9552                DO1510I=1,NCX1LA
9553                IX1LTE(I)=IXLABT(I)
9554 1510           CONTINUE
9555              ENDIF
9556            ENDIF
9557            IF(IFLAG2.EQ.0)THEN
9558              NCX2LA=NCXLA2
9559              IF(NCX2LA.GT.0)THEN
9560                DO1516I=1,NCX2LA
9561                IX2LTE(I)=IXLAB2(I)
9562 1516           CONTINUE
9563              ENDIF
9564            ENDIF
9565 1519       CONTINUE
9566            IF(ISPMLA.EQ.'BOX')PX1LDS=-((PYMAX-PYMIN)/2.0)
9567          ENDIF
9568C
9569          IF(IROW.EQ.1.AND.ITEMP1.EQ.0)THEN
9570            IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.0)GOTO1529
9571            IX1TSW='OFF'
9572            IX1ZSW='OFF'
9573            IF(ISPMLA.EQ.'YON')THEN
9574              IX2TSW='OFF'
9575              IX2ZSW='OFF'
9576            ELSE
9577              IX2TSW='ON'
9578              IX2ZSW='ON'
9579            ENDIF
9580            IFLAG=0
9581            IF(ISPMLA.EQ.'BOX')IFLAG=1
9582            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9583     1        ISPMDI.EQ.'BLAN')IFLAG=1
9584            IF(IX1DS.LT.0)IFLAG=1
9585            IFLAG2=0
9586            IF(IX2DS.LT.0)IFLAG2=1
9587            IF(IFLAG.EQ.0)THEN
9588              NCX1LA=NCXLA
9589              IF(NCX1LA.GT.0)THEN
9590                DO1520I=1,NCX1LA
9591                IX1LTE(I)=IXLABT(I)
9592 1520           CONTINUE
9593              ENDIF
9594            ENDIF
9595            IF(IFLAG2.EQ.0)THEN
9596              NCX2LA=NCXLA2
9597              IF(NCX2LA.GT.0)THEN
9598                DO1526I=1,NCX2LA
9599                IX2LTE(I)=IXLAB2(I)
9600 1526           CONTINUE
9601              ENDIF
9602            ENDIF
9603 1529       CONTINUE
9604            IF(IX1DS.GT.0)PX1LDS=-((PYMAX-PYMIN)+PX1LD2)
9605            IF(ISPMLA.EQ.'BOX')PX1LDS=-((PYMAX-PYMIN)/2.0)
9606          ENDIF
9607        ELSEIF(ISPMXA.EQ.'BOTT' .OR. ISPMXA.EQ.'BOLE' .OR.
9608     1         ISPMXA.EQ.'BORI')THEN
9609C
9610          IF(ISPMXA.EQ.'BOLE')THEN
9611            IF(ISPMLD.EQ.'ON')THEN
9612              IF(ICOL.NE.1 .OR. IROW.NE.IROWL)THEN
9613                NCXLA=0
9614                NCX1LA=NCXLA
9615                GOTO1618
9616              ENDIF
9617            ELSE
9618              IF(ICOL.NE.1 .OR. IROW.NE.1)THEN
9619                NCXLA=0
9620                NCX1LA=NCXLA
9621                GOTO1618
9622              ENDIF
9623            ENDIF
9624          ELSEIF(ISPMXA.EQ.'BORI')THEN
9625            IF(ICOL.NE.ICOLLA .OR. IROW.NE.IROWL)THEN
9626              NCXLA=0
9627              NCX1LA=NCXLA
9628              IF(ISPMXT.EQ.'OFF')IX1TSW='OFF'
9629              IF(ISPMXL.EQ.'OFF')IX1ZSW='OFF'
9630              GOTO1618
9631            ENDIF
9632          ELSE
9633            IF(ISPMLD.EQ.'ON')THEN
9634              IF(IROW.NE.IROWL)THEN
9635                NCXLA=0
9636                NCX1LA=NCXLA
9637                GOTO1618
9638              ENDIF
9639            ELSE
9640              IF(IROW.NE.ICOL)THEN
9641                NCXLA=0
9642                NCX1LA=NCXLA
9643                GOTO1618
9644              ENDIF
9645            ENDIF
9646          ENDIF
9647C
9648          IF((ISPMLD.EQ.'ON'.AND.IROW.EQ.IROWL) .OR.
9649     1       (ISPMLD.EQ.'OFF'.AND.IROW.EQ.ICOL))THEN
9650            IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.0)GOTO1619
9651            IF(ISPMLA.EQ.'YON')THEN
9652              IX1TSW='OFF'
9653              IX1ZSW='OFF'
9654            ELSE
9655              IX1TSW='ON'
9656              IX1ZSW='ON'
9657              IF(ISPMXT.EQ.'OFF')IX1TSW='OFF'
9658              IF(ISPMXL.EQ.'OFF')IX1ZSW='OFF'
9659            ENDIF
9660            IF(ISPMTD.EQ.'STAG'.AND.ITEMP1.EQ.0)PX1ZDS=PSPMTD
9661            IX2TSW='OFF'
9662            IX2ZSW='OFF'
9663            IFLAG=0
9664            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9665     1        ISPMDI.EQ.'BLAN')IFLAG=1
9666            IF(IX1DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG=1
9667            IFLAG2=0
9668            IF(IX2DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG2=1
9669            IF(IFLAG.EQ.0)THEN
9670              NCX1LA=NCXLA
9671              IF(NCX1LA.GT.0)THEN
9672                DO1610I=1,NCX1LA
9673                IX1LTE(I)=IXLABT(I)
9674 1610           CONTINUE
9675              ENDIF
9676            ENDIF
9677            IF(IFLAG2.EQ.0)THEN
9678              NCX2LA=NCXLA2
9679              IF(NCX2LA.GT.0)THEN
9680                DO1616I=1,NCX2LA
9681                IX2LTE(I)=IXLAB2(I)
9682 1616           CONTINUE
9683              ENDIF
9684            ENDIF
9685 1619       CONTINUE
9686            IF(ISPMLA.EQ.'BOX')PX1LDS=-((PYMAX-PYMIN)/2.0)
9687          ENDIF
9688 1618     CONTINUE
9689        ELSEIF(ISPMXA.EQ.'TOP' .OR. ISPMXA.EQ.'TOLE' .OR.
9690     1         ISPMXA.EQ.'TORI')THEN
9691C
9692          IF(ISPMXA.EQ.'TOLE')THEN
9693            IF(IROW.NE.1 .OR. ICOL.NE.1)THEN
9694                NCXLA=0
9695                NCX1LA=NCXLA
9696                GOTO1728
9697            ENDIF
9698          ELSEIF(ISPMXA.EQ.'TORI')THEN
9699            IF(IROW.NE.1 .OR. ICOL.NE.ICOLLA)THEN
9700              NCXLA=0
9701              NCX1LA=NCXLA
9702              GOTO1728
9703            ENDIF
9704          ELSE
9705            IF(IROW.NE.1)THEN
9706                NCXLA=0
9707                NCX1LA=NCXLA
9708                GOTO1728
9709            ENDIF
9710          ENDIF
9711C
9712          IF(IROW.EQ.1)THEN
9713            IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.0)GOTO1719
9714            IX1TSW='OFF'
9715            IX1ZSW='OFF'
9716            IF(ISPMLA.EQ.'YON')THEN
9717              IX2TSW='OFF'
9718              IX2ZSW='OFF'
9719            ELSE
9720              IX2TSW='ON'
9721              IX2ZSW='ON'
9722              IF(ISPMXT.EQ.'OFF')IX2TSW='OFF'
9723              IF(ISPMXL.EQ.'OFF')IX2ZSW='OFF'
9724            ENDIF
9725            IF(ISPMTD.EQ.'STAG'.AND.ITEMP1.EQ.0)PX2ZDS=PSPMTD
9726            IFLAG=0
9727            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9728     1        ISPMDI.EQ.'BLAN')IFLAG=1
9729            IF(IX1DS.LT.0)IFLAG=1
9730            IF(ISPMLA.EQ.'BOX')GOTO1719
9731            IFLAG2=0
9732            IF(IX2DS.LT.0)IFLAG2=1
9733            IF(IFLAG.EQ.0)THEN
9734              NCX1LA=NCXLA
9735              IF(NCX1LA.GT.0)THEN
9736                DO1710I=1,NCX1LA
9737                IX1LTE(I)=IXLABT(I)
9738 1710           CONTINUE
9739              ENDIF
9740            ENDIF
9741            IF(IFLAG2.EQ.0)THEN
9742              NCX2LA=NCXLA2
9743              IF(NCX2LA.GT.0)THEN
9744                DO1716I=1,NCX2LA
9745                IX2LTE(I)=IXLAB2(I)
9746 1716           CONTINUE
9747              ENDIF
9748            ENDIF
9749 1719       CONTINUE
9750            PX1LDS=-(100.0+PX1LD2)
9751          ENDIF
9752C
9753          IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL.AND.ICOL.GT.0)THEN
9754            IFLAG=0
9755            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9756     1        ISPMDI.EQ.'BLAN')IFLAG=1
9757            IF(IX1DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG=1
9758            IFLAG2=0
9759            IF(IX2DS.LT.0.AND.ISPMLA.NE.'BOX')IFLAG2=1
9760            IF(IFLAG.EQ.0)THEN
9761              NCX1LA=NCXLA
9762              IF(NCX1LA.GT.0)THEN
9763                DO1720I=1,NCX1LA
9764                IX1LTE(I)=IXLABT(I)
9765 1720           CONTINUE
9766              ENDIF
9767            ENDIF
9768            PX1LDS=-(100.0+PX1LD2)
9769          ENDIF
9770 1728     CONTINUE
9771        ENDIF
9772C
9773 1499   CONTINUE
9774        IF(ISPMYA.EQ.'OFF')GOTO1699
9775        IF(ISPMYA.EQ.'ALTE')THEN
9776          IF((ICOL.EQ.IMPNC.AND.ITEMP2.EQ.0).OR.
9777     1       (ISPMLA.EQ.'BOX'.AND.ICOL.EQ.IMPNC-1.AND.ITEMP2.EQ.0).OR.
9778     1       (IPLOT.EQ.NPLOTS.AND.ITEMP2.EQ.0))THEN
9779            IY1TSW='OFF'
9780            IY1ZSW='OFF'
9781            IF(ISPMLA.EQ.'XON')THEN
9782              IY2TSW='OFF'
9783              IY2ZSW='OFF'
9784            ELSE
9785              IY2TSW='ON'
9786              IY2ZSW='ON'
9787            ENDIF
9788            IFLAG=0
9789            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9790     1        ISPMDI.EQ.'BLAN')IFLAG=1
9791            IF(ISPMLA.EQ.'BOX')IFLAG=1
9792            IF(IFLAG.EQ.0)THEN
9793              NCY2LA=NCYLA
9794              IF(NCY2LA.LE.0)GOTO1539
9795              DO1530I=1,NCY2LA
9796                IY2LTE(I)=IYLABT(I)
9797 1530         CONTINUE
9798 1539         CONTINUE
9799            ENDIF
9800          ENDIF
9801C
9802          IF(ICOL.EQ.ICOLF.AND.ITEMP2.EQ.1.OR.
9803     1      (ISPMLA.EQ.'BOX'.AND.ICOL.EQ.ICOLF).OR.
9804     1      (ISPMLD.EQ.'OFF'.AND.ITEMP2.EQ.1.AND.IROW.EQ.ICOL))THEN
9805            IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL)GOTO1549
9806            IF(ISPMLA.EQ.'BOX'.AND.ITEMP2.EQ.0)GOTO1542
9807            IF(ISPMLA.EQ.'XON')THEN
9808              IY1TSW='OFF'
9809              IY1ZSW='OFF'
9810            ELSE
9811              IY1TSW='ON'
9812              IY1ZSW='ON'
9813            ENDIF
9814            IY2TSW='OFF'
9815            IY2ZSW='OFF'
9816 1542       CONTINUE
9817            IFLAG=0
9818            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9819     1        ISPMDI.EQ.'BLAN')IFLAG=1
9820            IF(IFLAG.EQ.0)THEN
9821              NCY1LA=NCYLA
9822              IF(NCY1LA.LE.0)GOTO1549
9823              DO1540I=1,NCY1LA
9824                IY1LTE(I)=IYLABT(I)
9825 1540         CONTINUE
9826            ENDIF
9827            IF(ISPMLA.EQ.'BOX')THEN
9828              IY1LJU='CENT'
9829              PY1LDS=-((PXMAX-PXMIN)/2.0)
9830              PY1LAN=0.0
9831              IY1LDI='HORI'
9832            ENDIF
9833 1549       CONTINUE
9834          ENDIF
9835        ELSEIF(ISPMYA.EQ.'LEFT' .OR. ISPMYA.EQ.'LETO' .OR.
9836     1         ISPMYA.EQ.'LEBO')THEN
9837          IF(ISPMYA.EQ.'LETO' .AND. IROW.NE.1)GOTO1648
9838          IF(ISPMYA.EQ.'LEBO' .AND. IROW.NE.IROWL)GOTO1648
9839          IF(ICOL.EQ.ICOLF.OR.(ISPMLD.EQ.'OFF'.AND.IROW.EQ.ICOL))THEN
9840            IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL)GOTO1649
9841            IF(ISPMLA.EQ.'XON')THEN
9842              IY1TSW='OFF'
9843              IY1ZSW='OFF'
9844            ELSE
9845              IY1TSW='ON'
9846              IY1ZSW='ON'
9847              IF(ISPMYT.EQ.'OFF')IY1TSW='OFF'
9848              IF(ISPMYL.EQ.'OFF')IY1ZSW='OFF'
9849            ENDIF
9850            IF(ISPMTD.EQ.'STAG'.AND.ITEMP2.EQ.0)PY1ZDS=PSPMTD
9851            IY2TSW='OFF'
9852            IY2ZSW='OFF'
9853            IFLAG=0
9854            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9855     1        ISPMDI.EQ.'BLAN')IFLAG=1
9856            IF(IFLAG.EQ.0)THEN
9857              NCY1LA=NCYLA
9858              IF(NCY1LA.LE.0)GOTO1649
9859              DO1640I=1,NCY1LA
9860                IY1LTE(I)=IYLABT(I)
9861 1640         CONTINUE
9862            ENDIF
9863 1649       CONTINUE
9864            IF(ISPMLA.EQ.'BOX')THEN
9865              IY1LJU='CENT'
9866              PY1LDS=-((PXMAX-PXMIN)/2.0)
9867              PY1LAN=0.0
9868              IY1LDI='HORI'
9869            ENDIF
9870          ENDIF
9871 1648     CONTINUE
9872        ELSEIF(ISPMYA.EQ.'RIGH' .OR. ISPMYA.EQ.'RITO' .OR.
9873     1         ISPMYA.EQ.'RIBO')THEN
9874          IF(ISPMYA.EQ.'RITO' .AND. IROW.NE.1)GOTO1848
9875          IF(ISPMYA.EQ.'RIBO' .AND. IROW.NE.IROWL)GOTO1848
9876          IF(ICOL.EQ.IMPNC)THEN
9877            IF(ISPMLA.EQ.'BOX'.AND.IROW.EQ.IROWL)GOTO1839
9878            IY1TSW='OFF'
9879            IY1ZSW='OFF'
9880            IF(ISPMLA.EQ.'XON')THEN
9881              IY2TSW='OFF'
9882              IY2ZSW='OFF'
9883            ELSE
9884              IY2TSW='ON'
9885              IY2ZSW='ON'
9886              IF(ISPMYT.EQ.'OFF')IY2TSW='OFF'
9887              IF(ISPMYL.EQ.'OFF')IY2ZSW='OFF'
9888            ENDIF
9889            IF(ISPMTD.EQ.'STAG'.AND.ITEMP2.EQ.0)PY2ZDS=PSPMTD
9890            IFLAG=0
9891            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9892     1        ISPMDI.EQ.'BLAN')IFLAG=1
9893            IF(ISPMLA.EQ.'BOX')IFLAG=1
9894            IF(IFLAG.EQ.0)THEN
9895              NCY2LA=NCYLA
9896              IF(NCY2LA.LE.0)GOTO1839
9897              DO1830I=1,NCY2LA
9898                IY2LTE(I)=IYLABT(I)
9899 1830         CONTINUE
9900            ENDIF
9901 1839       CONTINUE
9902          ENDIF
9903C
9904          IF(ISPMLA.EQ.'BOX'.AND.ICOL.EQ.ICOLF.AND.IROW.LT.IROWL)THEN
9905            IFLAG=0
9906            IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9907     1        ISPMDI.EQ.'BLAN')IFLAG=1
9908            IF(IFLAG.EQ.0)THEN
9909              NCY1LA=NCYLA
9910              IF(NCY1LA.LE.0)GOTO1849
9911              DO1840I=1,NCY1LA
9912                IY1LTE(I)=IYLABT(I)
9913 1840         CONTINUE
9914            ENDIF
9915 1849       CONTINUE
9916          ENDIF
9917 1848     CONTINUE
9918        ENDIF
9919C
9920        IF(ICASPL.EQ.'SPMA'.AND.ISPMPT.EQ.'PLOT'.AND.
9921     1    ISPMDI.EQ.'BLAN'.AND.IROW.EQ.ICOL)THEN
9922          NCX1LA=NCXLA
9923          NCY1LA=0
9924          NCY2LA=0
9925          IF(NCX1LA.LE.0)GOTO1919
9926          DO1910I=1,NCX1LA
9927            IX1LTE(I)=IXLABT(I)
9928 1910     CONTINUE
9929 1919     CONTINUE
9930          PX1LDS=-((PYMAX-PYMIN)/2.0)
9931        ENDIF
9932 1699   CONTINUE
9933C
9934      ENDIF
9935C
9936C               *****************
9937C               **  STEP 90--  **
9938C               **  EXIT       **
9939C               *****************
9940C
9941 9000 CONTINUE
9942      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM1')THEN
9943        WRITE(ICOUT,999)
9944  999   FORMAT(1X)
9945        CALL DPWRST('XXX','BUG ')
9946        WRITE(ICOUT,9011)
9947 9011   FORMAT('***** AT THE END       OF DPSPM1--')
9948        CALL DPWRST('XXX','BUG ')
9949      ENDIF
9950C
9951      RETURN
9952      END
9953      SUBROUTINE DPSPM2(ICASPL,IVARN1,IVARN2,ICOLL,NUMVAR,NPLOTP,
9954     1                  IROW,ICOL,
9955     1                  TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
9956     1                  ALOWFR,ALOWDG,
9957     1                  IANGLU,MAXNPP,IAND1,IAND2,
9958     1                  ISPMFI,ISPMTA,
9959     1                  XMATN,YMATN,XMITN,YMITN,
9960     1                  ISQUAR,
9961     1                  IVGMSW,IHGMSW,
9962     1                  IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
9963     1                  IREPCH,
9964     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
9965     1                  ICNTPL,IOUNI5,
9966     1                  IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
9967     1                  IBUGUG,IBUGU2,IBUGU3,IBUGU4,
9968     1                  ISUBRO,IFOUND,IERROR)
9969C
9970C     PURPOSE--UTILTY ROUTINE FOR SCATTER PLOT MATRIX.  GENERATE
9971C              OVERLAID SMOOTH OR FITTED CURVE ON PLOT.  ALSO
9972C              USED BY FACTOR AND CONDITIONING PLOTS.
9973C     WRITTEN BY--ALAN HECKERT
9974C                 STATISTICAL ENGINEERING DIVISION
9975C                 INFORMATION TECHNOLOGY LABORATORY
9976C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9977C                 GAITHERSBURG, MD 20899-8980
9978C                 PHONE--301-975-2899
9979C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9980C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9981C     LANGUAGE--ANSI FORTRAN (1977)
9982C     VERSION NUMBER--99/11
9983C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--NOVEMBERR 1999.
9984C
9985C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
9986C
9987      INCLUDE 'DPCOPA.INC'
9988      INCLUDE 'DPCOPC.INC'
9989      INCLUDE 'DPCOHK.INC'
9990      INCLUDE 'DPCODA.INC'
9991      INCLUDE 'DPCOSP.INC'
9992C
9993      CHARACTER*4 ICASPL
9994      CHARACTER*4 ICASAN
9995      CHARACTER*4 IANGLU
9996      CHARACTER*4 IMPSW
9997      CHARACTER*4 IREPCH
9998      CHARACTER*4 ISQUAR
9999      CHARACTER*4 IVGMSW
10000      CHARACTER*4 IHGMSW
10001      CHARACTER*4 IAND1
10002      CHARACTER*4 IAND2
10003      CHARACTER*4 IFTEXP
10004      CHARACTER*4 IFTORD
10005      CHARACTER*4 IOPTME
10006      CHARACTER*4 IOPTHE
10007C
10008      CHARACTER*4 IBUGG2
10009      CHARACTER*4 IBUGG3
10010      CHARACTER*4 IBUGUG
10011      CHARACTER*4 IBUGU2
10012      CHARACTER*4 IBUGU3
10013      CHARACTER*4 IBUGU4
10014      CHARACTER*4 IBUGCO
10015      CHARACTER*4 IBUGEV
10016      CHARACTER*4 IBUGQ
10017C
10018      CHARACTER*4 ICONT
10019      CHARACTER*4 IPOWE
10020      CHARACTER*4 IWRITE
10021      CHARACTER*4 IFOUND
10022      CHARACTER*4 ISUBRO
10023      CHARACTER*4 IERROR
10024C
10025      CHARACTER*4 ISPMFI
10026      CHARACTER*4 ISPMTA
10027C
10028      CHARACTER*4 ICAPSW
10029      CHARACTER*4 ICASP2
10030      CHARACTER*4 IFORSW
10031      CHARACTER*4 ICOMT
10032      CHARACTER*4 ICOM2T
10033C
10034      CHARACTER*4 IVARN1
10035      CHARACTER*4 IVARN2
10036C
10037      DIMENSION ICOLL(*)
10038      DIMENSION IVARN1(*)
10039      DIMENSION IVARN2(*)
10040C
10041      DIMENSION TEMP(*)
10042      DIMENSION TEMP2(*)
10043      DIMENSION TEMP3(*)
10044      DIMENSION XTEMP1(*)
10045      DIMENSION XTEMP2(*)
10046C
10047      PARAMETER (MAXART=20)
10048      CHARACTER*4 ITHARG
10049      CHARACTER*4 ITHAR2
10050      CHARACTER*4 ITARGT
10051      CHARACTER*4 IANST
10052      DIMENSION ITHARG(MAXART)
10053      DIMENSION ITHAR2(MAXART)
10054      DIMENSION ITARG(MAXART)
10055      DIMENSION TARG(MAXART)
10056      DIMENSION ITARGT(MAXART)
10057      DIMENSION IANST(MAXSTR)
10058C
10059C-----COMMON VARIABLES (GENERAL)----------------------------------
10060C
10061      INCLUDE 'DPCOP2.INC'
10062C
10063C-----START POINT-------------------------------------------------
10064C
10065      DO11I=1,MAXNXT
10066        TEMP(I)=0.0
10067        TEMP2(I)=0.0
10068        TEMP3(I)=0.0
10069        XTEMP1(I)=0.0
10070        XTEMP2(I)=0.0
10071   11 CONTINUE
10072C
10073      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM2')THEN
10074        WRITE(ICOUT,12)ICASPL,IVARN1(1),IVARN2(1)
10075   12   FORMAT('ICASPL,IVARN1(1),IVARN2(1) = ',A4,2X,2A4)
10076        CALL DPWRST('XXX','BUG ')
10077        WRITE(ICOUT,14)ICOLL(1),NUMVAR,NPLOTP,IROW,ICOL
10078   14   FORMAT('ICOLL(1),NUMVAR,NPLOTP,IROW,ICOL = ',5I6)
10079        CALL DPWRST('XXX','BUG ')
10080      ENDIF
10081C
10082CCCCC NOTE: CURRENTLY, LOWESS (AND OTHER) TYPE FITS ONLY
10083CCCCC       USED FOR "PLOT Y X" TYPE COMMANDS.  NOTE THAT
10084CCCCC       SOME OF THE LOGIC OF THIS ROUTINE WILL NEED TO
10085CCCCC       BE UPDATED IF THIS CAPABILITY IS EXTENDED TO
10086CCCCC       ADDITIONAL PLOT TYPES (I.E., SOME CARE NEEDS TO BE
10087CCCCC       TAKEN TO ENSURE THAT SUBSET CLAUSES ARE CARRIED
10088CCCCC       ALONG PROPERLY).
10089C
10090C               ***************************************
10091C               **  STEP 1--                         **
10092C               ***************************************
10093C
10094      ICAPSW='OFF'
10095      IFORSW='-7'
10096      IERROR='NO'
10097C
10098C     PARTIAL REGRESSION, PARTIAL RESIDUAL, AND PARTIAL
10099C     LEVERAGE PLOT ALLOW FITTED CURVE TO OVERLAID.
10100C
10101      IF(ICASPL.EQ.'PREG' .OR. ICASPL.EQ.'PRES' .OR.
10102     1   ICASPL.EQ.'PLEV')THEN
10103        ICASP2='PLOT'
10104      ELSE
10105        IF(ICOM.NE.'PLOT')GOTO9000
10106      ENDIF
10107C
10108      ICOMT=ICOM
10109      ICOM2T=ICOM2
10110      ICASP2=ICASPL
10111      NUMART=NUMARG
10112      DO100I=1,NUMARG
10113        ITHARG(I)=IHARG(I)
10114        ITHAR2(I)=IHARG2(I)
10115        ITARG(I)=IARG(I)
10116        TARG(I)=ARG(I)
10117        ITARGT(I)=IARGT(I)
10118  100 CONTINUE
10119      DO102I=1,MAXSTR
10120        IANST(I)=IANS(I)
10121  102 CONTINUE
10122      IWIDT=IWIDTH
10123C
10124      IFLAG=3
10125      CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC,
10126     1            IBUGG2,ISUBRO,IFOUND,IERROR)
10127C
10128      IF(ISPMTA.EQ.'ON')THEN
10129        ISHIFT=1
10130        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
10131     1              IBUGG2,IERROR)
10132        ITAGCO=3
10133        DO119I=1,NUMARG
10134          IF(I.EQ.ITAGCO)GOTO119
10135          IHARG(I)=ITHARG(I)
10136          IHARG2(I)=ITHAR2(I)
10137          IARG(I)=ITARG(I)
10138          ARG(I)=TARG(I)
10139          IARGT(I)=ITARGT(I)
10140  119   CONTINUE
10141      ENDIF
10142C
10143      IF(ICASPL.EQ.'PREG' .OR. ICASPL.EQ.'PRES' .OR.
10144     1   ICASPL.EQ.'PLEV')THEN
10145         NUMARG=2
10146         ICOM='PLOT'
10147         ICOM2='    '
10148         IHARG(1)='YPLO'
10149         IHARG2(1)='T   '
10150         IHARG(2)='XPLO'
10151         IHARG2(2)='T   '
10152      ENDIF
10153C
10154      IF(ISPMFI.EQ.'LOES')THEN
10155        ICOM='LOWE'
10156        ICOM2='SS  '
10157        CALL DPLOW(ALOWFR,ALOWDG,ICAPSW,IFORSW,
10158     1             TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
10159     1             IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
10160      ELSEIF(ISPMFI.EQ.'LINE')THEN
10161        ICOM='FIT '
10162        ICOM2='    '
10163        ICASAN='FIT'
10164        CALL DPFIT(ICAPSW,IFORSW,
10165     1             IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
10166     1             IFOUND,IERROR)
10167      ELSEIF(ISPMFI.EQ.'QUAD')THEN
10168        ISHIFT=1
10169        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
10170     1              IBUGG2,IERROR)
10171        IF(IERROR.EQ.'YES')GOTO9000
10172        ICOM='QUAD'
10173        ICOM2='RATI'
10174        IHARG(1)='FIT '
10175        IHARG2(1)='    '
10176        ICASAN='FIT'
10177        CALL DPFIT(ICAPSW,IFORSW,
10178     1             IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
10179     1             IFOUND,IERROR)
10180      ELSEIF(ISPMFI.EQ.'SMOO')THEN
10181        ICOM='SMOO'
10182        ICOM2='TH  '
10183        ICASAN='SMOO'
10184        CALL DPSMOO(IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
10185      ENDIF
10186C
10187      ICOM='PLOT'
10188      ICOM2='    '
10189      ISHIFT=1
10190      IF(ISHIFT.GT.0)THEN
10191        CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
10192     1            IBUGG2,IERROR)
10193      ELSEIF(ISHIFT.LT.0)THEN
10194        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
10195     1            IBUGG2,IERROR)
10196      ENDIF
10197      IF(ISPMTA.EQ.'OFF')THEN
10198        ITEMP=2
10199      ELSE
10200        IWRITE='OFF'
10201        CALL MAXIM(TAGPLO,NPLOTP,IWRITE,XMAX,IBUGG3,IERROR)
10202        ITEMP=1+INT(XMAX)
10203        IF(ITEMP.LT.1.OR.ITEMP.GT.100)ITEMP=2
10204      ENDIF
10205C
10206      IF(ICASPL.EQ.'PREG' .OR. ICASPL.EQ.'PRES' .OR.
10207     1   ICASPL.EQ.'PLEV')THEN
10208        NUMARG=3
10209        ICOM='LET '
10210        ICOM2='    '
10211        IHARG(1)='XTEM'
10212        IHARG2(1)='P   '
10213        IHARG(2)='=   '
10214        IHARG2(2)='    '
10215        IHARG(3)='XPLO'
10216        IHARG2(3)='T   '
10217        IANS(1)='L   '
10218        IANS(2)='E   '
10219        IANS(3)='T   '
10220        IANS(4)='    '
10221        IANS(5)='X   '
10222        IANS(6)='T   '
10223        IANS(7)='E   '
10224        IANS(8)='M   '
10225        IANS(9)='P   '
10226        IANS(10)='    '
10227        IANS(11)='=   '
10228        IANS(12)='    '
10229        IANS(13)='X   '
10230        IANS(14)='P   '
10231        IANS(15)='L   '
10232        IANS(16)='O   '
10233        IANS(17)='T   '
10234        IWIDTH=17
10235        CALL DPLET(IANGLU,ISEED,IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,
10236     1             TEMP,TEMP2,XTEMP1,XTEMP2,MAXNXT,
10237     1             IFTEXP,IFTORD,IFORSW,
10238     1             ROOTAC,OPTACC,IOPTME,IOPTHE,
10239     1             ISUBRO,IFOUND,IERROR)
10240C
10241        IF(IERROR.EQ.'YES')GOTO9000
10242        ICOM='PLOT'
10243        ICOM2='    '
10244        IHARG(1)='PRED'
10245        IHARG2(1)='    '
10246        IHARG(2)='VS  '
10247        IHARG2(2)='    '
10248        IHARG(3)='XTEM'
10249        IHARG2(3)='P   '
10250      ELSE
10251        IHARG(1)='PRED'
10252        IHARG2(1)='    '
10253        IHARG(2)='VS  '
10254        IHARG2(2)='    '
10255        IHARG(3)=IVARN1(ICOL)
10256        IHARG2(3)=IVARN2(ICOL)
10257      ENDIF
10258      CALL DPPLOT(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
10259     1            IANGLU,MAXNPP,
10260     1            IBUGG2,IBUGG3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
10261     1            IFOUND,IERROR)
10262      ICASPL=ICASP2
10263C
10264C
10265C               **************************************************
10266C               **   STEP 25--                                  **
10267C               **   PLOT THE CURRENT PLOT                      **
10268C               **************************************************
10269C
10270      ICONT=IDCONT(1)
10271      IPOWE=IDPOWE(1)
10272      NUMHPP=IDNHPP(1)
10273      IMPARG=2
10274      CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
10275     1            XMATN,YMATN,XMITN,YMITN,
10276     1            ISQUAR,
10277     1            IVGMSW,IHGMSW,
10278     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
10279     1            IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
10280     1            YPLOT,XPLOT,X2PLOT,TAGPLO,
10281     1            IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
10282     1            IMPARG,
10283     1            PMXMIN,PMXMAX,PMYMIN,PMYMAX,
10284     1            MAXCOL,
10285     1            DSIZE,DSYMB,DCOLOR,DFILL,
10286     1            ICAPSW,
10287     1            IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
10288     1            IERROR)
10289C
10290      ICNTPL=ICNTPL+1
10291      IF(N.GT.0 .AND. IOUNI5.GT.0)THEN
10292        DO3115II=1,N
10293          WRITE(IOUNI5,3118)ICNTPL,Y(II),X(II),D(II)
10294 3115   CONTINUE
10295 3118   FORMAT(I12,3E15.7)
10296      ENDIF
10297C
10298      IF(IERROR.EQ.'NO')IAND1=IAND2
10299      IERROR='NO'
10300C
10301      NUMARG=NUMART
10302      ICOM=ICOMT
10303      ICOM2=ICOM2T
10304      DO900I=1,NUMARG
10305        IHARG(I)=ITHARG(I)
10306        IHARG2(I)=ITHAR2(I)
10307        IARG(I)=ITARG(I)
10308        ARG(I)=TARG(I)
10309        IARGT(I)=ITARGT(I)
10310  900 CONTINUE
10311      DO902I=1,MAXSTR
10312        IANS(I)=IANST(I)
10313  902 CONTINUE
10314      IWIDTH=IWIDT
10315C
10316      IFLAG=4
10317      CALL DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC,
10318     1            IBUGG2,ISUBRO,IFOUND,IERROR)
10319C
10320C               *****************
10321C               **  STEP 90--  **
10322C               **  EXIT       **
10323C               *****************
10324C
10325 9000 CONTINUE
10326      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM2')THEN
10327        WRITE(ICOUT,999)
10328  999   FORMAT(1X)
10329        CALL DPWRST('XXX','BUG ')
10330        WRITE(ICOUT,9011)
10331 9011   FORMAT('***** AT THE END       OF DPSPM2--')
10332        CALL DPWRST('XXX','BUG ')
10333      ENDIF
10334C
10335      RETURN
10336      END
10337      SUBROUTINE DPSPM3(ICASPL,IOUNI5,
10338     1                  IROW,ICOL,
10339     1                  PX2LD2,NPLOTP,
10340     1                  IFORSW,
10341     1                  ISPX2L,ISPX2P,ISPX2S,
10342     1                  IHRIGH,IHRIG2,IHWUSE,
10343     1                  ISUBN1,ISUBN2,MESSAG,
10344     1                  IBUGG2,ISUBRO,IERROR)
10345C
10346C     PURPOSE--UTILTY ROUTINE FOR SCATTER PLOT MATRIX.  GENERATE
10347C              AN X2LABEL BASED ON CORRELATION, EFFECT SIZE, OR
10348C              NUMBER OF DEFECTIVES.
10349C     WRITTEN BY--ALAN HECKERT
10350C                 STATISTICAL ENGINEERING DIVISION
10351C                 INFORMATION TECHNOLOGY LABORATORY
10352C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
10353C                 GAITHERSBURG, MD 20899-8980
10354C                 PHONE--301-975-2899
10355C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10356C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
10357C     LANGUAGE--ANSI FORTRAN (1977)
10358C     VERSION NUMBER--99/11
10359C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--NOVEMBERR 1999.
10360C
10361C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
10362C
10363      INCLUDE 'DPCOPA.INC'
10364      INCLUDE 'DPCODA.INC'
10365      INCLUDE 'DPCOPC.INC'
10366      INCLUDE 'DPCOHK.INC'
10367C
10368      CHARACTER*4 IBUGG2
10369      CHARACTER*4 ICASPL
10370      CHARACTER*4 IFORSW
10371      CHARACTER*4 IWRITE
10372      CHARACTER*4 ISUBRO
10373      CHARACTER*4 IERROR
10374C
10375      CHARACTER*4 ISPX2L
10376      CHARACTER*16 ISPX2P
10377      CHARACTER*16 ISPX2S
10378      CHARACTER*4 IHRIGH
10379      CHARACTER*4 IHRIG2
10380      CHARACTER*4 IHWUSE
10381      CHARACTER*4 ISUBN1
10382      CHARACTER*4 ISUBN2
10383      CHARACTER*4 MESSAG
10384      CHARACTER*4 IXVAL
10385C
10386C-----COMMON VARIABLES (GENERAL)----------------------------------
10387C
10388      INCLUDE 'DPCOP2.INC'
10389C
10390C-----START POINT-------------------------------------------------
10391C
10392C               ***************************************
10393C               **  STEP 1--                         **
10394C               ***************************************
10395C
10396      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'SPM3')THEN
10397        WRITE(ICOUT,12)ICASPL,NPLOTP
10398   12   FORMAT('ICASPL,NPLOTP = ',A4,2X,I8)
10399        CALL DPWRST('XXX','BUG ')
10400      ENDIF
10401C
10402      IERROR='NO'
10403      IF(ISPX2L.EQ.'OFF ')GOTO9000
10404      IF(ISPX2L.EQ.'NONE')GOTO9000
10405      IF(ISPX2L.EQ.'BLAN')GOTO9000
10406C
10407      ALOWH=0.0
10408      ACORR=0.0
10409      GRAND=CPUMIN
10410      NACC=0
10411      NREJ=0
10412C
10413      IHRIGH='ALOW'
10414      IHRIG2='HIGH'
10415      IHWUSE='P'
10416      MESSAG='NO'
10417      CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
10418     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
10419     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
10420      IF(IERROR.EQ.'NO')ALOWH=VALUE(ILOCP)
10421C
10422      IHRIGH='PLOT'
10423      IHRIG2='CORR'
10424      IHWUSE='P'
10425      MESSAG='NO'
10426      CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
10427     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
10428     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
10429      IF(IERROR.EQ.'NO')ACORR=VALUE(ILOCP)
10430C
10431      IHRIGH='NACC'
10432      IHRIG2='EPT '
10433      IHWUSE='P'
10434      MESSAG='NO'
10435      CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
10436     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
10437     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
10438      IF(IERROR.EQ.'NO')NACC=INT(VALUE(ILOCP)+0.5)
10439C
10440      IHRIGH='NREJ'
10441      IHRIG2='ECT '
10442      IHWUSE='P'
10443      MESSAG='NO'
10444      CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
10445     1             IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
10446     1             ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
10447      IERROR='NO'
10448C
10449      IHRIGH='GRAN'
10450      IHRIG2='DSTA'
10451      IHWUSE='P'
10452      MESSAG='NO'
10453      CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
10454     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
10455     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
10456      IF(IERROR.EQ.'NO')GRAND=VALUE(ILOCP)
10457C
10458      NUMDIG=-1
10459      IF(IFORSW.EQ.'0')NUMDIG=0
10460      IF(IFORSW.EQ.'1')NUMDIG=1
10461      IF(IFORSW.EQ.'2')NUMDIG=2
10462      IF(IFORSW.EQ.'3')NUMDIG=3
10463      IF(IFORSW.EQ.'4')NUMDIG=4
10464      IF(IFORSW.EQ.'5')NUMDIG=5
10465      IF(IFORSW.EQ.'6')NUMDIG=6
10466      IF(IFORSW.EQ.'7')NUMDIG=7
10467      IF(IFORSW.EQ.'8')NUMDIG=8
10468      IF(IFORSW.EQ.'9')NUMDIG=9
10469      IF(IFORSW.EQ.'10')NUMDIG=10
10470      IF(IFORSW.EQ.'-2')NUMDIG=-2
10471      IF(IFORSW.EQ.'-3')NUMDIG=-3
10472      IF(IFORSW.EQ.'-4')NUMDIG=-4
10473      IF(IFORSW.EQ.'-5')NUMDIG=-5
10474      IF(IFORSW.EQ.'-6')NUMDIG=-6
10475      IF(IFORSW.EQ.'-7')NUMDIG=-7
10476      IF(IFORSW.EQ.'-8')NUMDIG=-8
10477      IF(IFORSW.EQ.'-9')NUMDIG=-9
10478C
10479      IF(ISPX2L.EQ.'CORR'.OR.ISPX2L.EQ.'PCOR')THEN
10480        IWRITE='OFF'
10481        IF(ISPX2P.EQ.'DEFAULT')THEN
10482          IX2LTE(1)='C'
10483          IX2LTE(2)='O'
10484          IX2LTE(3)='R'
10485          IX2LTE(4)='R'
10486          IX2LTE(5)=' '
10487          IX2LTE(6)='='
10488          IX2LTE(7)=' '
10489          NCX2LA=7
10490        ELSEIF(ISPX2P.EQ.' ')THEN
10491          NCX2LA=0
10492        ELSE
10493          DO110I=16,1,-1
10494            IF(ISPX2P(I:I).NE.' ')THEN
10495              NCX2LA=I
10496              DO120J=1,NCX2LA
10497                IX2LTE(J)(1:1)=ISPX2P(J:J)
10498  120         CONTINUE
10499              GOTO129
10500            ENDIF
10501  110     CONTINUE
10502  129     CONTINUE
10503        ENDIF
10504        CONST=0.5
10505        IF(ACORR.LT.0.0)CONST=-0.5
10506        IF(ISPX2L.EQ.'PCOR')ACORR=100.0*ACORR
10507        IF(IOUNI5.GT.0)WRITE(IOUNI5,'(G15.7)')ACORR
10508        NDEF=3
10509        IF(ISPX2L.EQ.'PCOR')NDEF=1
10510        IF(NUMDIG.LT.0)THEN
10511          ICORR=INT(ACORR*10**NDEF + CONST)
10512          ACORR=REAL(ICORR)/(10**NDEF)
10513        ELSE
10514          ICORR=INT(ACORR*10**NUMDIG + CONST)
10515          ACORR=REAL(ICORR)/(10**NUMDIG)
10516        ENDIF
10517        NCX2LA=NCX2LA+1
10518        CALL DPCONH(ICORR,ACORR,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10519        NCX2LA=NCX2LA+NH
10520        IF(ISPX2S.EQ.'DEFAULT')THEN
10521          IF(ISPX2L.EQ.'PCOR')THEN
10522            NCX2LA=NCX2LA+1
10523            IX2LTE(NCX2LA)='%'
10524          ENDIF
10525        ELSEIF(ISPX2S.NE.' ')THEN
10526          DO210I=16,1,-1
10527            IF(ISPX2S(I:I).NE.' ')THEN
10528              NTEMP=I
10529              DO220J=1,NTEMP
10530                NCX2LA=NCX2LA+1
10531                IX2LTE(NCX2LA)(1:1)=ISPX2S(J:J)
10532  220         CONTINUE
10533              GOTO229
10534            ENDIF
10535  210     CONTINUE
10536  229     CONTINUE
10537        ENDIF
10538        CONST=0.5
10539        PX2LDS=-((PYMAX-PYMIN)-PX2LD2)
10540      ELSEIF(ISPX2L.EQ.'PACC')THEN
10541        IF(ISPX2P.EQ.'DEFAULT')THEN
10542          NCX2LA=0
10543        ELSEIF(ISPX2P.EQ.' ')THEN
10544          NCX2LA=0
10545        ELSE
10546          DO310I=16,1,-1
10547            IF(ISPX2P(I:I).NE.' ')THEN
10548              NCX2LA=I
10549              DO320J=1,NCX2LA
10550                IX2LTE(J)(1:1)=ISPX2P(J:J)
10551  320         CONTINUE
10552              GOTO329
10553            ENDIF
10554  310     CONTINUE
10555  329     CONTINUE
10556        ENDIF
10557        CONST=0.5
10558        AV=REAL(NACC)/REAL(NACC+NREJ)
10559        AV=100.0*AV
10560        IF(IOUNI5.GT.0)WRITE(IOUNI5,'(G15.7)')AV
10561        IF(AV.LT.0.0)CONST=-0.5
10562        IF(NUMDIG.GE.0)THEN
10563          IVAL=INT(AV*10**NUMDIG + CONST)
10564          AV=REAL(IVAL)/(10**NUMDIG)
10565        ENDIF
10566        NCX2LA=NCX2LA+1
10567        CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10568        NCX2LA=NCX2LA+NH
10569        IF(ISPX2S.EQ.'DEFAULT')THEN
10570          CONTINUE
10571        ELSEIF(ISPX2P.NE.' ')THEN
10572          DO360I=16,1,-1
10573            IF(ISPX2S(I:I).NE.' ')THEN
10574              NTEMP=I
10575              DO370J=1,NTEMP
10576                NCX2LA=NCX2LA+1
10577                IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J)
10578  370         CONTINUE
10579              GOTO379
10580            ENDIF
10581  360     CONTINUE
10582  379     CONTINUE
10583        ENDIF
10584        CONST=0.5
10585        PX2LDS=-((PYMAX-PYMIN)-PX2LD2)
10586C
10587      ELSEIF(ISPX2L.EQ.'NACC')THEN
10588        IF(ISPX2P.EQ.'DEFAULT')THEN
10589          NCX2LA=0
10590        ELSEIF(ISPX2P.EQ.' ')THEN
10591          NCX2LA=0
10592        ELSE
10593          DO410I=16,1,-1
10594            IF(ISPX2P(I:I).NE.' ')THEN
10595              NCX2LA=I
10596              DO420J=1,NCX2LA
10597                IX2LTE(J)(1:1)=ISPX2P(J:J)
10598  420         CONTINUE
10599              GOTO429
10600            ENDIF
10601  410     CONTINUE
10602  429     CONTINUE
10603        ENDIF
10604        CONST=0.5
10605        AV=REAL(NACC)
10606        IF(IOUNI5.GT.0)WRITE(IOUNI5,'(G15.7)')AV
10607        IF(AV.LT.0.0)CONST=-0.5
10608        IF(NUMDIG.GE.0)THEN
10609          IVAL=INT(AV*10**NUMDIG + CONST)
10610          AV=REAL(IVAL)/(10**NUMDIG)
10611        ENDIF
10612        NCX2LA=NCX2LA+1
10613        CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10614        NCX2LA=NCX2LA+NH
10615        IF(ISPX2S.EQ.'DEFAULT')THEN
10616          CONTINUE
10617        ELSEIF(ISPX2P.NE.' ')THEN
10618          DO460I=16,1,-1
10619            IF(ISPX2S(I:I).NE.' ')THEN
10620              NTEMP=I
10621              DO470J=1,NTEMP
10622                NCX2LA=NCX2LA+1
10623                IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J)
10624  470         CONTINUE
10625              GOTO479
10626            ENDIF
10627  460     CONTINUE
10628  479     CONTINUE
10629        ENDIF
10630        CONST=0.5
10631        PX2LDS=-((PYMAX-PYMIN)-PX2LD2)
10632C
10633      ELSEIF(ISPX2L.EQ.'AT  ')THEN
10634        IF(ISPX2P.EQ.'DEFAULT')THEN
10635          NCX2LA=0
10636        ELSEIF(ISPX2P.EQ.' ')THEN
10637          NCX2LA=0
10638        ELSE
10639          DO810I=16,1,-1
10640            IF(ISPX2P(I:I).NE.' ')THEN
10641              NCX2LA=I
10642              DO820J=1,NCX2LA
10643                IX2LTE(J)(1:1)=ISPX2P(J:J)
10644  820         CONTINUE
10645              GOTO829
10646            ENDIF
10647  810     CONTINUE
10648  829     CONTINUE
10649        ENDIF
10650        CONST=0.5
10651        AV=REAL(NACC)
10652        AV1=AV
10653        IF(AV.LT.0.0)CONST=-0.5
10654        IF(NUMDIG.GE.0)THEN
10655          IVAL=INT(AV*10**NUMDIG + CONST)
10656          AV=REAL(IVAL)/(10**NUMDIG)
10657        ENDIF
10658        NCX2LA=NCX2LA+1
10659        CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10660        NCX2LA=NCX2LA+NH
10661        NCX2LA=NCX2LA+1
10662        IX2LTE(NCX2LA)(1:1)='/'
10663        AV=REAL(NACC+NREJ)
10664        IF(IOUNI5.GT.0)WRITE(IOUNI5,'(2G15.7)')AV1,AV
10665        IF(AV.LT.0.0)CONST=-0.5
10666        IF(NUMDIG.GE.0)THEN
10667          IVAL=INT(AV*10**NUMDIG + CONST)
10668          AV=REAL(IVAL)/(10**NUMDIG)
10669        ENDIF
10670        NCX2LA=NCX2LA+1
10671        CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10672        NCX2LA=NCX2LA+NH
10673        IF(ISPX2S.EQ.'DEFAULT')THEN
10674          CONTINUE
10675        ELSEIF(ISPX2P.NE.' ')THEN
10676          DO860I=16,1,-1
10677            IF(ISPX2S(I:I).NE.' ')THEN
10678              NTEMP=I
10679              DO870J=1,NTEMP
10680                NCX2LA=NCX2LA+1
10681                IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J)
10682  870         CONTINUE
10683              GOTO879
10684            ENDIF
10685  860     CONTINUE
10686  879     CONTINUE
10687        ENDIF
10688        CONST=0.5
10689        PX2LDS=-((PYMAX-PYMIN)-PX2LD2)
10690C
10691      ELSEIF(ISPX2L.EQ.'ATP ')THEN
10692        IF(ISPX2P.EQ.'DEFAULT')THEN
10693          NCX2LA=0
10694        ELSEIF(ISPX2P.EQ.' ')THEN
10695          NCX2LA=0
10696        ELSE
10697          DO710I=16,1,-1
10698            IF(ISPX2P(I:I).NE.' ')THEN
10699              NCX2LA=I
10700              DO720J=1,NCX2LA
10701                IX2LTE(J)(1:1)=ISPX2P(J:J)
10702  720         CONTINUE
10703              GOTO729
10704            ENDIF
10705  710     CONTINUE
10706  729     CONTINUE
10707        ENDIF
10708        CONST=0.5
10709        AV=REAL(NACC)
10710        AV1=AV
10711        IF(AV.LT.0.0)CONST=-0.5
10712        IF(NUMDIG.GE.0)THEN
10713          IVAL=INT(AV*10**NUMDIG + CONST)
10714          AV=REAL(IVAL)/(10**NUMDIG)
10715        ENDIF
10716        NCX2LA=NCX2LA+1
10717        CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10718        NCX2LA=NCX2LA+NH
10719        NCX2LA=NCX2LA+1
10720        IX2LTE(NCX2LA)(1:1)='/'
10721        AV=REAL(NACC+NREJ)
10722        AV2=AV
10723        IF(AV.LT.0.0)CONST=-0.5
10724        IF(NUMDIG.GE.0)THEN
10725          IVAL=INT(AV*10**NUMDIG + CONST)
10726          AV=REAL(IVAL)/(10**NUMDIG)
10727        ENDIF
10728        NCX2LA=NCX2LA+1
10729        CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10730        NCX2LA=NCX2LA+NH
10731        NCX2LA=NCX2LA+1
10732        IX2LTE(NCX2LA)(1:1)=' '
10733        NCX2LA=NCX2LA+1
10734        IX2LTE(NCX2LA)(1:1)='='
10735        NCX2LA=NCX2LA+1
10736        IX2LTE(NCX2LA)(1:1)=' '
10737        AV=REAL(NACC)/REAL(NACC+NREJ)
10738        AV=100.0*AV
10739        IF(IOUNI5.GT.0)WRITE(IOUNI5,'(3G15.7)')AV1,AV2,AV
10740        IF(AV.LT.0.0)CONST=-0.5
10741        IF(NUMDIG.GE.0)THEN
10742          IVAL=INT(AV*10**NUMDIG + CONST)
10743          AV=REAL(IVAL)/(10**NUMDIG)
10744        ENDIF
10745        NCX2LA=NCX2LA+1
10746        CALL DPCONH(IVAL,AV,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10747        NCX2LA=NCX2LA+NH
10748        IF(ISPX2S.EQ.'DEFAULT')THEN
10749          CONTINUE
10750        ELSEIF(ISPX2P.NE.' ')THEN
10751          DO760I=16,1,-1
10752            IF(ISPX2S(I:I).NE.' ')THEN
10753              NTEMP=I
10754              DO770J=1,NTEMP
10755                NCX2LA=NCX2LA+1
10756                IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J)
10757  770         CONTINUE
10758              GOTO779
10759            ENDIF
10760  760     CONTINUE
10761  779     CONTINUE
10762        ENDIF
10763        CONST=0.5
10764        PX2LDS=-((PYMAX-PYMIN)-PX2LD2)
10765C
10766      ELSEIF(ISPX2L.EQ.'EFFE' .OR. ISPX2L.EQ.'REFF')THEN
10767        IF(ISPX2P.EQ.'DEFAULT')THEN
10768          IX2LTE(1)='E'
10769          IX2LTE(2)='F'
10770          IX2LTE(3)='F'
10771          IX2LTE(4)='E'
10772          IX2LTE(5)='C'
10773          IX2LTE(6)='T'
10774          IX2LTE(7)=' '
10775          IX2LTE(8)='='
10776          IX2LTE(9)=' '
10777          NCX2LA=9
10778        ELSEIF(ISPX2P.EQ.' ')THEN
10779          NCX2LA=0
10780        ELSE
10781          DO610I=16,1,-1
10782            IF(ISPX2P(I:I).NE.' ')THEN
10783              NCX2LA=I
10784              DO620J=1,NCX2LA
10785                IX2LTE(J)(1:1)=ISPX2P(J:J)
10786  620         CONTINUE
10787              GOTO629
10788            ENDIF
10789  610     CONTINUE
10790  629     CONTINUE
10791        ENDIF
10792        CONST=0.5
10793C
10794C       2018/04: SIGN IS WRONG DIRECTION
10795C
10796CCCCC   AVAL=ALOWH
10797        AVAL=-ALOWH
10798        IF(IOUNI5.GT.0)WRITE(IOUNI5,'(G15.7)')AVAL
10799        IF(AVAL.LT.0.0)CONST=-0.5
10800        IF(NUMDIG.GE.0)THEN
10801          IVAL=INT(AVAL*10**NUMDIG + CONST)
10802          AVAL=REAL(IVAL)/(10**NUMDIG)
10803        ENDIF
10804        NCX2LA=NCX2LA+1
10805        CALL DPCONH(IVAL,AVAL,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10806        NCX2LA=NCX2LA+NH
10807        IF(ISPX2S.EQ.'DEFAULT')THEN
10808          CONTINUE
10809        ELSEIF(ISPX2P.NE.' ')THEN
10810          DO660I=16,1,-1
10811            IF(ISPX2S(I:I).NE.' ')THEN
10812              NTEMP=I
10813              DO670J=1,NTEMP
10814                NCX2LA=NCX2LA+1
10815                IX2LTE(NCX2LA)(1:1)=ISPX2P(J:J)
10816  670         CONTINUE
10817              GOTO679
10818            ENDIF
10819  660     CONTINUE
10820  679     CONTINUE
10821        ENDIF
10822        CONST=0.5
10823        PX2LDS=-((PYMAX-PYMIN)-PX2LD2)
10824C
10825C       NOW ADD RELATIVE EFFECTS IF REQUESTED
10826C
10827        AVAL=GRAND
10828        IF(ISPX2L.EQ.'REFF' .AND. AVAL.NE.CPUMIN)THEN
10829          CONST=0.5
10830          IF(AVAL.LT.0.0)CONST=-0.5
10831          IVAL=INT(AVAL*10**2 + CONST)
10832          AVAL=REAL(IVAL)/(10**2)
10833          NCX2LA=NCX2LA+1
10834          IX2LTE(NCX2LA)(1:1)=' '
10835          NCX2LA=NCX2LA+1
10836          IX2LTE(NCX2LA)(1:1)=' '
10837          NCX2LA=NCX2LA+1
10838          IX2LTE(NCX2LA)(1:1)='('
10839          NCX2LA=NCX2LA+1
10840          CALL DPCONH(IVAL,AVAL,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10841          NCX2LA=NCX2LA+NH
10842          NCX2LA=NCX2LA+1
10843          IX2LTE(NCX2LA)(1:1)='%'
10844          NCX2LA=NCX2LA+1
10845          IX2LTE(NCX2LA)(1:1)=')'
10846        ENDIF
10847C
10848      ELSEIF(ISPX2L.EQ.'FILL' .OR. ISPX2L.EQ.'FREF')THEN
10849        NCX2LA=0
10850        IF(IROW.LE.9)THEN
10851          NCX2LA=NCX2LA+1
10852          WRITE(IX2LTE(NCX2LA)(1:1),'(I1)')IROW
10853        ELSEIF(IROW.LE.99)THEN
10854          WRITE(IXVAL(1:2),'(I2)')IROW
10855          NCX2LA=NCX2LA+1
10856          IX2LTE(NCX2LA)(1:1)=IXVAL(1:1)
10857          NCX2LA=NCX2LA+1
10858          IX2LTE(NCX2LA)(1:1)=IXVAL(2:2)
10859        ENDIF
10860        IF(IROW.NE.ICOL)THEN
10861          IF(ICOL.LE.9)THEN
10862            NCX2LA=NCX2LA+1
10863            WRITE(IX2LTE(NCX2LA)(1:1),'(I1)')ICOL
10864          ELSEIF(ICOL.LE.99)THEN
10865            WRITE(IXVAL(1:2),'(I2)')ICOL
10866            NCX2LA=NCX2LA+1
10867            IX2LTE(NCX2LA)(1:1)=IXVAL(1:1)
10868            NCX2LA=NCX2LA+1
10869            IX2LTE(NCX2LA)(1:1)=IXVAL(2:2)
10870          ENDIF
10871        ENDIF
10872        NCX2LA=NCX2LA+1
10873        IX2LTE(NCX2LA)(1:1)=':'
10874        NCX2LA=NCX2LA+1
10875        NCX2LA=NCX2LA+1
10876        IX2LTE(NCX2LA)(1:1)=' '
10877        CONST=0.5
10878CCCCC   AVAL=ALOWH
10879        AVAL=-ALOWH
10880        IF(IOUNI5.GT.0)WRITE(IOUNI5,'(G15.7)')AVAL
10881        IF(AVAL.LT.0.0)CONST=-0.5
10882        IF(NUMDIG.GE.0)THEN
10883          IVAL=INT(AVAL*10**NUMDIG + CONST)
10884          AVAL=REAL(IVAL)/(10**NUMDIG)
10885        ENDIF
10886        NCX2LA=NCX2LA+1
10887        CALL DPCONH(IVAL,AVAL,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10888        NCX2LA=NCX2LA+NH
10889        CONST=0.5
10890        PX2LDS=-((PYMAX-PYMIN)-PX2LD2)
10891C
10892C       NOW ADD RELATIVE EFFECTS IF REQUESTED
10893C
10894        AVAL2=GRAND
10895        IF(AVAL2.NE.0.0)THEN
10896          AVAL=100.0*(AVAL/AVAL2)
10897        ELSE
10898          AVAL=CPUMIN
10899        ENDIF
10900        IF(ISPX2L.EQ.'FREF' .AND. AVAL.NE.CPUMIN)THEN
10901          CONST=0.5
10902          IF(AVAL.LT.0.0)CONST=-0.5
10903          IVAL=INT(100.0*AVAL + CONST)
10904          AVAL=REAL(IVAL)/100.0
10905          NCX2LA=NCX2LA+1
10906          IX2LTE(NCX2LA)(1:1)=' '
10907          NCX2LA=NCX2LA+1
10908          IX2LTE(NCX2LA)(1:1)=' '
10909          NCX2LA=NCX2LA+1
10910          IX2LTE(NCX2LA)(1:1)='('
10911          NCX2LA=NCX2LA+1
10912          CALL DPCONH(IVAL,AVAL,IX2LTE(NCX2LA),NH,IBUGG2,IERROR)
10913          NCX2LA=NCX2LA+NH
10914          NCX2LA=NCX2LA+1
10915          IX2LTE(NCX2LA)(1:1)='%'
10916          NCX2LA=NCX2LA+1
10917          IX2LTE(NCX2LA)(1:1)=')'
10918        ENDIF
10919      ENDIF
10920C
10921C               *****************
10922C               **  STEP 90--  **
10923C               **  EXIT       **
10924C               *****************
10925C
10926 9000 CONTINUE
10927      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM3')THEN
10928        WRITE(ICOUT,999)
10929  999   FORMAT(1X)
10930        CALL DPWRST('XXX','BUG ')
10931        WRITE(ICOUT,9011)
10932 9011   FORMAT('***** AT THE END       OF DPSPM3--')
10933        CALL DPWRST('XXX','BUG ')
10934        WRITE(ICOUT,9013)J,NCX2LA,PX2LDS
10935 9013   FORMAT('J,NCX2LA,PX2LDS = ',2I8,G15.7)
10936        CALL DPWRST('XXX','BUG ')
10937        IF(NCX2LA.GT.0)THEN
10938          DO9014I=1,NCX2LA
10939            WRITE(ICOUT,9015)I,IX2LTE(I)(1:1)
10940 9015       FORMAT('I,IX2LTE(J)(1:1) = ',I6,A1)
10941            CALL DPWRST('XXX','BUG ')
10942 9014     CONTINUE
10943        ENDIF
10944      ENDIF
10945C
10946      RETURN
10947      END
10948      SUBROUTINE DPSPM4(ICASPL,IOPTN,IDX,IDY,
10949     1                  ISUBNU,
10950     1                  ISUBSW,
10951     1                  ASUBXL,ASUBXU,ASUBYL,ASUBYU,
10952     1                  ISUBN9,
10953     1                  ISUBSZ,
10954     1                  ASBXL2,ASBXU2,ASBYL2,ASBYU2,
10955     1                  PSPXSL,PSPXSU,PSPYSL,PSPYSU,
10956     1                  IBUGG2,ISUBRO,IERROR)
10957C
10958C     PURPOSE--UTILTY ROUTINE FOR SCATTER PLOT MATRIX.  SET SUBREGION
10959C              LIMITS (IF SPECIFIED BY USER).
10960C              IOPTN = 1  - SAVE CURENT SETTINGS
10961C              IOPTN = 2  - RESTORE CURENT SETTINGS
10962C              IOPTN = 3  - SET SUBREGION LIMITS FOR GIVEN Y, X
10963C                           PAIR OF VARIABLES.  NOTE IF LIMIT SET TO
10964C                           CPUMIN OR CPUMAX, THEN NOTHING SET.
10965C                           ALSO, MATRIX PLOTS ONLY RESET FIRST
10966C                           SUBREGION (OTHERS ARE LEFT AS IS)
10967C              IDX   = SETTING OF PSPXSL, PSPXSU TO USE
10968C              IDY   = SETTING OF PSPYSL, PSPYSU TO USE
10969C     WRITTEN BY--ALAN HECKERT
10970C                 STATISTICAL ENGINEERING DIVISION
10971C                 INFORMATION TECHNOLOGY LABORATORY
10972C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
10973C                 GAITHERSBURG, MD 20899-8980
10974C                 PHONE--301-975-2899
10975C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10976C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
10977C     LANGUAGE--ANSI FORTRAN (1977)
10978C     VERSION NUMBER--99/12
10979C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--DECEMBER  1999.
10980C
10981C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
10982C
10983      CHARACTER*4 IBUGG2
10984      CHARACTER*4 ICASPL
10985      CHARACTER*4 ISUBRO
10986      CHARACTER*4 IERROR
10987C
10988      CHARACTER*4 ISUBSW
10989      CHARACTER*4 ISUBSZ
10990C
10991      DIMENSION ISUBSW(*)
10992      DIMENSION ASUBXL(*)
10993      DIMENSION ASUBXU(*)
10994      DIMENSION ASUBYL(*)
10995      DIMENSION ASUBYU(*)
10996      DIMENSION PSPXSL(*)
10997      DIMENSION PSPXSU(*)
10998      DIMENSION PSPYSL(*)
10999      DIMENSION PSPYSU(*)
11000C
11001C-----COMMON VARIABLES (GENERAL)----------------------------------
11002C
11003      INCLUDE 'DPCOP2.INC'
11004C
11005C-----START POINT-------------------------------------------------
11006C
11007      IF(ISUBRO.EQ.'SPM4')THEN
11008        WRITE(ICOUT,12)ICASPL,IFOUND
11009   12   FORMAT('ICASPL,IFOUND = ',A4,2X,A4)
11010        CALL DPWRST('XXX','BUG ')
11011      ENDIF
11012C
11013      IERROR='NO'
11014C
11015C               ***************************************
11016C               **  STEP 1--SAVE INITIAL SETTINGS    **
11017C               ***************************************
11018C
11019      IF(IOPTN.EQ.1)THEN
11020        ISUBSZ=ISUBSW(1)
11021        ASBXL2=ASUBXL(1)
11022        ASBXU2=ASUBXU(1)
11023        ASBYL2=ASUBYL(1)
11024        ASBYU2=ASUBYU(1)
11025        ISUBN9=ISUBNU
11026      ELSEIF(IOPTN.EQ.2)THEN
11027        ISUBSW(1)=ISUBSZ
11028        ASUBXL(1)=ASBXL2
11029        ASUBXU(1)=ASBXU2
11030        ASUBYL(1)=ASBYL2
11031        ASUBYU(1)=ASBYU2
11032        ISUBNU=ISUBN9
11033      ELSEIF(IOPTN.EQ.3)THEN
11034        IF(PSPXSL(IDX).NE.CPUMIN .AND. PSPXSU(IDX).NE.CPUMIN)THEN
11035          ISUBSW(1)='ON'
11036          IF(ISUBNU.EQ.0)ISUBNU=1
11037          ASUBXL(1)=PSPXSL(IDX)
11038          ASUBXU(1)=PSPXSU(IDX)
11039        ENDIF
11040        IF(PSPYSL(IDY).NE.CPUMIN .AND. PSPYSU(IDY).NE.CPUMIN)THEN
11041          ISUBSW(1)='ON'
11042          IF(ISUBNU.EQ.0)ISUBNU=1
11043          ASUBYL(1)=PSPYSL(IDY)
11044          ASUBYU(1)=PSPYSU(IDY)
11045        ENDIF
11046      ENDIF
11047C
11048C               *****************
11049C               **  STEP 90--  **
11050C               **  EXIT       **
11051C               *****************
11052C
11053      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM4')THEN
11054        WRITE(ICOUT,999)
11055  999   FORMAT(1X)
11056        CALL DPWRST('XXX','BUG ')
11057        WRITE(ICOUT,9011)
11058 9011   FORMAT('***** AT THE END       OF DPSPM4--')
11059        CALL DPWRST('XXX','BUG ')
11060      ENDIF
11061C
11062      RETURN
11063      END
11064      SUBROUTINE DPSPM5(IFLAG,IMPSW,IMPCO,IMPNR,IMPNC,
11065     1                  IBUGG2,ISUBRO,IFOUND,IERROR)
11066C
11067C     PURPOSE--UTILTY ROUTINE FOR SCATTER PLOT MATRIX.  DO ONE OF THE
11068C              FOLLOWING:
11069C                 1) SAVE CURRENT PLOT CONTROL SETTINGS FOR PLOT
11070C                 2) RESTORE CURRENT PLOT CONTROL SETTINGS FOR PLOT
11071C                 3) SAVE CURRENT PLOT CONTROL SETTINGS FOR OVERLAID FIT
11072C                 4) RESTORE CURRENT PLOT CONTROL SETTINGS FOR OVERLAID FIT
11073C               ALSO USED BY CONDITION PLOT AND FACTOR PLOT
11074C     WRITTEN BY--ALAN HECKERT
11075C                 STATISTICAL ENGINEERING DIVISION
11076C                 INFORMATION TECHNOLOGY LABORATORY
11077C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11078C                 GAITHERSBURG, MD 20899-8980
11079C                 PHONE--301-975-2899
11080C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11081C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11082C     LANGUAGE--ANSI FORTRAN (1977)
11083C     VERSION NUMBER--2011/7
11084C     ORIGINAL VERSION--JULY 2011.
11085C
11086C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
11087C
11088      CHARACTER*4 IMPSW
11089      CHARACTER*4 IBUGG2
11090      CHARACTER*4 ISUBRO
11091      CHARACTER*4 IFOUND
11092      CHARACTER*4 IERROR
11093C
11094C-----COMMON VARIABLES (GENERAL)----------------------------------
11095C
11096      INCLUDE 'DPCOPA.INC'
11097      INCLUDE 'DPCOPC.INC'
11098      INCLUDE 'DPCOST.INC'
11099      INCLUDE 'DPCOSP.INC'
11100      INCLUDE 'DPCOF2.INC'
11101      INCLUDE 'DPCOP2.INC'
11102C
11103C-----START POINT-------------------------------------------------
11104C
11105      IFOUND='YES'
11106      IERROR='NO'
11107C
11108      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM5')THEN
11109        WRITE(ICOUT,999)
11110  999   FORMAT(1X)
11111        CALL DPWRST('XXX','BUG ')
11112        WRITE(ICOUT,51)
11113   51   FORMAT('***** AT THE BEGINNING OF DPSPM5--')
11114        CALL DPWRST('XXX','BUG ')
11115      ENDIF
11116C
11117C               **********************************************************
11118C               **  STEP 0--SAVE/RESTORE PLOT CONTROL SETTINGS THAT ARE **
11119C               **          COMMON TO BOTH CASES.                       **
11120C               **********************************************************
11121C
11122      IF(IFLAG.EQ.1 .OR. IFLAG.EQ.3)THEN
11123C
11124        GY1MNS=GY1MIN
11125        GY1MXS=GY1MAX
11126        GY2MNS=GY2MIN
11127        GY2MXS=GY2MAX
11128        GX1MNS=GX1MIN
11129        GX1MXS=GX1MAX
11130        GX2MNS=GX2MIN
11131        GX2MXS=GX2MAX
11132C
11133        IY1MNS=IY1MIN
11134        IY1MXS=IY1MAX
11135        IY2MNS=IY2MIN
11136        IY2MXS=IY2MAX
11137        IX1MNS=IX1MIN
11138        IX1MXS=IX1MAX
11139        IX2MNS=IX2MIN
11140        IX2MXS=IX2MAX
11141C
11142C           **********************************************************
11143C           **  STEP 1--SAVE PLOT CONTROL SETTINGS FOR INITIAL PLOT **
11144C           **********************************************************
11145C
11146        IF(IFLAG.EQ.1)THEN
11147C
11148          PXMN2=PXMIN
11149          PXMX2=PXMAX
11150          PYMN2=PYMIN
11151          PYMX2=PYMAX
11152          PWXMN2=PWXMIN
11153          PWXMX2=PWXMAX
11154          PWYMN2=PWYMIN
11155          PWYMX2=PWYMAX
11156          IF(ISPMFR.EQ.'DEFA')THEN
11157            PXMIN=0.0
11158            PXMAX=100.0
11159            PYMIN=0.0
11160            PYMAX=100.0
11161          ENDIF
11162C
11163          IFENC2=IFENSW
11164          IERAS2=IERASW
11165          IPPTB2=IPPTBI
11166          ISORS2=ISORSW
11167C
11168          IX1TSV=IX1TSW
11169          IX2TSV=IX2TSW
11170          IY1TSV=IY1TSW
11171          IY2TSV=IY2TSW
11172          IX1ZSV=IX1ZSW
11173          IX2ZSV=IX2ZSW
11174          IY1ZSV=IY1ZSW
11175          IY2ZSV=IY2ZSW
11176          PX1LD2=PX1LDS
11177          PX2LD2=PX2LDS
11178          PY1LD2=PY1LDS
11179          PY1LA2=PY1LAN
11180          IY1LJ2=IY1LJU
11181          IY1LD2=IY1LDI
11182          IX1FSV=IX1FSW
11183          IX2FSV=IX2FSW
11184          IY1FSV=IY1FSW
11185          IY2FSV=IY2FSW
11186          PX1ZD2=PX1ZDS
11187          PX2ZD2=PX2ZDS
11188          PY1ZD2=PY1ZDS
11189          PY2ZD2=PY2ZDS
11190          DO1010I=1,100
11191            ICHAP2(I)=ICHAPA(I)
11192            ILINP2(I)=ILINPA(I)
11193            IBARS2(I)=IBARSW(I)
11194            ISPIS2(I)=ISPISW(I)
11195 1010     CONTINUE
11196C
11197          DO1020I=1,MAXCH
11198            IX1LT2(I)=IX1LTE(I)
11199            IX2LT2(I)=IX2LTE(I)
11200            IY1LT2(I)=IY1LTE(I)
11201            IY2LT2(I)=IY2LTE(I)
11202 1020     CONTINUE
11203          NCX1L2=NCX1LA
11204          NCX2L2=NCX2LA
11205          NCY1L2=NCY1LA
11206          NCY2L2=NCY2LA
11207C
11208          DO1030I=1,MAXCH
11209            ITITSV(I)=ITITTE(I)
11210 1030     CONTINUE
11211          NCTITS=NCTITL
11212          PTITDZ=PTITDS
11213C
11214C           **********************************************************
11215C           **  STEP 3--SAVE PLOT CONTROL SETTINGS FOR OVERLAID PLOT *
11216C           **********************************************************
11217C
11218        ELSEIF(IFLAG.EQ.3)THEN
11219C
11220          DO3010I=1,MAXSUB
11221            ISU2SW(I)=ISUBSW(I)
11222            ISUBSW(I)='OFF'
11223 3010     CONTINUE
11224C
11225          DO3020I=1,100
11226            ILI2CO(I)=ILINCO(I)
11227            PLI2TH(I)=PLINTH(I)
11228            ICH2PO(I)=ICHAPO(I)
11229            ICH2FO(I)=ICHAFO(I)
11230            ICH2CA(I)=ICHACA(I)
11231            ICH2JU(I)=ICHAJU(I)
11232            ICH2DI(I)=ICHADI(I)
11233            ICH2FI(I)=ICHAFI(I)
11234            ICH2CO(I)=ICHACO(I)
11235            PCH2HE(I)=PCHAHE(I)
11236            PCH2WI(I)=PCHAWI(I)
11237            PCH2VG(I)=PCHAVG(I)
11238            PCH2HG(I)=PCHAHG(I)
11239            PCH2HO(I)=PCHAHO(I)
11240            PCH2VO(I)=PCHAVO(I)
11241            ACH2AN(I)=ACHAAN(I)
11242 3020     CONTINUE
11243C
11244          GY1MIN=FY1MNZ
11245          GY1MAX=FY1MXZ
11246          GY2MIN=GY1MIN
11247          GY2MAX=GY1MAX
11248          GX1MIN=FX1MNZ
11249          GX1MAX=FX1MXZ
11250          GX2MIN=GX1MIN
11251          GX2MAX=GX1MAX
11252          IY1MIN='FIXE'
11253          IY1MAX='FIXE'
11254          IY2MIN='FIXE'
11255          IY2MAX='FIXE'
11256          IX1MIN='FIXE'
11257          IX1MAX='FIXE'
11258          IX2MIN='FIXE'
11259          IX2MAX='FIXE'
11260          IX1TSW='OFF'
11261          IX1ZSW='OFF'
11262          IX2TSW='OFF'
11263          IX2ZSW='OFF'
11264          IY1TSW='OFF'
11265          IY1ZSW='OFF'
11266          IY2TSW='OFF'
11267          IY2ZSW='OFF'
11268C
11269CCCCC     NOTE: SHOULD ITEMP BE PASSED AS ARGUMENT?  NEED TO
11270CCCCC           INVESTIGATE THIS FURTHER.
11271C
11272          ITEMP=1
11273          ICHAPA(1)=ICHAP2(ITEMP)
11274          ILINPA(1)=ILINP2(ITEMP)
11275          ILINCO(1)=ILI2CO(ITEMP)
11276          PLINTH(1)=PLI2TH(ITEMP)
11277          ICHAPO(1)=ICH2PO(ITEMP)
11278          ICHAFO(1)=ICH2FO(ITEMP)
11279          ICHACA(1)=ICH2CA(ITEMP)
11280          ICHAJU(1)=ICH2JU(ITEMP)
11281          ICHADI(1)=ICH2DI(ITEMP)
11282          ICHAFI(1)=ICH2FI(ITEMP)
11283          ICHACO(1)=ICH2CO(ITEMP)
11284          PCHAHE(1)=PCH2HE(ITEMP)
11285          PCHAWI(1)=PCH2WI(ITEMP)
11286          PCHAVG(1)=PCH2VG(ITEMP)
11287          PCHAHG(1)=PCH2HG(ITEMP)
11288          PCHAHO(1)=PCH2HO(ITEMP)
11289          PCHAVO(1)=PCH2VO(ITEMP)
11290          ACHAAN(1)=ACH2AN(ITEMP)
11291        ENDIF
11292      ELSEIF(IFLAG.EQ.2 .OR. IFLAG.EQ.4)THEN
11293C
11294        GX1MIN=GX1MNS
11295        GX1MAX=GX1MXS
11296        GX2MIN=GX2MNS
11297        GX2MAX=GX2MXS
11298        GY1MIN=GY1MNS
11299        GY1MAX=GY1MXS
11300        GY2MIN=GY2MNS
11301        GY2MAX=GY2MXS
11302C
11303        IX1MIN=IX1MNS
11304        IX1MAX=IX1MXS
11305        IX2MIN=IX2MNS
11306        IX2MAX=IX2MXS
11307        IY1MIN=IY1MNS
11308        IY1MAX=IY1MXS
11309        IY2MIN=IY2MNS
11310        IY2MAX=IY2MXS
11311C
11312C         *********************************************************
11313C         **  STEP 2--RESTORE PLOT CONTROL SETTINGS FOR INITIAL  **
11314C         **          PLOT                                       **
11315C         *********************************************************
11316C
11317        IF(IFLAG.EQ.2)THEN
11318C
11319          PWXMIN=PWXMN2
11320          PWXMAX=PWXMX2
11321          PWYMIN=PWYMN2
11322          PWYMAX=PWYMX2
11323          PXMIN=PXMN2
11324          PXMAX=PXMX2
11325          PYMIN=PYMN2
11326          PYMAX=PYMX2
11327C
11328          IERASW=IERAS2
11329          IFENSW=IFENC2
11330          ISORSW=ISORS2
11331          IPPTBI=IPPTB2
11332C
11333          IX1TSW=IX1TSV
11334          IX2TSW=IX2TSV
11335          IY1TSW=IY1TSV
11336          IY2TSW=IY2TSV
11337          IX1ZSW=IX1ZSV
11338          IX2ZSW=IX2ZSV
11339          IY1ZSW=IY1ZSV
11340          IY2ZSW=IY2ZSV
11341          PX1LDS=PX1LD2
11342          PX2LDS=PX2LD2
11343          PY1LDS=PY1LD2
11344          PY1LAN=PY1LA2
11345          IY1LJU=IY1LJ2
11346          IY1LDI=IY1LD2
11347          PX1ZDS=PX1ZD2
11348          PX2ZDS=PX2ZD2
11349          PY1ZDS=PY1ZD2
11350          PY2ZDS=PY2ZD2
11351C
11352          DO2010I=1,100
11353            ICHAPA(I)=ICHAP2(I)
11354            ILINPA(I)=ILINP2(I)
11355            IBARSW(I)=IBARS2(I)
11356            ISPISW(I)=ISPIS2(I)
11357 2010   CONTINUE
11358C
11359          IMPSW='OFF'
11360          IMPCO=1
11361          IMPNR=IMPNR2
11362          IMPNC=IMPNC2
11363C
11364          DO2020I=1,MAXCH
11365            IX1LTE(I)=IX1LT2(I)
11366            IX2LTE(I)=IX2LT2(I)
11367            IY1LTE(I)=IY1LT2(I)
11368            IY2LTE(I)=IY2LT2(I)
11369 2020   CONTINUE
11370          NCX1LA=NCX1L2
11371          NCX2LA=NCX2L2
11372          NCY1LA=NCY1L2
11373          NCY2LA=NCY2L2
11374          DO2030I=1,MAXCH
11375            ITITTE(I)=ITITSV(I)
11376 2030     CONTINUE
11377          NCTITL=NCTITS
11378          PTITDS=PTITDZ
11379C
11380C           **********************************************************
11381C           **  STEP 4--RESTORE PLOT CONTROL SETTINGS FOR OVERLAID  **
11382C           **          PLOT                                        **
11383C           **********************************************************
11384C
11385        ELSEIF(IFLAG.EQ.4)THEN
11386C
11387          DO4010I=1,100
11388            ILINCO(I)=ILI2CO(I)
11389            PLINTH(I)=PLI2TH(I)
11390            ICHAPO(I)=ICH2PO(I)
11391            ICHAFO(I)=ICH2FO(I)
11392            ICHACA(I)=ICH2CA(I)
11393            ICHAJU(I)=ICH2JU(I)
11394            ICHADI(I)=ICH2DI(I)
11395            ICHAFI(I)=ICH2FI(I)
11396            ICHACO(I)=ICH2CO(I)
11397            PCHAHE(I)=PCH2HE(I)
11398            PCHAWI(I)=PCH2WI(I)
11399            PCHAVG(I)=PCH2VG(I)
11400            PCHAHG(I)=PCH2HG(I)
11401            PCHAHO(I)=PCH2HO(I)
11402            PCHAVO(I)=PCH2VO(I)
11403            ACHAAN(I)=ACH2AN(I)
11404 4010     CONTINUE
11405        ENDIF
11406C
11407      ENDIF
11408C
11409C               *****************
11410C               **  STEP 90--  **
11411C               **  EXIT       **
11412C               *****************
11413C
11414      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'SPM2')THEN
11415        WRITE(ICOUT,999)
11416        CALL DPWRST('XXX','BUG ')
11417        WRITE(ICOUT,9011)
11418 9011   FORMAT('***** AT THE END       OF DPSPM5--')
11419        CALL DPWRST('XXX','BUG ')
11420      ENDIF
11421C
11422      RETURN
11423      END
11424      SUBROUTINE DPSPPA(IHARG,IHARG2,NUMARG,IDEFSL,MAXSPI,ISPILI,
11425CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
11426CCCCC SUBROUTINE DPSPPA(IHARG,NUMARG,IDEFSL,MAXSPI,ISPILI,
11427     1IBUGP2,IFOUND,IERROR)
11428C
11429C     PURPOSE--DEFINE THE SPIKE LINE PATTERNS.
11430C              THESE ARE LOCATED IN THE VECTOR ISPILI(.).
11431C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
11432C                     --NUMARG
11433C                     --IDEFSL
11434C                     --MAXSPI
11435C                     --IBUGP2 ('ON' OR 'OFF' )
11436C     OUTPUT ARGUMENTS--ISPILI (A CHARACTER VECTOR)
11437C                     --IFOUND ('YES' OR 'NO' )
11438C                     --IERROR ('YES' OR 'NO' )
11439C     WRITTEN BY--JAMES J. FILLIBEN
11440C                 STATISTICAL ENGINEERING DIVISION
11441C                 INFORMATION TECHNOLOGY LABORATORY
11442C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11443C                 GAITHERSBURG, MD 20899-8980
11444C                 PHONE--301-975-2855
11445C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11446C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11447C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
11448C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
11449C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
11450C     LANGUAGE--ANSI FORTRAN (1977)
11451C     VERSION NUMBER--82/7
11452C     ORIGINAL VERSION--DECEMBER  1983.
11453C     UPDATED         --AUGUST    1995.  DASH2 BUG
11454C
11455C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11456C
11457      CHARACTER*4 IHARG
11458CCCCC AUGUST 1995.  ADD FOLLOWING LINE
11459      CHARACTER*4 IHARG2
11460      CHARACTER*4 IDEFSL
11461      CHARACTER*4 ISPILI
11462C
11463      CHARACTER*4 IBUGP2
11464      CHARACTER*4 IFOUND
11465      CHARACTER*4 IERROR
11466C
11467      CHARACTER*4 IHOLD1
11468      CHARACTER*4 IHOLD2
11469C
11470      CHARACTER*4 ISUBN1
11471      CHARACTER*4 ISUBN2
11472      CHARACTER*4 ISTEPN
11473C
11474      DIMENSION IHARG(*)
11475CCCCC AUGUST 1995.  ADD FOLLOWING LINE
11476      DIMENSION IHARG2(*)
11477      DIMENSION ISPILI(*)
11478C
11479C-----COMMON----------------------------------------------------------
11480C
11481      INCLUDE 'DPCOP2.INC'
11482C
11483C-----START POINT-----------------------------------------------------
11484C
11485      IFOUND='NO'
11486      IERROR='NO'
11487      ISUBN1='DPSP'
11488      ISUBN2='PA  '
11489C
11490      NUMSPI=0
11491      IHOLD1='-999'
11492      IHOLD2='-999'
11493C
11494      IF(IBUGP2.EQ.'OFF')GOTO90
11495      WRITE(ICOUT,999)
11496  999 FORMAT(1X)
11497      CALL DPWRST('XXX','BUG ')
11498      WRITE(ICOUT,51)
11499   51 FORMAT('***** AT THE BEGINNING OF DPSPPA--')
11500      CALL DPWRST('XXX','BUG ')
11501      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
11502   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
11503      CALL DPWRST('XXX','BUG ')
11504      WRITE(ICOUT,53)MAXSPI,NUMSPI
11505   53 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
11506      CALL DPWRST('XXX','BUG ')
11507      WRITE(ICOUT,54)IHOLD1,IHOLD2
11508   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
11509      CALL DPWRST('XXX','BUG ')
11510      WRITE(ICOUT,55)IDEFSL
11511   55 FORMAT('IDEFSL = ',A4)
11512      CALL DPWRST('XXX','BUG ')
11513      WRITE(ICOUT,60)NUMARG
11514   60 FORMAT('NUMARG = ',I8)
11515      CALL DPWRST('XXX','BUG ')
11516      DO65I=1,NUMARG
11517      WRITE(ICOUT,66)IHARG(I)
11518   66 FORMAT('IHARG(I) = ',A4)
11519      CALL DPWRST('XXX','BUG ')
11520   65 CONTINUE
11521      WRITE(ICOUT,70)ISPILI(1)
11522   70 FORMAT('ISPILI(1) = ',A4)
11523      CALL DPWRST('XXX','BUG ')
11524      DO75I=1,10
11525      WRITE(ICOUT,76)I,ISPILI(I)
11526   76 FORMAT('I,ISPILI(I) = ',I8,2X,A4)
11527      CALL DPWRST('XXX','BUG ')
11528   75 CONTINUE
11529   90 CONTINUE
11530C
11531C               **************************************
11532C               **  STEP 1--                        **
11533C               **  BRANCH TO THE APPROPRIATE CASE  **
11534C               **************************************
11535C
11536      ISTEPN='1'
11537      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11538C
11539      IF(NUMARG.LE.0)GOTO1100
11540      IF(NUMARG.EQ.1)GOTO1110
11541      IF(NUMARG.EQ.2)GOTO1120
11542      GOTO1130
11543C
11544 1100 CONTINUE
11545      GOTO1200
11546C
11547 1110 CONTINUE
11548      IF(IHARG(1).EQ.'ALL')IHOLD1='    '
11549      IF(IHARG(1).EQ.'ALL')GOTO1300
11550      GOTO1200
11551C
11552 1120 CONTINUE
11553CCCCC IF(IHARG(1).EQ.'ALL')IHOLD1=IHARG(2)
11554CCCCC IF(IHARG(1).EQ.'ALL')GOTO1300
11555CCCCC IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(1)
11556CCCCC IF(IHARG(2).EQ.'ALL')GOTO1300
11557CCCCC APRIL 1996.  CHANGE IHOLD TO IHOLD1 BELOW
11558      IF(IHARG(1).EQ.'ALL')THEN
11559        IHOLD1=IHARG(2)
11560        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'2')IHOLD1='DA2'
11561        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'3')IHOLD1='DA3'
11562        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'4')IHOLD1='DA4'
11563        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(2).EQ.'5')IHOLD1='DA5'
11564        GOTO1300
11565      ENDIF
11566      IF(IHARG(2).EQ.'ALL')THEN
11567        IHOLD1=IHARG(1)
11568        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(1).EQ.'2')IHOLD1='DA2'
11569        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(1).EQ.'3')IHOLD1='DA3'
11570        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(1).EQ.'4')IHOLD1='DA4'
11571        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(1).EQ.'5')IHOLD1='DA5'
11572        GOTO1300
11573      ENDIF
11574      GOTO1200
11575C
11576 1130 CONTINUE
11577      GOTO1200
11578C
11579C               *************************************************
11580C               **  STEP 2--                                   **
11581C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
11582C               *************************************************
11583C
11584 1200 CONTINUE
11585      ISTEPN='2'
11586      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11587C
11588      IF(NUMARG.LE.0)GOTO1210
11589      GOTO1220
11590C
11591 1210 CONTINUE
11592      NUMSPI=1
11593      ISPILI(1)='    '
11594      GOTO1270
11595C
11596 1220 CONTINUE
11597      NUMSPI=NUMARG
11598      IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI
11599      DO1225I=1,NUMSPI
11600      J=I
11601      IHOLD1=IHARG(J)
11602      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2'
11603      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3'
11604      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4'
11605      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5'
11606      IHOLD2=IHOLD1
11607      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
11608      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
11609      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSL
11610      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSL
11611      ISPILI(I)=IHOLD2
11612 1225 CONTINUE
11613      GOTO1270
11614C
11615 1270 CONTINUE
11616      IF(IFEEDB.EQ.'OFF')GOTO1279
11617      WRITE(ICOUT,999)
11618      CALL DPWRST('XXX','BUG ')
11619      DO1278I=1,NUMSPI
11620      WRITE(ICOUT,1276)I,ISPILI(I)
11621 1276 FORMAT('SPIKE ',I6,' HAS JUST BEEN SET TO ',
11622     1A4)
11623      CALL DPWRST('XXX','BUG ')
11624 1278 CONTINUE
11625 1279 CONTINUE
11626      IFOUND='YES'
11627      GOTO9000
11628C
11629C               **************************
11630C               **  STEP 2--            **
11631C               **  TREAT THE ALL CASE  **
11632C               **************************
11633C
11634 1300 CONTINUE
11635      ISTEPN='3'
11636      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11637C
11638      NUMSPI=MAXSPI
11639      IHOLD2=IHOLD1
11640      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
11641      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
11642      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSL
11643      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSL
11644      DO1315I=1,NUMSPI
11645      ISPILI(I)=IHOLD2
11646 1315 CONTINUE
11647      GOTO1370
11648C
11649 1370 CONTINUE
11650      IF(IFEEDB.EQ.'OFF')GOTO1319
11651      WRITE(ICOUT,999)
11652      CALL DPWRST('XXX','BUG ')
11653      I=1
11654      WRITE(ICOUT,1316)ISPILI(I)
11655 1316 FORMAT('ALL SPIKES HAVE JUST BEEN SET TO ',
11656     1A4)
11657      CALL DPWRST('XXX','BUG ')
11658 1319 CONTINUE
11659      IFOUND='YES'
11660      GOTO9000
11661C
11662C               *****************
11663C               **  STEP 90--  **
11664C               **  EXIT       **
11665C               *****************
11666C
11667 9000 CONTINUE
11668      IF(IBUGP2.EQ.'OFF')GOTO9090
11669      WRITE(ICOUT,9011)
11670 9011 FORMAT('***** AT THE END       OF DPSPPA--')
11671      CALL DPWRST('XXX','BUG ')
11672      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
11673 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
11674      CALL DPWRST('XXX','BUG ')
11675      WRITE(ICOUT,9013)MAXSPI,NUMSPI
11676 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
11677      CALL DPWRST('XXX','BUG ')
11678      WRITE(ICOUT,9014)IHOLD1,IHOLD2
11679 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
11680      CALL DPWRST('XXX','BUG ')
11681      WRITE(ICOUT,9015)IDEFSL
11682 9015 FORMAT('IDEFSL = ',A4)
11683      CALL DPWRST('XXX','BUG ')
11684      WRITE(ICOUT,9020)NUMARG
11685 9020 FORMAT('NUMARG = ',I8)
11686      CALL DPWRST('XXX','BUG ')
11687      DO9025I=1,NUMARG
11688      WRITE(ICOUT,9026)IHARG(I)
11689 9026 FORMAT('IHARG(I) = ',A4)
11690      CALL DPWRST('XXX','BUG ')
11691 9025 CONTINUE
11692      WRITE(ICOUT,9030)ISPILI(1)
11693 9030 FORMAT('ISPILI(1) = ',A4)
11694      CALL DPWRST('XXX','BUG ')
11695      DO9035I=1,10
11696      WRITE(ICOUT,9036)I,ISPILI(I)
11697 9036 FORMAT('I,ISPILI(I) = ',I8,2X,A4)
11698      CALL DPWRST('XXX','BUG ')
11699 9035 CONTINUE
11700 9090 CONTINUE
11701C
11702      RETURN
11703      END
11704      SUBROUTINE DPSPSM(X,N,XS,ICHANG,IBUGG3,IERROR)
11705C
11706C     PURPOSE--THIS SUBROUTINE TAKES THE DATA IN THE VECTOR X,
11707C              DETERMINES THE VARIOUS MESAS,
11708C              AND APPLIES A 3-TERM MEDIAN SMOOTH TO THE DATA
11709C              BETWEEN EACH MESA.
11710C     OUTPUT ARGUMENTS--XS     = THE SINGLE PRECISION VECTOR
11711C                                CONTAINING SMOOTHED VALUES.
11712C                     --ICHANG = THE CHARACTER VARIABLE
11713C                                CONTAINING EITHER YES OR NO
11714C                                DEPENDING ON WHETHER OR NOT THE
11715C                                SMOOTHED DATA IS CHANGED OR NOT
11716C                                FROM THE ORIGINAL DATA.
11717C     OUTPUT--THE COMPUTED SINGLE PRECISION VECTOR
11718C             OF SMOOTHED VALUES.
11719C     NOTE--THE VECTOR X REMAINS UNCHANGED.
11720C     ASSUMPTION--THE VECTOR X HAS AT LEAST 3 VALUES.
11721C     LANGUAGE--ANSI FORTRAN (1977)
11722C     REFERENCES--MCNEIL, INTERACTIVE DATA ANALYSIS
11723C                 1977, PAGE 146
11724C                 (= SOURCE OF ALGORITHM).
11725C     WRITTEN BY--JAMES J. FILLIBEN
11726C                 STATISTICAL ENGINEERING DIVISION
11727C                 INFORMATION TECHNOLOGY LABORATORY
11728C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11729C                 GAITHERSBURG, MD 20899-8980
11730C                 PHONE--301-975-2855
11731C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11732C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11733C     VERSION NUMBER--83.6
11734C     ORIGINAL VERSION--JULY      1983.
11735C
11736C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11737C
11738      CHARACTER*4 ICHANG
11739C
11740      CHARACTER*4 IBUGG3
11741      CHARACTER*4 IERROR
11742C
11743C---------------------------------------------------------------------
11744C
11745      DIMENSION X(*)
11746      DIMENSION XS(*)
11747C
11748C-----COMMON----------------------------------------------------------
11749C
11750      INCLUDE 'DPCOP2.INC'
11751C
11752C-----START POINT-----------------------------------------------------
11753C
11754      IERROR='NO'
11755C
11756      IF(IBUGG3.EQ.'OFF')GOTO90
11757      WRITE(ICOUT,999)
11758  999 FORMAT(1X)
11759      CALL DPWRST('XXX','BUG ')
11760      WRITE(ICOUT,51)
11761   51 FORMAT('***** AT THE BEGINNING OF DPSPSM--')
11762      CALL DPWRST('XXX','BUG ')
11763      WRITE(ICOUT,52)IBUGG3
11764   52 FORMAT('IBUGG3 = ',A4)
11765      CALL DPWRST('XXX','BUG ')
11766      WRITE(ICOUT,53)N
11767   53 FORMAT('N = ',I8)
11768      CALL DPWRST('XXX','BUG ')
11769      DO55I=1,N
11770      WRITE(ICOUT,56)I,X(I)
11771   56 FORMAT('I,X(I) = ',I8,E15.7)
11772      CALL DPWRST('XXX','BUG ')
11773   55 CONTINUE
11774   90 CONTINUE
11775C
11776C               *********************************************
11777C               **  SPLIT THE DATA AT EACH MESA            **
11778C               **  AND THEN APPLY A 3-TERM MEDIAN SMOOTH  **
11779C               **  TO THE SUBSET OF THE DATA              **
11780C               **  BETWEEN EACH MESA.                     **
11781C               *********************************************
11782C
11783C               ****************************************
11784C               **  STEP 1--                          **
11785C               **  COPY THE DATA FROM X(.) TO XS(.)  **
11786C               ****************************************
11787C
11788      DO1100I=1,N
11789      XS(I)=X(I)
11790 1100 CONTINUE
11791C
11792C               ********************************
11793C               **  STEP 2--                  **
11794C               **  SEARCH FOR A MESA IN THE  **
11795C               **  FIRST 3 OBSERVATIONS      **
11796C               ********************************
11797C
11798      IF(X(2).NE.X(3))GOTO1290
11799      IF(X(1).LE.X(2).AND.X(3).LE.X(4))GOTO1290
11800      IF(X(1).GE.X(2).AND.X(3).GE.X(4))GOTO1290
11801      XS(2)=X(1)
11802      ARG1=X(3)
11803      ARG2=X(4)
11804      ARG3=3*X(4)-2*X(5)
11805      CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR)
11806      XS(3)=XMED3
11807 1290 CONTINUE
11808C
11809C               ***********************************
11810C               **  STEP 3--                     **
11811C               **  SEARCH FOR MESAS             **
11812C               **  IN THE MIDDLE OF THE SERIES  **
11813C               ***********************************
11814C
11815      NM2=N-2
11816      IF(3.GT.NM2)GOTO1390
11817      DO1300I=3,NM2
11818C
11819      IM2=I-2
11820      IM1=I-1
11821      IP1=I+1
11822      IP2=I+2
11823      IP3=I+3
11824C
11825      IF(X(I).NE.X(IP1))GOTO1300
11826      IF(X(IM1).LE.X(I).AND.X(IP1).LE.X(IP2))GOTO1300
11827      IF(X(IM1).GE.X(I).AND.X(IP1).GE.X(IP2))GOTO1300
11828C
11829      ARG1=X(I)
11830      ARG2=X(IM1)
11831      ARG3=3*X(IM1)-2*X(IM2)
11832      CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR)
11833      XS(I)=XMED3
11834C
11835      ARG1=X(IP1)
11836      ARG2=X(IP2)
11837      ARG3=3*X(IP2)-2*X(IP3)
11838      CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR)
11839      XS(IP1)=XMED3
11840C
11841 1300 CONTINUE
11842 1390 CONTINUE
11843C
11844C               ********************************
11845C               **  STEP 4--                  **
11846C               **  SEARCH FOR A MESA IN THE  **
11847C               **  LAST  3 OBSERVATIONS      **
11848C               ********************************
11849C
11850      NM1=N-1
11851      NM2=N-2
11852      NM3=N-3
11853      NM4=N-4
11854      IF(X(NM1).NE.X(NM2))GOTO1490
11855      IF(X(N).LE.X(NM1).AND.X(NM2).LE.X(NM3))GOTO1490
11856      IF(X(N).GE.X(NM1).AND.X(NM2).GE.X(NM3))GOTO1490
11857      XS(NM1)=X(N)
11858      ARG1=X(NM2)
11859      ARG2=X(NM3)
11860      ARG3=3*X(NM3)-2*X(NM4)
11861      CALL DPMED3(ARG1,ARG2,ARG3,XMED3,IBUGG3,IERROR)
11862      XS(NM2)=XMED3
11863 1490 CONTINUE
11864C               *********************************************
11865C               **  STEP 5--                               **
11866C               **  CHECK TO SEE IF A CHANGE HAS OCCURRED  **
11867C               **  BETWEEN THE RAW DATA AND               **
11868C               **  THE SPLIT & SMOOTHED DATA.             **
11869C               *********************************************
11870C
11871      ICHANG='NO'
11872      DO1500I=1,N
11873      IF(XS(I).NE.X(I))GOTO1510
11874 1500 CONTINUE
11875      GOTO1590
11876 1510 CONTINUE
11877      ICHANG='YES'
11878 1590 CONTINUE
11879C
11880C               *****************
11881C               **  STEP 90--  **
11882C               **  EXIT.      **
11883C               *****************
11884C
11885      IF(IBUGG3.EQ.'ON')THEN
11886        WRITE(ICOUT,999)
11887        CALL DPWRST('XXX','BUG ')
11888        WRITE(ICOUT,9011)
11889 9011   FORMAT('***** AT THE END       OF DPSPSM--')
11890        CALL DPWRST('XXX','BUG ')
11891        WRITE(ICOUT,9012)IBUGG3,ICHANG,N
11892 9012   FORMAT('IBUGG3,ICHANG,N = ',2(A4,2X),I8)
11893        CALL DPWRST('XXX','BUG ')
11894        DO9015I=1,N
11895          WRITE(ICOUT,9016)I,X(I),XS(I)
11896 9016     FORMAT('I,X(I),XS(I) = ',I8,2G15.7)
11897          CALL DPWRST('XXX','BUG ')
11898 9015   CONTINUE
11899      ENDIF
11900C
11901      RETURN
11902      END
11903      SUBROUTINE DPSPSW(IHARG,NUMARG,IDEFSS,MAXSPI,ISPISW,
11904     1IBUGP2,IFOUND,IERROR)
11905C
11906C     PURPOSE--DEFINE THE SPIKE SWITCHES.
11907C              THESE ARE LOCATED IN THE VECTOR ISPISW(.).
11908C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
11909C                     --NUMARG
11910C                     --IDEFSS
11911C                     --MAXSPI
11912C                     --IBUGP2 ('ON' OR 'OFF' )
11913C     OUTPUT ARGUMENTS--ISPISW (A CHARACTER VECTOR)
11914C                     --IFOUND ('YES' OR 'NO' )
11915C                     --IERROR ('YES' OR 'NO' )
11916C     WRITTEN BY--JAMES J. FILLIBEN
11917C                 STATISTICAL ENGINEERING DIVISION
11918C                 INFORMATION TECHNOLOGY LABORATORY
11919C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11920C                 GAITHERSBURG, MD 20899-8980
11921C                 PHONE--301-975-2855
11922C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11923C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11924C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
11925C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
11926C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
11927C     LANGUAGE--ANSI FORTRAN (1977)
11928C     VERSION NUMBER--82/7
11929C     ORIGINAL VERSION--DECEMBER  1983.
11930C
11931C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11932C
11933      CHARACTER*4 IHARG
11934      CHARACTER*4 IDEFSS
11935      CHARACTER*4 ISPISW
11936C
11937      CHARACTER*4 IBUGP2
11938      CHARACTER*4 IFOUND
11939      CHARACTER*4 IERROR
11940C
11941      CHARACTER*4 IHOLD1
11942      CHARACTER*4 IHOLD2
11943C
11944      CHARACTER*4 ISUBN1
11945      CHARACTER*4 ISUBN2
11946      CHARACTER*4 ISTEPN
11947C
11948      DIMENSION IHARG(*)
11949      DIMENSION ISPISW(*)
11950C
11951C-----COMMON----------------------------------------------------------
11952C
11953      INCLUDE 'DPCOP2.INC'
11954C
11955C-----START POINT-----------------------------------------------------
11956C
11957      IFOUND='NO'
11958      IERROR='NO'
11959      ISUBN1='DPSP'
11960      ISUBN2='SW  '
11961C
11962      NUMSPI=0
11963      IHOLD1='-999'
11964      IHOLD2='-999'
11965C
11966      IF(IBUGP2.EQ.'OFF')GOTO90
11967      WRITE(ICOUT,999)
11968  999 FORMAT(1X)
11969      CALL DPWRST('XXX','BUG ')
11970      WRITE(ICOUT,51)
11971   51 FORMAT('***** AT THE BEGINNING OF DPSPSW--')
11972      CALL DPWRST('XXX','BUG ')
11973      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
11974   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
11975      CALL DPWRST('XXX','BUG ')
11976      WRITE(ICOUT,53)MAXSPI,NUMSPI
11977   53 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
11978      CALL DPWRST('XXX','BUG ')
11979      WRITE(ICOUT,54)IHOLD1,IHOLD2
11980   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
11981      CALL DPWRST('XXX','BUG ')
11982      WRITE(ICOUT,55)IDEFSS
11983   55 FORMAT('IDEFSS = ',A4)
11984      CALL DPWRST('XXX','BUG ')
11985      WRITE(ICOUT,60)NUMARG
11986   60 FORMAT('NUMARG = ',I8)
11987      CALL DPWRST('XXX','BUG ')
11988      DO65I=1,NUMARG
11989      WRITE(ICOUT,66)IHARG(I)
11990   66 FORMAT('IHARG(I) = ',A4)
11991      CALL DPWRST('XXX','BUG ')
11992   65 CONTINUE
11993      WRITE(ICOUT,70)ISPISW(1)
11994   70 FORMAT('ISPISW(1) = ',A4)
11995      CALL DPWRST('XXX','BUG ')
11996      DO75I=1,10
11997      WRITE(ICOUT,76)I,ISPISW(I)
11998   76 FORMAT('I,ISPISW(I) = ',I8,2X,A4)
11999      CALL DPWRST('XXX','BUG ')
12000   75 CONTINUE
12001   90 CONTINUE
12002C
12003C               **************************************
12004C               **  STEP 1--                        **
12005C               **  BRANCH TO THE APPROPRIATE CASE  **
12006C               **************************************
12007C
12008      ISTEPN='1'
12009      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12010C
12011      IF(NUMARG.LE.0)GOTO1100
12012      IF(NUMARG.EQ.1)GOTO1110
12013      IF(NUMARG.EQ.2)GOTO1120
12014      GOTO1130
12015C
12016 1100 CONTINUE
12017      GOTO1200
12018C
12019 1110 CONTINUE
12020      IF(IHARG(1).EQ.'ALL')IHOLD1='OFF'
12021      IF(IHARG(1).EQ.'ALL')GOTO1300
12022      GOTO1200
12023C
12024 1120 CONTINUE
12025      IF(IHARG(1).EQ.'ALL')IHOLD1=IHARG(2)
12026      IF(IHARG(1).EQ.'ALL')GOTO1300
12027      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(1)
12028      IF(IHARG(2).EQ.'ALL')GOTO1300
12029      GOTO1200
12030C
12031 1130 CONTINUE
12032      GOTO1200
12033C
12034C               *************************************************
12035C               **  STEP 2--                                   **
12036C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
12037C               *************************************************
12038C
12039 1200 CONTINUE
12040      ISTEPN='2'
12041      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12042C
12043      IF(NUMARG.LE.0)GOTO1210
12044      GOTO1220
12045C
12046 1210 CONTINUE
12047      NUMSPI=1
12048      ISPISW(1)='ON'
12049      GOTO1270
12050C
12051 1220 CONTINUE
12052      NUMSPI=NUMARG
12053      IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI
12054      DO1225I=1,NUMSPI
12055      J=I
12056      IHOLD1=IHARG(J)
12057      IHOLD2=IHOLD1
12058      IF(IHOLD1.EQ.'ON')IHOLD2='ON'
12059      IF(IHOLD1.EQ.'OFF')IHOLD2='OFF'
12060CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSS
12061CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSS
12062      ISPISW(I)=IHOLD2
12063 1225 CONTINUE
12064      GOTO1270
12065C
12066 1270 CONTINUE
12067      IF(IFEEDB.EQ.'OFF')GOTO1279
12068      WRITE(ICOUT,999)
12069      CALL DPWRST('XXX','BUG ')
12070      DO1278I=1,NUMSPI
12071      WRITE(ICOUT,1276)I,ISPISW(I)
12072 1276 FORMAT('SPIKE ',I6,' HAS JUST BEEN SET TO ',
12073     1A4)
12074      CALL DPWRST('XXX','BUG ')
12075 1278 CONTINUE
12076 1279 CONTINUE
12077      IFOUND='YES'
12078      GOTO9000
12079C
12080C               **************************
12081C               **  STEP 2--            **
12082C               **  TREAT THE ALL CASE  **
12083C               **************************
12084C
12085 1300 CONTINUE
12086      ISTEPN='3'
12087      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12088C
12089      NUMSPI=MAXSPI
12090      IHOLD2=IHOLD1
12091      IF(IHOLD1.EQ.'ON')IHOLD2='ON'
12092      IF(IHOLD1.EQ.'OFF')IHOLD2='OFF'
12093CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFSS
12094CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFSS
12095      DO1315I=1,NUMSPI
12096      ISPISW(I)=IHOLD2
12097 1315 CONTINUE
12098      GOTO1370
12099C
12100 1370 CONTINUE
12101      IF(IFEEDB.EQ.'OFF')GOTO1319
12102      WRITE(ICOUT,999)
12103      CALL DPWRST('XXX','BUG ')
12104      I=1
12105      WRITE(ICOUT,1316)ISPISW(I)
12106 1316 FORMAT('ALL SPIKES HAVE JUST BEEN SET TO ',
12107     1A4)
12108      CALL DPWRST('XXX','BUG ')
12109 1319 CONTINUE
12110      IFOUND='YES'
12111      GOTO9000
12112C
12113C               *****************
12114C               **  STEP 90--  **
12115C               **  EXIT       **
12116C               *****************
12117C
12118 9000 CONTINUE
12119      IF(IBUGP2.EQ.'OFF')GOTO9090
12120      WRITE(ICOUT,9011)
12121 9011 FORMAT('***** AT THE END       OF DPSPSW--')
12122      CALL DPWRST('XXX','BUG ')
12123      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
12124 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
12125      CALL DPWRST('XXX','BUG ')
12126      WRITE(ICOUT,9013)MAXSPI,NUMSPI
12127 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
12128      CALL DPWRST('XXX','BUG ')
12129      WRITE(ICOUT,9014)IHOLD1,IHOLD2
12130 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
12131      CALL DPWRST('XXX','BUG ')
12132      WRITE(ICOUT,9015)IDEFSS
12133 9015 FORMAT('IDEFSS = ',A4)
12134      CALL DPWRST('XXX','BUG ')
12135      WRITE(ICOUT,9020)NUMARG
12136 9020 FORMAT('NUMARG = ',I8)
12137      CALL DPWRST('XXX','BUG ')
12138      DO9025I=1,NUMARG
12139      WRITE(ICOUT,9026)IHARG(I)
12140 9026 FORMAT('IHARG(I) = ',A4)
12141      CALL DPWRST('XXX','BUG ')
12142 9025 CONTINUE
12143      WRITE(ICOUT,9030)ISPISW(1)
12144 9030 FORMAT('ISPISW(1) = ',A4)
12145      CALL DPWRST('XXX','BUG ')
12146      DO9035I=1,10
12147      WRITE(ICOUT,9036)I,ISPISW(I)
12148 9036 FORMAT('I,ISPISW(I) = ',I8,2X,A4)
12149      CALL DPWRST('XXX','BUG ')
12150 9035 CONTINUE
12151 9090 CONTINUE
12152C
12153      RETURN
12154      END
12155      SUBROUTINE DPSPTH(IHARG,IARGT,ARG,NUMARG,PDEFST,MAXSPI,PSPITH,
12156     1IBUGP2,IFOUND,IERROR)
12157C
12158C     PURPOSE--DEFINE THE SPIKE THICKNESSES.
12159C              THESE ARE LOCATED IN THE VECTOR PSPITH(.).
12160C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
12161C                     --IARGT  (A  CHARACTER VECTOR)
12162C                     --ARG
12163C                     --NUMARG
12164C                     --PDEFST
12165C                     --MAXSPI
12166C                     --IBUGP2 ('ON' OR 'OFF' )
12167C     OUTPUT ARGUMENTS--PSPITH (A FLOATING POINT VECTOR)
12168C                     --IFOUND ('YES' OR 'NO' )
12169C                     --IERROR ('YES' OR 'NO' )
12170C     WRITTEN BY--JAMES J. FILLIBEN
12171C                 STATISTICAL ENGINEERING DIVISION
12172C                 INFORMATION TECHNOLOGY LABORATORY
12173C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12174C                 GAITHERSBURG, MD 20899-8980
12175C                 PHONE--301-975-2855
12176C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12177C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12178C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
12179C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
12180C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
12181C     LANGUAGE--ANSI FORTRAN (1977)
12182C     VERSION NUMBER--82/7
12183C     ORIGINAL VERSION--DECEMBER  1983.
12184C     UPDATED         --JANUARY   1989.  ERROR IN FORMAT STATEMENT (ALAN)
12185C
12186C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12187C
12188      CHARACTER*4 IHARG
12189      CHARACTER*4 IARGT
12190C
12191      CHARACTER*4 IBUGP2
12192      CHARACTER*4 IFOUND
12193      CHARACTER*4 IERROR
12194C
12195      CHARACTER*4 IHOLD1
12196C
12197      CHARACTER*4 ISUBN1
12198      CHARACTER*4 ISUBN2
12199      CHARACTER*4 ISTEPN
12200C
12201      DIMENSION IHARG(*)
12202      DIMENSION IARGT(*)
12203      DIMENSION ARG(*)
12204      DIMENSION PSPITH(*)
12205C
12206C-----COMMON----------------------------------------------------------
12207C
12208      INCLUDE 'DPCOP2.INC'
12209C
12210C-----START POINT-----------------------------------------------------
12211C
12212      IFOUND='NO'
12213      IERROR='NO'
12214      ISUBN1='DPSP'
12215      ISUBN2='TH  '
12216C
12217      NUMSPI=0
12218      IHOLD1='-999'
12219      HOLD1=-999.0
12220      HOLD2=-999.0
12221C
12222      IF(IBUGP2.EQ.'OFF')GOTO90
12223      WRITE(ICOUT,999)
12224  999 FORMAT(1X)
12225      CALL DPWRST('XXX','BUG ')
12226      WRITE(ICOUT,51)
12227   51 FORMAT('***** AT THE BEGINNING OF DPSPTH--')
12228      CALL DPWRST('XXX','BUG ')
12229      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
12230   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
12231      CALL DPWRST('XXX','BUG ')
12232      WRITE(ICOUT,53)MAXSPI,NUMSPI
12233   53 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
12234      CALL DPWRST('XXX','BUG ')
12235      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
12236   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
12237      CALL DPWRST('XXX','BUG ')
12238      WRITE(ICOUT,55)PDEFST
12239   55 FORMAT('PDEFST = ',E15.7)
12240      CALL DPWRST('XXX','BUG ')
12241      WRITE(ICOUT,60)NUMARG
12242   60 FORMAT('NUMARG = ',I8)
12243      CALL DPWRST('XXX','BUG ')
12244      DO65I=1,NUMARG
12245      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
12246   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
12247      CALL DPWRST('XXX','BUG ')
12248   65 CONTINUE
12249      WRITE(ICOUT,70)PSPITH(1)
12250   70 FORMAT('PSPITH(1) = ',E15.7)
12251      CALL DPWRST('XXX','BUG ')
12252      DO75I=1,10
12253      WRITE(ICOUT,76)I,PSPITH(I)
12254   76 FORMAT('I,PSPITH(I) = ',I8,2X,E15.7)
12255      CALL DPWRST('XXX','BUG ')
12256   75 CONTINUE
12257   90 CONTINUE
12258C
12259C               **************************************
12260C               **  STEP 1--                        **
12261C               **  BRANCH TO THE APPROPRIATE CASE  **
12262C               **************************************
12263C
12264      ISTEPN='1'
12265      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12266C
12267      IF(NUMARG.LE.0)GOTO9000
12268      IF(NUMARG.EQ.1)GOTO1110
12269      IF(NUMARG.EQ.2)GOTO1120
12270      IF(NUMARG.EQ.3)GOTO1130
12271      GOTO1140
12272C
12273 1110 CONTINUE
12274      GOTO1200
12275C
12276 1120 CONTINUE
12277      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
12278      IF(IHARG(2).EQ.'ALL')HOLD1=PDEFST
12279      IF(IHARG(2).EQ.'ALL')GOTO1300
12280      GOTO1200
12281C
12282 1130 CONTINUE
12283      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
12284      IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3)
12285      IF(IHARG(2).EQ.'ALL')GOTO1300
12286      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
12287      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2)
12288      IF(IHARG(3).EQ.'ALL')GOTO1300
12289      GOTO1200
12290C
12291 1140 CONTINUE
12292      GOTO1200
12293C
12294C               *************************************************
12295C               **  STEP 2--                                   **
12296C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
12297C               *************************************************
12298C
12299 1200 CONTINUE
12300      ISTEPN='2'
12301      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12302C
12303      IF(NUMARG.LE.1)GOTO1210
12304      GOTO1220
12305C
12306 1210 CONTINUE
12307      NUMSPI=1
12308      PSPITH(1)=PDEFST
12309      GOTO1270
12310C
12311 1220 CONTINUE
12312      NUMSPI=NUMARG-1
12313      IF(NUMSPI.GT.MAXSPI)NUMSPI=MAXSPI
12314      DO1225I=1,NUMSPI
12315      J=I+1
12316      IHOLD1=IHARG(J)
12317      HOLD1=ARG(J)
12318      HOLD2=HOLD1
12319      IF(IHOLD1.EQ.'ON')HOLD2=PDEFST
12320      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFST
12321      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFST
12322      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFST
12323      PSPITH(I)=HOLD2
12324 1225 CONTINUE
12325      GOTO1270
12326C
12327 1270 CONTINUE
12328      IF(IFEEDB.EQ.'OFF')GOTO1279
12329      WRITE(ICOUT,999)
12330      CALL DPWRST('XXX','BUG ')
12331      DO1278I=1,NUMSPI
12332      WRITE(ICOUT,1276)I,PSPITH(I)
12333 1276 FORMAT('SPIKE THICKNESS ',I6,' HAS JUST BEEN SET TO ',
12334     1E15.7)
12335      CALL DPWRST('XXX','BUG ')
12336 1278 CONTINUE
12337 1279 CONTINUE
12338      IFOUND='YES'
12339      GOTO9000
12340C
12341C               **************************
12342C               **  STEP 2--            **
12343C               **  TREAT THE ALL CASE  **
12344C               **************************
12345C
12346 1300 CONTINUE
12347      ISTEPN='3'
12348      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12349C
12350      NUMSPI=MAXSPI
12351      HOLD2=HOLD1
12352      IF(IHOLD1.EQ.'ON')HOLD2=PDEFST
12353      IF(IHOLD1.EQ.'OFF')HOLD2=PDEFST
12354      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEFST
12355      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEFST
12356      DO1315I=1,NUMSPI
12357      PSPITH(I)=HOLD2
12358 1315 CONTINUE
12359      GOTO1370
12360C
12361 1370 CONTINUE
12362      IF(IFEEDB.EQ.'OFF')GOTO1319
12363      WRITE(ICOUT,999)
12364      CALL DPWRST('XXX','BUG ')
12365      I=1
12366      WRITE(ICOUT,1316)PSPITH(I)
12367 1316 FORMAT('ALL SPIKE THICKNESSES HAVE JUST BEEN SET TO ',
12368     1E15.7)
12369      CALL DPWRST('XXX','BUG ')
12370 1319 CONTINUE
12371      IFOUND='YES'
12372      GOTO9000
12373C
12374C               *****************
12375C               **  STEP 90--  **
12376C               **  EXIT       **
12377C               *****************
12378C
12379 9000 CONTINUE
12380      IF(IBUGP2.EQ.'OFF')GOTO9090
12381      WRITE(ICOUT,9011)
12382 9011 FORMAT('***** AT THE END       OF DPSPTH--')
12383      CALL DPWRST('XXX','BUG ')
12384      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
12385 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
12386      CALL DPWRST('XXX','BUG ')
12387      WRITE(ICOUT,9013)MAXSPI,NUMSPI
12388 9013 FORMAT('MAXSPI,NUMSPI = ',I8,I8)
12389      CALL DPWRST('XXX','BUG ')
12390      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
12391 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
12392      CALL DPWRST('XXX','BUG ')
12393      WRITE(ICOUT,9015)PDEFST
12394 9015 FORMAT('PDEFST = ',E15.7)
12395      CALL DPWRST('XXX','BUG ')
12396      WRITE(ICOUT,9020)NUMARG
12397 9020 FORMAT('NUMARG = ',I8)
12398      CALL DPWRST('XXX','BUG ')
12399      DO9025I=1,NUMARG
12400      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
12401 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
12402      CALL DPWRST('XXX','BUG ')
12403 9025 CONTINUE
12404      WRITE(ICOUT,9030)PSPITH(1)
12405 9030 FORMAT('PSPITH(1) = ',E15.7)
12406      CALL DPWRST('XXX','BUG ')
12407      DO9035I=1,10
12408      WRITE(ICOUT,9036)I,PSPITH(I)
12409 9036 FORMAT('I,PSPITH(I) = ',I8,2X,E15.7)
12410      CALL DPWRST('XXX','BUG ')
12411 9035 CONTINUE
12412 9090 CONTINUE
12413C
12414      RETURN
12415      END
12416      SUBROUTINE DPSQRA(MAXNXT,ICAPSW,IFORSW,
12417     1                  ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
12418C
12419C     PURPOSE--CARRY OUT NONPARAMETRIC SQUARED RANKS TEST TO TEST FOR
12420C              EQUAL VARIANCES AMONG K GROUPS.
12421C     EXAMPLE--SQUARED RANKS TEST Y X
12422C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
12423C                THIRD EDITION, WILEY, PP. 300-310.
12424C     WRITTEN BY--ALAN HECKERT
12425C                 STATISTICAL ENGINEERING DIVISION
12426C                 INFORMATION TECHNOLOGY LABORATORY
12427C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12428C                 GAITHERSBURG, MD 20899-8980
12429C                 PHONE--301-975-2899
12430C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12431C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12432C     LANGUAGE--ANSI FORTRAN (1977)
12433C     VERSION NUMBER--2011/6
12434C     ORIGINAL VERSION--JUNE      2011.
12435C
12436C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12437C
12438      CHARACTER*4 ICAPSW
12439      CHARACTER*4 IFORSW
12440      CHARACTER*4 ISUBRO
12441      CHARACTER*4 IBUGA2
12442      CHARACTER*4 IBUGA3
12443      CHARACTER*4 IBUGQ
12444      CHARACTER*4 IFOUND
12445      CHARACTER*4 IERROR
12446C
12447      CHARACTER*4 IMULT
12448      CHARACTER*4 ICASAN
12449      CHARACTER*4 ICASA2
12450      CHARACTER*4 ICASE
12451      CHARACTER*4 ISUBN1
12452      CHARACTER*4 ISUBN2
12453      CHARACTER*4 ISTEPN
12454      CHARACTER*4 ICTMP1
12455      CHARACTER*4 ICTMP2
12456      CHARACTER*4 ICTMP3
12457      CHARACTER*4 IFLAGU
12458      LOGICAL IFRST
12459      LOGICAL ILAST
12460C
12461      CHARACTER*40 INAME
12462      PARAMETER (MAXSPN=30)
12463      CHARACTER*4 IVARN1(MAXSPN)
12464      CHARACTER*4 IVARN2(MAXSPN)
12465      CHARACTER*4 IVARTY(MAXSPN)
12466      REAL PVAR(MAXSPN)
12467      INTEGER ILIS(MAXSPN)
12468      INTEGER NRIGHT(MAXSPN)
12469      INTEGER ICOLR(MAXSPN)
12470C
12471C---------------------------------------------------------------------
12472C
12473C-----COMMON----------------------------------------------------------
12474C
12475      INCLUDE 'DPCOPA.INC'
12476      INCLUDE 'DPCOZZ.INC'
12477      INCLUDE 'DPCOZD.INC'
12478C
12479      DIMENSION TEMP1(MAXOBV)
12480      DIMENSION TEMP2(MAXOBV)
12481      DIMENSION TEMP3(MAXOBV)
12482      DIMENSION TEMP4(MAXOBV)
12483      DOUBLE PRECISION DTEMP1(MAXOBV)
12484      DOUBLE PRECISION DTEMP2(MAXOBV)
12485C
12486      EQUIVALENCE(GARBAG(IGARB1),TEMP1(1))
12487      EQUIVALENCE(GARBAG(IGARB2),TEMP2(1))
12488      EQUIVALENCE(GARBAG(IGARB3),TEMP3(1))
12489      EQUIVALENCE(GARBAG(IGARB4),TEMP4(1))
12490      EQUIVALENCE(DGARBG(IDGAR1),DTEMP1(1))
12491      EQUIVALENCE(DGARBG(IDGAR2),DTEMP2(1))
12492C
12493C-----COMMON VARIABLES (GENERAL)--------------------------------------
12494C
12495      INCLUDE 'DPCOHK.INC'
12496      INCLUDE 'DPCOSU.INC'
12497      INCLUDE 'DPCODA.INC'
12498      INCLUDE 'DPCOST.INC'
12499      INCLUDE 'DPCOP2.INC'
12500C
12501C-----START POINT-----------------------------------------------------
12502C
12503      ISUBN1='DPSQ'
12504      ISUBN2='RA  '
12505      IFOUND='YES'
12506      IERROR='NO'
12507C
12508      MAXCP1=MAXCOL+1
12509      MAXCP2=MAXCOL+2
12510      MAXCP3=MAXCOL+3
12511      MAXCP4=MAXCOL+4
12512      MAXCP5=MAXCOL+5
12513      MAXCP6=MAXCOL+6
12514C
12515C               ******************************************
12516C               **  TREAT THE SQUARED RANKS TEST CASE  **
12517C               ******************************************
12518C
12519      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SQRA')THEN
12520        WRITE(ICOUT,999)
12521  999   FORMAT(1X)
12522        CALL DPWRST('XXX','BUG ')
12523        WRITE(ICOUT,51)
12524   51   FORMAT('***** AT THE BEGINNING OF DPSQRA--')
12525        CALL DPWRST('XXX','BUG ')
12526        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
12527   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
12528        CALL DPWRST('XXX','BUG ')
12529        WRITE(ICOUT,55)IMULT,IKRUGS,MAXNXT
12530   55   FORMAT('IMULT,IKRUGS,MAXNXT = ',2(A4,2X),I8)
12531        CALL DPWRST('XXX','BUG ')
12532      ENDIF
12533C
12534C               *********************************************************
12535C               **  STEP 1--                                           **
12536C               **  EXTRACT THE COMMAND                                **
12537C               *********************************************************
12538C
12539      ISTEPN='1'
12540      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')
12541     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12542C
12543      ILASTZ=9999
12544      ICASAN='SQRA'
12545      ICASA2='TWOT'
12546      IMULT='OFF'
12547C
12548C     LOOK FOR:
12549C
12550C          SQUARED RANKS TEST
12551C          LOWER TAILED
12552C          UPPER TAILED
12553C          MULTIPLE
12554C
12555      DO100I=0,NUMARG-1
12556C
12557        IF(I.EQ.0)THEN
12558          ICTMP1=ICOM
12559        ELSE
12560          ICTMP1=IHARG(I)
12561        ENDIF
12562        ICTMP2=IHARG(I+1)
12563        ICTMP3=IHARG(I+2)
12564C
12565        IF(ICTMP1.EQ.'=')THEN
12566          IFOUND='NO'
12567          GOTO9000
12568        ELSEIF(ICTMP1.EQ.'SQUA' .AND. ICTMP2.EQ.'RANK' .AND.
12569     1         ICTMP3.EQ.'TEST')THEN
12570          IFOUND='YES'
12571          ICASAN='SQRA'
12572          ILASTZ=I+2
12573        ELSEIF(ICTMP1.EQ.'SQUA' .AND. ICTMP2.EQ.'RANK')THEN
12574          IFOUND='YES'
12575          ICASAN='SQRA'
12576          ILASTZ=I+1
12577        ELSEIF(ICTMP1.EQ.'LOWE' .AND. ICTMP2.EQ.'TAIL')THEN
12578          ICASA2='LOWE'
12579          ILASTZ=MAX(ILASTZ,I+1)
12580        ELSEIF(ICTMP1.EQ.'UPPE' .AND. ICTMP2.EQ.'TAIL')THEN
12581          ICASA2='UPPE'
12582          ILASTZ=MAX(ILASTZ,I+1)
12583        ELSEIF(ICTMP1.EQ.'MULT')THEN
12584          IMULT='ON'
12585          ILASTZ=MAX(ILASTZ,I+1)
12586        ENDIF
12587  100 CONTINUE
12588C
12589      IF(IFOUND.EQ.'NO')GOTO9000
12590C
12591      ISHIFT=ILASTZ
12592      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
12593     1            IBUGA2,IERROR)
12594C
12595      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')THEN
12596        WRITE(ICOUT,91)ICASAN,ICASA2,IMULT,ISHIFT
12597   91   FORMAT('DPSQRA: ICASAN,ICASA2,IMULT,ISHIFT = ',
12598     1         3(A4,2X),I5)
12599        CALL DPWRST('XXX','BUG ')
12600      ENDIF
12601C
12602C               *********************************
12603C               **  STEP 2--                   **
12604C               **  EXTRACT THE VARIABLE LIST  **
12605C               *********************************
12606C
12607      ISTEPN='2'
12608      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')
12609     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12610C
12611      INAME='SQARED RANK TEST'
12612      MAXNA=100
12613      MINNVA=2
12614      MAXNVA=MAXSPN
12615      MINNA=1
12616      IFLAGE=1
12617      IFLAGM=0
12618      IF(IMULT.EQ.'ON')THEN
12619        IFLAGE=0
12620        IFLAGM=1
12621        MAXNVA=MAXSPN
12622      ENDIF
12623      MINN2=2
12624      IFLAGP=0
12625      JMIN=1
12626      JMAX=NUMARG
12627C
12628      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
12629     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
12630     1            JMIN,JMAX,
12631     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
12632     1            IVARN1,IVARN2,IVARTY,PVAR,
12633     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
12634     1            MINNVA,MAXNVA,
12635     1            IFLAGM,IFLAGP,
12636     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
12637      IF(IERROR.EQ.'YES')GOTO9000
12638C
12639      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')THEN
12640        WRITE(ICOUT,999)
12641        CALL DPWRST('XXX','BUG ')
12642        WRITE(ICOUT,181)
12643  181   FORMAT('***** AFTER CALL DPPARS--')
12644        CALL DPWRST('XXX','BUG ')
12645        WRITE(ICOUT,182)NQ,NUMVAR,IMULT
12646  182   FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4)
12647        CALL DPWRST('XXX','BUG ')
12648        IF(NUMVAR.GT.0)THEN
12649          DO185I=1,NUMVAR
12650            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
12651     1                      ICOLR(I)
12652  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
12653     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
12654            CALL DPWRST('XXX','BUG ')
12655  185     CONTINUE
12656        ENDIF
12657      ENDIF
12658C
12659C               *******************************************************
12660C               **  STEP 3--                                         **
12661C               **  GENERATE THE SQUARED RANK   TEST FOR THE VARIOUS **
12662C               **  CASES                                            **
12663C               *******************************************************
12664C
12665      ISTEPN='3'
12666      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')
12667     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12668C
12669C               *****************************************
12670C               **  STEP 3A--                          **
12671C               **  CASE 1: TWO RESPONSE VARIABLES     **
12672C               **          WITH NO REPLICATION        **
12673C               *****************************************
12674C
12675      IF(IMULT.EQ.'OFF')THEN
12676        ISTEPN='3A'
12677        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')
12678     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12679C
12680        ICOL=1
12681        NUMVA2=2
12682        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12683     1              INAME,IVARN1,IVARN2,IVARTY,
12684     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
12685     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12686     1              MAXCP4,MAXCP5,MAXCP6,
12687     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12688     1              Y,X,X,NLOCAL,NLOCA2,NLOCA2,ICASE,
12689     1              IBUGA3,ISUBRO,IFOUND,IERROR)
12690        IF(IERROR.EQ.'YES')GOTO9000
12691C
12692C
12693C               ******************************************************
12694C               **  STEP 3B--
12695C               **  PREPARE FOR ENTRANCE INTO DPSQR2--
12696C               ******************************************************
12697C
12698        ISTEPN='3B'
12699        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')THEN
12700          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12701          WRITE(ICOUT,999)
12702          CALL DPWRST('XXX','BUG ')
12703          WRITE(ICOUT,331)
12704  331     FORMAT('***** FROM DPSQRA, AS WE ARE ABOUT TO CALL DPSQR2--')
12705          CALL DPWRST('XXX','BUG ')
12706          WRITE(ICOUT,332)NLOCAL
12707  332     FORMAT('NLOCAL = ',I8)
12708          CALL DPWRST('XXX','BUG ')
12709          DO335I=1,NLOCAL
12710            WRITE(ICOUT,336)I,Y(I),X(I)
12711  336       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
12712            CALL DPWRST('XXX','BUG ')
12713  335     CONTINUE
12714        ENDIF
12715C
12716        CALL DPSQR2(Y,X,NLOCAL,IVARN1,IVARN2,ICASA2,MAXNXT,
12717     1              TEMP1,TEMP2,TEMP3,TEMP4,DTEMP1,DTEMP2,
12718     1              STATVA,STATCD,PVAL,PVALLT,PVALUT,NDIST,
12719     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,
12720     1              CUT99,CUT999,
12721     1              CTL001,CTL005,CTL010,CTL025,CTL050,CTL100,
12722     1              CTL200,CTL500,
12723     1              CTU999,CTU995,CTU990,CT975,CTU950,CTU900,
12724     1              CTU800,CTU500,
12725     1              ICAPSW,ICAPTY,IFORSW,IMULT,IKRUGS,
12726     1              ISUBRO,IBUGA3,IERROR)
12727C
12728C               ***************************************
12729C               **  STEP 8C--                        **
12730C               **  UPDATE INTERNAL DATAPLOT TABLES  **
12731C               ***************************************
12732C
12733          ISTEPN='8C'
12734          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')
12735     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12736C
12737          IFLAGU='ON'
12738          IFRST=.TRUE.
12739          ILAST=.TRUE.
12740          IF(NDIST.EQ.2)THEN
12741            CALL DPMNN5(ICASA2,
12742     1                  STATVA,STATCD,
12743     1                  PVAL2T,PVALLT,PVALUT,
12744     1                  CTL001,CTL005,CTL010,CTL025,CTL050,CTL100,
12745     1                  CTU999,CTU995,CTU990,CT975,CTU950,CTU900,
12746     1                  IFLAGU,IFRST,ILAST,
12747     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
12748          ELSEIF(NDIST.GE.3)THEN
12749            CALL DPFRT5(STATVA,STATCD,PVAL,
12750     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
12751     1                  CUT975,CUT99,CUT999,
12752     1                  IFLAGU,IFRST,ILAST,
12753     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
12754          ENDIF
12755C
12756C               *******************************************************
12757C               **  STEP 4A--                                        **
12758C               **  CASE 2: MULTIPLE RESPONSE VARIABLES.  NOTE THAT  **
12759C               **          FOR SQUARED RANKS TEST, THE MULTIPLE     **
12760C               **          LABS ARE CONVERTED INTO A "Y X" STACKED  **
12761C               **          PAIR WHERE "X" IS THE LAB-ID VARIABLE.   **
12762C               *******************************************************
12763C
12764      ELSEIF(IMULT.EQ.'ON')THEN
12765        ISTEPN='4A'
12766        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')
12767     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12768C
12769        ICOL=1
12770        NUMVA2=NUMVAR
12771        CALL DPPAR8(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12772     1              INAME,IVARN1,IVARN2,IVARTY,
12773     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
12774     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12775     1              MAXCP4,MAXCP5,MAXCP6,
12776     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12777     1              TEMP1,Y,X,NLOCAL,ICASE,
12778     1              IBUGA3,ISUBRO,IFOUND,IERROR)
12779        NUMVAR=2
12780        IF(IERROR.EQ.'YES')GOTO9000
12781C
12782        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SQRA')THEN
12783          ISTEPN='4B'
12784          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12785          WRITE(ICOUT,999)
12786          CALL DPWRST('XXX','BUG ')
12787          WRITE(ICOUT,442)
12788  442     FORMAT('***** FROM THE MIDDLE  OF DPSQRA--')
12789          CALL DPWRST('XXX','BUG ')
12790          WRITE(ICOUT,443)ICASAN,NUMVAR,NLOCAL
12791  443     FORMAT('ICASAN,NUMVAR,NLOCAL = ',A4,2I8)
12792          CALL DPWRST('XXX','BUG ')
12793          IF(NLOCAL.GE.1)THEN
12794            DO445I=1,NLOCAL
12795              WRITE(ICOUT,446)I,Y(I),X(I)
12796  446         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
12797              CALL DPWRST('XXX','BUG ')
12798  445       CONTINUE
12799          ENDIF
12800        ENDIF
12801C
12802        CALL DPSQR2(Y,X,NLOCAL,IVARN1,IVARN2,ICASA2,MAXNXT,
12803     1              TEMP1,TEMP2,TEMP3,TEMP4,DTEMP1,DTEMP2,
12804     1              STATVA,STATCD,PVAL,PVALLT,PVALUT,NDIST,
12805     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,
12806     1              CUT99,CUT999,
12807     1              CTL001,CTL005,CTL010,CTL025,CTL050,CTL100,
12808     1              CTL200,CTL500,
12809     1              CTU999,CTU995,CTU990,CT975,CTU950,CTU900,
12810     1              CTU800,CTU500,
12811     1              ICAPSW,ICAPTY,IFORSW,IMULT,IKRUGS,
12812     1              ISUBRO,IBUGA3,IERROR)
12813C
12814C         ***************************************
12815C         **  STEP 8C--                        **
12816C         **  UPDATE INTERNAL DATAPLOT TABLES  **
12817C         ***************************************
12818C
12819          ISTEPN='8C'
12820          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'SQRA')
12821     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12822C
12823          IFLAGU='ON'
12824          IFRST=.TRUE.
12825          ILAST=.TRUE.
12826          IF(NDIST.EQ.2)THEN
12827            CALL DPMNN5(ICASA2,
12828     1                  STATVA,STATCD,
12829     1                  PVAL2T,PVALLT,PVALUT,
12830     1                  CTL001,CTL005,CTL010,CTL025,CTL050,CTL100,
12831     1                  CTU999,CTU995,CTU990,CT975,CTU950,CTU900,
12832     1                  IFLAGU,IFRST,ILAST,
12833     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
12834          ELSEIF(NDIST.GE.3)THEN
12835            CALL DPFRT5(STATVA,STATCD,PVAL,
12836     1                  CUT0,CUT50,CUT75,CUT90,CUT95,
12837     1                  CUT975,CUT99,CUT999,
12838     1                  IFLAGU,IFRST,ILAST,
12839     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
12840          ENDIF
12841C
12842      ENDIF
12843C
12844C               *****************
12845C               **  STEP 90--  **
12846C               **  EXIT       **
12847C               *****************
12848C
12849 9000 CONTINUE
12850      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'SQRA')THEN
12851        WRITE(ICOUT,999)
12852        CALL DPWRST('XXX','BUG ')
12853        WRITE(ICOUT,9011)
12854 9011   FORMAT('***** AT THE END       OF DPSQRA--')
12855        CALL DPWRST('XXX','BUG ')
12856        WRITE(ICOUT,9014)NLOCAL,STATVA,STATCD
12857 9014   FORMAT('NLOCAL,STATVA,STATCD = ',I8,2G15.7)
12858        CALL DPWRST('XXX','BUG ')
12859        WRITE(ICOUT,9016)IFOUND,IERROR
12860 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
12861        CALL DPWRST('XXX','BUG ')
12862      ENDIF
12863C
12864      RETURN
12865      END
12866      SUBROUTINE DPSQR2(Y,TAG,N,IVARID,IVARI2,ICASAN,MAXNXT,
12867     1                  TEMP1,TEMP2,TEMP3,TEMP4,DSUMSQ,DN,
12868     1                  STATVA,STATCD,PVAL2P,PVALLP,PVALUP,NDIST,
12869     1                  CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,
12870     1                  CUT99,CUT999,
12871     1                  CTL001,CTL005,CTL010,CTL025,CTL050,CTL100,
12872     1                  CTL200,CTL500,
12873     1                  CTU999,CTU995,CTU990,CTU975,CTU950,CTU900,
12874     1                  CTU800,CTU500,
12875     1                  ICAPSW,ICAPTY,IFORSW,IMULT,IKRUGS,
12876     1                  ISUBRO,IBUGA3,IERROR)
12877C
12878C     PURPOSE--THIS ROUTINE CARRIES OUT A NONPARAMETRIC SQUARED RANKS
12879C              TEST FOR EQUAL VARIANCES
12880C     EXAMPLE--SQUARED RANK TEST Y TAG
12881C     REFERENCE--W. J. CONOVER, "PRACTICAL NONPARAMETRIC
12882C                STATISTICS", THIRD EDITION, 1999, WILEY,
12883C                PP. 300-310.
12884C     WRITTEN BY--ALAN HECKERT
12885C                 STATISTICAL ENGINEERING DIVISION
12886C                 INFORMATION TECHNOLOGY LABORATORY
12887C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12888C                 GAITHERSBURG, MD 20899-8980
12889C                 PHONE--301-975-2899
12890C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12891C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12892C     LANGUAGE--ANSI FORTRAN (1977)
12893C     VERSION NUMBER--2011/6
12894C     ORIGINAL VERSION--JUNE      2011.
12895C
12896C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12897C
12898      CHARACTER*4 ICASAN
12899      CHARACTER*4 ICAPSW
12900      CHARACTER*4 ICAPTY
12901      CHARACTER*4 IFORSW
12902      CHARACTER*4 IMULT
12903      CHARACTER*4 IKRUGS
12904      CHARACTER*4 ISUBRO
12905      CHARACTER*4 IBUGA3
12906      CHARACTER*4 IERROR
12907      CHARACTER*4 IVARID(*)
12908      CHARACTER*4 IVARI2(*)
12909C
12910      CHARACTER*4 IWRITE
12911      CHARACTER*3 IATEMP
12912      CHARACTER*4 ISUBN0
12913      CHARACTER*4 ISUBN1
12914      CHARACTER*4 ISUBN2
12915      CHARACTER*4 ISTEPN
12916      CHARACTER*4 IOP
12917C
12918      DOUBLE PRECISION DNTOT
12919      DOUBLE PRECISION D2
12920C
12921C---------------------------------------------------------------------
12922C
12923      DIMENSION Y(*)
12924      DIMENSION TAG(*)
12925      DIMENSION TEMP1(*)
12926      DIMENSION TEMP2(*)
12927      DIMENSION TEMP3(*)
12928      DIMENSION TEMP4(*)
12929C
12930      DOUBLE PRECISION DSUMSQ(*)
12931      DOUBLE PRECISION DN(*)
12932C
12933C---------------------------------------------------------------------
12934C
12935      PARAMETER (NUMALP=8)
12936      PARAMETER (NUMAL2=4)
12937      REAL ALPHA(NUMALP)
12938      REAL ALPHA2(NUMAL2)
12939C
12940      PARAMETER(NUMCLI=6)
12941      PARAMETER(MAXLIN=3)
12942      PARAMETER (MAXROW=50)
12943      CHARACTER*60 ITITLE
12944      CHARACTER*60 ITITLZ
12945      CHARACTER*60 ITITL9
12946      CHARACTER*60 ITEXT(MAXROW)
12947      CHARACTER*4  ALIGN(NUMCLI)
12948      CHARACTER*4  VALIGN(NUMCLI)
12949      REAL         AVALUE(MAXROW)
12950      INTEGER      NCTEXT(MAXROW)
12951      INTEGER      IDIGIT(MAXROW)
12952      INTEGER      NTOT(MAXROW)
12953      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
12954      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
12955      CHARACTER*4  ITYPCO(NUMCLI)
12956      INTEGER      NCTIT2(MAXLIN,NUMCLI)
12957      INTEGER      NCVALU(MAXROW,NUMCLI)
12958      INTEGER      IWHTML(NUMCLI)
12959      INTEGER      IWRTF(NUMCLI)
12960      REAL         AMAT(MAXROW,NUMCLI)
12961      LOGICAL IFRST
12962      LOGICAL ILAST
12963      LOGICAL IFLAGS
12964      LOGICAL IFLAGE
12965C
12966C-----COMMON----------------------------------------------------------
12967C
12968      INCLUDE 'DPCOP2.INC'
12969C
12970C-----START POINT-----------------------------------------------------
12971C
12972      DATA ALPHA/
12973     1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/
12974      DATA ALPHA2/0.80, 0.90, 0.95, 0.99/
12975C
12976      ISUBN1='DPSQ'
12977      ISUBN2='R2  '
12978      ISUBN0='    '
12979      IWRITE='OFF'
12980      IERROR='NO'
12981C
12982      PVAL=CPUMIN
12983      PVALLT=CPUMIN
12984      PVALUT=CPUMIN
12985C
12986      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SQR2')THEN
12987        WRITE(ICOUT,999)
12988  999   FORMAT(1X)
12989        CALL DPWRST('XXX','WRIT')
12990        WRITE(ICOUT,51)
12991   51   FORMAT('**** AT THE BEGINNING OF DPSQR2--')
12992        CALL DPWRST('XXX','WRIT')
12993        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
12994   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
12995        CALL DPWRST('XXX','WRIT')
12996        DO56I=1,N
12997          WRITE(ICOUT,57)I,Y(I),TAG(I)
12998   57     FORMAT('I,Y(I),TAG(I) = ',I8,2G15.7)
12999          CALL DPWRST('XXX','WRIT')
13000   56   CONTINUE
13001      ENDIF
13002C
13003C               ****************************************************
13004C               **  STEP 1--                                      **
13005C               **  CARRY OUT CALCULATIONS FOR SQUARED RANK TEST  **
13006C               **  (COMPUTATIONS PERFORMED IN DPSQR3)            **
13007C               ****************************************************
13008C
13009      ISTEPN='1'
13010      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR2')
13011     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13012C
13013      CALL DPSQR3(Y,TAG,N,
13014     1            TEMP1,TEMP2,TEMP3,TEMP4,MAXNXT,
13015     1            DSUMSQ,DN,
13016     1            STATVA,STATCD,PVAL2P,PVALLP,PVALUP,
13017     1            IDF,NDIST,D2,
13018     1            IBUGA3,ISUBRO,IERROR)
13019C
13020      IF(NDIST.GE.3)THEN
13021        CUT0=0.0
13022        CALL CHSPPF(.50,IDF,CUT50)
13023        CALL CHSPPF(.75,IDF,CUT75)
13024        CALL CHSPPF(.90,IDF,CUT90)
13025        CALL CHSPPF(.95,IDF,CUT95)
13026        CALL CHSPPF(.975,IDF,CUT975)
13027        CALL CHSPPF(.99,IDF,CUT99)
13028        CALL CHSPPF(.999,IDF,CUT999)
13029        ALPHAT=0.05
13030        CALL TPPF(1.0-ALPHAT/2.0,REAL(IDF),AT95)
13031        ALPHAT=0.10
13032        CALL TPPF(1.0-ALPHAT/2.0,REAL(IDF),AT90)
13033        ALPHAT=0.01
13034        CALL TPPF(1.0-ALPHAT/2.0,REAL(IDF),AT99)
13035        DNTOT=DBLE(N)
13036        AFACT2=REAL(DSQRT(D2*(DNTOT-1.0D0-STATVA)/DBLE(N-NDIST)))
13037C
13038      ELSEIF(NDIST.EQ.2)THEN
13039        CALL NORPPF(.001,CTL001)
13040        CALL NORPPF(.005,CTL005)
13041        CALL NORPPF(.010,CTL010)
13042        CALL NORPPF(.025,CTL025)
13043        CALL NORPPF(.050,CTL050)
13044        CALL NORPPF(.100,CTL100)
13045        CALL NORPPF(.200,CTL200)
13046        CALL NORPPF(.500,CTL500)
13047        CALL NORPPF(.500,CTU500)
13048        CALL NORPPF(.800,CTU800)
13049        CALL NORPPF(.900,CTU900)
13050        CALL NORPPF(.950,CTU950)
13051        CALL NORPPF(.975,CTU975)
13052        CALL NORPPF(.990,CTU990)
13053        CALL NORPPF(.995,CTU995)
13054        CALL NORPPF(.995,CTU999)
13055      ENDIF
13056C
13057      IF(NDIST.GE.3)THEN
13058        IOP='OPEN'
13059        IFLG1=1
13060        IFLG2=0
13061        IFLG3=0
13062        IFLG4=0
13063        IFLG5=0
13064        CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
13065     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
13066     1              IBUGA3,ISUBRO,IERROR)
13067        IF(IERROR.EQ.'YES')GOTO9000
13068C
13069        WRITE(IOUNI1,2305)
13070 2305   FORMAT('     I       J    ',
13071     1       '|Si/Ni-Sj/nj|      ',
13072     1       '90% CV        ',
13073     1       '95% CV        ',
13074     1       '99% CV        ')
13075C
13076        DO2330I=1,NDIST
13077          DO2339J=1,NDIST
13078            IF(I.LT.J)THEN
13079              AFACT3=REAL(DSQRT((1.0D0/DN(I)) + (1.0D0/DN(J))))
13080              ADIFF=REAL(DABS((DSUMSQ(I)/DN(I)) - (DSUMSQ(J)/DN(J))))
13081              ACV90=AT90*AFACT2*AFACT3
13082              ACV95=AT95*AFACT2*AFACT3
13083              ACV99=AT99*AFACT2*AFACT3
13084              IATEMP='   '
13085              IF(ADIFF.GE.ACV90)IATEMP(1:1)='*'
13086              IF(ADIFF.GE.ACV95)IATEMP(2:2)='*'
13087              IF(ADIFF.GE.ACV99)IATEMP(3:3)='*'
13088              WRITE(IOUNI1,2337)I,J,ADIFF,ACV90,ACV95,ACV99,IATEMP
13089 2337         FORMAT(I6,2X,I6,2X,4E15.7,A3)
13090C
13091              IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR2')THEN
13092                WRITE(ICOUT,2341)I,J,DN(I),DN(J),DSUMSQ(I),DSUMSQ(J)
13093 2341           FORMAT('I,J,DN(I),DN(J),DSUMSQ(I),DSUMSQ(J) = ',
13094     1                 2I8,4G15.7)
13095                CALL DPWRST('XXX','WRIT')
13096                WRITE(ICOUT,2343)AFACT2,AFACT3,ADIFF
13097 2343           FORMAT('AFACT2,AFACT3,ADIFF = ',3G15.7)
13098                CALL DPWRST('XXX','WRIT')
13099              ENDIF
13100C
13101            ENDIF
13102 2339     CONTINUE
13103 2330   CONTINUE
13104C
13105        IOP='CLOS'
13106        CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
13107     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
13108     1              IBUGA3,ISUBRO,IERROR)
13109        IF(IERROR.EQ.'YES')GOTO9000
13110      ENDIF
13111C
13112C               ********************************
13113C               **   STEP 42--                **
13114C               **   WRITE OUT EVERYTHING     **
13115C               **   FOR SQUARED RANKS TEST   **
13116C               ********************************
13117C
13118      ISTEPN='42'
13119      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR2')
13120     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13121C
13122      IF(IPRINT.EQ.'OFF')GOTO9000
13123C
13124      NUMDIG=7
13125      IF(IFORSW.EQ.'1')NUMDIG=1
13126      IF(IFORSW.EQ.'2')NUMDIG=2
13127      IF(IFORSW.EQ.'3')NUMDIG=3
13128      IF(IFORSW.EQ.'4')NUMDIG=4
13129      IF(IFORSW.EQ.'5')NUMDIG=5
13130      IF(IFORSW.EQ.'6')NUMDIG=6
13131      IF(IFORSW.EQ.'7')NUMDIG=7
13132      IF(IFORSW.EQ.'8')NUMDIG=8
13133      IF(IFORSW.EQ.'9')NUMDIG=9
13134      IF(IFORSW.EQ.'0')NUMDIG=0
13135      IF(IFORSW.EQ.'E')NUMDIG=-2
13136      IF(IFORSW.EQ.'-2')NUMDIG=-2
13137      IF(IFORSW.EQ.'-3')NUMDIG=-3
13138      IF(IFORSW.EQ.'-4')NUMDIG=-4
13139      IF(IFORSW.EQ.'-5')NUMDIG=-5
13140      IF(IFORSW.EQ.'-6')NUMDIG=-6
13141      IF(IFORSW.EQ.'-7')NUMDIG=-7
13142      IF(IFORSW.EQ.'-8')NUMDIG=-8
13143      IF(IFORSW.EQ.'-9')NUMDIG=-9
13144C
13145      ITITLE='Squared Ranks Test'
13146      NCTITL=18
13147      ITITLZ=' '
13148      NCTITZ=0
13149C
13150      ICNT=1
13151      ITEXT(ICNT)=' '
13152      NCTEXT(ICNT)=0
13153      AVALUE(ICNT)=0.0
13154      IDIGIT(ICNT)=-1
13155      IF(IMULT.EQ.'OFF')THEN
13156        ICNT=ICNT+1
13157        ITEXT(ICNT)='Response Variable: '
13158        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
13159        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
13160        NCTEXT(ICNT)=27
13161        AVALUE(ICNT)=0.0
13162        IDIGIT(ICNT)=-1
13163C
13164        ICNT=ICNT+1
13165        ITEXT(ICNT)='Group-ID Variable: '
13166        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(2)(1:4)
13167        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(2)(1:4)
13168        NCTEXT(ICNT)=27
13169        AVALUE(ICNT)=0.0
13170        IDIGIT(ICNT)=-1
13171      ENDIF
13172C
13173C     IF REQUESTED, PRINT OUT GROUP INFORMATION.  SINCE NUMBER
13174C     OF GROUPS IS UNKNOWN (AND POTENTIALLY LARGE, PRINT EACH
13175C     GROUP AS A SEPARATE TABLE.
13176C
13177      IF(IKRUGS.EQ.'ON')THEN
13178C
13179CCCCC   DO2060I=1,NUMDIS
13180        DO2060I=1,NDIST
13181C
13182          NUMROW=ICNT
13183          DO2065II=1,NUMROW
13184            NTOT(II)=15
13185 2065     CONTINUE
13186C
13187          IFRST=.TRUE.
13188          ILAST=.TRUE.
13189C
13190          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
13191     1                AVALUE,IDIGIT,
13192     1                NTOT,NUMROW,
13193     1                ICAPSW,ICAPTY,ILAST,IFRST,
13194     1                ISUBRO,IBUGA3,IERROR)
13195          ICNT=0
13196          ITITLE=' '
13197          NCTITL=0
13198          ITITLZ=' '
13199          NCTITZ=0
13200C
13201          ICNT=ICNT+1
13202          ITEXT(ICNT)=' '
13203          NCTEXT(ICNT)=1
13204          AVALUE(ICNT)=0.0
13205          IDIGIT(ICNT)=-1
13206C
13207          IF(IMULT.EQ.'ON')THEN
13208            ICNT=ICNT+1
13209            ITEXT(ICNT)='Group Variable: '
13210            WRITE(ITEXT(ICNT)(17:20),'(A4)')IVARID(I)(1:4)
13211            WRITE(ITEXT(ICNT)(21:24),'(A4)')IVARI2(I)(1:4)
13212            NCTEXT(ICNT)=24
13213            AVALUE(ICNT)=0.0
13214            IDIGIT(ICNT)=-1
13215          ELSE
13216            ICNT=ICNT+1
13217            ITEXT(ICNT)='Group    '
13218            WRITE(ITEXT(ICNT)(7:9),'(I3)')I
13219            NCTEXT(ICNT)=9
13220            AVALUE(ICNT)=0.0
13221            IDIGIT(ICNT)=-1
13222          ENDIF
13223          ICNT=ICNT+1
13224          ITEXT(ICNT)='Number of Observations:'
13225          NCTEXT(ICNT)=23
13226          AVALUE(ICNT)=REAL(DN(I))
13227          IDIGIT(ICNT)=0
13228          ICNT=ICNT+1
13229          ITEXT(ICNT)='Sum of Squared Ranks:'
13230          NCTEXT(ICNT)=21
13231          AVALUE(ICNT)=REAL(DSUMSQ(I))
13232          IDIGIT(ICNT)=NUMDIG
13233 2060   CONTINUE
13234C
13235        IF(ICNT.GT.0)THEN
13236          NUMROW=ICNT
13237          DO2068II=1,NUMROW
13238            NTOT(II)=15
13239 2068     CONTINUE
13240C
13241          IFRST=.TRUE.
13242          ILAST=.TRUE.
13243C
13244          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
13245     1                AVALUE,IDIGIT,
13246     1                NTOT,NUMROW,
13247     1                ICAPSW,ICAPTY,ILAST,IFRST,
13248     1                ISUBRO,IBUGA3,IERROR)
13249          ICNT=0
13250        ENDIF
13251      ENDIF
13252C
13253      ICNT=ICNT+1
13254      ITEXT(ICNT)=' '
13255      NCTEXT(ICNT)=1
13256      AVALUE(ICNT)=0.0
13257      IDIGIT(ICNT)=-1
13258C
13259      ICNT=ICNT+1
13260      ITEXT(ICNT)='H0: Samples Have Equal Variability'
13261      NCTEXT(ICNT)=34
13262      AVALUE(ICNT)=0.0
13263      IDIGIT(ICNT)=-1
13264      ICNT=ICNT+1
13265      ITEXT(ICNT)='Ha: Samples Do Not Have Equal Variability'
13266      NCTEXT(ICNT)=41
13267      AVALUE(ICNT)=0.0
13268      IDIGIT(ICNT)=-1
13269C
13270      ICNT=ICNT+1
13271      ITEXT(ICNT)=' '
13272      NCTEXT(ICNT)=1
13273      AVALUE(ICNT)=0.0
13274      IDIGIT(ICNT)=-1
13275      ICNT=ICNT+1
13276      ITEXT(ICNT)='Summary Statistics:'
13277      NCTEXT(ICNT)=19
13278      AVALUE(ICNT)=0.0
13279      IDIGIT(ICNT)=-1
13280      ICNT=ICNT+1
13281      ITEXT(ICNT)='Total Number of Observations:'
13282      NCTEXT(ICNT)=29
13283      AVALUE(ICNT)=REAL(N)
13284      IDIGIT(ICNT)=0
13285      ICNT=ICNT+1
13286      ITEXT(ICNT)='Number of Groups:'
13287      NCTEXT(ICNT)=17
13288      AVALUE(ICNT)=REAL(NDIST)
13289      IDIGIT(ICNT)=0
13290      ICNT=ICNT+1
13291      ITEXT(ICNT)=' '
13292      NCTEXT(ICNT)=1
13293      AVALUE(ICNT)=0.0
13294      IDIGIT(ICNT)=-1
13295C
13296      ICNT=ICNT+1
13297      ITEXT(ICNT)='Squared Ranks Test Statistic Value:'
13298      NCTEXT(ICNT)=35
13299      AVALUE(ICNT)=STATVA
13300      IDIGIT(ICNT)=NUMDIG
13301      ICNT=ICNT+1
13302      ITEXT(ICNT)='CDF of Test Statistic:'
13303      NCTEXT(ICNT)=22
13304      AVALUE(ICNT)=STATCD
13305      IDIGIT(ICNT)=NUMDIG
13306      IF(NDIST.GE.3)THEN
13307        ICNT=ICNT+1
13308        ITEXT(ICNT)='P-Value:'
13309        NCTEXT(ICNT)=8
13310        AVALUE(ICNT)=PVAL2P
13311        IDIGIT(ICNT)=NUMDIG
13312      ELSE
13313        ICNT=ICNT+1
13314        ITEXT(ICNT)='Two-Tailed P-Value:'
13315        NCTEXT(ICNT)=19
13316        AVALUE(ICNT)=PVAL2P
13317        IDIGIT(ICNT)=NUMDIG
13318        ICNT=ICNT+1
13319        ITEXT(ICNT)='Lower Tailed P-Value:'
13320        NCTEXT(ICNT)=21
13321        AVALUE(ICNT)=PVALLP
13322        IDIGIT(ICNT)=NUMDIG
13323        ICNT=ICNT+1
13324        ITEXT(ICNT)='Upper Tailed P-Value:'
13325        NCTEXT(ICNT)=21
13326        AVALUE(ICNT)=PVALUP
13327        IDIGIT(ICNT)=NUMDIG
13328      ENDIF
13329C
13330      NUMROW=ICNT
13331      DO4210I=1,NUMROW
13332        NTOT(I)=15
13333 4210 CONTINUE
13334C
13335      IFRST=.TRUE.
13336      ILAST=.TRUE.
13337C
13338      ISTEPN='42A'
13339      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR2')
13340     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13341C
13342      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
13343     1            AVALUE,IDIGIT,
13344     1            NTOT,NUMROW,
13345     1            ICAPSW,ICAPTY,ILAST,IFRST,
13346     1            ISUBRO,IBUGA3,IERROR)
13347C
13348      IF(NDIST.EQ.2)GOTO5000
13349C
13350      ITITLE=' '
13351      NCTITL=0
13352      ITITL9=' '
13353      NCTIT9=0
13354      ITITLE(1:55)=
13355     1'Percent Points of the Chi-Square Reference Distribution'
13356      NCTITL=55
13357      NUMLIN=1
13358      NUMROW=8
13359      NUMCOL=3
13360      ITITL2(1,1)='Percent Point'
13361      ITITL2(1,2)=' '
13362      ITITL2(1,3)='Value'
13363      NCTIT2(1,1)=13
13364      NCTIT2(1,2)=1
13365      NCTIT2(1,3)=5
13366C
13367      NMAX=0
13368      DO4221I=1,NUMCOL
13369        VALIGN(I)='b'
13370        ALIGN(I)='r'
13371        NTOT(I)=15
13372        IF(I.EQ.2)NTOT(I)=5
13373        NMAX=NMAX+NTOT(I)
13374        IDIGIT(I)=NUMDIG
13375        ITYPCO(I)='NUME'
13376 4221 CONTINUE
13377      ITYPCO(2)='ALPH'
13378      IDIGIT(1)=1
13379      IDIGIT(3)=3
13380      DO4223I=1,NUMROW
13381        DO4225J=1,NUMCOL
13382          NCVALU(I,J)=0
13383          IVALUE(I,J)=' '
13384          NCVALU(I,J)=0
13385          AMAT(I,J)=0.0
13386          IF(J.EQ.1)THEN
13387            AMAT(I,J)=ALPHA(I)
13388          ELSEIF(J.EQ.2)THEN
13389            IVALUE(I,J)='='
13390            NCVALU(I,J)=1
13391          ELSEIF(J.EQ.3)THEN
13392            IF(I.EQ.1)THEN
13393              AMAT(I,J)=RND(CUT0,IDIGIT(J))
13394            ELSEIF(I.EQ.2)THEN
13395              AMAT(I,J)=RND(CUT50,IDIGIT(J))
13396            ELSEIF(I.EQ.3)THEN
13397              AMAT(I,J)=RND(CUT75,IDIGIT(J))
13398            ELSEIF(I.EQ.4)THEN
13399              AMAT(I,J)=RND(CUT90,IDIGIT(J))
13400            ELSEIF(I.EQ.5)THEN
13401              AMAT(I,J)=RND(CUT95,IDIGIT(J))
13402            ELSEIF(I.EQ.6)THEN
13403              AMAT(I,J)=RND(CUT975,IDIGIT(J))
13404            ELSEIF(I.EQ.7)THEN
13405              AMAT(I,J)=RND(CUT99,IDIGIT(J))
13406            ELSEIF(I.EQ.8)THEN
13407              AMAT(I,J)=RND(CUT999,IDIGIT(J))
13408            ENDIF
13409          ENDIF
13410 4225   CONTINUE
13411 4223 CONTINUE
13412C
13413      IWHTML(1)=150
13414      IWHTML(2)=50
13415      IWHTML(3)=150
13416      IWRTF(1)=2000
13417      IWRTF(2)=IWRTF(1)+500
13418      IWRTF(3)=IWRTF(2)+2000
13419      IFRST=.TRUE.
13420      ILAST=.FALSE.
13421C
13422      ISTEPN='42C'
13423      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR2')
13424     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13425C
13426      CALL DPDTA4(ITITL9,NCTIT9,
13427     1            ITITLE,NCTITL,ITITL2,NCTIT2,
13428     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
13429     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
13430     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
13431     1            ICAPSW,ICAPTY,IFRST,ILAST,
13432     1            ISUBRO,IBUGA3,IERROR)
13433C
13434      ISTEPN='42D'
13435      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR2')
13436     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13437C
13438      ITITLE='Upper-Tailed Test: Chi-Square Approximation'
13439      NCTITL=43
13440      ITITL9='H0: Variances Are Equal; Ha: Variance Are Not Equal'
13441      NCTIT9=51
13442C
13443      DO2130J=1,NUMCLI
13444        DO2140I=1,MAXLIN
13445          ITITL2(I,J)=' '
13446          NCTIT2(I,J)=0
13447 2140   CONTINUE
13448 2130 CONTINUE
13449C
13450      NUMCOL=4
13451      ITITL2(2,1)='Significance'
13452      NCTIT2(2,1)=12
13453      ITITL2(3,1)='Level'
13454      NCTIT2(3,1)=5
13455C
13456      ITITL2(2,2)='Test '
13457      NCTIT2(2,2)=4
13458      ITITL2(3,2)='Statistic'
13459      NCTIT2(3,2)=9
13460C
13461      ITITL2(2,3)='Critical'
13462      NCTIT2(2,3)=8
13463      ITITL2(3,3)='Value (>)'
13464      NCTIT2(3,3)=9
13465C
13466      ITITL2(1,4)='Null'
13467      NCTIT2(1,4)=4
13468      ITITL2(2,4)='Hypothesis'
13469      NCTIT2(2,4)=10
13470      ITITL2(3,4)='Conclusion'
13471      NCTIT2(3,4)=10
13472C
13473      NMAX=0
13474      DO2150I=1,NUMCOL
13475        VALIGN(I)='b'
13476        ALIGN(I)='r'
13477        NTOT(I)=15
13478        NMAX=NMAX+NTOT(I)
13479        ITYPCO(I)='NUME'
13480        IDIGIT(I)=NUMDIG
13481        IF(I.EQ.1 .OR. I.EQ.4)THEN
13482          ITYPCO(I)='ALPH'
13483        ENDIF
13484 2150 CONTINUE
13485C
13486      IWHTML(1)=125
13487      IWHTML(2)=175
13488      IWHTML(3)=175
13489      IWHTML(4)=175
13490      IINC=1800
13491      IINC2=1400
13492      IWRTF(1)=IINC
13493      IWRTF(2)=IWRTF(1)+IINC
13494      IWRTF(3)=IWRTF(2)+IINC
13495      IWRTF(4)=IWRTF(3)+IINC
13496C
13497      ICNT=NUMAL2
13498      DO2160J=1,NUMAL2
13499C
13500        AMAT(J,2)=STATVA
13501        ALPHAT=ALPHA(J)
13502        ATEMP=ALPHAT/100.0
13503        CALL CHSPPF(ATEMP,IDF,CUTTMP)
13504        AMAT(J,3)=CUTTMP
13505        IVALUE(J,4)(1:6)='REJECT'
13506        IF(ABS(STATVA).LT.AMAT(J,3))THEN
13507          IVALUE(J,4)(1:6)='ACCEPT'
13508        ENDIF
13509        NCVALU(J,4)=6
13510C
13511        WRITE(IVALUE(J,1)(1:4),'(F4.1)')ALPHAT
13512        IVALUE(J,1)(5:5)='%'
13513        NCVALU(J,1)=5
13514 2160 CONTINUE
13515C
13516      NUMLIN=3
13517      IFRST=.TRUE.
13518      ILAST=.TRUE.
13519      IFLAGS=.TRUE.
13520      IFLAGE=.TRUE.
13521C
13522      CALL DPDTA5(ITITLE,NCTITL,
13523     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
13524     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
13525     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
13526     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
13527     1            ICAPSW,ICAPTY,IFRST,ILAST,
13528     1            IFLAGS,IFLAGE,
13529     1            ISUBRO,IBUGA3,IERROR)
13530C
13531      ITITLE(1:26)='Multiple Comparisons Table'
13532      NCTITL=26
13533      ITITL9=' '
13534      NCTIT9=0
13535C
13536      ITITL2(1,1)='I'
13537      NCTIT2(1,1)=1
13538      ITITL2(1,2)='J'
13539      NCTIT2(1,2)=1
13540      ITITL2(1,3)='|Si/Ni - Sj/Nj|'
13541      NCTIT2(1,3)=15
13542      ITITL2(1,4)='90% CV'
13543      NCTIT2(1,4)=6
13544      ITITL2(1,5)='95% CV'
13545      NCTIT2(1,5)=6
13546      ITITL2(1,6)='99% CV'
13547      NCTIT2(1,6)=6
13548C
13549      NMAX=0
13550      NUMCOL=6
13551      DO4010I=1,NUMCOL
13552        VALIGN(I)='b'
13553        ALIGN(I)='r'
13554        ITYPCO(I)='NUME'
13555        IDIGIT(I)=NUMDIG
13556        NTOT(I)=15
13557        IF(I.EQ.1 .OR. I.EQ.2)THEN
13558          NTOT(I)=5
13559          IDIGIT(I)=0
13560        ELSEIF(I.EQ.3)THEN
13561          NTOT(I)=17
13562        ENDIF
13563        NMAX=NMAX+NTOT(I)
13564 4010 CONTINUE
13565      IWHTML(1)=50
13566      IWHTML(2)=50
13567      IWHTML(3)=150
13568      IWHTML(4)=150
13569      IWHTML(5)=150
13570      IWHTML(6)=150
13571      IINC=1600
13572      IINC2=200
13573      IINC3=1000
13574      IWRTF(1)=IINC2
13575      IWRTF(2)=IWRTF(1)+IINC2
13576      IWRTF(3)=IWRTF(2)+IINC
13577      IWRTF(4)=IWRTF(3)+IINC
13578      IWRTF(5)=IWRTF(4)+IINC
13579      IWRTF(6)=IWRTF(5)+IINC
13580C
13581      ICNT=0
13582      DO4081I=1,NDIST
13583        DO4083J=1,NDIST
13584          IF(I.LT.J)THEN
13585C
13586            AFACT3=REAL(DSQRT((1.0D0/DN(I)) + (1.0D0/DN(J))))
13587            ADIFF=REAL(DABS((DSUMSQ(I)/DN(I)) - (DSUMSQ(J)/DN(J))))
13588            ACV90=AT90*AFACT2*AFACT3
13589            ACV95=AT95*AFACT2*AFACT3
13590            ACV99=AT99*AFACT2*AFACT3
13591            IATEMP='   '
13592            IF(ADIFF.GE.ACV90)IATEMP(1:1)='*'
13593            IF(ADIFF.GE.ACV95)IATEMP(2:2)='*'
13594            IF(ADIFF.GE.ACV99)IATEMP(3:3)='*'
13595C
13596            IF(ICNT.GE.MAXROW)THEN
13597              NUMLIN=1
13598              IFRST=.TRUE.
13599              ILAST=.TRUE.
13600              IFLAGS=.TRUE.
13601              IFLAGE=.TRUE.
13602              CALL DPDTA5(ITITLE,NCTITL,
13603     1                    ITITL9,NCTIT9,ITITL2,NCTIT2,
13604     1                    MAXLIN,NUMLIN,NUMCLI,NUMCOL,
13605     1                    IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
13606     1                    IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
13607     1                    ICAPSW,ICAPTY,IFRST,ILAST,
13608     1                    IFLAGS,IFLAGE,
13609     1                    ISUBRO,IBUGA3,IERROR)
13610              ICNT=0
13611            ENDIF
13612C
13613            ICNT=ICNT+1
13614            IVALUE(ICNT,1)=' '
13615            NCVALU(ICNT,1)=0
13616            AMAT(ICNT,1)=REAL(I)
13617            IVALUE(ICNT,2)=' '
13618            NCVALU(ICNT,2)=0
13619            AMAT(ICNT,2)=REAL(J)
13620            IVALUE(ICNT,3)=' '
13621            NCVALU(ICNT,3)=0
13622            AMAT(ICNT,3)=ADIFF
13623            IVALUE(ICNT,4)=' '
13624            NCVALU(ICNT,4)=0
13625            AMAT(ICNT,4)=ACV90
13626            IVALUE(ICNT,5)=' '
13627            NCVALU(ICNT,5)=0
13628            AMAT(ICNT,5)=ACV95
13629            IVALUE(ICNT,6)=' '
13630            NCVALU(ICNT,6)=0
13631            AMAT(ICNT,6)=ACV99
13632          ENDIF
13633 4083   CONTINUE
13634 4081 CONTINUE
13635C
13636      IF(ICNT.GE.1)THEN
13637        NUMLIN=1
13638        IFRST=.TRUE.
13639        ILAST=.TRUE.
13640        IFLAGS=.TRUE.
13641        IFLAGE=.TRUE.
13642        CALL DPDTA5(ITITLE,NCTITL,
13643     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
13644     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
13645     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
13646     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
13647     1              ICAPSW,ICAPTY,IFRST,ILAST,
13648     1              IFLAGS,IFLAGE,
13649     1              ISUBRO,IBUGA3,IERROR)
13650      ENDIF
13651      GOTO9000
13652C
13653 5000 CONTINUE
13654C
13655      ITITLE='Two-Tailed Test: Normal Approximation'
13656      NCTITL=37
13657      ITITL9='H0: Var(Y1) = Var(Y2); Ha: Var(Y1) <> Var(Y2)'
13658      NCTIT9=45
13659C
13660      DO5130J=1,NUMCLI
13661        DO5140I=1,MAXLIN
13662          ITITL2(I,J)=' '
13663          NCTIT2(I,J)=0
13664 5140   CONTINUE
13665 5130 CONTINUE
13666C
13667      NUMCOL=4
13668      ITITL2(2,1)='Significance'
13669      NCTIT2(2,1)=12
13670      ITITL2(3,1)='Level'
13671      NCTIT2(3,1)=5
13672C
13673      ITITL2(2,2)='Test '
13674      NCTIT2(2,2)=4
13675      ITITL2(3,2)='Statistic'
13676      NCTIT2(3,2)=9
13677C
13678      ITITL2(2,3)='Critical'
13679      NCTIT2(2,3)=8
13680      ITITL2(3,3)='Value (+/-)'
13681      NCTIT2(3,3)=11
13682C
13683      ITITL2(1,4)='Null'
13684      NCTIT2(1,4)=4
13685      ITITL2(2,4)='Hypothesis'
13686      NCTIT2(2,4)=10
13687      ITITL2(3,4)='Conclusion'
13688      NCTIT2(3,4)=10
13689C
13690      NMAX=0
13691      DO5150I=1,NUMCOL
13692        VALIGN(I)='b'
13693        ALIGN(I)='r'
13694        NTOT(I)=15
13695        NMAX=NMAX+NTOT(I)
13696        ITYPCO(I)='NUME'
13697        IDIGIT(I)=NUMDIG
13698        IF(I.EQ.1 .OR. I.EQ.4)THEN
13699          ITYPCO(I)='ALPH'
13700        ENDIF
13701 5150 CONTINUE
13702C
13703      IWHTML(1)=125
13704      IWHTML(2)=175
13705      IWHTML(3)=175
13706      IWHTML(4)=175
13707      IINC=1800
13708      IINC2=1400
13709      IWRTF(1)=IINC
13710      IWRTF(2)=IWRTF(1)+IINC
13711      IWRTF(3)=IWRTF(2)+IINC
13712      IWRTF(4)=IWRTF(3)+IINC
13713C
13714      ICNT=NUMAL2
13715      DO5160J=1,NUMAL2
13716C
13717        AMAT(J,2)=STATVA
13718        ALPHAT=ALPHA2(J)
13719        ATEMP=(1.0 - ALPHAT)/2.0
13720        ATEMP=1.0 - ATEMP
13721        CALL NORPPF(ATEMP,CUTTMP)
13722        AMAT(J,3)=CUTTMP
13723        IVALUE(J,4)(1:6)='REJECT'
13724        IF(ABS(STATVA).LT.AMAT(J,3))THEN
13725          IVALUE(J,4)(1:6)='ACCEPT'
13726        ENDIF
13727        NCVALU(J,4)=6
13728C
13729        WRITE(IVALUE(J,1)(1:4),'(F4.1)')100.0*ALPHAT
13730        IVALUE(J,1)(5:5)='%'
13731        NCVALU(J,1)=5
13732 5160 CONTINUE
13733C
13734      NUMLIN=3
13735      IFRST=.TRUE.
13736      ILAST=.TRUE.
13737      IFLAGS=.TRUE.
13738      IFLAGE=.TRUE.
13739C
13740      IF(ICASAN.EQ.'TWOT')THEN
13741        CALL DPDTA5(ITITLE,NCTITL,
13742     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
13743     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
13744     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
13745     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
13746     1              ICAPSW,ICAPTY,IFRST,ILAST,
13747     1              IFLAGS,IFLAGE,
13748     1              ISUBRO,IBUGA3,IERROR)
13749      ENDIF
13750C
13751      IF(ICASAN.EQ.'LOWE')THEN
13752C
13753        ITITLE='Lower-Tailed Test: Normal Approximation'
13754        NCTITL=39
13755        ITITL9='H0: Var(Y1) = Var(Y2); Ha: Var(Y1) < Var(Y2)'
13756        NCTIT9=44
13757C
13758        ITITL2(2,3)='Critical'
13759        NCTIT2(2,3)=8
13760        ITITL2(3,3)='Value (<)'
13761        NCTIT2(3,3)=9
13762        NUMCOL=4
13763C
13764        NMAX=0
13765        DO5250I=1,NUMCOL
13766          NTOT(I)=15
13767          NMAX=NMAX+NTOT(I)
13768 5250   CONTINUE
13769C
13770        ICNT=NUMALP
13771        DO5260J=1,NUMALP
13772C
13773          AMAT(J,2)=STATVA
13774          ALPHAT=ALPHA(J)
13775          ATEMP=(1.0 - ALPHAT)
13776          CALL NORPPF(ATEMP,CUTTMP)
13777          AMAT(J,3)=CUTTMP
13778          IVALUE(J,4)(1:6)='ACCEPT'
13779          IF(ABS(STATVA).LT.AMAT(J,3))THEN
13780            IVALUE(J,4)(1:6)='REJECT'
13781          ENDIF
13782          NCVALU(J,4)=6
13783          WRITE(IVALUE(J,1)(1:4),'(F4.1)')100.0*ALPHAT
13784          IVALUE(J,1)(5:5)='%'
13785          NCVALU(J,1)=5
13786 5260   CONTINUE
13787C
13788        NUMLIN=3
13789        IFRST=.TRUE.
13790        ILAST=.TRUE.
13791        IFLAGS=.TRUE.
13792        IFLAGE=.TRUE.
13793        CALL DPDTA5(ITITLE,NCTITL,
13794     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
13795     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
13796     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
13797     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
13798     1              ICAPSW,ICAPTY,IFRST,ILAST,
13799     1              IFLAGS,IFLAGE,
13800     1              ISUBRO,IBUGA3,IERROR)
13801      ENDIF
13802C
13803      IF(ICASAN.EQ.'UPPE')THEN
13804C
13805        ITITLE='Upper-Tailed Test: Normal Approximation'
13806        NCTITL=39
13807        ITITL9='H0: Var(Y1) = Var(Y2); Ha: Var(Y1) > Var(Y2)'
13808        NCTIT9=44
13809C
13810        ITITL2(2,3)='Critical'
13811        NCTIT2(2,3)=8
13812        ITITL2(3,3)='Value (>)'
13813        NCTIT2(3,3)=9
13814        NUMCOL=4
13815C
13816        NMAX=0
13817        DO5350I=1,NUMCOL
13818          NTOT(I)=15
13819          NMAX=NMAX+NTOT(I)
13820 5350   CONTINUE
13821C
13822        ICNT=NUMALP
13823        DO5360J=1,NUMALP
13824C
13825          AMAT(J,2)=STATVA
13826          ALPHAT=ALPHA(J)
13827          ATEMP=ALPHAT
13828          CALL NORPPF(ATEMP,CUTTMP)
13829          AMAT(J,3)=CUTTMP
13830          IVALUE(J,4)(1:6)='ACCEPT'
13831          IF(ABS(STATVA).GT.AMAT(J,3))THEN
13832            IVALUE(J,4)(1:6)='REJECT'
13833          ENDIF
13834          NCVALU(J,4)=6
13835          WRITE(IVALUE(J,1)(1:4),'(F4.1)')100.0*ALPHAT
13836          IVALUE(J,1)(5:5)='%'
13837          NCVALU(J,1)=5
13838 5360   CONTINUE
13839C
13840        NUMLIN=3
13841        IFRST=.TRUE.
13842        ILAST=.TRUE.
13843        IFLAGS=.TRUE.
13844        IFLAGE=.TRUE.
13845        CALL DPDTA5(ITITLE,NCTITL,
13846     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
13847     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
13848     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
13849     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
13850     1              ICAPSW,ICAPTY,IFRST,ILAST,
13851     1              IFLAGS,IFLAGE,
13852     1              ISUBRO,IBUGA3,IERROR)
13853      ENDIF
13854C               *****************
13855C               **  STEP 90--  **
13856C               **  EXIT       **
13857C               *****************
13858C
13859 9000 CONTINUE
13860      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SQR2')THEN
13861        WRITE(ICOUT,999)
13862        CALL DPWRST('XXX','WRIT')
13863        WRITE(ICOUT,9011)
13864 9011   FORMAT('***** AT THE END       OF DPSQR2--')
13865        CALL DPWRST('XXX','WRIT')
13866        WRITE(ICOUT,9025)STATVA,STATCD
13867 9025   FORMAT('STATVA,STATCD = ',2G15.7)
13868        CALL DPWRST('XXX','WRIT')
13869      ENDIF
13870C
13871      RETURN
13872      END
13873      SUBROUTINE DPSQR3(Y,X,N,
13874     1                  TEMP1,TEMP2,YRANK,XIDTEM,MAXNXT,
13875     1                  DSUMSQ,DN,
13876     1                  STATVA,STATCD,PVALUE,PVALLT,PVALUT,
13877     1                  IDF,NDIST,D2,
13878     1                  IBUGA3,ISUBRO,IERROR)
13879C
13880C     PURPOSE--THIS ROUTINE COMPUTES THE SQUARED RANKS K-SAMPLE TEST
13881C              STATISTIC FOR EQUAL VARIANCES AND ASSOCIATED CDF AND
13882C              P-VALUES.
13883C
13884C              THIS PART IS EXTRACTED FROM DPSQR2 IN ORDER TO
13885C              ALLOW IT TO BE COMPUTED FROM THE "STATISTICS" ROUTINES
13886C              (E.G., STATISTIC PLOT, BOOTSTRAP).
13887C
13888C     EXAMPLE--SQUARED RANKS TEST Y X
13889C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
13890C                THIRD EDITION, WILEY, PP. 300 - 310.
13891C     WRITTEN BY--ALAN HECKERT
13892C                 STATISTICAL ENGINEERING DIVISION
13893C                 INFORMATION TECHNOLOGY LABORATORY
13894C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13895C                 GAITHERSBURG, MD 20899-8980
13896C                 PHONE--301-975-2855
13897C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13898C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13899C     LANGUAGE--ANSI FORTRAN (1977)
13900C     VERSION NUMBER--2011/6
13901C     ORIGINAL VERSION--JUNE      2011.
13902C
13903C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13904C
13905      CHARACTER*4 IBUGA3
13906      CHARACTER*4 ISUBRO
13907      CHARACTER*4 IERROR
13908C
13909      CHARACTER*4 IWRITE
13910      CHARACTER*4 ISUBN1
13911      CHARACTER*4 ISUBN2
13912      CHARACTER*4 ISTEPN
13913C
13914      DOUBLE PRECISION DSUM1
13915      DOUBLE PRECISION DSUM2
13916      DOUBLE PRECISION DSUM3
13917      DOUBLE PRECISION DSUM4
13918      DOUBLE PRECISION D2
13919      DOUBLE PRECISION SBAR
13920      DOUBLE PRECISION DTERM1
13921      DOUBLE PRECISION DNUM
13922      DOUBLE PRECISION DENOM
13923      DOUBLE PRECISION C1
13924      DOUBLE PRECISION C2
13925C
13926C---------------------------------------------------------------------
13927C
13928      DIMENSION Y(*)
13929      DIMENSION X(*)
13930      DIMENSION TEMP1(*)
13931      DIMENSION TEMP2(*)
13932      DIMENSION YRANK(*)
13933      DIMENSION XIDTEM(*)
13934C
13935      DOUBLE PRECISION DSUMSQ(*)
13936      DOUBLE PRECISION DN(*)
13937C
13938C-----COMMON----------------------------------------------------------
13939C
13940      INCLUDE 'DPCOP2.INC'
13941C
13942C-----START POINT-----------------------------------------------------
13943C
13944      ISUBN1='DPSQ'
13945      ISUBN2='R3  '
13946      IERROR='NO'
13947      IWRITE='OFF'
13948C
13949      STATVA=CPUMIN
13950      STATCD=CPUMIN
13951      PVALUE=CPUMIN
13952      IDF=-99
13953C
13954      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR3')THEN
13955        WRITE(ICOUT,999)
13956  999   FORMAT(1X)
13957        CALL DPWRST('XXX','WRIT')
13958        WRITE(ICOUT,51)
13959   51   FORMAT('**** AT THE BEGINNING OF DPSQR3--')
13960        CALL DPWRST('XXX','WRIT')
13961        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
13962   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
13963        CALL DPWRST('XXX','WRIT')
13964        DO56I=1,N
13965          WRITE(ICOUT,57)I,Y(I),X(I)
13966   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
13967          CALL DPWRST('XXX','WRIT')
13968   56   CONTINUE
13969      ENDIF
13970C
13971C               ********************************************
13972C               **  STEP 01--                             **
13973C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
13974C               ********************************************
13975C
13976      ISTEPN='01'
13977      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR3')
13978     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13979C
13980      IF(N.LE.1)THEN
13981        WRITE(ICOUT,999)
13982        CALL DPWRST('XXX','BUG ')
13983        WRITE(ICOUT,101)
13984  101   FORMAT('***** ERROR IN SQUARED RANKS TEST--')
13985        CALL DPWRST('XXX','BUG ')
13986        WRITE(ICOUT,112)
13987  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE ',
13988     1         'RESPONSE')
13989        CALL DPWRST('XXX','BUG ')
13990        WRITE(ICOUT,113)
13991  113   FORMAT('      VARIABLES MUST BE 2 OR LARGER.  SUCH WAS NOT ',
13992     1         'THE CASE HERE.')
13993        CALL DPWRST('XXX','BUG ')
13994        WRITE(ICOUT,117)N
13995  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS   = ',I8,'.')
13996        CALL DPWRST('XXX','BUG ')
13997        IERROR='YES'
13998        GOTO9000
13999      ENDIF
14000C
14001      HOLD=Y(1)
14002      DO135I=2,N
14003        IF(Y(I).NE.HOLD)GOTO139
14004  135 CONTINUE
14005      WRITE(ICOUT,999)
14006      CALL DPWRST('XXX','WRIT')
14007      WRITE(ICOUT,101)
14008      CALL DPWRST('XXX','WRIT')
14009      WRITE(ICOUT,131)HOLD
14010  131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
14011      CALL DPWRST('XXX','WRIT')
14012      IERROR='YES'
14013      GOTO9000
14014  139 CONTINUE
14015C
14016      HOLD=X(1)
14017      DO145I=2,N
14018        IF(X(I).NE.HOLD)GOTO149
14019  145 CONTINUE
14020      WRITE(ICOUT,999)
14021      CALL DPWRST('XXX','WRIT')
14022      WRITE(ICOUT,101)
14023      CALL DPWRST('XXX','WRIT')
14024      WRITE(ICOUT,141)HOLD
14025  141 FORMAT('      THE GROUP-ID VARIABLE HAS ALL ELEMENTS = ',G15.7)
14026      CALL DPWRST('XXX','WRIT')
14027      IERROR='YES'
14028      GOTO9000
14029  149 CONTINUE
14030C
14031C               *************************************
14032C               **   STEP 11--                     **
14033C               **   COMPUTE SQUARED RANKS   TEST  **
14034C               *************************************
14035C
14036      ISTEPN='11'
14037      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR3')
14038     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14039C
14040C     DETERMINE DISTINCT VALUES OF GROUP-ID VARIABLE.  SUBTRACT
14041C     GROUP MEANS FROM VARIABLE.
14042C
14043      CALL DISTIN(X,N,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
14044      DO1010K=1,NDIST
14045        HOLD=XIDTEM(K)
14046        NTEMP=0
14047        DO1020I=1,N
14048          IF(X(I).EQ.HOLD)THEN
14049            NTEMP=NTEMP+1
14050            TEMP2(NTEMP)=Y(I)
14051          ENDIF
14052 1020   CONTINUE
14053        CALL MEAN(TEMP2,NTEMP,IWRITE,YMEAN,IBUGA3,IERROR)
14054        YRANK(K)=YMEAN
14055 1010 CONTINUE
14056C
14057      DO1030I=1,N
14058        DO1040K=1,NDIST
14059          IF(XIDTEM(K).EQ.X(I))THEN
14060            TEMP1(I)=ABS(Y(I) - REAL(YRANK(K)))
14061            GOTO1049
14062          ENDIF
14063 1040   CONTINUE
14064 1049   CONTINUE
14065 1030 CONTINUE
14066C
14067C     COMPUTE RANKS, BUT SUBTRACT MEANS FROM DATA FIRST
14068C
14069      CALL RANK(TEMP1,N,IWRITE,YRANK,TEMP2,MAXNXT,IBUGA3,IERROR)
14070C
14071      DSUM1=0.0D0
14072      DSUM2=0.0D0
14073      DSUM4=0.0D0
14074      DO1050I=1,N
14075        DSUM1=DSUM1 + YRANK(I)**2
14076        DSUM2=DSUM2 + DBLE(YRANK(I))**4
14077        IF(X(I).EQ.XIDTEM(1))DSUM4=DSUM4 + DBLE(YRANK(I))**2
14078 1050 CONTINUE
14079      SBAR=DSUM1/DBLE(N)
14080C
14081      DSUM1=0.0D0
14082      DO1060K=1,NDIST
14083        HOLD=XIDTEM(K)
14084        NTEMP=0
14085        DSUM3=0.0D0
14086        DO1070I=1,N
14087          IF(XIDTEM(K).EQ.X(I))THEN
14088            NTEMP=NTEMP+1
14089            DSUM3=DSUM3 + DBLE(YRANK(I))**2
14090          ENDIF
14091 1070   CONTINUE
14092        DSUM1=DSUM1 + DSUM3**2/DBLE(NTEMP)
14093        DSUMSQ(K)=DSUM3
14094        DN(K)=DBLE(NTEMP)
14095 1060 CONTINUE
14096C
14097C     COMPUTE SQUARED RANKS TEST STATISTIC:
14098C
14099C         T = (1/D**2)*{SUM[i=1 to k][S(i)**2/n(i)] - N*SBAR**2}
14100C
14101C     WHERE
14102C
14103C         S(i) = SUM OF SQUARE RANKS IN SUBSAMPLE i
14104C         n(i) = NUMBER OF OBSERVATIONS IN SUBSAMPLE i
14105C         D**2 = (1/(N-1))*{SUM[i=1 to N][R(i)**4] - N*SBAR**2}
14106C         SBAR = (1/N)*SUM[j=1 to k][S(k)]
14107C              = (1/N)*SUM[i=1 to N][S(k)]
14108C
14109C     FOR 2-SAMPLE CASE, THE FORMULA IS
14110C
14111C        T1 = {T - N1*SBAR**2}/
14112C             SQRT{(N1*N2)/(N*(N-1))}*SUM[i=1 to N][R(i)**4] -
14113C             (N1*N2/(N-1))*(SBAR)**2}
14114C
14115      ISTEPN='12'
14116      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR3')
14117     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14118C
14119      IF(NDIST.GT.2)THEN
14120        D2=(DSUM2 - DBLE(N)*SBAR**2)/DBLE(N-1)
14121        DTERM1=(DSUM1 - DBLE(N)*SBAR**2)/D2
14122        STATVA=REAL(DTERM1)
14123C
14124C       CDF AND P-VALUES COMPUTED FROM CHI-SQUARE APPROXIMATION
14125C
14126        IDF=NDIST-1
14127        CALL CHSCDF(STATVA,IDF,STATCD)
14128        PVALUE=1.0 - STATCD
14129        PVALLT=CPUMIN
14130        PVALUT=CPUMIN
14131      ELSE
14132        DNUM=DSUM4 - DN(1)*SBAR
14133        C1=DN(1)*DN(2)/(DBLE(N)*DBLE(N-1))
14134        C2=DN(1)*DN(2)/DBLE(N-1)
14135        DENOM=DSQRT(C1*DSUM2 - C2*SBAR**2)
14136        STATVA=REAL(DNUM/DENOM)
14137        CALL NORCDF(STATVA,STATCD)
14138        PVALLT=STATCD
14139        PVALUT=1.0 - STATCD
14140        PVALUE=2.0*MIN(PVALLT,PVALUT)
14141      ENDIF
14142C
14143C               *****************
14144C               **  STEP 90--  **
14145C               **  EXIT       **
14146C               *****************
14147C
14148 9000 CONTINUE
14149      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SQR3')THEN
14150        WRITE(ICOUT,999)
14151        CALL DPWRST('XXX','WRIT')
14152        WRITE(ICOUT,9011)
14153 9011   FORMAT('***** AT THE END       OF DPSQR3--')
14154        CALL DPWRST('XXX','WRIT')
14155        WRITE(ICOUT,9013)STATVA,STATCD,PVALUE,IDF
14156 9013   FORMAT('STATVA,STATCD,PVALUE,IDF = ',3G15.7,I8)
14157        CALL DPWRST('XXX','WRIT')
14158        WRITE(ICOUT,9014)SBAR,D2,DSUM1,DSUM2,DSUM3
14159 9014   FORMAT('SBAR,D2,DSUM1,DSUM2,DSUM3 = ',5G15.7)
14160        CALL DPWRST('XXX','WRIT')
14161      ENDIF
14162C
14163      RETURN
14164      END
14165      SUBROUTINE DPSQUE(PX,PY,NP,
14166     1PXMIN,PXMAX,PYMIN,PYMAX)
14167C
14168C     PURPOSE--SCAN EACH VALUE OF PX(.) AND
14169C              COMPARE IT TO (PXMIN,PXMAX).
14170C              IF ONLY SLIGHTLY SMALLER THAN PXMIN,
14171C              THEN CHANGE PX(I) TO PXMAX.
14172C              IF ONLY SLIGHTLY LARGER THAN PXMAX,
14173C              THEN CHANGE PX(I) TO PXMAX.
14174C              SIMILARLY, SCAN EACH VALUE OF PY(.) AND
14175C              COMPARE IT TO (PYMIN,PYMAX).
14176C              IF ONLY SLIGHTLY SMALLER THAN PYMIN,
14177C              THEN CHANGE PY(I) TO PYMAX.
14178C              IF ONLY SLIGHTLY LARGER THAN PYMAX,
14179C              THEN CHANGE PY(I) TO PYMAX.
14180C     NOTE--THIS SUBROUTINE COUNTERACTS INCORRECT
14181C           COORDINATE CALCULATIONS FOR P WHICH ARE
14182C           INCORRECT DUE TO ROUNDOFF ERROR
14183C           AND SQUEEZES THEM BACK TO THEIR PROPER VALUE.
14184C     DANGER--PX(.) AND PY(.) SERVE AS BOTH INPUT AND
14185C             OUTPUT ARGUMENTS IN THIS SUBROUTINE.
14186C
14187C     WRITTEN BY--JAMES J. FILLIBEN
14188C                 STATISTICAL ENGINEERING DIVISION
14189C                 INFORMATION TECHNOLOGY LABORATORY
14190C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14191C                 GAITHERSBURG, MD 20899-8980
14192C                 PHONE--301-975-2855
14193C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14194C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14195C           THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED,
14196C           MODIFIED, OR OTHERWISE USED IN A CONTEXT
14197C           OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM.
14198C     LANGUAGE--ANSI FORTRAN (1977)
14199C     VERSION NUMBER--83.6
14200C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY       1983.
14201C
14202C--------------------------------------------------------
14203C
14204      DIMENSION PX(*)
14205      DIMENSION PY(*)
14206C
14207C-----COMMON----------------------------------------------------------
14208C
14209      INCLUDE 'DPCOBE.INC'
14210      INCLUDE 'DPCOP2.INC'
14211C
14212C-----START POINT-----------------------------------------------------
14213C
14214      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SQUE')GOTO90
14215      WRITE(ICOUT,999)
14216  999 FORMAT(1X)
14217      CALL DPWRST('XXX','BUG ')
14218      WRITE(ICOUT,51)
14219   51 FORMAT('***** AT THE BEGINNING OF DPSQUE--')
14220      CALL DPWRST('XXX','BUG ')
14221      WRITE(ICOUT,52)PXMIN,PXMAX,PYMIN,PYMAX
14222   52 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
14223      CALL DPWRST('XXX','BUG ')
14224      WRITE(ICOUT,54)NP
14225   54 FORMAT('NP = ',I8)
14226      CALL DPWRST('XXX','BUG ')
14227      DO55I=1,NP
14228      DELXMN=PXMIN-PX(I)
14229      DELXMX=PX(I)-PXMAX
14230      DELYMN=PYMIN-PY(I)
14231      DELYMX=PY(I)-PYMAX
14232      WRITE(ICOUT,56)I,PX(I),PY(I)
14233   56 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
14234      CALL DPWRST('XXX','BUG ')
14235      WRITE(ICOUT,57)DELXMN,DELXMX,DELYMN,DELYMN
14236   57 FORMAT('DELXMN,DELXMX,DELYMN,DELYMN = ',4E15.7)
14237      CALL DPWRST('XXX','BUG ')
14238   55 CONTINUE
14239      WRITE(ICOUT,59)IBUGG4,ISUBG4,IERRG4
14240   59 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
14241      CALL DPWRST('XXX','BUG ')
14242   90 CONTINUE
14243C
14244C               *************************************************
14245C               **  STEP 1--                                   **
14246C               **  CHECK TO SEE IF PX(.) NEAR PXMIN OR PXMAX  **
14247C               *************************************************
14248C
14249      IF(NP.LE.0)GOTO1190
14250      DO1100I=1,NP
14251C
14252      IF(PX(I).LT.PXMIN)GOTO1110
14253      IF(PX(I).GT.PXMAX)GOTO1120
14254      GOTO1100
14255C
14256 1110 CONTINUE
14257      DELMIN=PXMIN-PX(I)
14258      IF(DELMIN.LE.0.0001)PX(I)=PXMIN
14259      GOTO1100
14260C
14261 1120 CONTINUE
14262      DELMAX=PX(I)-PXMAX
14263      IF(DELMAX.LE.0.0001)PX(I)=PXMAX
14264      GOTO1100
14265C
14266 1100 CONTINUE
14267 1190 CONTINUE
14268C
14269C               *************************************************
14270C               **  STEP 2--                                   **
14271C               **  CHECK TO SEE IF PY(.) NEAR PYMIN OR PYMAX  **
14272C               *************************************************
14273C
14274      IF(NP.LE.0)GOTO1290
14275      DO1200I=1,NP
14276C
14277      IF(PY(I).LT.PYMIN)GOTO1210
14278      IF(PY(I).GT.PYMAX)GOTO1220
14279      GOTO1200
14280C
14281 1210 CONTINUE
14282      DELMIN=PYMIN-PY(I)
14283      IF(DELMIN.LE.0.0001)PY(I)=PYMIN
14284      GOTO1200
14285C
14286 1220 CONTINUE
14287      DELMAX=PY(I)-PYMAX
14288      IF(DELMAX.LE.0.0001)PY(I)=PYMAX
14289      GOTO1200
14290C
14291 1200 CONTINUE
14292 1290 CONTINUE
14293C
14294C               *****************
14295C               **  STEP 90--  **
14296C               **  EXIT       **
14297C               *****************
14298C
14299      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'SQUE')GOTO9090
14300      WRITE(ICOUT,999)
14301      CALL DPWRST('XXX','BUG ')
14302      WRITE(ICOUT,9011)
14303 9011 FORMAT('***** AT THE END       OF DPSQUE--')
14304      CALL DPWRST('XXX','BUG ')
14305      WRITE(ICOUT,9012)PXMIN,PXMAX,PYMIN,PYMAX
14306 9012 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
14307      CALL DPWRST('XXX','BUG ')
14308      WRITE(ICOUT,9014)NP
14309 9014 FORMAT('NP = ',I8)
14310      CALL DPWRST('XXX','BUG ')
14311      DO9015I=1,NP
14312      DELXMN=PXMIN-PX(I)
14313      DELXMX=PX(I)-PXMAX
14314      DELYMN=PYMIN-PY(I)
14315      DELYMX=PY(I)-PYMAX
14316      WRITE(ICOUT,9016)I,PX(I),PY(I)
14317 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
14318      CALL DPWRST('XXX','BUG ')
14319      WRITE(ICOUT,9017)DELXMN,DELXMX,DELYMN,DELYMN
14320 9017 FORMAT('DELXMN,DELXMX,DELYMN,DELYMN = ',4E15.7)
14321      CALL DPWRST('XXX','BUG ')
14322 9015 CONTINUE
14323      WRITE(ICOUT,9019)IBUGG4,ISUBG4,IERRG4
14324 9019 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
14325      CALL DPWRST('XXX','BUG ')
14326 9090 CONTINUE
14327C
14328      RETURN
14329      END
14330      SUBROUTINE DPSSPL(ISUBRO,IBUGA3,IERROR)
14331C
14332C     PURPOSE--SPLIT A STRING INTO SEPARATE WORDS.
14333C     EXAMPLE--LET SBASE = STRING SPLIT SORG
14334C
14335C              THAT IS, SORG WILL BE SPLIT INTO SEPARATE WORDS WHICH
14336C              WILL BE SAVED TO STRINGS SBASE1, SBASE2, ...
14337C     WRITTEN BY--ALAN HECKERT
14338C                 STATISTICAL ENGINEERING DIVISION
14339C                 INFORMATION TECHNOLOGY LABORATORY
14340C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
14341C                 GAITHERSBURG, MD 20899-8980
14342C                 PHONE--301-975-2899
14343C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14344C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
14345C     LANGUAGE--ANSI FORTRAN (1977)
14346C     VERSION NUMBER--2018/09
14347C     ORIGINAL VERSION--SEPTEMBER 2018.
14348C
14349C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14350C
14351      CHARACTER*4 ISUBRO
14352      CHARACTER*4 IBUGA3
14353      CHARACTER*4 IERROR
14354C
14355      CHARACTER*4 NEWNAM
14356      CHARACTER*4 NEWCOL
14357      CHARACTER*4 ICASEL
14358      CHARACTER*8 IHLEFT
14359      CHARACTER*8 ISTRIN
14360      CHARACTER*4 IHLEF3
14361      CHARACTER*4 IHLEF4
14362      CHARACTER*4 IHRIGH
14363      CHARACTER*4 IHRIG2
14364      CHARACTER*4 ISUBN1
14365      CHARACTER*4 ISUBN2
14366      CHARACTER*4 ISTEPN
14367C
14368      CHARACTER*40 ISTRZZ
14369      CHARACTER*4  ISTRZ2(1000)
14370C
14371C---------------------------------------------------------------------
14372C
14373C-----COMMON----------------------------------------------------------
14374C
14375      INCLUDE 'DPCOPA.INC'
14376      INCLUDE 'DPCOHK.INC'
14377      INCLUDE 'DPCOHO.INC'
14378      INCLUDE 'DPCODA.INC'
14379      INCLUDE 'DPCOST.INC'
14380      INCLUDE 'DPCOP2.INC'
14381C
14382C-----START POINT-----------------------------------------------------
14383C
14384      ISUBN1='DPSS'
14385      ISUBN2='PL  '
14386      IERROR='NO'
14387C
14388      ILOC3=0
14389      ISTRT=0
14390      ISTOP=0
14391C
14392      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SSPL')THEN
14393        WRITE(ICOUT,999)
14394  999   FORMAT(1X)
14395        CALL DPWRST('XXX','BUG ')
14396        WRITE(ICOUT,51)
14397   51   FORMAT('***** AT THE BEGINNING OF DPSSPL--')
14398        CALL DPWRST('XXX','BUG ')
14399        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
14400   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',2(A4,2X),I8)
14401        CALL DPWRST('XXX','BUG ')
14402        DO55I=1,NUMNAM
14403          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
14404     1                   IVSTOP(I)
14405   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
14406     1           'IVSTOP(I)=',I8,2X,2A4,2X,A4,2I8)
14407          CALL DPWRST('XXX','BUG ')
14408   55   CONTINUE
14409        WRITE(ICOUT,57)NUMCHF,MAXCHF
14410   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
14411        CALL DPWRST('XXX','BUG ')
14412        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
14413   60   FORMAT('IFUNC(.)  = ',120A1)
14414        CALL DPWRST('XXX','BUG ')
14415      ENDIF
14416C
14417C               *************************************
14418C               **  STEP 1--                       **
14419C               **  CHECK IF VARIABLE ON RHS IS    **
14420C               **  A CURRENTLY EXISTING STRING.   **
14421C               *************************************
14422C
14423      ISTEPN='1'
14424      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SSPL')
14425     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14426C
14427      IHRIGH=IHARG(5)
14428      IHRIG2=IHARG2(5)
14429C
14430      DO110II=1,NUMNAM
14431        I2=II
14432        IF(IHRIGH.EQ.IHNAME(I2).AND.
14433     1     IHRIG2.EQ.IHNAM2(I2))THEN
14434          IF(IUSE(I2).EQ.'F')THEN
14435            ICASEL='STRI'
14436            ILISTL=I2
14437            ISTRT=IVSTAR(I2)
14438            ISTOP=IVSTOP(I2)
14439            NLEN=ISTOP-ISTRT+1
14440            GOTO119
14441          ELSE
14442            WRITE(ICOUT,999)
14443            CALL DPWRST('XXX','BUG ')
14444            WRITE(ICOUT,121)
14445  121       FORMAT('****** ERROR IN STRING SPLIT--')
14446            CALL DPWRST('XXX','BUG ')
14447            WRITE(ICOUT,113)IHRIGH,IHRIG2
14448  113       FORMAT('      THE NAME ',2A4,' ALREADY EXISTS, BUT NOT ',
14449     1             'AS A STRING.')
14450            CALL DPWRST('XXX','BUG ')
14451            WRITE(ICOUT,115)
14452  115       FORMAT('      THE STRING SPLIT WILL NOT BE PERFORMED.')
14453            CALL DPWRST('XXX','BUG ')
14454            GOTO9000
14455          ENDIF
14456        ENDIF
14457  110 CONTINUE
14458  119 CONTINUE
14459C
14460C               *************************************************
14461C               **  STEP 2--                                   **
14462C               **  EXTRACT THE BASE NAME ON THE LHS OF THE    **
14463C               **  EQUAL SIGN AND THEN LOOP THROUGH THE       **
14464C               **  NUMBER OF STRINGS TO CREATE.               **
14465C               *************************************************
14466C
14467      ISTEPN='2'
14468      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SSPL')
14469     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14470C
14471      IHLEFT(1:4)=IHARG(1)
14472      IHLEFT(5:8)=IHARG2(1)
14473      NBASE=1
14474      DO210I=8,1,-1
14475        IF(IHLEFT(I:I).NE.' ')THEN
14476          NBASE=I
14477          GOTO219
14478        ENDIF
14479  210 CONTINUE
14480  219 CONTINUE
14481C
14482C
14483C               **********************************
14484C               **  STEP 3--                    **
14485C               **  SCAN STRING AND SPLIT INTO  **
14486C               **  SEPARATE WORDS.             **
14487C               **********************************
14488C
14489      ISTEPN='3'
14490      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SSPL')THEN
14491        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14492        WRITE(ICOUT,301)ISTRT,ISTOP,ILISTL,NLEN
14493  301   FORMAT('ISTRT,ISTOP,ILISTL,NLEN = ',4I6)
14494        CALL DPWRST('XXX','BUG ')
14495      ENDIF
14496C
14497      IFLAG=0
14498      IFLAGQ=0
14499      NSTR=0
14500      ICNT=0
14501      ISTRIN=' '
14502      ISTRZZ=' '
14503C
14504C     IFLAG  = 0 => LOOKING FOR FIRST NON-BLANK CHARACTER
14505C            = 1 => ADD TO NEXT SUB-STRING
14506C            = 2 => CURENT SUB-STRING IS EMPTY (I.E., LOOKING
14507C                   FOR FIRST NON-DELIMITER CHARACTER)
14508C     IFLAGQ = 0 => NO QUOTES CURRENTLY ACTIVE
14509C            = 1 => CURRENTLY IN QUOTED SECTION (SO
14510C                   IGNORE WORD DELIMITER)
14511C
14512      DO310II=ISTRT,ISTOP
14513C
14514        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SSPL')THEN
14515          WRITE(ICOUT,311)II,IFLAG
14516  311     FORMAT('II,IFLAG = ',2I5)
14517          CALL DPWRST('XXX','BUG ')
14518        ENDIF
14519C
14520        IF(IFLAG.EQ.0)THEN
14521          IF(IFUNC(II).EQ.' ')THEN
14522            GOTO310
14523          ELSEIF(IFUNC(II).EQ.IWRDDL(1:1))THEN
14524            GOTO310
14525          ELSE
14526            IFLAG=1
14527            IF(IFUNC(II).EQ.'"')THEN
14528              IFLAGQ=1
14529            ELSE
14530              ICNT=ICNT+1
14531              ISTRZZ(ICNT:ICNT)=IFUNC(II)(1:1)
14532            ENDIF
14533          ENDIF
14534          GOTO310
14535        ENDIF
14536C
14537        IF(IFUNC(II).EQ.'"')THEN
14538          IF(IFLAGQ.EQ.0)THEN
14539            IFLAGQ=1
14540            GOTO310
14541          ELSE
14542            IF(II.LT.ISTOP)THEN
14543              IFLAGQ=0
14544              GOTO310
14545            ENDIF
14546          ENDIF
14547        ENDIF
14548C
14549        IF(IFLAG.EQ.2)THEN
14550C
14551          IF(IFUNC(II)(1:1).EQ.IWRDDL(1:1) .AND. IFLAGQ.EQ.0)THEN
14552            GOTO310
14553          ELSE
14554            IFLAG=1
14555            ICNT=ICNT+1
14556            ISTRZZ(ICNT:ICNT)=IFUNC(II)(1:1)
14557          ENDIF
14558        ELSEIF(IFLAG.EQ.1)THEN
14559          IF(II.EQ.ISTOP)THEN
14560            IF(IFLAGQ.EQ.1 .AND. IFUNC(II).EQ.'"')THEN
14561              CONTINUE
14562            ELSE
14563              ICNT=ICNT+1
14564              ISTRZZ(ICNT:ICNT)=IFUNC(II)(1:1)
14565            ENDIF
14566          ENDIF
14567          IF((IFUNC(II)(1:1).EQ.IWRDDL(1:1) .AND. IFLAGQ.EQ.0) .OR.
14568     1        II.EQ.ISTOP)THEN
14569C
14570C           CREATE NAME FOR NEW STRING
14571C
14572            IF(ICNT.LE.0)THEN
14573              ISTRZZ=' '
14574              ICNT=0
14575              IFLAG=2
14576              GOTO310
14577            ENDIF
14578C
14579            NSTR=NSTR+1
14580            IF(NSTR.GT.999)GOTO319
14581            IF(NSTR.LE.9)THEN
14582              IF(NBASE.GT.7)NBASE=7
14583            ELSEIF(NSTR.LE.99)THEN
14584              IF(NBASE.GT.6)NBASE=6
14585            ELSE
14586              IF(NBASE.GT.5)NBASE=5
14587            ENDIF
14588C
14589            ISTRIN=' '
14590            ISTRIN(1:NBASE)=IHLEFT(1:NBASE)
14591            IF(NSTR.LE.9)THEN
14592              WRITE(ISTRIN(NBASE+1:NBASE+1),'(I1)')NSTR
14593            ELSEIF(NSTR.LE.99)THEN
14594              WRITE(ISTRIN(NBASE+1:NBASE+2),'(I2)')NSTR
14595            ELSE
14596              WRITE(ISTRIN(NBASE+1:NBASE+3),'(I3)')NSTR
14597            ENDIF
14598C
14599            IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SSPL')THEN
14600              WRITE(ICOUT,345)NSTR,ICNT,ISTRIN,ISTRZZ(1:ICNT)
14601  345         FORMAT('NSTR,ICNT,ISTRIN,ISTRZZ = ',2I6,A8,2X,A40)
14602              CALL DPWRST('XXX','BUG ')
14603            ENDIF
14604C
14605C           NOW UPDATE THE NEW STRING IN THE NAME/FUNCTION TABLES
14606C
14607            NEWNAM='NO'
14608            NEWCOL='NO'
14609            ICASEL='UNKN'
14610            NIOLD1=0
14611            ICOLL=0
14612C
14613            DO510JJ=1,NUMNAM
14614              I2=JJ
14615              IF(ISTRIN(1:4).EQ.IHNAME(I2).AND.
14616     1           ISTRIN(5:8).EQ.IHNAM2(I2))THEN
14617                IF(IUSE(I2).EQ.'F')THEN
14618                  ICASEL='STRI'
14619                  ILISTL=I2
14620                  GOTO519
14621                ELSE
14622                  WRITE(ICOUT,999)
14623                  CALL DPWRST('XXX','BUG ')
14624                  WRITE(ICOUT,121)
14625                  CALL DPWRST('XXX','BUG ')
14626                  WRITE(ICOUT,513)ISTRIN
14627  513             FORMAT('      THE NAME ',A8,' ALREADY EXISTS, BUT ',
14628     1               'NOT AS A STRING.')
14629                  CALL DPWRST('XXX','BUG ')
14630                  WRITE(ICOUT,515)
14631  515             FORMAT('      THIS STRING WILL NOT BE CREATED.')
14632                  CALL DPWRST('XXX','BUG ')
14633                  GOTO599
14634                ENDIF
14635              ENDIF
14636  510       CONTINUE
14637            NEWNAM='YES'
14638            ICASEL='STRI'
14639C
14640            ILISTL=NUMNAM+1
14641            IF(ILISTL.GT.MAXNAM)THEN
14642              WRITE(ICOUT,999)
14643              CALL DPWRST('XXX','BUG ')
14644              WRITE(ICOUT,121)
14645              CALL DPWRST('XXX','BUG ')
14646              WRITE(ICOUT,522)
14647  522         FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
14648     1               'FUNCTION')
14649              CALL DPWRST('XXX','BUG ')
14650              WRITE(ICOUT,524)MAXNAM
14651  524         FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
14652              CALL DPWRST('XXX','BUG ')
14653              GOTO599
14654            ENDIF
14655C
14656  519       CONTINUE
14657            IHLEF3=ISTRIN(1:4)
14658            IHLEF4=ISTRIN(5:8)
14659            DO551J=1,ICNT
14660              ISTRZ2(J)=' '
14661              ISTRZ2(J)(1:1)=ISTRZZ(J:J)
14662  551       CONTINUE
14663C
14664            CALL DPINFU(ISTRZ2,ICNT,IHNAME,IHNAM2,IUSE,IN,
14665     1                  IVSTAR,IVSTOP,
14666     1                  NUMNAM,IANS,IWIDTH,IHLEF3,IHLEF4,ILISTL,
14667     1                  NEWNAM,MAXNAM,
14668     1                  IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
14669C
14670C           RESET SOME PARAMETERS
14671C
14672  599       CONTINUE
14673            ISTRZZ=' '
14674            ICNT=0
14675            IFLAG=2
14676          ELSE
14677            ICNT=ICNT+1
14678            ISTRZZ(ICNT:ICNT)=IFUNC(II)(1:1)
14679          ENDIF
14680        ENDIF
14681 310  CONTINUE
14682 319  CONTINUE
14683C
14684C               *****************************************************
14685C               **  STEP 7--                                       **
14686C               **  PRINT FEEDBACK MESSAGE                         **
14687C               *****************************************************
14688C
14689      ISTEPN='7'
14690      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'SSPL')
14691     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14692C
14693      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
14694        WRITE(ICOUT,999)
14695        CALL DPWRST('XXX','BUG ')
14696        WRITE(ICOUT,710)NSTR
14697  710   FORMAT(I5,' STRINGS HAVE BEEN CREATED FROM THE STRING SPLIT.')
14698        CALL DPWRST('XXX','BUG ')
14699        WRITE(ICOUT,999)
14700        CALL DPWRST('XXX','BUG ')
14701      ENDIF
14702C
14703C
14704C               ****************
14705C               **  STEP 90-- **
14706C               **  EXIT.     **
14707C               ****************
14708C
14709 9000 CONTINUE
14710      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'SSPL')THEN
14711        WRITE(ICOUT,999)
14712        CALL DPWRST('XXX','BUG ')
14713        WRITE(ICOUT,9011)
14714 9011   FORMAT('***** AT THE END       OF DPSSPL--')
14715        CALL DPWRST('XXX','BUG ')
14716        WRITE(ICOUT,9013)NSTR
14717 9013   FORMAT('NSTR = ',2I8)
14718        CALL DPWRST('XXX','BUG ')
14719      ENDIF
14720C
14721      RETURN
14722      END
14723      SUBROUTINE DPSTAC(ICASL8,ILOCV,ISTANR,
14724     1                  IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,
14725     1                  FLOAT1,IERRO1,
14726     1                  TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
14727CCCCC                   JULY 2002.  ADD ISEED FOR HODHES-LEHMAN
14728     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
14729     1                  DTEMP1,DTEMP2,DTEMP3,
14730     1                  IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
14731C
14732C     PURPOSE--COMPUTE A LET STATISTIC SUB-COMMAND (HELP STATISTIC FOR
14733C              THE LIST OF CURRENTLY SUPPORTED STATISTICS).
14734C     NOTE--THIS SUBROUTINE OPERATES ON A VECTOR AND PRODUCES A
14735C           PARAMETER (= A SCALAR).
14736C     NOTE-INPUT WILL BE A VECTOR (OR 2 OR 3 VECTORS).
14737C          OUTPUT WILL BE A SCALAR--
14738C               1) PARAMETER, OR
14739C               2) ELEMENT OF A VECTOR.
14740C          THE STATISTICS CAN BE CALCULATED ON A FULL VARIABLE
14741C          OR ON A PARTIAL VARIABLE.
14742C     EXAMPLE--LET A    = MEAN X                      (A FULL VARIABLE)
14743C            --LET Y(4) = MEAN X                      (A FULL VARIABLE)
14744C            --LET A    = MEAN X   SUBSET 2 3 5       (A PARTIAL VAR.)
14745C            --LET Y(4) = MEAN X   SUBSET 2 3 5       (A PARTIAL VAR.)
14746C            --LET A    = MEAN X   FOR I = 1 2 10     (A PARTIAL VAR.)
14747C            --LET Y(4) = MEAN X   FOR I = 1 2 10     (A PARTIAL VAR.)
14748C            --LET A    = CORRELATION X Y              (A FULL VARIABLE
14749C            --LET Y(4) = CORRELATION X Y              (A FULL VARIABLE
14750C            --LET A    = CORRELATION X Y  SUBSET 2 3 5     (A PARTIAL
14751C            --LET Y(4) = CORRELATION X Y  SUBSET 2 3 5     (A PARTIAL
14752C            --LET A    = CORRELATION X Y  FOR I = 1 2 10   (A PARTIAL
14753C            --LET Y(4) = CORRELATION X Y  FOR I = 1 2 10   (A PARTIAL
14754C     WRITTEN BY--JAMES J. FILLIBEN
14755C                 STATISTICAL ENGINEERING DIVISION
14756C                 INFORMATION TECHNOLOGY LABORATORY
14757C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14758C                 GAITHERSBURG, MD 20899-8980
14759C                 PHONE--301-975-2855
14760C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14761C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14762C     LANGUAGE--ANSI FORTRAN (1977)
14763C     VERSION NUMBER--82/7
14764C     ORIGINAL VERSION (AS A PART OF DPLET)--DECEMBER 1977.
14765C     UPDATED         --MAY       1982.
14766C     ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MARCH 1978.
14767C     UPDATED         --JULY      1978.
14768C     UPDATED         --NOVEMBER  1978.
14769C     UPDATED         --MARCH     1979.
14770C     UPDATED         --APRIL     1979.
14771C     UPDATED         --JULY      1979.
14772C     UPDATED         --JUNE      1981.
14773C     UPDATED         --SEPTEMBER 1981.
14774C     UPDATED         --OCTOBER   1981.
14775C     UPDATED         --NOVEMBER  1981.
14776C     UPDATED         --NOVEMBER  1987.  (EXIT OUT IF ERROR)
14777C     UPDATED         --AUGUST    1988.  (WEIGHTED MEAN, MEDIAN, SD, VARIANCE)
14778C     UPDATED         --DECEMBER  1988.  LET Y(K) = MEAN X INSIDE LOOP
14779C     UPDATED         --JANUARY   1989.  TRY TO REUSE A PARAM. AS A VAR.
14780C     UPDATED         --FEBRUARY  1989.  AVERAGE ABSOLUTE DEVIATION (ALAN)
14781C     UPDATED         --APRIL     1990.  EXTREME
14782C     UPDATED         --SEPTEMBER 1990.  CP, CPK, % DEF, EXP. LOSS
14783C     UPDATED         --AUGUST    1991.  COMOVEMENT
14784C     UPDATED         --FEBRUARY  1994.  CHANGE ICASL8: RSD => RESD
14785C     UPDATED         --FEBRUARY  1994.  CHANGE ICASL8: SDM => SDME
14786C     UPDATED         --FEBRUARY  1994.  RELATIVE VARIANCE
14787C     UPDATED         --FEBRUARY  1994.  VARIANCE OF THE MEAN
14788C     UPDATED         --FEBRUARY  1994.  NORMAL PPCC
14789C     UPDATED         --FEBRUARY  1994.  TAGUCHI SN- SN0 SN+ SN00
14790C     UPDATED         --NOVEMBER  1994.  DISTINGUISH RELATIVE SD AND
14791C                                        COEF OF VARIATION CASES.
14792C     UPDATED         --MARCH     1995.  MAD
14793C     UPDATED         --NOVEMBER  1998.  <VALUE> PERCENTILE
14794C     UPDATED         --NOVEMBER  1998.  CPM, CC
14795C     UPDATED         --MARCH     1999.  CNPK
14796C     UPDATED         --MARCH     1999.  GEOMETRIC MEAN
14797C     UPDATED         --MARCH     1999.  GEOMETRIC STANDARD DEVIATION
14798C     UPDATED         --APRIL     2001.  ARGUMENT LIST TO CP, CPK, CPM
14799C     UPDATED         --APRIL     2001.  CPL, CPU
14800C     UPDATED         --AUGUST    2001.  COMMON DIGITS
14801C     UPDATED         --AUGUST    2001.  NUMBER OF COMMON DIGITS
14802C     UPDATED         --SEPTEMBER 2001.  IQ RANGE
14803C     UPDATED         --NOVEMBER  2001.  BIWEIGHT LOCATION
14804C     UPDATED         --NOVEMBER  2001.  BIWEIGHT SCALE
14805C     UPDATED         --JULY      2002.  WINSORIZED VARIANCE
14806C     UPDATED         --JULY      2002.  WINSORIZED SD
14807C     UPDATED         --JULY      2002.  WINSORIZED COVARIANCE
14808C     UPDATED         --JULY      2002.  WINSORIZED CORRELATION
14809C     UPDATED         --JULY      2002.  HODGES LEHMAN
14810C     UPDATED         --JULY      2002.  PERCENTAGE BEND MIDVARIANCE
14811C     UPDATED         --JULY      2002.  PERCENTAGE BEND CORRELATION
14812C     UPDATED         --JULY      2002.  BIWEIGHT MIDVARIANCE
14813C     UPDATED         --JULY      2002.  BIWEIGHT MIDCOVARIANCE
14814C     UPDATED         --JULY      2002.  BIWEIGHT MIDCORRELATION
14815C     UPDATED         --JULY      2002.  TRIMMED MEAN STANDARD ERROR
14816C     UPDATED         --JULY      2002.  QUANTILE STANDARD ERROR
14817C     UPDATED         --JULY      2002.  QUANTILE
14818C     UPDATED         --MARCH     2003.  ADD 32 "DIFFERENCE OF"
14819C                                        STATISTICS
14820C     UPDATED         --APRIL     2003.  ADD SN AND QN (AND DIFFERENCE
14821C                                        OF).  REQUIRED ADDITIONAL
14822C                                        SCRATCH ARRAYS.
14823C     UPDATED         --MAY       2003.  ADD WEIGHTED TRIMMED MEAN
14824C     UPDATED         --DECEMBER  2003.  BUG IN INTEGRAL (DETERMINE
14825C                                        WHETHER 1 OR 2 VARIABLES
14826C                                        SPECIFIED)
14827C     UPDATED         --OCTOBER   2004.  KENDELLS TAU
14828C     UPDATED         --FEBRUARY  2005.  REPEATABILITY SD
14829C     UPDATED         --FEBRUARY  2005.  REPRODUCABILITY SD
14830C     UPDATED         --SEPTEMBER 2005.  RATIO
14831C     UPDATED         --MARCH     2007.  RELATIVE RISK
14832C     UPDATED         --MARCH     2007.  CRAMER CONTINGENCY COEFFICENT
14833C     UPDATED         --MARCH     2007.  PEARSON CONTINGENCY COEFFICENT
14834C     UPDATED         --APRIL     2007.  POSITIVE PREDICTIVE VALUE
14835C     UPDATED         --APRIL     2007.  NEGATIVE PREDICTIVE VALUE
14836C     UPDATED         --APRIL     2007.  ODDS RATIO
14837C     UPDATED         --APRIL     2007.  STANDARD ERROR ODDS RATIO
14838C     UPDATED         --APRIL     2007.  LOG ODDS RATIO
14839C     UPDATED         --APRIL     2007.  LOG STANDARD ERROR ODDS RATIO
14840C     UPDATED         --MAY       2007.  TRIMMED STANDARD DEVIATION
14841C     UPDATED         --NOVEMBER  2007.  DOUBLE PRECISION ARRAYS FOR
14842C                                        CMPSTA
14843C     UPDATED         --NOVEMBER  2007.  LP LOCATION
14844C     UPDATED         --NOVEMBER  2007.  VARIANCE OF LP LOCATION
14845C     UPDATED         --NOVEMBER  2007.  SD OF LP LOCATION
14846C     UPDATED         --NOVEMBER  2007.  DIFFERENCE OF LP LOCATION
14847C     UPDATED         --NOVEMBER  2007.  DIFFERENCE OF VARI LP LOCATION
14848C     UPDATED         --NOVEMBER  2007.  DIFFERENCE OF SD LP LOCATION
14849C     UPDATED         --SEPTEMBER 2008.  BINOMIAL PROBABILITY
14850C     UPDATED         --SEPTEMBER 2008.  DIFFERENCE OF BINOMIAL PROB
14851C     UPDATED         --JANUARY   2010.  PASS ISTANR ARGUMENT
14852C     UPDATED         --JUNE      2010.  CALL LIST TO CMPSTA
14853C     UPDATED         --JUNE      2011.  ACCEPT MATRIX ARGUMENTS
14854C     UPDATED         --JANUARY   2012.  ACCEPT PARAMETER ARGUMENTS
14855C     UPDATED         --APRIL     2014.  IVALUE FOR NEGATIVE NUMBERS
14856C                                        BUG FIX
14857C
14858C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14859C
14860      CHARACTER*4 ICASL8
14861      CHARACTER*4 IFOUNZ
14862      CHARACTER*4 ITYPE
14863      CHARACTER*4 IHOL
14864      CHARACTER*4 IHOL2
14865      CHARACTER*4 IERRO1
14866      CHARACTER*4 IBUGA3
14867      CHARACTER*4 IBUGQ
14868      CHARACTER*4 ISUBRO
14869      CHARACTER*4 IFOUND
14870      CHARACTER*4 IERROR
14871C
14872      CHARACTER*4 NEWNAM
14873      CHARACTER*4 NEWCOL
14874      CHARACTER*4 ICASEL
14875      CHARACTER*4 ICASEQ
14876      CHARACTER*4 IHWUSE
14877      CHARACTER*4 MESSAG
14878      CHARACTER*4 IWRITE
14879      CHARACTER*4 IHARG3
14880      CHARACTER*4 IHARG4
14881      CHARACTER*4 IHARG5
14882      CHARACTER*4 IHARG6
14883      CHARACTER*4 ILEFT
14884      CHARACTER*4 ILEFT2
14885      CHARACTER*4 ISUBSF
14886      CHARACTER*4 IFORF
14887      CHARACTER*4 IARG4T
14888      CHARACTER*4 IARG4F
14889      CHARACTER*4 IHSET
14890      CHARACTER*4 IHSET2
14891      CHARACTER*4 IH
14892      CHARACTER*4 IH2
14893      CHARACTER*4 ISUBN1
14894      CHARACTER*4 ISUBN2
14895      CHARACTER*4 ISTEPN
14896      CHARACTER*4 IFLAGD
14897C
14898C---------------------------------------------------------------------
14899C
14900      DIMENSION IFOUNZ(*)
14901      DIMENSION IBEGIN(*)
14902      DIMENSION IEND(*)
14903      DIMENSION ITYPE(*)
14904      DIMENSION IHOL(*)
14905      DIMENSION IHOL2(*)
14906      DIMENSION INT1(*)
14907      DIMENSION FLOAT1(*)
14908      DIMENSION IERRO1(*)
14909C
14910      DIMENSION TEMP(*)
14911      DIMENSION TEMP2(*)
14912      DIMENSION TEMP3(*)
14913C
14914      DIMENSION XTEMP1(*)
14915      DIMENSION XTEMP2(*)
14916      DIMENSION XTEMP3(*)
14917C
14918      DIMENSION ITEMP1(*)
14919      DIMENSION ITEMP2(*)
14920      DIMENSION ITEMP3(*)
14921      DIMENSION ITEMP4(*)
14922      DIMENSION ITEMP5(*)
14923      DIMENSION ITEMP6(*)
14924C
14925      DOUBLE PRECISION DTEMP1(*)
14926      DOUBLE PRECISION DTEMP2(*)
14927      DOUBLE PRECISION DTEMP3(*)
14928C
14929C---------------------------------------------------------------------
14930C
14931C-----COMMON----------------------------------------------------------
14932C
14933      INCLUDE 'DPCOPA.INC'
14934      INCLUDE 'DPCOHK.INC'
14935      INCLUDE 'DPCODA.INC'
14936      INCLUDE 'DPCOST.INC'
14937      INCLUDE 'DPCOP2.INC'
14938C
14939C-----START POINT-----------------------------------------------------
14940C
14941      ISUBN1='DPST'
14942      ISUBN2='AC  '
14943      IFOUND='NO'
14944      IERROR='NO'
14945      ICASEL='UNKN'
14946      NEWNAM='NO'
14947      NEWCOL='NO'
14948      IFLAGD='OFF'
14949C
14950      MAXCP1=MAXCOL+1
14951      MAXCP2=MAXCOL+2
14952      MAXCP3=MAXCOL+3
14953      MAXCP4=MAXCOL+4
14954      MAXCP5=MAXCOL+5
14955      MAXCP6=MAXCOL+6
14956C
14957      ICOLL=0
14958      ICOL2=0
14959      ICOL3=0
14960      ICOL22=0
14961      ICOL32=0
14962      NIRIG2=0
14963      ILOCSV=0
14964CCCCC FEBRUARY 1998.  ADD FOLLOWING LINE.  CAUSED A PROBLEM IN
14965CCCCC SOME CASES (RS_6000 COMPILED WITH f2c)
14966      NIOLD=0
14967      NCOL=0
14968      NCOL2=0
14969      NCOL3=0
14970      IFLGP1=0
14971      IFLGP2=0
14972      IFLGP3=0
14973      NUMVAR=1
14974      ICOLR=0
14975      ICOLR2=0
14976C
14977C
14978C               **********************************************************
14979C               **  TREAT THE SUBCASE OF CALCULATING CERTAIN            **
14980C               **  ELEMENTARY STATISTICS (MEAN, SD, ETC.)              **
14981C               **       1) FOR A FULL VARIABLE, OR                     **
14982C               **       2) FOR PART OF A VARIABLE.                     **
14983C               **********************************************************
14984C
14985      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STAC')THEN
14986        WRITE(ICOUT,999)
14987  999   FORMAT(1X)
14988        CALL DPWRST('XXX','BUG ')
14989        WRITE(ICOUT,51)
14990   51   FORMAT('***** AT THE BEGINNING OF DPSTAC--')
14991        CALL DPWRST('XXX','BUG ')
14992        WRITE(ICOUT,52)IBUGA3,IBUGQ,ICASL8,IERRO1(1)
14993   52   FORMAT('IBUGA3,IBUGQ,ICASL8,IERRO1(1) = ',3(A4,2X),A4)
14994        CALL DPWRST('XXX','BUG ')
14995        WRITE(ICOUT,53)ILOCV,ISTANR,IBEGIN(1),IEND(1),FLOAT1(1)
14996   53   FORMAT('ILOCV,ISTANR,IBEGIN(1),IEND(1),FLOAT1(1) = ',4I8,G15.7)
14997        CALL DPWRST('XXX','BUG ')
14998      ENDIF
14999C
15000C
15001C               *********************************************************
15002C               **  STEP 2--                                            *
15003C               **  EXAMINE THE LEFT-HAND SIDE--                        *
15004C               **  IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN *
15005C               **  ALREADY IN THE NAME LIST?                           *
15006C               **  NOTE THAT     ILEFT     IS THE NAME OF THE VARIABLE *
15007C               **  ON THE LEFT.                                        *
15008C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE    *
15009C               **  OF THE NAME ON THE LEFT.                            *
15010C               **  NOTE THAT     ICOLL    IS THE DATA COLUMN (1 TO 12) *
15011C               **  FOR THE NAME OF THE LEFT.                           *
15012C               *********************************************************
15013C
15014      ISTEPN='2'
15015      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15016     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15017C
15018CCCCC CALL DPTYP8(IANS,IWIDTH,IHNAME,IHNAM2,NUMNAM,MAXNAM,IBUGA3,
15019CCCCC1                  IFOUNZ,ITYPE,IHOL,IHOL2,INT1,FLOAT1,IERRO1)
15020      ILEFT=IHOL(2)
15021      ILEFT2=IHOL2(2)
15022      DO200I=1,NUMNAM
15023        I2=I
15024        IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
15025     1    IUSE(I).EQ.'P')THEN
15026          ILISTL=I2
15027CCCCC     THE FOLLOWING LINE WAS COMMENTED OUT (JANUARY 1989)
15028CCCCC     AND REPLACED BY THE SUCCEEDING 12 LINES (JANUARY 1989)
15029CCCCC     TO FIX PROBLEM OF REUSING A PARAMETER AS A VARIABLE
15030CCCCC     (JANUARY 1989)
15031CCCCC     GOTO290
15032          IF(IFOUNZ(4).EQ.'NO')GOTO290
15033          WRITE(ICOUT,999)
15034          CALL DPWRST('XXX','BUG ')
15035          WRITE(ICOUT,221)
15036          CALL DPWRST('XXX','BUG ')
15037          WRITE(ICOUT,217)IHOL(2),IHOL2(2)
15038  217     FORMAT('      AN ATTEMPT WAS MADE TO USE ',A4,A4,' AS A ',
15039     1           'VARIABLE')
15040          CALL DPWRST('XXX','BUG ')
15041          WRITE(ICOUT,218)
15042  218     FORMAT('      EVEN THOUGH IT ALREADY EXISTS AS A PARAMETER.')
15043          CALL DPWRST('XXX','BUG ')
15044          IERROR='YES'
15045          GOTO9000
15046        ELSEIF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
15047     1    IUSE(I).EQ.'V')THEN
15048          ILISTL=I2
15049          ICOLL=IVALUE(ILISTL)
15050          NIOLD=IN(ILISTL)
15051          GOTO290
15052        ENDIF
15053  200 CONTINUE
15054C
15055      ISTEPN='2B'
15056      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15057     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15058C
15059      NEWNAM='YES'
15060      ILISTL=NUMNAM+1
15061      IF(ILISTL.GT.MAXNAM)THEN
15062        WRITE(ICOUT,999)
15063        CALL DPWRST('XXX','BUG ')
15064        WRITE(ICOUT,221)
15065  221   FORMAT('***** ERROR IN DPSTAC--')
15066        CALL DPWRST('XXX','BUG ')
15067        WRITE(ICOUT,222)
15068  222   FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER NAMES ',
15069     1         'HAS JUST')
15070        CALL DPWRST('XXX','BUG ')
15071        WRITE(ICOUT,223)MAXNAM
15072  223   FORMAT('      EXCEEDED THE MAX ALLOWABLE ',I8,'  .  ',
15073     1         'SUGGESTED ACTION--')
15074        CALL DPWRST('XXX','BUG ')
15075        WRITE(ICOUT,225)
15076  225   FORMAT('      ENTER      STATUS')
15077        CALL DPWRST('XXX','BUG ')
15078        WRITE(ICOUT,226)
15079  226   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
15080        CALL DPWRST('XXX','BUG ')
15081        WRITE(ICOUT,227)
15082  227   FORMAT('      THEN REDEFINE (REUSE) SOME OF THE ALREADY-USED',
15083     1         'NAMES')
15084        CALL DPWRST('XXX','BUG ')
15085        IERROR='YES'
15086        GOTO19000
15087      ENDIF
15088C
15089      ISTEPN='2C'
15090      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15091     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15092C
15093      IARG4F=IFOUNZ(4)
15094      ISUBSF=IFOUNZ(11)
15095      IFORF=IFOUNZ(21)
15096      IF(IARG4F.EQ.'NO')GOTO290
15097      NIOLD=0
15098      ICOLL=NUMCOL+1
15099C
15100      IF(ICOLL.GT.MAXCOL)THEN
15101        WRITE(ICOUT,221)
15102        CALL DPWRST('XXX','BUG ')
15103        WRITE(ICOUT,242)
15104  242   FORMAT('      THE NUMBER OF DATA COLUMNS HAS JUST EXCEEDED THE')
15105        CALL DPWRST('XXX','BUG ')
15106        WRITE(ICOUT,243)MAXCOL
15107  243   FORMAT('      MAX ALLOWABLE ',I8,'  .  SUGGESTED ACTION--')
15108        CALL DPWRST('XXX','BUG ')
15109        WRITE(ICOUT,245)
15110  245   FORMAT('      ENTER      STATUS VARIABLES')
15111        CALL DPWRST('XXX','BUG ')
15112        WRITE(ICOUT,246)
15113  246   FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
15114        CALL DPWRST('XXX','BUG ')
15115        WRITE(ICOUT,247)
15116  247   FORMAT('      AND THEN OVERWRITE SOME COLUMNS.   EXAMPLE--')
15117        CALL DPWRST('XXX','BUG ')
15118        WRITE(ICOUT,248)
15119  248   FORMAT('      IF (E.G.)   LET Y(3) = MEAN X          FAILED')
15120        CALL DPWRST('XXX','BUG ')
15121        WRITE(ICOUT,249)
15122  249   FORMAT('      THEN ONE MIGHT ENTER     NAME Y 7')
15123        CALL DPWRST('XXX','BUG ')
15124        WRITE(ICOUT,250)
15125  250   FORMAT('      (THEREBY EQUATING THE NAME Y WITH COLUMN 7')
15126        CALL DPWRST('XXX','BUG ')
15127        WRITE(ICOUT,251)
15128  251   FORMAT('      FOLLOWED BY              LET Y(3) = MEAN X ')
15129        CALL DPWRST('XXX','BUG ')
15130        WRITE(ICOUT,252)
15131  252   FORMAT('      (WHICH WILL ACTUALLY OVERWRITE ROW 3 ',
15132     1         'OF COLUMN 7')
15133        CALL DPWRST('XXX','BUG ')
15134        WRITE(ICOUT,253)
15135  253   FORMAT('      WITH THE CALCULATED MEAN OF VARIABLE X)')
15136        CALL DPWRST('XXX','BUG ')
15137        IERROR='YES'
15138        GOTO19000
15139      ENDIF
15140C
15141      ISTEPN='2D'
15142      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15143     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15144C
15145      MAXNI=0
15146      DO235I=1,12
15147        IF(IUSE(I).EQ.'V')THEN
15148          IF(IN(I).GT.MAXNI)MAXNI=IN(I)
15149        ENDIF
15150  235 CONTINUE
15151      IF(MAXNI.EQ.0)MAXNI=MAXN
15152C
15153  290 CONTINUE
15154C
15155      ISTEPN='2E'
15156      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15157     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15158C
15159C               *********************************************************
15160C               **  STEP 3--                                            *
15161C               **  EXAMINE THE RIGHT-HAND SIDE--                       *
15162C               **  HAS THE VARIABLE OR COLUMN ON THE RIGHT             *
15163C               **  ALREADY BEEN DEFINED?                               *
15164C               **  NOTE THAT     IRIGHT    IS THE NAME OF THE VARIABLE *
15165C               **  ON THE RIGHT.                                       *
15166C               **  NOTE THAT     ILISTR    IS THE LINE IN THE TABLE    *
15167C               **  OF THE VARIABLE OR COLUMN ON THE RIGHT.             *
15168C               **  NOTE THAT     ICOLR    IS THE DATA COLUMN (1 TO 12) *
15169C               **  FOR THE VARIABLE OR COLUMN ON THE RIGHT.            *
15170C               *********************************************************
15171C
15172C
15173C               ********************************************
15174C               **  STEP 4--                              **
15175C               **  BRANCH BETWEEN 1-VARIABLE STATISTICS  **
15176C               **  (E.G., MEAN, SD, MIN, ETC.)           **
15177C               **  AND 2-VARIABLE STATISTICS             **
15178C               **  (CORRELATION AND RANK CORRELATION).   **
15179C               ********************************************
15180C
15181      ISTEPN='4'
15182      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15183     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15184C
15185      NUMVIN=1
15186      IF(ICASL8.EQ.'WEME' .OR. ICASL8.EQ.'WEMD' .OR.
15187     1   ICASL8.EQ.'WESD' .OR. ICASL8.EQ.'WEVA' .OR.
15188     1   ICASL8.EQ.'WETM' .OR. ICASL8.EQ.'INTE')THEN
15189        ILOCVP=ILOCV+1
15190        IH=IHARG(ILOCVP)
15191        IH2=IHARG2(ILOCVP)
15192        IF(ILOCVP.GT.NUMARG)THEN
15193          NUMVIN=1
15194        ELSEIF(IH.EQ.'SUBS'.AND.IH2.EQ.'ET  ')THEN
15195          NUMVIN=1
15196        ELSEIF(IH.EQ.'EXCE'.AND.IH2.EQ.'PT  ')THEN
15197          NUMVIN=1
15198        ELSEIF(IH.EQ.'FOR '.AND.IH2.EQ.'    ')THEN
15199          NUMVIN=1
15200        ELSE
15201          NUMVIN=2
15202        ENDIF
15203      ELSEIF(ISTANR.EQ.2)THEN
15204        NUMVIN=2
15205      ELSEIF(ISTANR.EQ.3)THEN
15206        NUMVIN=3
15207      ELSE
15208        NUMVIN=1
15209      ENDIF
15210C
15211C     DIFFERENCE OF INTEGRAL CAN HAVE EITHER 2 OR 3 RESPONSE VARIABLES
15212C     (THE THIRD VARIABLE IS AN OPTIONAL X-COORDINATE VARIABLE)
15213C
15214      IF(ICASL8.EQ.'DINT')THEN
15215        ILOCVP=ILOCV+2
15216        IH=IHARG(ILOCVP)
15217        IH2=IHARG2(ILOCVP)
15218        IF(ILOCVP.GT.NUMARG)THEN
15219          NUMVIN=2
15220        ELSEIF(IH.EQ.'SUBS'.AND.IH2.EQ.'ET  ')THEN
15221          NUMVIN=2
15222        ELSEIF(IH.EQ.'EXCE'.AND.IH2.EQ.'PT  ')THEN
15223          NUMVIN=2
15224        ELSEIF(IH.EQ.'FOR '.AND.IH2.EQ.'    ')THEN
15225          NUMVIN=2
15226        ELSE
15227          NUMVIN=3
15228        ENDIF
15229      ENDIF
15230C
15231C
15232C               ***************************************
15233C               **  STEP 5--                         **
15234C               **  EXTRACT THE FIRST VARIABLE       **
15235C               ***************************************
15236C
15237      ISTEPN='5'
15238      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15239     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15240C
15241      IH=IHARG(ILOCV)
15242      IH2=IHARG2(ILOCV)
15243      DO1110I=1,NUMNAM
15244        I2=I
15245        IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
15246     1    IUSE(I).EQ.'V')THEN
15247          ILISTR=I2
15248          ICOLR=IVALUE(ILISTR)
15249          NIRIGH=IN(ILISTR)
15250          ICOLR2=-99
15251          GOTO2000
15252        ELSEIF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
15253     1    IUSE(I).EQ.'M')THEN
15254          ILISTR=I2
15255          ICOLR=IVALUE(ILISTR)
15256          ICOLR2=IVALU2(ILISTR)
15257          NIRIGH=IN(ILISTR)
15258          NCOL=(ICOLR2 - ICOLR) + 1
15259          GOTO2000
15260        ELSEIF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
15261     1    IUSE(I).EQ.'P')THEN
15262          IFLGP1=1
15263          ILISTR=I2
15264          AVAL1=VALUE(ILISTR)
15265          NIRIGH=1
15266          GOTO2000
15267CCCCC     WRITE(ICOUT,999)
15268CCCCC     CALL DPWRST('XXX','BUG ')
15269CCCCC     WRITE(ICOUT,221)
15270CCCCC     CALL DPWRST('XXX','BUG ')
15271CCCCC     WRITE(ICOUT,1152)
15272C1152     FORMAT('      THE SPECIFIED ARGUMENT (VARIABLE NAME OR ',
15273CCCCC1           'COLUMN')
15274CCCCC     CALL DPWRST('XXX','BUG ')
15275CCCCC     WRITE(ICOUT,1154)
15276C1154     FORMAT('      NUMBER) ON THE RIGHT OF THE = SIGN WAS FOUND')
15277CCCCC     CALL DPWRST('XXX','BUG ')
15278CCCCC     WRITE(ICOUT,1155)
15279C1155     FORMAT('      IN THE INTERNAL NAME LIST, BUT AS A PARAMETER')
15280CCCCC     CALL DPWRST('XXX','BUG ')
15281CCCCC     WRITE(ICOUT,1157)
15282C1157     FORMAT('      AND NOT AS A VARIABLE AS IT SHOULD BE HERE.')
15283CCCCC     CALL DPWRST('XXX','BUG ')
15284CCCCC     WRITE(ICOUT,1158)
15285 1158     FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
15286CCCCC     CALL DPWRST('XXX','BUG ')
15287CCCCC     WRITE(ICOUT,1159)(IANS(II),II=1,MIN(80,IWIDTH))
15288 1159     FORMAT(80A1)
15289CCCCC     CALL DPWRST('XXX','BUG ')
15290CCCCC     IERROR='YES'
15291CCCCC     GOTO19000
15292        ENDIF
15293 1110 CONTINUE
15294C
15295      WRITE(ICOUT,999)
15296      CALL DPWRST('XXX','BUG ')
15297      WRITE(ICOUT,221)
15298      CALL DPWRST('XXX','BUG ')
15299      WRITE(ICOUT,1112)
15300 1112 FORMAT('      THE SPECIFIED ARGUMENT (VARIABLE NAME OR COLUMN')
15301      CALL DPWRST('XXX','BUG ')
15302      WRITE(ICOUT,1114)
15303 1114 FORMAT('      NUMBER) ON THE RIGHT OF THE = SIGN WAS NOT FOUND')
15304      CALL DPWRST('XXX','BUG ')
15305      WRITE(ICOUT,1115)
15306 1115 FORMAT('      IN THE INTERNAL NAME LIST.')
15307      CALL DPWRST('XXX','BUG ')
15308      WRITE(ICOUT,1158)
15309      CALL DPWRST('XXX','BUG ')
15310      WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
15311      CALL DPWRST('XXX','BUG ')
15312      IERROR='YES'
15313      GOTO19000
15314C
15315C               ************************************************
15316C               **  STEP 6.2--                                **
15317C               **  EXTRACT THE SECOND VARIABLE               **
15318C               ************************************************
15319C
15320 2000 CONTINUE
15321C
15322      ISTEPN='6.2'
15323      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15324     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15325C
15326      IF(NUMVIN.LT.2)GOTO700
15327C
15328      NUMVAR=2
15329      ILOCVP=ILOCV+1
15330      IF(ILOCVP.GT.NUMARG)THEN
15331        WRITE(ICOUT,221)
15332        CALL DPWRST('XXX','BUG ')
15333        WRITE(ICOUT,2302)
15334 2302   FORMAT('      NO SECOND VARIABLE NAME OR COLUMN NUMBER WAS')
15335        CALL DPWRST('XXX','BUG ')
15336        WRITE(ICOUT,2303)
15337 2303   FORMAT('      WAS GIVEN AFTER THE STATISTIC CALCULATION')
15338        CALL DPWRST('XXX','BUG ')
15339        WRITE(ICOUT,1158)
15340        CALL DPWRST('XXX','BUG ')
15341        IF(IWIDTH.GE.1)THEN
15342          WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
15343          CALL DPWRST('XXX','BUG ')
15344        ENDIF
15345        IERROR='YES'
15346        GOTO19000
15347      ENDIF
15348C
15349      IHARG3=IHARG(ILOCVP)
15350      IHARG4=IHARG2(ILOCVP)
15351      DO2310I=1,NUMNAM
15352        I2=I
15353        IF(IHARG3.EQ.IHNAME(I).AND.IHARG4.EQ.IHNAM2(I).AND.
15354     1    IUSE(I).EQ.'V')THEN
15355          ILIST2=I2
15356          ICOL2=IVALUE(ILIST2)
15357          NIRIG2=IN(ILIST2)
15358          ICOL22=-99
15359          GOTO2390
15360        ELSEIF(IHARG3.EQ.IHNAME(I).AND.IHARG4.EQ.IHNAM2(I).AND.
15361     1    IUSE(I).EQ.'M')THEN
15362          ILIST2=I2
15363          ICOL2=IVALUE(ILIST2)
15364          ICOL22=IVALU2(ILIST2)
15365          NIRIG2=IN(ILIST2)
15366          NCOL2=(ICOL22 - ICOL2) + 1
15367          GOTO2390
15368        ELSEIF(IHARG3.EQ.IHNAME(I).AND.IHARG4.EQ.IHNAM2(I).AND.
15369     1    IUSE(I).EQ.'P')THEN
15370          IFLGP2=1
15371          ILIST2=I2
15372          AVAL2=VALUE(ILIST2)
15373          NIRIG2=1
15374          GOTO2390
15375CCCCC     WRITE(ICOUT,999)
15376CCCCC     CALL DPWRST('XXX','BUG ')
15377CCCCC     WRITE(ICOUT,221)
15378CCCCC     CALL DPWRST('XXX','BUG ')
15379CCCCC     WRITE(ICOUT,2322)
15380C2322     FORMAT('      THE SPECIFIED SECOND ARGUMENT VARIABLE NAME OR')
15381CCCCC     CALL DPWRST('XXX','BUG ')
15382CCCCC     WRITE(ICOUT,2324)
15383C2324     FORMAT('      COLUMN NUMBER) ON THE RIGHT OF THE = SIGN ',
15384CCCCC1           'WAS FOUND')
15385CCCCC     CALL DPWRST('XXX','BUG ')
15386CCCCC     WRITE(ICOUT,2325)
15387C2325     FORMAT('      IN THE INTERNAL NAME LIST, BUT AS A PARAMETER')
15388CCCCC     CALL DPWRST('XXX','BUG ')
15389CCCCC     WRITE(ICOUT,2327)
15390C2327     FORMAT('      AND NOT AS A VARIABLE AS IT SHOULD BE HERE.')
15391CCCCC     CALL DPWRST('XXX','BUG ')
15392CCCCC     WRITE(ICOUT,1158)
15393CCCCC     CALL DPWRST('XXX','BUG ')
15394CCCCC     IF(IWIDTH.GE.1)THEN
15395CCCCC       WRITE(ICOUT,1159)(IANS(II),II=1,MIN(80,IWIDTH))
15396CCCCC       CALL DPWRST('XXX','BUG ')
15397CCCCC     ENDIF
15398CCCCC     IERROR='YES'
15399CCCCC     GOTO19000
15400        ENDIF
15401 2310 CONTINUE
15402C
15403      WRITE(ICOUT,999)
15404      CALL DPWRST('XXX','BUG ')
15405      WRITE(ICOUT,221)
15406      CALL DPWRST('XXX','BUG ')
15407      WRITE(ICOUT,2312)
15408 2312 FORMAT('      THE SPECIFIED SECOND ARGUMENT (VARIABLE NAME OR')
15409      CALL DPWRST('XXX','BUG ')
15410      WRITE(ICOUT,2314)
15411 2314 FORMAT('      COLUMN NUMBER) ON THE RIGHT OF THE = SIGN')
15412      CALL DPWRST('XXX','BUG ')
15413      WRITE(ICOUT,2315)
15414 2315 FORMAT('      WAS NOT FOUND IN THE INTERNAL NAME LIST.')
15415      CALL DPWRST('XXX','BUG ')
15416      WRITE(ICOUT,1158)
15417      CALL DPWRST('XXX','BUG ')
15418      IF(IWIDTH.GE.1)THEN
15419        WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
15420        CALL DPWRST('XXX','BUG ')
15421      ENDIF
15422      IERROR='YES'
15423      GOTO19000
15424C
15425 2390 CONTINUE
15426C
15427C
15428C               ******************************************************
15429C               **  STEP 6.4--                                      **
15430C               **  CHECK THAT THE 2 VARIABLES HAVE THE SAME        **
15431C               **  NUMBER OF ELEMENTS.                             **
15432C               ******************************************************
15433C
15434      ISTEPN='6.4'
15435      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15436     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15437C
15438C     "DIFFERENCE OF" STATISTICS DO NOT REQUIRE EQUAL SAMPLE
15439C     SIZES
15440C
15441      IF(ICASL8.EQ.'DMEA')IFLAGD='ON'
15442      IF(ICASL8.EQ.'DMDM')IFLAGD='ON'
15443      IF(ICASL8.EQ.'DMED')IFLAGD='ON'
15444      IF(ICASL8.EQ.'DTRM')IFLAGD='ON'
15445      IF(ICASL8.EQ.'DWNM')IFLAGD='ON'
15446      IF(ICASL8.EQ.'DGEO')IFLAGD='ON'
15447      IF(ICASL8.EQ.'DHAR')IFLAGD='ON'
15448      IF(ICASL8.EQ.'DHDL')IFLAGD='ON'
15449      IF(ICASL8.EQ.'DBIW')IFLAGD='ON'
15450      IF(ICASL8.EQ.'DSD ')IFLAGD='ON'
15451      IF(ICASL8.EQ.'DRMS ')IFLAGD='ON'
15452      IF(ICASL8.EQ.'DVAR')IFLAGD='ON'
15453      IF(ICASL8.EQ.'DAAD')IFLAGD='ON'
15454      IF(ICASL8.EQ.'DAAM')IFLAGD='ON'
15455      IF(ICASL8.EQ.'DMAD')IFLAGD='ON'
15456      IF(ICASL8.EQ.'DIQR')IFLAGD='ON'
15457      IF(ICASL8.EQ.'DWSD')IFLAGD='ON'
15458      IF(ICASL8.EQ.'DWVA')IFLAGD='ON'
15459      IF(ICASL8.EQ.'DBIM')IFLAGD='ON'
15460      IF(ICASL8.EQ.'DBIS')IFLAGD='ON'
15461      IF(ICASL8.EQ.'DPBN')IFLAGD='ON'
15462      IF(ICASL8.EQ.'DGSD')IFLAGD='ON'
15463      IF(ICASL8.EQ.'DRAN')IFLAGD='ON'
15464      IF(ICASL8.EQ.'DMDR')IFLAGD='ON'
15465      IF(ICASL8.EQ.'DQSE')IFLAGD='ON'
15466      IF(ICASL8.EQ.'DQUA')IFLAGD='ON'
15467      IF(ICASL8.EQ.'DSKE')IFLAGD='ON'
15468      IF(ICASL8.EQ.'DGSK')IFLAGD='ON'
15469      IF(ICASL8.EQ.'DPSK')IFLAGD='ON'
15470      IF(ICASL8.EQ.'DKUR')IFLAGD='ON'
15471      IF(ICASL8.EQ.'DEKU')IFLAGD='ON'
15472      IF(ICASL8.EQ.'DRSD')IFLAGD='ON'
15473      IF(ICASL8.EQ.'DSDM')IFLAGD='ON'
15474      IF(ICASL8.EQ.'DRVA')IFLAGD='ON'
15475      IF(ICASL8.EQ.'DVAM')IFLAGD='ON'
15476      IF(ICASL8.EQ.'DMIN')IFLAGD='ON'
15477      IF(ICASL8.EQ.'DMAX')IFLAGD='ON'
15478      IF(ICASL8.EQ.'DEXT')IFLAGD='ON'
15479      IF(ICASL8.EQ.'DCVA')IFLAGD='ON'
15480      IF(ICASL8.EQ.'DCOU')IFLAGD='ON'
15481      IF(ICASL8.EQ.'DSUM')IFLAGD='ON'
15482      IF(ICASL8.EQ.'DPRO')IFLAGD='ON'
15483      IF(ICASL8.EQ.'10LD')IFLAGD='ON'
15484      IF(ICASL8.EQ.'12LD')IFLAGD='ON'
15485      IF(ICASL8.EQ.'15LD')IFLAGD='ON'
15486      IF(ICASL8.EQ.'17LD')IFLAGD='ON'
15487      IF(ICASL8.EQ.'20LD')IFLAGD='ON'
15488      IF(ICASL8.EQ.'10SD')IFLAGD='ON'
15489      IF(ICASL8.EQ.'12SD')IFLAGD='ON'
15490      IF(ICASL8.EQ.'15SD')IFLAGD='ON'
15491      IF(ICASL8.EQ.'17SD')IFLAGD='ON'
15492      IF(ICASL8.EQ.'20SD')IFLAGD='ON'
15493      IF(ICASL8.EQ.'DSN')IFLAGD='ON'
15494      IF(ICASL8.EQ.'DQN')IFLAGD='ON'
15495      IF(ICASL8.EQ.'DLPL')IFLAGD='ON'
15496      IF(ICASL8.EQ.'DLPV')IFLAGD='ON'
15497      IF(ICASL8.EQ.'DLPS')IFLAGD='ON'
15498      IF(ICASL8.EQ.'DBPR')IFLAGD='ON'
15499      IF(ICASL8.EQ.'DTSD')IFLAGD='ON'
15500      IF(ICASL8.EQ.'DPER')IFLAGD='ON'
15501      IF(ICASL8.EQ.'D1DE')IFLAGD='ON'
15502      IF(ICASL8.EQ.'D2DE')IFLAGD='ON'
15503      IF(ICASL8.EQ.'D3DE')IFLAGD='ON'
15504      IF(ICASL8.EQ.'D4DE')IFLAGD='ON'
15505      IF(ICASL8.EQ.'D5DE')IFLAGD='ON'
15506      IF(ICASL8.EQ.'D6DE')IFLAGD='ON'
15507      IF(ICASL8.EQ.'D7DE')IFLAGD='ON'
15508      IF(ICASL8.EQ.'D8DE')IFLAGD='ON'
15509      IF(ICASL8.EQ.'D9DE')IFLAGD='ON'
15510      IF(ICASL8.EQ.'DLHI')IFLAGD='ON'
15511      IF(ICASL8.EQ.'DUHI')IFLAGD='ON'
15512      IF(ICASL8.EQ.'DLQU')IFLAGD='ON'
15513      IF(ICASL8.EQ.'DUQU')IFLAGD='ON'
15514      IF(ICASL8.EQ.'DSSQ')IFLAGD='ON'
15515      IF(ICASL8.EQ.'DRSC')IFLAGD='ON'
15516      IF(ICASL8.EQ.'DQQR')IFLAGD='ON'
15517      IF(ICASL8.EQ.'ORSE')IFLAGD='ON'
15518      IF(ICASL8.EQ.'ODRA')IFLAGD='ON'
15519      IF(ICASL8.EQ.'RATI')IFLAGD='ON'
15520      IF(ICASL8.EQ.'LOSE')IFLAGD='ON'
15521      IF(ICASL8.EQ.'LODR')IFLAGD='ON'
15522      IF(ICASL8.EQ.'KS2S')IFLAGD='ON'
15523      IF(ICASL8.EQ.'KSCV')IFLAGD='ON'
15524      IF(ICASL8.EQ.'CS2S')IFLAGD='ON'
15525      IF(ICASL8.EQ.'CC2S')IFLAGD='ON'
15526      IF(ICASL8.EQ.'CP2S')IFLAGD='ON'
15527      IF(ICASL8.EQ.'FTES')IFLAGD='ON'
15528      IF(ICASL8.EQ.'FTPV')IFLAGD='ON'
15529      IF(ICASL8.EQ.'FTCD')IFLAGD='ON'
15530      IF(ICASL8.EQ.'2TTE')IFLAGD='ON'
15531      IF(ICASL8.EQ.'2TCD')IFLAGD='ON'
15532      IF(ICASL8.EQ.'2T2P')IFLAGD='ON'
15533      IF(ICASL8.EQ.'2TLP')IFLAGD='ON'
15534      IF(ICASL8.EQ.'2TUP')IFLAGD='ON'
15535      IF(ICASL8.EQ.'PTTE')IFLAGD='ON'
15536      IF(ICASL8.EQ.'PTCD')IFLAGD='ON'
15537      IF(ICASL8.EQ.'PT2P')IFLAGD='ON'
15538      IF(ICASL8.EQ.'PTLP')IFLAGD='ON'
15539      IF(ICASL8.EQ.'PTUP')IFLAGD='ON'
15540      IF(ICASL8.EQ.'2STE')IFLAGD='ON'
15541      IF(ICASL8.EQ.'2SCD')IFLAGD='ON'
15542      IF(ICASL8.EQ.'2S2P')IFLAGD='ON'
15543      IF(ICASL8.EQ.'2SLP')IFLAGD='ON'
15544      IF(ICASL8.EQ.'2SUP')IFLAGD='ON'
15545      IF(ICASL8.EQ.'MWUS')IFLAGD='ON'
15546      IF(ICASL8.EQ.'MWTE')IFLAGD='ON'
15547      IF(ICASL8.EQ.'MWCD')IFLAGD='ON'
15548      IF(ICASL8.EQ.'MW2P')IFLAGD='ON'
15549      IF(ICASL8.EQ.'MWLP')IFLAGD='ON'
15550      IF(ICASL8.EQ.'MWUP')IFLAGD='ON'
15551      IF(ICASL8.EQ.'KLTE')IFLAGD='ON'
15552      IF(ICASL8.EQ.'KLCD')IFLAGD='ON'
15553      IF(ICASL8.EQ.'KL2P')IFLAGD='ON'
15554      IF(ICASL8.EQ.'KLLP')IFLAGD='ON'
15555      IF(ICASL8.EQ.'KLUP')IFLAGD='ON'
15556      IF(ICASL8.EQ.'SRTE')IFLAGD='ON'
15557      IF(ICASL8.EQ.'SRCD')IFLAGD='ON'
15558      IF(ICASL8.EQ.'SR2P')IFLAGD='ON'
15559      IF(ICASL8.EQ.'SRLP')IFLAGD='ON'
15560      IF(ICASL8.EQ.'SRUP')IFLAGD='ON'
15561      IF(ICASL8.EQ.'METE')IFLAGD='ON'
15562      IF(ICASL8.EQ.'MECD')IFLAGD='ON'
15563      IF(ICASL8.EQ.'ME2P')IFLAGD='ON'
15564      IF(ICASL8.EQ.'2SFR')IFLAGD='ON'
15565      IF(ICASL8.EQ.'2F2P')IFLAGD='ON'
15566      IF(ICASL8.EQ.'FMAT')IFLAGD='ON'
15567      IF(ICASL8.EQ.'LMAT')IFLAGD='ON'
15568      IF(ICASL8.EQ.'FNOM')IFLAGD='ON'
15569      IF(ICASL8.EQ.'LNOM')IFLAGD='ON'
15570      IF(ICASL8.EQ.'PDIF')IFLAGD='ON'
15571      IF(ICASL8.EQ.'2CTE')IFLAGD='ON'
15572      IF(ICASL8.EQ.'2CCD')IFLAGD='ON'
15573      IF(ICASL8.EQ.'2C2P')IFLAGD='ON'
15574      IF(ICASL8.EQ.'2CLP')IFLAGD='ON'
15575      IF(ICASL8.EQ.'2CUP')IFLAGD='ON'
15576      IF(ICASL8.EQ.'DCDI')IFLAGD='ON'
15577      IF(ICASL8.EQ.'DIDI')IFLAGD='ON'
15578      IF(ICASL8.EQ.'DQDI')IFLAGD='ON'
15579      IF(ICASL8.EQ.'DAMD')IFLAGD='ON'
15580      IF(ICASL8.EQ.'DPRE')IFLAGD='ON'
15581      IF(ICASL8.EQ.'DSNR')IFLAGD='ON'
15582      IF(ICASL8.EQ.'DSHM')IFLAGD='ON'
15583      IF(ICASL8.EQ.'DSHR')IFLAGD='ON'
15584      IF(ICASL8.EQ.'HEDG')IFLAGD='ON'
15585      IF(ICASL8.EQ.'BCHG')IFLAGD='ON'
15586      IF(ICASL8.EQ.'COHD')IFLAGD='ON'
15587      IF(ICASL8.EQ.'GLAS')IFLAGD='ON'
15588      IF(ICASL8.EQ.'DBLC')IFLAGD='ON'
15589      IF(ICASL8.EQ.'DBUC')IFLAGD='ON'
15590      IF(ICASL8.EQ.'HESE')IFLAGD='ON'
15591      IF(ICASL8.EQ.'HELC')IFLAGD='ON'
15592      IF(ICASL8.EQ.'HEUC')IFLAGD='ON'
15593C
15594      IF(NIRIG2.NE.NIRIGH .AND. IFLAGD.NE.'ON')THEN
15595        WRITE(ICOUT,221)
15596        CALL DPWRST('XXX','BUG ')
15597        WRITE(ICOUT,2412)
15598 2412   FORMAT('      FOR A 2-VARIABLE STATISTIC CALCULATION, THE')
15599        CALL DPWRST('XXX','BUG ')
15600        WRITE(ICOUT,2413)
15601 2413   FORMAT('      NUMBER OF OBSERVATIONS IN EACH VARIABLE MUST BE')
15602        CALL DPWRST('XXX','BUG ')
15603        WRITE(ICOUT,2415)
15604 2415   FORMAT('      THE SAME;  SUCH WAS NOT THE CASE HERE.')
15605        CALL DPWRST('XXX','BUG ')
15606        WRITE(ICOUT,2416)IH,IH2,NIRIGH
15607 2416   FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS;')
15608        CALL DPWRST('XXX','BUG ')
15609        WRITE(ICOUT,2417)IHARG3,IHARG4,NIRIG2
15610 2417   FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
15611        CALL DPWRST('XXX','BUG ')
15612        WRITE(ICOUT,1158)
15613        CALL DPWRST('XXX','BUG ')
15614        IF(IWIDTH.GE.1)THEN
15615          WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
15616          CALL DPWRST('XXX','BUG ')
15617        ENDIF
15618        IERROR='YES'
15619        GOTO19000
15620      ENDIF
15621C
15622C               ************************************************
15623C               **  STEP 6.5--                                **
15624C               **  EXTRACT THE THIRD  VARIABLE               **
15625C               ************************************************
15626C
15627      ISTEPN='6.5'
15628      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15629     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15630C
15631      IF(NUMVIN.LT.3)GOTO700
15632C
15633      NUMVAR=3
15634      ILOCVP=ILOCV+2
15635      IF(ILOCVP.GT.NUMARG)THEN
15636        WRITE(ICOUT,221)
15637        CALL DPWRST('XXX','BUG ')
15638        WRITE(ICOUT,3302)
15639 3302   FORMAT('      NO THIRD VARIABLE NAME OR COLUMN NUMBER WAS')
15640        CALL DPWRST('XXX','BUG ')
15641        WRITE(ICOUT,2303)
15642        CALL DPWRST('XXX','BUG ')
15643        WRITE(ICOUT,1158)
15644        CALL DPWRST('XXX','BUG ')
15645        IF(IWIDTH.GE.1)THEN
15646          WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
15647          CALL DPWRST('XXX','BUG ')
15648        ENDIF
15649        IERROR='YES'
15650        GOTO19000
15651      ENDIF
15652C
15653      ICOL32=0
15654      IHARG5=IHARG(ILOCVP)
15655      IHARG6=IHARG2(ILOCVP)
15656      DO3310I=1,NUMNAM
15657        I2=I
15658        IF(IHARG5.EQ.IHNAME(I).AND.IHARG6.EQ.IHNAM2(I).AND.
15659     1    IUSE(I).EQ.'V')THEN
15660          ILIST3=I2
15661          ICOL3=IVALUE(ILIST3)
15662          NIRIG3=IN(ILIST3)
15663          ICOL32=-99
15664          GOTO3390
15665        ELSEIF(IHARG5.EQ.IHNAME(I).AND.IHARG6.EQ.IHNAM2(I).AND.
15666     1    IUSE(I).EQ.'M')THEN
15667          ILIST3=I2
15668          ICOL3=IVALUE(ILIST3)
15669          ICOL32=IVALU2(ILIST3)
15670          NIRIG3=IN(ILIST3)
15671          NCOL3=(ICOL32 - ICOL3) + 1
15672          GOTO3390
15673        ELSEIF(IHARG5.EQ.IHNAME(I).AND.IHARG6.EQ.IHNAM2(I).AND.
15674     1    IUSE(I).EQ.'P')THEN
15675          IFLGP3=1
15676          ILIST3=I2
15677          AVAL3=VALUE(ILIST3)
15678          NIRIG3=1
15679          GOTO3390
15680CCCCC     WRITE(ICOUT,999)
15681CCCCC     CALL DPWRST('XXX','BUG ')
15682CCCCC     WRITE(ICOUT,221)
15683CCCCC     CALL DPWRST('XXX','BUG ')
15684CCCCC     WRITE(ICOUT,3322)
15685C3322     FORMAT('      THE SPECIFIED THIRD ARGUMENT VARIABLE NAME OR')
15686CCCCC     CALL DPWRST('XXX','BUG ')
15687CCCCC     WRITE(ICOUT,2324)
15688CCCCC     CALL DPWRST('XXX','BUG ')
15689CCCCC     WRITE(ICOUT,2325)
15690CCCCC     CALL DPWRST('XXX','BUG ')
15691CCCCC     WRITE(ICOUT,2327)
15692CCCCC     CALL DPWRST('XXX','BUG ')
15693CCCCC     WRITE(ICOUT,1158)
15694CCCCC     CALL DPWRST('XXX','BUG ')
15695CCCCC     IF(IWIDTH.GE.1)THEN
15696CCCCC       WRITE(ICOUT,1159)(IANS(II),II=1,MIN(80,IWIDTH))
15697CCCCC       CALL DPWRST('XXX','BUG ')
15698CCCCC     ENDIF
15699CCCCC     IERROR='YES'
15700CCCCC     GOTO19000
15701        ENDIF
15702 3310 CONTINUE
15703C
15704      WRITE(ICOUT,999)
15705      CALL DPWRST('XXX','BUG ')
15706      WRITE(ICOUT,221)
15707      CALL DPWRST('XXX','BUG ')
15708      WRITE(ICOUT,3312)
15709 3312 FORMAT('      THE SPECIFIED THIRD ARGUMENT (VARIABLE NAME OR')
15710      CALL DPWRST('XXX','BUG ')
15711      WRITE(ICOUT,2314)
15712      CALL DPWRST('XXX','BUG ')
15713      WRITE(ICOUT,2315)
15714      CALL DPWRST('XXX','BUG ')
15715      WRITE(ICOUT,1158)
15716      CALL DPWRST('XXX','BUG ')
15717      IF(IWIDTH.GE.1)THEN
15718        WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
15719        CALL DPWRST('XXX','BUG ')
15720      ENDIF
15721      IERROR='YES'
15722      GOTO19000
15723C
15724 3390 CONTINUE
15725C
15726C
15727C               ******************************************************
15728C               **  STEP 6.6--                                      **
15729C               **  CHECK THAT THE 3 VARIABLES HAVE THE SAME        **
15730C               **  NUMBER OF ELEMENTS.                             **
15731C               ******************************************************
15732C
15733      ISTEPN='6.6'
15734      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15735     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15736C
15737      IF(NIRIG3.NE.NIRIGH .AND. IFLAGD.NE.'ON')THEN
15738        WRITE(ICOUT,221)
15739        CALL DPWRST('XXX','BUG ')
15740        WRITE(ICOUT,3412)
15741 3412   FORMAT('      FOR A 3-VARIABLE STATISTIC CALCULATION, THE')
15742        CALL DPWRST('XXX','BUG ')
15743        WRITE(ICOUT,2413)
15744        CALL DPWRST('XXX','BUG ')
15745        WRITE(ICOUT,2415)
15746        CALL DPWRST('XXX','BUG ')
15747        WRITE(ICOUT,3416)IH,IH2,NIRIGH
15748 3416   FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS;')
15749        CALL DPWRST('XXX','BUG ')
15750        WRITE(ICOUT,3417)IHARG5,IHARG6,NIRIG3
15751 3417   FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
15752        CALL DPWRST('XXX','BUG ')
15753        WRITE(ICOUT,1158)
15754        CALL DPWRST('XXX','BUG ')
15755        IF(IWIDTH.GE.1)THEN
15756          WRITE(ICOUT,1159)(IANS(II),II=1,MIN(80,IWIDTH))
15757          CALL DPWRST('XXX','BUG ')
15758        ENDIF
15759        IERROR='YES'
15760        GOTO19000
15761      ENDIF
15762C
15763C               *******************************
15764C               **  STEP 7--                 **
15765C               **  DETERMINE THE SUBCASE    **
15766C               **  AND BRANCH ACCORDINGLY.  **
15767C               *******************************
15768C
15769  700 CONTINUE
15770      ISTEPN='7'
15771      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15772     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15773C
15774      IARG4F=IFOUNZ(4)
15775      IARG4T=ITYPE(4)
15776C
15777      ICASEL='UNKN'
15778      IF(IARG4F.EQ.'NO')ICASEL='PARA'
15779      IF(IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB')ICASEL='ELEM'
15780CCCCC THE FOLLOWING LINE WAS REPLACED                   (DECEMBER 1988)
15781CCCCC BY THE SUCCEEDING LINE                            (DECEMBER 1988)
15782CCCCC TO ALLOW    LET X(K) = MEAN ETC.  INSIDE LOOP     (DECEMBER 1988)
15783CCCCC IF(IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')ICASEL='VAR'
15784      IF(IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')ICASEL='ELEM'
15785      IF(ICASEL.EQ.'UNKN'.OR.ICASEL.EQ.'VAR')GOTO710
15786      GOTO729
15787C
15788  710 CONTINUE
15789      WRITE(ICOUT,221)
15790      CALL DPWRST('XXX','BUG ')
15791      WRITE(ICOUT,712)
15792  712 FORMAT('      UNKNOWN VARIABLE/PARAMETER EXPRESSION')
15793      CALL DPWRST('XXX','BUG ')
15794      WRITE(ICOUT,713)
15795  713 FORMAT('      TO THE LEFT OF THE EQUAL SIGN.')
15796      CALL DPWRST('XXX','BUG ')
15797      WRITE(ICOUT,1158)
15798      CALL DPWRST('XXX','BUG ')
15799      WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
15800      CALL DPWRST('XXX','BUG ')
15801      IERROR='YES'
15802      GOTO19000
15803C
15804  729 CONTINUE
15805C
15806      ICASEQ='UNKN'
15807      IMIN=ILOCV+1
15808      IF(IMIN.GT.NUMARG)GOTO741
15809      DO740I=IMIN,NUMARG
15810      IF(IHARG(I).EQ.'SUBS'.AND.IHARG2(I).EQ.'ET  ')GOTO742
15811      IF(IHARG(I).EQ.'EXCE'.AND.IHARG2(I).EQ.'PT  ')GOTO742
15812      IF(IHARG(I).EQ.'FOR '.AND.IHARG2(I).EQ.'    ')GOTO743
15813  740 CONTINUE
15814  741 CONTINUE
15815      ICASEQ='FULL'
15816      GOTO749
15817  742 CONTINUE
15818      ICASEQ='SUBS'
15819      GOTO749
15820  743 CONTINUE
15821      ICASEQ='FOR'
15822      GOTO749
15823  749 CONTINUE
15824      IF(ICASEQ.EQ.'UNKN')GOTO750
15825C
15826      IF(ICASEQ.EQ.'FULL')GOTO8000
15827      IF(ICASEQ.EQ.'SUBS')GOTO9000
15828      IF(ICASEQ.EQ.'FOR')GOTO10000
15829C
15830  750 CONTINUE
15831      WRITE(ICOUT,751)
15832  751 FORMAT('***** INTERNAL ERROR IN DPSTAC--')
15833      CALL DPWRST('XXX','BUG ')
15834      WRITE(ICOUT,752)
15835  752 FORMAT('      UNKNOWN QUALIFIER TYPE FOR LET COMMAND')
15836      CALL DPWRST('XXX','BUG ')
15837      WRITE(ICOUT,1158)
15838      CALL DPWRST('XXX','BUG ')
15839      WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
15840      CALL DPWRST('XXX','BUG ')
15841      IERROR='YES'
15842      GOTO19000
15843C
15844C               ************************************************
15845C               **  STEP 8--                                  **
15846C               **  TREAT THE FULL VARIABLE CASE.             **
15847C               **  EXAMPLE--LET Y = SORT(X)                  **
15848C               **         --LET Y(I) = SORT(X)               **
15849C               **  JUMP TO STEP NUMBER 11 BELOW              **
15850C               **  FOR THE ACTUAL STATISTICAL CALCULATION,   **
15851C               **  FOR THE LIST UPDATING, AND                **
15852C               **  FOR SOME INFORMATIVE PRINTING.            **
15853C               ************************************************
15854C
15855 8000 CONTINUE
15856      ISTEPN='8'
15857      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15858     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15859C
15860      NIOLD=NIRIGH
15861      IF(NUMVAR.GE.2.AND.NIRIG2.GT.NIOLD)NIOLD=NIRIG2
15862      NINEW=NIOLD
15863      DO8100I=1,NINEW
15864        ISUB(I)=1
15865 8100 CONTINUE
15866      GOTO11000
15867C
15868C               ****************************************************
15869C               **  STEP 9--                                       *
15870C               **  TREAT THE PARTIAL VARIABLE SUBSET CASE.        *
15871C               **  EXAMPLE--LET Y = SORT(X)    SUBSET 2 3 5       *
15872C               **         --LET Y(I) = SORT(X) SUBSET 2 3 5       *
15873C               **  JUMP TO STEP NUMBER 11 BELOW                   *
15874C               **  FOR THE ACTUAL STATISTICAL CALCULATION,        *
15875C               **  FOR THE LIST UPDATING, AND                     *
15876C               **  FOR SOME INFORMATIVE PRINTING.                 *
15877C               ****************************************************
15878C
15879 9000 CONTINUE
15880      ISTEPN='9'
15881      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15882     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15883C
15884      IF(NUMVAR.EQ.1)ILOCSV=ILOCV+2
15885      IF(NUMVAR.EQ.2)ILOCSV=ILOCV+3
15886      IF(NUMVAR.EQ.3)ILOCSV=ILOCV+4
15887      IHSET=IHARG(ILOCSV)
15888      IHSET2=IHARG2(ILOCSV)
15889      IHWUSE='V'
15890      MESSAG='YES'
15891      CALL CHECKN(IHSET,IHSET2,IHWUSE,
15892     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
15893     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
15894      IF(IERROR.EQ.'YES')GOTO19000
15895      NIOLD=IN(ILOC)
15896      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
15897      IF(IERROR.EQ.'YES')GOTO19000
15898      NINEW=NIOLD
15899      GOTO11000
15900C
15901C               *****************************************************
15902C               **  STEP 10--                                       *
15903C               **  TREAT THE PARTIAL VARIABLE FOR CASE.            *
15904C               **  EXAMPLE--LET Y = SORT(X)    FOR I = 1 2 10      *
15905C               **         --LET Y(I) = SORT(X) FOR I = 1 2 10      *
15906C               **  JUMP TO STEP NUMBER 11 BELOW                    *
15907C               **  FOR THE ACTUAL STATISTICAL CALCULATION,         *
15908C               **  FOR THE LIST UPDATING, AND                      *
15909C              **  FOR SOME INFORMATIVE PRINTING.                   *
15910C               *****************************************************
15911C
1591210000 CONTINUE
15913      ISTEPN='10'
15914      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15915     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15916C
15917      CALL DPFOR(NIOLD,NINEW,IROW1,IROWN,
15918     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
15919      NIFOR=NINEW
15920      GOTO11000
15921C
15922C               *******************************************
15923C               **  STEP 11--                            **
15924C               **  CARRY OUT THE                        **
15925C               **  ACTUAL STATISTICAL CALCULATION,      ZZ
15926C               **  THE LIST UPDATING, AND               **
15927C               **  GENERATE THE INFORMATIVE PRINTING    **
15928C               **  FOR STEP NUMBERS 7, 8, AND 9 ABOVE.  **
15929C               *******************************************
15930C
1593111000 CONTINUE
15932      ISTEPN='11'
15933      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
15934     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15935C
15936      NS2=0
15937      NS3=0
15938      NS4=0
15939C
15940C     EXTRACT DATA VARIABLE ONE.  HANDLE VARIABLE AND MATRIX
15941C     CASES DIFFERENTLY.
15942C
15943      IF(IFLGP1.EQ.1)THEN
15944        NS2=1
15945        TEMP(NS2)=AVAL1
15946      ELSEIF(ICOLR2.LE.0)THEN
15947        DO11100I=1,NINEW
15948          IF(ISUB(I).EQ.0)GOTO11100
15949          IF(I.GT.NIRIGH)GOTO11109
15950          NS2=NS2+1
15951C
15952          IJ=MAXN*(ICOLR-1)+I
15953          IF(ICOLR.LE.MAXCOL)TEMP(NS2)=V(IJ)
15954          IF(ICOLR.EQ.MAXCP1)TEMP(NS2)=PRED(I)
15955          IF(ICOLR.EQ.MAXCP2)TEMP(NS2)=RES(I)
15956          IF(ICOLR.EQ.MAXCP3)TEMP(NS2)=YPLOT(I)
15957          IF(ICOLR.EQ.MAXCP4)TEMP(NS2)=XPLOT(I)
15958          IF(ICOLR.EQ.MAXCP5)TEMP(NS2)=X2PLOT(I)
15959          IF(ICOLR.EQ.MAXCP6)TEMP(NS2)=TAGPLO(I)
15960C
1596111100   CONTINUE
1596211109   CONTINUE
15963      ELSE
15964        NLOOP=NCOL
15965        IF(NLOOP.LT.1)NLOOP=1
15966        NS2=0
15967        DO11101JLOOP=1,NLOOP
15968          DO11103I=1,NINEW
15969            IF(ISUB(I).EQ.0)GOTO11103
15970            IF(I.GT.NIRIGH)GOTO11105
15971            NS2=NS2+1
15972            IF(NS2.GT.MAXOBV)THEN
15973              WRITE(ICOUT,999)
15974              CALL DPWRST('XXX','BUG ')
15975              WRITE(ICOUT,221)
15976              CALL DPWRST('XXX','BUG ')
15977              WRITE(ICOUT,11106)
1597811106         FORMAT('      FOR THE MATRIX CASE, THE MAXIMUM NUMBER')
15979              CALL DPWRST('XXX','BUG ')
15980              WRITE(ICOUT,11107)
1598111107         FORMAT('      OF OBSERVATIONS HAS BEEN EXCEEDED.')
15982              CALL DPWRST('XXX','BUG ')
15983              WRITE(ICOUT,11108)MAXOBV
1598411108         FORMAT('      THE MAXIMUM NUMBER OF OBSERVATIONS = ',I10)
15985              CALL DPWRST('XXX','BUG ')
15986              IERROR='YES'
15987              GOTO9000
15988            ENDIF
15989            ICOLT=ICOLR+JLOOP-1
15990            IJ=MAXN*(ICOLT-1)+I
15991            IF(ICOLT.LE.MAXCOL)TEMP(NS2)=V(IJ)
15992            IF(ICOLT.EQ.MAXCP1)TEMP(NS2)=PRED(I)
15993            IF(ICOLT.EQ.MAXCP2)TEMP(NS2)=RES(I)
15994            IF(ICOLT.EQ.MAXCP3)TEMP(NS2)=YPLOT(I)
15995            IF(ICOLT.EQ.MAXCP4)TEMP(NS2)=XPLOT(I)
15996            IF(ICOLT.EQ.MAXCP5)TEMP(NS2)=X2PLOT(I)
15997            IF(ICOLT.EQ.MAXCP6)TEMP(NS2)=TAGPLO(I)
1599811103     CONTINUE
1599911105     CONTINUE
1600011101   CONTINUE
16001      ENDIF
16002C
16003      IF(NUMVAR.GE.2)THEN
16004        IF(IFLGP2.EQ.1)THEN
16005          NS3=1
16006          TEMP2(NS3)=AVAL2
16007        ELSEIF(ICOL22.LE.0)THEN
16008          DO11200I=1,NINEW
16009            IF(ISUB(I).EQ.0)GOTO11200
16010            IF(I.GT.NIRIG2)GOTO11209
16011            NS3=NS3+1
16012C
16013            IJ=MAXN*(ICOL2-1)+I
16014            IF(ICOL2.LE.MAXCOL)TEMP2(NS3)=V(IJ)
16015            IF(ICOL2.EQ.MAXCP1)TEMP2(NS3)=PRED(I)
16016            IF(ICOL2.EQ.MAXCP2)TEMP2(NS3)=RES(I)
16017            IF(ICOL2.EQ.MAXCP3)TEMP2(NS3)=YPLOT(I)
16018            IF(ICOL2.EQ.MAXCP4)TEMP2(NS3)=XPLOT(I)
16019            IF(ICOL2.EQ.MAXCP5)TEMP2(NS3)=X2PLOT(I)
16020            IF(ICOL2.EQ.MAXCP6)TEMP2(NS3)=TAGPLO(I)
16021C
1602211200     CONTINUE
1602311209     CONTINUE
16024        ELSE
16025          NLOOP=NCOL2
16026          IF(NLOOP.LT.1)NLOOP=1
16027          NS3=0
16028          DO11201JLOOP=1,NLOOP
16029            DO11203I=1,NINEW
16030              IF(ISUB(I).EQ.0)GOTO11203
16031              IF(I.GT.NIRIG2)GOTO11205
16032              NS3=NS3+1
16033              IF(NS3.GT.MAXOBV)THEN
16034                WRITE(ICOUT,999)
16035                CALL DPWRST('XXX','BUG ')
16036                WRITE(ICOUT,221)
16037                CALL DPWRST('XXX','BUG ')
16038                WRITE(ICOUT,11106)
16039                CALL DPWRST('XXX','BUG ')
16040                WRITE(ICOUT,11107)
16041                CALL DPWRST('XXX','BUG ')
16042                WRITE(ICOUT,11108)MAXOBV
16043                CALL DPWRST('XXX','BUG ')
16044                IERROR='YES'
16045                GOTO9000
16046              ENDIF
16047              ICOLT=ICOL2+JLOOP-1
16048              IJ=MAXN*(ICOLT-1)+I
16049              IF(ICOLT.LE.MAXCOL)TEMP2(NS3)=V(IJ)
16050              IF(ICOLT.EQ.MAXCP1)TEMP2(NS3)=PRED(I)
16051              IF(ICOLT.EQ.MAXCP2)TEMP2(NS3)=RES(I)
16052              IF(ICOLT.EQ.MAXCP3)TEMP2(NS3)=YPLOT(I)
16053              IF(ICOLT.EQ.MAXCP4)TEMP2(NS3)=XPLOT(I)
16054              IF(ICOLT.EQ.MAXCP5)TEMP2(NS3)=X2PLOT(I)
16055              IF(ICOLT.EQ.MAXCP6)TEMP2(NS3)=TAGPLO(I)
1605611203       CONTINUE
1605711205       CONTINUE
1605811201     CONTINUE
16059        ENDIF
16060      ENDIF
16061C
16062      IF(NUMVAR.GE.3)THEN
16063        IF(IFLGP3.EQ.1)THEN
16064          NS4=1
16065          TEMP3(NS4)=AVAL3
16066        ELSEIF(ICOL32.LE.0)THEN
16067          DO11300I=1,NINEW
16068            IF(ISUB(I).EQ.0)GOTO11300
16069            IF(I.GT.NIRIG3)GOTO11309
16070            NS4=NS4+1
16071C
16072            IJ=MAXN*(ICOL3-1)+I
16073            IF(ICOL3.LE.MAXCOL)TEMP3(NS4)=V(IJ)
16074            IF(ICOL3.EQ.MAXCP1)TEMP3(NS4)=PRED(I)
16075            IF(ICOL3.EQ.MAXCP2)TEMP3(NS4)=RES(I)
16076            IF(ICOL3.EQ.MAXCP3)TEMP3(NS4)=YPLOT(I)
16077            IF(ICOL3.EQ.MAXCP4)TEMP3(NS4)=XPLOT(I)
16078            IF(ICOL3.EQ.MAXCP5)TEMP3(NS4)=X2PLOT(I)
16079            IF(ICOL3.EQ.MAXCP6)TEMP3(NS4)=TAGPLO(I)
16080C
1608111300     CONTINUE
1608211309     CONTINUE
16083        ELSE
16084          NLOOP=NCOL3
16085          IF(NLOOP.LT.1)NLOOP=1
16086          NS4=0
16087          DO11301JLOOP=1,NLOOP
16088            DO11303I=1,NINEW
16089              IF(ISUB(I).EQ.0)GOTO11303
16090              IF(I.GT.NIRIG3)GOTO11305
16091              NS4=NS4+1
16092              IF(NS4.GT.MAXOBV)THEN
16093                WRITE(ICOUT,999)
16094                CALL DPWRST('XXX','BUG ')
16095                WRITE(ICOUT,221)
16096                CALL DPWRST('XXX','BUG ')
16097                WRITE(ICOUT,11106)
16098                CALL DPWRST('XXX','BUG ')
16099                WRITE(ICOUT,11107)
16100                CALL DPWRST('XXX','BUG ')
16101                WRITE(ICOUT,11108)MAXOBV
16102                CALL DPWRST('XXX','BUG ')
16103                IERROR='YES'
16104                GOTO9000
16105              ENDIF
16106              ICOLT=ICOL3+JLOOP-1
16107              IJ=MAXN*(ICOLT-1)+I
16108              IF(ICOLT.LE.MAXCOL)TEMP3(NS4)=V(IJ)
16109              IF(ICOLT.EQ.MAXCP1)TEMP3(NS4)=PRED(I)
16110              IF(ICOLT.EQ.MAXCP2)TEMP3(NS4)=RES(I)
16111              IF(ICOLT.EQ.MAXCP3)TEMP3(NS4)=YPLOT(I)
16112              IF(ICOLT.EQ.MAXCP4)TEMP3(NS4)=XPLOT(I)
16113              IF(ICOLT.EQ.MAXCP5)TEMP3(NS4)=X2PLOT(I)
16114              IF(ICOLT.EQ.MAXCP6)TEMP3(NS4)=TAGPLO(I)
1611511303       CONTINUE
1611611305       CONTINUE
1611711301     CONTINUE
16118        ENDIF
16119      ENDIF
16120C
16121      IF(NS2.LE.0)THEN
16122        IF(ICASL8.EQ.'NUMB')THEN
16123          RIGHT=0
16124          IFOUND='YES'
16125          IERROR='NO'
16126          IF(ICASEL.EQ.'PARA')GOTO15000
16127          IF(ICASEL.EQ.'ELEM')GOTO16000
16128        ELSE
16129          WRITE(ICOUT,999)
16130          CALL DPWRST('XXX','BUG ')
16131          WRITE(ICOUT,12111)ICASL8
1613212111     FORMAT('****** ERROR--AFTER SUBSET/FOR/EXCEPT CLAUSE ',
16133     1           'APPLIED FOR STATISTIC ',A4,',')
16134          CALL DPWRST('XXX','BUG ')
16135          WRITE(ICOUT,12113)
1613612113     FORMAT('       THE RESPONSE VARIABLE IS EMPTY.  THE ',
16137     1           'STATISTIC WAS NOT COMPUTED.')
16138          CALL DPWRST('XXX','BUG ')
16139          IFOUND='YES'
16140          IERROR='YES'
16141          GOTO19000
16142        ENDIF
16143      ENDIF
16144C
16145      IWRITE='ON'
16146      IF(IPRINT.EQ.'OFF')IWRITE='OFF'
16147      IF(IFEEDB.EQ.'OFF')IWRITE='OFF'
16148C
16149CCCCC MARCH 2003: CALL CMPSTA TO COMPUTE THE STATISTIC.
16150C
16151      ISTEPN='12'
16152      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
16153     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16154C
16155      CALL CMPSTA(
16156     1     TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,XTEMP3,
16157     1     MAXNXT,NS2,NS3,NS4,NUMVAR,ICASL8,
16158     1     ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
16159     1     DTEMP1,DTEMP2,DTEMP3,
16160CCCCC1     IQUAME,IQUASE,PSTAMV,
16161     1     RIGHT,
16162     1     ISUBRO,IBUGA3,IERROR)
16163C
16164      GOTO11900
16165C
1616611900 CONTINUE
16167      ISTEPN='13'
16168      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
16169     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16170C
16171      IFOUND='YES'
16172      IF(IERROR.EQ.'YES')GOTO19000
16173      IF(ICASEL.EQ.'PARA')GOTO15000
16174      IF(ICASEL.EQ.'ELEM')GOTO16000
16175C
16176C               *****************************************************
16177C               **  STEP 15--                                      **
16178C               **  TREAT THE PARAMETER CASE.                      **
16179C               **  EXAMPLE--LET A = MEAN X                        **
16180C               **           WHERE A WAS PREVIOUSLY UNDEFINED      **
16181C               **           OR WHERE A WAS PREVIOUSLY A PARAMETER.**
16182C               **  CARRY OUT THE LIST UPDATING  AND               **
16183C               **  GENERATE THE INFORMATIVE PRINTING.             **
16184C               **  THEN EXIT.                                     **
16185C               *****************************************************
16186C
1618715000 CONTINUE
16188      ISTEPN='15'
16189      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
16190     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16191C
16192      IHNAME(ILISTL)=ILEFT
16193      IHNAM2(ILISTL)=ILEFT2
16194      IUSE(ILISTL)='P'
16195      VALUE(ILISTL)=RIGHT
16196C     ***** THE FOLLOWING LINE WAS ADDED 7/83 *****
16197C     ***** ROUNDING NEEDS TO BE DIFFERENT FOR NEGATIVE
16198C           NUMBERS 4/2014                    *******
16199      IF(VALUE(ILISTL).GE.0.0)THEN
16200        IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
16201      ELSE
16202        IVALUE(ILISTL)=INT(VALUE(ILISTL)-0.5)
16203      ENDIF
16204      IN(ILISTL)=1
16205      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
16206C
16207      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
16208        WRITE(ICOUT,999)
16209        CALL DPWRST('XXX','BUG ')
16210        WRITE(ICOUT,15111)ILEFT,ILEFT2,RIGHT
1621115111   FORMAT('THE COMPUTED VALUE OF THE CONSTANT ',
16212     1         A4,A4,'      = ',G15.7)
16213        CALL DPWRST('XXX','BUG ')
16214        WRITE(ICOUT,999)
16215        CALL DPWRST('XXX','BUG ')
16216      ENDIF
16217      GOTO19000
16218C
16219C               *********************************************
16220C               **  STEP 16--                              **
16221C               **  TREAT THE ELEMENT SPECIFICATION CASE.  **
16222C               **  EXAMPLE--LET Y(4)=MEAN X               **
16223C               **  ALSO, CARRY OUT THE LIST UPDATING AND  **
16224C               **  GENERATE THE INFORMATIVE PRINTING.     **
16225C               *********************************************
16226C
1622716000 CONTINUE
16228      ISTEPN='16'
16229      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STAC')
16230     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16231C
16232      IARGL=INT1(4)
16233      IF(1.LE.IARGL.AND.IARGL.LE.MAXN)GOTO16100
16234      WRITE(ICOUT,221)
16235      CALL DPWRST('XXX','BUG ')
16236      WRITE(ICOUT,16002)IARGL,ILEFT
1623716002 FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
16238      CALL DPWRST('XXX','BUG ')
16239      WRITE(ICOUT,16003)RIGHT
1624016003 FORMAT('      (THAT WAS TO BE SET = ',G15.7,')')
16241      CALL DPWRST('XXX','BUG ')
16242      WRITE(ICOUT,16004)
1624316004 FORMAT('      WAS LESS THAN 1 OR')
16244      CALL DPWRST('XXX','BUG ')
16245      WRITE(ICOUT,16005)MAXN
1624616005 FORMAT('      GREATER THAN THE MAX ALLOWABLE ',I8)
16247      CALL DPWRST('XXX','BUG ')
16248      IERROR='YES'
16249      GOTO19000
16250C
1625116100 CONTINUE
16252CCCCC THE FOLLOWING 2 LINES WERE ADDED     (DECEMBER 1988)
16253CCCCC TO FIX PROBLEM OF LET Y(K) = MEAN X  (DECEMBER 1988)
16254CCCCC INSIDE A LOOP                        (DECEMBER 1988)
16255      IF(NEWNAM.EQ.'NO')NIOLD=IN(ILISTL)
16256      IF(NEWNAM.EQ.'YES')NIOLD=1
16257      NINEW=NIOLD
16258      IF(IARGL.GT.NINEW)NINEW=IARGL
16259      NS2=1
16260C
16261      IJ=MAXN*(ICOLL-1)+IARGL
16262      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
16263      IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT
16264      IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT
16265      IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT
16266      IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT
16267      IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT
16268      IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT
16269C
16270      IHNAME(ILISTL)=ILEFT
16271      IHNAM2(ILISTL)=ILEFT2
16272      IUSE(ILISTL)='V'
16273      IVALUE(ILISTL)=ICOLL
16274      VALUE(ILISTL)=ICOLL
16275      IN(ILISTL)=NINEW
16276C
16277CCCCC IUSE(ICOLL)='V'
16278CCCCC IVALUE(ICOLL)=ICOLL
16279CCCCC VALUE(ICOLL)=ICOLL
16280CCCCC IN(ICOLL)=NINEW
16281C
16282      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
16283      IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1
16284C
16285      DO16200J4=1,NUMNAM
16286      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO16205
16287      GOTO16200
1628816205 CONTINUE
16289      IUSE(J4)='V'
16290      IVALUE(J4)=ICOLL
16291      VALUE(J4)=ICOLL
16292      IN(J4)=NINEW
1629316200 CONTINUE
16294C
16295      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
16296        WRITE(ICOUT,999)
16297        CALL DPWRST('XXX','BUG ')
16298        WRITE(ICOUT,16111)ILEFT,ILEFT2,IARGL,RIGHT
1629916111   FORMAT('THE COMPUTED VALUE OF ',
16300     1         A4,A4,'(',I6,')      = ',G15.7)
16301        CALL DPWRST('XXX','BUG ')
16302        WRITE(ICOUT,999)
16303        CALL DPWRST('XXX','BUG ')
16304      ENDIF
16305      GOTO19000
16306C
16307C               *****************
16308C               **  STEP 90--  **
16309C               **  EXIT       **
16310C               *****************
16311C
1631219000 CONTINUE
16313      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STAC')THEN
16314        WRITE(ICOUT,999)
16315        CALL DPWRST('XXX','BUG ')
16316        WRITE(ICOUT,19011)
1631719011   FORMAT('***** AT THE END       OF DPSTAC--')
16318        CALL DPWRST('XXX','BUG ')
16319        WRITE(ICOUT,19012)IFOUND,IERROR
1632019012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
16321        CALL DPWRST('XXX','BUG ')
16322        WRITE(ICOUT,9014)ICASL8,ICASEL,IWRITE,IFLAGD,ILOCV
16323 9014   FORMAT('ICASL8,ICASEL,IWRITE,IFLAGD,ILOCV = ',4(A4,2X),I8)
16324        CALL DPWRST('XXX','BUG ')
16325        WRITE(ICOUT,19015)NS2,NS3,NS4,RIGHT
1632619015   FORMAT('NS2,NS3,NS4,RIGHT = ',3I8,G15.7)
16327        CALL DPWRST('XXX','BUG ')
16328      ENDIF
16329C
16330      RETURN
16331      END
16332      SUBROUTINE DPSTAR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
16333     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
16334C
16335C     PURPOSE--GENERATE A STAR PLOT--
16336C              A MULTIVARIATE TECHNICQUE WHICH PLOTS A SEQUENCE
16337C              OF RADIAL SPOKES AT EQUAL ANGLES AROUND A CIRCLE.
16338C              EACH RADIAL SPOKE REPRESENTS A SEPARATE VARIABLE.
16339C              THE LENGTH OF EACH RADIAL SPOKE IS PROPORTIONAL
16340C              TO THE RELATIVE SIZE OF THE RESPONSE.
16341C     WRITTEN BY--JAMES J. FILLIBEN
16342C                 STATISTICAL ENGINEERING DIVISION
16343C                 INFORMATION TECHNOLOGY LABORATORY
16344C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16345C                 GAITHERSBURG, MD 20899-8980
16346C                 PHONE--301-975-2855
16347C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16348C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16349C     LANGUAGE--ANSI FORTRAN (1977)
16350C     VERSION NUMBER--88/2
16351C     ORIGINAL VERSION--FEBRUARY  1988.
16352C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
16353C     UPDATED         --MARCH     2011. USE DPPARS
16354C
16355C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16356C
16357      CHARACTER*4 ICASPL
16358      CHARACTER*4 IAND1
16359      CHARACTER*4 IAND2
16360      CHARACTER*4 IBUGG2
16361      CHARACTER*4 IBUGG3
16362      CHARACTER*4 IBUGQ
16363      CHARACTER*4 ISUBRO
16364      CHARACTER*4 IFOUND
16365      CHARACTER*4 IERROR
16366C
16367      CHARACTER*4 IWRITE
16368      CHARACTER*4 ISUBN1
16369      CHARACTER*4 ISUBN2
16370      CHARACTER*4 ISTEPN
16371C
16372      CHARACTER*40 INAME
16373      PARAMETER (MAXSPN=50)
16374      CHARACTER*4 IVARN1(MAXSPN)
16375      CHARACTER*4 IVARN2(MAXSPN)
16376      CHARACTER*4 IVARTY(MAXSPN)
16377      REAL PVAR(MAXSPN)
16378      INTEGER ILIS(MAXSPN)
16379      INTEGER NRIGHT(MAXSPN)
16380      INTEGER ICOLR(MAXSPN)
16381C
16382C---------------------------------------------------------------------
16383C
16384      INCLUDE 'DPCOPA.INC'
16385C
16386      DIMENSION Z1(MAXOBV)
16387      DIMENSION Z2(MAXOBV)
16388      DIMENSION Z3(MAXOBV)
16389      DIMENSION YSUB(MAXOBV)
16390      DIMENSION YFULL(MAXOBV)
16391      DIMENSION XTEMP(MAXOBV)
16392CCCCC FOLLOWING LINES ADDED JUNE, 1990
16393      INCLUDE 'DPCOZZ.INC'
16394      EQUIVALENCE (GARBAG(IGARB1),Z1(1))
16395      EQUIVALENCE (GARBAG(IGARB2),Z2(1))
16396      EQUIVALENCE (GARBAG(IGARB3),Z3(1))
16397      EQUIVALENCE (GARBAG(IGARB4),YSUB(1))
16398      EQUIVALENCE (GARBAG(IGARB5),YFULL(1))
16399      EQUIVALENCE (GARBAG(IGARB6),XTEMP(1))
16400CCCCC END CHANGE
16401C
16402C-----COMMON----------------------------------------------------------
16403C
16404      INCLUDE 'DPCOHK.INC'
16405      INCLUDE 'DPCODA.INC'
16406      INCLUDE 'DPCOP2.INC'
16407C
16408C-----START POINT-----------------------------------------------------
16409C
16410      IERROR='NO'
16411      ISUBN1='DPST'
16412      ISUBN2='AR  '
16413C
16414      MAXCP1=MAXCOL+1
16415      MAXCP2=MAXCOL+2
16416      MAXCP3=MAXCOL+3
16417      MAXCP4=MAXCOL+4
16418      MAXCP5=MAXCOL+5
16419      MAXCP6=MAXCOL+6
16420C
16421C               ***********************************
16422C               **  TREAT THE STAR PLOT CASE     **
16423C               ***********************************
16424C
16425      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR')THEN
16426        WRITE(ICOUT,999)
16427  999   FORMAT(1X)
16428        CALL DPWRST('XXX','BUG ')
16429        WRITE(ICOUT,51)
16430   51   FORMAT('***** AT THE BEGINNING OF DPSTAR--')
16431        CALL DPWRST('XXX','BUG ')
16432        WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
16433   52   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
16434        CALL DPWRST('XXX','BUG ')
16435        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
16436   53   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
16437        CALL DPWRST('XXX','BUG ')
16438      ENDIF
16439C
16440C               ***************************
16441C               **  STEP 1--             **
16442C               **  EXTRACT THE COMMAND  **
16443C               ***************************
16444C
16445      ISTEPN='11'
16446      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR')
16447     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16448C
16449      ICASPL='STAR'
16450C
16451      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
16452        IFOUND='YES'
16453        ILASTC=1
16454        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
16455      ELSE
16456        IFOUND='NO'
16457        GOTO9000
16458      ENDIF
16459C
16460C               ****************************************
16461C               **  STEP 2--                          **
16462C               **  EXTRACT THE VARIABLE LIST         **
16463C               ****************************************
16464C
16465      ISTEPN='2'
16466      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR')
16467     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16468C
16469      INAME='STAR PLOT'
16470      MINNA=1
16471      MAXNA=100
16472      MINN2=1
16473      IFLAGE=1
16474      IFLAGM=0
16475      IFLAGP=0
16476      JMIN=1
16477      JMAX=NUMARG
16478      MINNVA=1
16479      MAXNVA=MAXSPN
16480C
16481      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
16482     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
16483     1            JMIN,JMAX,
16484     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
16485     1            IVARN1,IVARN2,IVARTY,PVAR,
16486     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
16487     1            MINNVA,MAXNVA,
16488     1            IFLAGM,IFLAGP,
16489     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
16490      IF(IERROR.EQ.'YES')GOTO9000
16491C
16492      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR')THEN
16493        WRITE(ICOUT,999)
16494        CALL DPWRST('XXX','BUG ')
16495        WRITE(ICOUT,281)
16496  281   FORMAT('***** AFTER CALL DPPARS--')
16497        CALL DPWRST('XXX','BUG ')
16498        WRITE(ICOUT,282)NQ,NUMVAR
16499  282   FORMAT('NQ,NUMVAR = ',2I8)
16500        CALL DPWRST('XXX','BUG ')
16501        IF(NUMVAR.GT.0)THEN
16502          DO285I=1,NUMVAR
16503            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
16504     1                      ICOLR(I),IVARTY(I)
16505  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
16506     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
16507            CALL DPWRST('XXX','BUG ')
16508  285     CONTINUE
16509        ENDIF
16510      ENDIF
16511C
16512      IWRITE='OFF'
16513      DO2200K=1,NUMVAR
16514        JF=0
16515        JS=0
16516        IMAX=NRIGHT(K)
16517        IF(NQ.LT.NRIGHT(1))IMAX=NQ
16518        DO2210I=1,IMAX
16519C
16520C         CREATE THE "FULL" VARIABLE
16521C
16522          JF=JF+1
16523          IJ=MAXN*(ICOLR(K)-1)+I
16524          IF(ICOLR(K).LE.MAXCOL)YFULL(JF)=V(IJ)
16525          IF(ICOLR(K).EQ.MAXCP1)YFULL(JF)=PRED(I)
16526          IF(ICOLR(K).EQ.MAXCP2)YFULL(JF)=RES(I)
16527          IF(ICOLR(K).EQ.MAXCP3)YFULL(JF)=YPLOT(I)
16528          IF(ICOLR(K).EQ.MAXCP4)YFULL(JF)=XPLOT(I)
16529          IF(ICOLR(K).EQ.MAXCP5)YFULL(JF)=X2PLOT(I)
16530          IF(ICOLR(K).EQ.MAXCP6)YFULL(JF)=TAGPLO(I)
16531 2210   CONTINUE
16532        NFULL=JF
16533        CALL MINIM(YFULL,NFULL,IWRITE,XMIN,IBUGG3,IERROR)
16534        CALL MAXIM(YFULL,NFULL,IWRITE,XMAX,IBUGG3,IERROR)
16535        Z2(K)=XMIN
16536        Z3(K)=XMAX
16537C
16538C       CREATE THE "SUBSET" VARIABLE
16539C
16540        DO2240I=1,IMAX
16541          IF(ISUB(I).EQ.0)GOTO2240
16542          JS=JS+1
16543          IJ=MAXN*(ICOLR(K)-1)+I
16544C
16545          IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR')THEN
16546             WRITE(ICOUT,2241)I,JS,MAXN,ICOLR(I),IJ,NRIGHT(I),NQ,IMAX
16547 2241        FORMAT('I,JS,MAXN,ICOLR(I),IJ,NRIGHT(I),NQ,IMAX = ',8I8)
16548             CALL DPWRST('XXX','BUG ')
16549          ENDIF
16550C
16551          IF(ICOLR(K).LE.MAXCOL)YSUB(JS)=V(IJ)
16552          IF(ICOLR(K).EQ.MAXCP1)YSUB(JS)=PRED(I)
16553          IF(ICOLR(K).EQ.MAXCP2)YSUB(JS)=RES(I)
16554          IF(ICOLR(K).EQ.MAXCP3)YSUB(JS)=YPLOT(I)
16555          IF(ICOLR(K).EQ.MAXCP4)YSUB(JS)=XPLOT(I)
16556          IF(ICOLR(K).EQ.MAXCP5)YSUB(JS)=X2PLOT(I)
16557          IF(ICOLR(K).EQ.MAXCP6)YSUB(JS)=TAGPLO(I)
16558C
16559 2240   CONTINUE
16560        NSUB=JS
16561C
16562        CALL MEDIAN(YSUB,NSUB,IWRITE,XTEMP,MAXN,XMED,IBUGG3,IERROR)
16563        Z1(K)=XMED
16564C
16565 2200 CONTINUE
16566      NZ=NUMVAR
16567C
16568C               ********************************************************
16569C               **  STEP 31--                                         **
16570C               **  FORM THE VERTICAL AND HORIZONTAL AXIS             **
16571C               **  VALUES Y(.) AND X(.) FOR THE PLOT.                **
16572C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S       **
16573C               **  FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, **
16574C               **  AND THE UPPER CONFIDENCE LINE.                    **
16575C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).     **
16576C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).     **
16577C               ********************************************************
16578C
16579      ISTEPN='8'
16580      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR')
16581     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16582C
16583      CALL DPSTA2(Z1,Z2,Z3,NZ,ICASPL,
16584     1            Y,X,D,NPLOTP,NPLOTV,
16585     1            IBUGG3,ISUBRO,IERROR)
16586C
16587C               *****************
16588C               **  STEP 90--  **
16589C               **  EXIT       **
16590C               *****************
16591C
16592 9000 CONTINUE
16593      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STAR')THEN
16594        WRITE(ICOUT,999)
16595        CALL DPWRST('XXX','BUG ')
16596        WRITE(ICOUT,9011)
16597 9011   FORMAT('***** AT THE END       OF DPPROF--')
16598        CALL DPWRST('XXX','BUG ')
16599        WRITE(ICOUT,9013)IFOUND,IERROR
16600 9013   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
16601        CALL DPWRST('XXX','BUG ')
16602        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
16603 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
16604     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
16605        CALL DPWRST('XXX','BUG ')
16606        WRITE(ICOUT,9021)NSUB,NFULL,NZ,NPLOTP
16607 9021   FORMAT('NSUB,NFULL,NZ,NPLOTP = ',4I8)
16608        CALL DPWRST('XXX','BUG ')
16609        IF(NSUB.GT.0)THEN
16610          DO9022I=1,NSUB
16611            WRITE(ICOUT,9023)I,YSUB(I)
16612 9023       FORMAT('I,YSUB(I) = ',I8,E15.7)
16613            CALL DPWRST('XXX','BUG ')
16614 9022     CONTINUE
16615        ENDIF
16616        IF(NFULL.GT.0)THEN
16617          DO9032I=1,NFULL
16618            WRITE(ICOUT,9033)I,YFULL(I)
16619 9033       FORMAT('I,YFULL(I) = ',I8,E15.7)
16620            CALL DPWRST('XXX','BUG ')
16621 9032     CONTINUE
16622        ENDIF
16623        IF(NZ.GT.0)THEN
16624          DO9042I=1,NZ
16625            WRITE(ICOUT,9043)I,Z1(I),Z2(I),Z3(I)
16626 9043       FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,3G15.7)
16627            CALL DPWRST('XXX','BUG ')
16628 9042     CONTINUE
16629        ENDIF
16630        IF(NPLOTP.GT.0)THEN
16631          DO9052I=1,NPLOTP
16632            WRITE(ICOUT,9053)I,Y(I),X(I),D(I)
16633 9053       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
16634            CALL DPWRST('XXX','BUG ')
16635 9052     CONTINUE
16636        ENDIF
16637      ENDIF
16638C
16639      RETURN
16640      END
16641      SUBROUTINE DPSTAT(ISUBRO,IFOUND,IERROR)
16642C
16643C     PURPOSE--WRITE OUT A STATUS LISTING OF PARAMETERS,
16644C              VARIABLES, AND PLOT SPECIFICATIONS.
16645C     WRITTEN BY--JAMES J. FILLIBEN
16646C                 STATISTICAL ENGINEERING DIVISION
16647C                 INFORMATION TECHNOLOGY LABORATORY
16648C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16649C                 GAITHERSBURG, MD 20899-8980
16650C                 PHONE--301-975-2855
16651C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16652C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16653C     LANGUAGE--ANSI FORTRAN (1977)
16654C     VERSION NUMBER--82/7
16655C     ORIGINAL VERSION--DECEMBER  1977.
16656C     UPDATED         --APRIL     1978.
16657C     UPDATED         --JULY      1978.
16658C     UPDATED         --DECEMBER  1978.
16659C     UPDATED         --MARCH     1979.
16660C     UPDATED         --JULY      1979.
16661C     UPDATED         --NOVEMBER  1980.
16662C     UPDATED         --MARCH     1981.
16663C     UPDATED         --SEPTEMBER 1981.
16664C     UPDATED         --MARCH     1982.
16665C     UPDATED         --MAY       1982.
16666C     UPDATED         --DECEMBER  1991. DIME, VARI, PARA, ETC. ARGS
16667C     UPDATED         --DECEMBER  1991. VARI/PARAM FORMAT STATEMENTS
16668C     UPDATED         --SEPTEMBER 1993. WRITE MESSAGE IF NO VAR.,
16669C                                       PAR. FUNC., ETC.
16670C     UPDATED         --JANUARY   2007. CRASH ON "STATUS LEGEND".
16671C                                       ADD SOME DIMENSION CHECKS TO
16672C                                       AVOID THESE.
16673C     UPDATED         --JULY      2009. FOR "STATUS VARIABLES", PRINT
16674C                                       IN SORTED ORDER
16675C     UPDATED         --SEPTEMBER 2010. LS IS SYNONYM FOR STATUS
16676C     UPDATED         --NOVEMBER  2014. WRITE VARIABLE LIST TO "DPST1F.DAT"
16677C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
16678C     UPDATED         --DECEMBER  2015. ADDITIONAL INFO TO DPST1F.DAT
16679C     UPDATED         --JUNE      2016. SET STATUS DISTINCT SWITCH
16680C     UPDATED         --JUNE      2018. FOR "STATUS V", PRINT NUMBER
16681C                                       OF VARIABLES CURRENTLY ASSIGNED
16682C                                       AND MAXIMUM NUMBER OF VARIABLES
16683C     UPDATED         --JUNE      2018. ADD ROW LABELS, GROUP LABELS,
16684C                                       AND CHARACTER VARIABLES
16685C
16686C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16687C
16688      CHARACTER*4 ISUBRO
16689      CHARACTER*4 IFOUND
16690      CHARACTER*4 IERROR
16691C
16692      INCLUDE 'DPCOPA.INC'
16693C
16694      CHARACTER*4 ISUBN1
16695      CHARACTER*4 ISUBN2
16696      CHARACTER*4 ISTEPN
16697      CHARACTER*4 IOP
16698      CHARACTER*4 IWRITE
16699      CHARACTER*1 CTEMP
16700C
16701CCCCC CHARACTER*80 IFILE
16702      CHARACTER (LEN=MAXFNC) :: IFILE
16703      CHARACTER*12 ISTAT
16704      CHARACTER*12 IFORM
16705      CHARACTER*12 IACCES
16706      CHARACTER*12 IPROT
16707      CHARACTER*12 ICURST
16708      CHARACTER*4 IENDFI
16709      CHARACTER*4 IREWIN
16710      CHARACTER*4 ISUBN0
16711      CHARACTER*4 IERRFI
16712      CHARACTER*8 IH
16713      CHARACTER*8 IHSTR
16714C
16715C---------------------------------------------------------------------
16716C
16717C-----COMMON----------------------------------------------------------
16718C
16719      INCLUDE 'DPCOMC.INC'
16720      INCLUDE 'DPCODB.INC'
16721      INCLUDE 'DPCOHK.INC'
16722      INCLUDE 'DPCOPC.INC'
16723      INCLUDE 'DPCOSU.INC'
16724      INCLUDE 'DPCODA.INC'
16725      INCLUDE 'DPCOHO.INC'
16726      INCLUDE 'DPCOF2.INC'
16727      INCLUDE 'DPCOZZ.INC'
16728      INCLUDE 'DPCOZC.INC'
16729      INCLUDE 'DPCOZI.INC'
16730      INCLUDE 'DPCOST.INC'
16731C
16732      INTEGER INUMEL(MAXNME)
16733C
16734      CHARACTER*4 IJUNK(MAXNME)
16735      CHARACTER*4 IJUNK2(MAXNME)
16736C
16737      DIMENSION TEMP1(MAXOBV)
16738      DIMENSION TEMP2(MAXOBV)
16739C
16740      EQUIVALENCE (GARBAG(IGARB1),TEMP1(1))
16741      EQUIVALENCE (GARBAG(IGARB2),TEMP2(1))
16742      EQUIVALENCE (CGARBG(1),IJUNK(1))
16743      EQUIVALENCE (CGARBG(4*MAXNME+1),IJUNK2(1))
16744      EQUIVALENCE (IGARBG(1),INUMEL(1))
16745C
16746C-----COMMON VARIABLES (GENERAL)--------------------------------------
16747C
16748      INCLUDE 'DPCOP2.INC'
16749C
16750C-----START POINT-----------------------------------------------------
16751C
16752      ISUBN1='DPST'
16753      ISUBN2='AT  '
16754      IFOUND='NO'
16755      IERROR='NO'
16756C
16757      NI=0
16758      NUMELE=0
16759      KMAX=0
16760C
16761      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'STAT')THEN
16762        WRITE(ICOUT,999)
16763  999   FORMAT(1X)
16764        CALL DPWRST('XXX','BUG ')
16765        WRITE(ICOUT,51)
16766   51   FORMAT('AT THE BEGINNING OF DPSTAT--')
16767        CALL DPWRST('XXX','BUG ')
16768        WRITE(ICOUT,53)IBUGS2,ISUBRO,IHARG(1)
16769   53   FORMAT('IBUGS2,ISUBRO,IHARG(1) = ',2(A4,2X),A4)
16770        CALL DPWRST('XXX','BUG ')
16771        WRITE(ICOUT,54)IPR,NUMARG,NUMNAM
16772   54   FORMAT('IPR,NUMARG,NUMNAM = ',3I10)
16773        CALL DPWRST('XXX','BUG ')
16774        DO69I=1,NUMNAM
16775          WRITE(ICOUT,62)I,IHNAME(I),IHNAM2(I),IUSE(I)
16776   62     FORMAT('I,IHNAME,IHNAM2,IUSE   = ',I4,3(A4,1X))
16777          CALL DPWRST('XXX','BUG ')
16778          WRITE(ICOUT,63)IN(I),IVALUE(I),IVALU2(I)
16779   63     FORMAT('IN,IVALUE,IVALU2  = ',3I8)
16780          CALL DPWRST('XXX','BUG ')
16781          WRITE(ICOUT,64)IVSTAR(I),IVSTOP(I),VALUE(I)
16782   64     FORMAT('IVSTAR,IVSTOP,VALUE     = ',2I8,G15.7)
16783          CALL DPWRST('XXX','BUG ')
16784   69   CONTINUE
16785      ENDIF
16786C
16787C               *****************************
16788C               **  TREAT THE STATUS CASE  **
16789C               *****************************
16790C
16791      IFOUND='YES'
16792C
16793C               *********************************************
16794C               **  STEP 10--                               **
16795C               **  PRINT OUT DETAILED STATUS INFORMATION  **
16796C               *********************************************
16797C
16798C               ****************************************
16799C               **  STEP 11--                         **
16800C               **  TREAT THE MACHINE CONSTANTS CASE  **
16801C               ****************************************
16802C
16803      IF(IHARG(1).EQ.'MACH' .OR. IHARG(1).EQ.'COMP' .OR.
16804     1   IHARG(1).EQ.'SITE' .OR. IHARG(1).EQ.'HOST')THEN
16805C
16806        ISTEPN='11'
16807        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
16808     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16809C
16810        WRITE(ICOUT,999)
16811        CALL DPWRST('XXX','WRIT')
16812        WRITE(ICOUT,999)
16813        CALL DPWRST('XXX','WRIT')
16814        WRITE(ICOUT,1111)
16815 1111   FORMAT('STATUS OF MACHINE CONSTANTS--')
16816        CALL DPWRST('XXX','WRIT')
16817C
16818        WRITE(ICOUT,999)
16819        CALL DPWRST('XXX','WRIT')
16820        WRITE(ICOUT,1112)IHOST1,IHOST2
16821 1112   FORMAT('IHOST1,IHOST2  (HOST) = ',A4,2X,A4)
16822        CALL DPWRST('XXX','WRIT')
16823        WRITE(ICOUT,1113)IHMOD1,IHMOD2
16824 1113   FORMAT('IHMOD1,IHMOD2 (MODEL) = ',A4,2X,A4)
16825        CALL DPWRST('XXX','WRIT')
16826        WRITE(ICOUT,1114)IOPSY1,IOPSY2
16827 1114   FORMAT('IOPSY1,IOPSY2 (OPERATING SYSTEM) = ',A4,2X,A4)
16828        CALL DPWRST('XXX','WRIT')
16829        WRITE(ICOUT,1115)ICOMPI
16830 1115   FORMAT('ICOMPI        (COMPILER) = ',A4)
16831        CALL DPWRST('XXX','WRIT')
16832        WRITE(ICOUT,1116)ISITE
16833 1116   FORMAT('ISITE         (SITE) = ',A4)
16834        CALL DPWRST('XXX','WRIT')
16835C
16836        WRITE(ICOUT,999)
16837        CALL DPWRST('XXX','WRIT')
16838        WRITE(ICOUT,1123)IPR,IRD,CPUMIN,CPUMAX
16839 1123   FORMAT('IPR,IRD,CPUMIN,CPUMAX = ',2I6,2E15.7)
16840        CALL DPWRST('XXX','WRIT')
16841        WRITE(ICOUT,1124)NUMBPC,NUMCPW,NUMBPW
16842 1124   FORMAT('NUMBPC,NUMCPW,NUMBPW = ',3I6)
16843        CALL DPWRST('XXX','WRIT')
16844C
16845        WRITE(ICOUT,999)
16846        CALL DPWRST('XXX','WRIT')
16847        DO1130I=1,16
16848          IF(NUMBPW.LT.32)THEN
16849            WRITE(ICOUT,1131)I,I1MACH(I)
16850 1131       FORMAT('I,I1MACH(I) = ',I8,2X,I8)
16851            CALL DPWRST('XXX','WRIT')
16852          ELSEIF(NUMBPW.EQ.32)THEN
16853            WRITE(ICOUT,1132)I,I1MACH(I)
16854 1132       FORMAT('I,I1MACH(I) = ',I8,2X,I11)
16855            CALL DPWRST('XXX','WRIT')
16856          ELSEIF(NUMBPW.EQ.36)THEN
16857            WRITE(ICOUT,1133)I,I1MACH(I)
16858 1133       FORMAT('I,I1MACH(I) = ',I8,2X,I12)
16859            CALL DPWRST('XXX','WRIT')
16860          ELSEIF(NUMBPW.EQ.48)THEN
16861            WRITE(ICOUT,1134)I,I1MACH(I)
16862 1134       FORMAT('I,I1MACH(I) = ',I8,2X,I16)
16863            CALL DPWRST('XXX','WRIT')
16864          ELSEIF(NUMBPW.GE.60)THEN
16865            WRITE(ICOUT,1135)I,I1MACH(I)
16866 1135       FORMAT('I,I1MACH(I) = ',I8,2X,I20)
16867            CALL DPWRST('XXX','WRIT')
16868          ELSE
16869            WRITE(ICOUT,1136)I,I1MACH(I)
16870 1136       FORMAT('I,I1MACH(I) = ',I8,2X,I8)
16871            CALL DPWRST('XXX','WRIT')
16872          ENDIF
16873 1130   CONTINUE
16874C
16875        WRITE(ICOUT,999)
16876        CALL DPWRST('XXX','WRIT')
16877        DO1140I=1,5
16878          WRITE(ICOUT,1141)I,R1MACH(I)
16879 1141     FORMAT('I,R1MACH(I)  = ',I8,2X,E15.7)
16880          CALL DPWRST('XXX','WRIT')
16881 1140   CONTINUE
16882C
16883        WRITE(ICOUT,999)
16884        CALL DPWRST('XXX','WRIT')
16885        DO1150I=1,5
16886          WRITE(ICOUT,1151)I,D1MACH(I)
16887 1151     FORMAT('I,D1MACH(I)  = ',I8,2X,D15.7)
16888          CALL DPWRST('XXX','WRIT')
16889 1150   CONTINUE
16890C
16891        GOTO9000
16892C
16893C               ***************************
16894C               **  STEP 12--            **
16895C               **  TREAT THE FILE CASE  **
16896C               ***************************
16897C
16898      ELSEIF(IHARG(1).EQ.'FILE' .OR. IHARG(1).EQ.'I/O')THEN
16899C
16900        ISTEPN='12'
16901        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
16902     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16903C
16904        WRITE(ICOUT,999)
16905        CALL DPWRST('XXX','WRIT')
16906        WRITE(ICOUT,999)
16907        CALL DPWRST('XXX','WRIT')
16908        WRITE(ICOUT,1211)
16909 1211   FORMAT('STATUS OF FILES--')
16910        CALL DPWRST('XXX','WRIT')
16911        WRITE(ICOUT,999)
16912        CALL DPWRST('XXX','WRIT')
16913        WRITE(ICOUT,1253)IPR,IRD,CPUMIN,CPUMAX
16914 1253   FORMAT('IPR,IRD,CPUMIN,CPUMAX = ',2I6,2E15.7)
16915        CALL DPWRST('XXX','WRIT')
16916        WRITE(ICOUT,1254)NUMBPC,NUMCPW,NUMBPW
16917 1254   FORMAT('NUMBPC,NUMCPW,NUMBPW = ',3I6)
16918        CALL DPWRST('XXX','WRIT')
16919        WRITE(ICOUT,999)
16920        CALL DPWRST('XXX','WRIT')
16921        WRITE(ICOUT,1261)IMESNU,IMESST,IMESNA
16922 1261   FORMAT('IMESNU,IMESST,IMESNA = ',I8,2X,A12,2X,A80)
16923        CALL DPWRST('XXX','WRIT')
16924        WRITE(ICOUT,1262)INEWNU,INEWST,INEWNA
16925 1262   FORMAT('INEWNU,INEWST,INEWNA = ',I8,2X,A12,2X,A80)
16926        CALL DPWRST('XXX','WRIT')
16927        WRITE(ICOUT,1264)IHELNU,IHELST,IHELNA
16928 1264   FORMAT('IHELNU,IHELST,IHELNA = ',I8,2X,A12,2X,A80)
16929        CALL DPWRST('XXX','WRIT')
16930        WRITE(ICOUT,1265)IBUGNU,IBUGST,IBUGNA
16931 1265   FORMAT('IBUGNU,IBUGST,IBUGNA = ',I8,2X,A12,2X,A80)
16932        CALL DPWRST('XXX','WRIT')
16933        WRITE(ICOUT,1267)ISYSNU,ISYSST,ISYSNA
16934 1267   FORMAT('ISYSNU,ISYSST,ISYSNA = ',I8,2X,A12,2X,A80)
16935        CALL DPWRST('XXX','WRIT')
16936        WRITE(ICOUT,1268)ILOGNU,ILOGST,ILOGNA
16937 1268   FORMAT('ILOGNU,ILOGST,ILOGNA = ',I8,2X,A12,2X,A80)
16938        CALL DPWRST('XXX','WRIT')
16939        WRITE(ICOUT,1271)IREANU,IREAST,IREANA
16940 1271   FORMAT('IREANU,IREAST,IREANA = ',I8,2X,A12,2X,A80)
16941        CALL DPWRST('XXX','WRIT')
16942        WRITE(ICOUT,1272)IWRINU,IWRIST,IWRINA
16943 1272   FORMAT('IWRINU,IWRIST,IWRINA = ',I8,2X,A12,2X,A80)
16944        CALL DPWRST('XXX','WRIT')
16945        WRITE(ICOUT,1273)ISAVNU,ISAVST,ISAVNA
16946 1273   FORMAT('ISAVNU,ISAVST,ISAVNA = ',I8,2X,A12,2X,A80)
16947        CALL DPWRST('XXX','WRIT')
16948        WRITE(ICOUT,1274)ICRENU,ICREST,ICRENA
16949 1274   FORMAT('ICRENU,ICREST,ICRENA = ',I8,2X,A12,2X,A80)
16950        CALL DPWRST('XXX','WRIT')
16951CCCCC   WRITE(ICOUT,1275)IMACNU,IMACST,IMACNA
16952C1275   FORMAT('IMACNU,IMACST,IMACNA = ',I8,2X,A12,2X,A80)
16953CCCCC   CALL DPWRST('XXX','WRIT')
16954        WRITE(ICOUT,1276)ISCRNU,ISCRST,ISCRNA
16955 1276   FORMAT('ISCRNU,ISCRST,ISCRNA = ',I8,2X,A12,2X,A80)
16956        CALL DPWRST('XXX','WRIT')
16957        WRITE(ICOUT,1277)IDATNU,IDATST,IDATNA
16958 1277   FORMAT('IDATNU,IDATST,IDATNA = ',I8,2X,A12,2X,A80)
16959        CALL DPWRST('XXX','WRIT')
16960        WRITE(ICOUT,1278)IPL1NU,IPL1ST,IPL1NA
16961 1278   FORMAT('IPL1NU,IPL1ST,IPL1NA = ',I8,2X,A12,2X,A80)
16962        CALL DPWRST('XXX','WRIT')
16963        WRITE(ICOUT,1279)IPL2NU,IPL2ST,IPL2NA
16964 1279   FORMAT('IPL2NU,IPL2ST,IPL2NA = ',I8,2X,A12,2X,A80)
16965        CALL DPWRST('XXX','WRIT')
16966        WRITE(ICOUT,1280)IPRONU,IPROST,IPRONA
16967 1280   FORMAT('IPRONU,IPROST,IPRONA = ',I8,2X,A12,2X,A80)
16968        CALL DPWRST('XXX','WRIT')
16969        WRITE(ICOUT,1281)ICONNU,ICONST,ICONNA
16970 1281   FORMAT('ICONNU,ICONST,ICONNA = ',I8,2X,A12,2X,A80)
16971        CALL DPWRST('XXX','WRIT')
16972        WRITE(ICOUT,999)
16973        CALL DPWRST('XXX','WRIT')
16974        GOTO9000
16975C
16976C               *****************************
16977C               **  STEP 21--              **
16978C               **  TREAT THE ARROWS CASE  **
16979C               *****************************
16980C
16981      ELSEIF(IHARG(1).EQ.'ARRO')THEN
16982C
16983        ISTEPN='21'
16984        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
16985     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16986C
16987        WRITE(ICOUT,999)
16988        CALL DPWRST('XXX','WRIT')
16989        WRITE(ICOUT,999)
16990        CALL DPWRST('XXX','WRIT')
16991        WRITE(ICOUT,2111)
16992 2111   FORMAT('STATUS OF ARROWS--')
16993        CALL DPWRST('XXX','WRIT')
16994        WRITE(ICOUT,999)
16995        CALL DPWRST('XXX','WRIT')
16996        WRITE(ICOUT,2112)NUMARR
16997 2112   FORMAT('       NUMBER OF ARROWS = ',I8)
16998        CALL DPWRST('XXX','WRIT')
16999C
17000CCCCC   THE FOLLOWING LINE WAS CHANGED    SEPTEMBER 1993
17001CCCCC   IF(NUMARR.LE.0)GOTO2180
17002        IF(NUMARR.LE.0)THEN
17003           WRITE(ICOUT,999)
17004           CALL DPWRST('XXX','WRIT')
17005           WRITE(ICOUT,2105)
17006 2105      FORMAT('NO ARROWS DEFINED')
17007           CALL DPWRST('XXX','WRIT')
17008        ELSE
17009C
17010          WRITE(ICOUT,999)
17011          CALL DPWRST('XXX','WRIT')
17012          DO2115I=1,NUMARR
17013            IF(PARRXC(I,1).LT.0.0.OR.PARRXC(I,1).GT.100.0)GOTO2115
17014            IF(PARRYC(I,1).LT.0.0.OR.PARRYC(I,1).GT.100.0)GOTO2115
17015            IF(PARRXC(I,2).LT.0.0.OR.PARRXC(I,2).GT.100.0)GOTO2115
17016            IF(PARRYC(I,2).LT.0.0.OR.PARRYC(I,2).GT.100.0)GOTO2115
17017            WRITE(ICOUT,2116)I,PARRXC(I,1),PARRYC(I,1),PARRXC(I,2),
17018     1                       PARRYC(I,2)
17019 2116       FORMAT('       ARROW   ',I8,' COORDINATES       --',4F10.4)
17020            CALL DPWRST('XXX','WRIT')
17021 2115     CONTINUE
17022C
17023          WRITE(ICOUT,999)
17024          CALL DPWRST('XXX','WRIT')
17025          DO2125I=1,NUMARR
17026            WRITE(ICOUT,2126)I,IARRCO(I)
17027 2126       FORMAT('       ARROW   ',I8,' COLOR             --',A4)
17028            CALL DPWRST('XXX','WRIT')
17029 2125     CONTINUE
17030C
17031        ENDIF
17032C
17033        GOTO9000
17034C
17035C               *******************************
17036C               **  STEP 22--                **
17037C               **  TREAT THE SEGMENTS CASE  **
17038C               *******************************
17039C
17040      ELSEIF(IHARG(1).EQ.'SEGM')THEN
17041C
17042        ISTEPN='22'
17043        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17044     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17045C
17046        WRITE(ICOUT,999)
17047        CALL DPWRST('XXX','WRIT')
17048        WRITE(ICOUT,999)
17049        CALL DPWRST('XXX','WRIT')
17050        WRITE(ICOUT,2211)
17051 2211   FORMAT('STATUS OF SEGMENTS--')
17052        CALL DPWRST('XXX','WRIT')
17053        WRITE(ICOUT,999)
17054        CALL DPWRST('XXX','WRIT')
17055        WRITE(ICOUT,2212)NUMSEG
17056 2212   FORMAT('       NUMBER OF SEGMENTS = ',I8)
17057        CALL DPWRST('XXX','WRIT')
17058C
17059CCCCC   THE FOLLOWING LINE WAS CHANGED    SEPTEMBER 1993
17060CCCCC   IF(NUMSEG.LE.0)GOTO2280
17061        IF(NUMSEG.LE.0)THEN
17062           WRITE(ICOUT,999)
17063           CALL DPWRST('XXX','WRIT')
17064           WRITE(ICOUT,2205)
17065 2205      FORMAT('NO SEGMENTS DEFINED')
17066           CALL DPWRST('XXX','WRIT')
17067        ELSE
17068C
17069          WRITE(ICOUT,999)
17070          CALL DPWRST('XXX','WRIT')
17071          DO2215I=1,NUMSEG
17072            IF(PSEGXC(I,1).LT.0.0.OR.PSEGXC(I,1).GT.100.0)GOTO2215
17073            IF(PSEGYC(I,1).LT.0.0.OR.PSEGYC(I,1).GT.100.0)GOTO2215
17074            IF(PSEGXC(I,2).LT.0.0.OR.PSEGXC(I,2).GT.100.0)GOTO2215
17075            IF(PSEGYC(I,2).LT.0.0.OR.PSEGYC(I,2).GT.100.0)GOTO2215
17076            WRITE(ICOUT,2216)I,PSEGXC(I,1),PSEGYC(I,1),PSEGXC(I,2),
17077     1                       PSEGYC(I,2)
17078 2216       FORMAT('       SEGMENT ',I8,' COORDINATES       --',4F10.4)
17079            CALL DPWRST('XXX','WRIT')
17080 2215     CONTINUE
17081C
17082          WRITE(ICOUT,999)
17083          CALL DPWRST('XXX','WRIT')
17084          DO2225I=1,NUMSEG
17085            WRITE(ICOUT,2226)I,ISEGCO(I)
17086 2226       FORMAT('       SEGMENT ',I8,' COLOR             --',A4)
17087            CALL DPWRST('XXX','WRIT')
17088 2225     CONTINUE
17089        ENDIF
17090C
17091        GOTO9000
17092C
17093C               ******************************
17094C               **  STEP 23--               **
17095C               **  TREAT THE LEGENDS CASE  **
17096C               ******************************
17097C
17098      ELSEIF(IHARG(1).EQ.'LEGE')THEN
17099C
17100        ISTEPN='23'
17101        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17102     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17103C
17104        WRITE(ICOUT,999)
17105        CALL DPWRST('XXX','WRIT')
17106        WRITE(ICOUT,999)
17107        CALL DPWRST('XXX','WRIT')
17108        WRITE(ICOUT,2311)
17109 2311   FORMAT('STATUS OF LEGENDS--')
17110        CALL DPWRST('XXX','WRIT')
17111        WRITE(ICOUT,999)
17112        CALL DPWRST('XXX','WRIT')
17113        WRITE(ICOUT,2312)NUMLEG
17114 2312   FORMAT('       NUMBER OF LEGENDS = ',I8)
17115        CALL DPWRST('XXX','WRIT')
17116C
17117CCCCC   THE FOLLOWING LINE WAS CHANGED    SEPTEMBER 1993
17118CCCCC   IF(NUMLEG.LE.0)GOTO2380
17119        IF(NUMLEG.LE.0)THEN
17120          WRITE(ICOUT,999)
17121          CALL DPWRST('XXX','WRIT')
17122          WRITE(ICOUT,2305)
17123 2305     FORMAT('NO LEGENDS DEFINED')
17124          CALL DPWRST('XXX','WRIT')
17125        ELSE
17126C
17127          WRITE(ICOUT,999)
17128          CALL DPWRST('XXX','WRIT')
17129          DO2315I=1,NUMLEG
17130            JMIN=ILEGST(I)
17131            JMAX=ILEGSP(I)
17132            JLENGT=JMAX-JMIN+1
17133            IF(JLENGT.LE.100)THEN
17134              JSTOP=JMAX
17135            ELSE
17136              JSTOP=JMIN+99
17137            ENDIF
17138            IF(JSTOP.GE.JMIN)THEN
17139              WRITE(ICOUT,2316)I,(ILEGTE(J),J=JMIN,JSTOP)
17140 2316         FORMAT('       LEGEND  ',I8,'--',100A1)
17141              CALL DPWRST('XXX','WRIT')
17142            ENDIF
17143 2315     CONTINUE
17144C
17145          WRITE(ICOUT,999)
17146          CALL DPWRST('XXX','WRIT')
17147          DO2325I=1,NUMLEG
17148            IF(PLEGXC(I).LT.0.0.OR.PLEGXC(I).GT.100.0)GOTO2325
17149            IF(PLEGYC(I).LT.0.0.OR.PLEGYC(I).GT.100.0)GOTO2325
17150            WRITE(ICOUT,2326)I,PLEGXC(I),PLEGYC(I)
17151 2326       FORMAT('       LEGEND  ',I8,' COORDINATES       --',2F10.4)
17152            CALL DPWRST('XXX','WRIT')
17153 2325     CONTINUE
17154C
17155          WRITE(ICOUT,999)
17156          CALL DPWRST('XXX','WRIT')
17157          DO2335I=1,NUMLEG
17158            WRITE(ICOUT,2336)I,ILEGCO(I)
17159 2336       FORMAT('       LEGEND  ',I8,' COLOR             --',A4)
17160            CALL DPWRST('XXX','WRIT')
17161 2335     CONTINUE
17162        ENDIF
17163C
17164        GOTO9000
17165C
17166C               ****************************
17167C               **  STEP 24--             **
17168C               **  TREAT THE BOXES CASE  **
17169C               ****************************
17170C
17171      ELSEIF(IHARG(1).EQ.'BOXE' .OR. IHARG(1).EQ.'BOX')THEN
17172C
17173        ISTEPN='24'
17174        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17175     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17176C
17177        WRITE(ICOUT,999)
17178        CALL DPWRST('XXX','WRIT')
17179        WRITE(ICOUT,999)
17180        CALL DPWRST('XXX','WRIT')
17181        WRITE(ICOUT,2411)
17182 2411   FORMAT('STATUS OF BOXES--')
17183        CALL DPWRST('XXX','WRIT')
17184        WRITE(ICOUT,999)
17185        CALL DPWRST('XXX','WRIT')
17186        WRITE(ICOUT,2412)NUMBOX
17187 2412   FORMAT('       NUMBER OF BOXES = ',I8)
17188        CALL DPWRST('XXX','WRIT')
17189C
17190CCCCC   THE FOLLOWING LINE WAS CHANGED    SEPTEMBER 1993
17191CCCCC   IF(NUMBOX.LE.0)GOTO2480
17192        IF(NUMBOX.LE.0)THEN
17193          WRITE(ICOUT,999)
17194          CALL DPWRST('XXX','WRIT')
17195          WRITE(ICOUT,2405)
17196 2405     FORMAT('NO BOXES DEFINED')
17197          CALL DPWRST('XXX','WRIT')
17198        ELSE
17199C
17200          WRITE(ICOUT,999)
17201          CALL DPWRST('XXX','WRIT')
17202          DO2415I=1,NUMBOX
17203            IF(PBOXXC(I,1).LT.0.0.OR.PBOXXC(I,1).GT.100.0)GOTO2415
17204            IF(PBOXYC(I,1).LT.0.0.OR.PBOXYC(I,1).GT.100.0)GOTO2415
17205            IF(PBOXXC(I,2).LT.0.0.OR.PBOXXC(I,2).GT.100.0)GOTO2415
17206            IF(PBOXYC(I,2).LT.0.0.OR.PBOXYC(I,2).GT.100.0)GOTO2415
17207            WRITE(ICOUT,2416)I,PBOXXC(I,1),PBOXYC(I,1),PBOXXC(I,2),
17208     1                       PBOXYC(I,2)
17209 2416       FORMAT('       BOX     ',I8,' CORNER COORDINATES--',4F10.4)
17210            CALL DPWRST('XXX','WRIT')
17211 2415     CONTINUE
17212C
17213          WRITE(ICOUT,999)
17214          CALL DPWRST('XXX','WRIT')
17215          DO2425I=1,NUMBOX
17216            WRITE(ICOUT,2426)I,IBOPCO(I)
17217 2426       FORMAT('       BOX     ',I8,' COLOR             --',A4)
17218            CALL DPWRST('XXX','WRIT')
17219 2425     CONTINUE
17220        ENDIF
17221C
17222        GOTO9000
17223C
17224C               ****************************
17225C               **  STEP 31--             **
17226C               **  TREAT THE SPIKE CASE  **
17227C               ****************************
17228C
17229      ELSEIF(IHARG(1).EQ.'SPIK' .OR. IHARG(1).EQ.'S   ')THEN
17230C
17231        ISTEPN='31'
17232        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17233     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17234C
17235        WRITE(ICOUT,999)
17236        CALL DPWRST('XXX','WRIT')
17237        WRITE(ICOUT,999)
17238        CALL DPWRST('XXX','WRIT')
17239        WRITE(ICOUT,3111)
17240 3111   FORMAT('STATUS OF SPIKE SETTINGS--')
17241        CALL DPWRST('XXX','WRIT')
17242        WRITE(ICOUT,999)
17243        CALL DPWRST('XXX','WRIT')
17244        WRITE(ICOUT,999)
17245        CALL DPWRST('XXX','WRIT')
17246        WRITE(ICOUT,3112)
17247 3112   FORMAT('   SET       SPIKE     SPIKE     SPIKE     SPIKE  ',
17248     1         '    SPIKE  ')
17249        CALL DPWRST('XXX','WRIT')
17250        WRITE(ICOUT,3113)
17251 3113   FORMAT('  INDEX     SWITCH     LINE      COLOR   THICKNESS',
17252     1         '    BASE   ')
17253        CALL DPWRST('XXX','WRIT')
17254        WRITE(ICOUT,999)
17255        CALL DPWRST('XXX','WRIT')
17256        IMAX=10
17257CCCCC   IF(NUMSET.GT.IMAX)IMAX=NUMSET
17258        DO3120I=1,IMAX
17259          WRITE(ICOUT,3121)I,ISPISW(I),ISPILI(I),ISPICO(I),PSPITH(I),
17260     1                     ASPIBA(I)
17261 3121     FORMAT(I5,8X,A4,6X,A4,6X,A4,6X,F7.3,3X,E15.7)
17262          CALL DPWRST('XXX','WRIT')
17263 3120   CONTINUE
17264        WRITE(ICOUT,3122)IDEFSS,IDEFSL,IDEFSC,PDEFST,ADEFSB
17265 3122   FORMAT('DEFAULT',6X,A4,6X,A4,6X,A4,6X,F7.3,3X,E15.7)
17266        CALL DPWRST('XXX','WRIT')
17267        WRITE(ICOUT,999)
17268        CALL DPWRST('XXX','WRIT')
17269C
17270        GOTO9000
17271C
17272C               ****************************
17273C               **  STEP 32--             **
17274C               **  TREAT THE BAR   CASE  **
17275C               ****************************
17276C
17277      ELSEIF(IHARG(1).EQ.'BAR ' .OR. IHARG(1).EQ.'BARS' .OR.
17278     1       IHARG(1).EQ.'B   ')THEN
17279C
17280        ISTEPN='32'
17281        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17282     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17283C
17284        WRITE(ICOUT,999)
17285        CALL DPWRST('XXX','WRIT')
17286        WRITE(ICOUT,999)
17287        CALL DPWRST('XXX','WRIT')
17288        WRITE(ICOUT,3211)
17289 3211   FORMAT('STATUS OF BAR SETTINGS--')
17290        CALL DPWRST('XXX','WRIT')
17291        WRITE(ICOUT,999)
17292        CALL DPWRST('XXX','WRIT')
17293        WRITE(ICOUT,999)
17294        CALL DPWRST('XXX','WRIT')
17295        WRITE(ICOUT,3212)
17296 3212   FORMAT('   SET       BAR       BAR       BAR       BAR   ',
17297     1         '        BAR   ')
17298        CALL DPWRST('XXX','WRIT')
17299        WRITE(ICOUT,3213)
17300 3213   FORMAT('  INDEX     SWITCH     FILL   DIMENSION  PATTERN',
17301     1         '         BASE ')
17302        CALL DPWRST('XXX','WRIT')
17303        WRITE(ICOUT,999)
17304        CALL DPWRST('XXX','WRIT')
17305        IMAX=10
17306CCCCC   IF(NUMSET.GT.IMAX)IMAX=NUMSET
17307        DO3220I=1,IMAX
17308          WRITE(ICOUT,3221)I,IBARSW(I),IBAFSW(I),IBARTY(I),IBAPTY(I),
17309     1                     ABARBA(I)
17310 3221     FORMAT(I5,8X,A4,6X,A4,6X,A4,6X,A4,6X,E15.7)
17311          CALL DPWRST('XXX','WRIT')
17312 3220   CONTINUE
17313        WRITE(ICOUT,3222)IDEBSW,IDEBFS,IDEBTY,IDEBPT,ADEBBA
17314 3222   FORMAT('DEFAULT',6X,A4,6X,A4,6X,A4,6X,A4,6X,E15.7)
17315        CALL DPWRST('XXX','WRIT')
17316        WRITE(ICOUT,999)
17317        CALL DPWRST('XXX','WRIT')
17318C
17319        GOTO9000
17320C
17321      ENDIF
17322C
17323C               *************************************
17324C               **  STEP 70--                      **
17325C               **  TREAT THE GENERAL STATUS CASE  **
17326C               *************************************
17327C
17328C               *****************************
17329C               **  STEP 70.1--            **
17330C               **  PRINT OUT A            **
17331C               **  STORAGE SUMMARY TABLE  **
17332C               *****************************
17333C
17334      ISTEPN='70.1'
17335      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17336     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17337C
17338CCCCC THE FOLLOWING 4 LINES WERE ADDED     DECEMBER 1991
17339      IF(NUMARG.LE.0 .OR.
17340     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'DIME') .OR.
17341     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'D   '))THEN
17342C
17343        NUMN=0
17344        DO110I=1,NUMNAM
17345          IF(IHNAME(I).EQ.'PRED')GOTO110
17346          IF(IHNAME(I).EQ.'RES')GOTO110
17347          IF(IHNAME(I).EQ.'YPLO')GOTO110
17348          IF(IHNAME(I).EQ.'XPLO')GOTO110
17349          IF(IHNAME(I).EQ.'X2PL')GOTO110
17350          IF(IHNAME(I).EQ.'TAGP')GOTO110
17351          IF(IUSE(I).EQ.'V')NI=IN(I)
17352          IF(NI.GT.NUMN)NUMN=NI
17353  110   CONTINUE
17354C
17355        NUMNK=MAXN*NUMCOL
17356        IDELCO=MAXCOL-NUMCOL
17357        IDELN=MAXN-NUMN
17358        IDELNK=MAXNK-NUMNK
17359        IDELCF=MAXCHF-NUMCHF
17360        IDELNA=MAXNAM-NUMNAM
17361C
17362        WRITE(ICOUT,999)
17363        CALL DPWRST('XXX','WRIT')
17364        WRITE(ICOUT,131)
17365  131   FORMAT('******************************************************')
17366        CALL DPWRST('XXX','WRIT')
17367        WRITE(ICOUT,132)
17368  132   FORMAT('*                STORAGE INFORMATION                 *')
17369        CALL DPWRST('XXX','WRIT')
17370        WRITE(ICOUT,131)
17371        CALL DPWRST('XXX','WRIT')
17372        WRITE(ICOUT,133)
17373  133   FORMAT('* NUMBER OF ...      *  MAXIMUM  * UNUSED  *   USED  *')
17374        CALL DPWRST('XXX','WRIT')
17375        WRITE(ICOUT,131)
17376        CALL DPWRST('XXX','WRIT')
17377        WRITE(ICOUT,141)MAXCOL,IDELCO,NUMCOL
17378  141   FORMAT('* VARIABLES (COLUMNS)*',I9,'  *',I7,'  *',I7,'  *')
17379        CALL DPWRST('XXX','WRIT')
17380        WRITE(ICOUT,142)MAXN,IDELN,NUMN
17381  142   FORMAT('* OBS PER VARIABLE   *',I9,'  *',I7,'  *',I7,'  *')
17382        CALL DPWRST('XXX','WRIT')
17383        WRITE(ICOUT,143)MAXNK,IDELNK,NUMNK
17384  143   FORMAT('* OBS (TOTAL)        *',I9,'  *',I7,'  *',I7,'  *')
17385        CALL DPWRST('XXX','WRIT')
17386        WRITE(ICOUT,144)MAXCHF,IDELCF,NUMCHF
17387  144   FORMAT('* FUNC CHAR (TOTAL)  *',I9,'  *',I7,'  *',I7,'  *')
17388        CALL DPWRST('XXX','WRIT')
17389        WRITE(ICOUT,145)MAXNAM,IDELNA,NUMNAM
17390  145   FORMAT('* VAR/PAR/FUNC NAMES *',I9,'  *',I7,'  *',I7,'  *')
17391        CALL DPWRST('XXX','WRIT')
17392        WRITE(ICOUT,131)
17393        CALL DPWRST('XXX','WRIT')
17394CCCCC   THE FOLLOWING LINE WAS ADDED    DECEMBER 1991
17395       ENDIF
17396C
17397C               *******************************
17398C               **  STEP 70.2--              **
17399C               **  PRINT OUT PLOT LINE,     **
17400C               **  PLOT CHARACTER, AND      **
17401C               **  PLOT LIMITS INFORMATION  **
17402C               *******************************
17403C
17404      ISTEPN='70.2'
17405      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17406     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17407C
17408CCCCC THE FOLLOWING 4 LINES WERE ADDED     DECEMBER 1991
17409      IF(NUMARG.LE.0 .OR.
17410     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR'.AND.IHARG(2).NE.'VARI') .OR.
17411     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'C   ') .OR.
17412     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'LINE') .OR.
17413     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'L   '))THEN
17414C
17415        WRITE(ICOUT,999)
17416        CALL DPWRST('XXX','WRIT')
17417        WRITE(ICOUT,999)
17418        CALL DPWRST('XXX','WRIT')
17419        WRITE(ICOUT,211)
17420  211   FORMAT('   SET       PLOT      PLOT      PLOT      PLOT   ',
17421     1         '    PLOT  ')
17422        CALL DPWRST('XXX','WRIT')
17423        WRITE(ICOUT,212)
17424  212   FORMAT('  INDEX      LINE      LINE    CHARACTER CHARACTER',
17425     1         ' CHARACTER')
17426        CALL DPWRST('XXX','WRIT')
17427        WRITE(ICOUT,213)
17428  213   FORMAT('             TYPE      COLOR     TYPE      COLOR  ',
17429     1         '    SIZE  ')
17430        CALL DPWRST('XXX','WRIT')
17431        WRITE(ICOUT,999)
17432        CALL DPWRST('XXX','WRIT')
17433        IMAX=10
17434CCCCC   IF(NUMSET.GT.IMAX)IMAX=NUMSET
17435        DO220I=1,IMAX
17436          WRITE(ICOUT,221)I,ILINPA(I),ILINCO(I),ICHAPA(I),ICHACO(I),
17437     1                    PCHAHE(I)
17438  221     FORMAT(I5,8X,A4,6X,A4,6X,A24,6X,A4,4X,F7.3)
17439          CALL DPWRST('XXX','WRIT')
17440  220   CONTINUE
17441C
17442        WRITE(ICOUT,999)
17443        CALL DPWRST('XXX','WRIT')
17444        WRITE(ICOUT,231)FX1MIN
17445  231   FORMAT('X-AXIS PLOT MINIMUM = ',E15.7)
17446        CALL DPWRST('XXX','WRIT')
17447        WRITE(ICOUT,232)FX1MAX
17448  232   FORMAT('X-AXIS PLOT MAXIMUM = ',E15.7)
17449        CALL DPWRST('XXX','WRIT')
17450        WRITE(ICOUT,233)FY1MIN
17451  233   FORMAT('Y-AXIS PLOT MINIMUM = ',E15.7)
17452        CALL DPWRST('XXX','WRIT')
17453        WRITE(ICOUT,234)FY1MAX
17454  234   FORMAT('Y-AXIS PLOT MAXIMUM = ',E15.7)
17455        CALL DPWRST('XXX','WRIT')
17456      ENDIF
17457C
17458C               ***************************************
17459C               **  STEP 70.3--                      **
17460C               **  PRINT OUT VARIABLES INFORMATION  **
17461C               ***************************************
17462C
17463      ISTEPN='70.3'
17464      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17465     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17466C
17467      IF(NUMARG.LE.0 .OR.
17468     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'VARI') .OR.
17469     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'VAR ') .OR.
17470     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'V   '))THEN
17471C
17472        IOP='OPEN'
17473        IFLG1=1
17474        IFLG2=0
17475        IFLG3=0
17476        IFLG4=0
17477        IFLG5=0
17478        CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
17479     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17480     1              IBUGA3,ISUBRO,IERROR)
17481        IF(IERROR.EQ.'YES')GOTO9000
17482C
17483        CTEMP(1:1)=' '
17484        IF(NUMARG.GE.2)THEN
17485          CTEMP(1:1)=IHARG(2)(1:1)
17486        ENDIF
17487C
17488CCCCC   THE FOLLOWING LINE WAS CHANGED    SEPTEMBER 1993
17489CCCCC   IF(NUMCOL.LE.0)GOTO399
17490        IF(NUMCOL.LE.0)THEN
17491          WRITE(ICOUT,999)
17492          CALL DPWRST('XXX','WRIT')
17493          WRITE(ICOUT,355)
17494  355     FORMAT('NO VARIABLES  (= VECTORS) DEFINED')
17495          CALL DPWRST('XXX','WRIT')
17496          WRITE(IOUNI1,355)
17497        ELSE
17498C
17499          WRITE(ICOUT,999)
17500          CALL DPWRST('XXX','WRIT')
17501          WRITE(ICOUT,999)
17502          CALL DPWRST('XXX','WRIT')
17503          NJUNK=0
17504          DO390I=1,NUMCOL
17505            DO391J=1,NUMNAM
17506              IF(I.EQ.IVALUE(J).AND.IUSE(J).EQ.'V')THEN
17507                IF(NJUNK.LE.MAXNME)THEN
17508                  IF(CTEMP.EQ.' ')THEN
17509                    NJUNK=NJUNK+1
17510                    IJUNK(NJUNK)=IHNAME(J)
17511                    IJUNK2(NJUNK)=IHNAM2(J)
17512                    INUMEL(NJUNK)=IN(J)
17513                  ELSEIF(IHNAME(J)(1:1).EQ.CTEMP)THEN
17514                    NJUNK=NJUNK+1
17515                    IJUNK(NJUNK)=IHNAME(J)
17516                    IJUNK2(NJUNK)=IHNAM2(J)
17517                    INUMEL(NJUNK)=IN(J)
17518                  ENDIF
17519                ENDIF
17520              ENDIF
17521  391       CONTINUE
17522  390     CONTINUE
17523          WRITE(IOUNI1,'(I5)')NJUNK
17524          IF(NJUNK.GE.1)THEN
17525            DO395K=1,NJUNK
17526              WRITE(ICOUT,397)K,INUMEL(K),IJUNK(K),IJUNK2(K)
17527  397         FORMAT('VARIABLE ',I5,' (',I8,' ELEMENTS) IS: ',2A4)
17528              CALL DPWRST('XXX','WRIT')
17529C
17530C             2015/12: WRITE FOLLOWING TO DPST1F.DAT:
17531C
17532C                      1. VARIABLE NAME
17533C                      2. NUMBER OF OBSERVATIONS
17534C                      3. NUMBER OF DISTINCT OBSERVATIONS
17535C                      4. FIRST 10 DISTINCT VALUES
17536C
17537C             2016/12: OPTION TO SUPPRESS DISTINCT VALUES
17538C
17539              IWRITE='OFF'
17540              DO3310JJ=1,NUMNAM
17541                IF(IJUNK(K).EQ.IHNAME(JJ) .AND.
17542     1             IJUNK2(K).EQ.IHNAM2(JJ))THEN
17543                   NOBS=IN(JJ)
17544                   ICOLR=IVALUE(JJ)
17545                   IF(ISTADS.EQ.'ON')THEN
17546                     DO3320LL=1,NOBS
17547                       IJ=MAXN*(ICOLR-1)+LL
17548                       TEMP1(LL)=V(IJ)
17549 3320                CONTINUE
17550                     CALL DISTIN(TEMP1,NOBS,IWRITE,TEMP2,NDIST,
17551     1                           IBUGA3,IERROR)
17552C
17553                     WRITE(IOUNI1,398)IJUNK(K),IJUNK2(K),K,NOBS,NDIST,
17554     1                                (TEMP2(LL),LL=1,MIN(10,NDIST))
17555  398                FORMAT(2A4,I6,2I10,10E15.7)
17556C
17557                   ELSE
17558                     WRITE(IOUNI1,3398)IJUNK(K),IJUNK2(K),K,NOBS
17559 3398                FORMAT(2A4,I6,2I10)
17560                   ENDIF
17561                   GOTO3319
17562                ENDIF
17563 3310         CONTINUE
17564 3319         CONTINUE
17565  395       CONTINUE
17566          ENDIF
17567        ENDIF
17568C
17569        WRITE(ICOUT,999)
17570        CALL DPWRST('XXX','WRIT')
17571        WRITE(ICOUT,999)
17572        CALL DPWRST('XXX','WRIT')
17573        WRITE(ICOUT,3395)NUMCOL
17574 3395   FORMAT('NUMBER OF VARIABLES CURRENTLY ASSIGNED: ',I5)
17575        CALL DPWRST('XXX','WRIT')
17576        WRITE(ICOUT,3397)MAXCOL
17577 3397   FORMAT('MAXIMUM NUMBER OF VARIABLES:            ',I5)
17578        CALL DPWRST('XXX','WRIT')
17579C
17580        IOP='CLOS'
17581        CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
17582     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17583     1              IBUGA3,ISUBRO,IERROR)
17584        IF(IERROR.EQ.'YES')GOTO9000
17585C
17586      ENDIF
17587C
17588CCCCC THE FOLLOWING SECTION WAS CHANGED    SEPTEMBER 1993
17589C               ****************************
17590C               **  STEP 70.4--           **
17591C               **  PRINT OUT PARAMETERS  **
17592C               ****************************
17593C
17594      ISTEPN='70.4'
17595      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17596     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17597C
17598      IF(NUMARG.LE.0 .OR.
17599     1  (NUMARG.GE.1 .AND. IHARG(1).EQ.'PARA') .OR.
17600     1  (NUMARG.GE.1 .AND. IHARG(1).EQ.'PAR ') .OR.
17601     1  (NUMARG.GE.1 .AND. IHARG(1).EQ.'P   '))THEN
17602C
17603        NUMPAR=0
17604        IF(NUMNAM.GT.0)THEN
17605C
17606          DO430J=1,NUMNAM
17607            IF(IUSE(J).EQ.'P')THEN
17608              NUMPAR=NUMPAR+1
17609              IF(NUMPAR.LE.1)THEN
17610                WRITE(ICOUT,999)
17611                CALL DPWRST('XXX','WRIT')
17612                WRITE(ICOUT,999)
17613                CALL DPWRST('XXX','WRIT')
17614              ENDIF
17615              WRITE(ICOUT,436)IHNAME(J),IHNAM2(J),VALUE(J)
17616              CALL DPWRST('XXX','WRIT')
17617  436         FORMAT('PARAMETER ',2A4,'  HAS THE VALUE:   ',E15.7)
17618            ENDIF
17619  430     CONTINUE
17620        ENDIF
17621C
17622        IF(NUMPAR.LE.0)THEN
17623          WRITE(ICOUT,999)
17624          CALL DPWRST('XXX','WRIT')
17625          WRITE(ICOUT,481)
17626  481     FORMAT('NO PARAMETERS (= SCALARS) DEFINED')
17627          CALL DPWRST('XXX','WRIT')
17628        ENDIF
17629C
17630      ENDIF
17631C
17632C
17633CCCCC THE FOLLOWING SECTION WAS CHANGED    SEPTEMBER 1993
17634C               ****************************
17635C               **  STEP 70.5--           **
17636C               **  PRINT OUT FUNCTIONS   **
17637C               ****************************
17638C
17639C     2018/06: SUPPORT
17640C
17641C                 STATUS F STR
17642C
17643C              FOR THIS SYNTAX, ONLY PRINT FUNCTIONS THAT CONTAIN
17644C              "STR" IN NAME.  SINCE STRINGS PRESERVE CASE, BE SURE
17645C              TO MAKE MATCH CASE INSENSITIVE.
17646C
17647      ISTEPN='70.5'
17648      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17649     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17650C
17651      IF(NUMARG.LE.0 .OR.
17652     1  (NUMARG.LE.2 .AND. IHARG(1).EQ.'FUNC') .OR.
17653     1  (NUMARG.LE.2 .AND. IHARG(1).EQ.'FUN ') .OR.
17654     1  (NUMARG.LE.2 .AND. IHARG(1).EQ.'F   ') .OR.
17655     1  (NUMARG.LE.2 .AND. IHARG(1).EQ.'STRI'))THEN
17656C
17657        IHSTR=' '
17658        NLAST=0
17659        IF(NUMARG.GE.2 .AND. IHARG(1).NE.'    ')THEN
17660          IHSTR(1:4)=IHARG(2)(1:4)
17661          IHSTR(5:8)=IHARG2(2)(1:4)
17662          DO520J=8,1,-1
17663            IF(IHSTR(J:J).NE.' ')THEN
17664              NLAST=J
17665              GOTO529
17666            ENDIF
17667 520      CONTINUE
17668 529      CONTINUE
17669        ENDIF
17670C
17671        NUMFUN=0
17672        IF(NUMNAM.GT.0)THEN
17673C
17674          DO530J=1,NUMNAM
17675            IF(IUSE(J).EQ.'F')THEN
17676              IMIN=IVSTAR(J)
17677              IMAX=IVSTOP(J)
17678              IH(1:4)=IHNAME(J)(1:4)
17679              IH(5:8)=IHNAM2(J)(1:4)
17680C
17681C             CHECK TO SEE IF THERE IS A SUBSTRING MATCH
17682C
17683              IF(NLAST.GT.0)THEN
17684                IF(NLAST.GT.IMAX)GOTO530
17685                IF(IHSTR(1:NLAST).NE.IH(1:NLAST))GOTO530
17686              ENDIF
17687C
17688              NUMFUN=NUMFUN+1
17689              IDEL=IMAX-IMIN+1
17690              NUMLIN=((IDEL-1)/100)+1
17691              IF(NUMLIN.GT.0)THEN
17692                DO540KLINE=1,NUMLIN
17693                  IF(KLINE.EQ.1)THEN
17694                    KMIN=IMIN
17695                    KMAX=KMIN+100-1
17696                    IF(KMAX.GT.IMAX)KMAX=IMAX
17697                    WRITE(ICOUT,552)IHNAME(J),IHNAM2(J),
17698     1                              (IFUNC(K),K=KMIN,KMAX)
17699  552               FORMAT('FUNCTION  ',2A4,'--',100A1)
17700                    CALL DPWRST('XXX','WRIT')
17701                  ELSEIF(KLINE.GE.2)THEN
17702                    KMIN=KMAX+1
17703                    KMAX=KMIN+100-1
17704                    IF(KMAX.GT.IMAX)KMAX=IMAX
17705                    WRITE(ICOUT,562)(IFUNC(K),K=KMIN,KMAX)
17706  562               FORMAT(18X,100A1)
17707                    CALL DPWRST('XXX','WRIT')
17708                  ENDIF
17709  540           CONTINUE
17710              ENDIF
17711            ENDIF
17712  530     CONTINUE
17713        ENDIF
17714C
17715        IF(NUMFUN.LE.0)THEN
17716          WRITE(ICOUT,999)
17717          CALL DPWRST('XXX','WRIT')
17718          WRITE(ICOUT,581)
17719  581     FORMAT('NO FUNCTIONS (= STRINGS) DEFINED')
17720          CALL DPWRST('XXX','WRIT')
17721        ENDIF
17722C
17723      ENDIF
17724C
17725C               ***************************************
17726C               **  STEP 70.6--                     **
17727C               **  PRINT OUT MATRIX    INFORMATION  **
17728C               ***************************************
17729              NUMFUN=NUMFUN+1
17730              IF(NUMFUN.LE.1)THEN
17731                WRITE(ICOUT,999)
17732                CALL DPWRST('XXX','WRIT')
17733                WRITE(ICOUT,999)
17734                CALL DPWRST('XXX','WRIT')
17735              ENDIF
17736C
17737      ISTEPN='70.6'
17738      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17739     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17740C
17741CCCCC THE FOLLOWING 4 LINES WERE ADDED     DECEMBER 1991
17742      IF(NUMARG.LE.0 .OR.
17743     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'MATR') .OR.
17744     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'M   '))THEN
17745C
17746CCCCC   THE FOLLOWING LINE WAS CHANGED    SEPTEMBER 1993
17747CCCCC   IF(NUMNAM.LE.0)GOTO619
17748        IF(NUMNAM.LE.0)THEN
17749           WRITE(ICOUT,999)
17750           CALL DPWRST('XXX','WRIT')
17751           WRITE(ICOUT,605)
17752  605      FORMAT('NO MATRICES               DEFINED')
17753           CALL DPWRST('XXX','WRIT')
17754        ELSE
17755C
17756          IPASS=0
17757          DO610J=1,NUMNAM
17758            IF(IUSE(J).EQ.'M')THEN
17759              IPASS=IPASS+1
17760              IF(IPASS.EQ.1)THEN
17761                WRITE(ICOUT,999)
17762                CALL DPWRST('XXX','WRIT')
17763                WRITE(ICOUT,999)
17764                CALL DPWRST('XXX','WRIT')
17765              ENDIF
17766              NR1=IN(J)
17767              NC1=IVALU2(J)-IVALUE(J)+1
17768              WRITE(ICOUT,616)IHNAME(J),IHNAM2(J),NR1,NC1,IVALUE(J)
17769  616         FORMAT('MATRIX ',2A4,' HAS ',I8,' ROWS AND ',I8,
17770     1               ' COLUMNS (AND STARTS IN COLUMN ',I8,')')
17771              CALL DPWRST('XXX','WRIT')
17772            ENDIF
17773  610     CONTINUE
17774        ENDIF
17775      ENDIF
17776C
17777C               **************************
17778C               **  STEP 70.7--         **
17779C               **  PRINT OUT THE LAST  **
17780C               **  MODEL FITTED        **
17781C               **************************
17782C
17783      ISTEPN='70.7'
17784      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17785     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17786C
17787CCCCC THE FOLLOWING 4 LINES WERE ADDED     DECEMBER 1991
17788      IF(NUMARG.LE.0 .OR.
17789     1  (NUMARG.GE.1.AND.IHARG(1).EQ.'MODE'))THEN
17790C
17791        WRITE(ICOUT,999)
17792        CALL DPWRST('XXX','WRIT')
17793        WRITE(ICOUT,999)
17794        CALL DPWRST('XXX','WRIT')
17795        IF(NUMCHM.EQ.0)THEN
17796          WRITE(ICOUT,731)
17797  731     FORMAT('MODEL--NO MODEL YET DEFINED')
17798          CALL DPWRST('XXX','WRIT')
17799        ELSE
17800          DO740I=1,20
17801            I2=I
17802            IF(MODEL(I).NE.' ')GOTO748
17803  740     CONTINUE
17804  748     CONTINUE
17805          IF(NUMCHM.GE.I2)THEN
17806            ISTOP=MIN(NUMCHM,I2+119)
17807            WRITE(ICOUT,741)(MODEL(I),I=I2,ISTOP)
17808  741       FORMAT('MODEL--',120A1)
17809            CALL DPWRST('XXX','WRIT')
17810          ENDIF
17811          WRITE(ICOUT,999)
17812          CALL DPWRST('XXX','WRIT')
17813        ENDIF
17814      ENDIF
17815C
17816C               ***************************************
17817C               **  STEP 70.8--                      **
17818C               **  PRINT OUT ROW LABELS INFORMATION **
17819C               ***************************************
17820C
17821      ISTEPN='70.8'
17822      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17823     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17824C
17825      IF(NUMARG.LE.0 .OR.
17826     1  (NUMARG.GE.2.AND.IHARG(1).EQ.'ROW '.AND.IHARG(2).EQ.'LABE'))THEN
17827C
17828        WRITE(ICOUT,999)
17829        CALL DPWRST('XXX','WRIT')
17830        WRITE(ICOUT,999)
17831        CALL DPWRST('XXX','WRIT')
17832C
17833        IF(IROWLB(1).EQ.' ')THEN
17834          WRITE(ICOUT,781)
17835  781     FORMAT('NO ROW LABELS CURRENTLY DEFINED.')
17836          CALL DPWRST('XXX','WRIT')
17837        ELSE
17838          NLAST=1
17839          DO783II=1,MAXOBV
17840            IF(IROWLB(II).EQ.' ')THEN
17841              NLAST=II-1
17842              GOTO785
17843            ENDIF
17844  783     CONTINUE
17845  785     CONTINUE
17846          IVAL=1
17847          WRITE(ICOUT,787)IVAL,IROWLB(1)
17848          CALL DPWRST('XXX','WRIT')
17849          WRITE(ICOUT,787)NLAST,IROWLB(NLAST)
17850  787     FORMAT('ROW ',I8,' OF THE ROW LABELS: ',A24)
17851          CALL DPWRST('XXX','WRIT')
17852        ENDIF
17853C
17854      ENDIF
17855C
17856C               *****************************************
17857C               **  STEP 70.9--                        **
17858C               **  PRINT OUT GROUP LABELS INFORMATION **
17859C               *****************************************
17860C
17861      ISTEPN='70.9'
17862      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17863     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17864C
17865      IF(NUMARG.LE.0 .OR.
17866     1  (NUMARG.GE.2.AND.IHARG(1).EQ.'GROU'.AND.IHARG(2).EQ.'LABE'))THEN
17867C
17868        WRITE(ICOUT,999)
17869        CALL DPWRST('XXX','WRIT')
17870C
17871        ICNT=0
17872        DO790II=1,MAXGRP
17873          IF(IGRPVN(II).EQ.' ')GOTO790
17874          ICNT=ICNT+1
17875          WRITE(ICOUT,999)
17876          CALL DPWRST('XXX','WRIT')
17877          WRITE(ICOUT,791)II,IGRPVN(II)
17878  791     FORMAT('GROUP LABEL ',I5,' NAME: ',A8)
17879          CALL DPWRST('XXX','WRIT')
17880          DO792JJ=1,MAXGLA
17881            IF(IGRPLA(JJ,II).EQ.' ')GOTO793
17882            WRITE(ICOUT,794)JJ,IGRPLA(JJ,II)
17883  794       FORMAT('     LEVEL ',I5,': ',A40)
17884            CALL DPWRST('XXX','WRIT')
17885  792     CONTINUE
17886  793     CONTINUE
17887  790   CONTINUE
17888C
17889        IF(ICNT.EQ.0)THEN
17890          WRITE(ICOUT,999)
17891          CALL DPWRST('XXX','WRIT')
17892          WRITE(ICOUT,799)
17893  799     FORMAT('NO GROUP LABELS CURRENTLY DEFINED.')
17894          CALL DPWRST('XXX','WRIT')
17895        ENDIF
17896C
17897      ENDIF
17898C
17899C               ************************************************
17900C               **  STEP 70.A--                               **
17901C               **  PRINT OUT CHARACTER VARIABLES INFORMATION **
17902C               ************************************************
17903C
17904      ISTEPN='70.A'
17905      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STAT')
17906     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17907C
17908      IF(NUMARG.LE.0 .OR.
17909     1  (NUMARG.GE.2.AND.IHARG(1).EQ.'CHAR'.AND.IHARG(2).EQ.'VARI'))THEN
17910C
17911        WRITE(ICOUT,999)
17912        CALL DPWRST('XXX','WRIT')
17913C
17914        IOUNIT=IZCHNU
17915        IFILE=IZCHNA
17916        ISTAT=IZCHST
17917        IFORM=IZCHFO
17918        IACCES=IZCHAC
17919        IPROT=IZCHPR
17920        ICURST=IZCHCS
17921C
17922        ISUBN0='STAT'
17923        IERRFI='NO'
17924        CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,
17925     1              ICURST,
17926     1              IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
17927        IF(IERRFI.EQ.'YES')THEN
17928          WRITE(ICOUT,999)
17929          CALL DPWRST('XXX','BUG ')
17930          WRITE(ICOUT,801)
17931  801     FORMAT('NO CHARACTER VARIABLES ARE CURRENTLY DEFINED.')
17932          CALL DPWRST('XXX','BUG ')
17933          GOTO809
17934        ENDIF
17935C
17936        READ(IOUNIT,'(I8)',END=871,ERR=871)NUMVAR
17937C
17938        DO803I=1,NUMVAR
17939          READ(IOUNIT,'(A8)',END=881,ERR=881)IH
17940          WRITE(ICOUT,804)I,IH
17941  804     FORMAT('CHARACTER VARIABLE ',I5,' IS: ',A8)
17942          CALL DPWRST('XXX','BUG ')
17943  803   CONTINUE
17944C
17945C       NOW DETERMINE THE NUMBER OF ROWS
17946C
17947        NROWS=0
17948        DO805I=1,20000000
17949          NROWS=I-1
17950          READ(IOUNIT,'(A8)',END=807,ERR=807)IH
17951  805   CONTINUE
17952  807   CONTINUE
17953        WRITE(ICOUT,999)
17954        CALL DPWRST('XXX','BUG ')
17955        WRITE(ICOUT,808)NROWS
17956  808   FORMAT('THE CHARACTER VARIABLES HAVE ',I8,' ROWS.')
17957        CALL DPWRST('XXX','BUG ')
17958        GOTO809
17959C
17960  871   CONTINUE
17961        WRITE(ICOUT,999)
17962        CALL DPWRST('XXX','BUG ')
17963        WRITE(ICOUT,873)
17964  873   FORMAT('      NO CHARACTER VARIABLES ARE CURRENTLY DEFINED.')
17965        CALL DPWRST('XXX','BUG ')
17966        IERROR='NO'
17967        GOTO809
17968C
17969  881   CONTINUE
17970        WRITE(ICOUT,999)
17971        CALL DPWRST('XXX','BUG ')
17972        WRITE(ICOUT,883)
17973  883   FORMAT('      ERROR READING THE VARIABLE NAMES ',
17974     1         'IN THE CHARACTER DATA FILE:')
17975        CALL DPWRST('XXX','BUG ')
17976        IERROR='YES'
17977        GOTO809
17978C
17979  809   CONTINUE
17980C
17981        IENDFI='OFF'
17982        IREWIN='ON'
17983        CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
17984     1              IENDFI,IREWIN,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
17985        IZCHCS='CLOSED'
17986C
17987      ENDIF
17988C
17989      GOTO9000
17990C
17991C               *****************
17992C               **  STEP 90--  **
17993C               **  EXIT       **
17994C               *****************
17995C
17996 9000 CONTINUE
17997C
17998      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'STAT')THEN
17999        WRITE(ICOUT,999)
18000        CALL DPWRST('XXX','WRIT')
18001        WRITE(ICOUT,9011)
18002 9011   FORMAT('AT THE END       OF DPSTAT--')
18003        CALL DPWRST('XXX','WRIT')
18004        WRITE(ICOUT,9013)IBUGS2,IFOUND,IERROR
18005 9013   FORMAT('IBUGS2,IFOUND,IERROR = ',2(A4,2X),A4)
18006        CALL DPWRST('XXX','WRIT')
18007      ENDIF
18008C
18009      RETURN
18010      END
18011      SUBROUTINE DPSTA2(Z1,Z2,Z3,NZ,ICASPL,
18012     1                  Y2,X2,D2,N2,NPLOTV,
18013     1                  IBUGG3,ISUBRO,IERROR)
18014C
18015C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
18016C              THAT WILL DEFINE A STAR PLOT
18017C              (USEFUL FOR MULTIVARIATE ANALYSIS).
18018C     WRITTEN BY--JAMES J. FILLIBEN
18019C                 STATISTICAL ENGINEERING DIVISION
18020C                 INFORMATION TECHNOLOGY LABORATORY
18021C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18022C                 GAITHERSBURG, MD 20899-8980
18023C                 PHONE--301-975-2855
18024C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18025C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18026C     LANGUAGE--ANSI FORTRAN (1977)
18027C     VERSION NUMBER--88/2
18028C     ORIGINAL VERSION--JANUARY   1988.
18029C
18030C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18031C
18032      CHARACTER*4 ICASPL
18033      CHARACTER*4 IBUGG3
18034      CHARACTER*4 ISUBRO
18035      CHARACTER*4 IERROR
18036C
18037      CHARACTER*4 ISUBN1
18038      CHARACTER*4 ISUBN2
18039C
18040C---------------------------------------------------------------------
18041C
18042      DIMENSION Z1(*)
18043      DIMENSION Z2(*)
18044      DIMENSION Z3(*)
18045C
18046      DIMENSION Y2(*)
18047      DIMENSION X2(*)
18048      DIMENSION D2(*)
18049C
18050C-----COMMON----------------------------------------------------------
18051C
18052      INCLUDE 'DPCOP2.INC'
18053C
18054C-----START POINT-----------------------------------------------------
18055C
18056      ISUBN1='DPST'
18057      ISUBN2='A2  '
18058      IERROR='NO'
18059C
18060      TWOPI=2.0*3.1415926
18061C
18062C               ********************************************
18063C               **  STEP 1--                              **
18064C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
18065C               ********************************************
18066C
18067      IF(NZ.LT.1)THEN
18068        WRITE(ICOUT,999)
18069  999   FORMAT(1X)
18070        CALL DPWRST('XXX','BUG ')
18071        WRITE(ICOUT,31)
18072   31   FORMAT('***** ERROR IN STAR PLOT--')
18073        CALL DPWRST('XXX','BUG ')
18074        WRITE(ICOUT,32)
18075   32   FORMAT('      THE NUMBER OF OBSERVATIONS IS NON-POSITIVE.')
18076        CALL DPWRST('XXX','BUG ')
18077        WRITE(ICOUT,34)NZ
18078   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
18079        CALL DPWRST('XXX','BUG ')
18080        WRITE(ICOUT,999)
18081        CALL DPWRST('XXX','BUG ')
18082        IERROR='YES'
18083        GOTO9000
18084      ENDIF
18085C
18086      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'STA2')THEN
18087        WRITE(ICOUT,999)
18088        CALL DPWRST('XXX','BUG ')
18089        WRITE(ICOUT,71)
18090   71   FORMAT('***** AT THE BEGINNING OF DPPRO2--')
18091        CALL DPWRST('XXX','BUG ')
18092        WRITE(ICOUT,72)ICASPL,NZ,N2,NPLOTV
18093   72   FORMAT('ICASPL,NZ,N2,NPLOTV = ',A4,2X,3I8)
18094        CALL DPWRST('XXX','BUG ')
18095        IF(NZ.GT.0)THEN
18096          DO81I=1,NZ
18097            WRITE(ICOUT,82)I,Z1(I),Z2(I),Z3(I)
18098   82       FORMAT('I,Z1(I),Z2(I),Z3(I) = ',I8,3F15.7)
18099            CALL DPWRST('XXX','BUG ')
18100   81     CONTINUE
18101        ENDIF
18102      ENDIF
18103C
18104C               ****************************************
18105C               **  STEP 11--                         **
18106C               **  DETERMINE PLOT COORDINATES        **
18107C               ****************************************
18108C
18109      ANZ=NZ
18110C
18111      J=0
18112      K=1
18113      DO1100I=1,NZ
18114        AI=I
18115        ANUM=Z1(I)-Z2(I)
18116        ADEN=Z3(I)-Z2(I)
18117        P=0.0
18118        IF(ADEN.GT.0.0)P=ANUM/ADEN
18119        THETA=((AI-1.0)/ANZ)*TWOPI
18120        J=J+1
18121        Y2(J)=P*SIN(THETA)
18122        X2(J)=P*COS(THETA)
18123        D2(J)=K
18124 1100 CONTINUE
18125      J=J+1
18126      Y2(J)=Y2(1)
18127      X2(J)=X2(1)
18128      D2(J)=D2(1)
18129C
18130      DO1200I=1,NZ
18131        AI=I
18132        THETA=((AI-1.0)/ANZ)*TWOPI
18133        J=J+1
18134        K=K+1
18135        Y2(J)=0.0
18136        X2(J)=0.0
18137        D2(J)=K
18138        J=J+1
18139        Y2(J)=SIN(THETA)
18140        X2(J)=COS(THETA)
18141        D2(J)=K
18142 1200 CONTINUE
18143C
18144      N2=J
18145      NPLOTV=3
18146      GOTO9000
18147C
18148C               *****************
18149C               **  STEP 90--  **
18150C               **  EXIT       **
18151C               *****************
18152C
18153 9000 CONTINUE
18154      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'STA2')THEN
18155        WRITE(ICOUT,999)
18156        CALL DPWRST('XXX','BUG ')
18157        WRITE(ICOUT,9011)
18158 9011   FORMAT('***** AT THE END       OF DPSTA2--')
18159        CALL DPWRST('XXX','BUG ')
18160        WRITE(ICOUT,9031)N2,NPLOTV
18161 9031   FORMAT('N2,NPLOTV = ',2I8)
18162        CALL DPWRST('XXX','BUG ')
18163        DO9035I=1,N2
18164          WRITE(ICOUT,9036)I,Y2(I),X2(I),D2(I)
18165 9036     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2)
18166          CALL DPWRST('XXX','BUG ')
18167 9035   CONTINUE
18168      ENDIF
18169C
18170      RETURN
18171      END
18172      SUBROUTINE DPSTC2(ICASL8,ILOCV,ISTANR,
18173     1                  IFOUNZ,IBEGIN,IEND,ITYPE,IHOL,IHOL2,INT1,
18174     1                  FLOAT1,IERRO1,
18175     1                  TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
18176     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
18177     1                  DTEMP1,DTEMP2,DTEMP3,
18178     1                  IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
18179C
18180C     PURPOSE--COMPUTE A LET STATISTIC SUB-COMMAND.  NOTE THAT THIS IS
18181C              IS A COPY OF DPSTAC THAT IS CALLED BY DPSBEX (EXECUTE A
18182C              STATISTIC BLOCK).  IT IS REQUIRED TO AVOID A RECURSIVE
18183C              CALL (I.E., DPSTAC CALLS CMPSTA WHICH CALLS DPSBEX WHICH
18184C              CALLS CMPSTA).  THE PRIMARY DIFFERENCE IS THAT IT CALLS
18185C              CMPST2 RATHER THAN CMPSTA.
18186C     NOTE--THIS SUBROUTINE OPERATES ON A VECTOR AND PRODUCES A
18187C           PARAMETER (= A SCALAR); THIS IS TO BE CONTRASTED WITH DPLET7
18188C           WHICH OPERATES ON A VECTOR BUT PRODUCES A VECTOR.
18189C     NOTE-INPUT WILL BE A VECTOR (OR 2 OR 3 VECTORS).  OUTPUT WILL BE A
18190C          SCALAR--
18191C               1) PARAMETER, OR
18192C               2) ELEMENT OF A VECTOR.
18193C          THE STATISTICS CAN BE CALCULATED ON A FULL VARIABLE
18194C          OR ON A PARTIAL VARIABLE.
18195C     EXAMPLE--LET A    = MEAN X                      (A FULL VARIABLE)
18196C            --LET Y(4) = MEAN X                      (A FULL VARIABLE)
18197C            --LET A    = MEAN X   SUBSET 2 3 5       (A PARTIAL VAR.)
18198C            --LET Y(4) = MEAN X   SUBSET 2 3 5       (A PARTIAL VAR.)
18199C            --LET A    = MEAN X   FOR I = 1 2 10     (A PARTIAL VAR.)
18200C            --LET Y(4) = MEAN X   FOR I = 1 2 10     (A PARTIAL VAR.)
18201C            --LET A    = CORRELATION X Y              (A FULL VARIABLE
18202C            --LET Y(4) = CORRELATION X Y              (A FULL VARIABLE
18203C            --LET A    = CORRELATION X Y  SUBSET 2 3 5     (A PARTIAL
18204C            --LET Y(4) = CORRELATION X Y  SUBSET 2 3 5     (A PARTIAL
18205C            --LET A    = CORRELATION X Y  FOR I = 1 2 10   (A PARTIAL
18206C            --LET Y(4) = CORRELATION X Y  FOR I = 1 2 10   (A PARTIAL
18207C     WRITTEN BY--JAMES J. FILLIBEN
18208C                 STATISTICAL ENGINEERING DIVISION
18209C                 INFORMATION TECHNOLOGY LABORATORY
18210C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18211C                 GAITHERSBURG, MD 20899-8980
18212C                 PHONE--301-975-2855
18213C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18214C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18215C     LANGUAGE--ANSI FORTRAN (1977)
18216C     VERSION NUMBER--2016/08
18217C     ORIGINAL VERSION--AUGUST    2016.
18218C
18219C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18220C
18221      CHARACTER*4 ICASL8
18222      CHARACTER*4 IFOUNZ
18223      CHARACTER*4 ITYPE
18224      CHARACTER*4 IHOL
18225      CHARACTER*4 IHOL2
18226      CHARACTER*4 IERRO1
18227      CHARACTER*4 IBUGA3
18228      CHARACTER*4 IBUGQ
18229      CHARACTER*4 ISUBRO
18230      CHARACTER*4 IFOUND
18231      CHARACTER*4 IERROR
18232C
18233      CHARACTER*4 NEWNAM
18234      CHARACTER*4 NEWCOL
18235      CHARACTER*4 ICASEL
18236      CHARACTER*4 ICASEQ
18237      CHARACTER*4 IHWUSE
18238      CHARACTER*4 MESSAG
18239      CHARACTER*4 IWRITE
18240      CHARACTER*4 IHARG3
18241      CHARACTER*4 IHARG4
18242      CHARACTER*4 IHARG5
18243      CHARACTER*4 IHARG6
18244      CHARACTER*4 ILEFT
18245      CHARACTER*4 ILEFT2
18246      CHARACTER*4 ISUBSF
18247      CHARACTER*4 IFORF
18248      CHARACTER*4 IARG4T
18249      CHARACTER*4 IARG4F
18250      CHARACTER*4 IHSET
18251      CHARACTER*4 IHSET2
18252      CHARACTER*4 IH
18253      CHARACTER*4 IH2
18254C
18255      CHARACTER*4 ISUBN1
18256      CHARACTER*4 ISUBN2
18257      CHARACTER*4 ISTEPN
18258C
18259      CHARACTER*4 IFLAGD
18260C
18261C---------------------------------------------------------------------
18262C
18263      DIMENSION IFOUNZ(*)
18264      DIMENSION IBEGIN(*)
18265      DIMENSION IEND(*)
18266      DIMENSION ITYPE(*)
18267      DIMENSION IHOL(*)
18268      DIMENSION IHOL2(*)
18269      DIMENSION INT1(*)
18270      DIMENSION FLOAT1(*)
18271      DIMENSION IERRO1(*)
18272C
18273      DIMENSION TEMP(*)
18274      DIMENSION TEMP2(*)
18275      DIMENSION TEMP3(*)
18276C
18277      DIMENSION XTEMP1(*)
18278      DIMENSION XTEMP2(*)
18279      DIMENSION XTEMP3(*)
18280C
18281      DIMENSION ITEMP1(*)
18282      DIMENSION ITEMP2(*)
18283      DIMENSION ITEMP3(*)
18284      DIMENSION ITEMP4(*)
18285      DIMENSION ITEMP5(*)
18286      DIMENSION ITEMP6(*)
18287C
18288      DOUBLE PRECISION DTEMP1(*)
18289      DOUBLE PRECISION DTEMP2(*)
18290      DOUBLE PRECISION DTEMP3(*)
18291C
18292C---------------------------------------------------------------------
18293C
18294C-----COMMON----------------------------------------------------------
18295C
18296      INCLUDE 'DPCOPA.INC'
18297      INCLUDE 'DPCOHK.INC'
18298      INCLUDE 'DPCODA.INC'
18299      INCLUDE 'DPCOST.INC'
18300      INCLUDE 'DPCOP2.INC'
18301C
18302C-----START POINT-----------------------------------------------------
18303C
18304      ISUBN1='DPST'
18305      ISUBN2='C2  '
18306      IFOUND='NO'
18307      IERROR='NO'
18308      ICASEL='UNKN'
18309      NEWNAM='NO'
18310      NEWCOL='NO'
18311      IFLAGD='OFF'
18312C
18313      MAXCP1=MAXCOL+1
18314      MAXCP2=MAXCOL+2
18315      MAXCP3=MAXCOL+3
18316      MAXCP4=MAXCOL+4
18317      MAXCP5=MAXCOL+5
18318      MAXCP6=MAXCOL+6
18319C
18320      ICOLL=0
18321      ICOL2=0
18322      NIRIG2=0
18323      ILOCSV=0
18324      NIOLD=0
18325      ICOL3=0
18326      ICOL22=0
18327      ICOL32=0
18328      ICOLR=0
18329      ICOLR2=0
18330      NCOL=0
18331      NCOL2=0
18332      NCOL3=0
18333      IFLGP1=0
18334      IFLGP2=0
18335      IFLGP3=0
18336      AVAL1=0.0
18337      AVAL2=0.0
18338      AVAL3=0.0
18339      NUMVAR=0
18340C
18341C               *******************************************************
18342C               **  TREAT THE SUBCASE OF CALCULATING CERTAIN         **
18343C               **  ELEMENTARY STATISTICS (MEAN, SD, ETC.)           **
18344C               **       1) FOR A FULL VARIABLE, OR                  **
18345C               **       2) FOR PART OF A VARIABLE.                  **
18346C               *******************************************************
18347C
18348      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STC2')THEN
18349        WRITE(ICOUT,999)
18350  999   FORMAT(1X)
18351        CALL DPWRST('XXX','BUG ')
18352        WRITE(ICOUT,51)
18353   51   FORMAT('***** AT THE BEGINNING OF DPSTC2--')
18354        CALL DPWRST('XXX','BUG ')
18355        WRITE(ICOUT,52)IBUGA3,IBUGQ,ICASL8,IERRO1(1)
18356   52   FORMAT('IBUGA3,IBUGQ,ICASL8,IERRO1(1) = ',3(A4,2X),A4)
18357        CALL DPWRST('XXX','BUG ')
18358        WRITE(ICOUT,53)ILOCV,ISTANR,IBEGIN(1),IEND(1),FLOAT1(1)
18359   53   FORMAT('ILOCV,ISTANR,IBEGIN(1),IEND(1),FLOAT1(1) = ',4I8,G15.7)
18360        CALL DPWRST('XXX','BUG ')
18361      ENDIF
18362C
18363C               *********************************************************
18364C               **  STEP 2--                                            *
18365C               **  EXAMINE THE LEFT-HAND SIDE--                        *
18366C               **  IS THE PARAMETER OR VARIABLE NAME TO LEFT OF = SIGN *
18367C               **  ALREADY IN THE NAME LIST?                           *
18368C               **  NOTE THAT     ILEFT     IS THE NAME OF THE VARIABLE *
18369C               **  ON THE LEFT.                                        *
18370C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE    *
18371C               **  OF THE NAME ON THE LEFT.                            *
18372C               **  NOTE THAT     ICOLL    IS THE DATA COLUMN (1 TO 12) *
18373C               **  FOR THE NAME OF THE LEFT.                           *
18374C               *********************************************************
18375C
18376      ISTEPN='2'
18377      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18378     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18379C
18380      ILEFT=IHOL(2)
18381      ILEFT2=IHOL2(2)
18382      DO200I=1,NUMNAM
18383        I2=I
18384        IF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
18385     1    IUSE(I).EQ.'P')THEN
18386          ILISTL=I2
18387          IF(IFOUNZ(4).EQ.'NO')GOTO290
18388          WRITE(ICOUT,999)
18389          CALL DPWRST('XXX','BUG ')
18390          WRITE(ICOUT,221)
18391          CALL DPWRST('XXX','BUG ')
18392          WRITE(ICOUT,217)IHOL(2),IHOL2(2)
18393  217     FORMAT('      AN ATTEMPT WAS MADE TO USE ',A4,A4,' AS A ',
18394     1           'VARIABLE')
18395          CALL DPWRST('XXX','BUG ')
18396          WRITE(ICOUT,218)
18397  218     FORMAT('      EVEN THOUGH IT ALREADY EXISTS AS A PARAMETER.')
18398          CALL DPWRST('XXX','BUG ')
18399          IERROR='YES'
18400          GOTO9000
18401        ELSEIF(ILEFT.EQ.IHNAME(I).AND.ILEFT2.EQ.IHNAM2(I).AND.
18402     1    IUSE(I).EQ.'V')THEN
18403          ILISTL=I2
18404          ICOLL=IVALUE(ILISTL)
18405          NIOLD=IN(ILISTL)
18406          GOTO290
18407        ENDIF
18408  200 CONTINUE
18409C
18410      ISTEPN='2B'
18411      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18412     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18413C
18414      NEWNAM='YES'
18415      ILISTL=NUMNAM+1
18416      IF(ILISTL.GT.MAXNAM)THEN
18417        WRITE(ICOUT,999)
18418        CALL DPWRST('XXX','BUG ')
18419        WRITE(ICOUT,221)
18420  221   FORMAT('***** ERROR IN DPSTC2--')
18421        CALL DPWRST('XXX','BUG ')
18422        WRITE(ICOUT,222)
18423  222   FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER NAMES ',
18424     1         'HAS JUST')
18425        CALL DPWRST('XXX','BUG ')
18426        WRITE(ICOUT,223)MAXNAM
18427  223   FORMAT('      EXCEEDED THE MAX ALLOWABLE ',I8,'  .  ',
18428     1         'SUGGESTED ACTION--')
18429        CALL DPWRST('XXX','BUG ')
18430        WRITE(ICOUT,225)
18431  225   FORMAT('      ENTER      STATUS')
18432        CALL DPWRST('XXX','BUG ')
18433        WRITE(ICOUT,226)
18434  226   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
18435        CALL DPWRST('XXX','BUG ')
18436        WRITE(ICOUT,227)
18437  227   FORMAT('      THEN REDEFINE (REUSE) SOME OF THE ALREADY-USED',
18438     1         'NAMES')
18439        CALL DPWRST('XXX','BUG ')
18440        IERROR='YES'
18441        GOTO19000
18442      ENDIF
18443C
18444      ISTEPN='2C'
18445      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18446     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18447C
18448      IARG4F=IFOUNZ(4)
18449      ISUBSF=IFOUNZ(11)
18450      IFORF=IFOUNZ(21)
18451      IF(IARG4F.EQ.'NO')GOTO290
18452      NIOLD=0
18453      ICOLL=NUMCOL+1
18454C
18455      IF(ICOLL.GT.MAXCOL)THEN
18456        WRITE(ICOUT,221)
18457        CALL DPWRST('XXX','BUG ')
18458        WRITE(ICOUT,242)
18459  242   FORMAT('      THE NUMBER OF DATA COLUMNS HAS JUST EXCEEDED THE')
18460        CALL DPWRST('XXX','BUG ')
18461        WRITE(ICOUT,243)MAXCOL
18462  243   FORMAT('      MAX ALLOWABLE ',I8,'  .  SUGGESTED ACTION--')
18463        CALL DPWRST('XXX','BUG ')
18464        WRITE(ICOUT,245)
18465  245   FORMAT('      ENTER      STATUS VARIABLES')
18466        CALL DPWRST('XXX','BUG ')
18467        WRITE(ICOUT,246)
18468  246   FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
18469        CALL DPWRST('XXX','BUG ')
18470        WRITE(ICOUT,247)
18471  247   FORMAT('      AND THEN OVERWRITE SOME COLUMNS.   EXAMPLE--')
18472        CALL DPWRST('XXX','BUG ')
18473        WRITE(ICOUT,248)
18474  248   FORMAT('      IF (E.G.)   LET Y(3) = MEAN X          FAILED')
18475        CALL DPWRST('XXX','BUG ')
18476        WRITE(ICOUT,249)
18477  249   FORMAT('      THEN ONE MIGHT ENTER     NAME Y 7')
18478        CALL DPWRST('XXX','BUG ')
18479        WRITE(ICOUT,250)
18480  250   FORMAT('      (THEREBY EQUATING THE NAME Y WITH COLUMN 7')
18481        CALL DPWRST('XXX','BUG ')
18482        WRITE(ICOUT,251)
18483  251   FORMAT('      FOLLOWED BY              LET Y(3) = MEAN X ')
18484        CALL DPWRST('XXX','BUG ')
18485        WRITE(ICOUT,252)
18486  252   FORMAT('      (WHICH WILL ACTUALLY OVERWRITE ROW 3 ',
18487     1         'OF COLUMN 7')
18488        CALL DPWRST('XXX','BUG ')
18489        WRITE(ICOUT,253)
18490  253   FORMAT('      WITH THE CALCULATED MEAN OF VARIABLE X)')
18491        CALL DPWRST('XXX','BUG ')
18492        IERROR='YES'
18493        GOTO19000
18494      ENDIF
18495C
18496      ISTEPN='2D'
18497      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18498     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18499C
18500      MAXNI=0
18501      DO235I=1,12
18502        IF(IUSE(I).EQ.'V')THEN
18503          IF(IN(I).GT.MAXNI)MAXNI=IN(I)
18504        ENDIF
18505  235 CONTINUE
18506      IF(MAXNI.EQ.0)MAXNI=MAXN
18507C
18508  290 CONTINUE
18509C
18510      ISTEPN='2E'
18511      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18512     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18513C
18514C               *********************************************************
18515C               **  STEP 3--                                            *
18516C               **  EXAMINE THE RIGHT-HAND SIDE--                       *
18517C               **  HAS THE VARIABLE OR COLUMN ON THE RIGHT             *
18518C               **  ALREADY BEEN DEFINED?                               *
18519C               **  NOTE THAT     IRIGHT    IS THE NAME OF THE VARIABLE *
18520C               **  ON THE RIGHT.                                       *
18521C               **  NOTE THAT     ILISTR    IS THE LINE IN THE TABLE    *
18522C               **  OF THE VARIABLE OR COLUMN ON THE RIGHT.             *
18523C               **  NOTE THAT     ICOLR    IS THE DATA COLUMN (1 TO 12) *
18524C               **  FOR THE VARIABLE OR COLUMN ON THE RIGHT.            *
18525C               *********************************************************
18526C
18527C
18528C               ********************************************
18529C               **  STEP 4--                              **
18530C               **  BRANCH BETWEEN 1-VARIABLE STATISTICS  **
18531C               **  (E.G., MEAN, SD, MIN, ETC.)           **
18532C               **  AND 2-VARIABLE STATISTICS             **
18533C               **  (CORRELATION AND RANK CORRELATION).   **
18534C               ********************************************
18535C
18536      ISTEPN='4'
18537      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18538     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18539C
18540      NUMVIN=1
18541      IF(ICASL8.EQ.'WEME' .OR. ICASL8.EQ.'WEMD' .OR.
18542     1   ICASL8.EQ.'WESD' .OR. ICASL8.EQ.'WEVA' .OR.
18543     1   ICASL8.EQ.'WETM' .OR. ICASL8.EQ.'INTE')THEN
18544        ILOCVP=ILOCV+1
18545        IH=IHARG(ILOCVP)
18546        IH2=IHARG2(ILOCVP)
18547        IF(ILOCVP.GT.NUMARG)THEN
18548          NUMVIN=1
18549        ELSEIF(IH.EQ.'SUBS'.AND.IH2.EQ.'ET  ')THEN
18550          NUMVIN=1
18551        ELSEIF(IH.EQ.'EXCE'.AND.IH2.EQ.'PT  ')THEN
18552          NUMVIN=1
18553        ELSEIF(IH.EQ.'FOR '.AND.IH2.EQ.'    ')THEN
18554          NUMVIN=1
18555        ELSE
18556          NUMVIN=2
18557        ENDIF
18558      ELSEIF(ISTANR.EQ.2)THEN
18559        NUMVIN=2
18560      ELSEIF(ISTANR.EQ.3)THEN
18561        NUMVIN=3
18562      ELSE
18563        NUMVIN=1
18564      ENDIF
18565C
18566C     DIFFERENCE OF INTEGRAL CAN HAVE EITHER 2 OR 3 RESPONSE VARIABLES
18567C     (THE THIRD VARIABLE IS AN OPTIONAL X-COORDINATE VARIABLE)
18568C
18569      IF(ICASL8.EQ.'DINT')THEN
18570        ILOCVP=ILOCV+2
18571        IH=IHARG(ILOCVP)
18572        IH2=IHARG2(ILOCVP)
18573        IF(ILOCVP.GT.NUMARG)THEN
18574          NUMVIN=2
18575        ELSEIF(IH.EQ.'SUBS'.AND.IH2.EQ.'ET  ')THEN
18576          NUMVIN=2
18577        ELSEIF(IH.EQ.'EXCE'.AND.IH2.EQ.'PT  ')THEN
18578          NUMVIN=2
18579        ELSEIF(IH.EQ.'FOR '.AND.IH2.EQ.'    ')THEN
18580          NUMVIN=2
18581        ELSE
18582          NUMVIN=3
18583        ENDIF
18584      ENDIF
18585C
18586C
18587C               ***************************************
18588C               **  STEP 5--                         **
18589C               **  EXTRACT THE FIRST VARIABLE       **
18590C               ***************************************
18591C
18592      ISTEPN='5'
18593      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18594     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18595C
18596      IFLGP1=0
18597      IFLGP2=0
18598      IFLGP3=0
18599      NUMVAR=1
18600C
18601      IH=IHARG(ILOCV)
18602      IH2=IHARG2(ILOCV)
18603      DO1110I=1,NUMNAM
18604        I2=I
18605        IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
18606     1    IUSE(I).EQ.'V')THEN
18607          ILISTR=I2
18608          ICOLR=IVALUE(ILISTR)
18609          NIRIGH=IN(ILISTR)
18610          ICOLR2=-99
18611          GOTO2000
18612        ELSEIF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
18613     1    IUSE(I).EQ.'M')THEN
18614          ILISTR=I2
18615          ICOLR=IVALUE(ILISTR)
18616          ICOLR2=IVALU2(ILISTR)
18617          NIRIGH=IN(ILISTR)
18618          NCOL=(ICOLR2 - ICOLR) + 1
18619          GOTO2000
18620        ELSEIF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
18621     1    IUSE(I).EQ.'P')THEN
18622          IFLGP1=1
18623          ILISTR=I2
18624          AVAL1=VALUE(ILISTR)
18625          NIRIGH=1
18626          GOTO2000
18627        ENDIF
18628 1110 CONTINUE
18629C
18630      WRITE(ICOUT,999)
18631      CALL DPWRST('XXX','BUG ')
18632      WRITE(ICOUT,221)
18633      CALL DPWRST('XXX','BUG ')
18634      WRITE(ICOUT,1112)
18635 1112 FORMAT('      THE SPECIFIED ARGUMENT (VARIABLE NAME OR COLUMN')
18636      CALL DPWRST('XXX','BUG ')
18637      WRITE(ICOUT,1114)
18638 1114 FORMAT('      NUMBER) ON THE RIGHT OF THE = SIGN WAS NOT FOUND')
18639      CALL DPWRST('XXX','BUG ')
18640      WRITE(ICOUT,1115)
18641 1115 FORMAT('      IN THE INTERNAL NAME LIST.')
18642      CALL DPWRST('XXX','BUG ')
18643      WRITE(ICOUT,1158)
18644 1158 FORMAT('      THE COMMAND LINE WAS AS FOLLOWS--')
18645      CALL DPWRST('XXX','BUG ')
18646      WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
18647 1159 FORMAT(80A1)
18648      CALL DPWRST('XXX','BUG ')
18649      IERROR='YES'
18650      GOTO19000
18651C
18652C               ************************************************
18653C               **  STEP 6.2--                                **
18654C               **  EXTRACT THE SECOND VARIABLE               **
18655C               ************************************************
18656C
18657 2000 CONTINUE
18658C
18659      ISTEPN='6.2'
18660      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18661     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18662C
18663      IF(NUMVIN.LT.2)GOTO700
18664C
18665      NUMVAR=2
18666      ILOCVP=ILOCV+1
18667      IF(ILOCVP.GT.NUMARG)THEN
18668        WRITE(ICOUT,221)
18669        CALL DPWRST('XXX','BUG ')
18670        WRITE(ICOUT,2302)
18671 2302   FORMAT('      NO SECOND VARIABLE NAME OR COLUMN NUMBER WAS')
18672        CALL DPWRST('XXX','BUG ')
18673        WRITE(ICOUT,2303)
18674 2303   FORMAT('      WAS GIVEN AFTER THE STATISTIC CALCULATION')
18675        CALL DPWRST('XXX','BUG ')
18676        WRITE(ICOUT,1158)
18677        CALL DPWRST('XXX','BUG ')
18678        IF(IWIDTH.GE.1)THEN
18679          WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
18680          CALL DPWRST('XXX','BUG ')
18681        ENDIF
18682        IERROR='YES'
18683        GOTO19000
18684      ENDIF
18685C
18686      IHARG3=IHARG(ILOCVP)
18687      IHARG4=IHARG2(ILOCVP)
18688      DO2310I=1,NUMNAM
18689        I2=I
18690        IF(IHARG3.EQ.IHNAME(I).AND.IHARG4.EQ.IHNAM2(I).AND.
18691     1    IUSE(I).EQ.'V')THEN
18692          ILIST2=I2
18693          ICOL2=IVALUE(ILIST2)
18694          NIRIG2=IN(ILIST2)
18695          ICOL22=-99
18696          GOTO2390
18697        ELSEIF(IHARG3.EQ.IHNAME(I).AND.IHARG4.EQ.IHNAM2(I).AND.
18698     1    IUSE(I).EQ.'M')THEN
18699          ILIST2=I2
18700          ICOL2=IVALUE(ILIST2)
18701          ICOL22=IVALU2(ILIST2)
18702          NIRIG2=IN(ILIST2)
18703          NCOL2=(ICOL22 - ICOL2) + 1
18704          GOTO2390
18705        ELSEIF(IHARG3.EQ.IHNAME(I).AND.IHARG4.EQ.IHNAM2(I).AND.
18706     1    IUSE(I).EQ.'P')THEN
18707          IFLGP2=1
18708          ILIST2=I2
18709          AVAL2=VALUE(ILIST2)
18710          NIRIG2=1
18711          GOTO2390
18712        ENDIF
18713 2310 CONTINUE
18714C
18715      WRITE(ICOUT,999)
18716      CALL DPWRST('XXX','BUG ')
18717      WRITE(ICOUT,221)
18718      CALL DPWRST('XXX','BUG ')
18719      WRITE(ICOUT,2312)
18720 2312 FORMAT('      THE SPECIFIED SECOND ARGUMENT (VARIABLE NAME OR')
18721      CALL DPWRST('XXX','BUG ')
18722      WRITE(ICOUT,2314)
18723 2314 FORMAT('      COLUMN NUMBER) ON THE RIGHT OF THE = SIGN')
18724      CALL DPWRST('XXX','BUG ')
18725      WRITE(ICOUT,2315)
18726 2315 FORMAT('      WAS NOT FOUND IN THE INTERNAL NAME LIST.')
18727      CALL DPWRST('XXX','BUG ')
18728      WRITE(ICOUT,1158)
18729      CALL DPWRST('XXX','BUG ')
18730      IF(IWIDTH.GE.1)THEN
18731        WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
18732        CALL DPWRST('XXX','BUG ')
18733      ENDIF
18734      IERROR='YES'
18735      GOTO19000
18736C
18737 2390 CONTINUE
18738C
18739C               ******************************************************
18740C               **  STEP 6.4--                                      **
18741C               **  CHECK THAT THE 2 VARIABLES HAVE THE SAME        **
18742C               **  NUMBER OF ELEMENTS.                             **
18743C               ******************************************************
18744C
18745      ISTEPN='6.4'
18746      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18747     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18748C
18749C     "DIFFERENCE OF" STATISTICS DO NOT REQUIRE EQUAL SAMPLE
18750C     SIZES
18751C
18752      IF(ICASL8.EQ.'DMEA')IFLAGD='ON'
18753      IF(ICASL8.EQ.'DMDM')IFLAGD='ON'
18754      IF(ICASL8.EQ.'DMED')IFLAGD='ON'
18755      IF(ICASL8.EQ.'DTRM')IFLAGD='ON'
18756      IF(ICASL8.EQ.'DWNM')IFLAGD='ON'
18757      IF(ICASL8.EQ.'DGEO')IFLAGD='ON'
18758      IF(ICASL8.EQ.'DHAR')IFLAGD='ON'
18759      IF(ICASL8.EQ.'DHDL')IFLAGD='ON'
18760      IF(ICASL8.EQ.'DBIW')IFLAGD='ON'
18761      IF(ICASL8.EQ.'DSD ')IFLAGD='ON'
18762      IF(ICASL8.EQ.'DRMS ')IFLAGD='ON'
18763      IF(ICASL8.EQ.'DVAR')IFLAGD='ON'
18764      IF(ICASL8.EQ.'DAAD')IFLAGD='ON'
18765      IF(ICASL8.EQ.'DAAM')IFLAGD='ON'
18766      IF(ICASL8.EQ.'DMAD')IFLAGD='ON'
18767      IF(ICASL8.EQ.'DIQR')IFLAGD='ON'
18768      IF(ICASL8.EQ.'DWSD')IFLAGD='ON'
18769      IF(ICASL8.EQ.'DWVA')IFLAGD='ON'
18770      IF(ICASL8.EQ.'DBIM')IFLAGD='ON'
18771      IF(ICASL8.EQ.'DBIS')IFLAGD='ON'
18772      IF(ICASL8.EQ.'DPBN')IFLAGD='ON'
18773      IF(ICASL8.EQ.'DGSD')IFLAGD='ON'
18774      IF(ICASL8.EQ.'DRAN')IFLAGD='ON'
18775      IF(ICASL8.EQ.'DMDR')IFLAGD='ON'
18776      IF(ICASL8.EQ.'DQSE')IFLAGD='ON'
18777      IF(ICASL8.EQ.'DQUA')IFLAGD='ON'
18778      IF(ICASL8.EQ.'DSKE')IFLAGD='ON'
18779      IF(ICASL8.EQ.'DGSK')IFLAGD='ON'
18780      IF(ICASL8.EQ.'DPSK')IFLAGD='ON'
18781      IF(ICASL8.EQ.'DKUR')IFLAGD='ON'
18782      IF(ICASL8.EQ.'DEKU')IFLAGD='ON'
18783      IF(ICASL8.EQ.'DRSD')IFLAGD='ON'
18784      IF(ICASL8.EQ.'DSDM')IFLAGD='ON'
18785      IF(ICASL8.EQ.'DRVA')IFLAGD='ON'
18786      IF(ICASL8.EQ.'DVAM')IFLAGD='ON'
18787      IF(ICASL8.EQ.'DMIN')IFLAGD='ON'
18788      IF(ICASL8.EQ.'DMAX')IFLAGD='ON'
18789      IF(ICASL8.EQ.'DEXT')IFLAGD='ON'
18790      IF(ICASL8.EQ.'DCVA')IFLAGD='ON'
18791      IF(ICASL8.EQ.'DCOU')IFLAGD='ON'
18792      IF(ICASL8.EQ.'DSUM')IFLAGD='ON'
18793      IF(ICASL8.EQ.'DPRO')IFLAGD='ON'
18794      IF(ICASL8.EQ.'10LD')IFLAGD='ON'
18795      IF(ICASL8.EQ.'12LD')IFLAGD='ON'
18796      IF(ICASL8.EQ.'15LD')IFLAGD='ON'
18797      IF(ICASL8.EQ.'17LD')IFLAGD='ON'
18798      IF(ICASL8.EQ.'20LD')IFLAGD='ON'
18799      IF(ICASL8.EQ.'10SD')IFLAGD='ON'
18800      IF(ICASL8.EQ.'12SD')IFLAGD='ON'
18801      IF(ICASL8.EQ.'15SD')IFLAGD='ON'
18802      IF(ICASL8.EQ.'17SD')IFLAGD='ON'
18803      IF(ICASL8.EQ.'20SD')IFLAGD='ON'
18804      IF(ICASL8.EQ.'DSN')IFLAGD='ON'
18805      IF(ICASL8.EQ.'DQN')IFLAGD='ON'
18806      IF(ICASL8.EQ.'DLPL')IFLAGD='ON'
18807      IF(ICASL8.EQ.'DLPV')IFLAGD='ON'
18808      IF(ICASL8.EQ.'DLPS')IFLAGD='ON'
18809      IF(ICASL8.EQ.'DBPR')IFLAGD='ON'
18810      IF(ICASL8.EQ.'DTSD')IFLAGD='ON'
18811      IF(ICASL8.EQ.'DPER')IFLAGD='ON'
18812      IF(ICASL8.EQ.'D1DE')IFLAGD='ON'
18813      IF(ICASL8.EQ.'D2DE')IFLAGD='ON'
18814      IF(ICASL8.EQ.'D3DE')IFLAGD='ON'
18815      IF(ICASL8.EQ.'D4DE')IFLAGD='ON'
18816      IF(ICASL8.EQ.'D5DE')IFLAGD='ON'
18817      IF(ICASL8.EQ.'D6DE')IFLAGD='ON'
18818      IF(ICASL8.EQ.'D7DE')IFLAGD='ON'
18819      IF(ICASL8.EQ.'D8DE')IFLAGD='ON'
18820      IF(ICASL8.EQ.'D9DE')IFLAGD='ON'
18821      IF(ICASL8.EQ.'DLHI')IFLAGD='ON'
18822      IF(ICASL8.EQ.'DUHI')IFLAGD='ON'
18823      IF(ICASL8.EQ.'DLQU')IFLAGD='ON'
18824      IF(ICASL8.EQ.'DUQU')IFLAGD='ON'
18825      IF(ICASL8.EQ.'DSSQ')IFLAGD='ON'
18826      IF(ICASL8.EQ.'DRSC')IFLAGD='ON'
18827      IF(ICASL8.EQ.'DQQR')IFLAGD='ON'
18828      IF(ICASL8.EQ.'10LD')IFLAGD='ON'
18829      IF(ICASL8.EQ.'KS2S')IFLAGD='ON'
18830      IF(ICASL8.EQ.'KSCV')IFLAGD='ON'
18831      IF(ICASL8.EQ.'CS2S')IFLAGD='ON'
18832      IF(ICASL8.EQ.'CC2S')IFLAGD='ON'
18833      IF(ICASL8.EQ.'CP2S')IFLAGD='ON'
18834      IF(ICASL8.EQ.'FTES')IFLAGD='ON'
18835      IF(ICASL8.EQ.'FTPV')IFLAGD='ON'
18836      IF(ICASL8.EQ.'FTCD')IFLAGD='ON'
18837      IF(ICASL8.EQ.'2TTE')IFLAGD='ON'
18838      IF(ICASL8.EQ.'2TCD')IFLAGD='ON'
18839      IF(ICASL8.EQ.'2T2P')IFLAGD='ON'
18840      IF(ICASL8.EQ.'2TLP')IFLAGD='ON'
18841      IF(ICASL8.EQ.'2TUP')IFLAGD='ON'
18842      IF(ICASL8.EQ.'PTTE')IFLAGD='ON'
18843      IF(ICASL8.EQ.'PTCD')IFLAGD='ON'
18844      IF(ICASL8.EQ.'PT2P')IFLAGD='ON'
18845      IF(ICASL8.EQ.'PTLP')IFLAGD='ON'
18846      IF(ICASL8.EQ.'PTUP')IFLAGD='ON'
18847      IF(ICASL8.EQ.'2STE')IFLAGD='ON'
18848      IF(ICASL8.EQ.'2SCD')IFLAGD='ON'
18849      IF(ICASL8.EQ.'2S2P')IFLAGD='ON'
18850      IF(ICASL8.EQ.'2SLP')IFLAGD='ON'
18851      IF(ICASL8.EQ.'2SUP')IFLAGD='ON'
18852      IF(ICASL8.EQ.'MWUS')IFLAGD='ON'
18853      IF(ICASL8.EQ.'MWTE')IFLAGD='ON'
18854      IF(ICASL8.EQ.'MWCD')IFLAGD='ON'
18855      IF(ICASL8.EQ.'MW2P')IFLAGD='ON'
18856      IF(ICASL8.EQ.'MWLP')IFLAGD='ON'
18857      IF(ICASL8.EQ.'MWUP')IFLAGD='ON'
18858      IF(ICASL8.EQ.'KLTE')IFLAGD='ON'
18859      IF(ICASL8.EQ.'KLCD')IFLAGD='ON'
18860      IF(ICASL8.EQ.'KL2P')IFLAGD='ON'
18861      IF(ICASL8.EQ.'KLLP')IFLAGD='ON'
18862      IF(ICASL8.EQ.'KLUP')IFLAGD='ON'
18863      IF(ICASL8.EQ.'SRTE')IFLAGD='ON'
18864      IF(ICASL8.EQ.'SRCD')IFLAGD='ON'
18865      IF(ICASL8.EQ.'SR2P')IFLAGD='ON'
18866      IF(ICASL8.EQ.'SRLP')IFLAGD='ON'
18867      IF(ICASL8.EQ.'SRUP')IFLAGD='ON'
18868      IF(ICASL8.EQ.'METE')IFLAGD='ON'
18869      IF(ICASL8.EQ.'MECD')IFLAGD='ON'
18870      IF(ICASL8.EQ.'ME2P')IFLAGD='ON'
18871      IF(ICASL8.EQ.'2SFR')IFLAGD='ON'
18872      IF(ICASL8.EQ.'2F2P')IFLAGD='ON'
18873      IF(ICASL8.EQ.'1LNT')IFLAGD='ON'
18874      IF(ICASL8.EQ.'1UNT')IFLAGD='ON'
18875      IF(ICASL8.EQ.'1KNT')IFLAGD='ON'
18876      IF(ICASL8.EQ.'2LNT')IFLAGD='ON'
18877      IF(ICASL8.EQ.'2UNT')IFLAGD='ON'
18878      IF(ICASL8.EQ.'2KNT')IFLAGD='ON'
18879      IF(ICASL8.EQ.'FMAT')IFLAGD='ON'
18880      IF(ICASL8.EQ.'LMAT')IFLAGD='ON'
18881      IF(ICASL8.EQ.'FNOM')IFLAGD='ON'
18882      IF(ICASL8.EQ.'LNOM')IFLAGD='ON'
18883C
18884      IF(NIRIG2.NE.NIRIGH .AND. IFLAGD.NE.'ON')THEN
18885        WRITE(ICOUT,221)
18886        CALL DPWRST('XXX','BUG ')
18887        WRITE(ICOUT,2412)
18888 2412   FORMAT('      FOR A 2-VARIABLE STATISTIC CALCULATION, THE')
18889        CALL DPWRST('XXX','BUG ')
18890        WRITE(ICOUT,2413)
18891 2413   FORMAT('      NUMBER OF OBSERVATIONS IN EACH VARIABLE MUST BE')
18892        CALL DPWRST('XXX','BUG ')
18893        WRITE(ICOUT,2415)
18894 2415   FORMAT('      THE SAME;  SUCH WAS NOT THE CASE HERE.')
18895        CALL DPWRST('XXX','BUG ')
18896        WRITE(ICOUT,2416)IH,IH2,NIRIGH
18897 2416   FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS;')
18898        CALL DPWRST('XXX','BUG ')
18899        WRITE(ICOUT,2417)IHARG3,IHARG4,NIRIG2
18900 2417   FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
18901        CALL DPWRST('XXX','BUG ')
18902        WRITE(ICOUT,1158)
18903        CALL DPWRST('XXX','BUG ')
18904        IF(IWIDTH.GE.1)THEN
18905          WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
18906          CALL DPWRST('XXX','BUG ')
18907        ENDIF
18908        IERROR='YES'
18909        GOTO19000
18910      ENDIF
18911C
18912C               ************************************************
18913C               **  STEP 6.5--                                **
18914C               **  EXTRACT THE THIRD  VARIABLE               **
18915C               ************************************************
18916C
18917      ISTEPN='6.5'
18918      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
18919     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18920C
18921      IF(NUMVIN.LT.3)GOTO700
18922C
18923      NUMVAR=3
18924      ILOCVP=ILOCV+2
18925      IF(ILOCVP.GT.NUMARG)THEN
18926        WRITE(ICOUT,221)
18927        CALL DPWRST('XXX','BUG ')
18928        WRITE(ICOUT,3302)
18929 3302   FORMAT('      NO THIRD VARIABLE NAME OR COLUMN NUMBER WAS')
18930        CALL DPWRST('XXX','BUG ')
18931        WRITE(ICOUT,2303)
18932        CALL DPWRST('XXX','BUG ')
18933        WRITE(ICOUT,1158)
18934        CALL DPWRST('XXX','BUG ')
18935        IF(IWIDTH.GE.1)THEN
18936          WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
18937          CALL DPWRST('XXX','BUG ')
18938        ENDIF
18939        IERROR='YES'
18940        GOTO19000
18941      ENDIF
18942C
18943      IHARG5=IHARG(ILOCVP)
18944      IHARG6=IHARG2(ILOCVP)
18945      DO3310I=1,NUMNAM
18946        I2=I
18947        IF(IHARG5.EQ.IHNAME(I).AND.IHARG6.EQ.IHNAM2(I).AND.
18948     1    IUSE(I).EQ.'V')THEN
18949          ILIST3=I2
18950          ICOL3=IVALUE(ILIST3)
18951          NIRIG3=IN(ILIST3)
18952          ICOL32=-99
18953          GOTO3390
18954        ELSEIF(IHARG5.EQ.IHNAME(I).AND.IHARG6.EQ.IHNAM2(I).AND.
18955     1    IUSE(I).EQ.'M')THEN
18956          ILIST3=I2
18957          ICOL3=IVALUE(ILIST3)
18958          ICOL32=IVALU2(ILIST3)
18959          NIRIG3=IN(ILIST3)
18960          NCOL3=(ICOL32 - ICOL3) + 1
18961          GOTO3390
18962        ELSEIF(IHARG5.EQ.IHNAME(I).AND.IHARG6.EQ.IHNAM2(I).AND.
18963     1    IUSE(I).EQ.'P')THEN
18964          IFLGP3=1
18965          ILIST3=I2
18966          AVAL3=VALUE(ILIST3)
18967          NIRIG3=1
18968          GOTO3390
18969        ENDIF
18970 3310 CONTINUE
18971C
18972      WRITE(ICOUT,999)
18973      CALL DPWRST('XXX','BUG ')
18974      WRITE(ICOUT,221)
18975      CALL DPWRST('XXX','BUG ')
18976      WRITE(ICOUT,3312)
18977 3312 FORMAT('      THE SPECIFIED THIRD ARGUMENT (VARIABLE NAME OR')
18978      CALL DPWRST('XXX','BUG ')
18979      WRITE(ICOUT,2314)
18980      CALL DPWRST('XXX','BUG ')
18981      WRITE(ICOUT,2315)
18982      CALL DPWRST('XXX','BUG ')
18983      WRITE(ICOUT,1158)
18984      CALL DPWRST('XXX','BUG ')
18985      IF(IWIDTH.GE.1)THEN
18986        WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
18987        CALL DPWRST('XXX','BUG ')
18988      ENDIF
18989      IERROR='YES'
18990      GOTO19000
18991C
18992 3390 CONTINUE
18993C
18994C               ******************************************************
18995C               **  STEP 6.6--                                      **
18996C               **  CHECK THAT THE 3 VARIABLES HAVE THE SAME        **
18997C               **  NUMBER OF ELEMENTS.                             **
18998C               ******************************************************
18999C
19000      ISTEPN='6.6'
19001      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19002     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19003C
19004      IF(NIRIG3.NE.NIRIGH .AND. IFLAGD.NE.'ON')THEN
19005        WRITE(ICOUT,221)
19006        CALL DPWRST('XXX','BUG ')
19007        WRITE(ICOUT,3412)
19008 3412   FORMAT('      FOR A 3-VARIABLE STATISTIC CALCULATION, THE')
19009        CALL DPWRST('XXX','BUG ')
19010        WRITE(ICOUT,2413)
19011        CALL DPWRST('XXX','BUG ')
19012        WRITE(ICOUT,2415)
19013        CALL DPWRST('XXX','BUG ')
19014        WRITE(ICOUT,3416)IH,IH2,NIRIGH
19015 3416   FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS;')
19016        CALL DPWRST('XXX','BUG ')
19017        WRITE(ICOUT,3417)IHARG5,IHARG6,NIRIG3
19018 3417   FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
19019        CALL DPWRST('XXX','BUG ')
19020        WRITE(ICOUT,1158)
19021        CALL DPWRST('XXX','BUG ')
19022        IF(IWIDTH.GE.1)THEN
19023          WRITE(ICOUT,1159)(IANS(II),II=1,MIN(80,IWIDTH))
19024          CALL DPWRST('XXX','BUG ')
19025        ENDIF
19026        IERROR='YES'
19027        GOTO19000
19028      ENDIF
19029C
19030C               *******************************
19031C               **  STEP 7--                 **
19032C               **  DETERMINE THE SUBCASE    **
19033C               **  AND BRANCH ACCORDINGLY.  **
19034C               *******************************
19035C
19036  700 CONTINUE
19037      ISTEPN='7'
19038      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19039     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19040C
19041      IARG4F=IFOUNZ(4)
19042      IARG4T=ITYPE(4)
19043C
19044      ICASEL='UNKN'
19045      IF(IARG4F.EQ.'NO')ICASEL='PARA'
19046      IF(IARG4F.EQ.'YES'.AND.IARG4T.EQ.'NUMB')ICASEL='ELEM'
19047      IF(IARG4F.EQ.'YES'.AND.IARG4T.EQ.'WORD')ICASEL='ELEM'
19048      IF(ICASEL.EQ.'UNKN'.OR.ICASEL.EQ.'VAR')GOTO710
19049      GOTO729
19050C
19051  710 CONTINUE
19052      WRITE(ICOUT,221)
19053      CALL DPWRST('XXX','BUG ')
19054      WRITE(ICOUT,712)
19055  712 FORMAT('      UNKNOWN VARIABLE/PARAMETER EXPRESSION')
19056      CALL DPWRST('XXX','BUG ')
19057      WRITE(ICOUT,713)
19058  713 FORMAT('      TO THE LEFT OF THE EQUAL SIGN.')
19059      CALL DPWRST('XXX','BUG ')
19060      WRITE(ICOUT,1158)
19061      CALL DPWRST('XXX','BUG ')
19062      WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
19063      CALL DPWRST('XXX','BUG ')
19064      IERROR='YES'
19065      GOTO19000
19066C
19067  729 CONTINUE
19068C
19069      ICASEQ='UNKN'
19070      IMIN=ILOCV+1
19071      IF(IMIN.GT.NUMARG)GOTO741
19072      DO740I=IMIN,NUMARG
19073      IF(IHARG(I).EQ.'SUBS'.AND.IHARG2(I).EQ.'ET  ')GOTO742
19074      IF(IHARG(I).EQ.'EXCE'.AND.IHARG2(I).EQ.'PT  ')GOTO742
19075      IF(IHARG(I).EQ.'FOR '.AND.IHARG2(I).EQ.'    ')GOTO743
19076  740 CONTINUE
19077  741 CONTINUE
19078      ICASEQ='FULL'
19079      GOTO749
19080  742 CONTINUE
19081      ICASEQ='SUBS'
19082      GOTO749
19083  743 CONTINUE
19084      ICASEQ='FOR'
19085      GOTO749
19086  749 CONTINUE
19087      IF(ICASEQ.EQ.'UNKN')GOTO750
19088C
19089      IF(ICASEQ.EQ.'FULL')GOTO8000
19090      IF(ICASEQ.EQ.'SUBS')GOTO9000
19091      IF(ICASEQ.EQ.'FOR')GOTO10000
19092C
19093  750 CONTINUE
19094      WRITE(ICOUT,751)
19095  751 FORMAT('***** INTERNAL ERROR IN DPSTC2--')
19096      CALL DPWRST('XXX','BUG ')
19097      WRITE(ICOUT,752)
19098  752 FORMAT('      UNKNOWN QUALIFIER TYPE FOR LET COMMAND')
19099      CALL DPWRST('XXX','BUG ')
19100      WRITE(ICOUT,1158)
19101      CALL DPWRST('XXX','BUG ')
19102      WRITE(ICOUT,1159)(IANS(I),I=1,MIN(80,IWIDTH))
19103      CALL DPWRST('XXX','BUG ')
19104      IERROR='YES'
19105      GOTO19000
19106C
19107C               ************************************************
19108C               **  STEP 8--                                  **
19109C               **  TREAT THE FULL VARIABLE CASE.             **
19110C               **  EXAMPLE--LET Y = SORT(X)                  **
19111C               **         --LET Y(I) = SORT(X)               **
19112C               **  JUMP TO STEP NUMBER 11 BELOW              **
19113C               **  FOR THE ACTUAL STATISTICAL CALCULATION,   **
19114C               **  FOR THE LIST UPDATING, AND                **
19115C               **  FOR SOME INFORMATIVE PRINTING.            **
19116C               ************************************************
19117C
19118 8000 CONTINUE
19119      ISTEPN='8'
19120      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19121     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19122C
19123      NIOLD=NIRIGH
19124      IF(NUMVAR.GE.2.AND.NIRIG2.GT.NIOLD)NIOLD=NIRIG2
19125      NINEW=NIOLD
19126      DO8100I=1,NINEW
19127        ISUB(I)=1
19128 8100 CONTINUE
19129      GOTO11000
19130C
19131C               ****************************************************
19132C               **  STEP 9--                                       *
19133C               **  TREAT THE PARTIAL VARIABLE SUBSET CASE.        *
19134C               **  EXAMPLE--LET Y = SORT(X)    SUBSET 2 3 5       *
19135C               **         --LET Y(I) = SORT(X) SUBSET 2 3 5       *
19136C               **  JUMP TO STEP NUMBER 11 BELOW                   *
19137C               **  FOR THE ACTUAL STATISTICAL CALCULATION,        *
19138C               **  FOR THE LIST UPDATING, AND                     *
19139C               **  FOR SOME INFORMATIVE PRINTING.                 *
19140C               ****************************************************
19141C
19142 9000 CONTINUE
19143      ISTEPN='9'
19144      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19145     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19146C
19147      IF(NUMVAR.EQ.1)ILOCSV=ILOCV+2
19148      IF(NUMVAR.EQ.2)ILOCSV=ILOCV+3
19149      IF(NUMVAR.EQ.3)ILOCSV=ILOCV+4
19150      IHSET=IHARG(ILOCSV)
19151      IHSET2=IHARG2(ILOCSV)
19152      IHWUSE='V'
19153      MESSAG='YES'
19154      CALL CHECKN(IHSET,IHSET2,IHWUSE,
19155     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
19156     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
19157      IF(IERROR.EQ.'YES')GOTO19000
19158      NIOLD=IN(ILOC)
19159      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
19160      NINEW=NIOLD
19161      GOTO11000
19162C
19163C               *****************************************************
19164C               **  STEP 10--                                       *
19165C               **  TREAT THE PARTIAL VARIABLE FOR CASE.            *
19166C               **  EXAMPLE--LET Y = SORT(X)    FOR I = 1 2 10      *
19167C               **         --LET Y(I) = SORT(X) FOR I = 1 2 10      *
19168C               **  JUMP TO STEP NUMBER 11 BELOW                    *
19169C               **  FOR THE ACTUAL STATISTICAL CALCULATION,         *
19170C               **  FOR THE LIST UPDATING, AND                      *
19171C              **  FOR SOME INFORMATIVE PRINTING.                   *
19172C               *****************************************************
19173C
1917410000 CONTINUE
19175      ISTEPN='10'
19176      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19177     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19178C
19179      CALL DPFOR(NIOLD,NINEW,IROW1,IROWN,
19180     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
19181      NIFOR=NINEW
19182      GOTO11000
19183C
19184C               *******************************************
19185C               **  STEP 11--                            **
19186C               **  CARRY OUT THE                        **
19187C               **  ACTUAL STATISTICAL CALCULATION,      ZZ
19188C               **  THE LIST UPDATING, AND               **
19189C               **  GENERATE THE INFORMATIVE PRINTING    **
19190C               **  FOR STEP NUMBERS 7, 8, AND 9 ABOVE.  **
19191C               *******************************************
19192C
1919311000 CONTINUE
19194      ISTEPN='11'
19195      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19196     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19197C
19198      NS2=0
19199      NS3=0
19200      NS4=0
19201C
19202C     EXTRACT DATA VARIABLE ONE.  HANDLE VARIABLE AND MATRIX
19203C     CASES DIFFERENTLY.
19204C
19205      IF(IFLGP1.EQ.1)THEN
19206        NS2=1
19207        TEMP(NS2)=AVAL1
19208      ELSEIF(ICOLR2.LE.0)THEN
19209        DO11100I=1,NINEW
19210          IF(ISUB(I).EQ.0)GOTO11100
19211          IF(I.GT.NIRIGH)GOTO11109
19212          NS2=NS2+1
19213C
19214          IJ=MAXN*(ICOLR-1)+I
19215          IF(ICOLR.LE.MAXCOL)TEMP(NS2)=V(IJ)
19216          IF(ICOLR.EQ.MAXCP1)TEMP(NS2)=PRED(I)
19217          IF(ICOLR.EQ.MAXCP2)TEMP(NS2)=RES(I)
19218          IF(ICOLR.EQ.MAXCP3)TEMP(NS2)=YPLOT(I)
19219          IF(ICOLR.EQ.MAXCP4)TEMP(NS2)=XPLOT(I)
19220          IF(ICOLR.EQ.MAXCP5)TEMP(NS2)=X2PLOT(I)
19221          IF(ICOLR.EQ.MAXCP6)TEMP(NS2)=TAGPLO(I)
19222C
1922311100   CONTINUE
1922411109   CONTINUE
19225      ELSE
19226        NLOOP=NCOL
19227        IF(NLOOP.LT.1)NLOOP=1
19228        NS2=0
19229        DO11101JLOOP=1,NLOOP
19230          DO11103I=1,NINEW
19231            IF(ISUB(I).EQ.0)GOTO11103
19232            IF(I.GT.NIRIGH)GOTO11105
19233            NS2=NS2+1
19234            IF(NS2.GT.MAXOBV)THEN
19235              WRITE(ICOUT,999)
19236              CALL DPWRST('XXX','BUG ')
19237              WRITE(ICOUT,221)
19238              CALL DPWRST('XXX','BUG ')
19239              WRITE(ICOUT,11106)
1924011106         FORMAT('      FOR THE MATRIX CASE, THE MAXIMUM NUMBER')
19241              CALL DPWRST('XXX','BUG ')
19242              WRITE(ICOUT,11107)
1924311107         FORMAT('      OF OBSERVATIONS HAS BEEN EXCEEDED.')
19244              CALL DPWRST('XXX','BUG ')
19245              WRITE(ICOUT,11108)MAXOBV
1924611108         FORMAT('      THE MAXIMUM NUMBER OF OBSERVATIONS = ',I10)
19247              CALL DPWRST('XXX','BUG ')
19248              IERROR='YES'
19249              GOTO9000
19250            ENDIF
19251            ICOLT=ICOLR+JLOOP-1
19252            IJ=MAXN*(ICOLT-1)+I
19253            IF(ICOLT.LE.MAXCOL)TEMP(NS2)=V(IJ)
19254            IF(ICOLT.EQ.MAXCP1)TEMP(NS2)=PRED(I)
19255            IF(ICOLT.EQ.MAXCP2)TEMP(NS2)=RES(I)
19256            IF(ICOLT.EQ.MAXCP3)TEMP(NS2)=YPLOT(I)
19257            IF(ICOLT.EQ.MAXCP4)TEMP(NS2)=XPLOT(I)
19258            IF(ICOLT.EQ.MAXCP5)TEMP(NS2)=X2PLOT(I)
19259            IF(ICOLT.EQ.MAXCP6)TEMP(NS2)=TAGPLO(I)
1926011103     CONTINUE
1926111105     CONTINUE
1926211101   CONTINUE
19263      ENDIF
19264C
19265      IF(NUMVAR.GE.2)THEN
19266        IF(IFLGP2.EQ.1)THEN
19267          NS3=1
19268          TEMP2(NS3)=AVAL2
19269        ELSEIF(ICOL22.LE.0)THEN
19270          DO11200I=1,NINEW
19271            IF(ISUB(I).EQ.0)GOTO11200
19272            IF(I.GT.NIRIG2)GOTO11209
19273            NS3=NS3+1
19274C
19275            IJ=MAXN*(ICOL2-1)+I
19276            IF(ICOL2.LE.MAXCOL)TEMP2(NS3)=V(IJ)
19277            IF(ICOL2.EQ.MAXCP1)TEMP2(NS3)=PRED(I)
19278            IF(ICOL2.EQ.MAXCP2)TEMP2(NS3)=RES(I)
19279            IF(ICOL2.EQ.MAXCP3)TEMP2(NS3)=YPLOT(I)
19280            IF(ICOL2.EQ.MAXCP4)TEMP2(NS3)=XPLOT(I)
19281            IF(ICOL2.EQ.MAXCP5)TEMP2(NS3)=X2PLOT(I)
19282            IF(ICOL2.EQ.MAXCP6)TEMP2(NS3)=TAGPLO(I)
19283C
1928411200     CONTINUE
1928511209     CONTINUE
19286        ELSE
19287          NLOOP=NCOL2
19288          IF(NLOOP.LT.1)NLOOP=1
19289          NS3=0
19290          DO11201JLOOP=1,NLOOP
19291            DO11203I=1,NINEW
19292              IF(ISUB(I).EQ.0)GOTO11203
19293              IF(I.GT.NIRIG2)GOTO11205
19294              NS3=NS3+1
19295              IF(NS3.GT.MAXOBV)THEN
19296                WRITE(ICOUT,999)
19297                CALL DPWRST('XXX','BUG ')
19298                WRITE(ICOUT,221)
19299                CALL DPWRST('XXX','BUG ')
19300                WRITE(ICOUT,11106)
19301                CALL DPWRST('XXX','BUG ')
19302                WRITE(ICOUT,11107)
19303                CALL DPWRST('XXX','BUG ')
19304                WRITE(ICOUT,11108)MAXOBV
19305                CALL DPWRST('XXX','BUG ')
19306                IERROR='YES'
19307                GOTO9000
19308              ENDIF
19309              ICOLT=ICOL2+JLOOP-1
19310              IJ=MAXN*(ICOLT-1)+I
19311              IF(ICOLT.LE.MAXCOL)TEMP2(NS3)=V(IJ)
19312              IF(ICOLT.EQ.MAXCP1)TEMP2(NS3)=PRED(I)
19313              IF(ICOLT.EQ.MAXCP2)TEMP2(NS3)=RES(I)
19314              IF(ICOLT.EQ.MAXCP3)TEMP2(NS3)=YPLOT(I)
19315              IF(ICOLT.EQ.MAXCP4)TEMP2(NS3)=XPLOT(I)
19316              IF(ICOLT.EQ.MAXCP5)TEMP2(NS3)=X2PLOT(I)
19317              IF(ICOLT.EQ.MAXCP6)TEMP2(NS3)=TAGPLO(I)
1931811203       CONTINUE
1931911205       CONTINUE
1932011201     CONTINUE
19321        ENDIF
19322      ENDIF
19323C
19324      IF(NUMVAR.GE.3)THEN
19325        IF(IFLGP3.EQ.1)THEN
19326          NS4=1
19327          TEMP3(NS4)=AVAL3
19328        ELSEIF(ICOL32.LE.0)THEN
19329          DO11300I=1,NINEW
19330            IF(ISUB(I).EQ.0)GOTO11300
19331            IF(I.GT.NIRIG3)GOTO11309
19332            NS4=NS4+1
19333C
19334            IJ=MAXN*(ICOL3-1)+I
19335            IF(ICOL3.LE.MAXCOL)TEMP3(NS4)=V(IJ)
19336            IF(ICOL3.EQ.MAXCP1)TEMP3(NS4)=PRED(I)
19337            IF(ICOL3.EQ.MAXCP2)TEMP3(NS4)=RES(I)
19338            IF(ICOL3.EQ.MAXCP3)TEMP3(NS4)=YPLOT(I)
19339            IF(ICOL3.EQ.MAXCP4)TEMP3(NS4)=XPLOT(I)
19340            IF(ICOL3.EQ.MAXCP5)TEMP3(NS4)=X2PLOT(I)
19341            IF(ICOL3.EQ.MAXCP6)TEMP3(NS4)=TAGPLO(I)
19342C
1934311300     CONTINUE
1934411309     CONTINUE
19345        ELSE
19346          NLOOP=NCOL3
19347          IF(NLOOP.LT.1)NLOOP=1
19348          NS4=0
19349          DO11301JLOOP=1,NLOOP
19350            DO11303I=1,NINEW
19351              IF(ISUB(I).EQ.0)GOTO11303
19352              IF(I.GT.NIRIG3)GOTO11305
19353              NS4=NS4+1
19354              IF(NS4.GT.MAXOBV)THEN
19355                WRITE(ICOUT,999)
19356                CALL DPWRST('XXX','BUG ')
19357                WRITE(ICOUT,221)
19358                CALL DPWRST('XXX','BUG ')
19359                WRITE(ICOUT,11106)
19360                CALL DPWRST('XXX','BUG ')
19361                WRITE(ICOUT,11107)
19362                CALL DPWRST('XXX','BUG ')
19363                WRITE(ICOUT,11108)MAXOBV
19364                CALL DPWRST('XXX','BUG ')
19365                IERROR='YES'
19366                GOTO9000
19367              ENDIF
19368              ICOLT=ICOL3+JLOOP-1
19369              IJ=MAXN*(ICOLT-1)+I
19370              IF(ICOLT.LE.MAXCOL)TEMP3(NS4)=V(IJ)
19371              IF(ICOLT.EQ.MAXCP1)TEMP3(NS4)=PRED(I)
19372              IF(ICOLT.EQ.MAXCP2)TEMP3(NS4)=RES(I)
19373              IF(ICOLT.EQ.MAXCP3)TEMP3(NS4)=YPLOT(I)
19374              IF(ICOLT.EQ.MAXCP4)TEMP3(NS4)=XPLOT(I)
19375              IF(ICOLT.EQ.MAXCP5)TEMP3(NS4)=X2PLOT(I)
19376              IF(ICOLT.EQ.MAXCP6)TEMP3(NS4)=TAGPLO(I)
1937711303       CONTINUE
1937811305       CONTINUE
1937911301     CONTINUE
19380        ENDIF
19381      ENDIF
19382C
19383      IF(NS2.LE.0)THEN
19384        IF(ICASL8.EQ.'NUMB')THEN
19385          RIGHT=0
19386          IFOUND='YES'
19387          IERROR='NO'
19388          IF(ICASEL.EQ.'PARA')GOTO15000
19389          IF(ICASEL.EQ.'ELEM')GOTO16000
19390        ELSE
19391          WRITE(ICOUT,999)
19392          CALL DPWRST('XXX','BUG ')
19393          WRITE(ICOUT,12111)ICASL8
1939412111     FORMAT('****** ERROR--AFTER SUBSET/FOR/EXCEPT CLAUSE ',
19395     1           'APPLIED FOR STATISTIC ',A4,',')
19396          CALL DPWRST('XXX','BUG ')
19397          WRITE(ICOUT,12113)
1939812113     FORMAT('       THE RESPONSE VARIABLE IS EMPTY.  THE ',
19399     1           'STATISTIC WAS NOT COMPUTED.')
19400          CALL DPWRST('XXX','BUG ')
19401          IFOUND='YES'
19402          IERROR='YES'
19403          GOTO19000
19404        ENDIF
19405      ENDIF
19406C
19407      IWRITE='ON'
19408      IF(IPRINT.EQ.'OFF')IWRITE='OFF'
19409      IF(IFEEDB.EQ.'OFF')IWRITE='OFF'
19410C
19411      ISTEPN='12'
19412      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19413     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19414C
19415      CALL CMPST2(TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,XTEMP3,
19416     1            MAXNXT,NS2,NS3,NS4,NUMVAR,ICASL8,
19417     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
19418     1            DTEMP1,DTEMP2,DTEMP3,
19419     1            RIGHT,
19420     1            ISUBRO,IBUGA3,IERROR)
19421C
19422      GOTO11900
19423C
1942411900 CONTINUE
19425      ISTEPN='13'
19426      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19427     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19428C
19429      IFOUND='YES'
19430      IF(IERROR.EQ.'YES')GOTO19000
19431      IF(ICASEL.EQ.'PARA')GOTO15000
19432      IF(ICASEL.EQ.'ELEM')GOTO16000
19433C
19434C               *****************************************************
19435C               **  STEP 15--                                      **
19436C               **  TREAT THE PARAMETER CASE.                      **
19437C               **  EXAMPLE--LET A = MEAN X                        **
19438C               **           WHERE A WAS PREVIOUSLY UNDEFINED      **
19439C               **           OR WHERE A WAS PREVIOUSLY A PARAMETER.**
19440C               **  CARRY OUT THE LIST UPDATING  AND               **
19441C               **  GENERATE THE INFORMATIVE PRINTING.             **
19442C               **  THEN EXIT.                                     **
19443C               *****************************************************
19444C
1944515000 CONTINUE
19446      ISTEPN='15'
19447      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19448     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19449C
19450      IHNAME(ILISTL)=ILEFT
19451      IHNAM2(ILISTL)=ILEFT2
19452      IUSE(ILISTL)='P'
19453      VALUE(ILISTL)=RIGHT
19454      IF(VALUE(ILISTL).GE.0.0)THEN
19455        IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
19456      ELSE
19457        IVALUE(ILISTL)=INT(VALUE(ILISTL)-0.5)
19458      ENDIF
19459      IN(ILISTL)=1
19460      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
19461C
19462      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
19463        WRITE(ICOUT,999)
19464        CALL DPWRST('XXX','BUG ')
19465        WRITE(ICOUT,15111)ILEFT,ILEFT2,RIGHT
1946615111   FORMAT('THE COMPUTED VALUE OF THE CONSTANT ',
19467     1         A4,A4,'      = ',G15.7)
19468        CALL DPWRST('XXX','BUG ')
19469        WRITE(ICOUT,999)
19470        CALL DPWRST('XXX','BUG ')
19471      ENDIF
19472      GOTO19000
19473C
19474C               *********************************************
19475C               **  STEP 16--                              **
19476C               **  TREAT THE ELEMENT SPECIFICATION CASE.  **
19477C               **  EXAMPLE--LET Y(4)=MEAN X               **
19478C               **  ALSO, CARRY OUT THE LIST UPDATING AND  **
19479C               **  GENERATE THE INFORMATIVE PRINTING.     **
19480C               *********************************************
19481C
1948216000 CONTINUE
19483      ISTEPN='16'
19484      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STC2')
19485     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19486C
19487      IARGL=INT1(4)
19488      IF(1.LE.IARGL.AND.IARGL.LE.MAXN)GOTO16100
19489      WRITE(ICOUT,221)
19490      CALL DPWRST('XXX','BUG ')
19491      WRITE(ICOUT,16002)IARGL,ILEFT
1949216002 FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
19493      CALL DPWRST('XXX','BUG ')
19494      WRITE(ICOUT,16003)RIGHT
1949516003 FORMAT('      (THAT WAS TO BE SET = ',G15.7,')')
19496      CALL DPWRST('XXX','BUG ')
19497      WRITE(ICOUT,16004)
1949816004 FORMAT('      WAS LESS THAN 1 OR')
19499      CALL DPWRST('XXX','BUG ')
19500      WRITE(ICOUT,16005)MAXN
1950116005 FORMAT('      GREATER THAN THE MAX ALLOWABLE ',I8)
19502      CALL DPWRST('XXX','BUG ')
19503      IERROR='YES'
19504      GOTO19000
19505C
1950616100 CONTINUE
19507      IF(NEWNAM.EQ.'NO')NIOLD=IN(ILISTL)
19508      IF(NEWNAM.EQ.'YES')NIOLD=1
19509      NINEW=NIOLD
19510      IF(IARGL.GT.NINEW)NINEW=IARGL
19511      NS2=1
19512C
19513      IJ=MAXN*(ICOLL-1)+IARGL
19514      IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
19515      IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT
19516      IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT
19517      IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT
19518      IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT
19519      IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT
19520      IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT
19521C
19522      IHNAME(ILISTL)=ILEFT
19523      IHNAM2(ILISTL)=ILEFT2
19524      IUSE(ILISTL)='V'
19525      IVALUE(ILISTL)=ICOLL
19526      VALUE(ILISTL)=ICOLL
19527      IN(ILISTL)=NINEW
19528C
19529      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
19530      IF(NEWNAM.EQ.'YES')NUMCOL=NUMCOL+1
19531C
19532      DO16200J4=1,NUMNAM
19533      IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)GOTO16205
19534      GOTO16200
1953516205 CONTINUE
19536      IUSE(J4)='V'
19537      IVALUE(J4)=ICOLL
19538      VALUE(J4)=ICOLL
19539      IN(J4)=NINEW
1954016200 CONTINUE
19541C
19542      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
19543        WRITE(ICOUT,999)
19544        CALL DPWRST('XXX','BUG ')
19545        WRITE(ICOUT,16111)ILEFT,ILEFT2,IARGL,RIGHT
1954616111   FORMAT('THE COMPUTED VALUE OF ',
19547     1         A4,A4,'(',I6,')      = ',G15.7)
19548        CALL DPWRST('XXX','BUG ')
19549        WRITE(ICOUT,999)
19550        CALL DPWRST('XXX','BUG ')
19551      ENDIF
19552      GOTO19000
19553C
19554C               *****************
19555C               **  STEP 90--  **
19556C               **  EXIT       **
19557C               *****************
19558C
1955919000 CONTINUE
19560      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STC2')THEN
19561        WRITE(ICOUT,999)
19562        CALL DPWRST('XXX','BUG ')
19563        WRITE(ICOUT,19011)
1956419011   FORMAT('***** AT THE END       OF DPSTC2--')
19565        CALL DPWRST('XXX','BUG ')
19566        WRITE(ICOUT,19012)IFOUND,IERROR
1956719012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
19568        CALL DPWRST('XXX','BUG ')
19569        WRITE(ICOUT,9014)ICASL8,ICASEL,IWRITE,IFLAGD,ILOCV
19570 9014   FORMAT('ICASL8,ICASEL,IWRITE,IFLAGD,ILOCV = ',4(A4,2X),I8)
19571        CALL DPWRST('XXX','BUG ')
19572        WRITE(ICOUT,19015)NS2,NS3,NS4,RIGHT
1957319015   FORMAT('NS2,NS3,NS4,RIGHT = ',3I8,G15.7)
19574        CALL DPWRST('XXX','BUG ')
19575      ENDIF
19576C
19577      RETURN
19578      END
19579      SUBROUTINE DPSTCH(ISUBRO,IBUGA3,IERROR)
19580C
19581C     PURPOSE--CONVERT AN ARRAY OF NUMBERS TO A STRING THAT
19582C              CONTAINS THE ASCII CHARACTERS CORRESPONDING TO
19583C              THE NUMBERS.
19584C     EXAMPLE--LET SOUT = CHARACTER IVAL
19585C     WRITTEN BY--ALAN HECKERT
19586C                 STATISTICAL ENGINEERING DIVISION
19587C                 INFORMATION TECHNOLOGY LABORATORY
19588C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
19589C                 GAITHERSBURG, MD 20899-8980
19590C                 PHONE--301-975-2899
19591C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19592C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
19593C     LANGUAGE--ANSI FORTRAN (1977)
19594C     VERSION NUMBER--2008/11
19595C     ORIGINAL VERSION--NOVEMBER  2008.
19596C
19597C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19598C
19599      CHARACTER*4 ISUBRO
19600      CHARACTER*4 IBUGA3
19601      CHARACTER*4 IERROR
19602C
19603      CHARACTER*4 NEWNAM
19604      CHARACTER*4 NEWCOL
19605      CHARACTER*4 ICASEL
19606      CHARACTER*4 ICASER
19607      CHARACTER*4 IHLEFT
19608      CHARACTER*4 IHLEF2
19609      CHARACTER*4 IHRIGH
19610      CHARACTER*4 IHRIG2
19611C
19612      CHARACTER*1 IC
19613C
19614      CHARACTER*4 ISUBN1
19615      CHARACTER*4 ISUBN2
19616      CHARACTER*4 ISTEPN
19617C
19618      CHARACTER*4 ILAB(10)
19619C
19620C---------------------------------------------------------------------
19621C
19622C-----COMMON----------------------------------------------------------
19623C
19624      INCLUDE 'DPCOPA.INC'
19625      INCLUDE 'DPCOHK.INC'
19626      INCLUDE 'DPCODA.INC'
19627      INCLUDE 'DPCOP2.INC'
19628C
19629C-----START POINT-----------------------------------------------------
19630C
19631      ISUBN1='DPST'
19632      ISUBN2='CH  '
19633      IERROR='NO'
19634C
19635      ILOC3=0
19636      ICOLR=0
19637      AVAL=0.0
19638C
19639      MAXCP1=MAXCOL+1
19640      MAXCP2=MAXCOL+2
19641      MAXCP3=MAXCOL+3
19642      MAXCP4=MAXCOL+4
19643      MAXCP5=MAXCOL+5
19644      MAXCP6=MAXCOL+6
19645C
19646      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCH')THEN
19647        WRITE(ICOUT,999)
19648        CALL DPWRST('XXX','BUG ')
19649        WRITE(ICOUT,51)
19650   51   FORMAT('***** AT THE BEGINNING OF DPSTCH--')
19651        CALL DPWRST('XXX','BUG ')
19652        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
19653   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
19654        CALL DPWRST('XXX','BUG ')
19655        DO55I=1,NUMNAM
19656          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
19657     1                   IVSTOP(I)
19658   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
19659     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
19660          CALL DPWRST('XXX','BUG ')
19661   55   CONTINUE
19662        WRITE(ICOUT,57)NUMCHF,MAXCHF
19663   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
19664        CALL DPWRST('XXX','BUG ')
19665        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
19666   60   FORMAT('IFUNC(.)  = ',120A1)
19667        CALL DPWRST('XXX','BUG ')
19668      ENDIF
19669C
19670C               **********************************
19671C               **  STEP 1--                    **
19672C               **  INITIALIZE SOME VARIABLES.  **
19673C               **********************************
19674C
19675      ISTEPN='1'
19676      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCH')
19677     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19678C
19679      NEWNAM='NO'
19680      NEWCOL='NO'
19681      ICASEL='UNKN'
19682      NIOLD1=0
19683      ICOLL=0
19684C
19685C               ******************************************************
19686C               **  STEP 2--                                         *
19687C               **  EXAMINE THE ARGUMENT ON THE                      *
19688C               **  LEFT-HAND SIDE--                                 *
19689C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
19690C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
19691C               ******************************************************
19692C
19693      ISTEPN='2'
19694      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCH')
19695     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19696C
19697      IHLEFT=IHARG(1)
19698      IHLEF2=IHARG2(1)
19699C
19700      DO2000I=1,NUMNAM
19701        I2=I
19702        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
19703          IF(IUSE(I2).EQ.'F')THEN
19704            ICASEL='STRI'
19705            ILISTL=I2
19706            GOTO2299
19707          ELSE
19708            WRITE(ICOUT,999)
19709  999       FORMAT(1X)
19710            CALL DPWRST('XXX','BUG ')
19711            WRITE(ICOUT,2001)
19712 2001       FORMAT('***** ERROR IN CHARACTER--')
19713            CALL DPWRST('XXX','BUG ')
19714            WRITE(ICOUT,2003)IHLEFT,IHLEF2
19715 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
19716     1             A4,A4,')')
19717            CALL DPWRST('XXX','BUG ')
19718            WRITE(ICOUT,2005)
19719 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
19720            CALL DPWRST('XXX','BUG ')
19721            IERROR='YES'
19722            GOTO9000
19723          ENDIF
19724        ENDIF
19725 2000 CONTINUE
19726C
19727      NEWNAM='YES'
19728      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
19729C
19730      ILISTL=NUMNAM+1
19731      IF(ILISTL.GT.MAXNAM)THEN
19732        WRITE(ICOUT,999)
19733        CALL DPWRST('XXX','BUG ')
19734        WRITE(ICOUT,2001)
19735        CALL DPWRST('XXX','BUG ')
19736        WRITE(ICOUT,2202)
19737 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
19738     1         'FUNCTION')
19739        CALL DPWRST('XXX','BUG ')
19740        WRITE(ICOUT,2203)MAXNAM
19741 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
19742        CALL DPWRST('XXX','BUG ')
19743        WRITE(ICOUT,2204)
19744 2204   FORMAT('      ENTER      STATUS')
19745        CALL DPWRST('XXX','BUG ')
19746        WRITE(ICOUT,2205)
19747 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
19748        CALL DPWRST('XXX','BUG ')
19749        WRITE(ICOUT,2206)
19750 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
19751     1         'USED NAMES.')
19752        CALL DPWRST('XXX','BUG ')
19753        IERROR='YES'
19754        GOTO9000
19755      ENDIF
19756C
19757 2299 CONTINUE
19758C
19759C               *****************************************************
19760C               **  STEP 3--                                       **
19761C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
19762C               *****************************************************
19763C
19764      ISTEPN='3A'
19765      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCH')
19766     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19767C
19768      IHRIGH=IHARG(4)
19769      IHRIG2=IHARG2(4)
19770      DO3000I=1,NUMNAM
19771        I4=I
19772        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
19773          IF(IUSE(I4).EQ.'P')THEN
19774            ICASER='PARA'
19775            ILISTR=I4
19776            IVAL=IVALUE(ILISTR)
19777            NIOLD=1
19778            GOTO3099
19779          ELSEIF(IUSE(I4).EQ.'V')THEN
19780            ICASER='VARI'
19781            ILISTR=I4
19782            ICOLR=IVALUE(ILISTR)
19783            NIOLD=IN(ILISTR)
19784            GOTO3099
19785          ELSE
19786            WRITE(ICOUT,999)
19787            CALL DPWRST('XXX','BUG ')
19788            WRITE(ICOUT,2001)
19789            CALL DPWRST('XXX','BUG ')
19790            WRITE(ICOUT,3003)IHRIGH,IHRIG2
19791 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
19792     1             A4,A4,')')
19793            CALL DPWRST('XXX','BUG ')
19794            WRITE(ICOUT,3005)
19795 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER ',
19796     1             'OR A VARIABLE.')
19797            CALL DPWRST('XXX','BUG ')
19798            IERROR='YES'
19799            GOTO9000
19800          ENDIF
19801        ENDIF
19802 3000 CONTINUE
19803C
19804      IF(NUMARG.GE.4)THEN
19805        IF(IARGT(4).EQ.'NUMB')THEN
19806          IVAL=IARG(4)
19807          ICASER='PARA'
19808          GOTO3099
19809        ENDIF
19810      ENDIF
19811C
19812      WRITE(ICOUT,999)
19813      CALL DPWRST('XXX','BUG ')
19814      WRITE(ICOUT,2001)
19815      CALL DPWRST('XXX','BUG ')
19816      WRITE(ICOUT,3003)IHRIGH,IHRIG2
19817      CALL DPWRST('XXX','BUG ')
19818      WRITE(ICOUT,3015)
19819 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
19820      CALL DPWRST('XXX','BUG ')
19821      IERROR='YES'
19822      GOTO9000
19823C
19824 3099 CONTINUE
19825C
19826C               *****************************************************
19827C               **  STEP 4--                                       **
19828C               **  CREATE THE STRING                              **
19829C               *****************************************************
19830C
19831      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCH')THEN
19832        ISTEPN='4'
19833        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19834        WRITE(ICOUT,4011)ILISTR,NIOLD
19835 4011   FORMAT('ILISTR,NIOLD = ',2I8)
19836        CALL DPWRST('XXX','BUG ')
19837        WRITE(ICOUT,4013)ICASEL,ICASER
19838 4013   FORMAT('ICASEL,ICASER = ',A4,2X,A4)
19839        CALL DPWRST('XXX','BUG ')
19840      ENDIF
19841C
19842      IF(ICASER.EQ.'PARA')THEN
19843C
19844        IF(IVAL.LT.0 .OR. IVAL.GT.255)THEN
19845          WRITE(ICOUT,999)
19846          CALL DPWRST('XXX','BUG ')
19847          WRITE(ICOUT,2001)
19848          CALL DPWRST('XXX','BUG ')
19849          WRITE(ICOUT,4021)
19850 4021     FORMAT('      THE PARAMETER ON THE RIGHT HAND SIDE IS')
19851          CALL DPWRST('XXX','BUG ')
19852          WRITE(ICOUT,4023)
19853 4023     FORMAT('      OUTSIDE THE (0,255) INTERVAL.')
19854          CALL DPWRST('XXX','BUG ')
19855          WRITE(ICOUT,4025)IVAL
19856 4025     FORMAT('      THE VALUE OF THE PARAMETER IS ',I8)
19857          CALL DPWRST('XXX','BUG ')
19858          IERROR='YES'
19859          GOTO9000
19860        ENDIF
19861C
19862        ICNT=1
19863        IFUNC2(ICNT)=' '
19864        CALL DPCONA(IVAL,IC)
19865        IFUNC2(ICNT)(1:1)=IC
19866      ELSEIF(ICASER.EQ.'VARI')THEN
19867        ICNT=0
19868        DO4110I=1,NIOLD
19869          IJ=MAXN*(ICOLR-1)+I
19870          IF(ICOLR.LE.MAXCOL)AVAL=V(IJ)
19871          IF(ICOLR.EQ.MAXCP1)AVAL=PRED(I)
19872          IF(ICOLR.EQ.MAXCP2)AVAL=RES(I)
19873          IF(ICOLR.EQ.MAXCP3)AVAL=YPLOT(I)
19874          IF(ICOLR.EQ.MAXCP4)AVAL=XPLOT(I)
19875          IF(ICOLR.EQ.MAXCP5)AVAL=X2PLOT(I)
19876          IF(ICOLR.EQ.MAXCP6)AVAL=TAGPLO(I)
19877          IVAL=INT(AVAL+0.5)
19878C
19879          IF(IVAL.LT.0 .OR. IVAL.GT.255)THEN
19880            WRITE(ICOUT,999)
19881            CALL DPWRST('XXX','BUG ')
19882            WRITE(ICOUT,2001)
19883            CALL DPWRST('XXX','BUG ')
19884            WRITE(ICOUT,4121)I
19885 4121       FORMAT('      ROW ',I8,' OF THE VARIABLE ON THE RIGHT ',
19886     1             'HAND SIDE IS')
19887            CALL DPWRST('XXX','BUG ')
19888            WRITE(ICOUT,4123)
19889 4123       FORMAT('      OUTSIDE THE (0,255) INTERVAL.')
19890            CALL DPWRST('XXX','BUG ')
19891            WRITE(ICOUT,4125)IVAL
19892 4125       FORMAT('      THE VALUE OF THE ROW ELEMENT IS ',I8)
19893            CALL DPWRST('XXX','BUG ')
19894            IERROR='YES'
19895            GOTO9000
19896          ENDIF
19897C
19898          ICNT=ICNT+1
19899          IFUNC2(ICNT)=' '
19900          CALL DPCONA(IVAL,IC)
19901          IFUNC2(ICNT)(1:1)=IC
19902C
19903 4110   CONTINUE
19904      ELSE
19905        IERROR='YES'
19906        GOTO9000
19907      ENDIF
19908C
19909C               *****************************************************
19910C               **  STEP 5--                                       **
19911C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
19912C               *****************************************************
19913C
19914C
19915      IF(ICASEL.EQ.'STRI')THEN
19916C
19917        ISTEPN='5'
19918        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCH')
19919     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19920C
19921        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
19922     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
19923CCCCC1              NEWNAM,MAXN3,
19924     1              NEWNAM,MAXNAM,
19925     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
19926        IF(IERROR.EQ.'YES')GOTO9000
19927C
19928        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
19929          WRITE(ICOUT,999)
19930          CALL DPWRST('XXX','BUG ')
19931          WRITE(ICOUT,6606)IHLEFT,IHLEF2
19932 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
19933          CALL DPWRST('XXX','BUG ')
19934          ILAB(1)='TO T'
19935          ILAB(2)='HE F'
19936          ILAB(3)='UNCT'
19937          ILAB(4)='ION '
19938          ILAB(5)='    '
19939          ILAB(6)=' -- '
19940          NUMWDL=6
19941          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
19942C
19943          WRITE(ICOUT,999)
19944          CALL DPWRST('XXX','BUG ')
19945C
19946        ENDIF
19947C
19948      ENDIF
19949C
19950C
19951C               ****************
19952C               **  STEP 90-- **
19953C               **  EXIT.     **
19954C               ****************
19955C
19956 9000 CONTINUE
19957      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCH')THEN
19958        WRITE(ICOUT,999)
19959        CALL DPWRST('XXX','BUG ')
19960        WRITE(ICOUT,9011)
19961 9011   FORMAT('***** AT THE END       OF DPSTCH--')
19962        CALL DPWRST('XXX','BUG ')
19963        WRITE(ICOUT,9013)NUMNAM
19964 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
19965        CALL DPWRST('XXX','BUG ')
19966        DO9015I=1,NUMNAM
19967          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
19968     1                     IVSTAR(I),IVSTOP(I)
19969 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
19970     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
19971          CALL DPWRST('XXX','BUG ')
19972 9015   CONTINUE
19973      ENDIF
19974C
19975      RETURN
19976      END
19977      SUBROUTINE DPSTCK(ISUBRO,IBUGA3,IERROR)
19978C
19979C     PURPOSE--CHECK IF THE ARGUMENTS SPECIFIED ON THE COMMAND ARE
19980C              CURRENTLY DEFINED NAMES
19981C     EXAMPLE--LET IFLAG = CHECK NAMES S1 S2 S3
19982C     WRITTEN BY--ALAN HECKERT
19983C                 STATISTICAL ENGINEERING DIVISION
19984C                 INFORMATION TECHNOLOGY LABORATORY
19985C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
19986C                 GAITHERSBURG, MD 20899-8980
19987C                 PHONE--301-975-2899
19988C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19989C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
19990C     LANGUAGE--ANSI FORTRAN (1977)
19991C     VERSION NUMBER--2015/03
19992C     ORIGINAL VERSION--MARCH     2015.
19993C     UPDATED         --JUNE      2016. CHECK NAME OUTPUT
19994C                                             <FILLIBEN/DEFAULT>
19995C
19996C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19997C
19998      CHARACTER*4 ISUBRO
19999      CHARACTER*4 IBUGA3
20000      CHARACTER*4 IERROR
20001C
20002      CHARACTER*4 NEWNAM
20003      CHARACTER*4 NEWCOL
20004      CHARACTER*4 ICASEL
20005      CHARACTER*4 IHLEFT
20006      CHARACTER*4 IHLEF2
20007      CHARACTER*4 IHRIGH
20008      CHARACTER*4 IHRIG2
20009C
20010      CHARACTER*4 IHWUSE
20011      CHARACTER*4 MESSAG
20012      CHARACTER*4 IHP
20013      CHARACTER*4 IHP2
20014      CHARACTER*4 ISUBN1
20015      CHARACTER*4 ISUBN2
20016      CHARACTER*4 ISTEPN
20017      CHARACTER*4 IFOUND
20018C
20019      CHARACTER*8 ISTR
20020      CHARACTER*8 IQUOTE
20021C
20022      PARAMETER (MAXIND=100)
20023      CHARACTER*4 IVARN1(MAXIND)
20024      CHARACTER*4 IVARN2(MAXIND)
20025C---------------------------------------------------------------------
20026C
20027C-----COMMON----------------------------------------------------------
20028C
20029      INCLUDE 'DPCOPA.INC'
20030      INCLUDE 'DPCOHK.INC'
20031      INCLUDE 'DPCODA.INC'
20032      INCLUDE 'DPCOST.INC'
20033C
20034      CHARACTER (LEN=MAXFNC) :: IMANAM(10)
20035      COMMON/IMAC/IMACNU,IMALEV,IMANAM
20036C
20037C-----COMMON VARIABLES (GENERAL)--------------------------------------
20038C
20039      INCLUDE 'DPCOP2.INC'
20040C
20041C-----START POINT-----------------------------------------------------
20042C
20043      ISUBN1='DPST'
20044      ISUBN2='CK  '
20045      IERROR='NO'
20046      IFOUND='NO'
20047      IQUOTE="'"
20048C
20049      ILOC3=0
20050      ICOLL=0
20051      ILISTL=0
20052      NIOLD=0
20053C
20054      MAXCP1=MAXCOL+1
20055      MAXCP2=MAXCOL+2
20056      MAXCP3=MAXCOL+3
20057      MAXCP4=MAXCOL+4
20058      MAXCP5=MAXCOL+5
20059      MAXCP6=MAXCOL+6
20060C
20061      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCK')THEN
20062        WRITE(ICOUT,999)
20063        CALL DPWRST('XXX','BUG ')
20064        WRITE(ICOUT,51)
20065   51   FORMAT('***** AT THE BEGINNING OF DPSTCK--')
20066        CALL DPWRST('XXX','BUG ')
20067        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF
20068   52   FORMAT('IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF = ',2(A4,2X),3I8)
20069        CALL DPWRST('XXX','BUG ')
20070        DO55I=1,NUMNAM
20071          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
20072     1                   IVSTOP(I)
20073   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
20074     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
20075          CALL DPWRST('XXX','BUG ')
20076   55   CONTINUE
20077      ENDIF
20078C
20079C               **********************************
20080C               **  STEP 1--                    **
20081C               **  INITIALIZE SOME VARIABLES.  **
20082C               **********************************
20083C
20084      ISTEPN='1'
20085      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCK')
20086     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20087C
20088      NEWNAM='NO'
20089      NEWCOL='NO'
20090      ICASEL='UNKN'
20091C
20092C               ******************************************************
20093C               **  STEP 2--                                         *
20094C               **  EXAMINE THE LEFT-HAND SIDE--                     *
20095C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
20096C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
20097C               ******************************************************
20098C
20099      ISTEPN='2'
20100      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCK')
20101     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20102C
20103      IHLEFT=IHARG(1)
20104      IHLEF2=IHARG2(1)
20105C
20106      DO1910I=1,4
20107        IF(IHLEFT(I:I).EQ.'(')THEN
20108          IHLEFT(I:4)=' '
20109          IHLEF2=' '
20110          ICASEL='ELEM'
20111          GOTO1999
20112        ENDIF
20113 1910 CONTINUE
20114      DO1920I=1,4
20115        IF(IHLEF2(I:I).EQ.'(')THEN
20116          IHLEF2(I:4)=' '
20117          ICASEL='ELEM'
20118          GOTO1999
20119        ENDIF
20120 1920 CONTINUE
20121 1999 CONTINUE
20122C
20123      DO2000I=1,NUMNAM
20124        I2=I
20125        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
20126          IF(IUSE(I2).EQ.'P')THEN
20127            ICASEL='PARA'
20128            ILISTL=I2
20129            GOTO2900
20130          ELSEIF(IUSE(I2).EQ.'V')THEN
20131            ICASEL='ELEM'
20132            ILISTL=I2
20133            ICOLL=IVALUE(ILISTL)
20134            NIOLD=IN(ILISTL)
20135            GOTO2900
20136          ELSE
20137            WRITE(ICOUT,999)
20138  999       FORMAT(1X)
20139            CALL DPWRST('XXX','BUG ')
20140            WRITE(ICOUT,2001)
20141 2001       FORMAT('***** ERROR IN CHECK NAME--')
20142            CALL DPWRST('XXX','BUG ')
20143            WRITE(ICOUT,2003)IHLEFT,IHLEF2
20144 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
20145     1             A4,A4,')')
20146            CALL DPWRST('XXX','BUG ')
20147            WRITE(ICOUT,2005)
20148 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
20149            CALL DPWRST('XXX','BUG ')
20150            IERROR='YES'
20151            GOTO9000
20152          ENDIF
20153        ENDIF
20154 2000 CONTINUE
20155C
20156      NEWNAM='YES'
20157      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
20158C
20159      ILISTL=NUMNAM+1
20160      IF(ILISTL.GT.MAXNAM)THEN
20161        WRITE(ICOUT,999)
20162        CALL DPWRST('XXX','BUG ')
20163        WRITE(ICOUT,2001)
20164        CALL DPWRST('XXX','BUG ')
20165        WRITE(ICOUT,2202)
20166 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
20167     1         'FUNCTION')
20168        CALL DPWRST('XXX','BUG ')
20169        WRITE(ICOUT,2203)MAXNAM
20170 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
20171        CALL DPWRST('XXX','BUG ')
20172        WRITE(ICOUT,2204)
20173 2204   FORMAT('      ENTER      STATUS')
20174        CALL DPWRST('XXX','BUG ')
20175        WRITE(ICOUT,2205)
20176 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
20177        CALL DPWRST('XXX','BUG ')
20178        WRITE(ICOUT,2206)
20179 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
20180     1         'USED NAMES.')
20181        CALL DPWRST('XXX','BUG ')
20182        IERROR='YES'
20183        GOTO9000
20184      ENDIF
20185C
20186 2900 CONTINUE
20187C
20188C               *****************************************************
20189C               **  STEP 3--                                       **
20190C               **  EXTRACT THE NAMES ON THE RIGHT HAND SIDE       **
20191C               *****************************************************
20192C
20193      ISTEPN='3'
20194      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCK')
20195     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20196C
20197      IFRST=5
20198      IF(NUMARG.LT.IFRST)THEN
20199        IFLAG=-1
20200        GOTO3900
20201      ENDIF
20202      IFLAG=1
20203C
20204      JMIN=IFRST
20205      JMAX=NUMARG
20206      CALL EXTVA3(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND,
20207     1            IHNAME,IHNAM2,NUMNAM,
20208     1            IVARN1,IVARN2,NUMIND,
20209     1            IBUGA3,ISUBRO,IERROR)
20210      IERROR='NO'
20211C
20212      DO3010II=1,NUMIND
20213        IHRIGH=IVARN1(II)
20214        IHRIG2=IVARN2(II)
20215        DO3020I=1,NUMNAM
20216          I4=I
20217          IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
20218            GOTO3029
20219          ENDIF
20220 3020   CONTINUE
20221C
20222        IFLAG=0
20223C
20224C       2016/06: OPTION TO PRINT ERROR MESSAGE AS IN JIM FILLIBEN'S
20225C                CHECKINPUT.DP MACRO.
20226C
20227        IF(ICHKNA.EQ.'DEFA')THEN
20228          WRITE(ICOUT,999)
20229          CALL DPWRST('XXX','BUG ')
20230          WRITE(ICOUT,2001)
20231          CALL DPWRST('XXX','BUG ')
20232          WRITE(ICOUT,3023)IHRIGH,IHRIG2
20233 3023     FORMAT('      NAME ',2A4,' WAS NOT FOUND IN THE CURRENT ',
20234     1           'NAME LIST.')
20235          CALL DPWRST('XXX','BUG ')
20236        ELSE
20237C
20238C         CHECK FOR "HTMLSW" PARAMETER
20239C         CHECK FOR "IBATCH" PARAMETER
20240C
20241C         IF THIS IS SET TO 1, JIM HAS SOME SPECIAL CODE FOR PYTHON
20242C         BASED INTERFACE.  SO HERE, JUST SET IFLAG TO -1.
20243C
20244          IHP='HTML'
20245          IHP2='SW  '
20246          IHWUSE='P'
20247          MESSAG='NO'
20248          CALL CHECKN(IHP,IHP2,IHWUSE,
20249     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
20250     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
20251          IHTML=0
20252          IF(IERROR.EQ.'NO')IHTML=INT(VALUE(ILOCP)+0.5)
20253          IF(IHTML.NE.1)IHTML=0
20254          IERROR='NO'
20255C
20256          IHP='IBAT'
20257          IHP2='CH  '
20258          IHWUSE='P'
20259          MESSAG='NO'
20260          CALL CHECKN(IHP,IHP2,IHWUSE,
20261     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
20262     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
20263          IBATCH=0
20264          IF(IERROR.EQ.'NO')IBATCH=INT(VALUE(ILOCP)+0.5)
20265          IF(IBATCH.NE.1)IBATCH=0
20266          IERROR='NO'
20267C
20268          IF(IHTML.EQ.1)THEN
20269            IFLAG=-1
20270            WRITE(ICOUT,999)
20271            CALL DPWRST('XXX','BUG ')
20272            WRITE(ICOUT,3026)
20273            CALL DPWRST('XXX','BUG ')
20274C
20275            IF(IMACNU.NE.5)THEN
20276              WRITE(ICOUT,3031)IMANAM(IMALEV)
20277              CALL DPWRST('XXX','BUG ')
20278            ELSE
20279              WRITE(ICOUT,3032)
20280              CALL DPWRST('XXX','BUG ')
20281            ENDIF
20282            IF(IHRIGH.EQ.'K   ')THEN
20283              WRITE(ICOUT,3041)
20284              CALL DPWRST('XXX','BUG ')
20285            ELSE
20286              WRITE(ICOUT,3051)IHRIGH,IHRIG2
20287              CALL DPWRST('XXX','BUG ')
20288            ENDIF
20289            WRITE(ICOUT,999)
20290            CALL DPWRST('XXX','BUG ')
20291            WRITE(ICOUT,3120)
20292 3120       FORMAT('       1. Close this error-message window ',
20293     1             '(via X-out)')
20294            CALL DPWRST('XXX','BUG ')
20295            WRITE(ICOUT,3122)
20296 3122       FORMAT('       2. Terminate the Dataplot run ',
20297     1             '(via Ctrl-C)')
20298            CALL DPWRST('XXX','BUG ')
20299            WRITE(ICOUT,3124)IQUOTE
20300 3124       FORMAT('       3. Edit Dataplot',A1,'s main routine to ',
20301     1             'define k')
20302            CALL DPWRST('XXX','BUG ')
20303            WRITE(ICOUT,3126)
20304 3126       FORMAT('               Example: let k = 3')
20305            CALL DPWRST('XXX','BUG ')
20306            WRITE(ICOUT,3128)
20307 3128       FORMAT('       4. Rerun Dataplot')
20308            CALL DPWRST('XXX','BUG ')
20309            WRITE(ICOUT,3026)
20310            CALL DPWRST('XXX','BUG ')
20311            CALL DPPAUS(IBUGA3,IFOUND,IERROR)
20312C
20313          ELSE
20314C
20315            WRITE(ICOUT,999)
20316            CALL DPWRST('XXX','BUG ')
20317            WRITE(ICOUT,3026)
20318 3026       FORMAT('========================================')
20319            CALL DPWRST('XXX','BUG ')
20320C
20321            IF(IMACNU.NE.5)THEN
20322              WRITE(ICOUT,3031)IMANAM(IMALEV)
20323 3031         FORMAT('Error--Macro ',A80)
20324              CALL DPWRST('XXX','BUG ')
20325            ELSE
20326              WRITE(ICOUT,3032)
20327 3032         FORMAT('Error--From terminal')
20328              CALL DPWRST('XXX','BUG ')
20329            ENDIF
20330            IF(IHRIGH.EQ.'K   ')THEN
20331              WRITE(ICOUT,3041)
20332 3041         FORMAT('        is missing required input:  k (= ',
20333     1               'number of factors')
20334              CALL DPWRST('XXX','BUG ')
20335            ELSE
20336              WRITE(ICOUT,3051)IHRIGH,IHRIG2
20337 3051         FORMAT('        is missing required input: ',2A4)
20338              CALL DPWRST('XXX','BUG ')
20339            ENDIF
20340            IF(IBATCH.EQ.0)THEN
20341              WRITE(ICOUT,3058)
20342 3058         FORMAT('        Click    Enter   to continue ...')
20343              CALL DPWRST('XXX','BUG ')
20344              WRITE(ICOUT,3026)
20345              CALL DPWRST('XXX','BUG ')
20346              WRITE(ICOUT,999)
20347              CALL DPWRST('XXX','BUG ')
20348              CALL DPPAUS(IBUGA3,IFOUND,IERROR)
20349            ELSE
20350              WRITE(ICOUT,3026)
20351              CALL DPWRST('XXX','BUG ')
20352              WRITE(ICOUT,999)
20353              CALL DPWRST('XXX','BUG ')
20354            ENDIF
20355          ENDIF
20356        ENDIF
20357C
20358 3029   CONTINUE
20359 3010 CONTINUE
20360C
20361 3900 CONTINUE
20362C
20363C               *****************************************************
20364C               **  STEP 4--                                       **
20365C               **  SAVE PARAMETER                                 **
20366C               *****************************************************
20367C
20368      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCK')THEN
20369        ISTEPN='4'
20370        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20371        WRITE(ICOUT,4011)ISTART,ISTOP,IVAL
20372 4011   FORMAT('ISTART,ISTOP,IVAL = ',3I8)
20373        CALL DPWRST('XXX','BUG ')
20374        WRITE(ICOUT,4013)ICASEL
20375 4013   FORMAT('ICASEL = ',A4)
20376        CALL DPWRST('XXX','BUG ')
20377      ENDIF
20378C
20379      IF(ICASEL.EQ.'PARA')THEN
20380C
20381        ISTEPN='4A'
20382        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCK')
20383     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20384C
20385        IHNAME(ILISTL)=IHLEFT
20386        IHNAM2(ILISTL)=IHLEF2
20387        IUSE(ILISTL)='P'
20388        VALUE(ILISTL)=REAL(IFLAG)
20389        IVALUE(ILISTL)=IFLAG
20390        IN(ILISTL)=1
20391        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
20392      ELSEIF(ICASEL.EQ.'ELEM')THEN
20393C
20394C       SEARCH IANS STRING FOR "(xx) =".  IF NO PARENTHESIS
20395C       FOUND BEFORE "=", THEN DO NOT KNOW WHAT ROW OF THE
20396C       VARIABLE TO SAVE.  TREAT THIS AS AN ERROR.
20397C
20398        NLEFT=-1
20399        NRIGHT=-1
20400        NEQUAL=-1
20401        DO4201I=1,IWIDTH
20402          IF(IANS(I)(1:1).EQ.'(' .AND. NLEFT.LT.0)THEN
20403            NLEFT=I
20404          ELSEIF(IANS(I)(1:1).EQ.')' .AND. NRIGHT.LT.0)THEN
20405            NRIGHT=I
20406          ELSEIF(IANS(I)(1:1).EQ.'=' .AND. NEQUAL.LT.0)THEN
20407            NEQUAL=I
20408          ENDIF
20409 4201   CONTINUE
20410C
20411C       NEED  NLEFT < NRIGHT < NEQUAL
20412C
20413        NSTRT=NLEFT+1
20414        NSTOP=NRIGHT-1
20415        NLEN=NSTOP-NSTRT+1
20416        IF(NLEFT.GT.NRIGHT .OR. NRIGHT.GT.NEQUAL .OR.
20417     1     NSTRT.GT.NSTOP .OR. NLEN.GT.8) THEN
20418          WRITE(ICOUT,999)
20419          CALL DPWRST('XXX','BUG ')
20420          WRITE(ICOUT,2001)
20421          CALL DPWRST('XXX','BUG ')
20422          WRITE(ICOUT,4211)
20423 4211     FORMAT('      UNRECOGNIZED SYNTAX FOR VARIABLE ELEMENT ON ',
20424     1           'LEFT HAND SIDE EQUAL SIGN.')
20425          CALL DPWRST('XXX','BUG ')
20426          IERROR='YES'
20427          GOTO9000
20428        ELSE
20429          ISTR=' '
20430          DO4216I=1,NLEN
20431            ISTR(I:I)=IANS(NSTRT+I-1)(1:1)
20432 4216     CONTINUE
20433          READ(ISTR,'(I8)',ERR=4218)IARGL
20434          GOTO4219
20435C
20436 4218     CONTINUE
20437          WRITE(ICOUT,999)
20438          CALL DPWRST('XXX','BUG ')
20439          WRITE(ICOUT,2001)
20440          CALL DPWRST('XXX','BUG ')
20441          WRITE(ICOUT,4211)
20442          CALL DPWRST('XXX','BUG ')
20443          IERROR='YES'
20444          GOTO9000
20445C
20446 4219     CONTINUE
20447        ENDIF
20448C
20449        IF(IARGL.LT.1 .OR. IARGL.GT.MAXN)THEN
20450          WRITE(ICOUT,999)
20451          CALL DPWRST('XXX','BUG ')
20452          WRITE(ICOUT,2001)
20453          CALL DPWRST('XXX','BUG ')
20454          WRITE(ICOUT,4231)IARGL,ILEFT
20455 4231     FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
20456          CALL DPWRST('XXX','BUG ')
20457          WRITE(ICOUT,4233)
20458 4233     FORMAT('      WAS LESS THAN 1 OR GREATER THAN THE')
20459          CALL DPWRST('XXX','BUG ')
20460          WRITE(ICOUT,4235)MAXN
20461 4235     FORMAT('      MAXIMUM ALLOWABLE ',I8)
20462          CALL DPWRST('XXX','BUG ')
20463          IERROR='YES'
20464          GOTO9000
20465        ENDIF
20466C
20467        IF(NEWNAM.EQ.'YES')THEN
20468          NIOLD=1
20469        ENDIF
20470        NINEW=NIOLD
20471        IF(IARGL.GT.NINEW)NINEW=IARGL
20472        NS2=1
20473C
20474        RIGHT=REAL(IFLAG)
20475        IJ=MAXN*(ICOLL-1)+IARGL
20476        IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
20477        IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT
20478        IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT
20479        IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT
20480        IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT
20481        IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT
20482        IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT
20483C
20484        IHNAME(ILISTL)=IHLEFT
20485        IHNAM2(ILISTL)=IHLEF2
20486        IUSE(ILISTL)='V'
20487        IVALUE(ILISTL)=ICOLL
20488        VALUE(ILISTL)=ICOLL
20489        IN(ILISTL)=NINEW
20490C
20491        IF(NEWNAM.EQ.'YES')THEN
20492          NUMNAM=NUMNAM+1
20493          NUMCOL=NUMCOL+1
20494        ENDIF
20495C
20496        DO4290J4=1,NUMNAM
20497          IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)THEN
20498            IUSE(J4)='V'
20499            IVALUE(J4)=ICOLL
20500            VALUE(J4)=ICOLL
20501            IN(J4)=NINEW
20502            GOTO4299
20503          ENDIF
20504 4290   CONTINUE
20505 4299   CONTINUE
20506C
20507      ENDIF
20508C
20509      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON' .AND. ICHKNA.EQ.'DEFA')THEN
20510        WRITE(ICOUT,999)
20511        CALL DPWRST('XXX','BUG ')
20512        WRITE(ICOUT,8011)IFLAG
20513 8011   FORMAT('THE STATUS FLAG FOR CHECK NAME = ',I8)
20514        CALL DPWRST('XXX','BUG ')
20515        WRITE(ICOUT,999)
20516        CALL DPWRST('XXX','BUG ')
20517      ENDIF
20518      GOTO9000
20519C
20520C
20521C               ****************
20522C               **  STEP 90-- **
20523C               **  EXIT.     **
20524C               ****************
20525C
20526 9000 CONTINUE
20527      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCK')THEN
20528        WRITE(ICOUT,999)
20529        CALL DPWRST('XXX','BUG ')
20530        WRITE(ICOUT,9011)
20531 9011   FORMAT('***** AT THE END       OF DPSTCK--')
20532        CALL DPWRST('XXX','BUG ')
20533        WRITE(ICOUT,9013)NUMNAM
20534 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
20535        CALL DPWRST('XXX','BUG ')
20536        DO9015I=1,NUMNAM
20537          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
20538     1                     IVSTAR(I),IVSTOP(I)
20539 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
20540     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
20541          CALL DPWRST('XXX','BUG ')
20542 9015   CONTINUE
20543      ENDIF
20544C
20545      RETURN
20546      END
20547      SUBROUTINE DPSTCM(ISUBRO,IBUGA3,IERROR)
20548C
20549C     PURPOSE--COMPARE TWO STRINGS AND RETURN A 1 IF THEY ARE
20550C              IDENTICAL AND A 0 IF THEY ARE NOT.
20551C     EXAMPLE--LET IFLAG = STRING COMPARE S1 S2
20552C     WRITTEN BY--ALAN HECKERT
20553C                 STATISTICAL ENGINEERING DIVISION
20554C                 INFORMATION TECHNOLOGY LABORATORY
20555C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
20556C                 GAITHERSBURG, MD 20899-8980
20557C                 PHONE--301-975-2899
20558C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20559C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
20560C     LANGUAGE--ANSI FORTRAN (1977)
20561C     VERSION NUMBER--2011/1
20562C     ORIGINAL VERSION--JANUARY   2011.
20563C
20564C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20565C
20566      CHARACTER*4 ISUBRO
20567      CHARACTER*4 IBUGA3
20568      CHARACTER*4 IERROR
20569C
20570      CHARACTER*4 NEWNAM
20571      CHARACTER*4 NEWCOL
20572      CHARACTER*4 ICASEL
20573      CHARACTER*4 IHLEFT
20574      CHARACTER*4 IHLEF2
20575      CHARACTER*4 IHRIGH
20576      CHARACTER*4 IHRIG2
20577C
20578      CHARACTER*4 ISUBN1
20579      CHARACTER*4 ISUBN2
20580      CHARACTER*4 ISTEPN
20581C
20582      CHARACTER*132 ISTR
20583C
20584C---------------------------------------------------------------------
20585C
20586C-----COMMON----------------------------------------------------------
20587C
20588      INCLUDE 'DPCOPA.INC'
20589      INCLUDE 'DPCOHK.INC'
20590      INCLUDE 'DPCODA.INC'
20591      INCLUDE 'DPCOP2.INC'
20592C
20593C-----START POINT-----------------------------------------------------
20594C
20595      ISUBN1='DPST'
20596      ISUBN2='CM  '
20597      IERROR='NO'
20598C
20599      ILOC3=0
20600      NLEN1=0
20601      NLEN2=0
20602C
20603      MAXCP1=MAXCOL+1
20604      MAXCP2=MAXCOL+2
20605      MAXCP3=MAXCOL+3
20606      MAXCP4=MAXCOL+4
20607      MAXCP5=MAXCOL+5
20608      MAXCP6=MAXCOL+6
20609C
20610      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCM')THEN
20611        WRITE(ICOUT,999)
20612        CALL DPWRST('XXX','BUG ')
20613        WRITE(ICOUT,51)
20614   51   FORMAT('***** AT THE BEGINNING OF DPSTCM--')
20615        CALL DPWRST('XXX','BUG ')
20616        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
20617   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
20618        CALL DPWRST('XXX','BUG ')
20619        DO55I=1,NUMNAM
20620          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
20621     1                   IVSTOP(I)
20622   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
20623     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
20624          CALL DPWRST('XXX','BUG ')
20625   55   CONTINUE
20626        WRITE(ICOUT,57)NUMCHF,MAXCHF
20627   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
20628        CALL DPWRST('XXX','BUG ')
20629        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
20630   60   FORMAT('IFUNC(.)  = ',120A1)
20631        CALL DPWRST('XXX','BUG ')
20632      ENDIF
20633C
20634C               **********************************
20635C               **  STEP 1--                    **
20636C               **  INITIALIZE SOME VARIABLES.  **
20637C               **********************************
20638C
20639      ISTEPN='1'
20640      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCM')
20641     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20642C
20643      NEWNAM='NO'
20644      NEWCOL='NO'
20645      ICASEL='UNKN'
20646      NIOLD1=0
20647      ICOLL=0
20648C
20649C               ******************************************************
20650C               **  STEP 2--                                         *
20651C               **  EXAMINE THE ARGUMENT ON THE                      *
20652C               **  LEFT-HAND SIDE--                                 *
20653C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
20654C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
20655C               ******************************************************
20656C
20657      ISTEPN='2'
20658      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCM')
20659     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20660C
20661      IHLEFT=IHARG(1)
20662      IHLEF2=IHARG2(1)
20663C
20664      DO2000I=1,NUMNAM
20665        I2=I
20666        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
20667          IF(IUSE(I2).EQ.'P')THEN
20668            ICASEL='PARA'
20669            ILISTL=I2
20670            GOTO2299
20671          ELSE
20672            WRITE(ICOUT,999)
20673  999       FORMAT(1X)
20674            CALL DPWRST('XXX','BUG ')
20675            WRITE(ICOUT,2001)
20676 2001       FORMAT('***** ERROR IN STRING COMPARE--')
20677            CALL DPWRST('XXX','BUG ')
20678            WRITE(ICOUT,2003)IHLEFT,IHLEF2
20679 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
20680     1             A4,A4,')')
20681            CALL DPWRST('XXX','BUG ')
20682            WRITE(ICOUT,2005)
20683 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
20684            CALL DPWRST('XXX','BUG ')
20685            IERROR='YES'
20686            GOTO9000
20687          ENDIF
20688        ENDIF
20689 2000 CONTINUE
20690C
20691      NEWNAM='YES'
20692      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
20693C
20694      ILISTL=NUMNAM+1
20695      IF(ILISTL.GT.MAXNAM)THEN
20696        WRITE(ICOUT,999)
20697        CALL DPWRST('XXX','BUG ')
20698        WRITE(ICOUT,2001)
20699        CALL DPWRST('XXX','BUG ')
20700        WRITE(ICOUT,2202)
20701 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
20702     1         'FUNCTION')
20703        CALL DPWRST('XXX','BUG ')
20704        WRITE(ICOUT,2203)MAXNAM
20705 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
20706        CALL DPWRST('XXX','BUG ')
20707        WRITE(ICOUT,2204)
20708 2204   FORMAT('      ENTER      STATUS')
20709        CALL DPWRST('XXX','BUG ')
20710        WRITE(ICOUT,2205)
20711 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
20712        CALL DPWRST('XXX','BUG ')
20713        WRITE(ICOUT,2206)
20714 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
20715     1         'USED NAMES.')
20716        CALL DPWRST('XXX','BUG ')
20717        IERROR='YES'
20718        GOTO9000
20719      ENDIF
20720C
20721 2299 CONTINUE
20722C
20723C               *****************************************************
20724C               **  STEP 3--                                       **
20725C               **  LOOP THROUGH THE NAMES ON THE RIGHT HAND SIDE  **
20726C               *****************************************************
20727C
20728      ISTEPN='3A'
20729      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCM')
20730     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20731C
20732      IF(NUMARG.LT.5)THEN
20733        WRITE(ICOUT,999)
20734        CALL DPWRST('XXX','BUG ')
20735        WRITE(ICOUT,2001)
20736        CALL DPWRST('XXX','BUG ')
20737        WRITE(ICOUT,3003)
20738 3003   FORMAT('      THERE ARE NO STRINGS SPECIFIED ON THE RIGHT ',
20739     1         'HAND SIDE.')
20740        CALL DPWRST('XXX','BUG ')
20741        IERROR='YES'
20742        GOTO9000
20743      ENDIF
20744C
20745      IF(NUMARG.GT.6)THEN
20746        WRITE(ICOUT,999)
20747        CALL DPWRST('XXX','BUG ')
20748        WRITE(ICOUT,2001)
20749        CALL DPWRST('XXX','BUG ')
20750        WRITE(ICOUT,3013)
20751 3013   FORMAT('      THERE ARE MORE THAN TWO STRINGS SPECIFIED ON ',
20752     1         'THE RIGHT HAND SIDE.')
20753        CALL DPWRST('XXX','BUG ')
20754        IERROR='YES'
20755        GOTO9000
20756      ENDIF
20757C
20758      ICNT=0
20759      DO3000I=5,NUMARG
20760C
20761        IHRIGH=IHARG(I)
20762        IHRIG2=IHARG2(I)
20763C
20764        DO3100J=1,NUMNAM
20765          I4=J
20766          IF(IHRIGH.EQ.IHNAME(J).AND.IHRIG2.EQ.IHNAM2(J))THEN
20767            IF(IUSE(I4).NE.'F')THEN
20768              WRITE(ICOUT,999)
20769              CALL DPWRST('XXX','BUG ')
20770              WRITE(ICOUT,2001)
20771              CALL DPWRST('XXX','BUG ')
20772              WRITE(ICOUT,3103)IHRIGH,IHRIG2
20773 3103         FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
20774     1               A4,A4,')')
20775              CALL DPWRST('XXX','BUG ')
20776              WRITE(ICOUT,3105)
20777 3105         FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
20778              CALL DPWRST('XXX','BUG ')
20779              IERROR='YES'
20780              GOTO9000
20781            ELSE
20782              IF(I.EQ.5)THEN
20783                ISTRT1=IVSTAR(I4)
20784                ISTOP1=IVSTOP(I4)
20785                NLEN1=ISTOP1-ISTRT1+1
20786              ELSE
20787                ISTRT2=IVSTAR(I4)
20788                ISTOP2=IVSTOP(I4)
20789                NLEN2=ISTOP2-ISTRT2+1
20790              ENDIF
20791              GOTO3199
20792            ENDIF
20793          ENDIF
20794 3100   CONTINUE
20795C
20796        WRITE(ICOUT,999)
20797        CALL DPWRST('XXX','BUG ')
20798        WRITE(ICOUT,2001)
20799        CALL DPWRST('XXX','BUG ')
20800        WRITE(ICOUT,3103)IHRIGH,IHRIG2
20801        CALL DPWRST('XXX','BUG ')
20802        WRITE(ICOUT,3115)
20803 3115   FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
20804        CALL DPWRST('XXX','BUG ')
20805        IERROR='YES'
20806        GOTO9000
20807C
20808 3199   CONTINUE
20809C
20810C
20811C               *****************************************************
20812C               **  STEP 4--                                       **
20813C               **  DETERMINE IF STRINGS ARE THE SAME              **
20814C               *****************************************************
20815C
20816        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCM')THEN
20817          ISTEPN='3B'
20818          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20819          WRITE(ICOUT,3211)I,ISTART,ISTOP,NLEN
20820 3211     FORMAT('I,ISTART,ISTOP,NLEN = ',4I8)
20821          CALL DPWRST('XXX','BUG ')
20822          WRITE(ICOUT,3214)ICASEL
20823 3214     FORMAT('ICASEL = ',A4)
20824          CALL DPWRST('XXX','BUG ')
20825        ENDIF
20826C
20827        IVAL=1
20828        IF(NLEN1.NE.NLEN2)THEN
20829          IVAL=0
20830        ELSE
20831          DO3310II=1,NLEN1
20832            IINDX1=ISTRT1+II
20833            IINDX2=ISTRT2+II
20834            IF(IFUNC(IINDX1).NE.IFUNC(IINDX2))THEN
20835              IVAL=0
20836              GOTO3319
20837            ENDIF
20838 3310     CONTINUE
20839 3319     CONTINUE
20840        ENDIF
20841C
20842 3000 CONTINUE
20843C
20844C               *****************************************************
20845C               **  STEP 5--                                       **
20846C               **  SAVE PARAMETER                                 **
20847C               *****************************************************
20848C
20849C
20850      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCM')THEN
20851        ISTEPN='4'
20852        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20853        WRITE(ICOUT,4011)ISTRT1,ISTOP1,ISTRT2,ISTOP2
20854 4011   FORMAT('ISTRT1,ISTOP1,ISTRT2,ISTOP2 = ',4I8)
20855        CALL DPWRST('XXX','BUG ')
20856        WRITE(ICOUT,4013)ICASEL
20857 4013   FORMAT('ICASEL = ',A4)
20858        CALL DPWRST('XXX','BUG ')
20859      ENDIF
20860C
20861      IF(ICASEL.EQ.'PARA')THEN
20862C
20863        ISTEPN='4A'
20864        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCM')
20865     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20866C
20867        IHNAME(ILISTL)=IHLEFT
20868        IHNAM2(ILISTL)=IHLEF2
20869        IUSE(ILISTL)='P'
20870        VALUE(ILISTL)=REAL(IVAL)
20871        IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
20872        IN(ILISTL)=1
20873        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
20874C
20875        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
20876          WRITE(ICOUT,999)
20877          CALL DPWRST('XXX','BUG ')
20878          WRITE(ICOUT,15111)IHLEFT,IHLEF2,IVAL
2087915111     FORMAT(A4,A4,' CONTAINS THE VALUE ',I4)
20880          CALL DPWRST('XXX','BUG ')
20881          WRITE(ICOUT,999)
20882          CALL DPWRST('XXX','BUG ')
20883        ENDIF
20884      ELSEIF(ICASEL.EQ.'ELEM')THEN
20885C
20886C       SEARCH IANS STRING FOR "(xx) =".  IF NO PARENTHESIS
20887C       FOUND BEFORE "=", THEN DO NOT KNOW WHAT ROW OF THE
20888C       VARIABLE TO SAVE.  TREAT THIS AS AN ERROR.
20889C
20890        NLEFT=-1
20891        NRIGHT=-1
20892        NEQUAL=-1
20893        DO16001I=1,IWIDTH
20894          IF(IANS(I)(1:1).EQ.'(' .AND. NLEFT.LT.0)THEN
20895            NLEFT=I
20896          ELSEIF(IANS(I)(1:1).EQ.')' .AND. NRIGHT.LT.0)THEN
20897            NRIGHT=I
20898          ELSEIF(IANS(I)(1:1).EQ.'=' .AND. NEQUAL.LT.0)THEN
20899            NEQUAL=I
20900          ENDIF
2090116001   CONTINUE
20902C
20903C       NEED  NLEFT < NRIGHT < NEQUAL
20904C
20905        NSTRT=NLEFT+1
20906        NSTOP=NRIGHT-1
20907        NLEN=NSTOP-NSTRT+1
20908        IF(NLEFT.GT.NRIGHT .OR. NRIGHT.GT.NEQUAL .OR.
20909     1     NSTRT.GT.NSTOP .OR. NLEN.GT.8) THEN
20910          WRITE(ICOUT,999)
20911          CALL DPWRST('XXX','BUG ')
20912          WRITE(ICOUT,2001)
20913          CALL DPWRST('XXX','BUG ')
20914          WRITE(ICOUT,16011)
2091516011     FORMAT('      UNRECOGNIZED SYNTAX FOR VARIABLE ELEMENT ON')
20916          CALL DPWRST('XXX','BUG ')
20917          WRITE(ICOUT,16013)
2091816013     FORMAT('      LEFT HAND SIDE EQUAL SIGN.')
20919          CALL DPWRST('XXX','BUG ')
20920          IERROR='YES'
20921          GOTO9000
20922        ELSE
20923          ISTR=' '
20924          DO16020I=1,NLEN
20925            ISTR(I:I)=IANS(NSTRT+I-1)(1:1)
2092616020     CONTINUE
20927          READ(ISTR,'(I8)',ERR=16029)IARGL
20928          GOTO16049
20929C
2093016029     CONTINUE
20931          WRITE(ICOUT,999)
20932          CALL DPWRST('XXX','BUG ')
20933          WRITE(ICOUT,2001)
20934          CALL DPWRST('XXX','BUG ')
20935          WRITE(ICOUT,16011)
20936          CALL DPWRST('XXX','BUG ')
20937          WRITE(ICOUT,16013)
20938          CALL DPWRST('XXX','BUG ')
20939          IERROR='YES'
20940          GOTO9000
20941C
2094216049     CONTINUE
20943        ENDIF
20944C
20945        IF(IARGL.LT.1 .OR. IARGL.GT.MAXN)THEN
20946          WRITE(ICOUT,999)
20947          CALL DPWRST('XXX','BUG ')
20948          WRITE(ICOUT,2001)
20949          CALL DPWRST('XXX','BUG ')
20950          WRITE(ICOUT,16052)IARGL,ILEFT
2095116052     FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
20952          CALL DPWRST('XXX','BUG ')
20953          WRITE(ICOUT,16054)
2095416054     FORMAT('      WAS LESS THAN 1 OR GREATER THAN THE')
20955          CALL DPWRST('XXX','BUG ')
20956          WRITE(ICOUT,16055)MAXN
2095716055     FORMAT('      MAXIMUM ALLOWABLE ',I8)
20958          CALL DPWRST('XXX','BUG ')
20959          IERROR='YES'
20960          GOTO9000
20961        ENDIF
20962C
20963        IF(NEWNAM.EQ.'YES')THEN
20964          NIOLD=1
20965        ENDIF
20966        NINEW=NIOLD
20967        IF(IARGL.GT.NINEW)NINEW=IARGL
20968        NS2=1
20969C
20970        RIGHT=REAL(IVAL)
20971        IJ=MAXN*(ICOLL-1)+IARGL
20972        IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
20973        IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT
20974        IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT
20975        IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT
20976        IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT
20977        IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT
20978        IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT
20979C
20980        IHNAME(ILISTL)=IHLEFT
20981        IHNAM2(ILISTL)=IHLEF2
20982        IUSE(ILISTL)='V'
20983        IVALUE(ILISTL)=ICOLL
20984        VALUE(ILISTL)=ICOLL
20985        IN(ILISTL)=NINEW
20986C
20987        IF(NEWNAM.EQ.'YES')THEN
20988          NUMNAM=NUMNAM+1
20989          NUMCOL=NUMCOL+1
20990        ENDIF
20991C
20992        DO16200J4=1,NUMNAM
20993          IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)THEN
20994            IUSE(J4)='V'
20995            IVALUE(J4)=ICOLL
20996            VALUE(J4)=ICOLL
20997            IN(J4)=NINEW
20998            GOTO16209
20999          ENDIF
2100016200   CONTINUE
2100116209   CONTINUE
21002C
21003        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
21004          WRITE(ICOUT,999)
21005          CALL DPWRST('XXX','BUG ')
21006          WRITE(ICOUT,16211)IVAL
2100716211     FORMAT('THE RESULT OF THE STRING COMPARISON  = ',I4)
21008          CALL DPWRST('XXX','BUG ')
21009          WRITE(ICOUT,999)
21010          CALL DPWRST('XXX','BUG ')
21011        ENDIF
21012      ENDIF
21013      GOTO9000
21014C
21015C
21016C               ****************
21017C               **  STEP 90-- **
21018C               **  EXIT.     **
21019C               ****************
21020C
21021 9000 CONTINUE
21022      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCM')THEN
21023        WRITE(ICOUT,999)
21024        CALL DPWRST('XXX','BUG ')
21025        WRITE(ICOUT,9011)
21026 9011   FORMAT('***** AT THE END       OF DPSTCM--')
21027        CALL DPWRST('XXX','BUG ')
21028        WRITE(ICOUT,9013)NUMNAM
21029 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
21030        CALL DPWRST('XXX','BUG ')
21031        DO9015I=1,NUMNAM
21032          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
21033     1                     IVSTAR(I),IVSTOP(I)
21034 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
21035     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
21036          CALL DPWRST('XXX','BUG ')
21037 9015   CONTINUE
21038      ENDIF
21039C
21040      RETURN
21041      END
21042      SUBROUTINE DPSTCN(ISUBRO,IBUGA3,IERROR)
21043C
21044C     PURPOSE--CONCATENATE ONE OR MORE STRINGS.
21045C     EXAMPLE--LET SOUT = STRING CONCATENATE S1 S2 S3 S4
21046C     WRITTEN BY--ALAN HECKERT
21047C                 STATISTICAL ENGINEERING DIVISION
21048C                 INFORMATION TECHNOLOGY LABORATORY
21049C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
21050C                 GAITHERSBURG, MD 20899-8980
21051C                 PHONE--301-975-2899
21052C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21053C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
21054C     LANGUAGE--ANSI FORTRAN (1977)
21055C     VERSION NUMBER--2008/11
21056C     ORIGINAL VERSION--NOVEMBER  2008.
21057C
21058C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21059C
21060      CHARACTER*4 ISUBRO
21061      CHARACTER*4 IBUGA3
21062      CHARACTER*4 IERROR
21063C
21064      CHARACTER*4 NEWNAM
21065      CHARACTER*4 NEWCOL
21066      CHARACTER*4 ICASEL
21067      CHARACTER*4 IHLEFT
21068      CHARACTER*4 IHLEF2
21069      CHARACTER*4 IHRIGH
21070      CHARACTER*4 IHRIG2
21071C
21072      CHARACTER*4 ISUBN1
21073      CHARACTER*4 ISUBN2
21074      CHARACTER*4 ISTEPN
21075C
21076      CHARACTER*4 ILAB(10)
21077C
21078C---------------------------------------------------------------------
21079C
21080C-----COMMON----------------------------------------------------------
21081C
21082      INCLUDE 'DPCOPA.INC'
21083      INCLUDE 'DPCOHK.INC'
21084      INCLUDE 'DPCODA.INC'
21085      INCLUDE 'DPCOP2.INC'
21086C
21087C-----START POINT-----------------------------------------------------
21088C
21089      ISUBN1='DPST'
21090      ISUBN2='CN  '
21091      IERROR='NO'
21092C
21093      ILOC3=0
21094C
21095      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCN')THEN
21096        WRITE(ICOUT,999)
21097        CALL DPWRST('XXX','BUG ')
21098        WRITE(ICOUT,51)
21099   51   FORMAT('***** AT THE BEGINNING OF DPSTCN--')
21100        CALL DPWRST('XXX','BUG ')
21101        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
21102   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
21103        CALL DPWRST('XXX','BUG ')
21104        DO55I=1,NUMNAM
21105          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
21106     1                   IVSTOP(I)
21107   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
21108     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
21109          CALL DPWRST('XXX','BUG ')
21110   55   CONTINUE
21111        WRITE(ICOUT,57)NUMCHF,MAXCHF
21112   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
21113        CALL DPWRST('XXX','BUG ')
21114        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
21115   60   FORMAT('IFUNC(.)  = ',120A1)
21116        CALL DPWRST('XXX','BUG ')
21117      ENDIF
21118C
21119C               **********************************
21120C               **  STEP 1--                    **
21121C               **  INITIALIZE SOME VARIABLES.  **
21122C               **********************************
21123C
21124      ISTEPN='1'
21125      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCN')
21126     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21127C
21128      NEWNAM='NO'
21129      NEWCOL='NO'
21130      ICASEL='UNKN'
21131      NIOLD1=0
21132      ICOLL=0
21133C
21134C               ******************************************************
21135C               **  STEP 2--                                         *
21136C               **  EXAMINE THE ARGUMENT ON THE                      *
21137C               **  LEFT-HAND SIDE--                                 *
21138C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
21139C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
21140C               ******************************************************
21141C
21142      ISTEPN='2'
21143      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCN')
21144     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21145C
21146      IHLEFT=IHARG(1)
21147      IHLEF2=IHARG2(1)
21148C
21149      DO2000I=1,NUMNAM
21150        I2=I
21151        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
21152          IF(IUSE(I2).EQ.'F')THEN
21153            ICASEL='STRI'
21154            ILISTL=I2
21155            GOTO2299
21156          ELSE
21157            WRITE(ICOUT,999)
21158  999       FORMAT(1X)
21159            CALL DPWRST('XXX','BUG ')
21160            WRITE(ICOUT,2001)
21161 2001       FORMAT('***** ERROR IN STRING CONCATENATE--')
21162            CALL DPWRST('XXX','BUG ')
21163            WRITE(ICOUT,2003)IHLEFT,IHLEF2
21164 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
21165     1             A4,A4,')')
21166            CALL DPWRST('XXX','BUG ')
21167            WRITE(ICOUT,2005)
21168 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
21169            CALL DPWRST('XXX','BUG ')
21170            IERROR='YES'
21171            GOTO9000
21172          ENDIF
21173        ENDIF
21174 2000 CONTINUE
21175C
21176      NEWNAM='YES'
21177      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
21178C
21179      ILISTL=NUMNAM+1
21180      IF(ILISTL.GT.MAXNAM)THEN
21181        WRITE(ICOUT,999)
21182        CALL DPWRST('XXX','BUG ')
21183        WRITE(ICOUT,2001)
21184        CALL DPWRST('XXX','BUG ')
21185        WRITE(ICOUT,2202)
21186 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
21187     1         'FUNCTION')
21188        CALL DPWRST('XXX','BUG ')
21189        WRITE(ICOUT,2203)MAXNAM
21190 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
21191        CALL DPWRST('XXX','BUG ')
21192        WRITE(ICOUT,2204)
21193 2204   FORMAT('      ENTER      STATUS')
21194        CALL DPWRST('XXX','BUG ')
21195        WRITE(ICOUT,2205)
21196 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
21197        CALL DPWRST('XXX','BUG ')
21198        WRITE(ICOUT,2206)
21199 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
21200     1         'USED NAMES.')
21201        CALL DPWRST('XXX','BUG ')
21202        IERROR='YES'
21203        GOTO9000
21204      ENDIF
21205C
21206 2299 CONTINUE
21207C
21208C               *****************************************************
21209C               **  STEP 3--                                       **
21210C               **  LOOP THROUGH THE NAMES ON THE RIGHT HAND SIDE  **
21211C               *****************************************************
21212C
21213      ISTEPN='3A'
21214      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCN')
21215     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21216C
21217      IF(NUMARG.LT.5)THEN
21218        WRITE(ICOUT,999)
21219        CALL DPWRST('XXX','BUG ')
21220        WRITE(ICOUT,2001)
21221        CALL DPWRST('XXX','BUG ')
21222        WRITE(ICOUT,3003)
21223 3003   FORMAT('      THERE ARE NO STRINGS SPECIFIED ON THE RIGHT ',
21224     1         'HAND SIDE')
21225        CALL DPWRST('XXX','BUG ')
21226        IERROR='YES'
21227        GOTO9000
21228      ENDIF
21229C
21230      ICNT=0
21231      DO3000I=5,NUMARG
21232C
21233        IHRIGH=IHARG(I)
21234        IHRIG2=IHARG2(I)
21235C
21236        DO3100J=1,NUMNAM
21237          I4=J
21238          IF(IHRIGH.EQ.IHNAME(J).AND.IHRIG2.EQ.IHNAM2(J))THEN
21239            IF(IUSE(I4).NE.'F')THEN
21240              WRITE(ICOUT,999)
21241              CALL DPWRST('XXX','BUG ')
21242              WRITE(ICOUT,2001)
21243              CALL DPWRST('XXX','BUG ')
21244              WRITE(ICOUT,3103)IHRIGH,IHRIG2
21245 3103         FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
21246     1               A4,A4,')')
21247              CALL DPWRST('XXX','BUG ')
21248              WRITE(ICOUT,3105)
21249 3105         FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
21250              CALL DPWRST('XXX','BUG ')
21251              IERROR='YES'
21252              GOTO9000
21253            ELSE
21254              ISTART=IVSTAR(I4)
21255              ISTOP=IVSTOP(I4)
21256              NLEN=ISTOP-ISTART+1
21257              GOTO3199
21258            ENDIF
21259          ENDIF
21260 3100   CONTINUE
21261C
21262        WRITE(ICOUT,999)
21263        CALL DPWRST('XXX','BUG ')
21264        WRITE(ICOUT,2001)
21265        CALL DPWRST('XXX','BUG ')
21266        WRITE(ICOUT,3103)IHRIGH,IHRIG2
21267        CALL DPWRST('XXX','BUG ')
21268        WRITE(ICOUT,3115)
21269 3115   FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
21270        CALL DPWRST('XXX','BUG ')
21271        IERROR='YES'
21272        GOTO9000
21273C
21274 3199   CONTINUE
21275C
21276C
21277C               *****************************************************
21278C               **  STEP 4--                                       **
21279C               **  ADD THE CURRENT STRING                         **
21280C               *****************************************************
21281C
21282        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCN')THEN
21283          ISTEPN='3B'
21284          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21285          WRITE(ICOUT,3211)I,ISTART,ISTOP,NLEN
21286 3211     FORMAT('I,ISTART,ISTOP,NLEN = ',4I8)
21287          CALL DPWRST('XXX','BUG ')
21288          WRITE(ICOUT,3214)ICASEL
21289 3214     FORMAT('ICASEL = ',A4)
21290          CALL DPWRST('XXX','BUG ')
21291        ENDIF
21292C
21293        IF(NLEN.GE.1)THEN
21294          DO3310II=ISTART,ISTOP
21295            ICNT=ICNT+1
21296            IFUNC2(ICNT)=IFUNC(II)
21297 3310     CONTINUE
21298        ENDIF
21299C
21300 3000 CONTINUE
21301C
21302C               *****************************************************
21303C               **  STEP 4--                                       **
21304C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
21305C               *****************************************************
21306C
21307C
21308      IF(ICASEL.EQ.'STRI')THEN
21309C
21310        ISTEPN='4'
21311        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCN')
21312     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21313C
21314        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
21315     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
21316CCCCC1              NEWNAM,MAXN3,
21317     1              NEWNAM,MAXNAM,
21318     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
21319        IF(IERROR.EQ.'YES')GOTO9000
21320C
21321        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
21322          WRITE(ICOUT,999)
21323          CALL DPWRST('XXX','BUG ')
21324          WRITE(ICOUT,6606)IHLEFT,IHLEF2
21325 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
21326          CALL DPWRST('XXX','BUG ')
21327          ILAB(1)='TO T'
21328          ILAB(2)='HE F'
21329          ILAB(3)='UNCT'
21330          ILAB(4)='ION '
21331          ILAB(5)='    '
21332          ILAB(6)=' -- '
21333          NUMWDL=6
21334          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
21335C
21336          WRITE(ICOUT,999)
21337          CALL DPWRST('XXX','BUG ')
21338C
21339        ENDIF
21340C
21341      ENDIF
21342C
21343C
21344C               ****************
21345C               **  STEP 90-- **
21346C               **  EXIT.     **
21347C               ****************
21348C
21349 9000 CONTINUE
21350      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCN')THEN
21351        WRITE(ICOUT,999)
21352        CALL DPWRST('XXX','BUG ')
21353        WRITE(ICOUT,9011)
21354 9011   FORMAT('***** AT THE END       OF DPSTCN--')
21355        CALL DPWRST('XXX','BUG ')
21356        WRITE(ICOUT,9013)NUMNAM
21357 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
21358        CALL DPWRST('XXX','BUG ')
21359        DO9015I=1,NUMNAM
21360          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
21361     1                     IVSTAR(I),IVSTOP(I)
21362 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
21363     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
21364          CALL DPWRST('XXX','BUG ')
21365 9015   CONTINUE
21366      ENDIF
21367C
21368      RETURN
21369      END
21370      SUBROUTINE DPSTCB(ISUBRO,IBUGA3,IERROR)
21371C
21372C     PURPOSE--IMPLEMENT THE FOLLOWING COMMAND
21373C
21374C                LET SOUT = STRING COMBINE X1 TO X8
21375C
21376C              THIS COMMAND IS SIMILAR TO THE STRING CONCATENATE, BUT
21377C              DIFFERS IN THE FOLLOWING WAYS:
21378C
21379C                 1) WITH STRING CONCATENATE, THE ARGUMENTS ARE
21380C                    PREVIOUSLY DEFINED STRINGS.  WITH STRING COMBINE,
21381C                    WE FIRST CHECK TO SEE IF THE ARGUMENT IS THE
21382C                    NAME OF A PREVIOUSLY DEFINED STRING.  IF YES,
21383C                    ADD THE CONTENTS OF THE STRING TO THE OUTPUT
21384C                    STRING.  IF NOT, TREAT THE ARGUMENT AS LITERAL TEXT
21385C                    TO BE ADDED TO THE STRING.
21386C
21387C                 2) THIS COMMAND PUTS SPACES BETWEEN THE ARGUMENTS
21388C                    IN THE OUTPUT STRING.
21389C
21390C                 3) YOU CAN USE THE "TO" SYNTAX WITH THIS COMMAND.
21391C
21392C               THIS IS A RATHER SPECIALIZED COMMAND.  IT IS USEFUL FOR
21393C               CREATING COMMAND STRINGS WHERE THE "TO" SYNTAX IS NOT
21394C               SUPPORTED.  FOR EXAMPLE,
21395C
21396C                   LET STALL = STRING COMBINE X1 TO X^K
21397C                   LET FLAG  = DEX CHECK CLASSIC ^STALL
21398C
21399C                IN ADDITION, IT CAN BE USED AS AN ALTERNATIVE TO
21400C                "STRING CONCATENATE" WITH THE DIFFERENCE BEING THAT
21401C                A SPACE IS AUTOMATICALLY ADDED BETWEEN THE INPUT
21402C                STRINGS (YOU HAVE TO DO THIS MANUALLY WITH "STRING
21403C                CONCATENATE).
21404C
21405C     EXAMPLES--LET SOUT = STRING COMBINE S1 S2 S3 S4
21406C               LET SOUT = STRING COMBINE Y X1 TO X8
21407C     WRITTEN BY--ALAN HECKERT
21408C                 STATISTICAL ENGINEERING DIVISION
21409C                 INFORMATION TECHNOLOGY LABORATORY
21410C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
21411C                 GAITHERSBURG, MD 20899-8980
21412C                 PHONE--301-975-2899
21413C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21414C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
21415C     LANGUAGE--ANSI FORTRAN (1977)
21416C     VERSION NUMBER--2018/02
21417C     ORIGINAL VERSION--FEBRUARY  2018.
21418C     UPDATED         --SEPTEMBER 2019. ALLOW USER TO SPECIFY THE
21419C                                       SEPARATOR CHARACTER
21420C     UPDATED         --FEBRUARY  2020. FIX:
21421C                                       LET S = STRING COMBINE X1 TO X1
21422C
21423C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21424C
21425      CHARACTER*4 ISUBRO
21426      CHARACTER*4 IBUGA3
21427      CHARACTER*4 IERROR
21428C
21429      CHARACTER*4 NEWNAM
21430      CHARACTER*4 NEWCOL
21431      CHARACTER*4 ICASEL
21432      CHARACTER*4 IHLEFT
21433      CHARACTER*4 IHLEF2
21434      CHARACTER*4 ISUBN1
21435      CHARACTER*4 ISUBN2
21436      CHARACTER*4 ISTEPN
21437      CHARACTER*4 ISEPZZ
21438C
21439      CHARACTER*4 ILAB(10)
21440C
21441      PARAMETER (MAXIND=100)
21442      CHARACTER*4 IVARN1(MAXIND)
21443      CHARACTER*4 IVARN2(MAXIND)
21444      CHARACTER*4 IVARTY(MAXIND)
21445      REAL PVAR(MAXIND)
21446C
21447C---------------------------------------------------------------------
21448C
21449C-----COMMON----------------------------------------------------------
21450C
21451      INCLUDE 'DPCOPA.INC'
21452      INCLUDE 'DPCOHK.INC'
21453      INCLUDE 'DPCODA.INC'
21454      INCLUDE 'DPCOST.INC'
21455      INCLUDE 'DPCOP2.INC'
21456C
21457C-----START POINT-----------------------------------------------------
21458C
21459      ISUBN1='DPST'
21460      ISUBN2='CB  '
21461      IERROR='NO'
21462      ISEPZZ='    '
21463C
21464      ILOC3=0
21465C
21466      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCB')THEN
21467        WRITE(ICOUT,999)
21468        CALL DPWRST('XXX','BUG ')
21469        WRITE(ICOUT,51)
21470   51   FORMAT('***** AT THE BEGINNING OF DPSTCB--')
21471        CALL DPWRST('XXX','BUG ')
21472        WRITE(ICOUT,52)IBUGA3,ISUBRO,ISTRCS,NUMNAM
21473   52   FORMAT('IBUGA3,ISUBRO,ISTRCS,NUMNAM = ',3(A4,2X),I8)
21474        CALL DPWRST('XXX','BUG ')
21475        DO55I=1,NUMNAM
21476          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
21477     1                   IVSTOP(I)
21478   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
21479     1           'IVSTOP(I)=',I8,2X,2A4,2X,A4,2I8)
21480          CALL DPWRST('XXX','BUG ')
21481   55   CONTINUE
21482        WRITE(ICOUT,57)NUMCHF,MAXCHF
21483   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
21484        CALL DPWRST('XXX','BUG ')
21485        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
21486   60   FORMAT('IFUNC(.)  = ',120A1)
21487        CALL DPWRST('XXX','BUG ')
21488      ENDIF
21489C
21490C               **********************************
21491C               **  STEP 1--                    **
21492C               **  INITIALIZE SOME VARIABLES.  **
21493C               **********************************
21494C
21495      ISTEPN='1'
21496      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')
21497     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21498C
21499      NEWNAM='NO'
21500      NEWCOL='NO'
21501      ICASEL='UNKN'
21502      NIOLD1=0
21503      ICOLL=0
21504C
21505      IF(ISTRCS.EQ.'SP()' .OR. ISTRCS.EQ.'    ')THEN
21506        ISEPZZ=' '
21507        NCSEP=1
21508      ELSE
21509        DO110II=4,1,-1
21510          IF(ISTRCS(II:II).NE.' ')THEN
21511            ISEPZZ(1:II)=ISTRCS(1:II)
21512            NCSEP=II
21513            GOTO119
21514          ENDIF
21515  110   CONTINUE
21516  119   CONTINUE
21517      ENDIF
21518C
21519C               ******************************************************
21520C               **  STEP 2--                                         *
21521C               **  EXAMINE THE ARGUMENT ON THE                      *
21522C               **  LEFT-HAND SIDE--                                 *
21523C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
21524C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
21525C               ******************************************************
21526C
21527      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')THEN
21528        ISTEPN='2'
21529        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21530        WRITE(ICOUT,101)NCSEP,ISEPZZ
21531  101   FORMAT('NCSEP,ISEPZZ = ',I5,2X,A4)
21532        CALL DPWRST('XXX','BUG ')
21533      ENDIF
21534C
21535      IHLEFT=IHARG(1)
21536      IHLEF2=IHARG2(1)
21537C
21538      DO2000I=1,NUMNAM
21539        I2=I
21540        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
21541          IF(IUSE(I2).EQ.'F')THEN
21542            ICASEL='STRI'
21543            ILISTL=I2
21544            GOTO2299
21545          ELSE
21546            WRITE(ICOUT,999)
21547  999       FORMAT(1X)
21548            CALL DPWRST('XXX','BUG ')
21549            WRITE(ICOUT,2001)
21550 2001       FORMAT('***** ERROR IN STRING COMBINE--')
21551            CALL DPWRST('XXX','BUG ')
21552            WRITE(ICOUT,2003)IHLEFT,IHLEF2
21553 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
21554     1             A4,A4,')')
21555            CALL DPWRST('XXX','BUG ')
21556            WRITE(ICOUT,2005)
21557 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
21558            CALL DPWRST('XXX','BUG ')
21559            IERROR='YES'
21560            GOTO9000
21561          ENDIF
21562        ENDIF
21563 2000 CONTINUE
21564C
21565      NEWNAM='YES'
21566      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
21567C
21568      ILISTL=NUMNAM+1
21569      IF(ILISTL.GT.MAXNAM)THEN
21570        WRITE(ICOUT,999)
21571        CALL DPWRST('XXX','BUG ')
21572        WRITE(ICOUT,2001)
21573        CALL DPWRST('XXX','BUG ')
21574        WRITE(ICOUT,2202)
21575 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
21576     1         'FUNCTION')
21577        CALL DPWRST('XXX','BUG ')
21578        WRITE(ICOUT,2203)MAXNAM
21579 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
21580        CALL DPWRST('XXX','BUG ')
21581        WRITE(ICOUT,2204)
21582 2204   FORMAT('      ENTER      STATUS')
21583        CALL DPWRST('XXX','BUG ')
21584        WRITE(ICOUT,2205)
21585 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
21586        CALL DPWRST('XXX','BUG ')
21587        WRITE(ICOUT,2206)
21588 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
21589     1         'USED NAMES.')
21590        CALL DPWRST('XXX','BUG ')
21591        IERROR='YES'
21592        GOTO9000
21593      ENDIF
21594C
21595 2299 CONTINUE
21596C
21597C               *****************************************************
21598C               **  STEP 3--                                       **
21599C               **  LOOP THROUGH THE NAMES ON THE RIGHT HAND SIDE  **
21600C               *****************************************************
21601C
21602      ISTEPN='3A'
21603      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')
21604     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21605C
21606      IF(NUMARG.LT.5)THEN
21607        WRITE(ICOUT,999)
21608        CALL DPWRST('XXX','BUG ')
21609        WRITE(ICOUT,2001)
21610        CALL DPWRST('XXX','BUG ')
21611        WRITE(ICOUT,3003)
21612 3003   FORMAT('      THERE ARE NO STRINGS SPECIFIED ON THE RIGHT ',
21613     1         'HAND SIDE')
21614        CALL DPWRST('XXX','BUG ')
21615        IERROR='YES'
21616        GOTO9000
21617      ENDIF
21618C
21619C     USE EXTVA2 TO EXTRACT LIST OF NAMES (EXTVA2 SUPPORTS THE "TO"
21620C     SYNTAX AND WILL ALSO RETURN TYPE OF EACH NAME).
21621C
21622      IFLAGM=1
21623      IFLAGP=1
21624      IFLAGT=1
21625      JMIN=5
21626      JMAX=NUMARG
21627      CALL EXTVA2(IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,MAXIND,
21628     1            IHNAME,IHNAM2,IUSE,NUMNAM,
21629     1            IVARN1,IVARN2,IVARTY,PVAR,NUMIND,
21630     1            IFLAGM,IFLAGP,IFLAGT,
21631     1            IBUGA3,ISUBRO,IERROR)
21632C
21633      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')THEN
21634        WRITE(ICOUT,3006)IERROR,NUMIND
21635 3006   FORMAT('AFTER EXTVA2: IERROR,NUMIND = ',A4,2X,I5)
21636        CALL DPWRST('XXX','BUG ')
21637        DO3007KK=1,NUMIND
21638          WRITE(ICOUT,3008)KK,IVARN1(KK),IVARN2(KK),IVARTY(KK)
21639 3008     FORMAT('KK,IVARN1(KK),IVARN2(KK),IVARTY(KK) = ',I5,3(2X,A4))
21640          CALL DPWRST('XXX','BUG ')
21641 3007   CONTINUE
21642      ENDIF
21643C
21644      IF(IERROR.EQ.'YES')GOTO9000
21645C
21646C     NOW LOOP THROUGH EACH NAME.  IF NAME IS A PREVIOUSLY DEFINED
21647C     STRING, INSERT THE CONTENTS OF THAT STRING.  OTHERWISE, SIMPLY
21648C     INSERT THE LITERAL NAME INTO THE STRING.
21649C
21650      ICNT=0
21651      DO3000I=1,NUMIND
21652C
21653        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')THEN
21654          ISTEPN='3B'
21655          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21656          WRITE(ICOUT,3001)I,ICASEL,IVARN1(I),IVARN2(I),IVARTY(I)
21657 3001     FORMAT('I,ICASEL,IVARN1(I),IVARN2(I),IVARTY(I) = ',
21658     1           I5,A4,2X,2A4,2X,A4)
21659          CALL DPWRST('XXX','BUG ')
21660        ENDIF
21661C
21662C               *****************************************************
21663C               **  STEP 3A--                                      **
21664C               **  ADD CURRENT ARGUMENT AS LITERAL STRING         **
21665C               *****************************************************
21666C
21667        IF(IVARTY(I).NE.'F   ')THEN
21668          NLEN=1
21669          DO3110J=4,1,-1
21670            IF(IVARN2(I)(J:J).NE.' ')THEN
21671              NLEN=4+J
21672              GOTO3119
21673            ENDIF
21674 3110     CONTINUE
21675          DO3115J=4,1,-1
21676            IF(IVARN1(I)(J:J).NE.' ')THEN
21677              NLEN=J
21678              GOTO3119
21679            ENDIF
21680 3115     CONTINUE
21681 3119     CONTINUE
21682C
21683          DO3120J=1,MIN(4,NLEN)
21684            ICNT=ICNT+1
21685            IFUNC2(ICNT)=IVARN1(I)(J:J)
21686 3120     CONTINUE
21687          IF(NLEN.GE.5)THEN
21688            DO3125J=5,MIN(8,NLEN)
21689              ICNT=ICNT+1
21690              IFUNC2(ICNT)=IVARN2(I)(J-4:J-4)
21691 3125       CONTINUE
21692          ENDIF
21693C
21694          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')THEN
21695            ISTEPN='3C'
21696            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21697            WRITE(ICOUT,3127)I,NLEN,ICNT
21698 3127       FORMAT('I,NLEN,ICNT = ',3I8)
21699            CALL DPWRST('XXX','BUG ')
21700            DO3128KK=1,ICNT
21701              WRITE(ICOUT,3129)KK,IFUNC2(KK)
21702 3129         FORMAT('KK,IFUNC2(KK) = ',I8,2X,A4)
21703            CALL DPWRST('XXX','BUG ')
21704 3128       CONTINUE
21705          ENDIF
21706C
21707        ELSE
21708C
21709C               *****************************************************
21710C               **  STEP 3B--                                      **
21711C               **  ADD THE CURRENT STRING                         **
21712C               *****************************************************
21713C
21714          DO3201KK=1,NUMNAM
21715            IF(IVARN1(I).EQ.IHNAME(KK).AND.IVARN2(I).EQ.IHNAM2(KK))THEN
21716              I4=KK
21717              GOTO3209
21718            ENDIF
21719 3201     CONTINUE
21720 3209     CONTINUE
21721          ISTART=IVSTAR(I4)
21722          ISTOP=IVSTOP(I4)
21723          NLEN=ISTOP-ISTART+1
21724C
21725          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')THEN
21726            ISTEPN='3B'
21727            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21728            WRITE(ICOUT,3211)ICASEL,I,I4,ISTART,ISTOP,NLEN
21729 3211       FORMAT('ICASEL: I,I4,ISTART,ISTOP,NLEN = ',A4,2X,5I8)
21730            CALL DPWRST('XXX','BUG ')
21731          ENDIF
21732C
21733          IF(NLEN.GE.1)THEN
21734            DO3310II=ISTART,ISTOP
21735              ICNT=ICNT+1
21736              IFUNC2(ICNT)=IFUNC(II)
21737 3310       CONTINUE
21738          ENDIF
21739        ENDIF
21740C
21741        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')THEN
21742          WRITE(ICOUT,3311)I,NUMIND,NCSEP,ICNT
21743 3311     FORMAT('I,NUMIND,NCSEP,ICNT = ',4I5)
21744          CALL DPWRST('XXX','BUG ')
21745        ENDIF
21746C
21747        IF(I.LT.NUMIND)THEN
21748          DO3315II=1,NCSEP
21749            ICNT=ICNT+1
21750            IFUNC2(ICNT)=ISEPZZ(II:II)
21751C
21752            IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')THEN
21753              WRITE(ICOUT,3318)II,ICNT,IFUNC2(ICNT)
21754 3318         FORMAT('II,ICNT,IFUNC2(ICNT) = ',2I5,2X,A4)
21755              CALL DPWRST('XXX','BUG ')
21756            ENDIF
21757C
21758 3315     CONTINUE
21759        ENDIF
21760C
21761 3000 CONTINUE
21762C
21763C               *****************************************************
21764C               **  STEP 4--                                       **
21765C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
21766C               *****************************************************
21767C
21768C
21769      IF(ICASEL.EQ.'STRI')THEN
21770C
21771        ISTEPN='4'
21772        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCB')
21773     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21774C
21775        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
21776     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
21777CCCCC1              NEWNAM,MAXN3,
21778     1              NEWNAM,MAXNAM,
21779     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
21780        IF(IERROR.EQ.'YES')GOTO9000
21781C
21782        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
21783          WRITE(ICOUT,999)
21784          CALL DPWRST('XXX','BUG ')
21785          WRITE(ICOUT,6606)IHLEFT,IHLEF2
21786 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
21787          CALL DPWRST('XXX','BUG ')
21788          ILAB(1)='TO T'
21789          ILAB(2)='HE F'
21790          ILAB(3)='UNCT'
21791          ILAB(4)='ION '
21792          ILAB(5)='    '
21793          ILAB(6)=' -- '
21794          NUMWDL=6
21795          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
21796C
21797          WRITE(ICOUT,999)
21798          CALL DPWRST('XXX','BUG ')
21799C
21800        ENDIF
21801C
21802      ENDIF
21803C
21804C
21805C               ****************
21806C               **  STEP 90-- **
21807C               **  EXIT.     **
21808C               ****************
21809C
21810 9000 CONTINUE
21811      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCB')THEN
21812        WRITE(ICOUT,999)
21813        CALL DPWRST('XXX','BUG ')
21814        WRITE(ICOUT,9011)
21815 9011   FORMAT('***** AT THE END       OF DPSTCB--')
21816        CALL DPWRST('XXX','BUG ')
21817      ENDIF
21818C
21819      RETURN
21820      END
21821      SUBROUTINE DPSTCO(ICASEZ,ISUBRO,IBUGA3,IERROR)
21822C
21823C     PURPOSE--IMPLEMENT THE FOLLOWING COMMAND:
21824C
21825C                 LET IFLAG = STRING CONTAINS SORG SMATCH
21826C
21827C              THAT IS, WE CHECK WHETHER A STRING (SORG) CONTAINS THE
21828C              SPECIFIC SUBSTRING (SMATCH) OR NOT.  IF SO, IFLAG IS SET
21829C              TO 1, OTHERWISE IT IS SET TO 0.
21830C     NOTE--THE FOLLOWING SYNTAX IS NOT SUPPORTED FOR THIS COMMAND:
21831C              LET Y(2) = STRING CONTINS  S  SUBSTRING
21832C           ALSO, THE STRINGS ON THE RIGHT HAND SIDE MUST BOTH BE
21833C           PREVIOUSLY DEFINED.
21834C     WRITTEN BY--ALAN HECKERT
21835C                 STATISTICAL ENGINEERING DIVISION
21836C                 INFORMATION TECHNOLOGY LABORATORY
21837C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
21838C                 GAITHERSBURG, MD 20899-8980
21839C                 PHONE--301-975-2899
21840C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21841C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
21842C     LANGUAGE--ANSI FORTRAN (1977)
21843C     VERSION NUMBER--2019/01
21844C     ORIGINAL VERSION--JANUARY   2019.
21845C
21846C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21847C
21848      CHARACTER*4 ICASEZ
21849      CHARACTER*4 ISUBRO
21850      CHARACTER*4 IBUGA3
21851      CHARACTER*4 IERROR
21852C
21853      CHARACTER*4 NEWNAM
21854      CHARACTER*4 NEWNA2
21855      CHARACTER*4 NEWCOL
21856      CHARACTER*4 NEWCO2
21857      CHARACTER*4 ICASEL
21858      CHARACTER*4 IHLEFT
21859      CHARACTER*4 IHLEF2
21860      CHARACTER*4 IHRIGH
21861      CHARACTER*4 IHRIG2
21862      CHARACTER*4 IHRI21
21863      CHARACTER*4 IHRI22
21864C
21865      CHARACTER*4 ISUBN1
21866      CHARACTER*4 ISUBN2
21867      CHARACTER*4 ISTEPN
21868C
21869C---------------------------------------------------------------------
21870C
21871C-----COMMON----------------------------------------------------------
21872C
21873      INCLUDE 'DPCOPA.INC'
21874      INCLUDE 'DPCOHK.INC'
21875      INCLUDE 'DPCODA.INC'
21876      INCLUDE 'DPCOP2.INC'
21877C
21878C-----START POINT-----------------------------------------------------
21879C
21880      ISUBN1='DPST'
21881      ISUBN2='CO  '
21882      IERROR='NO'
21883C
21884      ILOC3=0
21885C
21886      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCO')THEN
21887        WRITE(ICOUT,999)
21888        CALL DPWRST('XXX','BUG ')
21889        WRITE(ICOUT,51)
21890   51   FORMAT('***** AT THE BEGINNING OF DPSTCO--')
21891        CALL DPWRST('XXX','BUG ')
21892        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF
21893   52   FORMAT('IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF = ',2(A4,2X),4I8)
21894        CALL DPWRST('XXX','BUG ')
21895        DO55I=1,NUMNAM
21896          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
21897     1                   IVSTOP(I)
21898   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
21899     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
21900          CALL DPWRST('XXX','BUG ')
21901   55   CONTINUE
21902        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
21903   60   FORMAT('IFUNC(.)  = ',120A1)
21904        CALL DPWRST('XXX','BUG ')
21905      ENDIF
21906C
21907C               **********************************
21908C               **  STEP 1--                    **
21909C               **  INITIALIZE SOME VARIABLES.  **
21910C               **********************************
21911C
21912      ISTEPN='1'
21913      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCO')
21914     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21915C
21916      NEWNAM='NO'
21917      NEWNA2='NO'
21918      NEWCOL='NO'
21919      NEWCO2='NO'
21920      ICASEL='UNKN'
21921      NIOLD1=0
21922      ICOLL=0
21923C
21924C               ******************************************************
21925C               **  STEP 2--                                         *
21926C               **  EXAMINE THE FIRST ARGUMENT ON THE                *
21927C               **  LEFT-HAND SIDE--                                 *
21928C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
21929C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
21930C               ******************************************************
21931C
21932      ISTEPN='2'
21933      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCO')
21934     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21935C
21936      IHLEFT=IHARG(1)
21937      IHLEF2=IHARG2(1)
21938C
21939      DO2000I=1,NUMNAM
21940        I2=I
21941        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
21942          IF(IUSE(I2).EQ.'P')THEN
21943            ICASEL='PARA'
21944            ILISTL=I2
21945            NUMTMP=NUMNAM
21946            GOTO2299
21947          ELSE
21948            WRITE(ICOUT,999)
21949  999       FORMAT(1X)
21950            CALL DPWRST('XXX','BUG ')
21951            WRITE(ICOUT,2001)
21952 2001       FORMAT('***** ERROR IN STRING CONTAINS--')
21953            CALL DPWRST('XXX','BUG ')
21954            WRITE(ICOUT,2003)IHLEFT,IHLEF2
21955 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
21956     1             A4,A4,')')
21957            CALL DPWRST('XXX','BUG ')
21958            WRITE(ICOUT,2005)
21959 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
21960            CALL DPWRST('XXX','BUG ')
21961            IERROR='YES'
21962            GOTO9000
21963          ENDIF
21964        ENDIF
21965 2000 CONTINUE
21966C
21967      NEWNAM='YES'
21968      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
21969C
21970      ILISTL=NUMNAM+1
21971      NUMTMP=NUMNAM+1
21972      IF(ILISTL.GT.MAXNAM)THEN
21973        WRITE(ICOUT,999)
21974        CALL DPWRST('XXX','BUG ')
21975        WRITE(ICOUT,2001)
21976        CALL DPWRST('XXX','BUG ')
21977        WRITE(ICOUT,2202)
21978 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
21979     1         'FUNCTION')
21980        CALL DPWRST('XXX','BUG ')
21981        WRITE(ICOUT,2203)MAXNAM
21982 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
21983        CALL DPWRST('XXX','BUG ')
21984        WRITE(ICOUT,2204)
21985 2204   FORMAT('      ENTER      STATUS')
21986        CALL DPWRST('XXX','BUG ')
21987        WRITE(ICOUT,2205)
21988 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
21989        CALL DPWRST('XXX','BUG ')
21990        WRITE(ICOUT,2206)
21991 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
21992     1         'USED NAMES.')
21993        CALL DPWRST('XXX','BUG ')
21994        IERROR='YES'
21995        GOTO9000
21996      ENDIF
21997C
21998 2299 CONTINUE
21999C
22000C               *****************************************************
22001C               **  STEP 3--                                       **
22002C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
22003C               *****************************************************
22004C
22005      ISTEPN='3A'
22006      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCO')
22007     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22008C
22009      IINDX=5
22010      IHRIGH=IHARG(IINDX)
22011      IHRIG2=IHARG2(IINDX)
22012      DO3000I=1,NUMNAM
22013        I4=I
22014        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
22015          IF(IUSE(I4).NE.'F')THEN
22016            WRITE(ICOUT,999)
22017            CALL DPWRST('XXX','BUG ')
22018            WRITE(ICOUT,2001)
22019            CALL DPWRST('XXX','BUG ')
22020            WRITE(ICOUT,3003)IHRIGH,IHRIG2
22021 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
22022     1             A4,A4,')')
22023            CALL DPWRST('XXX','BUG ')
22024            WRITE(ICOUT,3005)
22025 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
22026            CALL DPWRST('XXX','BUG ')
22027            IERROR='YES'
22028            GOTO9000
22029          ELSE
22030            ISTRT1=IVSTAR(I4)
22031            ISTOP1=IVSTOP(I4)
22032            NLEN1=ISTOP1-ISTRT1+1
22033            GOTO3099
22034          ENDIF
22035        ENDIF
22036 3000 CONTINUE
22037C
22038      WRITE(ICOUT,999)
22039      CALL DPWRST('XXX','BUG ')
22040      WRITE(ICOUT,2001)
22041      CALL DPWRST('XXX','BUG ')
22042      WRITE(ICOUT,3003)IHRIGH,IHRIG2
22043      CALL DPWRST('XXX','BUG ')
22044      WRITE(ICOUT,3015)
22045 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
22046      CALL DPWRST('XXX','BUG ')
22047      IERROR='YES'
22048      GOTO9000
22049C
22050 3099 CONTINUE
22051C
22052C               *****************************************************
22053C               **  STEP 3B-                                       **
22054C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
22055C               *****************************************************
22056C
22057      ISTEPN='3B'
22058      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCO')
22059     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22060C
22061      IINDX=IINDX+1
22062      IHRI21=IHARG(IINDX)
22063      IHRI22=IHARG2(IINDX)
22064      DO3100I=1,NUMNAM
22065        I4=I
22066        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
22067          IF(IUSE(I4).NE.'F')THEN
22068            WRITE(ICOUT,999)
22069            CALL DPWRST('XXX','BUG ')
22070            WRITE(ICOUT,2001)
22071            CALL DPWRST('XXX','BUG ')
22072            WRITE(ICOUT,3003)IHRI21,IHRI22
22073            CALL DPWRST('XXX','BUG ')
22074            WRITE(ICOUT,3005)
22075            CALL DPWRST('XXX','BUG ')
22076            IERROR='YES'
22077            GOTO9000
22078          ELSE
22079            ISTRT2=IVSTAR(I4)
22080            ISTOP2=IVSTOP(I4)
22081            NLEN2=ISTOP2-ISTRT2+1
22082            GOTO3199
22083          ENDIF
22084        ENDIF
22085 3100 CONTINUE
22086C
22087      WRITE(ICOUT,999)
22088      CALL DPWRST('XXX','BUG ')
22089      WRITE(ICOUT,2001)
22090      CALL DPWRST('XXX','BUG ')
22091      WRITE(ICOUT,3003)IHRI21,IHRI22
22092      CALL DPWRST('XXX','BUG ')
22093      WRITE(ICOUT,3015)
22094      CALL DPWRST('XXX','BUG ')
22095      IERROR='YES'
22096      GOTO9000
22097C
22098 3199 CONTINUE
22099C
22100C               *****************************************************
22101C               **  STEP 4--                                       **
22102C               **  CHECK FOR MATCHING STRINGS                     **
22103C               *****************************************************
22104C
22105      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCO')THEN
22106        ISTEPN='4'
22107        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22108        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1
22109 4011   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
22110        CALL DPWRST('XXX','BUG ')
22111        WRITE(ICOUT,4012)ISTRT2,ISTOP2,NLEN2
22112 4012   FORMAT('ISTART,ISTOP,NLEN2 = ',3I8)
22113        CALL DPWRST('XXX','BUG ')
22114        WRITE(ICOUT,4013)ICASEL,ICASEZ
22115 4013   FORMAT('ICASEL,ICASEZ = ',A4,2X,A4)
22116        CALL DPWRST('XXX','BUG ')
22117      ENDIF
22118C
22119      IMATCH=0
22120      IF(NLEN2.GT.NLEN1)GOTO4199
22121      NTEMP=ISTOP1-NLEN2+1
22122      DO4100J=ISTRT1,NTEMP
22123        ICNT=ISTRT2
22124        DO4110I=J,J+NLEN2-1
22125          IF(IFUNC(I)(1:1).NE.IFUNC(ICNT)(1:1))GOTO4100
22126          ICNT=ICNT+1
22127 4110   CONTINUE
22128        IMATCH=1
22129        GOTO4199
22130 4100 CONTINUE
22131 4199 CONTINUE
22132C
22133C
22134C               *****************************************************
22135C               **  STEP 5--                                       **
22136C               **  SAVE PARAMETER                                 **
22137C               *****************************************************
22138C
22139C
22140      IF(ICASEL.EQ.'PARA')THEN
22141C
22142        ISTEPN='5'
22143        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCO')
22144     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22145C
22146        IHNAME(ILISTL)=IHLEFT
22147        IHNAM2(ILISTL)=IHLEF2
22148        IUSE(ILISTL)='P'
22149        VALUE(ILISTL)=REAL(IMATCH)
22150        IVALUE(ILISTL)=IMATCH
22151        IN(ILISTL)=1
22152        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
22153C
22154        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
22155          WRITE(ICOUT,999)
22156          CALL DPWRST('XXX','BUG ')
22157          IF(IMATCH.EQ.0)THEN
22158            WRITE(ICOUT,5011)IHLEFT,IHLEF2,IMATCH
221595011        FORMAT('MATCH NOT FOUND, ',2A4,'  = ',I3)
22160            CALL DPWRST('XXX','BUG ')
22161          ELSE
22162            WRITE(ICOUT,5013)IHLEFT,IHLEF2,IMATCH
221635013        FORMAT('MATCH FOUND, ',2A4,'  = ',I3)
22164            CALL DPWRST('XXX','BUG ')
22165          ENDIF
22166          WRITE(ICOUT,999)
22167          CALL DPWRST('XXX','BUG ')
22168        ENDIF
22169      ENDIF
22170C
22171C
22172C               ****************
22173C               **  STEP 90-- **
22174C               **  EXIT.     **
22175C               ****************
22176C
22177 9000 CONTINUE
22178      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCO')THEN
22179        WRITE(ICOUT,999)
22180        CALL DPWRST('XXX','BUG ')
22181        WRITE(ICOUT,9011)
22182 9011   FORMAT('***** AT THE END       OF DPSTCO--')
22183        CALL DPWRST('XXX','BUG ')
22184        WRITE(ICOUT,9013)NUMNAM
22185 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
22186        CALL DPWRST('XXX','BUG ')
22187        DO9015I=1,NUMNAM
22188          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
22189     1                     IVSTAR(I),IVSTOP(I)
22190 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
22191     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
22192          CALL DPWRST('XXX','BUG ')
22193 9015   CONTINUE
22194      ENDIF
22195C
22196      RETURN
22197      END
22198      SUBROUTINE DPSTCR(ISUBRO,IBUGA3,IERROR)
22199C
22200C     PURPOSE--IMPLEMENT THE COMMAND
22201C
22202C              LET SNEW = STRING COMPARE AND REPLACE SOLD SREPLACE ...
22203C                                SC1 ... SCK
22204C
22205C              WHERE
22206C                  SC1 ... SCK   = A LIST OF PRE-EXISTING STRINGS
22207C                  SOLD          = A PRE-EXISTING STRING THAT WILL BE
22208C                                  COMPARED TO SC1 ... SCK
22209C                  SREPLACE      = IF A MATCH IS FOUND BETWEEN SOLD
22210C                                  AND ONE OF THE SC1 ... SCK, SET
22211C                                  SNEW TO SREPLACE.
22212C
22213C     EXAMPLE--LET SNEW = STRING SOLD SREPL S1 TO S16
22214C     WRITTEN BY--ALAN HECKERT
22215C                 STATISTICAL ENGINEERING DIVISION
22216C                 INFORMATION TECHNOLOGY LABORATORY
22217C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
22218C                 GAITHERSBURG, MD 20899-8980
22219C                 PHONE--301-975-2899
22220C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22221C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
22222C     LANGUAGE--ANSI FORTRAN (1977)
22223C     VERSION NUMBER--2018/03
22224C     ORIGINAL VERSION--MARCH     2018.
22225C
22226C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22227C
22228      CHARACTER*4 ISUBRO
22229      CHARACTER*4 IBUGA3
22230      CHARACTER*4 IERROR
22231C
22232      INCLUDE 'DPCOPA.INC'
22233C
22234      CHARACTER*4 IWRITE
22235      CHARACTER*4 NEWNAM
22236      CHARACTER*4 NEWCOL
22237      CHARACTER*4 ICASEL
22238      CHARACTER*4 IHLEFT
22239      CHARACTER*4 IHLEF2
22240      CHARACTER*4 IHRIGH
22241      CHARACTER*4 IHRIG2
22242      CHARACTER*8 IHTEMP
22243      CHARACTER*4 ISUBN1
22244      CHARACTER*4 ISUBN2
22245      CHARACTER*4 ISTEPN
22246      CHARACTER*80 ISTR1
22247      CHARACTER*80 ISTR2
22248      CHARACTER*80 ISTR3
22249      CHARACTER*4 ILAB(10)
22250C
22251      PARAMETER(MAXIND=200)
22252      CHARACTER*4 ISTRN1(MAXIND)
22253      CHARACTER*4 ISTRN2(MAXIND)
22254C
22255C---------------------------------------------------------------------
22256C
22257C-----COMMON----------------------------------------------------------
22258C
22259      INCLUDE 'DPCOHK.INC'
22260      INCLUDE 'DPCODA.INC'
22261      INCLUDE 'DPCOP2.INC'
22262C
22263C-----START POINT-----------------------------------------------------
22264C
22265      ISUBN1='DPST'
22266      ISUBN2='CR  '
22267      IERROR='NO'
22268C
22269      ILOC3=0
22270      IFLAG2=0
22271C
22272      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCR')THEN
22273        WRITE(ICOUT,999)
22274        CALL DPWRST('XXX','BUG ')
22275        WRITE(ICOUT,51)
22276   51   FORMAT('***** AT THE BEGINNING OF DPSTCR--')
22277        CALL DPWRST('XXX','BUG ')
22278        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF
22279   52   FORMAT('IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF = ',2(A4,2X),3I8)
22280        CALL DPWRST('XXX','BUG ')
22281        DO55I=1,NUMNAM
22282          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
22283     1                   IVSTOP(I)
22284   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
22285     1           'IVSTOP(I)=',I8,2X,2A4,2X,A4,I8,I8)
22286          CALL DPWRST('XXX','BUG ')
22287   55   CONTINUE
22288        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
22289   60   FORMAT('IFUNC(.)  = ',120A1)
22290        CALL DPWRST('XXX','BUG ')
22291      ENDIF
22292C
22293C               **********************************
22294C               **  STEP 1--                    **
22295C               **  INITIALIZE SOME VARIABLES.  **
22296C               **********************************
22297C
22298      ISTEPN='1'
22299      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')
22300     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22301C
22302      NEWNAM='NO'
22303      NEWCOL='NO'
22304      ICASEL='UNKN'
22305      NIOLD1=0
22306      ICOLL=0
22307C
22308C               ******************************************************
22309C               **  STEP 2--                                         *
22310C               **  EXAMINE THE ARGUMENT ON THE                      *
22311C               **  LEFT-HAND SIDE--                                 *
22312C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
22313C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
22314C               ******************************************************
22315C
22316      ISTEPN='2'
22317      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')
22318     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22319C
22320      IHLEFT=IHARG(1)
22321      IHLEF2=IHARG2(1)
22322C
22323      DO2000I=1,NUMNAM
22324        I2=I
22325        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
22326          IF(IUSE(I2).EQ.'F')THEN
22327            ICASEL='STRI'
22328            ILISTL=I2
22329            GOTO2299
22330          ELSE
22331            WRITE(ICOUT,999)
22332  999       FORMAT(1X)
22333            CALL DPWRST('XXX','BUG ')
22334            WRITE(ICOUT,2001)
22335 2001       FORMAT('***** ERROR IN STRING COMPARE AND REPLACE--')
22336            CALL DPWRST('XXX','BUG ')
22337            WRITE(ICOUT,2003)IHLEFT,IHLEF2
22338 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
22339     1             A4,A4,')')
22340            CALL DPWRST('XXX','BUG ')
22341            WRITE(ICOUT,2005)
22342 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
22343            CALL DPWRST('XXX','BUG ')
22344            IERROR='YES'
22345            GOTO9000
22346          ENDIF
22347        ENDIF
22348 2000 CONTINUE
22349C
22350      NEWNAM='YES'
22351      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
22352C
22353      ILISTL=NUMNAM+1
22354      IF(ILISTL.GT.MAXNAM)THEN
22355        WRITE(ICOUT,999)
22356        CALL DPWRST('XXX','BUG ')
22357        WRITE(ICOUT,2001)
22358        CALL DPWRST('XXX','BUG ')
22359        WRITE(ICOUT,2202)
22360 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
22361     1         'FUNCTION')
22362        CALL DPWRST('XXX','BUG ')
22363        WRITE(ICOUT,2203)MAXNAM
22364 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
22365        CALL DPWRST('XXX','BUG ')
22366        WRITE(ICOUT,2204)
22367 2204   FORMAT('      ENTER      STATUS')
22368        CALL DPWRST('XXX','BUG ')
22369        WRITE(ICOUT,2205)
22370 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
22371        CALL DPWRST('XXX','BUG ')
22372        WRITE(ICOUT,2206)
22373 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
22374     1         'USED NAMES.')
22375        CALL DPWRST('XXX','BUG ')
22376        IERROR='YES'
22377        GOTO9000
22378      ENDIF
22379C
22380 2299 CONTINUE
22381C
22382C               *****************************************************
22383C               **  STEP 3--                                       **
22384C               **  LOOP THROUGH THE NAMES ON THE RIGHT HAND SIDE  **
22385C               *****************************************************
22386C
22387      ISTEPN='3A'
22388      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')
22389     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22390C
22391      IF(NUMARG.LT.9)THEN
22392        WRITE(ICOUT,999)
22393        CALL DPWRST('XXX','BUG ')
22394        WRITE(ICOUT,2001)
22395        CALL DPWRST('XXX','BUG ')
22396        WRITE(ICOUT,3003)
22397 3003   FORMAT('      THERE MUST BE AT LEAST THREE STRINGS SPECIFIED ',
22398     1         'TO THE RIGHT HAND SIDE OF THE EQUAL SIGN')
22399        CALL DPWRST('XXX','BUG ')
22400        NTEMP=NUMARG-6
22401        WRITE(ICOUT,3005)NTEMP
22402 3005   FORMAT('      THE NUMBER OF STRINGS SPECIFIED IS ',I8)
22403        CALL DPWRST('XXX','BUG ')
22404        IERROR='YES'
22405        GOTO9000
22406      ENDIF
22407C
22408C               ******************************************************
22409C               **  STEP 3A--                                        *
22410C               **  THE FIRST ARGUMENT ON THE RHS IS THE "OLD"       *
22411C               **  STRING.  THIS MUST BE A PREVIOUSLY DEFINED       *
22412C               ******************************************************
22413C
22414      ISTEPN='3A'
22415      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')
22416     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22417C
22418C     CHECK FOR THE "OLD" STRING (THIS MUST CURRENTLY EXIST)
22419C
22420      IHRIGH=IHARG(7)
22421      IHRIG2=IHARG2(7)
22422C
22423      DO3100I=1,NUMNAM
22424        I2=I
22425        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
22426          IF(IUSE(I2).EQ.'F')THEN
22427            ISTART=IVSTAR(I2)
22428            ISTOP=IVSTOP(I2)
22429            NLEN1=ISTOP-ISTART+1
22430            IF(NLEN1.GE.1)THEN
22431              ICNT=0
22432              DO3110II=ISTART,ISTOP
22433                ICNT=ICNT+1
22434                ISTR1(ICNT:ICNT)=IFUNC(II)(1:1)
22435 3110         CONTINUE
22436              GOTO3109
22437            ELSE
22438              WRITE(ICOUT,999)
22439              CALL DPWRST('XXX','BUG ')
22440              WRITE(ICOUT,2001)
22441              CALL DPWRST('XXX','BUG ')
22442              WRITE(ICOUT,3101)IHRIGH,IHRIG2
22443 3101         FORMAT('      THE FIRST NAME ON THE RIGHT HAND SIDE (',
22444     1               A4,A4,')')
22445              CALL DPWRST('XXX','BUG ')
22446              WRITE(ICOUT,3102)
22447 3102         FORMAT('      IS A ZERO LENGTH STRING.')
22448              CALL DPWRST('XXX','BUG ')
22449              IERROR='YES'
22450              GOTO9000
22451            ENDIF
22452            GOTO3109
22453          ELSE
22454            WRITE(ICOUT,999)
22455            CALL DPWRST('XXX','BUG ')
22456            WRITE(ICOUT,2001)
22457            CALL DPWRST('XXX','BUG ')
22458            WRITE(ICOUT,3103)IHRIGH,IHRIG2
22459 3103       FORMAT('      THE FIRST NAME ON THE RIGHT HAND SIDE (',
22460     1             A4,A4,')')
22461            CALL DPWRST('XXX','BUG ')
22462            WRITE(ICOUT,3105)
22463 3105       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
22464            CALL DPWRST('XXX','BUG ')
22465            IERROR='YES'
22466            GOTO9000
22467          ENDIF
22468        ENDIF
22469 3100 CONTINUE
22470C
22471      WRITE(ICOUT,999)
22472      CALL DPWRST('XXX','BUG ')
22473      WRITE(ICOUT,2001)
22474      CALL DPWRST('XXX','BUG ')
22475      WRITE(ICOUT,3113)IHRIGH,IHRIG2
22476 3113 FORMAT('      THE FIRST NAME ON THE RIGHT HAND SIDE (',
22477     1       A4,A4,')')
22478      CALL DPWRST('XXX','BUG ')
22479      WRITE(ICOUT,3115)
22480 3115 FORMAT('      IS NOT DEFINED (THIS NAME DEFINES THE ORIGINAL ',
22481     1       'STRING).')
22482      CALL DPWRST('XXX','BUG ')
22483      IERROR='YES'
22484      GOTO9000
22485C
22486 3109 CONTINUE
22487C
22488      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')THEN
22489        WRITE(ICOUT,3121)NLEN1,ISTR1(1:NLEN1)
22490 3121   FORMAT('NLEN1,ISTR1(1:NLEN1) = ',I5,2X,A80)
22491        CALL DPWRST('XXX','BUG ')
22492      ENDIF
22493C
22494C               *********************************************************
22495C               **  STEP 3B--                                           *
22496C               **  THE SECOND ARGUMENT ON THE RHS IS THE "REPLACEMENT" *
22497C               **  STRING.  THIS MUST BE A PREVIOUSLY DEFINED          *
22498C               *********************************************************
22499C
22500C     FOR THE REPLACEMENT STRING, HAVE 2 CASES:
22501C
22502C        1. THE STRING IS CURRENTLY IN THE NAME TABLE.  SET IFLAG = 1.
22503C
22504C        2. THE STRING IS NOT CURRENTLY IN THE NAME TABLE.  SET IFLAG = 0.
22505C           IN THIS CASE, TREAT THE STRING AS THE "BASE" NAME.  THEN
22506C           IF A MATCH IS FOUND, LOOK FOR THE STRING WITH AN "INDEX"
22507C           ATTACHED.  FOR EXAMPLE, IF THE REPLACEMENT STRING IS
22508C           STC AND IT IS THE SECOND STRING IN THE LIST THAT IS MATCHED
22509C           TO THE "OLD" STRING, THEN LOOK FOR THE STRING "STC2" TO BE
22510C           THE REPLACEMENT STRING.
22511C
22512      ISTEPN='3B'
22513      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')
22514     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22515      IHRIGH=IHARG(8)
22516      IHRIG2=IHARG2(8)
22517C
22518      DO3200I=1,NUMNAM
22519        I2=I
22520        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
22521          IF(IUSE(I2).EQ.'F')THEN
22522            ISTART=IVSTAR(I2)
22523            ISTOP=IVSTOP(I2)
22524            NLEN2=ISTOP-ISTART+1
22525            IF(NLEN2.GE.1)THEN
22526              ICNT=0
22527              DO3210II=ISTART,ISTOP
22528                ICNT=ICNT+1
22529                ISTR2(ICNT:ICNT)=IFUNC(II)(1:1)
22530 3210         CONTINUE
22531            ELSE
22532              WRITE(ICOUT,999)
22533              CALL DPWRST('XXX','BUG ')
22534              WRITE(ICOUT,2001)
22535              CALL DPWRST('XXX','BUG ')
22536              WRITE(ICOUT,3201)IHRIGH,IHRIG2
22537 3201         FORMAT('      THE SECOND NAME ON THE RIGHT HAND SIDE (',
22538     1               A4,A4,')')
22539              CALL DPWRST('XXX','BUG ')
22540              WRITE(ICOUT,3202)
22541 3202         FORMAT('      IS A ZERO LENGTH STRING.')
22542              CALL DPWRST('XXX','BUG ')
22543              IERROR='YES'
22544              GOTO9000
22545            ENDIF
22546            IFLAG=1
22547            GOTO3209
22548          ELSE
22549            WRITE(ICOUT,999)
22550            CALL DPWRST('XXX','BUG ')
22551            WRITE(ICOUT,2001)
22552            CALL DPWRST('XXX','BUG ')
22553            WRITE(ICOUT,3203)IHRIGH,IHRIG2
22554 3203       FORMAT('      THE SECOND NAME ON THE RIGHT HAND SIDE (',
22555     1             A4,A4,')')
22556            CALL DPWRST('XXX','BUG ')
22557            WRITE(ICOUT,3205)
22558 3205       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
22559            CALL DPWRST('XXX','BUG ')
22560            IERROR='YES'
22561            GOTO9000
22562          ENDIF
22563        ENDIF
22564 3200 CONTINUE
22565C
22566      IFLAG=0
22567CCCCC WRITE(ICOUT,999)
22568CCCCC CALL DPWRST('XXX','BUG ')
22569CCCCC WRITE(ICOUT,2001)
22570CCCCC CALL DPWRST('XXX','BUG ')
22571CCCCC WRITE(ICOUT,3213)IHRIGH,IHRIG2
22572C3213 FORMAT('      THE SECOND NAME ON THE RIGHT HAND SIDE (',
22573CCCCC1       A4,A4,')')
22574CCCCC CALL DPWRST('XXX','BUG ')
22575CCCCC WRITE(ICOUT,3215)
22576C3215 FORMAT('      IS NOT DEFINED (THIS NAME DEFINES THE ',
22577CCCCC1       'REPLACEMENT STRING).')
22578CCCCC CALL DPWRST('XXX','BUG ')
22579CCCCC IERROR='YES'
22580CCCCC GOTO9000
22581C
22582 3209 CONTINUE
22583C
22584      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')THEN
22585        IF(IFLAG.EQ.1)THEN
22586          WRITE(ICOUT,3221)NLEN2,ISTR2(1:NLEN2)
22587 3221     FORMAT('NLEN2,ISTR2(1:NLEN2) = ',I5,2X,A80)
22588          CALL DPWRST('XXX','BUG ')
22589        ELSEIF(IFLAG.EQ.0)THEN
22590          WRITE(ICOUT,3223)
22591 3223     FORMAT('NO MATCH FOUND FOR REPLACEMENT STRING.  DEFER ',
22592     1           'CHECK UNTIL LATER.')
22593          CALL DPWRST('XXX','BUG ')
22594        ENDIF
22595      ENDIF
22596C
22597C               *********************************************************
22598C               **  STEP 3C--                                           *
22599C               **  NOW SEARCH THROUGH THE REMAINING STRINGS AND SEE    *
22600C               **  IF A MATCH FOUND.                                   *
22601C               *********************************************************
22602C
22603      ISTEPN='3c'
22604      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')
22605     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22606C
22607      JMIN=9
22608      JMAX=NUMARG
22609C
22610      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCR')THEN
22611        WRITE(ICOUT,3301)JMIN,JMAX,MAXIND
22612 3301   FORMAT('JMIN,JMAX,MAXIND = ',3I8)
22613        CALL DPWRST('XXX','BUG ')
22614      ENDIF
22615C
22616      IWRITE='OFF'
22617      IERROR='NO'
22618C
22619      CALL EXTSTR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND,
22620     1            IHNAME,IHNAM2,IUSE,NUMNAM,
22621     1            ISTRN1,ISTRN2,NUMSTR,
22622     1            IWRITE,IBUGA3,ISUBRO,IERROR)
22623C
22624      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCR')THEN
22625        WRITE(ICOUT,3303)NUMSTR,IERROR
22626 3303   FORMAT('NUMSTR,IERROR = ',I8,2X,A4)
22627        CALL DPWRST('XXX','BUG ')
22628        IF(NUMSTR.GE.1)THEN
22629          DO3305JJ=1,NUMSTR
22630            WRITE(ICOUT,3304)JJ,ISTRN1(JJ),ISTRN2(JJ)
22631 3304       FORMAT('JJ,ISTRN1(JJ),ISTRN2(JJ) = ',I8,2X,2A4)
22632            CALL DPWRST('XXX','BUG ')
22633 3305     CONTINUE
22634        ENDIF
22635      ENDIF
22636C
22637C     FOR NOW, ONLY SUPPORT THE CASE FOR PRE-DEFINED STRINGS.
22638C     THAT IS, LITERAL TEXT (E.G., "Case 1") NOT SUPPORTED.
22639C
22640      IF(IERROR.EQ.'YES')GOTO9000
22641C
22642C     CASE WHERE WE ARE EXTRACTING PREVIOUSLY DEFINED STRINGS
22643C
22644      DO3310I2=1,NUMSTR
22645        DO3315I=1,NUMNAM
22646          II=I
22647          IF(ISTRN1(I2).EQ.IHNAME(I) .AND. ISTRN2(I2).EQ.IHNAM2(I))THEN
22648            IINDX=I2
22649            ISTART=IVSTAR(II)
22650            ISTOP=IVSTOP(II)
22651            NLEN3=ISTOP-ISTART+1
22652            IF(NLEN3.GE.1)THEN
22653              ICNT=0
22654              DO3330II=ISTART,ISTOP
22655                ICNT=ICNT+1
22656                ISTR3(ICNT:ICNT)=IFUNC(II)(1:1)
22657 3330         CONTINUE
22658            ELSE
22659C
22660C             ZERO LENGTH STRINGS ARE NOT A MATCH
22661C
22662              GOTO3310
22663            ENDIF
22664            GOTO3319
22665          ENDIF
22666 3315   CONTINUE
22667C
22668C       NO MATCH FOUND FOR STRING NAME.  DON'T TREAT THIS AS AN
22669C       ERROR, SIMPLY IGNORE AND MOVE ON TO NEXT STRING.
22670C
22671CCCCC   WRITE(ICOUT,999)
22672CCCCC   CALL DPWRST('XXX','BUG ')
22673CCCCC   WRITE(ICOUT,2001)
22674CCCCC   CALL DPWRST('XXX','BUG ')
22675CCCCC   WRITE(ICOUT,3323)ISTRN1(I2),ISTRN2(I2)
22676C3323   FORMAT('       STRING ',A4,A4,' NOT MATCHED IN NAME ',
22677CCCCC1         'TABLE.')
22678CCCCC   CALL DPWRST('XXX','BUG ')
22679CCCCC   IERROR='YES'
22680        GOTO3310
22681C
22682 3319   CONTINUE
22683C
22684        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')THEN
22685          WRITE(ICOUT,3321)NLEN3,ISTR3(1:NLEN3)
22686 3321     FORMAT('NLEN3,ISTR3(1:NLEN3) = ',I5,2X,A80)
22687          CALL DPWRST('XXX','BUG ')
22688        ENDIF
22689C
22690C       NOW SEE IF CURRENT STRING MATCHES.
22691C
22692        IF(NLEN1.NE.NLEN3)GOTO3310
22693        DO3340JJ=1,NLEN3
22694          IF(ISTR1(JJ:JJ).NE.ISTR3(JJ:JJ))GOTO3310
22695 3340   CONTINUE
22696C
22697C       STRING MATCH FOUND, SAVE "REPLACEMENT" STRING IN IFUNC2.  BUT
22698C       FIRST CHECK TO SEE IF WE NEED TO RECHECK REPLACEMENT STRING.
22699C
22700        IF(IFLAG.EQ.0)THEN
22701          ISTEPN='3D'
22702          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')
22703     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22704          IHTEMP(1:4)=IHRIGH(1:4)
22705          IHTEMP(5:8)=IHRIG2(1:4)
22706          ILAST=8
22707          DO3501JJ=8,1,-1
22708            IF(IHTEMP(JJ:JJ).NE.' ')THEN
22709              ILAST=JJ
22710              GOTO3509
22711            ENDIF
22712 3501     CONTINUE
22713 3509     CONTINUE
22714          IF(IINDX.LE.9)THEN
22715            IF(ILAST.LE.7)THEN
22716              IFLAG2=1
22717              WRITE(IHTEMP(ILAST+1:ILAST+1),'(I1)')IINDX
22718            ELSE
22719              IFLAG2=0
22720            ENDIF
22721          ELSEIF(IINDX.LE.99)THEN
22722            IF(ILAST.LE.6)THEN
22723              IFLAG2=1
22724              WRITE(IHTEMP(ILAST+1:ILAST+2),'(I2)')IINDX
22725            ELSE
22726              IFLAG2=0
22727            ENDIF
22728          ELSEIF(IINDX.LE.999)THEN
22729            IF(ILAST.LE.5)THEN
22730              IFLAG2=1
22731              WRITE(IHTEMP(ILAST+1:ILAST+3),'(I3)')IINDX
22732            ELSE
22733              IFLAG2=0
22734            ENDIF
22735          ENDIF
22736          IHRIGH=IHTEMP(1:4)
22737          IHRIG2=IHTEMP(5:8)
22738          IF(IFLAG2.EQ.0)THEN
22739            WRITE(ICOUT,999)
22740            CALL DPWRST('XXX','BUG ')
22741            WRITE(ICOUT,2001)
22742            CALL DPWRST('XXX','BUG ')
22743            WRITE(ICOUT,3213)IHRIGH,IHRIG2
22744 3213       FORMAT('      THE SECOND NAME ON THE RIGHT HAND SIDE (',
22745     1             A4,A4,')')
22746            CALL DPWRST('XXX','BUG ')
22747            WRITE(ICOUT,3215)
22748 3215       FORMAT('      IS NOT DEFINED (THIS NAME DEFINES THE ',
22749     1             'REPLACEMENT STRING).')
22750            CALL DPWRST('XXX','BUG ')
22751            IERROR='YES'
22752            GOTO9000
22753          ENDIF
22754C
22755          DO3500KK=1,NUMNAM
22756            K2=KK
22757            IF(IHRIGH.EQ.IHNAME(KK).AND.IHRIG2.EQ.IHNAM2(KK))THEN
22758              IF(IUSE(K2).EQ.'F')THEN
22759                ISTART=IVSTAR(K2)
22760                ISTOP=IVSTOP(K2)
22761                NLEN2=ISTOP-ISTART+1
22762                IF(NLEN2.GE.1)THEN
22763                  ICNT=0
22764                  DO3510II=ISTART,ISTOP
22765                    ICNT=ICNT+1
22766                    ISTR2(ICNT:ICNT)=IFUNC(II)(1:1)
22767 3510             CONTINUE
22768                ELSE
22769                  WRITE(ICOUT,999)
22770                  CALL DPWRST('XXX','BUG ')
22771                  WRITE(ICOUT,2001)
22772                  CALL DPWRST('XXX','BUG ')
22773                  WRITE(ICOUT,3201)IHRIGH,IHRIG2
22774                  CALL DPWRST('XXX','BUG ')
22775                  WRITE(ICOUT,3202)
22776                  CALL DPWRST('XXX','BUG ')
22777                  IERROR='YES'
22778                  GOTO9000
22779                ENDIF
22780                IFLAG=1
22781                GOTO3519
22782              ELSE
22783                WRITE(ICOUT,999)
22784                CALL DPWRST('XXX','BUG ')
22785                WRITE(ICOUT,2001)
22786                CALL DPWRST('XXX','BUG ')
22787                WRITE(ICOUT,3203)IHRIGH,IHRIG2
22788                CALL DPWRST('XXX','BUG ')
22789                WRITE(ICOUT,3205)
22790                CALL DPWRST('XXX','BUG ')
22791                IERROR='YES'
22792                GOTO9000
22793              ENDIF
22794            ENDIF
22795 3500     CONTINUE
22796C
22797          WRITE(ICOUT,999)
22798          CALL DPWRST('XXX','BUG ')
22799          WRITE(ICOUT,2001)
22800          CALL DPWRST('XXX','BUG ')
22801          WRITE(ICOUT,3213)IHRIGH,IHRIG2
22802          CALL DPWRST('XXX','BUG ')
22803          WRITE(ICOUT,3215)
22804          CALL DPWRST('XXX','BUG ')
22805          IERROR='YES'
22806          GOTO9000
22807C
22808 3519     CONTINUE
22809        ENDIF
22810C
22811        DO3345JJ=1,NLEN2
22812          IFUNC2(JJ)='   '
22813          IFUNC2(JJ)(1:1)=ISTR2(JJ:JJ)
22814 3345   CONTINUE
22815C
22816        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')THEN
22817          ISTEPN='3D'
22818          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22819          WRITE(ICOUT,3350)NLEN2
22820 3350     FORMAT('NLEN2 = ',I5)
22821          CALL DPWRST('XXX','BUG ')
22822          DO3355JJ=1,NLEN2
22823            WRITE(ICOUT,3357)JJ,IFUNC2(JJ)
22824 3357       FORMAT('JJ,IFUNC2(JJ) = ',I5,2X,A4)
22825            CALL DPWRST('XXX','BUG ')
22826 3355     CONTINUE
22827        ENDIF
22828C
22829        GOTO3390
22830 3310 CONTINUE
22831C
22832      ISTEPN='3E'
22833      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')
22834     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22835C
22836      IF(IFEEDB.EQ.'ON')THEN
22837        WRITE(ICOUT,999)
22838        CALL DPWRST('XXX','BUG ')
22839        WRITE(ICOUT,3401)IHARG(7),IHARG2(7)
22840 3401   FORMAT('NO MATCH FOUND FOR ',2A4,'.  NOTHING DONE.')
22841        CALL DPWRST('XXX','BUG ')
22842        WRITE(ICOUT,999)
22843        CALL DPWRST('XXX','BUG ')
22844        GOTO9000
22845      ENDIF
22846C
22847 3390 CONTINUE
22848C
22849C               *****************************************************
22850C               **  STEP 4--                                       **
22851C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
22852C               *****************************************************
22853C
22854C
22855      ISTEPN='4'
22856      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCR')
22857     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22858C
22859      CALL DPINFU(IFUNC2,NLEN2,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
22860     1            NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
22861     1            NEWNAM,MAXNAM,
22862     1            IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
22863      IF(IERROR.EQ.'YES')GOTO9000
22864C
22865      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
22866        WRITE(ICOUT,999)
22867        CALL DPWRST('XXX','BUG ')
22868        WRITE(ICOUT,6606)IHLEFT,IHLEF2
22869 6606   FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
22870        CALL DPWRST('XXX','BUG ')
22871        ILAB(1)='TO T'
22872        ILAB(2)='HE F'
22873        ILAB(3)='UNCT'
22874        ILAB(4)='ION '
22875        ILAB(5)='    '
22876        ILAB(6)=' -- '
22877        NUMWDL=6
22878        CALL DPPRIF(ILAB,NUMWDL,IFUNC2,NLEN2,IBUGA3)
22879        WRITE(ICOUT,999)
22880        CALL DPWRST('XXX','BUG ')
22881      ENDIF
22882C
22883C
22884C               ****************
22885C               **  STEP 90-- **
22886C               **  EXIT.     **
22887C               ****************
22888C
22889 9000 CONTINUE
22890      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCR')THEN
22891        WRITE(ICOUT,999)
22892        CALL DPWRST('XXX','BUG ')
22893        WRITE(ICOUT,9011)
22894 9011   FORMAT('***** AT THE END       OF DPSTCR--')
22895        CALL DPWRST('XXX','BUG ')
22896      ENDIF
22897C
22898      RETURN
22899      END
22900      SUBROUTINE DPSTCT(ICASE,ISUBRO,IBUGA3,IERROR)
22901C
22902C     PURPOSE--CHECK IF THE ARGUMENTS SPECIFIED ON THE COMMAND ARE
22903C              OF THE SPECIFIED TYPE
22904C     EXAMPLE--LET IFLAG = CHECK TYPE VARIABLE S1 S2 S3
22905C            --LET IFLAG = CHECK TYPE STRING S1 S2 S3
22906C            --LET IFLAG = CHECK TYPE S1 S2 S3
22907C     WRITTEN BY--ALAN HECKERT
22908C                 STATISTICAL ENGINEERING DIVISION
22909C                 INFORMATION TECHNOLOGY LABORATORY
22910C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
22911C                 GAITHERSBURG, MD 20899-8980
22912C                 PHONE--301-975-2899
22913C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22914C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
22915C     LANGUAGE--ANSI FORTRAN (1977)
22916C     VERSION NUMBER--2015/03
22917C     ORIGINAL VERSION--MARCH     2015.
22918C     UPDATED         --MAY       2018. ADD OPTION TO CHECK IF
22919C                                       TYPE IS LITERAL NUMERIC
22920C
22921C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22922C
22923      CHARACTER*4 ICASE
22924      CHARACTER*4 ISUBRO
22925      CHARACTER*4 IBUGA3
22926      CHARACTER*4 IERROR
22927C
22928      CHARACTER*4 NEWNAM
22929      CHARACTER*4 NEWCOL
22930      CHARACTER*4 ICASEL
22931      CHARACTER*4 IHLEFT
22932      CHARACTER*4 IHLEF2
22933      CHARACTER*4 IHRIGH
22934      CHARACTER*4 IHRIG2
22935C
22936      CHARACTER*4 ISUBN1
22937      CHARACTER*4 ISUBN2
22938      CHARACTER*4 ISTEPN
22939C
22940      CHARACTER*8 ISTR
22941C
22942      PARAMETER (MAXIND=100)
22943      CHARACTER*4 IVARN1(MAXIND)
22944      CHARACTER*4 IVARN2(MAXIND)
22945C---------------------------------------------------------------------
22946C
22947C-----COMMON----------------------------------------------------------
22948C
22949      INCLUDE 'DPCOPA.INC'
22950      INCLUDE 'DPCOHK.INC'
22951      INCLUDE 'DPCODA.INC'
22952      INCLUDE 'DPCOP2.INC'
22953C
22954C-----START POINT-----------------------------------------------------
22955C
22956      ISUBN1='DPST'
22957      ISUBN2='CT  '
22958      IERROR='NO'
22959C
22960      ILOC3=0
22961      ICOLL=0
22962      ILISTL=0
22963      NIOLD=0
22964C
22965      MAXCP1=MAXCOL+1
22966      MAXCP2=MAXCOL+2
22967      MAXCP3=MAXCOL+3
22968      MAXCP4=MAXCOL+4
22969      MAXCP5=MAXCOL+5
22970      MAXCP6=MAXCOL+6
22971C
22972      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCT')THEN
22973        WRITE(ICOUT,999)
22974        CALL DPWRST('XXX','BUG ')
22975        WRITE(ICOUT,51)
22976   51   FORMAT('***** AT THE BEGINNING OF DPSTCT--')
22977        CALL DPWRST('XXX','BUG ')
22978        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,NUMNAM,NUMCHF,MAXCHF
22979   52   FORMAT('IBUGA3,ISUBRO,ICASE,NUMNAM,NUMCHF,MAXCHF = ',
22980     1         3(A4,2X),3I8)
22981        CALL DPWRST('XXX','BUG ')
22982        DO55I=1,NUMNAM
22983          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
22984     1                   IVSTOP(I)
22985   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
22986     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
22987          CALL DPWRST('XXX','BUG ')
22988   55   CONTINUE
22989      ENDIF
22990C
22991C               **********************************
22992C               **  STEP 1--                    **
22993C               **  INITIALIZE SOME VARIABLES.  **
22994C               **********************************
22995C
22996      ISTEPN='1'
22997      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCT')
22998     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22999C
23000      NEWNAM='NO'
23001      NEWCOL='NO'
23002      ICASEL='UNKN'
23003C
23004C               ******************************************************
23005C               **  STEP 2--                                         *
23006C               **  EXAMINE THE LEFT-HAND SIDE--                     *
23007C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
23008C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
23009C               ******************************************************
23010C
23011      ISTEPN='2'
23012      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCT')
23013     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23014C
23015      IHLEFT=IHARG(1)
23016      IHLEF2=IHARG2(1)
23017C
23018      DO1910I=1,4
23019        IF(IHLEFT(I:I).EQ.'(')THEN
23020          IHLEFT(I:4)=' '
23021          IHLEF2=' '
23022          ICASEL='ELEM'
23023          GOTO1999
23024        ENDIF
23025 1910 CONTINUE
23026      DO1920I=1,4
23027        IF(IHLEF2(I:I).EQ.'(')THEN
23028          IHLEF2(I:4)=' '
23029          ICASEL='ELEM'
23030          GOTO1999
23031        ENDIF
23032 1920 CONTINUE
23033 1999 CONTINUE
23034C
23035      DO2000I=1,NUMNAM
23036        I2=I
23037        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
23038          IF(IUSE(I2).EQ.'P')THEN
23039            ICASEL='PARA'
23040            ILISTL=I2
23041            GOTO2900
23042          ELSEIF(IUSE(I2).EQ.'V')THEN
23043            ICASEL='ELEM'
23044            ILISTL=I2
23045            ICOLL=IVALUE(ILISTL)
23046            NIOLD=IN(ILISTL)
23047            GOTO2900
23048          ELSE
23049            WRITE(ICOUT,999)
23050  999       FORMAT(1X)
23051            CALL DPWRST('XXX','BUG ')
23052            WRITE(ICOUT,2001)
23053 2001       FORMAT('***** ERROR IN CHECK TYPE--')
23054            CALL DPWRST('XXX','BUG ')
23055            WRITE(ICOUT,2003)IHLEFT,IHLEF2
23056 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
23057     1             A4,A4,')')
23058            CALL DPWRST('XXX','BUG ')
23059            WRITE(ICOUT,2005)
23060 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
23061            CALL DPWRST('XXX','BUG ')
23062            IERROR='YES'
23063            GOTO9000
23064          ENDIF
23065        ENDIF
23066 2000 CONTINUE
23067C
23068      NEWNAM='YES'
23069      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
23070C
23071      ILISTL=NUMNAM+1
23072      IF(ILISTL.GT.MAXNAM)THEN
23073        WRITE(ICOUT,999)
23074        CALL DPWRST('XXX','BUG ')
23075        WRITE(ICOUT,2001)
23076        CALL DPWRST('XXX','BUG ')
23077        WRITE(ICOUT,2202)
23078 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
23079     1         'FUNCTION')
23080        CALL DPWRST('XXX','BUG ')
23081        WRITE(ICOUT,2203)MAXNAM
23082 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
23083        CALL DPWRST('XXX','BUG ')
23084        WRITE(ICOUT,2204)
23085 2204   FORMAT('      ENTER      STATUS')
23086        CALL DPWRST('XXX','BUG ')
23087        WRITE(ICOUT,2205)
23088 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
23089        CALL DPWRST('XXX','BUG ')
23090        WRITE(ICOUT,2206)
23091 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
23092     1         'USED NAMES.')
23093        CALL DPWRST('XXX','BUG ')
23094        IERROR='YES'
23095        GOTO9000
23096      ENDIF
23097C
23098 2900 CONTINUE
23099C
23100C               *****************************************************
23101C               **  STEP 3--                                       **
23102C               **  EXTRACT THE NAMES ON THE RIGHT HAND SIDE       **
23103C               *****************************************************
23104C
23105      ISTEPN='3'
23106      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCT')
23107     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23108C
23109      IFRST=5
23110      IF(ICASE.NE.'UNKN')IFRST=IFRST+1
23111      IF(NUMARG.LT.IFRST)THEN
23112        IFLAG=-1
23113        GOTO3900
23114      ENDIF
23115      IFLAG=1
23116C
23117      JMIN=IFRST
23118      JMAX=NUMARG
23119      CALL EXTVA3(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND,
23120     1            IHNAME,IHNAM2,NUMNAM,
23121     1            IVARN1,IVARN2,NUMIND,
23122     1            IBUGA3,ISUBRO,IERROR)
23123      IERROR='NO'
23124C
23125      DO3010II=1,NUMIND
23126        IHRIGH=IVARN1(II)
23127        IHRIG2=IVARN2(II)
23128        DO3020I=1,NUMNAM
23129          I4=I
23130          IF(ICASE.EQ.'VARI')THEN
23131            IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
23132              IF(IUSE(I).NE.'V')THEN
23133                WRITE(ICOUT,999)
23134                CALL DPWRST('XXX','BUG ')
23135                WRITE(ICOUT,2001)
23136                CALL DPWRST('XXX','BUG ')
23137                WRITE(ICOUT,3021)IHRIGH,IHRIG2
23138 3021           FORMAT('      NAME ',2A4,' IS NOT A VARIABLE.')
23139                CALL DPWRST('XXX','BUG ')
23140                IFLAG=0
23141              ENDIF
23142              GOTO3010
23143            ENDIF
23144          ELSEIF(ICASE.EQ.'STRI')THEN
23145            IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
23146              IF(IUSE(I).NE.'F')THEN
23147                WRITE(ICOUT,999)
23148                CALL DPWRST('XXX','BUG ')
23149                WRITE(ICOUT,2001)
23150                CALL DPWRST('XXX','BUG ')
23151                WRITE(ICOUT,3022)IHRIGH,IHRIG2
23152 3022           FORMAT('      NAME ',2A4,' IS NOT A STRING/FUNCTION.')
23153                CALL DPWRST('XXX','BUG ')
23154                IFLAG=0
23155              ENDIF
23156              GOTO3010
23157            ENDIF
23158          ELSEIF(ICASE.EQ.'PARA')THEN
23159            IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
23160              IF(IUSE(I).NE.'P')THEN
23161                WRITE(ICOUT,999)
23162                CALL DPWRST('XXX','BUG ')
23163                WRITE(ICOUT,2001)
23164                CALL DPWRST('XXX','BUG ')
23165                WRITE(ICOUT,3023)IHRIGH,IHRIG2
23166 3023           FORMAT('      NAME ',2A4,' IS NOT A PARAMETER.')
23167                CALL DPWRST('XXX','BUG ')
23168                IFLAG=0
23169              ENDIF
23170              GOTO3010
23171            ENDIF
23172          ELSEIF(ICASE.EQ.'MATR')THEN
23173            IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
23174              IF(IUSE(I).NE.'M')THEN
23175                WRITE(ICOUT,999)
23176                CALL DPWRST('XXX','BUG ')
23177                WRITE(ICOUT,2001)
23178                CALL DPWRST('XXX','BUG ')
23179                WRITE(ICOUT,3024)IHRIGH,IHRIG2
23180 3024           FORMAT('      NAME ',2A4,' IS NOT A MATRIX.')
23181                CALL DPWRST('XXX','BUG ')
23182                IFLAG=0
23183              ENDIF
23184              GOTO3010
23185            ENDIF
23186          ELSEIF(ICASE.EQ.'NUMB')THEN
23187            IVAL=IFRST+II-1
23188            IF(IARGT(IVAL).NE.'NUMB')THEN
23189              WRITE(ICOUT,999)
23190              CALL DPWRST('XXX','BUG ')
23191              WRITE(ICOUT,2001)
23192              CALL DPWRST('XXX','BUG ')
23193              WRITE(ICOUT,3033)IHRIGH,IHRIG2
23194 3033         FORMAT('      NAME ',2A4,' IS NOT A NUMBER.')
23195              CALL DPWRST('XXX','BUG ')
23196              IFLAG=0
23197            ENDIF
23198            GOTO3010
23199          ELSE
23200            IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
23201              IF(IUSE(I).EQ.'V')ICASE='VARI'
23202              IF(IUSE(I).EQ.'F')ICASE='STRI'
23203              IF(IUSE(I).EQ.'P')ICASE='PARA'
23204              IF(IUSE(I).EQ.'M')ICASE='MATR'
23205              GOTO3010
23206            ENDIF
23207          ENDIF
23208 3020   CONTINUE
23209C
23210        IFLAG=0
23211        WRITE(ICOUT,999)
23212        CALL DPWRST('XXX','BUG ')
23213        WRITE(ICOUT,2001)
23214        CALL DPWRST('XXX','BUG ')
23215        WRITE(ICOUT,3043)IHRIGH,IHRIG2
23216 3043   FORMAT('      NAME ',2A4,' WAS NOT FOUND IN THE CURRENT NAME ',
23217     1         'LIST.')
23218        CALL DPWRST('XXX','BUG ')
23219C
23220 3010 CONTINUE
23221C
23222 3900 CONTINUE
23223C
23224C               *****************************************************
23225C               **  STEP 4--                                       **
23226C               **  SAVE PARAMETER                                 **
23227C               *****************************************************
23228C
23229      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCT')THEN
23230        ISTEPN='4'
23231        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23232        WRITE(ICOUT,4011)ISTART,ISTOP,IVAL
23233 4011   FORMAT('ISTART,ISTOP,IVAL = ',3I8)
23234        CALL DPWRST('XXX','BUG ')
23235        WRITE(ICOUT,4013)ICASEL
23236 4013   FORMAT('ICASEL = ',A4)
23237        CALL DPWRST('XXX','BUG ')
23238      ENDIF
23239C
23240      IF(ICASEL.EQ.'PARA')THEN
23241C
23242        ISTEPN='4A'
23243        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCT')
23244     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23245C
23246        IHNAME(ILISTL)=IHLEFT
23247        IHNAM2(ILISTL)=IHLEF2
23248        IUSE(ILISTL)='P'
23249        VALUE(ILISTL)=REAL(IFLAG)
23250        IVALUE(ILISTL)=IFLAG
23251        IN(ILISTL)=1
23252        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
23253      ELSEIF(ICASEL.EQ.'ELEM')THEN
23254C
23255C       SEARCH IANS STRING FOR "(xx) =".  IF NO PARENTHESIS
23256C       FOUND BEFORE "=", THEN DO NOT KNOW WHAT ROW OF THE
23257C       VARIABLE TO SAVE.  TREAT THIS AS AN ERROR.
23258C
23259        NLEFT=-1
23260        NRIGHT=-1
23261        NEQUAL=-1
23262        DO4201I=1,IWIDTH
23263          IF(IANS(I)(1:1).EQ.'(' .AND. NLEFT.LT.0)THEN
23264            NLEFT=I
23265          ELSEIF(IANS(I)(1:1).EQ.')' .AND. NRIGHT.LT.0)THEN
23266            NRIGHT=I
23267          ELSEIF(IANS(I)(1:1).EQ.'=' .AND. NEQUAL.LT.0)THEN
23268            NEQUAL=I
23269          ENDIF
23270 4201   CONTINUE
23271C
23272C       NEED  NLEFT < NRIGHT < NEQUAL
23273C
23274        NSTRT=NLEFT+1
23275        NSTOP=NRIGHT-1
23276        NLEN=NSTOP-NSTRT+1
23277        IF(NLEFT.GT.NRIGHT .OR. NRIGHT.GT.NEQUAL .OR.
23278     1     NSTRT.GT.NSTOP .OR. NLEN.GT.8) THEN
23279          WRITE(ICOUT,999)
23280          CALL DPWRST('XXX','BUG ')
23281          WRITE(ICOUT,2001)
23282          CALL DPWRST('XXX','BUG ')
23283          WRITE(ICOUT,4211)
23284 4211     FORMAT('      UNRECOGNIZED SYNTAX FOR VARIABLE ELEMENT ON ',
23285     1           'LEFT HAND SIDE EQUAL SIGN.')
23286          CALL DPWRST('XXX','BUG ')
23287          IERROR='YES'
23288          GOTO9000
23289        ELSE
23290          ISTR=' '
23291          DO4216I=1,NLEN
23292            ISTR(I:I)=IANS(NSTRT+I-1)(1:1)
23293 4216     CONTINUE
23294          READ(ISTR,'(I8)',ERR=4218)IARGL
23295          GOTO4219
23296C
23297 4218     CONTINUE
23298          WRITE(ICOUT,999)
23299          CALL DPWRST('XXX','BUG ')
23300          WRITE(ICOUT,2001)
23301          CALL DPWRST('XXX','BUG ')
23302          WRITE(ICOUT,4211)
23303          CALL DPWRST('XXX','BUG ')
23304          IERROR='YES'
23305          GOTO9000
23306C
23307 4219     CONTINUE
23308        ENDIF
23309C
23310        IF(IARGL.LT.1 .OR. IARGL.GT.MAXN)THEN
23311          WRITE(ICOUT,999)
23312          CALL DPWRST('XXX','BUG ')
23313          WRITE(ICOUT,2001)
23314          CALL DPWRST('XXX','BUG ')
23315          WRITE(ICOUT,4231)IARGL,ILEFT
23316 4231     FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
23317          CALL DPWRST('XXX','BUG ')
23318          WRITE(ICOUT,4233)
23319 4233     FORMAT('      WAS LESS THAN 1 OR GREATER THAN THE')
23320          CALL DPWRST('XXX','BUG ')
23321          WRITE(ICOUT,4235)MAXN
23322 4235     FORMAT('      MAXIMUM ALLOWABLE ',I8)
23323          CALL DPWRST('XXX','BUG ')
23324          IERROR='YES'
23325          GOTO9000
23326        ENDIF
23327C
23328        IF(NEWNAM.EQ.'YES')THEN
23329          NIOLD=1
23330        ENDIF
23331        NINEW=NIOLD
23332        IF(IARGL.GT.NINEW)NINEW=IARGL
23333        NS2=1
23334C
23335        RIGHT=REAL(IFLAG)
23336        IJ=MAXN*(ICOLL-1)+IARGL
23337        IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
23338        IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT
23339        IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT
23340        IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT
23341        IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT
23342        IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT
23343        IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT
23344C
23345        IHNAME(ILISTL)=IHLEFT
23346        IHNAM2(ILISTL)=IHLEF2
23347        IUSE(ILISTL)='V'
23348        IVALUE(ILISTL)=ICOLL
23349        VALUE(ILISTL)=ICOLL
23350        IN(ILISTL)=NINEW
23351C
23352        IF(NEWNAM.EQ.'YES')THEN
23353          NUMNAM=NUMNAM+1
23354          NUMCOL=NUMCOL+1
23355        ENDIF
23356C
23357        DO4290J4=1,NUMNAM
23358          IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)THEN
23359            IUSE(J4)='V'
23360            IVALUE(J4)=ICOLL
23361            VALUE(J4)=ICOLL
23362            IN(J4)=NINEW
23363            GOTO4299
23364          ENDIF
23365 4290   CONTINUE
23366 4299   CONTINUE
23367C
23368      ENDIF
23369C
23370      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
23371        WRITE(ICOUT,999)
23372        CALL DPWRST('XXX','BUG ')
23373        WRITE(ICOUT,8011)IFLAG
23374 8011   FORMAT('THE STATUS FLAG FOR CHECK TYPE = ',I8)
23375        CALL DPWRST('XXX','BUG ')
23376        WRITE(ICOUT,999)
23377        CALL DPWRST('XXX','BUG ')
23378      ENDIF
23379      GOTO9000
23380C
23381C
23382C               ****************
23383C               **  STEP 90-- **
23384C               **  EXIT.     **
23385C               ****************
23386C
23387 9000 CONTINUE
23388      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STCT')THEN
23389        WRITE(ICOUT,999)
23390        CALL DPWRST('XXX','BUG ')
23391        WRITE(ICOUT,9011)
23392 9011   FORMAT('***** AT THE END       OF DPSTCT--')
23393        CALL DPWRST('XXX','BUG ')
23394        WRITE(ICOUT,9013)NUMNAM
23395 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
23396        CALL DPWRST('XXX','BUG ')
23397        DO9015I=1,NUMNAM
23398          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
23399     1                     IVSTAR(I),IVSTOP(I)
23400 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
23401     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
23402          CALL DPWRST('XXX','BUG ')
23403 9015   CONTINUE
23404      ENDIF
23405C
23406      RETURN
23407      END
23408      SUBROUTINE DPSTDE(ICASEZ,ISUBRO,IBUGA3,IERROR)
23409C
23410C     PURPOSE--IMPLEMENT THE FOLLOWING COMMAND:
23411C
23412C                 LET SOUT = STRING DELETE SORG SCHAR
23413C
23414C              FOR EACH CHARACTER IN THE STRING "SCHAR", SEARCH
23415C              THE STRING "SORG" AND REMOVE THAT CHARACTER IF FOUND.
23416C
23417C              THE STRINGS ON THE RIGHT HAND SIDE MUST BOTH BE
23418C              PREVIOUSLY DEFINED.
23419C     WRITTEN BY--ALAN HECKERT
23420C                 STATISTICAL ENGINEERING DIVISION
23421C                 INFORMATION TECHNOLOGY LABORATORY
23422C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
23423C                 GAITHERSBURG, MD 20899-8980
23424C                 PHONE--301-975-2899
23425C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23426C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
23427C     LANGUAGE--ANSI FORTRAN (1977)
23428C     VERSION NUMBER--2018/10
23429C     ORIGINAL VERSION--OCTOBER   2018.
23430C
23431C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23432C
23433      CHARACTER*4 ICASEZ
23434      CHARACTER*4 ISUBRO
23435      CHARACTER*4 IBUGA3
23436      CHARACTER*4 IERROR
23437C
23438      CHARACTER*4 NEWNAM
23439      CHARACTER*4 NEWNA2
23440      CHARACTER*4 NEWCOL
23441      CHARACTER*4 NEWCO2
23442      CHARACTER*4 ICASEL
23443      CHARACTER*4 IHLEFT
23444      CHARACTER*4 IHLEF2
23445      CHARACTER*4 IHRIGH
23446      CHARACTER*4 IHRIG2
23447      CHARACTER*4 IHRI21
23448      CHARACTER*4 IHRI22
23449C
23450      CHARACTER*4 ISUBN1
23451      CHARACTER*4 ISUBN2
23452      CHARACTER*4 ISTEPN
23453C
23454      CHARACTER*4 ILAB(10)
23455C
23456C---------------------------------------------------------------------
23457C
23458C-----COMMON----------------------------------------------------------
23459C
23460      INCLUDE 'DPCOPA.INC'
23461      INCLUDE 'DPCOHK.INC'
23462      INCLUDE 'DPCODA.INC'
23463      INCLUDE 'DPCOP2.INC'
23464C
23465C-----START POINT-----------------------------------------------------
23466C
23467      ISUBN1='DPST'
23468      ISUBN2='DE  '
23469      IERROR='NO'
23470C
23471      ILOC3=0
23472C
23473      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STDE')THEN
23474        WRITE(ICOUT,999)
23475        CALL DPWRST('XXX','BUG ')
23476        WRITE(ICOUT,51)
23477   51   FORMAT('***** AT THE BEGINNING OF DPSTDE--')
23478        CALL DPWRST('XXX','BUG ')
23479        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
23480   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',2(A4,2X),I8)
23481        CALL DPWRST('XXX','BUG ')
23482        DO55I=1,NUMNAM
23483          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
23484     1                   IVSTOP(I)
23485   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
23486     1           'IVSTOP(I)=',I8,2X,2A4,2X,A4,2I8)
23487          CALL DPWRST('XXX','BUG ')
23488   55   CONTINUE
23489        WRITE(ICOUT,57)NUMCHF,MAXCHF
23490   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
23491        CALL DPWRST('XXX','BUG ')
23492        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
23493   60   FORMAT('IFUNC(.)  = ',120A1)
23494        CALL DPWRST('XXX','BUG ')
23495      ENDIF
23496C
23497C               **********************************
23498C               **  STEP 1--                    **
23499C               **  INITIALIZE SOME VARIABLES.  **
23500C               **********************************
23501C
23502      ISTEPN='1'
23503      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STDE')
23504     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23505C
23506      NEWNAM='NO'
23507      NEWNA2='NO'
23508      NEWCOL='NO'
23509      NEWCO2='NO'
23510      ICASEL='UNKN'
23511      NIOLD1=0
23512      ICOLL=0
23513C
23514C               ******************************************************
23515C               **  STEP 2--                                         *
23516C               **  EXAMINE THE FIRST ARGUMENT ON THE                *
23517C               **  LEFT-HAND SIDE--                                 *
23518C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
23519C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
23520C               ******************************************************
23521C
23522      ISTEPN='2'
23523      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STDE')
23524     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23525C
23526      IHLEFT=IHARG(1)
23527      IHLEF2=IHARG2(1)
23528C
23529      DO2000I=1,NUMNAM
23530        I2=I
23531        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
23532          IF(IUSE(I2).EQ.'F')THEN
23533            ICASEL='STRI'
23534            ILISTL=I2
23535            GOTO2299
23536          ELSE
23537            WRITE(ICOUT,999)
23538  999       FORMAT(1X)
23539            CALL DPWRST('XXX','BUG ')
23540            WRITE(ICOUT,2001)
23541 2001       FORMAT('***** ERROR IN STRING DELETE--')
23542            CALL DPWRST('XXX','BUG ')
23543            WRITE(ICOUT,2003)IHLEFT,IHLEF2
23544 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
23545     1             A4,A4,')')
23546            CALL DPWRST('XXX','BUG ')
23547            WRITE(ICOUT,2005)
23548 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
23549            CALL DPWRST('XXX','BUG ')
23550            IERROR='YES'
23551            GOTO9000
23552          ENDIF
23553        ENDIF
23554 2000 CONTINUE
23555C
23556      NEWNAM='YES'
23557      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
23558C
23559      ILISTL=NUMNAM+1
23560      NUMTMP=NUMNAM+1
23561      IF(ILISTL.GT.MAXNAM)THEN
23562        WRITE(ICOUT,999)
23563        CALL DPWRST('XXX','BUG ')
23564        WRITE(ICOUT,2001)
23565        CALL DPWRST('XXX','BUG ')
23566        WRITE(ICOUT,2202)
23567 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
23568     1         'FUNCTION')
23569        CALL DPWRST('XXX','BUG ')
23570        WRITE(ICOUT,2203)MAXNAM
23571 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
23572        CALL DPWRST('XXX','BUG ')
23573        WRITE(ICOUT,2204)
23574 2204   FORMAT('      ENTER      STATUS')
23575        CALL DPWRST('XXX','BUG ')
23576        WRITE(ICOUT,2205)
23577 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
23578        CALL DPWRST('XXX','BUG ')
23579        WRITE(ICOUT,2206)
23580 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
23581     1         'USED NAMES.')
23582        CALL DPWRST('XXX','BUG ')
23583        IERROR='YES'
23584        GOTO9000
23585      ENDIF
23586C
23587 2299 CONTINUE
23588C
23589C               *****************************************************
23590C               **  STEP 3--                                       **
23591C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
23592C               *****************************************************
23593C
23594      ISTEPN='3A'
23595      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STDE')
23596     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23597C
23598      IINDX=5
23599      IHRIGH=IHARG(IINDX)
23600      IHRIG2=IHARG2(IINDX)
23601      DO3000I=1,NUMNAM
23602        I4=I
23603        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
23604          IF(IUSE(I4).NE.'F')THEN
23605            WRITE(ICOUT,999)
23606            CALL DPWRST('XXX','BUG ')
23607            WRITE(ICOUT,2001)
23608            CALL DPWRST('XXX','BUG ')
23609            WRITE(ICOUT,3003)IHRIGH,IHRIG2
23610 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
23611     1             A4,A4,')')
23612            CALL DPWRST('XXX','BUG ')
23613            WRITE(ICOUT,3005)
23614 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
23615            CALL DPWRST('XXX','BUG ')
23616            IERROR='YES'
23617            GOTO9000
23618          ELSE
23619            ISTRT1=IVSTAR(I4)
23620            ISTOP1=IVSTOP(I4)
23621            NLEN1=ISTOP1-ISTRT1+1
23622            GOTO3099
23623          ENDIF
23624        ENDIF
23625 3000 CONTINUE
23626C
23627      WRITE(ICOUT,999)
23628      CALL DPWRST('XXX','BUG ')
23629      WRITE(ICOUT,2001)
23630      CALL DPWRST('XXX','BUG ')
23631      WRITE(ICOUT,3003)IHRIGH,IHRIG2
23632      CALL DPWRST('XXX','BUG ')
23633      WRITE(ICOUT,3015)
23634 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
23635      CALL DPWRST('XXX','BUG ')
23636      IERROR='YES'
23637      GOTO9000
23638C
23639 3099 CONTINUE
23640C
23641C               *****************************************************
23642C               **  STEP 3B-                                       **
23643C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
23644C               *****************************************************
23645C
23646      ISTEPN='3B'
23647      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STDE')
23648     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23649C
23650      IINDX=IINDX+1
23651      IHRI21=IHARG(IINDX)
23652      IHRI22=IHARG2(IINDX)
23653      DO3100I=1,NUMNAM
23654        I4=I
23655        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
23656          IF(IUSE(I4).NE.'F')THEN
23657            WRITE(ICOUT,999)
23658            CALL DPWRST('XXX','BUG ')
23659            WRITE(ICOUT,2001)
23660            CALL DPWRST('XXX','BUG ')
23661            WRITE(ICOUT,3003)IHRI21,IHRI22
23662            CALL DPWRST('XXX','BUG ')
23663            WRITE(ICOUT,3005)
23664            CALL DPWRST('XXX','BUG ')
23665            IERROR='YES'
23666            GOTO9000
23667          ELSE
23668            ISTRT2=IVSTAR(I4)
23669            ISTOP2=IVSTOP(I4)
23670            NLEN2=ISTOP2-ISTRT2+1
23671            GOTO3199
23672          ENDIF
23673        ENDIF
23674 3100 CONTINUE
23675C
23676      WRITE(ICOUT,999)
23677      CALL DPWRST('XXX','BUG ')
23678      WRITE(ICOUT,2001)
23679      CALL DPWRST('XXX','BUG ')
23680      WRITE(ICOUT,3003)IHRI21,IHRI22
23681      CALL DPWRST('XXX','BUG ')
23682      WRITE(ICOUT,3015)
23683      CALL DPWRST('XXX','BUG ')
23684      IERROR='YES'
23685      GOTO9000
23686C
23687 3199 CONTINUE
23688C
23689C               *****************************************************
23690C               **  STEP 4--                                       **
23691C               **  CHECK FOR CHARACTERS TO DELETE                 **
23692C               *****************************************************
23693C
23694      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STDE')THEN
23695        ISTEPN='4'
23696        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23697        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1
23698 4011   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
23699        CALL DPWRST('XXX','BUG ')
23700        WRITE(ICOUT,4012)ISTRT2,ISTOP2,NLEN2
23701 4012   FORMAT('ISTART,ISTOP,NLEN2 = ',3I8)
23702        CALL DPWRST('XXX','BUG ')
23703        WRITE(ICOUT,4013)ICASEL,ICASEZ
23704 4013   FORMAT('ICASEL,ICASEZ = ',A4,2X,A4)
23705        CALL DPWRST('XXX','BUG ')
23706      ENDIF
23707C
23708      ICNT=0
23709      DO4100I=ISTRT1,ISTOP1
23710        DO4200J=ISTRT2,ISTOP2
23711          IF(IFUNC(I).EQ.IFUNC(J))GOTO4199
23712 4200   CONTINUE
23713        ICNT=ICNT+1
23714        IFUNC2(ICNT)=' '
23715        IFUNC2(ICNT)(1:1)=IFUNC(I)(1:1)
23716 4199 CONTINUE
23717 4100 CONTINUE
23718C
23719C               *****************************************************
23720C               **  STEP 5--                                       **
23721C               **  SAVE STRING                                    **
23722C               *****************************************************
23723C
23724C
23725      IF(ICASEL.EQ.'STRI')THEN
23726C
23727        ISTEPN='5'
23728        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STDE')
23729     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23730C
23731        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
23732     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
23733     1              NEWNAM,MAXNAM,
23734     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
23735        IF(IERROR.EQ.'YES')GOTO9000
23736C
23737        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
23738          WRITE(ICOUT,999)
23739          CALL DPWRST('XXX','BUG ')
23740          WRITE(ICOUT,6606)IHLEFT,IHLEF2
23741 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
23742          CALL DPWRST('XXX','BUG ')
23743          ILAB(1)='TO T'
23744          ILAB(2)='HE F'
23745          ILAB(3)='UNCT'
23746          ILAB(4)='ION '
23747          ILAB(5)='    '
23748          ILAB(6)=' -- '
23749          NUMWDL=6
23750          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
23751C
23752          WRITE(ICOUT,999)
23753          CALL DPWRST('XXX','BUG ')
23754C
23755        ENDIF
23756C
23757      ENDIF
23758C
23759C
23760C               ****************
23761C               **  STEP 90-- **
23762C               **  EXIT.     **
23763C               ****************
23764C
23765 9000 CONTINUE
23766      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STDE')THEN
23767        WRITE(ICOUT,999)
23768        CALL DPWRST('XXX','BUG ')
23769        WRITE(ICOUT,9011)
23770 9011   FORMAT('***** AT THE END       OF DPSTDE--')
23771        CALL DPWRST('XXX','BUG ')
23772        WRITE(ICOUT,9013)NUMNAM
23773 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
23774        CALL DPWRST('XXX','BUG ')
23775        DO9015I=1,NUMNAM
23776          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
23777     1                     IVSTAR(I),IVSTOP(I)
23778 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
23779     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
23780          CALL DPWRST('XXX','BUG ')
23781 9015   CONTINUE
23782      ENDIF
23783C
23784      RETURN
23785      END
23786      SUBROUTINE DPSTED(IFLAGG,ISUBRO,IBUGA3,IERROR)
23787C
23788C     PURPOSE--EDIT A PREVIOUSLY DEFINED STRING
23789C     EXAMPLE--LET SOUT = STRING EDIT SORG SOLD SNEW
23790C     WRITTEN BY--JAMES J. FILLIBEN
23791C                 STATISTICAL ENGINEERING DIVISION
23792C                 INFORMATION TECHNOLOGY LABORATORY
23793C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
23794C                 GAITHERSBURG, MD 20899-8980
23795C                 PHONE--301-975-2855
23796C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23797C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
23798C     LANGUAGE--ANSI FORTRAN (1977)
23799C     VERSION NUMBER--2008/11
23800C     ORIGINAL VERSION--NOVEMBER  2008.
23801C     UPDATED         --FEBRUARY  2015. SUPPORT "NULL()" FOR
23802C                                       REPLACEMENT STRING
23803C     UPDATED         --FEBRUARY  2015. ADD A "GLOBAL" OPTION
23804C                                       (IFLAGG PARAMETER)
23805C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
23806C
23807C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23808C
23809      CHARACTER*4 ISUBRO
23810      CHARACTER*4 IBUGA3
23811      CHARACTER*4 IERROR
23812C
23813      CHARACTER*4 NEWNAM
23814      CHARACTER*4 NEWNA2
23815      CHARACTER*4 NEWCOL
23816      CHARACTER*4 NEWCO2
23817      CHARACTER*4 ICASEL
23818      CHARACTER*4 ICASE2
23819      CHARACTER*4 IHLEFT
23820      CHARACTER*4 IHLEF2
23821      CHARACTER*4 IHRIGH
23822      CHARACTER*4 IHRIG2
23823      CHARACTER*4 IHRI21
23824      CHARACTER*4 IHRI22
23825      CHARACTER*4 IHRI31
23826      CHARACTER*4 IHRI32
23827C
23828      CHARACTER*4 ISUBN1
23829      CHARACTER*4 ISUBN2
23830      CHARACTER*4 ISTEPN
23831C
23832      CHARACTER*4 ILAB(10)
23833C
23834C---------------------------------------------------------------------
23835C
23836C-----COMMON----------------------------------------------------------
23837C
23838      INCLUDE 'DPCOPA.INC'
23839      INCLUDE 'DPCOHK.INC'
23840      INCLUDE 'DPCODA.INC'
23841      INCLUDE 'DPCOP2.INC'
23842C
23843C-----START POINT-----------------------------------------------------
23844C
23845      ISUBN1='DPST'
23846      ISUBN2='ED  '
23847      IERROR='NO'
23848C
23849      ILOC3=0
23850C
23851      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STED')THEN
23852        WRITE(ICOUT,999)
23853        CALL DPWRST('XXX','BUG ')
23854        WRITE(ICOUT,51)
23855   51   FORMAT('***** AT THE BEGINNING OF DPSTED--')
23856        CALL DPWRST('XXX','BUG ')
23857        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM,IFLAGG
23858   52   FORMAT('IBUGA3,ISUBRO,NUMNAM,IFLAGG = ',2(A4,2X),2I8)
23859        CALL DPWRST('XXX','BUG ')
23860        DO55I=1,NUMNAM
23861          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
23862     1                   IVSTOP(I)
23863   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
23864     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
23865          CALL DPWRST('XXX','BUG ')
23866   55   CONTINUE
23867        WRITE(ICOUT,57)NUMCHF,MAXCHF
23868   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
23869        CALL DPWRST('XXX','BUG ')
23870        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
23871   60   FORMAT('IFUNC(.)  = ',120A1)
23872        CALL DPWRST('XXX','BUG ')
23873      ENDIF
23874C
23875C               **********************************
23876C               **  STEP 1--                    **
23877C               **  INITIALIZE SOME VARIABLES.  **
23878C               **********************************
23879C
23880      ISTEPN='1'
23881      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STED')
23882     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23883C
23884      NEWNAM='NO'
23885      NEWNA2='NO'
23886      NEWCOL='NO'
23887      NEWCO2='NO'
23888      ICASEL='UNKN'
23889      ICASE2='UNKN'
23890      NIOLD1=0
23891      NIOLD2=0
23892      ICOLL=0
23893      ICOL2=0
23894C
23895      IPASS=0
23896C
23897 1000 CONTINUE
23898      IPASS=IPASS+1
23899C
23900C               ******************************************************
23901C               **  STEP 2--                                         *
23902C               **  EXAMINE THE ARGUMENT ON THE                      *
23903C               **  LEFT-HAND SIDE--                                 *
23904C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
23905C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
23906C               ******************************************************
23907C
23908      ISTEPN='2'
23909      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STED')
23910     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23911C
23912      IHLEFT=IHARG(1)
23913      IHLEF2=IHARG2(1)
23914C
23915      DO2000I=1,NUMNAM
23916        I2=I
23917        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
23918          IF(IUSE(I2).EQ.'F')THEN
23919            ICASEL='STRI'
23920            ILISTL=I2
23921            GOTO2299
23922          ELSE
23923            WRITE(ICOUT,999)
23924  999       FORMAT(1X)
23925            CALL DPWRST('XXX','BUG ')
23926            WRITE(ICOUT,2001)
23927 2001       FORMAT('***** ERROR IN STRING EDIT--')
23928            CALL DPWRST('XXX','BUG ')
23929            WRITE(ICOUT,2003)IHLEFT,IHLEF2
23930 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
23931     1             A4,A4,')')
23932            CALL DPWRST('XXX','BUG ')
23933            WRITE(ICOUT,2005)
23934 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
23935            CALL DPWRST('XXX','BUG ')
23936            IERROR='YES'
23937            GOTO9000
23938          ENDIF
23939        ENDIF
23940 2000 CONTINUE
23941C
23942      NEWNAM='YES'
23943      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
23944C
23945      ILISTL=NUMNAM+1
23946      IF(ILISTL.GT.MAXNAM)THEN
23947        WRITE(ICOUT,999)
23948        CALL DPWRST('XXX','BUG ')
23949        WRITE(ICOUT,2001)
23950        CALL DPWRST('XXX','BUG ')
23951        WRITE(ICOUT,2202)
23952 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
23953     1         'FUNCTION')
23954        CALL DPWRST('XXX','BUG ')
23955        WRITE(ICOUT,2203)MAXNAM
23956 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
23957        CALL DPWRST('XXX','BUG ')
23958        WRITE(ICOUT,2204)
23959 2204   FORMAT('      ENTER      STATUS')
23960        CALL DPWRST('XXX','BUG ')
23961        WRITE(ICOUT,2205)
23962 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
23963        CALL DPWRST('XXX','BUG ')
23964        WRITE(ICOUT,2206)
23965 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
23966     1         'USED NAMES.')
23967        CALL DPWRST('XXX','BUG ')
23968        IERROR='YES'
23969        GOTO9000
23970      ENDIF
23971C
23972 2299 CONTINUE
23973C
23974C               *****************************************************
23975C               **  STEP 3--                                       **
23976C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
23977C               *****************************************************
23978C
23979      ISTEPN='3A'
23980      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STED')
23981     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23982C
23983C     2015/02: FOR GLOBAL EDIT CASE, ON SECOND PASS OR GREATER WE
23984C              WILL BE EDITING THE "OUTPUT" STRING RATHER THAN THE
23985C              INPUT STRING.
23986C
23987      IF(IPASS.EQ.1)THEN
23988        NINDX=5
23989        IF(IFLAGG.EQ.1)NINDX=6
23990      ELSE
23991        NINDX=1
23992      ENDIF
23993      IHRIGH=IHARG(NINDX)
23994      IHRIG2=IHARG2(NINDX)
23995C
23996      DO3000I=1,NUMNAM
23997        I4=I
23998        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
23999          IF(IUSE(I4).NE.'F')THEN
24000            WRITE(ICOUT,999)
24001            CALL DPWRST('XXX','BUG ')
24002            WRITE(ICOUT,2001)
24003            CALL DPWRST('XXX','BUG ')
24004            WRITE(ICOUT,3003)IHRIGH,IHRIG2
24005 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
24006     1             A4,A4,')')
24007            CALL DPWRST('XXX','BUG ')
24008            WRITE(ICOUT,3005)
24009 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
24010            CALL DPWRST('XXX','BUG ')
24011            IERROR='YES'
24012            GOTO9000
24013          ELSE
24014            ISTRT1=IVSTAR(I4)
24015            ISTOP1=IVSTOP(I4)
24016            NLEN1=ISTOP1-ISTRT1+1
24017            GOTO3099
24018          ENDIF
24019        ENDIF
24020 3000 CONTINUE
24021C
24022      WRITE(ICOUT,999)
24023      CALL DPWRST('XXX','BUG ')
24024      WRITE(ICOUT,2001)
24025      CALL DPWRST('XXX','BUG ')
24026      WRITE(ICOUT,3003)IHRIGH,IHRIG2
24027      CALL DPWRST('XXX','BUG ')
24028      WRITE(ICOUT,3015)
24029 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
24030      CALL DPWRST('XXX','BUG ')
24031      IERROR='YES'
24032      GOTO9000
24033C
24034 3099 CONTINUE
24035C
24036C               *****************************************************
24037C               **  STEP 3B-                                       **
24038C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
24039C               *****************************************************
24040C
24041      ISTEPN='3B'
24042      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STED')
24043     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24044C
24045      IF(IPASS.GT.1)GOTO3199
24046C
24047      NINDX=NINDX+1
24048      IHRI21=IHARG(NINDX)
24049      IHRI22=IHARG2(NINDX)
24050      DO3100I=1,NUMNAM
24051        I4=I
24052        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
24053          IF(IUSE(I4).NE.'F')THEN
24054            WRITE(ICOUT,999)
24055            CALL DPWRST('XXX','BUG ')
24056            WRITE(ICOUT,2001)
24057            CALL DPWRST('XXX','BUG ')
24058            WRITE(ICOUT,3003)IHRI21,IHRI22
24059            CALL DPWRST('XXX','BUG ')
24060            WRITE(ICOUT,3005)
24061            CALL DPWRST('XXX','BUG ')
24062            IERROR='YES'
24063            GOTO9000
24064          ELSE
24065            ISTRT2=IVSTAR(I4)
24066            ISTOP2=IVSTOP(I4)
24067            NLEN2=ISTOP2-ISTRT2+1
24068            GOTO3199
24069          ENDIF
24070        ENDIF
24071 3100 CONTINUE
24072C
24073      WRITE(ICOUT,999)
24074      CALL DPWRST('XXX','BUG ')
24075      WRITE(ICOUT,2001)
24076      CALL DPWRST('XXX','BUG ')
24077      WRITE(ICOUT,3003)IHRI21,IHRI22
24078      CALL DPWRST('XXX','BUG ')
24079      WRITE(ICOUT,3015)
24080      CALL DPWRST('XXX','BUG ')
24081      IERROR='YES'
24082      GOTO9000
24083C
24084 3199 CONTINUE
24085C
24086C               *****************************************************
24087C               **  STEP 3C-                                       **
24088C               **  EXTRACT THE THIRD  NAME ON THE RIGHT HAND SIDE **
24089C               *****************************************************
24090C
24091      ISTEPN='3C'
24092      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STED')
24093     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24094C
24095      IF(IPASS.GT.1)GOTO3299
24096C
24097C     2015/02: CHECK TO SEE IF LITERAL "NULL()" GIVEN AS ARGUMENT
24098C
24099      NINDX=NINDX+1
24100      IF(IHARG(NINDX).EQ.'NULL' .AND. IHARG2(NINDX).EQ.'()')THEN
24101        NLEN3=0
24102        GOTO3299
24103      ENDIF
24104C
24105      IHRI31=IHARG(NINDX)
24106      IHRI32=IHARG2(NINDX)
24107      DO3200I=1,NUMNAM
24108        I4=I
24109        IF(IHRI31.EQ.IHNAME(I).AND.IHRI32.EQ.IHNAM2(I))THEN
24110          IF(IUSE(I4).NE.'F')THEN
24111            WRITE(ICOUT,999)
24112            CALL DPWRST('XXX','BUG ')
24113            WRITE(ICOUT,2001)
24114            CALL DPWRST('XXX','BUG ')
24115            WRITE(ICOUT,3003)IHRI31,IHRI32
24116            CALL DPWRST('XXX','BUG ')
24117            WRITE(ICOUT,3005)
24118            CALL DPWRST('XXX','BUG ')
24119            IERROR='YES'
24120            GOTO9000
24121          ELSE
24122            I4SAVE=I4
24123            ISTRT3=IVSTAR(I4)
24124            ISTOP3=IVSTOP(I4)
24125            NLEN3=ISTOP3-ISTRT3+1
24126C
24127C           2015/02: CHECK FOR "NULL()" OR "null()" TO
24128C                    DENOTE A NULL STRING
24129C
24130            IF(NLEN3.EQ.6 .AND. IFUNC(ISTOP3-1).EQ.'(' .AND.
24131     1         IFUNC(ISTOP3).EQ.')')THEN
24132              IF(IFUNC(ISTRT3).EQ.'N' .AND.
24133     1           IFUNC(ISTRT3+1).EQ.'U' .AND.
24134     1           IFUNC(ISTRT3+2).EQ.'L' .AND.
24135     1           IFUNC(ISTRT3+3).EQ.'L')THEN
24136                NLEN3=0
24137              ELSEIF(IFUNC(ISTRT3).EQ.'n' .AND.
24138     1           IFUNC(ISTRT3+1).EQ.'u' .AND.
24139     1           IFUNC(ISTRT3+2).EQ.'l' .AND.
24140     1           IFUNC(ISTRT3+3).EQ.'l')THEN
24141                NLEN3=0
24142              ENDIF
24143            ENDIF
24144            GOTO3299
24145          ENDIF
24146        ENDIF
24147 3200 CONTINUE
24148C
24149      WRITE(ICOUT,999)
24150      CALL DPWRST('XXX','BUG ')
24151      WRITE(ICOUT,2001)
24152      CALL DPWRST('XXX','BUG ')
24153      WRITE(ICOUT,3003)IHRI31,IHRI32
24154      CALL DPWRST('XXX','BUG ')
24155      WRITE(ICOUT,3015)
24156      CALL DPWRST('XXX','BUG ')
24157      IERROR='YES'
24158      GOTO9000
24159C
24160 3299 CONTINUE
24161C
24162C               *****************************************************
24163C               **  STEP 4--                                       **
24164C               **  PERFORM THE STRING EDIT                        **
24165C               *****************************************************
24166C
24167      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STED')THEN
24168        ISTEPN='4A'
24169        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24170        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1,IPASS
24171 4011   FORMAT('ISTRT1,ISTOP1,NLEN1,IPASS = ',4I8)
24172        CALL DPWRST('XXX','BUG ')
24173        WRITE(ICOUT,4012)ISTRT2,ISTOP2,NLEN2
24174 4012   FORMAT('ISTRT2,ISTOP2,NLEN2 = ',3I8)
24175        CALL DPWRST('XXX','BUG ')
24176        WRITE(ICOUT,4013)ISTRT3,ISTOP3,NLEN3
24177 4013   FORMAT('ISTRT3,ISTOP3,NLEN3 = ',3I8)
24178        CALL DPWRST('XXX','BUG ')
24179        WRITE(ICOUT,4014)ICASEL
24180 4014   FORMAT('ICASEL = ',A4)
24181        CALL DPWRST('XXX','BUG ')
24182      ENDIF
24183C
24184C     CHECK TO SEE IF A MATCH FOUND
24185C
24186      IMATCH=0
24187      NLAST=ISTOP1-NLEN2+1
24188      IF(NLAST.GE.ISTRT1)THEN
24189        DO4100I=ISTRT1,NLAST
24190          ICNT=0
24191          DO4110J=I,I+NLEN2-1
24192            ICNT=ICNT+1
24193            IINDX=ISTRT2+ICNT-1
24194            IF(IFUNC(J)(1:1).NE.IFUNC(IINDX)(1:1))GOTO4100
24195 4110     CONTINUE
24196          IMATCH=1
24197          NSTART=I
24198          GOTO4199
24199 4100   CONTINUE
24200 4199   CONTINUE
24201      ENDIF
24202C
24203      IF(IMATCH.EQ.0)THEN
24204C
24205        IF(IPASS.GT.1)GOTO8000
24206C
24207        WRITE(ICOUT,999)
24208        CALL DPWRST('XXX','BUG ')
24209        WRITE(ICOUT,2001)
24210        CALL DPWRST('XXX','BUG ')
24211        WRITE(ICOUT,4191)IHRI21,IHRI22,IHRIGH,IHRIG2
24212 4191   FORMAT('       NO MATCH FOR STRING ',A4,A4,' FOUND IN ',
24213     1         'STRING ',A4,A4)
24214        CALL DPWRST('XXX','BUG ')
24215        IERROR='YES'
24216        GOTO9000
24217      ENDIF
24218C
24219C     IF MATCH FOUND, PERFORM THE EDIT
24220C
24221      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STED')THEN
24222        ISTEPN='4B'
24223        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24224        WRITE(ICOUT,4196)IMATCH,NSTART
24225 4196   FORMAT('IMATCH,NSTART = ',2I8)
24226        CALL DPWRST('XXX','BUG ')
24227      ENDIF
24228C
24229C     COPY THE PORTION OF THE STRING UP TO THE EDIT POINT
24230C
24231      ICNT=0
24232      IF(NSTART.GT.1)THEN
24233        DO4210I=ISTRT1,NSTART-1
24234          ICNT=ICNT+1
24235          IFUNC2(ICNT)=IFUNC(I)
24236 4210   CONTINUE
24237      ENDIF
24238C
24239C     NOW INSERT THE "NEW" STRING
24240C
24241      IF(NLEN3.GE.1)THEN
24242        DO4120I=1,NLEN2
24243          ICNT=ICNT+1
24244          IINDX=I+ISTRT3-1
24245          IFUNC2(ICNT)=IFUNC(IINDX)
24246 4120   CONTINUE
24247      ENDIF
24248C
24249C     NOW INSERT THE PART OF THE ORIGINAL STRING AFTER THE EDIT POINT
24250C
24251      NTEMP=NSTART+NLEN2
24252      IF(NTEMP.LE.ISTOP1)THEN
24253        DO4130I=NTEMP,ISTOP1
24254          ICNT=ICNT+1
24255          IFUNC2(ICNT)=IFUNC(I)
24256 4130   CONTINUE
24257      ENDIF
24258C
24259C               *****************************************************
24260C               **  STEP 5--                                       **
24261C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
24262C               *****************************************************
24263C
24264C
24265      ISTEPN='5'
24266      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STED')
24267     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24268C
24269      CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
24270     1            NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
24271CCCCC1            NEWNAM,MAXN3,
24272     1            NEWNAM,MAXNAM,
24273     1            IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
24274      IF(IERROR.EQ.'YES')GOTO9000
24275C
24276C     2015/02: FOR GLOBAL EDIT, RESTART THE EDIT
24277C
24278      IF(IFLAGG.EQ.0)GOTO8000
24279      GOTO1000
24280C
24281 8000 CONTINUE
24282C
24283      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
24284        WRITE(ICOUT,999)
24285        CALL DPWRST('XXX','BUG ')
24286        WRITE(ICOUT,8606)IHLEFT,IHLEF2
24287 8606   FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
24288        CALL DPWRST('XXX','BUG ')
24289        ILAB(1)='TO T'
24290        ILAB(2)='HE F'
24291        ILAB(3)='UNCT'
24292        ILAB(4)='ION '
24293        ILAB(5)='    '
24294        ILAB(6)=' -- '
24295        NUMWDL=6
24296        CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
24297C
24298        WRITE(ICOUT,999)
24299        CALL DPWRST('XXX','BUG ')
24300C
24301      ENDIF
24302C
24303C
24304C               ****************
24305C               **  STEP 90-- **
24306C               **  EXIT.     **
24307C               ****************
24308C
24309 9000 CONTINUE
24310      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STED')THEN
24311        WRITE(ICOUT,999)
24312        CALL DPWRST('XXX','BUG ')
24313        WRITE(ICOUT,9011)
24314 9011   FORMAT('***** AT THE END       OF DPSTED--')
24315        CALL DPWRST('XXX','BUG ')
24316        WRITE(ICOUT,9013)NUMNAM
24317 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
24318        CALL DPWRST('XXX','BUG ')
24319        DO9015I=1,NUMNAM
24320          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
24321     1                     IVSTAR(I),IVSTOP(I)
24322 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
24323     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
24324          CALL DPWRST('XXX','BUG ')
24325 9015   CONTINUE
24326      ENDIF
24327C
24328      RETURN
24329      END
24330      SUBROUTINE DPSTE2(Y,W,N,YS,MAXN,IBUGG3,ISUBRO,IERROR)
24331C
24332C     PURPOSE--FORM A STEM AND LEAF DIAGRAM
24333C     OUTPUT--A STEM AND LEAF DIAGRAM
24334C             OF SMOOTHED VALUES.
24335C     NOTE--THE VECTOR Y REMAINS UNCHANGED.
24336C     LANGUAGE--ANSI FORTRAN (1977)
24337C     REFERENCES--MCNEIL, INTERACTIVE DATA ANALYSIS
24338C                 1977, PAGE 23
24339C                 (= SOURCE OF ALGORITHM).
24340C     WRITTEN BY--JAMES J. FILLIBEN
24341C                 STATISTICAL ENGINEERING DIVISION
24342C                 INFORMATION TECHNOLOGY LABORATORY
24343C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24344C                 GAITHERSBURG, MD 20899-8980
24345C                 PHONE--301-975-2855
24346C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24347C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24348C     VERSION NUMBER--83.6
24349C     ORIGINAL VERSION--JULY      1983.
24350C
24351C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24352C
24353      CHARACTER*4 IBUGG3
24354      CHARACTER*4 ISUBRO
24355      CHARACTER*4 IERROR
24356C
24357      CHARACTER*1 IA
24358      CHARACTER*1 M
24359      CHARACTER*1 IOUT
24360C
24361C---------------------------------------------------------------------
24362C
24363      DIMENSION Y(*)
24364      DIMENSION W(*)
24365      DIMENSION YS(*)
24366C
24367      DIMENSION IOUT(132)
24368      DIMENSION IA(20)
24369      DIMENSION M(4)
24370C
24371      INCLUDE 'DPCOP2.INC'
24372C
24373C---------------------------------------------------------------------
24374C
24375      DATA IA(1)/'0'/
24376      DATA IA(2)/'1'/
24377      DATA IA(3)/'2'/
24378      DATA IA(4)/'3'/
24379      DATA IA(5)/'4'/
24380      DATA IA(6)/'5'/
24381      DATA IA(7)/'6'/
24382      DATA IA(8)/'7'/
24383      DATA IA(9)/'8'/
24384      DATA IA(10)/'9'/
24385      DATA IA(11)/'0'/
24386      DATA IA(12)/'1'/
24387      DATA IA(13)/'2'/
24388      DATA IA(14)/'3'/
24389      DATA IA(15)/'4'/
24390      DATA IA(16)/'5'/
24391      DATA IA(17)/'6'/
24392      DATA IA(18)/'7'/
24393      DATA IA(19)/'8'/
24394      DATA IA(20)/'9'/
24395C
24396      DATA M(1)/'-'/
24397      DATA M(2)/' '/
24398      DATA M(3)/':'/
24399      DATA M(4)/'+'/
24400C
24401C-----START POINT-----------------------------------------------------
24402C
24403      IERROR='NO'
24404C
24405      IWIDTH=50
24406      SCALE=1.0
24407      EPS=0.00000001
24408C
24409      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'STE2')THEN
24410        WRITE(ICOUT,999)
24411  999   FORMAT(1X)
24412        CALL DPWRST('XXX','BUG ')
24413        WRITE(ICOUT,51)
24414   51   FORMAT('***** AT THE BEGINNING OF DPSTE2--')
24415        CALL DPWRST('XXX','BUG ')
24416        WRITE(ICOUT,52)IBUGG3,ISUBRO,N,MAXN
24417   52   FORMAT('IBUGG3,ISUBRO,N,MAXN = ',2(A4,2X),2I8)
24418        CALL DPWRST('XXX','BUG ')
24419        DO55I=1,N
24420          WRITE(ICOUT,56)I,Y(I),W(I)
24421   56     FORMAT('I,Y(I),W(I) = ',I8,2G15.7)
24422          CALL DPWRST('XXX','BUG ')
24423   55   CONTINUE
24424      ENDIF
24425C
24426C               ************************************
24427C               **  FORM A STEM-AND-LEAF DIAGRAM  **
24428C               ************************************
24429C
24430      IF(N.LT.2)THEN
24431        WRITE(ICOUT,999)
24432        CALL DPWRST('XXX','BUG ')
24433        WRITE(ICOUT,111)
24434  111   FORMAT('***** ERROR IN STEM AND LEAF PLOT--')
24435        CALL DPWRST('XXX','BUG ')
24436        WRITE(ICOUT,112)
24437  112   FORMAT('     NUMBER OF OBSERVATIONS IS LESS THAN TWO.')
24438        CALL DPWRST('XXX','BUG ')
24439        WRITE(ICOUT,113)N
24440  113   FORMAT('NUMBER OF OBSERVATIONS = ',I8)
24441        CALL DPWRST('XXX','BUG ')
24442        IERROR='YES'
24443        GOTO9000
24444      ENDIF
24445C
24446C
24447C               *********************
24448C               **  STEP 1--       **
24449C               **  SORT THE DATA  **
24450C               *********************
24451C
24452      CALL SORT(Y,N,YS)
24453C
24454C     STEP 2--
24455C     DEFINE C
24456C
24457      RANGE=YS(N)-YS(1)
24458      R=EPS+RANGE/SCALE
24459C
24460      C=10.0**(11-INT(LOG10(R)+10.0))
24461      ARG1=INT(R*C/25.0)
24462      ARG2=0
24463      MAX=INT(ARG1+0.1)
24464      IF(ARG2.GT.ARG1)MAX=INT(ARG2+0.1)
24465C
24466      ARG1=2
24467      ARG2=MAX
24468      MM=INT(ARG1+0.1)
24469      IF(ARG2.LT.ARG1)MM=INT(ARG2+0.1)
24470C
24471      K=3*MM+2-150/(N+50)
24472      IPROD=(K-1)*(K-2)*(K-5)
24473      IF(IPROD.EQ.0)C=C*10
24474C
24475C     STEP 3--
24476C     DEFINE MU
24477C
24478      MU=10
24479      IPROD=K*(K-4)*(K-8)
24480      IF(IPROD.EQ.0)MU=5
24481      IPROD=(K-1)*(K-5)*(K-6)
24482      IF(IPROD.EQ.0)MU=20
24483C
24484      I=1
24485      IF(YS(1).GE.0)I=2
24486      I2=1
24487      TERM=INT(YS(I2)*C/MU)+I-2
24488      D=MU*TERM/10.0
24489C
24490C               *****************************************
24491C               **  STEP XX--                          **
24492C               **  SET UP A LOOP IN WHICH             **
24493C               **  EACH ITERATION OF THE LOOP         **
24494C               **  WILL FORM A NEW LINE (ROW) OF THE  **
24495C               **  STEM AND LEAF DIAGRAM              **
24496C               *****************************************
24497C
24498      WRITE(ICOUT,999)
24499      CALL DPWRST('XXX','BUG ')
24500      WRITE(ICOUT,999)
24501      CALL DPWRST('XXX','BUG ')
24502 1000 CONTINUE
24503C
24504C               *****************************************************
24505C               **  STEP XX--                                      **
24506C               **  FORM THE NEXT OUTPUT LINE OF THE STEM AND LEAF **
24507C               **  DIAGRAM.  FILL THE OUTPUT LINE WITH BLANKS.    **
24508C               *****************************************************
24509C
24510      DO1100K=1,IWIDTH
24511      IOUT(K)=' '
24512 1100 CONTINUE
24513C
24514      IF(I.EQ.2.OR.D.LE.0)GOTO1290
24515      I=2
24516      D=D-MU/10.0
24517 1290 CONTINUE
24518C
24519      ICOL=0
24520 1300 CONTINUE
24521      ICOL=ICOL+1
24522      TERM1=YS(I2)*C-10*INT(D)
24523      IY=INT(0.5+ABS(TERM1))
24524      IF(YS(I2)*C-10*D.GE.0.5+(MU-1)*(I-1))GOTO1390
24525      IF(ICOL.LE.IWIDTH)IOUT(ICOL)=IA(1+IY)
24526      I2=I2+1
24527      IF(I2.GT.N)GOTO1390
24528      GOTO1300
24529 1390 CONTINUE
24530C
24531      ID=MOD(IABS(INT(D)),100)
24532      K1=1+ID/10
24533      K2=1+ID-10*(K1-1)
24534      IF(ICOL.LE.IWIDTH+1)GOTO1490
24535      IOUT(IWIDTH-2)='+'
24536      IOUT(IWIDTH-1)=IA(1+(ICOL-IWIDTH+2)/10)
24537      IOUT(IWIDTH)=IA(ICOL-IWIDTH+3-10*((ICOL-IWIDTH+2)/10))
24538 1490 CONTINUE
24539C
24540C               **********************************************
24541C               **  STEP XX--                               **
24542C               **  WRITE OUT THE OUTPUT LINE FOR THIS ROW  **
24543C               **********************************************
24544C
24545      K=IWIDTH
24546      IF(ICOL.LT.IWIDTH)K=ICOL
24547      WRITE(ICOUT,1510)M(I),IA(K1),IA(K2),M(2),M(3),M(2),
24548     1(IOUT(ICOL),ICOL=1,K)
24549 1510 FORMAT(132A1)
24550      CALL DPWRST('XXX','BUG ')
24551C
24552C               *****************************************************
24553C               **  STEP XX--                                      **
24554C               **  JUMP BACK TO THE BEGINNING OF THE LOOP         **
24555C               **  TO WORK ON THE NEXT LINE (ROW) OF THE DIAGRAM  **
24556C               *****************************************************
24557C
24558      IF(I2.GT.N)GOTO9000
24559      D=D+MU/10.0
24560      GOTO1000
24561C
24562C               *****************
24563C               **  STEP 90--  **
24564C               **  EXIT.      **
24565C               *****************
24566C
24567 9000 CONTINUE
24568      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'STE2')THEN
24569        WRITE(ICOUT,999)
24570        CALL DPWRST('XXX','BUG ')
24571        WRITE(ICOUT,9011)
24572 9011   FORMAT('***** AT THE END       OF DPSTE2--')
24573        CALL DPWRST('XXX','BUG ')
24574      ENDIF
24575C
24576      RETURN
24577      END
24578      SUBROUTINE DPSTEM(IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
24579C
24580C     PURPOSE--GENERATE A STEM AND LEAF DIAGRAM.
24581C     WRITTEN BY--JAMES J. FILLIBEN
24582C                 STATISTICAL ENGINEERING DIVISION
24583C                 INFORMATION TECHNOLOGY LABORATORY
24584C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24585C                 GAITHERSBURG, MD 20899-8980
24586C                 PHONE--301-975-2855
24587C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24588C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24589C     LANGUAGE--ANSI FORTRAN (1977)
24590C     VERSION NUMBER--83/7
24591C     ORIGINAL VERSION--JULY      1983.
24592C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
24593C     UPDATED         --MARCH     2011. USE DPPARS AND DPPAR3
24594C
24595C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24596C
24597      CHARACTER*4 IBUGA2
24598      CHARACTER*4 IBUGA3
24599      CHARACTER*4 IBUGQ
24600      CHARACTER*4 ISUBRO
24601      CHARACTER*4 IFOUND
24602      CHARACTER*4 IERROR
24603C
24604      CHARACTER*4 ISUBN1
24605      CHARACTER*4 ISUBN2
24606      CHARACTER*4 ISTEPN
24607C
24608      CHARACTER*4 ICASE
24609      CHARACTER*40 INAME
24610      PARAMETER (MAXSPN=10)
24611      CHARACTER*4 IVARN1(MAXSPN)
24612      CHARACTER*4 IVARN2(MAXSPN)
24613      CHARACTER*4 IVARTY(MAXSPN)
24614      REAL PVAR(MAXSPN)
24615      INTEGER ILIS(MAXSPN)
24616      INTEGER NRIGHT(MAXSPN)
24617      INTEGER ICOLR(MAXSPN)
24618C
24619C---------------------------------------------------------------------
24620C
24621      INCLUDE 'DPCOPA.INC'
24622C
24623      DIMENSION TEMP(MAXOBV)
24624C
24625      DIMENSION W(MAXOBV)
24626CCCCC FOLLOWING LINES ADDED JUNE, 1990
24627      INCLUDE 'DPCOZZ.INC'
24628      EQUIVALENCE (GARBAG(IGARB1),W(1))
24629      EQUIVALENCE (GARBAG(IGARB2),TEMP(1))
24630CCCCC END CHANGE
24631C
24632C-----COMMON----------------------------------------------------------
24633C
24634      INCLUDE 'DPCOHK.INC'
24635      INCLUDE 'DPCOSU.INC'
24636      INCLUDE 'DPCODA.INC'
24637      INCLUDE 'DPCOP2.INC'
24638C
24639C-----START POINT-----------------------------------------------------
24640C
24641      ISUBN1='DPSU'
24642      ISUBN2='MM  '
24643      IFOUND='NO'
24644      IERROR='NO'
24645C
24646      MAXCP1=MAXCOL+1
24647      MAXCP2=MAXCOL+2
24648      MAXCP3=MAXCOL+3
24649      MAXCP4=MAXCOL+4
24650      MAXCP5=MAXCOL+5
24651      MAXCP6=MAXCOL+6
24652C
24653C               ************************************
24654C               **  TREAT THE STEM AND LEAF CASE  **
24655C               ************************************
24656C
24657      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'STEM')THEN
24658        WRITE(ICOUT,999)
24659  999   FORMAT(1X)
24660        CALL DPWRST('XXX','BUG ')
24661        WRITE(ICOUT,51)
24662   51   FORMAT('***** AT THE BEGINNING OF DPSTEM--')
24663        CALL DPWRST('XXX','BUG ')
24664        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
24665   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
24666        CALL DPWRST('XXX','BUG ')
24667      ENDIF
24668C
24669C               ***************************
24670C               **  STEP 1--             **
24671C               **  EXTRACT THE COMMAND  **
24672C               ***************************
24673C
24674      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
24675        ISHIFT=1
24676      ELSEIF(NUMARG.GE.1.AND.
24677     1       IHARG(1).EQ.'DIAG'.AND.IHARG2(1).EQ.'RAM')THEN
24678        ISHIFT=1
24679      ELSEIF(NUMARG.GE.2.AND.
24680     1       IHARG(1).EQ.'AND'.AND.IHARG(2).EQ.'PLOT')THEN
24681        ISHIFT=2
24682      ELSEIF(NUMARG.GE.2.AND.
24683     1       IHARG(2).EQ.'AND'.AND.IHARG(2).EQ.'DIAG'.AND.
24684     1       IHARG2(2).EQ.'RAM')THEN
24685        ISHIFT=2
24686      ELSEIF(NUMARG.GE.2.AND.
24687     1       IHARG(1).EQ.'LEAF'.AND.IHARG(2).EQ.'PLOT')THEN
24688        ISHIFT=2
24689      ELSEIF(NUMARG.GE.2.AND.
24690     1       IHARG(2).EQ.'LEAF'.AND.
24691     1       IHARG(2).EQ.'DIAG'.AND.IHARG2(2).EQ.'RAM')THEN
24692        ISHIFT=2
24693      ELSEIF(NUMARG.GE.3.AND.
24694     1       IHARG(1).EQ.'AND'.AND.IHARG(2).EQ.'LEAF'.AND.
24695     1       IHARG(3).EQ.'PLOT')THEN
24696        ISHIFT=3
24697      ELSEIF(NUMARG.GE.3.AND.
24698     1       IHARG(1).EQ.'AND'.AND.IHARG(2).EQ.'LEAF'.AND.
24699     1       IHARG(3).EQ.'DIAG'.AND.IHARG2(3).EQ.'RAM')THEN
24700        ISHIFT=3
24701      ELSEIF(NUMARG.GE.3.AND.
24702     1       IHARG(1).EQ.'AND'.AND.IHARG(2).EQ.'LEAF')THEN
24703        ISHIFT=2
24704      ELSE
24705        GOTO9000
24706      ENDIF
24707C
24708      IFOUND='YES'
24709      CALL ADJUST(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
24710C
24711C               ****************************************
24712C               **  STEP 2--                          **
24713C               **  EXTRACT THE VARIABLE LIST         **
24714C               ****************************************
24715C
24716      ISTEPN='2'
24717      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'STEM')
24718     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24719C
24720      INAME='STEM AND LEAF PLOT'
24721      MINNA=1
24722      MAXNA=100
24723      MINN2=2
24724      IFLAGE=1
24725      IFLAGM=1
24726      IFLAGP=0
24727      JMIN=1
24728      JMAX=NUMARG
24729      MINNVA=1
24730      MAXNVA=1
24731C
24732      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
24733     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
24734     1            JMIN,JMAX,
24735     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
24736     1            IVARN1,IVARN2,IVARTY,PVAR,
24737     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
24738     1            MINNVA,MAXNVA,
24739     1            IFLAGM,IFLAGP,
24740     1            IBUGA2,IBUGQ,ISUBRO,IFOUND,IERROR)
24741      IF(IERROR.EQ.'YES')GOTO9000
24742C
24743      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'STEM')THEN
24744        WRITE(ICOUT,999)
24745        CALL DPWRST('XXX','BUG ')
24746        WRITE(ICOUT,281)
24747  281   FORMAT('***** AFTER CALL DPPARS--')
24748        CALL DPWRST('XXX','BUG ')
24749        WRITE(ICOUT,282)NQ,NUMVAR
24750  282   FORMAT('NQ,NUMVAR = ',2I8)
24751        CALL DPWRST('XXX','BUG ')
24752        IF(NUMVAR.GT.0)THEN
24753          DO285I=1,NUMVAR
24754            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
24755     1                      ICOLR(I),IVARTY(I)
24756  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
24757     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
24758            CALL DPWRST('XXX','BUG ')
24759  285     CONTINUE
24760        ENDIF
24761      ENDIF
24762C
24763      ICOL=1
24764      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
24765     1            INAME,IVARN1,IVARN2,IVARTY,
24766     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
24767     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
24768     1            MAXCP4,MAXCP5,MAXCP6,
24769     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
24770     1            Y,Y,Y,NS,NLOCA2,NLOCA3,ICASE,
24771     1            IBUGA3,ISUBRO,IFOUND,IERROR)
24772      IF(IERROR.EQ.'YES')GOTO9000
24773C
24774C               ****************************************************
24775C               **  STEP 8--                                      **
24776C               **  PREPARE FOR ENTRANCE INTO DPSTE2--            **
24777C               **  SET THE WEIGHT VECTOR TO UNITY THROUGHOUT.    **
24778C               ****************************************************
24779C
24780      ISTEPN='8'
24781      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'STEM')
24782     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24783C
24784      DO1110I=1,NS
24785      W(I)=1.0
24786 1110 CONTINUE
24787C
24788      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'STEM')THEN
24789        WRITE(ICOUT,999)
24790        CALL DPWRST('XXX','BUG ')
24791        WRITE(ICOUT,1211)
24792 1211   FORMAT('***** FROM DPSTEM, AS WE ARE ABOUT TO CALL DPSTE2--')
24793        CALL DPWRST('XXX','BUG ')
24794        WRITE(ICOUT,1212)NS
24795 1212   FORMAT('NS = ',I8)
24796        CALL DPWRST('XXX','BUG ')
24797        DO1215I=1,NS
24798          WRITE(ICOUT,1216)I,Y(I),W(I)
24799 1216     FORMAT('I,Y(I),W(I) = ',I8,2G15.7)
24800          CALL DPWRST('XXX','BUG ')
24801 1215   CONTINUE
24802      ENDIF
24803C
24804      CALL DPSTE2(Y,W,NS,TEMP,MAXN,IBUGA3,ISUBRO,IERROR)
24805C
24806C               *****************
24807C               **  STEP 90--  **
24808C               **  EXIT       **
24809C               *****************
24810C
24811 9000 CONTINUE
24812      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'STEM')THEN
24813        WRITE(ICOUT,999)
24814        CALL DPWRST('XXX','BUG ')
24815        WRITE(ICOUT,9011)
24816 9011   FORMAT('***** AT THE END       OF DPSTEM--')
24817        CALL DPWRST('XXX','BUG ')
24818        WRITE(ICOUT,9016)IFOUND,IERROR
24819 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
24820        CALL DPWRST('XXX','BUG ')
24821      ENDIF
24822C
24823      RETURN
24824      END
24825      SUBROUTINE DPSTGL(ISUBRO,IBUGA3,IERROR)
24826C
24827C     PURPOSE--EXTRACT GROUP LABELS TO STRING
24828C     EXAMPLE--LET STEMP = GROUP LABEL TO STRINGS IG
24829C
24830C              SO IF THE GROUP LABEL VARIABLE "IG" HAS 10 LABELS,
24831C              THEN THESE WILL BE EXTRACTED TO STRINGS STEMP1, STEMP2,
24832C              ..., STEMP10
24833C     WRITTEN BY--ALAN HECKERT
24834C                 STATISTICAL ENGINEERING DIVISION
24835C                 INFORMATION TECHNOLOGY LABORATORY
24836C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
24837C                 GAITHERSBURG, MD 20899-8980
24838C                 PHONE--301-975-2899
24839C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24840C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
24841C     LANGUAGE--ANSI FORTRAN (1977)
24842C     VERSION NUMBER--2011/10
24843C     ORIGINAL VERSION--OCTOBER   2011.
24844C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
24845C     UPDATED         --JUNE      2018. ADD BASE STRING TO
24846C                                       CONTAIN ALL LEVELS
24847C                                       COMBINED
24848C     UPDATED         --JUNE      2018. ADD PARAMETER THAT
24849C                                       SPECIFIES NUMBER OF
24850C                                       LEVELS
24851C
24852C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24853C
24854      CHARACTER*4 ISUBRO
24855      CHARACTER*4 IBUGA3
24856      CHARACTER*4 IERROR
24857C
24858      CHARACTER*4 NEWNAM
24859      CHARACTER*4 NEWCOL
24860      CHARACTER*4 ICASEL
24861      CHARACTER*8 IHLEFT
24862      CHARACTER*8 ISTRIN
24863      CHARACTER*8 ISTRBA
24864      CHARACTER*4 IHLEF3
24865      CHARACTER*4 IHLEF4
24866      CHARACTER*4 IHRIGH
24867      CHARACTER*4 IHRIG2
24868C
24869      CHARACTER*40 ISTRZZ
24870      CHARACTER*4  ISTRZ2(1000)
24871      CHARACTER*1000 ISTRZX
24872C
24873      CHARACTER*4 ISUBN0
24874      CHARACTER*4 ISUBN1
24875      CHARACTER*4 ISUBN2
24876      CHARACTER*4 ISTEPN
24877C
24878C---------------------------------------------------------------------
24879C
24880C-----COMMON----------------------------------------------------------
24881C
24882      INCLUDE 'DPCOPA.INC'
24883      INCLUDE 'DPCOHK.INC'
24884      INCLUDE 'DPCOHO.INC'
24885      INCLUDE 'DPCODA.INC'
24886      INCLUDE 'DPCOP2.INC'
24887C
24888C-----START POINT-----------------------------------------------------
24889C
24890      ISUBN1='DPST'
24891      ISUBN2='GL  '
24892      IERROR='NO'
24893C
24894      ILOC3=0
24895C
24896      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STGL')THEN
24897        WRITE(ICOUT,999)
24898  999   FORMAT(1X)
24899        CALL DPWRST('XXX','BUG ')
24900        WRITE(ICOUT,51)
24901   51   FORMAT('***** AT THE BEGINNING OF DPSTGL--')
24902        CALL DPWRST('XXX','BUG ')
24903        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
24904   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
24905        CALL DPWRST('XXX','BUG ')
24906        DO55I=1,NUMNAM
24907          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
24908     1                   IVSTOP(I)
24909   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
24910     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
24911          CALL DPWRST('XXX','BUG ')
24912   55   CONTINUE
24913        WRITE(ICOUT,57)NUMCHF,MAXCHF
24914   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
24915        CALL DPWRST('XXX','BUG ')
24916        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
24917   60   FORMAT('IFUNC(.)  = ',120A1)
24918        CALL DPWRST('XXX','BUG ')
24919      ENDIF
24920C
24921C               **********************************
24922C               **  STEP 1--                    **
24923C               **  CHECK IF VARIABLE ON RHS IS **
24924C               **  A GROUP LABEL VARIABLE.     **
24925C               **********************************
24926C
24927      ISTEPN='1'
24928      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
24929     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24930C
24931      IGVAR=0
24932      IHRIGH=IHARG(7)
24933      IHRIG2=IHARG2(7)
24934C
24935      DO110I=1,MAXGRP
24936        IF(IHRIGH(1:4).EQ.IGRPVN(I)(1:4) .AND.
24937     1     IHRIG2(1:4).EQ.IGRPVN(I)(5:8))THEN
24938            IGVAR=I
24939            GOTO119
24940        ENDIF
24941  110 CONTINUE
24942C
24943      WRITE(ICOUT,999)
24944      CALL DPWRST('XXX','BUG ')
24945      WRITE(ICOUT,121)
24946  121 FORMAT('***** ERROR IN GROUP LABEL TO STRINGS COMMAND--')
24947      CALL DPWRST('XXX','BUG ')
24948      WRITE(ICOUT,123)IHRIGH,IHRIG2
24949  123 FORMAT('      ',A4,A4,' NOT RECOGNIZED AS A PREVIOUSLY DEFINED ',
24950     1       'GROUP LABEL VARIABLE.')
24951      CALL DPWRST('XXX','BUG ')
24952      IERROR='YES'
24953      GOTO9000
24954C
24955  119 CONTINUE
24956C
24957C               **********************************
24958C               **  STEP 2--                    **
24959C               **  DETERMINE NUMBER OF STRINGS **
24960C               **  TO CREATE (LOOK FOR FIRST   **
24961C               **  BLANK LABEL).               **
24962C               **********************************
24963C
24964      ISTEPN='2'
24965      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
24966     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24967C
24968      NSTR=200
24969      DO210I=1,MAXGLA
24970        IF(IGRPLA(I,IGVAR).EQ.' ')THEN
24971          NSTR=I-1
24972          GOTO219
24973        ENDIF
24974  210 CONTINUE
24975  219 CONTINUE
24976      IF(NSTR.GT.999)NSTR=999
24977      IF(NSTR.LT.1)GOTO9000
24978C
24979C               *************************************************
24980C               **  STEP 3--                                   **
24981C               **  EXTRACT THE BASE NAME ON THE LHS OF THE    **
24982C               **  EQUAL SIGN AND THEN LOOP THROUGH THE       **
24983C               **  NUMBER OF STRINGS TO CREATE.               **
24984C               *************************************************
24985C
24986      ISTEPN='3'
24987      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
24988     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24989C
24990      IHLEFT(1:4)=IHARG(1)
24991      IHLEFT(5:8)=IHARG2(1)
24992      NBASE=1
24993      DO310I=8,1,-1
24994        IF(IHLEFT(I:I).NE.' ')THEN
24995          NBASE=I
24996          GOTO319
24997        ENDIF
24998  310 CONTINUE
24999  319 CONTINUE
25000C
25001      IF(NSTR.LE.9)THEN
25002        IF(NBASE.GT.7)NBASE=7
25003      ELSEIF(NSTR.LE.99)THEN
25004        IF(NBASE.GT.6)NBASE=6
25005      ELSE
25006        IF(NBASE.GT.5)NBASE=5
25007      ENDIF
25008      ISTRBA(1:8)=IHLEFT(1:8)
25009      ISTRBA(NBASE+1:8)=' '
25010C
25011      ISTEPN='4'
25012      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
25013     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25014C
25015      NTOT=0
25016      ISTRZX=' '
25017      DO410I=1,NSTR
25018C
25019        ISTRZZ=' '
25020        ISTRIN=' '
25021        ISTRIN(1:NBASE)=IHLEFT(1:NBASE)
25022        IF(I.LE.9)THEN
25023          WRITE(ISTRIN(NBASE+1:NBASE+1),'(I1)')I
25024        ELSEIF(I.LE.99)THEN
25025          WRITE(ISTRIN(NBASE+1:NBASE+2),'(I2)')I
25026        ELSE
25027          WRITE(ISTRIN(NBASE+1:NBASE+3),'(I3)')I
25028        ENDIF
25029C
25030        NCHAR=40
25031        DO420J=40,1,-1
25032          IF(IGRPLA(I,IGVAR)(J:J).NE.' ')THEN
25033            NCHAR=J
25034            GOTO429
25035          ENDIF
25036  420   CONTINUE
25037        NCHAR=1
25038  429   CONTINUE
25039C
25040        ISTRZZ(1:NCHAR)=IGRPLA(I,IGVAR)(1:NCHAR)
25041        NSTRT=NTOT+1
25042        NSTOP=NTOT+NCHAR
25043        IF(NSTOP.LE.999)THEN
25044          ISTRZX(NSTRT:NSTOP)=ISTRZZ(1:NCHAR)
25045          NTOT=NSTOP
25046          IF(I.LT.NSTR)THEN
25047            NTOT=NTOT+1
25048            ISTRZX(NTOT:NTOT)=' '
25049          ENDIF
25050        ENDIF
25051C
25052        NEWNAM='NO'
25053        NEWCOL='NO'
25054        ICASEL='UNKN'
25055        NIOLD1=0
25056        ICOLL=0
25057C
25058C               ******************************************************
25059C               **  STEP 5--                                         *
25060C               **  EXAMINE THE CURRENT STRING--                     *
25061C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
25062C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
25063C               ******************************************************
25064C
25065        ISTEPN='5'
25066        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
25067     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25068C
25069        DO510II=1,NUMNAM
25070          I2=II
25071          IF(ISTRIN(1:4).EQ.IHNAME(I2).AND.
25072     1       ISTRIN(5:8).EQ.IHNAM2(I2))THEN
25073            IF(IUSE(I2).EQ.'F')THEN
25074              ICASEL='STRI'
25075              ILISTL=I2
25076              GOTO519
25077            ELSE
25078              WRITE(ICOUT,999)
25079              CALL DPWRST('XXX','BUG ')
25080              WRITE(ICOUT,121)
25081              CALL DPWRST('XXX','BUG ')
25082              WRITE(ICOUT,513)ISTRIN
25083  513         FORMAT('      THE NAME ',A8,' ALREADY EXISTS, BUT NOT ',
25084     1               'AS A STRING.')
25085              CALL DPWRST('XXX','BUG ')
25086              WRITE(ICOUT,515)
25087  515         FORMAT('      THIS STRING WILL NOT BE CREATED.')
25088              CALL DPWRST('XXX','BUG ')
25089              GOTO9000
25090            ENDIF
25091          ENDIF
25092  510   CONTINUE
25093  519   CONTINUE
25094C
25095        NEWNAM='YES'
25096        ICASEL='STRI'
25097C
25098        ILISTL=NUMNAM+1
25099        IF(ILISTL.GT.MAXNAM)THEN
25100          WRITE(ICOUT,999)
25101          CALL DPWRST('XXX','BUG ')
25102          WRITE(ICOUT,121)
25103          CALL DPWRST('XXX','BUG ')
25104          WRITE(ICOUT,522)
25105  522     FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
25106     1           'FUNCTION')
25107          CALL DPWRST('XXX','BUG ')
25108          WRITE(ICOUT,524)MAXNAM
25109  524     FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
25110          CALL DPWRST('XXX','BUG ')
25111          IERROR='YES'
25112          GOTO9000
25113        ENDIF
25114C
25115C               *****************************************************
25116C               **  STEP 6--                                       **
25117C               **  ADD THE CURRENT STRING                         **
25118C               *****************************************************
25119C
25120        ISTEPN='6'
25121        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
25122     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25123C
25124        IHLEF3=ISTRIN(1:4)
25125        IHLEF4=ISTRIN(5:8)
25126        DO411J=1,NCHAR
25127          ISTRZ2(J)=' '
25128          ISTRZ2(J)(1:1)=ISTRZZ(J:J)
25129  411   CONTINUE
25130C
25131        CALL DPINFU(ISTRZ2,NCHAR,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
25132     1              NUMNAM,IANS,IWIDTH,IHLEF3,IHLEF4,ILISTL,
25133CCCCC1              NEWNAM,MAXN3,
25134     1              NEWNAM,MAXNAM,
25135     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
25136        IF(IERROR.EQ.'YES')GOTO9000
25137C
25138  410 CONTINUE
25139C
25140C               *****************************************************
25141C               **  STEP 7--                                       **
25142C               **  PRINT FEEDBACK MESSAGE                         **
25143C               *****************************************************
25144C
25145      ISTEPN='4'
25146      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
25147     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25148C
25149      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
25150        WRITE(ICOUT,999)
25151        CALL DPWRST('XXX','BUG ')
25152        WRITE(ICOUT,710)NSTR
25153  710   FORMAT(I5,' STRINGS HAVE BEEN CREATED FROM THE GROUP LABELS.')
25154        CALL DPWRST('XXX','BUG ')
25155        WRITE(ICOUT,999)
25156        CALL DPWRST('XXX','BUG ')
25157      ENDIF
25158C
25159      IHLEF3='NUMS'
25160      IHLEF4='TRIN'
25161      VALUE0=REAL(NSTR)
25162      CALL DPADDP(IHLEF3,IHLEF4,VALUE0,IHOST1,ISUBN0,
25163     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
25164     1            IANS,IWIDTH,IBUGA3,IERROR)
25165C
25166C               ******************************************************
25167C               **  STEP 8--                                         *
25168C               **  EXAMINE THE BASE STRING--                        *
25169C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
25170C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
25171C               ******************************************************
25172C
25173      ISTEPN='8'
25174      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
25175     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25176C
25177      NEWNAM='NO'
25178      NEWCOL='NO'
25179      ICASEL='UNKN'
25180      NIOLD1=0
25181      ICOLL=0
25182C
25183      DO810II=1,NUMNAM
25184        I2=II
25185        IF(ISTRBA(1:4).EQ.IHNAME(I2).AND.
25186     1     ISTRBA(5:8).EQ.IHNAM2(I2))THEN
25187          IF(IUSE(I2).EQ.'F')THEN
25188            ICASEL='STRI'
25189            ILISTL=I2
25190            GOTO819
25191          ELSE
25192            WRITE(ICOUT,999)
25193            CALL DPWRST('XXX','BUG ')
25194            WRITE(ICOUT,121)
25195            CALL DPWRST('XXX','BUG ')
25196            WRITE(ICOUT,513)ISTRBA
25197            CALL DPWRST('XXX','BUG ')
25198            WRITE(ICOUT,515)
25199            CALL DPWRST('XXX','BUG ')
25200            GOTO9000
25201          ENDIF
25202        ENDIF
25203  810 CONTINUE
25204  819 CONTINUE
25205C
25206      NEWNAM='YES'
25207      ICASEL='STRI'
25208C
25209      ILISTL=NUMNAM+1
25210      IF(ILISTL.GT.MAXNAM)THEN
25211        WRITE(ICOUT,999)
25212        CALL DPWRST('XXX','BUG ')
25213        WRITE(ICOUT,121)
25214        CALL DPWRST('XXX','BUG ')
25215        WRITE(ICOUT,522)
25216        CALL DPWRST('XXX','BUG ')
25217        WRITE(ICOUT,524)MAXNAM
25218        CALL DPWRST('XXX','BUG ')
25219        IERROR='YES'
25220        GOTO9000
25221      ENDIF
25222C
25223C               *****************************************************
25224C               **  STEP 8B--                                      **
25225C               **  ADD THE BASE STRING                            **
25226C               *****************************************************
25227C
25228      ISTEPN='8B'
25229      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STGL')
25230     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25231C
25232      IHLEF3=ISTRBA(1:4)
25233      IHLEF4=ISTRBA(5:8)
25234      DO831J=1,NTOT
25235        ISTRZ2(J)=' '
25236        ISTRZ2(J)(1:1)=ISTRZX(J:J)
25237  831 CONTINUE
25238C
25239      CALL DPINFU(ISTRZ2,NTOT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
25240     1            NUMNAM,IANS,IWIDTH,IHLEF3,IHLEF4,ILISTL,
25241     1            NEWNAM,MAXNAM,
25242     1            IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
25243      IF(IERROR.EQ.'YES')GOTO9000
25244C
25245C
25246C               ****************
25247C               **  STEP 90-- **
25248C               **  EXIT.     **
25249C               ****************
25250C
25251 9000 CONTINUE
25252      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STGL')THEN
25253        WRITE(ICOUT,999)
25254        CALL DPWRST('XXX','BUG ')
25255        WRITE(ICOUT,9011)
25256 9011   FORMAT('***** AT THE END       OF DPSTGL--')
25257        CALL DPWRST('XXX','BUG ')
25258        WRITE(ICOUT,9013)NUMNAM
25259 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
25260        CALL DPWRST('XXX','BUG ')
25261        DO9015I=1,NUMNAM
25262          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
25263     1                     IVSTAR(I),IVSTOP(I)
25264 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
25265     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
25266          CALL DPWRST('XXX','BUG ')
25267 9015   CONTINUE
25268      ENDIF
25269C
25270      RETURN
25271      END
25272      SUBROUTINE DPSTHD(ISUBRO,IBUGA3,IERROR)
25273C
25274C     PURPOSE--RETURN THE HAMMING DISTANCE BETWEEN TWO STRINGS.
25275C              THE HAMMING DISTANCE IS THE NUMBER OF CHARACTERS
25276C              IN THE TWO STRINGS THAT ARE DIFFERENT.
25277C     EXAMPLE--LET NLEN = STRING HAMMING DISTANCE S1 S2
25278C     WRITTEN BY--ALAN HECKERT
25279C                 STATISTICAL ENGINEERING DIVISION
25280C                 INFORMATION TECHNOLOGY LABORATORY
25281C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
25282C                 GAITHERSBURG, MD 20899-8980
25283C                 PHONE--301-975-2899
25284C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25285C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
25286C     LANGUAGE--ANSI FORTRAN (1977)
25287C     VERSION NUMBER--2018/09
25288C     ORIGINAL VERSION--SEPTEMBER 2018.
25289C
25290C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25291C
25292      CHARACTER*4 ISUBRO
25293      CHARACTER*4 IBUGA3
25294      CHARACTER*4 IERROR
25295C
25296      CHARACTER*4 NEWNAM
25297      CHARACTER*4 NEWCOL
25298      CHARACTER*4 ICASEL
25299      CHARACTER*4 IHLEFT
25300      CHARACTER*4 IHLEF2
25301      CHARACTER*4 IHRIGH
25302      CHARACTER*4 IHRIG2
25303      CHARACTER*4 IHRIG3
25304      CHARACTER*4 IHRIG4
25305C
25306      CHARACTER*4 ISUBN1
25307      CHARACTER*4 ISUBN2
25308      CHARACTER*4 ISTEPN
25309C
25310      CHARACTER*8 ISTR
25311C
25312C---------------------------------------------------------------------
25313C
25314C-----COMMON----------------------------------------------------------
25315C
25316      INCLUDE 'DPCOPA.INC'
25317      INCLUDE 'DPCOHK.INC'
25318      INCLUDE 'DPCODA.INC'
25319      INCLUDE 'DPCOP2.INC'
25320C
25321C-----START POINT-----------------------------------------------------
25322C
25323      ISUBN1='DPST'
25324      ISUBN2='HD  '
25325      IERROR='NO'
25326C
25327      ILOC3=0
25328C
25329C               *****************************************************
25330C               **  TREAT THE SUBCASE OF THE LET FUNCTION COMMAND  **
25331C               **  WHICH DEFINES A FUNCTION                       **
25332C               *****************************************************
25333C
25334      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STHD')THEN
25335        WRITE(ICOUT,999)
25336        CALL DPWRST('XXX','BUG ')
25337        WRITE(ICOUT,51)
25338   51   FORMAT('***** AT THE BEGINNING OF DPSTHD--')
25339        CALL DPWRST('XXX','BUG ')
25340        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
25341   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
25342        CALL DPWRST('XXX','BUG ')
25343        DO55I=1,NUMNAM
25344          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
25345     1                   IVSTOP(I)
25346   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
25347     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
25348          CALL DPWRST('XXX','BUG ')
25349   55   CONTINUE
25350        WRITE(ICOUT,57)NUMCHF,MAXCHF
25351   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
25352        CALL DPWRST('XXX','BUG ')
25353        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
25354   60   FORMAT('IFUNC(.)  = ',120A1)
25355        CALL DPWRST('XXX','BUG ')
25356      ENDIF
25357C
25358C               **********************************
25359C               **  STEP 1--                    **
25360C               **  INITIALIZE SOME VARIABLES.  **
25361C               **********************************
25362C
25363      ISTEPN='1'
25364      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STHD')
25365     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25366C
25367      NEWNAM='NO'
25368      NEWCOL='NO'
25369      ICASEL='UNKN'
25370      NIOLD=0
25371      ICOLL=0
25372      ICOL2=0
25373C
25374      MAXCP1=MAXCOL+1
25375      MAXCP2=MAXCOL+2
25376      MAXCP3=MAXCOL+3
25377      MAXCP4=MAXCOL+4
25378      MAXCP5=MAXCOL+5
25379      MAXCP6=MAXCOL+6
25380C
25381C               ******************************************************
25382C               **  STEP 2--                                         *
25383C               **  EXAMINE THE LEFT-HAND SIDE--                     *
25384C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
25385C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
25386C               ******************************************************
25387C
25388      ISTEPN='2'
25389      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STHD')
25390     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25391C
25392      IHLEFT=IHARG(1)
25393      IHLEF2=IHARG2(1)
25394C
25395      DO1910I=1,4
25396        IF(IHLEFT(I:I).EQ.'(')THEN
25397          IHLEFT(I:4)=' '
25398          IHLEF2=' '
25399          ICASEL='ELEM'
25400          GOTO1999
25401        ENDIF
25402 1910 CONTINUE
25403      DO1920I=1,4
25404        IF(IHLEF2(I:I).EQ.'(')THEN
25405          IHLEF2(I:4)=' '
25406          ICASEL='ELEM'
25407          GOTO1999
25408        ENDIF
25409 1920 CONTINUE
25410 1999 CONTINUE
25411C
25412      DO2000I=1,NUMNAM
25413        I2=I
25414        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
25415          IF(IUSE(I2).EQ.'P')THEN
25416            ICASEL='PARA'
25417            ILISTL=I2
25418            GOTO2900
25419          ELSEIF(IUSE(I2).EQ.'V')THEN
25420            ICASEL='ELEM'
25421            ILISTL=I2
25422            ICOLL=IVALUE(ILISTL)
25423            NIOLD=IN(ILISTL)
25424            GOTO2900
25425          ELSE
25426            WRITE(ICOUT,999)
25427  999       FORMAT(1X)
25428            CALL DPWRST('XXX','BUG ')
25429            WRITE(ICOUT,2001)
25430 2001       FORMAT('***** ERROR IN STRING HAMMING DISTANCE--')
25431            CALL DPWRST('XXX','BUG ')
25432            WRITE(ICOUT,2003)IHLEFT,IHLEF2
25433 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
25434     1             A4,A4,')')
25435            CALL DPWRST('XXX','BUG ')
25436            WRITE(ICOUT,2005)
25437 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
25438            CALL DPWRST('XXX','BUG ')
25439            IERROR='YES'
25440            GOTO9000
25441          ENDIF
25442        ENDIF
25443 2000 CONTINUE
25444C
25445      NEWNAM='YES'
25446      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
25447C
25448      ILISTL=NUMNAM+1
25449      IF(ILISTL.GT.MAXNAM)THEN
25450        WRITE(ICOUT,999)
25451        CALL DPWRST('XXX','BUG ')
25452        WRITE(ICOUT,2001)
25453        CALL DPWRST('XXX','BUG ')
25454        WRITE(ICOUT,2202)
25455 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
25456     1         'FUNCTION')
25457        CALL DPWRST('XXX','BUG ')
25458        WRITE(ICOUT,2203)MAXNAM
25459 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
25460        CALL DPWRST('XXX','BUG ')
25461        WRITE(ICOUT,2204)
25462 2204   FORMAT('      ENTER      STATUS')
25463        CALL DPWRST('XXX','BUG ')
25464        WRITE(ICOUT,2205)
25465 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
25466        CALL DPWRST('XXX','BUG ')
25467        WRITE(ICOUT,2206)
25468 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
25469     1         'USED NAMES.')
25470        CALL DPWRST('XXX','BUG ')
25471        IERROR='YES'
25472        GOTO9000
25473      ENDIF
25474C
25475 2900 CONTINUE
25476C
25477C               *****************************************************
25478C               **  STEP 3A--                                      **
25479C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
25480C               *****************************************************
25481C
25482      ISTEPN='3A'
25483      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STHD')
25484     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25485C
25486      IHRIGH=IHARG(6)
25487      IHRIG2=IHARG2(6)
25488      DO3000I=1,NUMNAM
25489        I4=I
25490        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
25491          IF(IUSE(I4).NE.'F')THEN
25492            WRITE(ICOUT,999)
25493            CALL DPWRST('XXX','BUG ')
25494            WRITE(ICOUT,2001)
25495            CALL DPWRST('XXX','BUG ')
25496            WRITE(ICOUT,3003)IHRIGH,IHRIG2
25497 3003       FORMAT('      THE FIRST NAME ON THE RIGHT HAND SIDE (',
25498     1             A4,A4,')')
25499            CALL DPWRST('XXX','BUG ')
25500            WRITE(ICOUT,3005)
25501 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
25502            CALL DPWRST('XXX','BUG ')
25503            IERROR='YES'
25504            GOTO9000
25505          ELSE
25506            ISTRT1=IVSTAR(I4)
25507            ISTOP1=IVSTOP(I4)
25508            IVAL1=ISTOP1-ISTRT1+1
25509            GOTO3099
25510          ENDIF
25511        ENDIF
25512 3000 CONTINUE
25513C
25514      WRITE(ICOUT,999)
25515      CALL DPWRST('XXX','BUG ')
25516      WRITE(ICOUT,2001)
25517      CALL DPWRST('XXX','BUG ')
25518      WRITE(ICOUT,3003)IHRIGH,IHRIG2
25519      CALL DPWRST('XXX','BUG ')
25520      WRITE(ICOUT,3015)
25521 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
25522      CALL DPWRST('XXX','BUG ')
25523      IERROR='YES'
25524      GOTO9000
25525C
25526 3099 CONTINUE
25527C
25528C               *****************************************************
25529C               **  STEP 3B--                                      **
25530C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
25531C               *****************************************************
25532C
25533      ISTEPN='3B'
25534      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STHD')
25535     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25536C
25537      IHRIG3=IHARG(7)
25538      IHRIG4=IHARG2(7)
25539      DO3100I=1,NUMNAM
25540        I4=I
25541        IF(IHRIG3.EQ.IHNAME(I).AND.IHRIG4.EQ.IHNAM2(I))THEN
25542          IF(IUSE(I4).NE.'F')THEN
25543            WRITE(ICOUT,999)
25544            CALL DPWRST('XXX','BUG ')
25545            WRITE(ICOUT,2001)
25546            CALL DPWRST('XXX','BUG ')
25547            WRITE(ICOUT,3103)IHRIG3,IHRIG4
25548 3103       FORMAT('      THE SECOND NAME ON THE RIGHT HAND SIDE (',
25549     1             A4,A4,')')
25550            CALL DPWRST('XXX','BUG ')
25551            WRITE(ICOUT,3005)
25552            CALL DPWRST('XXX','BUG ')
25553            IERROR='YES'
25554            GOTO9000
25555          ELSE
25556            ISTRT2=IVSTAR(I4)
25557            ISTOP2=IVSTOP(I4)
25558            IVAL2=ISTOP2-ISTRT2+1
25559            GOTO3900
25560          ENDIF
25561        ENDIF
25562 3100 CONTINUE
25563C
25564      WRITE(ICOUT,999)
25565      CALL DPWRST('XXX','BUG ')
25566      WRITE(ICOUT,2001)
25567      CALL DPWRST('XXX','BUG ')
25568      WRITE(ICOUT,3003)IHRIGH,IHRIG2
25569      CALL DPWRST('XXX','BUG ')
25570      WRITE(ICOUT,3015)
25571      CALL DPWRST('XXX','BUG ')
25572      IERROR='YES'
25573      GOTO9000
25574C
25575 3900 CONTINUE
25576C
25577      IF(IVAL1.NE.IVAL2)THEN
25578        WRITE(ICOUT,999)
25579        CALL DPWRST('XXX','BUG ')
25580        WRITE(ICOUT,2001)
25581        CALL DPWRST('XXX','BUG ')
25582        WRITE(ICOUT,3901)
25583 3901   FORMAT('      THE TWO STRINGS ARE NOT THE SAME LENGTH.')
25584        CALL DPWRST('XXX','BUG ')
25585        WRITE(ICOUT,3902)IVAL1
25586 3902   FORMAT('      STRING ONE HAS ',I6,' CHARACTERS.')
25587        CALL DPWRST('XXX','BUG ')
25588        WRITE(ICOUT,3903)IVAL2
25589 3903   FORMAT('      STRING TWO HAS ',I6,' CHARACTERS.')
25590        CALL DPWRST('XXX','BUG ')
25591        IERROR='YES'
25592        GOTO9000
25593      ENDIF
25594C
25595C               *****************************************************
25596C               **  STEP 4--                                       **
25597C               **  SAVE PARAMETER                                 **
25598C               *****************************************************
25599C
25600      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STHD')THEN
25601        ISTEPN='4'
25602        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25603        WRITE(ICOUT,4011)ISTRT1,ISTOP1,IVAL1
25604 4011   FORMAT('ISTRT1,ISTOP1,IVAL1 = ',3I8)
25605        CALL DPWRST('XXX','BUG ')
25606        WRITE(ICOUT,4012)ISTRT2,ISTOP2,IVAL2
25607 4012   FORMAT('ISTRT2,ISTOP2,IVAL2 = ',3I8)
25608        CALL DPWRST('XXX','BUG ')
25609        WRITE(ICOUT,4013)ICASEL
25610 4013   FORMAT('ICASEL = ',A4)
25611        CALL DPWRST('XXX','BUG ')
25612      ENDIF
25613C
25614      ICNT=0
25615      DO4020I=1,IVAL1
25616        IF(IFUNC(ISTRT1+I-1).NE.IFUNC(ISTRT2+I-1))ICNT=ICNT+1
25617 4020 CONTINUE
25618C
25619      IF(ICASEL.EQ.'PARA')THEN
25620C
25621        ISTEPN='4A'
25622        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STHD')
25623     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25624C
25625        IHNAME(ILISTL)=IHLEFT
25626        IHNAM2(ILISTL)=IHLEF2
25627        IUSE(ILISTL)='P'
25628        VALUE(ILISTL)=REAL(ICNT)
25629        IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
25630        IN(ILISTL)=1
25631        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
25632C
25633        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
25634          WRITE(ICOUT,999)
25635          CALL DPWRST('XXX','BUG ')
25636          WRITE(ICOUT,15111)IHLEFT,IHLEF2,IHRIGH,IHRIG2,IHRIG3,IHRIG4
2563715111     FORMAT(2A4,' CONTAINS THE HAMMING DISTANCE OF STRINGS ',
25638     1           2A4,' AND ',2A4)
25639          CALL DPWRST('XXX','BUG ')
25640          WRITE(ICOUT,15113)ICNT
2564115113     FORMAT('THE HAMMING DISTANCE = ',I8)
25642          CALL DPWRST('XXX','BUG ')
25643          WRITE(ICOUT,999)
25644          CALL DPWRST('XXX','BUG ')
25645        ENDIF
25646      ELSEIF(ICASEL.EQ.'ELEM')THEN
25647C
25648C       SEARCH IANS STRING FOR "(xx) =".  IF NO PARENTHESIS
25649C       FOUND BEFORE "=", THEN DO NOT KNOW WHAT ROW OF THE
25650C       VARIABLE TO SAVE.  TREAT THIS AS AN ERROR.
25651C
25652        NLEFT=-1
25653        NRIGHT=-1
25654        NEQUAL=-1
25655        DO16001I=1,IWIDTH
25656          IF(IANS(I)(1:1).EQ.'(' .AND. NLEFT.LT.0)THEN
25657            NLEFT=I
25658          ELSEIF(IANS(I)(1:1).EQ.')' .AND. NRIGHT.LT.0)THEN
25659            NRIGHT=I
25660          ELSEIF(IANS(I)(1:1).EQ.'=' .AND. NEQUAL.LT.0)THEN
25661            NEQUAL=I
25662          ENDIF
2566316001   CONTINUE
25664C
25665C       NEED  NLEFT < NRIGHT < NEQUAL
25666C
25667        NSTRT=NLEFT+1
25668        NSTOP=NRIGHT-1
25669        NLEN=NSTOP-NSTRT+1
25670        IF(NLEFT.GT.NRIGHT .OR. NRIGHT.GT.NEQUAL .OR.
25671     1     NSTRT.GT.NSTOP .OR. NLEN.GT.8) THEN
25672          WRITE(ICOUT,999)
25673          CALL DPWRST('XXX','BUG ')
25674          WRITE(ICOUT,2001)
25675          CALL DPWRST('XXX','BUG ')
25676          WRITE(ICOUT,16011)
2567716011     FORMAT('      UNRECOGNIZED SYNTAX FOR VARIABLE ELEMENT ON')
25678          CALL DPWRST('XXX','BUG ')
25679          WRITE(ICOUT,16013)
2568016013     FORMAT('      LEFT HAND SIDE EQUAL SIGN.')
25681          CALL DPWRST('XXX','BUG ')
25682          IERROR='YES'
25683          GOTO9000
25684        ELSE
25685          ISTR=' '
25686          DO16020I=1,NLEN
25687            ISTR(I:I)=IANS(NSTRT+I-1)(1:1)
2568816020     CONTINUE
25689          READ(ISTR,'(I8)',ERR=16029)IARGL
25690          GOTO16049
25691C
2569216029     CONTINUE
25693          WRITE(ICOUT,999)
25694          CALL DPWRST('XXX','BUG ')
25695          WRITE(ICOUT,2001)
25696          CALL DPWRST('XXX','BUG ')
25697          WRITE(ICOUT,16011)
25698          CALL DPWRST('XXX','BUG ')
25699          WRITE(ICOUT,16013)
25700          CALL DPWRST('XXX','BUG ')
25701          IERROR='YES'
25702          GOTO9000
25703C
2570416049     CONTINUE
25705        ENDIF
25706C
25707        IF(IARGL.LT.1 .OR. IARGL.GT.MAXN)THEN
25708          WRITE(ICOUT,999)
25709          CALL DPWRST('XXX','BUG ')
25710          WRITE(ICOUT,2001)
25711          CALL DPWRST('XXX','BUG ')
25712          WRITE(ICOUT,16052)IARGL,ILEFT
2571316052     FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
25714          CALL DPWRST('XXX','BUG ')
25715          WRITE(ICOUT,16054)
2571616054     FORMAT('      WAS LESS THAN 1 OR GREATER THAN THE')
25717          CALL DPWRST('XXX','BUG ')
25718          WRITE(ICOUT,16055)MAXN
2571916055     FORMAT('      MAXIMUM ALLOWABLE ',I8)
25720          CALL DPWRST('XXX','BUG ')
25721          IERROR='YES'
25722          GOTO9000
25723        ENDIF
25724C
25725        IF(NEWNAM.EQ.'YES')THEN
25726          NIOLD=1
25727        ENDIF
25728        NINEW=NIOLD
25729        IF(IARGL.GT.NINEW)NINEW=IARGL
25730        NS2=1
25731C
25732        RIGHT=REAL(ICNT)
25733        IJ=MAXN*(ICOLL-1)+IARGL
25734        IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
25735        IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT
25736        IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT
25737        IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT
25738        IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT
25739        IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT
25740        IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT
25741C
25742        IHNAME(ILISTL)=IHLEFT
25743        IHNAM2(ILISTL)=IHLEF2
25744        IUSE(ILISTL)='V'
25745        IVALUE(ILISTL)=ICOLL
25746        VALUE(ILISTL)=ICOLL
25747        IN(ILISTL)=NINEW
25748C
25749        IF(NEWNAM.EQ.'YES')THEN
25750          NUMNAM=NUMNAM+1
25751          NUMCOL=NUMCOL+1
25752        ENDIF
25753C
25754        DO16200J4=1,NUMNAM
25755          IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)THEN
25756            IUSE(J4)='V'
25757            IVALUE(J4)=ICOLL
25758            VALUE(J4)=ICOLL
25759            IN(J4)=NINEW
25760            GOTO16209
25761          ENDIF
2576216200   CONTINUE
2576316209   CONTINUE
25764C
25765        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
25766          WRITE(ICOUT,999)
25767          CALL DPWRST('XXX','BUG ')
25768          WRITE(ICOUT,16211)IHRIGH,IHRIG2,IHRIG3,IHRIG4,ICNT
2576916211     FORMAT('THE HAMMING DISTANCE OF STRINGS ',2A4,
25770     1           ' AND ',2A4,' = ',I8)
25771          CALL DPWRST('XXX','BUG ')
25772          WRITE(ICOUT,999)
25773          CALL DPWRST('XXX','BUG ')
25774        ENDIF
25775      ENDIF
25776      GOTO9000
25777C
25778C
25779C               ****************
25780C               **  STEP 90-- **
25781C               **  EXIT.     **
25782C               ****************
25783C
25784 9000 CONTINUE
25785      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STHD')THEN
25786        WRITE(ICOUT,999)
25787        CALL DPWRST('XXX','BUG ')
25788        WRITE(ICOUT,9011)
25789 9011   FORMAT('***** AT THE END       OF DPSTHD--')
25790        CALL DPWRST('XXX','BUG ')
25791        WRITE(ICOUT,9013)NUMNAM
25792 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
25793        CALL DPWRST('XXX','BUG ')
25794        DO9015I=1,NUMNAM
25795          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
25796     1                     IVSTAR(I),IVSTOP(I)
25797 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
25798     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
25799          CALL DPWRST('XXX','BUG ')
25800 9015   CONTINUE
25801      ENDIF
25802C
25803      RETURN
25804      END
25805      SUBROUTINE DPSTIN(ICASEZ,ISUBRO,IBUGA3,IERROR)
25806C
25807C     PURPOSE--RETURN THE START AND STOP POSITIONS OF A SUBSTRING
25808C              OF A PREVIOUSLY DEFINED STRING.
25809C     EXAMPLE--LET STRING SORG = ABCDEF
25810C              LET STRING SUB  = DE
25811C              LET NSTART NSTOP = STRING INDEX SORG SUB
25812C     NOTE--THE FOLLOWING SYNTAX IS NOT SUPPORTED FOR THIS COMMAND:
25813C              LET Y(2) Y(8) = STRING INDEX S  SUBSTRING
25814C           ALSO, THE STRINGS ON THE RIGHT HAND SIDE MUST BOTH BE
25815C           PREVIOUSLY DEFINED.
25816C     WRITTEN BY--ALAN HECKERT
25817C                 STATISTICAL ENGINEERING DIVISION
25818C                 INFORMATION TECHNOLOGY LABORATORY
25819C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
25820C                 GAITHERSBURG, MD 20899-8980
25821C                 PHONE--301-975-2899
25822C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25823C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
25824C     LANGUAGE--ANSI FORTRAN (1977)
25825C     VERSION NUMBER--2008/11
25826C     ORIGINAL VERSION--NOVEMBER  2008.
25827C     UPDATED         --SEPTEMBER 2018. STRING FIND AS ALIAS
25828C     UPDATED         --SEPTEMBER 2018. STRING RIGHT INDEX (TO SEARCH
25829C                                       STRING FROM RIGHT TO LEFT)
25830C
25831C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25832C
25833      CHARACTER*4 ICASEZ
25834      CHARACTER*4 ISUBRO
25835      CHARACTER*4 IBUGA3
25836      CHARACTER*4 IERROR
25837C
25838      CHARACTER*4 NEWNAM
25839      CHARACTER*4 NEWNA2
25840      CHARACTER*4 NEWCOL
25841      CHARACTER*4 NEWCO2
25842      CHARACTER*4 ICASEL
25843      CHARACTER*4 ICASE2
25844      CHARACTER*4 IHLEFT
25845      CHARACTER*4 IHLEF2
25846      CHARACTER*4 IHLE21
25847      CHARACTER*4 IHLE22
25848      CHARACTER*4 IHRIGH
25849      CHARACTER*4 IHRIG2
25850      CHARACTER*4 IHRI21
25851      CHARACTER*4 IHRI22
25852      CHARACTER*4 ISUBN1
25853      CHARACTER*4 ISUBN2
25854      CHARACTER*4 ISTEPN
25855C
25856C---------------------------------------------------------------------
25857C
25858C-----COMMON----------------------------------------------------------
25859C
25860      INCLUDE 'DPCOPA.INC'
25861      INCLUDE 'DPCOHK.INC'
25862      INCLUDE 'DPCODA.INC'
25863      INCLUDE 'DPCOP2.INC'
25864C
25865C-----START POINT-----------------------------------------------------
25866C
25867      ISUBN1='DPST'
25868      ISUBN2='IN  '
25869      IERROR='NO'
25870C
25871      ILOC3=0
25872      ILIST2=0
25873      NUMTMP=0
25874      IMATCH=0
25875C
25876      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STIN')THEN
25877        WRITE(ICOUT,999)
25878        CALL DPWRST('XXX','BUG ')
25879        WRITE(ICOUT,51)
25880   51   FORMAT('***** AT THE BEGINNING OF DPSTIN--')
25881        CALL DPWRST('XXX','BUG ')
25882        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
25883   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
25884        CALL DPWRST('XXX','BUG ')
25885        DO55I=1,NUMNAM
25886          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
25887     1                   IVSTOP(I)
25888   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
25889     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
25890          CALL DPWRST('XXX','BUG ')
25891   55   CONTINUE
25892        WRITE(ICOUT,57)NUMCHF,MAXCHF
25893   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
25894        CALL DPWRST('XXX','BUG ')
25895        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
25896   60   FORMAT('IFUNC(.)  = ',120A1)
25897        CALL DPWRST('XXX','BUG ')
25898      ENDIF
25899C
25900C               **********************************
25901C               **  STEP 1--                    **
25902C               **  INITIALIZE SOME VARIABLES.  **
25903C               **********************************
25904C
25905      ISTEPN='1'
25906      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')
25907     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25908C
25909      NEWNAM='NO'
25910      NEWNA2='NO'
25911      NEWCOL='NO'
25912      NEWCO2='NO'
25913      ICASEL='UNKN'
25914      ICASE2='UNKN'
25915      NIOLD1=0
25916      NIOLD2=0
25917      ICOLL=0
25918      ICOL2=0
25919C
25920C               ******************************************************
25921C               **  STEP 2--                                         *
25922C               **  EXAMINE THE FIRST ARGUMENT ON THE                *
25923C               **  LEFT-HAND SIDE--                                 *
25924C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
25925C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
25926C               ******************************************************
25927C
25928      ISTEPN='2'
25929      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')
25930     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25931C
25932      IHLEFT=IHARG(1)
25933      IHLEF2=IHARG2(1)
25934C
25935      DO2000I=1,NUMNAM
25936        I2=I
25937        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
25938          IF(IUSE(I2).EQ.'P')THEN
25939            ICASEL='PARA'
25940            ILISTL=I2
25941            NUMTMP=NUMNAM
25942            GOTO2299
25943          ELSE
25944            WRITE(ICOUT,999)
25945  999       FORMAT(1X)
25946            CALL DPWRST('XXX','BUG ')
25947            WRITE(ICOUT,2001)
25948 2001       FORMAT('***** ERROR IN STRING INDEX--')
25949            CALL DPWRST('XXX','BUG ')
25950            WRITE(ICOUT,2003)IHLEFT,IHLEF2
25951 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
25952     1             A4,A4,')')
25953            CALL DPWRST('XXX','BUG ')
25954            WRITE(ICOUT,2005)
25955 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
25956            CALL DPWRST('XXX','BUG ')
25957            IERROR='YES'
25958            GOTO9000
25959          ENDIF
25960        ENDIF
25961 2000 CONTINUE
25962C
25963      NEWNAM='YES'
25964      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
25965C
25966      ILISTL=NUMNAM+1
25967      NUMTMP=NUMNAM+1
25968      IF(ILISTL.GT.MAXNAM)THEN
25969        WRITE(ICOUT,999)
25970        CALL DPWRST('XXX','BUG ')
25971        WRITE(ICOUT,2001)
25972        CALL DPWRST('XXX','BUG ')
25973        WRITE(ICOUT,2202)
25974 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
25975     1         'FUNCTION')
25976        CALL DPWRST('XXX','BUG ')
25977        WRITE(ICOUT,2203)MAXNAM
25978 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
25979        CALL DPWRST('XXX','BUG ')
25980        WRITE(ICOUT,2204)
25981 2204   FORMAT('      ENTER      STATUS')
25982        CALL DPWRST('XXX','BUG ')
25983        WRITE(ICOUT,2205)
25984 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
25985        CALL DPWRST('XXX','BUG ')
25986        WRITE(ICOUT,2206)
25987 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
25988     1         'USED NAMES.')
25989        CALL DPWRST('XXX','BUG ')
25990        IERROR='YES'
25991        GOTO9000
25992      ENDIF
25993C
25994 2299 CONTINUE
25995C
25996C               ******************************************************
25997C               **  STEP 2B-                                         *
25998C               **  EXAMINE THE SECOND ARGUMENT ON THE               *
25999C               **  LEFT-HAND SIDE--                                 *
26000C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
26001C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
26002C               ******************************************************
26003C
26004      ISTEPN='2B'
26005      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')
26006     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26007C
26008      IHLE21=IHARG(2)
26009      IHLE22=IHARG2(2)
26010C
26011      DO2300I=1,NUMNAM
26012        I2=I
26013        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
26014          IF(IUSE(I2).EQ.'P')THEN
26015            ICASE2='PARA'
26016            ILISTL=I2
26017            GOTO2399
26018          ELSE
26019            WRITE(ICOUT,999)
26020            CALL DPWRST('XXX','BUG ')
26021            WRITE(ICOUT,2001)
26022            CALL DPWRST('XXX','BUG ')
26023            WRITE(ICOUT,2303)IHLEFT,IHLEF2
26024 2303       FORMAT('      THE SECOND NAME ON THE LEFT HAND SIDE (',
26025     1             A4,A4,')')
26026            CALL DPWRST('XXX','BUG ')
26027            WRITE(ICOUT,2005)
26028            CALL DPWRST('XXX','BUG ')
26029            IERROR='YES'
26030            GOTO9000
26031          ENDIF
26032        ENDIF
26033 2300 CONTINUE
26034C
26035      NEWNA2='YES'
26036      IF(ICASE2.EQ.'UNKN')ICASE2='PARA'
26037C
26038      ILIST2=NUMTMP+1
26039      IF(ILIST2.GT.MAXNAM)THEN
26040        WRITE(ICOUT,999)
26041        CALL DPWRST('XXX','BUG ')
26042        WRITE(ICOUT,2001)
26043        CALL DPWRST('XXX','BUG ')
26044        WRITE(ICOUT,2202)
26045        CALL DPWRST('XXX','BUG ')
26046        WRITE(ICOUT,2203)MAXNAM
26047        CALL DPWRST('XXX','BUG ')
26048        WRITE(ICOUT,2204)
26049        CALL DPWRST('XXX','BUG ')
26050        WRITE(ICOUT,2205)
26051        CALL DPWRST('XXX','BUG ')
26052        WRITE(ICOUT,2206)
26053        CALL DPWRST('XXX','BUG ')
26054        IERROR='YES'
26055        GOTO9000
26056      ENDIF
26057C
26058 2399 CONTINUE
26059C
26060C               *****************************************************
26061C               **  STEP 3--                                       **
26062C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
26063C               *****************************************************
26064C
26065      ISTEPN='3A'
26066      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')
26067     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26068C
26069      IINDX=6
26070      IF(ICASEZ.EQ.'STIR')IINDX=7
26071      IHRIGH=IHARG(IINDX)
26072      IHRIG2=IHARG2(IINDX)
26073      DO3000I=1,NUMNAM
26074        I4=I
26075        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
26076          IF(IUSE(I4).NE.'F')THEN
26077            WRITE(ICOUT,999)
26078            CALL DPWRST('XXX','BUG ')
26079            WRITE(ICOUT,2001)
26080            CALL DPWRST('XXX','BUG ')
26081            WRITE(ICOUT,3003)IHRIGH,IHRIG2
26082 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
26083     1             A4,A4,')')
26084            CALL DPWRST('XXX','BUG ')
26085            WRITE(ICOUT,3005)
26086 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
26087            CALL DPWRST('XXX','BUG ')
26088            IERROR='YES'
26089            GOTO9000
26090          ELSE
26091            ISTRT1=IVSTAR(I4)
26092            ISTOP1=IVSTOP(I4)
26093            NLEN1=ISTOP1-ISTRT1+1
26094            GOTO3099
26095          ENDIF
26096        ENDIF
26097 3000 CONTINUE
26098C
26099      WRITE(ICOUT,999)
26100      CALL DPWRST('XXX','BUG ')
26101      WRITE(ICOUT,2001)
26102      CALL DPWRST('XXX','BUG ')
26103      WRITE(ICOUT,3003)IHRIGH,IHRIG2
26104      CALL DPWRST('XXX','BUG ')
26105      WRITE(ICOUT,3015)
26106 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
26107      CALL DPWRST('XXX','BUG ')
26108      IERROR='YES'
26109      GOTO9000
26110C
26111 3099 CONTINUE
26112C
26113C               *****************************************************
26114C               **  STEP 3B-                                       **
26115C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
26116C               *****************************************************
26117C
26118      ISTEPN='3B'
26119      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')
26120     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26121C
26122      IINDX=IINDX+1
26123      IHRI21=IHARG(IINDX)
26124      IHRI22=IHARG2(IINDX)
26125      DO3100I=1,NUMNAM
26126        I4=I
26127        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
26128          IF(IUSE(I4).NE.'F')THEN
26129            WRITE(ICOUT,999)
26130            CALL DPWRST('XXX','BUG ')
26131            WRITE(ICOUT,2001)
26132            CALL DPWRST('XXX','BUG ')
26133            WRITE(ICOUT,3003)IHRI21,IHRI22
26134            CALL DPWRST('XXX','BUG ')
26135            WRITE(ICOUT,3005)
26136            CALL DPWRST('XXX','BUG ')
26137            IERROR='YES'
26138            GOTO9000
26139          ELSE
26140            ISTRT2=IVSTAR(I4)
26141            ISTOP2=IVSTOP(I4)
26142            NLEN2=ISTOP2-ISTRT2+1
26143            GOTO3199
26144          ENDIF
26145        ENDIF
26146 3100 CONTINUE
26147C
26148      WRITE(ICOUT,999)
26149      CALL DPWRST('XXX','BUG ')
26150      WRITE(ICOUT,2001)
26151      CALL DPWRST('XXX','BUG ')
26152      WRITE(ICOUT,3003)IHRI21,IHRI22
26153      CALL DPWRST('XXX','BUG ')
26154      WRITE(ICOUT,3015)
26155      CALL DPWRST('XXX','BUG ')
26156      IERROR='YES'
26157      GOTO9000
26158C
26159 3199 CONTINUE
26160C
26161C               *****************************************************
26162C               **  STEP 4--                                       **
26163C               **  CHECK FOR MATCHING STRINGS                     **
26164C               *****************************************************
26165C
26166      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')THEN
26167        ISTEPN='4'
26168        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26169        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1
26170 4011   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
26171        CALL DPWRST('XXX','BUG ')
26172        WRITE(ICOUT,4012)ISTRT2,ISTOP2,NLEN2
26173 4012   FORMAT('ISTART,ISTOP,NLEN2 = ',3I8)
26174        CALL DPWRST('XXX','BUG ')
26175        WRITE(ICOUT,4013)ICASEL,ICASE2,ICASEZ
26176 4013   FORMAT('ICASEL,ICASE2,ICASEZ = ',2(A4,2X),A4)
26177        CALL DPWRST('XXX','BUG ')
26178      ENDIF
26179C
26180      IF(ICASEZ.EQ.'STIN')THEN
26181        NTEMP=ISTOP1-NLEN2+1
26182        IMATCH=0
26183        IF(ISTRT1.GT.NTEMP)GOTO4199
26184        DO4100I=ISTRT1,NTEMP
26185          NSTRT=I
26186          NSTOP=NSTRT+NLEN2-1
26187          ICNT=0
26188C
26189          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')THEN
26190            WRITE(ICOUT,4801)I,NSTRT,NSTOP
26191 4801       FORMAT('I,NSTRT,NSTOP = ',3I8)
26192            CALL DPWRST('XXX','BUG ')
26193          ENDIF
26194C
26195          DO4110J=NSTRT,NSTOP
26196            IF(IFUNC(J)(1:1).NE.IFUNC(ISTRT2+ICNT)(1:1))GOTO4100
26197            ICNT=ICNT+1
26198 4110     CONTINUE
26199          IMATCH=1
26200          GOTO4199
26201 4100   CONTINUE
26202C
26203 4199   CONTINUE
26204C
26205      ELSEIF(ICASEZ.EQ.'STIR')THEN
26206C
26207C       DO RIGHT TO LEFT MATCHING
26208C
26209        NTEMP=ISTRT1+NLEN2-1
26210        IMATCH=0
26211        IF(ISTRT1.GT.NTEMP)GOTO4299
26212        DO4200I=ISTOP1,NTEMP,-1
26213          NSTOP=I
26214          NSTRT=NSTOP-NLEN2+1
26215          ICNT=0
26216C
26217          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')THEN
26218            WRITE(ICOUT,4801)I,NSTRT,NSTOP
26219            CALL DPWRST('XXX','BUG ')
26220          ENDIF
26221C
26222          DO4210J=NSTRT,NSTOP
26223            IF(IFUNC(J)(1:1).NE.IFUNC(ISTRT2+ICNT)(1:1))GOTO4200
26224            ICNT=ICNT+1
26225 4210     CONTINUE
26226          IMATCH=1
26227          GOTO4299
26228 4200   CONTINUE
26229C
26230 4299   CONTINUE
26231      ENDIF
26232C
26233      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')THEN
26234        ISTEPN='4B'
26235        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26236        WRITE(ICOUT,4901)NSTRT,NSTOP,IMATCH
26237 4901   FORMAT('NSTRT,NSTOP,IMATCH = ',3I8)
26238        CALL DPWRST('XXX','BUG ')
26239      ENDIF
26240C
26241C               *****************************************************
26242C               **  STEP 5--                                       **
26243C               **  SAVE PARAMETERS                                **
26244C               *****************************************************
26245C
26246C
26247      IF(IMATCH.EQ.0)THEN
26248        WRITE(ICOUT,999)
26249        CALL DPWRST('XXX','BUG ')
26250        WRITE(ICOUT,5001)IHRI21,IHRI22,IHRIGH,IHRIG2
26251 5001   FORMAT('STRING  ',A4,A4,'  WAS NOT MATCHED IN STRING ',A4,A4)
26252        CALL DPWRST('XXX','BUG ')
26253        IERROR='YES'
26254        GOTO9000
26255      ELSE
26256        NSTRT=NSTRT-ISTRT1+1
26257        NSTOP=NSTOP-ISTRT1+1
26258      ENDIF
26259C
26260      IF(ICASEL.EQ.'PARA' .AND. ICASE2.EQ.'PARA')THEN
26261C
26262        ISTEPN='5'
26263        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIN')
26264     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26265C
26266        IHNAME(ILISTL)=IHLEFT
26267        IHNAM2(ILISTL)=IHLEF2
26268        IUSE(ILISTL)='P'
26269        VALUE(ILISTL)=REAL(NSTRT)
26270        IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
26271        IN(ILISTL)=1
26272        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
26273C
26274        IHNAME(ILIST2)=IHLE21
26275        IHNAM2(ILIST2)=IHLE22
26276        IUSE(ILIST2)='P'
26277        VALUE(ILIST2)=REAL(NSTOP)
26278        IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
26279        IN(ILISTL)=1
26280        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
26281C
26282        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
26283          WRITE(ICOUT,999)
26284          CALL DPWRST('XXX','BUG ')
26285          WRITE(ICOUT,5011)IHLEFT,IHLEF2,NSTRT
262865011      FORMAT(A4,A4,' (START OF SUBSTRING) = ',I8)
26287          CALL DPWRST('XXX','BUG ')
26288          WRITE(ICOUT,5013)IHLE21,IHLE22,NSTOP
262895013      FORMAT(A4,A4,' (END OF SUBSTRING)   = ',I8)
26290          CALL DPWRST('XXX','BUG ')
26291          WRITE(ICOUT,999)
26292          CALL DPWRST('XXX','BUG ')
26293        ENDIF
26294      ENDIF
26295C
26296C
26297C               ****************
26298C               **  STEP 90-- **
26299C               **  EXIT.     **
26300C               ****************
26301C
26302 9000 CONTINUE
26303      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STIN')THEN
26304        WRITE(ICOUT,999)
26305        CALL DPWRST('XXX','BUG ')
26306        WRITE(ICOUT,9011)
26307 9011   FORMAT('***** AT THE END       OF DPSTIN--')
26308        CALL DPWRST('XXX','BUG ')
26309        WRITE(ICOUT,9013)NUMNAM
26310 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
26311        CALL DPWRST('XXX','BUG ')
26312        DO9015I=1,NUMNAM
26313          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
26314     1                     IVSTAR(I),IVSTOP(I)
26315 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
26316     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
26317          CALL DPWRST('XXX','BUG ')
26318 9015   CONTINUE
26319      ENDIF
26320C
26321      RETURN
26322      END
26323      SUBROUTINE DPSTIP(ISUBRO,IBUGA3,IERROR)
26324C
26325C     PURPOSE--IMPLEMENT THE COMMAND
26326C
26327C              LET SNEW = STRING INTERACTION S1 ... SK
26328C
26329C              WHERE
26330C                  S1 ... SK     = A LIST OF PRE-EXISTING PARAMETERS
26331C
26332C              FOR EXAMPLE,
26333C
26334C                  LET SNEW = STRING INTERACTION 1 3 5 -9999 -9999
26335C
26336C              WILL GENERATE THE STRING
26337C
26338C                   X1 * X3 * X5
26339C
26340C              THE STRING GENERATION WILL TERMINATE WHEN THE FIRST
26341C              "-9999" VALUE IS ENCOUNTERED IN THE S1 ... SK LIST.
26342C
26343C              THIS COMMAND IS USED IN THE 10-STEP MACROS.
26344C
26345C     WRITTEN BY--ALAN HECKERT
26346C                 STATISTICAL ENGINEERING DIVISION
26347C                 INFORMATION TECHNOLOGY LABORATORY
26348C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
26349C                 GAITHERSBURG, MD 20899-8980
26350C                 PHONE--301-975-2899
26351C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
26352C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
26353C     LANGUAGE--ANSI FORTRAN (1977)
26354C     VERSION NUMBER--2018/03
26355C     ORIGINAL VERSION--MARCH     2018.
26356C
26357C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
26358C
26359      CHARACTER*4 ISUBRO
26360      CHARACTER*4 IBUGA3
26361      CHARACTER*4 IERROR
26362C
26363      CHARACTER*4 IWRITE
26364      CHARACTER*4 NEWNAM
26365      CHARACTER*4 NEWCOL
26366      CHARACTER*4 ICASEL
26367      CHARACTER*4 IHLEFT
26368      CHARACTER*4 IHLEF2
26369      CHARACTER*4 ISUBN1
26370      CHARACTER*4 ISUBN2
26371      CHARACTER*4 ISTEPN
26372      CHARACTER*255 ISTR1
26373      CHARACTER*4 ILAB(10)
26374C
26375      PARAMETER(MAXIND=50)
26376      REAL PVAR(MAXIND)
26377      CHARACTER*4 IVARN1(MAXIND)
26378      CHARACTER*4 IVARN2(MAXIND)
26379      CHARACTER*4 IVARTY(MAXIND)
26380C
26381C---------------------------------------------------------------------
26382C
26383C-----COMMON----------------------------------------------------------
26384C
26385      INCLUDE 'DPCOPA.INC'
26386      INCLUDE 'DPCOHK.INC'
26387      INCLUDE 'DPCODA.INC'
26388      INCLUDE 'DPCOP2.INC'
26389C
26390C-----START POINT-----------------------------------------------------
26391C
26392      ISUBN1='DPST'
26393      ISUBN2='IP  '
26394      IERROR='NO'
26395C
26396      NCSTR=0
26397C
26398      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STIP')THEN
26399        WRITE(ICOUT,999)
26400        CALL DPWRST('XXX','BUG ')
26401        WRITE(ICOUT,51)
26402   51   FORMAT('***** AT THE BEGINNING OF DPSTIP--')
26403        CALL DPWRST('XXX','BUG ')
26404        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF
26405   52   FORMAT('IBUGA3,ISUBRO,NUMNAM,NUMCHF,MAXCHF = ',2(A4,2X),3I8)
26406        CALL DPWRST('XXX','BUG ')
26407        DO55I=1,NUMNAM
26408          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
26409     1                   IVSTOP(I)
26410   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
26411     1           'IVSTOP(I)=',I8,2X,2A4,2X,A4,I8,I8)
26412          CALL DPWRST('XXX','BUG ')
26413   55   CONTINUE
26414        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
26415   60   FORMAT('IFUNC(.)  = ',120A1)
26416        CALL DPWRST('XXX','BUG ')
26417      ENDIF
26418C
26419C               **********************************
26420C               **  STEP 1--                    **
26421C               **  INITIALIZE SOME VARIABLES.  **
26422C               **********************************
26423C
26424      ISTEPN='1'
26425      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIP')
26426     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26427C
26428      NEWNAM='NO'
26429      NEWCOL='NO'
26430      ICASEL='UNKN'
26431      NIOLD1=0
26432      ICOLL=0
26433C
26434C               ******************************************************
26435C               **  STEP 2--                                         *
26436C               **  EXAMINE THE ARGUMENT ON THE                      *
26437C               **  LEFT-HAND SIDE--                                 *
26438C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
26439C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
26440C               ******************************************************
26441C
26442      ISTEPN='2'
26443      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIP')
26444     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26445C
26446      IHLEFT=IHARG(1)
26447      IHLEF2=IHARG2(1)
26448C
26449      DO2000I=1,NUMNAM
26450        I2=I
26451        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
26452          IF(IUSE(I2).EQ.'F')THEN
26453            ICASEL='STRI'
26454            ILISTL=I2
26455            GOTO2299
26456          ELSE
26457            WRITE(ICOUT,999)
26458  999       FORMAT(1X)
26459            CALL DPWRST('XXX','BUG ')
26460            WRITE(ICOUT,2001)
26461 2001       FORMAT('***** ERROR IN STRING INTERACTION--')
26462            CALL DPWRST('XXX','BUG ')
26463            WRITE(ICOUT,2003)IHLEFT,IHLEF2
26464 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
26465     1             A4,A4,')')
26466            CALL DPWRST('XXX','BUG ')
26467            WRITE(ICOUT,2005)
26468 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
26469            CALL DPWRST('XXX','BUG ')
26470            IERROR='YES'
26471            GOTO9000
26472          ENDIF
26473        ENDIF
26474 2000 CONTINUE
26475C
26476      NEWNAM='YES'
26477      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
26478C
26479      ILISTL=NUMNAM+1
26480      IF(ILISTL.GT.MAXNAM)THEN
26481        WRITE(ICOUT,999)
26482        CALL DPWRST('XXX','BUG ')
26483        WRITE(ICOUT,2001)
26484        CALL DPWRST('XXX','BUG ')
26485        WRITE(ICOUT,2202)
26486 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
26487     1         'FUNCTION')
26488        CALL DPWRST('XXX','BUG ')
26489        WRITE(ICOUT,2203)MAXNAM
26490 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
26491        CALL DPWRST('XXX','BUG ')
26492        WRITE(ICOUT,2204)
26493 2204   FORMAT('      ENTER      STATUS')
26494        CALL DPWRST('XXX','BUG ')
26495        WRITE(ICOUT,2205)
26496 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
26497        CALL DPWRST('XXX','BUG ')
26498        WRITE(ICOUT,2206)
26499 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
26500     1         'USED NAMES.')
26501        CALL DPWRST('XXX','BUG ')
26502        IERROR='YES'
26503        GOTO9000
26504      ENDIF
26505C
26506 2299 CONTINUE
26507C
26508C               *****************************************************
26509C               **  STEP 3--                                       **
26510C               **  LOOP THROUGH THE NAMES ON THE RIGHT HAND SIDE  **
26511C               *****************************************************
26512C
26513      ISTEPN='3'
26514      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIP')
26515     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26516C
26517      IF(NUMARG.LT.5)THEN
26518        WRITE(ICOUT,999)
26519        CALL DPWRST('XXX','BUG ')
26520        WRITE(ICOUT,2001)
26521        CALL DPWRST('XXX','BUG ')
26522        WRITE(ICOUT,3003)
26523 3003   FORMAT('      THERE MUST BE AT LEAST ONE STRINGS SPECIFIED ',
26524     1         'TO THE RIGHT HAND SIDE OF THE EQUAL SIGN')
26525        CALL DPWRST('XXX','BUG ')
26526        NTEMP=NUMARG-4
26527        WRITE(ICOUT,3005)NTEMP
26528 3005   FORMAT('      THE NUMBER OF STRINGS SPECIFIED IS ',I8)
26529        CALL DPWRST('XXX','BUG ')
26530        IERROR='YES'
26531        GOTO9000
26532      ENDIF
26533C
26534C               *********************************************************
26535C               **  STEP 3A--                                           *
26536C               **  NOW SEARCH THROUGH THE ARGUMENTS                    *
26537C               *********************************************************
26538C
26539      ISTEPN='3A'
26540      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIP')
26541     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26542C
26543      JMIN=5
26544      JMAX=NUMARG
26545C
26546      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STIP')THEN
26547        WRITE(ICOUT,3301)JMIN,JMAX,MAXIND
26548 3301   FORMAT('JMIN,JMAX,MAXIND = ',3I8)
26549        CALL DPWRST('XXX','BUG ')
26550      ENDIF
26551C
26552      IWRITE='OFF'
26553      IERROR='NO'
26554C
26555      IFLAGM=0
26556      IFLAGP=1
26557      IFLAGT=0
26558      CALL EXTVA2(IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,MAXIND,
26559     1            IHNAME,IHNAM2,IUSE,NUMNAM,
26560     1            IVARN1,IVARN2,IVARTY,PVAR,NUMIND,
26561     1            IFLAGM,IFLAGP,IFLAGT,
26562     1            IBUGA3,ISUBRO,IERROR)
26563C
26564      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STIP')THEN
26565        WRITE(ICOUT,3303)NUMIND,IERROR
26566 3303   FORMAT('NUMIND,IERROR = ',I8,2X,A4)
26567        CALL DPWRST('XXX','BUG ')
26568        IF(NUMIND.GE.1)THEN
26569          DO3305JJ=1,NUMIND
26570            WRITE(ICOUT,3304)JJ,IVARN1(JJ),IVARN2(JJ),IVARTY(JJ),
26571     1                       PVAR(JJ)
26572 3304       FORMAT('JJ,IVARN1(JJ),IVARN2(JJ),IVARTY(JJ),PVAR(JJ) = ',
26573     1             I8,2X,2A4,2X,A4,2X,G15.7)
26574            CALL DPWRST('XXX','BUG ')
26575 3305     CONTINUE
26576        ENDIF
26577      ENDIF
26578C
26579      IF(IERROR.EQ.'YES')GOTO9000
26580C
26581C     NOW LOOP THROUGH AND CREATE THE OUTPUT STRING
26582C
26583      DO3310I2=1,NUMIND
26584        IF(IVARTY(I2).NE.'PARA')THEN
26585          WRITE(ICOUT,999)
26586          CALL DPWRST('XXX','BUG ')
26587          WRITE(ICOUT,2001)
26588          CALL DPWRST('XXX','BUG ')
26589          WRITE(ICOUT,3312)I2,IVARN1(I2),IVARN2(I2)
26590 3312     FORMAT('      ARGUMENT ',I5,' (',2A4,') IS NOT A PARAMETER.')
26591          CALL DPWRST('XXX','BUG ')
26592          WRITE(ICOUT,999)
26593          CALL DPWRST('XXX','BUG ')
26594          IERROR='YES'
26595          GOTO9000
26596        ENDIF
26597C
26598        DO3320I=1,NUMNAM
26599          IF(IVARN1(I2).EQ.IHNAME(I).AND.IVARN2(I2).EQ.IHNAM2(I))THEN
26600            AVAL=VALUE(I)
26601            GOTO3329
26602          ENDIF
26603 3320   CONTINUE
26604 3329   CONTINUE
26605C
26606        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STIP')THEN
26607          WRITE(ICOUT,3333)I2,I,AVAL
26608 3333     FORMAT('I2,I,AVAL = ',2I8,G15.7)
26609          CALL DPWRST('XXX','BUG ')
26610        ENDIF
26611C
26612        IF(AVAL.GE.0.0)THEN
26613          IVAL=INT(AVAL+0.1)
26614          IF(IVAL.GT.999)GOTO3390
26615          IF(I2.GT.1)THEN
26616            NCSTR=NCSTR+1
26617            ISTR1(NCSTR:NCSTR+2)=' * '
26618            NCSTR=NCSTR+2
26619          ENDIF
26620          NCSTR=NCSTR+1
26621          ISTR1(NCSTR:NCSTR)='X'
26622          IF(IVAL.LE.9)THEN
26623            NCSTR=NCSTR+1
26624            WRITE(ISTR1(NCSTR:NCSTR),'(I1)')IVAL
26625          ELSEIF(IVAL.LE.99)THEN
26626            NCSTR=NCSTR+1
26627            WRITE(ISTR1(NCSTR:NCSTR+1),'(I2)')IVAL
26628            NCSTR=NCSTR+1
26629          ELSEIF(IVAL.LE.999)THEN
26630            NCSTR=NCSTR+1
26631            WRITE(ISTR1(NCSTR:NCSTR+2),'(I3)')IVAL
26632            NCSTR=NCSTR+2
26633          ENDIF
26634        ELSE
26635          IF(I2.EQ.1)THEN
26636            ISTR1='X1'
26637            NCSTR=2
26638          ENDIF
26639          GOTO3390
26640        ENDIF
26641 3310 CONTINUE
26642 3390 CONTINUE
26643C
26644      ISTEPN='3B'
26645      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIP')
26646     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26647C
26648      DO3410JJ=1,NCSTR
26649        IFUNC2(JJ)='   '
26650        IFUNC2(JJ)(1:1)=ISTR1(JJ:JJ)
26651 3410 CONTINUE
26652C
26653      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIP')THEN
26654        ISTEPN='3C'
26655        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26656        WRITE(ICOUT,3450)NCSTR
26657 3450   FORMAT('NLEN2 = ',I5)
26658        CALL DPWRST('XXX','BUG ')
26659        DO3455JJ=1,NCSTR
26660          WRITE(ICOUT,3457)JJ,IFUNC2(JJ)
26661 3457     FORMAT('JJ,IFUNC2(JJ) = ',I5,2X,A4)
26662          CALL DPWRST('XXX','BUG ')
26663 3455   CONTINUE
26664      ENDIF
26665C
26666C               *****************************************************
26667C               **  STEP 4--                                       **
26668C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
26669C               *****************************************************
26670C
26671C
26672      ISTEPN='4'
26673      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STIP')
26674     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26675C
26676      CALL DPINFU(IFUNC2,NCSTR,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
26677     1            NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
26678     1            NEWNAM,MAXNAM,
26679     1            IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
26680      IF(IERROR.EQ.'YES')GOTO9000
26681C
26682      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
26683        WRITE(ICOUT,999)
26684        CALL DPWRST('XXX','BUG ')
26685        WRITE(ICOUT,6606)IHLEFT,IHLEF2
26686 6606   FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
26687        CALL DPWRST('XXX','BUG ')
26688        ILAB(1)='TO T'
26689        ILAB(2)='HE F'
26690        ILAB(3)='UNCT'
26691        ILAB(4)='ION '
26692        ILAB(5)='    '
26693        ILAB(6)=' -- '
26694        NUMWDL=6
26695        CALL DPPRIF(ILAB,NUMWDL,IFUNC2,NCSTR,IBUGA3)
26696        WRITE(ICOUT,999)
26697        CALL DPWRST('XXX','BUG ')
26698      ENDIF
26699C
26700C
26701C               ****************
26702C               **  STEP 90-- **
26703C               **  EXIT.     **
26704C               ****************
26705C
26706 9000 CONTINUE
26707      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STIP')THEN
26708        WRITE(ICOUT,999)
26709        CALL DPWRST('XXX','BUG ')
26710        WRITE(ICOUT,9011)
26711 9011   FORMAT('***** AT THE END       OF DPSTIP--')
26712        CALL DPWRST('XXX','BUG ')
26713      ENDIF
26714C
26715      RETURN
26716      END
26717      SUBROUTINE DPSTJU(ICASE,ISUBRO,IBUGA3,IERROR)
26718C
26719C     PURPOSE--LEFT/CENTER/RIGHT JUSTIFY A STRING.  THAT IS,
26720C              BASED ON THE REQUESTED LENGTH OF THE STRING, ADD
26721C              LEADING OR TRAILING SPACES.
26722C     EXAMPLE--LET SOUT = STRING <LEFT/CENTER/RIGHT> JUSTIFY SIN NLEN
26723C     WRITTEN BY--ALAN HECKERT
26724C                 STATISTICAL ENGINEERING DIVISION
26725C                 INFORMATION TECHNOLOGY LABORATORY
26726C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
26727C                 GAITHERSBURG, MD 20899-8980
26728C                 PHONE--301-975-2899
26729C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
26730C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
26731C     LANGUAGE--ANSI FORTRAN (1977)
26732C     VERSION NUMBER--2019/01
26733C     ORIGINAL VERSION--JANUARY   2019.
26734C
26735C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
26736C
26737      CHARACTER*4 ICASE
26738      CHARACTER*4 ISUBRO
26739      CHARACTER*4 IBUGA3
26740      CHARACTER*4 IERROR
26741C
26742      CHARACTER*4 NEWNAM
26743      CHARACTER*4 NEWNA2
26744      CHARACTER*4 NEWCOL
26745      CHARACTER*4 NEWCO2
26746      CHARACTER*4 ICASEL
26747      CHARACTER*4 IHLEFT
26748      CHARACTER*4 IHLEF2
26749      CHARACTER*4 IHRIGH
26750      CHARACTER*4 IHRIG2
26751      CHARACTER*4 IHRI21
26752      CHARACTER*4 IHRI22
26753      CHARACTER*4 ISUBN1
26754      CHARACTER*4 ISUBN2
26755      CHARACTER*4 ISTEPN
26756      CHARACTER*1 IVALC
26757C
26758      CHARACTER*4 ILAB(10)
26759C
26760C---------------------------------------------------------------------
26761C
26762C-----COMMON----------------------------------------------------------
26763C
26764      INCLUDE 'DPCOPA.INC'
26765      INCLUDE 'DPCOHK.INC'
26766      INCLUDE 'DPCODA.INC'
26767      INCLUDE 'DPCOST.INC'
26768      INCLUDE 'DPCOP2.INC'
26769C
26770C-----START POINT-----------------------------------------------------
26771C
26772      ISUBN1='DPST'
26773      ISUBN2='JU  '
26774      IERROR='NO'
26775      IVALC=' '
26776      IF(ISJUCH.NE.'SPAC')IVALC=ISJUCH(1:1)
26777C
26778      ILOC3=0
26779C
26780      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STJU')THEN
26781        WRITE(ICOUT,999)
26782        CALL DPWRST('XXX','BUG ')
26783        WRITE(ICOUT,51)
26784   51   FORMAT('***** AT THE BEGINNING OF DPSTJU--')
26785        CALL DPWRST('XXX','BUG ')
26786        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
26787   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
26788        CALL DPWRST('XXX','BUG ')
26789        DO55I=1,NUMNAM
26790          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
26791     1                   IVSTOP(I)
26792   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
26793     1           'IVSTOP(I)=',I8,2X,2A4,2X,A4,2I8)
26794          CALL DPWRST('XXX','BUG ')
26795   55   CONTINUE
26796        WRITE(ICOUT,57)NUMCHF,MAXCHF,NUMARG
26797   57   FORMAT('NUMCHF,MAXCHF,NUMARG = ',3I8)
26798        CALL DPWRST('XXX','BUG ')
26799        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
26800   60   FORMAT('IFUNC(.)  = ',120A1)
26801        CALL DPWRST('XXX','BUG ')
26802        IF(NUMARG.GE.1)THEN
26803          DO70I=1,NUMARG
26804            WRITE(ICOUT,76)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
26805   76       FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
26806     1             I8,2X,2A4,2X,A4,2X,I8)
26807            CALL DPWRST('XXX','BUG ')
26808   70     CONTINUE
26809        ENDIF
26810      ENDIF
26811C
26812C               **********************************
26813C               **  STEP 1--                    **
26814C               **  INITIALIZE SOME VARIABLES.  **
26815C               **********************************
26816C
26817      ISTEPN='1'
26818      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STJU')
26819     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26820C
26821      NEWNAM='NO'
26822      NEWNA2='NO'
26823      NEWCOL='NO'
26824      NEWCO2='NO'
26825      ICASEL='UNKN'
26826      NIOLD1=0
26827      NIOLD2=0
26828      ICOLL=0
26829      ICOL2=0
26830C
26831C               ******************************************************
26832C               **  STEP 2--                                         *
26833C               **  EXAMINE THE ARGUMENT ON THE                      *
26834C               **  LEFT-HAND SIDE--                                 *
26835C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
26836C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
26837C               ******************************************************
26838C
26839      ISTEPN='2'
26840      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STJU')
26841     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26842C
26843      IHLEFT=IHARG(1)
26844      IHLEF2=IHARG2(1)
26845C
26846      DO2000I=1,NUMNAM
26847        I2=I
26848        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
26849          IF(IUSE(I2).EQ.'F')THEN
26850            ICASEL='STRI'
26851            ILISTL=I2
26852            GOTO2299
26853          ELSE
26854            WRITE(ICOUT,999)
26855  999       FORMAT(1X)
26856            CALL DPWRST('XXX','BUG ')
26857            WRITE(ICOUT,2001)
26858 2001       FORMAT('***** ERROR IN STRING JUSTIFY--')
26859            CALL DPWRST('XXX','BUG ')
26860            WRITE(ICOUT,2003)IHLEFT,IHLEF2
26861 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
26862     1             A4,A4,')')
26863            CALL DPWRST('XXX','BUG ')
26864            WRITE(ICOUT,2005)
26865 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
26866            CALL DPWRST('XXX','BUG ')
26867            IERROR='YES'
26868            GOTO9000
26869          ENDIF
26870        ENDIF
26871 2000 CONTINUE
26872C
26873      NEWNAM='YES'
26874      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
26875C
26876      ILISTL=NUMNAM+1
26877      IF(ILISTL.GT.MAXNAM)THEN
26878        WRITE(ICOUT,999)
26879        CALL DPWRST('XXX','BUG ')
26880        WRITE(ICOUT,2001)
26881        CALL DPWRST('XXX','BUG ')
26882        WRITE(ICOUT,2202)
26883 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
26884     1         'FUNCTION')
26885        CALL DPWRST('XXX','BUG ')
26886        WRITE(ICOUT,2203)MAXNAM
26887 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
26888        CALL DPWRST('XXX','BUG ')
26889        WRITE(ICOUT,2204)
26890 2204   FORMAT('      ENTER      STATUS')
26891        CALL DPWRST('XXX','BUG ')
26892        WRITE(ICOUT,2205)
26893 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
26894        CALL DPWRST('XXX','BUG ')
26895        WRITE(ICOUT,2206)
26896 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
26897     1         'USED NAMES.')
26898        CALL DPWRST('XXX','BUG ')
26899        IERROR='YES'
26900        GOTO9000
26901      ENDIF
26902C
26903 2299 CONTINUE
26904C
26905C               *****************************************************
26906C               **  STEP 3--                                       **
26907C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
26908C               *****************************************************
26909C
26910      ISTEPN='3A'
26911      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STJU')
26912     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26913C
26914      IHRIGH=IHARG(6)
26915      IHRIG2=IHARG2(6)
26916      DO3000I=1,NUMNAM
26917        I4=I
26918        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
26919          IF(IUSE(I4).NE.'F')THEN
26920            WRITE(ICOUT,999)
26921            CALL DPWRST('XXX','BUG ')
26922            WRITE(ICOUT,2001)
26923            CALL DPWRST('XXX','BUG ')
26924            WRITE(ICOUT,3003)IHRIGH,IHRIG2
26925 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
26926     1             A4,A4,')')
26927            CALL DPWRST('XXX','BUG ')
26928            WRITE(ICOUT,3005)
26929 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
26930            CALL DPWRST('XXX','BUG ')
26931            IERROR='YES'
26932            GOTO9000
26933          ELSE
26934            ISTRT1=IVSTAR(I4)
26935            ISTOP1=IVSTOP(I4)
26936            NLEN1=ISTOP1-ISTRT1+1
26937            GOTO3099
26938          ENDIF
26939        ENDIF
26940 3000 CONTINUE
26941C
26942      WRITE(ICOUT,999)
26943      CALL DPWRST('XXX','BUG ')
26944      WRITE(ICOUT,2001)
26945      CALL DPWRST('XXX','BUG ')
26946      WRITE(ICOUT,3003)IHRIGH,IHRIG2
26947      CALL DPWRST('XXX','BUG ')
26948      WRITE(ICOUT,3015)
26949 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
26950      CALL DPWRST('XXX','BUG ')
26951      IERROR='YES'
26952      GOTO9000
26953C
26954 3099 CONTINUE
26955C
26956C               *****************************************************
26957C               **  STEP 3B-                                       **
26958C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
26959C               *****************************************************
26960C
26961      ISTEPN='3B'
26962      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STJU')
26963     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26964C
26965      IHRI21=IHARG(7)
26966      IHRI22=IHARG2(7)
26967      DO3100I=1,NUMNAM
26968        I4=I
26969        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
26970          IF(IUSE(I4).NE.'P')THEN
26971            WRITE(ICOUT,999)
26972            CALL DPWRST('XXX','BUG ')
26973            WRITE(ICOUT,2001)
26974            CALL DPWRST('XXX','BUG ')
26975            WRITE(ICOUT,3003)IHRI21,IHRI22
26976            CALL DPWRST('XXX','BUG ')
26977            WRITE(ICOUT,3115)
26978 3115       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
26979            CALL DPWRST('XXX','BUG ')
26980            IERROR='YES'
26981            GOTO9000
26982          ELSE
26983            ILISR1=I4
26984            NLEN2=IVALUE(ILISR1)
26985            GOTO3199
26986          ENDIF
26987        ENDIF
26988 3100 CONTINUE
26989C
26990      IF(NUMARG.GE.7)THEN
26991        IF(IARGT(7).EQ.'NUMB')THEN
26992          NLEN2=IARG(7)
26993          GOTO3199
26994        ENDIF
26995      ENDIF
26996C
26997      WRITE(ICOUT,999)
26998      CALL DPWRST('XXX','BUG ')
26999      WRITE(ICOUT,2001)
27000      CALL DPWRST('XXX','BUG ')
27001      WRITE(ICOUT,3003)IHRI21,IHRI22
27002      CALL DPWRST('XXX','BUG ')
27003      WRITE(ICOUT,3015)
27004      CALL DPWRST('XXX','BUG ')
27005      IERROR='YES'
27006      GOTO9000
27007C
27008 3199 CONTINUE
27009C
27010C               *****************************************************
27011C               **  STEP 4--                                       **
27012C               **  CREATE THE JUSTIFIED STRING                    **
27013C               *****************************************************
27014C
27015      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STJU')THEN
27016        ISTEPN='4'
27017        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27018        WRITE(ICOUT,4011)ILISR1,ILISR2,NLEN
27019 4011   FORMAT('ILISR1,ILISR2,NLEN = ',3I8)
27020        CALL DPWRST('XXX','BUG ')
27021        WRITE(ICOUT,4012)ISTRT1,ISTOP1,NLEN1,NLEN2
27022 4012   FORMAT('ISTRT1,ISTOP1,NLEN1,NLEN2 = ',4I8)
27023        CALL DPWRST('XXX','BUG ')
27024        WRITE(ICOUT,4013)ICASE
27025 4013   FORMAT('ICASE = ',A4)
27026        CALL DPWRST('XXX','BUG ')
27027      ENDIF
27028C
27029      IF(NLEN1.GE.NLEN2)THEN
27030        ICNT=0
27031        DO4100I=ISTRT1,ISTOP1
27032          ICNT=ICNT+1
27033          IINDX=I+ISTRT1-1
27034          IFUNC2(ICNT)=IFUNC(IINDX)
27035 4100   CONTINUE
27036      ELSEIF(ICASE.EQ.'RIGH')THEN
27037        ISPACE=NLEN2-NLEN1
27038        ICNT=0
27039        DO4110I=1,ISPACE
27040          ICNT=ICNT+1
27041          IFUNC2(ICNT)=IVALC
27042 4110   CONTINUE
27043        DO4112I=ISTRT1,ISTOP1
27044          ICNT=ICNT+1
27045          IFUNC2(ICNT)=IFUNC(I)
27046 4112   CONTINUE
27047      ELSEIF(ICASE.EQ.'LEFT')THEN
27048        ISPACE=NLEN2-NLEN1
27049        ICNT=0
27050        DO4120I=ISTRT1,ISTOP1
27051          ICNT=ICNT+1
27052          IFUNC2(ICNT)=IFUNC(I)
27053 4120   CONTINUE
27054        DO4122I=1,ISPACE
27055          ICNT=ICNT+1
27056          IFUNC2(ICNT)=IVALC
27057 4122   CONTINUE
27058      ELSEIF(ICASE.EQ.'CENT')THEN
27059        ISPACE=NLEN2-NLEN1
27060        IVAL=MOD(ISPACE,2)
27061        IF(IVAL.EQ.0)THEN
27062          ISPACL=ISPACE/2
27063          ISPACR=ISPACL
27064        ELSE
27065          ISPACL=(ISPACE/2) + 1
27066          ISPACR=ISPACE/2
27067        ENDIF
27068        ICNT=0
27069        DO4130I=1,ISPACL
27070          ICNT=ICNT+1
27071          IFUNC2(ICNT)=IVALC
27072 4130   CONTINUE
27073        DO4132I=ISTRT1,ISTOP1
27074          ICNT=ICNT+1
27075          IFUNC2(ICNT)=IFUNC(I)
27076 4132   CONTINUE
27077        DO4134I=1,ISPACR
27078          ICNT=ICNT+1
27079          IFUNC2(ICNT)=IVALC
27080 4134   CONTINUE
27081      ENDIF
27082C
27083C               *****************************************************
27084C               **  STEP 5--                                       **
27085C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
27086C               *****************************************************
27087C
27088C
27089      ISTEPN='5'
27090      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STJU')
27091     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27092C
27093      CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
27094     1            NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
27095     1            NEWNAM,MAXNAM,
27096     1            IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
27097      IF(IERROR.EQ.'YES')GOTO9000
27098C
27099      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
27100        WRITE(ICOUT,999)
27101        CALL DPWRST('XXX','BUG ')
27102        WRITE(ICOUT,6606)IHLEFT,IHLEF2
27103 6606   FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
27104        CALL DPWRST('XXX','BUG ')
27105        ILAB(1)='TO T'
27106        ILAB(2)='HE F'
27107        ILAB(3)='UNCT'
27108        ILAB(4)='ION '
27109        ILAB(5)='    '
27110        ILAB(6)=' -- '
27111        NUMWDL=6
27112        CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
27113C
27114        WRITE(ICOUT,999)
27115        CALL DPWRST('XXX','BUG ')
27116C
27117      ENDIF
27118C
27119C
27120C               ****************
27121C               **  STEP 90-- **
27122C               **  EXIT.     **
27123C               ****************
27124C
27125 9000 CONTINUE
27126      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STJU')THEN
27127        WRITE(ICOUT,999)
27128        CALL DPWRST('XXX','BUG ')
27129        WRITE(ICOUT,9011)
27130 9011   FORMAT('***** AT THE END       OF DPSTJU--')
27131        CALL DPWRST('XXX','BUG ')
27132        WRITE(ICOUT,9013)NUMNAM
27133 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
27134        CALL DPWRST('XXX','BUG ')
27135        DO9015I=1,NUMNAM
27136          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
27137     1                     IVSTAR(I),IVSTOP(I)
27138 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
27139     1           'IVSTOP(I)=',I8,2X,2A4,2X,A4,2I8)
27140          CALL DPWRST('XXX','BUG ')
27141 9015   CONTINUE
27142      ENDIF
27143C
27144      RETURN
27145      END
27146      SUBROUTINE DPSTLC(ISUBRO,IBUGA3,IERROR)
27147C
27148C     PURPOSE--CONVERT A STRING TO LOWER CASE
27149C     EXAMPLE--LET SOUT = LOWER CASE SOLD
27150C     WRITTEN BY--ALAN HECKERT
27151C                 STATISTICAL ENGINEERING DIVISION
27152C                 INFORMATION TECHNOLOGY LABORATORY
27153C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
27154C                 GAITHERSBURG, MD 20899-8980
27155C                 PHONE--301-975-2899
27156C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27157C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
27158C     LANGUAGE--ANSI FORTRAN (1977)
27159C     VERSION NUMBER--2008/11
27160C     ORIGINAL VERSION--NOVEMBER  2008.
27161C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
27162C
27163C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27164C
27165      CHARACTER*4 ISUBRO
27166      CHARACTER*4 IBUGA3
27167      CHARACTER*4 IERROR
27168C
27169      CHARACTER*4 NEWNAM
27170      CHARACTER*4 NEWCOL
27171      CHARACTER*4 ICASEL
27172      CHARACTER*4 IHLEFT
27173      CHARACTER*4 IHLEF2
27174      CHARACTER*4 IHRIGH
27175      CHARACTER*4 IHRIG2
27176C
27177      CHARACTER*1 IC
27178C
27179      CHARACTER*4 ISUBN1
27180      CHARACTER*4 ISUBN2
27181      CHARACTER*4 ISTEPN
27182C
27183      CHARACTER*4 ILAB(10)
27184C
27185C---------------------------------------------------------------------
27186C
27187C-----COMMON----------------------------------------------------------
27188C
27189      INCLUDE 'DPCOPA.INC'
27190      INCLUDE 'DPCOHK.INC'
27191      INCLUDE 'DPCODA.INC'
27192      INCLUDE 'DPCOP2.INC'
27193C
27194C-----START POINT-----------------------------------------------------
27195C
27196      ISUBN1='DPST'
27197      ISUBN2='LC  '
27198      IERROR='NO'
27199C
27200      ILOC3=0
27201C
27202      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STLC')THEN
27203        WRITE(ICOUT,999)
27204        CALL DPWRST('XXX','BUG ')
27205        WRITE(ICOUT,51)
27206   51   FORMAT('***** AT THE BEGINNING OF DPSTLC--')
27207        CALL DPWRST('XXX','BUG ')
27208        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
27209   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
27210        CALL DPWRST('XXX','BUG ')
27211        DO55I=1,NUMNAM
27212          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
27213     1                   IVSTOP(I)
27214   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
27215     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
27216          CALL DPWRST('XXX','BUG ')
27217   55   CONTINUE
27218        WRITE(ICOUT,57)NUMCHF,MAXCHF
27219   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
27220        CALL DPWRST('XXX','BUG ')
27221        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
27222   60   FORMAT('IFUNC(.)  = ',120A1)
27223        CALL DPWRST('XXX','BUG ')
27224      ENDIF
27225C
27226C               **********************************
27227C               **  STEP 1--                    **
27228C               **  INITIALIZE SOME VARIABLES.  **
27229C               **********************************
27230C
27231      ISTEPN='1'
27232      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLC')
27233     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27234C
27235      NEWNAM='NO'
27236      NEWCOL='NO'
27237      ICASEL='UNKN'
27238      ICOLL=0
27239C
27240C               ******************************************************
27241C               **  STEP 2--                                         *
27242C               **  EXAMINE THE ARGUMENT ON THE                      *
27243C               **  LEFT-HAND SIDE--                                 *
27244C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
27245C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
27246C               ******************************************************
27247C
27248      ISTEPN='2'
27249      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLC')
27250     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27251C
27252      IHLEFT=IHARG(1)
27253      IHLEF2=IHARG2(1)
27254C
27255      DO2000I=1,NUMNAM
27256        I2=I
27257        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
27258          IF(IUSE(I2).EQ.'F')THEN
27259            ICASEL='STRI'
27260            ILISTL=I2
27261            GOTO2299
27262          ELSE
27263            WRITE(ICOUT,999)
27264  999       FORMAT(1X)
27265            CALL DPWRST('XXX','BUG ')
27266            WRITE(ICOUT,2001)
27267 2001       FORMAT('***** ERROR IN LOWER CASE--')
27268            CALL DPWRST('XXX','BUG ')
27269            WRITE(ICOUT,2003)IHLEFT,IHLEF2
27270 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
27271     1             A4,A4,')')
27272            CALL DPWRST('XXX','BUG ')
27273            WRITE(ICOUT,2005)
27274 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
27275            CALL DPWRST('XXX','BUG ')
27276            IERROR='YES'
27277            GOTO9000
27278          ENDIF
27279        ENDIF
27280 2000 CONTINUE
27281C
27282      NEWNAM='YES'
27283      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
27284C
27285      ILISTL=NUMNAM+1
27286      IF(ILISTL.GT.MAXNAM)THEN
27287        WRITE(ICOUT,999)
27288        CALL DPWRST('XXX','BUG ')
27289        WRITE(ICOUT,2001)
27290        CALL DPWRST('XXX','BUG ')
27291        WRITE(ICOUT,2202)
27292 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
27293     1         'FUNCTION')
27294        CALL DPWRST('XXX','BUG ')
27295        WRITE(ICOUT,2203)MAXNAM
27296 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
27297        CALL DPWRST('XXX','BUG ')
27298        WRITE(ICOUT,2204)
27299 2204   FORMAT('      ENTER      STATUS')
27300        CALL DPWRST('XXX','BUG ')
27301        WRITE(ICOUT,2205)
27302 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
27303        CALL DPWRST('XXX','BUG ')
27304        WRITE(ICOUT,2206)
27305 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
27306     1         'USED NAMES.')
27307        CALL DPWRST('XXX','BUG ')
27308        IERROR='YES'
27309        GOTO9000
27310      ENDIF
27311C
27312 2299 CONTINUE
27313C
27314C               *****************************************************
27315C               **  STEP 3--                                       **
27316C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
27317C               *****************************************************
27318C
27319      ISTEPN='3A'
27320      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLC')
27321     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27322C
27323      IHRIGH=IHARG(5)
27324      IHRIG2=IHARG2(5)
27325      DO3000I=1,NUMNAM
27326        I4=I
27327        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
27328          IF(IUSE(I4).NE.'F')THEN
27329            WRITE(ICOUT,999)
27330            CALL DPWRST('XXX','BUG ')
27331            WRITE(ICOUT,2001)
27332            CALL DPWRST('XXX','BUG ')
27333            WRITE(ICOUT,3003)IHRIGH,IHRIG2
27334 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
27335     1             A4,A4,')')
27336            CALL DPWRST('XXX','BUG ')
27337            WRITE(ICOUT,3005)
27338 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
27339            CALL DPWRST('XXX','BUG ')
27340            IERROR='YES'
27341            GOTO9000
27342          ELSE
27343            ISTRT1=IVSTAR(I4)
27344            ISTOP1=IVSTOP(I4)
27345            NLEN1=ISTOP1-ISTRT1+1
27346            GOTO3099
27347          ENDIF
27348        ENDIF
27349 3000 CONTINUE
27350C
27351      WRITE(ICOUT,999)
27352      CALL DPWRST('XXX','BUG ')
27353      WRITE(ICOUT,2001)
27354      CALL DPWRST('XXX','BUG ')
27355      WRITE(ICOUT,3003)IHRIGH,IHRIG2
27356      CALL DPWRST('XXX','BUG ')
27357      WRITE(ICOUT,3015)
27358 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
27359      CALL DPWRST('XXX','BUG ')
27360      IERROR='YES'
27361      GOTO9000
27362C
27363 3099 CONTINUE
27364C
27365C               *****************************************************
27366C               **  STEP 4--                                       **
27367C               **  PERFORM THE CASE CONVERSION                    **
27368C               *****************************************************
27369C
27370      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLC')THEN
27371        ISTEPN='4A'
27372        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27373        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1
27374 4011   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
27375        CALL DPWRST('XXX','BUG ')
27376        WRITE(ICOUT,4014)ICASEL
27377 4014   FORMAT('ICASEL = ',A4)
27378        CALL DPWRST('XXX','BUG ')
27379      ENDIF
27380C
27381      IF(NLEN1.GE.1)THEN
27382        ICNT=0
27383        DO4100I=ISTRT1,ISTOP1
27384          ICNT=ICNT+1
27385          IC=IFUNC(I)(1:1)
27386          CALL DPCOAN(IC,IJUNK)
27387          IF(IJUNK.GE.65 .AND. IJUNK.LE.90)THEN
27388            IJUNK=IJUNK+32
27389          ENDIF
27390          CALL DPCONA(IJUNK,IC)
27391          IFUNC2(ICNT)=' '
27392          IFUNC2(ICNT)(1:1)=IC
27393 4100   CONTINUE
27394      ENDIF
27395C
27396C               *****************************************************
27397C               **  STEP 5--                                       **
27398C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
27399C               *****************************************************
27400C
27401C
27402      IF(ICASEL.EQ.'STRI')THEN
27403C
27404        ISTEPN='5'
27405        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLC')
27406     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27407C
27408        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
27409     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
27410CCCCC1              NEWNAM,MAXN3,
27411     1              NEWNAM,MAXNAM,
27412     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
27413        IF(IERROR.EQ.'YES')GOTO9000
27414C
27415        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
27416          WRITE(ICOUT,999)
27417          CALL DPWRST('XXX','BUG ')
27418          WRITE(ICOUT,6606)IHLEFT,IHLEF2
27419 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
27420          CALL DPWRST('XXX','BUG ')
27421          ILAB(1)='TO T'
27422          ILAB(2)='HE F'
27423          ILAB(3)='UNCT'
27424          ILAB(4)='ION '
27425          ILAB(5)='    '
27426          ILAB(6)=' -- '
27427          NUMWDL=6
27428          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
27429C
27430          WRITE(ICOUT,999)
27431          CALL DPWRST('XXX','BUG ')
27432C
27433        ENDIF
27434C
27435      ENDIF
27436C
27437C
27438C               ****************
27439C               **  STEP 90-- **
27440C               **  EXIT.     **
27441C               ****************
27442C
27443 9000 CONTINUE
27444      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STLC')THEN
27445        WRITE(ICOUT,999)
27446        CALL DPWRST('XXX','BUG ')
27447        WRITE(ICOUT,9011)
27448 9011   FORMAT('***** AT THE END       OF DPSTLC--')
27449        CALL DPWRST('XXX','BUG ')
27450        WRITE(ICOUT,9013)NUMNAM
27451 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
27452        CALL DPWRST('XXX','BUG ')
27453        DO9015I=1,NUMNAM
27454          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
27455     1                     IVSTAR(I),IVSTOP(I)
27456 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
27457     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
27458          CALL DPWRST('XXX','BUG ')
27459 9015   CONTINUE
27460      ENDIF
27461C
27462      RETURN
27463      END
27464      SUBROUTINE DPSTLN(ISUBRO,IBUGA3,IERROR)
27465C
27466C     PURPOSE--RETURN THE NUMBER OF CHARACTERS IN A PREVIOUSLY
27467C              DEFINED STRING.
27468C     EXAMPLE--LET NLEN = STRING LENGTH S
27469C     WRITTEN BY--JAMES J. FILLIBEN
27470C                 STATISTICAL ENGINEERING DIVISION
27471C                 INFORMATION TECHNOLOGY LABORATORY
27472C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
27473C                 GAITHERSBURG, MD 20899-8980
27474C                 PHONE--301-975-2855
27475C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27476C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
27477C     LANGUAGE--ANSI FORTRAN (1977)
27478C     VERSION NUMBER--2008/11
27479C     ORIGINAL VERSION--NOVEMBER  2008.
27480C
27481C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27482C
27483      CHARACTER*4 ISUBRO
27484      CHARACTER*4 IBUGA3
27485      CHARACTER*4 IERROR
27486C
27487      CHARACTER*4 NEWNAM
27488      CHARACTER*4 NEWCOL
27489      CHARACTER*4 ICASEL
27490      CHARACTER*4 IHLEFT
27491      CHARACTER*4 IHLEF2
27492      CHARACTER*4 IHRIGH
27493      CHARACTER*4 IHRIG2
27494C
27495      CHARACTER*4 ISUBN1
27496      CHARACTER*4 ISUBN2
27497      CHARACTER*4 ISTEPN
27498C
27499      CHARACTER*8 ISTR
27500C
27501C---------------------------------------------------------------------
27502C
27503C-----COMMON----------------------------------------------------------
27504C
27505      INCLUDE 'DPCOPA.INC'
27506      INCLUDE 'DPCOHK.INC'
27507      INCLUDE 'DPCODA.INC'
27508      INCLUDE 'DPCOP2.INC'
27509C
27510C-----START POINT-----------------------------------------------------
27511C
27512      ISUBN1='DPST'
27513      ISUBN2='LN  '
27514      IERROR='NO'
27515C
27516      ILOC3=0
27517      MAXCP1=MAXCOL+1
27518      MAXCP2=MAXCOL+2
27519      MAXCP3=MAXCOL+3
27520      MAXCP4=MAXCOL+4
27521      MAXCP5=MAXCOL+5
27522      MAXCP6=MAXCOL+6
27523C
27524C               *****************************************************
27525C               **  TREAT THE SUBCASE OF THE LET FUNCTION COMMAND  **
27526C               **  WHICH DEFINES A FUNCTION                       **
27527C               *****************************************************
27528C
27529      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STLN')THEN
27530        WRITE(ICOUT,999)
27531        CALL DPWRST('XXX','BUG ')
27532        WRITE(ICOUT,51)
27533   51   FORMAT('***** AT THE BEGINNING OF DPSTLN--')
27534        CALL DPWRST('XXX','BUG ')
27535        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
27536   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
27537        CALL DPWRST('XXX','BUG ')
27538        DO55I=1,NUMNAM
27539          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
27540     1                   IVSTOP(I)
27541   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
27542     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
27543          CALL DPWRST('XXX','BUG ')
27544   55   CONTINUE
27545        WRITE(ICOUT,57)NUMCHF,MAXCHF
27546   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
27547        CALL DPWRST('XXX','BUG ')
27548        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
27549   60   FORMAT('IFUNC(.)  = ',120A1)
27550        CALL DPWRST('XXX','BUG ')
27551      ENDIF
27552C
27553C               **********************************
27554C               **  STEP 1--                    **
27555C               **  INITIALIZE SOME VARIABLES.  **
27556C               **********************************
27557C
27558      ISTEPN='1'
27559      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLN')
27560     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27561C
27562      NEWNAM='NO'
27563      NEWCOL='NO'
27564      ICASEL='UNKN'
27565      NIOLD=0
27566      ICOLL=0
27567      ICOL2=0
27568C
27569C               ******************************************************
27570C               **  STEP 2--                                         *
27571C               **  EXAMINE THE LEFT-HAND SIDE--                     *
27572C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
27573C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
27574C               ******************************************************
27575C
27576      ISTEPN='2'
27577      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLN')
27578     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27579C
27580      IHLEFT=IHARG(1)
27581      IHLEF2=IHARG2(1)
27582C
27583      DO1910I=1,4
27584        IF(IHLEFT(I:I).EQ.'(')THEN
27585          IHLEFT(I:4)=' '
27586          IHLEF2=' '
27587          ICASEL='ELEM'
27588          GOTO1999
27589        ENDIF
27590 1910 CONTINUE
27591      DO1920I=1,4
27592        IF(IHLEF2(I:I).EQ.'(')THEN
27593          IHLEF2(I:4)=' '
27594          ICASEL='ELEM'
27595          GOTO1999
27596        ENDIF
27597 1920 CONTINUE
27598 1999 CONTINUE
27599C
27600      DO2000I=1,NUMNAM
27601        I2=I
27602        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
27603          IF(IUSE(I2).EQ.'P')THEN
27604            ICASEL='PARA'
27605            ILISTL=I2
27606            GOTO2900
27607          ELSEIF(IUSE(I2).EQ.'V')THEN
27608            ICASEL='ELEM'
27609            ILISTL=I2
27610            ICOLL=IVALUE(ILISTL)
27611            NIOLD=IN(ILISTL)
27612            GOTO2900
27613          ELSE
27614            WRITE(ICOUT,999)
27615  999       FORMAT(1X)
27616            CALL DPWRST('XXX','BUG ')
27617            WRITE(ICOUT,2001)
27618 2001       FORMAT('***** ERROR IN STRING LENGTH--')
27619            CALL DPWRST('XXX','BUG ')
27620            WRITE(ICOUT,2003)IHLEFT,IHLEF2
27621 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
27622     1             A4,A4,')')
27623            CALL DPWRST('XXX','BUG ')
27624            WRITE(ICOUT,2005)
27625 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
27626            CALL DPWRST('XXX','BUG ')
27627            IERROR='YES'
27628            GOTO9000
27629          ENDIF
27630        ENDIF
27631 2000 CONTINUE
27632C
27633      NEWNAM='YES'
27634      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
27635C
27636      ILISTL=NUMNAM+1
27637      IF(ILISTL.GT.MAXNAM)THEN
27638        WRITE(ICOUT,999)
27639        CALL DPWRST('XXX','BUG ')
27640        WRITE(ICOUT,2001)
27641        CALL DPWRST('XXX','BUG ')
27642        WRITE(ICOUT,2202)
27643 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
27644     1         'FUNCTION')
27645        CALL DPWRST('XXX','BUG ')
27646        WRITE(ICOUT,2203)MAXNAM
27647 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
27648        CALL DPWRST('XXX','BUG ')
27649        WRITE(ICOUT,2204)
27650 2204   FORMAT('      ENTER      STATUS')
27651        CALL DPWRST('XXX','BUG ')
27652        WRITE(ICOUT,2205)
27653 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
27654        CALL DPWRST('XXX','BUG ')
27655        WRITE(ICOUT,2206)
27656 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
27657     1         'USED NAMES.')
27658        CALL DPWRST('XXX','BUG ')
27659        IERROR='YES'
27660        GOTO9000
27661      ENDIF
27662C
27663 2900 CONTINUE
27664C
27665C               *****************************************************
27666C               **  STEP 3--                                       **
27667C               **  EXTRACT THE NAME ON THE RIGHT HAND SIDE        **
27668C               *****************************************************
27669C
27670      ISTEPN='3'
27671      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLN')
27672     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27673C
27674      IHRIGH=IHARG(5)
27675      IHRIG2=IHARG2(5)
27676      DO3000I=1,NUMNAM
27677        I4=I
27678        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
27679          IF(IUSE(I4).NE.'F')THEN
27680            WRITE(ICOUT,999)
27681            CALL DPWRST('XXX','BUG ')
27682            WRITE(ICOUT,2001)
27683            CALL DPWRST('XXX','BUG ')
27684            WRITE(ICOUT,3003)IHRIGH,IHRIG2
27685 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
27686     1             A4,A4,')')
27687            CALL DPWRST('XXX','BUG ')
27688            WRITE(ICOUT,3005)
27689 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
27690            CALL DPWRST('XXX','BUG ')
27691            IERROR='YES'
27692            GOTO9000
27693          ELSE
27694            ISTART=IVSTAR(I4)
27695            ISTOP=IVSTOP(I4)
27696            IVAL=ISTOP-ISTART+1
27697            GOTO3900
27698          ENDIF
27699        ENDIF
27700 3000 CONTINUE
27701C
27702      WRITE(ICOUT,999)
27703      CALL DPWRST('XXX','BUG ')
27704      WRITE(ICOUT,2001)
27705      CALL DPWRST('XXX','BUG ')
27706      WRITE(ICOUT,3003)IHRIGH,IHRIG2
27707      CALL DPWRST('XXX','BUG ')
27708      WRITE(ICOUT,3015)
27709 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
27710      CALL DPWRST('XXX','BUG ')
27711      IERROR='YES'
27712      GOTO9000
27713C
27714 3900 CONTINUE
27715C
27716C               *****************************************************
27717C               **  STEP 4--                                       **
27718C               **  SAVE PARAMETER                                 **
27719C               *****************************************************
27720C
27721      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLN')THEN
27722        ISTEPN='4'
27723        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27724        WRITE(ICOUT,4011)ISTART,ISTOP,IVAL
27725 4011   FORMAT('ISTART,ISTOP,IVAL = ',3I8)
27726        CALL DPWRST('XXX','BUG ')
27727        WRITE(ICOUT,4013)ICASEL
27728 4013   FORMAT('ICASEL = ',A4)
27729        CALL DPWRST('XXX','BUG ')
27730      ENDIF
27731C
27732      IF(ICASEL.EQ.'PARA')THEN
27733C
27734        ISTEPN='4A'
27735        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STLN')
27736     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27737C
27738        IHNAME(ILISTL)=IHLEFT
27739        IHNAM2(ILISTL)=IHLEF2
27740        IUSE(ILISTL)='P'
27741        VALUE(ILISTL)=REAL(IVAL)
27742        IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
27743        IN(ILISTL)=1
27744        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
27745C
27746        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
27747          WRITE(ICOUT,999)
27748          CALL DPWRST('XXX','BUG ')
27749          WRITE(ICOUT,15111)IHLEFT,IHLEF2,IHRIGH,IHRIG2,IVAL
2775015111     FORMAT(A4,A4,' CONTAINS THE LENGTH OF STRING ',A4,A4,
27751     1           ' = ',I8)
27752          CALL DPWRST('XXX','BUG ')
27753          WRITE(ICOUT,999)
27754          CALL DPWRST('XXX','BUG ')
27755        ENDIF
27756      ELSEIF(ICASEL.EQ.'ELEM')THEN
27757C
27758C       SEARCH IANS STRING FOR "(xx) =".  IF NO PARENTHESIS
27759C       FOUND BEFORE "=", THEN DO NOT KNOW WHAT ROW OF THE
27760C       VARIABLE TO SAVE.  TREAT THIS AS AN ERROR.
27761C
27762        NLEFT=-1
27763        NRIGHT=-1
27764        NEQUAL=-1
27765        DO16001I=1,IWIDTH
27766          IF(IANS(I)(1:1).EQ.'(' .AND. NLEFT.LT.0)THEN
27767            NLEFT=I
27768          ELSEIF(IANS(I)(1:1).EQ.')' .AND. NRIGHT.LT.0)THEN
27769            NRIGHT=I
27770          ELSEIF(IANS(I)(1:1).EQ.'=' .AND. NEQUAL.LT.0)THEN
27771            NEQUAL=I
27772          ENDIF
2777316001   CONTINUE
27774C
27775C       NEED  NLEFT < NRIGHT < NEQUAL
27776C
27777        NSTRT=NLEFT+1
27778        NSTOP=NRIGHT-1
27779        NLEN=NSTOP-NSTRT+1
27780        IF(NLEFT.GT.NRIGHT .OR. NRIGHT.GT.NEQUAL .OR.
27781     1     NSTRT.GT.NSTOP .OR. NLEN.GT.8) THEN
27782          WRITE(ICOUT,999)
27783          CALL DPWRST('XXX','BUG ')
27784          WRITE(ICOUT,2001)
27785          CALL DPWRST('XXX','BUG ')
27786          WRITE(ICOUT,16011)
2778716011     FORMAT('      UNRECOGNIZED SYNTAX FOR VARIABLE ELEMENT ON')
27788          CALL DPWRST('XXX','BUG ')
27789          WRITE(ICOUT,16013)
2779016013     FORMAT('      LEFT HAND SIDE EQUAL SIGN.')
27791          CALL DPWRST('XXX','BUG ')
27792          IERROR='YES'
27793          GOTO9000
27794        ELSE
27795          ISTR=' '
27796          DO16020I=1,NLEN
27797            ISTR(I:I)=IANS(NSTRT+I-1)(1:1)
2779816020     CONTINUE
27799          READ(ISTR,'(I8)',ERR=16029)IARGL
27800          GOTO16049
27801C
2780216029     CONTINUE
27803          WRITE(ICOUT,999)
27804          CALL DPWRST('XXX','BUG ')
27805          WRITE(ICOUT,2001)
27806          CALL DPWRST('XXX','BUG ')
27807          WRITE(ICOUT,16011)
27808          CALL DPWRST('XXX','BUG ')
27809          WRITE(ICOUT,16013)
27810          CALL DPWRST('XXX','BUG ')
27811          IERROR='YES'
27812          GOTO9000
27813C
2781416049     CONTINUE
27815        ENDIF
27816C
27817        IF(IARGL.LT.1 .OR. IARGL.GT.MAXN)THEN
27818          WRITE(ICOUT,999)
27819          CALL DPWRST('XXX','BUG ')
27820          WRITE(ICOUT,2001)
27821          CALL DPWRST('XXX','BUG ')
27822          WRITE(ICOUT,16052)IARGL,ILEFT
2782316052     FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
27824          CALL DPWRST('XXX','BUG ')
27825          WRITE(ICOUT,16054)
2782616054     FORMAT('      WAS LESS THAN 1 OR GREATER THAN THE')
27827          CALL DPWRST('XXX','BUG ')
27828          WRITE(ICOUT,16055)MAXN
2782916055     FORMAT('      MAXIMUM ALLOWABLE ',I8)
27830          CALL DPWRST('XXX','BUG ')
27831          IERROR='YES'
27832          GOTO9000
27833        ENDIF
27834C
27835        IF(NEWNAM.EQ.'YES')THEN
27836          NIOLD=1
27837        ENDIF
27838        NINEW=NIOLD
27839        IF(IARGL.GT.NINEW)NINEW=IARGL
27840        NS2=1
27841C
27842        RIGHT=REAL(IVAL)
27843        IJ=MAXN*(ICOLL-1)+IARGL
27844        IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
27845        IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT
27846        IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT
27847        IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT
27848        IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT
27849        IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT
27850        IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT
27851C
27852        IHNAME(ILISTL)=IHLEFT
27853        IHNAM2(ILISTL)=IHLEF2
27854        IUSE(ILISTL)='V'
27855        IVALUE(ILISTL)=ICOLL
27856        VALUE(ILISTL)=ICOLL
27857        IN(ILISTL)=NINEW
27858C
27859        IF(NEWNAM.EQ.'YES')THEN
27860          NUMNAM=NUMNAM+1
27861          NUMCOL=NUMCOL+1
27862        ENDIF
27863C
27864        DO16200J4=1,NUMNAM
27865          IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)THEN
27866            IUSE(J4)='V'
27867            IVALUE(J4)=ICOLL
27868            VALUE(J4)=ICOLL
27869            IN(J4)=NINEW
27870            GOTO16209
27871          ENDIF
2787216200   CONTINUE
2787316209   CONTINUE
27874C
27875        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
27876          WRITE(ICOUT,999)
27877          CALL DPWRST('XXX','BUG ')
27878          WRITE(ICOUT,16211)IHRIGH,IHRIG2,IVAL
2787916211     FORMAT('THE LENGTH OF STRING ',A4,A4,' = ',I8)
27880          CALL DPWRST('XXX','BUG ')
27881          WRITE(ICOUT,999)
27882          CALL DPWRST('XXX','BUG ')
27883        ENDIF
27884      ENDIF
27885      GOTO9000
27886C
27887C
27888C               ****************
27889C               **  STEP 90-- **
27890C               **  EXIT.     **
27891C               ****************
27892C
27893 9000 CONTINUE
27894      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STLN')THEN
27895        WRITE(ICOUT,999)
27896        CALL DPWRST('XXX','BUG ')
27897        WRITE(ICOUT,9011)
27898 9011   FORMAT('***** AT THE END       OF DPSTLN--')
27899        CALL DPWRST('XXX','BUG ')
27900        WRITE(ICOUT,9013)NUMNAM
27901 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
27902        CALL DPWRST('XXX','BUG ')
27903        DO9015I=1,NUMNAM
27904          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
27905     1                     IVSTAR(I),IVSTOP(I)
27906 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
27907     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
27908          CALL DPWRST('XXX','BUG ')
27909 9015   CONTINUE
27910      ENDIF
27911C
27912      RETURN
27913      END
27914      SUBROUTINE DPSTMR(ISUBRO,IBUGA3,IERROR)
27915C
27916C     PURPOSE--INSERT A STRING INTO A PREVIOUSLY DEFINED STRING
27917C     EXAMPLE--LET SOUT = STRING MERGE SOLD SNEW START
27918C     WRITTEN BY--JAMES J. FILLIBEN
27919C                 STATISTICAL ENGINEERING DIVISION
27920C                 INFORMATION TECHNOLOGY LABORATORY
27921C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
27922C                 GAITHERSBURG, MD 20899-8980
27923C                 PHONE--301-975-2855
27924C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27925C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
27926C     LANGUAGE--ANSI FORTRAN (1977)
27927C     VERSION NUMBER--2008/11
27928C     ORIGINAL VERSION--NOVEMBER  2008.
27929C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
27930C
27931C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27932C
27933      CHARACTER*4 ISUBRO
27934      CHARACTER*4 IBUGA3
27935      CHARACTER*4 IERROR
27936C
27937      CHARACTER*4 NEWNAM
27938      CHARACTER*4 NEWNA2
27939      CHARACTER*4 NEWCOL
27940      CHARACTER*4 NEWCO2
27941      CHARACTER*4 ICASEL
27942      CHARACTER*4 ICASE2
27943      CHARACTER*4 IHLEFT
27944      CHARACTER*4 IHLEF2
27945      CHARACTER*4 IHRIGH
27946      CHARACTER*4 IHRIG2
27947      CHARACTER*4 IHRI21
27948      CHARACTER*4 IHRI22
27949      CHARACTER*4 IHRI31
27950      CHARACTER*4 IHRI32
27951C
27952      CHARACTER*4 ISUBN1
27953      CHARACTER*4 ISUBN2
27954      CHARACTER*4 ISTEPN
27955C
27956      CHARACTER*4 ILAB(10)
27957C
27958C---------------------------------------------------------------------
27959C
27960C-----COMMON----------------------------------------------------------
27961C
27962      INCLUDE 'DPCOPA.INC'
27963      INCLUDE 'DPCOHK.INC'
27964      INCLUDE 'DPCODA.INC'
27965      INCLUDE 'DPCOP2.INC'
27966C
27967C-----START POINT-----------------------------------------------------
27968C
27969      ISUBN1='DPST'
27970      ISUBN2='MR  '
27971      IERROR='NO'
27972C
27973      ILOC3=0
27974C
27975      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STMR')THEN
27976        WRITE(ICOUT,999)
27977        CALL DPWRST('XXX','BUG ')
27978        WRITE(ICOUT,51)
27979   51   FORMAT('***** AT THE BEGINNING OF DPSTMR--')
27980        CALL DPWRST('XXX','BUG ')
27981        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
27982   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
27983        CALL DPWRST('XXX','BUG ')
27984        DO55I=1,NUMNAM
27985          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
27986     1                   IVSTOP(I)
27987   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
27988     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
27989          CALL DPWRST('XXX','BUG ')
27990   55   CONTINUE
27991        WRITE(ICOUT,57)NUMCHF,MAXCHF
27992   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
27993        CALL DPWRST('XXX','BUG ')
27994        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
27995   60   FORMAT('IFUNC(.)  = ',120A1)
27996        CALL DPWRST('XXX','BUG ')
27997      ENDIF
27998C
27999C               **********************************
28000C               **  STEP 1--                    **
28001C               **  INITIALIZE SOME VARIABLES.  **
28002C               **********************************
28003C
28004      ISTEPN='1'
28005      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STMR')
28006     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28007C
28008      NEWNAM='NO'
28009      NEWNA2='NO'
28010      NEWCOL='NO'
28011      NEWCO2='NO'
28012      ICASEL='UNKN'
28013      ICASE2='UNKN'
28014      NIOLD1=0
28015      NIOLD2=0
28016      ICOLL=0
28017      ICOL2=0
28018C
28019C               ******************************************************
28020C               **  STEP 2--                                         *
28021C               **  EXAMINE THE ARGUMENT ON THE                      *
28022C               **  LEFT-HAND SIDE--                                 *
28023C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
28024C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
28025C               ******************************************************
28026C
28027      ISTEPN='2'
28028      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STMR')
28029     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28030C
28031      IHLEFT=IHARG(1)
28032      IHLEF2=IHARG2(1)
28033C
28034      DO2000I=1,NUMNAM
28035        I2=I
28036        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
28037          IF(IUSE(I2).EQ.'F')THEN
28038            ICASEL='STRI'
28039            ILISTL=I2
28040            GOTO2299
28041          ELSE
28042            WRITE(ICOUT,999)
28043  999       FORMAT(1X)
28044            CALL DPWRST('XXX','BUG ')
28045            WRITE(ICOUT,2001)
28046 2001       FORMAT('***** ERROR IN STRING MERGE--')
28047            CALL DPWRST('XXX','BUG ')
28048            WRITE(ICOUT,2003)IHLEFT,IHLEF2
28049 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
28050     1             A4,A4,')')
28051            CALL DPWRST('XXX','BUG ')
28052            WRITE(ICOUT,2005)
28053 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
28054            CALL DPWRST('XXX','BUG ')
28055            IERROR='YES'
28056            GOTO9000
28057          ENDIF
28058        ENDIF
28059 2000 CONTINUE
28060C
28061      NEWNAM='YES'
28062      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
28063C
28064      ILISTL=NUMNAM+1
28065      IF(ILISTL.GT.MAXNAM)THEN
28066        WRITE(ICOUT,999)
28067        CALL DPWRST('XXX','BUG ')
28068        WRITE(ICOUT,2001)
28069        CALL DPWRST('XXX','BUG ')
28070        WRITE(ICOUT,2202)
28071 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
28072     1         'FUNCTION')
28073        CALL DPWRST('XXX','BUG ')
28074        WRITE(ICOUT,2203)MAXNAM
28075 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
28076        CALL DPWRST('XXX','BUG ')
28077        WRITE(ICOUT,2204)
28078 2204   FORMAT('      ENTER      STATUS')
28079        CALL DPWRST('XXX','BUG ')
28080        WRITE(ICOUT,2205)
28081 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
28082        CALL DPWRST('XXX','BUG ')
28083        WRITE(ICOUT,2206)
28084 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
28085     1         'USED NAMES.')
28086        CALL DPWRST('XXX','BUG ')
28087        IERROR='YES'
28088        GOTO9000
28089      ENDIF
28090C
28091 2299 CONTINUE
28092C
28093C               *****************************************************
28094C               **  STEP 3--                                       **
28095C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
28096C               *****************************************************
28097C
28098      ISTEPN='3A'
28099      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STMR')
28100     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28101C
28102      IHRIGH=IHARG(5)
28103      IHRIG2=IHARG2(5)
28104      DO3000I=1,NUMNAM
28105        I4=I
28106        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
28107          IF(IUSE(I4).NE.'F')THEN
28108            WRITE(ICOUT,999)
28109            CALL DPWRST('XXX','BUG ')
28110            WRITE(ICOUT,2001)
28111            CALL DPWRST('XXX','BUG ')
28112            WRITE(ICOUT,3003)IHRIGH,IHRIG2
28113 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
28114     1             A4,A4,')')
28115            CALL DPWRST('XXX','BUG ')
28116            WRITE(ICOUT,3005)
28117 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
28118            CALL DPWRST('XXX','BUG ')
28119            IERROR='YES'
28120            GOTO9000
28121          ELSE
28122            ISTRT1=IVSTAR(I4)
28123            ISTOP1=IVSTOP(I4)
28124            NLEN1=ISTOP1-ISTRT1+1
28125            GOTO3099
28126          ENDIF
28127        ENDIF
28128 3000 CONTINUE
28129C
28130      WRITE(ICOUT,999)
28131      CALL DPWRST('XXX','BUG ')
28132      WRITE(ICOUT,2001)
28133      CALL DPWRST('XXX','BUG ')
28134      WRITE(ICOUT,3003)IHRIGH,IHRIG2
28135      CALL DPWRST('XXX','BUG ')
28136      WRITE(ICOUT,3015)
28137 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
28138      CALL DPWRST('XXX','BUG ')
28139      IERROR='YES'
28140      GOTO9000
28141C
28142 3099 CONTINUE
28143C
28144C               *****************************************************
28145C               **  STEP 3B-                                       **
28146C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
28147C               *****************************************************
28148C
28149      ISTEPN='3B'
28150      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STMR')
28151     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28152C
28153      IHRI21=IHARG(6)
28154      IHRI22=IHARG2(6)
28155      DO3100I=1,NUMNAM
28156        I4=I
28157        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
28158          IF(IUSE(I4).NE.'F')THEN
28159            WRITE(ICOUT,999)
28160            CALL DPWRST('XXX','BUG ')
28161            WRITE(ICOUT,2001)
28162            CALL DPWRST('XXX','BUG ')
28163            WRITE(ICOUT,3003)IHRI21,IHRI22
28164            CALL DPWRST('XXX','BUG ')
28165            WRITE(ICOUT,3005)
28166            CALL DPWRST('XXX','BUG ')
28167            IERROR='YES'
28168            GOTO9000
28169          ELSE
28170            ISTRT2=IVSTAR(I4)
28171            ISTOP2=IVSTOP(I4)
28172            NLEN2=ISTOP2-ISTRT2+1
28173            GOTO3199
28174          ENDIF
28175        ENDIF
28176 3100 CONTINUE
28177C
28178      WRITE(ICOUT,999)
28179      CALL DPWRST('XXX','BUG ')
28180      WRITE(ICOUT,2001)
28181      CALL DPWRST('XXX','BUG ')
28182      WRITE(ICOUT,3003)IHRI21,IHRI22
28183      CALL DPWRST('XXX','BUG ')
28184      WRITE(ICOUT,3015)
28185      CALL DPWRST('XXX','BUG ')
28186      IERROR='YES'
28187      GOTO9000
28188C
28189 3199 CONTINUE
28190C
28191C               *****************************************************
28192C               **  STEP 3C-                                       **
28193C               **  EXTRACT THE THIRD  NAME ON THE RIGHT HAND SIDE **
28194C               *****************************************************
28195C
28196      ISTEPN='3C'
28197      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STMR')
28198     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28199C
28200      IHRI31=IHARG(7)
28201      IHRI32=IHARG2(7)
28202      DO3200I=1,NUMNAM
28203        I4=I
28204        IF(IHRI31.EQ.IHNAME(I).AND.IHRI32.EQ.IHNAM2(I))THEN
28205          IF(IUSE(I4).NE.'P')THEN
28206            WRITE(ICOUT,999)
28207            CALL DPWRST('XXX','BUG ')
28208            WRITE(ICOUT,2001)
28209            CALL DPWRST('XXX','BUG ')
28210            WRITE(ICOUT,3003)IHRI31,IHRI32
28211            CALL DPWRST('XXX','BUG ')
28212            WRITE(ICOUT,3215)
28213 3215       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
28214            CALL DPWRST('XXX','BUG ')
28215            IERROR='YES'
28216            GOTO9000
28217          ELSE
28218            ILISR1=I4
28219            NSTART=IVALUE(ILISR1)
28220            GOTO3299
28221          ENDIF
28222        ENDIF
28223 3200 CONTINUE
28224C
28225      IF(NUMARG.GE.7)THEN
28226        IF(IARGT(7).EQ.'NUMB')THEN
28227          NSTART=IARG(7)
28228          GOTO3299
28229        ENDIF
28230      ENDIF
28231C
28232      WRITE(ICOUT,999)
28233      CALL DPWRST('XXX','BUG ')
28234      WRITE(ICOUT,2001)
28235      CALL DPWRST('XXX','BUG ')
28236      WRITE(ICOUT,3003)IHRI31,IHRI32
28237      CALL DPWRST('XXX','BUG ')
28238      WRITE(ICOUT,3015)
28239      CALL DPWRST('XXX','BUG ')
28240      IERROR='YES'
28241      GOTO9000
28242C
28243 3299 CONTINUE
28244C
28245C               *****************************************************
28246C               **  STEP 4--                                       **
28247C               **  CREATE THE SUBSTRING                           **
28248C               *****************************************************
28249C
28250      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STMR')THEN
28251        ISTEPN='4'
28252        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28253        WRITE(ICOUT,4011)ILISR1,ILISR2,NSTART,NSTOP
28254 4011   FORMAT('ILISR1,ILISR2,NSTART,NSTOP = ',4I8)
28255        CALL DPWRST('XXX','BUG ')
28256        WRITE(ICOUT,4013)ICASEL
28257 4013   FORMAT('ICASEL = ',A4)
28258        CALL DPWRST('XXX','BUG ')
28259      ENDIF
28260C
28261      IF(NSTART.LT.1 .OR. NSTART.GT.MAXCHF)THEN
28262        WRITE(ICOUT,999)
28263        CALL DPWRST('XXX','BUG ')
28264        WRITE(ICOUT,2001)
28265        CALL DPWRST('XXX','BUG ')
28266        WRITE(ICOUT,4021)MAXCHF
28267 4021   FORMAT('      THE START INDEX IS LESS THAN 1 OR GREATER ',
28268     1         'THAN ',I8)
28269        CALL DPWRST('XXX','BUG ')
28270        WRITE(ICOUT,4023)NSTART
28271 4023   FORMAT('      THE VALUE OF THE START INDEX IS ',I8)
28272        CALL DPWRST('XXX','BUG ')
28273        IERROR='YES'
28274        GOTO9000
28275      ENDIF
28276C
28277      ICNT=0
28278      IF(NSTART.GT.1)THEN
28279        DO4100I=1,NSTART-1
28280          ICNT=ICNT+1
28281          IINDX=I+ISTRT1-1
28282          IFUNC2(ICNT)=IFUNC(IINDX)
28283 4100   CONTINUE
28284      ENDIF
28285      IF(NLEN2.GE.1)THEN
28286        DO4110I=1,NLEN2
28287          ICNT=ICNT+1
28288          IINDX=I+ISTRT2-1
28289          IFUNC2(ICNT)=IFUNC(IINDX)
28290 4110   CONTINUE
28291      ENDIF
28292      IF(NSTART.LT.NLEN1)THEN
28293        DO4120I=NSTART,NLEN1
28294          ICNT=ICNT+1
28295          IINDX=I+ISTRT1-1
28296          IFUNC2(ICNT)=IFUNC(IINDX)
28297 4120   CONTINUE
28298      ENDIF
28299C
28300C               *****************************************************
28301C               **  STEP 5--                                       **
28302C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
28303C               *****************************************************
28304C
28305C
28306      IF(ICASEL.EQ.'STRI')THEN
28307C
28308        ISTEPN='5'
28309        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STMR')
28310     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28311C
28312        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
28313     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
28314CCCCC1              NEWNAM,MAXN3,
28315     1              NEWNAM,MAXNAM,
28316     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
28317        IF(IERROR.EQ.'YES')GOTO9000
28318C
28319        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
28320          WRITE(ICOUT,999)
28321          CALL DPWRST('XXX','BUG ')
28322          WRITE(ICOUT,6606)IHLEFT,IHLEF2
28323 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
28324          CALL DPWRST('XXX','BUG ')
28325          ILAB(1)='TO T'
28326          ILAB(2)='HE F'
28327          ILAB(3)='UNCT'
28328          ILAB(4)='ION '
28329          ILAB(5)='    '
28330          ILAB(6)=' -- '
28331          NUMWDL=6
28332          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
28333C
28334          WRITE(ICOUT,999)
28335          CALL DPWRST('XXX','BUG ')
28336C
28337        ENDIF
28338C
28339      ENDIF
28340C
28341C
28342C               ****************
28343C               **  STEP 90-- **
28344C               **  EXIT.     **
28345C               ****************
28346C
28347 9000 CONTINUE
28348      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STMR')THEN
28349        WRITE(ICOUT,999)
28350        CALL DPWRST('XXX','BUG ')
28351        WRITE(ICOUT,9011)
28352 9011   FORMAT('***** AT THE END       OF DPSTMR--')
28353        CALL DPWRST('XXX','BUG ')
28354        WRITE(ICOUT,9013)NUMNAM
28355 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
28356        CALL DPWRST('XXX','BUG ')
28357        DO9015I=1,NUMNAM
28358          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
28359     1                     IVSTAR(I),IVSTOP(I)
28360 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
28361     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
28362          CALL DPWRST('XXX','BUG ')
28363 9015   CONTINUE
28364      ENDIF
28365C
28366      RETURN
28367      END
28368      SUBROUTINE DPSTNS(ICASLE,ISUBRO,IBUGA3,IERROR)
28369C
28370C     PURPOSE--IMPLEMENT THE FOLLOWING COMMAND:
28371C
28372C                 LET NC = STRING SUBSET COUNT SORG SMATCH
28373C
28374C              THAT IS, CHECK HOW MANY TIMES THE SUBSTRING "SMATCH"
28375C              IS FOUND IN THE STRING "SORG".  THE STRINGS ON THE RIGHT
28376C              HAND SIDE MUST BOTH BE PREVIOUSLY DEFINED.
28377C     WRITTEN BY--ALAN HECKERT
28378C                 STATISTICAL ENGINEERING DIVISION
28379C                 INFORMATION TECHNOLOGY LABORATORY
28380C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
28381C                 GAITHERSBURG, MD 20899-8980
28382C                 PHONE--301-975-2899
28383C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28384C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
28385C     LANGUAGE--ANSI FORTRAN (1977)
28386C     VERSION NUMBER--2019/02
28387C     ORIGINAL VERSION--FEBRUARY  2019.
28388C
28389C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28390C
28391      CHARACTER*4 ICASLE
28392      CHARACTER*4 ISUBRO
28393      CHARACTER*4 IBUGA3
28394      CHARACTER*4 IERROR
28395C
28396      CHARACTER*4 NEWNAM
28397      CHARACTER*4 NEWNA2
28398      CHARACTER*4 NEWCOL
28399      CHARACTER*4 NEWCO2
28400      CHARACTER*4 ICASEL
28401      CHARACTER*4 IHLEFT
28402      CHARACTER*4 IHLEF2
28403      CHARACTER*4 IHRIGH
28404      CHARACTER*4 IHRIG2
28405      CHARACTER*4 IHRI21
28406      CHARACTER*4 IHRI22
28407      CHARACTER*4 ISUBN1
28408      CHARACTER*4 ISUBN2
28409      CHARACTER*4 ISTEPN
28410C
28411C---------------------------------------------------------------------
28412C
28413C-----COMMON----------------------------------------------------------
28414C
28415      INCLUDE 'DPCOPA.INC'
28416      INCLUDE 'DPCOHK.INC'
28417      INCLUDE 'DPCODA.INC'
28418      INCLUDE 'DPCOP2.INC'
28419C
28420C-----START POINT-----------------------------------------------------
28421C
28422      ISUBN1='DPST'
28423      ISUBN2='NS  '
28424      IERROR='NO'
28425C
28426      ILOC3=0
28427C
28428      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STNS')THEN
28429        WRITE(ICOUT,999)
28430        CALL DPWRST('XXX','BUG ')
28431        WRITE(ICOUT,51)
28432   51   FORMAT('***** AT THE BEGINNING OF DPSTNS--')
28433        CALL DPWRST('XXX','BUG ')
28434        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASLE
28435   52   FORMAT('IBUGA3,ISUBRO,ICASLE = ',2(A4,2X),A4)
28436        CALL DPWRST('XXX','BUG ')
28437        WRITE(ICOUT,53)NUMNAM,NUMCHF,MAXCHF
28438   53   FORMAT('NUMNAM,NUMCHF,MAXCHF = ',3I8)
28439        CALL DPWRST('XXX','BUG ')
28440        DO55I=1,NUMNAM
28441          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
28442     1                   IVSTOP(I)
28443   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
28444     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
28445          CALL DPWRST('XXX','BUG ')
28446   55   CONTINUE
28447        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
28448   60   FORMAT('IFUNC(.)  = ',120A1)
28449        CALL DPWRST('XXX','BUG ')
28450      ENDIF
28451C
28452C               **********************************
28453C               **  STEP 1--                    **
28454C               **  INITIALIZE SOME VARIABLES.  **
28455C               **********************************
28456C
28457      ISTEPN='1'
28458      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNS')
28459     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28460C
28461      NEWNAM='NO'
28462      NEWNA2='NO'
28463      NEWCOL='NO'
28464      NEWCO2='NO'
28465      ICASEL='UNKN'
28466      NIOLD1=0
28467      ICOLL=0
28468C
28469C               ******************************************************
28470C               **  STEP 2--                                         *
28471C               **  EXAMINE THE FIRST ARGUMENT ON THE                *
28472C               **  LEFT-HAND SIDE--                                 *
28473C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
28474C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
28475C               ******************************************************
28476C
28477      ISTEPN='2'
28478      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNS')
28479     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28480C
28481      IHLEFT=IHARG(1)
28482      IHLEF2=IHARG2(1)
28483C
28484      DO2000I=1,NUMNAM
28485        I2=I
28486        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
28487          IF(IUSE(I2).EQ.'P')THEN
28488            ICASEL='PARA'
28489            ILISTL=I2
28490            NUMTMP=NUMNAM
28491            GOTO2299
28492          ELSE
28493            WRITE(ICOUT,999)
28494  999       FORMAT(1X)
28495            CALL DPWRST('XXX','BUG ')
28496            WRITE(ICOUT,2001)
28497 2001       FORMAT('***** ERROR IN STRING SUBSET COUNT--')
28498            CALL DPWRST('XXX','BUG ')
28499            WRITE(ICOUT,2003)IHLEFT,IHLEF2
28500 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
28501     1             A4,A4,')')
28502            CALL DPWRST('XXX','BUG ')
28503            WRITE(ICOUT,2005)
28504 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
28505            CALL DPWRST('XXX','BUG ')
28506            IERROR='YES'
28507            GOTO9000
28508          ENDIF
28509        ENDIF
28510 2000 CONTINUE
28511C
28512      NEWNAM='YES'
28513      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
28514C
28515      ILISTL=NUMNAM+1
28516      NUMTMP=NUMNAM+1
28517      IF(ILISTL.GT.MAXNAM)THEN
28518        WRITE(ICOUT,999)
28519        CALL DPWRST('XXX','BUG ')
28520        WRITE(ICOUT,2001)
28521        CALL DPWRST('XXX','BUG ')
28522        WRITE(ICOUT,2202)
28523 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
28524     1         'FUNCTION')
28525        CALL DPWRST('XXX','BUG ')
28526        WRITE(ICOUT,2203)MAXNAM
28527 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
28528        CALL DPWRST('XXX','BUG ')
28529        WRITE(ICOUT,2204)
28530 2204   FORMAT('      ENTER      STATUS')
28531        CALL DPWRST('XXX','BUG ')
28532        WRITE(ICOUT,2205)
28533 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
28534        CALL DPWRST('XXX','BUG ')
28535        WRITE(ICOUT,2206)
28536 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
28537     1         'USED NAMES.')
28538        CALL DPWRST('XXX','BUG ')
28539        IERROR='YES'
28540        GOTO9000
28541      ENDIF
28542C
28543 2299 CONTINUE
28544C
28545C               *****************************************************
28546C               **  STEP 3--                                       **
28547C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
28548C               *****************************************************
28549C
28550      ISTEPN='3A'
28551      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNS')
28552     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28553C
28554      IINDX=6
28555      IHRIGH=IHARG(IINDX)
28556      IHRIG2=IHARG2(IINDX)
28557      DO3000I=1,NUMNAM
28558        I4=I
28559        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
28560          IF(IUSE(I4).NE.'F')THEN
28561            WRITE(ICOUT,999)
28562            CALL DPWRST('XXX','BUG ')
28563            WRITE(ICOUT,2001)
28564            CALL DPWRST('XXX','BUG ')
28565            WRITE(ICOUT,3003)IHRIGH,IHRIG2
28566 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
28567     1             A4,A4,')')
28568            CALL DPWRST('XXX','BUG ')
28569            WRITE(ICOUT,3005)
28570 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
28571            CALL DPWRST('XXX','BUG ')
28572            IERROR='YES'
28573            GOTO9000
28574          ELSE
28575            ISTRT1=IVSTAR(I4)
28576            ISTOP1=IVSTOP(I4)
28577            NLEN1=ISTOP1-ISTRT1+1
28578            GOTO3099
28579          ENDIF
28580        ENDIF
28581 3000 CONTINUE
28582C
28583      WRITE(ICOUT,999)
28584      CALL DPWRST('XXX','BUG ')
28585      WRITE(ICOUT,2001)
28586      CALL DPWRST('XXX','BUG ')
28587      WRITE(ICOUT,3003)IHRIGH,IHRIG2
28588      CALL DPWRST('XXX','BUG ')
28589      WRITE(ICOUT,3015)
28590 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
28591      CALL DPWRST('XXX','BUG ')
28592      IERROR='YES'
28593      GOTO9000
28594C
28595 3099 CONTINUE
28596C
28597C               *****************************************************
28598C               **  STEP 3B-                                       **
28599C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
28600C               *****************************************************
28601C
28602      ISTEPN='3B'
28603      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNS')
28604     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28605C
28606      IINDX=IINDX+1
28607      IHRI21=IHARG(IINDX)
28608      IHRI22=IHARG2(IINDX)
28609      DO3100I=1,NUMNAM
28610        I4=I
28611        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
28612          IF(IUSE(I4).NE.'F')THEN
28613            WRITE(ICOUT,999)
28614            CALL DPWRST('XXX','BUG ')
28615            WRITE(ICOUT,2001)
28616            CALL DPWRST('XXX','BUG ')
28617            WRITE(ICOUT,3003)IHRI21,IHRI22
28618            CALL DPWRST('XXX','BUG ')
28619            WRITE(ICOUT,3005)
28620            CALL DPWRST('XXX','BUG ')
28621            IERROR='YES'
28622            GOTO9000
28623          ELSE
28624            ISTRT2=IVSTAR(I4)
28625            ISTOP2=IVSTOP(I4)
28626            NLEN2=ISTOP2-ISTRT2+1
28627            GOTO3199
28628          ENDIF
28629        ENDIF
28630 3100 CONTINUE
28631C
28632      WRITE(ICOUT,999)
28633      CALL DPWRST('XXX','BUG ')
28634      WRITE(ICOUT,2001)
28635      CALL DPWRST('XXX','BUG ')
28636      WRITE(ICOUT,3003)IHRI21,IHRI22
28637      CALL DPWRST('XXX','BUG ')
28638      WRITE(ICOUT,3015)
28639      CALL DPWRST('XXX','BUG ')
28640      IERROR='YES'
28641      GOTO9000
28642C
28643 3199 CONTINUE
28644C
28645C               *****************************************************
28646C               **  STEP 4--                                       **
28647C               **  CHECK FOR MATCHING STRINGS                     **
28648C               *****************************************************
28649C
28650      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNS')THEN
28651        ISTEPN='4'
28652        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28653        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1
28654 4011   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
28655        CALL DPWRST('XXX','BUG ')
28656        WRITE(ICOUT,4012)ISTRT2,ISTOP2,NLEN2
28657 4012   FORMAT('ISTART,ISTOP,NLEN2 = ',3I8)
28658        CALL DPWRST('XXX','BUG ')
28659      ENDIF
28660C
28661      IMATCH=0
28662      IF(NLEN2.GT.NLEN1)GOTO4199
28663      NTEMP=ISTOP1-NLEN2+1
28664      DO4100J=ISTRT1,NTEMP
28665        ICNT=ISTRT2
28666        DO4110I=J,J+NLEN2-1
28667          IF(IFUNC(I)(1:1).NE.IFUNC(ICNT)(1:1))GOTO4100
28668          ICNT=ICNT+1
28669 4110   CONTINUE
28670        IMATCH=IMATCH+1
28671 4100 CONTINUE
28672 4199 CONTINUE
28673C
28674C
28675C               *****************************************************
28676C               **  STEP 5--                                       **
28677C               **  SAVE PARAMETER                                 **
28678C               *****************************************************
28679C
28680      IF(ICASEL.EQ.'PARA')THEN
28681C
28682        ISTEPN='5'
28683        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STCO')
28684     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28685C
28686        IHNAME(ILISTL)=IHLEFT
28687        IHNAM2(ILISTL)=IHLEF2
28688        IUSE(ILISTL)='P'
28689        VALUE(ILISTL)=REAL(IMATCH)
28690        IVALUE(ILISTL)=IMATCH
28691        IN(ILISTL)=1
28692        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
28693C
28694        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
28695          WRITE(ICOUT,999)
28696          CALL DPWRST('XXX','BUG ')
28697          IF(IMATCH.EQ.0)THEN
28698            WRITE(ICOUT,5011)IHLEFT,IHLEF2,IMATCH
286995011        FORMAT('MATCH NOT FOUND, ',2A4,'  = ',I3)
28700            CALL DPWRST('XXX','BUG ')
28701          ELSE
28702            WRITE(ICOUT,5013)IHLEFT,IHLEF2,IMATCH
287035013        FORMAT('NUMBER OF MATCHES FOUND, ',2A4,'  = ',I3)
28704            CALL DPWRST('XXX','BUG ')
28705          ENDIF
28706          WRITE(ICOUT,999)
28707          CALL DPWRST('XXX','BUG ')
28708        ENDIF
28709      ENDIF
28710C
28711C
28712C               ****************
28713C               **  STEP 90-- **
28714C               **  EXIT.     **
28715C               ****************
28716C
28717 9000 CONTINUE
28718      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STNS')THEN
28719        WRITE(ICOUT,999)
28720        CALL DPWRST('XXX','BUG ')
28721        WRITE(ICOUT,9011)
28722 9011   FORMAT('***** AT THE END       OF DPSTNS--')
28723        CALL DPWRST('XXX','BUG ')
28724        WRITE(ICOUT,9013)NUMNAM
28725 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
28726        CALL DPWRST('XXX','BUG ')
28727        DO9015I=1,NUMNAM
28728          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
28729     1                     IVSTAR(I),IVSTOP(I)
28730 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
28731     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
28732          CALL DPWRST('XXX','BUG ')
28733 9015   CONTINUE
28734      ENDIF
28735C
28736      RETURN
28737      END
28738      SUBROUTINE DPSTNW(ISUBRO,IBUGA3,IERROR)
28739C
28740C     PURPOSE--DETERMINE THE NUMBER OF WORDS IN A STRING
28741C     EXAMPLE--LET NWORD = NUMBER OF WORD STIN
28742C     WRITTEN BY--ALAN HECKERT
28743C                 STATISTICAL ENGINEERING DIVISION
28744C                 INFORMATION TECHNOLOGY LABORATORY
28745C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
28746C                 GAITHERSBURG, MD 20899-8980
28747C                 PHONE--301-975-2899
28748C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28749C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
28750C     LANGUAGE--ANSI FORTRAN (1977)
28751C     VERSION NUMBER--2010/10
28752C     ORIGINAL VERSION--OCTOBER   2010.
28753C
28754C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28755C
28756      CHARACTER*4 ISUBRO
28757      CHARACTER*4 IBUGA3
28758      CHARACTER*4 IERROR
28759C
28760      CHARACTER*4 NEWNAM
28761      CHARACTER*4 NEWNA2
28762      CHARACTER*4 NEWCOL
28763      CHARACTER*4 NEWCO2
28764      CHARACTER*4 ICASEL
28765      CHARACTER*4 ICASE2
28766      CHARACTER*4 IHLEFT
28767      CHARACTER*4 IHLEF2
28768      CHARACTER*4 IHRIGH
28769      CHARACTER*4 IHRIG2
28770      CHARACTER*4 ISUBN1
28771      CHARACTER*4 ISUBN2
28772      CHARACTER*4 ISTEPN
28773C
28774C---------------------------------------------------------------------
28775C
28776C-----COMMON----------------------------------------------------------
28777C
28778      INCLUDE 'DPCOPA.INC'
28779      INCLUDE 'DPCOHK.INC'
28780      INCLUDE 'DPCODA.INC'
28781      INCLUDE 'DPCOP2.INC'
28782C
28783C-----START POINT-----------------------------------------------------
28784C
28785      ISUBN1='DPST'
28786      ISUBN2='NW  '
28787      IERROR='NO'
28788C
28789      ILOC3=0
28790C
28791      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STNW')THEN
28792        WRITE(ICOUT,999)
28793        CALL DPWRST('XXX','BUG ')
28794        WRITE(ICOUT,51)
28795   51   FORMAT('***** AT THE BEGINNING OF DPSTNW--')
28796        CALL DPWRST('XXX','BUG ')
28797        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
28798   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
28799        CALL DPWRST('XXX','BUG ')
28800        DO55I=1,NUMNAM
28801          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
28802     1                   IVSTOP(I)
28803   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
28804     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
28805          CALL DPWRST('XXX','BUG ')
28806   55   CONTINUE
28807        WRITE(ICOUT,57)NUMCHF,MAXCHF,NUMARG
28808   57   FORMAT('NUMCHF,MAXCHF,NUMARG = ',3I8)
28809        CALL DPWRST('XXX','BUG ')
28810        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
28811   60   FORMAT('IFUNC(.)  = ',120A1)
28812        CALL DPWRST('XXX','BUG ')
28813        IF(NUMARG.GE.1)THEN
28814          DO70I=1,NUMARG
28815            WRITE(ICOUT,76)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
28816   76       FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
28817     1             I8,2X,A4,A4,2X,A4,2X,I8)
28818            CALL DPWRST('XXX','BUG ')
28819   70     CONTINUE
28820        ENDIF
28821      ENDIF
28822C
28823C               **********************************
28824C               **  STEP 1--                    **
28825C               **  INITIALIZE SOME VARIABLES.  **
28826C               **********************************
28827C
28828      ISTEPN='1'
28829      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNW')
28830     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28831C
28832      NEWNAM='NO'
28833      NEWNA2='NO'
28834      NEWCOL='NO'
28835      NEWCO2='NO'
28836      ICASEL='UNKN'
28837      ICASE2='UNKN'
28838      NIOLD1=0
28839      NIOLD2=0
28840      ICOLL=0
28841      ICOL2=0
28842C
28843C               ******************************************************
28844C               **  STEP 2--                                         *
28845C               **  EXAMINE THE FIRST ARGUMENT ON THE                *
28846C               **  LEFT-HAND SIDE--                                 *
28847C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
28848C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
28849C               ******************************************************
28850C
28851      ISTEPN='2'
28852      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNW')
28853     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28854C
28855      IHLEFT=IHARG(1)
28856      IHLEF2=IHARG2(1)
28857C
28858      DO2000I=1,NUMNAM
28859        I2=I
28860        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
28861          IF(IUSE(I2).EQ.'P')THEN
28862            ICASEL='PARA'
28863            ILISTL=I2
28864            NUMTMP=NUMNAM
28865            GOTO2299
28866          ELSE
28867            WRITE(ICOUT,999)
28868  999       FORMAT(1X)
28869            CALL DPWRST('XXX','BUG ')
28870            WRITE(ICOUT,2001)
28871 2001       FORMAT('***** ERROR IN NUMBER OF WORDS--')
28872            CALL DPWRST('XXX','BUG ')
28873            WRITE(ICOUT,2003)IHLEFT,IHLEF2
28874 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
28875     1             A4,A4,')')
28876            CALL DPWRST('XXX','BUG ')
28877            WRITE(ICOUT,2005)
28878 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
28879            CALL DPWRST('XXX','BUG ')
28880            IERROR='YES'
28881            GOTO9000
28882          ENDIF
28883        ENDIF
28884 2000 CONTINUE
28885C
28886      NEWNAM='YES'
28887      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
28888C
28889      ILISTL=NUMNAM+1
28890      NUMTMP=NUMNAM+1
28891      IF(ILISTL.GT.MAXNAM)THEN
28892        WRITE(ICOUT,999)
28893        CALL DPWRST('XXX','BUG ')
28894        WRITE(ICOUT,2001)
28895        CALL DPWRST('XXX','BUG ')
28896        WRITE(ICOUT,2202)
28897 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
28898     1         'FUNCTION')
28899        CALL DPWRST('XXX','BUG ')
28900        WRITE(ICOUT,2203)MAXNAM
28901 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
28902        CALL DPWRST('XXX','BUG ')
28903        WRITE(ICOUT,2204)
28904 2204   FORMAT('      ENTER      STATUS')
28905        CALL DPWRST('XXX','BUG ')
28906        WRITE(ICOUT,2205)
28907 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
28908        CALL DPWRST('XXX','BUG ')
28909        WRITE(ICOUT,2206)
28910 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
28911     1         'USED NAMES.')
28912        CALL DPWRST('XXX','BUG ')
28913        IERROR='YES'
28914        GOTO9000
28915      ENDIF
28916C
28917 2299 CONTINUE
28918C
28919C               *****************************************************
28920C               **  STEP 3--                                       **
28921C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
28922C               *****************************************************
28923C
28924      ISTEPN='3A'
28925      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNW')
28926     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28927C
28928      IHRIGH=IHARG(6)
28929      IHRIG2=IHARG2(6)
28930      DO3000I=1,NUMNAM
28931        I4=I
28932        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
28933          IF(IUSE(I4).NE.'F')THEN
28934            WRITE(ICOUT,999)
28935            CALL DPWRST('XXX','BUG ')
28936            WRITE(ICOUT,2001)
28937            CALL DPWRST('XXX','BUG ')
28938            WRITE(ICOUT,3003)IHRIGH,IHRIG2
28939 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
28940     1             A4,A4,')')
28941            CALL DPWRST('XXX','BUG ')
28942            WRITE(ICOUT,3005)
28943 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
28944            CALL DPWRST('XXX','BUG ')
28945            IERROR='YES'
28946            GOTO9000
28947          ELSE
28948            ISTRT1=IVSTAR(I4)
28949            ISTOP1=IVSTOP(I4)
28950            NLEN1=ISTOP1-ISTRT1+1
28951C
28952            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STNW')THEN
28953              WRITE(ICOUT,999)
28954              CALL DPWRST('XXX','BUG ')
28955              WRITE(ICOUT,3011)I4,ISTRT1,ISTOP1,NLEN1
28956 3011         FORMAT('I4,ISTRT1,ISTOP1,NLEN1 = ',4I8)
28957              CALL DPWRST('XXX','BUG ')
28958            ENDIF
28959C
28960            GOTO3099
28961          ENDIF
28962        ENDIF
28963 3000 CONTINUE
28964C
28965      WRITE(ICOUT,999)
28966      CALL DPWRST('XXX','BUG ')
28967      WRITE(ICOUT,2001)
28968      CALL DPWRST('XXX','BUG ')
28969      WRITE(ICOUT,3003)IHRIGH,IHRIG2
28970      CALL DPWRST('XXX','BUG ')
28971      WRITE(ICOUT,3015)
28972 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
28973      CALL DPWRST('XXX','BUG ')
28974      IERROR='YES'
28975      GOTO9000
28976C
28977 3099 CONTINUE
28978C
28979C               *****************************************************
28980C               **  STEP 4--                                       **
28981C               **  FIND THE NUMBER OF WORDS                       **
28982C               *****************************************************
28983C
28984      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNW')THEN
28985        ISTEPN='4'
28986        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28987        WRITE(ICOUT,4012)ISTRT1,ISTOP1,NLEN1
28988 4012   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
28989        CALL DPWRST('XXX','BUG ')
28990        WRITE(ICOUT,4013)ICASEL
28991 4013   FORMAT('ICASEL = ',A4)
28992        CALL DPWRST('XXX','BUG ')
28993      ENDIF
28994C
28995C     NOW EXTRACT NUMBER OF WORDS
28996C
28997C     WORD BOUNDARIES ARE DEFINED BY SPACES (NON-PRINTING CHARACTERS
28998C     ARE DEFINED AS SPACES).
28999C
29000C     STEP 1: DETERMINE START/STOP POSITION OF WORD
29001C
29002      NWORD=0
29003      IFLAG=0
29004C
29005      DO4100I=ISTRT1,ISTOP1
29006        IPOS=I
29007        IXTEMP=ICHAR(IFUNC(IPOS)(1:1))
29008C
29009        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STNW')THEN
29010          WRITE(ICOUT,4111)I,IFLAG,NWORD,IPOS,IXTEMP,IFUNC(IPOS)
29011 4111     FORMAT('I,IFLAG,NWORD,IPOS,IXTEMP,IFUNC(IPOS) = ',5I8,2X,A4)
29012          CALL DPWRST('XXX','BUG ')
29013        ENDIF
29014C
29015C       CASE 1: WORD BOUNDARY DETECTED
29016C
29017        IF(IXTEMP.LE.32 .OR. IXTEMP.GE.127)THEN
29018          IF(IFLAG.EQ.1)THEN
29019            IFLAG=0
29020          ELSEIF(IFLAG.EQ.0)THEN
29021            CONTINUE
29022          ENDIF
29023C
29024C       CASE 2: NOT A WORD BOUNDARY DETECTED.  IS THIS START OF
29025C               NEW WORD OR CONTINUATION OF CURRENT WORD?
29026C
29027        ELSE
29028          IF(IFLAG.EQ.0)THEN
29029            ISTART=I
29030            ISTOP=I
29031            NWORD=NWORD+1
29032            IFLAG=1
29033          ELSEIF(IFLAG.EQ.1)THEN
29034            ISTOP=I
29035          ENDIF
29036        ENDIF
29037 4100 CONTINUE
29038C
29039C               *********************************
29040C               **  STEP 5--                   **
29041C               **  SAVE PARAMETER (NWORD)     **
29042C               *********************************
29043C
29044C
29045      IF(ICASEL.EQ.'PARA')THEN
29046C
29047        ISTEPN='5'
29048        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STNW')
29049     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29050C
29051        IHNAME(ILISTL)=IHLEFT
29052        IHNAM2(ILISTL)=IHLEF2
29053        IUSE(ILISTL)='P'
29054        VALUE(ILISTL)=REAL(NWORD)
29055        IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
29056        IN(ILISTL)=1
29057        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
29058C
29059        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
29060          WRITE(ICOUT,999)
29061          CALL DPWRST('XXX','BUG ')
29062          WRITE(ICOUT,5011)IHLEFT,IHLEF2,NWORD
290635011      FORMAT('NUMBER OF WORDS IN STRING ',A4,A4,'  = ',I8)
29064          CALL DPWRST('XXX','BUG ')
29065          WRITE(ICOUT,999)
29066          CALL DPWRST('XXX','BUG ')
29067        ENDIF
29068      ENDIF
29069C
29070C               ****************
29071C               **  STEP 90-- **
29072C               **  EXIT.     **
29073C               ****************
29074C
29075 9000 CONTINUE
29076      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STNW')THEN
29077        WRITE(ICOUT,999)
29078        CALL DPWRST('XXX','BUG ')
29079        WRITE(ICOUT,9011)
29080 9011   FORMAT('***** AT THE END       OF DPSTNW--')
29081        CALL DPWRST('XXX','BUG ')
29082        WRITE(ICOUT,9013)NUMNAM
29083 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
29084        CALL DPWRST('XXX','BUG ')
29085        DO9015I=1,NUMNAM
29086          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
29087     1                     IVSTAR(I),IVSTOP(I)
29088 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
29089     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
29090          CALL DPWRST('XXX','BUG ')
29091 9015   CONTINUE
29092      ENDIF
29093C
29094      RETURN
29095      END
29096      SUBROUTINE DPSTRE(IFROW1,IFROW2,IFCOL1,IFCOL2,ISKIP,INTINF,
29097     1                  IMACRO,IMACNU,IMACCS,IMALEV,IOSW,ICREAF,NCREAF,
29098     1                  ICWRIF,NCWRIF,IREARW,ICOMCH,ICOMSW,
29099     1                  IUNFOF,IUNFNR,IUNFMC,NUMRCM,
29100     1                  IFCOLL,IFCOLU,
29101     1                  IANSLO,ILOOST,ILOOLI,IREPCH,
29102     1                  IBUGS2,IBUGQ,ISUBRO,IFOUND,IERROR)
29103C
29104C     PURPOSE--PEFORM A "STREAM" READ.  THE PURPOSE OF THIS COMMAND
29105C              IS TO READ LARGE FILES, SPECIFICALLY FILES EXCEEDING
29106C              DATAPLOT'S MAXIMUM NUMBER OF ROWS, AND GENERATE VARIABLES
29107C              OR FILES THAT CAN BE PROCESSED BY DATAPLOT.
29108C
29109C              SPECIFICALLY, THE FOLLOWING FORMATS ARE SUPPORTED.
29110C
29111C              1. STREAM READ WRITE FILE.DAT X1 ... XK
29112C
29113C                 WILL READ A LINE OF "FILE.DAT" AND IMMEDIATELY WRITE
29114C                 IT TO THE FILE "FILE_FORMATTED.DAT".  THE IDEA IS THAT
29115C                 THE WRITE WILL USE A FORMATTED WRITE COMMAND FOR
29116C                 THE OUTPUT FILE.
29117C
29118C                 THE MOTIVATION FOR THIS IS FOR LARGE DATA SETS,
29119C                 POSSIBLY EXCEEDING DATAPLOT LIMITS, TO BE ABLE TO
29120C                 CREATE A FORMATTED DATA FILE WITHOUT EVER READING
29121C                 THE FULL DATA SET INTO DATAPLOT.
29122C
29123C                 THE FORMATTED VERSION OF THE FILE ALLOWS FASTER
29124C                 INPUT VIA THE SET READ FORMAT COMMAND AND ALSO
29125C                 ALLOWS SELECTIVE SELECTION OF VARIABLES TO INPUT.
29126C
29127C              2. STREAM READ GROUP STATISTIC <STAT> FILE.DAT X1 ... XK
29128C
29129C                 WHERE <STAT> IS ONE OF DATAPLOT'S SUPPORTED
29130C                 UNIVARIATE STATISTICS.
29131C
29132C                 THIS VERSION WILL READ A USER-SPECIFIED NUMBER
29133C                 OF ROWS AT A TIME.  IT WILL THEN REPLACE THOSE
29134C                 ROWS WITH THE SPECIFIED STATISTIC.  FOR EXAMPLE,
29135C                 IT WILL READ 1,000 ROWS, COMPUTE THE MEAN FOR
29136C                 THOSE 1,000 ROWS, SAVE THE MEAN VALUE, THEN
29137C                 REPEAT FOR THE NEXT 1,000 ROWS.  SO THE ORIGINAL
29138C                 DATA WILL BE REPLACED WITH THE MEANS OF FIXED
29139C                 INTERVALS OF THE DATA.
29140C
29141C                 TO SPECIFY THE NUMBER OF ROWS TO READ AT A TIME,
29142C                 ENTER
29143C
29144C                     SET STREAM READ SIZE <VALUE>
29145C
29146C                 ALTERNATIVELY, YOU CAN SPECIFY ONE OF THE VARIABLES
29147C                 TO DEFINE THE GROUP (I.E., WHEN THE VALUE OF THE
29148C                 SPECIFIED VARIABLE CHANGES, THIS DENOTES THE START
29149C                 OF A NEW GROUP).  FOR THIS OPTION, ENTER
29150C
29151C                     SET STREAM READ GROUP VARIBLE <VAR-NAME>
29152C
29153C                 THIS CAPABILITY IS MOTIVATED BY THE DESIRE TO
29154C                 HANDLE LARGE DATA SETS THAT MAY EXCEED DATAPLOT'S
29155C                 STORAGE LIMITS.  THIS COMMAND ALLOWS YOU TO
29156C                 COMPUTE SOME BASIC STATISTICS (MEAN, MIN, MAX,
29157C                 SD, AND SO ON) FOR SLICES OF THE DATA.  OFTEN,
29158C                 SOME USEFUL EXPLORATORY ANALYSIS CAN BE PERFORMED
29159C                 ON THIS COMPRESSED DATA.
29160C
29161C                 NOTE THAT THIS IS NOT A TRUE CROSS-TABULATION AS IT
29162C                 ASSUMES THE VALUES FOR THE GROUP-ID VARIABLE ARE
29163C                 CONTIGUOUS.
29164C
29165C              3. STREAM READ DEFAULT STATISTICS FILE.DAT X1 ... XK
29166C
29167C                 THIS IS A VARIANT ON 2) THAT ALLOWS A DEFAULT SET
29168C                 OF STATISTICS TO BE COMPUTED ON A SINGLE PASS OF
29169C                 THE DATA.  THE FOLLOWING STATISTICS ARE COMPUTED:
29170C
29171C                    1. VALUE OF LAST ROW OF GROUP
29172C                    2. GROUP-ID
29173C                    3. SIZE
29174C                    4. MINIMUM
29175C                    5. MAXIMUM
29176C                    6. MEAN
29177C                    7. STANDARD DEVIATION
29178C                    8. SKEWNESS
29179C                    9. KURTOSIS
29180C                   10. MEDIAN
29181C                   11. INTERQUARTILE RANGE
29182C                   12. RANGE
29183C                   13. AUTOCORRELATION
29184C                   14. LOWER QUARTILE
29185C                   15. UPPER QUARTILE
29186C                   16. 0.01 QUANTILE
29187C                   17. 0.05 QUANTILE
29188C                   18. 0.10 QUANTILE
29189C                   19. 0.25 QUANTILE
29190C                   20. 0.75 QUANTILE
29191C                   21. 0.90 QUANTILE
29192C                   22. 0.95 QUANTILE
29193C                   23. 0.99 QUANTILE
29194C
29195C                 IN THIS CASE, A TAG VARIABLE (TAGSTAT) WILL BE
29196C                 CREATED THAT DEFINES THE STATISTIC).
29197C
29198C              4. STREAM READ FULL STATISTIC FILE.DAT X1 ... XK
29199C
29200C                 THIS SYNTAX WILL COMPUTE THE FOLLOWING STATISTICS
29201C                 USING A 1-PASS ALGORITHM FOR ALL OF THE DATA:
29202C
29203C                    1. COUNT
29204C                    2. MINIMUM
29205C                    3. MAXIMUM
29206C                    4. MEAN
29207C                    5. STANDARD DEVIATION
29208C                    6. SKEWNESS
29209C                    7. KURTOSIS
29210C                    8. RANGE
29211C                    9. AUTOCORRELATION (NOT AVAILABLE YET)
29212C
29213C                 FOLLOWING DEPEND ON ONE-PASS APPROXIMATION
29214C                 FOR PERCENTILES.  THIS IS STILL BEING INVESTIGATED,
29215C                 SO FOLLOWING NOT YET AVAILABLE.
29216C
29217C                   10. MEDIAN
29218C                   11. INTERQUARTILE RANGE
29219C                   12. 0.01 QUANTILE
29220C                   13. 0.05 QUANTILE
29221C                   14. 0.10 QUANTILE
29222C                   15. 0.25 QUANTILE
29223C                   16. 0.75 QUANTILE
29224C                   17. 0.90 QUANTILE
29225C                   18. 0.95 QUANTILE
29226C                   19. 0.99 QUANTILE
29227C
29228C                 A TAG VARIABLE WILL BE AUTOMATICALLY CREATED
29229C                 TO IDENTIFY THE STATISTIC.
29230C
29231C              5. STREAM READ PERCENTILES FILE.DAT X1 ... XK
29232C                 STREAM READ CROSS TABULATE PERCENTILES FILE.DAT X1 ...  XK
29233C
29234C                 THIS SYNTAX WILL REPLACE THE FULL VARIABLE WITH
29235C                 PERCENTILES OF THE DATA.  NOTE THAT THE PERCENTILE
29236C                 WILL BE APPROXIMATE (THE P^2 ALGORITHM IS USED).
29237C
29238C              6. STREAM READ CROSS TABULATE FILE.DAT Y1 ... YK
29239C
29240C                 THIS SYNTAX WILL COMPUTE THE ONE-PASS STATISTICS
29241C                 FOR THE CROSS-TABULATION.
29242C
29243C              7. STREAM READ CORRELATION           FILE.DAT X1 ... XK
29244C                 STREAM READ COVARIANCE            FILE.DAT X1 ... XK
29245C                 STREAM READ DISTANCE              FILE.DAT X1 ... XK
29246C                 STREAM READ MANHATTAN DISTANCE    FILE.DAT X1 ... XK
29247C                 STREAM READ CHEBYCHEV DISTANCE    FILE.DAT X1 ... XK
29248C                 STREAM READ COSINE DISTANCE       FILE.DAT X1 ... XK
29249C                 STREAM READ COSINE SIMILARITY     FILE.DAT X1 ... XK
29250C                 STREAM READ ANGULAR COSINE DISTANCE   FILE.DAT X1 ... XK
29251C                 STREAM READ ANGULAR COSINE SIMILARITY FILE.DAT X1 ... XK
29252C                 STREAM READ JACCARD SIMILARITY    FILE.DAT X1 ... XK
29253C                 STREAM READ JACCARD DISTANCE      FILE.DAT X1 ... XK
29254C                 STREAM READ HAMMING DISTANCE      FILE.DAT X1 ... XK
29255C                 STREAM READ CANBERRA DISTANCE     FILE.DAT X1 ... XK
29256C
29257C                 THIS SYNTAX WILL COMPUTE A CORRELATION MATRIX (OR
29258C                 A DISTANCE MATRIX) OF THE VARIABLES.  ANY PAIRS CONTAINING
29259C                 MISSING VALUES WILL BE OMITTED.
29260C
29261C                 YOU CAN USE THE COMMAND
29262C
29263C                     SET STREAM READ VARIABLE TYPE <VAR-NAME>
29264C
29265C                 WHERE <VAR-NAME> SPECIFIES A VARIABLE WHICH IDENTIFIES
29266C                 COLUMNS AS RESPONSE VARIABLES OR CATEGORICAL VARIABLES.
29267C                 SPECIFICALLY, IF ROW I OF THE THIS VARIABLE IS 0, THEN
29268C                 COLUMN I IS A CATEGORICAL VARIABLE AND IF ROW I IS 1,
29269C                 THEN COLUMN I IS A RESPONSE VARIABLE.  ONLY RESPONSE
29270C                 VARIABLES WILL BE INCLUDED IN THE CORRELATION MATRIX.
29271C
29272C              8. STREAM READ CROSS TABULATE CORRELATION           FILE.DAT X1 ... XK
29273C                 STREAM READ CROSS TABULATE COVARIANCE            FILE.DAT X1 ... XK
29274C                 STREAM READ CROSS TABULATE DISTANCE              FILE.DAT X1 ... XK
29275C                 STREAM READ CROSS TABULATE MANHATTAN DISTANCE    FILE.DAT X1 ... XK
29276C                 STREAM READ CROSS TABULATE CHEBYCHEV DISTANCE    FILE.DAT X1 ... XK
29277C                 STREAM READ CROSS TABULATE COSINE DISTANCE       FILE.DAT X1 ... XK
29278C                 STREAM READ CROSS TABULATE COSINE SIMILARITY     FILE.DAT X1 ... XK
29279C                 STREAM READ CROSS TABULATE ANGULAR COSINE DISTANCE   FILE.DAT X1 ... XK
29280C                 STREAM READ CROSS TABULATE ANGULAR COSINE SIMILARITY FILE.DAT X1 ... XK
29281C                 STREAM READ CROSS TABULATE JACCARD SIMILARITY    FILE.DAT X1 ... XK
29282C                 STREAM READ CROSS TABULATE JACCARD DISTANCE      FILE.DAT X1 ... XK
29283C                 STREAM READ CROSS TABULATE HAMMING DISTANCE      FILE.DAT X1 ... XK
29284C                 STREAM READ CROSS TABULATE CANBERRA DISTANCE     FILE.DAT X1 ... XK
29285C
29286C                 THIS IS A COMBINATION OF SYNTAX 6 AND SYNTAX 7.  THAT
29287C                 IS, WE COMPUTE VARIOUS DISTANCE/SIMILARITY MEASURES,
29288C                 BUT WE DO THIS FOR CROSS-TABULATIONS INSTEAD OF FOR
29289C                 THE FULL DATA SET.
29290C
29291C              NOTE THAT THIS VERSION OF THE READ HAS THE FOLLOWING
29292C              LIMITATIONS:
29293C
29294C              1. FUNCTIONS/STRINGS, PARAMETERS, MATRICES, AND
29295C                 IMAGES ARE NOT SUPPORTED.  ALSO, READING FROM THE
29296C                 CLIPBOARD IS NOT SUPPORTED.
29297C
29298C              2. THIS FORM OF THE READ IS RESTRICTED TO FILES (I.E.,
29299C                 READING FROM THE TERMINAL NOT SUPPORTED).
29300C
29301C              3. AUTOMATIC NAME DETECTION IS NOT SUPPORTED.
29302C
29303C              4. CHARACTER DATA IS NOT SUPPORTED (YOU CAN IGNORE
29304C                 FIELDS, BUT YOU CANNOT CREATE CHARACTER FIELDS).
29305C
29306C                 2018/07: CHARACTER VARIABLES WILL NOW BE INTERPERTED
29307C                          AS "CATEGORICAL" VARIABLES.  NOTE THAT
29308C                          THE CATEGORIES ARE CODED AS 1, 2, ... IN
29309C                          THE ORDER THEY ARE DETECTED IN THE FILE.
29310C
29311C              5. UNFORMATTED READ (BINARY FILE) NOT SUPPORTED.
29312C
29313C              6. SUBSET/EXCEPT/FOR CLAUSES ARE NOT SUPPORTED.
29314C
29315C     ASSUMPTION--THE INPUT  FILE ALREADY EXISTS; (THAT IS, DATAPLOT
29316C                 WILL AUTOMATICALLY OPEN THE FILE
29317C                 VIA (ON THE UNIVAC 1108), BY AN @ASG,AX ...)
29318C                 BUT WILL NOT AUTOMATICALLY CREATE THE FILE
29319C                 VIA (ON THE UNIVAC 1108), BY AN @ASG,UP ...))
29320C     ASSUMPTION--THE COMPUTER SYSTEM IS SUCH THAT EQUATING THE FILE NAME
29321C                 TO THE FORTRAN NUMERIC DESIGNATION OF 31 (OR HOWEVER
29322C                 THE VARIABLE  IREANU  IS DEFINED IN INITFO) IS
29323C                 PERMISSIBLE.
29324C     WRITTEN BY--ALAN HECKERT
29325C                 STATISTICAL ENGINEERING DIVISION
29326C                 INFORMATION TECHNOLOGY LABORATORY
29327C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29328C                 GAITHERSBURG, MD 20899-8980
29329C                 PHONE--301-975-2899
29330C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29331C           OF THE NATIONAL BUREAU OF STANDARDS.
29332C     LANGUAGE--ANSI FORTRAN (1977)
29333C     VERSION NUMBER--2016/7
29334C     ORIGINAL VERSION--JULY      2016.
29335C     UPDATED         --JULY      2018. INTERPRERT CHARACTER VARIABLES
29336C                                       AS CATEGORICAL NUMERIC VARIABLES
29337C                                       (WRITE AND CROSS-TAB CASES)
29338C     UPDATED         --JULY      2018. SUPPORT FOR CROSS TABULATION CASE
29339C     UPDATED         --JULY      2018. WHEN COMPUTE STATISTICS, OMIT
29340C                                       MISSING VALUES
29341C     UPDATED         --JULY      2018. OPTION TO AUTOMATICALLY CREATE
29342C                                       GROUP LABELS FROM CHARACTER DATA
29343C     UPDATED         --JULY      2018. IF A ROW LABEL COLUMN HAS BEEN
29344C                                       SPECIFIED, THEN IGNORE THIS
29345C                                       COLUMN
29346C     UPDATED         --JULY      2018. SUPPORT STREAM READ EUCLIDEAN DISTANCE
29347C     UPDATED         --JULY      2018. SUPPORT STREAM READ MANHATTAN DISTANCE
29348C     UPDATED         --JULY      2018. SUPPORT STREAM READ CHEBYCHEV DISTANCE
29349C     UPDATED         --JULY      2018. SUPPORT STREAM READ COSINE DISTANCE
29350C     UPDATED         --JULY      2018. SUPPORT STREAM READ COSINE SIMILARITY
29351C     UPDATED         --JULY      2018. SUPPORT STREAM READ ANGULAR COSINE DISTANCE
29352C     UPDATED         --JULY      2018. SUPPORT STREAM READ ANGULAR COSINE SIMILARITY
29353C     UPDATED         --JULY      2018. SUPPORT STREAM READ COVARIANCE
29354C     UPDATED         --JULY      2018. SUPPORT STREAM READ CORRELATION
29355C     UPDATED         --AUGUST    2018. SUPPORT STREAM READ CROSS
29356C                                               TABULATE .. DISTANCE
29357C     UPDATED         --AUGUST    2018. SUPPORT STREAM READ CROSS
29358C                                               TABULATE .. CORRELATION
29359C     UPDATED         --AUGUST    2018. SUPPORT STREAM READ CROSS
29360C                                               TABULATE .. COVARIANCE
29361C     UPDATED         --AUGUST    2018. SUPPORT STREAM READ HAMMING DISTANCE
29362C     UPDATED         --AUGUST    2018. SUPPORT STREAM READ CANBERRA DISTANCE
29363C     UPDATED         --AUGUST    2018. SUPPORT STREAM READ PERCENTILES
29364C     UPDATED         --AUGUST    2018. SUPPORT STREAM READ CROSS
29365C                                               TABULATE PERCENTILES
29366C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE
29367C     UPDATED         --SEPTEMBER 2019. CALL LIST TO DPREAL
29368C
29369C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29370C
29371      CHARACTER*4 IMACRO
29372      CHARACTER*12 IMACCS
29373      CHARACTER*4 ILOOST
29374      CHARACTER*1 IREPCH
29375C
29376      CHARACTER*80 ICREAF
29377      CHARACTER*80 ICWRIF
29378C
29379      CHARACTER*4 IOSW
29380      CHARACTER*4 IREARW
29381      CHARACTER*4 IGRPA2
29382      CHARACTER*4 ICFLAG
29383      CHARACTER*4 IBUGS2
29384      CHARACTER*4 IBUGQ
29385      CHARACTER*4 ISUBRO
29386      CHARACTER*4 IFOUND
29387      CHARACTER*4 IERROR
29388      CHARACTER*4 ICASEQ
29389      CHARACTER*4 ICASEA
29390      CHARACTER*4 IEND
29391      CHARACTER*4 IH1
29392      CHARACTER*4 IH2
29393      CHARACTER*4 ISUBN1
29394      CHARACTER*4 ISUBN2
29395      CHARACTER*4 ISTEPN
29396      CHARACTER*4 IFMFLG
29397      CHARACTER*4 ICASRE
29398      CHARACTER*4 ICASR2
29399      CHARACTER*4 IOFILE
29400      CHARACTER*4 IOTERM
29401      CHARACTER*4 IFILQ2
29402      CHARACTER*4 IFOUN7
29403      CHARACTER*4 ICASS7
29404      CHARACTER*4 IWRITE
29405      CHARACTER*10 IFORMT
29406      CHARACTER*4 ICOMCH
29407      CHARACTER*4 ICOMSW
29408      CHARACTER*4 LINETY
29409      CHARACTER*4 IHWUSE
29410      CHARACTER*4 MESSAG
29411      CHARACTER*4 IH41
29412      CHARACTER*4 IH42
29413C
29414      INCLUDE 'DPCOPA.INC'
29415C
29416CCCCC CHARACTER*80 IFILE
29417      CHARACTER (LEN=MAXFNC) :: IFILE
29418      CHARACTER*12 ISTAT
29419      CHARACTER*12 IFORM
29420      CHARACTER*12 IACCES
29421      CHARACTER*12 IPROT
29422      CHARACTER*12 ICURST
29423      CHARACTER*4 IENDFI
29424      CHARACTER*4 IREWIN
29425      CHARACTER*4 ISUBN0
29426      CHARACTER*4 IERRFI
29427C
29428CCCCC CHARACTER*80 IFILE2
29429      CHARACTER (LEN=MAXFNC) :: IFILE2
29430      CHARACTER*12 ISTAT2
29431      CHARACTER*12 IFORM2
29432      CHARACTER*12 IACCE2
29433      CHARACTER*12 IPROT2
29434      CHARACTER*12 ICURS2
29435C
29436      CHARACTER*60 ISTANM
29437      CHARACTER*4  ISTADF
29438CCCCC CHARACTER*255 ICANS
29439      CHARACTER (LEN=MAXSTR) :: ICANS
29440      CHARACTER*4 ICASTO
29441      CHARACTER*80 IAJUNK
29442C
29443      INCLUDE 'DPCOZZ.INC'
29444      INCLUDE 'DPCOZ3.INC'
29445      INCLUDE 'DPCOZD.INC'
29446      INCLUDE 'DPCOZI.INC'
29447      INCLUDE 'DPCOZC.INC'
29448C
29449      PARAMETER(MAXRDV=2048)
29450      PARAMETER(MAXCHV=20)
29451      PARAMETER(NDEFST=16)
29452      PARAMETER(NQUAN=6)
29453      PARAMETER(MAXCEL=10000)
29454C
29455      INTEGER IADE(200)
29456      INTEGER IFCOLL(*)
29457      INTEGER IFCOLU(*)
29458      INTEGER ITYPE(MAXRDV)
29459      INTEGER NIV(MAXRDV)
29460      INTEGER IEN(MAXRDV)
29461      INTEGER IECOL2(MAXRDV)
29462      INTEGER IXCATN(MAXCHV)
29463      INTEGER IECOLC(MAXCHV)
29464      INTEGER IENC(MAXCHV)
29465      DIMENSION X0CAT(MAXCHV)
29466      DIMENSION ICTLST(MAXRDV)
29467C
29468      INTEGER ITEMP1(MAXOBV)
29469      INTEGER ITEMP2(MAXOBV)
29470      INTEGER ITEMP3(MAXOBV)
29471      INTEGER ITEMP4(MAXOBV)
29472      INTEGER ITEMP5(MAXOBV)
29473      INTEGER ITEMP6(MAXOBV)
29474      INTEGER IVTYPE(MAXOBV)
29475C
29476      DOUBLE PRECISION DTEMP1(MAXOBV)
29477      DOUBLE PRECISION DTEMP2(MAXOBV)
29478      DOUBLE PRECISION DTEMP3(MAXOBV)
29479C
29480      DOUBLE PRECISION DVAL
29481      DOUBLE PRECISION DMEAN
29482      DOUBLE PRECISION DSD
29483      DOUBLE PRECISION DVALM1
29484      DOUBLE PRECISION DVALS1
29485      DOUBLE PRECISION DVALSO
29486      DOUBLE PRECISION DTERM1
29487      DOUBLE PRECISION DTERM2
29488      DOUBLE PRECISION DTERM3
29489      DOUBLE PRECISION DTERM4
29490      DOUBLE PRECISION DELTA
29491      DOUBLE PRECISION DELTAN
29492      DOUBLE PRECISION DELTN2
29493      DOUBLE PRECISION DM2
29494      DOUBLE PRECISION DM3
29495      DOUBLE PRECISION DM4
29496      DOUBLE PRECISION DSKEW
29497      DOUBLE PRECISION DKURT
29498      DOUBLE PRECISION DNNEW
29499C
29500      REAL TEMP1(MAXOBV)
29501      REAL TEMP2(MAXOBV)
29502      REAL TEMP3(MAXOBV)
29503      REAL TEMP4(MAXOBV)
29504      REAL TEMP5(MAXOBV)
29505      REAL TEMP6(MAXOBV)
29506      REAL XQ(NQUAN)
29507C
29508      INTEGER CELLID(MAXCEL)
29509      INTEGER CELLCN(MAXCEL)
29510      REAL CELLX1(MAXCEL)
29511      REAL CELLX2(MAXCEL)
29512      REAL CELLX3(MAXCEL)
29513      REAL CELLX4(MAXCEL)
29514C
29515      CHARACTER*4 IVRLST
29516      CHARACTER*4 IECASE(MAXRDV)
29517      CHARACTER*4 IVLIST(MAXRDV)
29518      CHARACTER*4 IVLIS2(MAXRDV)
29519      CHARACTER*4 ICLIST(MAXRDV)
29520      CHARACTER*4 ICLIS2(MAXRDV)
29521      CHARACTER*4 IASAVE(MAXRDV)
29522C
29523      CHARACTER*4 JVNAM1(MAXRDV)
29524      CHARACTER*4 JVNAM2(MAXRDV)
29525      CHARACTER*4 JENAM1(MAXRDV)
29526      CHARACTER*4 JENAM2(MAXRDV)
29527C
29528      CHARACTER*24 IXC(MAXCHV)
29529      CHARACTER*24 IXCAT(1000,MAXCHV)
29530      CHARACTER*4 ISTOR1(MAXRCL)
29531      CHARACTER*4 ISTOR2(MAXRCL)
29532      CHARACTER*4 ISTOR3(MAXRCL)
29533      CHARACTER*4 IB(MAXRCL)
29534C
29535      CHARACTER*4 LISTST(NDEFST)
29536C
29537      CHARACTER*4 IANSLO(MAXCIL,MAXLIL)
29538C
29539C-----COMMON----------------------------------------------------------
29540C
29541      INCLUDE 'DPCOHK.INC'
29542      INCLUDE 'DPCODA.INC'
29543      INCLUDE 'DPCOFO.INC'
29544      INCLUDE 'DPCOF2.INC'
29545      INCLUDE 'DPCOHO.INC'
29546      INCLUDE 'DPCOST.INC'
29547      INCLUDE 'DPCOMC.INC'
29548C
29549      DIMENSION XSCRT(3*MAXOBW)
29550      DIMENSION X0(MAXRDV)
29551      DIMENSION X02(MAXRDV)
29552C
29553      EQUIVALENCE (G3RBAG(KGARB1),TEMP1(1))
29554      EQUIVALENCE (G3RBAG(KGARB2),TEMP2(1))
29555      EQUIVALENCE (G3RBAG(KGARB3),TEMP3(1))
29556      EQUIVALENCE (G3RBAG(KGARB4),TEMP4(1))
29557      EQUIVALENCE (G3RBAG(KGARB5),TEMP5(1))
29558      EQUIVALENCE (G3RBAG(KGARB6),TEMP6(1))
29559C
29560      EQUIVALENCE (GARBAG(IGARB1),X0(1))
29561      EQUIVALENCE (GARBAG(IGARB1+50000),X02(1))
29562      EQUIVALENCE (GARBAG(IGARB2),CELLX1(1))
29563      EQUIVALENCE (GARBAG(IGARB2+2*MAXCEL),CELLX2(1))
29564      EQUIVALENCE (GARBAG(IGARB2+4*MAXCEL),CELLX3(1))
29565      EQUIVALENCE (GARBAG(IGARB2+6*MAXCEL),CELLX4(1))
29566      EQUIVALENCE (GARBAG(IGARB3),XSCRT(1))
29567C
29568      EQUIVALENCE (IGARBG(IIGAR1),ITYPE(1))
29569      EQUIVALENCE (IGARBG(IIGAR1+5000),NIV(1))
29570      EQUIVALENCE (IGARBG(IIGAR1+10000),IEN(1))
29571      EQUIVALENCE (IGARBG(IIGAR1+15000),IECOL2(1))
29572      EQUIVALENCE (IGARBG(IIGAR1+20000),IADE(1))
29573      EQUIVALENCE (IGARBG(IIGAR1+25000),IXCATN(1))
29574      EQUIVALENCE (IGARBG(IIGAR1+30000),IECOLC(1))
29575      EQUIVALENCE (IGARBG(IIGAR1+35000),IENC(1))
29576      EQUIVALENCE (IGARBG(IIGAR1+40000),ICTLST(1))
29577      EQUIVALENCE (IGARBG(IIGAR2),ITEMP1(1))
29578      EQUIVALENCE (IGARBG(IIGAR3),ITEMP2(1))
29579      EQUIVALENCE (IGARBG(IIGAR4),ITEMP3(1))
29580      EQUIVALENCE (IGARBG(IIGAR5),ITEMP4(1))
29581      EQUIVALENCE (IGARBG(IIGAR6),ITEMP5(1))
29582      EQUIVALENCE (IGARBG(IIGAR7),ITEMP6(1))
29583      EQUIVALENCE (IGARBG(IIGAR8),IVTYPE(1))
29584      EQUIVALENCE (IGARBG(IIGAR9),CELLID(1))
29585      EQUIVALENCE (IGARBG(IIGR10),CELLCN(1))
29586C
29587      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
29588      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
29589      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
29590C
29591      EQUIVALENCE (CGARBG(1),IECASE(1))
29592      EQUIVALENCE (CGARBG(20000),IVLIST(1))
29593      EQUIVALENCE (CGARBG(40000),IVLIS2(1))
29594      EQUIVALENCE (CGARBG(60000),IASAVE(1))
29595      EQUIVALENCE (CGARBG(80000),ICLIST(1))
29596      EQUIVALENCE (CGARBG(100000),ICLIS2(1))
29597      EQUIVALENCE (CGARBG(120000),JVNAM1(1))
29598      EQUIVALENCE (CGARBG(220000),JENAM1(1))
29599      EQUIVALENCE (CGARBG(240000),JVNAM2(1))
29600      EQUIVALENCE (CGARBG(340000),JENAM2(1))
29601      EQUIVALENCE (CGARBG(360000),ISTOR1(1))
29602      EQUIVALENCE (CGARBG(380000),ISTOR2(1))
29603      EQUIVALENCE (CGARBG(400000),ISTOR3(1))
29604      EQUIVALENCE (CGARBG(420000),IB(1))
29605      EQUIVALENCE (CGARBG(600000),IXC(1))
29606      EQUIVALENCE (CGARBG(800000),IXCAT(1,1))
29607C
29608C-----COMMON VARIABLES (GENERAL)--------------------------------------
29609C
29610      INCLUDE 'DPCOP2.INC'
29611C
29612      DATA LISTST/'VALU','SEQU','NUMB','MINI','MAXI','MEAN','SD  ',
29613     1            'SKEW','KURT','MEDI','IQRA','RANG','AUCR','LOWQ',
29614     1            'UPPQ','QUAN'/
29615C
29616      DATA XQ/0.01, 0.05, 0.10, 0.90, 0.95, 0.99/
29617      DATA PI/3.1415926535 8979323846 2643383279 503/
29618C
29619C-----START POINT-----------------------------------------------------
29620C
29621      ISUBN1='DPST'
29622      ISUBN2='RE  '
29623      IFOUND='YES'
29624      IERROR='NO'
29625      ICASRE='-999'
29626      ICASR2='-999'
29627      IOFILE='-999'
29628      IOTERM='-999'
29629      IFILQ2=IFILQU
29630      IFILQU='ON'
29631      IVRLST='YES'
29632      IGRPA2=IGRPAU
29633C
29634      MAXCP1=MAXCOL+1
29635      MAXCP2=MAXCOL+2
29636      MAXCP3=MAXCOL+3
29637      MAXCP4=MAXCOL+4
29638      MAXCP5=MAXCOL+5
29639      MAXCP6=MAXCOL+6
29640      IMNVAR=-1
29641      IMXVAR=-1
29642      NGRP=0
29643      NCELL=0
29644      ICELL=0
29645      ILAST=0
29646      IGRP1=0
29647      J=0
29648      JM1=0
29649      AVAL=0.0
29650      IFLAGC=0
29651      ICNT2=0
29652      NINT=0
29653      IIDX1=0
29654      IFLGOU=0
29655C
29656      DO15I=1,MAXRDV
29657        IASAVE(I)='    '
29658        IVLIST(I)='    '
29659        IVLIS2(I)='    '
29660        ITYPE(I)=0
29661        JVNAM1(I)='    '
29662        JVNAM2(I)='    '
29663   15 CONTINUE
29664      DO13I=1,MAXCHV
29665        IXC(I)=' '
29666        ICLIST(I)=' '
29667        ICLIS2(I)=' '
29668        IECOLC(I)=0
29669        IENC(I)=0
29670        DO14J=1,1000
29671          IXCAT(J,I)=' '
29672   14   CONTINUE
29673        IXCATN(I)=0
29674        X0CAT(I)=0.0
29675   13 CONTINUE
29676      DO18I=1,MAXCEL
29677        CELLID(I)=0
29678        CELLCN(I)=0
29679        CELLX1(I)=0.0
29680        CELLX2(I)=0.0
29681        CELLX3(I)=0.0
29682        CELLX4(I)=0.0
29683   18 CONTINUE
29684C
29685       DO19I=1,3*MAXOBW
29686         XSCRT(I)=0.0
29687   19  CONTINUE
29688C
29689      IBILLI=I1MACH(9)
29690      I2=0
29691      NUMVRD=0
29692      NUMPRD=0
29693      NUMFRD=0
29694      AFROW2=IFROW2
29695      MAXN2=MAXCHF
29696      IMATC1=(-999)
29697      IMATNR=(-999)
29698      IMATNC=(-999)
29699      LINETY='-999'
29700      NCALL=0
29701      NCOLS=0
29702      NROWZ=0
29703      NCOLZ=0
29704      ITOTZ=0
29705      MAXV2=MAXRDV
29706C
29707      PSTAM2=PSTAMV
29708      PSTAMV=PREAMV
29709C
29710      IF(ISREGL.EQ.'ON')THEN
29711        DO22I=1,MAXGRP
29712          IF(IGRPVN(I).EQ.'        ')THEN
29713            IGRP1=I
29714            GOTO23
29715          ENDIF
29716   22   CONTINUE
29717        IGRP1=MAXGRP+1
29718   23   CONTINUE
29719      ENDIF
29720C
29721C               ***************************
29722C               **  TREAT THE READ CASE  **
29723C               ***************************
29724C
29725      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
29726        WRITE(ICOUT,999)
29727  999   FORMAT(1X)
29728        CALL DPWRST('XXX','BUG ')
29729        WRITE(ICOUT,51)
29730   51   FORMAT('***** AT THE BEGINNING OF DPSTRE--')
29731        CALL DPWRST('XXX','BUG ')
29732        WRITE(ICOUT,52)IFROW1,AFROW2,IFCOL1,IFCOL2,NUMRCM
29733   52   FORMAT('IFROW1,AFROW2,IFCOL1,IFCOL2,NUMRCM = ',I8,2X,G15.7,3I8)
29734        CALL DPWRST('XXX','BUG ')
29735        WRITE(ICOUT,54)IRD,IRD2,ISKIP,IOSW
29736   54   FORMAT('IRD,IRD2,ISKIP,IOSW = ',3I8,2X,A4)
29737        CALL DPWRST('XXX','BUG ')
29738        WRITE(ICOUT,56)IMACRO,IMACNU,IMACCS
29739   56   FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12)
29740        CALL DPWRST('XXX','BUG ')
29741        WRITE(ICOUT,63)IBUGQ,IBUGS2,ISUBRO,IERROR,IWIDTH
29742   63   FORMAT('IBUGQ,IBUGS2,ISUBRO,IERROR,IWIDTH = ',4(A4,2X),I8)
29743        CALL DPWRST('XXX','BUG ')
29744        IF(IWIDTH.GE.1)THEN
29745          WRITE(ICOUT,65)(IANSLC(I),I=1,MIN(100,IWIDTH))
29746   65     FORMAT('(IANSLC(I),I=1,IWIDTH) = ',100A1)
29747          CALL DPWRST('XXX','BUG ')
29748        ENDIF
29749        WRITE(ICOUT,72)IREANA
29750   72   FORMAT('IREANA = ',A80)
29751        CALL DPWRST('XXX','BUG ')
29752        WRITE(ICOUT,73)IREANU,IREAST,IREAFO,IREAAC,IREAFO,IREACS
29753   73   FORMAT('IREANU,IREAST,IREAFO,IREAAC,IREAFO,IREACS = ',
29754     1         I8,5(1X,A12))
29755        CALL DPWRST('XXX','BUG ')
29756        WRITE(ICOUT,82)NUMNAM,N2,MAXN2,NCREAF
29757   82   FORMAT('NUMNAM,N2,MAXN2,NCREAF = ',4I8)
29758        CALL DPWRST('XXX','BUG ')
29759        IF(NCREAF.GE.1)THEN
29760          WRITE(ICOUT,85)(ICREAF(I:I),I=1,NCREAF)
29761   85     FORMAT('(ICREAF(I:I),I=1,NCREAF) = ',80A1)
29762          CALL DPWRST('XXX','BUG ')
29763        ENDIF
29764        WRITE(ICOUT,87)IREARW,ICOMCH,ICOMSW
29765   87   FORMAT('IREARW,ICOMCH,ICOMSW = ',2(A4,2X),A4)
29766        CALL DPWRST('XXX','BUG ')
29767        WRITE(ICOUT,88)IUNFOF,IUNFNR,IUNFMC,NUMRCM
29768   88   FORMAT('IUNFOF,IUNFNR,IUNFMC,NUMRCM = ',3(A4,2X),I8)
29769        CALL DPWRST('XXX','BUG ')
29770      ENDIF
29771C
29772C               *******************************************************
29773C               **  STEP 1--                                         **
29774C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
29775C               *******************************************************
29776C
29777      ISTEPN='1'
29778      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
29779     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
29780C
29781      IF(NUMARG.LT.2)THEN
29782        WRITE(ICOUT,999)
29783        CALL DPWRST('XXX','BUG ')
29784        WRITE(ICOUT,211)
29785        CALL DPWRST('XXX','BUG ')
29786        WRITE(ICOUT,111)
29787  111   FORMAT('      NO ARGUMENTS GIVEN FOR THE COMMAND.')
29788        CALL DPWRST('XXX','BUG ')
29789        IERROR='YES'
29790        GOTO8800
29791      ENDIF
29792C
29793C               *****************************************
29794C               **  STEP 1B--                          **
29795C               **  DETERMINE THE TYPE OF READ CASE--  **
29796C               **     1) VARIABLE                     **
29797C               *****************************************
29798C
29799      ICASRE='VARI'
29800      IF(ICOM.NE.'STRE')GOTO9000
29801      IF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'WRIT')THEN
29802        ICASRE='WRIT'
29803        IWORD=4
29804      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'GROU'.AND.
29805     1       IHARG(3).EQ.'STAT')THEN
29806        ICASRE='GSTA'
29807        JMIN=4
29808        JMAX=MIN(NUMARG,JMIN+6)
29809        CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
29810     1              ICASS7,ISTANM,ISTANR,ISTADF,IFOUN7,ILOCV,
29811     1              ISUBRO,IBUGS2,IERROR)
29812C
29813        IF(IFOUN7.EQ.'NO')THEN
29814          WRITE(ICOUT,999)
29815          CALL DPWRST('XXX','BUG ')
29816          WRITE(ICOUT,211)
29817          CALL DPWRST('XXX','BUG ')
29818          WRITE(ICOUT,135)
29819  135     FORMAT('      THE REQUESTED STATISTIC WAS NOT FOUND.')
29820          CALL DPWRST('XXX','BUG ')
29821          IERROR='YES'
29822          GOTO9000
29823        ELSEIF(ISTANR.GT.1)THEN
29824          WRITE(ICOUT,999)
29825          CALL DPWRST('XXX','BUG ')
29826          WRITE(ICOUT,211)
29827          CALL DPWRST('XXX','BUG ')
29828          WRITE(ICOUT,131)
29829  131     FORMAT('      THE SPECIED STATISTIC REQUIRES MORE THAN ',
29830     1           'ONE REPONSE VARIABLE.')
29831          CALL DPWRST('XXX','BUG ')
29832          WRITE(ICOUT,133)ISTANM
29833  133     FORMAT('      THE SPECIED STATISTIC IS: ',A60)
29834          CALL DPWRST('XXX','BUG ')
29835          IERROR='YES'
29836          GOTO9000
29837        ENDIF
29838        IWORD=ILOCV+1
29839      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'DEFA'.AND.
29840     1       IHARG(3).EQ.'STAT')THEN
29841        ICASRE='DSTA'
29842        IWORD=5
29843      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'FULL'.AND.
29844     1       IHARG(3).EQ.'STAT')THEN
29845        ICASRE='FSTA'
29846        IWORD=5
29847      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'CROS'.AND.
29848     1       IHARG(3).EQ.'TABU')THEN
29849C
29850        IF(IHARG(4).EQ.'EUCL' .AND. IHARG(5).EQ.'DIST')THEN
29851          ICASRE='CTED'
29852          IWORD=7
29853        ELSEIF(IHARG(4).EQ.'CHEB' .AND. IHARG(5).EQ.'DIST')THEN
29854          ICASRE='CTCD'
29855          IWORD=7
29856        ELSEIF(IHARG(4).EQ.'MANH' .AND. IHARG(5).EQ.'DIST')THEN
29857          ICASRE='CTMD'
29858          IWORD=7
29859        ELSEIF(IHARG(4).EQ.'BLOC' .AND. IHARG(5).EQ.'DIST')THEN
29860          ICASRE='CTMD'
29861          IWORD=7
29862        ELSEIF(IHARG(4).EQ.'COSI' .AND. IHARG(5).EQ.'DIST')THEN
29863          ICASRE='CCOD'
29864          IWORD=7
29865        ELSEIF(IHARG(4).EQ.'COSI' .AND. IHARG(5).EQ.'SIMI')THEN
29866          ICASRE='CCOS'
29867          IWORD=7
29868        ELSEIF(IHARG(4).EQ.'JACC' .AND. IHARG(5).EQ.'SIMI')THEN
29869          ICASRE='CJAS'
29870          IWORD=7
29871        ELSEIF(IHARG(4).EQ.'JACC' .AND. IHARG(5).EQ.'DIST')THEN
29872          ICASRE='CJAD'
29873          IWORD=7
29874        ELSEIF(IHARG(4).EQ.'ANGU' .AND. IHARG(5).EQ.'COSI' .AND.
29875     1         IHARG(6).EQ.'DIST')THEN
29876          ICASRE='CACD'
29877          IWORD=8
29878        ELSEIF(IHARG(4).EQ.'ANGU' .AND. IHARG(5).EQ.'COSI' .AND.
29879     1         IHARG(6).EQ.'SIMI')THEN
29880          ICASRE='CACS'
29881          IWORD=8
29882        ELSEIF(IHARG(4).EQ.'CANB' .AND. IHARG(5).EQ.'DIST')THEN
29883          ICASRE='CTXD'
29884          IWORD=7
29885        ELSEIF(IHARG(4).EQ.'HAMM' .AND. IHARG(5).EQ.'DIST')THEN
29886          ICASRE='CTHD'
29887          IWORD=7
29888        ELSEIF(IHARG(4).EQ.'CORR')THEN
29889          ICASRE='CTCR'
29890          IWORD=6
29891        ELSEIF(IHARG(4).EQ.'COVA')THEN
29892          ICASRE='CTCV'
29893          IWORD=6
29894        ELSEIF(IHARG(4).EQ.'PERC')THEN
29895          ICASRE='CTPE'
29896          IWORD=6
29897        ELSE
29898          ICASRE='CSTA'
29899          IWORD=5
29900        ENDIF
29901C
29902C       CHECK IF ANY CROSS-TAB VARIABLES HAVE BEEN DEFINED
29903C
29904        NCRT=0
29905        IF(ISREC1.NE.' ' .AND. ISREC1.NE.'NULL')THEN
29906          NCRT=1
29907          IF(ISREC2.NE.' ' .AND. ISREC2.NE.'NULL')THEN
29908            NCRT=2
29909            IF(ISREC3.NE.' ' .AND. ISREC3.NE.'NULL')THEN
29910              NCRT=3
29911              IF(ISREC4.NE.' ' .AND. ISREC4.NE.'NULL')THEN
29912                NCRT=4
29913              ENDIF
29914            ENDIF
29915          ENDIF
29916        ELSE
29917          WRITE(ICOUT,999)
29918          CALL DPWRST('XXX','BUG ')
29919          WRITE(ICOUT,211)
29920          CALL DPWRST('XXX','BUG ')
29921          WRITE(ICOUT,141)
29922  141     FORMAT('      FOR THE CROSS-TAB CASE, NO CROSS-TABULATION ',
29923     1           'VARIABLES WERE SPECIFIED.')
29924          CALL DPWRST('XXX','BUG ')
29925          WRITE(ICOUT,143)
29926  143     FORMAT('      USE THE   SET STREAM READ CROSS TABULATE ',
29927     1           'VARIABLE <ONE/TWO/THREE FOUR>  COMMAND')
29928          CALL DPWRST('XXX','BUG ')
29929          WRITE(ICOUT,145)
29930  145     FORMAT('      TO SPECIFY THE CROSS-TABULATION VARIABLES.')
29931          CALL DPWRST('XXX','BUG ')
29932          IERROR='YES'
29933          GOTO9000
29934        ENDIF
29935      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'PERC')THEN
29936        ICASRE='PERC'
29937        IWORD=4
29938      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'CORR')THEN
29939        ICASRE='CORR'
29940        IWORD=4
29941      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'COVA')THEN
29942        ICASRE='COVA'
29943        IWORD=4
29944      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'DIST')THEN
29945        ICASRE='EDIS'
29946        IWORD=4
29947      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'EUCL'.AND.
29948     1       IHARG(3).EQ.'DIST')THEN
29949        ICASRE='EDIS'
29950        IWORD=5
29951      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'MANH'.AND.
29952     1       IHARG(3).EQ.'DIST')THEN
29953        ICASRE='MDIS'
29954        IWORD=5
29955      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'CHEB'.AND.
29956     1       IHARG(3).EQ.'DIST')THEN
29957        ICASRE='CDIS'
29958        IWORD=5
29959      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'COSI'.AND.
29960     1       IHARG(3).EQ.'DIST')THEN
29961        ICASRE='CODI'
29962        IWORD=5
29963      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'COSI'.AND.
29964     1       IHARG(3).EQ.'SIMI')THEN
29965        ICASRE='COSI'
29966        IWORD=5
29967      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'ANGU'.AND.
29968     1       IHARG(3).EQ.'COSI'.AND.IHARG(4).EQ.'DIST')THEN
29969        ICASRE='ACDI'
29970        IWORD=6
29971      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'ANGU'.AND.
29972     1       IHARG(3).EQ.'COSI'.AND.IHARG(4).EQ.'SIMI')THEN
29973        ICASRE='ACSI'
29974        IWORD=6
29975      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'JACC'.AND.
29976     1       IHARG(3).EQ.'SIMI')THEN
29977        ICASRE='JASI'
29978        IWORD=5
29979      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'JACC'.AND.
29980     1       IHARG(3).EQ.'DIST')THEN
29981        ICASRE='JADI'
29982        IWORD=5
29983      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'HAMM'.AND.
29984     1       IHARG(3).EQ.'DIST')THEN
29985        ICASRE='HDIS'
29986        IWORD=5
29987      ELSEIF(IHARG(1).EQ.'READ'.AND.IHARG(2).EQ.'CANB'.AND.
29988     1       IHARG(3).EQ.'DIST')THEN
29989        ICASRE='CNDI'
29990        IWORD=5
29991      ELSE
29992        WRITE(ICOUT,999)
29993        CALL DPWRST('XXX','BUG ')
29994        WRITE(ICOUT,211)
29995        CALL DPWRST('XXX','BUG ')
29996        WRITE(ICOUT,121)
29997  121   FORMAT('      UNRECOGNIZED FORM FOR THE COMMAND.')
29998        CALL DPWRST('XXX','BUG ')
29999        IERROR='YES'
30000        GOTO9000
30001      ENDIF
30002C
30003      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30004        WRITE(ICOUT,155)ICASRE,IWORD
30005  155   FORMAT('ICASRE,IWORD = ',A4,2X,I5)
30006        CALL DPWRST('XXX','BUG ')
30007      ENDIF
30008C
30009C     2018/07: AUTOMATICALLY TURN ON READING OF CHARACTER DATA AS
30010C              CATEGORICAL DATA FOR "WRITE" AND "CROSS-TAB" CASES
30011C              ONLY.
30012C
30013      IF(ICASRE.EQ.'CSTA' .OR. ICASRE.EQ.'WRIT')THEN
30014        IGRPAU='CATE'
30015      ELSE
30016        IGRPAU='OFF'
30017      ENDIF
30018C
30019C     2018/07: FOR CORRELATION AND DISTANCE CASES, CHECK IF USER
30020C              HAS ENTERED THE "SET STREAM READ VARIABLE TYPE" COMMAND.
30021C
30022C              ALSO ADD THIS FOR PERCENTILE CASE.  FOR PERCENTILE
30023C              CASE, USE AS A WAY OF SKIPPING VARIABLES (SUCH AS
30024C              FACTOR VARIABLES) FOR WHICH WE DO NOT WANT TO
30025C              COMPUTE PERCENTILES.
30026C
30027      IF(ICASRE.EQ.'CORR' .OR. ICASRE.EQ.'EDIS' .OR.
30028     1   ICASRE.EQ.'PERC' .OR. ICASRE.EQ.'CTPE' .OR.
30029     1   ICASRE.EQ.'MDIS' .OR. ICASRE.EQ.'CDIS' .OR.
30030     1   ICASRE.EQ.'CODI' .OR. ICASRE.EQ.'COSI' .OR.
30031     1   ICASRE.EQ.'ACDI' .OR. ICASRE.EQ.'ACSI' .OR.
30032     1   ICASRE.EQ.'JADI' .OR. ICASRE.EQ.'JASI' .OR.
30033     1   ICASRE.EQ.'HDIS' .OR. ICASRE.EQ.'CNDI' .OR.
30034     1   ICASRE.EQ.'COVA' .OR. ICASRE.EQ.'CTED' .OR.
30035     1   ICASRE.EQ.'CTMD' .OR. ICASRE.EQ.'CTCD' .OR.
30036     1   ICASRE.EQ.'CTHD' .OR. ICASRE.EQ.'CTXD' .OR.
30037     1   ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CCOS' .OR.
30038     1   ICASRE.EQ.'CACD' .OR. ICASRE.EQ.'CACS' .OR.
30039     1   ICASRE.EQ.'CJAD' .OR. ICASRE.EQ.'CJAS' .OR.
30040     1   ICASRE.EQ.'CTCR' .OR. ICASRE.EQ.'CTCV'
30041     1  )THEN
30042        DO160II=1,MAXOBV
30043          IVTYPE(II)=1
30044  160   CONTINUE
30045        IF(ISREVT.EQ.' ' .OR. ISREVT.EQ.'NULL' .OR.
30046     1     ISREVT.EQ.'NONE')THEN
30047          DO161II=1,MAXOBV
30048            IVTYPE(II)=1
30049  161     CONTINUE
30050        ELSE
30051          IH41=ISREVT(1:4)
30052          IH42=ISREVT(5:8)
30053          IHWUSE='V'
30054          MESSAG='NO'
30055          CALL CHECKN(IH41,IH42,IHWUSE,
30056     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
30057     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
30058C
30059          IF(IERROR.EQ.'YES')THEN
30060            DO163II=1,MAXOBV
30061              IVTYPE(II)=1
30062  163       CONTINUE
30063          ELSE
30064            ICOLQP=IVALUE(ILOCV)
30065            NTEMP=IN(ILOCV)
30066            ICNT=0
30067            DO165I=1,NTEMP
30068              IJ=MAXN*(ICOLQP-1)+I
30069              ICNT=ICNT+1
30070              IF(ICOLQP.LE.MAXCOL)IVTYPE(ICNT)=INT(V(IJ)+0.5)
30071              IF(ICOLQP.EQ.MAXCP1)IVTYPE(ICNT)=INT(PRED(I)+0.5)
30072              IF(ICOLQP.EQ.MAXCP2)IVTYPE(ICNT)=INT(RES(I)+0.5)
30073              IF(ICOLQP.EQ.MAXCP3)IVTYPE(ICNT)=INT(YPLOT(I)+0.5)
30074              IF(ICOLQP.EQ.MAXCP4)IVTYPE(ICNT)=INT(XPLOT(I)+0.5)
30075              IF(ICOLQP.EQ.MAXCP5)IVTYPE(ICNT)=INT(X2PLOT(I)+0.5)
30076              IF(ICOLQP.EQ.MAXCP6)IVTYPE(ICNT)=INT(TAGPLO(I)+0.5)
30077              IF(IVTYPE(ICNT).LT.0)THEN
30078                IVTYPE(ICNT)=0
30079              ELSEIF(IVTYPE(ICNT).GT.1)THEN
30080                IVTYPE(ICNT)=1
30081              ENDIF
30082  165       CONTINUE
30083          ENDIF
30084        ENDIF
30085      ENDIF
30086C
30087C               ******************************************************
30088C               **  STEP 2A--                                       **
30089C               **  EXTRACT FILE NAME (STREAM READ ONLY SUPPORTED   **
30090C               ******************************************************
30091C
30092      ISTEPN='2A'
30093      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30094     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30095C
30096      IOFILE='NO'
30097      CALL DPFILE(IANSLC,IWIDTH,IWORD,
30098     1            IOFILE,IBUGS2,ISUBRO,IERROR)
30099      IF(IERROR.EQ.'YES')GOTO9000
30100C
30101      IF(IOFILE.EQ.'NO')THEN
30102        WRITE(ICOUT,999)
30103        CALL DPWRST('XXX','BUG ')
30104        WRITE(ICOUT,211)
30105  211   FORMAT('***** ERROR FROM STREAM READ--')
30106        CALL DPWRST('XXX','BUG ')
30107        WRITE(ICOUT,213)
30108  213   FORMAT('      TERMINAL READS (I.E., READ WITH NO FILE NAME ',
30109     1         'SPECIFIED)')
30110        CALL DPWRST('XXX','BUG ')
30111        WRITE(ICOUT,215)
30112  215   FORMAT('      ARE NOT SUPPORTED FOR THE STREAM READ COMMAND.')
30113        CALL DPWRST('XXX','BUG ')
30114        WRITE(ICOUT,999)
30115        CALL DPWRST('XXX','BUG ')
30116        IERROR='YES'
30117        GOTO9000
30118      ENDIF
30119C
30120C               *************************************
30121C               **  STEP 2B--                      **
30122C               **  IF HAVE THE FILE INPUT CASE--  **
30123C               **  COPY OVER VARIABLES            **
30124C               *************************************
30125C
30126      ISTEPN='2B'
30127      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30128     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30129C
30130      IOUNIT=IREANU
30131      IFILE=IREANA
30132      ISTAT=IREAST
30133      IFORM=IREAFO
30134      IACCES=IREAAC
30135      IPROT=IREAPR
30136      ICURST=IREACS
30137C
30138      ISUBN0='STRE'
30139      IERRFI='NO'
30140C
30141      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30142        WRITE(ICOUT,1183)IOUNIT,ISUBN0,IERRFI
30143 1183   FORMAT('IOUNIT,ISUBN0,IERRFI = ',I8,A4,2X,A4)
30144        CALL DPWRST('XXX','BUG ')
30145        WRITE(ICOUT,1184)IFILE
30146 1184   FORMAT('IFILE = ',A80)
30147        CALL DPWRST('XXX','BUG ')
30148        WRITE(ICOUT,1185)ISTAT,IFORM,IACCES,IPROT,ICURST
30149 1185   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12)
30150        CALL DPWRST('XXX','BUG ')
30151      ENDIF
30152C
30153C               ***********************************************
30154C               **  STEP 2C--                                **
30155C               **  IF HAVE THE FILE INPUT CASE--            **
30156C               **  CHECK TO SEE IF THE READ FILE MAY EXIST  **
30157C               ***********************************************
30158C
30159      ISTEPN='2C'
30160      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30161     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30162C
30163      IF(ISTAT.EQ.'NONE')THEN
30164        IERROR='YES'
30165        WRITE(ICOUT,999)
30166        CALL DPWRST('XXX','BUG ')
30167        WRITE(ICOUT,211)
30168        CALL DPWRST('XXX','BUG ')
30169        WRITE(ICOUT,1212)
30170 1212   FORMAT('      THE DESIRED READING CANNOT BE CARRIED OUT')
30171        CALL DPWRST('XXX','BUG ')
30172        WRITE(ICOUT,1214)
30173 1214   FORMAT('      BECAUSE THE INTERNAL VARIABLE   IREAST   WHICH')
30174        CALL DPWRST('XXX','BUG ')
30175        WRITE(ICOUT,1215)
30176 1215   FORMAT('      ALLOWS SUCH READING HAS BEEN SET TO    NONE')
30177        CALL DPWRST('XXX','BUG ')
30178        WRITE(ICOUT,1217)ISTAT,IREAST
30179 1217   FORMAT('ISTAT,IREAST = ',A12,2X,A12)
30180        CALL DPWRST('XXX','BUG ')
30181        WRITE(ICOUT,1218)
30182 1218   FORMAT('      ALL READING MUST BE DONE DIRECTLY FROM ',
30183     1         'THE TERMINAL')
30184        CALL DPWRST('XXX','BUG ')
30185        GOTO9000
30186      ENDIF
30187C
30188C               *************************************
30189C               **  STEP 2D--                      **
30190C               **  IF HAVE THE FILE INPUT CASE--  **
30191C               **  EXTRACT THE FILE NAME          **
30192C               *************************************
30193C
30194      ISTEPN='2D'
30195      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30196     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30197C
30198      DO1310I=1,MAXSTR
30199        ICANS(I:I)=IANSLC(I)(1:1)
30200 1310 CONTINUE
30201C
30202      ISTART=1
30203      ISTOP=IWIDTH
30204      CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD,
30205     1            ICOL1,ICOL2,IFILE,NCFILE,
30206     1            IBUGS2,ISUBRO,IERROR)
30207C
30208      IF(NCFILE.LT.1)THEN
30209        WRITE(ICOUT,999)
30210        CALL DPWRST('XXX','BUG ')
30211        WRITE(ICOUT,211)
30212        CALL DPWRST('XXX','BUG ')
30213        WRITE(ICOUT,1342)
30214 1342   FORMAT('      A USER FILE NAME IS REQUIRED IN THE STREAM ',
30215     1         'READ COMMAND.')
30216        CALL DPWRST('XXX','BUG ')
30217        WRITE(ICOUT,1346)
30218 1346   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
30219        CALL DPWRST('XXX','BUG ')
30220        IF(IWIDTH.GE.1)THEN
30221          WRITE(ICOUT,1347)(IANSLC(I),I=1,MIN(100,IWIDTH))
30222 1347     FORMAT('      ',100A1)
30223          CALL DPWRST('XXX','BUG ')
30224          WRITE(ICOUT,999)
30225          CALL DPWRST('XXX','BUG ')
30226        ENDIF
30227        IERROR='YES'
30228        GOTO9000
30229      ENDIF
30230C
30231      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30232        WRITE(ICOUT,1351)NCFILE,IFILE(1:NCFILE)
30233 1351   FORMAT('NCFILE,IFILE(1:NCFILE) = ',I5,2X,A80)
30234        CALL DPWRST('XXX','BUG ')
30235      ENDIF
30236C
30237C     FOR THE WRITE CASE, NEED TO SPECIFY AN OUTPUT FILE
30238C
30239      IFLGOU=0
30240C
30241      IF(ICASRE.EQ.'WRIT')THEN
30242C
30243C       FOR "WRITE" CASE, ADD A "_FORM" BEFORE THE PERIOD.  FOR
30244C       EXAMPLE, IF THE INPUT FILE IS "TEST.DAT", THEN MAKE THE
30245C       OUTPUT FILE "TEST_FORM.DAT".
30246C
30247        IF(NCFILE.GT.75)THEN
30248          WRITE(ICOUT,999)
30249          CALL DPWRST('XXX','BUG ')
30250          WRITE(ICOUT,211)
30251          CALL DPWRST('XXX','BUG ')
30252          WRITE(ICOUT,1412)
30253 1412     FORMAT('      OUTPUT FILE NAME HAS GREATER THAN 80 ',
30254     1           'CHARACTERS.')
30255          CALL DPWRST('XXX','BUG ')
30256          WRITE(ICOUT,1414)
30257 1414     FORMAT('      STREAM READ NOT PERFORMED.')
30258          CALL DPWRST('XXX','BUG ')
30259          WRITE(ICOUT,1346)
30260          CALL DPWRST('XXX','BUG ')
30261          IF(IWIDTH.GE.1)THEN
30262            WRITE(ICOUT,1347)(IANSLC(I),I=1,MIN(100,IWIDTH))
30263            CALL DPWRST('XXX','BUG ')
30264            WRITE(ICOUT,999)
30265            CALL DPWRST('XXX','BUG ')
30266          ENDIF
30267          IERROR='YES'
30268          GOTO8800
30269        ENDIF
30270C
30271        IOUNI2=IWRINU
30272        ISTAT2=IWRIST
30273        IFORM2=IWRIFO
30274        IACCE2=IWRIAC
30275        IPROT2=IWRIPR
30276        ICURS2=IWRICS
30277C
30278        DO1410II=NCFILE,1,-1
30279          IF(IFILE(II:II).EQ.IFCHAR)THEN
30280            IFILE2=' '
30281            IFILE2(1:II-1)=IFILE(1:II-1)
30282            IFILE2(II:II+4)='_FORM'
30283            IFILE2(II+5:II+5)=IFCHAR
30284            NCFIL2=II+5
30285            NTEMP=NCFILE-II
30286            IFILE2(NCFIL2+1:NCFIL2+NTEMP)=IFILE(II+1:NCFILE)
30287            NCFIL2=NCFIL2+NTEMP
30288            GOTO1419
30289          ENDIF
30290 1410   CONTINUE
30291 1419   CONTINUE
30292        IFLGOU=1
30293      ENDIF
30294C
30295C               **************************************
30296C               **  STEP 2E--                       **
30297C               **  OPEN THE INPUT AND OUTPUT FILES **
30298C               **************************************
30299C
30300      ISTEPN='2E'
30301      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30302     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30303C
30304      IREWIN='ON'
30305      IF(NCREAF.GT.0)THEN
30306        IF(ICREAF(1:5).EQ.'(UNFO')THEN
30307          WRITE(ICOUT,999)
30308          CALL DPWRST('XXX','BUG ')
30309          WRITE(ICOUT,211)
30310          CALL DPWRST('XXX','BUG ')
30311          WRITE(ICOUT,1442)
30312 1442     FORMAT('      UNFORMATTED READS NOT SUPPORTED FOR STREAM ',
30313     1           'READ COMMAND.')
30314          CALL DPWRST('XXX','BUG ')
30315          IERROR='YES'
30316          GOTO9000
30317        ELSE
30318          IFORM='FORMATTED'
30319          IFMFLG='OFF'
30320        ENDIF
30321      ELSE
30322        IFORM='FORMATTED'
30323        IFMFLG='OFF'
30324      ENDIF
30325C
30326      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30327        WRITE(ICOUT,1451)IREACS
30328 1451   FORMAT('BEFORE DPOPFI: IREACS = ',A12)
30329        CALL DPWRST('XXX','BUG ')
30330      ENDIF
30331C
30332      IF(IREACS(1:4).EQ.'CLOS')THEN
30333        CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
30334     1              IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
30335        IF(IERRFI.EQ.'YES')GOTO9090
30336C
30337        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30338          WRITE(ICOUT,1453)IREACS
30339 1453     FORMAT('AFTER DPOPFI: IREACS = ',A12)
30340          CALL DPWRST('XXX','BUG ')
30341        ENDIF
30342C
30343        IF(IREACS(1:4).EQ.'CLOS')IREACS='OPEN'
30344      ENDIF
30345C
30346      IF(IWRICS(1:4).EQ.'CLOS' .AND. IFLGOU.EQ.1)THEN
30347        CALL DPOPFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
30348     1              IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
30349        IF(IERRFI.EQ.'YES')GOTO9090
30350        IF(IWRICS(1:4).EQ.'CLOS')IWRICS='OPEN'
30351      ENDIF
30352C
30353C               ******************************************
30354C               **  STEP 2F--                           **
30355C               **  DEFINE THE INPUT READ UNIT NUMBER,  **
30356C               **  AND OTHER VARIABLES NEEDED          **
30357C               **  FOR UPCOMING READS.                 **
30358C               ******************************************
30359C
30360      ISTEPN='2F'
30361      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30362     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30363C
30364      IRD2=IREANU
30365C
30366C               *****************************************
30367C               **  STEP 3--                           **
30368C               **  CHECK TO SEE THE TYPE CASE--       **
30369C               **    1) UNQUALIFIED (THAT IS, FULL);  **
30370C               **    2) SUBSET; OR                    **
30371C               **    3) FOR.                          **
30372C               *****************************************
30373C
30374      ISTEPN='3'
30375      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30376     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30377C
30378      ICASEQ='FULL'
30379      ILOCQ=NUMARG+1
30380      IF(NUMARG.LT.1)GOTO390
30381      DO300J=1,NUMARG
30382        J1=J
30383        IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')THEN
30384          ICASEQ='SUBS'
30385          ILOCQ=J1
30386          GOTO390
30387        ELSEIF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')THEN
30388          ICASEQ='SUBS'
30389          ILOCQ=J1
30390          GOTO390
30391        ELSEIF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')THEN
30392          ICASEQ='FOR'
30393          ILOCQ=J1
30394          GOTO390
30395        ENDIF
30396  300 CONTINUE
30397  390 CONTINUE
30398C
30399      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30400        WRITE(ICOUT,391)NUMARG,ILOCQ
30401  391   FORMAT('NUMARG,ILOCQ = ',2I8)
30402        CALL DPWRST('XXX','BUG ')
30403      ENDIF
30404C
30405C               ******************************************************
30406C               **  STEP 4--                                        **
30407C               **  DETERMINE THE TYPE AND NUMBER OF ITEMS          **
30408C               **  TO BE READ.  CURRENTLY ONLY VARIABLES ARE       **
30409C               **  SUPPORTED, ANY OTHER TYPE WILL BE AN ERROR.     **
30410C               **  NUMV   = NUMBER OF VARIABLES TO BE READ         **
30411C               ******************************************************
30412C
30413      ISTEPN='4'
30414      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30415     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30416C
30417      IV=0
30418      JMIN=IWORD
30419C
30420CCCCC QUOTED FILE NAMES MAY CONTAIN SPACES.  DETERMINE HOW MANY ARGUMENTS
30421CCCCC FILE NAME MAY CONTAIN.  INCLUDE HYPHENS AS WELL AS SPACES.
30422C
30423      IF(IFILE(1:1).EQ.'"')THEN
30424        DO421I=80,1,-1
30425          IF(IFILE(I:I).NE.' ')THEN
30426            ILAST=I
30427            GOTO424
30428          ENDIF
30429  421   CONTINUE
30430  424   CONTINUE
30431        ICOUNT=0
30432        ISPAC=0
30433        DO426I=1,ILAST
30434          IF((IFILE(I:I).EQ.' '.OR.IFILE(I:I).EQ.'-') .AND.
30435     1      ISPAC.EQ.0)THEN
30436            ISPAC=1
30437            ICOUNT=ICOUNT+1
30438          ELSEIF((IFILE(I:I).NE.' '.AND.IFILE(I:I).NE.'-') .AND.
30439     1      ISPAC.EQ.1)THEN
30440            ISPAC=0
30441          ENDIF
30442  426   CONTINUE
30443        JMIN=JMIN+ICOUNT
30444      ENDIF
30445C
30446      JMAX=ILOCQ-1
30447      NUMV=JMAX-JMIN+1
30448C
30449      ISTEPN='4A'
30450      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30451        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30452        WRITE(ICOUT,403)ICASRE,IVRLST,JMIN,JMAX,NUMV
30453  403   FORMAT('ICASRE,IVRLST,JMIN,JMAX,NUMV = ',2(A4,2X),3I8)
30454        CALL DPWRST('XXX','BUG ')
30455      ENDIF
30456C
30457      IF(JMIN.GT.JMAX)THEN
30458        WRITE(ICOUT,999)
30459        CALL DPWRST('XXX','BUG ')
30460        WRITE(ICOUT,211)
30461        CALL DPWRST('XXX','BUG ')
30462        WRITE(ICOUT,404)
30463  404   FORMAT('      NO VARIABLE NAMES FOUND.')
30464        CALL DPWRST('XXX','BUG ')
30465        IERROR='YES'
30466        GOTO8800
30467      ENDIF
30468C
30469      ICNTNU=0
30470      ICNTCH=0
30471      ICOUNT=0
30472      IISKIP=0
30473      ICFLAG='NO'
30474      IF(IGRPAU.EQ.'ON' .OR. IGRPAU.EQ.'CATE')ICFLAG='YES'
30475C
30476      DO4200J=JMIN,JMAX
30477C
30478        IF(IISKIP.EQ.1)THEN
30479          IISKIP=0
30480          GOTO4200
30481        ENDIF
30482C
30483        ICOUNT=ICOUNT+1
30484        IH1=IHARG(J)
30485        IH2=IHARG2(J)
30486C
30487C     ***************
30488C     THE FOLLOWING CODE ALLOWS THE    TO    KEYWORD
30489C     TO BE ACTIVATED, AS IN
30490C     READ FILE.EXT Y1 TO Y10
30491C     DECEMBER 1986
30492C     ***************
30493C
30494        ICASTO='OFF'
30495        IF(IH1.EQ.'TO  ')THEN
30496          ICASTO='ON'
30497          JM1=J-1
30498          JP1=J+1
30499          CALL DPEXTL(IHARG(JM1),IHARG2(JM1),IHARG(JP1),IHARG2(JP1),
30500     1                KNUMB,IVAL1,IVAL2,IBUGS2,ISUBRO,IERROR)
30501C
30502          IF(IVAL1.EQ.IVAL2)THEN
30503            IISKIP=1
30504            GOTO4200
30505          ENDIF
30506C
30507          IVA1P1=IVAL1+1
30508          IVA2M1=IVAL2-1
30509          IF(IVA1P1.GT.IVA2M1)GOTO4200
30510          IVAL=IVAL1
30511        ELSE
30512          GOTO4219
30513        ENDIF
30514 4215   CONTINUE
30515        IVAL=IVAL+1
30516        IF(IVAL.GE.IVAL2)GOTO4200
30517C
30518        CALL DPAPNU(IHARG(JM1),IHARG2(JM1),KNUMB,IVAL,
30519     1              IH1,IH2,IBUGS2,ISUBRO,IERROR)
30520 4219   CONTINUE
30521C
30522        ISTEPN='4B'
30523        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30524          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30525          WRITE(ICOUT,4271)NUMNAM
30526 4271     FORMAT('AT 4300, NUMNAM = ',I8)
30527          CALL DPWRST('XXX','BUG ')
30528        ENDIF
30529C
30530        ICASEA='    '
30531        DO4300I=1,NUMNAM
30532          I2=I
30533          IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN
30534            IF(IUSE(I).EQ.'V')THEN
30535              ICASEA='V'
30536              IV=IV+1
30537              IF(IV.GT.MAXV2)GOTO4370
30538              JVNAM1(IV)=IH1
30539              JVNAM2(IV)=IH2
30540              NIV(IV)=IN(I2)
30541              IECASE(IV)='OLD'
30542              IECOL2(IV)=IVALUE(I2)
30543            ELSE
30544              WRITE(ICOUT,999)
30545              CALL DPWRST('XXX','BUG ')
30546              WRITE(ICOUT,211)
30547              CALL DPWRST('XXX','BUG ')
30548              WRITE(ICOUT,4312)
30549 4312         FORMAT('      A NAME IN THE LIST OF VARIABLES TO BE ',
30550     1               'READ INCLUDED THE')
30551              CALL DPWRST('XXX','BUG ')
30552              WRITE(ICOUT,4315)
30553 4315         FORMAT('      A PREVIOUSLY-DEFINED NAME, BUT NOT AS A ',
30554     1               'VARIABLE.')
30555              CALL DPWRST('XXX','BUG ')
30556              WRITE(ICOUT,4316)IH1,IH2
30557 4316         FORMAT('      THE PREVIOUSLY DEFINED NAME IS ',2A4,' .')
30558              CALL DPWRST('XXX','BUG ')
30559              WRITE(ICOUT,4317)
30560 4317         FORMAT('      THE STREAM READ WAS NOT CARRIED OUT.')
30561              CALL DPWRST('XXX','BUG ')
30562              IERROR='YES'
30563              GOTO8800
30564C
30565            ENDIF
30566          ENDIF
30567 4300   CONTINUE
30568C
30569        IV=IV+1
30570        IF(IV.LE.MAXV2)THEN
30571          JVNAM1(IV)=IH1
30572          JVNAM2(IV)=IH2
30573          IECASE(IV)='NEW'
30574          IECOL2(IV)=-1
30575        ENDIF
30576C
30577        ISTEPN='4C'
30578        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30579          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30580          WRITE(ICOUT,4273)IV,MAXV2
30581 4273     FORMAT('AFTER 4300, IV,MAXV2 = ',2I8)
30582          CALL DPWRST('XXX','BUG ')
30583          IF(IV.GT.0)THEN
30584            DO4275II=1,IV
30585              WRITE(ICOUT,4277)II,JVNAM1(II),JVNAM2(II)
30586 4277         FORMAT('II,JVNAM1(II),JVNAM2(II)=',I8,2X,2A4)
30587              CALL DPWRST('XXX','BUG ')
30588 4275       CONTINUE
30589          ENDIF
30590        ENDIF
30591C
30592 4370   CONTINUE
30593        IF(IV.GT.MAXV2)THEN
30594          WRITE(ICOUT,999)
30595          CALL DPWRST('XXX','BUG ')
30596          WRITE(ICOUT,211)
30597          CALL DPWRST('XXX','BUG ')
30598          WRITE(ICOUT,4382)
30599 4382     FORMAT('      THE NUMBER OF NAMES IN THE STREAM READ ',
30600     1           'COMMAND HAS')
30601          CALL DPWRST('XXX','BUG ')
30602          WRITE(ICOUT,4384)MAXV2
30603 4384     FORMAT('      JUST EXCEEDED THE ALLOWABLE MAXIMUM (',
30604     1           I5,')')
30605          CALL DPWRST('XXX','BUG ')
30606          IERROR='YES'
30607          GOTO8800
30608        ENDIF
30609C
30610        IF(ICASTO.EQ.'ON')GOTO4215
30611C
30612 4200 CONTINUE
30613C
30614      NUMV=IV
30615C
30616      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30617        WRITE(ICOUT,4411)NUMV
30618 4411   FORMAT('NUMV = ',7I6)
30619        CALL DPWRST('XXX','BUG ')
30620        WRITE(ICOUT,999)
30621        CALL DPWRST('XXX','BUG ')
30622        WRITE(ICOUT,4412)
30623 4412   FORMAT('I,JVNAM1(I),JVNAM2(I)')
30624        CALL DPWRST('XXX','BUG ')
30625        DO4420I=1,NUMV
30626          WRITE(ICOUT,4421)I,JVNAM1(I),JVNAM2(I)
30627 4421     FORMAT(I8,5X,2A4,1X,2A4)
30628          CALL DPWRST('XXX','BUG ')
30629 4420   CONTINUE
30630      ENDIF
30631C
30632C               ******************************************************
30633C               **  STEP 4B--                                       **
30634C               **  IS ONE OF THE VARIABLES THE "GROUP-ID"          **
30635C               **  VARIABLE?                                       **
30636C               ******************************************************
30637C
30638      ISTEPN='4B'
30639      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30640     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30641C
30642      IVARGR=-1
30643      AHOLD=CPUMIN
30644      IF(ISREVN.NE.'NONE')THEN
30645        DO4430II=1,NUMV
30646          IF(ISREVN(1:4).EQ.JVNAM1(II) .AND.
30647     1       ISREVN(5:8).EQ.JVNAM2(II))THEN
30648            IVARGR=II
30649            GOTO4439
30650          ENDIF
30651 4430   CONTINUE
30652 4439   CONTINUE
30653      ENDIF
30654C
30655      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30656        WRITE(ICOUT,4441)IVARGR,AHOLD
30657 4441   FORMAT('IVARGR,AHOLD = ',I5,2X,E15.7)
30658        CALL DPWRST('XXX','BUG ')
30659      ENDIF
30660C
30661C               ******************************************************
30662C               **  STEP 4C--                                       **
30663C               **  FOR THE CROSS TABULATION CASE, WHAT ARE THE     **
30664C               **  RESPONSE VARIABLES AND WHAT ARE THE CROSS-      **
30665C               **  TABULATION VARIABLES?                           **
30666C               ******************************************************
30667C
30668      ISTEPN='4C'
30669      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30670     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30671C
30672C     ONLY DO THIS FOR THE CROSS-TABULATION CASE
30673C
30674      IVARR1=-1
30675      IVARR2=-1
30676      IVARR3=-1
30677      IVARC1=-1
30678      IVARC2=-1
30679      IVARC3=-1
30680      IVARC4=-1
30681C
30682      IF(ICASRE.EQ.'CSTA' .OR. ICASRE.EQ.'CTED' .OR.
30683     1   ICASRE.EQ.'CTMD' .OR. ICASRE.EQ.'CTCD' .OR.
30684     1   ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CCOS' .OR.
30685     1   ICASRE.EQ.'CACD' .OR. ICASRE.EQ.'CACS' .OR.
30686     1   ICASRE.EQ.'CJAD' .OR. ICASRE.EQ.'CJAS' .OR.
30687     1   ICASRE.EQ.'CTHD' .OR. ICASRE.EQ.'CTXD' .OR.
30688     1   ICASRE.EQ.'CTCR' .OR. ICASRE.EQ.'CTCV' .OR.
30689     1   ICASRE.EQ.'CTPE'
30690     1  )THEN
30691        IF(ISRER1.NE.'NONE' .AND. ISRER1.NE.' ')THEN
30692          DO4440II=1,NUMV
30693            IF(ISRER1(1:4).EQ.JVNAM1(II) .AND.
30694     1         ISRER1(5:8).EQ.JVNAM2(II))THEN
30695              IVARR1=II
30696              GOTO4449
30697            ENDIF
30698 4440     CONTINUE
30699 4449     CONTINUE
30700        ENDIF
30701C
30702        IF(ISRER2.NE.'NONE' .AND. ISRER2.NE.' ')THEN
30703          DO4450II=1,NUMV
30704            IF(ISRER2(1:4).EQ.JVNAM1(II) .AND.
30705     1         ISRER2(5:8).EQ.JVNAM2(II))THEN
30706              IVARR2=II
30707              GOTO4459
30708            ENDIF
30709 4450     CONTINUE
30710 4459     CONTINUE
30711        ENDIF
30712C
30713        IF(ISRER3.NE.'NONE' .AND. ISRER3.NE.' ')THEN
30714          DO4460II=1,NUMV
30715            IF(ISRER3(1:4).EQ.JVNAM1(II) .AND.
30716     1         ISRER3(5:8).EQ.JVNAM2(II))THEN
30717              IVARR3=II
30718              GOTO4469
30719            ENDIF
30720 4460     CONTINUE
30721 4469     CONTINUE
30722        ENDIF
30723C
30724        IF(NCRT.GE.1)THEN
30725          DO4470II=1,NUMV
30726            IF(ISREC1(1:4).EQ.JVNAM1(II) .AND.
30727     1         ISREC1(5:8).EQ.JVNAM2(II))THEN
30728              IVARC1=II
30729              GOTO4479
30730            ENDIF
30731 4470     CONTINUE
30732 4479     CONTINUE
30733        ENDIF
30734C
30735        IF(NCRT.GE.2)THEN
30736          DO4480II=1,NUMV
30737            IF(ISREC2(1:4).EQ.JVNAM1(II) .AND.
30738     1         ISREC2(5:8).EQ.JVNAM2(II))THEN
30739              IVARC2=II
30740              GOTO4489
30741            ENDIF
30742 4480     CONTINUE
30743 4489     CONTINUE
30744        ENDIF
30745C
30746        IF(NCRT.GE.3)THEN
30747          DO4490II=1,NUMV
30748            IF(ISREC3(1:4).EQ.JVNAM1(II) .AND.
30749     1         ISREC3(5:8).EQ.JVNAM2(II))THEN
30750              IVARC3=II
30751              GOTO4494
30752            ENDIF
30753 4490     CONTINUE
30754 4494     CONTINUE
30755        ENDIF
30756C
30757        IF(NCRT.GE.4)THEN
30758          DO4495II=1,NUMV
30759            IF(ISREC4(1:4).EQ.JVNAM1(II) .AND.
30760     1         ISREC4(5:8).EQ.JVNAM2(II))THEN
30761              IVARC4=II
30762              GOTO4499
30763            ENDIF
30764 4495     CONTINUE
30765 4499     CONTINUE
30766        ENDIF
30767C
30768        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30769          WRITE(ICOUT,4443)IVARC1,IVARC2,IVARC3,IVARC4
30770 4443     FORMAT('IVARC1,IVARC2,IVARC3,IVARC4 = ',4I5)
30771          CALL DPWRST('XXX','BUG ')
30772        ENDIF
30773C
30774      ENDIF
30775C
30776C               ******************************************************
30777C               **  STEP 4D--                                       **
30778C               **  FOR "DEFAULT STATISTICS", "FULL STATISTICS",    **
30779C               **  AND "CROSS-TAB" CASES, ADD "TAGSTAT" VARIABLE.  **
30780C               ******************************************************
30781C
30782      ISTEPN='4D'
30783      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30784     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30785C
30786      IF(ICASRE.EQ.'DSTA' .OR. ICASRE.EQ.'FSTA' .OR.
30787     1   ICASRE.EQ.'CSTA' .OR. ICASRE.EQ.'CTED' .OR.
30788     1   ICASRE.EQ.'CTCD' .OR. ICASRE.EQ.'CTMD' .OR.
30789     1   ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CJAD' .OR.
30790     1   ICASRE.EQ.'CCOS' .OR. ICASRE.EQ.'CJAS' .OR.
30791     1   ICASRE.EQ.'CTCR' .OR. ICASRE.EQ.'CTCV' .OR.
30792     1   ICASRE.EQ.'CTHD' .OR. ICASRE.EQ.'CTXD' .OR.
30793     1   ICASRE.EQ.'CTPE' .OR.
30794     1   ICASRE.EQ.'CACD' .OR. ICASRE.EQ.'CACS')THEN
30795        IH1='TAGS'
30796        IH2='TAT '
30797        DO610I=1,NUMNAM
30798          I2=I
30799          IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN
30800            IF(IUSE(I).EQ.'V')THEN
30801              ICASEA='V'
30802              IV=NUMV+1
30803              IF(IV.GT.MAXV2)THEN
30804                WRITE(ICOUT,999)
30805                CALL DPWRST('XXX','BUG ')
30806                WRITE(ICOUT,211)
30807                CALL DPWRST('XXX','BUG ')
30808                WRITE(ICOUT,4382)
30809                CALL DPWRST('XXX','BUG ')
30810                WRITE(ICOUT,4384)MAXV2
30811                CALL DPWRST('XXX','BUG ')
30812                IERROR='YES'
30813                GOTO8800
30814              ENDIF
30815              JVNAM1(IV)=IH1
30816              JVNAM2(IV)=IH2
30817              NIV(IV)=IN(I2)
30818              IECASE(IV)='OLD'
30819              IECOL2(IV)=IVALUE(I2)
30820            ELSE
30821              WRITE(ICOUT,999)
30822              CALL DPWRST('XXX','BUG ')
30823              WRITE(ICOUT,211)
30824              CALL DPWRST('XXX','BUG ')
30825              WRITE(ICOUT,4312)
30826              CALL DPWRST('XXX','BUG ')
30827              WRITE(ICOUT,4315)
30828              CALL DPWRST('XXX','BUG ')
30829              WRITE(ICOUT,4316)IH1,IH2
30830              CALL DPWRST('XXX','BUG ')
30831              WRITE(ICOUT,4317)
30832              CALL DPWRST('XXX','BUG ')
30833              IERROR='YES'
30834              GOTO8800
30835            ENDIF
30836          ENDIF
30837  610   CONTINUE
30838C
30839        IV=NUMV+1
30840        IF(IV.LE.MAXV2)THEN
30841          JVNAM1(IV)=IH1
30842          JVNAM2(IV)=IH2
30843          IECASE(IV)='NEW'
30844          IECOL2(IV)=-1
30845        ENDIF
30846C
30847        NUMV=IV
30848C
30849      ENDIF
30850C
30851C               ***************************************************
30852C               **  STEP 5--                                     **
30853C               **  CHECK FOR A VALID NUMBER OF VARIABLES TO BE  **
30854C               **  READ                                         **
30855C               ***************************************************
30856C
30857      IF(NUMV.LE.0 .OR. NUMV.GT.MAXV2)THEN
30858C
30859        WRITE(ICOUT,211)
30860        CALL DPWRST('XXX','BUG ')
30861        WRITE(ICOUT,512)
30862  512   FORMAT('      FOR A STREAM READ, THE NUMBER OF VARIABLES MUST')
30863        CALL DPWRST('XXX','BUG ')
30864        WRITE(ICOUT,514)MAXV2
30865  514   FORMAT('      BE AT MOST ',I8,'  .  THE SPECIFIED')
30866        CALL DPWRST('XXX','BUG ')
30867        WRITE(ICOUT,517)NUMV
30868  517   FORMAT('      NUMBER OF VARIABLES TO BE READ WAS ',I8)
30869        CALL DPWRST('XXX','BUG ')
30870        WRITE(ICOUT,518)MAXV2
30871  518   FORMAT('      NOTE--ONLY THE FIRST ',I8,' VARIABLES WILL BE ',
30872     1         'READ.')
30873        CALL DPWRST('XXX','BUG ')
30874        WRITE(ICOUT,520)
30875  520   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
30876        CALL DPWRST('XXX','BUG ')
30877        IF(IWIDTH.GE.1)THEN
30878          WRITE(ICOUT,521)(IANSLC(I),I=1,MIN(120,IWIDTH))
30879  521     FORMAT(120A1)
30880          CALL DPWRST('XXX','BUG ')
30881        ENDIF
30882        IF(NUMV.LE.0)THEN
30883          IERROR='YES'
30884          GOTO8800
30885        ENDIF
30886      ENDIF
30887C
30888C               *******************************************************
30889C               **  STEP 6--                                         **
30890C               **  THOSE NAMES WHICH ARE OF THE UNKNOWN CATEGORY    **
30891C               **  WILL BECOME  FUTURE VARIABLES.  ASSIGN THESE     **
30892C               **  VARIABLES TO THE NEXT AVAILABLE COLUMNS AND      **
30893C               **  UPDATE THE NAME TABLE ACCORDINGLY.               **
30894C               *******************************************************
30895C
30896      INAM=NUMNAM
30897      ICOL=NUMCOL
30898      DO700IE=1,NUMV
30899        IF(IECASE(IE).EQ.'NEW')THEN
30900          INAM=INAM+1
30901          ICOL=ICOL+1
30902C
30903          IF(INAM.GT.MAXNAM)THEN
30904            WRITE(ICOUT,999)
30905            CALL DPWRST('XXX','BUG ')
30906            WRITE(ICOUT,211)
30907            CALL DPWRST('XXX','BUG ')
30908            WRITE(ICOUT,712)
30909  712       FORMAT('      THE NUMBER OF NAMES ')
30910            CALL DPWRST('XXX','BUG ')
30911            WRITE(ICOUT,714)
30912  714       FORMAT('      + FUNCTIONS HAS JUST EXCEEDED THE MAXIMUM ',
30913     1             'SIZE')
30914            CALL DPWRST('XXX','BUG ')
30915            WRITE(ICOUT,715)MAXNAM
30916  715       FORMAT('      (',I5,') OF THE INTERNAL NAME TABLE.')
30917            CALL DPWRST('XXX','BUG ')
30918            IERROR='YES'
30919            GOTO8800
30920          ENDIF
30921C
30922          IF(ICOL.GT.MAXCOL)THEN
30923            WRITE(ICOUT,999)
30924            CALL DPWRST('XXX','BUG ')
30925            WRITE(ICOUT,211)
30926            CALL DPWRST('XXX','BUG ')
30927            WRITE(ICOUT,722)
30928  722       FORMAT('      THE NUMBER OF COLUMNS IN THE INTERNAL ',
30929     1             'DATAPLOT DATA')
30930            CALL DPWRST('XXX','BUG ')
30931            WRITE(ICOUT,724)MAXCOL
30932  724       FORMAT('      ARRAY HAS JUST EXCEEDED THE ALLOWABLE ',
30933     1             'MAXIMUM (',I5,')')
30934            CALL DPWRST('XXX','BUG ')
30935            IERROR='YES'
30936            GOTO8800
30937          ENDIF
30938C
30939          IHNAME(INAM)=JVNAM1(IE)
30940          IHNAM2(INAM)=JVNAM2(IE)
30941          IUSE(INAM)='V'
30942          IVALUE(INAM)=ICOL
30943          IECOL2(IE)=ICOL
30944          IN(INAM)=0
30945        ENDIF
30946  700 CONTINUE
30947      NUMNAM=INAM
30948      NUMCOL=ICOL
30949C
30950      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
30951        WRITE(ICOUT,999)
30952        CALL DPWRST('XXX','BUG ')
30953        WRITE(ICOUT,791)NUMNAM,NUMCOL,NUMNAM,ICASRE
30954  791   FORMAT('NUMNAM,NUMCOL,NUMNAM,ICASRE = ',3I8,2X,A4)
30955        CALL DPWRST('XXX','BUG ')
30956      ENDIF
30957C
30958C               ********************************************************
30959C               **  STEP 7--                                          **
30960C               **  FIRST, BRANCH TO THE APPROPRIATE SUBCASE          **
30961C               **  (DEPENDING ON WHETHER UNQUALIFIED, SUBSET OR FOR);**
30962C               **  THE DETERMINE THE LENGTH OF THE LONGEST           **
30963C               **  VARIABLE TO BE READ    IN ;                       **
30964C               **  THEN READ IN  THE VARIABLES                       **
30965C               **  THAT WERE SPECIFIED.                              **
30966C               ********************************************************
30967C
30968      ISTEPN='7'
30969      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30970     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30971C
30972C               *******************************************
30973C               **  STEP 8--                             **
30974C               **  IF A DATA ROW MINIMUM EXISTS AND SO  **
30975C               **  OUR ATTENTION IS FOCUSED ONLY ON     **
30976C               **  CERTAIN ROWS OF THE DATA FILE,       **
30977C               **  THEN GO DOWN TO THE FIRST SUCH ROW   **
30978C               **  IN THE FILE.                         **
30979C               *******************************************
30980C
30981      ISTEPN='8'
30982      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
30983     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30984C
30985      IF(IFROW1.GT.1)THEN
30986        IFRMIN=1
30987        IFRMAX=IFROW1-1
30988        IF(IFRMIN.GT.IFRMAX)GOTO7369
30989        MINCO2=1
30990        MAXCO2=NUMRCM
30991        IFCOL3=IFCOL1
30992        IFCOL4=IFCOL2
30993C
30994        DO7360IFROW=IFRMIN,IFRMAX
30995          NUMCHA=-1
30996          CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
30997     1                IA,NUMCHA,
30998     1                ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
30999          IF(IERROR.EQ.'YES')GOTO8800
31000          IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND.
31001     1      NUMCHA.EQ.3)THEN
31002            WRITE(ICOUT,999)
31003            CALL DPWRST('XXX','BUG ')
31004            WRITE(ICOUT,211)
31005            CALL DPWRST('XXX','BUG ')
31006            WRITE(ICOUT,7365)
31007 7365       FORMAT('      END OF FILE ENCOUNTERED WHILE SKIPPING OVER',
31008     1             'HEADER LINES.')
31009            CALL DPWRST('XXX','BUG ')
31010            WRITE(ICOUT,7367)
31011 7367       FORMAT('      NOTE SKIP AND ROW LIMITS SETTINGS--')
31012            CALL DPWRST('XXX','BUG ')
31013            WRITE(ICOUT,7368)ISKIP,IFROW1,AFROW2
31014 7368       FORMAT('      ISKIP,IFROW1,IFROW2 = ',2I8,2X,G15.7)
31015            CALL DPWRST('XXX','BUG ')
31016            IERROR='YES'
31017            GOTO8800
31018          ENDIF
31019 7360   CONTINUE
31020 7369   CONTINUE
31021      ENDIF
31022C
31023C               *******************************************
31024C               **  STEP 9--                             **
31025C               **  IN ADDITION, IF HEADER (= NON-DATA)  **
31026C               **  LINES EXIST WHICH ARE TO BE SKIPPED  **
31027C               **  OVER IN THE READ, DO SO HERE.        **
31028C               *******************************************
31029C
31030      ISTEPN='9'
31031      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
31032     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31033C
31034      IF(IFEEDB.EQ.'ON')THEN
31035        WRITE(ICOUT,999)
31036        CALL DPWRST('XXX','BUG ')
31037        IF(IFROW1.LE.1)THEN
31038          WRITE(ICOUT,7371)ISKIP
31039 7371     FORMAT('THE NUMBER OF HEADER LINES BEING SKIPPED = ',I8)
31040          CALL DPWRST('XXX','BUG ')
31041        ELSEIF(IFROW1.GE.2)THEN
31042          WRITE(ICOUT,7372)ISKIP
31043 7372     FORMAT('THE NUMBER OF (ADDITIONAL) HEADER LINES BEING ',
31044     1           'SKIPPED = ',I8)
31045          CALL DPWRST('XXX','BUG ')
31046        ENDIF
31047      ENDIF
31048C
31049      IF(ISKIP.EQ.-1)THEN
31050        IFRMIN=1
31051        MINCO2=1
31052        MAXCO2=NUMRCM
31053        IFCOL3=IFCOL1
31054        IFCOL4=IFCOL2
31055        IF(IRD2.EQ.IRD.AND.IFCOL4.GT.MAXCO2)IFCOL4=MAXCO2
31056        DO7378I=1,50000
31057          NUMCHA=-1
31058          CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
31059     1                IA,NUMCHA,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
31060C
31061          IF(IERROR.EQ.'YES')GOTO8800
31062          IF(IA(1).EQ.'-'.AND.IA(2).EQ.'-'.AND.IA(3).EQ.'-'.AND.
31063     1      IA(4).EQ.'-')THEN
31064            GOTO7389
31065          ENDIF
31066          IF(NUMCHA.GE.5)THEN
31067            DO7379LL=1,NUMCHA-3
31068              IF(IA(LL).EQ.'-'.AND.IA(LL+1).EQ.'-'.AND.
31069     1          IA(LL+2).EQ.'-'.AND.IA(LL+3).EQ.'-')THEN
31070                GOTO7389
31071              ENDIF
31072 7379       CONTINUE
31073          ENDIF
31074          IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND.
31075     1      NUMCHA.EQ.3)THEN
31076            REWIND IOUNIT
31077            GOTO7389
31078          ENDIF
31079 7378   CONTINUE
31080      ENDIF
31081C
31082      IF(ISKIP.LE.0)GOTO7389
31083      IFRMIN=IFROW1
31084      IFRMAX=IFROW1+ISKIP-1
31085      IF(IFRMIN.GT.IFRMAX)GOTO7389
31086      MINCO2=1
31087      MAXCO2=NUMRCM
31088      IFCOL3=IFCOL1
31089      IFCOL4=IFCOL2
31090C
31091      DO7380IFROW=IFRMIN,IFRMAX
31092        NUMCHA=-1
31093        CALL DPREFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
31094     1              IA,NUMCHA,
31095     1              ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
31096        IF(IERROR.EQ.'YES')GOTO8800
31097        IF(IA(1).EQ.'E'.AND.IA(2).EQ.'O'.AND.IA(3).EQ.'F'.AND.
31098     1      NUMCHA.EQ.3)THEN
31099          WRITE(ICOUT,999)
31100          CALL DPWRST('XXX','BUG ')
31101          WRITE(ICOUT,211)
31102          CALL DPWRST('XXX','BUG ')
31103          WRITE(ICOUT,7365)
31104          CALL DPWRST('XXX','BUG ')
31105          WRITE(ICOUT,7367)
31106          CALL DPWRST('XXX','BUG ')
31107          WRITE(ICOUT,7368)ISKIP,IFROW1,AFROW2
31108          CALL DPWRST('XXX','BUG ')
31109          IERROR='YES'
31110          GOTO8800
31111        ENDIF
31112 7380 CONTINUE
31113 7389 CONTINUE
31114C
31115C               ************************
31116C               **  STEP 10--         **
31117C               **  READ IN THE DATA  **
31118C               ************************
31119C
31120      ISTEPN='10'
31121      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
31122     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31123C
31124      DO7260I=1,MAXRCL
31125        ISTOR1(I)=' '
31126        ISTOR2(I)=' '
31127        ISTOR3(I)=' '
31128        IB(I)=' '
31129 7260 CONTINUE
31130C
31131      IF(NUMV.GT.0)THEN
31132        DO7300I=1,NUMV
31133          IEN(I)=0
31134 7300   CONTINUE
31135      ENDIF
31136C
31137      MINCO2=1
31138      MAXCO2=NUMRCM
31139      IFCOL3=IFCOL1
31140      IFCOL4=IFCOL2
31141C
31142      I=0
31143      IIN=0
31144      NUMLRD=0
31145      NUMLGR=0
31146      IENDTY=1
31147      IEND='NO'
31148      IF(ISKIP.GE.0)THEN
31149        IFRMIN=IFROW1+ISKIP
31150CCCCC   IF(ICASEQ.EQ.'FOR')IFRMIN=IFROW1+ISKIP+IROW1-1
31151      ELSE
31152        IFRMIN=1
31153CCCCC   IF(ICASEQ.EQ.'FOR')IFRMIN=IROW1
31154      ENDIF
31155C
31156      IFRMAX=IFROW2
31157C
31158      IF(IFRMAX.GE.IBILLI)IFRMAX=IBILLI
31159      IF(IFRMIN.GT.IFRMAX)GOTO7490
31160C
31161      NCALL=0
31162      I=0
31163      ICNT2=0
31164      IEOF=0
31165      IMAXRW=IFRMAX-IFRMIN+1
31166      IFLGSV=0
31167      DO7400IFROW=IFRMIN,IFRMAX
31168C
31169        IIN=IIN+1
31170        IF(NCREAF.LE.0)THEN
31171C
31172C         CASE 1: NO SET READ FORMAT GIVEN
31173C
31174          NXC=0
31175          CALL DPREAL(IRD2,IFCOL3,IFCOL4,MINCO2,MAXCO2,X0,NUMDPL,IFLGSV,
31176     1                IXC,NXC,
31177     1                ICASRE,IFUNC2,N2,MAXN2,
31178     1                IMACRO,IMACNU,IMACCS,
31179     1                IANSLC,IWIDTH,IREACS,ISTOR1,ISTOR2,IEND,NUMLRD,
31180     1                IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
31181     1                ICOMCH,ICOMSW,LINETY,IGRPA2,
31182     1                IFCOLL,IFCOLU,ITYPE,NCOLS,NCALL,
31183     1                IREADL,IDATDL,ITIMDL,IRDIPA,PREAMV,
31184     1                MAXRDV,MAXCHV,IFIETY,
31185     1                IDECPT,IDATMV,IDATNN,
31186     1                IREACD,IREACM,IREADS,IREAPM,IREAMC,ITABNC,
31187     1                IREAAS,IREAPC,
31188     1                IB,
31189     1                IOTERM,IANSLO,MAXLIL,MAXCIL,ILOOST,ILOOLI,
31190     1                IREPCH,IMALEV,
31191     1                IERRFI,IBUGS2,ISUBRO,IERROR)
31192          IF(LINETY.EQ.'BLAN')GOTO7400
31193          IF(NUMDPL.LT.IMNVAR)IMNVAR=NUMDPL
31194          IF(NUMDPL.GT.IMXVAR)IMXVAR=NUMDPL
31195          NUMLRD=NUMLRD+1
31196          NCALL=NCALL+1
31197C
31198C
31199C         IF CHARACTER DATA ENCOUNTERED, CONVERT IT TO CATEGORICAL
31200C         NUMERIC DATA.  FOR STREAM READ, DO NOT WRITE ANYTHING TO
31201C         DPZCHF.DAT.
31202C
31203          IF(NXC.GT.0)THEN
31204            IF(IGRPAU.EQ.'CATE')THEN
31205              DO27820J=1,NXC
31206                NTEMP=IXCATN(J)
31207                IF(NTEMP.LT.1)THEN
31208                  IXCATN(J)=1
31209                  IXCAT(1,J)(1:24)=IXC(J)(1:24)
31210                  IF(ISREGL.EQ.'ON')THEN
31211                    IVAL=IGRP1 + J - 1
31212                    IF(IVAL.LE.MAXGRP)IGRPLA(1,IVAL)(1:24)=IXC(J)(1:24)
31213                  ENDIF
31214                  X0CAT(J)=1.0
31215                ELSE
31216                  DO27830II=1,NTEMP
31217                    IF(IXC(J)(1:24).EQ.IXCAT(II,J)(1:24))THEN
31218                      X0CAT(J)=REAL(II)
31219                      GOTO27820
31220                    ENDIF
3122127830             CONTINUE
31222                  NTEMP2=IXCATN(J)
31223                  IF(NTEMP2.GT.1000)THEN
31224                    X0CAT(J)=-1.0
31225                  ELSE
31226                    IXCATN(J)=IXCATN(J)+1
31227                    IXCAT(IXCATN(J),J)(1:24)=IXC(J)(1:24)
31228                    X0CAT(J)=REAL(IXCATN(J))
31229                    IF(ISREGL.EQ.'ON')THEN
31230                      IVAL=IGRP1 + J - 1
31231                      IF(IVAL.LE.MAXGRP)IGRPLA(IXCATN(J),IVAL)(1:24)=
31232     1                  IXC(J)(1:24)
31233                    ENDIF
31234                  ENDIF
31235                ENDIF
3123627820         CONTINUE
31237C
31238C             NOW MERGE X0 AND X0CAT
31239C
31240              NTOTVA=NXC+NUMDPL
31241              ICNT1=0
31242              ICNT2=0
31243              DO27840J=1,NTOTVA
31244                IF(ITYPE(J).EQ.1)THEN
31245                  ICNT2=ICNT2+1
31246                  X02(J)=X0CAT(ICNT2)
31247                  IF(J.EQ.IRWLCO)X02(J)=REAL(NUMLRD)
31248                  IF(ISREGL.EQ.'ON')THEN
31249                    IVAL=IGRP1 + ICNT2 - 1
31250                    IF(IVAL.LE.MAXGRP .AND. IGRPVN(IVAL).EQ.' ')THEN
31251                      IGRPVN(IVAL)(1:4)=JVNAM1(J)(1:4)
31252                      IGRPVN(IVAL)(5:8)=JVNAM2(J)(1:4)
31253                    ENDIF
31254                  ENDIF
31255                ELSE
31256                  ICNT1=ICNT1+1
31257                  X02(J)=X0(ICNT1)
31258                ENDIF
3125927840         CONTINUE
31260              DO27850J=1,NTOTVA
31261                X0(J)=X02(J)
3126227850         CONTINUE
31263            ENDIF
31264C
31265          ENDIF
31266C
31267          IF(IEND.EQ.'YES')THEN
31268            IEOF=1
31269            IF(ICASRE.EQ.'GSTA')GOTO7440
31270            IF(ICASRE.EQ.'DSTA')GOTO7440
31271            IF(ICASRE.EQ.'FSTA')GOTO7440
31272            IF(ICASRE.EQ.'CSTA')GOTO7440
31273            IF(ICASRE.EQ.'CORR')GOTO7440
31274            IF(ICASRE.EQ.'COVA')GOTO7440
31275            IF(ICASRE.EQ.'EDIS')GOTO7440
31276            IF(ICASRE.EQ.'MDIS')GOTO7440
31277            IF(ICASRE.EQ.'CDIS')GOTO7440
31278            IF(ICASRE.EQ.'CODI')GOTO7440
31279            IF(ICASRE.EQ.'COSI')GOTO7440
31280            IF(ICASRE.EQ.'ACDI')GOTO7440
31281            IF(ICASRE.EQ.'ACSI')GOTO7440
31282            IF(ICASRE.EQ.'JASI')GOTO7440
31283            IF(ICASRE.EQ.'JADI')GOTO7440
31284            IF(ICASRE.EQ.'HDIS')GOTO7440
31285            IF(ICASRE.EQ.'CNDI')GOTO7440
31286            IF(ICASRE.EQ.'CTED')GOTO7440
31287            IF(ICASRE.EQ.'CTCD')GOTO7440
31288            IF(ICASRE.EQ.'CTMD')GOTO7440
31289            IF(ICASRE.EQ.'CCOD')GOTO7440
31290            IF(ICASRE.EQ.'CCOS')GOTO7440
31291            IF(ICASRE.EQ.'CACD')GOTO7440
31292            IF(ICASRE.EQ.'CACS')GOTO7440
31293            IF(ICASRE.EQ.'CJAS')GOTO7440
31294            IF(ICASRE.EQ.'CJAD')GOTO7440
31295            IF(ICASRE.EQ.'CTCR')GOTO7440
31296            IF(ICASRE.EQ.'CTCV')GOTO7440
31297            IF(ICASRE.EQ.'CTHD')GOTO7440
31298            IF(ICASRE.EQ.'CTXD')GOTO7440
31299            IF(ICASRE.EQ.'CTPE')GOTO7440
31300            IF(ICASRE.EQ.'PERC')GOTO7440
31301            GOTO7490
31302         ENDIF
31303C
31304        ELSE
31305C
31306C         CASE 2: SET READ FORMAT GIVEN
31307C
31308          NUMLRD=NUMLRD+1
31309          NUMDPL=NUMV
31310          IF(ICOMSW.EQ.'ON')THEN
31311 7417       CONTINUE
31312            READ(IRD2,'(A80)',END=7480)IAJUNK
31313            IF(IAJUNK(1:1).EQ.ICOMCH(1:1))GOTO7417
31314            BACKSPACE(UNIT=IRD2,IOSTAT=IOS,ERR=7413)
31315            GOTO7415
31316 7413       CONTINUE
31317            WRITE(ICOUT,743)
31318 743        FORMAT('ERROR TRYING TO BACKSPACE FILE ON FORMATTED READ')
31319            CALL DPWRST('XXX','BUG ')
31320            GOTO7417
31321          ENDIF
31322          NUMVZZ=NUMV
31323          IF(ICASRE.EQ.'DSTA')NUMVZZ=NUMVZZ-1
31324          IF(ICASRE.EQ.'FSTA')NUMVZZ=NUMVZZ-1
31325          IEOF=0
31326          READ(IRD2,ICREAF,END=7480,ERR=7482)(X0(K),K=1,NUMVZZ)
31327          GOTO7415
31328C
31329 7480     CONTINUE
31330          IEOF=1
31331          IF(ICASRE.EQ.'GSTA')GOTO7440
31332          IF(ICASRE.EQ.'DSTA')GOTO7440
31333          IF(ICASRE.EQ.'FSTA')GOTO7440
31334          IF(ICASRE.EQ.'CSTA')GOTO7440
31335          IF(ICASRE.EQ.'CORR')GOTO7440
31336          IF(ICASRE.EQ.'COVA')GOTO7440
31337          IF(ICASRE.EQ.'EDIS')GOTO7440
31338          IF(ICASRE.EQ.'MDIS')GOTO7440
31339          IF(ICASRE.EQ.'CDIS')GOTO7440
31340          IF(ICASRE.EQ.'CODI')GOTO7440
31341          IF(ICASRE.EQ.'COSI')GOTO7440
31342          IF(ICASRE.EQ.'ACDI')GOTO7440
31343          IF(ICASRE.EQ.'ACSI')GOTO7440
31344          IF(ICASRE.EQ.'JASI')GOTO7440
31345          IF(ICASRE.EQ.'JADI')GOTO7440
31346          IF(ICASRE.EQ.'HDIS')GOTO7440
31347          IF(ICASRE.EQ.'CNDI')GOTO7440
31348          IF(ICASRE.EQ.'CTED')GOTO7440
31349          IF(ICASRE.EQ.'CTCD')GOTO7440
31350          IF(ICASRE.EQ.'CTMD')GOTO7440
31351          IF(ICASRE.EQ.'CCOD')GOTO7440
31352          IF(ICASRE.EQ.'CCOS')GOTO7440
31353          IF(ICASRE.EQ.'CACD')GOTO7440
31354          IF(ICASRE.EQ.'CACS')GOTO7440
31355          IF(ICASRE.EQ.'CJAS')GOTO7440
31356          IF(ICASRE.EQ.'CJAD')GOTO7440
31357          IF(ICASRE.EQ.'CTCR')GOTO7440
31358          IF(ICASRE.EQ.'CTCV')GOTO7440
31359          IF(ICASRE.EQ.'CTHD')GOTO7440
31360          IF(ICASRE.EQ.'CTXD')GOTO7440
31361          IF(ICASRE.EQ.'CTPE')GOTO7440
31362          IF(ICASRE.EQ.'PERC')GOTO7440
31363          GOTO7490
31364C
31365 7482     CONTINUE
31366          WRITE(ICOUT,999)
31367          CALL DPWRST('XXX','BUG ')
31368          WRITE(ICOUT,211)
31369          CALL DPWRST('XXX','BUG ')
31370          WRITE(ICOUT,7483)IFROW
31371 7483     FORMAT('      ERROR READING LINE ',I10)
31372          CALL DPWRST('XXX','BUG ')
31373          IERROR='YES'
31374          GOTO8800
31375        ENDIF
31376C
31377 7415   CONTINUE
31378        IF(IERROR.EQ.'YES')GOTO8800
31379        IF(IFROW.EQ.IFRMIN)THEN
31380          DO7425K=1,132
31381            ISTOR3(K)=ISTOR2(K)
31382 7425     CONTINUE
31383          GOTO7430
31384        ENDIF
31385        IF(IEND.EQ.'YES')THEN
31386          IEOF=1
31387          IF(ICASRE.EQ.'GSTA')GOTO7440
31388          IF(ICASRE.EQ.'DSTA')GOTO7440
31389          IF(ICASRE.EQ.'FSTA')GOTO7440
31390          IF(ICASRE.EQ.'CSTA')GOTO7440
31391          IF(ICASRE.EQ.'CORR')GOTO7440
31392          IF(ICASRE.EQ.'COVA')GOTO7440
31393          IF(ICASRE.EQ.'EDIS')GOTO7440
31394          IF(ICASRE.EQ.'MDIS')GOTO7440
31395          IF(ICASRE.EQ.'CDIS')GOTO7440
31396          IF(ICASRE.EQ.'CODI')GOTO7440
31397          IF(ICASRE.EQ.'COSI')GOTO7440
31398          IF(ICASRE.EQ.'ACDI')GOTO7440
31399          IF(ICASRE.EQ.'ACSI')GOTO7440
31400          IF(ICASRE.EQ.'JASI')GOTO7440
31401          IF(ICASRE.EQ.'JADI')GOTO7440
31402          IF(ICASRE.EQ.'HDIS')GOTO7440
31403          IF(ICASRE.EQ.'CNDI')GOTO7440
31404          IF(ICASRE.EQ.'CTED')GOTO7440
31405          IF(ICASRE.EQ.'CTCD')GOTO7440
31406          IF(ICASRE.EQ.'CTMD')GOTO7440
31407          IF(ICASRE.EQ.'CCOD')GOTO7440
31408          IF(ICASRE.EQ.'CCOS')GOTO7440
31409          IF(ICASRE.EQ.'CACD')GOTO7440
31410          IF(ICASRE.EQ.'CACS')GOTO7440
31411          IF(ICASRE.EQ.'CJAS')GOTO7440
31412          IF(ICASRE.EQ.'CJAD')GOTO7440
31413          IF(ICASRE.EQ.'CTCR')GOTO7440
31414          IF(ICASRE.EQ.'CTCV')GOTO7440
31415          IF(ICASRE.EQ.'CTHD')GOTO7440
31416          IF(ICASRE.EQ.'CTXD')GOTO7440
31417          IF(ICASRE.EQ.'CTPE')GOTO7440
31418          IF(ICASRE.EQ.'PERC')GOTO7440
31419          GOTO7490
31420        ENDIF
31421C
31422 7430   CONTINUE
31423        I=I+1
31424C
31425        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
31426          WRITE(ICOUT,999)
31427          CALL DPWRST('XXX','BUG ')
31428          WRITE(ICOUT,7431)
31429 7431     FORMAT('***** FROM THE MIDDLE OF DPSTRE--')
31430          CALL DPWRST('XXX','BUG ')
31431          AFRMAX=IFRMAX
31432          WRITE(ICOUT,7432)IFROW,IFRMIN,AFRMAX
31433 7432     FORMAT('IFROW,IFRMIN,AFRMAX = ',2I8,G15.7)
31434          CALL DPWRST('XXX','BUG ')
31435          WRITE(ICOUT,7434)MAXN,MAXCOL,MAXCP1,MAXCP2
31436 7434     FORMAT('MAXN,MAXCOL,MAXCP1,MAXCP2 = ',4I8)
31437          CALL DPWRST('XXX','BUG ')
31438          WRITE(ICOUT,7435)X0(1),X0(2),X0(3)
31439 7435     FORMAT('X0(1),X0(2),X0(3) = ',3G15.7)
31440          CALL DPWRST('XXX','BUG ')
31441          WRITE(ICOUT,7436)IECOL2(1),IECOL2(2),IECOL2(3)
31442 7436     FORMAT('IECOL2(1),IECOL2(2),IECOL2(3) = ',3I8)
31443          CALL DPWRST('XXX','BUG ')
31444          WRITE(ICOUT,7437)IEN(1),IEN(2),IEN(3)
31445 7437     FORMAT('IEN(1),IEN(2),IEN(3) = ',3I8)
31446          CALL DPWRST('XXX','BUG ')
31447          WRITE(ICOUT,7438)ICASRE,NUMVRD,NUMPRD,NUMFRD
31448 7438     FORMAT('ICASRE,NUMVRD,NUMPRD,NUMFRD = ',A4,3I8)
31449          CALL DPWRST('XXX','BUG ')
31450        ENDIF
31451C
31452 7440   CONTINUE
31453C
31454C       IF NUMBER OF REQUESTED ITEMS IS GREATER THAN NUMBER OF ITEMS
31455C       ON THE LINE, PAD WITH MISSING VALUE (PREAMV).
31456C
31457C       THE SET READ PAD MISSING COLUMNS COMMANDS DETERMINES WHETHER WE
31458C       PAD OR USE THE PREVIOUS BEHAVIOR (I.E., IN SOME CASES, A MISSING
31459C       COLUMN MAY INDICATE AN ERROR).
31460C
31461
31462        IF(ICASRE.EQ.'WRIT')THEN
31463C
31464C         CASE 1: FORMATTED WRITE TO OUTPUT FILE.  IF NO SET WRITE
31465C                 FORMAT IS ACTIVE, USE "E15.7" FOR ALL VARIABLES.
31466C
31467          ISTEPN='10A'
31468          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
31469     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31470C
31471          IF(IFROW.EQ.IFRMAX .OR. IEOF.EQ.1)GOTO7490
31472C
31473          IF(NCWRIF.GT.0)THEN
31474            WRITE(IOUNI2,ICWRIF,ERR=17740) (X0(JJ),JJ=1,NUMV)
31475            GOTO17749
31476C
3147717740       CONTINUE
31478            WRITE(ICOUT,999)
31479            CALL DPWRST('XXX','BUG ')
31480            WRITE(ICOUT,211)
31481            CALL DPWRST('XXX','BUG ')
31482            WRITE(ICOUT,17741)
3148317741       FORMAT('      ERROR WITH FORMATTED WRITE WHEN WRITING TO ',
31484     1             'THE OUTPUT FILE.')
31485            CALL DPWRST('XXX','BUG ')
31486            IERROR='YES'
31487            GOTO8800
3148817749       CONTINUE
31489          ELSE
31490            IFORMT='(   E15.7)'
31491            WRITE(IFORMT(2:4),'(I3)')NUMV
31492            WRITE(IOUNI2,IFORMT) (X0(JJ),JJ=1,NUMV)
31493          ENDIF
31494C
31495        ELSEIF(ICASRE.EQ.'GSTA')THEN
31496C
31497C         CASE 2: COMPUTE A SPECIFIC STATISTIC FOR A SPECIFIED NUMBER
31498C                 OF ROWS FOR EACH VARIABLE.  TO MAKE IT EASIER TO
31499C                 EXTRACT FOR CMPSTA, STORE VALUES FOR A VARIABLE
31500C                 CONTINGUOUSLY.
31501C
31502C         GROUP CAN BE DEFINED BY EITHER A SET NUMBER OF ROWS OR
31503C         WHEN A SPECIFIED VARIABLE CHANGES VALUE.
31504C
31505          ISTEPN='10B'
31506          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
31507     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31508C
31509          IFLGSW=0
31510          IF(IVARGR.GT.0)THEN
31511            IF(NUMLGR.EQ.1)AHOLD=X0(IVARGR)
31512            IF(X0(IVARGR).NE.AHOLD)THEN
31513              IFLGSW=1
31514              AHOLD=X0(IVARGR)
31515            ENDIF
31516            ISTRID=MAXOBW/NUMV
31517          ELSE
31518            IF(NUMLGR.GE.ISRESI)IFLGSW=1
31519            ISTRID=ISRESI
31520          ENDIF
31521C
31522C         NOTE: IF DEFINING GROUPS BY A CHANGE IN VALUE FOR A
31523C               SPECIFIC VARIABLE, DON'T ADD CURRENT DATA UNTIL
31524C               COMPUTE STATISTIC FOR PREVIOUS GROUP.
31525C
31526          IF(IFLGSW.EQ.0)THEN
31527            IF(IEOF.EQ.0)THEN
31528              NUMLGR=NUMLGR+1
31529              DO7520JJ=1,NUMV
31530                IINDX=(JJ-1)*ISTRID + NUMLGR
31531                XSCRT(IINDX)=X0(JJ)
31532 7520         CONTINUE
31533            ENDIF
31534          ENDIF
31535C
31536          IF(IFLGSW.EQ.1 .OR. IFROW.EQ.IFRMAX .OR. IEOF.EQ.1)THEN
31537            IF(NUMLGR.GE.1)THEN
31538              ICNT2=ICNT2+1
31539C
31540C             CHECK TO SEE IF MAXIMUM NUMBER OF ROWS EXCEEDED
31541C
31542              IF(ICNT2.GT.MAXOBV)THEN
31543                WRITE(ICOUT,999)
31544                CALL DPWRST('XXX','BUG ')
31545                WRITE(ICOUT,211)
31546                CALL DPWRST('XXX','BUG ')
31547                WRITE(ICOUT,17751)
3154817751           FORMAT('      MAXIMUM NUMBER OF ROWS REACHED. ',
31549     1                 'THE INPUT FILE WILL BE TRUCATED.')
31550                CALL DPWRST('XXX','BUG ')
31551                IERROR='YES'
31552                GOTO8800
31553              ENDIF
31554C
31555              DO7530JJ=1,NUMV
31556                IINDX=(JJ-1)*ISTRID + 1
31557                CALL CMPSTA(XSCRT(IINDX),TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
31558     1                      MAXOBV,NUMLGR,NUMLGR,NUMLGR,ISTANR,ICASS7,
31559     1                      ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,
31560     1                      ITEMP5,ITEMP6,
31561     1                      DTEMP1,DTEMP2,DTEMP3,
31562     1                      Z0,
31563     1                      ISUBRO,IBUGS2,IERROR)
31564                ICOLVJ=IECOL2(JJ)
31565                IJ=MAXN*(ICOLVJ-1)+ICNT2
31566                IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
31567                IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
31568                IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
31569                IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
31570                IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
31571                IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
31572                IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
31573 7530         CONTINUE
31574            ENDIF
31575            NUMLGR=0
31576          ENDIF
31577          IF(IFROW.EQ.IFRMAX .OR. IEOF.EQ.1)GOTO7490
31578C
31579C         NOTE: IF DEFINING GROUPS BY A CHANGE IN VALUE FOR A
31580C               SPECIFIC VARIABLE, DON'T ADD CURRENT DATA UNTIL
31581C               COMPUTE STATISTIC FOR PREVIOUS GROUP.
31582C
31583          IF(IFLGSW.EQ.1)THEN
31584            IF(IEOF.EQ.0)THEN
31585              NUMLGR=NUMLGR+1
31586              DO7529JJ=1,NUMV
31587                IINDX=(JJ-1)*ISTRID + NUMLGR
31588                XSCRT(IINDX)=X0(JJ)
31589 7529         CONTINUE
31590            ENDIF
31591          ENDIF
31592        ELSEIF(ICASRE.EQ.'DSTA')THEN
31593C
31594C         CASE 3: COMPUTE A SET OF DEFAULT STATISTICS FOR A SPECIFIED
31595C                 NUMBER OF ROWS FOR EACH VARIABLE.  TO MAKE IT EASIER TO
31596C                 EXTRACT FOR CMPSTA, STORE VALUES FOR A VARIABLE
31597C                 CONTINGUOUSLY.
31598C
31599C                 THE DEFAULT STATISTICS ARE:
31600C
31601C                    1. VALUE OF LAST ROW OF GROUP
31602C                    2. GROUP-ID
31603C                    3. SIZE
31604C                    4. MINIMUM
31605C                    5. MAXIMUM
31606C                    6. MEAN
31607C                    7. STANDARD DEVIATION
31608C                    8. SKEWNESS
31609C                    9. KURTOSIS
31610C                   10. MEDIAN
31611C                   11. INTERQUARTILE RANGE
31612C                   12. RANGE
31613C                   13. AUTOCORRELATION
31614C                   14. LOWER QUARTILE
31615C                   15. UPPER QUARTILE
31616C                   16. 0.01 QUANTILE
31617C                   17. 0.05 QUANTILE
31618C                   18. 0.10 QUANTILE
31619C                   19. 0.25 QUANTILE
31620C                   20. 0.75 QUANTILE
31621C                   21. 0.90 QUANTILE
31622C                   22. 0.95 QUANTILE
31623C                   23. 0.99 QUANTILE
31624C
31625C         GROUP CAN BE DEFINED BY EITHER A SET NUMBER OF ROWS OR
31626C         WHEN A SPECIFIED VARIABLE CHANGES VALUE.
31627C
31628C         NOTE: IF GROUP BY VARIABLE RATHER THAN FIXED NUMBER OF
31629C               ROWS, NEED TO BE CAREFUL IN HOW WE INDEX.
31630C
31631          ISTEPN='10C'
31632          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
31633     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31634C
31635          IFLGSW=0
31636          IF(IVARGR.GT.0)THEN
31637            IF(NUMLGR.EQ.1)AHOLD=X0(IVARGR)
31638            IF(X0(IVARGR).NE.AHOLD)THEN
31639              IFLGSW=1
31640              AHOLD=X0(IVARGR)
31641            ENDIF
31642            ISTRID=MAXOBW/NUMV
31643          ELSE
31644            IF(NUMLGR.GE.ISRESI)IFLGSW=1
31645            ISTRID=ISRESI
31646          ENDIF
31647C
31648          IF(NUMLGR.GT.ISTRID)THEN
31649            WRITE(ICOUT,999)
31650            CALL DPWRST('XXX','BUG ')
31651            WRITE(ICOUT,211)
31652            CALL DPWRST('XXX','BUG ')
31653            WRITE(ICOUT,7531)ISTRID
31654 7531       FORMAT('      NUMBER OF OBSERVATIONS WITHIN A GROUP ',
31655     1             'EXCEEDS THE MAXIMUM OF ',I10)
31656            CALL DPWRST('XXX','BUG ')
31657            IERROR='YES'
31658            GOTO9000
31659          ENDIF
31660C
31661C         NOTE: IF DEFINING GROUPS BY A CHANGE IN VALUE FOR A
31662C               SPECIFIC VARIABLE, DON'T ADD CURRENT DATA UNTIL
31663C               COMPUTE STATISTIC FOR PREVIOUS GROUP.
31664C
31665C         NOTE: IN ADDITION TO THE LIST OF STATISTICS, ADD THE
31666C               FOLLOWING ROWS:
31667C
31668C                  1. THE VALUE OF THE VARIABLE.  NOTE THAT THIS
31669C                     WILL BE THE VALUE OF THE LAST ROW OF THE
31670C                     GROUP.  IT IS PRIMARILY INTENDED FOR DISCRETE
31671C                     VARIABLES.
31672C
31673C                  2. THE GROUP NUMBER VALUE.
31674C
31675          IF(IFLGSW.EQ.0)THEN
31676            IF(IEOF.EQ.0)THEN
31677              NUMLGR=NUMLGR+1
31678              DO7525JJ=1,NUMV-1
31679                IINDX=(JJ-1)*ISTRID + NUMLGR
31680                XSCRT(IINDX)=X0(JJ)
31681 7525         CONTINUE
31682            ENDIF
31683          ENDIF
31684C
31685          IF(IFLGSW.EQ.1 .OR. IFROW.EQ.IFRMAX .OR. IEOF.EQ.1)THEN
31686            IF(NUMLGR.GE.1)THEN
31687              DO7540KK=1,NDEFST+NQUAN-1
31688                ICNT2=ICNT2+1
31689C
31690C               CHECK TO SEE IF MAXIMUM NUMBER OF ROWS EXCEEDED
31691C
31692                IF(ICNT2.GT.MAXOBV)THEN
31693                  WRITE(ICOUT,999)
31694                  CALL DPWRST('XXX','BUG ')
31695                  WRITE(ICOUT,211)
31696                  CALL DPWRST('XXX','BUG ')
31697                  WRITE(ICOUT,17751)
31698                  CALL DPWRST('XXX','BUG ')
31699                  IERROR='YES'
31700                  GOTO8800
31701                ENDIF
31702C
31703                IF(KK.GE.NDEFST .AND. KK.LE.NDEFST+NQUAN-1)THEN
31704                  IROWT=KK-NDEFST+1
31705                  XQUAN=XQ(IROWT)
31706                ELSE
31707                  ICASS7=LISTST(KK)
31708                ENDIF
31709                DO7545JJ=1,NUMV
31710                  IF(JJ.EQ.NUMV)THEN
31711                    Z0=REAL(KK)
31712                  ELSEIF(KK.EQ.1)THEN
31713                    IINDX=(JJ-1)*ISTRID + 1
31714                    Z0=XSCRT(IINDX)
31715                  ELSEIF(KK.EQ.2)THEN
31716                    Z0=REAL(NGRP)
31717                  ELSEIF(KK.EQ.3)THEN
31718                    Z0=REAL(NUMLGR)
31719                  ELSEIF(KK.GE.NDEFST .AND. KK.LE.NDEFST+NQUAN-1)THEN
31720                    IINDX=(JJ-1)*ISTRID + 1
31721                    IWRITE='OFF'
31722                    CALL QUANT(XQUAN,XSCRT(IINDX),NUMLGR,IWRITE,
31723     1                         TEMP1,MAXOBV,
31724     1                         IQUAME,
31725     1                         Z0,IBUGS2,IERROR)
31726                  ELSE
31727                    IINDX=(JJ-1)*ISTRID + 1
31728                    CALL CMPSTA(XSCRT(IINDX),TEMP1,TEMP2,TEMP3,
31729     1                          TEMP4,TEMP5,
31730     1                          MAXOBV,NUMLGR,NUMLGR,NUMLGR,
31731     1                          ISTANR,ICASS7,
31732     1                          ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,
31733     1                          ITEMP5,ITEMP6,
31734     1                          DTEMP1,DTEMP2,DTEMP3,
31735     1                          Z0,
31736     1                          ISUBRO,IBUGS2,IERROR)
31737                  ENDIF
31738                  ICOLVJ=IECOL2(JJ)
31739                  IJ=MAXN*(ICOLVJ-1)+ICNT2
31740                  IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
31741                  IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
31742                  IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
31743                  IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
31744                  IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
31745                  IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
31746                  IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
31747 7545           CONTINUE
31748 7540         CONTINUE
31749            ENDIF
31750            NUMLGR=0
31751          ENDIF
31752          IF(IFROW.EQ.IFRMAX .OR. IEOF.EQ.1)GOTO7490
31753C
31754C         NOTE: IF DEFINING GROUPS BY A CHANGE IN VALUE FOR A
31755C               SPECIFIC VARIABLE, DON'T ADD CURRENT DATA UNTIL
31756C               COMPUTE STATISTIC FOR PREVIOUS GROUP.
31757C
31758          IF(IFLGSW.EQ.1)THEN
31759            IF(IEOF.EQ.0)THEN
31760              NGRP=NGRP+1
31761              NUMLGR=NUMLGR+1
31762              DO7528JJ=1,NUMV
31763                IINDX=(JJ-1)*ISTRID + NUMLGR
31764                XSCRT(IINDX)=X0(JJ)
31765 7528         CONTINUE
31766            ENDIF
31767          ENDIF
31768        ELSEIF(ICASRE.EQ.'FSTA')THEN
31769C
31770C         CASE 4: ONE PASS COMPUTATION FOR A LIST OF STATISTICS
31771C
31772C                 CURRENTLY, COMPUTE THE FOLLOWING STATISTICS:
31773C
31774C                   1. COUNT
31775C                   2. MINIMUM
31776C                   3. MAXIMUM
31777C                   4. MEAN
31778C                   5. STANDARD DEVIATION
31779C                   6. SKEWNESS
31780C                   7. KURTOSIS
31781C                   8. RANGE
31782C                   9. AUTOCORRELATION (NOT YET SUPPORTED)
31783C                  10. M2 (SECOND CENTRAL MOMENT)
31784C                  11. M3 (THIRD CENTRAL MOMENT)
31785C                  12. M4 (FOURTH CENTRAL MOMENT)
31786C                  13. Q (USED IN STANDARD DEVIATION COMPUTATION)
31787C
31788C                  NOTE THAT M2, M3, M4, AND Q ARE USED TO COMPUTE THE
31789C                  SKEWNESS, KURTOSIS AND SD.  HOWEVER, THEY WILL NOT BE
31790C                  SAVED.
31791C
31792C         2018/07: DO NOT INCLUDE MISSING VALUES (AS DEFINED BY THE
31793C                  "SET READ MISSING VALUE <VALUE>" COMMAND.
31794C
31795          ISTEPN='10D'
31796          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
31797     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31798C
31799          IF(IEOF.EQ.0 .AND. IFROW.LE.IFRMAX)THEN
31800            DO7575JJ=1,NUMV
31801              IF(X0(JJ).EQ.PREAMV)GOTO7575
31802              XSCRT(JJ)=XSCRT(JJ) + 1.0
31803              NUMLGR=INT(XSCRT(JJ) + 0.1)
31804              NVAL=NUMLGR
31805              IF(NUMLGR.EQ.1)THEN
31806                XSCRT(JJ+NUMV)=X0(JJ)
31807                XSCRT(JJ+2*NUMV)=X0(JJ)
31808                XSCRT(JJ+3*NUMV)=X0(JJ)
31809                XSCRT(JJ+4*NUMV)=0.0
31810                XSCRT(JJ+5*NUMV)=0.0
31811                XSCRT(JJ+6*NUMV)=0.0
31812                XSCRT(JJ+7*NUMV)=0.0
31813                XSCRT(JJ+8*NUMV)=0.0
31814                XSCRT(JJ+9*NUMV)=0.0
31815                XSCRT(JJ+10*NUMV)=0.0
31816                XSCRT(JJ+11*NUMV)=0.0
31817                XSCRT(JJ+12*NUMV)=0.0
31818              ELSE
31819                DNOLD=DBLE(NUMLGR-1)
31820                DNNEW=DBLE(NUMLGR)
31821                XSCRT(JJ+NUMV)=MIN(XSCRT(JJ+NUMV),X0(JJ))
31822                XSCRT(JJ+2*NUMV)=MAX(XSCRT(JJ+2*NUMV),X0(JJ))
31823                XSCRT(JJ+7*NUMV)=XSCRT(JJ+2*NUMV) - XSCRT(JJ+NUMV)
31824                DVALM1=DBLE(XSCRT(JJ+3*NUMV))
31825                DVALSO=DBLE(XSCRT(JJ+12*NUMV))
31826C
31827                DVAL=DBLE(X0(JJ))
31828                DELTA=DVAL - DVALM1
31829                DELTAN=DELTA/DNNEW
31830                DELTN2=DELTAN*DELTAN
31831                DTERM1=DELTA*DELTAN*DNOLD
31832C
31833                DMEAN=DVALM1 + DELTAN
31834C
31835                DTERM2=(DNOLD/DNNEW)*DELTA**2
31836                DVALS1=DVALSO + DTERM2
31837                DSD=DSQRT(DVALS1/DBLE(NUMLGR-1))
31838C
31839                DM2=DBLE(XSCRT(JJ+9*NUMV))
31840                DM3=DBLE(XSCRT(JJ+10*NUMV))
31841                DM4=DBLE(XSCRT(JJ+11*NUMV))
31842                DM4=DM4 + DTERM1*DELTN2*(DNNEW*DNNEW - 3.0D0*DNNEW
31843     1              + 3.0D0) + 6.0D0*DELTN2*DM2 - 4.0D0*DELTAN*DM3
31844                DM3=DM3 + DTERM1*DELTAN*(DNNEW - 2.0D0) -
31845     1              3.0D0*DELTAN*DM2
31846                DM2=DM2 + DTERM1
31847C
31848                IF(DM2.GT.0.0D0)THEN
31849                  DSKEW=DSQRT(DNNEW)*DM3/(DM2**1.5D0)
31850                  DKURT=(DNNEW*DM4)/(DM2*DM2)
31851                ELSE
31852                  IF(DM2.NE.0.0)THEN
31853                    DSKEW=0.0D0
31854                    DKURT=(DNNEW*DM4)/(DM2*DM2)
31855                  ELSE
31856                    DSKEW=0.0D0
31857                    DKURT=0.0D0
31858                  ENDIF
31859                ENDIF
31860C
31861C               COMPUTE AUTOCORRELATION.  USE THE ONE-PASS FORMULA
31862C               FOR CORRELATION.  THE COMPLICATION IS THAT FOR
31863C               AUTOCORRELATION WE ARE COMPUTING FOR A LAGGED
31864C               VERSION OF THE VARIABLE.  NOT CURRENTLY IMPLEMENTED.
31865C
31866                XSCRT(JJ+3*NUMV)=REAL(DMEAN)
31867                XSCRT(JJ+4*NUMV)=REAL(DSD)
31868                XSCRT(JJ+5*NUMV)=REAL(DSKEW)
31869                XSCRT(JJ+6*NUMV)=REAL(DKURT)
31870                XSCRT(JJ+9*NUMV)=REAL(DM2)
31871                XSCRT(JJ+10*NUMV)=REAL(DM3)
31872                XSCRT(JJ+11*NUMV)=REAL(DM4)
31873                XSCRT(JJ+12*NUMV)=REAL(DVALS1)
31874              ENDIF
31875 7575       CONTINUE
31876          ELSE
31877C
31878C           END OF FILE REACHED, SAVE COMPUTED STATISTIC
31879C
31880            NSTAT=8
31881            IF(NUMLGR.GE.1)THEN
31882              DO7560KK=1,NSTAT
31883                ICNT2=ICNT2+1
31884C
31885                DO7565JJ=1,NUMV
31886                  IF(JJ.EQ.NUMV)THEN
31887                    Z0=REAL(KK)
31888                  ELSE
31889                    IINDX=(KK-1)*NUMV + JJ
31890                    Z0=XSCRT(IINDX)
31891                  ENDIF
31892                  ICOLVJ=IECOL2(JJ)
31893                  IJ=MAXN*(ICOLVJ-1)+ICNT2
31894                  IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
31895                  IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
31896                  IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
31897                  IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
31898                  IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
31899                  IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
31900                  IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
31901 7565           CONTINUE
31902 7560         CONTINUE
31903            ENDIF
31904            GOTO7490
31905          ENDIF
31906C
31907        ELSEIF(ICASRE.EQ.'CORR' .OR. ICASRE.EQ.'COVA')THEN
31908C
31909C         CASE 7: ONE PASS COMPUTATION FOR COVARIANCE OR CORRELATION
31910C                 MATRIX
31911C
31912C         FOR THE ONE-PASS COVARIANCE COMPUTATIONS, YOU CAN
31913C         USE THE RECURRENCE RELATIONSHIP
31914C
31915C            C(n) = C(n-1) + (X(n) - Xbar(n-1))*(Y(n) - Ybar(n))
31916C
31917C         WHERE THE COVARIANCE CAN THEN BE COMPUTED AS C(n)/(n-1).
31918C
31919C         THE CORRELATION IS COV(X,Y)/S(X)*S(Y).  NOTE THAT WE ONLY
31920C         COMPUTE C(n) WHILE READING.  THE FINAL COVARIANCE/CORRELATION
31921C         IS COMPUTED ONLY AT THE SAVE STEP.
31922C
31923C         FOR THIS COMPUTATION WE NEED TO SAVE THE FOLLOWING SET OF
31924C         NUMVxNUMV MATRICES FOR THE RECURRENCE RELATION.
31925C
31926C             1. Cov(n)
31927C             2. N(n) (THE SAMPLE SIZE)
31928C             3. Xbar(n)
31929C             4. Ybar(n)
31930C
31931C         NOTE THAT THE VARIANCE CAN BE OBTAINED FROM THE DIAGONAL OF
31932C         THE FIRST MATRIX.
31933C
31934          ISTEPN='10D7'
31935          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
31936     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31937C
31938          ISTRT1=0
31939          ISTRT2=NUMV*NUMV
31940          ISTRT3=2*NUMV*NUMV
31941          ISTRT4=3*NUMV*NUMV
31942C
31943          IF(IEOF.EQ.0 .AND. IFROW.LE.IFRMAX)THEN
31944C
31945            DO7675JJ=1,NUMV
31946              IF(IVTYPE(JJ).EQ.0)GOTO7675
31947              IF(X0(JJ).EQ.PREAMV)GOTO7675
31948              DO7680KK=JJ,NUMV
31949                IF(IVTYPE(KK).EQ.0)GOTO7680
31950                IF(X0(KK).EQ.PREAMV)GOTO7680
31951                IINDX2=(JJ-1)*NUMV + KK
31952                IINDX3=(KK-1)*NUMV + JJ
31953C
31954C               CHECK IF THIS IS THE FIRST OBSERVATION
31955C
31956                IF(XSCRT(ISTRT2+IINDX2).LT.0.5)THEN
31957                  XSCRT(ISTRT1+IINDX2)=0.0
31958                  XSCRT(ISTRT2+IINDX2)=1.0
31959                  XSCRT(ISTRT3+IINDX2)=X0(JJ)
31960                  XSCRT(ISTRT4+IINDX2)=X0(KK)
31961                ELSE
31962                  DNOLD=DBLE(XSCRT(ISTRT2+IINDX2))
31963                  DNNEW=DNOLD + 1.0
31964                  DTERM3=DNOLD/DNNEW
31965                  XSCRT(ISTRT2+IINDX2)=REAL(DNNEW)
31966C
31967                  DVAL=DBLE(X0(JJ))
31968                  DVALM1=XSCRT(ISTRT3+IINDX2)
31969                  DTERM1=(DVAL - DVALM1)
31970                  DMEAN=DVALM1 + (DVAL - DVALM1)/DNNEW
31971                  XSCRT(ISTRT3+IINDX2)=REAL(DMEAN)
31972C
31973                  DVAL=DBLE(X0(KK))
31974                  DVALM1=XSCRT(ISTRT4+IINDX2)
31975                  DMEAN=DVALM1 + (DVAL - DVALM1)/DNNEW
31976                  DTERM2=(DVAL - DMEAN)
31977                  XSCRT(ISTRT4+IINDX2)=REAL(DMEAN)
31978C
31979                  DTERM3=DTERM1*DTERM2
31980                  DTERM4=DBLE(XSCRT(ISTRT1+IINDX2)) + DTERM3
31981                  XSCRT(ISTRT1+IINDX2)=REAL(DTERM4)
31982C
31983C                 ONLY NEED TO SAVE LOWER DIAGONAL FOR C(n)
31984C
31985                  XSCRT(ISTRT1 + IINDX3)=XSCRT(ISTRT1+IINDX2)
31986                  XSCRT(ISTRT2 + IINDX3)=XSCRT(ISTRT2+IINDX2)
31987                ENDIF
31988 7680         CONTINUE
31989 7675       CONTINUE
31990C
31991          ELSE
31992C
31993C           END OF FILE REACHED, SAVE COMPUTED STATISTIC
31994C
31995            DO7690IROW=1,NUMV
31996              IF(IVTYPE(IROW).EQ.0)GOTO7690
31997              DO7695ICOL=1,NUMV
31998                IF(IVTYPE(ICOL).EQ.0)GOTO7695
31999                IINDX=(IROW-1)*NUMV + ICOL
32000                Z0=XSCRT(ISTRT1+IINDX)
32001                ZN=XSCRT(ISTRT2+IINDX)
32002                IF(ZN.GT.1.5)THEN
32003                  Z0=Z0/(ZN-1.0)
32004                  IF(ICASRE.EQ.'CORR')THEN
32005                    IF(IROW.EQ.ICOL)THEN
32006                      Z0=1.0
32007                    ELSE
32008                      IINDX1=(IROW-1)*NUMV+IROW
32009                      IINDX2=(ICOL-1)*NUMV+ICOL
32010                      TERM1=XSCRT(ISTRT1+IINDX1)
32011                      ZN=XSCRT(ISTRT2+IINDX1)
32012                      TERM1=SQRT((TERM1/(ZN-1.0)))
32013                      TERM2=XSCRT(ISTRT1+IINDX2)
32014                      ZN=XSCRT(ISTRT2+IINDX1)
32015                      TERM2=SQRT(TERM2/(ZN-1.0))
32016                      IF(TERM1.GT.0.0 .AND. TERM2.GT.0.0)THEN
32017                        Z0=Z0/(TERM1*TERM2)
32018                      ENDIF
32019                    ENDIF
32020                  ENDIF
32021                ELSE
32022                  Z0=0.0
32023                ENDIF
32024                ICOLVJ=IECOL2(ICOL)
32025                IJ=MAXN*(ICOLVJ-1)+IROW
32026                IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
32027                IF(ICOLVJ.EQ.MAXCP1)PRED(IROW)=Z0
32028                IF(ICOLVJ.EQ.MAXCP2)RES(IROW)=Z0
32029                IF(ICOLVJ.EQ.MAXCP3)YPLOT(IROW)=Z0
32030                IF(ICOLVJ.EQ.MAXCP4)XPLOT(IROW)=Z0
32031                IF(ICOLVJ.EQ.MAXCP5)X2PLOT(IROW)=Z0
32032                IF(ICOLVJ.EQ.MAXCP6)TAGPLO(IROW)=Z0
32033 7695         CONTINUE
32034 7690       CONTINUE
32035            GOTO7490
32036          ENDIF
32037        ELSEIF(ICASRE.EQ.'EDIS' .OR. ICASRE.EQ.'MDIS' .OR.
32038     1         ICASRE.EQ.'CDIS' .OR. ICASRE.EQ.'CODI' .OR.
32039     1         ICASRE.EQ.'COSI' .OR. ICASRE.EQ.'ACDI' .OR.
32040     1         ICASRE.EQ.'JASI' .OR. ICASRE.EQ.'JADI' .OR.
32041     1         ICASRE.EQ.'HDIS' .OR. ICASRE.EQ.'CNDI' .OR.
32042     1         ICASRE.EQ.'ACSI')THEN
32043C
32044C         CASE 7: ONE PASS COMPUTATION FOR VARIOUS DISTANCE AND
32045C                 SIMILARITY STATISTICS
32046C
32047C         EUCLIDEAN DISTANCE:
32048C
32049C            D = SQRT(SUM[i=1 to n][(X(i) - Y(i))**2])
32050C
32051C         MANHATTAN DISTANCE:
32052C
32053C            D = SQRT(SUM[i=1 to n][|X(i) - Y(i)|])
32054C
32055C          CANBERRA DISTANCE:
32056C
32057C            D(ij)=SUM[k=1 to p][|X(ik) - X(jk)|/
32058C                  (|X(i)| + |Y(i)|)]
32059C
32060C         CHEBYCHEV DISTANCE:
32061C
32062C            D = MAX[i=1 to n][|X(i) - Y(i)|])
32063C
32064C         COSINE SIMILARITY:
32065C
32066C            D = SUM[i=1 to n][X(i)*Y(i)]/{SQRT(SUM[i=1 to n][X(i)**2])*
32067C                SQRT(SUM[i=1 to n][X(i)**2])}
32068C
32069C         COSINE DISTANCE:
32070C
32071C            D = 1 - COSINE SIMILARITY
32072C
32073C         ANGULAR COSINE DISTANCE:
32074C
32075C            D = (1/COSINE SIMILARITY)/PI
32076C
32077C         ANGULAR COSINE SIMILARITY:
32078C
32079C            D = 1 - ANGULAR COSINE DISTANCE
32080C
32081C         JACCARD SIMILARITY:
32082C
32083C            J = SUM[i=1 to n][MIN(X(i),Y(i))/SUM[i=1 to n][MAX(X(i),Y(I))]
32084C
32085C         JACCARD DISTANCE:
32086C
32087C            J = 1 - JACCARD SIMILARITY
32088C
32089C         HAMMING DISTANCE:
32090C
32091C            D = NUMBER OF ELEMENTS THAT DIFFER IN X AND Y
32092C
32093C         WE ONLY NEED TO DO THE SQRT WHEN WE GO TO SAVE
32094C         THE DISTANCE MATRIX.
32095C
32096C         DO NOT INCLUDE MISSING VALUES (AS DEFINED BY THE
32097C         "SET READ MISSING VALUE <VALUE>" COMMAND.
32098C
32099C         ALSO, SKIP COLUMNS THAT USER HAS IDENTIFIED AS
32100C         CATEGORICAL DATA.
32101C
32102          ISTEPN='10D7'
32103          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
32104     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32105C
32106          ISTRT1=0
32107          ISTRT2=NUMV*NUMV
32108          ISTRT3=2*NUMV*NUMV
32109          ISTRT4=3*NUMV*NUMV
32110C
32111          IF(IEOF.EQ.0 .AND. IFROW.LE.IFRMAX)THEN
32112            DO7775JJ=1,NUMV
32113              IF(IVTYPE(JJ).EQ.0)GOTO7775
32114              IF(X0(JJ).EQ.PREAMV)GOTO7775
32115              IINDX1=(JJ-1)*NUMV + JJ
32116              IF(ICASRE.EQ.'EDIS' .OR. ICASRE.EQ.'MDIS' .OR.
32117     1           ICASRE.EQ.'CDIS' .OR. ICASRE.EQ.'HDIS' .OR.
32118     1           ICASRE.EQ.'CNDI')THEN
32119                XSCRT(IIDX1)=0.0
32120                JSTRT=JJ+1
32121                IFLAGJ=0
32122              ELSE
32123                JSTRT=JJ
32124                IFLAGJ=1
32125              ENDIF
32126              IF((IFLAGJ.EQ.0 .AND. JJ.LT.NUMV) .OR.
32127     1           IFLAGJ.EQ.1)THEN
32128                DO7780KK=JSTRT,NUMV
32129                  IF(IVTYPE(KK).EQ.0)GOTO7780
32130                  IF(X0(KK).EQ.PREAMV)GOTO7780
32131                  IINDX2=(JJ-1)*NUMV + KK
32132                  IINDX3=(KK-1)*NUMV + JJ
32133                  IF(ICASRE.EQ.'EDIS')THEN
32134                    DEL=X0(JJ) - X0(KK)
32135                    XSCRT(IINDX2)=XSCRT(IINDX2) + DEL*DEL
32136                  ELSEIF(ICASRE.EQ.'MDIS')THEN
32137                    XSCRT(IINDX2)=XSCRT(IINDX2) + ABS(X0(JJ) - X0(KK))
32138                  ELSEIF(ICASRE.EQ.'MDIS')THEN
32139                    XSCRT(IINDX2)=XSCRT(IINDX2) + ABS(X0(JJ) - X0(KK))
32140                  ELSEIF(ICASRE.EQ.'CNDI')THEN
32141                    XSCRT(IINDX2)=XSCRT(IINDX2) + ABS(X0(JJ) - X0(KK))/
32142     1                            (ABS(X0(JJ)) + ABS(X0(KK)))
32143                  ELSEIF(ICASRE.EQ.'HDIS')THEN
32144                    IF(X0(JJ).NE.X0(KK))XSCRT(IINDX2)=XSCRT(IINDX2)+1.0
32145                  ELSEIF(ICASRE.EQ.'CDIS')THEN
32146                    XSCRT(IINDX2)=MAX(XSCRT(IINDX2),ABS(X0(JJ)-X0(KK)))
32147                  ELSEIF(ICASRE.EQ.'JASI' .OR. ICASRE.EQ.'JADI')THEN
32148                    AVAL1=MIN(X0(JJ),X0(KK))
32149                    AVAL2=MAX(X0(JJ),X0(KK))
32150                    XSCRT(IINDX2)=XSCRT(IINDX2) + AVAL1
32151                    XSCRT(ISTRT2+IINDX2)=XSCRT(ISTRT2+IINDX2) + AVAL2
32152                    XSCRT(ISTRT2+IINDX3)=XSCRT(ISTRT2+IINDX2)
32153                  ELSEIF(ICASRE.EQ.'CODI' .OR. ICASRE.EQ.'COSI' .OR.
32154     1                   ICASRE.EQ.'ACDI' .OR. ICASRE.EQ.'ACSI')THEN
32155                    IF(ICASRE.EQ.'CODI' .AND.
32156     1                (X0(JJ).LT.0.0 .OR. X0(KK).LT.0.0))THEN
32157                      WRITE(ICOUT,999)
32158                      CALL DPWRST('XXX','BUG ')
32159                      WRITE(ICOUT,211)
32160                      CALL DPWRST('XXX','BUG ')
32161                      WRITE(ICOUT,22100)
3216222100                 FORMAT('      A NEGATIVE VALUE ENCOUNTERED ',
32163     1                       'TRYING TO COMPUTE COSINE DISTANCE.')
32164                      CALL DPWRST('XXX','BUG ')
32165                      WRITE(ICOUT,22103)IFROW
3216622103                 FORMAT('      ERROR OCCURRED READING LINE ',I10)
32167                      CALL DPWRST('XXX','BUG ')
32168                      IERROR='YES'
32169                      GOTO9000
32170                    ENDIF
32171                    IFLAGC=1
32172                    IF(X0(JJ).LT.0.0 .OR. X0(KK).LT.0.0)IFLAGC=0
32173                    XSCRT(IINDX2)=XSCRT(IINDX2) + X0(JJ)*X0(KK)
32174                    XSCRT(ISTRT2+IINDX2)=XSCRT(ISTRT2+IINDX2) +
32175     1                                   X0(JJ)*X0(JJ)
32176                    XSCRT(ISTRT3+IINDX2)=XSCRT(ISTRT3+IINDX2) +
32177     1                                   X0(KK)*X0(KK)
32178                    IF(IFLAGC.EQ.0)THEN
32179                      XSCRT(ISTRT4+IINDX2)=0.0
32180                    ELSE
32181                      IF(IFROW.EQ.IFRMIN)THEN
32182                        XSCRT(ISTRT4+IINDX2)=1.0
32183                      ENDIF
32184                    ENDIF
32185                    XSCRT(ISTRT2+IINDX3)=XSCRT(ISTRT2+IINDX2)
32186                    XSCRT(ISTRT3+IINDX3)=XSCRT(ISTRT3+IINDX2)
32187                    XSCRT(ISTRT4+IINDX3)=XSCRT(ISTRT4+IINDX2)
32188                  ENDIF
32189                  XSCRT(IINDX3)=XSCRT(IINDX2)
32190 7780           CONTINUE
32191              ENDIF
32192 7775       CONTINUE
32193C
32194          ELSE
32195C
32196C           END OF FILE REACHED, SAVE COMPUTED STATISTIC
32197C
32198            DO7790IROW=1,NUMV
32199              IF(IVTYPE(IROW).EQ.0)GOTO7790
32200              DO7795ICOL=1,NUMV
32201                IF(IVTYPE(ICOL).EQ.0)GOTO7795
32202                IINDX=(IROW-1)*NUMV + ICOL
32203                Z0=XSCRT(IINDX)
32204                IF(ICASRE.EQ.'EDIS')THEN
32205                  Z0=SQRT(Z0)
32206                ELSEIF(ICASRE.EQ.'CODI' .OR. ICASRE.EQ.'COSI' .OR.
32207     1                 ICASRE.EQ.'ACDI' .OR. ICASRE.EQ.'ACSI')THEN
32208                  IF(IROW.EQ.ICOL)THEN
32209                    Z0=1.0
32210                  ELSE
32211                    TERM1=SQRT(XSCRT(ISTRT2+IINDX))
32212                    TERM2=SQRT(XSCRT(ISTRT3+IINDX))
32213                    IF(TERM1.GT.0.0)THEN
32214                      Z0=Z0/(TERM1*TERM2)
32215                    ELSE
32216                      Z0=CPUMIN
32217                      GOTO7794
32218                    ENDIF
32219                  ENDIF
32220                  IF(ICASRE.EQ.'CODI')THEN
32221                    Z0=1.0 - Z0
32222                  ELSEIF(ICASRE.EQ.'ACDI')THEN
32223                    IFLAGC=1
32224                    IF(XSCRT(ISTRT4+IINDX).EQ.0.0)IFLAGC=0
32225                    IF(IFLAGC.EQ.1)THEN
32226                      Z0=2.0*ACOS(Z0)/PI
32227                    ELSE
32228                      Z0=ACOS(Z0)/PI
32229                    ENDIF
32230                  ELSEIF(ICASRE.EQ.'ACSI')THEN
32231                    IF(IFLAGC.EQ.1)THEN
32232                      AFACT=2.0
32233                    ELSE
32234                      AFACT=1.0
32235                    ENDIF
32236                    Z0=1.0 - AFACT*ACOS(Z0)/PI
32237                  ENDIF
32238                ELSEIF(ICASRE.EQ.'JADI' .OR. ICASRE.EQ.'JASI')THEN
32239                  TERM1=XSCRT(IINDX)
32240                  TERM2=XSCRT(ISTRT2+IINDX)
32241                  IF(TERM2.NE.0.0)THEN
32242                    Z0=TERM1/TERM2
32243                    IF(ICASRE.EQ.'JADI')Z0=1.0 - Z0
32244                  ELSE
32245                    Z0=CPUMIN
32246                  ENDIF
32247                ENDIF
32248 7794           CONTINUE
32249                ICOLVJ=IECOL2(ICOL)
32250                IJ=MAXN*(ICOLVJ-1)+IROW
32251                IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
32252                IF(ICOLVJ.EQ.MAXCP1)PRED(IROW)=Z0
32253                IF(ICOLVJ.EQ.MAXCP2)RES(IROW)=Z0
32254                IF(ICOLVJ.EQ.MAXCP3)YPLOT(IROW)=Z0
32255                IF(ICOLVJ.EQ.MAXCP4)XPLOT(IROW)=Z0
32256                IF(ICOLVJ.EQ.MAXCP5)X2PLOT(IROW)=Z0
32257                IF(ICOLVJ.EQ.MAXCP6)TAGPLO(IROW)=Z0
32258 7795         CONTINUE
32259 7790       CONTINUE
32260            GOTO7490
32261          ENDIF
32262C
32263        ELSEIF(ICASRE.EQ.'CTCR' .OR. ICASRE.EQ.'CTCV' .OR.
32264     1         ICASRE.EQ.'CTED' .OR. ICASRE.EQ.'CTCD' .OR.
32265     1         ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CCOS' .OR.
32266     1         ICASRE.EQ.'CACD' .OR. ICASRE.EQ.'CACS' .OR.
32267     1         ICASRE.EQ.'CTHD' .OR. ICASRE.EQ.'CTXD' .OR.
32268     1         ICASRE.EQ.'CJAD' .OR. ICASRE.EQ.'CJAS' .OR.
32269     1         ICASRE.EQ.'CTMD')THEN
32270C
32271C         CASE 8: ONE PASS COMPUTATION FOR
32272C
32273C                    1) CORRELATION OR COVARIANCE
32274C                    2) VARIOUS DISTANCE/SIMILARITY STATISTICS
32275C                    3) PERCENTILES
32276C
32277C                 ON CROSS-TABULATION OF ONE TO FOUR VARIABLES
32278C
32279          ISTEPN='10G'
32280          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
32281     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32282C
32283          IF(NCRT.EQ.1)THEN
32284            XHOLD1=X0(IVARC1)
32285C
32286C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
32287C
32288            IF(NCELL.EQ.0)THEN
32289              NCELL=NCELL+1
32290              CELLID(NCELL)=NCELL
32291              CELLX1(NCELL)=XHOLD1
32292              ICELL=NCELL
32293            ELSE
32294              DO8601K=1,NCELL
32295                IF(XHOLD1.EQ.CELLX1(K))THEN
32296                  ICELL=K
32297                  GOTO8609
32298                ENDIF
32299 8601         CONTINUE
32300              IF(NCELL.LT.MAXCEL)THEN
32301                NCELL=NCELL+1
32302                ICELL=NCELL
32303                CELLX1(NCELL)=XHOLD1
32304              ELSE
32305                WRITE(ICOUT,999)
32306                CALL DPWRST('XXX','BUG ')
32307                WRITE(ICOUT,211)
32308                CALL DPWRST('XXX','BUG ')
32309                WRITE(ICOUT,8603)MAXCEL
32310 8603           FORMAT('      MAXIMUM NUMBER OF CELLS (',I8,
32311     1                 ') EXCEEDED.')
32312                CALL DPWRST('XXX','BUG ')
32313                IERROR='YES'
32314                GOTO9000
32315              ENDIF
32316 8609         CONTINUE
32317            ENDIF
32318          ELSEIF(NCRT.EQ.2)THEN
32319            XHOLD1=X0(IVARC1)
32320            XHOLD2=X0(IVARC2)
32321C
32322C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
32323C
32324            IF(NCELL.EQ.0)THEN
32325              NCELL=NCELL+1
32326              CELLID(NCELL)=NCELL
32327              CELLX1(NCELL)=XHOLD1
32328              CELLX2(NCELL)=XHOLD2
32329            ELSE
32330              DO8611K=1,NCELL
32331                IF(XHOLD1.EQ.CELLX1(K) .AND. XHOLD2.EQ.CELLX2(K))THEN
32332                  ICELL=K
32333                  GOTO8619
32334                ENDIF
32335 8611         CONTINUE
32336              IF(NCELL.LT.MAXCEL)THEN
32337                NCELL=NCELL+1
32338                ICELL=NCELL
32339                CELLX1(NCELL)=XHOLD1
32340                CELLX2(NCELL)=XHOLD2
32341              ELSE
32342                WRITE(ICOUT,999)
32343                CALL DPWRST('XXX','BUG ')
32344                WRITE(ICOUT,211)
32345                CALL DPWRST('XXX','BUG ')
32346                WRITE(ICOUT,8603)MAXCEL
32347                CALL DPWRST('XXX','BUG ')
32348                IERROR='YES'
32349                GOTO9000
32350              ENDIF
32351 8619         CONTINUE
32352            ENDIF
32353          ELSEIF(NCRT.EQ.3)THEN
32354            XHOLD1=X0(IVARC1)
32355            XHOLD2=X0(IVARC2)
32356            XHOLD3=X0(IVARC3)
32357C
32358C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
32359C
32360            IF(NCELL.EQ.0)THEN
32361              NCELL=NCELL+1
32362              CELLID(NCELL)=NCELL
32363              CELLX1(NCELL)=XHOLD1
32364              CELLX2(NCELL)=XHOLD2
32365              CELLX3(NCELL)=XHOLD3
32366            ELSE
32367              DO8621K=1,NCELL
32368                IF(XHOLD1.EQ.CELLX1(K) .AND. XHOLD2.EQ.CELLX2(K) .AND.
32369     1             XHOLD3.EQ.CELLX3(K))THEN
32370                  ICELL=K
32371                  GOTO8629
32372                ENDIF
32373 8621         CONTINUE
32374              IF(NCELL.LT.MAXCEL)THEN
32375                NCELL=NCELL+1
32376                ICELL=NCELL
32377                CELLX1(NCELL)=XHOLD1
32378                CELLX2(NCELL)=XHOLD2
32379                CELLX3(NCELL)=XHOLD3
32380              ELSE
32381                WRITE(ICOUT,999)
32382                CALL DPWRST('XXX','BUG ')
32383                WRITE(ICOUT,211)
32384                CALL DPWRST('XXX','BUG ')
32385                WRITE(ICOUT,8603)MAXCEL
32386                CALL DPWRST('XXX','BUG ')
32387                IERROR='YES'
32388                GOTO9000
32389              ENDIF
32390 8629         CONTINUE
32391            ENDIF
32392          ELSEIF(NCRT.EQ.4)THEN
32393            XHOLD1=X0(IVARC1)
32394            XHOLD2=X0(IVARC2)
32395            XHOLD3=X0(IVARC3)
32396            XHOLD4=X0(IVARC4)
32397C
32398C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
32399C
32400            IF(NCELL.EQ.0)THEN
32401              NCELL=NCELL+1
32402              CELLID(NCELL)=NCELL
32403              CELLX1(NCELL)=XHOLD1
32404              CELLX2(NCELL)=XHOLD2
32405              CELLX3(NCELL)=XHOLD3
32406              CELLX4(NCELL)=XHOLD4
32407            ELSE
32408              DO8631K=1,NCELL
32409                IF(XHOLD1.EQ.CELLX1(K) .AND. XHOLD2.EQ.CELLX2(K) .AND.
32410     1             XHOLD3.EQ.CELLX3(K) .AND. XHOLD4.EQ.CELLX4(K))THEN
32411                  ICELL=K
32412                  GOTO8639
32413                ENDIF
32414 8631         CONTINUE
32415              IF(NCELL.LT.MAXCEL)THEN
32416                NCELL=NCELL+1
32417                ICELL=NCELL
32418                CELLX1(NCELL)=XHOLD1
32419                CELLX2(NCELL)=XHOLD2
32420                CELLX3(NCELL)=XHOLD3
32421                CELLX4(NCELL)=XHOLD4
32422              ELSE
32423                WRITE(ICOUT,999)
32424                CALL DPWRST('XXX','BUG ')
32425                WRITE(ICOUT,211)
32426                CALL DPWRST('XXX','BUG ')
32427                WRITE(ICOUT,8603)MAXCEL
32428                CALL DPWRST('XXX','BUG ')
32429                IERROR='YES'
32430                GOTO9000
32431              ENDIF
32432 8639         CONTINUE
32433            ENDIF
32434          ENDIF
32435C
32436          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32437            WRITE(ICOUT,8641)NUMV,NCRT,NCELL,ICELL,
32438     1                       XHOLD1,XHOLD2,XHOLD3,XHOLD4
32439 8641       FORMAT('NUMV,NCRT,NCELL,ICELL,XHOLD1,XHOLD2,XHOLD3,',
32440     1             'XHOLD4 = ',4I6,4G15.7)
32441            CALL DPWRST('XXX','BUG ')
32442            DO8643JJ=1,NUMV
32443              WRITE(ICOUT,8645)JJ,X0(JJ)
32444 8645         FORMAT('JJ,X0(JJ) = ',I6,G15.7)
32445              CALL DPWRST('XXX','BUG ')
32446 8643       CONTINUE
32447          ENDIF
32448C
32449C         STATISTICS WILL NOT BE COMPUTED FOR ALL VARIABLES.
32450C         SPECIFICALLY, CHARACTER DATA WILL ONLY BE USED AS
32451C         CROSS-TABULATION VARIABLES.  IF A NUMERIC VARIABLE
32452C         IS USED AS A CROSS-TABULATION VARIABLE, THEN IT WILL
32453C         STORE THE "LEVEL" VALUE, BUT NO STATISTICS.
32454C
32455C         ICTLST  =  0   => SKIP THIS COLUMN
32456C         ICTLST  >= 1   => COMPUTE DISTANCE FOR THIS COLUMN
32457C         ICTLST  = -1   => THIS COLUMN IS A CROSS-TAB VARIABLE
32458C
32459C         THE LAST VARIABLE IS THE "TAGSTAT" VARIABLE, SO DON'T
32460C         ADD ANYTHING TO XSCRT FOR THAT VARIABLE.
32461C
32462          NCOLCT=0
32463          NCOLNU=0
32464          DO8810JJ=1,NUMV
32465            IF(JJ.EQ.NUMV)THEN
32466              ICTLST(JJ)=0
32467              GOTO8810
32468            ENDIF
32469C
32470            IF(ITYPE(JJ).EQ.1)THEN
32471C
32472C             CHARACTER FIELD - CHECK IF CROSS-TAB VARIABLE
32473C
32474               IF(JJ.EQ.IVARC1 .OR. JJ.EQ.IVARC2 .OR.
32475     1            JJ.EQ.IVARC3 .OR. JJ.EQ.IVARC4)THEN
32476                 ICTLST(JJ)=-1
32477                 NCOLCT=NCOLCT+1
32478               ELSE
32479                 ICTLST(JJ)=0
32480               ENDIF
32481            ELSE
32482C
32483C             NUMERIC FIELD - CHECK IF CROSS-TAB VARIABLE
32484C
32485               IF(JJ.EQ.IVARC1 .OR. JJ.EQ.IVARC2 .OR.
32486     1            JJ.EQ.IVARC3 .OR. JJ.EQ.IVARC4)THEN
32487                 ICTLST(JJ)=-1
32488                 NCOLCT=NCOLCT+1
32489               ELSE
32490                 NCOLCT=NCOLCT+1
32491                 NCOLNU=NCOLNU+1
32492                 ICTLST(JJ)=NCOLNU
32493               ENDIF
32494            ENDIF
32495 8810     CONTINUE
32496C
32497          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32498            WRITE(ICOUT,8811)NCOLCT,NCOLNU,NUMV
32499 8811       FORMAT('NCOLCT,NCOLNU,NUMV = ',3I8)
32500            CALL DPWRST('XXX','BUG ')
32501            DO8813JJ=1,MIN(NCOLCT,NUMV)
32502              WRITE(ICOUT,8815)JJ,ICTLST(JJ)
32503 8815         FORMAT('JJ,ICTLST(JJ) = ',2I8)
32504              CALL DPWRST('XXX','BUG ')
32505 8813       CONTINUE
32506          ENDIF
32507C
32508          IF(IEOF.EQ.0 .AND. IFROW.LE.IFRMAX)THEN
32509            CELLCN(ICELL)=CELLCN(ICELL) + 1
32510C
32511            ISTRTC=4*NCOLNU*NCOLNU*(ICELL-1)
32512            ISTRT1=ISTRTC
32513            ISTRT2=ISTRTC + NCOLNU*NCOLNU
32514            ISTRT3=ISTRTC + 2*NCOLNU*NCOLNU
32515            ISTRT4=ISTRTC + 3*NCOLNU*NCOLNU
32516C
32517            IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32518              WRITE(ICOUT,8816)ISTRTC,ISTRT1,ISTRT2,ISTRT3,ISTRT4
32519 8816         FORMAT('ISTRTC,ISTRT1,ISTRT2,ISTRT3,ISTRT4 = ',5I8)
32520              CALL DPWRST('XXX','BUG ')
32521            ENDIF
32522C
32523            DO8825JJ=1,NUMV-1
32524              IF(X0(JJ).EQ.PREAMV)GOTO8825
32525              IF(ICTLST(JJ).LE.0)GOTO8825
32526              ICOL=ICTLST(JJ)
32527C
32528              DO8830KK=JJ,NUMV-1
32529                IF(X0(KK).EQ.PREAMV)GOTO8830
32530                IF(ICTLST(KK).LE.0)GOTO8830
32531                IROW=ICTLST(KK)
32532                IINDX1=(IROW-1)*NCOLNU + ICOL
32533                IINDX2=(ICOL-1)*NCOLNU + IROW
32534                IF(JJ.EQ.KK)THEN
32535                  IF(ICASRE.EQ.'CTED' .OR. ICASRE.EQ.'CTMD' .OR.
32536     1               ICASRE.EQ.'CTXD' .OR. ICASRE.EQ.'CTHD' .OR.
32537     1               ICASRE.EQ.'CTCD' .OR. ICASRE.EQ.'CJAD' .OR.
32538     1               ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CACD'
32539     1              )THEN
32540                    XSCRT(ISTRT1 + IINDX1)=0.0
32541                    GOTO8829
32542                  ELSEIF(ICASRE.EQ.'CTCR')THEN
32543                    XSCRT(ISTRT1 + IINDX1)=1.0
32544                    GOTO8829
32545                  ENDIF
32546                ENDIF
32547                IF(ICASRE.EQ.'CTED')THEN
32548                  DEL=X0(JJ) - X0(KK)
32549                  XSCRT(ISTRT1 + IINDX1)=XSCRT(ISTRT1 + IINDX1) +
32550     1                                   DEL*DEL
32551C
32552                  IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32553                    WRITE(ICOUT,8817)JJ,KK,ICOL,IROW,IINDX1,IINDX2,
32554     1                               DEL*DEL,XSCRT(ISTRT1+IINDX1)
32555 8817               FORMAT('JJ,KK,ICOL,IROW,IINDX1,IINDX2,',
32556     1                     'DEL*DEL,XSCRT(ISTRT1+IINDX1) = ',6I4,2G15.7)
32557                    CALL DPWRST('XXX','BUG ')
32558                  ENDIF
32559C
32560                ELSEIF(ICASRE.EQ.'CTMD')THEN
32561                  XSCRT(ISTRT1 + IINDX1)=XSCRT(ISTRT1 + IINDX1) +
32562     1                                   ABS(X0(JJ) - X0(KK))
32563                ELSEIF(ICASRE.EQ.'CTXD')THEN
32564                  TERM1=ABS(X0(JJ) - X0(KK))
32565                  TERM2=ABS(X0(JJ)) + ABS(X0(KK))
32566                  TERM3=XSCRT(ISTRT1+IINDX1)
32567                  IF(TERM2.NE.0.0 .AND. TERM3.NE.CPUMIN)THEN
32568                    XSCRT(ISTRT1 + IINDX1)=XSCRT(ISTRT1 + IINDX1) +
32569     1                                     TERM1/TERM2
32570                  ELSE
32571                    XSCRT(ISTRT1 + IINDX1)=PSTAMV
32572                  ENDIF
32573                ELSEIF(ICASRE.EQ.'CTHD')THEN
32574                  IF(X0(JJ).NE.X0(KK))THEN
32575                    XSCRT(ISTRT1 + IINDX1)=XSCRT(ISTRT1 + IINDX1) + 1.0
32576                  ENDIF
32577                ELSEIF(ICASRE.EQ.'CTCD')THEN
32578                  XSCRT(ISTRT1 + IINDX1)=MAX(XSCRT(ISTRT1 + IINDX1),
32579     1                                       ABS(X0(JJ)-X0(KK)))
32580                ELSEIF(ICASRE.EQ.'CJAS' .OR. ICASRE.EQ.'CJAD')THEN
32581                  AVAL1=MIN(X0(JJ),X0(KK))
32582                  AVAL2=MAX(X0(JJ),X0(KK))
32583                  XSCRT(ISTRT1 + IINDX1)=XSCRT(ISTRT1 + IINDX1) +
32584     1                                   AVAL1
32585                  XSCRT(ISTRT2 + IINDX1)=XSCRT(ISTRT2 + IINDX1) + AVAL2
32586                  XSCRT(ISTRT2 + IINDX2)=XSCRT(ISTRT2 + IINDX1)
32587                ELSEIF(ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CCOS' .OR.
32588     1                 ICASRE.EQ.'CACD' .OR. ICASRE.EQ.'CACS')THEN
32589                  IF(ICASRE.EQ.'CCOD' .AND.
32590     1              (X0(JJ).LT.0.0 .OR. X0(KK).LT.0.0))THEN
32591                    WRITE(ICOUT,999)
32592                    CALL DPWRST('XXX','BUG ')
32593                    WRITE(ICOUT,211)
32594                    CALL DPWRST('XXX','BUG ')
32595                    WRITE(ICOUT,22100)
32596                    CALL DPWRST('XXX','BUG ')
32597                    WRITE(ICOUT,22103)IFROW
32598                    CALL DPWRST('XXX','BUG ')
32599                    IERROR='YES'
32600                    GOTO9000
32601                  ENDIF
32602                  IFLAGC=0
32603                  EPS=-0.000001
32604                  IF(X0(JJ).LT.EPS .OR. X0(KK).LT.EPS)IFLAGC=1
32605                  XSCRT(ISTRT1 + IINDX1)=XSCRT(ISTRT1 + IINDX1) +
32606     1                                   X0(JJ)*X0(KK)
32607                  XSCRT(ISTRT2+IINDX1)=XSCRT(ISTRT2+IINDX1) +
32608     1                                 X0(JJ)*X0(JJ)
32609                  XSCRT(ISTRT3+IINDX1)=XSCRT(ISTRT3+IINDX1) +
32610     1                                 X0(KK)*X0(KK)
32611                  IF(IFLAGC.EQ.1)THEN
32612                    XSCRT(ISTRT4+IINDX1)=1.0
32613                  ENDIF
32614                  XSCRT(ISTRT2+IINDX2)=XSCRT(ISTRT2+IINDX1)
32615                  XSCRT(ISTRT3+IINDX2)=XSCRT(ISTRT3+IINDX1)
32616                  XSCRT(ISTRT4+IINDX2)=XSCRT(ISTRT4+IINDX1)
32617                ELSEIF(ICASRE.EQ.'CTCR' .OR. ICASRE.EQ.'CTCV')THEN
32618C
32619C                 CHECK IF THIS IS THE FIRST OBSERVATION
32620C
32621                  IF(XSCRT(ISTRT2+IINDX1).LT.0.5)THEN
32622                    XSCRT(ISTRT1+IINDX1)=0.0
32623                    XSCRT(ISTRT2+IINDX1)=1.0
32624                    XSCRT(ISTRT3+IINDX1)=X0(JJ)
32625                    XSCRT(ISTRT4+IINDX1)=X0(KK)
32626                  ELSE
32627                    DNOLD=DBLE(XSCRT(ISTRT2+IINDX1))
32628                    DNNEW=DNOLD + 1.0
32629                    DTERM3=DNOLD/DNNEW
32630                    XSCRT(ISTRT2+IINDX1)=REAL(DNNEW)
32631C
32632                    DVAL=DBLE(X0(JJ))
32633                    DVALM1=XSCRT(ISTRT3+IINDX1)
32634                    DTERM1=(DVAL - DVALM1)
32635                    DMEAN=DVALM1 + (DVAL - DVALM1)/DNNEW
32636                    XSCRT(ISTRT3+IINDX1)=REAL(DMEAN)
32637C
32638                    DVAL=DBLE(X0(KK))
32639                    DVALM1=XSCRT(ISTRT4+IINDX1)
32640                    DMEAN=DVALM1 + (DVAL - DVALM1)/DNNEW
32641                    DTERM2=(DVAL - DMEAN)
32642                    XSCRT(ISTRT4+IINDX1)=REAL(DMEAN)
32643C
32644                    DTERM3=DTERM1*DTERM2
32645                    DTERM4=DBLE(XSCRT(ISTRT1+IINDX1)) + DTERM3
32646                    XSCRT(ISTRT1+IINDX1)=REAL(DTERM4)
32647C
32648C                   ONLY NEED TO SAVE LOWER DIAGONAL FOR C(n)
32649C
32650                    XSCRT(ISTRT1 + IINDX2)=XSCRT(ISTRT1+IINDX1)
32651                    XSCRT(ISTRT2 + IINDX2)=XSCRT(ISTRT2+IINDX1)
32652                    XSCRT(ISTRT3 + IINDX2)=XSCRT(ISTRT3+IINDX1)
32653                    XSCRT(ISTRT4 + IINDX2)=XSCRT(ISTRT4+IINDX1)
32654                  ENDIF
32655                ENDIF
32656C
32657 8829           CONTINUE
32658                XSCRT(ISTRT1 + IINDX2)=XSCRT(ISTRT1 + IINDX1)
32659 8830         CONTINUE
32660 8825       CONTINUE
32661          ELSE
32662C
32663C           END OF FILE REACHED, SAVE COMPUTED STATISTIC
32664C
32665            IF(CELLCN(NCELL).EQ.0)NCELL=NCELL-1
32666C
32667            IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32668              WRITE(ICOUT,8851)NCELL,NUMV
32669 8851         FORMAT('SAVE DATA: NCELL,NUMV = ',2I8)
32670              CALL DPWRST('XXX','BUG ')
32671              NLAST=ISTRTC + 4*NUMV*NUMV - 1
32672              DO8853LL=1,NLAST
32673                WRITE(ICOUT,8855)LL,XSCRT(LL)
32674 8855           FORMAT('LL,XSCRT(LL) = ',I8,G15.7)
32675                CALL DPWRST('XXX','BUG ')
32676 8853         CONTINUE
32677            ENDIF
32678C
32679            DO8863LL=1,NCELL
32680              ISTRTC=4*NCOLNU*NCOLNU*(LL-1)
32681              ISTRT1=ISTRTC
32682              ISTRT2=ISTRTC + NCOLNU*NCOLNU
32683              ISTRT3=ISTRTC + 2*NCOLNU*NCOLNU
32684              ISTRT4=ISTRTC + 3*NCOLNU*NCOLNU
32685C
32686              IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32687                WRITE(ICOUT,8868)LL,ISTRTC,ISTRT1,ISTRT2
32688 8868           FORMAT('LL,ISTRTC,ISTRT1,ISTRT2=',4I6)
32689                CALL DPWRST('XXX','BUG ')
32690              ENDIF
32691C
32692              DO8860KK=1,NUMV
32693                IROW=ICTLST(KK)
32694                IROW2=(LL-1)*NCOLNU + ICTLST(KK)
32695                IF(ICTLST(KK).LE.0)GOTO8860
32696                DO8865JJ=1,NUMV
32697                  ICOL=ICTLST(JJ)
32698                  IINDX1=(IROW-1)*NCOLNU + ICOL
32699                  IINDX2=(ICOL-1)*NCOLNU + IROW
32700C
32701                  IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32702                    WRITE(ICOUT,8867)ICOL,IROW,IROW2,IINDX1,IINDX2
32703 8867               FORMAT('ICOL,IROW,IROW2,IINDX1,IINDX2=',5I6)
32704                    CALL DPWRST('XXX','BUG ')
32705                  ENDIF
32706C
32707                  IF(JJ.EQ.NUMV)THEN
32708                    Z0=REAL(LL)
32709                  ELSEIF(JJ.EQ.IVARC1)THEN
32710                    Z0=CELLX1(LL)
32711                  ELSEIF(JJ.EQ.IVARC2)THEN
32712                    Z0=CELLX2(LL)
32713                  ELSEIF(JJ.EQ.IVARC3)THEN
32714                    Z0=CELLX3(LL)
32715                  ELSEIF(JJ.EQ.IVARC4)THEN
32716                    Z0=CELLX4(LL)
32717                  ELSEIF(ICTLST(JJ).EQ.0)THEN
32718                    GOTO8865
32719                  ELSEIF(ICASRE.EQ.'CTED')THEN
32720                    Z0=XSCRT(ISTRT1 + IINDX1)
32721                    Z0=SQRT(Z0)
32722                  ELSEIF(ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CCOS' .OR.
32723     1                   ICASRE.EQ.'CACD' .OR. ICASRE.EQ.'CACS')THEN
32724                    IF(KK.EQ.JJ)THEN
32725                      Z0=1.0
32726                    ELSE
32727                      Z0=XSCRT(ISTRT1 + IINDX1)
32728                      TERM1=SQRT(XSCRT(ISTRT2+IINDX1))
32729                      TERM2=SQRT(XSCRT(ISTRT3+IINDX1))
32730                      IF(TERM1.GT.0.0)THEN
32731                        Z0=Z0/(TERM1*TERM2)
32732                      ELSE
32733                        Z0=CPUMIN
32734                        GOTO8864
32735                      ENDIF
32736                    ENDIF
32737                    IFLAGC=0
32738                    IF(XSCRT(ISTRT4+IINDX1).EQ.1.0)IFLAGC=1
32739                    IF(ICASRE.EQ.'CCOD')THEN
32740                      Z0=1.0 - Z0
32741                    ELSEIF(ICASRE.EQ.'CACD')THEN
32742                      IF(IFLAGC.EQ.0)THEN
32743                        AFACT=2.0
32744                      ELSE
32745                        AFACT=1.0
32746                      ENDIF
32747                      Z0=AFACT*ACOS(Z0)/PI
32748                    ELSEIF(ICASRE.EQ.'CACS')THEN
32749                      IF(IFLAGC.EQ.0)THEN
32750                        AFACT=2.0
32751                      ELSE
32752                        AFACT=1.0
32753                      ENDIF
32754                      Z0=1.0 - AFACT*ACOS(Z0)/PI
32755                    ENDIF
32756                  ELSEIF(ICASRE.EQ.'CJAD' .OR. ICASRE.EQ.'CJAS')THEN
32757                    TERM1=XSCRT(ISTRT1 + IINDX1)
32758                    TERM2=XSCRT(ISTRT2 + IINDX1)
32759                    IF(TERM2.NE.0.0)THEN
32760                      Z0=TERM1/TERM2
32761                      IF(ICASRE.EQ.'CJAD')Z0=1.0 - Z0
32762                    ELSE
32763                      Z0=CPUMIN
32764                    ENDIF
32765                  ELSEIF(ICASRE.EQ.'CTCR' .OR. ICASRE.EQ.'CTCV')THEN
32766                    Z0=XSCRT(ISTRT1 + IINDX1)
32767                    ZN=XSCRT(ISTRT2 + IINDX1)
32768                    IF(ZN.GT.1.5)THEN
32769                      Z0=Z0/(ZN-1.0)
32770                      IF(ICASRE.EQ.'CTCR')THEN
32771                        IF(JJ.EQ.KK)THEN
32772                          Z0=1.0
32773                        ELSE
32774                          IINDXR=(KK-1)*NCOLNU + KK
32775                          IINDXC=(JJ-1)*NCOLNU + JJ
32776                          TERM1=XSCRT(ISTRT1+IINDXR)
32777                          ZN1=XSCRT(ISTRT2+IINDXR)
32778                          TERM1=SQRT((TERM1/(ZN1-1.0)))
32779                          TERM2=XSCRT(ISTRT1+IINDXC)
32780                          ZN2=XSCRT(ISTRT2+IINDXC)
32781                          TERM2=SQRT(TERM2/(ZN-1.0))
32782                          IF(TERM1.GT.0.0 .AND. TERM2.GT.0.0)THEN
32783                            Z0=Z0/(TERM1*TERM2)
32784                          ENDIF
32785                        ENDIF
32786                      ENDIF
32787                    ELSE
32788                      Z0=0.0
32789                    ENDIF
32790                  ELSE
32791                    Z0=XSCRT(ISTRT1 + IINDX1)
32792                  ENDIF
32793 8864             CONTINUE
32794                  ICOLVJ=IECOL2(JJ)
32795                  IJ=MAXN*(ICOLVJ-1)+IROW2
32796C
32797                  IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32798                     WRITE(ICOUT,8861)LL,KK,JJ,IROW2,Z0
32799 8861                FORMAT('LL,KK,JJ,IROW2,Z0 = ',4I8,G15.7)
32800                     CALL DPWRST('XXX','BUG ')
32801                  ENDIF
32802C
32803                  IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
32804                  IF(ICOLVJ.EQ.MAXCP1)PRED(IJ)=Z0
32805                  IF(ICOLVJ.EQ.MAXCP2)RES(IJ)=Z0
32806                  IF(ICOLVJ.EQ.MAXCP3)YPLOT(IJ)=Z0
32807                  IF(ICOLVJ.EQ.MAXCP4)XPLOT(IJ)=Z0
32808                  IF(ICOLVJ.EQ.MAXCP5)X2PLOT(IJ)=Z0
32809                  IF(ICOLVJ.EQ.MAXCP6)TAGPLO(IJ)=Z0
32810 8865           CONTINUE
32811 8860         CONTINUE
32812 8863       CONTINUE
32813            GOTO7490
32814          ENDIF
32815        ELSEIF(ICASRE.EQ.'PERC')THEN
32816C
32817C         CASE 5: ONE PASS COMPUTATION FOR PERCENTILES
32818C
32819C                 WE USE THE P2 ALGORITHM GIVEN IN
32820C
32821C                     JAIN AND CHLAMTAC (1985), "The P^2
32822C                     ALGORITHM FOR DYNAMIC CALCULATION
32823C                     OF QUANTILES AND HISTOGRAMS WITHOUT
32824C                     STORING OBSERVATIONS", COMMUNICATIONS
32825C                     OF THE ACM, 28, NO. 10, PP. 1076-1085.
32826C
32827C                 SPECIFICALLY, WE USE THE EXTENDED P2
32828C                 ALGORITHM FOR MULTIPLE PERCENTILES GIVEN IN
32829C
32830C                     RAATIKANIEN (1987), "SIMULTANEOUS ESTIMATION
32831C                     OF SEVERAL PERCENTILES", SIMULATION,
32832C                     PP. 159-164.
32833C
32834C                 THE MINIMUM, ESTIMATED PERCENTILES FROM
32835C                 0.001 IN INCREMENTS OF 0.001 TO 0.999, AND
32836C                 THE MAXIMUM (FOR 1,001 POINTS TOTAL).  IF
32837C                 THERE IS 1,001 POINTS OR LESS, THE RAW DATA
32838C                 IS RETURNED.
32839C
32840C                 NOTE THAT THIS ALGORITHM RETURNS APPROXIMATE
32841C                 PERCENTILES, BUT SHOULD GET MORE ACCURATE AS
32842C                 THE SIZE OF THE DATA INCREASES.
32843C
32844          ISTEPN='10E'
32845          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
32846     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32847C
32848          IF(IEOF.EQ.0 .AND. IFROW.LE.IFRMAX)THEN
32849C
32850C           FOR FIRST LINE READ, DEFINE THE DESIRED PERCENTILES.
32851C
32852            IF(XSCRT(1).EQ.0.0)THEN
32853              IF(ISRENP.EQ.9)THEN
32854                M=9
32855                AINC=0.1
32856              ELSEIF(ISRENP.EQ.99)THEN
32857                M=99
32858                AINC=0.01
32859              ELSEIF(ISRENP.EQ.999)THEN
32860                M=999
32861                AINC=0.001
32862              ELSE
32863                M=9999
32864                AINC=0.0001
32865              ENDIF
32866              DO5510II=1,M
32867                AVAL=REAL(II)*AINC
32868                TEMP1(II)=REAL(II)*AINC
32869 5510         CONTINUE
32870              NINIT=2*M + 3
32871              IINC=4*NINIT
32872C
32873              IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32874                WRITE(ICOUT,5506)M,NINIT,IINC
32875 5506           FORMAT('M,NINIT,IINC = ',3I8)
32876                CALL DPWRST('XXX','BUG ')
32877              ENDIF
32878C
32879            ENDIF
32880C
32881            DO5520JJ=1,NUMV
32882              IF(X0(JJ).EQ.PREAMV)GOTO5520
32883              ITEMP1(JJ)=ITEMP1(JJ) + 1
32884              NUMLGR=ITEMP1(JJ)
32885C
32886C             DEFINE START INDEX FOR Q, F, D, N ARRAYS
32887C
32888              IINDX1=(JJ-1)*IINC
32889              IINDX2=(JJ-1)*IINC + NINIT
32890              IINDX3=(JJ-1)*IINC + 2*NINIT
32891              IINDX4=(JJ-1)*IINC + 3*NINIT
32892C
32893              IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32894                WRITE(ICOUT,5507)JJ,IINDX1,IINDX2,IINDX3,IINDX4,NUMLGR
32895 5507           FORMAT('JJ,IINDX1,IINDX2,IINDX3,IINDX4,NUMLGR = ',6I8)
32896                CALL DPWRST('XXX','BUG ')
32897              ENDIF
32898C
32899              IF(NUMLGR.LT.NINIT)THEN
32900                XSCRT(IINDX1+NUMLGR)=X0(JJ)
32901              ELSEIF(NUMLGR.EQ.NINIT)THEN
32902                XSCRT(IINDX1+NUMLGR)=X0(JJ)
32903                CALL SORT(XSCRT(IINDX1+1),NUMLGR,XSCRT(IINDX1+1))
32904                XSCRT(IINDX2+1)=0.0
32905                XSCRT(IINDX2+NINIT)=1.0
32906                DO5511II=1,M
32907                  XSCRT(IINDX2 + 2*II+1)=TEMP1(II)
32908 5511           CONTINUE
32909                DO5512II=1,M+1
32910                  AVAL1=XSCRT(IINDX2 + 2*II-1)
32911                  AVAL2=XSCRT(IINDX2 + 2*II+1)
32912                  XSCRT(IINDX2 + 2*II)=(AVAL1 + AVAL2)/2.0
32913 5512           CONTINUE
32914                ACONST=2.0*REAL(M+1)
32915                DO5513II=1,NINT
32916                  XSCRT(IINDX3 + II)=1.0 + ACONST*XSCRT(IINDX2 + II)
32917                  XSCRT(IINDX4 + II)=REAL(II)
32918 5513           CONTINUE
32919C
32920                IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32921                  DO5519II=1,4*NINIT
32922                    WRITE(ICOUT,5518)II,XSCRT(IINDX1+II)
32923 5518               FORMAT('II,XSCRT(IINDX1+II) = ',I5,G15.7)
32924                    CALL DPWRST('XXX','BUG ')
32925 5519             CONTINUE
32926                ENDIF
32927C
32928              ELSE
32929                YNEW=X0(JJ)
32930                QMIN=XSCRT(IINDX1 + 1)
32931                QMAX=XSCRT(IINDX1 + NINIT)
32932                IF(YNEW.LT.QMIN)THEN
32933                  K=1
32934                  XSCRT(IINDX1 + 1)=YNEW
32935                ELSEIF(YNEW.GT.QMAX)THEN
32936                  K=NINIT-1
32937                  XSCRT(IINDX1 + NINIT)=YNEW
32938                ELSE
32939                  TEMP2(1)=YNEW
32940                  NVAL=1
32941                  CALL MATCH2(XSCRT(IINDX1+1),NINIT,TEMP2,NVAL,
32942     1                        TEMP3,IWRITE,
32943     1                        ISUBRO,IBUGS2,IERROR)
32944                  K=INT(TEMP3(1)+0.1)
32945                ENDIF
32946C
32947                IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
32948                  WRITE(ICOUT,5522)JJ,NUMLGR,K,XSCRT(IINDX1+1),
32949     1                             XSCRT(IINDX1+NINIT)
32950 5522             FORMAT('5522: JJ,NUMLGR,K,XSCRT(IINDX1+1),',
32951     1                   'XSCRT(IINDX1+NINIT) = ',3I5,2G15.7)
32952                  CALL DPWRST('XXX','BUG ')
32953                ENDIF
32954C
32955                DO5515II=K+1,NINIT
32956                  XSCRT(IINDX4 + II)=XSCRT(IINDX4 + II) + 1.0
32957 5515           CONTINUE
32958                DO5517II=1,NINIT
32959                  XSCRT(IINDX3 + II)=XSCRT(IINDX3 + II) +
32960     1                               XSCRT(IINDX2 + II)
32961 5517           CONTINUE
32962              ENDIF
32963C
32964              DO5525L=2,2*M+2
32965                QL=XSCRT(IINDX1+L)
32966                QLM1=XSCRT(IINDX1+L-1)
32967                QLP1=XSCRT(IINDX1+L+1)
32968                DL=XSCRT(IINDX3+L)
32969                DLM1=XSCRT(IINDX3+L-1)
32970                DLP1=XSCRT(IINDX3+L+1)
32971                ANL=XSCRT(IINDX4+L)
32972                ANLM1=XSCRT(IINDX4+L-1)
32973                ANLP1=XSCRT(IINDX4+L+1)
32974                DI=DL - ANL
32975                DP=ANLP1 - ANL
32976                DM=ANLM1 - ANL
32977                QP=(QLP1 - QL)/DP
32978                QM=(QLM1 - QL)/DM
32979C
32980                IF(DI.GE.1.0 .AND. DP.GT.1.0)THEN
32981                  QT=QL + ((1.0 - DM)*QP + (DP - 1.0)*QM)/(DP - DM)
32982                  IF(QLM1.LT.QT .AND. QT.LT.QLP1)THEN
32983                    XSCRT(IINDX1 + L)=QT
32984                  ELSE
32985                    XSCRT(IINDX1 + L)=QL + QP
32986                  ENDIF
32987                  XSCRT(IINDX4 + L)=XSCRT(IINDX4 + L) + 1.0
32988                ELSEIF(DI.LE.-1.0 .AND. DM.LT.-1.0)THEN
32989                  QT=QL - ((1.0 + DP)*QM - (DM + 1.0)*QP)/(DP - DM)
32990                  IF(QLM1.LT.QT .AND. QT.LT.QLP1)THEN
32991                    XSCRT(IINDX1 + L)=QT
32992                  ELSE
32993                    XSCRT(IINDX1 + L)=QL - QM
32994                  ENDIF
32995                  XSCRT(IINDX4 + L)=XSCRT(IINDX4 + L) - 1.0
32996                ENDIF
32997C
32998 5525         CONTINUE
32999C
33000 5520       CONTINUE
33001          ELSE
33002C
33003C           END OF FILE REACHED, SAVE COMPUTED STATISTIC
33004C
33005            DO5540JJ=1,NUMV
33006              NUMLGR=ITEMP1(JJ)
33007              ICOLVJ=IECOL2(JJ)
33008              IINDX1=(JJ-1)*IINC
33009              IF(NUMLGR.GE.1 .AND. NUMLGR.LE.NINIT)THEN
33010                CALL SORT(XSCRT(IINDX1+1),NUMLGR,XSCRT(IINDX1+1))
33011                ICNT2=0
33012C
33013                IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33014                  WRITE(ICOUT,5541)JJ,NUMLGR,ICOLVJ,IINDX1
33015 5541             FORMAT('5540: JJ,NUMLGR,ICOLVJ,IINDX1 = ',4I8)
33016                  CALL DPWRST('XXX','BUG ')
33017                ENDIF
33018C
33019                DO5550KK=1,NUMLGR
33020                  ICNT2=ICNT2+1
33021                  Z0=XSCRT(IINDX1 + KK)
33022                  IJ=MAXN*(ICOLVJ-1)+ICNT2
33023                  IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
33024                  IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
33025                  IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
33026                  IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
33027                  IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
33028                  IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
33029                  IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
33030 5550           CONTINUE
33031              ELSE
33032C
33033C               FIRST ADD MINIMUM VALUE
33034C
33035                ICNT2=1
33036                Z0=XSCRT(IINDX1 + 1)
33037                IJ=MAXN*(ICOLVJ-1)+ICNT2
33038                IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
33039                IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
33040                IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
33041                IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
33042                IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
33043                IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
33044                IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
33045C
33046                DO5560KK=1,M
33047                  ICNT2=ICNT2+1
33048                  Z0=XSCRT(IINDX1 + 1 + 2*KK)
33049                  IJ=MAXN*(ICOLVJ-1)+ICNT2
33050                  IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
33051                  IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
33052                  IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
33053                  IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
33054                  IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
33055                  IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
33056                  IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
33057 5560           CONTINUE
33058C
33059C               LAST ADD MAXIMUM VALUE
33060C
33061                ICNT2=ICNT2+1
33062                Z0=XSCRT(IINDX1 + NINIT)
33063                IJ=MAXN*(ICOLVJ-1)+ICNT2
33064                IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
33065                IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
33066                IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
33067                IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
33068                IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
33069                IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
33070                IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
33071C
33072              ENDIF
33073 5540       CONTINUE
33074            GOTO7490
33075          ENDIF
33076C
33077        ELSEIF(ICASRE.EQ.'CSTA')THEN
33078C
33079C         CASE 6: ONE PASS COMPUTATION FOR A LIST OF STATISTICS BASED
33080C                 ON CROSS-TABULATION OF ONE TO FOUR VARIABLES
33081C
33082C                 CURRENTLY, COMPUTE THE FOLLOWING STATISTICS:
33083C
33084C                   1. COUNT
33085C                   2. MINIMUM
33086C                   3. MAXIMUM
33087C                   4. RANGE
33088C                   5. MEAN
33089C                   6. STANDARD DEVIATION
33090C                   7. SKEWNESS
33091C                   8. KURTOSIS
33092C                   9. AUTOCORRELATION
33093C                  10. M2 (SECOND CENTRAL MOMENT)
33094C                  11. M3 (THIRD CENTRAL MOMENT)
33095C                  12. M4 (FOURTH CENTRAL MOMENT)
33096C                  13. Q (USED FOR ONE-PASS STANDARD DEVIATION)
33097C                  14. NUMBER OF MISSING
33098C
33099C                  NOTE THAT M2, M3, AND M4 ARE USED TO COMPUTE THE
33100C                  SKEWNESS AND KURTOSIS.  HOWEVER, THEY WILL NOT BE
33101C                  SAVED.  Q IS USED IN THE COMPUTATION OF THE STANDARD
33102C                  DEVIATION, BUT IT WILL NOT BE SAVED.
33103C
33104          ISTEPN='10E'
33105          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
33106     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33107C
33108          IF(NCRT.EQ.1)THEN
33109            XHOLD1=X0(IVARC1)
33110C
33111C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
33112C
33113            IF(NCELL.EQ.0)THEN
33114              NCELL=NCELL+1
33115              CELLID(NCELL)=NCELL
33116              CELLX1(NCELL)=XHOLD1
33117              ICELL=NCELL
33118            ELSE
33119              DO7601K=1,NCELL
33120                IF(XHOLD1.EQ.CELLX1(K))THEN
33121                  ICELL=K
33122                  GOTO7609
33123                ENDIF
33124 7601         CONTINUE
33125              IF(NCELL.LT.MAXCEL)THEN
33126                NCELL=NCELL+1
33127                ICELL=NCELL
33128                CELLX1(NCELL)=XHOLD1
33129              ELSE
33130                WRITE(ICOUT,999)
33131                CALL DPWRST('XXX','BUG ')
33132                WRITE(ICOUT,211)
33133                CALL DPWRST('XXX','BUG ')
33134                WRITE(ICOUT,7603)MAXCEL
33135 7603           FORMAT('      MAXIMUM NUMBER OF CELLS (',I8,
33136     1                 ') EXCEEDED.')
33137                CALL DPWRST('XXX','BUG ')
33138                IERROR='YES'
33139                GOTO9000
33140              ENDIF
33141 7609         CONTINUE
33142            ENDIF
33143          ELSEIF(NCRT.EQ.2)THEN
33144            XHOLD1=X0(IVARC1)
33145            XHOLD2=X0(IVARC2)
33146C
33147C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
33148C
33149            IF(NCELL.EQ.0)THEN
33150              NCELL=NCELL+1
33151              CELLID(NCELL)=NCELL
33152              CELLX1(NCELL)=XHOLD1
33153              CELLX2(NCELL)=XHOLD2
33154            ELSE
33155              DO7611K=1,NCELL
33156                IF(XHOLD1.EQ.CELLX1(K) .AND. XHOLD2.EQ.CELLX2(K))THEN
33157                  ICELL=K
33158                  GOTO7619
33159                ENDIF
33160 7611         CONTINUE
33161              IF(NCELL.LT.MAXCEL)THEN
33162                NCELL=NCELL+1
33163                ICELL=NCELL
33164                CELLX1(NCELL)=XHOLD1
33165                CELLX2(NCELL)=XHOLD2
33166              ELSE
33167                WRITE(ICOUT,999)
33168                CALL DPWRST('XXX','BUG ')
33169                WRITE(ICOUT,211)
33170                CALL DPWRST('XXX','BUG ')
33171                WRITE(ICOUT,7603)MAXCEL
33172                CALL DPWRST('XXX','BUG ')
33173                IERROR='YES'
33174                GOTO9000
33175              ENDIF
33176 7619         CONTINUE
33177            ENDIF
33178          ELSEIF(NCRT.EQ.3)THEN
33179            XHOLD1=X0(IVARC1)
33180            XHOLD2=X0(IVARC2)
33181            XHOLD3=X0(IVARC3)
33182C
33183C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
33184C
33185            IF(NCELL.EQ.0)THEN
33186              NCELL=NCELL+1
33187              CELLID(NCELL)=NCELL
33188              CELLX1(NCELL)=XHOLD1
33189              CELLX2(NCELL)=XHOLD2
33190              CELLX3(NCELL)=XHOLD3
33191            ELSE
33192              DO7621K=1,NCELL
33193                IF(XHOLD1.EQ.CELLX1(K) .AND. XHOLD2.EQ.CELLX2(K) .AND.
33194     1             XHOLD3.EQ.CELLX3(K))THEN
33195                  ICELL=K
33196                  GOTO7629
33197                ENDIF
33198 7621         CONTINUE
33199              IF(NCELL.LT.MAXCEL)THEN
33200                NCELL=NCELL+1
33201                ICELL=NCELL
33202                CELLX1(NCELL)=XHOLD1
33203                CELLX2(NCELL)=XHOLD2
33204                CELLX3(NCELL)=XHOLD3
33205              ELSE
33206                WRITE(ICOUT,999)
33207                CALL DPWRST('XXX','BUG ')
33208                WRITE(ICOUT,211)
33209                CALL DPWRST('XXX','BUG ')
33210                WRITE(ICOUT,7603)MAXCEL
33211                CALL DPWRST('XXX','BUG ')
33212                IERROR='YES'
33213                GOTO9000
33214              ENDIF
33215 7629         CONTINUE
33216            ENDIF
33217          ELSEIF(NCRT.EQ.4)THEN
33218            XHOLD1=X0(IVARC1)
33219            XHOLD2=X0(IVARC2)
33220            XHOLD3=X0(IVARC3)
33221            XHOLD4=X0(IVARC4)
33222C
33223C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
33224C
33225            IF(NCELL.EQ.0)THEN
33226              NCELL=NCELL+1
33227              CELLID(NCELL)=NCELL
33228              CELLX1(NCELL)=XHOLD1
33229              CELLX2(NCELL)=XHOLD2
33230              CELLX3(NCELL)=XHOLD3
33231              CELLX4(NCELL)=XHOLD4
33232            ELSE
33233              DO7631K=1,NCELL
33234                IF(XHOLD1.EQ.CELLX1(K) .AND. XHOLD2.EQ.CELLX2(K) .AND.
33235     1             XHOLD3.EQ.CELLX3(K) .AND. XHOLD4.EQ.CELLX4(K))THEN
33236                  ICELL=K
33237                  GOTO7639
33238                ENDIF
33239 7631         CONTINUE
33240              IF(NCELL.LT.MAXCEL)THEN
33241                NCELL=NCELL+1
33242                ICELL=NCELL
33243                CELLX1(NCELL)=XHOLD1
33244                CELLX2(NCELL)=XHOLD2
33245                CELLX3(NCELL)=XHOLD3
33246                CELLX4(NCELL)=XHOLD4
33247              ELSE
33248                WRITE(ICOUT,999)
33249                CALL DPWRST('XXX','BUG ')
33250                WRITE(ICOUT,211)
33251                CALL DPWRST('XXX','BUG ')
33252                WRITE(ICOUT,7603)MAXCEL
33253                CALL DPWRST('XXX','BUG ')
33254                IERROR='YES'
33255                GOTO9000
33256              ENDIF
33257 7639         CONTINUE
33258            ENDIF
33259          ENDIF
33260C
33261          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33262            WRITE(ICOUT,7641)NCRT,NCELL,ICELL,XHOLD1,XHOLD2,
33263     1                       XHOLD3,XHOLD4
33264 7641       FORMAT('NCRT,NCELL,ICELL,XHOLD1,XHOLD2,XHOLD3,XHOLD4 = ',
33265     1             3I6,4G15.7)
33266            CALL DPWRST('XXX','BUG ')
33267            DO7643JJ=1,NUMV
33268              WRITE(ICOUT,7645)JJ,X0(JJ)
33269 7645         FORMAT('JJ,X0(JJ) = ',I6,G15.7)
33270              CALL DPWRST('XXX','BUG ')
33271 7643       CONTINUE
33272          ENDIF
33273C
33274C         STATISTICS WILL NOT BE COMPUTED FOR ALL VARIABLES.
33275C         SPECIFICALLY, CHARACTER DATA WILL ONLY BE USED AS
33276C         CROSS-TABULATION VARIABLES.  IF A NUMERIC VARIABLE
33277C         IS USED AS A CROSS-TABULATION VARIABLE, THEN IT WILL
33278C         STORE THE "LEVEL" VALUE, BUT NO STATISTICS.
33279C
33280C         ICTLST  = 0   => SKIP THIS COLUMN
33281C         ICTLST  = 1   => COMPUTE STATISTICS FOR THIS COLUMN
33282C         ICTLST  = 2   => THIS COLUMN IS A CROSS-TAB VARIABLE
33283C
33284C         THE LAST VARIABLE IS THE "TAGSTAT" VARIABLE, SO DON'T
33285C         ADD ANYTHING TO XSCRT FOR THAT VARIABLE.
33286C
33287          NCOLCT=0
33288          DO7810JJ=1,NUMV
33289            IF(JJ.EQ.NUMV)THEN
33290              ICTLST(JJ)=0
33291              GOTO7810
33292            ENDIF
33293C
33294            IF(ITYPE(JJ).EQ.1)THEN
33295C
33296C             CHARACTER FIELD - CHECK IF CROSS-TAB VARIABLE
33297C
33298               IF(JJ.EQ.IVARC1 .OR. JJ.EQ.IVARC2 .OR.
33299     1            JJ.EQ.IVARC3 .OR. JJ.EQ.IVARC4)THEN
33300                 ICTLST(JJ)=2
33301                 NCOLCT=NCOLCT+1
33302               ELSE
33303                 ICTLST(JJ)=0
33304               ENDIF
33305            ELSE
33306C
33307C             NUMERIC FIELD - CHECK IF CROSS-TAB VARIABLE
33308C
33309               IF(JJ.EQ.IVARC1 .OR. JJ.EQ.IVARC2 .OR.
33310     1            JJ.EQ.IVARC3 .OR. JJ.EQ.IVARC4)THEN
33311                 ICTLST(JJ)=2
33312                 NCOLCT=NCOLCT+1
33313               ELSE
33314                 ICTLST(JJ)=1
33315                 NCOLCT=NCOLCT+1
33316               ENDIF
33317            ENDIF
33318 7810     CONTINUE
33319C
33320          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33321            WRITE(ICOUT,7811)NCOLCT,NUMV
33322 7811       FORMAT('NCOLCT,NUMV = ',2I8)
33323            CALL DPWRST('XXX','BUG ')
33324            DO7813JJ=1,MIN(NCOLCT,NUMV)
33325              WRITE(ICOUT,7815)JJ,ICTLST(JJ)
33326 7815         FORMAT('JJ,ICTLST(JJ) = ',2I8)
33327              CALL DPWRST('XXX','BUG ')
33328 7813       CONTINUE
33329          ENDIF
33330C
33331C         IF THE INPUT VALUE IS
33332C
33333          NSTATF=14
33334          IF(IEOF.EQ.0 .AND. IFROW.LE.IFRMAX)THEN
33335            CELLCN(ICELL)=CELLCN(ICELL) + 1
33336C
33337            ICNT=0
33338            DO7825JJ=1,NUMV
33339              IF(ICTLST(JJ).EQ.0)GOTO7825
33340              ISTRT=(ICELL-1)*(NCOLCT*NSTATF)
33341              NLAST=NCELL*(NCOLCT*NSTATF)
33342              ICNT=ICNT+1
33343C
33344C             CHECK FOR MISSING VALUE IN RESPONSE VARIABLES
33345C
33346              IF(ICTLST(JJ).EQ.1)THEN
33347                IF(X0(JJ).EQ.PREAMV)THEN
33348                  XSCRT(ISTRT+ICNT+13*NCOLCT)=
33349     1              XSCRT(ISTRT+ICNT+13*NCOLCT)+1
33350                  GOTO7825
33351                ELSE
33352                  XSCRT(ISTRT+ICNT)=XSCRT(ISTRT+ICNT)+1.0
33353                ENDIF
33354              ELSEIF(ICTLST(JJ).EQ.2)THEN
33355                IF(JJ.EQ.IVARC1)THEN
33356                  AVAL=CELLX1(ICELL)
33357                ELSEIF(JJ.EQ.IVARC2)THEN
33358                  AVAL=CELLX2(ICELL)
33359                ELSEIF(JJ.EQ.IVARC3)THEN
33360                  AVAL=CELLX3(ICELL)
33361                ELSEIF(JJ.EQ.IVARC4)THEN
33362                  AVAL=CELLX4(ICELL)
33363                ENDIF
33364                XSCRT(ISTRT+ICNT)=AVAL
33365                XSCRT(ISTRT+ICNT+NCOLCT)=AVAL
33366                XSCRT(ISTRT+ICNT+2*NCOLCT)=AVAL
33367                XSCRT(ISTRT+ICNT+3*NCOLCT)=AVAL
33368                XSCRT(ISTRT+ICNT+4*NCOLCT)=AVAL
33369                XSCRT(ISTRT+ICNT+5*NCOLCT)=AVAL
33370                XSCRT(ISTRT+ICNT+6*NCOLCT)=AVAL
33371                XSCRT(ISTRT+ICNT+7*NCOLCT)=AVAL
33372                XSCRT(ISTRT+ICNT+8*NCOLCT)=AVAL
33373                XSCRT(ISTRT+ICNT+9*NCOLCT)=AVAL
33374                XSCRT(ISTRT+ICNT+10*NCOLCT)=AVAL
33375                XSCRT(ISTRT+ICNT+11*NCOLCT)=AVAL
33376                XSCRT(ISTRT+ICNT+12*NCOLCT)=AVAL
33377                XSCRT(ISTRT+ICNT+13*NCOLCT)=AVAL
33378                GOTO7825
33379              ENDIF
33380C
33381              NUMLGR=INT(XSCRT(ISTRT+ICNT)+0.1)
33382              NVAL=NUMLGR
33383C
33384C              1 - COUNT
33385C              2 - MIN
33386C              3 - MAX
33387C              4 - RANGE
33388C              5 - MEAN
33389C              6 - SD
33390C              7 - SKEWNESS
33391C              8 - KURTOSIS
33392C              9 - AUTO-CORRELATION
33393C             10 - M2
33394C             11 - M3
33395C             12 - M4
33396C             13 - Q
33397C             14 - NUMBER OF MISSING
33398C
33399C             NOTE: ONE-PASS FORMULA FOR STANDARD DEVIATION IS
33400C
33401C                       SD = SQRT(Qk/(k-1))
33402C
33403C                   WHERE
33404C
33405C                       Q(k) = Q(K-1) + (K-1)*[X(k) - M(K-1)]^2/K
33406C
33407              IF(NUMLGR.EQ.1)THEN
33408                XSCRT(ISTRT+ICNT+NCOLCT)=X0(JJ)
33409                XSCRT(ISTRT+ICNT+2*NCOLCT)=X0(JJ)
33410                XSCRT(ISTRT+ICNT+3*NCOLCT)=0.0
33411                XSCRT(ISTRT+ICNT+4*NCOLCT)=X0(JJ)
33412                XSCRT(ISTRT+ICNT+5*NCOLCT)=0.0
33413                XSCRT(ISTRT+ICNT+6*NCOLCT)=0.0
33414                XSCRT(ISTRT+ICNT+7*NCOLCT)=0.0
33415                XSCRT(ISTRT+ICNT+8*NCOLCT)=0.0
33416                XSCRT(ISTRT+ICNT+9*NCOLCT)=0.0
33417                XSCRT(ISTRT+ICNT+10*NCOLCT)=0.0
33418                XSCRT(ISTRT+ICNT+11*NCOLCT)=0.0
33419                XSCRT(ISTRT+ICNT+12*NCOLCT)=0.0
33420              ELSE
33421C
33422                DNOLD=DBLE(NUMLGR-1)
33423                DNNEW=DBLE(NUMLGR)
33424                XSCRT(ISTRT+ICNT+NCOLCT)=
33425     1                MIN(XSCRT(ISTRT+ICNT+NCOLCT),X0(JJ))
33426                XSCRT(ISTRT+ICNT+2*NCOLCT)=
33427     1               MAX(XSCRT(ISTRT+ICNT+2*NCOLCT),X0(JJ))
33428                XSCRT(ISTRT+ICNT+3*NCOLCT)=
33429     1                XSCRT(ISTRT+ICNT+2*NCOLCT) -
33430     1                XSCRT(ISTRT+ICNT+NCOLCT)
33431                DVALM1=DBLE(XSCRT(ISTRT+ICNT+4*NCOLCT))
33432                DVALSO=DBLE(XSCRT(ISTRT+ICNT+12*NCOLCT))
33433C
33434                DVAL=DBLE(X0(JJ))
33435                DELTA=DVAL - DVALM1
33436                DELTAN=DELTA/DNNEW
33437                DELTN2=DELTAN*DELTAN
33438                DTERM1=DELTA*DELTAN*DNOLD
33439C
33440                DMEAN=DVALM1 + DELTAN
33441C
33442                DTERM2=(DNOLD/DNNEW)*DELTA**2
33443                DVALS1=DVALSO + DTERM2
33444                DSD=DSQRT(DVALS1/DBLE(NUMLGR-1))
33445C
33446                DM2=DBLE(XSCRT(ISTRT+ICNT+9*NCOLCT))
33447                DM3=DBLE(XSCRT(ISTRT+ICNT+10*NCOLCT))
33448                DM4=DBLE(XSCRT(ISTRT+ICNT+11*NCOLCT))
33449                DM4=DM4 + DTERM1*DELTN2*(DNNEW*DNNEW - 3.0D0*DNNEW
33450     1              + 3.0D0) + 6.0D0*DELTN2*DM2 - 4.0D0*DELTAN*DM3
33451                DM3=DM3 + DTERM1*DELTAN*(DNNEW - 2.0D0) -
33452     1              3.0D0*DELTAN*DM2
33453                DM2=DM2 + DTERM1
33454C
33455                IF(DM2.GT.0.0D0)THEN
33456                  DSKEW=DSQRT(DNNEW)*DM3/(DM2**1.5D0)
33457                  DKURT=(DNNEW*DM4)/(DM2*DM2)
33458                ELSE
33459                  IF(DM2.NE.0.0)THEN
33460                    DSKEW=0.0D0
33461                    DKURT=(DNNEW*DM4)/(DM2*DM2)
33462                  ELSE
33463                    DSKEW=0.0D0
33464                    DKURT=0.0D0
33465                  ENDIF
33466                ENDIF
33467C
33468C               COMPUTE AUTOCORRELATION.  USE THE ONE-PASS FORMULA
33469C               FOR CORRELATION.  THE COMPLICATION IS THAT FOR
33470C               AUTOCORRELATION WE ARE COMPUTING FOR A LAGGED
33471C               VERSION OF THE VARIABLE.
33472C
33473                XSCRT(ISTRT+ICNT+4*NCOLCT)=REAL(DMEAN)
33474                XSCRT(ISTRT+ICNT+5*NCOLCT)=REAL(DSD)
33475                XSCRT(ISTRT+ICNT+6*NCOLCT)=REAL(DSKEW)
33476                XSCRT(ISTRT+ICNT+7*NCOLCT)=REAL(DKURT)
33477                XSCRT(ISTRT+ICNT+8*NCOLCT)=0.0
33478                XSCRT(ISTRT+ICNT+9*NCOLCT)=REAL(DM2)
33479                XSCRT(ISTRT+ICNT+10*NCOLCT)=REAL(DM3)
33480                XSCRT(ISTRT+ICNT+11*NCOLCT)=REAL(DM4)
33481                XSCRT(ISTRT+ICNT+12*NCOLCT)=REAL(DVALS1)
33482              ENDIF
33483 7825       CONTINUE
33484          ELSE
33485C
33486C           END OF FILE REACHED, SAVE COMPUTED STATISTIC
33487C
33488            NSTAT=9
33489            IF(CELLCN(NCELL).EQ.0)NCELL=NCELL-1
33490C
33491            IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33492              WRITE(ICOUT,7851)NCELL,NUMV,NSTAT
33493 7851         FORMAT('SAVE DATA: NCELL,NUMV,NSTAT = ',3I8)
33494              CALL DPWRST('XXX','BUG ')
33495              NLAST=NCELL*NCOLCT*NSTATF
33496              DO7853LL=1,NLAST
33497                WRITE(ICOUT,7855)LL,XSCRT(LL)
33498 7855           FORMAT('LL,XSCRT(LL) = ',I8,G15.7)
33499                CALL DPWRST('XXX','BUG ')
33500 7853         CONTINUE
33501            ENDIF
33502C
33503            DO7863LL=1,NCELL
33504              ISTRT=(LL-1)*(NCOLCT*NSTATF)
33505              DO7860KK=1,NSTAT
33506                ICNT=0
33507                DO7865JJ=1,NUMV
33508                  IROW=(LL-1)*NSTAT + KK
33509                  IF(JJ.EQ.NUMV)THEN
33510                    Z0=REAL(KK)
33511                  ELSEIF(ICTLST(JJ).EQ.0)THEN
33512                    GOTO7865
33513                  ELSE
33514                    ICNT=ICNT+1
33515                    IF(KK.EQ.NSTAT)THEN
33516                      IINDX=ISTRT + (NSTATF-1)*NCOLCT + ICNT
33517                    ELSE
33518                      IINDX=ISTRT + (KK-1)*NCOLCT + ICNT
33519                    ENDIF
33520                    Z0=XSCRT(IINDX)
33521                  ENDIF
33522                  ICOLVJ=IECOL2(JJ)
33523                  IJ=MAXN*(ICOLVJ-1)+IROW
33524C
33525                  IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33526                     WRITE(ICOUT,7861)LL,KK,JJ,IINDX,IROW,Z0
33527 7861                FORMAT('LL,KK,JJ,IINDX,IROW,Z0 = ',5I8,G15.7)
33528                     CALL DPWRST('XXX','BUG ')
33529                  ENDIF
33530C
33531                  IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
33532                  IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
33533                  IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
33534                  IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
33535                  IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
33536                  IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
33537                  IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
33538 7865           CONTINUE
33539 7860         CONTINUE
33540 7863       CONTINUE
33541            GOTO7490
33542          ENDIF
33543        ELSEIF(ICASRE.EQ.'CTPE')THEN
33544C
33545C         CASE 9: ONE PASS COMPUTATION FOR
33546C
33547C                    1) PERCENTILES
33548C
33549C                 ON CROSS-TABULATION OF ONE TO FOUR VARIABLES
33550C
33551          ISTEPN='10H'
33552          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
33553     1       CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
33554C
33555          IF(NCRT.EQ.1)THEN
33556            XHOLD1=X0(IVARC1)
33557C
33558C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
33559C
33560            IF(NCELL.EQ.0)THEN
33561              NCELL=NCELL+1
33562              CELLID(NCELL)=NCELL
33563              CELLX1(NCELL)=XHOLD1
33564              ICELL=NCELL
33565            ELSE
33566              DO8901K=1,NCELL
33567                IF(XHOLD1.EQ.CELLX1(K))THEN
33568                  ICELL=K
33569                  GOTO8909
33570                ENDIF
33571 8901         CONTINUE
33572              IF(NCELL.LT.MAXCEL)THEN
33573                NCELL=NCELL+1
33574                ICELL=NCELL
33575                CELLX1(NCELL)=XHOLD1
33576              ELSE
33577                WRITE(ICOUT,999)
33578                CALL DPWRST('XXX','BUG ')
33579                WRITE(ICOUT,211)
33580                CALL DPWRST('XXX','BUG ')
33581                WRITE(ICOUT,8903)MAXCEL
33582 8903           FORMAT('      MAXIMUM NUMBER OF CELLS (',I8,
33583     1                 ') EXCEEDED.')
33584                CALL DPWRST('XXX','BUG ')
33585                IERROR='YES'
33586                GOTO9000
33587              ENDIF
33588 8909         CONTINUE
33589            ENDIF
33590          ELSEIF(NCRT.EQ.2)THEN
33591            XHOLD1=X0(IVARC1)
33592            XHOLD2=X0(IVARC2)
33593C
33594C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
33595C
33596            IF(NCELL.EQ.0)THEN
33597              NCELL=NCELL+1
33598              CELLID(NCELL)=NCELL
33599              CELLX1(NCELL)=XHOLD1
33600              CELLX2(NCELL)=XHOLD2
33601            ELSE
33602              DO8911K=1,NCELL
33603                IF(XHOLD1.EQ.CELLX1(K) .AND. XHOLD2.EQ.CELLX2(K))THEN
33604                  ICELL=K
33605                  GOTO8919
33606                ENDIF
33607 8911         CONTINUE
33608              IF(NCELL.LT.MAXCEL)THEN
33609                NCELL=NCELL+1
33610                ICELL=NCELL
33611                CELLX1(NCELL)=XHOLD1
33612                CELLX2(NCELL)=XHOLD2
33613              ELSE
33614                WRITE(ICOUT,999)
33615                CALL DPWRST('XXX','BUG ')
33616                WRITE(ICOUT,211)
33617                CALL DPWRST('XXX','BUG ')
33618                WRITE(ICOUT,8903)MAXCEL
33619                CALL DPWRST('XXX','BUG ')
33620                IERROR='YES'
33621                GOTO9000
33622              ENDIF
33623 8919         CONTINUE
33624            ENDIF
33625          ELSEIF(NCRT.EQ.3)THEN
33626            XHOLD1=X0(IVARC1)
33627            XHOLD2=X0(IVARC2)
33628            XHOLD3=X0(IVARC3)
33629C
33630C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
33631C
33632            IF(NCELL.EQ.0)THEN
33633              NCELL=NCELL+1
33634              CELLID(NCELL)=NCELL
33635              CELLX1(NCELL)=XHOLD1
33636              CELLX2(NCELL)=XHOLD2
33637              CELLX3(NCELL)=XHOLD3
33638            ELSE
33639              DO8921K=1,NCELL
33640                IF(XHOLD1.EQ.CELLX1(K) .AND. XHOLD2.EQ.CELLX2(K) .AND.
33641     1             XHOLD3.EQ.CELLX3(K))THEN
33642                  ICELL=K
33643                  GOTO8929
33644                ENDIF
33645 8921         CONTINUE
33646              IF(NCELL.LT.MAXCEL)THEN
33647                NCELL=NCELL+1
33648                ICELL=NCELL
33649                CELLX1(NCELL)=XHOLD1
33650                CELLX2(NCELL)=XHOLD2
33651                CELLX3(NCELL)=XHOLD3
33652              ELSE
33653                WRITE(ICOUT,999)
33654                CALL DPWRST('XXX','BUG ')
33655                WRITE(ICOUT,211)
33656                CALL DPWRST('XXX','BUG ')
33657                WRITE(ICOUT,8903)MAXCEL
33658                CALL DPWRST('XXX','BUG ')
33659                IERROR='YES'
33660                GOTO9000
33661              ENDIF
33662 8929         CONTINUE
33663            ENDIF
33664          ELSEIF(NCRT.EQ.4)THEN
33665            XHOLD1=X0(IVARC1)
33666            XHOLD2=X0(IVARC2)
33667            XHOLD3=X0(IVARC3)
33668            XHOLD4=X0(IVARC4)
33669C
33670C           CHECK TO SEE IF THIS CELL ALREADY EXISTS
33671C
33672            IF(NCELL.EQ.0)THEN
33673              NCELL=NCELL+1
33674              CELLID(NCELL)=NCELL
33675              CELLX1(NCELL)=XHOLD1
33676              CELLX2(NCELL)=XHOLD2
33677              CELLX3(NCELL)=XHOLD3
33678              CELLX4(NCELL)=XHOLD4
33679            ELSE
33680              DO8931K=1,NCELL
33681                IF(XHOLD1.EQ.CELLX1(K) .AND. XHOLD2.EQ.CELLX2(K) .AND.
33682     1             XHOLD3.EQ.CELLX3(K) .AND. XHOLD4.EQ.CELLX4(K))THEN
33683                  ICELL=K
33684                  GOTO8939
33685                ENDIF
33686 8931         CONTINUE
33687              IF(NCELL.LT.MAXCEL)THEN
33688                NCELL=NCELL+1
33689                ICELL=NCELL
33690                CELLX1(NCELL)=XHOLD1
33691                CELLX2(NCELL)=XHOLD2
33692                CELLX3(NCELL)=XHOLD3
33693                CELLX4(NCELL)=XHOLD4
33694              ELSE
33695                WRITE(ICOUT,999)
33696                CALL DPWRST('XXX','BUG ')
33697                WRITE(ICOUT,211)
33698                CALL DPWRST('XXX','BUG ')
33699                WRITE(ICOUT,8903)MAXCEL
33700                CALL DPWRST('XXX','BUG ')
33701                IERROR='YES'
33702                GOTO9000
33703              ENDIF
33704 8939         CONTINUE
33705            ENDIF
33706          ENDIF
33707C
33708          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33709            WRITE(ICOUT,8941)NUMV,NCRT,NCELL,ICELL,
33710     1                       XHOLD1,XHOLD2,XHOLD3,XHOLD4
33711 8941       FORMAT('NUMV,NCRT,NCELL,ICELL,XHOLD1,XHOLD2,XHOLD3,',
33712     1             'XHOLD4 = ',4I6,4G15.7)
33713            CALL DPWRST('XXX','BUG ')
33714            DO8943JJ=1,NUMV
33715              WRITE(ICOUT,8945)JJ,X0(JJ)
33716 8945         FORMAT('JJ,X0(JJ) = ',I6,G15.7)
33717              CALL DPWRST('XXX','BUG ')
33718 8943       CONTINUE
33719          ENDIF
33720C
33721C         STATISTICS WILL NOT BE COMPUTED FOR ALL VARIABLES.
33722C         SPECIFICALLY, CHARACTER DATA WILL ONLY BE USED AS
33723C         CROSS-TABULATION VARIABLES.  IF A NUMERIC VARIABLE
33724C         IS USED AS A CROSS-TABULATION VARIABLE, THEN IT WILL
33725C         STORE THE "LEVEL" VALUE, BUT NO STATISTICS.
33726C
33727C         ICTLST  =  0   => SKIP THIS COLUMN
33728C         ICTLST  >= 1   => COMPUTE PERCENTILE FOR THIS COLUMN
33729C         ICTLST  = -1   => THIS COLUMN IS A CROSS-TAB VARIABLE
33730C
33731C         THE LAST VARIABLE IS THE "TAGSTAT" VARIABLE, SO DON'T
33732C         ADD ANYTHING TO XSCRT FOR THAT VARIABLE.
33733C
33734          NCOLCT=0
33735          NCOLNU=0
33736          DO8950JJ=1,NUMV
33737            IF(JJ.EQ.NUMV)THEN
33738              ICTLST(JJ)=0
33739              GOTO8950
33740            ENDIF
33741C
33742            IF(ITYPE(JJ).EQ.1)THEN
33743C
33744C             CHARACTER FIELD - CHECK IF CROSS-TAB VARIABLE
33745C
33746               IF(JJ.EQ.IVARC1 .OR. JJ.EQ.IVARC2 .OR.
33747     1            JJ.EQ.IVARC3 .OR. JJ.EQ.IVARC4)THEN
33748                 ICTLST(JJ)=-1
33749                 NCOLCT=NCOLCT+1
33750               ELSE
33751                 ICTLST(JJ)=0
33752               ENDIF
33753            ELSE
33754C
33755C             NUMERIC FIELD - CHECK IF CROSS-TAB VARIABLE
33756C
33757               IF(JJ.EQ.IVARC1 .OR. JJ.EQ.IVARC2 .OR.
33758     1            JJ.EQ.IVARC3 .OR. JJ.EQ.IVARC4)THEN
33759                 ICTLST(JJ)=-1
33760                 NCOLCT=NCOLCT+1
33761               ELSE
33762                 NCOLCT=NCOLCT+1
33763                 NCOLNU=NCOLNU+1
33764                 ICTLST(JJ)=NCOLNU
33765               ENDIF
33766            ENDIF
33767 8950     CONTINUE
33768C
33769          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33770            WRITE(ICOUT,8951)NCOLCT,NCOLNU,NUMV
33771 8951       FORMAT('NCOLCT,NCOLNU,NUMV = ',3I8)
33772            CALL DPWRST('XXX','BUG ')
33773            DO8953JJ=1,MIN(NCOLCT,NUMV)
33774              WRITE(ICOUT,8955)JJ,ICTLST(JJ)
33775 8955         FORMAT('JJ,ICTLST(JJ) = ',2I8)
33776              CALL DPWRST('XXX','BUG ')
33777 8953       CONTINUE
33778          ENDIF
33779C
33780          IF(IEOF.EQ.0 .AND. IFROW.LE.IFRMAX)THEN
33781C
33782C           FOR FIRST LINE READ, DEFINE THE DESIRED PERCENTILES
33783C
33784            IF(XSCRT(1).EQ.0.0)THEN
33785              IF(ISRENP.EQ.9)THEN
33786                M=9
33787                AINC=0.1
33788              ELSEIF(ISRENP.EQ.99)THEN
33789                M=99
33790                AINC=0.01
33791              ELSEIF(ISRENP.EQ.999)THEN
33792                M=999
33793                AINC=0.001
33794              ELSE
33795                M=9999
33796                AINC=0.0001
33797              ENDIF
33798              DO8960II=1,M
33799                AVAL=REAL(II)*AINC
33800                TEMP1(II)=REAL(II)*AINC
33801 8960         CONTINUE
33802              NINIT=2*M + 3
33803              IINC=4*NINIT
33804C
33805              IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33806                WRITE(ICOUT,8961)M,NINIT,IINC
33807 8961           FORMAT('M,NINIT,IINC = ',3I8)
33808                CALL DPWRST('XXX','BUG ')
33809              ENDIF
33810C
33811            ENDIF
33812C
33813            CELLCN(ICELL)=CELLCN(ICELL) + 1
33814C
33815            ISTRTC=NCOLNU*IINC*(ICELL-1)
33816C
33817            IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33818              WRITE(ICOUT,8963)ICELL,CELLCN(ICELL),ISTRTC
33819 8963         FORMAT('ICELL,CELLCN(ICELL),ISTRTC = ',3I8)
33820              CALL DPWRST('XXX','BUG ')
33821            ENDIF
33822C
33823            DO8970JJ=1,NUMV-1
33824              IF(X0(JJ).EQ.PREAMV)GOTO8970
33825              IF(ICTLST(JJ).LE.0)GOTO8970
33826              ICOL=ICTLST(JJ)
33827C
33828              IVAL=(ICELL-1)*(NUMV-1)+JJ
33829              ITEMP1(IVAL)=ITEMP1(IVAL) + 1
33830              NUMLGR=ITEMP1(IVAL)
33831C
33832C             DEFINE START INDEX FOR Q, F, D, N ARRAYS
33833C
33834              IINDX1=ISTRTC + (JJ-1)*IINC
33835              IINDX2=ISTRTC + (JJ-1)*IINC + NINIT
33836              IINDX3=ISTRTC + (JJ-1)*IINC + 2*NINIT
33837              IINDX4=ISTRTC + (JJ-1)*IINC + 3*NINIT
33838C
33839              IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33840                WRITE(ICOUT,8971)JJ,IINDX1,IINDX2,IINDX3,IINDX4,NUMLGR
33841 8971           FORMAT('JJ,IINDX1,IINDX2,IINDX3,IINDX4,NUMLGR = ',6I8)
33842                CALL DPWRST('XXX','BUG ')
33843              ENDIF
33844C
33845              IF(NUMLGR.LT.NINIT)THEN
33846                XSCRT(IINDX1+NUMLGR)=X0(JJ)
33847              ENDIF
33848              IF(NUMLGR.EQ.NINIT-1)THEN
33849                XSCRT(IINDX1+NUMLGR)=X0(JJ)
33850                CALL SORT(XSCRT(IINDX1+1),NUMLGR,XSCRT(IINDX1+1))
33851                XSCRT(IINDX2+1)=0.0
33852                XSCRT(IINDX2+NINIT)=1.0
33853                DO8972II=1,M
33854                  XSCRT(IINDX2 + 2*II+1)=TEMP1(II)
33855 8972           CONTINUE
33856                DO8973II=1,M+1
33857                  AVAL1=XSCRT(IINDX2 + 2*II-1)
33858                  AVAL2=XSCRT(IINDX2 + 2*II+1)
33859                  XSCRT(IINDX2 + 2*II)=(AVAL1 + AVAL2)/2.0
33860 8973           CONTINUE
33861                ACONST=2.0*REAL(M+1)
33862                DO8974II=1,NINT
33863                  XSCRT(IINDX3 + II)=1.0 + ACONST*XSCRT(IINDX2 + II)
33864                  XSCRT(IINDX4 + II)=REAL(II)
33865 8974           CONTINUE
33866C
33867                IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33868                  DO8975II=1,4*NINIT
33869                    WRITE(ICOUT,8976)II,XSCRT(IINDX1+II)
33870 8976               FORMAT('II,XSCRT(IINDX1+II) = ',I5,G15.7)
33871                    CALL DPWRST('XXX','BUG ')
33872 8975             CONTINUE
33873                ENDIF
33874C
33875              ELSE
33876                YNEW=X0(JJ)
33877                QMIN=XSCRT(IINDX1 + 1)
33878                QMAX=XSCRT(IINDX1 + NINIT)
33879                IF(YNEW.LT.QMIN)THEN
33880                  K=1
33881                  XSCRT(IINDX1 + 1)=YNEW
33882                ELSEIF(YNEW.GT.QMAX)THEN
33883                  K=NINIT-1
33884                  XSCRT(IINDX1 + NINIT)=YNEW
33885                ELSE
33886                  TEMP2(1)=YNEW
33887                  NVAL=1
33888                  CALL MATCH2(XSCRT(IINDX1+1),NINIT,TEMP2,NVAL,
33889     1                        TEMP3,IWRITE,
33890     1                        ISUBRO,IBUGS2,IERROR)
33891                  K=INT(TEMP3(1)+0.1)
33892                ENDIF
33893C
33894                IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33895                  WRITE(ICOUT,8978)JJ,NUMLGR,K,XSCRT(IINDX1+1),
33896     1                             XSCRT(IINDX1+NINIT)
33897 8978             FORMAT('8978: JJ,NUMLGR,K,XSCRT(IINDX1+1),',
33898     1                   'XSCRT(IINDX1+NINIT) = ',3I5,2G15.7)
33899                  CALL DPWRST('XXX','BUG ')
33900                ENDIF
33901C
33902                DO8980II=K+1,NINIT
33903                  XSCRT(IINDX4 + II)=XSCRT(IINDX4 + II) + 1.0
33904 8980           CONTINUE
33905                DO8981II=1,NINIT
33906                  XSCRT(IINDX3 + II)=XSCRT(IINDX3 + II) +
33907     1                               XSCRT(IINDX2 + II)
33908 8981           CONTINUE
33909              ENDIF
33910C
33911              DO8982L=2,2*M+2
33912                QL=XSCRT(IINDX1+L)
33913                QLM1=XSCRT(IINDX1+L-1)
33914                QLP1=XSCRT(IINDX1+L+1)
33915                DL=XSCRT(IINDX3+L)
33916                DLM1=XSCRT(IINDX3+L-1)
33917                DLP1=XSCRT(IINDX3+L+1)
33918                ANL=XSCRT(IINDX4+L)
33919                ANLM1=XSCRT(IINDX4+L-1)
33920                ANLP1=XSCRT(IINDX4+L+1)
33921                DI=DL - ANL
33922                DP=ANLP1 - ANL
33923                DM=ANLM1 - ANL
33924                QP=(QLP1 - QL)/DP
33925                QM=(QLM1 - QL)/DM
33926C
33927                IF(DI.GE.1.0 .AND. DP.GT.1.0)THEN
33928                  QT=QL + ((1.0 - DM)*QP + (DP - 1.0)*QM)/(DP - DM)
33929                  IF(QLM1.LT.QT .AND. QT.LT.QLP1)THEN
33930                    XSCRT(IINDX1 + L)=QT
33931                  ELSE
33932                    XSCRT(IINDX1 + L)=QL + QP
33933                  ENDIF
33934                  XSCRT(IINDX4 + L)=XSCRT(IINDX4 + L) + 1.0
33935                ELSEIF(DI.LE.-1.0 .AND. DM.LT.-1.0)THEN
33936                  QT=QL - ((1.0 + DP)*QM - (DM + 1.0)*QP)/(DP - DM)
33937                  IF(QLM1.LT.QT .AND. QT.LT.QLP1)THEN
33938                    XSCRT(IINDX1 + L)=QT
33939                  ELSE
33940                    XSCRT(IINDX1 + L)=QL - QM
33941                  ENDIF
33942                  XSCRT(IINDX4 + L)=XSCRT(IINDX4 + L) - 1.0
33943                ENDIF
33944C
33945 8982         CONTINUE
33946 8970       CONTINUE
33947C
33948          ELSE
33949C
33950C           END OF FILE REACHED, SAVE COMPUTED STATISTIC
33951C
33952            IF(CELLCN(NCELL).EQ.0)NCELL=NCELL-1
33953C
33954            IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33955              WRITE(ICOUT,8986)NCELL,NUMV
33956 8986         FORMAT('SAVE DATA: NCELL,NUMV = ',2I8)
33957              CALL DPWRST('XXX','BUG ')
33958              NLAST=NCOLNU*IINC*NCELL
33959              DO8987LL=1,NLAST
33960                WRITE(ICOUT,8988)LL,XSCRT(LL)
33961 8988           FORMAT('LL,XSCRT(LL) = ',I8,G15.7)
33962                CALL DPWRST('XXX','BUG ')
33963 8987         CONTINUE
33964            ENDIF
33965C
33966            IROWTO=0
33967            DO8991LL=1,NCELL
33968              ISTRTC=NCOLNU*IINC*(LL-1)
33969              IVAL1=(LL-1)*NCOLNU
33970              MAXROW=0
33971C
33972              DO8993KK=1,NUMV-1
33973                IF(ICTLST(KK).LE.0)GOTO8993
33974                IVAL2=ITEMP1(IVAL1+KK)
33975C
33976C               IF IVAL2 >= NINIT, THEN ONLY M PERCENTILES ARE
33977C               EXTRACTED, PLUS MIN AND MAX POINTS
33978C
33979                IF(IVAL2.GE.NINIT)THEN
33980                  IVAL2=M + 2
33981                ENDIF
33982                IF(IVAL2.GT.MAXROW)MAXROW=IVAL2
33983 8993         CONTINUE
33984              IF(MAXROW.GT.NINIT)MAXROW=NINIT
33985              IROWTO=IROWTO+MAXROW
33986              ITEMP3(LL)=IROWTO
33987              IF(LL.EQ.1)THEN
33988                IINDX2=0
33989              ELSE
33990                IINDX2=ITEMP3(LL-1)
33991              ENDIF
33992C
33993              IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
33994                WRITE(ICOUT,8989)LL,ISTRTC,IVAL1,MAXROW,
33995     1                           IROWTO,ITEMP3(LL),IINDX2
33996 8989           FORMAT('LL,ISTRTC,IVAL1,MAXROW,IROWTO,ITEMP3(LL)',
33997     1                 'IINDX2=',7I6)
33998                CALL DPWRST('XXX','BUG ')
33999                WRITE(ICOUT,18988)CELLX1(LL),CELLX2(LL)
3400018988           FORMAT('CELLX1(LL),CELLX2(LL) = ',2G15.7)
34001                CALL DPWRST('XXX','BUG ')
34002              ENDIF
34003C
34004              DO8995JJ=1,NUMV
34005                IINDX1=ISTRTC + (JJ-1)*IINC
34006                ICOLVJ=IECOL2(JJ)
34007C
34008                IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
34009                  WRITE(ICOUT,8996)ISTRTC,JJ,IINDX1
34010 8996             FORMAT('ISTRTC,JJ,IINDX1=',3I6)
34011                  CALL DPWRST('XXX','BUG ')
34012                ENDIF
34013C
34014                IF(JJ.EQ.NUMV)THEN
34015                  DO8994KK=1,MAXROW
34016                    Z0=REAL(LL)
34017                    IJ=MAXN*(ICOLVJ-1)+IINDX2+KK
34018                    IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
34019                    IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
34020                    IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
34021                    IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
34022                    IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
34023                    IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
34024                    IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
34025 8994             CONTINUE
34026                ELSEIF(ICTLST(JJ).LE.0)THEN
34027                  DO18995KK=1,MAXROW
34028                    IF(JJ.EQ.IVARC1)THEN
34029                      Z0=CELLX1(LL)
34030                    ELSEIF(JJ.EQ.IVARC2)THEN
34031                      Z0=CELLX2(LL)
34032                    ELSEIF(JJ.EQ.IVARC3)THEN
34033                      Z0=CELLX3(LL)
34034                    ELSEIF(JJ.EQ.IVARC4)THEN
34035                      Z0=CELLX4(LL)
34036                    ELSE
34037                      Z0=PSTAMV
34038                    ENDIF
34039                    IJ=MAXN*(ICOLVJ-1)+IINDX2+KK
34040                    IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
34041                    IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
34042                    IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
34043                    IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
34044                    IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
34045                    IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
34046                    IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
3404718995             CONTINUE
34048                ELSE
34049C
34050                  IVAL2=ITEMP1(IVAL1+JJ)
34051                  NUMLGR=ITEMP1(IVAL)
34052                  ICOLVJ=IECOL2(JJ)
34053                  IINDX1=ISTRTC + (JJ-1)*IINC
34054                  IF(NUMLGR.GE.1 .AND. NUMLGR.LT.NINIT)THEN
34055                    CALL SORT(XSCRT(IINDX1+1),NUMLGR,XSCRT(IINDX1+1))
34056                    ICNT2=0
34057C
34058                    IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
34059                      WRITE(ICOUT,8997)JJ,NUMLGR,ICOLVJ,IINDX1
34060 8997                 FORMAT('8997: JJ,NUMLGR,ICOLVJ,IINDX1 = ',4I8)
34061                      CALL DPWRST('XXX','BUG ')
34062                    ENDIF
34063C
34064                    DO8998KK=1,MAXROW
34065                      ICNT2=ICNT2+1
34066                      IF(KK.LE.NUMLGR)THEN
34067                        Z0=XSCRT(IINDX1 + KK)
34068                      ELSE
34069                        Z0=PSTAMV
34070                      ENDIF
34071                      IJ=MAXN*(ICOLVJ-1)+IINDX2+ICNT2
34072                      IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
34073                      IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
34074                      IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
34075                      IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
34076                      IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
34077                      IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
34078                      IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
34079 8998               CONTINUE
34080                  ELSE
34081C
34082C                   MINIMUM VALUE
34083C
34084                    ICNT2=1
34085                    Z0=XSCRT(IINDX1 + 1)
34086                    IJ=MAXN*(ICOLVJ-1)+IINDX2+ICNT2
34087                    IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
34088                    IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
34089                    IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
34090                    IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
34091                    IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
34092                    IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
34093                    IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
34094C
34095C                   M PERCENTILES
34096C
34097                    DO8999KK=1,M
34098                      ICNT2=ICNT2+1
34099                      Z0=XSCRT(IINDX1 + 1 + 2*KK)
34100                      IJ=MAXN*(ICOLVJ-1)+IINDX2+ICNT2
34101                      IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
34102                      IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
34103                      IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
34104                      IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
34105                      IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
34106                      IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
34107                      IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
34108 8999               CONTINUE
34109C
34110C                   ADD MAXIMUM VALUE
34111C
34112                    ICNT2=ICNT2+1
34113                    Z0=XSCRT(IINDX1 + NINIT)
34114                    IJ=MAXN*(ICOLVJ-1)+IINDX2+ICNT2
34115                    IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
34116                    IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
34117                    IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
34118                    IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
34119                    IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
34120                    IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
34121                    IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
34122C
34123C                   PAD WITH MISSING VALUES IF LESS THAN MAXIMUM
34124C                   NUMBER OF ROWS FOR THIS CELL
34125C
34126                    IF(ICNT2.LT.MAXROW)THEN
34127                      DO18999KK=ICNT2+1,MAXROW
34128                        ICNT2=ICNT2+1
34129                        Z0=PSTAMV
34130                        IJ=MAXN*(ICOLVJ-1)+IINDX2+ICNT2
34131                        IF(ICOLVJ.LE.MAXCOL)V(IJ)=Z0
34132                        IF(ICOLVJ.EQ.MAXCP1)PRED(ICNT2)=Z0
34133                        IF(ICOLVJ.EQ.MAXCP2)RES(ICNT2)=Z0
34134                        IF(ICOLVJ.EQ.MAXCP3)YPLOT(ICNT2)=Z0
34135                        IF(ICOLVJ.EQ.MAXCP4)XPLOT(ICNT2)=Z0
34136                        IF(ICOLVJ.EQ.MAXCP5)X2PLOT(ICNT2)=Z0
34137                        IF(ICOLVJ.EQ.MAXCP6)TAGPLO(ICNT2)=Z0
3413818999                 CONTINUE
34139                    ENDIF
34140                  ENDIF
34141                ENDIF
34142C
34143 8995         CONTINUE
34144 8991       CONTINUE
34145            GOTO7490
34146          ENDIF
34147        ENDIF
34148C
34149 7400 CONTINUE
34150 7490 CONTINUE
34151C
34152C               *****************************
34153C               **  STEP 11--              **
34154C               **  UPDATE THE NAME TABLE  **
34155C               *****************************
34156C
34157      ISTEPN='11'
34158      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
34159     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34160C
34161      ISTEPN='7600'
34162C
34163      IF(ICASRE.EQ.'WRIT')THEN
34164        IF(IFEEDB.EQ.'ON')THEN
34165          WRITE(ICOUT,999)
34166          CALL DPWRST('XXX','BUG ')
34167          WRITE(ICOUT,8021)IFILE2
34168 8021     FORMAT('FORMATTED DATA WRITTEN TO FILE: ',A80)
34169          CALL DPWRST('XXX','BUG ')
34170          WRITE(ICOUT,999)
34171          CALL DPWRST('XXX','BUG ')
34172        ENDIF
34173      ELSEIF(ICASRE.EQ.'GSTA' .OR. ICASRE.EQ.'DSTA' .OR.
34174     1       ICASRE.EQ.'FSTA' .OR. ICASRE.EQ.'CSTA' .OR.
34175     1       ICASRE.EQ.'EDIS' .OR. ICASRE.EQ.'MDIS' .OR.
34176     1       ICASRE.EQ.'CODI' .OR. ICASRE.EQ.'COSI' .OR.
34177     1       ICASRE.EQ.'ACDI' .OR. ICASRE.EQ.'ACSI' .OR.
34178     1       ICASRE.EQ.'CDIS' .OR. ICASRE.EQ.'CORR' .OR.
34179     1       ICASRE.EQ.'JADI' .OR. ICASRE.EQ.'JASI' .OR.
34180     1       ICASRE.EQ.'HDIS' .OR. ICASRE.EQ.'CNDI' .OR.
34181     1       ICASRE.EQ.'COVA' .OR. ICASRE.EQ.'CTED' .OR.
34182     1       ICASRE.EQ.'CTCD' .OR. ICASRE.EQ.'CTMD' .OR.
34183     1       ICASRE.EQ.'CTCR' .OR. ICASRE.EQ.'CTCV' .OR.
34184     1       ICASRE.EQ.'CTHD' .OR. ICASRE.EQ.'CTXD' .OR.
34185     1       ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CCOS' .OR.
34186     1       ICASRE.EQ.'CACD' .OR. ICASRE.EQ.'CACS' .OR.
34187     1       ICASRE.EQ.'CJAD' .OR. ICASRE.EQ.'CJAS' .OR.
34188     1       ICASRE.EQ.'PERC' .OR. ICASRE.EQ.'CTPE'
34189     1      )THEN
34190        NLAST=NUMV
34191        IF(ICASRE.EQ.'CTED' .OR.
34192     1     ICASRE.EQ.'CTCD' .OR. ICASRE.EQ.'CTMD' .OR.
34193     1     ICASRE.EQ.'CTCR' .OR. ICASRE.EQ.'CTCV' .OR.
34194     1     ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CCOS' .OR.
34195     1     ICASRE.EQ.'CACD' .OR. ICASRE.EQ.'CACS' .OR.
34196     1     ICASRE.EQ.'CTHD' .OR. ICASRE.EQ.'CTXD' .OR.
34197     1     ICASRE.EQ.'CJAD' .OR. ICASRE.EQ.'CJAS' .OR.
34198     1     ICASRE.EQ.'CTPE'
34199     1      )NLAST=NUMV+1
34200        DO7610IE=1,NUMV
34201          IF(ICASRE.EQ.'CSTA' .AND.
34202     1      (IE.LT.NUMV .AND. ICTLST(IE).EQ.0))GOTO7610
34203          IF(ICASRE.EQ.'EDIS' .AND. IVTYPE(IE).EQ.0)GOTO7610
34204          IF(ICASRE.EQ.'MDIS' .AND. IVTYPE(IE).EQ.0)GOTO7610
34205          IF(ICASRE.EQ.'CDIS' .AND. IVTYPE(IE).EQ.0)GOTO7610
34206          IF(ICASRE.EQ.'HDIS' .AND. IVTYPE(IE).EQ.0)GOTO7610
34207          IF(ICASRE.EQ.'CNDI' .AND. IVTYPE(IE).EQ.0)GOTO7610
34208          IF(ICASRE.EQ.'CODI' .AND. IVTYPE(IE).EQ.0)GOTO7610
34209          IF(ICASRE.EQ.'COSI' .AND. IVTYPE(IE).EQ.0)GOTO7610
34210          IF(ICASRE.EQ.'ACDI' .AND. IVTYPE(IE).EQ.0)GOTO7610
34211          IF(ICASRE.EQ.'ACSI' .AND. IVTYPE(IE).EQ.0)GOTO7610
34212          IF(ICASRE.EQ.'CORR' .AND. IVTYPE(IE).EQ.0)GOTO7610
34213          IF(ICASRE.EQ.'JADI' .AND. IVTYPE(IE).EQ.0)GOTO7610
34214          IF(ICASRE.EQ.'JASI' .AND. IVTYPE(IE).EQ.0)GOTO7610
34215          IF(ICASRE.EQ.'COVA' .AND. IVTYPE(IE).EQ.0)GOTO7610
34216          IF(ICASRE.EQ.'PERC' .AND. IVTYPE(IE).EQ.0)GOTO7610
34217          N=ICNT2
34218          IF(ICASRE.EQ.'CTPE')N=IROWTO
34219          IF(ICASRE.EQ.'CSTA')N=NSTAT*NCELL
34220          IF(ICASRE.EQ.'EDIS')N=NUMV
34221          IF(ICASRE.EQ.'MDIS')N=NUMV
34222          IF(ICASRE.EQ.'CDIS')N=NUMV
34223          IF(ICASRE.EQ.'HDIS')N=NUMV
34224          IF(ICASRE.EQ.'CNDI')N=NUMV
34225          IF(ICASRE.EQ.'CODI')N=NUMV
34226          IF(ICASRE.EQ.'COSI')N=NUMV
34227          IF(ICASRE.EQ.'ACDI')N=NUMV
34228          IF(ICASRE.EQ.'ACSI')N=NUMV
34229          IF(ICASRE.EQ.'CORR')N=NUMV
34230          IF(ICASRE.EQ.'COVA')N=NUMV
34231          IF(ICASRE.EQ.'JADI')N=NUMV
34232          IF(ICASRE.EQ.'JASI')N=NUMV
34233          IF(ICASRE.EQ.'CTED')N=NCOLNU*NCELL
34234          IF(ICASRE.EQ.'CTMD')N=NCOLNU*NCELL
34235          IF(ICASRE.EQ.'CTCD')N=NCOLNU*NCELL
34236          IF(ICASRE.EQ.'CTCR')N=NCOLNU*NCELL
34237          IF(ICASRE.EQ.'CTCV')N=NCOLNU*NCELL
34238          IF(ICASRE.EQ.'CCOD')N=NCOLNU*NCELL
34239          IF(ICASRE.EQ.'CCOS')N=NCOLNU*NCELL
34240          IF(ICASRE.EQ.'CACD')N=NCOLNU*NCELL
34241          IF(ICASRE.EQ.'CACS')N=NCOLNU*NCELL
34242          IF(ICASRE.EQ.'CJAD')N=NCOLNU*NCELL
34243          IF(ICASRE.EQ.'CJAS')N=NCOLNU*NCELL
34244          IF(ICASRE.EQ.'CTHD')N=NCOLNU*NCELL
34245          IF(ICASRE.EQ.'CTXD')N=NCOLNU*NCELL
34246          IF(ICASRE.EQ.'PERC')THEN
34247            IF(ITEMP1(IE).LE.NINIT)THEN
34248              N=ITEMP1(IE)
34249            ELSE
34250              N=M+2
34251            ENDIF
34252          ENDIF
34253          ICOLVJ=IECOL2(IE)
34254          DO7620J=1,NUMNAM
34255            IF(IUSE(J).EQ.'V'.AND.IVALUE(J).EQ.ICOLVJ)THEN
34256              IUSE(J)='V'
34257              IVALUE(J)=ICOLVJ
34258              IF(N.GT.IN(J))IN(J)=N
34259              IVSTAR(J)=MAXN*(ICOLVJ-1)+1
34260              IVSTOP(J)=MAXN*(ICOLVJ-1)+N
34261            ENDIF
34262 7620     CONTINUE
34263 7610   CONTINUE
34264C
34265        IF(IFEEDB.EQ.'ON')THEN
34266          WRITE(ICOUT,999)
34267          CALL DPWRST('XXX','BUG ')
34268          WRITE(ICOUT,8000)
34269 8000     FORMAT('INPUT DATA FILE SUMMARY INFORMATION--')
34270          CALL DPWRST('XXX','BUG ')
34271          IF(ICASRE.EQ.'GSTA')THEN
34272            WRITE(ICOUT,8001)ISTANM
34273 8001       FORMAT('STREAM READ FOR STATISTIC: ',A)
34274            CALL DPWRST('XXX','BUG ')
34275          ELSEIF(ICASRE.EQ.'DSTA')THEN
34276            WRITE(ICOUT,8031)
34277 8031       FORMAT('STREAM READ FOR DEFAULT STATISTICS')
34278            CALL DPWRST('XXX','BUG ')
34279          ELSEIF(ICASRE.EQ.'FSTA')THEN
34280            WRITE(ICOUT,8033)
34281 8033       FORMAT('STREAM READ FOR STATISTICS ON FULL DATA SET')
34282            CALL DPWRST('XXX','BUG ')
34283          ELSEIF(ICASRE.EQ.'EDIS' .OR. ICASRE.EQ.'MDIS' .OR.
34284     1           ICASRE.EQ.'CDIS' .OR.
34285     1           ICASRE.EQ.'JADI' .OR. ICASRE.EQ.'JASI' .OR.
34286     1           ICASRE.EQ.'HDIS' .OR. ICASRE.EQ.'CNDI' .OR.
34287     1           ICASRE.EQ.'CODI' .OR. ICASRE.EQ.'COSI' .OR.
34288     1           ICASRE.EQ.'ACDI' .OR. ICASRE.EQ.'ACSI')THEN
34289            WRITE(ICOUT,8034)
34290 8034       FORMAT('STREAM READ FOR DISTANCE MATRIX ON FULL DATA SET')
34291            CALL DPWRST('XXX','BUG ')
34292          ELSEIF(ICASRE.EQ.'COVA')THEN
34293            WRITE(ICOUT,8035)
34294 8035       FORMAT('STREAM READ FOR COVARIANCE MATRIX ON FULL DATA SET')
34295            CALL DPWRST('XXX','BUG ')
34296          ELSEIF(ICASRE.EQ.'CORR')THEN
34297            WRITE(ICOUT,8036)
34298 8036       FORMAT('STREAM READ FOR CORRELATION MATRIX ON FULL ',
34299     1             'DATA SET')
34300            CALL DPWRST('XXX','BUG ')
34301          ELSEIF(ICASRE.EQ.'CTED' .OR. ICASRE.EQ.'CTCD' .OR.
34302     1           ICASRE.EQ.'CTMD' .OR.
34303     1           ICASRE.EQ.'CJAD' .OR. ICASRE.EQ.'CJAS' .OR.
34304     1           ICASRE.EQ.'CCOD' .OR. ICASRE.EQ.'CCOS' .OR.
34305     1           ICASRE.EQ.'CTHD' .OR. ICASRE.EQ.'CTXD' .OR.
34306     1           ICASRE.EQ.'CACD' .OR. ICASRE.EQ.'CACS')THEN
34307            WRITE(ICOUT,8044)
34308 8044       FORMAT('STREAM READ FOR DISTANCE MATRIX ON CROSS-',
34309     1             'TABULATED DATA SET')
34310            CALL DPWRST('XXX','BUG ')
34311          ELSEIF(ICASRE.EQ.'CTCV')THEN
34312            WRITE(ICOUT,8045)
34313 8045       FORMAT('STREAM READ FOR COVARIANCE MATRIX ON CROSS-',
34314     1             'TABULATED DATA SET')
34315            CALL DPWRST('XXX','BUG ')
34316          ELSEIF(ICASRE.EQ.'CTCR')THEN
34317            WRITE(ICOUT,8046)
34318 8046       FORMAT('STREAM READ FOR CORRELATION MATRIX ON CROSS- ',
34319     1             'TABULATED DATA SET')
34320            CALL DPWRST('XXX','BUG ')
34321          ELSEIF(ICASRE.EQ.'PERC')THEN
34322            WRITE(ICOUT,8048)
34323 8048       FORMAT('STREAM READ FOR PERCENTILES ON FULL DATA SET')
34324            CALL DPWRST('XXX','BUG ')
34325          ELSEIF(ICASRE.EQ.'CTPE')THEN
34326            WRITE(ICOUT,8049)
34327 8049       FORMAT('STREAM READ FOR PERCENTILES ON CROSS- ',
34328     1             'TABULATED DATA SET')
34329            CALL DPWRST('XXX','BUG ')
34330          ENDIF
34331          IF(ICASRE.NE.'FSTA')THEN
34332            WRITE(ICOUT,8002)ISRESI
34333 8002       FORMAT('NUMBER OF ROWS FOR STATISTIC: ',I8)
34334            CALL DPWRST('XXX','BUG ')
34335          ENDIF
34336          WRITE(ICOUT,8003)IFCOL3,IFCOL4
34337 8003     FORMAT('INPUT FILE COLUMN     LIMITS     = ',I8,4X,I8)
34338          CALL DPWRST('XXX','BUG ')
34339          IF(IFROW2.EQ.INTINF)THEN
34340            WRITE(ICOUT,8004)IFROW1
34341 8004       FORMAT('INPUT FILE ROW        LIMITS     = ',I8,4X,
34342     1             'INFINITY')
34343            CALL DPWRST('XXX','BUG ')
34344          ELSEIF(IFROW2.NE.INTINF)THEN
34345            WRITE(ICOUT,8005)IFROW1,IFROW2
34346 8005       FORMAT('INPUT FILE ROW        LIMITS     = ',I8,4X,I8)
34347            CALL DPWRST('XXX','BUG ')
34348          ENDIF
34349          WRITE(ICOUT,8006)ISKIP
34350 8006     FORMAT('NUMBER OF HEADER LINES SKIPPED   = ',I8)
34351          CALL DPWRST('XXX','BUG ')
34352          WRITE(ICOUT,8007)NUMLRD
34353 8007     FORMAT('NUMBER OF DATA   LINES READ      = ',I10)
34354          CALL DPWRST('XXX','BUG ')
34355          IF(NUMV.GE.1)THEN
34356            WRITE(ICOUT,8008)NUMV
34357 8008       FORMAT('NUMBER OF VARIABLES    READ      = ',I8)
34358            CALL DPWRST('XXX','BUG ')
34359          ENDIF
34360C
34361          IFRST=IFCOL3
34362          IF(IFRST+240-1.GE.IFCOL4)THEN
34363            ILAST=IFCOL4
34364          ELSE
34365            ILAST=IFRST+240-1
34366          ENDIF
34367C
34368          WRITE(ICOUT,8011)
34369 8011     FORMAT('THE SCANNED REGION OF THE FIRST DATA LINE READ ',
34370     1           '(TO A MAXIMUM OF 240 CHARACTERS) = ')
34371          CALL DPWRST('XXX','BUG ')
34372          WRITE(ICOUT,8012)(ISTOR3(J),J=IFRST,MIN(240,ILAST))
34373 8012     FORMAT(240A1)
34374          CALL DPWRST('XXX','BUG ')
34375          WRITE(ICOUT,8013)
34376 8013     FORMAT('THE SCANNED REGION OF THE LAST  DATA LINE READ ',
34377     1           '(TO A MAXIMUM OF 240 CHARACTERS) = ')
34378          CALL DPWRST('XXX','BUG ')
34379          IF(IENDTY.EQ.1)THEN
34380            WRITE(ICOUT,8014)(ISTOR1(J),J=IFRST,MIN(240,ILAST))
34381            CALL DPWRST('XXX','BUG ')
34382          ELSEIF(IENDTY.EQ.2)THEN
34383            WRITE(ICOUT,8014)(ISTOR2(J),J=IFRST,MIN(240,ILAST))
34384 8014       FORMAT(240A1)
34385            CALL DPWRST('XXX','BUG ')
34386          ENDIF
34387        ENDIF
34388C
34389        WRITE(ICOUT,999)
34390        CALL DPWRST('XXX','BUG ')
34391        WRITE(ICOUT,8101)
34392 8101   FORMAT('VARIABLE     COLUMN    OBS/VARIABLE')
34393        CALL DPWRST('XXX','BUG ')
34394C
34395        DO8110IE=1,NUMV
34396          IH1=JVNAM1(IE)
34397          IH2=JVNAM2(IE)
34398          DO8120I=1,NUMNAM
34399            I2=I
34400            IF(IH1.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I))THEN
34401              WRITE(ICOUT,8126)IH1,IH2,IVALUE(I2),IN(I2)
34402 8126         FORMAT(A4,A4,1X,I8,5X,I8)
34403              CALL DPWRST('XXX','BUG ')
34404            ENDIF
34405 8120     CONTINUE
34406 8110   CONTINUE
34407      ENDIF
34408C
34409C               ***************************************
34410C               **  STEP 88--                        **
34411C               **  FOR THE FILE CASE,               **
34412C               **  CLOSE THE FILE.                  **
34413C               ***************************************
34414C
34415 8800 CONTINUE
34416      ISTEPN='88'
34417      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')
34418     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34419C
34420      IF(IOFILE.EQ.'YES'.AND.ICURST.EQ.'OPEN')THEN
34421        IENDFI='OFF'
34422        IREWIN='ON'
34423        CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
34424     1              IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
34425        IREACS='CLOSED'
34426      ENDIF
34427C
34428      IF(IFLGOU.EQ.1)THEN
34429        IENDFI='OFF'
34430        IREWIN='ON'
34431        CALL DPCLFI(IOUNI2,IFILE2,ISTAT2,IFORM2,IACCE2,IPROT2,ICURS2,
34432     1              IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
34433        IREACS='CLOSED'
34434      ENDIF
34435C
34436C               *****************
34437C               **  STEP 90--  **
34438C               **  EXIT       **
34439C               *****************
34440C
34441 9000 CONTINUE
34442 9090 CONTINUE
34443C
34444      IFILQU=IFILQ2
34445      IGRPAU=IGRPA2
34446      PSTAMV=PSTAM2
34447C
34448      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'STRE')THEN
34449        WRITE(ICOUT,999)
34450        CALL DPWRST('XXX','BUG ')
34451        WRITE(ICOUT,9011)
34452 9011   FORMAT('***** AT THE END       OF DPSTRE--')
34453        CALL DPWRST('XXX','BUG ')
34454        WRITE(ICOUT,9012)IFROW1,IFCOL1,IFCOL2,AFROW2,ICASRE
34455 9012   FORMAT('IFROW1,IFCOL1,IFCOL2,AFROW2,ICASRE = ',
34456     1         3I8,2X,E15.7,2X,A4)
34457        CALL DPWRST('XXX','BUG ')
34458        WRITE(ICOUT,9015)IFOUND,IERROR
34459 9015   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
34460        CALL DPWRST('XXX','BUG ')
34461        WRITE(ICOUT,9016)NUMVRD,NUMPRD,NUMFRD
34462 9016   FORMAT('NUMVRD,NUMPRD,NUMFRD = ',3I8)
34463        CALL DPWRST('XXX','BUG ')
34464        WRITE(ICOUT,9017)IMACRO,IMACNU,IMACCS
34465 9017   FORMAT('IMACRO,IMACNU,IMACCS = ',A4,I8,2X,A12)
34466        CALL DPWRST('XXX','BUG ')
34467        WRITE(ICOUT,9019)IOSW,IOFILE,IOTERM,IRD,IRD2,IOUNIT
34468 9019   FORMAT('IOSW,IOFILE,IOTERM,IRD,IRD2,IOUNIT = ',3(A4,2X),3I8)
34469        CALL DPWRST('XXX','BUG ')
34470        WRITE(ICOUT,9022)IFILE
34471 9022   FORMAT('IFILE  = ',A80)
34472        CALL DPWRST('XXX','BUG ')
34473        WRITE(ICOUT,9023)ISTAT,IFORM,IACCES,IPROT,ICURST
34474 9023   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST  =',5(1X,A12))
34475        CALL DPWRST('XXX','BUG ')
34476        WRITE(ICOUT,9028)IENDFI,IREWIN,ISUBN0,IERRFI,NUMNAM
34477 9028   FORMAT('IENDFI,IREWIN,ISUBN0,IERRFI,NUMNAM = ',3(A4,1X),A12,I8)
34478        CALL DPWRST('XXX','BUG ')
34479        WRITE(ICOUT,9041)N2,MAXN2,N3,NCREAF
34480 9041   FORMAT('N2,MAXN2,N3,NCREAF = ',4I8)
34481        CALL DPWRST('XXX','BUG ')
34482      ENDIF
34483C
34484      RETURN
34485      END
34486      SUBROUTINE DPSTRI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,ISEED,
34487     1ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
34488C
34489C     PURPOSE--GENERATE A STRIP PLOT (ALSO KNOWN AS A DOT PLOT)
34490C     WRITTEN BY--ALAN HECKERT
34491C                 STATISTICAL ENGINEERING DIVISION
34492C                 INFORMATION TECHNOLOGY LABORATROY
34493C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
34494C                 GAITHERSBURG, MD 20899-8980
34495C                 PHONE--301-975-2899
34496C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
34497C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
34498C     LANGUAGE--ANSI FORTRAN (1977)
34499C     VERSION NUMBER--2008/10
34500C     ORIGINAL VERSION--OCTOBER   2008.
34501C     UPDATED         --OCTOBER   2009. ADD A "BATCH MULTIPLE" OPTION
34502C
34503C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
34504C
34505      CHARACTER*4 ICASPL
34506      CHARACTER*4 IAND1
34507      CHARACTER*4 IAND2
34508      CHARACTER*4 ISUBRO
34509      CHARACTER*4 IBUGG2
34510      CHARACTER*4 IBUGG3
34511      CHARACTER*4 IBUGQ
34512      CHARACTER*4 IFOUND
34513      CHARACTER*4 IERROR
34514C
34515      CHARACTER*4 IDATSW
34516      CHARACTER*4 ISUBN1
34517      CHARACTER*4 ISUBN2
34518      CHARACTER*4 ISTEPN
34519C
34520      PARAMETER (MAXSPN=10)
34521      CHARACTER*4 IVARN1(MAXSPN)
34522      CHARACTER*4 IVARN2(MAXSPN)
34523      CHARACTER*4 IVARTY(MAXSPN)
34524      REAL PVAR(MAXSPN)
34525      INTEGER ILIS(MAXSPN)
34526      INTEGER NRIGHT(MAXSPN)
34527      INTEGER ICOLR(MAXSPN)
34528      CHARACTER*40 INAME
34529C
34530C---------------------------------------------------------------------
34531C
34532      INCLUDE 'DPCOPA.INC'
34533C
34534      DIMENSION Y1(MAXOBV)
34535      DIMENSION X1(MAXOBV)
34536      DIMENSION TAG1(MAXOBV)
34537      DIMENSION TAG2(MAXOBV)
34538      DIMENSION XIDTEM(MAXOBV)
34539      DIMENSION XIDTE2(MAXOBV)
34540      DIMENSION XTEMP(MAXOBV)
34541      DIMENSION YTEMP(MAXOBV)
34542      DIMENSION TEMP3(MAXOBV)
34543      DIMENSION TEMP4(MAXOBV)
34544      DIMENSION TEMP5(MAXOBV)
34545      DIMENSION ITEMP1(MAXOBV)
34546      INCLUDE 'DPCOZZ.INC'
34547      INCLUDE 'DPCOZI.INC'
34548      EQUIVALENCE (GARBAG(IGARB1),X1(1))
34549      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
34550      EQUIVALENCE (GARBAG(IGARB3),TAG1(1))
34551      EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1))
34552      EQUIVALENCE (GARBAG(IGARB5),XTEMP(1))
34553      EQUIVALENCE (GARBAG(IGARB6),YTEMP(1))
34554      EQUIVALENCE (GARBAG(IGARB7),TEMP3(1))
34555      EQUIVALENCE (GARBAG(IGARB8),TAG2(1))
34556      EQUIVALENCE (GARBAG(IGARB9),XIDTE2(1))
34557      EQUIVALENCE (GARBAG(IGAR10),TEMP4(1))
34558      EQUIVALENCE (GARBAG(JGAR11),TEMP5(1))
34559      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
34560C
34561C-----COMMON----------------------------------------------------------
34562C
34563      INCLUDE 'DPCOST.INC'
34564      INCLUDE 'DPCOHK.INC'
34565      INCLUDE 'DPCODA.INC'
34566      INCLUDE 'DPCOP2.INC'
34567C
34568C-----START POINT-----------------------------------------------------
34569C
34570      IFOUND='NO'
34571      IERROR='NO'
34572      ISUBN1='DPST'
34573      ISUBN2='RI  '
34574C
34575      MAXCP1=MAXCOL+1
34576      MAXCP2=MAXCOL+2
34577      MAXCP3=MAXCOL+3
34578      MAXCP4=MAXCOL+4
34579      MAXCP5=MAXCOL+5
34580      MAXCP6=MAXCOL+6
34581C
34582      MINN2=2
34583C
34584C               **********************************************
34585C               **  TREAT THE STRIP    PLOT AND             **
34586C               **  RELATED STATISTICAL DISTRIBUTION PLOTS  **
34587C               **********************************************
34588C
34589      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'STRI')THEN
34590        WRITE(ICOUT,999)
34591  999   FORMAT(1X)
34592        CALL DPWRST('XXX','BUG ')
34593        WRITE(ICOUT,51)
34594   51   FORMAT('***** AT THE BEGINNING OF DPSTRI--')
34595        CALL DPWRST('XXX','BUG ')
34596        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ
34597   53   FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4)
34598        CALL DPWRST('XXX','BUG ')
34599      ENDIF
34600C
34601C               ***************************
34602C               **  STEP 1--             **
34603C               **  EXTRACT THE COMMAND  **
34604C               ***************************
34605C
34606      ISTEPN='1'
34607      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STRI')
34608     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34609C
34610      IF(ICOM.EQ.'STRI'.AND.IHARG(1).EQ.'PLOT')THEN
34611        ICASPL='STRI'
34612        ILASTC=1
34613        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
34614        IFOUND='YES'
34615      ELSEIF(ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'STRI'.AND.
34616     1       IHARG(2).EQ.'PLOT')THEN
34617        ICASPL='BSPL'
34618        ILASTC=2
34619        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
34620        IFOUND='YES'
34621      ELSEIF(ICOM.EQ.'BATC'.AND.IHARG(1).EQ.'MULT'.AND.
34622     1       IHARG(2).EQ.'STRI'.AND.IHARG(3).EQ.'PLOT')THEN
34623        ICASPL='BMSP'
34624        ILASTC=3
34625        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
34626        IFOUND='YES'
34627      ELSEIF(ICOM.EQ.'MULT'.AND.IHARG(1).EQ.'BATCH'.AND.
34628     1       IHARG(2).EQ.'STRI'.AND.IHARG(3).EQ.'PLOT')THEN
34629        ICASPL='BMSP'
34630        ILASTC=3
34631        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
34632        IFOUND='YES'
34633      ELSE
34634        IFOUND='NO'
34635        GOTO9000
34636      ENDIF
34637C
34638      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'STRI')THEN
34639        WRITE(ICOUT,62)ICASPL,MAXV2
34640   62   FORMAT('ICASPL,MAXV2 = ',A4,2X,I5)
34641        CALL DPWRST('XXX','BUG ')
34642      ENDIF
34643C
34644C               ****************************************
34645C               **  STEP 2--                          **
34646C               **  EXTRACT THE VARIABLE LIST         **
34647C               ****************************************
34648C
34649      ISTEPN='2'
34650      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STRI')
34651     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34652C
34653      INAME='STRIP PLOT'
34654      MINNA=1
34655      IF(ICASPL.EQ.'BSPL')MINNA=2
34656      IF(ICASPL.EQ.'BMSP')MINNA=3
34657      MAXNA=100
34658      MINN2=1
34659      IFLAGE=1
34660      IFLAGM=0
34661      IFLAGP=0
34662      JMIN=1
34663      JMAX=NUMARG
34664      MINNVA=1
34665      IF(ICASPL.EQ.'BSPL')MINNVA=2
34666      IF(ICASPL.EQ.'BMSP')MINNVA=3
34667      MAXNVA=2
34668      IF(ICASPL.EQ.'BSPL')MAXNVA=3
34669      IF(ICASPL.EQ.'BMSP')MAXNVA=3
34670C
34671      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
34672     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
34673     1            JMIN,JMAX,
34674     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
34675     1            IVARN1,IVARN2,IVARTY,PVAR,
34676     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
34677     1            MINNVA,MAXNVA,
34678     1            IFLAGM,IFLAGP,
34679     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
34680      IF(IERROR.EQ.'YES')GOTO9000
34681C
34682      IF(NUMVAR.EQ.1)THEN
34683        IDATSW='RAW'
34684      ELSEIF(NUMVAR.EQ.2)THEN
34685        IF(ICASPL.EQ.'STRI')THEN
34686          IDATSW='FREQ'
34687        ELSE
34688          IDATSW='RAW'
34689        ENDIF
34690      ELSEIF(NUMVAR.EQ.3)THEN
34691        IF(ICASPL.EQ.'BSPL')IDATSW='FREQ'
34692        IF(ICASPL.EQ.'BMSP')IDATSW='RAW'
34693      ENDIF
34694C
34695      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'STRI')THEN
34696        WRITE(ICOUT,999)
34697        CALL DPWRST('XXX','BUG ')
34698        WRITE(ICOUT,281)
34699  281   FORMAT('***** AFTER CALL DPPARS--')
34700        CALL DPWRST('XXX','BUG ')
34701        WRITE(ICOUT,282)NQ,NUMVAR
34702  282   FORMAT('NQ,NUMVAR = ',2I8)
34703        CALL DPWRST('XXX','BUG ')
34704        IF(NUMVAR.GT.0)THEN
34705          DO285I=1,NUMVAR
34706            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
34707     1                      ICOLR(I)
34708  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
34709     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
34710            CALL DPWRST('XXX','BUG ')
34711  285     CONTINUE
34712        ENDIF
34713      ENDIF
34714C
34715      NLEFT=NRIGHT(1)
34716C
34717      IF(ICASPL.EQ.'STRI' .AND. IDATSW.EQ.'RAW')THEN
34718        J=0
34719        IMAX=NLEFT
34720        IF(NQ.LT.NLEFT)IMAX=NQ
34721        DO810I=1,IMAX
34722          IF(ISUB(I).EQ.0)GOTO810
34723          J=J+1
34724          IJ=MAXN*(ICOLR(1)-1)+I
34725          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
34726          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
34727          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
34728          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
34729          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
34730          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
34731          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
34732          TAG1(J)=1.0
34733          TAG2(J)=1.0
34734  810   CONTINUE
34735        NLOCAL=J
34736c
34737      ELSEIF(ICASPL.EQ.'STRI' .AND. IDATSW.EQ.'FREQ')THEN
34738        J=0
34739        IMAX=NLEFT
34740        IF(NQ.LT.NLEFT)IMAX=NQ
34741        DO820I=1,IMAX
34742          IF(ISUB(I).EQ.0)GOTO820
34743          J=J+1
34744          IJ=MAXN*(ICOLR(2)-1)+I
34745          IF(ICOLR(2).LE.MAXCOL)X1(J)=V(IJ)
34746          IF(ICOLR(2).EQ.MAXCP1)X1(J)=PRED(I)
34747          IF(ICOLR(2).EQ.MAXCP2)X1(J)=RES(I)
34748          IF(ICOLR(2).EQ.MAXCP3)X1(J)=YPLOT(I)
34749          IF(ICOLR(2).EQ.MAXCP4)X1(J)=XPLOT(I)
34750          IF(ICOLR(2).EQ.MAXCP5)X1(J)=X2PLOT(I)
34751          IF(ICOLR(2).EQ.MAXCP6)X1(J)=TAGPLO(I)
34752          IJ=MAXN*(ICOLR(1)-1)+I
34753          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
34754          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
34755          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
34756          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
34757          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
34758          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
34759          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
34760          TAG1(J)=1.0
34761          TAG2(J)=1.0
34762  820   CONTINUE
34763        NLOCAL=J
34764C
34765      ELSEIF(ICASPL.EQ.'BSPL' .AND. IDATSW.EQ.'RAW')THEN
34766        J=0
34767        IMAX=NLEFT
34768        IF(NQ.LT.NLEFT)IMAX=NQ
34769        DO830I=1,IMAX
34770          IF(ISUB(I).EQ.0)GOTO830
34771          J=J+1
34772          IJ=MAXN*(ICOLR(1)-1)+I
34773          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
34774          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
34775          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
34776          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
34777          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
34778          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
34779          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
34780          IJ=MAXN*(ICOLR(2)-1)+I
34781          IF(ICOLR(2).LE.MAXCOL)TAG1(J)=V(IJ)
34782          IF(ICOLR(2).EQ.MAXCP1)TAG1(J)=PRED(I)
34783          IF(ICOLR(2).EQ.MAXCP2)TAG1(J)=RES(I)
34784          IF(ICOLR(2).EQ.MAXCP3)TAG1(J)=YPLOT(I)
34785          IF(ICOLR(2).EQ.MAXCP4)TAG1(J)=XPLOT(I)
34786          IF(ICOLR(2).EQ.MAXCP5)TAG1(J)=X2PLOT(I)
34787          IF(ICOLR(2).EQ.MAXCP6)TAG1(J)=TAGPLO(I)
34788          TAG2(J)=1.0
34789  830   CONTINUE
34790        NLOCAL=J
34791C
34792      ELSEIF(ICASPL.EQ.'BSPL' .AND. IDATSW.EQ.'FREQ')THEN
34793        J=0
34794        IMAX=NLEFT
34795        IF(NQ.LT.NLEFT)IMAX=NQ
34796        DO840I=1,IMAX
34797          IF(ISUB(I).EQ.0)GOTO840
34798          J=J+1
34799          IJ=MAXN*(ICOLR(1)-1)+I
34800          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
34801          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
34802          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
34803          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
34804          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
34805          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
34806          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
34807          IJ=MAXN*(ICOLR(2)-1)+I
34808          IF(ICOLR(2).LE.MAXCOL)X1(J)=V(IJ)
34809          IF(ICOLR(2).EQ.MAXCP1)X1(J)=PRED(I)
34810          IF(ICOLR(2).EQ.MAXCP2)X1(J)=RES(I)
34811          IF(ICOLR(2).EQ.MAXCP3)X1(J)=YPLOT(I)
34812          IF(ICOLR(2).EQ.MAXCP4)X1(J)=XPLOT(I)
34813          IF(ICOLR(2).EQ.MAXCP5)X1(J)=X2PLOT(I)
34814          IF(ICOLR(2).EQ.MAXCP6)X1(J)=TAGPLO(I)
34815          IJ=MAXN*(ICOLR(3)-1)+I
34816          IF(ICOLR(3).LE.MAXCOL)TAG1(J)=V(IJ)
34817          IF(ICOLR(3).EQ.MAXCP1)TAG1(J)=PRED(I)
34818          IF(ICOLR(3).EQ.MAXCP2)TAG1(J)=RES(I)
34819          IF(ICOLR(3).EQ.MAXCP3)TAG1(J)=YPLOT(I)
34820          IF(ICOLR(3).EQ.MAXCP4)TAG1(J)=XPLOT(I)
34821          IF(ICOLR(3).EQ.MAXCP5)TAG1(J)=X2PLOT(I)
34822          IF(ICOLR(3).EQ.MAXCP6)TAG1(J)=TAGPLO(I)
34823          TAG2(J)=1.0
34824  840   CONTINUE
34825        NLOCAL=J
34826C
34827      ELSEIF(ICASPL.EQ.'BMSP')THEN
34828        J=0
34829        IMAX=NLEFT
34830        IF(NQ.LT.NLEFT)IMAX=NQ
34831        DO850I=1,IMAX
34832          IF(ISUB(I).EQ.0)GOTO850
34833          J=J+1
34834          IJ=MAXN*(ICOLR(1)-1)+I
34835          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
34836          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
34837          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
34838          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
34839          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
34840          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
34841          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
34842          IJ=MAXN*(ICOLR(2)-1)+I
34843          IF(ICOLR(2).LE.MAXCOL)TAG1(J)=V(IJ)
34844          IF(ICOLR(2).EQ.MAXCP1)TAG1(J)=PRED(I)
34845          IF(ICOLR(2).EQ.MAXCP2)TAG1(J)=RES(I)
34846          IF(ICOLR(2).EQ.MAXCP3)TAG1(J)=YPLOT(I)
34847          IF(ICOLR(2).EQ.MAXCP4)TAG1(J)=XPLOT(I)
34848          IF(ICOLR(2).EQ.MAXCP5)TAG1(J)=X2PLOT(I)
34849          IF(ICOLR(2).EQ.MAXCP6)TAG1(J)=TAGPLO(I)
34850          IJ=MAXN*(ICOLR(3)-1)+I
34851          IF(ICOLR(3).LE.MAXCOL)TAG2(J)=V(IJ)
34852          IF(ICOLR(3).EQ.MAXCP1)TAG2(J)=PRED(I)
34853          IF(ICOLR(3).EQ.MAXCP2)TAG2(J)=RES(I)
34854          IF(ICOLR(3).EQ.MAXCP3)TAG2(J)=YPLOT(I)
34855          IF(ICOLR(3).EQ.MAXCP4)TAG2(J)=XPLOT(I)
34856          IF(ICOLR(3).EQ.MAXCP5)TAG2(J)=X2PLOT(I)
34857          IF(ICOLR(3).EQ.MAXCP6)TAG2(J)=TAGPLO(I)
34858  850   CONTINUE
34859        NLOCAL=J
34860C
34861      ENDIF
34862C
34863C               *****************************************************
34864C               **  STEP 9--                                       **
34865C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
34866C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
34867C               **  RESET THE VECTOR D(.) TO ALL ONES.             **
34868C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
34869C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
34870C               *****************************************************
34871C
34872      ISTEPN='9'
34873      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'STRI')
34874     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
34875C
34876      CALL DPSTR2(Y1,X1,TAG1,TAG2,XIDTEM,XIDTE2,
34877     1            NLOCAL,ICASPL,IDATSW,
34878     1            PSTRIN,ISTRPL,ISEED,
34879     1            YTEMP,XTEMP,TEMP3,TEMP4,TEMP5,ITEMP1,
34880     1            Y,X,D,NPLOTP,NPLOTV,ISUBRO,IBUGG3,IERROR)
34881C
34882C               *****************
34883C               **  STEP 90--  **
34884C               **  EXIT       **
34885C               *****************
34886C
34887 9000 CONTINUE
34888      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'STRI')THEN
34889        WRITE(ICOUT,999)
34890        CALL DPWRST('XXX','BUG ')
34891        WRITE(ICOUT,9011)
34892 9011   FORMAT('***** AT THE END       OF DPSTRI--')
34893        CALL DPWRST('XXX','BUG ')
34894        WRITE(ICOUT,9012)IFOUND,IERROR
34895 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
34896        CALL DPWRST('XXX','BUG ')
34897        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
34898 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
34899     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
34900        CALL DPWRST('XXX','BUG ')
34901        IF(NPLOTP.GE.1)THEN
34902          DO9015I=1,NPLOTP
34903            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
34904 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
34905            CALL DPWRST('XXX','BUG ')
34906 9015     CONTINUE
34907        ENDIF
34908      ENDIF
34909C
34910      RETURN
34911      END
34912      SUBROUTINE DPSTR2(Y,X,TAG1,TAG2,XIDTEM,XIDTE2,
34913     1                  N,ICASPL,IDATSW,
34914     1                  PSTRIN,ISTRPL,ISEED,
34915     1                  YTEMP,XTEMP,TEMP3,TEMP4,YDIST,ZCOUNT,
34916     1                  Y2,X2,D2,N2,NPLOTV,ISUBRO,IBUGG3,IERROR)
34917C
34918C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
34919C              THAT WILL DEFINE A STRIP PLOT (ALSO KNOWN AS
34920C              A DOT PLOT).
34921C
34922C              THE DATA CAN EITHER A SINGLE RESPONSE VARIABLE
34923C              OR A FREQUENCY TABLE.  NOTE THAT THE BINNING
34924C              SHOULD BE DONE BEFORE CALLING THE STRIP PLOT
34925C              (I.E., THE SINGLE VARIABLE CASE WILL NOT BE
34926C              BINNED).
34927C
34928C     WRITTEN BY--JAMES J. FILLIBEN
34929C                 STATISTICAL ENGINEERING DIVISION
34930C                 INFORMATION TECHNOLOGY LABORATORY
34931C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
34932C                 GAITHERSBURG, MD 20899-8980
34933C                 PHONE--301-975-2855
34934C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
34935C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
34936C     LANGUAGE--ANSI FORTRAN (1977)
34937C     VERSION NUMBER--2008/10
34938C     ORIGINAL VERSION--OCTOBER   2008.
34939C     UPDATED         --OCTOBER   2009. SUPPORT FOR "BATCH MULTIPLE"
34940C                                       OPTION
34941C
34942C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
34943C
34944      CHARACTER*4 ICASPL
34945      CHARACTER*4 IDATSW
34946      CHARACTER*4 ISTRPL
34947      CHARACTER*4 ISUBRO
34948      CHARACTER*4 IBUGG3
34949      CHARACTER*4 IERROR
34950C
34951      CHARACTER*4 IWRITE
34952      CHARACTER*4 ISUBN1
34953      CHARACTER*4 ISUBN2
34954C
34955C---------------------------------------------------------------------
34956C
34957      DIMENSION Y(*)
34958      DIMENSION X(*)
34959      DIMENSION TAG1(*)
34960      DIMENSION TAG2(*)
34961      DIMENSION XIDTEM(*)
34962      DIMENSION XIDTE2(*)
34963      DIMENSION YTEMP(*)
34964      DIMENSION XTEMP(*)
34965      DIMENSION TEMP3(*)
34966      DIMENSION TEMP4(*)
34967      DIMENSION YDIST(*)
34968      DIMENSION Y2(*)
34969      DIMENSION X2(*)
34970      DIMENSION D2(*)
34971C
34972      INTEGER ZCOUNT(*)
34973C
34974C---------------------------------------------------------------------
34975C
34976      INCLUDE 'DPCOP2.INC'
34977C
34978C-----START POINT-----------------------------------------------------
34979C
34980      ISUBN1='DPST'
34981      ISUBN2='R2  '
34982      IERROR='NO'
34983      IWRITE='OFF'
34984C
34985C               ********************************************
34986C               **  STEP 1--                              **
34987C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
34988C               ********************************************
34989C
34990      IF(N.LT.1)THEN
34991        WRITE(ICOUT,999)
34992  999   FORMAT(1X)
34993        CALL DPWRST('XXX','BUG ')
34994        WRITE(ICOUT,31)
34995   31   FORMAT('***** ERROR IN STRIP PLOT--')
34996        CALL DPWRST('XXX','BUG ')
34997        WRITE(ICOUT,32)
34998   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1.')
34999        CALL DPWRST('XXX','BUG ')
35000        WRITE(ICOUT,34)N
35001   34   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
35002        CALL DPWRST('XXX','BUG ')
35003        WRITE(ICOUT,999)
35004        CALL DPWRST('XXX','BUG ')
35005        IERROR='YES'
35006        GOTO9000
35007      ENDIF
35008C
35009      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'STR2')THEN
35010        WRITE(ICOUT,999)
35011        CALL DPWRST('XXX','BUG ')
35012        WRITE(ICOUT,70)
35013   70   FORMAT('***** AT THE BEGINNING OF DPSTR2--')
35014        CALL DPWRST('XXX','BUG ')
35015        WRITE(ICOUT,71)IDATSW,ICASPL,ISTRPL,N
35016   71   FORMAT('IDATSW,ICASPL,ISTRPL,N = ',3(A4,2X),I8)
35017        CALL DPWRST('XXX','BUG ')
35018        DO73I=1,N
35019          WRITE(ICOUT,74)I,Y(I),X(I),TAG1(I),TAG2(I)
35020   74     FORMAT('I,Y(I),X(I),TAG1(I),TAG2(I) = ',I8,4G15.7)
35021          CALL DPWRST('XXX','BUG ')
35022   73   CONTINUE
35023      ENDIF
35024C
35025C               **********************************************
35026C               **  STEP 2--                                **
35027C               **  GENERATE THE STRIP PLOT                 **
35028C               **********************************************
35029C
35030      IF(ICASPL.EQ.'BMSP')THEN
35031        CALL DISTIN(TAG1,N,IWRITE,XIDTEM,NGROUP,IBUGG3,IERROR)
35032        CALL SORT(XIDTEM,NGROUP,XIDTEM)
35033        CALL DISTIN(TAG2,N,IWRITE,XIDTE2,NGROU2,IBUGG3,IERROR)
35034        CALL SORT(XIDTE2,NGROU2,XIDTE2)
35035      ELSEIF(ICASPL.EQ.'BSPL')THEN
35036        CALL DISTIN(TAG1,N,IWRITE,XIDTEM,NGROUP,IBUGG3,IERROR)
35037        CALL SORT(XIDTEM,NGROUP,XIDTEM)
35038        NGROU2=1
35039      ELSE
35040        NGROUP=1
35041        NGROU2=1
35042        XIDTEM(1)=1.0
35043        XIDTE2(1)=1.0
35044      ENDIF
35045C
35046C     2018/06: IMPLEMENT THE "MULTIPLE BATCH" OPTION FOR RAW DATA
35047C              SEPARATELY WHEN USING "STACK" OPTION
35048C
35049      IF(ICASPL.EQ.'BMSP' .AND. IDATSW.EQ.'RAW' .AND.
35050     1   ISTRPL.EQ.'STAC')GOTO4000
35051C
35052      K1=0
35053      DO1000ISET=1,NGROUP
35054        HOLD=XIDTEM(ISET)
35055        NTEMP=0
35056        DO1010J=1,N
35057          IF(TAG1(J).EQ.HOLD)THEN
35058            NTEMP=NTEMP+1
35059            YTEMP(NTEMP)=Y(J)
35060            XTEMP(NTEMP)=X(J)
35061            TEMP4(NTEMP)=1.0
35062            DO1015ISET2=1,NGROU2
35063              HOLD2=XIDTE2(ISET2)
35064              IF(TAG2(J).EQ.XIDTE2(ISET2))THEN
35065                TEMP4(NTEMP)=REAL(ISET2)
35066                GOTO1019
35067              ENDIF
35068 1015       CONTINUE
35069 1019       CONTINUE
35070          ENDIF
35071 1010   CONTINUE
35072C
35073        IF(IDATSW.EQ.'RAW')THEN
35074          IF(ICASPL.NE.'BMSP')CALL SORT(YTEMP,NTEMP,YTEMP)
35075          IF(ISTRPL.EQ.'JITT')THEN
35076            DELTA=0.5
35077            DO1030J=1,NTEMP
35078              TEMP3(J)=HOLD
35079 1030       CONTINUE
35080            CALL JITTER(TEMP3,NTEMP,DELTA,TEMP3,NTEMP,
35081     1                  ISEED,IBUGG3,IERROR)
35082            DO1050I=1,NTEMP
35083              K1=K1+1
35084              IF(ICASPL.EQ.'BMSP')THEN
35085                D2(K1)=TEMP4(I)
35086              ELSE
35087                D2(K1)=REAL(ISET)
35088              ENDIF
35089              X2(K1)=YTEMP(I)
35090              Y2(K1)=TEMP3(I)
35091 1050       CONTINUE
35092            N2=K1
35093            NPLOTV=2
35094          ELSEIF(ISTRPL.EQ.'OVER')THEN
35095            DO1090I=1,NTEMP
35096              K1=K1+1
35097              IF(ICASPL.EQ.'BMSP')THEN
35098                D2(K1)=TEMP4(I)
35099              ELSE
35100                D2(K1)=REAL(ISET)
35101              ENDIF
35102              X2(K1)=YTEMP(I)
35103              Y2(K1)=HOLD
35104 1090       CONTINUE
35105            N2=K1
35106            NPLOTV=2
35107          ELSE
35108            K1=K1+1
35109            K2=1
35110            X2(K1)=YTEMP(1)
35111            Y2(K1)=HOLD
35112            IF(ICASPL.EQ.'BMSP')THEN
35113              D2(K1)=TEMP4(1)
35114            ELSE
35115              D2(K1)=REAL(ISET)
35116            ENDIF
35117            DO2000I=2,NTEMP
35118              K1=K1+1
35119              IF(ICASPL.EQ.'BMSP')THEN
35120                D2(K1)=TEMP4(I)
35121              ELSE
35122                D2(K1)=REAL(ISET)
35123              ENDIF
35124              X2(K1)=YTEMP(I)
35125              IF(YTEMP(I).EQ.YTEMP(I-1))THEN
35126                K2=K2+1
35127              ELSE
35128                K2=1
35129              ENDIF
35130              ATEMP=HOLD + (K2-1)*PSTRIN
35131              Y2(K1)=ATEMP
35132 2000       CONTINUE
35133            N2=K1
35134            NPLOTV=2
35135          ENDIF
35136        ELSE
35137C
35138C         NOTE: FOR FREQUENCY DATA, ONLY SUPPORT "STACKED" STYLE,
35139C               NOT THE JITTER FORMAT.  ALSO, "MULTIPLE" OPTION
35140C               IS NOT SUPPORTED.
35141C
35142          K2=0
35143          DO3000I=1,NTEMP
35144            IF(YTEMP(I).LT.0.0)THEN
35145              WRITE(ICOUT,999)
35146              CALL DPWRST('XXX','BUG ')
35147              WRITE(ICOUT,31)
35148              CALL DPWRST('XXX','BUG ')
35149              WRITE(ICOUT,3010)I,ISET,Y(I)
35150 3010         FORMAT('      ROW ',I8,' OF BATCH ',I8,' HAS A NEGATIVE ',
35151     1             'FREQUENCY (',G15.7,')')
35152              CALL DPWRST('XXX','BUG ')
35153              IERROR='YES'
35154              GOTO9000
35155            ENDIF
35156C
35157            IF(I.GE.2 .AND. (XTEMP(I).LE.XTEMP(I-1)))THEN
35158              WRITE(ICOUT,999)
35159              CALL DPWRST('XXX','BUG ')
35160              WRITE(ICOUT,31)
35161              CALL DPWRST('XXX','BUG ')
35162              WRITE(ICOUT,3020)I,ISET
35163 3020         FORMAT('      THE CLASS MID-POINT FOR ROW ',I8,' OF ',
35164     1               'BATCH ',I8,' IS ')
35165              CALL DPWRST('XXX','BUG ')
35166              WRITE(ICOUT,3022)I-1,ISET
35167 3022         FORMAT('      LESS THAN THE CLASS MID-POINT FOR ROW ',
35168     1               I8,' OF BATCH ',I8,'.')
35169              CALL DPWRST('XXX','BUG ')
35170              WRITE(ICOUT,3024)I,XTEMP(I)
35171 3024         FORMAT('      CLASS MID-POINT FOR ROW ',I8,' = ',G15.7)
35172              CALL DPWRST('XXX','BUG ')
35173              WRITE(ICOUT,3024)I-1,X(I-1)
35174              CALL DPWRST('XXX','BUG ')
35175              IERROR='YES'
35176              GOTO9000
35177            ENDIF
35178C
35179            IFREQ=INT(YTEMP(I)+0.1)
35180            IF(IFREQ.GE.1)THEN
35181              ATEMP=REAL(ISET)
35182              DO3030J=1,IFREQ
35183                K1=K1+1
35184                X2(K1)=XTEMP(I)
35185                D2(K1)=REAL(ISET)
35186                Y2(K1)=ATEMP
35187                ATEMP=ATEMP+PSTRIN
35188 3030         CONTINUE
35189            ENDIF
35190C
35191 3000     CONTINUE
35192          N2=K1
35193          NPLOTV=2
35194        ENDIF
35195C
35196 1000 CONTINUE
35197C
35198      GOTO9000
35199C
35200 4000 CONTINUE
35201C
35202C     MULTIPLE BATCH OPTION FOR RAW DATA
35203C
35204C     STEP 1: DETERMINE UNIQUE VALUES OF RESPONSE AND SORT
35205C
35206      CALL DISTIN(Y,N,IWRITE,YDIST,NYDIST,IBUGG3,IERROR)
35207      CALL SORT(YDIST,NYDIST,YDIST)
35208      N2=0
35209C
35210      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'STR2')THEN
35211        WRITE(ICOUT,4001)NGROUP,NGROU2,NYDIST
35212 4001   FORMAT('BATCH MULTIPLE RAW DATA CASE: NGROUP,NGROU2,NYDIST = ',
35213     1         3I8)
35214        CALL DPWRST('XXX','BUG ')
35215      ENDIF
35216C
35217      DO4010ISET=1,NGROUP
35218C
35219C       STEP 1: EXTRACT ALL DATA FOR A GIVEN GROUP
35220C
35221        HOLD=XIDTEM(ISET)
35222        NTEMP=0
35223        DO4020J=1,N
35224          IF(TAG1(J).EQ.HOLD)THEN
35225            NTEMP=NTEMP+1
35226            YTEMP(NTEMP)=Y(J)
35227            XTEMP(NTEMP)=TAG2(J)
35228          ENDIF
35229 4020   CONTINUE
35230C
35231        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'STR2')THEN
35232          WRITE(ICOUT,4021)ISET,NTEMP
35233 4021     FORMAT('AT 4020: ISET,NTEMP = ',2I8)
35234          CALL DPWRST('XXX','BUG ')
35235        ENDIF
35236C
35237        CALL SORTC(XTEMP,YTEMP,NTEMP,XTEMP,TEMP4)
35238        DO4025J=1,NTEMP
35239          YTEMP(J)=TEMP4(J)
35240 4025   CONTINUE
35241        DO4028J=1,NYDIST
35242          ZCOUNT(J)=0
35243 4028   CONTINUE
35244C
35245C       STEP 2: LOOP THROUGH DATA IN THE GROUP AND MATCH IT TO
35246C               DISTINCT VALUES OF RESPONSE
35247C
35248        K2=0
35249        DO4030J=1,NTEMP
35250C
35251          ASTRT=REAL(ISET)
35252          ASTRT2=XTEMP(J)
35253C
35254          DO4040K=1,NYDIST
35255            IF(YTEMP(J).EQ.YDIST(K))THEN
35256              N2=N2+1
35257              X2(N2)=YTEMP(J)
35258              AVAL=REAL(ZCOUNT(K))
35259              ZCOUNT(K)=ZCOUNT(K)+1
35260              Y2(N2)=ASTRT+PSTRIN*AVAL
35261              D2(N2)=REAL((ISET-1)*NGROU2) + ASTRT2
35262            ENDIF
35263 4040     CONTINUE
35264 4030   CONTINUE
35265 4010 CONTINUE
35266      NPLOTV=2
35267C
35268C               ******************
35269C               **   STEP 90--  **
35270C               **   EXIT       **
35271C               ******************
35272C
35273 9000 CONTINUE
35274      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'STR2')THEN
35275        WRITE(ICOUT,999)
35276        CALL DPWRST('XXX','BUG ')
35277        WRITE(ICOUT,9011)
35278 9011   FORMAT('***** AT THE END       OF DPSTR2--')
35279        CALL DPWRST('XXX','BUG ')
35280        WRITE(ICOUT,9012)ICASPL,IDATSW,PSTRIN,IERROR,N2
35281 9012   FORMAT('ICASPL,IDATSW,PSTRIN,IERROR,N2 = ',
35282     1         A4,2X,A4,2X,G15.7,2X,A4,2X,I8)
35283        CALL DPWRST('XXX','BUG ')
35284        DO9015I=1,N2
35285          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
35286 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
35287          CALL DPWRST('XXX','BUG ')
35288 9015   CONTINUE
35289      ENDIF
35290C
35291      RETURN
35292      END
35293      SUBROUTINE DPSTRB(ISUBRO,IBUGA3,IERROR)
35294C
35295C     PURPOSE--CREATE A BLANK STRING OF SPECIFIED LENGTH
35296C     EXAMPLE--LET SOUT = BLANK STRING NLEN
35297C     WRITTEN BY--ALAN HECKERT
35298C                 STATISTICAL ENGINEERING DIVISION
35299C                 INFORMATION TECHNOLOGY LABORATORY
35300C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
35301C                 GAITHERSBURG, MD 20899-8980
35302C                 PHONE--301-975-2899
35303C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
35304C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
35305C     LANGUAGE--ANSI FORTRAN (1977)
35306C     VERSION NUMBER--2017/01
35307C     ORIGINAL VERSION--JANUARY   2017.
35308C
35309C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
35310C
35311      CHARACTER*4 ISUBRO
35312      CHARACTER*4 IBUGA3
35313      CHARACTER*4 IERROR
35314C
35315      CHARACTER*4 NEWNAM
35316      CHARACTER*4 NEWNA2
35317      CHARACTER*4 NEWCOL
35318      CHARACTER*4 NEWCO2
35319      CHARACTER*4 ICASEL
35320      CHARACTER*4 ICASE2
35321      CHARACTER*4 IHLEFT
35322      CHARACTER*4 IHLEF2
35323      CHARACTER*4 IHRIGH
35324      CHARACTER*4 IHRIG2
35325      CHARACTER*4 ISUBN1
35326      CHARACTER*4 ISUBN2
35327      CHARACTER*4 ISTEPN
35328C
35329C---------------------------------------------------------------------
35330C
35331C-----COMMON----------------------------------------------------------
35332C
35333      INCLUDE 'DPCOPA.INC'
35334      INCLUDE 'DPCOHK.INC'
35335      INCLUDE 'DPCODA.INC'
35336      INCLUDE 'DPCOP2.INC'
35337C
35338C-----START POINT-----------------------------------------------------
35339C
35340      ISUBN1='DPST'
35341      ISUBN2='MR  '
35342      IERROR='NO'
35343C
35344      ILOC3=0
35345C
35346      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STRB')THEN
35347        WRITE(ICOUT,999)
35348        CALL DPWRST('XXX','BUG ')
35349        WRITE(ICOUT,51)
35350   51   FORMAT('***** AT THE BEGINNING OF DPSTRB--')
35351        CALL DPWRST('XXX','BUG ')
35352        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
35353   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
35354        CALL DPWRST('XXX','BUG ')
35355        DO55I=1,NUMNAM
35356          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
35357     1                   IVSTOP(I)
35358   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
35359     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
35360          CALL DPWRST('XXX','BUG ')
35361   55   CONTINUE
35362        WRITE(ICOUT,57)NUMCHF,MAXCHF
35363   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
35364        CALL DPWRST('XXX','BUG ')
35365        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
35366   60   FORMAT('IFUNC(.)  = ',120A1)
35367        CALL DPWRST('XXX','BUG ')
35368      ENDIF
35369C
35370C               **********************************
35371C               **  STEP 1--                    **
35372C               **  INITIALIZE SOME VARIABLES.  **
35373C               **********************************
35374C
35375      ISTEPN='1'
35376      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRB')
35377     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35378C
35379      NEWNAM='NO'
35380      NEWNA2='NO'
35381      NEWCOL='NO'
35382      NEWCO2='NO'
35383      ICASEL='UNKN'
35384      ICASE2='UNKN'
35385      NIOLD1=0
35386      NIOLD2=0
35387      ICOLL=0
35388      ICOL2=0
35389C
35390C               ******************************************************
35391C               **  STEP 2--                                         *
35392C               **  EXAMINE THE ARGUMENT ON THE                      *
35393C               **  LEFT-HAND SIDE--                                 *
35394C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
35395C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
35396C               ******************************************************
35397C
35398      ISTEPN='2'
35399      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRB')
35400     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35401C
35402      IHLEFT=IHARG(1)
35403      IHLEF2=IHARG2(1)
35404C
35405      DO2000I=1,NUMNAM
35406        I2=I
35407        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
35408          IF(IUSE(I2).EQ.'F')THEN
35409            ICASEL='STRI'
35410            ILISTL=I2
35411            GOTO2299
35412          ELSE
35413            WRITE(ICOUT,999)
35414  999       FORMAT(1X)
35415            CALL DPWRST('XXX','BUG ')
35416            WRITE(ICOUT,2001)
35417 2001       FORMAT('***** ERROR IN BLANK STRING--')
35418            CALL DPWRST('XXX','BUG ')
35419            WRITE(ICOUT,2003)IHLEFT,IHLEF2
35420 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
35421     1             A4,A4,')')
35422            CALL DPWRST('XXX','BUG ')
35423            WRITE(ICOUT,2005)
35424 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
35425            CALL DPWRST('XXX','BUG ')
35426            IERROR='YES'
35427            GOTO9000
35428          ENDIF
35429        ENDIF
35430 2000 CONTINUE
35431C
35432      NEWNAM='YES'
35433      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
35434C
35435      ILISTL=NUMNAM+1
35436      IF(ILISTL.GT.MAXNAM)THEN
35437        WRITE(ICOUT,999)
35438        CALL DPWRST('XXX','BUG ')
35439        WRITE(ICOUT,2001)
35440        CALL DPWRST('XXX','BUG ')
35441        WRITE(ICOUT,2202)
35442 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
35443     1         'FUNCTION')
35444        CALL DPWRST('XXX','BUG ')
35445        WRITE(ICOUT,2203)MAXNAM
35446 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
35447        CALL DPWRST('XXX','BUG ')
35448        WRITE(ICOUT,2204)
35449 2204   FORMAT('      ENTER      STATUS')
35450        CALL DPWRST('XXX','BUG ')
35451        WRITE(ICOUT,2205)
35452 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
35453        CALL DPWRST('XXX','BUG ')
35454        WRITE(ICOUT,2206)
35455 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
35456     1         'USED NAMES.')
35457        CALL DPWRST('XXX','BUG ')
35458        IERROR='YES'
35459        GOTO9000
35460      ENDIF
35461C
35462 2299 CONTINUE
35463C
35464C               *****************************************************
35465C               **  STEP 3--                                       **
35466C               **  EXTRACT THE FIRST  NAME ON THE RIGHT HAND SIDE **
35467C               *****************************************************
35468C
35469      ISTEPN='3'
35470      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRB')
35471     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35472C
35473      IHRIGH=IHARG(5)
35474      IHRIG2=IHARG2(5)
35475      DO3200I=1,NUMNAM
35476        I4=I
35477        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
35478          IF(IUSE(I4).NE.'P')THEN
35479            WRITE(ICOUT,999)
35480            CALL DPWRST('XXX','BUG ')
35481            WRITE(ICOUT,2001)
35482            CALL DPWRST('XXX','BUG ')
35483            WRITE(ICOUT,3203)IHRIGH,IHRIG2
35484 3203       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
35485     1             A4,A4,')')
35486            CALL DPWRST('XXX','BUG ')
35487            WRITE(ICOUT,3205)
35488 3205       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
35489            CALL DPWRST('XXX','BUG ')
35490            IERROR='YES'
35491            GOTO9000
35492          ELSE
35493            ILISR1=I4
35494            NLEN=IVALUE(ILISR1)
35495            GOTO3299
35496          ENDIF
35497        ENDIF
35498 3200 CONTINUE
35499C
35500      IF(NUMARG.GE.5)THEN
35501        IF(IARGT(5).EQ.'NUMB')THEN
35502          NLEN=IARG(5)
35503          GOTO3299
35504        ENDIF
35505      ENDIF
35506C
35507      WRITE(ICOUT,999)
35508      CALL DPWRST('XXX','BUG ')
35509      WRITE(ICOUT,2001)
35510      CALL DPWRST('XXX','BUG ')
35511      WRITE(ICOUT,3203)IHRIGH,IHRIG2
35512      CALL DPWRST('XXX','BUG ')
35513      WRITE(ICOUT,3215)
35514 3215 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
35515      CALL DPWRST('XXX','BUG ')
35516      IERROR='YES'
35517      GOTO9000
35518C
35519 3299 CONTINUE
35520C
35521C               *****************************************************
35522C               **  STEP 4--                                       **
35523C               **  CREATE THE STRING                              **
35524C               *****************************************************
35525C
35526      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRB')THEN
35527        ISTEPN='4'
35528        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35529        WRITE(ICOUT,4011)iCASEL,NLEN
35530 4011   FORMAT('ICASEL,NLEN = ',A4,2X,I8)
35531        CALL DPWRST('XXX','BUG ')
35532      ENDIF
35533C
35534      IF(NLEN.LT.1 .OR. NLEN.GT.MAXCHF)THEN
35535        WRITE(ICOUT,999)
35536        CALL DPWRST('XXX','BUG ')
35537        WRITE(ICOUT,2001)
35538        CALL DPWRST('XXX','BUG ')
35539        WRITE(ICOUT,4021)MAXCHF
35540 4021   FORMAT('      THE LENGHT VALUE IS LESS THAN 1 OR GREATER ',
35541     1         'THAN ',I8)
35542        CALL DPWRST('XXX','BUG ')
35543        WRITE(ICOUT,4023)NLEN
35544 4023   FORMAT('      THE LENGTH VALUE IS ',I8)
35545        CALL DPWRST('XXX','BUG ')
35546        IERROR='YES'
35547        GOTO9000
35548      ENDIF
35549C
35550      ICNT=0
35551      DO4100I=1,NLEN
35552        IFUNC2(I)=' '
35553 4100 CONTINUE
35554C
35555C               *****************************************************
35556C               **  STEP 5--                                       **
35557C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
35558C               *****************************************************
35559C
35560C
35561      ISTEPN='5'
35562      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRB')
35563     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35564C
35565      CALL DPINFU(IFUNC2,NLEN,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
35566     1            NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
35567     1            NEWNAM,MAXNAM,
35568     1            IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
35569      IF(IERROR.EQ.'YES')GOTO9000
35570C
35571      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
35572        WRITE(ICOUT,999)
35573        CALL DPWRST('XXX','BUG ')
35574        WRITE(ICOUT,6606)IHLEFT,IHLEF2,NLEN
35575 6606   FORMAT('THE NAME ',A4,A4,' HAS BEEN CREATED AS A BLANK STRING ',
35576     1         'OF LENGTH ',I8)
35577        CALL DPWRST('XXX','BUG ')
35578        WRITE(ICOUT,999)
35579        CALL DPWRST('XXX','BUG ')
35580      ENDIF
35581C
35582C
35583C               ****************
35584C               **  STEP 90-- **
35585C               **  EXIT.     **
35586C               ****************
35587C
35588 9000 CONTINUE
35589      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STRB')THEN
35590        WRITE(ICOUT,999)
35591        CALL DPWRST('XXX','BUG ')
35592        WRITE(ICOUT,9011)
35593 9011   FORMAT('***** AT THE END       OF DPSTRB--')
35594        CALL DPWRST('XXX','BUG ')
35595        WRITE(ICOUT,9013)NUMNAM
35596 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
35597        CALL DPWRST('XXX','BUG ')
35598        DO9015I=1,NUMNAM
35599          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
35600     1                     IVSTAR(I),IVSTOP(I)
35601 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
35602     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
35603          CALL DPWRST('XXX','BUG ')
35604 9015   CONTINUE
35605      ENDIF
35606C
35607      RETURN
35608      END
35609      SUBROUTINE DPSTRP(ISUBRO,IBUGA3,IERROR)
35610C
35611C     PURPOSE--INSERT A STRING INTO A PREVIOUSLY DEFINED STRING
35612C     EXAMPLE--LET SOUT = STRING REPLACE SOLD SNEW START
35613C     WRITTEN BY--ALAN HECKERT
35614C                 STATISTICAL ENGINEERING DIVISION
35615C                 INFORMATION TECHNOLOGY LABORATORY
35616C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
35617C                 GAITHERSBURG, MD 20899-8980
35618C                 PHONE--301-975-2899
35619C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
35620C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
35621C     LANGUAGE--ANSI FORTRAN (1977)
35622C     VERSION NUMBER--2008/11
35623C     ORIGINAL VERSION--NOVEMBER  2008.
35624C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
35625C
35626C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
35627C
35628      CHARACTER*4 ISUBRO
35629      CHARACTER*4 IBUGA3
35630      CHARACTER*4 IERROR
35631C
35632      CHARACTER*4 NEWNAM
35633      CHARACTER*4 NEWNA2
35634      CHARACTER*4 NEWCOL
35635      CHARACTER*4 NEWCO2
35636      CHARACTER*4 ICASEL
35637      CHARACTER*4 ICASE2
35638      CHARACTER*4 IHLEFT
35639      CHARACTER*4 IHLEF2
35640      CHARACTER*4 IHRIGH
35641      CHARACTER*4 IHRIG2
35642      CHARACTER*4 IHRI21
35643      CHARACTER*4 IHRI22
35644      CHARACTER*4 IHRI31
35645      CHARACTER*4 IHRI32
35646C
35647      CHARACTER*4 ISUBN1
35648      CHARACTER*4 ISUBN2
35649      CHARACTER*4 ISTEPN
35650C
35651      CHARACTER*4 ILAB(10)
35652C
35653C---------------------------------------------------------------------
35654C
35655C-----COMMON----------------------------------------------------------
35656C
35657      INCLUDE 'DPCOPA.INC'
35658      INCLUDE 'DPCOHK.INC'
35659      INCLUDE 'DPCODA.INC'
35660      INCLUDE 'DPCOP2.INC'
35661C
35662C-----START POINT-----------------------------------------------------
35663C
35664      ISUBN1='DPST'
35665      ISUBN2='MR  '
35666      IERROR='NO'
35667C
35668      ILOC3=0
35669C
35670      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STRP')THEN
35671        WRITE(ICOUT,999)
35672        CALL DPWRST('XXX','BUG ')
35673        WRITE(ICOUT,51)
35674   51   FORMAT('***** AT THE BEGINNING OF DPSTRP--')
35675        CALL DPWRST('XXX','BUG ')
35676        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
35677   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
35678        CALL DPWRST('XXX','BUG ')
35679        DO55I=1,NUMNAM
35680          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
35681     1                   IVSTOP(I)
35682   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
35683     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
35684          CALL DPWRST('XXX','BUG ')
35685   55   CONTINUE
35686        WRITE(ICOUT,57)NUMCHF,MAXCHF
35687   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
35688        CALL DPWRST('XXX','BUG ')
35689        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
35690   60   FORMAT('IFUNC(.)  = ',120A1)
35691        CALL DPWRST('XXX','BUG ')
35692      ENDIF
35693C
35694C               **********************************
35695C               **  STEP 1--                    **
35696C               **  INITIALIZE SOME VARIABLES.  **
35697C               **********************************
35698C
35699      ISTEPN='1'
35700      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRP')
35701     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35702C
35703      NEWNAM='NO'
35704      NEWNA2='NO'
35705      NEWCOL='NO'
35706      NEWCO2='NO'
35707      ICASEL='UNKN'
35708      ICASE2='UNKN'
35709      NIOLD1=0
35710      NIOLD2=0
35711      ICOLL=0
35712      ICOL2=0
35713C
35714C               ******************************************************
35715C               **  STEP 2--                                         *
35716C               **  EXAMINE THE ARGUMENT ON THE                      *
35717C               **  LEFT-HAND SIDE--                                 *
35718C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
35719C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
35720C               ******************************************************
35721C
35722      ISTEPN='2'
35723      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRP')
35724     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35725C
35726      IHLEFT=IHARG(1)
35727      IHLEF2=IHARG2(1)
35728C
35729      DO2000I=1,NUMNAM
35730        I2=I
35731        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
35732          IF(IUSE(I2).EQ.'F')THEN
35733            ICASEL='STRI'
35734            ILISTL=I2
35735            GOTO2299
35736          ELSE
35737            WRITE(ICOUT,999)
35738  999       FORMAT(1X)
35739            CALL DPWRST('XXX','BUG ')
35740            WRITE(ICOUT,2001)
35741 2001       FORMAT('***** ERROR IN STRING REPLACE--')
35742            CALL DPWRST('XXX','BUG ')
35743            WRITE(ICOUT,2003)IHLEFT,IHLEF2
35744 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
35745     1             A4,A4,')')
35746            CALL DPWRST('XXX','BUG ')
35747            WRITE(ICOUT,2005)
35748 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
35749            CALL DPWRST('XXX','BUG ')
35750            IERROR='YES'
35751            GOTO9000
35752          ENDIF
35753        ENDIF
35754 2000 CONTINUE
35755C
35756      NEWNAM='YES'
35757      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
35758C
35759      ILISTL=NUMNAM+1
35760      IF(ILISTL.GT.MAXNAM)THEN
35761        WRITE(ICOUT,999)
35762        CALL DPWRST('XXX','BUG ')
35763        WRITE(ICOUT,2001)
35764        CALL DPWRST('XXX','BUG ')
35765        WRITE(ICOUT,2202)
35766 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
35767     1         'FUNCTION')
35768        CALL DPWRST('XXX','BUG ')
35769        WRITE(ICOUT,2203)MAXNAM
35770 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
35771        CALL DPWRST('XXX','BUG ')
35772        WRITE(ICOUT,2204)
35773 2204   FORMAT('      ENTER      STATUS')
35774        CALL DPWRST('XXX','BUG ')
35775        WRITE(ICOUT,2205)
35776 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
35777        CALL DPWRST('XXX','BUG ')
35778        WRITE(ICOUT,2206)
35779 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
35780     1         'USED NAMES.')
35781        CALL DPWRST('XXX','BUG ')
35782        IERROR='YES'
35783        GOTO9000
35784      ENDIF
35785C
35786 2299 CONTINUE
35787C
35788C               *****************************************************
35789C               **  STEP 3--                                       **
35790C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
35791C               *****************************************************
35792C
35793      ISTEPN='3A'
35794      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRP')
35795     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35796C
35797      IHRIGH=IHARG(5)
35798      IHRIG2=IHARG2(5)
35799      DO3000I=1,NUMNAM
35800        I4=I
35801        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
35802          IF(IUSE(I4).NE.'F')THEN
35803            WRITE(ICOUT,999)
35804            CALL DPWRST('XXX','BUG ')
35805            WRITE(ICOUT,2001)
35806            CALL DPWRST('XXX','BUG ')
35807            WRITE(ICOUT,3003)IHRIGH,IHRIG2
35808 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
35809     1             A4,A4,')')
35810            CALL DPWRST('XXX','BUG ')
35811            WRITE(ICOUT,3005)
35812 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
35813            CALL DPWRST('XXX','BUG ')
35814            IERROR='YES'
35815            GOTO9000
35816          ELSE
35817            ISTRT1=IVSTAR(I4)
35818            ISTOP1=IVSTOP(I4)
35819            NLEN1=ISTOP1-ISTRT1+1
35820            GOTO3099
35821          ENDIF
35822        ENDIF
35823 3000 CONTINUE
35824C
35825      WRITE(ICOUT,999)
35826      CALL DPWRST('XXX','BUG ')
35827      WRITE(ICOUT,2001)
35828      CALL DPWRST('XXX','BUG ')
35829      WRITE(ICOUT,3003)IHRIGH,IHRIG2
35830      CALL DPWRST('XXX','BUG ')
35831      WRITE(ICOUT,3015)
35832 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
35833      CALL DPWRST('XXX','BUG ')
35834      IERROR='YES'
35835      GOTO9000
35836C
35837 3099 CONTINUE
35838C
35839C               *****************************************************
35840C               **  STEP 3B-                                       **
35841C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
35842C               *****************************************************
35843C
35844      ISTEPN='3B'
35845      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRP')
35846     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35847C
35848      IHRI21=IHARG(6)
35849      IHRI22=IHARG2(6)
35850      DO3100I=1,NUMNAM
35851        I4=I
35852        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
35853          IF(IUSE(I4).NE.'F')THEN
35854            WRITE(ICOUT,999)
35855            CALL DPWRST('XXX','BUG ')
35856            WRITE(ICOUT,2001)
35857            CALL DPWRST('XXX','BUG ')
35858            WRITE(ICOUT,3003)IHRI21,IHRI22
35859            CALL DPWRST('XXX','BUG ')
35860            WRITE(ICOUT,3005)
35861            CALL DPWRST('XXX','BUG ')
35862            IERROR='YES'
35863            GOTO9000
35864          ELSE
35865            ISTRT2=IVSTAR(I4)
35866            ISTOP2=IVSTOP(I4)
35867            NLEN2=ISTOP2-ISTRT2+1
35868            GOTO3199
35869          ENDIF
35870        ENDIF
35871 3100 CONTINUE
35872C
35873      WRITE(ICOUT,999)
35874      CALL DPWRST('XXX','BUG ')
35875      WRITE(ICOUT,2001)
35876      CALL DPWRST('XXX','BUG ')
35877      WRITE(ICOUT,3003)IHRI21,IHRI22
35878      CALL DPWRST('XXX','BUG ')
35879      WRITE(ICOUT,3015)
35880      CALL DPWRST('XXX','BUG ')
35881      IERROR='YES'
35882      GOTO9000
35883C
35884 3199 CONTINUE
35885C
35886C               *****************************************************
35887C               **  STEP 3C-                                       **
35888C               **  EXTRACT THE THIRD  NAME ON THE RIGHT HAND SIDE **
35889C               *****************************************************
35890C
35891      ISTEPN='3C'
35892      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRP')
35893     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35894C
35895      IHRI31=IHARG(7)
35896      IHRI32=IHARG2(7)
35897      DO3200I=1,NUMNAM
35898        I4=I
35899        IF(IHRI31.EQ.IHNAME(I).AND.IHRI32.EQ.IHNAM2(I))THEN
35900          IF(IUSE(I4).NE.'P')THEN
35901            WRITE(ICOUT,999)
35902            CALL DPWRST('XXX','BUG ')
35903            WRITE(ICOUT,2001)
35904            CALL DPWRST('XXX','BUG ')
35905            WRITE(ICOUT,3003)IHRI31,IHRI32
35906            CALL DPWRST('XXX','BUG ')
35907            WRITE(ICOUT,3215)
35908 3215       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
35909            CALL DPWRST('XXX','BUG ')
35910            IERROR='YES'
35911            GOTO9000
35912          ELSE
35913            ILISR1=I4
35914            NSTART=IVALUE(ILISR1)
35915            GOTO3299
35916          ENDIF
35917        ENDIF
35918 3200 CONTINUE
35919C
35920      IF(NUMARG.GE.7)THEN
35921        IF(IARGT(7).EQ.'NUMB')THEN
35922          NSTART=IARG(7)
35923          GOTO3299
35924        ENDIF
35925      ENDIF
35926C
35927      WRITE(ICOUT,999)
35928      CALL DPWRST('XXX','BUG ')
35929      WRITE(ICOUT,2001)
35930      CALL DPWRST('XXX','BUG ')
35931      WRITE(ICOUT,3003)IHRI31,IHRI32
35932      CALL DPWRST('XXX','BUG ')
35933      WRITE(ICOUT,3015)
35934      CALL DPWRST('XXX','BUG ')
35935      IERROR='YES'
35936      GOTO9000
35937C
35938 3299 CONTINUE
35939C
35940C               *****************************************************
35941C               **  STEP 4--                                       **
35942C               **  CREATE THE SUBSTRING                           **
35943C               *****************************************************
35944C
35945      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRP')THEN
35946        ISTEPN='4'
35947        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
35948        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1
35949 4011   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
35950        CALL DPWRST('XXX','BUG ')
35951        WRITE(ICOUT,4012)ISTRT2,ISTOP2,NLEN2
35952 4012   FORMAT('ISTRT2,ISTOP2,NLEN2 = ',3I8)
35953        CALL DPWRST('XXX','BUG ')
35954        WRITE(ICOUT,4013)ICASEL
35955 4013   FORMAT('ICASEL = ',A4)
35956        CALL DPWRST('XXX','BUG ')
35957      ENDIF
35958C
35959      IF(NSTART.LT.1 .OR. NSTART.GT.MAXCHF)THEN
35960        WRITE(ICOUT,999)
35961        CALL DPWRST('XXX','BUG ')
35962        WRITE(ICOUT,2001)
35963        CALL DPWRST('XXX','BUG ')
35964        WRITE(ICOUT,4021)MAXCHF
35965 4021   FORMAT('      THE START INDEX IS LESS THAN 1 OR GREATER ',
35966     1         'THAN ',I8)
35967        CALL DPWRST('XXX','BUG ')
35968        WRITE(ICOUT,4023)NSTART
35969 4023   FORMAT('      THE VALUE OF THE START INDEX IS ',I8)
35970        CALL DPWRST('XXX','BUG ')
35971        IERROR='YES'
35972        GOTO9000
35973      ENDIF
35974C
35975      ICNT=0
35976      IF(NSTART.GT.1)THEN
35977        DO4100I=1,NLEN1-1
35978          ICNT=ICNT+1
35979          IINDX=I+ISTRT1-1
35980          IFUNC2(ICNT)=IFUNC(IINDX)
35981 4100   CONTINUE
35982        ICNT=NSTART-1
35983      ENDIF
35984      IF(NLEN2.GE.1)THEN
35985        DO4110I=1,NLEN2
35986          ICNT=ICNT+1
35987          IINDX=I+ISTRT2-1
35988          IFUNC2(ICNT)=IFUNC(IINDX)
35989 4110   CONTINUE
35990      ENDIF
35991      ICNT=MAX(ICNT,NLEN1)
35992C
35993C               *****************************************************
35994C               **  STEP 5--                                       **
35995C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
35996C               *****************************************************
35997C
35998C
35999      IF(ICASEL.EQ.'STRI')THEN
36000C
36001        ISTEPN='5'
36002        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STRP')
36003     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36004C
36005        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
36006     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
36007CCCCC1              NEWNAM,MAXN3,
36008     1              NEWNAM,MAXNAM,
36009     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
36010        IF(IERROR.EQ.'YES')GOTO9000
36011C
36012        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
36013          WRITE(ICOUT,999)
36014          CALL DPWRST('XXX','BUG ')
36015          WRITE(ICOUT,6606)IHLEFT,IHLEF2
36016 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
36017          CALL DPWRST('XXX','BUG ')
36018          ILAB(1)='TO T'
36019          ILAB(2)='HE F'
36020          ILAB(3)='UNCT'
36021          ILAB(4)='ION '
36022          ILAB(5)='    '
36023          ILAB(6)=' -- '
36024          NUMWDL=6
36025          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
36026C
36027          WRITE(ICOUT,999)
36028          CALL DPWRST('XXX','BUG ')
36029C
36030        ENDIF
36031C
36032      ENDIF
36033C
36034C
36035C               ****************
36036C               **  STEP 90-- **
36037C               **  EXIT.     **
36038C               ****************
36039C
36040 9000 CONTINUE
36041      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STRP')THEN
36042        WRITE(ICOUT,999)
36043        CALL DPWRST('XXX','BUG ')
36044        WRITE(ICOUT,9011)
36045 9011   FORMAT('***** AT THE END       OF DPSTRP--')
36046        CALL DPWRST('XXX','BUG ')
36047        WRITE(ICOUT,9013)NUMNAM
36048 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
36049        CALL DPWRST('XXX','BUG ')
36050        DO9015I=1,NUMNAM
36051          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
36052     1                     IVSTAR(I),IVSTOP(I)
36053 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
36054     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
36055          CALL DPWRST('XXX','BUG ')
36056 9015   CONTINUE
36057      ENDIF
36058C
36059      RETURN
36060      END
36061      SUBROUTINE DPSTSB(ISUBRO,IBUGA3,IERROR)
36062C
36063C     PURPOSE--EXTRACT A SUBSET OF A STRING.
36064C     EXAMPLE--LET SOUT = STRING SUBSET SIN START STOP
36065C     WRITTEN BY--ALAN HECKERT
36066C                 STATISTICAL ENGINEERING DIVISION
36067C                 INFORMATION TECHNOLOGY LABORATORY
36068C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
36069C                 GAITHERSBURG, MD 20899-8980
36070C                 PHONE--301-975-2899
36071C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
36072C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
36073C     LANGUAGE--ANSI FORTRAN (1977)
36074C     VERSION NUMBER--2008/11
36075C     ORIGINAL VERSION--NOVEMBER  2008.
36076C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
36077C
36078C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36079C
36080      CHARACTER*4 ISUBRO
36081      CHARACTER*4 IBUGA3
36082      CHARACTER*4 IERROR
36083C
36084      CHARACTER*4 NEWNAM
36085      CHARACTER*4 NEWNA2
36086      CHARACTER*4 NEWCOL
36087      CHARACTER*4 NEWCO2
36088      CHARACTER*4 ICASEL
36089      CHARACTER*4 ICASE2
36090      CHARACTER*4 IHLEFT
36091      CHARACTER*4 IHLEF2
36092      CHARACTER*4 IHRIGH
36093      CHARACTER*4 IHRIG2
36094      CHARACTER*4 IHRI21
36095      CHARACTER*4 IHRI22
36096      CHARACTER*4 IHRI31
36097      CHARACTER*4 IHRI32
36098C
36099      CHARACTER*4 ISUBN1
36100      CHARACTER*4 ISUBN2
36101      CHARACTER*4 ISTEPN
36102C
36103      CHARACTER*4 ILAB(10)
36104C
36105C---------------------------------------------------------------------
36106C
36107C-----COMMON----------------------------------------------------------
36108C
36109      INCLUDE 'DPCOPA.INC'
36110      INCLUDE 'DPCOHK.INC'
36111      INCLUDE 'DPCODA.INC'
36112      INCLUDE 'DPCOP2.INC'
36113C
36114C-----START POINT-----------------------------------------------------
36115C
36116      ISUBN1='DPST'
36117      ISUBN2='SB  '
36118      IERROR='NO'
36119C
36120      ILOC3=0
36121C
36122      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STSB')THEN
36123        WRITE(ICOUT,999)
36124        CALL DPWRST('XXX','BUG ')
36125        WRITE(ICOUT,51)
36126   51   FORMAT('***** AT THE BEGINNING OF DPSTSB--')
36127        CALL DPWRST('XXX','BUG ')
36128        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
36129   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
36130        CALL DPWRST('XXX','BUG ')
36131        DO55I=1,NUMNAM
36132          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
36133     1                   IVSTOP(I)
36134   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
36135     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
36136          CALL DPWRST('XXX','BUG ')
36137   55   CONTINUE
36138        WRITE(ICOUT,57)NUMCHF,MAXCHF,NUMARG
36139   57   FORMAT('NUMCHF,MAXCHF,NUMARG = ',3I8)
36140        CALL DPWRST('XXX','BUG ')
36141        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
36142   60   FORMAT('IFUNC(.)  = ',120A1)
36143        CALL DPWRST('XXX','BUG ')
36144        IF(NUMARG.GE.1)THEN
36145          DO70I=1,NUMARG
36146            WRITE(ICOUT,76)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
36147   76       FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
36148     1             I8,2X,A4,A4,2X,A4,2X,I8)
36149            CALL DPWRST('XXX','BUG ')
36150   70     CONTINUE
36151        ENDIF
36152      ENDIF
36153C
36154C               **********************************
36155C               **  STEP 1--                    **
36156C               **  INITIALIZE SOME VARIABLES.  **
36157C               **********************************
36158C
36159      ISTEPN='1'
36160      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSB')
36161     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36162C
36163      NEWNAM='NO'
36164      NEWNA2='NO'
36165      NEWCOL='NO'
36166      NEWCO2='NO'
36167      ICASEL='UNKN'
36168      ICASE2='UNKN'
36169      NIOLD1=0
36170      NIOLD2=0
36171      ICOLL=0
36172      ICOL2=0
36173C
36174C               ******************************************************
36175C               **  STEP 2--                                         *
36176C               **  EXAMINE THE ARGUMENT ON THE                      *
36177C               **  LEFT-HAND SIDE--                                 *
36178C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
36179C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
36180C               ******************************************************
36181C
36182      ISTEPN='2'
36183      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSB')
36184     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36185C
36186      IHLEFT=IHARG(1)
36187      IHLEF2=IHARG2(1)
36188C
36189      DO2000I=1,NUMNAM
36190        I2=I
36191        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
36192          IF(IUSE(I2).EQ.'F')THEN
36193            ICASEL='STRI'
36194            ILISTL=I2
36195            GOTO2299
36196          ELSE
36197            WRITE(ICOUT,999)
36198  999       FORMAT(1X)
36199            CALL DPWRST('XXX','BUG ')
36200            WRITE(ICOUT,2001)
36201 2001       FORMAT('***** ERROR IN STRING SUBSET--')
36202            CALL DPWRST('XXX','BUG ')
36203            WRITE(ICOUT,2003)IHLEFT,IHLEF2
36204 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
36205     1             A4,A4,')')
36206            CALL DPWRST('XXX','BUG ')
36207            WRITE(ICOUT,2005)
36208 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
36209            CALL DPWRST('XXX','BUG ')
36210            IERROR='YES'
36211            GOTO9000
36212          ENDIF
36213        ENDIF
36214 2000 CONTINUE
36215C
36216      NEWNAM='YES'
36217      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
36218C
36219      ILISTL=NUMNAM+1
36220      IF(ILISTL.GT.MAXNAM)THEN
36221        WRITE(ICOUT,999)
36222        CALL DPWRST('XXX','BUG ')
36223        WRITE(ICOUT,2001)
36224        CALL DPWRST('XXX','BUG ')
36225        WRITE(ICOUT,2202)
36226 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
36227     1         'FUNCTION')
36228        CALL DPWRST('XXX','BUG ')
36229        WRITE(ICOUT,2203)MAXNAM
36230 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
36231        CALL DPWRST('XXX','BUG ')
36232        WRITE(ICOUT,2204)
36233 2204   FORMAT('      ENTER      STATUS')
36234        CALL DPWRST('XXX','BUG ')
36235        WRITE(ICOUT,2205)
36236 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
36237        CALL DPWRST('XXX','BUG ')
36238        WRITE(ICOUT,2206)
36239 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
36240     1         'USED NAMES.')
36241        CALL DPWRST('XXX','BUG ')
36242        IERROR='YES'
36243        GOTO9000
36244      ENDIF
36245C
36246 2299 CONTINUE
36247C
36248C               *****************************************************
36249C               **  STEP 3--                                       **
36250C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
36251C               *****************************************************
36252C
36253      ISTEPN='3A'
36254      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSB')
36255     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36256C
36257      IHRIGH=IHARG(4)
36258      IHRIG2=IHARG2(4)
36259      DO3000I=1,NUMNAM
36260        I4=I
36261        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
36262          IF(IUSE(I4).NE.'F')THEN
36263            WRITE(ICOUT,999)
36264            CALL DPWRST('XXX','BUG ')
36265            WRITE(ICOUT,2001)
36266            CALL DPWRST('XXX','BUG ')
36267            WRITE(ICOUT,3003)IHRIGH,IHRIG2
36268 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
36269     1             A4,A4,')')
36270            CALL DPWRST('XXX','BUG ')
36271            WRITE(ICOUT,3005)
36272 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
36273            CALL DPWRST('XXX','BUG ')
36274            IERROR='YES'
36275            GOTO9000
36276          ELSE
36277            ISTRT1=IVSTAR(I4)
36278            ISTOP1=IVSTOP(I4)
36279            NLEN1=ISTOP1-ISTRT1+1
36280            GOTO3099
36281          ENDIF
36282        ENDIF
36283 3000 CONTINUE
36284C
36285      WRITE(ICOUT,999)
36286      CALL DPWRST('XXX','BUG ')
36287      WRITE(ICOUT,2001)
36288      CALL DPWRST('XXX','BUG ')
36289      WRITE(ICOUT,3003)IHRIGH,IHRIG2
36290      CALL DPWRST('XXX','BUG ')
36291      WRITE(ICOUT,3015)
36292 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
36293      CALL DPWRST('XXX','BUG ')
36294      IERROR='YES'
36295      GOTO9000
36296C
36297 3099 CONTINUE
36298C
36299C               *****************************************************
36300C               **  STEP 3B-                                       **
36301C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
36302C               *****************************************************
36303C
36304      ISTEPN='3B'
36305      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSB')
36306     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36307C
36308      IHRI21=IHARG(5)
36309      IHRI22=IHARG2(5)
36310      DO3100I=1,NUMNAM
36311        I4=I
36312        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
36313          IF(IUSE(I4).NE.'P')THEN
36314            WRITE(ICOUT,999)
36315            CALL DPWRST('XXX','BUG ')
36316            WRITE(ICOUT,2001)
36317            CALL DPWRST('XXX','BUG ')
36318            WRITE(ICOUT,3003)IHRI21,IHRI22
36319            CALL DPWRST('XXX','BUG ')
36320            WRITE(ICOUT,3115)
36321 3115       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
36322            CALL DPWRST('XXX','BUG ')
36323            IERROR='YES'
36324            GOTO9000
36325          ELSE
36326            ILISR1=I4
36327            NSTART=IVALUE(ILISR1)
36328            GOTO3199
36329          ENDIF
36330        ENDIF
36331 3100 CONTINUE
36332C
36333      IF(NUMARG.GE.5)THEN
36334        IF(IARGT(5).EQ.'NUMB')THEN
36335          NSTART=IARG(5)
36336          GOTO3199
36337        ENDIF
36338      ENDIF
36339C
36340      WRITE(ICOUT,999)
36341      CALL DPWRST('XXX','BUG ')
36342      WRITE(ICOUT,2001)
36343      CALL DPWRST('XXX','BUG ')
36344      WRITE(ICOUT,3003)IHRI21,IHRI22
36345      CALL DPWRST('XXX','BUG ')
36346      WRITE(ICOUT,3015)
36347      CALL DPWRST('XXX','BUG ')
36348      IERROR='YES'
36349      GOTO9000
36350C
36351 3199 CONTINUE
36352C
36353C               *****************************************************
36354C               **  STEP 3C-                                       **
36355C               **  EXTRACT THE THIRD  NAME ON THE RIGHT HAND SIDE **
36356C               *****************************************************
36357C
36358      ISTEPN='3C'
36359      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSB')
36360     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36361C
36362      IHRI31=IHARG(6)
36363      IHRI32=IHARG2(6)
36364      DO3200I=1,NUMNAM
36365        I4=I
36366        IF(IHRI31.EQ.IHNAME(I).AND.IHRI32.EQ.IHNAM2(I))THEN
36367          IF(IUSE(I4).NE.'P')THEN
36368            WRITE(ICOUT,999)
36369            CALL DPWRST('XXX','BUG ')
36370            WRITE(ICOUT,2001)
36371            CALL DPWRST('XXX','BUG ')
36372            WRITE(ICOUT,3003)IHRI31,IHRI32
36373            CALL DPWRST('XXX','BUG ')
36374            WRITE(ICOUT,3115)
36375            CALL DPWRST('XXX','BUG ')
36376            IERROR='YES'
36377            GOTO9000
36378          ELSE
36379            ILISR2=I4
36380            NSTOP=IVALUE(ILISR2)
36381            GOTO3299
36382          ENDIF
36383        ENDIF
36384 3200 CONTINUE
36385C
36386      IF(NUMARG.GE.6)THEN
36387        IF(IARGT(6).EQ.'NUMB')THEN
36388          NSTOP=IARG(6)
36389          GOTO3299
36390        ENDIF
36391      ENDIF
36392C
36393      WRITE(ICOUT,999)
36394      CALL DPWRST('XXX','BUG ')
36395      WRITE(ICOUT,2001)
36396      CALL DPWRST('XXX','BUG ')
36397      WRITE(ICOUT,3003)IHRI31,IHRI32
36398      CALL DPWRST('XXX','BUG ')
36399      WRITE(ICOUT,3015)
36400      CALL DPWRST('XXX','BUG ')
36401      IERROR='YES'
36402      GOTO9000
36403C
36404 3299 CONTINUE
36405C
36406C               *****************************************************
36407C               **  STEP 4--                                       **
36408C               **  CREATE THE SUBSTRING                           **
36409C               *****************************************************
36410C
36411      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSB')THEN
36412        ISTEPN='4'
36413        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36414        WRITE(ICOUT,4011)ILISR1,ILISR2,NSTART,NSTOP
36415 4011   FORMAT('ILISR1,ILISR2,NSTART,NSTOP = ',4I8)
36416        CALL DPWRST('XXX','BUG ')
36417        WRITE(ICOUT,4012)ISTRT1,ISTOP1,NLEN1
36418 4012   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
36419        CALL DPWRST('XXX','BUG ')
36420        WRITE(ICOUT,4013)ICASEL
36421 4013   FORMAT('ICASEL = ',A4)
36422        CALL DPWRST('XXX','BUG ')
36423      ENDIF
36424C
36425      IF(NSTART.LT.1 .OR. NSTART.GT.MAXCHF)THEN
36426        WRITE(ICOUT,999)
36427        CALL DPWRST('XXX','BUG ')
36428        WRITE(ICOUT,2001)
36429        CALL DPWRST('XXX','BUG ')
36430        WRITE(ICOUT,4021)MAXCHF
36431 4021   FORMAT('      THE START INDEX IS LESS THAN 1 OR GREATER ',
36432     1         'THAN ',I8)
36433        CALL DPWRST('XXX','BUG ')
36434        WRITE(ICOUT,4023)NSTART
36435 4023   FORMAT('      THE VALUE OF THE START INDEX IS ',I8)
36436        CALL DPWRST('XXX','BUG ')
36437        IERROR='YES'
36438        GOTO9000
36439      ENDIF
36440C
36441      IF(NSTOP.LT.NSTART .OR. NSTOP.GT.MAXCHF)THEN
36442        WRITE(ICOUT,999)
36443        CALL DPWRST('XXX','BUG ')
36444        WRITE(ICOUT,2001)
36445        CALL DPWRST('XXX','BUG ')
36446        WRITE(ICOUT,4031)MAXCHF
36447 4031   FORMAT('      THE STOP INDEX IS LESS THAN THE START INDEX ',
36448     1        'OR GREATER THAN ',I8)
36449        CALL DPWRST('XXX','BUG ')
36450        WRITE(ICOUT,4033)NSTART
36451 4033   FORMAT('      THE VALUE OF THE START INDEX IS ',I8)
36452        CALL DPWRST('XXX','BUG ')
36453        WRITE(ICOUT,4035)NSTOP
36454 4035   FORMAT('      THE VALUE OF THE STOP INDEX IS ',I8)
36455        CALL DPWRST('XXX','BUG ')
36456        IERROR='YES'
36457        GOTO9000
36458      ENDIF
36459C
36460      ICNT=0
36461      DO4100I=NSTART,NSTOP
36462        ICNT=ICNT+1
36463        IINDX=I+ISTRT1-1
36464        IFUNC2(ICNT)=IFUNC(IINDX)
36465 4100 CONTINUE
36466C
36467C               *****************************************************
36468C               **  STEP 5--                                       **
36469C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
36470C               *****************************************************
36471C
36472C
36473      IF(ICASEL.EQ.'STRI')THEN
36474C
36475        ISTEPN='5'
36476        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSB')
36477     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36478C
36479        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
36480     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
36481CCCCC1              NEWNAM,MAXN3,
36482     1              NEWNAM,MAXNAM,
36483     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
36484        IF(IERROR.EQ.'YES')GOTO9000
36485C
36486        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
36487          WRITE(ICOUT,999)
36488          CALL DPWRST('XXX','BUG ')
36489          WRITE(ICOUT,6606)IHLEFT,IHLEF2
36490 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
36491          CALL DPWRST('XXX','BUG ')
36492          ILAB(1)='TO T'
36493          ILAB(2)='HE F'
36494          ILAB(3)='UNCT'
36495          ILAB(4)='ION '
36496          ILAB(5)='    '
36497          ILAB(6)=' -- '
36498          NUMWDL=6
36499          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
36500C
36501          WRITE(ICOUT,999)
36502          CALL DPWRST('XXX','BUG ')
36503C
36504        ENDIF
36505C
36506      ENDIF
36507C
36508C
36509C               ****************
36510C               **  STEP 90-- **
36511C               **  EXIT.     **
36512C               ****************
36513C
36514 9000 CONTINUE
36515      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STSB')THEN
36516        WRITE(ICOUT,999)
36517        CALL DPWRST('XXX','BUG ')
36518        WRITE(ICOUT,9011)
36519 9011   FORMAT('***** AT THE END       OF DPSTSB--')
36520        CALL DPWRST('XXX','BUG ')
36521        WRITE(ICOUT,9013)NUMNAM
36522 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
36523        CALL DPWRST('XXX','BUG ')
36524        DO9015I=1,NUMNAM
36525          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
36526     1                     IVSTAR(I),IVSTOP(I)
36527 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
36528     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
36529          CALL DPWRST('XXX','BUG ')
36530 9015   CONTINUE
36531      ENDIF
36532C
36533      RETURN
36534      END
36535      SUBROUTINE DPSTSC(ISUBRO,IBUGA3,IERROR)
36536C
36537C     PURPOSE--SWAP THE CASE FOR THE CHARACTERS IN A STRING.
36538C     EXAMPLE--LET SOUT = SWAP CASE SOLD
36539C     WRITTEN BY--ALAN HECKERT
36540C                 STATISTICAL ENGINEERING DIVISION
36541C                 INFORMATION TECHNOLOGY LABORATORY
36542C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
36543C                 GAITHERSBURG, MD 20899-8980
36544C                 PHONE--301-975-2899
36545C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
36546C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
36547C     LANGUAGE--ANSI FORTRAN (1977)
36548C     VERSION NUMBER--2019/02
36549C     ORIGINAL VERSION--FEBRUARY  2019.
36550C
36551C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36552C
36553      CHARACTER*4 ISUBRO
36554      CHARACTER*4 IBUGA3
36555      CHARACTER*4 IERROR
36556C
36557      CHARACTER*4 NEWNAM
36558      CHARACTER*4 NEWCOL
36559      CHARACTER*4 ICASEL
36560      CHARACTER*4 IHLEFT
36561      CHARACTER*4 IHLEF2
36562      CHARACTER*4 IHRIGH
36563      CHARACTER*4 IHRIG2
36564C
36565      CHARACTER*1 IC
36566C
36567      CHARACTER*4 ISUBN1
36568      CHARACTER*4 ISUBN2
36569      CHARACTER*4 ISTEPN
36570C
36571      CHARACTER*4 ILAB(10)
36572C
36573C---------------------------------------------------------------------
36574C
36575C-----COMMON----------------------------------------------------------
36576C
36577      INCLUDE 'DPCOPA.INC'
36578      INCLUDE 'DPCOHK.INC'
36579      INCLUDE 'DPCODA.INC'
36580      INCLUDE 'DPCOP2.INC'
36581C
36582C-----START POINT-----------------------------------------------------
36583C
36584      ISUBN1='DPST'
36585      ISUBN2='SC  '
36586      IERROR='NO'
36587C
36588      ILOC3=0
36589C
36590      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STSC')THEN
36591        WRITE(ICOUT,999)
36592        CALL DPWRST('XXX','BUG ')
36593        WRITE(ICOUT,51)
36594   51   FORMAT('***** AT THE BEGINNING OF DPSTSC--')
36595        CALL DPWRST('XXX','BUG ')
36596        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
36597   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
36598        CALL DPWRST('XXX','BUG ')
36599        DO55I=1,NUMNAM
36600          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
36601     1                   IVSTOP(I)
36602   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
36603     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
36604          CALL DPWRST('XXX','BUG ')
36605   55   CONTINUE
36606        WRITE(ICOUT,57)NUMCHF,MAXCHF
36607   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
36608        CALL DPWRST('XXX','BUG ')
36609        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
36610   60   FORMAT('IFUNC(.)  = ',120A1)
36611        CALL DPWRST('XXX','BUG ')
36612      ENDIF
36613C
36614C               **********************************
36615C               **  STEP 1--                    **
36616C               **  INITIALIZE SOME VARIABLES.  **
36617C               **********************************
36618C
36619      ISTEPN='1'
36620      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSC')
36621     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36622C
36623      NEWNAM='NO'
36624      NEWCOL='NO'
36625      ICASEL='UNKN'
36626      ICOLL=0
36627C
36628C               ******************************************************
36629C               **  STEP 2--                                         *
36630C               **  EXAMINE THE ARGUMENT ON THE                      *
36631C               **  LEFT-HAND SIDE--                                 *
36632C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
36633C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
36634C               ******************************************************
36635C
36636      ISTEPN='2'
36637      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSC')
36638     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36639C
36640      IHLEFT=IHARG(1)
36641      IHLEF2=IHARG2(1)
36642C
36643      DO2000I=1,NUMNAM
36644        I2=I
36645        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
36646          IF(IUSE(I2).EQ.'F')THEN
36647            ICASEL='STRI'
36648            ILISTL=I2
36649            GOTO2299
36650          ELSE
36651            WRITE(ICOUT,999)
36652  999       FORMAT(1X)
36653            CALL DPWRST('XXX','BUG ')
36654            WRITE(ICOUT,2001)
36655 2001       FORMAT('***** ERROR IN SWAP CASE--')
36656            CALL DPWRST('XXX','BUG ')
36657            WRITE(ICOUT,2003)IHLEFT,IHLEF2
36658 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
36659     1             A4,A4,')')
36660            CALL DPWRST('XXX','BUG ')
36661            WRITE(ICOUT,2005)
36662 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
36663            CALL DPWRST('XXX','BUG ')
36664            IERROR='YES'
36665            GOTO9000
36666          ENDIF
36667        ENDIF
36668 2000 CONTINUE
36669C
36670      NEWNAM='YES'
36671      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
36672C
36673      ILISTL=NUMNAM+1
36674      IF(ILISTL.GT.MAXNAM)THEN
36675        WRITE(ICOUT,999)
36676        CALL DPWRST('XXX','BUG ')
36677        WRITE(ICOUT,2001)
36678        CALL DPWRST('XXX','BUG ')
36679        WRITE(ICOUT,2202)
36680 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
36681     1         'FUNCTION')
36682        CALL DPWRST('XXX','BUG ')
36683        WRITE(ICOUT,2203)MAXNAM
36684 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
36685        CALL DPWRST('XXX','BUG ')
36686        WRITE(ICOUT,2204)
36687 2204   FORMAT('      ENTER      STATUS')
36688        CALL DPWRST('XXX','BUG ')
36689        WRITE(ICOUT,2205)
36690 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
36691        CALL DPWRST('XXX','BUG ')
36692        WRITE(ICOUT,2206)
36693 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
36694     1         'USED NAMES.')
36695        CALL DPWRST('XXX','BUG ')
36696        IERROR='YES'
36697        GOTO9000
36698      ENDIF
36699C
36700 2299 CONTINUE
36701C
36702C               *****************************************************
36703C               **  STEP 3--                                       **
36704C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
36705C               *****************************************************
36706C
36707      ISTEPN='3A'
36708      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSC')
36709     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36710C
36711      IHRIGH=IHARG(5)
36712      IHRIG2=IHARG2(5)
36713      DO3000I=1,NUMNAM
36714        I4=I
36715        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
36716          IF(IUSE(I4).NE.'F')THEN
36717            WRITE(ICOUT,999)
36718            CALL DPWRST('XXX','BUG ')
36719            WRITE(ICOUT,2001)
36720            CALL DPWRST('XXX','BUG ')
36721            WRITE(ICOUT,3003)IHRIGH,IHRIG2
36722 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
36723     1             A4,A4,')')
36724            CALL DPWRST('XXX','BUG ')
36725            WRITE(ICOUT,3005)
36726 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
36727            CALL DPWRST('XXX','BUG ')
36728            IERROR='YES'
36729            GOTO9000
36730          ELSE
36731            ISTRT1=IVSTAR(I4)
36732            ISTOP1=IVSTOP(I4)
36733            NLEN1=ISTOP1-ISTRT1+1
36734            GOTO3099
36735          ENDIF
36736        ENDIF
36737 3000 CONTINUE
36738C
36739      WRITE(ICOUT,999)
36740      CALL DPWRST('XXX','BUG ')
36741      WRITE(ICOUT,2001)
36742      CALL DPWRST('XXX','BUG ')
36743      WRITE(ICOUT,3003)IHRIGH,IHRIG2
36744      CALL DPWRST('XXX','BUG ')
36745      WRITE(ICOUT,3015)
36746 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
36747      CALL DPWRST('XXX','BUG ')
36748      IERROR='YES'
36749      GOTO9000
36750C
36751 3099 CONTINUE
36752C
36753C               *****************************************************
36754C               **  STEP 4--                                       **
36755C               **  PERFORM THE CASE CONVERSION                    **
36756C               *****************************************************
36757C
36758      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSC')THEN
36759        ISTEPN='4A'
36760        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36761        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1
36762 4011   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
36763        CALL DPWRST('XXX','BUG ')
36764        WRITE(ICOUT,4014)ICASEL
36765 4014   FORMAT('ICASEL = ',A4)
36766        CALL DPWRST('XXX','BUG ')
36767      ENDIF
36768C
36769      IF(NLEN1.GE.1)THEN
36770        ICNT=0
36771        DO4100I=ISTRT1,ISTOP1
36772          ICNT=ICNT+1
36773          IC=IFUNC(I)(1:1)
36774          CALL DPCOAN(IC,IJUNK)
36775          IF(IJUNK.GE.65 .AND. IJUNK.LE.90)THEN
36776            IJUNK=IJUNK+32
36777          ELSEIF(IJUNK.GE.97 .AND. IJUNK.LE.122)THEN
36778            IJUNK=IJUNK-32
36779          ENDIF
36780          CALL DPCONA(IJUNK,IC)
36781          IFUNC2(ICNT)=' '
36782          IFUNC2(ICNT)(1:1)=IC
36783 4100   CONTINUE
36784      ENDIF
36785C
36786C               *****************************************************
36787C               **  STEP 5--                                       **
36788C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
36789C               *****************************************************
36790C
36791      IF(ICASEL.EQ.'STRI')THEN
36792C
36793        ISTEPN='5'
36794        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSC')
36795     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36796C
36797        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
36798     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
36799CCCCC1              NEWNAM,MAXN3,
36800     1              NEWNAM,MAXNAM,
36801     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
36802        IF(IERROR.EQ.'YES')GOTO9000
36803C
36804        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
36805          WRITE(ICOUT,999)
36806          CALL DPWRST('XXX','BUG ')
36807          WRITE(ICOUT,6606)IHLEFT,IHLEF2
36808 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
36809          CALL DPWRST('XXX','BUG ')
36810          ILAB(1)='TO T'
36811          ILAB(2)='HE F'
36812          ILAB(3)='UNCT'
36813          ILAB(4)='ION '
36814          ILAB(5)='    '
36815          ILAB(6)=' -- '
36816          NUMWDL=6
36817          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
36818C
36819          WRITE(ICOUT,999)
36820          CALL DPWRST('XXX','BUG ')
36821C
36822        ENDIF
36823C
36824      ENDIF
36825C
36826C
36827C               ****************
36828C               **  STEP 90-- **
36829C               **  EXIT.     **
36830C               ****************
36831C
36832 9000 CONTINUE
36833      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STSC')THEN
36834        WRITE(ICOUT,999)
36835        CALL DPWRST('XXX','BUG ')
36836        WRITE(ICOUT,9011)
36837 9011   FORMAT('***** AT THE END       OF DPSTSC--')
36838        CALL DPWRST('XXX','BUG ')
36839        WRITE(ICOUT,9013)NUMNAM
36840 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
36841        CALL DPWRST('XXX','BUG ')
36842        DO9015I=1,NUMNAM
36843          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
36844     1                     IVSTAR(I),IVSTOP(I)
36845 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
36846     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
36847          CALL DPWRST('XXX','BUG ')
36848 9015   CONTINUE
36849      ENDIF
36850C
36851      RETURN
36852      END
36853      SUBROUTINE DPSTSP(ICASE,ISUBRO,IBUGA3,IERROR)
36854C
36855C     PURPOSE--REMOVE SPACES (ALL SPACES OR LEADING SPACES OR
36856C              TRAILING SPACES)
36857C
36858C              1) ALTERNATIVELY, REMOVE ALL PUNCTUATION
36859C              2) ALTERNATIVELY, CONVERT NON-PRINTING CHARACTERS
36860C                 TO SINGLE SPACE WITH OPTION TO EXPAND TABS TO
36861C                 A USER-SPECIFIED NUMBER OF SPACES
36862C
36863C     EXAMPLE--LET STOUT = STRING REMOVE SPACES  STIN
36864C              LET STOUT = STRING REMOVE LEADING SPACES STIN
36865C              LET STOUT = STRING REMOVE TRAILING SPACES STIN
36866C     WRITTEN BY--ALAN HECKERT
36867C                 STATISTICAL ENGINEERING DIVISION
36868C                 INFORMATION TECHNOLOGY LABORATORY
36869C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
36870C                 GAITHERSBURG, MD 20899-8980
36871C                 PHONE--301-975-2899
36872C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
36873C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
36874C     LANGUAGE--ANSI FORTRAN (1977)
36875C     VERSION NUMBER--2015/03
36876C     ORIGINAL VERSION--MARCH     2015.
36877C     UPDATED         --SEPTEMBER 2018. ADD "REMOVE PUNCTUATION" CASE
36878C     UPDATED         --FEBRUARY  2019. ADD "EXPAND WHITESPACE" CASE
36879C
36880C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36881C
36882      CHARACTER*4 ICASE
36883      CHARACTER*4 ISUBRO
36884      CHARACTER*4 IBUGA3
36885      CHARACTER*4 IERROR
36886C
36887      CHARACTER*4 NEWNAM
36888      CHARACTER*4 NEWNA2
36889      CHARACTER*4 NEWCOL
36890      CHARACTER*4 NEWCO2
36891      CHARACTER*4 ICASEL
36892      CHARACTER*4 ICASE2
36893      CHARACTER*4 IHLEFT
36894      CHARACTER*4 IHLEF2
36895      CHARACTER*4 IHRIGH
36896      CHARACTER*4 IHRIG2
36897      CHARACTER*4 ISUBN1
36898      CHARACTER*4 ISUBN2
36899      CHARACTER*4 ISTEPN
36900C
36901      CHARACTER*4 ILAB(10)
36902C
36903C---------------------------------------------------------------------
36904C
36905C-----COMMON----------------------------------------------------------
36906C
36907      INCLUDE 'DPCOPA.INC'
36908      INCLUDE 'DPCOHK.INC'
36909      INCLUDE 'DPCODA.INC'
36910      INCLUDE 'DPCOST.INC'
36911      INCLUDE 'DPCOP2.INC'
36912C
36913C-----START POINT-----------------------------------------------------
36914C
36915      ISUBN1='DPST'
36916      ISUBN2='SP  '
36917      IERROR='NO'
36918      ILOC3=0
36919C
36920      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STSP')THEN
36921        WRITE(ICOUT,999)
36922        CALL DPWRST('XXX','BUG ')
36923        WRITE(ICOUT,51)
36924   51   FORMAT('***** AT THE BEGINNING OF DPSTSP--')
36925        CALL DPWRST('XXX','BUG ')
36926        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,NUMNAM
36927   52   FORMAT('IBUGA3,ISUBRO,ICASE,NUMNAM = ',3(A4,2X),I8)
36928        CALL DPWRST('XXX','BUG ')
36929        DO55I=1,NUMNAM
36930          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
36931     1                   IVSTOP(I)
36932   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
36933     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
36934          CALL DPWRST('XXX','BUG ')
36935   55   CONTINUE
36936        WRITE(ICOUT,57)NUMCHF,MAXCHF,NUMARG
36937   57   FORMAT('NUMCHF,MAXCHF,NUMARG = ',3I8)
36938        CALL DPWRST('XXX','BUG ')
36939        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
36940   60   FORMAT('IFUNC(.)  = ',120A1)
36941        CALL DPWRST('XXX','BUG ')
36942        IF(NUMARG.GE.1)THEN
36943          DO70I=1,NUMARG
36944            WRITE(ICOUT,76)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
36945   76       FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
36946     1             I8,2X,A4,A4,2X,A4,2X,I8)
36947            CALL DPWRST('XXX','BUG ')
36948   70     CONTINUE
36949        ENDIF
36950      ENDIF
36951C
36952C               **********************************
36953C               **  STEP 1--                    **
36954C               **  INITIALIZE SOME VARIABLES.  **
36955C               **********************************
36956C
36957      ISTEPN='1'
36958      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSP')
36959     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36960C
36961      NEWNAM='NO'
36962      NEWNA2='NO'
36963      NEWCOL='NO'
36964      NEWCO2='NO'
36965      ICASEL='UNKN'
36966      ICASE2='UNKN'
36967      NIOLD1=0
36968      NIOLD2=0
36969      ICOLL=0
36970      ICOL2=0
36971C
36972C               ******************************************************
36973C               **  STEP 2--                                         *
36974C               **  EXAMINE THE ARGUMENT ON THE                      *
36975C               **  LEFT-HAND SIDE--                                 *
36976C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
36977C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
36978C               ******************************************************
36979C
36980      ISTEPN='2'
36981      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSP')
36982     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
36983C
36984      IHLEFT=IHARG(1)
36985      IHLEF2=IHARG2(1)
36986C
36987      DO2000I=1,NUMNAM
36988        I2=I
36989        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
36990          IF(IUSE(I2).EQ.'F')THEN
36991            ICASEL='STRI'
36992            ILISTL=I2
36993            GOTO2299
36994          ELSE
36995            WRITE(ICOUT,999)
36996  999       FORMAT(1X)
36997            CALL DPWRST('XXX','BUG ')
36998            WRITE(ICOUT,2001)
36999 2001       FORMAT('***** ERROR IN STRING REMOVE SPACES--')
37000            CALL DPWRST('XXX','BUG ')
37001            WRITE(ICOUT,2003)IHLEFT,IHLEF2
37002 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
37003     1             A4,A4,')')
37004            CALL DPWRST('XXX','BUG ')
37005            WRITE(ICOUT,2005)
37006 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
37007            CALL DPWRST('XXX','BUG ')
37008            IERROR='YES'
37009            GOTO9000
37010          ENDIF
37011        ENDIF
37012 2000 CONTINUE
37013C
37014      NEWNAM='YES'
37015      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
37016C
37017      ILISTL=NUMNAM+1
37018      IF(ILISTL.GT.MAXNAM)THEN
37019        WRITE(ICOUT,999)
37020        CALL DPWRST('XXX','BUG ')
37021        WRITE(ICOUT,2001)
37022        CALL DPWRST('XXX','BUG ')
37023        WRITE(ICOUT,2202)
37024 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
37025     1         'FUNCTION')
37026        CALL DPWRST('XXX','BUG ')
37027        WRITE(ICOUT,2203)MAXNAM
37028 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
37029        CALL DPWRST('XXX','BUG ')
37030        WRITE(ICOUT,2204)
37031 2204   FORMAT('      ENTER      STATUS')
37032        CALL DPWRST('XXX','BUG ')
37033        WRITE(ICOUT,2205)
37034 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
37035        CALL DPWRST('XXX','BUG ')
37036        WRITE(ICOUT,2206)
37037 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
37038     1         'USED NAMES.')
37039        CALL DPWRST('XXX','BUG ')
37040        IERROR='YES'
37041        GOTO9000
37042      ENDIF
37043C
37044 2299 CONTINUE
37045C
37046C               *****************************************************
37047C               **  STEP 3--                                       **
37048C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
37049C               *****************************************************
37050C
37051      ISTEPN='3A'
37052      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSP')
37053     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37054C
37055      IF(ICASE.EQ.'LEAD' .OR. ICASE.EQ.'TRAI')THEN
37056        IHRIGH=IHARG(7)
37057        IHRIG2=IHARG2(7)
37058      ELSE
37059        IHRIGH=IHARG(6)
37060        IHRIG2=IHARG2(6)
37061      ENDIF
37062C
37063      DO3000I=1,NUMNAM
37064        I4=I
37065        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
37066          IF(IUSE(I4).NE.'F')THEN
37067            WRITE(ICOUT,999)
37068            CALL DPWRST('XXX','BUG ')
37069            WRITE(ICOUT,2001)
37070            CALL DPWRST('XXX','BUG ')
37071            WRITE(ICOUT,3003)IHRIGH,IHRIG2
37072 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
37073     1             A4,A4,')')
37074            CALL DPWRST('XXX','BUG ')
37075            WRITE(ICOUT,3005)
37076 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
37077            CALL DPWRST('XXX','BUG ')
37078            IERROR='YES'
37079            GOTO9000
37080          ELSE
37081            ISTRT1=IVSTAR(I4)
37082            ISTOP1=IVSTOP(I4)
37083            NLEN1=ISTOP1-ISTRT1+1
37084            GOTO3099
37085          ENDIF
37086        ENDIF
37087 3000 CONTINUE
37088C
37089      WRITE(ICOUT,999)
37090      CALL DPWRST('XXX','BUG ')
37091      WRITE(ICOUT,2001)
37092      CALL DPWRST('XXX','BUG ')
37093      WRITE(ICOUT,3003)IHRIGH,IHRIG2
37094      CALL DPWRST('XXX','BUG ')
37095      WRITE(ICOUT,3015)
37096 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
37097      CALL DPWRST('XXX','BUG ')
37098      IERROR='YES'
37099      GOTO9000
37100C
37101 3099 CONTINUE
37102C
37103C               ***********************************************
37104C               **  STEP 4A--REMOVE LEADING SPACES           **
37105C               ***********************************************
37106C
37107      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSP')THEN
37108        ISTEPN='4'
37109        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37110        WRITE(ICOUT,4012)IIDX,ISTRT1,ISTOP1,NLEN1
37111 4012   FORMAT('IINDX,ISTRT1,ISTOP1,NLEN1 = ',4I8)
37112        CALL DPWRST('XXX','BUG ')
37113        WRITE(ICOUT,4013)ICASEL
37114 4013   FORMAT('ICASEL = ',A4)
37115        CALL DPWRST('XXX','BUG ')
37116      ENDIF
37117C
37118      IF(ICASE.EQ.'LEAD')THEN
37119        NLEN2=0
37120        IFLAG=0
37121        DO4110I=ISTRT1,ISTOP1
37122          IF(IFUNC(I).EQ.' ' .AND. IFLAG.EQ.0)GOTO4110
37123            IFLAG=1
37124            NLEN2=NLEN2+1
37125            IFUNC2(NLEN2)=IFUNC(I)
37126 4110   CONTINUE
37127      ELSEIF(ICASE.EQ.'TRAI')THEN
37128        NLEN2=0
37129        IFLAG=0
37130        DO4210I=ISTOP1,ISTRT1,-1
37131          IF(IFUNC(I).NE.' ')THEN
37132            ILAST=I
37133            GOTO4219
37134          ENDIF
37135 4210   CONTINUE
37136        ILAST=ISTOP1
37137 4219   CONTINUE
37138        DO4220I=ISTRT1,ILAST
37139          IF(IFUNC(I).EQ.' ' .AND. IFLAG.EQ.0)GOTO4220
37140            IFLAG=1
37141            NLEN2=NLEN2+1
37142            IFUNC2(NLEN2)=IFUNC(I)
37143 4220   CONTINUE
37144      ELSEIF(ICASE.EQ.'RPUN')THEN
37145        NLEN2=0
37146        DO4230I=ISTRT1,ISTOP1
37147          IF(IFUNC(I).EQ.'!')GOTO4230
37148          IF(IFUNC(I).EQ.'"')GOTO4230
37149          IF(IFUNC(I).EQ."'")GOTO4230
37150          IF(IFUNC(I).EQ.'#')GOTO4230
37151          IF(IFUNC(I).EQ.'$')GOTO4230
37152          IF(IFUNC(I).EQ.'%')GOTO4230
37153          IF(IFUNC(I).EQ.'&')GOTO4230
37154          IF(IFUNC(I).EQ.'\')GOTO4230
37155          IF(IFUNC(I).EQ.'(')GOTO4230
37156          IF(IFUNC(I).EQ.')')GOTO4230
37157          IF(IFUNC(I).EQ.'*')GOTO4230
37158          IF(IFUNC(I).EQ.'+')GOTO4230
37159          IF(IFUNC(I).EQ.',')GOTO4230
37160          IF(IFUNC(I).EQ.'-')GOTO4230
37161          IF(IFUNC(I).EQ.'.')GOTO4230
37162          IF(IFUNC(I).EQ.'/')GOTO4230
37163          IF(IFUNC(I).EQ.':')GOTO4230
37164          IF(IFUNC(I).EQ.';')GOTO4230
37165          IF(IFUNC(I).EQ.'<')GOTO4230
37166          IF(IFUNC(I).EQ.'=')GOTO4230
37167          IF(IFUNC(I).EQ.'>')GOTO4230
37168          IF(IFUNC(I).EQ.'?')GOTO4230
37169          IF(IFUNC(I).EQ.'@')GOTO4230
37170          IF(IFUNC(I).EQ.'[')GOTO4230
37171          IF(IFUNC(I).EQ.']')GOTO4230
37172          IF(IFUNC(I).EQ.'^')GOTO4230
37173          IF(IFUNC(I).EQ.'_')GOTO4230
37174          IF(IFUNC(I).EQ.'`')GOTO4230
37175          IF(IFUNC(I).EQ.'~')GOTO4230
37176          IF(IFUNC(I).EQ.'{')GOTO4230
37177          IF(IFUNC(I).EQ.'}')GOTO4230
37178          IF(IFUNC(I).EQ.'|')GOTO4230
37179          IF(IFUNC(I).EQ.'|')GOTO4230
37180            NLEN2=NLEN2+1
37181            IFUNC2(NLEN2)=IFUNC(I)
37182 4230   CONTINUE
37183      ELSEIF(ICASE.EQ.'RWHI')THEN
37184C
37185C       NOTE THAT FOR WHITE SPACE, WE ARE RESTRICTING
37186C       TO THE ONES IN THE ASCII 0-127 RANGE.
37187C
37188        NLEN2=0
37189        DO4240I=ISTRT1,ISTOP1
37190          IF(IFUNC(I).EQ.' ')GOTO4240
37191          CALL DPCOAN(IFUNC(I)(1:1),IVAL)
37192          IF(IVAL.GE.0 .AND. IVAL.LE.32)GOTO4240
37193          IF(IVAL.EQ.127)GOTO4240
37194            NLEN2=NLEN2+1
37195            IFUNC2(NLEN2)=IFUNC(I)
37196 4240   CONTINUE
37197      ELSEIF(ICASE.EQ.'EWHI')THEN
37198C
37199C       CONVERT NON-PRINTING CHARACTERS TO A SINGLE SPACE,
37200C       ALLOW USER TO SPECIFY HOW MANY CHARACTERS A TAB WILL
37201C       BE CONVERTED TO.
37202C
37203C       NON-PRINTING CHARACTERS ARE:
37204C
37205C           0 - 31 (TAB IS 9)
37206C
37207        NLEN2=0
37208        DO4440I=ISTRT1,ISTOP1
37209          CALL DPCOAN(IFUNC(I)(1:1),IVAL)
37210          IF(IVAL.EQ.9)THEN
37211            IF(ITABNC.GT.0)THEN
37212              DO4441J=1,ITABNC
37213                NLEN2=NLEN2+1
37214                IFUNC2(NLEN2)=' '
37215 4441         CONTINUE
37216            ENDIF
37217          ELSEIF(IVAL.GE.0 .AND. IVAL.LE.31)THEN
37218            NLEN2=NLEN2+1
37219            IFUNC2(NLEN2)=' '
37220          ELSEIF(IVAL.EQ.127)THEN
37221            NLEN2=NLEN2+1
37222            IFUNC2(NLEN2)=' '
37223          ELSE
37224            NLEN2=NLEN2+1
37225            IFUNC2(NLEN2)=IFUNC(I)
37226          ENDIF
37227 4440   CONTINUE
37228      ELSE
37229        NLEN2=0
37230        DO4310I=ISTRT1,ISTOP1
37231          IF(IFUNC(I).EQ.' ')GOTO4310
37232            NLEN2=NLEN2+1
37233            IFUNC2(NLEN2)=IFUNC(I)
37234 4310   CONTINUE
37235      ENDIF
37236C
37237      IF(NLEN2.EQ.0)THEN
37238        WRITE(ICOUT,999)
37239        CALL DPWRST('XXX','BUG ')
37240        WRITE(ICOUT,2001)
37241        CALL DPWRST('XXX','BUG ')
37242        WRITE(ICOUT,4401)
37243 4401   FORMAT('      THE RESULTING STRING IS OF ZERO LENGTH.  ',
37244     1         'NOTHING DONE.')
37245        CALL DPWRST('XXX','BUG ')
37246        IERROR='YES'
37247        GOTO9000
37248      ENDIF
37249C
37250C               *****************************************************
37251C               **  STEP 5--                                       **
37252C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
37253C               *****************************************************
37254C
37255C
37256      IF(ICASEL.EQ.'STRI')THEN
37257C
37258        ISTEPN='5'
37259        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSP')
37260     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37261C
37262        CALL DPINFU(IFUNC2,NLEN2,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
37263     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
37264CCCCC1              NEWNAM,MAXN3,
37265     1              NEWNAM,MAXNAM,
37266     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
37267        IF(IERROR.EQ.'YES')GOTO9000
37268C
37269        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
37270          WRITE(ICOUT,999)
37271          CALL DPWRST('XXX','BUG ')
37272          WRITE(ICOUT,6606)IHLEFT,IHLEF2
37273 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
37274          CALL DPWRST('XXX','BUG ')
37275          ILAB(1)='TO T'
37276          ILAB(2)='HE F'
37277          ILAB(3)='UNCT'
37278          ILAB(4)='ION '
37279          ILAB(5)='    '
37280          ILAB(6)=' -- '
37281          NUMWDL=6
37282          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,NLEN2,IBUGA3)
37283C
37284          WRITE(ICOUT,999)
37285          CALL DPWRST('XXX','BUG ')
37286C
37287        ENDIF
37288C
37289      ENDIF
37290C
37291C
37292C               ****************
37293C               **  STEP 90-- **
37294C               **  EXIT.     **
37295C               ****************
37296C
37297 9000 CONTINUE
37298      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STSP')THEN
37299        WRITE(ICOUT,999)
37300        CALL DPWRST('XXX','BUG ')
37301        WRITE(ICOUT,9011)
37302 9011   FORMAT('***** AT THE END       OF DPSTSP--')
37303        CALL DPWRST('XXX','BUG ')
37304        WRITE(ICOUT,9013)NUMNAM
37305 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
37306        CALL DPWRST('XXX','BUG ')
37307        DO9015I=1,NUMNAM
37308          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
37309     1                     IVSTAR(I),IVSTOP(I)
37310 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
37311     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
37312          CALL DPWRST('XXX','BUG ')
37313 9015   CONTINUE
37314      ENDIF
37315C
37316      RETURN
37317      END
37318      SUBROUTINE DPSTSW(ICASEZ,ISUBRO,IBUGA3,IERROR)
37319C
37320C     PURPOSE--IMPLEMENT THE FOLLOWING TWO COMMANDS:
37321C
37322C                 LET IFLAG = STRING STARTS WITH SORG SMATCH
37323C                 LET IFLAG = STRING ENDS   WITH SORG SMATCH
37324C
37325C              THAT IS, WE CHECK WHETHER A STRING (SORG) STARTS WITH A
37326C              SPECIFIC SUBSTRING (SMATCH) OR NOT.  IF SO, IFLAG IS SET
37327C              TO 1, OTHERWISE IT IS SET TO 0.  SIMILARLY, WE CAN CHECK
37328C              FOR THE END OF THE STRING.
37329C     NOTE--THE FOLLOWING SYNTAX IS NOT SUPPORTED FOR THIS COMMAND:
37330C              LET Y(2) = STRING STARTS WITH  S  SUBSTRING
37331C           ALSO, THE STRINGS ON THE RIGHT HAND SIDE MUST BOTH BE
37332C           PREVIOUSLY DEFINED.
37333C     WRITTEN BY--ALAN HECKERT
37334C                 STATISTICAL ENGINEERING DIVISION
37335C                 INFORMATION TECHNOLOGY LABORATORY
37336C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
37337C                 GAITHERSBURG, MD 20899-8980
37338C                 PHONE--301-975-2899
37339C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
37340C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
37341C     LANGUAGE--ANSI FORTRAN (1977)
37342C     VERSION NUMBER--2018/09
37343C     ORIGINAL VERSION--SEPTEMBER 2018.
37344C
37345C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
37346C
37347      CHARACTER*4 ICASEZ
37348      CHARACTER*4 ISUBRO
37349      CHARACTER*4 IBUGA3
37350      CHARACTER*4 IERROR
37351C
37352      CHARACTER*4 NEWNAM
37353      CHARACTER*4 NEWNA2
37354      CHARACTER*4 NEWCOL
37355      CHARACTER*4 NEWCO2
37356      CHARACTER*4 ICASEL
37357      CHARACTER*4 IHLEFT
37358      CHARACTER*4 IHLEF2
37359      CHARACTER*4 IHRIGH
37360      CHARACTER*4 IHRIG2
37361      CHARACTER*4 IHRI21
37362      CHARACTER*4 IHRI22
37363      CHARACTER*4 ISUBN1
37364      CHARACTER*4 ISUBN2
37365      CHARACTER*4 ISTEPN
37366C
37367C---------------------------------------------------------------------
37368C
37369C-----COMMON----------------------------------------------------------
37370C
37371      INCLUDE 'DPCOPA.INC'
37372      INCLUDE 'DPCOHK.INC'
37373      INCLUDE 'DPCODA.INC'
37374      INCLUDE 'DPCOP2.INC'
37375C
37376C-----START POINT-----------------------------------------------------
37377C
37378      ISUBN1='DPST'
37379      ISUBN2='SW  '
37380      IERROR='NO'
37381C
37382      ILOC3=0
37383C
37384      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STSW')THEN
37385        WRITE(ICOUT,999)
37386        CALL DPWRST('XXX','BUG ')
37387        WRITE(ICOUT,51)
37388   51   FORMAT('***** AT THE BEGINNING OF DPSTSW--')
37389        CALL DPWRST('XXX','BUG ')
37390        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
37391   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
37392        CALL DPWRST('XXX','BUG ')
37393        DO55I=1,NUMNAM
37394          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
37395     1                   IVSTOP(I)
37396   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
37397     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
37398          CALL DPWRST('XXX','BUG ')
37399   55   CONTINUE
37400        WRITE(ICOUT,57)NUMCHF,MAXCHF
37401   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
37402        CALL DPWRST('XXX','BUG ')
37403        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
37404   60   FORMAT('IFUNC(.)  = ',120A1)
37405        CALL DPWRST('XXX','BUG ')
37406      ENDIF
37407C
37408C               **********************************
37409C               **  STEP 1--                    **
37410C               **  INITIALIZE SOME VARIABLES.  **
37411C               **********************************
37412C
37413      ISTEPN='1'
37414      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSW')
37415     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37416C
37417      NEWNAM='NO'
37418      NEWNA2='NO'
37419      NEWCOL='NO'
37420      NEWCO2='NO'
37421      ICASEL='UNKN'
37422      NIOLD1=0
37423      ICOLL=0
37424C
37425C               ******************************************************
37426C               **  STEP 2--                                         *
37427C               **  EXAMINE THE FIRST ARGUMENT ON THE                *
37428C               **  LEFT-HAND SIDE--                                 *
37429C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
37430C               **  BE A PARAMETER (IF NOT, REPORT AN ERROR).        *
37431C               ******************************************************
37432C
37433      ISTEPN='2'
37434      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSW')
37435     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37436C
37437      IHLEFT=IHARG(1)
37438      IHLEF2=IHARG2(1)
37439C
37440      DO2000I=1,NUMNAM
37441        I2=I
37442        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
37443          IF(IUSE(I2).EQ.'P')THEN
37444            ICASEL='PARA'
37445            ILISTL=I2
37446            NUMTMP=NUMNAM
37447            GOTO2299
37448          ELSE
37449            WRITE(ICOUT,999)
37450  999       FORMAT(1X)
37451            CALL DPWRST('XXX','BUG ')
37452            WRITE(ICOUT,2001)
37453 2001       FORMAT('***** ERROR IN STRING STARTS (ENDS) WITH--')
37454            CALL DPWRST('XXX','BUG ')
37455            WRITE(ICOUT,2003)IHLEFT,IHLEF2
37456 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
37457     1             A4,A4,')')
37458            CALL DPWRST('XXX','BUG ')
37459            WRITE(ICOUT,2005)
37460 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
37461            CALL DPWRST('XXX','BUG ')
37462            IERROR='YES'
37463            GOTO9000
37464          ENDIF
37465        ENDIF
37466 2000 CONTINUE
37467C
37468      NEWNAM='YES'
37469      IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
37470C
37471      ILISTL=NUMNAM+1
37472      NUMTMP=NUMNAM+1
37473      IF(ILISTL.GT.MAXNAM)THEN
37474        WRITE(ICOUT,999)
37475        CALL DPWRST('XXX','BUG ')
37476        WRITE(ICOUT,2001)
37477        CALL DPWRST('XXX','BUG ')
37478        WRITE(ICOUT,2202)
37479 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
37480     1         'FUNCTION')
37481        CALL DPWRST('XXX','BUG ')
37482        WRITE(ICOUT,2203)MAXNAM
37483 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
37484        CALL DPWRST('XXX','BUG ')
37485        WRITE(ICOUT,2204)
37486 2204   FORMAT('      ENTER      STATUS')
37487        CALL DPWRST('XXX','BUG ')
37488        WRITE(ICOUT,2205)
37489 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
37490        CALL DPWRST('XXX','BUG ')
37491        WRITE(ICOUT,2206)
37492 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
37493     1         'USED NAMES.')
37494        CALL DPWRST('XXX','BUG ')
37495        IERROR='YES'
37496        GOTO9000
37497      ENDIF
37498C
37499 2299 CONTINUE
37500C
37501C               *****************************************************
37502C               **  STEP 3--                                       **
37503C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
37504C               *****************************************************
37505C
37506      ISTEPN='3A'
37507      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSW')
37508     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37509C
37510      IINDX=6
37511      IHRIGH=IHARG(IINDX)
37512      IHRIG2=IHARG2(IINDX)
37513      DO3000I=1,NUMNAM
37514        I4=I
37515        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
37516          IF(IUSE(I4).NE.'F')THEN
37517            WRITE(ICOUT,999)
37518            CALL DPWRST('XXX','BUG ')
37519            WRITE(ICOUT,2001)
37520            CALL DPWRST('XXX','BUG ')
37521            WRITE(ICOUT,3003)IHRIGH,IHRIG2
37522 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
37523     1             A4,A4,')')
37524            CALL DPWRST('XXX','BUG ')
37525            WRITE(ICOUT,3005)
37526 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
37527            CALL DPWRST('XXX','BUG ')
37528            IERROR='YES'
37529            GOTO9000
37530          ELSE
37531            ISTRT1=IVSTAR(I4)
37532            ISTOP1=IVSTOP(I4)
37533            NLEN1=ISTOP1-ISTRT1+1
37534            GOTO3099
37535          ENDIF
37536        ENDIF
37537 3000 CONTINUE
37538C
37539      WRITE(ICOUT,999)
37540      CALL DPWRST('XXX','BUG ')
37541      WRITE(ICOUT,2001)
37542      CALL DPWRST('XXX','BUG ')
37543      WRITE(ICOUT,3003)IHRIGH,IHRIG2
37544      CALL DPWRST('XXX','BUG ')
37545      WRITE(ICOUT,3015)
37546 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
37547      CALL DPWRST('XXX','BUG ')
37548      IERROR='YES'
37549      GOTO9000
37550C
37551 3099 CONTINUE
37552C
37553C               *****************************************************
37554C               **  STEP 3B-                                       **
37555C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE **
37556C               *****************************************************
37557C
37558      ISTEPN='3B'
37559      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSW')
37560     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37561C
37562      IINDX=IINDX+1
37563      IHRI21=IHARG(IINDX)
37564      IHRI22=IHARG2(IINDX)
37565      DO3100I=1,NUMNAM
37566        I4=I
37567        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
37568          IF(IUSE(I4).NE.'F')THEN
37569            WRITE(ICOUT,999)
37570            CALL DPWRST('XXX','BUG ')
37571            WRITE(ICOUT,2001)
37572            CALL DPWRST('XXX','BUG ')
37573            WRITE(ICOUT,3003)IHRI21,IHRI22
37574            CALL DPWRST('XXX','BUG ')
37575            WRITE(ICOUT,3005)
37576            CALL DPWRST('XXX','BUG ')
37577            IERROR='YES'
37578            GOTO9000
37579          ELSE
37580            ISTRT2=IVSTAR(I4)
37581            ISTOP2=IVSTOP(I4)
37582            NLEN2=ISTOP2-ISTRT2+1
37583            GOTO3199
37584          ENDIF
37585        ENDIF
37586 3100 CONTINUE
37587C
37588      WRITE(ICOUT,999)
37589      CALL DPWRST('XXX','BUG ')
37590      WRITE(ICOUT,2001)
37591      CALL DPWRST('XXX','BUG ')
37592      WRITE(ICOUT,3003)IHRI21,IHRI22
37593      CALL DPWRST('XXX','BUG ')
37594      WRITE(ICOUT,3015)
37595      CALL DPWRST('XXX','BUG ')
37596      IERROR='YES'
37597      GOTO9000
37598C
37599 3199 CONTINUE
37600C
37601C               *****************************************************
37602C               **  STEP 4--                                       **
37603C               **  CHECK FOR MATCHING STRINGS                     **
37604C               *****************************************************
37605C
37606      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSW')THEN
37607        ISTEPN='4'
37608        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37609        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1
37610 4011   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
37611        CALL DPWRST('XXX','BUG ')
37612        WRITE(ICOUT,4012)ISTRT2,ISTOP2,NLEN2
37613 4012   FORMAT('ISTART,ISTOP,NLEN2 = ',3I8)
37614        CALL DPWRST('XXX','BUG ')
37615        WRITE(ICOUT,4013)ICASEL,ICASEZ
37616 4013   FORMAT('ICASEL,ICASEZ = ',A4,2X,A4)
37617        CALL DPWRST('XXX','BUG ')
37618      ENDIF
37619C
37620      IF(ICASEZ.EQ.'STSW')THEN
37621        IMATCH=0
37622        IF(NLEN2.GT.NLEN1)GOTO4199
37623        NTEMP=ISTOP1-NLEN2+1
37624        IF(ISTRT1.GT.NTEMP)GOTO4199
37625        ICNT=0
37626        DO4100I=ISTRT1,ISTRT1+NLEN2-1
37627          IF(IFUNC(I)(1:1).NE.IFUNC(ISTRT2+ICNT)(1:1))GOTO4199
37628            ICNT=ICNT+1
37629 4100   CONTINUE
37630        IMATCH=1
37631 4199   CONTINUE
37632C
37633      ELSEIF(ICASEZ.EQ.'STEW')THEN
37634        IMATCH=0
37635        IF(NLEN2.GT.NLEN1)GOTO4299
37636        NTEMP=ISTOP1-NLEN2+1
37637        IF(ISTRT1.GT.NTEMP)GOTO4299
37638        ICNT=0
37639        DO4200I=NTEMP,ISTOP1
37640          IF(IFUNC(I)(1:1).NE.IFUNC(ISTRT2+ICNT)(1:1))GOTO4299
37641            ICNT=ICNT+1
37642 4200   CONTINUE
37643        IMATCH=1
37644 4299   CONTINUE
37645      ENDIF
37646C
37647C
37648C               *****************************************************
37649C               **  STEP 5--                                       **
37650C               **  SAVE PARAMETER                                 **
37651C               *****************************************************
37652C
37653C
37654      IF(ICASEL.EQ.'PARA')THEN
37655C
37656        ISTEPN='5'
37657        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STSW')
37658     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37659C
37660        IHNAME(ILISTL)=IHLEFT
37661        IHNAM2(ILISTL)=IHLEF2
37662        IUSE(ILISTL)='P'
37663        VALUE(ILISTL)=REAL(IMATCH)
37664        IVALUE(ILISTL)=IMATCH
37665        IN(ILISTL)=1
37666        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
37667C
37668        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
37669          WRITE(ICOUT,999)
37670          CALL DPWRST('XXX','BUG ')
37671          IF(IMATCH.EQ.0)THEN
37672            WRITE(ICOUT,5011)IHLEFT,IHLEF2,IMATCH
376735011        FORMAT('MATCH NOT FOUND, ',A4,A4,'  = ',I3)
37674            CALL DPWRST('XXX','BUG ')
37675          ELSE
37676            WRITE(ICOUT,5013)IHLEFT,IHLEF2,IMATCH
376775013        FORMAT('MATCH FOUND, ',A4,A4,'  = ',I3)
37678            CALL DPWRST('XXX','BUG ')
37679          ENDIF
37680          WRITE(ICOUT,999)
37681          CALL DPWRST('XXX','BUG ')
37682        ENDIF
37683      ENDIF
37684C
37685C
37686C               ****************
37687C               **  STEP 90-- **
37688C               **  EXIT.     **
37689C               ****************
37690C
37691 9000 CONTINUE
37692      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STSW')THEN
37693        WRITE(ICOUT,999)
37694        CALL DPWRST('XXX','BUG ')
37695        WRITE(ICOUT,9011)
37696 9011   FORMAT('***** AT THE END       OF DPSTSW--')
37697        CALL DPWRST('XXX','BUG ')
37698        WRITE(ICOUT,9013)NUMNAM
37699 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
37700        CALL DPWRST('XXX','BUG ')
37701        DO9015I=1,NUMNAM
37702          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
37703     1                     IVSTAR(I),IVSTOP(I)
37704 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
37705     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
37706          CALL DPWRST('XXX','BUG ')
37707 9015   CONTINUE
37708      ENDIF
37709C
37710      RETURN
37711      END
37712      SUBROUTINE DPSTUC(ISUBRO,IBUGA3,IERROR)
37713C
37714C     PURPOSE--CONVERT A STRING TO UPPER CASE
37715C     EXAMPLE--LET SOUT = UPPER CASE SOLD
37716C     WRITTEN BY--JAMES J. FILLIBEN
37717C                 STATISTICAL ENGINEERING DIVISION
37718C                 INFORMATION TECHNOLOGY LABORATORY
37719C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
37720C                 GAITHERSBURG, MD 20899-8980
37721C                 PHONE--301-975-2855
37722C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
37723C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
37724C     LANGUAGE--ANSI FORTRAN (1977)
37725C     VERSION NUMBER--2008/11
37726C     ORIGINAL VERSION--NOVEMBER  2008.
37727C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
37728C
37729C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
37730C
37731      CHARACTER*4 ISUBRO
37732      CHARACTER*4 IBUGA3
37733      CHARACTER*4 IERROR
37734C
37735      CHARACTER*4 NEWNAM
37736      CHARACTER*4 NEWCOL
37737      CHARACTER*4 ICASEL
37738      CHARACTER*4 IHLEFT
37739      CHARACTER*4 IHLEF2
37740      CHARACTER*4 IHRIGH
37741      CHARACTER*4 IHRIG2
37742C
37743      CHARACTER*1 IC
37744C
37745      CHARACTER*4 ISUBN1
37746      CHARACTER*4 ISUBN2
37747      CHARACTER*4 ISTEPN
37748C
37749      CHARACTER*4 ILAB(10)
37750C
37751C---------------------------------------------------------------------
37752C
37753C-----COMMON----------------------------------------------------------
37754C
37755      INCLUDE 'DPCOPA.INC'
37756      INCLUDE 'DPCOHK.INC'
37757      INCLUDE 'DPCODA.INC'
37758      INCLUDE 'DPCOP2.INC'
37759C
37760C-----START POINT-----------------------------------------------------
37761C
37762      ISUBN1='DPST'
37763      ISUBN2='UC  '
37764      IERROR='NO'
37765C
37766      ILOC3=0
37767C
37768      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STUC')THEN
37769        WRITE(ICOUT,999)
37770        CALL DPWRST('XXX','BUG ')
37771        WRITE(ICOUT,51)
37772   51   FORMAT('***** AT THE BEGINNING OF DPSTUC--')
37773        CALL DPWRST('XXX','BUG ')
37774        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
37775   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
37776        CALL DPWRST('XXX','BUG ')
37777        DO55I=1,NUMNAM
37778          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
37779     1                   IVSTOP(I)
37780   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
37781     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
37782          CALL DPWRST('XXX','BUG ')
37783   55   CONTINUE
37784        WRITE(ICOUT,57)NUMCHF,MAXCHF
37785   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
37786        CALL DPWRST('XXX','BUG ')
37787        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
37788   60   FORMAT('IFUNC(.)  = ',120A1)
37789        CALL DPWRST('XXX','BUG ')
37790      ENDIF
37791C
37792C               **********************************
37793C               **  STEP 1--                    **
37794C               **  INITIALIZE SOME VARIABLES.  **
37795C               **********************************
37796C
37797      ISTEPN='1'
37798      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STUC')
37799     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37800C
37801      NEWNAM='NO'
37802      NEWCOL='NO'
37803      ICASEL='UNKN'
37804      ICOLL=0
37805C
37806C               ******************************************************
37807C               **  STEP 2--                                         *
37808C               **  EXAMINE THE ARGUMENT ON THE                      *
37809C               **  LEFT-HAND SIDE--                                 *
37810C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
37811C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
37812C               ******************************************************
37813C
37814      ISTEPN='2'
37815      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STUC')
37816     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37817C
37818      IHLEFT=IHARG(1)
37819      IHLEF2=IHARG2(1)
37820C
37821      DO2000I=1,NUMNAM
37822        I2=I
37823        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
37824          IF(IUSE(I2).EQ.'F')THEN
37825            ICASEL='STRI'
37826            ILISTL=I2
37827            GOTO2299
37828          ELSE
37829            WRITE(ICOUT,999)
37830  999       FORMAT(1X)
37831            CALL DPWRST('XXX','BUG ')
37832            WRITE(ICOUT,2001)
37833 2001       FORMAT('***** ERROR IN UPPER CASE--')
37834            CALL DPWRST('XXX','BUG ')
37835            WRITE(ICOUT,2003)IHLEFT,IHLEF2
37836 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
37837     1             A4,A4,')')
37838            CALL DPWRST('XXX','BUG ')
37839            WRITE(ICOUT,2005)
37840 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
37841            CALL DPWRST('XXX','BUG ')
37842            IERROR='YES'
37843            GOTO9000
37844          ENDIF
37845        ENDIF
37846 2000 CONTINUE
37847C
37848      NEWNAM='YES'
37849      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
37850C
37851      ILISTL=NUMNAM+1
37852      IF(ILISTL.GT.MAXNAM)THEN
37853        WRITE(ICOUT,999)
37854        CALL DPWRST('XXX','BUG ')
37855        WRITE(ICOUT,2001)
37856        CALL DPWRST('XXX','BUG ')
37857        WRITE(ICOUT,2202)
37858 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
37859     1         'FUNCTION')
37860        CALL DPWRST('XXX','BUG ')
37861        WRITE(ICOUT,2203)MAXNAM
37862 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
37863        CALL DPWRST('XXX','BUG ')
37864        WRITE(ICOUT,2204)
37865 2204   FORMAT('      ENTER      STATUS')
37866        CALL DPWRST('XXX','BUG ')
37867        WRITE(ICOUT,2205)
37868 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
37869        CALL DPWRST('XXX','BUG ')
37870        WRITE(ICOUT,2206)
37871 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
37872     1         'USED NAMES.')
37873        CALL DPWRST('XXX','BUG ')
37874        IERROR='YES'
37875        GOTO9000
37876      ENDIF
37877C
37878 2299 CONTINUE
37879C
37880C               *****************************************************
37881C               **  STEP 3--                                       **
37882C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
37883C               *****************************************************
37884C
37885      ISTEPN='3A'
37886      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STUC')
37887     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37888C
37889      IHRIGH=IHARG(5)
37890      IHRIG2=IHARG2(5)
37891      DO3000I=1,NUMNAM
37892        I4=I
37893        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
37894          IF(IUSE(I4).NE.'F')THEN
37895            WRITE(ICOUT,999)
37896            CALL DPWRST('XXX','BUG ')
37897            WRITE(ICOUT,2001)
37898            CALL DPWRST('XXX','BUG ')
37899            WRITE(ICOUT,3003)IHRIGH,IHRIG2
37900 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
37901     1             A4,A4,')')
37902            CALL DPWRST('XXX','BUG ')
37903            WRITE(ICOUT,3005)
37904 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
37905            CALL DPWRST('XXX','BUG ')
37906            IERROR='YES'
37907            GOTO9000
37908          ELSE
37909            ISTRT1=IVSTAR(I4)
37910            ISTOP1=IVSTOP(I4)
37911            NLEN1=ISTOP1-ISTRT1+1
37912            GOTO3099
37913          ENDIF
37914        ENDIF
37915 3000 CONTINUE
37916C
37917      WRITE(ICOUT,999)
37918      CALL DPWRST('XXX','BUG ')
37919      WRITE(ICOUT,2001)
37920      CALL DPWRST('XXX','BUG ')
37921      WRITE(ICOUT,3003)IHRIGH,IHRIG2
37922      CALL DPWRST('XXX','BUG ')
37923      WRITE(ICOUT,3015)
37924 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
37925      CALL DPWRST('XXX','BUG ')
37926      IERROR='YES'
37927      GOTO9000
37928C
37929 3099 CONTINUE
37930C
37931C               *****************************************************
37932C               **  STEP 4--                                       **
37933C               **  PERFORM THE CASE CONVERSION                    **
37934C               *****************************************************
37935C
37936      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STUC')THEN
37937        ISTEPN='4A'
37938        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37939        WRITE(ICOUT,4011)ISTRT1,ISTOP1,NLEN1
37940 4011   FORMAT('ISTRT1,ISTOP1,NLEN1 = ',3I8)
37941        CALL DPWRST('XXX','BUG ')
37942        WRITE(ICOUT,4014)ICASEL
37943 4014   FORMAT('ICASEL = ',A4)
37944        CALL DPWRST('XXX','BUG ')
37945      ENDIF
37946C
37947      IF(NLEN1.GE.1)THEN
37948        ICNT=0
37949        DO4100I=ISTRT1,ISTOP1
37950          ICNT=ICNT+1
37951          IC=IFUNC(I)(1:1)
37952          CALL DPCOAN(IC,IJUNK)
37953          IF(IJUNK.GE.97 .AND. IJUNK.LE.122)THEN
37954            IJUNK=IJUNK-32
37955          ENDIF
37956          CALL DPCONA(IJUNK,IC)
37957          IFUNC2(ICNT)=' '
37958          IFUNC2(ICNT)(1:1)=IC
37959 4100   CONTINUE
37960      ENDIF
37961C
37962C               *****************************************************
37963C               **  STEP 5--                                       **
37964C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
37965C               *****************************************************
37966C
37967C
37968      IF(ICASEL.EQ.'STRI')THEN
37969C
37970        ISTEPN='5'
37971        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STUC')
37972     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
37973C
37974        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
37975     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
37976CCCCC1              NEWNAM,MAXN3,
37977     1              NEWNAM,MAXNAM,
37978     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
37979        IF(IERROR.EQ.'YES')GOTO9000
37980C
37981        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
37982          WRITE(ICOUT,999)
37983          CALL DPWRST('XXX','BUG ')
37984          WRITE(ICOUT,6606)IHLEFT,IHLEF2
37985 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
37986          CALL DPWRST('XXX','BUG ')
37987          ILAB(1)='TO T'
37988          ILAB(2)='HE F'
37989          ILAB(3)='UNCT'
37990          ILAB(4)='ION '
37991          ILAB(5)='    '
37992          ILAB(6)=' -- '
37993          NUMWDL=6
37994          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
37995C
37996          WRITE(ICOUT,999)
37997          CALL DPWRST('XXX','BUG ')
37998C
37999        ENDIF
38000C
38001      ENDIF
38002C
38003C
38004C               ****************
38005C               **  STEP 90-- **
38006C               **  EXIT.     **
38007C               ****************
38008C
38009 9000 CONTINUE
38010      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STUC')THEN
38011        WRITE(ICOUT,999)
38012        CALL DPWRST('XXX','BUG ')
38013        WRITE(ICOUT,9011)
38014 9011   FORMAT('***** AT THE END       OF DPSTUC--')
38015        CALL DPWRST('XXX','BUG ')
38016        WRITE(ICOUT,9013)NUMNAM
38017 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
38018        CALL DPWRST('XXX','BUG ')
38019        DO9015I=1,NUMNAM
38020          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
38021     1                     IVSTAR(I),IVSTOP(I)
38022 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
38023     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
38024          CALL DPWRST('XXX','BUG ')
38025 9015   CONTINUE
38026      ENDIF
38027C
38028      RETURN
38029      END
38030      SUBROUTINE DPSTVA(ISUBRO,IBUGA3,IERROR)
38031C
38032C     PURPOSE--CREATE A STRING VARIABLE.  THE STRING VARIABLE WILL BE
38033C              SAVED AS "CHARACTER VARIABLE" IN DPZCHF.DAT.
38034C     EXAMPLE--LET SOUT = STRING VARIABLE S1 TO S50
38035C              LET SOUT = STRING VARIABLE "abcd"  "efgh" "ijkl"
38036C
38037C              DO NOT CHECK IF SOUT IS A CURRENTLY DEFINED STRING
38038C     WRITTEN BY--ALAN HECKERT
38039C                 STATISTICAL ENGINEERING DIVISION
38040C                 INFORMATION TECHNOLOGY LABORATORY
38041C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
38042C                 GAITHERSBURG, MD 20899-8980
38043C                 PHONE--301-975-2899
38044C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
38045C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
38046C     LANGUAGE--ANSI FORTRAN (1977)
38047C     VERSION NUMBER--2019/09
38048C     ORIGINAL VERSION--SEPTEMBER 2019.
38049C
38050C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
38051C
38052      CHARACTER*4 ISUBRO
38053      CHARACTER*4 IBUGA3
38054      CHARACTER*4 IERROR
38055C
38056      INCLUDE 'DPCOPA.INC'
38057C
38058      CHARACTER*4 IHLEFT
38059      CHARACTER*4 IHLEF2
38060      CHARACTER*4 IHRIGH
38061      CHARACTER*4 IHRIG2
38062      CHARACTER*4 ISUBN1
38063      CHARACTER*4 ISUBN2
38064      CHARACTER*4 ISTEPN
38065C
38066      CHARACTER*9999 ISTR
38067      CHARACTER*20 IFRMT
38068      CHARACTER*20 IFRMT2
38069      CHARACTER*4 IOP
38070      CHARACTER*4 IOPEN
38071      CHARACTER*8 IACC
38072      CHARACTER*4 IEXIST
38073      CHARACTER*4 MESSAG
38074      CHARACTER*4 IWRITE
38075      CHARACTER*4 ICASE
38076      CHARACTER*4 ISUBN0
38077      CHARACTER*4 IERRFI
38078      CHARACTER*25 ISTR2
38079CCCCC CHARACTER*255 ISTRIN
38080CCCCC CHARACTER*255 ISTRI2
38081      CHARACTER (LEN=MAXSTR) :: ISTRIN
38082      CHARACTER (LEN=MAXSTR) :: ISTRI2
38083      PARAMETER(MAXIND=100)
38084      CHARACTER*4 ISTRN1(MAXIND)
38085      CHARACTER*4 ISTRN2(MAXIND)
38086      CHARACTER*4 IHTEMP(255)
38087      CHARACTER*4 IFILQ2
38088C
38089CCCCC CHARACTER*80 IFILE1
38090      CHARACTER (LEN=MAXFNC) :: IFILE1
38091      CHARACTER*12 ISTAT1
38092      CHARACTER*12 IFORM1
38093      CHARACTER*12 IACCE1
38094      CHARACTER*12 IPROT1
38095      CHARACTER*12 ICURS1
38096      CHARACTER*4 IERRF1
38097      CHARACTER*4 IENDF1
38098      CHARACTER*4 IREWI1
38099C
38100CCCCC CHARACTER*80 IFILE2
38101      CHARACTER (LEN=MAXFNC) :: IFILE2
38102      CHARACTER*12 ISTAT2
38103      CHARACTER*12 IFORM2
38104      CHARACTER*12 IACCE2
38105      CHARACTER*12 IPROT2
38106      CHARACTER*12 ICURS2
38107      CHARACTER*4 IERRF2
38108      CHARACTER*4 IENDF2
38109      CHARACTER*4 IREWI2
38110C
38111CCCCC CHARACTER*80 IFILE3
38112      CHARACTER (LEN=MAXFNC) :: IFILE3
38113      CHARACTER*12 ISTAT3
38114      CHARACTER*12 IFORM3
38115      CHARACTER*12 IACCE3
38116      CHARACTER*12 IPROT3
38117      CHARACTER*12 ICURS3
38118      CHARACTER*4 IERRF3
38119      CHARACTER*4 IENDF3
38120      CHARACTER*4 IREWI3
38121C
38122CCCCC CHARACTER*80 IFILE4
38123      CHARACTER (LEN=MAXFNC) :: IFILE4
38124      CHARACTER*12 ISTAT4
38125      CHARACTER*12 IFORM4
38126      CHARACTER*12 IACCE4
38127      CHARACTER*12 IPROT4
38128      CHARACTER*12 ICURS4
38129      CHARACTER*4 IERRF4
38130      CHARACTER*4 IENDF4
38131      CHARACTER*4 IREWI4
38132C
38133CCCCC CHARACTER*80 IFILE5
38134      CHARACTER (LEN=MAXFNC) :: IFILE5
38135      CHARACTER*12 ISTAT5
38136      CHARACTER*12 IFORM5
38137      CHARACTER*12 IACCE5
38138      CHARACTER*12 IPROT5
38139      CHARACTER*12 ICURS5
38140      CHARACTER*4 IERRF5
38141      CHARACTER*4 IENDF5
38142      CHARACTER*4 IREWI5
38143C
38144      COMMON/FILTMP/IFILE1, ISTAT1, IFORM1, IACCE1, IPROT1, ICURS1,
38145     1              IERRF1, IENDF1, IREWI1,
38146     1              IFILE2, ISTAT2, IFORM2, IACCE2, IPROT2, ICURS2,
38147     1              IERRF2, IENDF2, IREWI2,
38148     1              IFILE3, ISTAT3, IFORM3, IACCE3, IPROT3, ICURS3,
38149     1              IERRF3, IENDF3, IREWI3,
38150     1              IFILE4, ISTAT4, IFORM4, IACCE4, IPROT4, ICURS4,
38151     1              IERRF4, IENDF4, IREWI4,
38152     1              IFILE5, ISTAT5, IFORM5, IACCE5, IPROT5, ICURS5,
38153     1              IERRF5, IENDF5, IREWI5
38154C
38155C---------------------------------------------------------------------
38156C
38157C-----COMMON----------------------------------------------------------
38158C
38159      INCLUDE 'DPCOHK.INC'
38160      INCLUDE 'DPCODA.INC'
38161      INCLUDE 'DPCOF2.INC'
38162      INCLUDE 'DPCOST.INC'
38163      INCLUDE 'DPCOP2.INC'
38164C
38165C-----START POINT-----------------------------------------------------
38166C
38167      ISUBN1='DPST'
38168      ISUBN2='VA  '
38169      IERROR='NO'
38170      IFILQ2=IFILQU
38171C
38172      ILOC3=0
38173C
38174      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')THEN
38175        WRITE(ICOUT,999)
38176  999   FORMAT(1X)
38177        CALL DPWRST('XXX','BUG ')
38178        WRITE(ICOUT,51)
38179   51   FORMAT('***** AT THE BEGINNING OF DPSTVA--')
38180        CALL DPWRST('XXX','BUG ')
38181        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMARG
38182   52   FORMAT('IBUGA3,ISUBRO,NUMARG = ',2(A4,2X),I8)
38183        CALL DPWRST('XXX','BUG ')
38184        IF(NUMARG.GE.1)THEN
38185          DO70I=1,NUMARG
38186            WRITE(ICOUT,76)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
38187   76       FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
38188     1             I8,2X,2A4,2X,A4,2X,I8)
38189            CALL DPWRST('XXX','BUG ')
38190   70     CONTINUE
38191        ENDIF
38192      ENDIF
38193C
38194C               **********************************
38195C               **  STEP 1--                    **
38196C               **  INITIALIZE SOME VARIABLES.  **
38197C               **********************************
38198C
38199      ISTEPN='1'
38200      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STVA')
38201     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38202C
38203      ISTR=' '
38204      ISTR2=' '
38205C
38206C               ******************************************************
38207C               **  STEP 2--                                         *
38208C               **  EXAMINE THE ARGUMENT ON THE LEFT-HAND SIDE       *
38209C               ******************************************************
38210C
38211      ISTEPN='2'
38212      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STVA')
38213     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38214C
38215      IHLEFT=IHARG(1)
38216      IHLEF2=IHARG2(1)
38217C
38218C     AS THIS VARIABLE WILL BE SAVED IN THE DPZCHF.DAT FILE AND NOT THE
38219C     INTERNAL NAME TABLE, CHECK THE DPZCHF.DAT FILE FOR AN EXISTING NAME.
38220C
38221      IOUNI4=IZCHNU
38222      IFILE4=IZCHNA
38223      ISTAT4=IZCHST
38224      IFORM4=IZCHFO
38225      IACCE4=IZCHAC
38226      IPROT4=IZCHPR
38227      ICURS4=IZCHCS
38228C
38229C     IF "SET STRING VARIABLE OVERWRITE" ENTERED, THEN ALSO
38230C     SET DPZCHF.DAT AS "NOT EXIST".
38231C
38232      IF(ISTRVA.EQ.'OVER')THEN
38233        IEXIST='NO'
38234      ELSE
38235        IERRFI='NO'
38236        ISUBN0='STVA'
38237        IERRFI='NO'
38238        CALL DPINFI(IFILE4,IEXIST,IOPEN,IACC,ISUBN0,IBUGA3,
38239     1              ISUBRO,IERROR)
38240       ENDIF
38241C
38242      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')THEN
38243        WRITE(ICOUT,111)IEXIST
38244  111   FORMAT('IEXIST = ',A4)
38245        CALL DPWRST('XXX','BUG ')
38246      ENDIF
38247C
38248      CALL DPOPFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4,
38249     1            IREWI4,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
38250C
38251      IOP='OPEN'
38252      IFLG11=0
38253      IFLG21=1
38254      IFLG31=0
38255      IFLAG4=0
38256      IFLAG5=0
38257      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
38258     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
38259     1            IBUGA3,ISUBRO,IERROR)
38260C
38261      MXROW=0
38262      IVAR=0
38263      IFLAG1=0
38264      IF(IEXIST.EQ.'YES')THEN
38265        READ(IOUNI4,*,ERR=210,END=210)IVAR
38266        IFLAG1=1
38267      ENDIF
38268      GOTO300
38269C
38270  210 CONTINUE
38271      WRITE(ICOUT,999)
38272      CALL DPWRST('XXX','BUG ')
38273      WRITE(ICOUT,211)
38274  211 FORMAT('*****ERROR IN LET ... = CHARACTER VARIABLE (DPSTVA)--')
38275      CALL DPWRST('XXX','BUG ')
38276      WRITE(ICOUT,213)IFILE4
38277  213 FORMAT('     ERROR OR END OF FILE READING FIRST LINE OF ',A80)
38278      CALL DPWRST('XXX','BUG ')
38279      IERROR='YES'
38280      GOTO9000
38281C
38282C               *************************************************
38283C               **  STEP 3--                                   **
38284C               **  PROCESS RIGHT HAND SIDE.                   **
38285C               *************************************************
38286C
38287  300 CONTINUE
38288      ISTEPN='3'
38289      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')
38290     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38291C
38292      JMIN=5
38293      JMAX=NUMARG
38294C
38295      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')THEN
38296        WRITE(ICOUT,4001)JMIN,JMAX,MAXIND
38297 4001   FORMAT('JMIN,JMAX,MAXIND = ',3I8)
38298        CALL DPWRST('XXX','BUG ')
38299      ENDIF
38300C
38301      IF(JMAX.LT.JMIN)THEN
38302        WRITE(ICOUT,999)
38303        CALL DPWRST('XXX','BUG ')
38304        WRITE(ICOUT,211)
38305        CALL DPWRST('XXX','BUG ')
38306        WRITE(ICOUT,301)
38307  301   FORMAT('     NO STRINGS ON THE RIGHT HAND SIDE.')
38308        CALL DPWRST('XXX','BUG ')
38309        IERROR='YES'
38310        GOTO9000
38311      ENDIF
38312      IWRITE='OFF'
38313      IERROR='NO'
38314C
38315      CALL EXTSTR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXIND,
38316     1            IHNAME,IHNAM2,IUSE,NUMNAM,
38317     1            ISTRN1,ISTRN2,NUMSTR,
38318     1            IWRITE,IBUGA3,ISUBRO,IERROR)
38319C
38320      IF(IERROR.EQ.'NO')THEN
38321        ICASE='STRI'
38322      ELSE
38323        ICASE='LITE'
38324      ENDIF
38325C
38326      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')THEN
38327        WRITE(ICOUT,303)IERROR,ICASE,NUMSTR
38328  303   FORMAT('AFTER CALL EXTSTR: IERROR,ICASE,NUMSTR = ',2(A4,2X),I8)
38329        CALL DPWRST('XXX','BUG ')
38330      ENDIF
38331C
38332C     STEP 1: DETERMINE NUMBER OF STRINGS FOR LITERAL CASE
38333C
38334      IF(ICASE.EQ.'LITE')THEN
38335        ICNT=0
38336        NUMSTR=0
38337        IFRST=5
38338        IFILQU='ON'
38339        ISTRIN=' '
38340        DO318I=1,IWIDTH
38341          ISTRIN(I:I)=IANSLC(I)(1:1)
38342  318   CONTINUE
38343C
38344  320   CONTINUE
38345        IFRST=IFRST+1
38346        ICNT=ICNT+1
38347        ISTART=1
38348        ISTOP=IWIDTH
38349        IERROR='NO'
38350        CALL DPEXWO(ISTRIN,ISTART,ISTOP,IFRST,
38351     1              ICOL1,ICOL2,ISTRI2,NCSTR2,
38352     1              IBUGA3,ISUBRO,IERROR)
38353        IF(NCSTR2.GT.0)THEN
38354          NUMSTR=NUMSTR+1
38355          IF(ICOL2.LT.IWIDTH)GOTO320
38356        ENDIF
38357      ENDIF
38358C
38359C     STEP 2: UPDATE HEADER FOR DPZCHF.DAT FILE AND WRITE TO dpst2f.dat
38360C
38361      IVARSV=IVAR
38362      IVAR=IVAR+1
38363      NTEMP1=25*IVARSV
38364      NTEMP2=25*IVAR
38365      IF(NTEMP2.GT.9999)THEN
38366        WRITE(ICOUT,999)
38367        CALL DPWRST('XXX','BUG ')
38368        WRITE(ICOUT,211)
38369        CALL DPWRST('XXX','BUG ')
38370        WRITE(ICOUT,331)
38371  331   FORMAT('      MAXIMUM NUMBER OF CHARACTER VARIABLES EXCEEDED.')
38372        CALL DPWRST('XXX','BUG ')
38373        IERROR='YES'
38374        GOTO9000
38375      ENDIF
38376C
38377      IF(IEXIST.EQ.'YES')THEN
38378        REWIND(IOUNI4)
38379        READ(IOUNI4,*,ERR=897,END=897)IJUNK
38380        WRITE(IOUNI2,'(I8)')IVAR
38381        DO330KK=1,IVARSV
38382          READ(IOUNI4,'(2A4,I10)',ERR=897,END=897)IHRIGH,IHRIG2,NTEMP
38383          WRITE(IOUNI2,'(2A4,I10)')IHRIGH,IHRIG2,NTEMP
38384          IF(NTEMP.GT.MXROW)MXROW=NTEMP
38385  330   CONTINUE
38386        WRITE(IOUNI2,'(2A4,I10)')IHLEFT,IHLEF2,NUMSTR
38387        IF(NUMSTR.GT.MXROW)MXROW=NUMSTR
38388      ELSE
38389        WRITE(IOUNI2,'(I8)')IVAR
38390        WRITE(IOUNI2,'(2A4,I10)')IHLEFT,IHLEF2,NUMSTR
38391        IFLAG2=1
38392        MXROW=NUMSTR
38393      ENDIF
38394C
38395C     STEP 3: NOW LOOP THROUGH THE ROWS OF THE STRING VARIABLES
38396C
38397      IFRMT=' '
38398      IFRMT='(A    )'
38399      WRITE(IFRMT(3:6),'(I4)')NTEMP1
38400      IFRMT2=' '
38401      IFRMT2='(A    ,A25)'
38402      WRITE(IFRMT2(3:6),'(I4)')NTEMP1
38403C
38404      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')THEN
38405        WRITE(ICOUT,313)MXROW
38406  313   FORMAT('MXROW = ',I8)
38407        CALL DPWRST('XXX','BUG ')
38408      ENDIF
38409C
38410      IF(ICASE.EQ.'STRI')THEN
38411C
38412C       STEP 3A: ARGUMENTS ON RHS ARE NAMES OF PRE-EXISTING STRINGS
38413C
38414        DO360I2=1,MXROW
38415          ILAST=0
38416          ISTR2=' '
38417          NH=0
38418          IF(I2.GT.NUMSTR)GOTO379
38419          DO365I=1,NUMNAM
38420            II=I
38421            IF(ISTRN1(I2).EQ.IHNAME(I) .AND.
38422     1         ISTRN2(I2).EQ.IHNAM2(I) .AND. IUSE(I).EQ.'F')GOTO369
38423  365     CONTINUE
38424C
38425          WRITE(ICOUT,999)
38426          CALL DPWRST('XXX','BUG ')
38427          WRITE(ICOUT,211)
38428          CALL DPWRST('XXX','BUG ')
38429          WRITE(ICOUT,373)ISTRN1(I2),ISTRN2(I2)
38430  373     FORMAT('       STRING ',2A4,' NOT MATCHED IN NAME ',
38431     1           'TABLE AS A PRE-EXISTING STRING.')
38432          CALL DPWRST('XXX','BUG ')
38433          IERROR='YES'
38434          GOTO9000
38435C
38436  369     CONTINUE
38437          IVAL=IVALUE(II)
38438          VAL=VALUE(II)
38439          IL1=IVSTAR(II)
38440          IL2=IVSTOP(II)
38441C
38442          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')THEN
38443            WRITE(ICOUT,381)IL1,IL2
38444  381       FORMAT('II,IL1,IL2 = ',3I8)
38445            CALL DPWRST('XXX','BUG ')
38446          ENDIF
38447C
38448          CALL DPCOFH(IL1,IL2,IFUNC,NUMCHF,IHTEMP,NH,IBUGA3,IERROR)
38449          ISTRT=NH
38450          DO382LL=1,NH
38451            IF(IHTEMP(LL)(1:1).NE.' ')THEN
38452              ISTRT=LL
38453              GOTO383
38454            ENDIF
38455  382     CONTINUE
38456  383     CONTINUE
38457C
38458  379     CONTINUE
38459C
38460          IF(NH.GT.0)THEN
38461            DO390J=ISTRT,NH
38462              ILAST=ILAST+1
38463              ISTR2(ILAST:ILAST)=IHTEMP(J)(1:1)
38464  390       CONTINUE
38465            IF(ILAST.GT.25)ILAST=25
38466C
38467            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')THEN
38468              WRITE(ICOUT,394)I2,ILAST,ISTR2(1:ILAST)
38469  394         FORMAT('I2,ILAST,ISTR2(1:ILAST) = ',2I8,A25)
38470              CALL DPWRST('XXX','BUG ')
38471            ENDIF
38472          ENDIF
38473C
38474          IF(I2.LE.NUMSTR)THEN
38475            ISTR=' '
38476            IF(IEXIST.EQ.'YES')THEN
38477              READ(IOUNI4,IFRMT,ERR=897,END=897)ISTR(1:NTEMP1)
38478              WRITE(IOUNI2,IFRMT2)ISTR(1:NTEMP1),ISTR2(1:25)
38479            ELSE
38480              WRITE(IOUNI2,'(A25)')ISTR2(1:25)
38481            ENDIF
38482          ELSE
38483            ISTR=' '
38484            IF(IEXIST.EQ.'YES')THEN
38485              READ(IOUNI4,IFRMT,ERR=897,END=897)ISTR(1:NTEMP1)
38486              WRITE(IOUNI2,IFRMT2)ISTR(1:NTEMP1),ISTR2(1:25)
38487            ELSE
38488              WRITE(IOUNI2,'(A25)')ISTR2(1:25)
38489            ENDIF
38490          ENDIF
38491  360   CONTINUE
38492      ELSE
38493C
38494C       STEP 3B: ARGUMENTS ON RHS ARE LITERAL STRINGS
38495C
38496        ICNT=0
38497        IFRST=5
38498        MESSAG='OFF'
38499        ISTRIN=' '
38500        DO418I=1,IWIDTH
38501          ISTRIN(I:I)=IANSLC(I)(1:1)
38502  418   CONTINUE
38503C
38504        DO460I2=1,MXROW
38505C
38506          ISTR2=' '
38507          IF(I2.LE.NUMSTR)THEN
38508            IFRST=IFRST+1
38509            ICNT=ICNT+1
38510            ISTART=1
38511            ISTOP=IWIDTH
38512            IERROR='NO'
38513            CALL DPEXWO(ISTRIN,ISTART,ISTOP,IFRST,
38514     1                  ICOL1,ICOL2,ISTRI2,NCSTR2,
38515     1                  IBUGA3,ISUBRO,IERROR)
38516            ILAST=MIN(25,NCSTR2)
38517            IF(ILAST.GT.0)THEN
38518              IF(ISTRI2(1:1).EQ.'"' .AND.
38519     1           ISTRI2(ILAST:ILAST).EQ.'"')THEN
38520                ISTR2(1:ILAST-2)=ISTRI2(2:ILAST-1)
38521                ILAST=ILAST-2
38522              ELSEIF(ISTRI2(1:1).EQ.'"')THEN
38523                ISTR2(1:ILAST-1)=ISTRI2(2:ILAST)
38524                ILAST=ILAST-1
38525              ELSE
38526                ISTR2(1:ILAST)=ISTRI2(1:ILAST)
38527              ENDIF
38528            ENDIF
38529C
38530            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')THEN
38531              WRITE(ICOUT,394)I2,ILAST,ISTR2(1:ILAST)
38532              CALL DPWRST('XXX','BUG ')
38533            ENDIF
38534          ENDIF
38535C
38536          IF(I2.LE.NUMSTR)THEN
38537            ISTR=' '
38538            IF(IEXIST.EQ.'YES')THEN
38539              READ(IOUNI4,IFRMT,ERR=897,END=897)ISTR(1:NTEMP1)
38540              WRITE(IOUNI2,IFRMT2)ISTR(1:NTEMP1),ISTR2(1:25)
38541            ELSE
38542              WRITE(IOUNI2,'(A25)')ISTR2(1:25)
38543            ENDIF
38544          ELSE
38545            ISTR=' '
38546            IF(IEXIST.EQ.'YES')THEN
38547              READ(IOUNI4,IFRMT,ERR=897,END=897)ISTR(1:NTEMP1)
38548              WRITE(IOUNI2,IFRMT2)ISTR(1:NTEMP1),ISTR2(1:25)
38549            ELSE
38550              WRITE(IOUNI2,'(A25)')ISTR2(1:25)
38551            ENDIF
38552          ENDIF
38553  460   CONTINUE
38554        GOTO499
38555      ENDIF
38556C
38557C               *****************************************************
38558C               **  STEP 4--                                       **
38559C               **  NOW COPY dpst2f.dat TO dpzchf.dat              **
38560C               *****************************************************
38561C
38562  499 CONTINUE
38563      CALL DPCLFI(IOUNI4,IFILE4,ISTAT4,IFORM4,IACCE4,IPROT4,ICURS4,
38564     1            IENDF4,IREWI4,ISUBN0,IERRFI,IBUGA3,ISUBRO,IERROR)
38565      IZCHCS='CLOSED'
38566C
38567      IOP='CLOS'
38568      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
38569     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
38570     1            IBUGA3,ISUBRO,IERROR)
38571C
38572C      STEP 4B: COPY "dpst2f.dat" TO CHARACTER VARIABLE FILE
38573C
38574      CALL COPYFI(IFILE2,IFILE4,IBUGA3,ISUBRO,IERROR)
38575C
38576C               *****************************************************
38577C               **  STEP 5--                                       **
38578C               **  PRINT FEEDBACK MESSAGE                         **
38579C               *****************************************************
38580C
38581      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
38582        WRITE(ICOUT,999)
38583        CALL DPWRST('XXX','BUG ')
38584        WRITE(ICOUT,501)IHLEFT,IHLEF2
38585  501   FORMAT('THE NAME ',A4,A4,' HAS BEEN ADDED TO THE CHARACTER ',
38586     1         'VARIABLE LIST')
38587        CALL DPWRST('XXX','BUG ')
38588        WRITE(ICOUT,503)IZCHNA
38589  503   FORMAT('IN FILE ',A80)
38590        CALL DPWRST('XXX','BUG ')
38591        WRITE(ICOUT,999)
38592        CALL DPWRST('XXX','BUG ')
38593      ENDIF
38594      GOTO9000
38595C
38596C     ERROR OR END OF FILE READING dpzchf.dat
38597C
38598  897 CONTINUE
38599      WRITE(ICOUT,999)
38600      CALL DPWRST('XXX','BUG ')
38601      WRITE(ICOUT,211)
38602      CALL DPWRST('XXX','BUG ')
38603      WRITE(ICOUT,898)
38604  898 FORMAT('      ERROR READING THE CHARACTER VARIABLE FILE.')
38605      CALL DPWRST('XXX','BUG ')
38606      IERROR='YES'
38607      GOTO499
38608C
38609C               ****************
38610C               **  STEP 90-- **
38611C               **  EXIT.     **
38612C               ****************
38613C
38614 9000 CONTINUE
38615      IFILQU=IFILQ2
38616      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVA')THEN
38617        WRITE(ICOUT,999)
38618        CALL DPWRST('XXX','BUG ')
38619        WRITE(ICOUT,9011)
38620 9011   FORMAT('***** AT THE END       OF DPSTVA--')
38621        CALL DPWRST('XXX','BUG ')
38622        WRITE(ICOUT,9013)IERROR
38623 9013   FORMAT('IERROR = ',A4)
38624        CALL DPWRST('XXX','BUG ')
38625      ENDIF
38626C
38627      RETURN
38628      END
38629      SUBROUTINE DPSTVS(ISUBRO,IBUGA3,IERROR)
38630C
38631C     PURPOSE--CONVERT A VECTOR OF INTEGERS TO A STRING.  FOR EXAMPLE,
38632C              GIVEN A VECTOR THAT CONTAINS THE VALUES 2, 3, AND 5,
38633C              CREATE A STRING THAT CONTAINS "X2*X3*X5".  THIS IS
38634C              USED BY THE 10-STEP ANALYSIS OF FACTORIAL DESIGNS.
38635C
38636C     EXAMPLE--LET SOUT = DIGITS TO STRING Y
38637C     WRITTEN BY--ALAN HECKERT
38638C                 STATISTICAL ENGINEERING DIVISION
38639C                 INFORMATION TECHNOLOGY LABORATORY
38640C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
38641C                 GAITHERSBURG, MD 20899-8980
38642C                 PHONE--301-975-2899
38643C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
38644C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
38645C     LANGUAGE--ANSI FORTRAN (1977)
38646C     VERSION NUMBER--2015/03
38647C     ORIGINAL VERSION--MARCH     2015.
38648C
38649C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
38650C
38651      CHARACTER*4 ISUBRO
38652      CHARACTER*4 IBUGA3
38653      CHARACTER*4 IERROR
38654C
38655      CHARACTER*4 NEWNAM
38656      CHARACTER*4 NEWNA2
38657      CHARACTER*4 NEWCOL
38658      CHARACTER*4 NEWCO2
38659      CHARACTER*4 ICASEL
38660      CHARACTER*4 ICASE2
38661      CHARACTER*4 IHLEFT
38662      CHARACTER*4 IHLEF2
38663      CHARACTER*4 IHRIGH
38664      CHARACTER*4 IHRIG2
38665      CHARACTER*4 ISUBN1
38666      CHARACTER*4 ISUBN2
38667      CHARACTER*4 ISTEPN
38668      CHARACTER*10 ICSTR
38669C
38670      CHARACTER*4 ILAB(10)
38671C
38672C---------------------------------------------------------------------
38673C
38674C-----COMMON----------------------------------------------------------
38675C
38676      INCLUDE 'DPCOPA.INC'
38677      INCLUDE 'DPCOHK.INC'
38678      INCLUDE 'DPCODA.INC'
38679      INCLUDE 'DPCOP2.INC'
38680C
38681C-----START POINT-----------------------------------------------------
38682C
38683      ISUBN1='DPST'
38684      ISUBN2='VS  '
38685      IERROR='NO'
38686C
38687      ILOC3=0
38688      MAXCP1=MAXCOL+1
38689      MAXCP2=MAXCOL+2
38690      MAXCP3=MAXCOL+3
38691      MAXCP4=MAXCOL+4
38692      MAXCP5=MAXCOL+5
38693      MAXCP6=MAXCOL+6
38694      AVAL=0.0
38695C
38696      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVS')THEN
38697        WRITE(ICOUT,999)
38698        CALL DPWRST('XXX','BUG ')
38699        WRITE(ICOUT,51)
38700   51   FORMAT('***** AT THE BEGINNING OF DPSTVS--')
38701        CALL DPWRST('XXX','BUG ')
38702        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
38703   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',2(A4,2X),I8)
38704        CALL DPWRST('XXX','BUG ')
38705        DO55I=1,NUMNAM
38706          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
38707     1                   IVSTOP(I)
38708   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
38709     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
38710          CALL DPWRST('XXX','BUG ')
38711   55   CONTINUE
38712        WRITE(ICOUT,57)NUMCHF,MAXCHF
38713   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
38714        CALL DPWRST('XXX','BUG ')
38715        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
38716   60   FORMAT('IFUNC(.)  = ',120A1)
38717        CALL DPWRST('XXX','BUG ')
38718      ENDIF
38719C
38720C               **********************************
38721C               **  STEP 1--                    **
38722C               **  INITIALIZE SOME VARIABLES.  **
38723C               **********************************
38724C
38725      ISTEPN='1'
38726      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STVS')
38727     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38728C
38729      NEWNAM='NO'
38730      NEWNA2='NO'
38731      NEWCOL='NO'
38732      NEWCO2='NO'
38733      ICASEL='UNKN'
38734      ICASE2='UNKN'
38735      NIOLD1=0
38736      NIOLD2=0
38737      ICOLL=0
38738      ICOL2=0
38739C
38740C               ******************************************************
38741C               **  STEP 2--                                         *
38742C               **  EXAMINE THE ARGUMENT ON THE                      *
38743C               **  LEFT-HAND SIDE--                                 *
38744C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
38745C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
38746C               ******************************************************
38747C
38748      ISTEPN='2'
38749      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STVS')
38750     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38751C
38752      IHLEFT=IHARG(1)
38753      IHLEF2=IHARG2(1)
38754C
38755      DO2000I=1,NUMNAM
38756        I2=I
38757        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
38758          IF(IUSE(I2).EQ.'F')THEN
38759            ICASEL='STRI'
38760            ILISTL=I2
38761            GOTO2299
38762          ELSE
38763            WRITE(ICOUT,999)
38764  999       FORMAT(1X)
38765            CALL DPWRST('XXX','BUG ')
38766            WRITE(ICOUT,2001)
38767 2001       FORMAT('***** ERROR IN DIGITS TO STRING--')
38768            CALL DPWRST('XXX','BUG ')
38769            WRITE(ICOUT,2003)IHLEFT,IHLEF2
38770 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
38771     1             A4,A4,')')
38772            CALL DPWRST('XXX','BUG ')
38773            WRITE(ICOUT,2005)
38774 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
38775            CALL DPWRST('XXX','BUG ')
38776            IERROR='YES'
38777            GOTO9000
38778          ENDIF
38779        ENDIF
38780 2000 CONTINUE
38781C
38782      NEWNAM='YES'
38783      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
38784C
38785      ILISTL=NUMNAM+1
38786      IF(ILISTL.GT.MAXNAM)THEN
38787        WRITE(ICOUT,999)
38788        CALL DPWRST('XXX','BUG ')
38789        WRITE(ICOUT,2001)
38790        CALL DPWRST('XXX','BUG ')
38791        WRITE(ICOUT,2202)
38792 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
38793     1         'FUNCTION')
38794        CALL DPWRST('XXX','BUG ')
38795        WRITE(ICOUT,2203)MAXNAM
38796 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
38797        CALL DPWRST('XXX','BUG ')
38798        WRITE(ICOUT,2204)
38799 2204   FORMAT('      ENTER      STATUS')
38800        CALL DPWRST('XXX','BUG ')
38801        WRITE(ICOUT,2205)
38802 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
38803        CALL DPWRST('XXX','BUG ')
38804        WRITE(ICOUT,2206)
38805 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
38806     1         'USED NAMES.')
38807        CALL DPWRST('XXX','BUG ')
38808        IERROR='YES'
38809        GOTO9000
38810      ENDIF
38811C
38812 2299 CONTINUE
38813C
38814C               *****************************************************
38815C               **  STEP 3--                                       **
38816C               **  EXTRACT THE NAME ON THE RIGHT HAND SIDE        **
38817C               *****************************************************
38818C
38819      ISTEPN='3A'
38820      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STVS')
38821     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38822C
38823      NINDX=6
38824      IF(NUMARG.LT.NINDX)THEN
38825        WRITE(ICOUT,999)
38826        CALL DPWRST('XXX','BUG ')
38827        WRITE(ICOUT,2001)
38828        CALL DPWRST('XXX','BUG ')
38829        WRITE(ICOUT,3001)
38830 3001   FORMAT('      NO VARIABLE GIVEN ON THE RIGHT HAND SIDE.')
38831        CALL DPWRST('XXX','BUG ')
38832        IERROR='YES'
38833        GOTO9000
38834      ENDIF
38835C
38836      IHRIGH=IHARG(NINDX)
38837      IHRIG2=IHARG2(NINDX)
38838C
38839      DO3000I=1,NUMNAM
38840        I4=I
38841        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
38842          IF(IUSE(I4).NE.'V')THEN
38843            WRITE(ICOUT,999)
38844            CALL DPWRST('XXX','BUG ')
38845            WRITE(ICOUT,2001)
38846            CALL DPWRST('XXX','BUG ')
38847            WRITE(ICOUT,3003)IHRIGH,IHRIG2
38848 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
38849     1             A4,A4,')')
38850            CALL DPWRST('XXX','BUG ')
38851            WRITE(ICOUT,3005)
38852 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A VARIABLE.')
38853            CALL DPWRST('XXX','BUG ')
38854            IERROR='YES'
38855            GOTO9000
38856          ELSE
38857            NLEN=IN(I4)
38858            ICOLR=IVALUE(I4)
38859            GOTO3099
38860          ENDIF
38861        ENDIF
38862 3000 CONTINUE
38863C
38864      WRITE(ICOUT,999)
38865      CALL DPWRST('XXX','BUG ')
38866      WRITE(ICOUT,2001)
38867      CALL DPWRST('XXX','BUG ')
38868      WRITE(ICOUT,3003)IHRIGH,IHRIG2
38869      CALL DPWRST('XXX','BUG ')
38870      WRITE(ICOUT,3015)
38871 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
38872      CALL DPWRST('XXX','BUG ')
38873      IERROR='YES'
38874      GOTO9000
38875C
38876 3099 CONTINUE
38877C
38878C               *****************************************************
38879C               **  STEP 4--                                       **
38880C               **  EXTRACT VARIABLE AND CONVERT TO STRING         **
38881C               *****************************************************
38882C
38883      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STVS')THEN
38884        ISTEPN='4A'
38885        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38886        WRITE(ICOUT,4011)NLEN,ICASEL
38887 4011   FORMAT('NLEN1,ICASEL = ',I8,2X,A4)
38888        CALL DPWRST('XXX','BUG ')
38889      ENDIF
38890C
38891      ICNT=0
38892      J=0
38893C
38894      DO4016I=1,NLEN
38895C
38896        J=J+1
38897        IJ=MAXN*(ICOLR-1)+I
38898        IF(ICOLR.LE.MAXCOL)AVAL=V(IJ)
38899        IF(ICOLR.EQ.MAXCP1)AVAL=PRED(I)
38900        IF(ICOLR.EQ.MAXCP2)AVAL=RES(I)
38901        IF(ICOLR.EQ.MAXCP3)AVAL=YPLOT(I)
38902        IF(ICOLR.EQ.MAXCP4)AVAL=XPLOT(I)
38903        IF(ICOLR.EQ.MAXCP5)AVAL=X2PLOT(I)
38904        IF(ICOLR.EQ.MAXCP6)AVAL=TAGPLO(I)
38905C
38906        IVALT=INT(ABS(AVAL+0.5))
38907        ICNT=ICNT+1
38908        IFUNC2(ICNT)(1:1)='X'
38909        IF(IVALT.GE.0 .AND. IVALT.LE.9)THEN
38910          ICNT=ICNT+1
38911          WRITE(IFUNC2(ICNT)(1:1),'(I1)')IVALT
38912        ELSEIF(IVALT.GE.10 .AND. IVALT.LE.99)THEN
38913          WRITE(ICSTR(1:2),'(I2)')IVALT
38914          ICNT=ICNT+1
38915          IFUNC2(ICNT)(1:1)=ICSTR(1:1)
38916          ICNT=ICNT+1
38917          IFUNC2(ICNT)(1:1)=ICSTR(2:2)
38918        ELSEIF(IVALT.GE.100 .AND. IVALT.LE.999)THEN
38919          WRITE(ICSTR(1:3),'(I3)')IVALT
38920          ICNT=ICNT+1
38921          IFUNC2(ICNT)(1:1)=ICSTR(1:1)
38922          ICNT=ICNT+1
38923          IFUNC2(ICNT)(1:1)=ICSTR(2:2)
38924          ICNT=ICNT+1
38925          IFUNC2(ICNT)(1:1)=ICSTR(3:3)
38926        ELSEIF(IVALT.GE.1000 .AND. IVALT.LE.9999)THEN
38927          WRITE(ICSTR(1:4),'(I4)')IVALT
38928          ICNT=ICNT+1
38929          IFUNC2(ICNT)(1:1)=ICSTR(1:1)
38930          ICNT=ICNT+1
38931          IFUNC2(ICNT)(1:1)=ICSTR(2:2)
38932          ICNT=ICNT+1
38933          IFUNC2(ICNT)(1:1)=ICSTR(3:3)
38934          ICNT=ICNT+1
38935          IFUNC2(ICNT)(1:1)=ICSTR(4:4)
38936        ELSEIF(IVALT.GE.10000 .AND. IVALT.LE.99999)THEN
38937          WRITE(ICSTR(1:5),'(I5)')IVALT
38938          ICNT=ICNT+1
38939          IFUNC2(ICNT)(1:1)=ICSTR(1:1)
38940          ICNT=ICNT+1
38941          IFUNC2(ICNT)(1:1)=ICSTR(2:2)
38942          ICNT=ICNT+1
38943          IFUNC2(ICNT)(1:1)=ICSTR(3:3)
38944          ICNT=ICNT+1
38945          IFUNC2(ICNT)(1:1)=ICSTR(4:4)
38946          ICNT=ICNT+1
38947          IFUNC2(ICNT)(1:1)=ICSTR(5:5)
38948        ELSEIF(IVALT.GE.100000 .AND. IVALT.LE.999999)THEN
38949          WRITE(ICSTR(1:5),'(I6)')IVALT
38950          ICNT=ICNT+1
38951          IFUNC2(ICNT)(1:1)=ICSTR(1:1)
38952          ICNT=ICNT+1
38953          IFUNC2(ICNT)(1:1)=ICSTR(2:2)
38954          ICNT=ICNT+1
38955          IFUNC2(ICNT)(1:1)=ICSTR(3:3)
38956          ICNT=ICNT+1
38957          IFUNC2(ICNT)(1:1)=ICSTR(4:4)
38958          ICNT=ICNT+1
38959          IFUNC2(ICNT)(1:1)=ICSTR(5:5)
38960          ICNT=ICNT+1
38961          IFUNC2(ICNT)(1:1)=ICSTR(6:6)
38962        ENDIF
38963C
38964        IF(I.LT.NLEN)THEN
38965          ICNT=ICNT+1
38966          IFUNC2(ICNT)(1:1)='*'
38967        ENDIF
38968C
38969 4016 CONTINUE
38970C
38971C               *****************************************************
38972C               **  STEP 5--                                       **
38973C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
38974C               *****************************************************
38975C
38976C
38977      ISTEPN='5'
38978      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STVS')
38979     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
38980C
38981      CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
38982     1            NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
38983     1            NEWNAM,MAXNAM,
38984     1            IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
38985      IF(IERROR.EQ.'YES')GOTO9000
38986C
38987      IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
38988        WRITE(ICOUT,999)
38989        CALL DPWRST('XXX','BUG ')
38990        WRITE(ICOUT,8606)IHLEFT,IHLEF2
38991 8606   FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
38992        CALL DPWRST('XXX','BUG ')
38993        ILAB(1)='TO T'
38994        ILAB(2)='HE F'
38995        ILAB(3)='UNCT'
38996        ILAB(4)='ION '
38997        ILAB(5)='    '
38998        ILAB(6)=' -- '
38999        NUMWDL=6
39000        CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
39001C
39002        WRITE(ICOUT,999)
39003        CALL DPWRST('XXX','BUG ')
39004C
39005      ENDIF
39006C
39007C
39008C               ****************
39009C               **  STEP 90-- **
39010C               **  EXIT.     **
39011C               ****************
39012C
39013 9000 CONTINUE
39014      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STVS')THEN
39015        WRITE(ICOUT,999)
39016        CALL DPWRST('XXX','BUG ')
39017        WRITE(ICOUT,9011)
39018 9011   FORMAT('***** AT THE END       OF DPSTVS--')
39019        CALL DPWRST('XXX','BUG ')
39020        WRITE(ICOUT,9013)NUMNAM
39021 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
39022        CALL DPWRST('XXX','BUG ')
39023        DO9015I=1,NUMNAM
39024          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
39025     1                     IVSTAR(I),IVSTOP(I)
39026 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
39027     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
39028          CALL DPWRST('XXX','BUG ')
39029 9015   CONTINUE
39030      ENDIF
39031C
39032      RETURN
39033      END
39034      SUBROUTINE DPSTWD(ISUBRO,IBUGA3,IERROR)
39035C
39036C     PURPOSE--EXTRACT A SPECIFIED WORD OF A STRING.
39037C     EXAMPLE--LET SOUT = STRING WORD SIN INDEX
39038C     WRITTEN BY--ALAN HECKERT
39039C                 STATISTICAL ENGINEERING DIVISION
39040C                 INFORMATION TECHNOLOGY LABORATORY
39041C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
39042C                 GAITHERSBURG, MD 20899-8980
39043C                 PHONE--301-975-2899
39044C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
39045C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
39046C     LANGUAGE--ANSI FORTRAN (1977)
39047C     VERSION NUMBER--2010/10
39048C     ORIGINAL VERSION--OCTOBER   2010.
39049C     UPDATED         --OCTOBER   2014. ADD OPTIONAL THIRD ARGUMENT TO
39050C                                       SPECIFY A DELIMITER
39051C     UPDATED         --MARCH     2015. CALL LIST TO DPINFU
39052C
39053C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
39054C
39055      CHARACTER*4 ISUBRO
39056      CHARACTER*4 IBUGA3
39057      CHARACTER*4 IERROR
39058C
39059      CHARACTER*4 NEWNAM
39060      CHARACTER*4 NEWNA2
39061      CHARACTER*4 NEWCOL
39062      CHARACTER*4 NEWCO2
39063      CHARACTER*4 ICASEL
39064      CHARACTER*4 ICASE2
39065      CHARACTER*4 IHLEFT
39066      CHARACTER*4 IHLEF2
39067      CHARACTER*4 IHRIGH
39068      CHARACTER*4 IHRIG2
39069      CHARACTER*4 IHRI21
39070      CHARACTER*4 IHRI22
39071      CHARACTER*4 ISUBN1
39072      CHARACTER*4 ISUBN2
39073      CHARACTER*4 ISTEPN
39074C
39075      CHARACTER*1 IDELIM
39076C
39077      CHARACTER*4 ILAB(10)
39078C
39079C---------------------------------------------------------------------
39080C
39081C-----COMMON----------------------------------------------------------
39082C
39083      INCLUDE 'DPCOPA.INC'
39084      INCLUDE 'DPCOHK.INC'
39085      INCLUDE 'DPCODA.INC'
39086      INCLUDE 'DPCOP2.INC'
39087C
39088C-----START POINT-----------------------------------------------------
39089C
39090      ISUBN1='DPST'
39091      ISUBN2='WD  '
39092      IERROR='NO'
39093C
39094      ILOC3=0
39095      ISTART=0
39096      ISTOP=0
39097C
39098      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STWD')THEN
39099        WRITE(ICOUT,999)
39100        CALL DPWRST('XXX','BUG ')
39101        WRITE(ICOUT,51)
39102   51   FORMAT('***** AT THE BEGINNING OF DPSTWD--')
39103        CALL DPWRST('XXX','BUG ')
39104        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
39105   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
39106        CALL DPWRST('XXX','BUG ')
39107        DO55I=1,NUMNAM
39108          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
39109     1                   IVSTOP(I)
39110   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
39111     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
39112          CALL DPWRST('XXX','BUG ')
39113   55   CONTINUE
39114        WRITE(ICOUT,57)NUMCHF,MAXCHF,NUMARG
39115   57   FORMAT('NUMCHF,MAXCHF,NUMARG = ',3I8)
39116        CALL DPWRST('XXX','BUG ')
39117        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
39118   60   FORMAT('IFUNC(.)  = ',120A1)
39119        CALL DPWRST('XXX','BUG ')
39120        IF(NUMARG.GE.1)THEN
39121          DO70I=1,NUMARG
39122            WRITE(ICOUT,76)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I)
39123   76       FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I) = ',
39124     1             I8,2X,A4,A4,2X,A4,2X,I8)
39125            CALL DPWRST('XXX','BUG ')
39126   70     CONTINUE
39127        ENDIF
39128      ENDIF
39129C
39130C               **********************************
39131C               **  STEP 1--                    **
39132C               **  INITIALIZE SOME VARIABLES.  **
39133C               **********************************
39134C
39135      ISTEPN='1'
39136      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STWD')
39137     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39138C
39139      NEWNAM='NO'
39140      NEWNA2='NO'
39141      NEWCOL='NO'
39142      NEWCO2='NO'
39143      ICASEL='UNKN'
39144      ICASE2='UNKN'
39145      NIOLD1=0
39146      NIOLD2=0
39147      ICOLL=0
39148      ICOL2=0
39149C
39150C               ******************************************************
39151C               **  STEP 2--                                         *
39152C               **  EXAMINE THE ARGUMENT ON THE                      *
39153C               **  LEFT-HAND SIDE--                                 *
39154C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
39155C               **  BE A STRING    (IF NOT, REPORT AN ERROR).        *
39156C               ******************************************************
39157C
39158      ISTEPN='2'
39159      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STWD')
39160     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39161C
39162      IHLEFT=IHARG(1)
39163      IHLEF2=IHARG2(1)
39164C
39165      DO2000I=1,NUMNAM
39166        I2=I
39167        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
39168          IF(IUSE(I2).EQ.'F')THEN
39169            ICASEL='STRI'
39170            ILISTL=I2
39171            GOTO2299
39172          ELSE
39173            WRITE(ICOUT,999)
39174  999       FORMAT(1X)
39175            CALL DPWRST('XXX','BUG ')
39176            WRITE(ICOUT,2001)
39177 2001       FORMAT('***** ERROR IN STRING WORD--')
39178            CALL DPWRST('XXX','BUG ')
39179            WRITE(ICOUT,2003)IHLEFT,IHLEF2
39180 2003       FORMAT('      THE FIRST NAME ON THE LEFT HAND SIDE (',
39181     1             A4,A4,')')
39182            CALL DPWRST('XXX','BUG ')
39183            WRITE(ICOUT,2005)
39184 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
39185            CALL DPWRST('XXX','BUG ')
39186            IERROR='YES'
39187            GOTO9000
39188          ENDIF
39189        ENDIF
39190 2000 CONTINUE
39191C
39192      NEWNAM='YES'
39193      IF(ICASEL.EQ.'UNKN')ICASEL='STRI'
39194C
39195      ILISTL=NUMNAM+1
39196      IF(ILISTL.GT.MAXNAM)THEN
39197        WRITE(ICOUT,999)
39198        CALL DPWRST('XXX','BUG ')
39199        WRITE(ICOUT,2001)
39200        CALL DPWRST('XXX','BUG ')
39201        WRITE(ICOUT,2202)
39202 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
39203     1         'FUNCTION')
39204        CALL DPWRST('XXX','BUG ')
39205        WRITE(ICOUT,2203)MAXNAM
39206 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
39207        CALL DPWRST('XXX','BUG ')
39208        WRITE(ICOUT,2204)
39209 2204   FORMAT('      ENTER      STATUS')
39210        CALL DPWRST('XXX','BUG ')
39211        WRITE(ICOUT,2205)
39212 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
39213        CALL DPWRST('XXX','BUG ')
39214        WRITE(ICOUT,2206)
39215 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
39216     1         'USED NAMES.')
39217        CALL DPWRST('XXX','BUG ')
39218        IERROR='YES'
39219        GOTO9000
39220      ENDIF
39221C
39222 2299 CONTINUE
39223C
39224C               *****************************************************
39225C               **  STEP 3--                                       **
39226C               **  EXTRACT THE FIRST NAME ON THE RIGHT HAND SIDE  **
39227C               *****************************************************
39228C
39229      ISTEPN='3A'
39230      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STWD')
39231     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39232C
39233      IHRIGH=IHARG(5)
39234      IHRIG2=IHARG2(5)
39235      DO3000I=1,NUMNAM
39236        I4=I
39237        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
39238          IF(IUSE(I4).NE.'F')THEN
39239            WRITE(ICOUT,999)
39240            CALL DPWRST('XXX','BUG ')
39241            WRITE(ICOUT,2001)
39242            CALL DPWRST('XXX','BUG ')
39243            WRITE(ICOUT,3003)IHRIGH,IHRIG2
39244 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
39245     1             A4,A4,')')
39246            CALL DPWRST('XXX','BUG ')
39247            WRITE(ICOUT,3005)
39248 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
39249            CALL DPWRST('XXX','BUG ')
39250            IERROR='YES'
39251            GOTO9000
39252          ELSE
39253            ISTRT1=IVSTAR(I4)
39254            ISTOP1=IVSTOP(I4)
39255            NLEN1=ISTOP1-ISTRT1+1
39256            GOTO3099
39257          ENDIF
39258        ENDIF
39259 3000 CONTINUE
39260C
39261      WRITE(ICOUT,999)
39262      CALL DPWRST('XXX','BUG ')
39263      WRITE(ICOUT,2001)
39264      CALL DPWRST('XXX','BUG ')
39265      WRITE(ICOUT,3003)IHRIGH,IHRIG2
39266      CALL DPWRST('XXX','BUG ')
39267      WRITE(ICOUT,3015)
39268 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
39269      CALL DPWRST('XXX','BUG ')
39270      IERROR='YES'
39271      GOTO9000
39272C
39273 3099 CONTINUE
39274C
39275C               ******************************************************
39276C               **  STEP 3B-                                        **
39277C               **  EXTRACT THE SECOND NAME ON THE RIGHT HAND SIDE. **
39278C               **  THIS SHOULD BE A NUMERIC VALUE.                 **
39279C               ******************************************************
39280C
39281      ISTEPN='3B'
39282      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STWD')
39283     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39284C
39285      IHRI21=IHARG(6)
39286      IHRI22=IHARG2(6)
39287      DO3100I=1,NUMNAM
39288        I4=I
39289        IF(IHRI21.EQ.IHNAME(I).AND.IHRI22.EQ.IHNAM2(I))THEN
39290          IF(IUSE(I4).NE.'P')THEN
39291            WRITE(ICOUT,999)
39292            CALL DPWRST('XXX','BUG ')
39293            WRITE(ICOUT,2001)
39294            CALL DPWRST('XXX','BUG ')
39295            WRITE(ICOUT,3003)IHRI21,IHRI22
39296            CALL DPWRST('XXX','BUG ')
39297            WRITE(ICOUT,3115)
39298 3115       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER.')
39299            CALL DPWRST('XXX','BUG ')
39300            IERROR='YES'
39301            GOTO9000
39302          ELSE
39303            ILISR1=I4
39304            IINDX=IVALUE(ILISR1)
39305            GOTO3199
39306          ENDIF
39307        ENDIF
39308 3100 CONTINUE
39309C
39310      IF(NUMARG.GE.6)THEN
39311        IF(IARGT(6).EQ.'NUMB')THEN
39312          IINDX=IARG(6)
39313          GOTO3199
39314        ENDIF
39315      ENDIF
39316C
39317      WRITE(ICOUT,999)
39318      CALL DPWRST('XXX','BUG ')
39319      WRITE(ICOUT,2001)
39320      CALL DPWRST('XXX','BUG ')
39321      WRITE(ICOUT,3003)IHRI21,IHRI22
39322      CALL DPWRST('XXX','BUG ')
39323      WRITE(ICOUT,3015)
39324      CALL DPWRST('XXX','BUG ')
39325      IERROR='YES'
39326      GOTO9000
39327C
39328 3199 CONTINUE
39329C
39330C               ******************************************************
39331C               **  STEP 3C-                                        **
39332C               **  EXTRACT THE THIRD ARGUMENT ON THE RIGHT HAND    **
39333C               **  SIDE.  THE FIRST CHARACTER WILL BE USED TO      **
39334C               **  DEFINE A DELIMITER.                             **
39335C               ******************************************************
39336C
39337      ISTEPN='3C'
39338      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STWD')
39339     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39340C
39341      IF(NUMARG.GE.7)THEN
39342        IDELIM=IHARG(7)(1:1)
39343        IDELC=ICHAR(IDELIM)
39344      ELSE
39345        IDELIM=' '
39346        IDELC=-1
39347      ENDIF
39348C
39349C               *****************************************************
39350C               **  STEP 4--                                       **
39351C               **  FIND THE WORD BASED ON THE INDEX               **
39352C               *****************************************************
39353C
39354      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STWD')THEN
39355        ISTEPN='4'
39356        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39357        WRITE(ICOUT,4012)IIDX,ISTRT1,ISTOP1,NLEN1
39358 4012   FORMAT('IINDX,ISTRT1,ISTOP1,NLEN1 = ',4I8)
39359        CALL DPWRST('XXX','BUG ')
39360        WRITE(ICOUT,4013)ICASEL
39361 4013   FORMAT('ICASEL = ',A4)
39362        CALL DPWRST('XXX','BUG ')
39363      ENDIF
39364C
39365      IF(IINDX.LT.1 .OR. IINDX.GT.NLEN1)THEN
39366        WRITE(ICOUT,999)
39367        CALL DPWRST('XXX','BUG ')
39368        WRITE(ICOUT,2001)
39369        CALL DPWRST('XXX','BUG ')
39370        WRITE(ICOUT,4021)NLEN1
39371 4021   FORMAT('      THE WORD INDEX IS LESS THAN 1 OR GREATER ',
39372     1         'THAN ',I8)
39373        CALL DPWRST('XXX','BUG ')
39374        WRITE(ICOUT,4023)IINDX
39375 4023   FORMAT('      THE VALUE OF THE WORD INDEX IS ',I8)
39376        CALL DPWRST('XXX','BUG ')
39377        IERROR='YES'
39378        GOTO9000
39379      ENDIF
39380C
39381C     NOW EXTRACT WORD BASED ON IINDX
39382C
39383C     WORD BOUNDARIES ARE DEFINED BY SPACES (NON-PRINTING CHARACTERS
39384C     ARE DEFINED AS SPACES).
39385C
39386C     2014/10: USER CAN SPECIFY DELIMITER OTHER THAN SPACE
39387C
39388C     STEP 1: DETERMINE START/STOP POSITION OF WORD
39389C
39390      NWORD=0
39391      IFLAG=0
39392C
39393      DO4100I=ISTRT1,ISTOP1
39394        IPOS=I
39395        IXTEMP=ICHAR(IFUNC(IPOS)(1:1))
39396        IF((IDELC.EQ.-1 .AND. IXTEMP.LE.32 .OR. IXTEMP.GE.127) .OR.
39397     1     (IDELC.GE.1 .AND. IXTEMP.EQ.IDELC))THEN
39398          IF(IFLAG.EQ.1)THEN
39399            IF(NWORD.EQ.IINDX)GOTO4200
39400            IFLAG=0
39401          ELSEIF(IFLAG.EQ.0)THEN
39402            CONTINUE
39403          ENDIF
39404C
39405C       CASE 2: NOT A WORD BOUNDARY DETECTED.  IS THIS START OF
39406C               NEW WORD OR CONTINUATION OF CURRENT WORD?
39407C
39408        ELSE
39409          IF(IFLAG.EQ.0)THEN
39410            ISTART=I
39411            ISTOP=I
39412            NWORD=NWORD+1
39413            IFLAG=1
39414          ELSEIF(IFLAG.EQ.1)THEN
39415            ISTOP=I
39416          ENDIF
39417        ENDIF
39418 4100 CONTINUE
39419C
39420      IF(NWORD.EQ.IINDX)THEN
39421        ISTOP=ISTOP1
39422        GOTO4200
39423      ENDIF
39424C
39425      WRITE(ICOUT,999)
39426      CALL DPWRST('XXX','BUG ')
39427      WRITE(ICOUT,4160)IINDX
39428 4160 FORMAT('     UNABLE TO EXTRACT WORD ',I8,' FROM STRING.')
39429      CALL DPWRST('XXX','BUG ')
39430      IERROR='YES'
39431      GOTO9000
39432C
39433 4200 CONTINUE
39434      ICNT=0
39435      DO4210I=ISTART,ISTOP
39436        ICNT=ICNT+1
39437        IPOS=I
39438        IFUNC2(ICNT)=IFUNC(IPOS)
39439 4210 CONTINUE
39440C
39441C               *****************************************************
39442C               **  STEP 5--                                       **
39443C               **  SAVE STRING AND PRINT FEEDBACK MESSAGE         **
39444C               *****************************************************
39445C
39446C
39447      IF(ICASEL.EQ.'STRI')THEN
39448C
39449        ISTEPN='5'
39450        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'STWD')
39451     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
39452C
39453        CALL DPINFU(IFUNC2,ICNT,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
39454     1              NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
39455CCCCC1              NEWNAM,MAXN3,
39456     1              NEWNAM,MAXNAM,
39457     1              IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
39458        IF(IERROR.EQ.'YES')GOTO9000
39459C
39460        IF(IFEEDB.EQ.'ON' .AND. IPRINT.EQ.'ON')THEN
39461          WRITE(ICOUT,999)
39462          CALL DPWRST('XXX','BUG ')
39463          WRITE(ICOUT,6606)IHLEFT,IHLEF2
39464 6606     FORMAT('THE NAME ',A4,A4,' HAS JUST BEEN EQUIVALENCED ')
39465          CALL DPWRST('XXX','BUG ')
39466          ILAB(1)='TO T'
39467          ILAB(2)='HE F'
39468          ILAB(3)='UNCT'
39469          ILAB(4)='ION '
39470          ILAB(5)='    '
39471          ILAB(6)=' -- '
39472          NUMWDL=6
39473          CALL DPPRIF(ILAB,NUMWDL,IFUNC2,ICNT,IBUGA3)
39474C
39475          WRITE(ICOUT,999)
39476          CALL DPWRST('XXX','BUG ')
39477C
39478        ENDIF
39479C
39480      ENDIF
39481C
39482C
39483C               ****************
39484C               **  STEP 90-- **
39485C               **  EXIT.     **
39486C               ****************
39487C
39488 9000 CONTINUE
39489      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'STWD')THEN
39490        WRITE(ICOUT,999)
39491        CALL DPWRST('XXX','BUG ')
39492        WRITE(ICOUT,9011)
39493 9011   FORMAT('***** AT THE END       OF DPSTWD--')
39494        CALL DPWRST('XXX','BUG ')
39495        WRITE(ICOUT,9013)NUMNAM
39496 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
39497        CALL DPWRST('XXX','BUG ')
39498        DO9015I=1,NUMNAM
39499          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
39500     1                     IVSTAR(I),IVSTOP(I)
39501 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
39502     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
39503          CALL DPWRST('XXX','BUG ')
39504 9015   CONTINUE
39505      ENDIF
39506C
39507      RETURN
39508      END
39509