1      SUBROUTINE DPI(NPLOTV,NPLOTP,NS,ICASPL,ISEED,IAND1,IAND2,
2     1               ICONT,IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
3C
4C     PURPOSE--GENERATE ONE OF THE FOLLOWING 4 I PLOTS--
5C
6C              1) MEDIAN;
7C              2) MEAN;
8C              3) MIDRANGE;
9C              4) MIDMEAN;
10C              5) TRIMMED MEAN;
11C              6) BIWEIGHT;
12C
13C              NOTE 2013/10: THIS PLOT HAS BEEN UPDATED IN THE
14C              FOLLOWING WAYS:
15C
16C              1) ADD THE FOLLOWING VARIANTS:
17C
18C                    ONE STANDARD ERROR PLOT
19C                    TWO STANDARD ERROR PLOT
20C                    ONE STANDARD DEVIATION PLOT
21C                    TWO STANDARD DEVIATION PLOT
22C                    MEAN CONFIDENCE LIMIT PLOT
23C                    MEDIAN CONFIDENCE LIMIT PLOT
24C                    QUANTILE CONFIDENCE LIMIT PLOT
25C                    TRIMMED MEAN CONFIDENCE LIMIT PLOT
26C                    BIWEIGHT CONFIDENCE LIMIT PLOT
27C                    NORMAL TOLERANCE LIMIT PLOT
28C                    NORMAL PREDICTION LIMIT PLOT
29C                    STANDARD DEVIATION CONFIDENCE LIMIT PLOT
30C                    AGRESTI COUL CONFIDENCE LIMIT PLOT
31C
32C                    FOLLOWING ADDED 11/2017:
33C                    DIFFERENCE OF PROPORTION CONFIDENCE LIMIT PLOT
34C                    COEFFICENT OF VARIATION CONFIDENCE LIMIT PLOT
35C                    COEFFICENT OF DISPERSION CONFIDENCE LIMIT PLOT
36C
37C                    FOLLOWING ADDED 12/2017:
38C                    COEFFICENT OF QUARTILE DISPERSION CONFIDENCE LIMIT PLOT
39C
40C                    FOLLOWING ADDED 04/2018:
41C                    CORRELATION CONFIDENCE LIMIT PLOT
42C
43C                    FOLLOWING ADDED 10/2019:
44C                    RATIO OF MEANS CONFIDENCE LIMIT PLOT
45C
46C                 RATHER THAN THE LOCATION/MIN/MAX FORM OF THE
47C                 PLOT, THESE WILL GENERATE A POINT ESTIMATE,
48C                 LOWER INTERVAL, AND UPPER INTERVAL.
49C
50C              2) ADD A 3-VARIABLE FORM OF THE PLOT:
51C
52C                    I-PLOT Y X TAG
53C
54C                 THIS HANDLES REPLICATION IN A DIFFERENT WAY
55C                 THAN THE "REPLICATED" OPTION.  WITH THE REPLICATION
56C                 OPTION, GIVEN X1 = 1, 2, 3 AND X2 = 1, 2, THE
57C                 X-COORDINATES FOR THE PLOT WILL BE
58C
59C                     X1     X2  |  X-COOR
60C                     ====================
61C                      1      1          1
62C                      2      1          2
63C                      3      1          3
64C                      1      2          4
65C                      2      2          5
66C                      3      2          6
67C
68C                 WITH THE 3-VARIABLE FORM OF THE PLOT, THE
69C                 X-COORDINATES WILL BE AS FOLLOWS
70C
71C
72C                     X1     X2  |  X-COOR
73C                     ====================
74C                      1      1        0.8
75C                      2      1        1.8
76C                      3      1        2.8
77C                      1      2        1.2
78C                      2      2        2.2
79C                      3      2        3.2
80C
81C                 ALSO, THE 3-VARIABLE FORM ALLOWS THE X2 GROUPS
82C                 TO BE DRAWN WITH DIFFERENT ATTRIBUTES (E.G.,
83C                 DIFFERENT COLORS) WHILE THE REPLICATED OPTION
84C                 USES THE SAME ATTRIBUTES.
85C
86C     WRITTEN BY--JAMES J. FILLIBEN
87C                 STATISTICAL ENGINEERING DIVISION
88C                 INFORMATION TECHNOLOGY LABORATORY
89C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
90C                 GAITHERSBURG, MD 20899-8980
91C                 PHONE--301-975-2855
92C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
93C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
94C     LANGUAGE--ANSI FORTRAN (1977)
95C     VERSION NUMBER--82/7
96C     ORIGINAL VERSION--JANUARY   1981.
97C     UPDATED         --AUGUST    1981.
98C     UPDATED         --MAY       1982.
99C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
100C     UPDATED         --FEBRUARY  2011. USE DPPARS AND DPPAR3 TO PERFORM
101C                                       THE COMMAND PARSING
102C     UPDATED         --FEBRUARY  2011. SUPPORT FOR "MULTIPLE" CASE
103C     UPDATED         --FEBRUARY  2011. SUPPORT FOR TWO GROUP-ID VARIABLES
104C     UPDATED         --OCTOBER   2013. SUPPORT FOR THREE-VARIABLE FORM
105C     UPDATED         --OCTOBER   2013. SUPPORT FOR ALTERNATIVES TO
106C                                       MEDIAN I PLOT
107C     UPDATED         --OCTOBER   2013. SUPPORT FOR "INTERVAL" TYPE
108C                                       PLOTS
109C     UPDATED         --JULY      2016. FOR MULTIPLE CASE, ALLOW
110C                                       CREATION OF "STACKED" VARIABLES
111C                                       THAT ARE 5*MAXOBV
112C     UPDATED         --NOVEMBER  2017. UPDATES TO AGRESTI-COUL
113C                                       CONFIDENCE LIMTIS
114C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF PROPORTIONS
115C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF MEANS
116C     UPDATED         --NOVEMBER  2017. COEFFICIENT OF VARIATION
117C     UPDATED         --NOVEMBER  2017. COEFFICIENT OF DISPERSION
118C     UPDATED         --DECEMBER  2017. COEFFICIENT OF QUARTILE DISPERSION
119C     UPDATED         --APRIL     2018. CORRELATION
120C     UPDATED         --JUNE      2018. SUPPORT FOR UNEQUAL SAMPLE SIZES
121C                                       FOR DIFFERENCE OF MEAN AND
122C                                       DIFFERENCE OF PROPORTION
123C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE
124C     UPDATED         --OCTOBER   2019. RATIO OF MEANS CONFIDENCE LIMIT
125C                                       PLOT
126C
127C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
128C
129      CHARACTER*4 ICASPL
130      CHARACTER*4 IAND1
131      CHARACTER*4 IAND2
132      CHARACTER*4 ICONT
133      CHARACTER*4 IBUGG2
134      CHARACTER*4 IBUGG3
135      CHARACTER*4 IBUGQ
136      CHARACTER*4 ISUBRO
137      CHARACTER*4 IFOUND
138      CHARACTER*4 IERROR
139C
140      CHARACTER*4 IREPL
141      CHARACTER*4 IREP2
142      CHARACTER*4 IMULT
143      CHARACTER*4 IWRITE
144      CHARACTER*4 IFOUN1
145      CHARACTER*4 IFOUN2
146C
147      CHARACTER*4 IA1
148      CHARACTER*4 IA2
149      CHARACTER*4 IA3
150      CHARACTER*4 IA4
151      CHARACTER*4 IA5
152      CHARACTER*4 IA6
153      CHARACTER*4 IA7
154      CHARACTER*4 IHWUSE
155      CHARACTER*4 MESSAG
156      CHARACTER*4 IH
157      CHARACTER*4 IH2
158      CHARACTER*4 ICASE
159      CHARACTER*4 ISUBN1
160      CHARACTER*4 ISUBN2
161      CHARACTER*4 ISTEPN
162C
163      CHARACTER*40 INAME
164      PARAMETER (MAXSPN=30)
165      CHARACTER*4 IVARN1(MAXSPN)
166      CHARACTER*4 IVARN2(MAXSPN)
167      CHARACTER*4 IVARTY(MAXSPN)
168      REAL PVAR(MAXSPN)
169      INTEGER ILIS(MAXSPN)
170      INTEGER NRIGHT(MAXSPN)
171      INTEGER ICOLR(MAXSPN)
172C
173C---------------------------------------------------------------------
174C
175      INCLUDE 'DPCOPA.INC'
176C
177      DIMENSION Y1(5*MAXOBV)
178      DIMENSION Y2(5*MAXOBV)
179      DIMENSION X1(5*MAXOBV)
180      DIMENSION X2(MAXOBV)
181      DIMENSION X3(MAXOBV)
182      DIMENSION X4(MAXOBV)
183      DIMENSION X5(MAXOBV)
184      DIMENSION X6(MAXOBV)
185C
186      DIMENSION XIDTEM(MAXOBV)
187      DIMENSION XIDTE2(MAXOBV)
188      DIMENSION TEMP(MAXOBV)
189      DIMENSION TEMPZ(MAXOBV)
190      DIMENSION XTEMP0(MAXOBV)
191      DIMENSION XTEMP1(MAXOBV)
192      DIMENSION XTEMP2(MAXOBV)
193      DIMENSION XTEMP3(MAXOBV)
194      DIMENSION XTEMP4(MAXOBV)
195      DIMENSION XTEMP5(MAXOBV)
196      DIMENSION XTEMP6(MAXOBV)
197      DIMENSION TEMP1(MAXOBV)
198      DIMENSION TEMP2(MAXOBV)
199C
200      INCLUDE 'DPCOZZ.INC'
201      EQUIVALENCE (GARBAG(IGARB1),X2(1))
202      EQUIVALENCE (GARBAG(IGARB2),X3(1))
203      EQUIVALENCE (GARBAG(IGARB3),X4(1))
204      EQUIVALENCE (GARBAG(IGARB4),X5(1))
205      EQUIVALENCE (GARBAG(IGARB5),X6(1))
206      EQUIVALENCE (GARBAG(IGARB6),XIDTEM(1))
207      EQUIVALENCE (GARBAG(IGARB7),XTEMP1(1))
208      EQUIVALENCE (GARBAG(IGARB8),XTEMP2(1))
209      EQUIVALENCE (GARBAG(IGARB9),XTEMP3(1))
210      EQUIVALENCE (GARBAG(IGAR10),XTEMP4(1))
211      EQUIVALENCE (GARBAG(JGAR11),XTEMP5(1))
212      EQUIVALENCE (GARBAG(JGAR12),XTEMP6(1))
213      EQUIVALENCE (GARBAG(JGAR13),XTEMP0(1))
214      EQUIVALENCE (GARBAG(JGAR14),TEMP1(1))
215      EQUIVALENCE (GARBAG(JGAR15),TEMP2(1))
216      EQUIVALENCE (GARBAG(JGAR16),TEMPZ(1))
217      EQUIVALENCE (GARBAG(JGAR17),XIDTE2(1))
218      EQUIVALENCE (GARBAG(JGAR18),TEMP(1))
219      EQUIVALENCE (GARBAG(IGAR11),Y1(1))
220      EQUIVALENCE (GARBAG(IGAR16),Y2(1))
221      EQUIVALENCE (GARBAG(IGAR21),X1(1))
222C
223C-----COMMON----------------------------------------------------------
224C
225      COMMON/IPLOT/NREPI1,NREPI2
226C
227      INCLUDE 'DPCOHK.INC'
228      INCLUDE 'DPCODA.INC'
229      INCLUDE 'DPCOST.INC'
230      INCLUDE 'DPCOP2.INC'
231C
232C-----START POINT-----------------------------------------------------
233C
234      IERROR='NO'
235      IFOUND='NO'
236      IFOUN1='NO'
237      IFOUN2='NO'
238      IWRITE='OFF'
239      ISUBN1='DPI '
240      ISUBN2='    '
241C
242      NREPI1=0
243      NREPI2=0
244      MAXCP1=MAXCOL+1
245      MAXCP2=MAXCOL+2
246      MAXCP3=MAXCOL+3
247      MAXCP4=MAXCOL+4
248      MAXCP5=MAXCOL+5
249      MAXCP6=MAXCOL+6
250C
251C               *******************************
252C               **  TREAT THE I   PLOT CASE  **
253C               *******************************
254C
255      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPI')THEN
256        WRITE(ICOUT,999)
257  999   FORMAT(1X)
258        CALL DPWRST('XXX','BUG ')
259        WRITE(ICOUT,51)
260   51   FORMAT('***** AT THE BEGINNING OF DPI--')
261        CALL DPWRST('XXX','BUG ')
262        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,NS
263   52   FORMAT('ICASPL,IAND1,IAND2,NS = ',3(A4,2X),I8)
264        CALL DPWRST('XXX','BUG ')
265        WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ
266   53   FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',3(A4,2X),A4)
267        CALL DPWRST('XXX','BUG ')
268      ENDIF
269C
270C               ******************************************************
271C               **  STEP 1--                                        **
272C               **  EXTRACT THE COMMAND                             **
273C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:         **
274C               **    1) I PLOT Y X1 ... X2                         **
275C               **    2) MULTIPLE I PLOT Y1 ... YK                  **
276C               **    3) REPLICATED I PLOT Y X1 X2                  **
277C               **  THE "REPLICATION" CASE IS ACTUALLY THE DEFAULT  **
278C               **  AND THE KEYWORD "REPLICATION" IS OPTIONAL.      **
279C               **  HOWEVER, SUPPORT IT FOR COMPATABILITY WITH      **
280C               **  OTHER COMMANDS.                                 **
281C               ******************************************************
282C
283C     NOTE 2013/10: FOLLOWING ADDITIONAL COMMANDS ADDED:
284C
285C          ONE STANDARD ERROR PLOT
286C          TWO STANDARD ERROR PLOT
287C          MEAN CONFIDENCE LIMIT PLOT
288C          MEDIAN CONFIDENCE LIMIT PLOT
289C          QUANTILE CONFIDENCE LIMIT PLOT
290C          TRIMMED MEAN CONFIDENCE LIMIT PLOT
291C          BIWEIGHT CONFIDENCE LIMIT PLOT
292C          STANDARD DEVIATION CONFIDENCE LIMIT PLOT
293C          NORMAL TOLERANCE LIMIT PLOT
294C          NORMAL PREDICTION LIMIT PLOT
295C          AGRESTI COUL CONFIDENCE LIMIT PLOT
296C
297C     NOTE 2017/11: FOLLOWING ADDITIONAL COMMANDS ADDED:
298C
299C          DIFFERENCE OF MEANS CONFIDENCE LIMIT PLOT
300C          DIFFERENCE OF PROPORTIONS CONFIDENCE LIMIT PLOT
301C          STANDARD DEVIATION CONFIDENCE LIMIT PLOT
302C          COEFFICIENT OF VARIATION CONFIDENCE LIMIT PLOT
303C          COEFFICIENT OF DISPERSION CONFIDENCE LIMIT PLOT
304C
305C     NOTE 2017/11: FOLLOWING ADDITIONAL COMMANDS ADDED:
306C
307C          COEFFICIENT OF QUARTILE DISPERSION CONFIDENCE LIMIT PLOT
308C
309C     NOTE 2018/04: FOLLOWING ADDITIONAL COMMANDS ADDED:
310C
311C          CORRELATION CONFIDENCE LIMIT PLOT
312C
313C     NOTE 2019/10: FOLLOWING ADDITIONAL COMMANDS ADDED:
314C
315C          RATIO OF MEANS CONFIDENCE LIMIT PLOT
316C
317      ISTEPN='1'
318      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPI')
319     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
320C
321      IF(ICOM.EQ.'I')GOTO89
322      IF(ICOM.EQ.'MULT')GOTO89
323      IF(ICOM.EQ.'REPL')GOTO89
324      IF(ICOM.EQ.'MEAN')GOTO89
325      IF(ICOM.EQ.'MEDI')GOTO89
326      IF(ICOM.EQ.'MIDR')GOTO89
327      IF(ICOM.EQ.'MIDM')GOTO89
328      IF(ICOM.EQ.'MEDI')GOTO89
329      IF(ICOM.EQ.'QUAN')GOTO89
330      IF(ICOM.EQ.'TRIM')GOTO89
331      IF(ICOM.EQ.'BIWE')GOTO89
332      IF(ICOM.EQ.'NORM')GOTO89
333      IF(ICOM.EQ.'STAN' .AND. IHARG(1).EQ.'DEVI')GOTO89
334      IF(ICOM.EQ.'SD  ')GOTO89
335      IF(ICOM.EQ.'ONE' .OR. ICOM.EQ.'1')GOTO89
336      IF(ICOM.EQ.'TWO' .OR. ICOM.EQ.'2')GOTO89
337      IF(ICOM.EQ.'AGRE')GOTO89
338      IF(ICOM.EQ.'PROP')GOTO89
339      IF(ICOM.EQ.'BINO' .AND. IHARG(1).EQ.'PROP')GOTO89
340      IF(ICOM.EQ.'COEF')GOTO89
341      IF(ICOM.EQ.'DIFF')GOTO89
342      IF(ICOM.EQ.'CORR')GOTO89
343      IF(ICOM.EQ.'RATI' .AND. IHARG(1).EQ.'OF  ' .AND.
344     1   IHARG(2).EQ.'MEAN')GOTO89
345      GOTO9000
346C
347   89 CONTINUE
348      ICASPL='MDIP'
349      IMULT='OFF'
350      IREPL='OFF'
351      IREP2='OFF'
352      ILASTC=-9999
353      ISTOP=NUMARG
354      NRESP=1
355      DO91I=1,NUMARG
356        IF(IHARG(I).EQ.'PLOT')THEN
357          ISTOP=I
358          GOTO93
359        ENDIF
360   91 CONTINUE
361   93 CONTINUE
362C
363      DO100I=0,ISTOP
364C
365        IF(I.EQ.0)THEN
366          IA1=ICOM
367        ELSE
368          IA1=IHARG(I)
369        ENDIF
370        IA2=IHARG(I+1)
371        IA3=IHARG(I+2)
372        IA4=IHARG(I+3)
373        IA5=IHARG(I+4)
374        IA6=IHARG(I+5)
375        IA7=IHARG(I+6)
376C
377        IF(IHARG(I).EQ.'=')THEN
378          IFOUND='NO'
379          GOTO9000
380        ELSEIF(IA1.EQ.'REPL')THEN
381          IREPL='ON'
382        ELSEIF(IA1.EQ.'MULT')THEN
383          IMULT='ON'
384        ELSEIF(IA1.EQ.'I' .AND. IA2.EQ.'PLOT')THEN
385          IFOUN1='YES'
386          IFOUN2='YES'
387          ILASTC=MAX(ILASTC,I+1)
388          GOTO109
389        ELSEIF(IA1.EQ.'MEDI' .AND. IA2.EQ.'I' .AND.
390     1         IA3.EQ.'PLOT')THEN
391          ICASPL='MDIP'
392          IFOUN1='YES'
393          IFOUN2='YES'
394          ILASTC=MAX(ILASTC,I+2)
395          GOTO109
396        ELSEIF(IA1.EQ.'TRIM' .AND. IA2.EQ.'MEAN' .AND.
397     1         IA3.EQ.'I   ' .AND. IA4.EQ.'PLOT')THEN
398          ICASPL='TMIP'
399          IFOUN1='YES'
400          IFOUN2='YES'
401          ILASTC=MAX(ILASTC,I+3)
402          GOTO109
403        ELSEIF(IA1.EQ.'MEAN' .AND. IA2.EQ.'I' .AND.
404     1         IA3.EQ.'PLOT')THEN
405          ICASPL='MEIP'
406          IFOUN1='YES'
407          IFOUN2='YES'
408          ILASTC=MAX(ILASTC,I+2)
409          GOTO109
410        ELSEIF(IA1.EQ.'MIDR' .AND. IA2.EQ.'I' .AND.
411     1         IA3.EQ.'PLOT')THEN
412          ICASPL='MRIP'
413          IFOUN1='YES'
414          IFOUN2='YES'
415          ILASTC=MAX(ILASTC,I+2)
416          GOTO109
417        ELSEIF(IA1.EQ.'MIDM' .AND. IA2.EQ.'I' .AND.
418     1         IA3.EQ.'PLOT')THEN
419          ICASPL='MMIP'
420          IFOUN1='YES'
421          IFOUN2='YES'
422          ILASTC=MAX(ILASTC,I+2)
423          GOTO109
424        ELSEIF(IA1.EQ.'BIWE' .AND. IA2.EQ.'I' .AND.
425     1         IA3.EQ.'PLOT')THEN
426          ICASPL='BWIP'
427          IFOUN1='YES'
428          IFOUN2='YES'
429          ILASTC=MAX(ILASTC,I+2)
430          GOTO109
431        ELSEIF(IA1.EQ.'TRIM' .AND. IA2.EQ.'MEAN' .AND.
432     1         IA3.EQ.'CONF' .AND. IA4.EQ.'LIMI' .AND.
433     1         IA5.EQ.'PLOT')THEN
434          ICASPL='TMCL'
435          IFOUN1='YES'
436          IFOUN2='YES'
437          ILASTC=MAX(ILASTC,I+4)
438          GOTO109
439        ELSEIF(IA1.EQ.'DIFF' .AND. IA2.EQ.'OF  ' .AND.
440     1         IA3.EQ.'MEAN' .AND. IA4.EQ.'CONF' .AND.
441     1         IA5.EQ.'LIMI' .AND. IA6.EQ.'PLOT')THEN
442          ICASPL='DMEA'
443          IFOUN1='YES'
444          IFOUN2='YES'
445          ILASTC=MAX(ILASTC,I+5)
446          NRESP=2
447          GOTO109
448        ELSEIF(IA1.EQ.'MEAN' .AND. IA2.EQ.'CONF' .AND.
449     1         IA3.EQ.'LIMI' .AND. IA4.EQ.'PLOT')THEN
450          ICASPL='MECL'
451          IFOUN1='YES'
452          IFOUN2='YES'
453          ILASTC=MAX(ILASTC,I+3)
454          GOTO109
455        ELSEIF(IA1.EQ.'SD  ' .AND. IA2.EQ.'CONF' .AND.
456     1         IA3.EQ.'LIMI' .AND. IA4.EQ.'PLOT')THEN
457          ICASPL='SDCL'
458          IFOUN1='YES'
459          IFOUN2='YES'
460          ILASTC=MAX(ILASTC,I+3)
461          GOTO109
462        ELSEIF(IA1.EQ.'STAN' .AND. IA2.EQ.'DEVI' .AND.
463     1         IA3.EQ.'CONF' .AND. IA4.EQ.'LIMI' .AND.
464     1         IA5.EQ.'PLOT')THEN
465          ICASPL='SDCL'
466          IFOUN1='YES'
467          IFOUN2='YES'
468          ILASTC=MAX(ILASTC,I+4)
469          GOTO109
470        ELSEIF(IA1.EQ.'MEDI' .AND. IA2.EQ.'CONF' .AND.
471     1         IA3.EQ.'LIMI' .AND. IA4.EQ.'PLOT')THEN
472          ICASPL='MECL'
473          IFOUN1='YES'
474          IFOUN2='YES'
475          ILASTC=MAX(ILASTC,I+3)
476          GOTO109
477        ELSEIF(IA1.EQ.'QUAN' .AND. IA2.EQ.'CONF' .AND.
478     1         IA3.EQ.'LIMI' .AND. IA4.EQ.'PLOT')THEN
479          ICASPL='QUCL'
480          IFOUN1='YES'
481          IFOUN2='YES'
482          ILASTC=MAX(ILASTC,I+3)
483          GOTO109
484        ELSEIF(IA1.EQ.'BIWE' .AND. IA2.EQ.'CONF' .AND.
485     1         IA3.EQ.'LIMI' .AND. IA4.EQ.'PLOT')THEN
486          ICASPL='BWCL'
487          IFOUN1='YES'
488          IFOUN2='YES'
489          ILASTC=MAX(ILASTC,I+3)
490          GOTO109
491        ELSEIF(IA1.EQ.'DIFF' .AND. IA2.EQ.'OF  ' .AND.
492     1         IA3.EQ.'PROP' .AND. IA4.EQ.'CONF' .AND.
493     1         IA5.EQ.'LIMI' .AND. IA6.EQ.'PLOT')THEN
494          ICASPL='DPRO'
495          IFOUN1='YES'
496          IFOUN2='YES'
497          ILASTC=MAX(ILASTC,I+5)
498          NRESP=2
499          GOTO109
500        ELSEIF(IA1.EQ.'DIFF' .AND. IA2.EQ.'OF  ' .AND.
501     1         IA3.EQ.'BINO' .AND. IA4.EQ.'PROP' .AND.
502     1         IA5.EQ.'CONF' .AND. IA6.EQ.'LIMI' .AND.
503     1         IA7.EQ.'PLOT')THEN
504          ICASPL='DPRO'
505          IFOUN1='YES'
506          IFOUN2='YES'
507          ILASTC=MAX(ILASTC,I+6)
508          NRESP=2
509          GOTO109
510        ELSEIF(IA1.EQ.'AGRE' .AND. IA2.EQ.'COUL' .AND.
511     1         IA3.EQ.'CONF' .AND. IA4.EQ.'LIMI' .AND.
512     1         IA5.EQ.'PLOT')THEN
513C
514C         2017/11: ADD THE FOLLOWING SYNONYMS FOR
515C                  AGRESTI COUL
516C         PROPORTION CONFIDENCE LIMIT
517C         BINOMIAL PROPORTION CONFIDENCE LIMIT
518C
519          ICASPL='AGCL'
520          IFOUN1='YES'
521          IFOUN2='YES'
522          ILASTC=MAX(ILASTC,I+4)
523          GOTO109
524        ELSEIF(IA1.EQ.'BINO' .AND. IA2.EQ.'PROP' .AND.
525     1         IA3.EQ.'CONF' .AND. IA4.EQ.'LIMI' .AND.
526     1         IA5.EQ.'PLOT')THEN
527          ICASPL='AGCL'
528          IFOUN1='YES'
529          IFOUN2='YES'
530          ILASTC=MAX(ILASTC,I+4)
531          GOTO109
532        ELSEIF(IA1.EQ.'PROP' .AND. IA2.EQ.'CONF' .AND.
533     1         IA3.EQ.'LIMI' .AND. IA4.EQ.'PLOT')THEN
534          ICASPL='AGCL'
535          IFOUN1='YES'
536          IFOUN2='YES'
537          ILASTC=MAX(ILASTC,I+3)
538          GOTO109
539        ELSEIF(IA1.EQ.'COEF' .AND. IA2.EQ.'OF  ' .AND.
540     1         IA3.EQ.'VARI' .AND. IA4.EQ.'CONF' .AND.
541     1         IA5.EQ.'LIMI' .AND. IA6.EQ.'PLOT')THEN
542          ICASPL='CVCL'
543          IFOUN1='YES'
544          IFOUN2='YES'
545          ILASTC=MAX(ILASTC,I+5)
546          GOTO109
547        ELSEIF(IA1.EQ.'COEF' .AND. IA2.EQ.'OF  ' .AND.
548     1         IA3.EQ.'DISP' .AND. IA4.EQ.'CONF' .AND.
549     1         IA5.EQ.'LIMI' .AND. IA6.EQ.'PLOT')THEN
550          ICASPL='CDCL'
551          IFOUN1='YES'
552          IFOUN2='YES'
553          ILASTC=MAX(ILASTC,I+5)
554          GOTO109
555        ELSEIF(IA1.EQ.'COEF' .AND. IA2.EQ.'OF  ' .AND.
556     1         IA3.EQ.'QUAR' .AND. IA4.EQ.'DISP' .AND.
557     1         IA5.EQ.'CONF' .AND. IA6.EQ.'LIMI' .AND.
558     1         IA7.EQ.'PLOT')THEN
559          ICASPL='CQCL'
560          IFOUN1='YES'
561          IFOUN2='YES'
562          ILASTC=MAX(ILASTC,I+6)
563          GOTO109
564        ELSEIF((IA1.EQ.'ONE ' .OR. IA1.EQ.'1') .AND.
565     1          IA2.EQ.'STAN' .AND. IA3.EQ.'ERRO' .AND.
566     1          IA4.EQ.'PLOT')THEN
567          ICASPL='1SE '
568          IFOUN1='YES'
569          IFOUN2='YES'
570          ILASTC=MAX(ILASTC,I+3)
571          GOTO109
572        ELSEIF((IA1.EQ.'TWO ' .OR. IA1.EQ.'2') .AND.
573     1          IA2.EQ.'STAN' .AND. IA3.EQ.'ERRO' .AND.
574     1          IA4.EQ.'PLOT')THEN
575          ICASPL='2SE '
576          IFOUN1='YES'
577          IFOUN2='YES'
578          ILASTC=MAX(ILASTC,I+3)
579        ELSEIF((IA1.EQ.'ONE ' .OR. IA1.EQ.'1') .AND.
580     1          IA2.EQ.'STAN' .AND. IA3.EQ.'DEVI' .AND.
581     1          IA4.EQ.'PLOT')THEN
582          ICASPL='1SD '
583          IFOUN1='YES'
584          IFOUN2='YES'
585          ILASTC=MAX(ILASTC,I+3)
586          GOTO109
587        ELSEIF((IA1.EQ.'TWO ' .OR. IA1.EQ.'2') .AND.
588     1          IA2.EQ.'STAN' .AND. IA3.EQ.'DEVI' .AND.
589     1          IA4.EQ.'PLOT')THEN
590          ICASPL='2SD '
591          IFOUN1='YES'
592          IFOUN2='YES'
593          ILASTC=MAX(ILASTC,I+3)
594        ELSEIF(IA1.EQ.'NORM' .AND. IA2.EQ.'TOLE' .AND.
595     1          IA3.EQ.'LIMI' .AND. IA4.EQ.'PLOT')THEN
596          ICASPL='NTOL'
597          IFOUN1='YES'
598          IFOUN2='YES'
599          ILASTC=MAX(ILASTC,I+3)
600          GOTO109
601        ELSEIF(IA1.EQ.'NORM' .AND. IA2.EQ.'PRED' .AND.
602     1          IA3.EQ.'LIMI' .AND. IA4.EQ.'PLOT')THEN
603          ICASPL='NPRE'
604          IFOUN1='YES'
605          IFOUN2='YES'
606          ILASTC=MAX(ILASTC,I+3)
607          GOTO109
608        ELSEIF(IA1.EQ.'CORR' .AND. IA2.EQ.'CONF' .AND.
609     1         IA3.EQ.'LIMI' .AND. IA4.EQ.'PLOT')THEN
610          ICASPL='CRCL'
611          IFOUN1='YES'
612          IFOUN2='YES'
613          ILASTC=MAX(ILASTC,I+3)
614          NRESP=2
615          GOTO109
616        ELSEIF(IA1.EQ.'RATI' .AND. IA2.EQ.'OF  ' .AND.
617     1         IA3.EQ.'MEAN' .AND. IA4.EQ.'CONF' .AND.
618     1         (IA5.EQ.'LIMI' .OR. IA5.EQ.'INTE') .AND.
619     1         IA6.EQ.'PLOT')THEN
620          ICASPL='RMEA'
621          IFOUN1='YES'
622          IFOUN2='YES'
623          ILASTC=MAX(ILASTC,I+3)
624          NRESP=2
625          GOTO109
626        ENDIF
627  100 CONTINUE
628  109 CONTINUE
629C
630      IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')IFOUND='YES'
631      IF(IFOUND.EQ.'NO')GOTO9000
632C
633      IF(IMULT.EQ.'ON')THEN
634        IF(IREPL.EQ.'ON')THEN
635          WRITE(ICOUT,999)
636          CALL DPWRST('XXX','BUG ')
637          WRITE(ICOUT,101)
638  101     FORMAT('***** ERROR IN I PLOT--')
639          CALL DPWRST('XXX','BUG ')
640          WRITE(ICOUT,107)
641  107     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
642     1           '"REPLICATION" FOR THIS PLOT.')
643          CALL DPWRST('XXX','BUG ')
644          IERROR='YES'
645          GOTO9000
646        ENDIF
647      ENDIF
648C
649      IF(ILASTC.GE.1)THEN
650        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
651        ILASTC=0
652      ENDIF
653C
654      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPI')THEN
655        WRITE(ICOUT,112)ICASPL,IMULT,IREPL
656  112   FORMAT('ICASPL,IMULT,IREPL = ',2(A4,2X),A4)
657        CALL DPWRST('XXX','BUG ')
658      ENDIF
659C
660C               ****************************************
661C               **  STEP 2--                          **
662C               **  EXTRACT THE VARIABLE LIST         **
663C               ****************************************
664C
665      ISTEPN='2'
666      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPI')
667     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
668C
669      INAME='I PLOT'
670      MINNA=1
671      MAXNA=100
672      MINN2=2
673      IFLAGE=1
674      IF(IMULT.EQ.'ON')THEN
675        IFLAGE=0
676      ENDIF
677      IFLAGM=1
678      IFLAGP=0
679      JMIN=1
680      JMAX=NUMARG
681      MINNVA=NRESP
682      IF(IREPL.EQ.'ON')THEN
683        MINNVA=MINNVA+1
684      ENDIF
685C
686C     DIFFERENCE OF MEAN AND DIFFERENCE OF PROPORTION SUPPORT 4 VARIABLE
687C     CASE (Y1 TAG1 Y2 TAG2) TO HANDLE UNEQUAL SAMPLE SIZES.  HOWEVER,
688C     DO NOT SUPPORT THIS IF EITHER REPLICATION OR MULTIPLE SWITCH
689C     IS ON.
690C
691      IF(IREPL.EQ.'OFF' .AND. IMULT.EQ.'OFF')THEN
692        IF(ICASPL.EQ.'DMEA' .OR. ICASPL.EQ.'DPRO')THEN
693          IFLAGE=19
694          MINNVA=3
695          MAXNVA=4
696        ENDIF
697      ENDIF
698C
699C     NOTE: NEED TO KEEP "I PLOT Y" AS VALID SYNTAX, SO
700C           MINIMUM NUMBER OF VARIABLES IS 1 EVEN FOR REPLICATION
701C           CASE.
702C
703      IF(IMULT.EQ.'ON')THEN
704        MAXNVA=30
705      ELSE
706        MAXNVA=NRESP+6
707      ENDIF
708C
709      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
710     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
711     1            JMIN,JMAX,
712     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
713     1            IVARN1,IVARN2,IVARTY,PVAR,
714     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
715     1            MINNVA,MAXNVA,
716     1            IFLAGM,IFLAGP,
717     1            IBUGG2,IBUGQ,ISUBRO,IFOUND,IERROR)
718      IF(IERROR.EQ.'YES')GOTO9000
719C
720      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPI')THEN
721        WRITE(ICOUT,999)
722        CALL DPWRST('XXX','BUG ')
723        WRITE(ICOUT,281)
724  281   FORMAT('***** AFTER CALL DPPARS--')
725        CALL DPWRST('XXX','BUG ')
726        WRITE(ICOUT,282)NQ,NUMVAR
727  282   FORMAT('NQ,NUMVAR = ',2I8)
728        CALL DPWRST('XXX','BUG ')
729        IF(NUMVAR.GT.0)THEN
730          DO285I=1,NUMVAR
731            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
732     1                      ICOLR(I),IVARTY(I)
733  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
734     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
735            CALL DPWRST('XXX','BUG ')
736  285     CONTINUE
737        ENDIF
738      ENDIF
739C
740      IF(IREPL.EQ.'OFF' .AND. IMULT.EQ.'OFF' .AND.
741     1   NUMVAR.EQ.NRESP+2)THEN
742        IF(ICASPL.EQ.'DMEA' .OR. ICASPL.EQ.'DPRO')THEN
743          IREP2='OFF'
744        ELSE
745          IREP2='ON'
746        ENDIF
747      ELSEIF(IREPL.EQ.'OFF' .AND. IMULT.EQ.'OFF')THEN
748        IREPL='ON'
749      ENDIF
750C
751      NREPL=0
752      IF(IMULT.EQ.'ON')THEN
753        IF(NRESP.EQ.1)THEN
754          NRESP=NUMVAR
755        ELSE
756          WRITE(ICOUT,999)
757          CALL DPWRST('XXX','BUG ')
758          WRITE(ICOUT,101)
759          CALL DPWRST('XXX','BUG ')
760          WRITE(ICOUT,521)
761  521     FORMAT('      THE MULTIPLE OPTION IS NOT SUPPORTED FOR')
762          CALL DPWRST('XXX','BUG ')
763          WRITE(ICOUT,523)
764  523     FORMAT('      CASES WITH MULTIPLE RESPONSE VARIABLES. ')
765          CALL DPWRST('XXX','BUG ')
766          IERROR='YES'
767          GOTO9000
768        ENDIF
769      ELSE
770        NREPL=NUMVAR-NRESP
771        IF(NREPL.LT.0 .OR. NREPL.GT.6)THEN
772          WRITE(ICOUT,999)
773          CALL DPWRST('XXX','BUG ')
774          WRITE(ICOUT,101)
775          CALL DPWRST('XXX','BUG ')
776          WRITE(ICOUT,511)
777  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
778     1           'REPLICATION VARIABLES')
779          CALL DPWRST('XXX','BUG ')
780          WRITE(ICOUT,512)
781  512     FORMAT('      MUST BE BETWEEN 0 AND 6;  SUCH WAS NOT THE ',
782     1           'CASE HERE.')
783          CALL DPWRST('XXX','BUG ')
784          WRITE(ICOUT,513)NREPL
785  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
786          CALL DPWRST('XXX','BUG ')
787          IERROR='YES'
788          GOTO9000
789        ENDIF
790      ENDIF
791C
792      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PBOX')THEN
793        ISTEPN='6'
794        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
795        WRITE(ICOUT,601)NRESP,NREPL
796  601   FORMAT('NRESP,NREPL = ',2I5)
797        CALL DPWRST('XXX','BUG ')
798      ENDIF
799C
800      IH='ALPH'
801      IH2='A   '
802      IHWUSE='P'
803      MESSAG='NO'
804      CALL CHECKN(IH,IH2,IHWUSE,
805     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
806     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
807      IF(IERROR.EQ.'YES')THEN
808        ALPHA=0.05
809        IF(ICASPL.EQ.'NTOL')ALPHA=0.95
810      ELSE
811        ALPHA=VALUE(ILOCP)
812        IF(ALPHA.GE.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.
813        IF(ALPHA.GT.0.5 .AND. ALPHA.LT.1.0)ALPHA=1.0 - ALPHA
814        IF(ALPHA.LE.0.0 .OR. ALPHA.GE.0.5)ALPHA=0.05
815      ENDIF
816C
817      IF(ICASPL.EQ.'NTOL')THEN
818        IH='GAMM'
819        IH2='A   '
820        IHWUSE='P'
821        MESSAG='NO'
822        CALL CHECKN(IH,IH2,IHWUSE,
823     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
824     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
825        IF(IERROR.EQ.'YES')THEN
826          GAMMA=0.95
827        ELSE
828          GAMMA=VALUE(ILOCP)
829          IF(GAMMA.GE.1.0 .AND. GAMMA.LE.100.0)GAMMA=GAMMA/100.
830          IF(GAMMA.GT.0.0 .AND. GAMMA.LT.0.5)GAMMA=1.0 - GAMMA
831          IF(GAMMA.LE.0.5 .OR.  GAMMA.GE.1.0)GAMMA=0.95
832        ENDIF
833      ELSE
834        GAMMA=CPUMIN
835      ENDIF
836C
837      IF(ICASPL.EQ.'NPRE')THEN
838        IH='NNEW'
839        IH2='    '
840        IHWUSE='P'
841        MESSAG='NO'
842        CALL CHECKN(IH,IH2,IHWUSE,
843     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
844     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
845        IF(IERROR.EQ.'NO')THEN
846          NNEW=INT(VALUE(ILOCP)+0.5)
847        ELSE
848          NNEW=1
849        ENDIF
850        IF(NNEW.LT.1)NNEW=1
851      ELSE
852        NNEW=0
853      ENDIF
854C
855      IH='P1  '
856      IH2='    '
857      IHWUSE='P'
858      MESSAG='NO'
859      CALL CHECKN(IH,IH2,IHWUSE,
860     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
861     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
862      IF(IERROR.EQ.'YES')THEN
863        P1=0.25
864      ELSE
865        P1=VALUE(ILOCP)
866        IF(P1.GE.1.0 .AND. P1.LE.50.0)P1=P1/100.
867        IF(P1.LE.0.0 .OR. P1.GE.0.4)P1=0.25
868      ENDIF
869C
870      IH='P2  '
871      IH2='    '
872      IHWUSE='P'
873      MESSAG='NO'
874      CALL CHECKN(IH,IH2,IHWUSE,
875     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
876     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
877      IF(IERROR.EQ.'YES')THEN
878        P2=0.75
879      ELSE
880        P2=VALUE(ILOCP)
881        IF(P2.GE.50.0 .AND. P2.LE.100.0)P2=P2/100.
882        IF(P2.LE.0.50 .OR. P2.GT.1.0)P2=0.75
883      ENDIF
884C
885      IH='XQ  '
886      IH2='    '
887      IHWUSE='P'
888      MESSAG='NO'
889      CALL CHECKN(IH,IH2,IHWUSE,
890     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
891     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
892      IF(IERROR.EQ.'YES')THEN
893        P100=0.50
894      ELSE
895        P100=VALUE(ILOCP)
896        IF(P100.GE.1.0 .AND. P100.LE.100.0)P100=P100/100.
897        IF(P100.LE.0.0 .OR. P100.GE.1.0)P100=0.50
898      ENDIF
899C
900C               ********************************************************
901C               **  STEP 7--                                          **
902C               **  FOR THE 1-VARIABLE CASE ONLY,                     *
903C               **  DETERMINE IF THE ANALYST                          **
904C               **  HAS SPECIFIED    THE GROUP SIZE,                  **
905C               **  FOR THE I   PLOT      ANALYSIS.                   **
906C               **  THE GROUP SIZE SETTING IS DEFINED BY SEARCHING THE**
907C               **  INTERNAL TABLE FOR THE PARAMETER NAME      NI   ; **
908C               **  IF FOUND, USE THE SPECIFIED VALUE.                **
909C               **  IF NOT FOUND, GENERATE AN ERROR MESSAGE.          **
910C               ********************************************************
911C
912      ISTEPN='7'
913      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPI')
914     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
915C
916C               **************************************************
917C               **  STEP 7A--                                   **
918C               **  CASE 1: NO "MULTIPLE" CASE--CAN HAVE EITHER **
919C               **          1, 2, OR 3 VARIABLES.  THE FIRST    **
920C               **          VARIABLE IS A RESPONSE VARIABLE     **
921C               **          AND THE SECOND AND THIRD VARIABLES  **
922C               **          ARE REPLICATION VARIABLES (IF       **
923C               **          PRESENT).  NOTE THAT THIS VERSION   **
924C               **          DOES NOT ACCEPT MATRIX ARGUMENTS    **
925C               **          EVEN IF ONLY A SINGLE ARGUMENT IS   **
926C               **          GIVEN (YOU CAN USE THE MULTIPLE     **
927C               **          OPTION IN THAT CASE).               **
928C               **************************************************
929C
930      IF(IREP2.EQ.'ON')THEN
931        ISTEPN='7A'
932        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPI')
933     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
934C
935        ICOL=1
936        IF(NRESP.EQ.1)THEN
937          CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
938     1                INAME,IVARN1,IVARN2,IVARTY,
939     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
940     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
941     1                MAXCP4,MAXCP5,MAXCP6,
942     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
943     1                Y1,X1,X2,X3,X4,X5,X6,NLOCAL,
944     1                IBUGG2,ISUBRO,IFOUND,IERROR)
945        ELSE
946          CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
947     1                INAME,IVARN1,IVARN2,IVARTY,
948     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
949     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
950     1                MAXCP4,MAXCP5,MAXCP6,
951     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
952     1                Y1,Y2,X1,X2,X3,X4,X5,NLOCAL,
953     1                IBUGG2,ISUBRO,IFOUND,IERROR)
954        ENDIF
955        IF(IERROR.EQ.'YES')GOTO9000
956C
957C       FOR THIS CASE, THERE ARE EXACTLY TWO REPLICATION VARIABLES.
958C       LOOP OVER THE DISTINCT VALUES IN THE SECOND REPLICATION
959C       VARIABLE.
960C
961        CALL DISTIN(X1,NLOCAL,IWRITE,XTEMP3,NUMSE1,IBUGG2,IERROR)
962        CALL DISTIN(X2,NLOCAL,IWRITE,XTEMP3,NUMSE2,IBUGG2,IERROR)
963        CALL SORT(XTEMP3,NUMSE2,XTEMP3)
964        CALL CODE(XTEMP3,NUMSE2,IWRITE,XTEMP4,XTEMP5,MAXOBV,
965     1            IBUGG2,IERROR)
966        NREPI1=NUMSE1
967        NREPI2=NUMSE2
968C
969C       RESTRICT SECOND REPLICATION VARIABLE TO A MAXIMUM OF
970C       10 DISTINCT VALUE.
971C
972        IF(NUMSE2.GT.10)THEN
973          WRITE(ICOUT,999)
974          CALL DPWRST('XXX','BUG ')
975          WRITE(ICOUT,101)
976          CALL DPWRST('XXX','BUG ')
977          WRITE(ICOUT,7006)
978 7006     FORMAT('      FOR THE 3-VARIABLE REPLICATION CASE, THE ',
979     1           'NUMBER OF REPLICATIONS')
980          CALL DPWRST('XXX','BUG ')
981          WRITE(ICOUT,7007)
982 7007     FORMAT('      FOR THE SECOND REPLICTATION VARIABLE ',
983     1           'IS GREATER THAN 10.')
984          CALL DPWRST('XXX','BUG ')
985          IERROR='YES'
986          GOTO9000
987        ENDIF
988C
989        IF(NUMSE2.EQ.2)THEN
990          XSTRT=-0.2
991          XINC=0.4
992        ELSEIF(NUMSE2.EQ.3)THEN
993          XSTRT=-0.2
994          XINC=0.2
995        ELSEIF(NUMSE2.EQ.4)THEN
996          XSTRT=-0.3
997          XINC=0.2
998        ELSEIF(NUMSE2.EQ.5)THEN
999          XSTRT=-0.4
1000          XINC=0.2
1001        ELSE
1002          XSTRT=-0.4
1003          XINC=0.8/REAL(NUMSE2-1)
1004        ENDIF
1005        NPLOTP=0
1006        DO7001K=1,NUMSE2
1007          ATEMP=XTEMP3(K)
1008          ICNT=0
1009          XFACT=XSTRT + (K-1)*XINC
1010          DO7003L=1,NLOCAL
1011            IF(ATEMP.EQ.X2(L))THEN
1012              ICNT=ICNT+1
1013              XTEMP5(ICNT)=Y1(L)
1014              TEMPZ(ICNT)=Y2(L)
1015              XTEMP6(ICNT)=X1(L) + XFACT
1016            ENDIF
1017 7003     CONTINUE
1018          NUMV2=NRESP+1
1019          IF(K.EQ.1)JD=0
1020          CALL DPI2(XTEMP5,XTEMP6,TEMPZ,XTEMP6,ICNT,ICNT,NUMV2,
1021     1              ICASPL,IBINME,IBI2ME,ICVACI,PSTAMV,
1022     1              ITOLGC,ITOLM2,PTOLDF,IIPLJI,
1023     1              ISIZE,ICONT,IQUAME,IQUASE,IRATME,MAXOBV,ISEED,
1024     1              ALPHA,GAMMA,P1,P2,P100,NNEW,JD,
1025     1              XIDTEM,XIDTE2,TEMP,XTEMP4,TEMP1,TEMP2,
1026     1              Y,X,D,NPLOTP,NPLOTV,IBUGG2,ISUBRO,IERROR)
1027 7001   CONTINUE
1028C
1029      ELSEIF(IMULT.EQ.'OFF')THEN
1030        ISTEPN='7B'
1031        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPI')
1032     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1033C
1034        ICOL=1
1035        IF(NRESP.EQ.1)THEN
1036          CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1037     1                INAME,IVARN1,IVARN2,IVARTY,
1038     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
1039     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1040     1                MAXCP4,MAXCP5,MAXCP6,
1041     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1042     1                Y1,X1,X2,X3,X4,X5,X6,NLOCAL,
1043     1                IBUGG2,ISUBRO,IFOUND,IERROR)
1044        ELSE
1045C
1046C         2018/06: HANDLE 4-VARIABLE CASE FOR DIFFERENCE OF MEANS
1047C                  AND DIFFERENCE OF PROPORTIONS SEPARATELY.
1048C
1049          IF(NUMVAR.EQ.4 .AND.
1050     1      (ICASPL.EQ.'DMEA' .OR. ICASPL.EQ.'DPRO'))THEN
1051C
1052            ICOL=1
1053            NUMVA2=2
1054            CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1055     1                  INAME,IVARN1,IVARN2,IVARTY,
1056     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1057     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1058     1                  MAXCP4,MAXCP5,MAXCP6,
1059     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1060     1                  Y1,X1,X1,X1,X1,X1,X1,NLOCAL,
1061     1                  IBUGG2,ISUBRO,IFOUND,IERROR)
1062            IF(IERROR.EQ.'YES')GOTO9000
1063C
1064            ICOL=3
1065            NUMVA2=2
1066            CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1067     1                  INAME,IVARN1,IVARN2,IVARTY,
1068     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1069     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1070     1                  MAXCP4,MAXCP5,MAXCP6,
1071     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1072     1                  Y2,X2,X2,X2,X2,X2,X2,NLOCA2,
1073     1                  IBUGG2,ISUBRO,IFOUND,IERROR)
1074            IF(IERROR.EQ.'YES')GOTO9000
1075C
1076            JD=0
1077            NPLOTP=0
1078            CALL DPI2(Y1,X1,Y2,X2,NLOCAL,NLOCA2,NUMVAR,
1079     1                ICASPL,IBINME,IBI2ME,ICVACI,PSTAMV,
1080     1                ITOLGC,ITOLM2,PTOLDF,IIPLJI,
1081     1                ISIZE,ICONT,IQUAME,IQUASE,IRATME,MAXOBV,ISEED,
1082     1                ALPHA,GAMMA,P1,P2,P100,NNEW,JD,
1083     1                XIDTEM,XIDTE2,TEMP,TEMPZ,TEMP1,TEMP2,
1084     1                Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
1085C
1086            GOTO9000
1087          ENDIF
1088C
1089          CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1090     1                INAME,IVARN1,IVARN2,IVARTY,
1091     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
1092     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1093     1                MAXCP4,MAXCP5,MAXCP6,
1094     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1095     1                Y1,Y2,X1,X2,X3,X4,X5,NLOCAL,
1096     1                IBUGG2,ISUBRO,IFOUND,IERROR)
1097          IF(IERROR.EQ.'YES')GOTO9000
1098          IF(NREPL.EQ.6)THEN
1099            ICOL=8
1100            NUMVA2=1
1101            CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1102     1                  INAME,IVARN1,IVARN2,IVARTY,
1103     1                  ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1104     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1105     1                  MAXCP4,MAXCP5,MAXCP6,
1106     1                  V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1107     1                  X6,X6,X6,X6,X6,X6,X6,NLOCA2,
1108     1                  IBUGG2,ISUBRO,IFOUND,IERROR)
1109          ENDIF
1110        ENDIF
1111        IF(IERROR.EQ.'YES')GOTO9000
1112C
1113C       IF THERE ARE TWO OR MORE REPLICATION VARIABLES, COMBINE
1114C       THEM TO CREATE A SINGLE REPLICATION VARIABLE.
1115C
1116        IF(NUMVAR.EQ.NRESP+2)THEN
1117          CALL CODCT2(X1,X2,NLOCAL,ICCTOF,ICCTG1,IWRITE,
1118     1                XTEMP0,XTEMP1,XTEMP2,
1119     1                IBUGG2,ISUBRO,IERROR)
1120          DO7011I=1,NLOCAL
1121            X1(I)=XTEMP0(I)
1122 7011     CONTINUE
1123          NUMVAR=2
1124        ELSEIF(NUMVAR.EQ.NRESP+3)THEN
1125          CALL CODCT3(X1,X2,X3,NLOCAL,ICCTOF,ICCTG1,ICCTG2,IWRITE,
1126     1                XTEMP0,XTEMP1,XTEMP2,XTEMP3,
1127     1                IBUGG2,ISUBRO,IERROR)
1128          DO7012I=1,NLOCAL
1129            X1(I)=XTEMP0(I)
1130 7012     CONTINUE
1131          NUMVAR=2
1132        ELSEIF(NUMVAR.EQ.NRESP+4)THEN
1133          CALL CODCT4(X1,X2,X3,X4,NLOCAL,
1134     1                ICCTOF,ICCTG1,ICCTG2,ICCTG3,IWRITE,
1135     1                XTEMP0,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
1136     1                IBUGG2,ISUBRO,IERROR)
1137          DO7013I=1,NLOCAL
1138            X1(I)=XTEMP0(I)
1139 7013     CONTINUE
1140          NUMVAR=2
1141        ELSEIF(NUMVAR.EQ.NRESP+5)THEN
1142          CALL CODCT5(X1,X2,X3,X4,X5,NLOCAL,
1143     1                ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,IWRITE,
1144     1                XTEMP0,XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,
1145     1                IBUGG2,ISUBRO,IERROR)
1146          DO7014I=1,NLOCAL
1147            X1(I)=XTEMP0(I)
1148 7014     CONTINUE
1149          NUMVAR=2
1150        ELSEIF(NUMVAR.EQ.NRESP+6)THEN
1151          CALL CODCT6(X1,X2,X3,X4,X5,X6,NLOCAL,
1152     1                ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,ICCTG5,IWRITE,
1153     1                XTEMP0,XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,XTEMP6,
1154     1                IBUGG2,ISUBRO,IERROR)
1155          DO7015I=1,NLOCAL
1156            X1(I)=XTEMP0(I)
1157 7015     CONTINUE
1158          NUMVAR=2
1159        ELSEIF(NUMVAR.LE.1)THEN
1160          IH='NI  '
1161          IH2='    '
1162          IHWUSE='P'
1163          MESSAG='YES'
1164          CALL CHECKN(IH,IH2,IHWUSE,
1165     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
1166     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
1167          IF(IERROR.EQ.'YES')THEN
1168            ISIZE=NLOCAL
1169          ELSE
1170            ISIZE=INT(VALUE(ILOCP)+0.5)
1171          ENDIF
1172C
1173        ENDIF
1174C
1175        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPI')THEN
1176          ISTEPN='7C'
1177          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1178          WRITE(ICOUT,999)
1179          CALL DPWRST('XXX','BUG ')
1180          WRITE(ICOUT,791)NLOCAL
1181  791     FORMAT('DPI2 AFTER FORM REPLICATION VARIABLES: NLOCAL = ',I8)
1182          CALL DPWRST('XXX','BUG ')
1183          DO793I=1,NLOCAL
1184            WRITE(ICOUT,795)I,Y1(I),X1(I)
1185  795       FORMAT('I,Y1(I),X1(I) = ',I8,2G15.7)
1186            CALL DPWRST('XXX','BUG ')
1187  793     CONTINUE
1188        ENDIF
1189C
1190C               *********************************************************
1191C               **  STEP 7B--                                         **
1192C               **  GENERATE THE I PLOT.                              **
1193C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).     **
1194C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).     **
1195C               *********************************************************
1196C
1197        JD=0
1198        NPLOTP=0
1199        CALL DPI2(Y1,X1,Y2,X1,NLOCAL,NLOCAL,NUMVAR,
1200     1            ICASPL,IBINME,IBI2ME,ICVACI,PSTAMV,
1201     1            ITOLGC,ITOLM2,PTOLDF,IIPLJI,
1202     1            ISIZE,ICONT,IQUAME,IQUASE,IRATME,MAXOBV,ISEED,
1203     1            ALPHA,GAMMA,P1,P2,P100,NNEW,JD,
1204     1            XIDTEM,XIDTE2,TEMP,TEMPZ,TEMP1,TEMP2,
1205     1            Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
1206C
1207C               ***********************************************
1208C               **  STEP 8A--                                **
1209C               **  CASE 2: MULTIPLE RESPONSE VARIABLES.     **
1210C               **          THESE CAN BE EITHER VARIABLE OR  **
1211C               **          MATRIX ARGUMENTS.                **
1212C               ***********************************************
1213C
1214      ELSEIF(IMULT.EQ.'ON')THEN
1215        ISTEPN='8A'
1216        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPI')
1217     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1218C
1219C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES.  NOTE THAT IN
1220C       THIS CASE, WE ARE ULTIMATELY CREATING A "Y X" SYNTAX, SO THE
1221C       LOOP IS MERELY ADDING A NEW GROUP.  NEED TO BE CAREFUL THAT
1222C       COMBINED DATA DOES NOT EXCEED MAXIMUM POINTS FOR AN ARRAY.
1223C
1224C       2016/07: ALLOW Y1 AND X1 TO HAVE DIMENSION 5*MAXOBV.  THIS
1225C                CAN BE HELPFUL FOR LARGER DATA SETS.
1226C
1227C       2017/11: NOTE THAT THIS CASE NOT SUPPORTED FOR THE CASES
1228C                WHERE THERE ARE TWO RESPONSE VARIABLES.  THIS IS
1229C                CHECKED FOR ABOVE.
1230C
1231        NPLOTP=0
1232        DO810IRESP=1,NRESP
1233          NCURVE=IRESP
1234C
1235          IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPI')THEN
1236            WRITE(ICOUT,999)
1237            CALL DPWRST('XXX','BUG ')
1238            WRITE(ICOUT,811)IRESP,NCURVE
1239  811       FORMAT('IRESP,NCURVE = ',2I5)
1240            CALL DPWRST('XXX','BUG ')
1241          ENDIF
1242C
1243          ICOL=IRESP
1244          NUMVA2=1
1245          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1246     1                INAME,IVARN1,IVARN2,IVARTY,
1247     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1248     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1249     1                MAXCP4,MAXCP5,MAXCP6,
1250     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1251     1                XTEMP1,XTEMP2,XTEMP3,NLOCAL,NLOCA2,NLOCA3,ICASE,
1252     1                IBUGG2,ISUBRO,IFOUND,IERROR)
1253          IF(IERROR.EQ.'YES')GOTO9000
1254          DO815JJ=1,NLOCAL
1255            NPLOTP=NPLOTP+1
1256CCCCC       IF(NPLOTP.GT.MAXOBV)THEN
1257            IF(NPLOTP.GT.5*MAXOBV)THEN
1258              WRITE(ICOUT,999)
1259              CALL DPWRST('XXX','BUG ')
1260              WRITE(ICOUT,101)
1261              CALL DPWRST('XXX','BUG ')
1262              WRITE(ICOUT,816)
1263  816         FORMAT('      FOR THE MULTIPLE CASE, THE MAXIMUM NUMBER ',
1264     1               'OF POINTS HAS BEEN EXCEEDED.')
1265              CALL DPWRST('XXX','BUG ')
1266              IERROR='YES'
1267              GOTO9000
1268            ENDIF
1269            Y1(NPLOTP)=XTEMP1(JJ)
1270            X1(NPLOTP)=REAL(NCURVE)
1271  815     CONTINUE
1272C
1273  810   CONTINUE
1274        NLOCAL=NPLOTP
1275        NUMVAR=2
1276C
1277C               *****************************************************
1278C               **  STEP 8B--                                      **
1279C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
1280C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
1281C               *****************************************************
1282C
1283        NPLOTP=0
1284        JD=0
1285        CALL DPI2(Y1,X1,Y2,X1,NLOCAL,NLOCAL,NUMVAR,
1286     1            ICASPL,IBINME,IBI2ME,ICVACI,PSTAMV,
1287     1            ITOLGC,ITOLM2,PTOLDF,IIPLJI,
1288     1            ISIZE,ICONT,IQUAME,IQUASE,IRATME,MAXOBV,ISEED,
1289     1            ALPHA,GAMMA,P1,P2,P100,NNEW,JD,
1290     1            XIDTEM,XIDTE2,TEMP,TEMPZ,TEMP1,TEMP2,
1291     1            Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
1292      ENDIF
1293C
1294C               *****************
1295C               **  STEP 90--  **
1296C               **  EXIT       **
1297C               *****************
1298C
1299 9000 CONTINUE
1300      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'DPI')THEN
1301        WRITE(ICOUT,999)
1302        CALL DPWRST('XXX','BUG ')
1303        WRITE(ICOUT,9011)
1304 9011   FORMAT('***** AT THE END       OF DPI--')
1305        CALL DPWRST('XXX','BUG ')
1306        WRITE(ICOUT,9012)IFOUND,IFOUN1,IFOUN2,IERROR
1307 9012   FORMAT('IFOUND,IFOUN1,IFOUN2,IERROR = ',3(A4,2X),A4)
1308        CALL DPWRST('XXX','BUG ')
1309        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2
1310 9013   FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ',
1311     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
1312        CALL DPWRST('XXX','BUG ')
1313        WRITE(ICOUT,9014)ISIZE,NUMVAR
1314 9014   FORMAT('ISIZE,NUMVAR = ',2I8)
1315        CALL DPWRST('XXX','BUG ')
1316        IF(NPLOTP.GE.1)THEN
1317          DO9015I=1,NPLOTP
1318            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
1319 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
1320            CALL DPWRST('XXX','BUG ')
1321 9015     CONTINUE
1322        ENDIF
1323      ENDIF
1324C
1325      RETURN
1326      END
1327      SUBROUTINE DPI2(Y,X,YZ,XZ,N,NZ,NUMV2,
1328     1                ICASPL,IBINME,IBI2ME,ICVACI,PSTAMV,
1329     1                ITOLGC,ITOLM2,PTOLDF,IIPLJI,
1330     1                ISIZE,ICONT,IQUAME,IQUASE,IRATME,MAXNXT,ISEED,
1331     1                ALPHA,GAMMA,P1,P2,P100,NNEW,JD,
1332     1                XIDTEM,XIDTE2,TEMP,TEMPZ,XTEMP1,XTEMP2,
1333     1                Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
1334C
1335C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
1336C              THAT WILL DEFINE AN I PLOT
1337C              OF THE FOLLOWING TYPES--
1338C                 1) (MEDIAN) I  PLOT;
1339C                 2) MEAN I  PLOT;
1340C                 3) MIDRANGE I  PLOT;
1341C                 4) MIDMEAN I  PLOT;
1342C     WRITTEN BY--JAMES J. FILLIBEN
1343C                 STATISTICAL ENGINEERING DIVISION
1344C                 INFORMATION TECHNOLOGY LABORATORY
1345C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1346C                 GAITHERSBURG, MD 20899-8980
1347C                 PHONE--301-975-2855
1348C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1349C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1350C     LANGUAGE--ANSI FORTRAN (1977)
1351C     VERSION NUMBER--82/7
1352C     ORIGINAL VERSION--FEBRUARY  1981.
1353C     UPDATED         --DECEMBER  1981.
1354C     UPDATED         --MAY       1982.
1355C     UPDATED         --FEBRUARY  2011. ISUBRO ARGUMENT
1356C     UPDATED         --OCTOBER   2013. ADD SUPPORT FOR NEW PLOT OPTIONS
1357C     UPDATED         --NOVEMBER  2017. UPDATES TO AGRESTI-COUL
1358C                                       CONFIDENCE LIMTIS
1359C     UPDATED         --NOVEMBER  2017. DIFFERENCE OF PROPORTIONS
1360C     UPDATED         --NOVEMBER  2017. COEFFICIENT OF VARIATION
1361C     UPDATED         --NOVEMBER  2017. COEFFICIENT OF DISPERSION
1362C     UPDATED         --DECEMBER  2017. COEFFICIENT OF QUARTILE DISPERSION
1363C     UPDATED         --APRIL     2018. CORRELATION
1364C     UPDATED         --JUNE      2018. SUPPORT UNEQUAL SAMPLE SIZES FOR:
1365C                                          DIFFERENCE OF MEAN
1366C                                          DIFFERENCE OF PROPORTIONS
1367C     UPDATED         --OCTOBER   2019. RATIO OF MEANS
1368C     UPDATED         --JANUARY   2020. SUPPORT JITTER
1369C
1370C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1371C
1372      CHARACTER*4 ICASPL
1373      CHARACTER*4 IBINME
1374      CHARACTER*4 IBI2ME
1375      CHARACTER*4 ICVACI
1376      CHARACTER*4 ICONT
1377      CHARACTER*4 IQUAME
1378      CHARACTER*4 IRATME
1379      CHARACTER*4 IQUASE
1380      CHARACTER*4 ITOLGC
1381      CHARACTER*4 ITOLM2
1382      CHARACTER*4 IIPLJI
1383      CHARACTER*4 IBUGG3
1384      CHARACTER*4 ISUBRO
1385      CHARACTER*4 IERROR
1386C
1387      CHARACTER*4 ISUBN1
1388      CHARACTER*4 ISUBN2
1389      CHARACTER*4 ISTEPN
1390      CHARACTER*4 IWRITE
1391      CHARACTER*4 ICASAN
1392      CHARACTER*4 ICASA2
1393      CHARACTER*4 ICASA3
1394      CHARACTER*4 ICASA4
1395      CHARACTER*4 ICASA5
1396      CHARACTER*4 IDIST
1397C
1398C---------------------------------------------------------------------
1399C
1400      DIMENSION Y(*)
1401      DIMENSION YZ(*)
1402      DIMENSION X(*)
1403      DIMENSION XZ(*)
1404      DIMENSION Y2(*)
1405      DIMENSION X2(*)
1406      DIMENSION D2(*)
1407C
1408      DIMENSION XIDTEM(*)
1409      DIMENSION XIDTE2(*)
1410      DIMENSION TEMP(*)
1411      DIMENSION TEMPZ(*)
1412      DIMENSION XTEMP1(*)
1413      DIMENSION XTEMP2(*)
1414C
1415      DIMENSION ALPHAT(1)
1416      DIMENSION ALOWLV(1)
1417      DIMENSION AUPPLV(1)
1418C
1419C---------------------------------------------------------------------
1420C
1421      INCLUDE 'DPCOP2.INC'
1422C
1423C-----START POINT-----------------------------------------------------
1424C
1425      ISUBN1='DPI2'
1426      ISUBN2='    '
1427      IWRITE='OFF'
1428C
1429      I2=0
1430      AN=0.0
1431      N50=1
1432      NRESP=1
1433C
1434C     2018/06: DIFFERENCE OF MEAN AND DIFFERENCE OF PROPORTION SUPPORT
1435C              A 4 VARIABLE CASE (Y1 X1 Y2 X2) FOR UNEQUAL SAMPLE
1436C              SIZES.
1437C
1438      IFLAGD=0
1439      IF(ICASPL.EQ.'DPRO' .OR. ICASPL.EQ.'DMEA' .OR.
1440     1   ICASPL.EQ.'CRCL' .OR. ICASPL.EQ.'RMEA')THEN
1441        NRESP=2
1442        IF(ICASPL.EQ.'DPRO' .OR. ICASPL.EQ.'DMEA')THEN
1443          IF(NUMV2.EQ.4)IFLAGD=1
1444        ENDIF
1445      ENDIF
1446C
1447C     CHECK THE INPUT ARGUMENTS FOR ERRORS
1448C
1449      IF(N.LT.2)THEN
1450        WRITE(ICOUT,999)
1451  999   FORMAT(1X)
1452        CALL DPWRST('XXX','BUG ')
1453        WRITE(ICOUT,31)
1454   31   FORMAT('***** ERROR IN I PLOT--')
1455        CALL DPWRST('XXX','BUG ')
1456        WRITE(ICOUT,32)
1457   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;')
1458        CALL DPWRST('XXX','BUG ')
1459        WRITE(ICOUT,34)N
1460   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
1461        CALL DPWRST('XXX','BUG ')
1462        WRITE(ICOUT,999)
1463        CALL DPWRST('XXX','BUG ')
1464        IERROR='YES'
1465        GOTO9000
1466      ENDIF
1467C
1468      IF(IFLAGD.EQ.1 .AND. NZ.LT.2)THEN
1469        WRITE(ICOUT,999)
1470        CALL DPWRST('XXX','BUG ')
1471        WRITE(ICOUT,31)
1472        CALL DPWRST('XXX','BUG ')
1473        WRITE(ICOUT,42)
1474   42   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE SECOND ',
1475     1         'RESPONSE VARIABLE MUST BE AT LEAST 2;')
1476        CALL DPWRST('XXX','BUG ')
1477        WRITE(ICOUT,34)NZ
1478        CALL DPWRST('XXX','BUG ')
1479        WRITE(ICOUT,999)
1480        CALL DPWRST('XXX','BUG ')
1481        IERROR='YES'
1482        GOTO9000
1483      ENDIF
1484C
1485C     DON'T TREAT ALL RESPONSE VALUES EQUAL AS AN ERROR
1486C
1487CCCCC HOLD=Y(1)
1488CCCCC DO60I=1,N
1489CCCCC   IF(Y(I).NE.HOLD)GOTO69
1490CCC60 CONTINUE
1491CCCCC WRITE(ICOUT,999)
1492CCCCC CALL DPWRST('XXX','BUG ')
1493CCCCC WRITE(ICOUT,31)
1494CCCCC CALL DPWRST('XXX','BUG ')
1495CCCCC WRITE(ICOUT,62)
1496CCC62 FORMAT('      ALL RESPONSE VARIABLE ELEMENTS')
1497CCCCC CALL DPWRST('XXX','BUG ')
1498CCCCC WRITE(ICOUT,63)HOLD
1499CCC63 FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
1500CCCCC CALL DPWRST('XXX','BUG ')
1501CCCCC WRITE(ICOUT,999)
1502CCCCC CALL DPWRST('XXX','BUG ')
1503CCCCC IERROR='YES'
1504CCCCC GOTO9000
1505CCC69 CONTINUE
1506C
1507      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'DPI2')THEN
1508        WRITE(ICOUT,70)
1509   70   FORMAT('AT THE BEGINNING OF DPI2--')
1510        CALL DPWRST('XXX','BUG ')
1511        WRITE(ICOUT,71)ICONT,ICASPL,PSTAMV
1512   71   FORMAT('ICONT,ICASPL,PSTAMV = ',2(A4,2X),G15.7)
1513        CALL DPWRST('XXX','BUG ')
1514        WRITE(ICOUT,77)N,NZ,NRESP,NUMV2,ISIZE,IIPLJI
1515   77   FORMAT('N,NZ,NRESP,NUMV2,ISIZE,IIPLJI = ',6I8)
1516        CALL DPWRST('XXX','BUG ')
1517        DO72I=1,MAX(N,NZ)
1518          WRITE(ICOUT,73)I,Y(I),X(I),YZ(I),XZ(I)
1519   73     FORMAT('I,Y(I),X(I),YZ(I),XZ(I) = ',I8,4G15.7)
1520          CALL DPWRST('XXX','BUG ')
1521   72   CONTINUE
1522      ENDIF
1523C
1524C               ********************************************************
1525C               **  STEP 1--                                          **
1526C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
1527C               **  FOR VARIABLE 2 (THE GROUP VARIABLE).              **
1528C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
1529C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
1530C               **  WHICH IS AN ERROR CONDITION FOR AN I PLOT .       **
1531C               ********************************************************
1532C
1533      ISTEPN='1'
1534      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPI2')
1535     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1536C
1537      IF(NUMV2.EQ.NRESP)THEN
1538        NUMSET=0
1539        DO120I=ISIZE,N,ISIZE
1540          I2=I
1541          NUMSET=NUMSET+1
1542          XIDTEM(NUMSET)=NUMSET
1543  120   CONTINUE
1544        IF(I2.LT.N)THEN
1545          NUMSET=NUMSET+1
1546          XIDTEM(NUMSET)=NUMSET
1547        ENDIF
1548        DO145I=1,N
1549          IGROUP=1+((I-1)/ISIZE)
1550          IMID=(IGROUP-1)*ISIZE+(ISIZE/2)
1551          X(I)=IMID
1552  145   CONTINUE
1553C
1554      ELSEIF(IFLAGD.EQ.1)THEN
1555C
1556        CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR)
1557        IF(IERROR.EQ.'YES')GOTO9000
1558        CALL SORT(XIDTEM,NUMSET,XIDTEM)
1559        XID1=XIDTEM(1)
1560        XID2=XIDTEM(NUMSET)
1561        CALL DISTIN(XZ,NZ,IWRITE,XIDTE2,NUMSE2,IBUGG3,IERROR)
1562        IF(IERROR.EQ.'YES')GOTO9000
1563        CALL SORT(XIDTE2,NUMSE2,XIDTE2)
1564C
1565C       CURRENTLY ONLY SUPPORT CASE WHERE THE GROUPS ARE THE SAME
1566C
1567        IF(NUMSET.EQ.NUMSE2)THEN
1568          DO155II=1,NUMSET
1569            IF(XIDTEM(II).NE.XIDTE2(II))THEN
1570              WRITE(ICOUT,999)
1571              CALL DPWRST('XXX','BUG ')
1572              WRITE(ICOUT,31)
1573              CALL DPWRST('XXX','BUG ')
1574              WRITE(ICOUT,156)
1575  156         FORMAT('      THE GROUP-ID VARIABLES DO NOT HAVE THE ',
1576     1               'SAME VALUES.')
1577              CALL DPWRST('XXX','BUG ')
1578              IERROR='YES'
1579              GOTO9000
1580            ENDIF
1581  155     CONTINUE
1582        ELSE
1583          WRITE(ICOUT,999)
1584          CALL DPWRST('XXX','BUG ')
1585          WRITE(ICOUT,31)
1586          CALL DPWRST('XXX','BUG ')
1587          WRITE(ICOUT,157)
1588  157     FORMAT('      THE GROUP-ID VARIABLES DO NOT HAVE THE ',
1589     1               'SAME NUMBER OF ELEMENTS.')
1590          CALL DPWRST('XXX','BUG ')
1591          WRITE(ICOUT,158)NUMSET
1592  158     FORMAT('      GROUP-ID VARIABLE ONE HAS ',I8,' UNIQUE ',
1593     1               'ELEMENTS.')
1594          CALL DPWRST('XXX','BUG ')
1595          WRITE(ICOUT,159)NUMSE2
1596  159     FORMAT('      GROUP-ID VARIABLE TWO HAS ',I8,' UNIQUE ',
1597     1               'ELEMENTS.')
1598          CALL DPWRST('XXX','BUG ')
1599          IERROR='YES'
1600          GOTO9000
1601        ENDIF
1602      ELSEIF(NUMV2.EQ.NRESP+1)THEN
1603        CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR)
1604        IF(IERROR.EQ.'YES')GOTO9000
1605        CALL SORT(XIDTEM,NUMSET,XIDTEM)
1606        XID1=XIDTEM(1)
1607        XID2=XIDTEM(NUMSET)
1608      ENDIF
1609C
1610      IF(NUMSET.EQ.0)THEN
1611        WRITE(ICOUT,31)
1612        CALL DPWRST('XXX','BUG ')
1613        WRITE(ICOUT,191)
1614  191   FORMAT('      NUMSET = 0')
1615        CALL DPWRST('XXX','BUG ')
1616        IERROR='YES'
1617        GOTO9000
1618C
1619      ELSEIF(NUMSET.EQ.N)THEN
1620        WRITE(ICOUT,31)
1621        CALL DPWRST('XXX','BUG ')
1622        WRITE(ICOUT,192)
1623  192   FORMAT('      NUMSET = N')
1624        CALL DPWRST('XXX','BUG ')
1625        IERROR='YES'
1626        GOTO9000
1627      ENDIF
1628C
1629C               ********************************************************
1630C               **  STEP 4--                                          **
1631C               **  IN ORDER TO DETERMINE THE PROPER PLOT COOORDINATES**
1632C               **  FOR THE DESIRED PLOT,                             **
1633C               **  FIRST BRANCH TO THE PROPER SUBCASE--              **
1634C               **         1) (MEDIAN) I  PLOT;                       **
1635C               **         2) MEAN I  PLOT;                           **
1636C               ********************************************************
1637C
1638      ISTEPN='4'
1639      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPI2')
1640     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1641C
1642C               ***************************************************
1643C               **  STEP 4A--                                    **
1644C               **  DETERMINE PLOT COORDINATES FOR 4 SUBCASES--  **
1645C               **      1) (MEDIAN) I  PLOT;                     **
1646C               **      2) MEAN I  PLOT;                         **
1647C               **      3) MIDRANGE I  PLOT;                     **
1648C               **      4) MIDMEAN I  PLOT;                      **
1649C               ***************************************************
1650C
1651      ISTEPN='4A'
1652      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'DPI2')
1653     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1654C
1655      AN=N
1656      ANUMSE=NUMSET
1657C
1658C     2018/06: CHECK FOR "MISSING DATA" VALUES
1659C
1660      NUMCPL=11
1661      J=N2
1662      DO1110ISET=1,NUMSET
1663C
1664        K=0
1665        K2=0
1666        IF(IFLAGD.EQ.0)THEN
1667          DO1120I=1,N
1668            IF(X(I).EQ.XIDTEM(ISET))THEN
1669C
1670C             NOTE: CORRELATION DATA VALUES MUST BE PAIRED, SO ELIMINATE
1671C                   ANY ROWS WHERE EITHER DATA VALUE IS MISSING
1672C
1673              IF(ICASPL.EQ.'CORR' .OR. ICASPL.EQ.'RMEA')THEN
1674                IF(Y(I).NE.PSTAMV .AND. YZ(I).NE.PSTAMV)THEN
1675                  K=K+1
1676                  TEMP(K)=Y(I)
1677                  TEMPZ(K)=YZ(I)
1678                ENDIF
1679              ELSE
1680                IF(Y(I).NE.PSTAMV)THEN
1681                  K=K+1
1682                  TEMP(K)=Y(I)
1683                ENDIF
1684                IF(NRESP.EQ.2 .AND. YZ(I).NE.PSTAMV)THEN
1685                  K2=K2+1
1686                  TEMPZ(K2)=YZ(I)
1687                ENDIF
1688              ENDIF
1689            ENDIF
1690 1120     CONTINUE
1691        ELSE
1692          DO1130I=1,N
1693            IF(X(I).EQ.XIDTEM(ISET))THEN
1694              IF(Y(I).NE.PSTAMV)THEN
1695                K=K+1
1696                TEMP(K)=Y(I)
1697              ENDIF
1698            ENDIF
1699 1130     CONTINUE
1700          DO1135I=1,NZ
1701            IF(XZ(I).EQ.XIDTEM(ISET))THEN
1702              IF(YZ(I).NE.PSTAMV)THEN
1703                K2=K2+1
1704                TEMPZ(K2)=YZ(I)
1705              ENDIF
1706            ENDIF
1707 1135     CONTINUE
1708        ENDIF
1709C
1710        NI=K
1711        ANI=NI
1712        NI2=K2
1713        ANI2=NI2
1714C
1715        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'DPI2')THEN
1716          WRITE(ICOUT,1121)ISET,XIDTEM(ISET),NI,NI2
1717 1121     FORMAT('ISET,XIDTEM(ISET),NI,NI2 = ',I8,G15.7,2I8)
1718          CALL DPWRST('XXX','BUG ')
1719        ENDIF
1720C
1721        IF(NI.LE.0)THEN
1722          WRITE(ICOUT,999)
1723          CALL DPWRST('XXX','BUG ')
1724          WRITE(ICOUT,31)
1725          CALL DPWRST('XXX','BUG ')
1726          WRITE(ICOUT,1142)
1727 1142     FORMAT('      NI FOR SOME CLASS = 0')
1728          CALL DPWRST('XXX','BUG ')
1729          WRITE(ICOUT,1143)ISET,XIDTEM(ISET),NI
1730 1143     FORMAT('      ISET,XIDTEM(ISET),NI = ',I8,G15.7,I8)
1731          CALL DPWRST('XXX','BUG ')
1732          IERROR='YES'
1733          GOTO9000
1734        ELSEIF(NRESP.EQ.2 .AND. NI2.LE.0)THEN
1735          WRITE(ICOUT,999)
1736          CALL DPWRST('XXX','BUG ')
1737          WRITE(ICOUT,31)
1738          CALL DPWRST('XXX','BUG ')
1739          WRITE(ICOUT,1147)
1740 1147     FORMAT('      NI2 FOR SOME CLASS = 0')
1741          CALL DPWRST('XXX','BUG ')
1742          WRITE(ICOUT,1148)ISET,XIDTEM(ISET),NI2
1743 1148     FORMAT('      ISET,XIDTEM(ISET),NI2 = ',I8,G15.7,I8)
1744          CALL DPWRST('XXX','BUG ')
1745          IERROR='YES'
1746          GOTO9000
1747        ENDIF
1748C
1749        XMID=XIDTEM(ISET)
1750C
1751        IF(ICASPL.EQ.'MECL')THEN
1752          CALL MEAN(TEMP,NI,IWRITE,Y50,IBUGG3,IERROR)
1753          CALL SD(TEMP,NI,IWRITE,YSD,IBUGG3,IERROR)
1754          CDF=1.0 - (ALPHA/2.0)
1755          NM1=NI-1
1756          CALL TPPF(CDF,REAL(NM1),TCVAL)
1757          YMAX=Y50 + TCVAL*YSD/SQRT(REAL(NI))
1758          YMIN=Y50 - TCVAL*YSD/SQRT(REAL(NI))
1759        ELSEIF(ICASPL.EQ.'DMEA')THEN
1760          CALL MEAN(TEMP,NI,IWRITE,Y501,IBUGG3,IERROR)
1761          CALL SD(TEMP,NI,IWRITE,YSD1,IBUGG3,IERROR)
1762          AN1=REAL(NI)
1763          YTEMP1=YSD1**2/AN1
1764          CALL MEAN(TEMPZ,NI2,IWRITE,Y502,IBUGG3,IERROR)
1765          CALL SD(TEMPZ,NI2,IWRITE,YSD2,IBUGG3,IERROR)
1766          AN2=REAL(NI2)
1767          YTEMP2=YSD2**2/AN2
1768          Y50=Y501 - Y502
1769          YSTERR=SQRT(YTEMP1 + YTEMP2)
1770          TERM1=(YTEMP1 + YTEMP2)**2
1771          TERM2=YTEMP1*YTEMP1/(AN1-1.0) + YTEMP2*YTEMP2/(AN2-1.0)
1772          V=TERM1/TERM2
1773          IV=INT(V+0.5)
1774          CDF=1.0 - (ALPHA/2.0)
1775          CALL TPPF(CDF,REAL(IV),TCVAL)
1776          YMAX=Y50 + TCVAL*YSTERR
1777          YMIN=Y50 - TCVAL*YSTERR
1778        ELSEIF(ICASPL.EQ.'1SE ')THEN
1779          CALL MEAN(TEMP,NI,IWRITE,Y50,IBUGG3,IERROR)
1780          CALL SD(TEMP,NI,IWRITE,YSD,IBUGG3,IERROR)
1781          YMAX=Y50 + YSD/SQRT(REAL(NI))
1782          YMIN=Y50 - YSD/SQRT(REAL(NI))
1783        ELSEIF(ICASPL.EQ.'2SE ')THEN
1784          CALL MEAN(TEMP,NI,IWRITE,Y50,IBUGG3,IERROR)
1785          CALL SD(TEMP,NI,IWRITE,YSD,IBUGG3,IERROR)
1786          YMAX=Y50 + 2.0*YSD/SQRT(REAL(NI))
1787          YMIN=Y50 - 2.0*YSD/SQRT(REAL(NI))
1788        ELSEIF(ICASPL.EQ.'1SD ')THEN
1789          CALL MEAN(TEMP,NI,IWRITE,Y50,IBUGG3,IERROR)
1790          CALL SD(TEMP,NI,IWRITE,YSD,IBUGG3,IERROR)
1791          YMAX=Y50 + YSD
1792          YMIN=Y50 - YSD
1793        ELSEIF(ICASPL.EQ.'2SD ')THEN
1794          CALL MEAN(TEMP,NI,IWRITE,Y50,IBUGG3,IERROR)
1795          CALL SD(TEMP,NI,IWRITE,YSD,IBUGG3,IERROR)
1796          YMAX=Y50 + 2.0*YSD
1797          YMIN=Y50 - 2.0*YSD
1798        ELSEIF(ICASPL.EQ.'MDCL' .OR. ICASPL.EQ.'QUCL')THEN
1799          IF(ICASPL.EQ.'MDCL')THEN
1800            CALL MEDIAN(TEMP,NI,IWRITE,XTEMP1,MAXNXT,XMED,
1801     1                  IBUGG3,IERROR)
1802            Y50=XMED
1803          ELSE
1804            CALL QUANT(P100,TEMP,NI,IWRITE,XTEMP1,MAXNXT,IQUAME,XQUANT,
1805     1                 IBUGG3,IERROR)
1806            Y50=XQUANT
1807          ENDIF
1808          CALL QUANSE(P100,TEMP,NI,IWRITE,XTEMP1,MAXNXT,IQUASE,XQUASE,
1809     1                IBUGG3,IERROR)
1810          CDF=1.0 - (ALPHA/2.0)
1811          CALL NORCDF(CDF,TCVAL)
1812          YMAX=Y50 + TCVAL*XQUASE
1813          YMIN=Y50 - TCVAL*XQUASE
1814        ELSEIF(ICASPL.EQ.'TMCL' .OR. ICASPL.EQ.'TMIP')THEN
1815          NTRIM1=-1
1816          NTRIM2=-1
1817          CALL TRIMME(TEMP,NI,P1,P2,NTRIM1,NTRIM2,IWRITE,XTEMP1,
1818     1                MAXNXT,Y50,IBUGG3,ISUBRO,IERROR)
1819          IF(ICASPL.EQ.'TMCL')THEN
1820            CALL TRIMSE(TEMP,NI,P1,P2,NRIM1,NTRIM2,IWRITE,XTEMP1,XTEMP2,
1821     1                  MAXNXT,YSTERR,IBUGG3,ISUBRO,IERROR)
1822C
1823            AN1=NI
1824            LAMBDA=INT(AN1*(P1+P2)/100.)
1825            V=0.7*(AN1-1.0)
1826            IV=NI - LAMBDA - 1
1827            IF(IV.LT.1)IV=1
1828            CDF=1.0 - (ALPHA/2.0)
1829            CALL TPPF(CDF,REAL(IV),TCVAL)
1830            YMAX=Y50 + TCVAL*YSTERR
1831            YMIN=Y50 - TCVAL*YSTERR
1832          ELSE
1833            CALL MINIM(TEMP,NI,IWRITE,YMIN,IBUGG3,IERROR)
1834            CALL MAXIM(TEMP,NI,IWRITE,YMAX,IBUGG3,IERROR)
1835          ENDIF
1836        ELSEIF(ICASPL.EQ.'BWCL' .OR. ICASPL.EQ.'BWIP')THEN
1837          CALL BIWLOC(TEMP,NI,IWRITE,XTEMP1,XTEMP2,MAXNXT,Y50,
1838     1                IBUGG3,IERROR)
1839          IF(ICASPL.EQ.'BWCL')THEN
1840            CALL BIWSCA(TEMP,NI,IWRITE,XTEMP1,XTEMP2,MAXNXT,YBSC,
1841     1                  IBUGG3,IERROR)
1842            AN1=NI
1843            YSTERR=SQRT(YBSC/AN1)
1844            V=0.7*(AN1-1.0)
1845            IV=INT(V+0.5)
1846            CDF=1.0 - (ALPHA/2.0)
1847            CALL TPPF(CDF,REAL(IV),TCVAL)
1848            YMAX=Y50 + TCVAL*YSTERR
1849            YMIN=Y50 - TCVAL*YSTERR
1850          ELSE
1851            CALL MINIM(TEMP,NI,IWRITE,YMIN,IBUGG3,IERROR)
1852            CALL MAXIM(TEMP,NI,IWRITE,YMAX,IBUGG3,IERROR)
1853          ENDIF
1854        ELSEIF(ICASPL.EQ.'NTOL')THEN
1855          XMEAN=CPUMIN
1856          AN=REAL(NI)
1857          ICASAN='2   '
1858          CALL DPTOL3(TEMP,NI,XMEAN,XSD,AN,PTOLDF,
1859     1                ICASAN,ALPHA,GAMMA,ITOLGC,ITOLM2,
1860     1                AK,ALOWLM,AUPPLM,
1861     1                ISUBRO,IBUGG3,IERROR)
1862          Y50=XMEAN
1863          YMAX=AUPPLM
1864          YMIN=ALOWLM
1865        ELSEIF(ICASPL.EQ.'NPRE')THEN
1866          ALPHAT(1)=ALPHA
1867          NALPHA=1
1868          ICASA2='LIMI'
1869          ICASA3='LOWE'
1870          ICASA4='RAW '
1871          ICASA5='TWOS'
1872          CALL DPPRL3(TEMP,NI,NNEW,ICASA2,ICASA3,ICASA4,ICASA5,
1873     1                YMEAN,YSD,
1874     1                ALPHAT,NALPHA,ALOWLV,AUPPLV,
1875     1                ISUBRO,IBUGG3,IERROR)
1876          Y50=YMEAN
1877          YMAX=AUPPLV(1)
1878          YMIN=ALOWLV(1)
1879C
1880        ELSEIF(ICASPL.EQ.'SDCL')THEN
1881          ALPHAT(1)=ALPHA
1882          NALPHA=1
1883          ICASA2='LIMI'
1884          ICASA3='UPPE'
1885          ICASA4='RAW '
1886          ICASA5='TWOS'
1887          CALL MEAN(TEMP,NI,IWRITE,YMEAN,IBUGG3,IERROR)
1888          CALL DPSDC3(TEMP,NI,ICASA2,ICASA3,ICASA4,ICASA5,
1889     1                YSD,
1890     1                ALPHAT,NALPHA,ALOWLV,AUPPLV,
1891     1                ISUBRO,IBUGG3,IERROR)
1892          Y50=YSD
1893          YMAX=AUPPLV(1)
1894          YMIN=ALOWLV(1)
1895        ELSEIF(ICASPL.EQ.'CVCL')THEN
1896          ALPHAT(1)=ALPHA
1897          NALPHA=1
1898          ICASA2='LIMI'
1899          ICASA3='UPPE'
1900          ICASA4='RAW '
1901          ICASA5='TWOS'
1902          IDIST='NORM'
1903          YMEAN=CPUMIN
1904          YSD=CPUMIN
1905          CALL DPCVC3(TEMP,NI,YMEAN,YSD,
1906     1                ICASA2,ICASA3,ICASA4,ICASA5,
1907     1                ISEED,MAXNXT,IDIST,
1908     1                XTEMP1,XTEMP2,
1909     1                ICVACI,ALPHAT,NALPHA,ALOWLV,AUPPLV,YCV,
1910     1                ISUBRO,IBUGG3,IERROR)
1911          Y50=YCV
1912          YMAX=AUPPLV(1)
1913          YMIN=ALOWLV(1)
1914        ELSEIF(ICASPL.EQ.'CDCL')THEN
1915          ALPHAT(1)=ALPHA
1916          NALPHA=1
1917          ICASA3='UPPE'
1918          ICASA5='TWOS'
1919          CALL DPCDC3(TEMP,NI,ICASA3,ICASA5,ISEED,MAXNXT,
1920     1                XTEMP1,ALPHAT,NALPHA,ALOWLV,AUPPLV,
1921     1                YCD,YMED,YAAD,
1922     1                ISUBRO,IBUGG3,IERROR)
1923          Y50=YCD
1924          YMAX=AUPPLV(1)
1925          YMIN=ALOWLV(1)
1926        ELSEIF(ICASPL.EQ.'CRCL')THEN
1927          CALL CORR(TEMP,TEMPZ,NI,IWRITE,Y50,IBUGG3,IERROR)
1928          CALL DPCRC3(Y50,NI,ALPHA,U,Z,YMIN,YMAX,
1929     1                IBUGG3,ISUBRO,IERROR)
1930        ELSEIF(ICASPL.EQ.'RMEA')THEN
1931          ALPHAT(1)=ALPHA
1932          NALPHA=1
1933          IF(IRATME.EQ.'FIEL')THEN
1934            CALL DPMRC3(TEMP,TEMPZ,NI,ALPHAT,NALPHA,
1935     1                  RATIO,ALOWLV,AUPPLV,
1936     1                  YBAR,XBAR,YVAR,XVAR,
1937     1                  ISUBRO,IBUGG3,IERROR)
1938          ELSEIF(IRATME.EQ.'LSAM')THEN
1939            CALL DPMRC4(TEMP,TEMPZ,NI,ALPHAT,NALPHA,
1940     1                  RATIO,ALOWLV,AUPPLV,
1941     1                  YBAR,XBAR,YVAR,XVAR,XYCOV,
1942     1                  ISUBRO,IBUGG3,IERROR)
1943          ELSEIF(IRATME.EQ.'LRAT')THEN
1944            CALL DPMRC5(TEMP,TEMPZ,NI,ALPHAT,NALPHA,
1945     1                  RATIO,ALOWLV,AUPPLV,
1946     1                  YBAR,XBAR,YVAR,XVAR,XYCOV,
1947     1                  ISUBRO,IBUGG3,IERROR)
1948          ENDIF
1949          Y50=RATIO
1950          YMAX=AUPPLV(1)
1951          YMIN=ALOWLV(1)
1952        ELSEIF(ICASPL.EQ.'CQCL')THEN
1953          ALPHAT(1)=ALPHA
1954          NALPHA=1
1955          ICASA3='UPPE'
1956          ICASA5='TWOS'
1957          CALL DPCQD3(TEMP,NI,ICASA3,ICASA5,ISEED,MAXNXT,IQUAME,
1958     1                XTEMP1,ALPHAT,NALPHA,ALOWLV,AUPPLV,
1959     1                CQV,Q1,Q3,
1960     1                ISUBRO,IBUGG3,IERROR)
1961          Y50=CQV
1962          YMAX=AUPPLV(1)
1963          YMIN=ALOWLV(1)
1964       ELSEIF(ICASPL.EQ.'AGCL')THEN
1965C
1966C         11/2017: USE DPPRC3 IN ORDER TO ACCOMODATE MULTIPLE METHODS
1967C                  FOR COMPUTING PROOPORTION CONFIDENCE LIMITS.
1968C
1969CCCCC     ISUCC=0
1970CCCCC     DO1126II=1,NI
1971CCCCC       IF(TEMP(II).GE.0.5 .AND. TEMP(II).LE.1.5)THEN
1972CCCCC         ISUCC=ISUCC+1
1973CCCCC       ENDIF
1974C1126     CONTINUE
1975CCCCC     Y50=REAL(ISUCC)/REAL(NI)
1976CCCCC     CALL DPAGCO(Y50,NI,ALPHA,IWRITE,YMIN,YMAX,IBUGG3,IERROR)
1977          CALL DPPRC3(TEMP,NI,ALPHA,PSTAMV,IBINME,XTEMP1,
1978     1                Y50,YMIN,YMAX,
1979     1                ISUBRO,IBUGG3,IERROR)
1980       ELSEIF(ICASPL.EQ.'DPRO')THEN
1981          CALL DPPRC4(TEMP,NI,TEMPZ,NI2,ALPHA,PSTAMV,IBI2ME,XTEMP1,
1982     1                Y50,YMIN,YMAX,
1983     1                ISUBRO,IBUGG3,IERROR)
1984        ELSEIF(ICASPL.EQ.'MDIP' .OR. ICASPL.EQ.'MEIP' .OR.
1985     1     ICASPL.EQ.'MRIP' .OR. ICASPL.EQ.'MMIP')THEN
1986C
1987          CALL SORT(TEMP,NI,TEMP)
1988C
1989C               ***************************
1990C               **  STEP 4.1--           **
1991C               **  COMPUTE THE MAXIMUM  **
1992C               ***************************
1993C
1994          YMAX=TEMP(NI)
1995C
1996C               *********************************
1997C               **  STEP 4.2--                 **
1998C               **  COMPUTE THE TYPICAL VALUE  **
1999C               **  (MEDIAN, MEAN,             **
2000C               **  MIDRANGE, OR TRIMMED MEAN) **
2001C               *********************************
2002C
2003          IF(ICASPL.EQ.'MDIP')THEN
2004            N50=NI/2
2005            N50P1=N50+1
2006            IEVODD=NI-2*(NI/2)
2007            IF(IEVODD.EQ.0)Y50=(TEMP(N50)+TEMP(N50P1))/2.0
2008            IF(IEVODD.EQ.1)Y50=TEMP(N50P1)
2009          ELSEIF(ICASPL.EQ.'MEIP')THEN
2010            SUM=0.0
2011            DO1134I=1,NI
2012              SUM=SUM+TEMP(I)
2013 1134       CONTINUE
2014            Y50=SUM/ANI
2015          ELSEIF(ICASPL.EQ.'MRIP')THEN
2016            Y50=(TEMP(1)+TEMP(NI))/2.0
2017          ELSEIF(ICASPL.EQ.'MMIP')THEN
2018            NP1=INT(P1*ANI+0.0001)
2019            NP2=INT(P2*ANI+0.0001)
2020            IMIN=NP1+1
2021            IMAX=N-NP2
2022            IF(IMIN.LT.1)IMIN=1
2023            IF(IMAX.GT.NI)IMAX=NI
2024            IF(IMIN.GT.IMAX)IMIN=IMAX
2025            Y50=TEMP(1)
2026            SUM=0.0
2027            L=0
2028            DO1138I=IMIN,IMAX
2029              L=L+1
2030              SUM=SUM+TEMP(I)
2031 1138       CONTINUE
2032            AL=L
2033            Y50=SUM/AL
2034          ENDIF
2035C
2036          NP1=INT(P1*ANI+0.0001)
2037          NP2=INT(P2*ANI+0.0001)
2038C
2039C               ***************************
2040C               **  STEP 4.3--           **
2041C               **  COMPUTE THE MINIMUM  **
2042C               ***************************
2043C
2044          YMIN=TEMP(1)
2045C
2046        ELSE
2047          WRITE(ICOUT,999)
2048          CALL DPWRST('XXX','BUG ')
2049          WRITE(ICOUT,31)
2050          CALL DPWRST('XXX','BUG ')
2051          WRITE(ICOUT,262)
2052  262     FORMAT('      UNRECOGNIZED CASE--')
2053          CALL DPWRST('XXX','BUG ')
2054          WRITE(ICOUT,266)ICASPL
2055  266     FORMAT('      ICASPL = ',A4)
2056          CALL DPWRST('XXX','BUG ')
2057          IERROR='YES'
2058          GOTO9000
2059        ENDIF
2060C
2061        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'DPI2')THEN
2062           WRITE(ICOUT,1151)YMIN,Y50,YMAX,ISET,K,TEMP(K)
2063 1151      FORMAT('YMIN,Y50,YMAX,ISET,K,TEMP(K) = ',3G15.7,2I8,G15.7)
2064           CALL DPWRST('XXX','BUG ')
2065        ENDIF
2066C
2067C               ********************************************
2068C               **  STEP 4.11--                           **
2069C               **  DEFINE THE CHARACTER AT THE MAXIMUM;  **
2070C               ********************************************
2071C
2072        CALL DPCHLI(ICONT,NUMCPL,YMAX,YMAX,XMID,XMID,J,JD,Y2,X2,D2,
2073     1              IERROR)
2074C               ***************************************
2075C               **  STEP 4.12--                      **
2076C               **  DEFINE THE CHARACTER             **
2077C               **  FOR THE TYPICAL VALUE            **
2078C               **  (SUCH AS THE MEDIAN OR MEAN)     **
2079C               ***************************************
2080C
2081        CALL DPCHLI(ICONT,NUMCPL,Y50,Y50,XMID,XMID,J,JD,Y2,X2,D2,IERROR)
2082C
2083C               ********************************************
2084C               **  STEP 4.13--                           **
2085C               **  DEFINE THE CHARACTER AT THE MINIMUM.  **
2086C               ********************************************
2087C
2088        CALL DPCHLI(ICONT,NUMCPL,YMIN,YMIN,XMID,XMID,J,JD,Y2,X2,D2,
2089     1              IERROR)
2090C
2091C               *************************************
2092C               **  STEP 4.14--                    **
2093C               **  DEFINE THE VERTICAL LINE FROM  **
2094C               **  THE MAX TO THE TYPICAL VALUE   **
2095C               *************************************
2096C
2097        CALL DPCHLI(ICONT,NUMCPL,YMAX,Y50,XMID,XMID,J,JD,Y2,X2,D2,
2098     1              IERROR)
2099C
2100C               **********************************
2101C               **  STEP 4.15--                 **
2102C               **  DEFINE THE VERTICAL LINE    **
2103C               **  FROM THE TYPICAL VALUE      **
2104C               **  TO THE MIN                  **
2105C               **********************************
2106C
2107        CALL DPCHLI(ICONT,NUMCPL,Y50,YMIN,XMID,XMID,J,JD,Y2,X2,D2,
2108     1              IERROR)
2109C
2110 1110 CONTINUE
2111C
2112      N2=J
2113      NPLOTV=3
2114      GOTO9000
2115C
2116C               ******************
2117C               **   STEP 90--  **
2118C               **   EXIT       **
2119C               ******************
2120C
2121 9000 CONTINUE
2122      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'DPI2')THEN
2123        WRITE(ICOUT,999)
2124        CALL DPWRST('XXX','BUG ')
2125        WRITE(ICOUT,9011)
2126 9011   FORMAT('***** AT THE END       OF DPI2--')
2127        CALL DPWRST('XXX','BUG ')
2128        WRITE(ICOUT,9012)ICASPL,N,NUMSET,N2,IERROR
2129 9012   FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4)
2130        CALL DPWRST('XXX','BUG ')
2131        WRITE(ICOUT,9014)AN,NI,N50,NUMV2,N2
2132 9014   FORMAT('AN,NI,N50,NUMV2,N2 = ',G15.7,4I8)
2133        CALL DPWRST('XXX','BUG ')
2134        DO9015I=1,N2
2135          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
2136 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2)
2137          CALL DPWRST('XXX','BUG ')
2138 9015   CONTINUE
2139      ENDIF
2140C
2141      RETURN
2142      END
2143      SUBROUTINE DPICHA(ISUBRO,IBUGA3,IERROR)
2144C
2145C     PURPOSE--RETURN THE COLLATING SEQUENCE NUMBER (USUALLY THE
2146C              ASCII INDEX NUMBER) IN A PREVIOUSLY DEFINED STRING.
2147C              THIS IS ESSENTIALLY EQUIVALENT TO USING THE
2148C              ICHAR FUNCTION IN FORTRAN.  NOTE THAT ALL MAJOR
2149C              PLATFORMS CURRENTLY USE THE ASCII COLLATING SEQUENCE,
2150C              BUT A FEWER OLDER PLATFORMS DO NOT (E.G., EBCDIC
2151C              ON SOME IBM).
2152C     EXAMPLE--LET IVAL = ICHAR S
2153C     WRITTEN BY--ALAN HECKERT
2154C                 STATISTICAL ENGINEERING DIVISION
2155C                 INFORMATION TECHNOLOGY LABORATORY
2156C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
2157C                 GAITHERSBURG, MD 20899-8980
2158C                 PHONE--301-975-2899
2159C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2160C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
2161C     LANGUAGE--ANSI FORTRAN (1977)
2162C     VERSION NUMBER--2008/11
2163C     ORIGINAL VERSION--NOVEMBER  2008.
2164C
2165C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2166C
2167      CHARACTER*4 ISUBRO
2168      CHARACTER*4 IBUGA3
2169      CHARACTER*4 IERROR
2170C
2171      CHARACTER*4 NEWNAM
2172      CHARACTER*4 NEWCOL
2173      CHARACTER*4 ICASEL
2174      CHARACTER*4 IHLEFT
2175      CHARACTER*4 IHLEF2
2176      CHARACTER*4 IHRIGH
2177      CHARACTER*4 IHRIG2
2178      CHARACTER*4 ISUBN1
2179      CHARACTER*4 ISUBN2
2180      CHARACTER*4 ISTEPN
2181C
2182      CHARACTER*8 ISTR
2183C
2184C---------------------------------------------------------------------
2185C
2186C-----COMMON----------------------------------------------------------
2187C
2188      INCLUDE 'DPCOPA.INC'
2189      INCLUDE 'DPCOHK.INC'
2190      INCLUDE 'DPCODA.INC'
2191      INCLUDE 'DPCOZI.INC'
2192C
2193      INTEGER ITEMP1(MAXOBV)
2194C
2195      EQUIVALENCE(ITEMP1(1),IGARBG(1))
2196C
2197C-----COMMON VARIABLES (GENERAL)--------------------------------------
2198C
2199      INCLUDE 'DPCOP2.INC'
2200C
2201C-----START POINT-----------------------------------------------------
2202C
2203      ISUBN1='DPIC'
2204      ISUBN2='HA  '
2205      IERROR='NO'
2206C
2207      ILOC3=0
2208      MAXCP1=MAXCOL+1
2209      MAXCP2=MAXCOL+2
2210      MAXCP3=MAXCOL+3
2211      MAXCP4=MAXCOL+4
2212      MAXCP5=MAXCOL+5
2213      MAXCP6=MAXCOL+6
2214C
2215C               *****************************************************
2216C               **  TREAT THE SUBCASE OF THE LET FUNCTION COMMAND  **
2217C               **  WHICH DEFINES A FUNCTION                       **
2218C               *****************************************************
2219C
2220      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ICHA')THEN
2221        WRITE(ICOUT,999)
2222        CALL DPWRST('XXX','BUG ')
2223        WRITE(ICOUT,51)
2224   51   FORMAT('***** AT THE BEGINNING OF DPICHA--')
2225        CALL DPWRST('XXX','BUG ')
2226        WRITE(ICOUT,52)IBUGA3,ISUBRO,NUMNAM
2227   52   FORMAT('IBUGA3,ISUBRO,NUMNAM = ',A4,2X,A4,2X,I8)
2228        CALL DPWRST('XXX','BUG ')
2229        DO55I=1,NUMNAM
2230          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),
2231     1                   IVSTOP(I)
2232   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
2233     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
2234          CALL DPWRST('XXX','BUG ')
2235   55   CONTINUE
2236        WRITE(ICOUT,57)NUMCHF,MAXCHF
2237   57   FORMAT('NUMCHF,MAXCHF = ',2I8)
2238        CALL DPWRST('XXX','BUG ')
2239        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(120,MAXCHF))
2240   60   FORMAT('IFUNC(.)  = ',120A1)
2241        CALL DPWRST('XXX','BUG ')
2242      ENDIF
2243C
2244C               **********************************
2245C               **  STEP 1--                    **
2246C               **  INITIALIZE SOME VARIABLES.  **
2247C               **********************************
2248C
2249      ISTEPN='1'
2250      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ICHA')
2251     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2252C
2253      NEWNAM='NO'
2254      NEWCOL='NO'
2255      ICASEL='UNKN'
2256      NIOLD=0
2257      ICOLL=0
2258      ICOL2=0
2259C
2260C               ******************************************************
2261C               **  STEP 2--                                         *
2262C               **  EXAMINE THE LEFT-HAND SIDE--                     *
2263C               **  IF THIS IS A PREVIOUSLY DEFINED NAME, IT SHOULD  *
2264C               **  BE EITHER A PARAMETER OR A VARIABLE.             *
2265C               ******************************************************
2266C
2267      ISTEPN='2'
2268      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ICHA')
2269     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2270C
2271      IHLEFT=IHARG(1)
2272      IHLEF2=IHARG2(1)
2273C
2274      DO1910I=1,4
2275        IF(IHLEFT(I:I).EQ.'(')THEN
2276          IHLEFT(I:4)=' '
2277          IHLEF2=' '
2278          ICASEL='ELEM'
2279          GOTO1999
2280        ENDIF
2281 1910 CONTINUE
2282      DO1920I=1,4
2283        IF(IHLEF2(I:I).EQ.'(')THEN
2284          IHLEF2(I:4)=' '
2285          ICASEL='ELEM'
2286          GOTO1999
2287        ENDIF
2288 1920 CONTINUE
2289 1999 CONTINUE
2290C
2291      DO2000I=1,NUMNAM
2292        I2=I
2293        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
2294          IF(IUSE(I2).EQ.'P')THEN
2295            ICASEL='PARA'
2296            ILISTL=I2
2297            GOTO2900
2298          ELSEIF(IUSE(I2).EQ.'V')THEN
2299            ICASEL='VARI'
2300            ILISTL=I2
2301            ICOLL=IVALUE(ILISTL)
2302            NIOLD=IN(ILISTL)
2303            GOTO2900
2304          ELSE
2305            WRITE(ICOUT,999)
2306  999       FORMAT(1X)
2307            CALL DPWRST('XXX','BUG ')
2308            WRITE(ICOUT,2001)
2309 2001       FORMAT('***** ERROR IN ICHAR--')
2310            CALL DPWRST('XXX','BUG ')
2311            WRITE(ICOUT,2003)IHLEFT,IHLEF2
2312 2003       FORMAT('      THE NAME ON THE LEFT HAND SIDE (',
2313     1             A4,A4,')')
2314            CALL DPWRST('XXX','BUG ')
2315            WRITE(ICOUT,2005)
2316 2005       FORMAT('      ALREADY EXISTS, BUT NOT AS A PARAMETER ',
2317     1             'OR A VARIABLE.')
2318            CALL DPWRST('XXX','BUG ')
2319            IERROR='YES'
2320            GOTO9000
2321          ENDIF
2322        ENDIF
2323 2000 CONTINUE
2324C
2325      NEWNAM='YES'
2326C
2327      ILISTL=NUMNAM+1
2328      IF(ILISTL.GT.MAXNAM)THEN
2329        WRITE(ICOUT,999)
2330        CALL DPWRST('XXX','BUG ')
2331        WRITE(ICOUT,2001)
2332        CALL DPWRST('XXX','BUG ')
2333        WRITE(ICOUT,2202)
2334 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND ',
2335     1         'FUNCTION')
2336        CALL DPWRST('XXX','BUG ')
2337        WRITE(ICOUT,2203)MAXNAM
2338 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
2339        CALL DPWRST('XXX','BUG ')
2340        WRITE(ICOUT,2204)
2341 2204   FORMAT('      ENTER      STATUS')
2342        CALL DPWRST('XXX','BUG ')
2343        WRITE(ICOUT,2205)
2344 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND')
2345        CALL DPWRST('XXX','BUG ')
2346        WRITE(ICOUT,2206)
2347 2206   FORMAT('      THEN REDEFINE OR DELETE SOME OF THE ALREADY ',
2348     1         'USED NAMES.')
2349        CALL DPWRST('XXX','BUG ')
2350        IERROR='YES'
2351        GOTO9000
2352      ENDIF
2353C
2354 2900 CONTINUE
2355C
2356C               *****************************************************
2357C               **  STEP 3--                                       **
2358C               **  EXTRACT THE NAME ON THE RIGHT HAND SIDE        **
2359C               *****************************************************
2360C
2361      ISTEPN='3'
2362      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ICHA')
2363     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2364C
2365      IHRIGH=IHARG(4)
2366      IHRIG2=IHARG2(4)
2367      DO3000I=1,NUMNAM
2368        I4=I
2369        IF(IHRIGH.EQ.IHNAME(I).AND.IHRIG2.EQ.IHNAM2(I))THEN
2370          IF(IUSE(I4).NE.'F')THEN
2371            WRITE(ICOUT,999)
2372            CALL DPWRST('XXX','BUG ')
2373            WRITE(ICOUT,2001)
2374            CALL DPWRST('XXX','BUG ')
2375            WRITE(ICOUT,3003)IHRIGH,IHRIG2
2376 3003       FORMAT('      THE NAME ON THE RIGHT HAND SIDE (',
2377     1             A4,A4,')')
2378            CALL DPWRST('XXX','BUG ')
2379            WRITE(ICOUT,3005)
2380 3005       FORMAT('      ALREADY EXISTS, BUT NOT AS A STRING.')
2381            CALL DPWRST('XXX','BUG ')
2382            IERROR='YES'
2383            GOTO9000
2384          ELSE
2385            ISTART=IVSTAR(I4)
2386            ISTOP=IVSTOP(I4)
2387            NLEN=ISTOP-ISTART+1
2388            DO3010J=1,NLEN
2389              IINDX=ISTART+J-1
2390              CALL DPCOAN(IFUNC(IINDX)(1:1),IVAL)
2391              ITEMP1(J)=IVAL
2392 3010       CONTINUE
2393            GOTO3900
2394          ENDIF
2395        ENDIF
2396 3000 CONTINUE
2397C
2398      WRITE(ICOUT,999)
2399      CALL DPWRST('XXX','BUG ')
2400      WRITE(ICOUT,2001)
2401      CALL DPWRST('XXX','BUG ')
2402      WRITE(ICOUT,3003)IHRIGH,IHRIG2
2403      CALL DPWRST('XXX','BUG ')
2404      WRITE(ICOUT,3015)
2405 3015 FORMAT('      WAS NOT FOUND IN THE CURRENT NAME LIST.')
2406      CALL DPWRST('XXX','BUG ')
2407      IERROR='YES'
2408      GOTO9000
2409C
2410 3900 CONTINUE
2411C
2412C               *****************************************************
2413C               **  STEP 4--                                       **
2414C               **  SAVE PARAMETER                                 **
2415C               *****************************************************
2416C
2417      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ICHA')THEN
2418        ISTEPN='4'
2419        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2420        WRITE(ICOUT,4011)ISTART,ISTOP,IVAL
2421 4011   FORMAT('ISTART,ISTOP,IVAL = ',3I8)
2422        CALL DPWRST('XXX','BUG ')
2423        WRITE(ICOUT,4013)ICASEL
2424 4013   FORMAT('ICASEL = ',A4)
2425        CALL DPWRST('XXX','BUG ')
2426      ENDIF
2427C
2428      IF(NLEN.EQ.1)THEN
2429        IF(ICASEL.EQ.'UNKN')ICASEL='PARA'
2430      ELSEIF(NLEN.GT.1)THEN
2431        IF(ICASEL.EQ.'UNKN')ICASEL='VARI'
2432      ENDIF
2433C
2434      IF(ICASEL.EQ.'PARA')THEN
2435C
2436        ISTEPN='4A'
2437        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ICHA')
2438     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2439C
2440        IHNAME(ILISTL)=IHLEFT
2441        IHNAM2(ILISTL)=IHLEF2
2442        IUSE(ILISTL)='P'
2443        VALUE(ILISTL)=REAL(ITEMP1(1))
2444        IVALUE(ILISTL)=INT(VALUE(ILISTL)+0.5)
2445        IN(ILISTL)=1
2446        IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
2447C
2448        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
2449          WRITE(ICOUT,999)
2450          CALL DPWRST('XXX','BUG ')
2451          WRITE(ICOUT,15111)IHLEFT,IHLEF2,ITEMP1(1)
245215111     FORMAT(A4,A4,' = ',I6)
2453          CALL DPWRST('XXX','BUG ')
2454          WRITE(ICOUT,999)
2455          CALL DPWRST('XXX','BUG ')
2456        ENDIF
2457      ELSEIF(ICASEL.EQ.'VARI')THEN
2458C
2459        ISTEPN='4B'
2460        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ICHA')
2461     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2462C
2463        IF(NEWNAM.EQ.'YES')THEN
2464          NUMNAM=NUMNAM+1
2465          NUMCOL=NUMCOL+1
2466          ICOLL=NUMCOL
2467        ENDIF
2468        DO15200I=1,NLEN
2469          RIGHT=REAL(ITEMP1(I))
2470          IJ=MAXN*(ICOLL-1)+I
2471          IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
2472          IF(ICOLL.EQ.MAXCP1)PRED(I)=RIGHT
2473          IF(ICOLL.EQ.MAXCP2)RES(I)=RIGHT
2474          IF(ICOLL.EQ.MAXCP3)YPLOT(I)=RIGHT
2475          IF(ICOLL.EQ.MAXCP4)XPLOT(I)=RIGHT
2476          IF(ICOLL.EQ.MAXCP5)X2PLOT(I)=RIGHT
2477          IF(ICOLL.EQ.MAXCP6)TAGPLO(I)=RIGHT
2478C
247915200   CONTINUE
2480C
2481        IHNAME(ILISTL)=IHLEFT
2482        IHNAM2(ILISTL)=IHLEF2
2483        IUSE(ILISTL)='V'
2484        IVALUE(ILISTL)=ICOLL
2485        VALUE(ILISTL)=ICOLL
2486        IN(ILISTL)=NLEN
2487C
2488C
2489        DO15210J4=1,NUMNAM
2490          IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)THEN
2491            IUSE(J4)='V'
2492            IVALUE(J4)=ICOLL
2493            VALUE(J4)=ICOLL
2494            IN(J4)=NLEN
2495            GOTO15219
2496          ENDIF
249715210   CONTINUE
249815219   CONTINUE
2499C
2500        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
2501          WRITE(ICOUT,999)
2502          CALL DPWRST('XXX','BUG ')
2503          WRITE(ICOUT,15211)IHLEFT,IHLEF2,IHRIGH,IHRIG2
250415211     FORMAT(A4,A4,' CONTAINS THE ASCII COLLATING SEQUENCE ',
2505     1           'VALUES FOR ',A4,A4)
2506          CALL DPWRST('XXX','BUG ')
2507          WRITE(ICOUT,999)
2508          CALL DPWRST('XXX','BUG ')
2509        ENDIF
2510      ELSEIF(ICASEL.EQ.'ELEM')THEN
2511C
2512        ISTEPN='4C'
2513        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'ICHA')
2514     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2515C
2516C       SEARCH IANS STRING FOR "(xx) =".  IF NO PARENTHESIS
2517C       FOUND BEFORE "=", THEN DO NOT KNOW WHAT ROW OF THE
2518C       VARIABLE TO SAVE.  TREAT THIS AS AN ERROR.
2519C
2520        NLEFT=-1
2521        NRIGHT=-1
2522        NEQUAL=-1
2523        DO16001I=1,IWIDTH
2524          IF(IANS(I)(1:1).EQ.'(' .AND. NLEFT.LT.0)THEN
2525            NLEFT=I
2526          ELSEIF(IANS(I)(1:1).EQ.')' .AND. NRIGHT.LT.0)THEN
2527            NRIGHT=I
2528          ELSEIF(IANS(I)(1:1).EQ.'=' .AND. NEQUAL.LT.0)THEN
2529            NEQUAL=I
2530          ENDIF
253116001   CONTINUE
2532C
2533C       NEED  NLEFT < NRIGHT < NEQUAL
2534C
2535        NSTRT=NLEFT+1
2536        NSTOP=NRIGHT-1
2537        NLEN=NSTOP-NSTRT+1
2538        IF(NLEFT.GT.NRIGHT .OR. NRIGHT.GT.NEQUAL .OR.
2539     1     NSTRT.GT.NSTOP .OR. NLEN.GT.8) THEN
2540          WRITE(ICOUT,999)
2541          CALL DPWRST('XXX','BUG ')
2542          WRITE(ICOUT,2001)
2543          CALL DPWRST('XXX','BUG ')
2544          WRITE(ICOUT,16011)
254516011     FORMAT('      UNRECOGNIZED SYNTAX FOR VARIABLE ELEMENT ON')
2546          CALL DPWRST('XXX','BUG ')
2547          WRITE(ICOUT,16013)
254816013     FORMAT('      LEFT HAND SIDE EQUAL SIGN.')
2549          CALL DPWRST('XXX','BUG ')
2550          IERROR='YES'
2551          GOTO9000
2552        ELSE
2553          ISTR=' '
2554          DO16020I=1,NLEN
2555            ISTR(I:I)=IANS(NSTRT+I-1)(1:1)
255616020     CONTINUE
2557          READ(ISTR,'(I8)',ERR=16029)IARGL
2558          GOTO16049
2559C
256016029     CONTINUE
2561          WRITE(ICOUT,999)
2562          CALL DPWRST('XXX','BUG ')
2563          WRITE(ICOUT,2001)
2564          CALL DPWRST('XXX','BUG ')
2565          WRITE(ICOUT,16011)
2566          CALL DPWRST('XXX','BUG ')
2567          WRITE(ICOUT,16013)
2568          CALL DPWRST('XXX','BUG ')
2569          IERROR='YES'
2570          GOTO9000
2571C
257216049     CONTINUE
2573        ENDIF
2574C
2575        IF(IARGL.LT.1 .OR. IARGL.GT.MAXN)THEN
2576          WRITE(ICOUT,999)
2577          CALL DPWRST('XXX','BUG ')
2578          WRITE(ICOUT,2001)
2579          CALL DPWRST('XXX','BUG ')
2580          WRITE(ICOUT,16052)IARGL,ILEFT
258116052     FORMAT('      THE SPECIFIED ROW (',I8,') OF VARIABLE ',A4,A4)
2582          CALL DPWRST('XXX','BUG ')
2583          WRITE(ICOUT,16054)
258416054     FORMAT('      WAS LESS THAN 1 OR GREATER THAN THE')
2585          CALL DPWRST('XXX','BUG ')
2586          WRITE(ICOUT,16055)MAXN
258716055     FORMAT('      MAXIMUM ALLOWABLE ',I8)
2588          CALL DPWRST('XXX','BUG ')
2589          IERROR='YES'
2590          GOTO9000
2591        ENDIF
2592C
2593        IF(NEWNAM.EQ.'YES')THEN
2594          NIOLD=1
2595        ENDIF
2596        NINEW=NIOLD
2597        IF(IARGL.GT.NINEW)NINEW=IARGL
2598        NS2=1
2599C
2600        RIGHT=REAL(ITEMP1(1))
2601        IJ=MAXN*(ICOLL-1)+IARGL
2602        IF(ICOLL.LE.MAXCOL)V(IJ)=RIGHT
2603        IF(ICOLL.EQ.MAXCP1)PRED(IARGL)=RIGHT
2604        IF(ICOLL.EQ.MAXCP2)RES(IARGL)=RIGHT
2605        IF(ICOLL.EQ.MAXCP3)YPLOT(IARGL)=RIGHT
2606        IF(ICOLL.EQ.MAXCP4)XPLOT(IARGL)=RIGHT
2607        IF(ICOLL.EQ.MAXCP5)X2PLOT(IARGL)=RIGHT
2608        IF(ICOLL.EQ.MAXCP6)TAGPLO(IARGL)=RIGHT
2609C
2610        IHNAME(ILISTL)=IHLEFT
2611        IHNAM2(ILISTL)=IHLEF2
2612        IUSE(ILISTL)='V'
2613        IVALUE(ILISTL)=ICOLL
2614        VALUE(ILISTL)=ICOLL
2615        IN(ILISTL)=NINEW
2616C
2617        IF(NEWNAM.EQ.'YES')THEN
2618          NUMNAM=NUMNAM+1
2619          NUMCOL=NUMCOL+1
2620        ENDIF
2621C
2622        DO16200J4=1,NUMNAM
2623          IF(IUSE(J4).EQ.'V'.AND.IVALUE(J4).EQ.ICOLL)THEN
2624            IUSE(J4)='V'
2625            IVALUE(J4)=ICOLL
2626            VALUE(J4)=ICOLL
2627            IN(J4)=NINEW
2628            GOTO16209
2629          ENDIF
263016200   CONTINUE
263116209   CONTINUE
2632C
2633        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
2634          WRITE(ICOUT,999)
2635          CALL DPWRST('XXX','BUG ')
2636          WRITE(ICOUT,16211)IHRIGH,IHRIG2,ITEMP1(1)
263716211     FORMAT('THE ASCII COLLATING SEQUENCE VALUE OF  ',A4,A4,
2638     1           ' = ',I8)
2639          CALL DPWRST('XXX','BUG ')
2640          WRITE(ICOUT,999)
2641          CALL DPWRST('XXX','BUG ')
2642        ENDIF
2643      ENDIF
2644      GOTO9000
2645C
2646C
2647C               ****************
2648C               **  STEP 90-- **
2649C               **  EXIT.     **
2650C               ****************
2651C
2652 9000 CONTINUE
2653      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ICHA')THEN
2654        WRITE(ICOUT,999)
2655        CALL DPWRST('XXX','BUG ')
2656        WRITE(ICOUT,9011)
2657 9011   FORMAT('***** AT THE END       OF DPICHA--')
2658        CALL DPWRST('XXX','BUG ')
2659        WRITE(ICOUT,9013)NUMNAM
2660 9013   FORMAT('NUMNAM,IVALUE = ',2I8)
2661        CALL DPWRST('XXX','BUG ')
2662        DO9015I=1,NUMNAM
2663          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
2664     1                     IVSTAR(I),IVSTOP(I)
2665 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),',
2666     1           'IVSTOP(I)=',I8,2X,A4,A4,2X,A4,I8,I8)
2667          CALL DPWRST('XXX','BUG ')
2668 9015   CONTINUE
2669      ENDIF
2670C
2671      RETURN
2672      END
2673      SUBROUTINE DPICLA(ICOM,ICOM2,
2674     1                  IMACRO,IMACNU,IMACCS,
2675     1                  IMACL1,IMACL2,
2676     1                  IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM,MAXNAM,
2677     1                  IANSLC,IWIDTH,
2678     1                  IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
2679     1                  IBUGS2,ISUBRO,IFOUND,IERROR)
2680C
2681C     PURPOSE--WHEN THE CALL COMMAND IS ENTERED INSIDE OF A LOOP,
2682C              THE CALL COMMAND IS NOT INCLUDED IN THE SAVED LOOP
2683C              LINES.  RATHER THE CONTENTS OF THE CALL FILE ARE
2684C              SAVED.  ONE SIDE EFFECT OF THIS IS THAT ARGUMENTS
2685C              TO THE COMMAND LINE ARE NOT SAVED.
2686C
2687C              THIS COMMAND IMPLEMENTS THE COMMAND
2688C
2689C                   INSERT CALL ARGUMENTS <STRING>
2690C
2691C              WHERE <STRING> CONTAINS THE COMMAND LINE ARGUMENTS.
2692C
2693C              WHEN A CALL COMMAND IS EXECUTED IN LOOP STORE MODE AND
2694C              THE CALL COMMAND HAS ARGUMENTS, AN "INSERT CALL
2695C              ARGUMENTS" COMMAND WILL BE ENTERED INTO THE SAVED LOOP
2696C              LINES (THIS IS DONE IN THE "DPMACR" ROUTINE).  THIS
2697C              COMMAND THEN IMPLEMENTS THAT COMMAND WHEN THE LOOP LINES
2698C              ARE EXECUTED.
2699C
2700C     INPUT  ARGUMENTS--ICOM
2701C                     --ICOM2
2702C     INPUT  ARGUMENTS--IMACNU (AN INTEGER VALUE
2703C                              BY WHICH THE MACRO FILE/SUBFILE MAY BE
2704C                              REFERENCED IN A FORTRAN I/O STATEMENT.
2705C                     --IMACCS (A HOLLERITH VARIABLE CONTAINING STATUS
2706C                              INFORMATION FOR THE MACRO FILE/SUBFILE
2707C                     --IANSLC (A  HOLLERITH VECTOR WHOSE I-TH ELEMENT
2708C                              CONTAINS THE I-TH CHARACTER OF THE
2709C                              ORIGINAL INPUT COMMAND LINE.
2710C                     --IWIDTH (AN INTEGER VARIABLE WHICH CONTAINS THE
2711C                              NUMBER OF CHARACTERS IN THE ORIGINAL
2712C                              COMMAND LINE.
2713C                     --IHARG  (A  HOLLERITH VECTOR)
2714C                     --NUMARG (AN INTEGER VARIABLE)
2715C                     --IBUG   (A HOLLERITH VARIABLE FOR DEBUGGING
2716C     OUTPUT ARGUMENTS--IMACRO (AN INTEGER VARIABLE WHICH IF 'ON'
2717C                              INDICATES THAT CURRENT COMMANDS ARE ALSO
2718C                              BEING DIVERTED SO AS TO CONSTRUCT A MACRO;
2719C                              AND IF OFF INDICATES THAT A MACRO IS NOT
2720C                              BEING CONSTRUCTED.
2721C                     --IFOUND ('YES' OR 'NO' )
2722C                     --IERROR ('YES' OR 'NO' )
2723C     WRITTEN BY--ALAN HECKERT
2724C                 STATISTICAL ENGINEERING DIVISION
2725C                 INFORMATION TECHNOLOGY LABORATORY
2726C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2727C                 Gaithersburg, MD 20899-8980
2728C                 PHONE--301-975-2899
2729C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2730C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2731C     LANGUAGE--ANSI FORTRAN (1977)
2732C     VERSION NUMBER--2017/07
2733C     ORIGINAL VERSION--JULY      2017.
2734C     UPDATED         --MAY       2018. UPDATED TO SUPPORT NEW FORMS OF
2735C                                       PASSING ARGUMENTS
2736C
2737C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2738C
2739      INCLUDE 'DPCOPA.INC'
2740C
2741      CHARACTER*4 ICOM
2742      CHARACTER*4 ICOM2
2743      CHARACTER*4 IMACRO
2744      CHARACTER*12 IMACCS
2745      CHARACTER*4 IHNAME
2746      CHARACTER*4 IHNAM2
2747      CHARACTER*4 IUSE
2748      CHARACTER*4 IANSLC
2749      CHARACTER*4 IHARG
2750      CHARACTER*4 IHARG2
2751      CHARACTER*4 IARGT
2752C
2753      CHARACTER*4 IBUGS2
2754      CHARACTER*4 ISUBRO
2755      CHARACTER*4 IFOUND
2756      CHARACTER*4 IERROR
2757      CHARACTER*4 ISUBN1
2758      CHARACTER*4 ISUBN2
2759      CHARACTER*4 ISTEPN
2760      CHARACTER*4 IFILQZ
2761      CHARACTER*4 IHYPS2
2762      CHARACTER (LEN=MAXSTR) :: ICANS
2763      CHARACTER (LEN=MAXSTR) :: ISTR
2764C
2765C ---------------------------------------------------------------------
2766C
2767      DIMENSION IANSLC(*)
2768      DIMENSION IHARG(*)
2769      DIMENSION IHARG2(*)
2770      DIMENSION IARGT(*)
2771      DIMENSION IARG(*)
2772      DIMENSION ARG(*)
2773C
2774      DIMENSION IHNAME(*)
2775      DIMENSION IHNAM2(*)
2776      DIMENSION IUSE(*)
2777      DIMENSION IVALUE(*)
2778      DIMENSION VALUE(*)
2779C
2780C-----COMMON----------------------------------------------------------
2781C
2782      CHARACTER (LEN=MAXFNC) :: IMANAM(10)
2783      COMMON/IMAC/IMACN2,IMALE2,IMANAM
2784C
2785      INCLUDE 'DPCOSU.INC'
2786      INCLUDE 'DPCOST.INC'
2787      INCLUDE 'DPCOP2.INC'
2788C
2789C-----START POINT-----------------------------------------------------
2790C
2791      ISUBN1='DPIC'
2792      ISUBN2='LA  '
2793      IFOUND='YES'
2794      IERROR='NO'
2795C
2796      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')THEN
2797         WRITE(ICOUT,999)
2798  999    FORMAT(1X)
2799         CALL DPWRST('XXX','BUG ')
2800         WRITE(ICOUT,51)
2801   51    FORMAT('***** AT THE BEGINNING OF DPICLA--')
2802         CALL DPWRST('XXX','BUG ')
2803         WRITE(ICOUT,52)IMACRO,IMACNU,IMACCS,IMACL1,IMACL2
2804   52    FORMAT('IMACRO,IMACNU,IMACCS,IMACL1,IMACL2 = ',
2805     1          A4,I8,2X,A12,I8,I8)
2806         CALL DPWRST('XXX','BUG ')
2807         WRITE(ICOUT,53)IBUGS2,IERROR,ICOM,ICOM2,MAXOBV,IWIDTH
2808   53    FORMAT('IBUGS2,IERROR,ICOM,ICOM2,MAXOBV,IWIDTH = ',
2809     1          4(A4,2X),2I8)
2810         CALL DPWRST('XXX','BUG ')
2811         WRITE(ICOUT,56)(IANSLC(I),I=1,MIN(120,IWIDTH))
2812   56    FORMAT('IANSLC(.) = ',120A1)
2813         CALL DPWRST('XXX','BUG ')
2814C
2815         WRITE(ICOUT,57)NUMARG,MAXNAM
2816   57    FORMAT('NUMARG,MAXNAM = ',2I8)
2817         CALL DPWRST('XXX','BUG ')
2818         IF(NUMARG.GE.1)THEN
2819            DO58I=1,NUMARG
2820               WRITE(ICOUT,59)I,IHARG(I),IHARG2(I),IARGT(I),
2821     1                        IARG(I),ARG(I)
2822   59          FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),',
2823     1                'ARG(I) = ',I8,2X,2A4,2X,A4,I8,G15.7)
2824               CALL DPWRST('XXX','BUG ')
2825   58       CONTINUE
2826         ENDIF
2827C
2828         WRITE(ICOUT,62)NUMNAM,NUMCHA
2829   62    FORMAT('NUMNAM,NUMCHA = ',2I8)
2830         CALL DPWRST('XXX','BUG ')
2831         IF(NUMNAM.GE.1)THEN
2832            DO65I=1,NUMNAM
2833               WRITE(ICOUT,66)I,IHNAME(I),IHNAM2(I),IUSE(I),
2834     1         IVALUE(I),VALUE(I)
2835   66          FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),',
2836     1         'IVALUE(I),VALUE(I) = ',I8,2X,A4,2X,A4,2X,A4,I8,E15.7)
2837               CALL DPWRST('XXX','BUG ')
2838   65       CONTINUE
2839         ENDIF
2840      ENDIF
2841C
2842C               ***********************************************
2843C               **  STEP 1--                                 **
2844C               **  CHECK FOR                                **
2845C               **     INSERT CALL ARGUMENTS                 **
2846C               ***********************************************
2847C
2848      ISTEPN='1'
2849      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')
2850     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2851C
2852      IF(ICOM.EQ.'INSE ' .AND. IHARG(1).EQ.'CALL' .AND.
2853     1   IHARG(2).EQ.'ARGU')THEN
2854        IFOUND='YES'
2855      ELSE
2856        IFOUND='NO'
2857        GOTO9000
2858      ENDIF
2859C
2860C               **************************************************
2861C               **  STEP 63--                                   **
2862C               **  FIND THE FIRST AND LAST ROW OF THE SUB-CHUNK**
2863C               **  OF THE FILE BEING EXECUTED                  **
2864C               **  IMACL1 = FIRST LINE TO BE EXECUTED          **
2865C               **  IMACL2 = LAST  LINE TO BE EXECUTED          **
2866C               **  IMACLR = NUMBER OF LINES ALREADY EXECUTED   **
2867C               **************************************************
2868C
2869      ISTEPN='63'
2870      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')
2871     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2872C
2873      ICANS=' '
2874      DO6310I=1,IWIDTH
2875        ICANS(I:I)=IANSLC(I)(1:1)
2876 6310 CONTINUE
2877C
2878      IMACL1=1
2879      IMACL2=100000
2880      IHYPS2=IHYPSW
2881      ICOMCL='ON'
2882C
2883      DO6380II=1,50
2884        IMACAR(II)=' '
2885        IMACLA(II)=' '
2886        IMACLL(II)=0
2887 6380 CONTINUE
2888      NMACAG=0
2889      NMACLA=0
2890      NSARG=3
2891      IF(NUMARG.LT.NSARG)GOTO9000
2892C
2893      IFILQZ=IFILQU
2894C
2895C     DPTYPE DOES NOT SPLIT WORDS IN THE WAY NEEDED IN PARSING
2896C     COMMAND LINE ARGUMENTS.  CALL DPNUWO TO DETERMINE THE
2897C     NUMBER OF WORDS ON THE COMMAND LINE.
2898C
2899      ISTR=' '
2900      DO18394II=1,IWIDTH
2901        ISTR(II:II)=IANSLC(II)(1:1)
290218394 CONTINUE
2903      ISTART=1
2904      CALL DPNUWO(ISTR,ISTART,IWIDTH,NWORD,
2905     1            IBUGS2,ISUBRO,IERROR)
2906C
2907      IFILQU='ON'
2908      DO6370J=NSARG+1,NWORD
2909        NMACAG=NMACAG+1
2910        IF(NMACAG.GT.50)GOTO6379
2911        ISTART=1
2912        ISTOP=IWIDTH
2913        IWORD=J
2914        IHYPSW='OFF'
2915        CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD,
2916     1              ICOL1,ICOL2,IMACAR(NMACAG),NCTEMP,
2917     1              IBUGS2,ISUBRO,IERROR)
2918        IHYPSW=IHYPS2
2919C
2920        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')THEN
2921          ISTEPN='637'
2922          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2923          WRITE(ICOUT,6394)J,IWORD,NMACAG,NCTEMP,IMACAR(NMACAG)
2924 6394     FORMAT('6370: J,IWORD,NMACAG,NCTEMP,IMACAR(NMACAG) = ',
2925     1           4I5,2X,A80)
2926          CALL DPWRST('XXX','BUG ')
2927        ENDIF
2928C
2929C       CHECK IF 80 CHARACTERS EXCEEDED (BE SURE TO MAKE LAST
2930C       CHARACTER A QUOTE IF FIRST CHARACTER IS A QUOTE).
2931C
2932        IF(NCTEMP.GT.80)THEN
2933          NCTEMP=80
2934          IF(IMACAR(NMACAG)(1:1).EQ.'"')
2935     1       IMACAR(NMACAG)(NCTEMP:NCTEMP)='"'
2936        ENDIF
2937C
2938C       REMOVE LEADING/TRAILING QUOTES IF NEEEDED
2939C
2940        IF(IMACAR(NMACAG)(1:1).EQ.'"' .AND.
2941     1     IMACAR(NMACAG)(NCTEMP:NCTEMP).EQ.'"')THEN
2942          IF(IQUOST.EQ.'ON')THEN
2943            IMACAR(NMACAG)(1:NCTEMP-2)=IMACAR(NMACAG)(2:NCTEMP-1)
2944            NCTEMP=NCTEMP-2
2945            IMACAR(NMACAG)(NCTEMP+1:NCTEMP+2)='  '
2946          ENDIF
2947        ENDIF
2948C
2949        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')THEN
2950          WRITE(ICOUT,17394)
295117394     FORMAT('AFTER STRIP QUOTES: NMACAG,IMACAR(NMACAG) =',
2952     1           I5,2X,A80)
2953          CALL DPWRST('XXX','BUG ')
2954        ENDIF
2955C
2956C       2016/09: IF FIRST ARGUMENT IS "NULL", THEN BLANK OUT
2957C                ARGUMENT LIST AND SET NUMBER OF ARGUMENTS TO 0.
2958C
2959        IF(NMACAG.EQ.1)THEN
2960          IF(IMACAR(1).EQ.'NULL' .OR. IMACAR(1).EQ.'null')THEN
2961            IMACAR(1)=' '
2962            NMACAG=0
2963            GOTO6379
2964          ENDIF
2965        ENDIF
2966C
2967C       2018/05: ALLOW "EMPTY" ARGUMENTS, DO NOT SET TO ZZZZNULL
2968C
2969        IF(NCTEMP.EQ.1 .AND. IMACAR(NMACAG)(1:1).EQ.' ')THEN
2970          IMACAR(NMACAG)=' '
2971          NCTEMP=1
2972        ELSEIF(NCTEMP.EQ.0)THEN
2973          IMACAR(NMACAG)=' '
2974          NCTEMP=1
2975        ENDIF
2976C
2977C       2016/10: CHECK FOR NAMED ARGUMENTS
2978C
2979C       2018/04: CHECK FOR FOLLOWING 2 CASES
2980C
2981C                1.  "FRAME=FOR I = 1 1 50"
2982C                2.   FRAME="FOR I = 1 1 50"
2983C
2984C                AS FIRST STEP, CHECK FOR FIRST OCCURENCE OF QUOTE
2985C                (IF ANY) AND FIRST OCCURRENCE OF EQUAL SIGN.
2986C
2987C                NOTE THAT CODE WAS ADDED IN MAIN AND DPTYPE ROUTINES
2988C                SO THAT EQUAL SIGN WILL NOT BE A DELIMITER ON A CALL
2989C                COMMAND.
2990C
2991        IPOSQU=0
2992        IPOSEQ=0
2993C
2994C       CHECK FOR FIRST EQUAL CHARACTER.  HOWEVER, IF THE EQUAL
2995C       CHARACTER IS PRECEEDED BY AN ESCAPE CHARACTER ("\"), THEN
2996C       REMOVE THE ESCAPE CHARACTER BUT TREAT AS NO EQUAL CHARACTER
2997C       CASE.  START WITH CHARACTER POSITION 2 AS THERE NEEDS TO BE
2998C       AT LEAST ONE CHARACTER FOR THE ARGUMENT NAME.
2999C
3000        DO36311II=2,NCTEMP-1
3001          IF(IMACAR(NMACAG)(II:II).EQ.'=')THEN
3002            IF(II.GT.1 .AND. IMACAR(NMACAG)(II-1:II-1).EQ.'\')THEN
3003              IMACAR(NMACAG)(II-1:NCTEMP-1)=IMACAR(NMACAG)(II:NCTEMP)
3004              IMACAR(NMACAG)(NCTEMP:NCTEMP)=' '
3005              NCTEMP=NCTEMP-1
3006              GOTO36319
3007            ENDIF
3008            IPOSEQ=II
3009            GOTO36319
3010          ENDIF
301136311   CONTINUE
301236319   CONTINUE
3013C
3014C       NOW CHECK FOR OCCURENCE OF QUOTE.  NOTE THAT QUOTE IS ONLY
3015C       TREATED AS AN ARGUMENT DELIMITER IF IT IS THE FIRST CHARACTER
3016C       IN THE STRING OR THE FIRST CHARACTER AFTER THE EQUAL SIGN.  IN
3017C       ADDITION, IF A QUOTE DELIMITER IS FOUND, CHECK FOR A QUOTE AS
3018C       THE LAST CHARACTER.  IF NOT FOUND, THEN ADD IT.
3019C
3020        IF(IMACAR(NMACAG)(1:1).EQ.'"')THEN
3021          IPOSQU=1
3022        ELSEIF(IMACAR(NMACAG)(IPOSEQ+1:IPOSEQ+1).EQ.'"')THEN
3023          IPOSQU=IPOSEQ+1
3024        ENDIF
3025C
3026        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')THEN
3027          WRITE(ICOUT,36394)IPOSEQ,IPOSQU,NCTEMP
302836394     FORMAT('IPOSEQ,IPOSQU,NCTEMP = ',3I8)
3029          CALL DPWRST('XXX','BUG ')
3030        ENDIF
3031C
3032C       IF ENDING QUOTE NOT PRESENT, ADD IT.
3033C
3034        IF(IPOSQU.GT.0)THEN
3035          IF(IMACAR(NMACAG)(NCTEMP:NCTEMP).EQ.')')THEN
3036            IF(IMACAR(NMACAG)(NCTEMP-1:NCTEMP-1).NE.'"')THEN
3037              NCTEMP=NCTEMP+1
3038              IMACAR(NMACAG)(NCTEMP-1:NCTEMP)='")'
3039            ENDIF
3040          ELSE
3041            IF(IMACAR(NMACAG)(NCTEMP:NCTEMP).NE.'"')THEN
3042              NCTEMP=NCTEMP+1
3043              IMACAR(NMACAG)(NCTEMP:NCTEMP)='"'
3044            ENDIF
3045          ENDIF
3046        ENDIF
3047C
3048C       PROCESS STRING BASED ON WHETHER QUOTES/EQUAL SIGNS ARE PRESENT.
3049C
3050        IF(IPOSEQ.EQ.0 .AND. IPOSQU.EQ.0)THEN
3051C
3052C         CASE WITH NO EQUAL AND NO QUOTE.  IN THIS CASE, WE HAVE
3053C         A POSITIONAL ARGUMENT AND DO NOT NEED TO PROCESS QUOTES.
3054C
3055C         IN THIS CASE, NO ADDITIONAL PROCESSING IS REQUIRED.
3056C
3057          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')THEN
3058            WRITE(ICOUT,46351)
305946351       FORMAT('NO EQUAL, NO QUOTE CASE: NOTHING DONE')
3060            CALL DPWRST('XXX','BUG ')
3061          ENDIF
3062C
3063        ELSEIF(IPOSEQ.EQ.0 .AND. IPOSQU.GE.1)THEN
3064C
3065C         CASE WITH NO EQUAL BUT WITH QUOTE.  IN THIS CASE, WE HAVE
3066C         A POSITIONAL ARGUMENT AND WE NEED TO PROCESS QUOTES.
3067C
3068C         ONLY PROCESSING REQUIRED IS TO STRIP OFF LEADING/TRAILING
3069C         QUOTE IF THAT OPTION SET.
3070C
3071          IF(IQUOST.EQ.'ON')THEN
3072            IF(IMACAR(NMACAG)(NCTEMP:NCTEMP).EQ.')')THEN
3073              IMACAR(NMACAG)(1:NCTEMP-3)=IMACAR(NMACAG)(2:NCTEMP-2)
3074              NCTEMP=NCTEMP-2
3075              IMACAR(NMACAG)(NCTEMP:NCTEMP+2)=')  '
3076            ELSE
3077              IMACAR(NMACAG)(1:NCTEMP-2)=IMACAR(NMACAG)(2:NCTEMP-1)
3078              IMACAR(NMACAG)(NCTEMP+1:NCTEMP+2)='  '
3079              NCTEMP=NCTEMP-2
3080            ENDIF
3081          ENDIF
3082C
3083          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')THEN
3084            WRITE(ICOUT,46361)
308546361       FORMAT('NO EQUAL, QUOTE CASE:')
3086            CALL DPWRST('XXX','BUG ')
3087            WRITE(ICOUT,46363)NMACAG,NCTEMP,IMACAR(NMACAG)
308846363       FORMAT('NMACAG,NCTEMP,IMACAR(NMACAG) = ',2I8,A80)
3089            CALL DPWRST('XXX','BUG ')
3090          ENDIF
3091C
3092        ELSEIF(IPOSEQ.GE.1 .AND. IPOSQU.EQ.0)THEN
3093C
3094C         CASE WITH EQUAL AND NO QUOTE.  IN THIS CASE, WE HAVE
3095C         A NAMED ARGUMENT AND DO NOT NEED TO PROCESS QUOTES.
3096C
3097C         IN THIS CASE, NEED TO MODIFY THE MACRO NAME TABLE AND
3098C         ALSO ADJUST THE ARGUMENT STRING.
3099C
3100          NMACLA=NMACLA+1
3101          IMACLL(NMACLA)=NMACAG
3102          IMACLA(NMACLA)(1:IPOSEQ-1)=IMACAR(NMACAG)(1:IPOSEQ-1)
3103          IMACNC(NMACLA)=IPOSEQ-1
3104          ICNT2=NCTEMP-IPOSEQ
3105          IF(ICNT2.GE.1)THEN
3106            IMACAR(NMACAG)(1:ICNT2)=IMACAR(NMACAG)(IPOSEQ+1:NCTEMP)
3107            IMACAR(NMACAG)(ICNT2+1:NCTEMP)=' '
3108            NCTEMP=ICNT2
3109          ELSE
3110            IMACAR(NMACAG)=' '
3111            NCTEMP=1
3112          ENDIF
3113C
3114          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')THEN
3115            WRITE(ICOUT,46371)
311646371       FORMAT('EQUAL, NO QUOTE CASE:')
3117            CALL DPWRST('XXX','BUG ')
3118            WRITE(ICOUT,46373)NMACAG,NCTEMP,IMACAR(NMACAG)
311946373       FORMAT('NMACAG,NCTEMP,IMACAR(NMACAG) = ',2I8,A80)
3120            CALL DPWRST('XXX','BUG ')
3121            WRITE(ICOUT,46375)NMACLA,IMACLL(NMACLA),IMACNC(NMACLA),
3122     1                        IMACLA(NMACLA)
312346375       FORMAT('NMACLA,IMACLL(NMACLA),IMACNC(NMACLA),'
3124     1             'IMACLA(NMACLA) = ',3I8,A80)
3125            CALL DPWRST('XXX','BUG ')
3126          ENDIF
3127C
3128        ELSEIF(IPOSEQ.GE.1 .AND. IPOSQU.GE.1)THEN
3129C
3130C         CASE WITH EQUAL AND QUOTE.  IN THIS CASE, WE HAVE
3131C         A NAMED ARGUMENT AND WE NEED TO PROCESS QUOTES.
3132C
3133C         TREAT CASE WHERE QUOTE IS FOR THE FULL STRING SEPARATELY
3134C         FROM CASE WHERE QUOTE IS FOR THE VALUE ONLY.
3135C
3136          IF(IPOSQU.EQ.1)THEN
3137            NMACLA=NMACLA+1
3138            IMACLL(NMACLA)=NMACAG
3139            ICNT=IPOSEQ-2
3140            IMACLA(NMACLA)(1:ICNT)=IMACAR(NMACAG)(2:IPOSEQ-1)
3141            IMACNC(NMACLA)=ICNT
3142            ICNT2=NCTEMP-IPOSEQ-1
3143            IF(ICNT2.GE.1)THEN
3144              IMACAR(NMACAG)(1:ICNT2)=
3145     1          IMACAR(NMACAG)(IPOSEQ+1:NCTEMP-1)
3146              IMACAR(NMACAG)(ICNT2+1:80)=' '
3147              NCTEMP=ICNT2
3148            ELSE
3149              IMACAR(NMACAG)=' '
3150              NCTEMP=1
3151            ENDIF
3152          ELSE
3153            NMACLA=NMACLA+1
3154            IMACLL(NMACLA)=NMACAG
3155            ICNT=IPOSEQ-1
3156            IMACLA(NMACLA)(1:ICNT)=IMACAR(NMACAG)(1:IPOSEQ-1)
3157            IMACNC(NMACLA)=ICNT
3158            ICNT2=NCTEMP-IPOSEQ
3159            IF(ICNT2.GE.1)THEN
3160              IMACAR(NMACAG)(1:ICNT2)=IMACAR(NMACAG)(IPOSEQ+1:NCTEMP)
3161              IMACAR(NMACAG)(ICNT2+1:80)=' '
3162              NCTEMP=ICNT2
3163            ELSE
3164              IMACAR(NMACAG)=' '
3165              NCTEMP=1
3166            ENDIF
3167            IF(IQUOST.EQ.'ON' .AND. NCTEMP.GE.2)THEN
3168              IF(IMACAR(NMACAG)(NCTEMP:NCTEMP).EQ.')')THEN
3169                IMACAR(NMACAG)(1:NCTEMP-3)=IMACAR(NMACAG)(2:NCTEMP-2)
3170                NCTEMP=NCTEMP-2
3171                IMACAR(NMACAG)(NCTEMP:NCTEMP+2)=')  '
3172              ELSE
3173                IMACAR(NMACAG)(1:NCTEMP-2)=IMACAR(NMACAG)(2:NCTEMP-1)
3174                NCTEMP=NCTEMP-2
3175                IMACAR(NMACAG)(NCTEMP+1:NCTEMP+2)='  '
3176              ENDIF
3177              IF(NCTEMP.LE.0)THEN
3178                IMACAR(NMACAG)=' '
3179                NCTEMP=1
3180              ENDIF
3181            ENDIF
3182          ENDIF
3183C
3184          IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')THEN
3185            WRITE(ICOUT,46381)
318646381       FORMAT('EQUAL, QUOTE CASE:')
3187            CALL DPWRST('XXX','BUG ')
3188            WRITE(ICOUT,46373)NMACAG,NCTEMP,IMACAR(NMACAG)
3189            CALL DPWRST('XXX','BUG ')
3190            WRITE(ICOUT,46375)NMACLA,IMACLL(NMACLA),IMACNC(NMACLA),
3191     1                        IMACLA(NMACLA)
3192            CALL DPWRST('XXX','BUG ')
3193          ENDIF
3194C
3195        ENDIF
3196C
3197        IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'ICLA')THEN
3198          WRITE(ICOUT,6373)NMACAG,NCTEMP,IMACAR(NMACAG)
3199 6373     FORMAT('NMACAG,NCTEMP,IMACAR(NMACAG) = ',2I5,A80)
3200          CALL DPWRST('XXX','BUG ')
3201        ENDIF
3202C
3203 6370 CONTINUE
3204 6379 CONTINUE
3205      IFILQU=IFILQZ
3206C
3207C     2018/04: CHECK FOR OPENING AND CLOSING PARENTHEIS AROUND FULL
3208C              ARGUMENT LIST (E.G., CALL (Y=Y,X=X)).
3209C
3210C              NOTE THAT THE LEFT PARENTHESIS MAY BE PART OF THE
3211C              ARGUMENT LABEL (IF GIVEN) OR THE ARGUMENT VALUE
3212C              (IF ARGUMENTS ENTERED BY POSITION).  THE RIGHT
3213C              PARENTHESIS WILL ALWAYS BE PART OF THE ARGUMENT
3214C              VALUE.
3215C
3216C              AS A FURTHER COMPLICATION, NEED TO CHECK IF THE
3217C              LEFT PARENTHESIS IS FOLLOWED BY A SPACE AND LIKEWISE
3218C              IF THE RIGHT PARENTHESIS IS PRECEEDED BY A SPACE.
3219C
3220      IF(NMACAG.GE.1)THEN
3221C
3222C       STEP 1: CHECK IF EITHER FIRST LABEL OR FIRST ARGUMENT IS
3223C               STARTS WITH A PARENTHESIS.  CHECK LABEL FIRST.
3224C
3225        IFLAG=0
3226        IF(IMACLA(1)(1:1).EQ.'(')THEN
3227          IFLAG=1
3228          DO16392KK=1,7
3229            IMACLA(1)(KK:KK)=IMACLA(1)(KK+1:KK+1)
323016392     CONTINUE
3231          IMACLA(1)(8:8)=' '
3232          IMACNC(1)=IMACNC(1)-1
3233C
3234C         NOW REMOVE ANY LEADING SPACES FROM LABEL
3235C
3236          DO16394KK=1,IMACNC(1)
3237            IF(IMACLA(1)(KK:KK).NE.' ')THEN
3238              IF(KK.GT.1)THEN
3239                NCTEMP=IMACNC(1) - KK + 1
3240                IMACLA(1)(1:NCTEMP)=IMACLA(1)(KK:IMACNC(1))
3241                IMACLA(1)(NCTEMP+1:8)=' '
3242                IMACNC(1)=NCTEMP
3243              ENDIF
3244              GOTO16396
3245            ENDIF
324616394     CONTINUE
324716396     CONTINUE
3248        ELSEIF(IMACAR(1)(1:1).EQ.'(')THEN
3249          IFLAG=2
3250          DO16393KK=1,79
3251            IMACAR(1)(KK:KK)=IMACAR(1)(KK+1:KK+1)
325216393     CONTINUE
3253          IMACAR(1)(80:80)=' '
3254        ENDIF
3255C
3256        IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'ICLA')THEN
3257          WRITE(ICOUT,46661)IFLAG
325846661     FORMAT('IFLAG = ',I5)
3259          CALL DPWRST('XXX','BUG ')
3260        ENDIF
3261C
3262C       STEP 2: CHECK IF LAST ARGUMENT VALUE ENDS WITH RIGHT PARENTHESIS
3263C
3264        DO16391JJ=80,1,-1
3265          IF(IMACAR(NMACAG)(JJ:JJ).EQ.')')THEN
3266            IMACAR(NMACAG)(JJ:JJ)=' '
3267          ENDIF
326816391   CONTINUE
3269C
3270        IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'ICLA')THEN
3271          WRITE(ICOUT,46391)
327246391     FORMAT('AFTER REMOVE LEADING/TRAILING PARENTHESIS')
3273          CALL DPWRST('XXX','BUG ')
3274          WRITE(ICOUT,46392)NMACLA,IMACLL(1),IMACNC(1),
3275     1                      IMACNC(1),IMACLA(1)
327646392     FORMAT('NMACLA,IMACLL(1),IMACNC(1),IMACLA(1) = ',
3277     1           3I8,2X,A80)
3278          CALL DPWRST('XXX','BUG ')
3279          WRITE(ICOUT,46375)NMACLA,IMACLL(NMACLA),
3280     1                      IMACNC(NMACLA),IMACLA(NMACLA)
3281          CALL DPWRST('XXX','BUG ')
3282        ENDIF
3283      ENDIF
3284C
3285 9000 CONTINUE
3286      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'ICLA')THEN
3287        WRITE(ICOUT,9010)NMACLA,NMACAG
3288 9010   FORMAT('NMACLA,NMACAG = ',2I5)
3289        CALL DPWRST('XXX','BUG ')
3290        IF(NMACLA.GE.1)THEN
3291          DO9011JJ=1,NMACLA
3292            WRITE(ICOUT,9013)JJ,IMACLL(JJ),IMACLA(JJ)
3293 9013       FORMAT('JJ,IMACLL(JJ),IMACLA(JJ) = ',2I5,2X,A8)
3294            CALL DPWRST('XXX','BUG ')
3295 9011     CONTINUE
3296        ENDIF
3297C
3298        IF(NMACAG.GE.1)THEN
3299          DO9020JJ=1,NMACAG
3300            WRITE(ICOUT,9021)JJ,IMACAR(JJ)
3301 9021       FORMAT('JJ,IMACAR(JJ) = ',I5,2X,A80)
3302            CALL DPWRST('XXX','BUG ')
3303 9020     CONTINUE
3304        ENDIF
3305      ENDIF
3306C
3307      RETURN
3308      END
3309      SUBROUTINE DPICOM(Y,X,N,MINSIZ,
3310     1Y2,XLOW,XUPP,N2,
3311     1ISUBRO,IBUGA3,IERROR)
3312C
3313C     PURPOSE--FOR DISCRETE DISTRIBUTIONS, WE TYPICALLY WANT TO
3314C              GENERATE A FREQUENCY DISTRIBUTION FOR THE NON-NEGATIVE
3315C              INTEGERS.  THIS ROUTINE WILL DO THAT.  TWO ADDITIONAL
3316C              FEATURES:
3317C
3318C              1) FOR LONG-TAILED DISTRIBUTIONS (E.G., THE YULE
3319C                 OR ZETA DISTRIBUTIONS, WE WILL HAVE AN EXTREMELY
3320C                 LARGE NUMBER OF EMPTY CELLS IN THE TAIL.  SO
3321C                 THIS ROUTINE WILL RETURN THE FREQUENCY TABLE
3322C                 IN THE FORM:
3323C
3324C                    FREQ  CLASS-LOWER-LIMIT  CLASS-UPPER-LIMIT
3325C
3326C                 EMPTY CLASSES WILL BE COMBINED WITH THE NEXT
3327C                 HIGHEST NON-EMPTY CLASS.
3328C
3329C              2) FOR THE CHI-SQUARE GOODNESS OF FIT, IT IS
3330C                 RECOMMENDED THAT CLASSES WITH LESS THAN 5
3331C                 OBSERVATIONS BE COMBINED IN ORDER FOR THE CHI-SQUARE
3332C                 GOODNESS OF FIT TES TO BE VALID.  AFTER COMPUTING
3333C                 THE FREQUENCY TABLE, CLASSES WILL BE COMBINED SO
3334C                 THAT ALL CLASSES HAVE A FREQUENCY OF AT LEAST
3335C                 "MINSIZ" WHERE "MINSIZ" IS SET BY THE USER
3336C                 (THE DEFAULT VALUE IS 5).
3337C
3338C     WRITTEN BY--JAMES J. FILLIBEN
3339C                 STATISTICAL ENGINEERING DIVISION
3340C                 INFORMATION TECHNOLOGY LABORATORY
3341C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3342C                 GAITHERSBURG, MD 20899-8980
3343C                 PHONE--301-975-2855
3344C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3345C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3346C     LANGUAGE--ANSI FORTRAN (1977)
3347C     VERSION NUMBER--2006/5
3348C     ORIGINAL VERSION--MAY       2006.
3349C
3350C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3351C
3352      CHARACTER*4 ISUBRO
3353      CHARACTER*4 IBUGA3
3354      CHARACTER*4 IERROR
3355C
3356      CHARACTER*4 IWRITE
3357      CHARACTER*4 ISUBN1
3358      CHARACTER*4 ISUBN2
3359C
3360C---------------------------------------------------------------------
3361C
3362      DIMENSION Y(*)
3363      DIMENSION X(*)
3364      DIMENSION Y2(*)
3365      DIMENSION XLOW(*)
3366      DIMENSION XUPP(*)
3367C
3368C---------------------------------------------------------------------
3369C
3370      INCLUDE 'DPCOP2.INC'
3371C
3372C-----START POINT-----------------------------------------------------
3373C
3374      ISUBN1='DPIC'
3375      ISUBN2='OM  '
3376      IERROR='NO'
3377      IWRITE='NO'
3378C
3379C               ********************************************
3380C               **  STEP 1--                              **
3381C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
3382C               ********************************************
3383C
3384      IF(N.LT.2)THEN
3385        WRITE(ICOUT,999)
3386  999   FORMAT(1X)
3387        CALL DPWRST('XXX','BUG ')
3388        WRITE(ICOUT,31)
3389   31   FORMAT('***** ERROR IN INTEGER FREQUENCY TABLE--')
3390        CALL DPWRST('XXX','BUG ')
3391        WRITE(ICOUT,32)
3392   32   FORMAT('      THE NUMBER OF INPUT VALUE IS LESS THAN TWO.')
3393        CALL DPWRST('XXX','BUG ')
3394        WRITE(ICOUT,34)N
3395   34   FORMAT('      THE ENTERED NUMBER OF INPUT VALUES HERE = ',I6)
3396        CALL DPWRST('XXX','BUG ')
3397        WRITE(ICOUT,999)
3398        CALL DPWRST('XXX','BUG ')
3399        IERROR='YES'
3400        GOTO9000
3401      ENDIF
3402C
3403      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'ICOM')THEN
3404        WRITE(ICOUT,999)
3405        CALL DPWRST('XXX','BUG ')
3406        WRITE(ICOUT,70)
3407   70   FORMAT('***** AT THE BEGINNING OF DPICOM--')
3408        CALL DPWRST('XXX','BUG ')
3409        WRITE(ICOUT,72)N,MINSIZ
3410   72   FORMAT('N,MINSIZ = ',2I8)
3411        CALL DPWRST('XXX','BUG ')
3412        DO73I=1,N
3413          WRITE(ICOUT,74)I,Y(I)
3414   74     FORMAT('I,Y(I) = ',I8,G15.7)
3415          CALL DPWRST('XXX','BUG ')
3416   73   CONTINUE
3417      ENDIF
3418C
3419C               ********************************************
3420C               **  STEP 2--                              **
3421C               **  ROUND TO NEAREST INTEGER VALUE (AND   **
3422C               **  CHECK FOR NEGARIVE VALUES)            **
3423C               ********************************************
3424C
3425      DO100I=1,N
3426        ITEMP=INT(Y(I)+0.5)
3427        IF(ITEMP.LT.0)THEN
3428          WRITE(ICOUT,31)
3429          CALL DPWRST('XXX','BUG ')
3430          WRITE(ICOUT,102)I,Y(I)
3431  102     FORMAT('      ROW ',I8,' IS NON-POSITIVE.  VALUE = ',G15.7)
3432          CALL DPWRST('XXX','BUG ')
3433          IERROR='YES'
3434          GOTO9000
3435        ENDIF
3436        Y(I)=REAL(ITEMP)
3437  100 CONTINUE
3438C
3439C               ********************************************
3440C               **  STEP 3--                              **
3441C               **  1) SORT                               **
3442C               **  2) EXTRACT DISTINCT VALUES IN INPUT   **
3443C               **     VECTOR                             **
3444C               **  3) GENERATE THE FREQUENCY TABLE       **
3445C               ********************************************
3446C
3447      CALL SORT(Y,N,Y)
3448      CALL DISTIN(Y,N,IWRITE,X,NDIST,IBUGA3,IERROR)
3449C
3450C     CHECK IF ALL DATA VALUES EQUAL TO SAME VALUE.
3451C
3452      IF(NDIST.EQ.1)THEN
3453        Y2(1)=X(1)
3454        XLOW(1)=X(1)-0.5
3455        XUPP(1)=X(1)+0.5
3456        N2=1
3457        GOTO9000
3458      ENDIF
3459C
3460      DO200I=1,NDIST
3461        Y2(I)=0.0
3462        XLOW(I)=0.0
3463        XUPP(I)=0.0
3464  200 CONTINUE
3465C
3466      DO300J=1,NDIST
3467        AHOLD=X(J)
3468        IF(J.EQ.1)THEN
3469          XLOW(J)=AHOLD-0.5
3470          AHOLD2=X(J+1)
3471          XUPP(J)=AHOLD2-0.5
3472        ELSEIF(J.EQ.NDIST)THEN
3473          XUPP(J)=AHOLD+0.5
3474          XLOW(J)=XUPP(J-1)
3475        ELSE
3476          XLOW(J)=XUPP(J-1)
3477          XUPP(J)=AHOLD+0.5
3478        ENDIF
3479        DO310I=1,N
3480          IF(Y(I).EQ.AHOLD)THEN
3481            Y2(J)=Y2(J)+1
3482          ENDIF
3483  310   CONTINUE
3484  300 CONTINUE
3485C
3486C
3487C               **********************************************
3488C               **  STEP 4--                                **
3489C               **  COMBINE CLASSES WITH A FREQUECNY LESS   **
3490C               **  THAN MINSIZ.                            **
3491C               **********************************************
3492C
3493      N2=0
3494      IFLAG=0
3495      ISTRT=1
3496      ICNT2=NDIST
3497      AMINSZ=REAL(MINSIZ)
3498      EPS=1.0E-10
3499C
3500C  RIGHT TAIL TO CENTER.  TEMPORARILY STORE IN UPPER PART OF
3501C  XLOW, XUPP, AND Y2 ARRARYS, WILL THEN FLIP THE SORT AT THE
3502C  END.
3503C
3504      DO400I=NDIST,1,-1
3505        ALOW=XLOW(I)
3506        AHIGH=XUPP(I)
3507        ATEMP=Y2(I)
3508        IF(IFLAG.EQ.0)THEN
3509          IF(ATEMP+EPS.GE.AMINSZ)THEN
3510            ICNT2=ICNT2+1
3511            XLOW(ICNT2)=ALOW
3512            XUPP(ICNT2)=AHIGH
3513            Y2(ICNT2)=ATEMP
3514          ELSE
3515            IFLAG=1
3516            ASUM=ATEMP
3517            ISTOP=I
3518          ENDIF
3519        ELSE
3520          ASUM=ASUM + ATEMP
3521          IF(ASUM+EPS.GE.AMINSZ)THEN
3522            ICNT2=ICNT2 + 1
3523            XLOW(ICNT2)=ALOW
3524            XUPP(ICNT2)=XUPP(ISTOP)
3525            Y2(ICNT2)=ASUM
3526            ISTOP=-1
3527            IFLAG=0
3528          ENDIF
3529        ENDIF
3530  400 CONTINUE
3531C
3532      IF(IFLAG.EQ.1 .AND. ASUM.GT.0.0)THEN
3533        XLOW(ICNT2)=XLOW(1)
3534        XUPP(ICNT2)=XLOW(ICNT2-1)
3535        Y2(ICNT2)=Y2(ICNT2) + ASUM
3536      ENDIF
3537      N2RGHT=ICNT2
3538C
3539C  NOW COPY REVERSE ORDER RIGHT TAIL ENTRIES
3540C
3541      ICNT=0
3542      DO500I=ICNT2,NDIST+1,-1
3543        ICNT=ICNT+1
3544        Y2(ICNT)=Y2(I)
3545        XLOW(ICNT)=XLOW(I)
3546        XUPP(ICNT)=XUPP(I)
3547  500 CONTINUE
3548      N2=ICNT
3549C
3550C               ******************
3551C               **   STEP 90--  **
3552C               **   EXIT       **
3553C               ******************
3554C
3555 9000 CONTINUE
3556      IF(IBUGA3.EQ.'ON')THEN
3557        WRITE(ICOUT,999)
3558        CALL DPWRST('XXX','BUG ')
3559        WRITE(ICOUT,9011)
3560 9011   FORMAT('***** AT THE END OF DPICOM--')
3561        CALL DPWRST('XXX','BUG ')
3562        WRITE(ICOUT,9012)IERROR,N2
3563 9012   FORMAT('IERROR,N2 = ',A4,2X,I8)
3564        CALL DPWRST('XXX','BUG ')
3565        DO9015I=1,N2
3566          WRITE(ICOUT,9016)I,Y2(I),XLOW(I),XUPP(I)
3567 9016     FORMAT('I,Y2(I),XLOW(I),XUPP(I) = ',I8,3G15.7)
3568          CALL DPWRST('XXX','BUG ')
3569 9015   CONTINUE
3570      ENDIF
3571C
3572      RETURN
3573      END
3574      SUBROUTINE DPIF(ILOCS,ICASIF,IBUGQ,ISUBRO,IERROR)
3575C
3576C     PURPOSE--DEFINE A TRUE-FALSE CHARACTER VARIABLE
3577C              WHICH WILL BE USED IN OTHER SUBROUTINES
3578C              FOR THE CONDITIONAL EXECTUION OF STATEMENTS.
3579C     WRITTEN BY--JAMES J. FILLIBEN
3580C                 STATISTICAL ENGINEERING DIVISION
3581C                 INFORMATION TECHNOLOGY LABORATORY
3582C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3583C                 GAITHERSBURG, MD 20899-8980
3584C                 PHONE--301-975-2855
3585C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3586C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3587C     LANGUAGE--ANSI FORTRAN (1977)
3588C     VERSION NUMBER--83/1
3589C     ORIGINAL VERSION--JANUARY   1983.
3590C     UPDATED         --AUGUST    1987. (TO ALLOW <> TO WORK)
3591C     UPDATED         --AUGUST    1992. TO ALLOW    ... NOT EXIST
3592C     UPDATED         --AUGUST    1997. TO ALLOW    ... EXIST
3593C     UPDATED         --FEBRUARY  1999. IF ERROR, SET IF TO FALSE
3594C     UPDATED         --JULY      2002. REDO IF NOT EXIST AND IF EXIST
3595C     UPDATED         --JULY      2002. ADD: IF STRING = "..."
3596C     UPDATED         --SEPTEMBER 2012. ADD ISUBRO
3597C     UPDATED         --NOVEMBER  2014. FIX BUG WITH "<>" FOR STRINGS
3598C     UPDATED         --NOVEMBER  2014. FOR STRINGS, LET RHS BE A
3599C                                       PRE-DEFINED STRING
3600C     UPDATED         --FEBRUARY  2015. SUPPORT "SET FATAL ERROR"
3601C     UPDATED         --OCTOBER   2016. IF COMMAND LINE ARGUMENT xx
3602C                                       EXISTS
3603C     UPDATED         --MARCH     2017. SUPPORT AND, OR, AND XOR
3604C                                       FOR TWO IF CLAUSES
3605C     UPDATED         --FEBRUARY  2018. SUPPORT FOR AND, OR, AND XOR
3606C                                       EXTENDED TO THREE OR MORE IF
3607C                                       CLAUSES
3608C     UPDATED         --FEBRUARY  2018. FOR CASE   IF A = 1
3609C                                       IF A DOES NOT EXIST, SET TO
3610C                                       FALSE BUT DO NOT GENERATE
3611C                                       ERROR MESSAGE
3612C     UPDATED         --MAY       2018. SUPPORT NUMERIC VALUE FOR LHS:
3613C                                          IF 3 > 2
3614C     UPDATED         --MAY       2018. SUPPORT QUOTED LITERAL STRING
3615C                                       FOR LHS:
3616C                                          IF "XXXX" = SOLD
3617C     UPDATED         --MAY       2018. COMMAND LINE ARGUMENT ... NOT EXIST
3618C     UPDATED         --MAY       2018. BETTER MESSAGING FOR SPECIAL
3619C                                       CASES
3620C     UPDATED         --JUNE      2018. FIXED ISSUE WITH
3621C                                         IF " " = ...
3622C     UPDATED         --SEPTEMBER 2018. SUPPORT "<", "<=", ">", ">="
3623C                                       FOR STRINGS
3624C
3625C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3626C
3627      CHARACTER*4 IBUGQ
3628      CHARACTER*4 ISUBRO
3629      CHARACTER*4 IERROR
3630C
3631      CHARACTER*4 ICASIF
3632      CHARACTER*4 ICASI1
3633      CHARACTER*4 ICASI2
3634      CHARACTER*4 INOT
3635      CHARACTER*4 IEXIST
3636      CHARACTER*4 IOPER(10)
3637      CHARACTER*4 ISTATI
3638      CHARACTER*4 ICASSC
3639      CHARACTER*4 ICASQU
3640      CHARACTER*4 ICASPA
3641      CHARACTER*4 IHWUSE
3642      CHARACTER*4 MESSAG
3643      CHARACTER*4 ICASOP
3644      CHARACTER*4 IHSET
3645      CHARACTER*4 IHSET2
3646      CHARACTER*4 IH
3647      CHARACTER*4 IH2
3648      CHARACTER*4 IFILQZ
3649      CHARACTER*4 ISUBN1
3650      CHARACTER*4 ISUBN2
3651      CHARACTER*4 ISTEPN
3652C
3653      INCLUDE 'DPCOPA.INC'
3654C
3655      CHARACTER*8 ITYPE
3656      CHARACTER (LEN=MAXSTR) :: ITEXT1
3657      CHARACTER (LEN=MAXSTR) :: ITEXT2
3658      CHARACTER (LEN=MAXSTR) :: ISTRIN
3659      CHARACTER (LEN=MAXSTR) :: ISTRI2
3660CCCCC CHARACTER*255 ITEXT1
3661CCCCC CHARACTER*255 ITEXT2
3662CCCCC CHARACTER*255 ISTRIN
3663CCCCC CHARACTER*255 ISTRI2
3664C
3665C-----COMMON----------------------------------------------------------
3666C
3667      INCLUDE 'DPCOHK.INC'
3668      INCLUDE 'DPCODA.INC'
3669      INCLUDE 'DPCOST.INC'
3670      INCLUDE 'DPCOSU.INC'
3671      INCLUDE 'DPCOP2.INC'
3672C
3673C-----START POINT-----------------------------------------------------
3674C
3675      ISUBN1='DPIF'
3676      ISUBN2='    '
3677      IERROR='NO'
3678      ICASIF='TRUE'
3679      ICASI1='NULL'
3680      ICASI2='NULL'
3681      INOT='OFF'
3682      MAXCP1=MAXCOL+1
3683      MAXCP2=MAXCOL+2
3684C
3685C               ********************************
3686C               **  TREAT THE IF     CASE     **
3687C               ********************************
3688C
3689      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
3690        WRITE(ICOUT,999)
3691  999   FORMAT(1X)
3692        CALL DPWRST('XXX','BUG ')
3693        WRITE(ICOUT,51)
3694   51   FORMAT('***** AT THE BEGINNING OF DPIF--')
3695        CALL DPWRST('XXX','BUG ')
3696        WRITE(ICOUT,52)ILOCS,ICASIF,IBUGQ,IERROR
3697   52   FORMAT('ILOCS,ICASIF,IBUGQ,IERROR = ',I8,3(2X,A4))
3698        CALL DPWRST('XXX','BUG ')
3699        WRITE(ICOUT,55)NUMARG,NUMNAM,MAXNAM,N,MAXN
3700   55   FORMAT('NUMARG,NUMNAM,MAXNAM,N,MAXN = ',5I8)
3701        CALL DPWRST('XXX','BUG ')
3702        WRITE(ICOUT,56)IWIDTH,ILOCS
3703   56   FORMAT('IWIDTH,ILOCS = ',2I8)
3704        CALL DPWRST('XXX','BUG ')
3705      ENDIF
3706C
3707C               ********************************************************
3708C               **  STEP 1--                                          **
3709C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.   **
3710C               ********************************************************
3711C
3712      ISTEPN='1'
3713      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
3714     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3715C
3716      MINNA=0
3717      MAXNA=100
3718      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,
3719     1IERROR)
3720      IF(IERROR.EQ.'YES')GOTO9000
3721C
3722C               ********************************************************
3723C               **  STEP 1B-                                          **
3724C               **  CHECK FOR LOGICAL OPERATORS:                      **
3725C               **            AND                                     **
3726C               **            OR                                      **
3727C               **            XOR                                     **
3728C               ********************************************************
3729C
3730C               NOTE: CURRENTLY ALLOW ONLY ONE "AND", "OR", "XOR"
3731C                     OPERATOR.
3732C
3733C               NOTE (2017/07): EXTEND TO ALLOW TWO "AND", "OR", "XOR"
3734C                               OPERATORS
3735C
3736C                               HAS NOW BEEN EXTENDED TO "MAXLOG"
3737C                               (CURRENTLY SET TO 10)
3738C
3739      ISTEPN='1B'
3740      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
3741     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3742C
3743      MAXLOG=10
3744      NOPER=0
3745      NPASS=1
3746      JPASS=0
3747      NPOSLO=101
3748      DO59II=1,MAXLOG
3749        IOPER(II)='    '
3750   59 CONTINUE
3751      ICNT3=0
3752      IWIDTT=IWIDTH
3753C
3754C     SEARCH FOR AND, OR, XOR IN IANS
3755C
37561000  CONTINUE
3757C
3758      ISTEPN='1C'
3759      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
3760     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3761C
3762      NUMART=NUMARG
3763C
3764      IF(NUMARG.LE.1)THEN
3765        IF(JPASS.GE.1)THEN
3766          IF(IFEEDB.EQ.'ON')THEN
3767            WRITE(ICOUT,999)
3768            CALL DPWRST('XXX','BUG ')
3769            WRITE(ICOUT,60)ICASIF
3770   60       FORMAT('       COMBINED IF STATUS   = ',A4)
3771            CALL DPWRST('XXX','BUG ')
3772            WRITE(ICOUT,999)
3773            CALL DPWRST('XXX','BUG ')
3774          ENDIF
3775        ELSE
3776           ICASIF='FALS'
3777           IF(IFEEDB.EQ.'ON')THEN
3778             WRITE(ICOUT,999)
3779             CALL DPWRST('XXX','BUG ')
3780             WRITE(ICOUT,1011)
3781             CALL DPWRST('XXX','BUG ')
3782             WRITE(ICOUT,7112)
3783 7112        FORMAT('      THERE IS ONLY ONE (OR ZERO) ARGUMENT TO ',
3784     1              'THE IF COMMAND')
3785             CALL DPWRST('XXX','BUG ')
3786             WRITE(ICOUT,7017)ICASIF
3787             CALL DPWRST('XXX','BUG ')
3788           ENDIF
3789           GOTO9000
3790        ENDIF
3791        GOTO9009
3792      ENDIF
3793C
3794      IFLAG=0
3795      DO61II=1,NUMARG
3796        IF(IHARG(II).EQ.'AND ' .OR. IHARG(II).EQ.'OR  ' .OR.
3797     1     IHARG(II).EQ.'XOR ')THEN
3798          NOPER=NOPER+1
3799          NPASS=NPASS+1
3800          IF(NOPER.LE.MAXLOG)IOPER(NOPER)=IHARG(II)
3801          NPOSLO=II
3802          IFLAG=1
3803          GOTO63
3804        ENDIF
3805   61 CONTINUE
3806   63 CONTINUE
3807C
3808      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
3809        WRITE(ICOUT,66)NOPER,NPASS,NPOSLO,NUMART,IFLAG
3810   66   FORMAT('NOPER,NPASS,NPOSLO,NUMART,IFLAG = ',5I5)
3811        CALL DPWRST('XXX','BUG ')
3812      ENDIF
3813C
3814      IF(NOPER.GT.MAXLOG)THEN
3815        WRITE(ICOUT,999)
3816        CALL DPWRST('XXX','BUG ')
3817        WRITE(ICOUT,411)
3818        CALL DPWRST('XXX','BUG ')
3819        WRITE(ICOUT,68)MAXLOG
3820   68   FORMAT('      MORE THAN ',I2,' LOGICAL OPERATORS (AND, OR, ',
3821     1         'XOR) DETECTED.')
3822        CALL DPWRST('XXX','BUG ')
3823        IERROR='YES'
3824        GOTO9000
3825      ENDIF
3826C
3827C     FIND LOCATION IN STRING
3828C
3829      IF(NPASS.GE.2 .AND. IFLAG.EQ.1)THEN
3830        NUMART=NPOSLO-1
3831        IF(IOPER(NOPER).EQ.'AND ')THEN
3832          DO71I=1,IWIDTH
3833            IF(IANS(I)(1:1).EQ.' ' .AND. IANS(I+1)(1:1).EQ.'A' .AND.
3834     1         IANS(I+2)(1:1).EQ.'N' .AND. IANS(I+3)(1:1).EQ.'D' .AND.
3835     1         IANS(I+4)(1:1).EQ.' ')THEN
3836              IWIDTT=I-1
3837              ILOCP2=I+5
3838              ILOCSV=ILOCP2
3839              GOTO79
3840            ENDIF
3841   71     CONTINUE
3842        ELSEIF(IOPER(NOPER).EQ.'OR  ')THEN
3843          DO72I=1,IWIDTH
3844            IF(IANS(I)(1:1).EQ.' ' .AND. IANS(I+1)(1:1).EQ.'O' .AND.
3845     1         IANS(I+2)(1:1).EQ.'R' .AND. IANS(I+3)(1:1).EQ.' ')THEN
3846              IWIDTT=I-1
3847              ILOCP2=I+5
3848              ILOCSV=ILOCP2
3849              GOTO79
3850            ENDIF
3851   72     CONTINUE
3852        ELSEIF(IOPER(NOPER).EQ.'XOR ')THEN
3853          DO73I=1,IWIDTH
3854            IF(IANS(I)(1:1).EQ.' ' .AND. IANS(I+1)(1:1).EQ.'X' .AND.
3855     1         IANS(I+2)(1:1).EQ.'O' .AND. IANS(I+3)(1:1).EQ.'R' .AND.
3856     1         IANS(I+4)(1:1).EQ.' ')THEN
3857              IWIDTT=I-1
3858              ILOCP2=I+5
3859              ILOCSV=ILOCP2
3860              GOTO79
3861            ENDIF
3862   73     CONTINUE
3863        ELSE
3864          IWIDTT=IWIDTH
3865          ILOCP2=IWIDTH
3866        ENDIF
3867C
3868   79   CONTINUE
3869C
3870        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
3871          WRITE(ICOUT,74)IWIDTT,ILOCP2,ILOCSV
3872   74     FORMAT('AT 74: IWIDTT,ILOCP2,ILOCSV = ',3I8)
3873          CALL DPWRST('XXX','BUG ')
3874        ENDIF
3875C
3876      ENDIF
3877C
3878C     2016/10: CHECK IF FIRST ARGUMENT IS "NOT"
3879C
3880      IF(NUMART.GE.1 .AND. IHARG(1).EQ.'NOT ')THEN
3881        INOT='ON'
3882        ISHIFT=1
3883        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
3884     1              IBUGQ,IERROR)
3885        NUMART=NUMART-1
3886      ENDIF
3887C
3888C
3889CCCCC THE FOLLOWING SECTION WAS ADDED AUGUST 1992
3890C               **************************************************
3891C               **  STEP 2.0--                                  **
3892C               **  TREAT THE     IF ... NOT EXIST CASE         **
3893C               **      IF ... NOT EXIST THEN ==> ICASIF = TRUE **
3894C               **      IF ... EXIST THEN ==> ICASIF = FALSE    **
3895C               **************************************************
3896C
3897C               2016/10: ADD
3898C
3899C                        IF COMMAND LINE ARGUMENT <name> EXISTS
3900C
3901C               2018/05: ADD
3902C
3903C                        IF COMMAND LINE ARGUMENT <name> NOT EXISTS
3904C
3905      ISTEPN='2'
3906      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
3907     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3908C
3909      IF(NUMART.GE.5)THEN
3910        IF(IHARG(1).EQ.'COMM' .AND. IHARG(2).EQ.'LINE' .AND.
3911     1     IHARG(3).EQ.'ARGU' .AND. IHARG(5).EQ.'EXIS')THEN
3912C
3913          ISTRIN=' '
3914          ISTRI2=' '
3915          DO75II=1,IWIDTT
3916            ISTRIN(II:II)=IANSLC(II)(1:1)
3917   75     CONTINUE
3918          ISTART=1
3919          ISTOP=IWIDTT
3920          IWORD=5
3921          CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD,
3922     1                ICOL1,ICOL2,ISTRI2,NCSTRI,
3923     1                IBUGQ,ISUBRO,IERROR)
3924          DO77II=1,NMACLA
3925            IF(ISTRI2(1:8).EQ.IMACLA(II)(1:8))THEN
3926              IEXIST='YES'
3927              ICASIF='TRUE'
3928              GOTO7011
3929            ENDIF
3930   77     CONTINUE
3931          IEXIST='NO'
3932          ICASIF='FALS'
3933C
3934 7011     CONTINUE
3935          IF(IFEEDB.EQ.'ON')THEN
3936            WRITE(ICOUT,999)
3937            CALL DPWRST('XXX','BUG ')
3938            WRITE(ICOUT,1011)
3939            CALL DPWRST('XXX','BUG ')
3940            WRITE(ICOUT,7012)IHARG(4),IHARG2(4)
3941 7012       FORMAT('      IF     NAME         = ',2A4)
3942            CALL DPWRST('XXX','BUG ')
3943            WRITE(ICOUT,7013)IEXIST
3944 7013       FORMAT('      IF     NAME EXISTS  = ',A4)
3945            CALL DPWRST('XXX','BUG ')
3946            WRITE(ICOUT,7017)ICASIF
3947 7017       FORMAT('      IF     STATUS       = ',A4)
3948            CALL DPWRST('XXX','BUG ')
3949          ENDIF
3950C
3951          GOTO9000
3952C
3953        ELSEIF(IHARG(1).EQ.'COMM' .AND. IHARG(2).EQ.'LINE' .AND.
3954     1     IHARG(3).EQ.'ARGU' .AND. IHARG(5).EQ.'NOT ' .AND.
3955     1     IHARG(6).EQ.'EXIS')THEN
3956C
3957          ISTRIN=' '
3958          ISTRI2=' '
3959          DO7078II=1,IWIDTT
3960            ISTRIN(II:II)=IANSLC(II)(1:1)
3961 7078     CONTINUE
3962          ISTART=1
3963          ISTOP=IWIDTT
3964          IWORD=5
3965          CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD,
3966     1                ICOL1,ICOL2,ISTRI2,NCSTRI,
3967     1                IBUGQ,ISUBRO,IERROR)
3968          DO7079II=1,NMACLA
3969            IF(ISTRI2(1:8).EQ.IMACLA(II)(1:8))THEN
3970              ICASIF='FALS'
3971              IEXIST='YES'
3972              GOTO7081
3973            ENDIF
3974 7079     CONTINUE
3975          IEXIST='NO'
3976          ICASIF='TRUE'
3977C
3978 7081     CONTINUE
3979          IF(IFEEDB.EQ.'ON')THEN
3980            WRITE(ICOUT,999)
3981            CALL DPWRST('XXX','BUG ')
3982            WRITE(ICOUT,1011)
3983            CALL DPWRST('XXX','BUG ')
3984            WRITE(ICOUT,7012)IHARG(4),IHARG2(4)
3985            CALL DPWRST('XXX','BUG ')
3986            WRITE(ICOUT,7013)IEXIST
3987            CALL DPWRST('XXX','BUG ')
3988            WRITE(ICOUT,7017)ICASIF
3989            CALL DPWRST('XXX','BUG ')
3990          ENDIF
3991C
3992          GOTO9000
3993C
3994        ENDIF
3995      ENDIF
3996C
3997      IF(NUMART.GE.3)THEN
3998         IF(IHARG(2).EQ.'NOT'.AND.IHARG(3).EQ.'EXIS')THEN
3999C
4000            IH=IHARG(1)
4001            IH2=IHARG2(1)
4002            MESSAG='NO'
4003            CALL CHECKF(IH,IH2,IHWUSE,
4004     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
4005     1                  NUMNAM,MAXNAM,
4006     1                  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,ITYPE)
4007C
4008            IF(ITYPE.EQ.'NONE')THEN
4009              IEXIST='NO'
4010              ICASIF='TRUE'
4011            ELSE
4012              IEXIST='YES'
4013              ICASIF='FALS'
4014            ENDIF
4015            IERROR='NO'
4016C
4017            IF(IFEEDB.EQ.'ON')THEN
4018              WRITE(ICOUT,999)
4019              CALL DPWRST('XXX','BUG ')
4020              WRITE(ICOUT,1011)
4021              CALL DPWRST('XXX','BUG ')
4022              WRITE(ICOUT,7012)IHARG(4),IHARG2(4)
4023              CALL DPWRST('XXX','BUG ')
4024              WRITE(ICOUT,7013)IEXIST
4025              CALL DPWRST('XXX','BUG ')
4026              WRITE(ICOUT,7017)ICASIF
4027              CALL DPWRST('XXX','BUG ')
4028            ENDIF
4029C
4030            GOTO9000
4031C
4032         ENDIF
4033      ENDIF
4034C
4035CCCCC THE FOLLOWING SECTION WAS ADDED NOVEMBER 1997
4036C               **************************************************
4037C               **  STEP 2.0A--                                 **
4038C               **  TREAT THE     IF ...     EXIST CASE         **
4039C               **      IF ...     EXIST THEN ==> ICASIF = TRUE **
4040C               **      IF ... NOT EXIST THEN ==> ICASIF = FALSE**
4041C               **************************************************
4042C
4043      ISTEPN='2A'
4044      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4045     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4046C
4047      ICASIF='TRUE'
4048      IF(NUMART.GE.2)THEN
4049         IF(IHARG(2).EQ.'EXIS')THEN
4050C
4051            IH=IHARG(1)
4052            IH2=IHARG2(1)
4053            MESSAG='NO'
4054            ILOC=-99
4055            ITYPE='NONE'
4056            CALL CHECKF(IH,IH2,IHWUSE,
4057     1                  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
4058     1                  NUMNAM,MAXNAM,
4059     1                  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,ITYPE)
4060C
4061            IF(ITYPE.EQ.'NONE')THEN
4062              ICASIF='FALS'
4063            ELSE
4064              ICASIF='TRUE'
4065            ENDIF
4066            IERROR='NO'
4067C
4068            IF(IFEEDB.EQ.'ON')THEN
4069              WRITE(ICOUT,999)
4070              CALL DPWRST('XXX','BUG ')
4071              WRITE(ICOUT,1011)
4072              CALL DPWRST('XXX','BUG ')
4073              WRITE(ICOUT,7012)IHARG(4),IHARG2(4)
4074              CALL DPWRST('XXX','BUG ')
4075              WRITE(ICOUT,7013)IEXIST
4076              CALL DPWRST('XXX','BUG ')
4077              WRITE(ICOUT,7017)ICASIF
4078              CALL DPWRST('XXX','BUG ')
4079            ENDIF
4080C
4081            GOTO9000
4082C
4083         ENDIF
4084      ENDIF
4085C
4086CCCCC THE FOLLOWING SECTION WAS ADDED JULY 2002.
4087C               **************************************************
4088C               **  STEP 2.0B-                                  **
4089C               **  TREAT THE                                   **
4090C               **      IF STRING = "....."     CASE            **
4091C               **      IF STRING <> "..."      CASE            **
4092C               **************************************************
4093C
4094C     ORIGINAL IMPLEMENTATION REQUIRED PRE-DEFINED STRING ON
4095C     LEFT HAND SIDE OF "=" (OR "<>").
4096C
4097C     2018/05: FOR STRINGS, MAKE MATCH TRUE IF ONE SIDE IS A
4098C              SINGLE BLANK CHARACTER AND THE OTHER IS A
4099C              NULL (NO CHARACTERS) STRING.
4100C
4101C     2018/06: THE FOLLOWING WAS A PROBLEM
4102C
4103C                 IF " " = ....
4104C
4105C              IN THIS CASE, THE EQUAL SIGN IS IN IHARG(3), NOT
4106C              IHARG(2).  PACK THIS INTO "".
4107C
4108C              RELATED TO THIS, CONSTRUCTS LIKE
4109C
4110C                 IF "SUBSET Y 4" = ....
4111C
4112C              ARE AN ISSUE.   CHECK FOR LOCATION OF THE EQUAL SIGN.
4113C
4114      ISTEPN='2B'
4115      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4116     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4117C
4118      IF(ICOM.EQ.'IF')THEN
4119C
4120        IF(IHARG(1).EQ.'"   ' .AND. IHARG(2).EQ.'"   ')THEN
4121          ISHIFT=1
4122          CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
4123     1                IBUGQ,IERROR)
4124          IHARG(1)(1:1)='"'
4125          IHARG(1)(2:2)='"'
4126        ENDIF
4127C
4128        IPOSEQ=-1
4129        DO147KK=2,NUMARG-1
4130          IF(IHARG(KK).EQ.'=   ' .OR. IHARG(KK).EQ.'<>  ' .OR.
4131     1       IHARG(KK).EQ.'<=  ' .OR. IHARG(KK).EQ.'>=  ' .OR.
4132     1       IHARG(KK).EQ.'<   ' .OR. IHARG(KK).EQ.'>   ')THEN
4133            IPOSEQ=KK
4134            GOTO148
4135          ENDIF
4136  147   CONTINUE
4137  148   CONTINUE
4138C
4139CCCCC   IF(NUMART.GE.3.AND.(IHARG(2).EQ.'='.OR.IHARG(2).EQ.'<>'))THEN
4140        IF(NUMART.GE.3.AND.IPOSEQ.GT.0)THEN
4141C
4142          IH=IHARG(1)
4143          IH2=IHARG2(1)
4144          MESSAG='NO'
4145          CALL CHECKF(IH,IH2,IHWUSE,
4146     1    IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
4147     1    ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,ITYPE)
4148C
4149C         IF FIRST ARGUMENT IS A PREVIOSLY DEFINED STRING, EXTRACT
4150C         THE VALUE.  OTHERWISE, CHECK TO SEE IF THE FIRST ARGUMENT
4151C         IS A QUOTED STRING.  LITERAL STRINGS MUST BE ENCLOSED IN
4152C         DOUBLE QUOTES (IF NOT, THE ARGUMENT IS INTERPRETED AS A
4153C         NAME AND A STRING COMPARISON IS NOT PERFORMED).
4154C
4155          IF(ITYPE.EQ.'STRING')THEN
4156            NTEXT1=0
4157            ITEXT1=' '
4158            NSTRT=IVSTAR(ILOC)
4159            NSTOP=IVSTOP(ILOC)
4160            DO140J=NSTRT,NSTOP
4161              NTEXT1=NTEXT1+1
4162              ITEXT1(NTEXT1:NTEXT1)=IFUNC(J)(1:1)
4163  140       CONTINUE
4164          ELSE
4165            ISTRIN=' '
4166            ISTRI2=' '
4167            DO142II=1,IWIDTT
4168              ISTRIN(II:II)=IANSLC(II)(1:1)
4169  142       CONTINUE
4170            ISTART=1
4171            ISTOP=IWIDTT
4172            IWORD=2
4173            IFILQZ=IFILQU
4174            IFILQU='ON'
4175            CALL DPEXWO(ISTRIN,ISTART,ISTOP,IWORD,
4176     1                  ICOL1,ICOL2,ISTRI2,NCSTR,
4177     1                  IBUGQ,ISUBRO,IERROR)
4178            IFILQU=IFILQZ
4179            IF(ISTRI2(1:1).EQ.'"' .AND. ISTRI2(NCSTR:NCSTR).EQ.'"')THEN
4180              ITEXT1(1:NCSTR-2)=ISTRI2(2:NCSTR-1)
4181              NTEXT1=NCSTR-2
4182            ELSE
4183              GOTO199
4184            ENDIF
4185          ENDIF
4186C
4187          ISTEPN='2B1'
4188          IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4189     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4190C
4191          IF(IHARG(IPOSEQ).EQ.'=')THEN
4192            IFLAG=0
4193          ELSEIF(IHARG(IPOSEQ).EQ.'<>')THEN
4194            IFLAG=1
4195          ELSEIF(IHARG(IPOSEQ).EQ.'<'.AND.IHARG(IPOSEQ+1).EQ.'=')THEN
4196            IFLAG=3
4197          ELSEIF(IHARG(IPOSEQ).EQ.'<')THEN
4198            IFLAG=2
4199          ELSEIF(IHARG(IPOSEQ).EQ.'>'.AND.IHARG(IPOSEQ+1).EQ.'=')THEN
4200            IFLAG=5
4201          ELSEIF(IHARG(IPOSEQ).EQ.'>')THEN
4202            IFLAG=4
4203          ELSE
4204            IERROR='YES'
4205            GOTO9000
4206          ENDIF
4207          IERROR='NO'
4208C
4209CCCCC SEARCH FOR STRING AFTER THE "=" OR "<>".
4210C
4211CCCCC 2014/11: CHECK IF PRE-DEFINED STRING GIVEN FIRST
4212C
4213          IF(IFLAG.EQ.3 .OR. IFLAG.EQ.5)THEN
4214            IH=IHARG(IPOSEQ+2)
4215            IH2=IHARG2(IPOSEQ+2)
4216          ELSE
4217            IH=IHARG(IPOSEQ+1)
4218            IH2=IHARG2(IPOSEQ+1)
4219          ENDIF
4220          MESSAG='NO'
4221          CALL CHECKF(IH,IH2,IHWUSE,
4222     1    IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
4223     1    ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,ITYPE)
4224C
4225          IF(ITYPE.EQ.'STRING')THEN
4226            NTEXT2=0
4227            ITEXT2=' '
4228            NSTRT=IVSTAR(ILOC)
4229            NSTOP=IVSTOP(ILOC)
4230            DO143J=NSTRT,NSTOP
4231              NTEXT2=NTEXT2+1
4232              ITEXT2(NTEXT2:NTEXT2)=IFUNC(J)(1:1)
4233  143       CONTINUE
4234          ELSE
4235            IF(IFLAG.EQ.0 .OR.IFLAG.EQ.2 .OR. IFLAG.EQ.4)THEN
4236C
4237              ISTEPN='2B2'
4238              IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4239     1          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4240C
4241              DO110I=1,IWIDTT
4242                IF(IANSLC(I).EQ.'=')THEN
4243                  ISTRT=I+1
4244                  GOTO119
4245                ENDIF
4246  110         CONTINUE
4247              IERROR='YES'
4248              GOTO9000
4249  119         CONTINUE
4250            ELSEIF(IFLAG.EQ.1 .OR. IFLAG.EQ.3 .OR. IFLAG.EQ.5)THEN
4251C
4252              ISTEPN='2B2'
4253              IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4254     1          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4255C
4256              DO120I=1,IWIDTT
4257                IF(IANSLC(I).EQ.'<' .AND. IANSLC(I+1).EQ.'>')THEN
4258                  ISTRT=I+2
4259                  GOTO129
4260                ELSEIF(IANSLC(I).EQ.'<' .AND. IANSLC(I+1).EQ.'=')THEN
4261                  ISTRT=I+2
4262                  GOTO129
4263                ELSEIF(IANSLC(I).EQ.'>' .AND. IANSLC(I+1).EQ.'=')THEN
4264                  ISTRT=I+2
4265                  GOTO129
4266                ENDIF
4267  120         CONTINUE
4268              IERROR='YES'
4269              GOTO9000
4270  129         CONTINUE
4271            ENDIF
4272C
4273            ISTEPN='2B3'
4274            IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
4275              CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4276              WRITE(ICOUT,156)ISTRT
4277  156         FORMAT('ISTRT = ',I5)
4278              CALL DPWRST('XXX','BUG ')
4279            ENDIF
4280C
4281            NTEXT2=0
4282            ITEXT2=' '
4283            DO130I=ISTRT,IWIDTT
4284              IF(IANSLC(I).EQ.' ')THEN
4285                GOTO130
4286              ELSEIF(IANSLC(I).EQ.'"')THEN
4287                NSTRT=I+1
4288                ICOUNT=0
4289                DO132J=NSTRT,IWIDTT
4290                  IF(IANSLC(J).EQ.'"')THEN
4291                    NLAST=J-1
4292                    GOTO134
4293                  ELSE
4294                    ICOUNT=ICOUNT+1
4295                    ITEXT2(ICOUNT:ICOUNT)=IANSLC(J)(1:1)
4296                  ENDIF
4297  132           CONTINUE
4298                NLAST=IWIDTH
4299  134           CONTINUE
4300                NTEXT2=NLAST-NSTRT+1
4301                GOTO139
4302              ELSE
4303                NSTRT=I
4304                ICOUNT=0
4305                DO137J=NSTRT,IWIDTT
4306                  IF(IANSLC(J).EQ.' ')THEN
4307                    NLAST=J-1
4308                    GOTO138
4309                  ELSE
4310                    ICOUNT=ICOUNT+1
4311                    ITEXT2(ICOUNT:ICOUNT)=IANSLC(J)(1:1)
4312                  ENDIF
4313  137           CONTINUE
4314                NLAST=IWIDTT
4315  138           CONTINUE
4316                NTEXT2=NLAST-NSTRT+1
4317                GOTO139
4318              ENDIF
4319  130       CONTINUE
4320  139       CONTINUE
4321          ENDIF
4322C
4323CCCCC     NOW COMPARE THE TWO STRINGS (IMTCH=0 FOR MATCH,
4324CCCCC     1 FOR NO MATCH).
4325CCCCC
4326CCCCC     2018/05: MAKE SINGLE BLANK CHARACTER MATCH TRUE TO
4327CCCCC              EMPTY STRING.
4328CCCCC     2018/09: "<", "<=", ">", ">=" CASES HANDLED SEPARATELY.
4329C
4330          IF(IFLAG.EQ.2)THEN
4331C
4332C           LESS THAN CASE
4333C
4334            DO1141II=1,MAX(NTEXT1,NTEXT2)
4335              ICASIF='TRUE'
4336              IVAL1=0
4337              IVAL2=0
4338              ICNT=II
4339              IF(II.LE.NTEXT1)CALL DPCOAN(ITEXT1(II:II),IVAL1)
4340              IF(II.LE.NTEXT2)CALL DPCOAN(ITEXT2(II:II),IVAL2)
4341              IF(IVAL1.GT.IVAL2)THEN
4342                ICASIF='FALS'
4343                GOTO1651
4344              ENDIF
4345 1141       CONTINUE
4346            IF(IVAL1.EQ.IVAL2)ICASIF='FALS'
4347            GOTO1651
4348          ELSEIF(IFLAG.EQ.3)THEN
4349C
4350C           LESS THAN OR EQUAL TO CASE
4351C
4352            DO1142II=1,MAX(NTEXT1,NTEXT2)
4353              ICASIF='TRUE'
4354              IVAL1=0
4355              IVAL2=0
4356              IF(II.LE.NTEXT1)CALL DPCOAN(ITEXT1(II:II),IVAL1)
4357              IF(II.LE.NTEXT2)CALL DPCOAN(ITEXT2(II:II),IVAL2)
4358              IF(IVAL1.GT.IVAL2)THEN
4359                ICASIF='FALS'
4360                GOTO1651
4361              ENDIF
4362 1142       CONTINUE
4363            GOTO1651
4364          ELSEIF(IFLAG.EQ.4)THEN
4365C
4366C           GREATER THAN CASE
4367C
4368            DO1143II=1,MAX(NTEXT1,NTEXT2)
4369              ICASIF='TRUE'
4370              IVAL1=0
4371              IVAL2=0
4372              IF(II.LE.NTEXT1)CALL DPCOAN(ITEXT1(II:II),IVAL1)
4373              IF(II.LE.NTEXT2)CALL DPCOAN(ITEXT2(II:II),IVAL2)
4374              IF(IVAL1.LT.IVAL2)THEN
4375                ICASIF='FALS'
4376                GOTO1651
4377              ENDIF
4378 1143       CONTINUE
4379            IF(IVAL1.EQ.IVAL2)ICASIF='FALS'
4380            GOTO1651
4381          ELSEIF(IFLAG.EQ.5)THEN
4382C
4383C           GREATER THAN OR EQUAL TO CASE
4384C
4385            DO1144II=1,MAX(NTEXT1,NTEXT2)
4386              ICASIF='TRUE'
4387              IVAL1=0
4388              IVAL2=0
4389              IF(II.LE.NTEXT1)CALL DPCOAN(ITEXT1(II:II),IVAL1)
4390              IF(II.LE.NTEXT2)CALL DPCOAN(ITEXT2(II:II),IVAL2)
4391              IF(IVAL1.LT.IVAL2)THEN
4392                ICASIF='FALS'
4393                GOTO1651
4394              ENDIF
4395 1144       CONTINUE
4396            GOTO1651
4397          ENDIF
4398C
4399          IMTCH=0
4400          IF(NTEXT1.EQ.1 .AND. NTEXT2.EQ.0 .AND.
4401     1      ITEXT1(1:1).EQ.' ')THEN
4402              IMTCH=0
4403          ELSEIF(NTEXT1.EQ.1 .AND. NTEXT2.EQ.1 .AND.
4404     1      ITEXT1(1:1).EQ.' ' .AND. ITEXT2(1:1).EQ.' ')THEN
4405              IMTCH=0
4406          ELSEIF(NTEXT1.EQ.0 .AND. NTEXT2.EQ.0)THEN
4407              IMTCH=0
4408          ELSEIF(NTEXT1.EQ.0 .AND. NTEXT2.EQ.1 .AND.
4409     1      ITEXT2(1:1).EQ.' ')THEN
4410              IMTCH=0
4411          ELSEIF(NTEXT1.EQ.NTEXT2)THEN
4412            DO150J=1,NTEXT1
4413              IF(ITEXT1(J:J).NE.ITEXT2(J:J))THEN
4414                IMTCH=1
4415                GOTO159
4416              ENDIF
4417  150       CONTINUE
4418  159       CONTINUE
4419          ELSE
4420            IMTCH=1
4421          ENDIF
4422C
4423CCCCC SET IF STATUS
4424C
4425          IF(IFLAG.EQ.0)THEN
4426            IF(IMTCH.EQ.0)THEN
4427              ICASIF='TRUE'
4428            ELSE
4429              ICASIF='FALS'
4430            ENDIF
4431          ELSE
4432            IF(IMTCH.EQ.0)THEN
4433              ICASIF='FALS'
4434            ELSE
4435              ICASIF='TRUE'
4436            ENDIF
4437          ENDIF
4438C
4439 1651     CONTINUE
4440C
4441          IF(IFEEDB.EQ.'ON')THEN
4442            WRITE(ICOUT,999)
4443            CALL DPWRST('XXX','BUG ')
4444            WRITE(ICOUT,1601)
4445            CALL DPWRST('XXX','BUG ')
4446            WRITE(ICOUT,1652)ITEXT1(1:NTEXT1)
4447 1652       FORMAT('         LEFT HAND STRING  = ',A)
4448            CALL DPWRST('XXX','BUG ')
4449            WRITE(ICOUT,1654)ITEXT2(1:NTEXT2)
4450 1654       FORMAT('         RIGHT HAND STRING = ',A)
4451            CALL DPWRST('XXX','BUG ')
4452            WRITE(ICOUT,1655)ICASIF
4453 1655       FORMAT('         IF    STATUS      = ',A4)
4454            CALL DPWRST('XXX','BUG ')
4455          ENDIF
4456          GOTO9000
4457        ENDIF
4458      ENDIF
4459C
4460  199 CONTINUE
4461C
4462C               ********************************************************
4463C               **  STEP 2.1-- C                                      **
4464C               **  INITIALIZE ALL ELEMENTS IN ISUB(.) TO 11 ISUB(.)  **
4465C               **  ISUB(.) WILL TAKE ON 4 VALUES AT MOST--00, 01,    **
4466C               **  10, 11 .  THE FIRST  DIGIT INDICATES WHETHER OR   **
4467C               **  NOT THE GIVEN ELEMENT IS OUT (0) OR IN (1) OF THE **
4468C               **  LOCAL  CUMULATIVE UNION SET.  THE SECOND DIGIT    **
4469C               **  INDICATES WHETHER OR NOT THE GIVEN ELEMENT IS OUT **
4470C               **  (0) OR IN (1) OF THE GLOBAL CUMULATIVE            **
4471C               **  INTERSECTIONS THE INITIALIZATION OF ALL ELEMENTS  **
4472C               **  TO 11 THUS INDICATES THAT INITIALLY ALL ELEMENTS  **
4473C               **  (TEMPORARILY) ARE IN THE LOCAL UNION SET, AND     **
4474C               **  INITIALLY ALL ELEMENTS ARE IN THE GLOBAL          **
4475C               **  INTERSECTION SET.                                 **
4476C               ********************************************************
4477C
4478      ISTEPN='2.1'
4479      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4480     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4481C
4482      NIOLD=1
4483      DO200I=1,NIOLD
4484        ISUB(I)=11
4485  200 CONTINUE
4486C
4487C               *************************************************
4488C               **  STEP 2.2--                                 **
4489C               **  IF EXISTENT,                               **
4490C               **  PACK < = INTO <=                           **
4491C               **  PACK = < INTO =<                           **
4492C               **  PACK > = INTO >=                           **
4493C               **  PACK = > INTO =>                           **
4494C               **  THIS IS BECAUSE = SIGNS ARE AUTOMATICALLY  **
4495C               **  GIVEN A SPACE IN DPTYPE AND TREATED AS     **
4496C               **  AS A SEPARATE WORD.                        **
4497C               **  NOTE THAT NUMARG WILL BE CHANGED.          **
4498C               *************************************************
4499C
4500      ISTEPN='2.2'
4501      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4502     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4503C
4504      CALL ADJUS2(IHARG,IHARG2,IARG,ARG,IARGT,NUMART)
4505C
4506C               ************************************************
4507C               **  STEP 3.1--                                **
4508C               **  CHECK TO SEE IF HAVE THE  IF      CASE.   **
4509C               **  LOCATE THE POSITION IN THE ARGUMENT LIST  **
4510C               **  OF THE WORD    IF   .                     **
4511C               ************************************************
4512C
4513      ISTEPN='3.1'
4514      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4515     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4516C
4517      JMAX=0
4518      ICASSC='SEAR'
4519      ICASQU='UNKN'
4520      NUMSV=0
4521      DO300IPASS=1,100
4522C
4523        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
4524          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4525          WRITE(ICOUT,999)
4526          CALL DPWRST('XXX','BUG ')
4527          WRITE(ICOUT,301)
4528  301     FORMAT('***** AT THE BEGINNING OF ANOTHER PASS--')
4529          CALL DPWRST('XXX','BUG ')
4530          WRITE(ICOUT,302)IPASS,JMAX
4531  302     FORMAT('IPASS,JMAX = ',2I8)
4532          CALL DPWRST('XXX','BUG ')
4533          IF(ILOCTG.GE.1 .AND. ILOCTG.LE.100)THEN
4534            WRITE(ICOUT,303)ICASSC,ILOCTG,IHARG(ILOCTG),IHARG2(ILOCTG)
4535  303       FORMAT('ICASSC,ILOCTG,IHARG(ILOCTG),IHARG2(ILOCTG) = ',
4536     1             A4,I8,2(2X,A4))
4537            CALL DPWRST('XXX','BUG ')
4538          ELSE
4539            WRITE(ICOUT,304)ICASSC,ILOCTG
4540  304       FORMAT('ICASSC,ILOCTG = ',A4,2X,I8)
4541            CALL DPWRST('XXX','BUG ')
4542          ENDIF
4543        ENDIF
4544C
4545        IF(ICASSC.EQ.'STOP')GOTO1100
4546        JMIN=JMAX+1
4547        IF(JMIN.GT.NUMART)GOTO1100
4548        IF(JMIN.EQ.NUMART.AND.IHARG(JMIN).EQ.'AND '.AND.
4549     1     IHARG2(JMIN).EQ.'    ')GOTO1100
4550C
4551        IF(ICASSC.EQ.'CONT')GOTO600
4552        DO310I=1,NIOLD
4553          ITEMP=ISUB(I)
4554          IF(ITEMP.EQ.00)ISUB(I)=00
4555          IF(ITEMP.EQ.10)ISUB(I)=00
4556          IF(ITEMP.EQ.01)ISUB(I)=00
4557          IF(ITEMP.EQ.11)ISUB(I)=11
4558  310   CONTINUE
4559C
4560        ICASQU='UNKN'
4561        DO340J=JMIN,NUMART
4562          J2=J
4563          IF(IHARG(J).EQ.'IF  '.AND.IHARG2(J).EQ.'    ')THEN
4564            ICASQU='IF  '
4565            ILOCS=J2
4566            GOTO390
4567          ENDIF
4568  340   CONTINUE
4569        IF(JMIN.EQ.1.AND.
4570     1     ICOM.EQ.'IF  '.AND.ICOM2.EQ.'    ')THEN
4571          J2=0
4572          ICASQU='IF  '
4573          ILOCS=J2
4574          GOTO390
4575        ENDIF
4576        ILOCS=NUMART+1
4577        GOTO1100
4578C
4579  390   CONTINUE
4580C
4581        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
4582          WRITE(ICOUT,391)IPASS,ICASQU,ILOCS
4583  391     FORMAT('IPASS,ICASQU,ILOCS = ',I8,2X,A4,I8)
4584          CALL DPWRST('XXX','BUG ')
4585        ENDIF
4586C
4587C               *******************************************
4588C               **  STEP 3.2--                           **
4589C               **  IF HAVE THE IF     CASE,             **
4590C               **  INITIALIZE ISUB(.) TO 0X--00 OR 01.  **
4591C               *******************************************
4592C
4593        ISTEPN='3.2'
4594        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4595     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4596C
4597        IF(ICASQU.EQ.'IF  ')THEN
4598          DO401I=1,NIOLD
4599            ITEMP=ISUB(I)
4600            IF(ITEMP.EQ.00)ISUB(I)=00
4601            IF(ITEMP.EQ.10)ISUB(I)=00
4602            IF(ITEMP.EQ.01)ISUB(I)=01
4603            IF(ITEMP.EQ.11)ISUB(I)=01
4604  401     CONTINUE
4605        ELSE
4606          IERROR='YES'
4607          GOTO9000
4608        ENDIF
4609C
4610C               ****************************************************
4611C               **  STEP 4--                                      **
4612C               **  CHECK VALIDITY OF FIRST ARGUMENT AFTER     IF **
4613C               **  THIS SHOULD BE THE IF PARAMETER               **
4614C               ****************************************************
4615C
4616C       2018/05: ALLOW SYNTAX LIKE
4617C
4618C                   IF 3 > 2
4619C                   IF 3 > B
4620C
4621C                THAT IS, THE ARGUMENT ON THE LEFT HAND SIDE CAN BE
4622C                A NUMERIC VALUE AS WELL AS A PARAMETER.
4623C
4624        ISTEPN='4'
4625        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4626     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4627C
4628        ICASPA='UNKN'
4629        ILOCS1=ILOCS+1
4630        JMAX=ILOCS1
4631        IF(ILOCS1.GT.NUMART)THEN
4632          WRITE(ICOUT,999)
4633          CALL DPWRST('XXX','BUG ')
4634          WRITE(ICOUT,411)
4635  411     FORMAT('***** ERROR IN IF--')
4636          CALL DPWRST('XXX','BUG ')
4637          WRITE(ICOUT,412)
4638  412     FORMAT('      THE WORD    IF    WAS THE FINAL WORD ON THE')
4639          CALL DPWRST('XXX','BUG ')
4640          GOTO8000
4641        ENDIF
4642C
4643        IHSET=IHARG(ILOCS1)
4644        IHSET2=IHARG2(ILOCS1)
4645C
4646C       2015/02: IF PARAMETER NOT FOUND, SET IF STATUS TO FALSE
4647C
4648        ICASPA='P   '
4649        IHWUSE='P'
4650CCCCC   2018/02: IF PARAMETER DOES NOT EXIST, SIMPLY SET CLAUSE TO
4651CCCCC            FALSE, BUT DO NOT GENERATE ERROR MESSAGE.
4652CCCCC   MESSAG='YES'
4653        MESSAG='NO'
4654        CALL CHECKN(IHSET,IHSET2,IHWUSE,
4655     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
4656     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
4657        IF(IERROR.EQ.'YES')THEN
4658          IF(IARGT(ILOCS1).EQ.'NUMB')THEN
4659            ASETV=ARG(ILOCS1)
4660          ELSE
4661            ICASIF='FALS'
4662            IERROR='FALS'
4663            GOTO9000
4664          ENDIF
4665        ELSE
4666          ASETV=VALUE(ILOC)
4667        ENDIF
4668C
4669        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
4670          ISTEPN='4A'
4671          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4672          WRITE(ICOUT,451)ILOCS1,NUMART,IPASS,IHSET,IHSET2,ICASPA,ASETV
4673  451     FORMAT('ILOCS1,NUMARGT,IPASS,IHSET,IHSET2,ICASPA,ASETV = ',
4674     1           3I8,3X,2A4,2X,A4,3X,G15.7)
4675          CALL DPWRST('XXX','BUG ')
4676        ENDIF
4677C
4678C               ********************************************************
4679C               **  STEP 5--                                          **
4680C               **  CHECK TO SEE IF NEXT ARGUMENT IS                  **
4681C               **        <                                           **
4682C               **        <=                                          **
4683C               **        =                                           **
4684C               **        >=                                          **
4685C               **        >                                           **
4686C               **        <>                                          **
4687C               **  IF NONE OF THE ABOVE, THEN THE ASSUMED OPERATION  **
4688C               **  IS =   .                                          **
4689C               ********************************************************
4690C
4691        ISTEPN='5'
4692        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4693     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4694C
4695        ICASOP='UNKN'
4696        ILOCS2=ILOCS+2
4697        JMAX=ILOCS2
4698        IF(ILOCS2.GT.NUMART)THEN
4699          WRITE(ICOUT,999)
4700          CALL DPWRST('XXX','BUG ')
4701          WRITE(ICOUT,411)
4702          CALL DPWRST('XXX','BUG ')
4703          WRITE(ICOUT,502)
4704  502     FORMAT('      THE   IF   PARAMETER NAME WAS THE FINAL WORD ',
4705     1           'ON')
4706          CALL DPWRST('XXX','BUG ')
4707          GOTO8000
4708        ENDIF
4709C
4710        IHSET=IHARG(ILOCS2)
4711        IHSET2=IHARG2(ILOCS2)
4712C
4713        IF(IHSET.EQ.'<   ')THEN
4714          ICASOP='<   '
4715          ILOCTG=ILOCS2
4716        ELSEIF(IHSET.EQ.'<=  ' .OR. IHSET.EQ.'=<  ')THEN
4717          ICASOP='<=  '
4718          ILOCTG=ILOCS2
4719        ELSEIF(IHSET.EQ.'=   ')THEN
4720          ICASOP='=   '
4721          ILOCTG=ILOCS2
4722        ELSEIF(IHSET.EQ.'>=  ' .OR. IHSET.EQ.'=>  ')THEN
4723          ICASOP='>=  '
4724          ILOCTG=ILOCS2
4725        ELSEIF(IHSET.EQ.'>   ')THEN
4726          ICASOP='>   '
4727          ILOCTG=ILOCS2
4728        ELSEIF(IHSET.EQ.'<>  ' .OR. IHSET.EQ.'><  ' .OR.
4729     1         IHSET.EQ.'!=  ')THEN
4730          ICASOP='<>  '
4731          ILOCTG=ILOCS2
4732        ELSE
4733          ICASOP='=ASS'
4734          ILOCTG=ILOCS2-1
4735        ENDIF
4736C
4737        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
4738          ISTEPN='5A'
4739          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4740          WRITE(ICOUT,591)IPASS,ILOCTG,IHSET,IHSET2,ICASPA,ICASOP
4741  591     FORMAT('IPASS,ILOCTG,IHSET,IHSET2,ICASPA,ICASOP = ',
4742     1           2I8,4(2X,A4))
4743          CALL DPWRST('XXX','BUG ')
4744        ENDIF
4745C
4746C               **********************************************************
4747C               **  STEP 6--                                            **
4748C               **  DETERMINE THE LOWER LIMIT OF THE INTERVAL OF INTEREST.
4749C               **  THIS IS DONE BY CHECKING THE FIRST (NEXT) ARGUMENT  **
4750C               **  IN THE LIST.                                        **
4751C               **  ALSO, FOR THOSE 4 CASES IN WHICH                    **
4752C               **  ICASOP IS   <   <=   >=   >                         **
4753C               **  DETERMINE THE UPPER LIMIT OF THE INTERVAL OF INTEREST.
4754C               **********************************************************
4755C
4756  600   CONTINUE
4757C
4758        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
4759          ISTEPN='6'
4760          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4761          WRITE(ICOUT,601)
4762  601     FORMAT('     AT THE BEGINNING OF STEP 6 IN DPIF--')
4763          CALL DPWRST('XXX','BUG ')
4764          DO605I=1,NIOLD
4765            WRITE(ICOUT,606)I,ISUB(I)
4766  606       FORMAT('I,ISUB(I) = ',2I8)
4767            CALL DPWRST('XXX','BUG ')
4768  605     CONTINUE
4769       ENDIF
4770C
4771        ILOCTG=ILOCTG+1
4772        JMAX=ILOCTG
4773        IF(ILOCTG.GT.NUMART)THEN
4774          WRITE(ICOUT,999)
4775          CALL DPWRST('XXX','BUG ')
4776          WRITE(ICOUT,611)
4777  611     FORMAT('***** ERROR IN DPIF--')
4778          CALL DPWRST('XXX','BUG ')
4779          WRITE(ICOUT,612)
4780  612     FORMAT('      THE    IF    OPERATION   <   <=  =  >=  > ',
4781     1           'WAS THE FINAL WORD ON')
4782          CALL DPWRST('XXX','BUG ')
4783          GOTO8000
4784        ENDIF
4785C
4786        IF(IARGT(ILOCTG).EQ.'NUMB')THEN
4787          DMIN=ARG(ILOCTG)
4788          DMAX=ARG(ILOCTG)
4789          IF(ICASOP.EQ.'<   ')THEN
4790            DMIN=CPUMIN
4791            DMAX=ARG(ILOCTG)
4792          ELSEIF(ICASOP.EQ.'<=  ')THEN
4793            DMIN=CPUMIN
4794            DMAX=ARG(ILOCTG)
4795          ELSEIF(ICASOP.EQ.'>=  ')THEN
4796            DMIN=ARG(ILOCTG)
4797            DMAX=CPUMAX
4798          ELSEIF(ICASOP.EQ.'>   ')THEN
4799            DMIN=ARG(ILOCTG)
4800            DMAX=CPUMAX
4801          ENDIF
4802        ELSEIF(IARGT(ILOCTG).EQ.'WORD')THEN
4803          IH=IHARG(ILOCTG)
4804          IH2=IHARG2(ILOCTG)
4805          IHWUSE='P'
4806CCCCC     MESSAG='YES'
4807          MESSAG='NO'
4808          CALL CHECKN(IH,IH2,IHWUSE,
4809     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
4810     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
4811C
4812          IF(IERROR.EQ.'YES')THEN
4813            ICASIF='FALS'
4814            IERROR='FALS'
4815            GOTO9000
4816          ENDIF
4817C
4818          DMIN=VALUE(ILOC)
4819          DMAX=VALUE(ILOC)
4820          IF(ICASOP.EQ.'<   ')THEN
4821            DMIN=CPUMIN
4822            DMAX=VALUE(ILOC)
4823          ELSEIF(ICASOP.EQ.'<=  ')THEN
4824            DMIN=CPUMIN
4825            DMAX=VALUE(ILOC)
4826          ELSEIF(ICASOP.EQ.'>=  ')THEN
4827            DMIN=VALUE(ILOC)
4828            DMAX=CPUMAX
4829          ELSEIF(ICASOP.EQ.'>   ')THEN
4830            DMIN=VALUE(ILOC)
4831            DMAX=CPUMAX
4832          ENDIF
4833        ELSE
4834          WRITE(ICOUT,999)
4835          CALL DPWRST('XXX','BUG ')
4836          WRITE(ICOUT,631)
4837  631     FORMAT('***** INTERNAL ERROR IN DPIF--')
4838          CALL DPWRST('XXX','BUG ')
4839          WRITE(ICOUT,632)
4840  632     FORMAT('      AN ARGUMENT TYPE WHICH SHOULD BE ')
4841          CALL DPWRST('XXX','BUG ')
4842          WRITE(ICOUT,633)
4843  633     FORMAT('      EITHER A NUMBER OR A WORD, IS NEITHER.')
4844          CALL DPWRST('XXX','BUG ')
4845          WRITE(ICOUT,634)IHARG(ILOCTG),IHARG2(ILOCTG)
4846  634     FORMAT('      ARGUMENT                  = ',2A4)
4847          CALL DPWRST('XXX','BUG ')
4848          WRITE(ICOUT,635)ILOCTG
4849  635     FORMAT('      LOCATION IN ARGUMENT LIST = ',I8)
4850          CALL DPWRST('XXX','BUG ')
4851          WRITE(ICOUT,636)IARGT(ILOCTG)
4852  636     FORMAT('      ARGUMENT TYPE             = ',A4)
4853          CALL DPWRST('XXX','BUG ')
4854          WRITE(ICOUT,637)
4855  637     FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
4856          CALL DPWRST('XXX','BUG ')
4857          IF(IWIDTH.GE.1)THEN
4858            WRITE(ICOUT,638)(IANS(I),I=1,MIN(100,IWIDTH))
4859  638       FORMAT('      ',100A1)
4860            CALL DPWRST('XXX','BUG ')
4861          ENDIF
4862          ICASIF='FALS'
4863          IERROR='YES'
4864          GOTO9000
4865        ENDIF
4866C
4867        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
4868          WRITE(ICOUT,691)IPASS,ICASPA,ICASOP,IH,IH2,DMIN,DMAX
4869  691     FORMAT('IPASS,ICASPA,ICASOP,IH,IH2,DMIN,DMAX = ',
4870     1           I8,4(2X,A4,2X,A4,2X,A4,2X,A4),2G15.7)
4871          CALL DPWRST('XXX','BUG ')
4872        ENDIF
4873C
4874C               **********************************************************
4875C               **  STEP 7--                                            **
4876C               **  DETERMINE THE UPPER LIMIT OF THE INTERVAL OF INTEREST.
4877C               **  NOTE THAT FOR THOSE 4 CASES IN WHICH ICASOP IS      **
4878C               **  <   <=   >=   >    THE UPPER LIMIT OF THE INTERVAL  **
4879C               **  HAS ALREADY BEEN DETERMINED AND SO ALL OF THE CODE  **
4880C               **  OF THIS SECTION MAY BE  SKIPPED.  ON THE OTHER HAND **
4881C               **  WHEN THE OPERATION IS    =  , (EXPLICITLY OR        **
4882C               **  ASSUMED),  OR <>    ,  THE UPPER LIMIT MUST BE      **
4883C               **  DETERMINED.  THIS IS DONE BY CHECKING THE NEXT      **
4884C               **  ARGUMENT IN THE LIST.  IF THIS NEXT ARGUMENT IS TO, **
4885C               **  THIS IMPLIES THAT AN UPPER LIMIT WILL BE PROVIDED   **
4886C               **  (IN THE ARGUMENT AFTER THE   TO   ).  HOWEVER, IF   **
4887C               **  THE NEXT ARGUMENT IS NOT A    TO   , THEN THIS      **
4888C               **  IMPLIES THAT THE LIST CONSISTS OF INDIVIDUAL        **
4889C               **  ELEMENTS OF THE SUBSET AND SO THE UPPER LIMIT WILL  **
4890C               **  BE IDENTICAL TO THE LOWER LIMIT.                    **
4891C               **********************************************************
4892C
4893        ISTEPN='7'
4894        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
4895     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4896C
4897        IF(ICASOP.EQ.'<   ' .OR. ICASOP.EQ.'<=  ' .OR.
4898     1     ICASOP.EQ.'>=  ' .OR. ICASOP.EQ.'>   ')THEN
4899          ICASSC='SEAR'
4900          GOTO790
4901        ENDIF
4902C
4903        ILOCTG=ILOCTG+1
4904C
4905        IF(ILOCTG.GT.NUMART .OR.
4906     1     (ILOCTG.EQ.NUMART.AND.IHARG(ILOCTG).EQ.'AND '.AND.
4907     1     IHARG2(ILOCTG).EQ.'    '))THEN
4908          ILOCTG=ILOCTG-1
4909          JMAX=ILOCTG
4910          ICASSC='STOP'
4911          DMAX=DMIN
4912          GOTO790
4913        ELSEIF(ILOCTG.LE.NUMART.AND.IHARG(ILOCTG).EQ.'IF  '.AND.
4914     1         IHARG2(ILOCTG).EQ.'    ')THEN
4915          ILOCTG=ILOCTG-1
4916          JMAX=ILOCTG
4917          ICASSC='SEAR'
4918          DMAX=DMIN
4919          GOTO790
4920        ELSEIF(ILOCTG.LE.NUMART.AND.IHARG(ILOCTG).EQ.'TO  '.AND.
4921     1         IHARG2(ILOCTG).EQ.'    ')THEN
4922          ILOCTG=ILOCTG+1
4923          JMAX=ILOCTG
4924          IF(ILOCTG.GT.NUMART)GOTO760
4925          IF(ILOCTG.EQ.NUMART.AND.IHARG(ILOCTG).EQ.'AND '.AND.
4926     1       IHARG2(ILOCTG).EQ.'    ')GOTO760
4927          IF(ILOCTG.LE.NUMART.AND.IHARG(ILOCTG).EQ.'IF  '.AND.
4928     1       IHARG2(ILOCTG).EQ.'    ')GOTO760
4929          IF(ILOCTG.LE.NUMART.AND.IHARG(ILOCTG).EQ.'TO  '.AND.
4930     1       IHARG2(ILOCTG).EQ.'    ')GOTO760
4931          GOTO770
4932C
4933        ELSE
4934          ILOCTG=ILOCTG-1
4935          JMAX=ILOCTG
4936          ICASSC='CONT'
4937          DMAX=DMIN
4938          GOTO790
4939        ENDIF
4940C
4941  760   CONTINUE
4942        WRITE(ICOUT,999)
4943        CALL DPWRST('XXX','BUG ')
4944        WRITE(ICOUT,411)
4945        CALL DPWRST('XXX','BUG ')
4946        WRITE(ICOUT,762)
4947  762   FORMAT('      THE WORD    TO    SHOULD HAVE BEEN FOLLOWED BY A')
4948        CALL DPWRST('XXX','BUG ')
4949        WRITE(ICOUT,764)
4950  764   FORMAT('      NUMBER OR A PARAMETER NAME, BUT WAS NOT.')
4951        CALL DPWRST('XXX','BUG ')
4952        WRITE(ICOUT,765)IHARG(ILOCTG),IHARG2(ILOCTG)
4953  765   FORMAT('      TO    WAS FOLLOWED BY THE WORD   ',A4,A4)
4954        CALL DPWRST('XXX','BUG ')
4955        WRITE(ICOUT,766)
4956  766   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
4957        CALL DPWRST('XXX','BUG ')
4958        IF(IWIDTH.GE.1)THEN
4959          WRITE(ICOUT,638)(IANS(I),I=1,MIN(100,IWIDTH))
4960          CALL DPWRST('XXX','BUG ')
4961        ENDIF
4962        IERROR='YES'
4963        GOTO9000
4964C
4965  770   CONTINUE
4966        IF(IARGT(ILOCTG).EQ.'NUMB')THEN
4967          DMAX=ARG(ILOCTG)
4968        ELSEIF(IARGT(ILOCTG).EQ.'WORD')THEN
4969          IH=IHARG(ILOCTG)
4970          IH2=IHARG2(ILOCTG)
4971          IHWUSE='P'
4972          MESSAG='YES'
4973          CALL CHECKN(IH,IH2,IHWUSE,
4974     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
4975     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
4976          IF(IERROR.EQ.'YES')THEN
4977            ICASIF='FALS'
4978            GOTO9000
4979          ENDIF
4980          DMAX=VALUE(ILOC)
4981        ELSE
4982          IBRAN=770
4983          WRITE(ICOUT,631)
4984          CALL DPWRST('XXX','BUG ')
4985          WRITE(ICOUT,771)IBRAN
4986  771     FORMAT('      IMPOSSIBLE BRANCH CONDITION AT BRANCH POINT = ',
4987     1           I8)
4988          CALL DPWRST('XXX','BUG ')
4989          WRITE(ICOUT,772)ILOCTG,IARGT(ILOCTG)
4990  772     FORMAT('ILOCTG, IARGT(ILOCTG) = ',I8,2X,A4)
4991          CALL DPWRST('XXX','BUG ')
4992          IERROR='YES'
4993          GOTO9000
4994        ENDIF
4995C
4996        ILOCTG=ILOCTG+1
4997        ICASSC='CONT'
4998        IF(ILOCTG.GT.NUMART)ICASSC='STOP'
4999        IF(ILOCTG.EQ.NUMART.AND.IHARG(ILOCTG).EQ.'AND '.AND.
5000     1     IHARG2(ILOCTG).EQ.'    ')ICASSC='STOP'
5001        IF(ILOCTG.LE.NUMART.AND.IHARG(ILOCTG).EQ.'IF  '.AND.
5002     1     IHARG2(ILOCTG).EQ.'    ')ICASSC='SEAR'
5003        ILOCTG=ILOCTG-1
5004        JMAX=ILOCTG
5005C
5006  790   CONTINUE
5007        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5008          WRITE(ICOUT,791)IPASS,ICASPA,ICASOP,IH,IH2,DMIN,DMAX
5009  791     FORMAT('IPASS,ICASPA,ICASOP,IH,IH2,DMIN,DMAX = ',
5010     1           I8,4(2X,A4),2G15.7)
5011          CALL DPWRST('XXX','BUG ')
5012        ENDIF
5013C
5014C               ***************************************************
5015C               **  STEP 8--                                     **
5016C               **  TO ALLOW FOR ROUNDOFF ERRORS IN THE          **
5017C               **  STORAGE OF NUMBERS,                          **
5018C               **  JUDICIOUSLY EXPAND THE INTERVAL OF INTEREST  **
5019C               **  BY AN    EPSILON    AMOUNT.                  **
5020C               ***************************************************
5021C
5022        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5023          ISTEPN='8'
5024          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5025          WRITE(ICOUT,801)
5026  801     FORMAT('      AT THE BEGINNING OF STEP 8--')
5027          CALL DPWRST('XXX','BUG ')
5028          WRITE(ICOUT,802)DMIN,DMAX
5029  802     FORMAT('DMIN,DMAX = ',2G15.7)
5030          CALL DPWRST('XXX','BUG ')
5031        ENDIF
5032C
5033        IF(DMIN.GT.DMAX)THEN
5034          HOLD=DMIN
5035          DMIN=DMAX
5036          DMAX=HOLD
5037        ENDIF
5038C
5039        IF(DMIN.EQ.CPUMIN)GOTO819
5040        IF(DMIN.EQ.CPUMAX)GOTO819
5041        IF(ABS(DMIN).EQ.0.0)EPS=0.000001
5042        IF(ABS(DMIN).NE.0.0)EPS=ABS(DMIN*0.000001)
5043        IF(ICASOP.EQ.'=   ')DMIN=DMIN-EPS
5044        IF(ICASOP.EQ.'=ASS')DMIN=DMIN-EPS
5045        IF(ICASOP.EQ.'<>  ')DMIN=DMIN-EPS
5046        IF(ICASOP.EQ.'<   ')DMIN=DMIN-EPS
5047        IF(ICASOP.EQ.'<=  ')DMIN=DMIN-EPS
5048        IF(ICASOP.EQ.'>=  ')DMIN=DMIN-EPS
5049        IF(ICASOP.EQ.'>   ')DMIN=DMIN+EPS
5050  819   CONTINUE
5051C
5052        IF(DMAX.EQ.CPUMAX)GOTO829
5053        IF(DMAX.EQ.CPUMIN)GOTO829
5054        IF(ABS(DMAX).EQ.0.0)EPS=0.000001
5055        IF(ABS(DMAX).NE.0.0)EPS=ABS(DMAX*0.000001)
5056        IF(ICASOP.EQ.'=   ')DMAX=DMAX+EPS
5057        IF(ICASOP.EQ.'=ASS')DMAX=DMAX+EPS
5058        IF(ICASOP.EQ.'<>  ')DMAX=DMAX+EPS
5059        IF(ICASOP.EQ.'<   ')DMAX=DMAX-EPS
5060        IF(ICASOP.EQ.'<=  ')DMAX=DMAX+EPS
5061        IF(ICASOP.EQ.'>=  ')DMAX=DMAX+EPS
5062        IF(ICASOP.EQ.'>   ')DMAX=DMAX+EPS
5063  829   CONTINUE
5064C
5065        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5066          WRITE(ICOUT,891)IPASS,ICASPA,ICASOP,IH,IH2
5067  891     FORMAT('IPASS,ICASPA,ICASOP,IH,IH2 = ',I8,4(2X,A4))
5068          CALL DPWRST('XXX','BUG ')
5069          WRITE(ICOUT,892)EPS,DMIN,DMAX,CPUMIN,CPUMAX
5070  892     FORMAT('EPS,DMIN,DMAX,CPUMIN,CPUMAX = ',5G15.7)
5071          CALL DPWRST('XXX','BUG ')
5072        ENDIF
5073C
5074C               ****************************************************
5075C               **  STEP 9--                                      **
5076C               **  DEFINE THE ISUB(.) VECTOR--                   **
5077C               **  FOR ANY K (K = 1 TO NIOLD),                   **
5078C               **  IF THE K-TH ELEMENT OF THE                    **
5079C               **  SUBSET SPECIFICATION VARIABLE                 **
5080C               **  (THE VARIABLE SPECIFIED AFTER    SUBSET       **
5081C               **  IN THE COMMAND LINE)                          **
5082C               **  IS WITHIN THE SPECIFIED (DMIN,DMAX) LIMITS,   **
5083C               **  THEN ISUB(K) SHOULD RESULT IN A VALUE OF 1;   **
5084C               **  BUT IF THE K-TH ELEMENT OF THE                **
5085C               **  SUBSET SPECIFICATION VARIABLE                 **
5086C               **  IS OUTSIDE THE SPECIFIED (DMIN,DMAX) LIMITS,  **
5087C               **  THEN ISUB(K) SHOULD RESULT IN A 0 .           **
5088C               ****************************************************
5089C
5090        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5091          ISTEPN='9'
5092          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5093          WRITE(ICOUT,901)ILOCS1,IHSET,IHSET2,ICASPA,ASETV,MAXCOL
5094  901     FORMAT('ILOCS1,IHSET,IHSET2,ICASPA,ASETV,MAXCOL = ',
5095     1           I8,3(2X,A4),G15.7,I8)
5096          CALL DPWRST('XXX','BUG ')
5097        ENDIF
5098C
5099        IF(ICASPA.NE.'P   ')THEN
5100          WRITE(ICOUT,999)
5101          CALL DPWRST('XXX','BUG ')
5102          WRITE(ICOUT,631)
5103          CALL DPWRST('XXX','BUG ')
5104          WRITE(ICOUT,912)
5105  912     FORMAT('      IMPROPER VALUE FOR ICASPA AND/OR ASETV')
5106          CALL DPWRST('XXX','BUG ')
5107          WRITE(ICOUT,913)ICASPA,ASETV,MAXCOL,MAXCP1,MAXCP2
5108  913     FORMAT('      ICASPA,ASETV,MAXCOL,MAXCP1,MAXCP2 = ',A4,
5109     1           G15.7,3I8)
5110          CALL DPWRST('XXX','BUG ')
5111          IERROR='YES'
5112          ICASIF='FALS'
5113          GOTO9000
5114        ENDIF
5115C
5116        NS=0
5117        ND=0
5118        DO941I=1,NIOLD
5119          VIJ=ASETV
5120C
5121          IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5122            WRITE(9,947)I,NIOLD,ASETV,DMIN,DMAX,VIJ
5123  947       FORMAT('I,NIOLD,ASETV,DMIN,DMAX,VIJ = ',2I8,G15.7,3F12.5)
5124            CALL DPWRST('XXX','BUG ')
5125          ENDIF
5126C
5127          TARGET=VIJ
5128          ISTATI='FALS'
5129C
5130          IF(ICASQU.EQ.'IF  '.AND.ICASOP.EQ.'<>  ')THEN
5131            IF(TARGET.LT.DMIN .OR. DMAX.LT.TARGET)THEN
5132              ISTATI='TRUE'
5133              ITEMP=ISUB(I)
5134              IF(ITEMP.EQ.00)ISUB(I)=10
5135              IF(ITEMP.EQ.10)ISUB(I)=10
5136              IF(ITEMP.EQ.01)ISUB(I)=11
5137              IF(ITEMP.EQ.11)ISUB(I)=11
5138              NS=NS+1
5139            ELSEIF(DMIN.LE.TARGET.AND.TARGET.LE.DMAX)THEN
5140              ND=ND+1
5141            ENDIF
5142          ELSEIF(ICASQU.EQ.'IF  ')THEN
5143            IF(DMIN.LE.TARGET.AND.TARGET.LE.DMAX)THEN
5144              ISTATI='TRUE'
5145              ITEMP=ISUB(I)
5146              IF(ITEMP.EQ.00)ISUB(I)=10
5147              IF(ITEMP.EQ.10)ISUB(I)=10
5148              IF(ITEMP.EQ.01)ISUB(I)=11
5149              IF(ITEMP.EQ.11)ISUB(I)=11
5150              NS=NS+1
5151            ELSE
5152              ND=ND+1
5153            ENDIF
5154          ENDIF
5155C
5156  941   CONTINUE
5157C
5158        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5159          WRITE(ICOUT,991)IPASS,ICASQU,DMIN,DMAX,EPS,NIOLD,NS,ND
5160  991     FORMAT('IPASS,ICASQU,DMIN,DMAX,EPS,NIOLD,NS,ND = ',
5161     1           I8,2X,A4,3G15.7,3I8)
5162          CALL DPWRST('XXX','BUG ')
5163          DO992I=1,NIOLD
5164            WRITE(ICOUT,993)I,ISUB(I)
5165  993       FORMAT('I,ISUB(I) = ',I8,I8)
5166            CALL DPWRST('XXX','BUG ')
5167  992     CONTINUE
5168          WRITE(ICOUT,995)ITEMP,ISTATI
5169  995     FORMAT('ITEMP,ISTATI = ',I8,2X,A4)
5170          CALL DPWRST('XXX','BUG ')
5171        ENDIF
5172C
5173C               *************************************************
5174C               **  STEP 10--                                  **
5175C               **  WRITE OUT A MESSAGE FOR THIS STEP          **
5176C               **  INDICATING                                 **
5177C               **  THE SUBSET PARAMETER NAME,                 **
5178C               **  THE SUBSET MINIMUM,                        **
5179C               **  THE SUBSET MAXIMUM,                        **
5180C               **  THE SUBSET PARAMETER VALUE,                **
5181C               **  THE SUBSET PARAMETER STATUS,               **
5182C               *************************************************
5183C
5184        ISTEPN='10'
5185        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
5186     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5187C
5188        IF(IFEEDB.EQ.'ON')THEN
5189          WRITE(ICOUT,999)
5190          CALL DPWRST('XXX','BUG ')
5191          WRITE(ICOUT,1011)
5192 1011     FORMAT('***** NOTE--')
5193          CALL DPWRST('XXX','BUG ')
5194          WRITE(ICOUT,1012)IHARG(ILOCS1),IHARG2(ILOCS1)
5195 1012     FORMAT('      IF     PARAMETER = ',2A4)
5196          CALL DPWRST('XXX','BUG ')
5197          WRITE(ICOUT,1013)DMIN
5198 1013     FORMAT('      IF     MINIMUM   = ',G15.7)
5199          CALL DPWRST('XXX','BUG ')
5200          WRITE(ICOUT,1014)DMAX
5201 1014     FORMAT('      IF     MAXIMUM   = ',G15.7)
5202          CALL DPWRST('XXX','BUG ')
5203          WRITE(ICOUT,1015)ASETV
5204 1015     FORMAT('      IF     PARAMETER VALUE    = ',G15.7)
5205          CALL DPWRST('XXX','BUG ')
5206          IF(INOT.EQ.'ON')THEN
5207            IF(ISTATI.EQ.'TRUE')THEN
5208              WRITE(ICOUT,1017)
5209 1017         FORMAT('      IF     PARAMETER STATUS   = FALS')
5210              CALL DPWRST('XXX','BUG ')
5211            ELSE
5212              WRITE(ICOUT,1018)
5213 1018         FORMAT('      IF     PARAMETER STATUS   = TRUE')
5214              CALL DPWRST('XXX','BUG ')
5215            ENDIF
5216          ELSE
5217            WRITE(ICOUT,1016)ISTATI
5218 1016       FORMAT('      IF     PARAMETER STATUS   = ',A4)
5219            CALL DPWRST('XXX','BUG ')
5220          ENDIF
5221        ENDIF
5222C
5223        NUMSV=IPASS
5224C
5225  300 CONTINUE
5226C
5227 1100 CONTINUE
5228      DO1110I=1,NIOLD
5229        ITEMP=ISUB(I)
5230        IF(ITEMP.EQ.00)ISUB(I)=00
5231        IF(ITEMP.EQ.10)ISUB(I)=00
5232        IF(ITEMP.EQ.01)ISUB(I)=00
5233        IF(ITEMP.EQ.11)ISUB(I)=11
5234 1110 CONTINUE
5235C
5236C               *************************************
5237C               **  STEP 11--                      **
5238C               **  PUT ISUB(.) IN FINAL 0,1 FORM  **
5239C               *************************************
5240C
5241      ISTEPN='11'
5242      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
5243     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5244C
5245      DO1210I=1,NIOLD
5246        ITEMP=ISUB(I)
5247        IF(ITEMP.EQ.00)ISUB(I)=0
5248        IF(ITEMP.EQ.10)ISUB(I)=0
5249        IF(ITEMP.EQ.01)ISUB(I)=1
5250        IF(ITEMP.EQ.11)ISUB(I)=1
5251 1210 CONTINUE
5252C
5253C               *****************************************
5254C               **  STEP 12--                          **
5255C               **  IF THERE WERE 2 OR MORE SUBSET     **
5256C               **  VARIABLES, GATHER INFORMATION      **
5257C               **  FOR A FINAL SUMMARY MESSAGE BY     **
5258C               **  DETERMINING THE FINAL NUMBER OF    **
5259C               **  ELEMENTS IN THE SUBSET             **
5260C               **  (AFTER ALL VARIABLES HAVE          **
5261C               **  BEEN INDIVIDUALLY ACCOUNTED FOR).  **
5262C               *****************************************
5263C
5264      ISTEPN='12'
5265      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
5266     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5267C
5268      IF(NUMSV.GT.1)THEN
5269        NS=0
5270        DO1510I=1,NIOLD
5271          IF(ISUB(I).EQ.1)NS=NS+1
5272 1510   CONTINUE
5273      ENDIF
5274C
5275C               *************************************************
5276C               **  STEP 13--                                  **
5277C               **  IF THERE WERE 2 OR MORE SUBSET VARIABLES,  **
5278C               **  WRITE OUT A FINAL MESSAGE                  **
5279C               **  SUMMARIZING FOR ALL VARIABLES              **
5280C               **  THE NUMBER OF SUBSET VARIABLES             **
5281C               **  THE INPUT NUMBER OF OBSERVATIONS (LOCAL),  **
5282C               **  THE NUMBER OF OBSERVATIONS IGNORED         **
5283C               **  AND THE OUTPUT NUMBER OF OBSERVATIONS      **
5284C               **  (THAT IS, THE SUBSET SAMPLE SIZE).         **
5285C               **  ALSO, CHECK THAT NS IS POSITIVE.           **
5286C               *************************************************
5287C
5288      ISTEPN='13'
5289      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')
5290     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5291C
5292      ICASIF='FALS'
5293      IF(ISUB(1).EQ.1)ICASIF='TRUE'
5294C
5295      IF(NUMSV.GT.1 .AND. IFEEDB.EQ.'ON')THEN
5296        WRITE(ICOUT,999)
5297        CALL DPWRST('XXX','BUG ')
5298        WRITE(ICOUT,1601)
5299 1601   FORMAT('*****    IF    SUMMARY--')
5300        CALL DPWRST('XXX','BUG ')
5301        WRITE(ICOUT,1602)NUMSV
5302 1602   FORMAT('      NUMBER OF SPECIFICATIONS       = ',I8)
5303        CALL DPWRST('XXX','BUG ')
5304        WRITE(ICOUT,1605)ICASIF
5305 1605   FORMAT('      FINAL    IF    STATUS          = ',A4)
5306        CALL DPWRST('XXX','BUG ')
5307      ENDIF
5308C
5309      GOTO9000
5310C
5311 8000 CONTINUE
5312      WRITE(ICOUT,414)
5313  414 FORMAT('      COMMAND LINE.  THE WORD    IF    SHOULD HAVE  ')
5314      CALL DPWRST('XXX','BUG ')
5315      WRITE(ICOUT,415)
5316  415 FORMAT('      BEEN FOLLOWED BY OTHER ARGUMENTS, AS IN')
5317      CALL DPWRST('XXX','BUG ')
5318      WRITE(ICOUT,416)
5319  416 FORMAT('           IF A = 4')
5320      CALL DPWRST('XXX','BUG ')
5321      WRITE(ICOUT,417)
5322  417 FORMAT('           IF A > 6')
5323      CALL DPWRST('XXX','BUG ')
5324      WRITE(ICOUT,418)
5325  418 FORMAT('           IF X >= B')
5326      CALL DPWRST('XXX','BUG ')
5327      WRITE(ICOUT,419)
5328  419 FORMAT('           AND SO FORTH.')
5329      CALL DPWRST('XXX','BUG ')
5330      WRITE(ICOUT,421)
5331  421 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
5332      CALL DPWRST('XXX','BUG ')
5333      IF(IWIDTH.GE.1)THEN
5334        WRITE(ICOUT,422)(IANSLC(I),I=1,MIN(100,IWIDTH))
5335  422   FORMAT('      ',100A1)
5336        CALL DPWRST('XXX','BUG ')
5337        IERROR='YES'
5338        GOTO9000
5339      ENDIF
5340C
5341C               *****************
5342C               **  STEP 90--  **
5343C               **  EXIT.      **
5344C               *****************
5345C
5346 9000 CONTINUE
5347C
5348C     CHECK FOR "NOT" STATUS
5349C
5350      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5351        WRITE(ICOUT,9001)JPASS,NPASS,NUMART,ICNT3,IWIDTT,ICASIF,IERROR
5352 9001   FORMAT('AT 9000: JPASS,NPASS,NUMART,ICNT3,IWIDTT,ICASIF,',
5353     1         'IERROR = ',5I5,2(2X,A4))
5354        CALL DPWRST('XXX','BUG ')
5355        WRITE(ICOUT,9002)IOPER(1),IOPER(2),IOPER(3),IOPER(4)
5356 9002   FORMAT('IOPER(1),IOPER(2),IOPER(3),IOPER(4) = ',
5357     1         3(A4,2X),A4)
5358        CALL DPWRST('XXX','BUG ')
5359      ENDIF
5360C
5361      IF(INOT.EQ.'ON')THEN
5362        IF(ICASIF.EQ.'TRUE')THEN
5363          ICASIF='FALS'
5364        ELSEIF(ICASIF.EQ.'FALS')THEN
5365          ICASIF='TRUE'
5366        ENDIF
5367      ENDIF
5368C
5369C     CHECKS FOR CASE WHEN AND/OR/XOR
5370C
5371      IF(IERROR.EQ.'YES' .OR. NPASS.LE.1)GOTO9009
5372      IF(JPASS.EQ.0)THEN
5373        ICASI1=ICASIF
5374        ISHIFT=NUMART+1
5375        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
5376     1              IBUGQ,IERROR)
5377        ICNT=0
5378        DO9005I=ILOCP2,IWIDTH
5379          ICNT=ICNT+1
5380          IANS(ICNT)=IANS(I)
5381          IANSLC(ICNT)=IANSLC(I)
5382 9005   CONTINUE
5383        IWIDTT=ICNT
5384        JPASS=1
5385C
5386        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5387          WRITE(ICOUT,9006)(IANS(JJ)(1:1),JJ=1,MIN(80,IWIDTT))
5388 9006     FORMAT('IANS: ',80A1)
5389          CALL DPWRST('XXX','BUG ')
5390          WRITE(ICOUT,9007)ICASI1,IWIDTT,NUMARG
5391 9007     FORMAT('JPASS = 0 CASE: ICASI1,IWIDTT,NUMARG = ',
5392     1           A4,2X,2I5)
5393          CALL DPWRST('XXX','BUG ')
5394        ENDIF
5395C
5396        NUMART=NUMARG
5397C
5398        GOTO1000
5399      ELSEIF(JPASS.EQ.1)THEN
5400        ICASI2=ICASIF
5401        ICNT3=ICNT3+1
5402        IF(IOPER(ICNT3).EQ.'AND')THEN
5403          ICASIF='FALS'
5404          IF(ICASI1.EQ.'TRUE' .AND. ICASI2.EQ.'TRUE')ICASIF='TRUE'
5405        ELSEIF(IOPER(ICNT3).EQ.'OR')THEN
5406          ICASIF='FALS'
5407          IF(ICASI1.EQ.'TRUE' .OR. ICASI2.EQ.'TRUE')ICASIF='TRUE'
5408        ELSEIF(IOPER(ICNT3).EQ.'XOR')THEN
5409          ICASIF='FALS'
5410          IF(ICASI1.EQ.'TRUE' .AND. ICASI2.EQ.'FALS')ICASIF='TRUE'
5411          IF(ICASI1.EQ.'FALS' .AND. ICASI2.EQ.'TRUE')ICASIF='TRUE'
5412        ENDIF
5413C
5414        IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5415          WRITE(ICOUT,9003)ICASI1,ICASI2,ICASIF
5416 9003     FORMAT('JPASS = 1 CASE: ICASI1,ICASI2,ICASIF = ',
5417     1           2(A4,2X),A4)
5418          CALL DPWRST('XXX','BUG ')
5419        ENDIF
5420C
5421        ICASI1=ICASIF
5422        ISHIFT=NUMART+1
5423        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
5424     1              IBUGQ,IERROR)
5425        ICNT=0
5426        DO9008I=ILOCP2,IWIDTH
5427          ICNT=ICNT+1
5428          IANS(ICNT)=IANS(I)
5429          IANSLC(ICNT)=IANSLC(I)
5430 9008   CONTINUE
5431        IWIDTT=ICNT
5432        GOTO1000
5433      ENDIF
5434C
5435C  IF ERROR, THEN SET IF STATUS TO FALSE.    FEBRUARY 1999
5436C
5437C  2012/10: ADD PROMPT IF ERROR DETECTED.
5438C
5439 9009 CONTINUE
5440      IF(IERROR.EQ.'YES')THEN
5441        CALL DPERRO(IERRFA,IANSLC,IWIDTH,IGUIFL,
5442     1              ISUBN1,ISUBN2,ICASIF,
5443     1              IBUGQ,ISUBRO,IERROR)
5444      ENDIF
5445C
5446      IF(IBUGQ.EQ.'ON' .OR. ISUBRO.EQ.'DPIF')THEN
5447        WRITE(ICOUT,999)
5448        CALL DPWRST('XXX','BUG ')
5449        WRITE(ICOUT,9011)
5450 9011   FORMAT('***** AT THE END       OF DPIF--')
5451        CALL DPWRST('XXX','BUG ')
5452        WRITE(ICOUT,9012)NIOLD,ILOCS,NS,IBUGQ,IERROR
5453 9012   FORMAT('NIOLD,ILOCS,NS,IBUGQ,IERROR = ',3I8,2(2X,A4))
5454        CALL DPWRST('XXX','BUG ')
5455        WRITE(ICOUT,9015)NUMARG,NUMNAM,MAXNAM,N,MAXN
5456 9015   FORMAT('NUMARG,NUMNAM,MAXNAM,N,MAXN = ',5I8)
5457        CALL DPWRST('XXX','BUG ')
5458        WRITE(ICOUT,9016)IWIDTH,ILOCS,ILOCS2,ILOCTG
5459 9016   FORMAT('IWIDTH,ILOCS,ILOCS2,ILOCTG = ',4I8)
5460        CALL DPWRST('XXX','BUG ')
5461        WRITE(ICOUT,9017)NUMSV,ND,ILOCP2,ICASI1,ICASI2
5462 9017   FORMAT('NUMSV,ND,ILOCP2,ICASI1,ICASI2 = ',3I8,2(2X,A4))
5463        CALL DPWRST('XXX','BUG ')
5464        WRITE(ICOUT,9018)ICASQU,ICASPA,ICASOP,ICASSC
5465 9018   FORMAT('ICASQU,ICASPA,ICASOP,ICASSC = ',3(A4,2X),A4)
5466        CALL DPWRST('XXX','BUG ')
5467        DO9020I=1,NIOLD
5468          WRITE(ICOUT,9021)I,ISUB(I)
5469 9021     FORMAT('I,ISUB(I) = ',2I8)
5470          CALL DPWRST('XXX','BUG ')
5471 9020   CONTINUE
5472        WRITE(ICOUT,9023)ISTATI,ICASIF,JMIN,JMAX,NUMARG
5473 9023   FORMAT('ISTATI,ICASIF,JMIN,JMAX,NUMARG = ',2(A4,2X),3I8)
5474        CALL DPWRST('XXX','BUG ')
5475      ENDIF
5476C
5477      RETURN
5478      END
5479      SUBROUTINE DPIMAG(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
5480     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
5481C
5482C     PURPOSE--GENERATE AN IMAGE PLOT.  YOU CAN GENERATE EITHER
5483C              A GREY-SCALE IMAGE OR A FULL RGB COLOR IMAGE.
5484C              THE INPUT CAN BE EITHER VECTORS:
5485C                  RED    = VECTOR CONTAINING VALUES FOR "RED" COMPONENT
5486C                  BLUE   = VECTOR CONTAINING VALUES FOR "BLUE" COMPONENT
5487C                  GREEN  = VECToR CONTAINING VALUES FOR "GREEN" COMPONENT
5488C                  ROWID  = VECTOR CONTAINING THE ROW-ID
5489C                  COLID  = VECTOR CONTAINING THE COLUMN-ID
5490C
5491C                  GREY   = VECTOR CONTAINING VALUES FOR GREY SCALE
5492C                  ROWID  = VECTOR CONTAINING THE ROW-ID
5493C                  COLID  = VECTOR CONTAINING THE COLUMN-ID
5494C
5495C              OR MATRICES:
5496C                  RED    = MATRIX CONTAINING VALUES FOR "RED" COMPONENT
5497C                  BLUE   = MATRIX CONTAINING VALUES FOR "BLUE" COMPONENT
5498C                  GREEN  = MATRIX CONTAINING VALUES FOR "GREEN" COMPONENT
5499C
5500C                  GREY   = MATRIX CONTAINING VALUES FOR GREY SCALE
5501C
5502C     EXAMPLES--IMAGE PLOT GREY
5503C               IMAGE PLOT RED BLUE GREY
5504C               IMAGE PLOT GREY ROWID COLID
5505C               IMAGE PLOT RED BLUE GREEN ROWID COLID
5506C     WRITTEN BY--ALAN HECKERT
5507C                 STATISTICAL ENGINEERING DIVISION
5508C                 INFORMATION TECHNOLOGY LABORATORY
5509C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5510C                 GAITHERSBURG, MD 20899-8980
5511C                 PHONE--301-975-2899
5512C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5513C           OF THE NATIONAL BUREAU OF STANDARDS.
5514C     LANGUAGE--ANSI FORTRAN (1977)
5515C     VERSION NUMBER--2008/3
5516C     ORIGINAL VERSION--MARCH     2008.
5517C     UPDATED         --MARCH     2011. USE DPPARS AND DPPAR3
5518C
5519C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5520C
5521      CHARACTER*4 ICASPL
5522      CHARACTER*4 IAND1
5523      CHARACTER*4 IAND2
5524      CHARACTER*4 IBUGG2
5525      CHARACTER*4 IBUGG3
5526      CHARACTER*4 IBUGQ
5527      CHARACTER*4 ISUBRO
5528      CHARACTER*4 IFOUND
5529      CHARACTER*4 IERROR
5530C
5531      CHARACTER*4 ICASE
5532      CHARACTER*4 ICASCO
5533      CHARACTER*4 ISUBN1
5534      CHARACTER*4 ISUBN2
5535      CHARACTER*4 ISTEPN
5536C
5537      CHARACTER*40 INAME
5538      PARAMETER (MAXSPN=30)
5539      CHARACTER*4 IVARN1(MAXSPN)
5540      CHARACTER*4 IVARN2(MAXSPN)
5541      CHARACTER*4 IVARTY(MAXSPN)
5542      REAL PVAR(MAXSPN)
5543      INTEGER ILIS(MAXSPN)
5544      INTEGER NRIGHT(MAXSPN)
5545      INTEGER ICOLR(MAXSPN)
5546C
5547C-----COMMON----------------------------------------------------------
5548C
5549      INCLUDE 'DPCOPA.INC'
5550      INCLUDE 'DPCOCP.INC'
5551      INCLUDE 'DPCOHK.INC'
5552      INCLUDE 'DPCODA.INC'
5553      INCLUDE 'DPCOST.INC'
5554C
5555C---------------------------------------------------------------------
5556C
5557      DIMENSION YRED(MAXOBV)
5558      DIMENSION YBLUE(MAXOBV)
5559      DIMENSION YGREEN(MAXOBV)
5560      DIMENSION YALPHA(MAXOBV)
5561      DIMENSION ROWID(MAXOBV)
5562      DIMENSION COLID(MAXOBV)
5563      DIMENSION TEMP1(MAXOBV)
5564      DIMENSION TEMP2(MAXOBV)
5565      INCLUDE 'DPCOZZ.INC'
5566      EQUIVALENCE (GARBAG(IGARB1),YRED(1))
5567      EQUIVALENCE (GARBAG(IGARB2),YBLUE(1))
5568      EQUIVALENCE (GARBAG(IGARB3),YGREEN(1))
5569      EQUIVALENCE (GARBAG(IGARB4),YALPHA(1))
5570      EQUIVALENCE (GARBAG(IGARB5),ROWID(1))
5571      EQUIVALENCE (GARBAG(IGARB6),COLID(1))
5572      EQUIVALENCE (GARBAG(IGARB7),TEMP1(1))
5573      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
5574C
5575C-----COMMON VARIABLES (GENERAL)--------------------------------------
5576C
5577      INCLUDE 'DPCOP2.INC'
5578C
5579C-----START POINT-----------------------------------------------------
5580C
5581      ISUBN1='DPIM'
5582      ISUBN2='AG  '
5583      IFOUND='NO'
5584      IERROR='NO'
5585C
5586      ICASCO='GREY'
5587      ICASE='VARI'
5588      ICASPL='IMAG'
5589C
5590      MAXCP1=MAXCOL+1
5591      MAXCP2=MAXCOL+2
5592      MAXCP3=MAXCOL+3
5593      MAXCP4=MAXCOL+4
5594      MAXCP5=MAXCOL+5
5595      MAXCP6=MAXCOL+6
5596C
5597      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'IMAG')THEN
5598        WRITE(ICOUT,999)
5599  999   FORMAT(1X)
5600        CALL DPWRST('XXX','BUG ')
5601        WRITE(ICOUT,51)
5602   51   FORMAT('***** AT THE BEGINNING OF DPIMAG--')
5603        CALL DPWRST('XXX','BUG ')
5604        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXN,MAXNPP
5605   53   FORMAT('ICASPL,IAND1,IAND2,MAXN,MAXNPP = ',3(A4,2X),2I8)
5606        CALL DPWRST('XXX','BUG ')
5607        WRITE(ICOUT,57)IFOUND,IERROR
5608   57   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
5609        CALL DPWRST('XXX','BUG ')
5610      ENDIF
5611C
5612C               ***********************************
5613C               **  TREAT THE IMAGE PLOT CASE    **
5614C               ***********************************
5615C
5616      IFOUND='YES'
5617      ICASPL='IMAG'
5618C
5619C               ****************************************
5620C               **  STEP 2--                          **
5621C               **  EXTRACT THE VARIABLE LIST         **
5622C               ****************************************
5623C
5624      ISTEPN='2'
5625      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'IMAG')
5626     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5627C
5628      INAME='IMAGE PLOT'
5629      MINNA=1
5630      MAXNA=100
5631      MINN2=5
5632      IFLAGE=1
5633      IFLAGM=2
5634      IFLAGP=0
5635      JMIN=1
5636      JMAX=NUMARG
5637      MINNVA=1
5638      MAXNVA=5
5639C
5640      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
5641     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
5642     1            JMIN,JMAX,
5643     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
5644     1            IVARN1,IVARN2,IVARTY,PVAR,
5645     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
5646     1            MINNVA,MAXNVA,
5647     1            IFLAGM,IFLAGP,
5648     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
5649      IF(IERROR.EQ.'YES')GOTO9000
5650C
5651      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'IMAG')THEN
5652        WRITE(ICOUT,999)
5653        CALL DPWRST('XXX','BUG ')
5654        WRITE(ICOUT,281)
5655  281   FORMAT('***** AFTER CALL DPPARS--')
5656        CALL DPWRST('XXX','BUG ')
5657        WRITE(ICOUT,282)NQ,NUMVAR
5658  282   FORMAT('NQ,NUMVAR = ',2I8)
5659        CALL DPWRST('XXX','BUG ')
5660        IF(NUMVAR.GT.0)THEN
5661          DO285I=1,NUMVAR
5662            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
5663     1                      ICOLR(I),IVARTY(I)
5664  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
5665     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
5666            CALL DPWRST('XXX','BUG ')
5667  285     CONTINUE
5668        ENDIF
5669      ENDIF
5670C
5671C     IF VARIABLE ARGUMENTS GIVEN, THEN 3 TO 5 ARGUMENTS EXPECTED.
5672C     IF MATRIX ARGUMENTS GIVEN, THEN 1 TO 3 ARGUMENTS EXPECTED.
5673C
5674      IF(IVARTY(1).EQ.'VARI')THEN
5675        IF(NUMVAR.LT.3)THEN
5676          WRITE(ICOUT,999)
5677          CALL DPWRST('XXX','BUG ')
5678          WRITE(ICOUT,291)
5679  291     FORMAT('***** ERROR IN IMAGE PLOT--')
5680          CALL DPWRST('XXX','BUG ')
5681          WRITE(ICOUT,292)
5682  292     FORMAT('      WHEN VARIABLE ARGUMENTS ARE GIVEN, AT')
5683          CALL DPWRST('XXX','BUG ')
5684          WRITE(ICOUT,293)
5685  293     FORMAT('      LEAST THREE ARGUMENTS EXPECTED.')
5686          CALL DPWRST('XXX','BUG ')
5687          WRITE(ICOUT,294)NUMVAR
5688  294     FORMAT('      NUMBER OF ARGUMENTS FOUND = ',I8)
5689          CALL DPWRST('XXX','BUG ')
5690          IERROR='YES'
5691          GOTO9000
5692        ENDIF
5693      ELSEIF(IVARTY(1).EQ.'MATR')THEN
5694        IF(NUMVAR.GT.3)THEN
5695          WRITE(ICOUT,999)
5696          CALL DPWRST('XXX','BUG ')
5697          WRITE(ICOUT,291)
5698          CALL DPWRST('XXX','BUG ')
5699          WRITE(ICOUT,296)
5700  296     FORMAT('      WHEN MATRIX ARGUMENTS ARE GIVEN, AT')
5701          CALL DPWRST('XXX','BUG ')
5702          WRITE(ICOUT,298)
5703  298     FORMAT('      MOST THREE ARGUMENTS EXPECTED.')
5704          CALL DPWRST('XXX','BUG ')
5705          WRITE(ICOUT,294)NUMVAR
5706          CALL DPWRST('XXX','BUG ')
5707          IERROR='YES'
5708          GOTO9000
5709        ENDIF
5710      ENDIF
5711C
5712C     IF VARIABLE ARGUMENTS, PUT LAST TWO ARGUMENTS IN ROWID AND
5713C     COLUMN ID.  THE REST SHOULD GO IN YRED, YBLUE AND YGREEN.
5714C
5715      ICASCO='COLO'
5716      IF(IVARTY(1).EQ.'VARI')THEN
5717        IF(NUMVAR.LE.3)ICASCO='GREY'
5718        NUMVA2=NUMVAR-2
5719        ICOL=1
5720        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5721     1              INAME,IVARN1,IVARN2,IVARTY,
5722     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
5723     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5724     1              MAXCP4,MAXCP5,MAXCP6,
5725     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5726     1              YRED,YBLUE,YGREEN,NS,NTEMP,NTEMP,ICASE,
5727     1              IBUGG3,ISUBRO,IFOUND,IERROR)
5728        IF(IERROR.EQ.'YES')GOTO9000
5729C
5730        NUMVA2=2
5731        ICOL=NUMVAR-1
5732        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5733     1              INAME,IVARN1,IVARN2,IVARTY,
5734     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
5735     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5736     1              MAXCP4,MAXCP5,MAXCP6,
5737     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5738     1              ROWID,COLID,COLID,NS,NTEMP,NTEMP,ICASE,
5739     1              IBUGG3,ISUBRO,IFOUND,IERROR)
5740        IF(IERROR.EQ.'YES')GOTO9000
5741C
5742      ELSEIF(IVARTY(1).EQ.'MATR')THEN
5743C
5744        IF(NUMVAR.LE.1)ICASCO='GREY'
5745        DO301I=1,MAXOBV
5746          ROWID(I)=0.0
5747          COLID(I)=0.0
5748          YRED(I)=0.0
5749          YBLUE(I)=0.0
5750          YGREEN(I)=0.0
5751  301   CONTINUE
5752C
5753        ILISR=1
5754        ICOL31=IVALUE(ILISR)
5755        ICOL32=IVALU2(ILISR)
5756        NROW=IN(ILISR)
5757        NCOL=(ICOL32 - ICOL31) + 1
5758        ICNT=0
5759        DO310JCOL=1,NCOL
5760          DO320IROW=1,NROW
5761            ICNT=ICNT+1
5762            ROWID(ICNT)=REAL(IROW)
5763            COLID(ICNT)=REAL(JCOL)
5764  320     CONTINUE
5765  310   CONTINUE
5766C
5767        ICOL=1
5768        NUMVA2=1
5769        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5770     1              INAME,IVARN1,IVARN2,IVARTY,
5771     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
5772     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5773     1              MAXCP4,MAXCP5,MAXCP6,
5774     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5775     1              YRED,YRED,YRED,NS,NTEMP,NTEMP,ICASE,
5776     1              IBUGG3,ISUBRO,IFOUND,IERROR)
5777        IF(IERROR.EQ.'YES')GOTO9000
5778C
5779        IF(NUMVAR.GE.2)THEN
5780          ICOL=2
5781          NUMVA2=1
5782          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5783     1                INAME,IVARN1,IVARN2,IVARTY,
5784     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
5785     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5786     1                MAXCP4,MAXCP5,MAXCP6,
5787     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5788     1                YBLUE,YBLUE,YBLUE,NS,NTEMP,NTEMP,ICASE,
5789     1                IBUGG3,ISUBRO,IFOUND,IERROR)
5790          IF(IERROR.EQ.'YES')GOTO9000
5791        ENDIF
5792C
5793        IF(NUMVAR.GE.3)THEN
5794          ICOL=3
5795          NUMVA2=1
5796          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
5797     1                INAME,IVARN1,IVARN2,IVARTY,
5798     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
5799     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
5800     1                MAXCP4,MAXCP5,MAXCP6,
5801     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
5802     1                YGREEN,YGREEN,YGREEN,NS,NTEMP,NTEMP,ICASE,
5803     1                IBUGG3,ISUBRO,IFOUND,IERROR)
5804          IF(IERROR.EQ.'YES')GOTO9000
5805        ENDIF
5806C
5807      ENDIF
5808C
5809C               ********************************************************
5810C               **  STEP 61--                                          *
5811C               **  FORM THE VERTICAL AND HORIZONTAL AXIS VARIABLES    *
5812C               **  (Y(.) AND X(.), RESPECTIVELY) FOR THE PLOT.        *
5813C               **  FORM THE CURVE DESIGNATION VARIABLE D(.)  .        *
5814C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).      *
5815C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).      *
5816C               ********************************************************
5817C
5818      ISTEPN='61'
5819      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'IMAG')
5820     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5821C
5822      IF(ICASCO.EQ.'GREY')ICASPL='IMA2'
5823      CALL DPIMA2(YRED,YBLUE,YGREEN,YALPHA,ROWID,COLID,NS,
5824     1            ICASCO,PCOLMX,
5825     1            TEMP1,TEMP2,MAXOBV,
5826     1            Y,X,D,DCOLOR,DFILL,DSYMB,DSIZE,NPLOTP,NPLOTV,
5827     1            IBUGG3,ISUBRO,IERROR)
5828C
5829C               *****************
5830C               **  STEP 90--  **
5831C               **  EXIT       **
5832C               *****************
5833C
5834 9000 CONTINUE
5835      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'IMAG')THEN
5836        WRITE(ICOUT,999)
5837        CALL DPWRST('XXX','BUG ')
5838        WRITE(ICOUT,9011)
5839 9011   FORMAT('***** AT THE END       OF DPIMAG--')
5840        CALL DPWRST('XXX','BUG ')
5841        WRITE(ICOUT,9012)IFOUND,IERROR,ICASPL
5842 9012   FORMAT('IFOUND,IERROR,ICASPL = ',2(A4,2X),A4)
5843        CALL DPWRST('XXX','BUG ')
5844        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,MAXN,IAND1,IAND2
5845 9013   FORMAT('NPLOTV,NPLOTP,NS,MAXN,IAND1,IAND2 = ',
5846     1         4I8,2X,2(A4,2X),A4)
5847        CALL DPWRST('XXX','BUG ')
5848        IF(NPLOTP.GE.1)THEN
5849          DO9020I=1,MIN(NPLOTP,200)
5850            WRITE(ICOUT,9021)I,Y(I),X(I),D(I)
5851 9021       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
5852            CALL DPWRST('XXX','BUG ')
5853 9020     CONTINUE
5854          DO9030I=1,MIN(NPLOTP,200)
5855            WRITE(ICOUT,9031)I,DCOLOR(I),DFILL(I),DSYMB(I)
5856 9031       FORMAT('I,DCOLOR(I),DFILL(I),DSYMB(I) = ',I8,3F12.5)
5857            CALL DPWRST('XXX','BUG ')
5858 9030     CONTINUE
5859        ENDIF
5860      ENDIF
5861C
5862      RETURN
5863      END
5864      SUBROUTINE DPIMA2(YRED,YBLUE,YGREEN,YALPHA,ROWID,COLID,N,
5865     1                  ICASCO,PCOLMX,
5866     1                  TEMP1,TEMP2,MAXOBV,
5867     1                  Y2,X2,D2,DCOLOR,DFILL,DSYMB,DSIZE,
5868     1                  NPLOTP,NPLOTV,
5869     1                  IBUGG3,ISUBRO,IERROR)
5870C
5871C     PURPOSE--FORM A IMAGE PLOT.  THE X AND Y COORDINATES WILL
5872C              BE ROW AND COLUMN ID'S, RESPECTIVELY.  THE
5873C              RGB COLORS CORRESPONDING TO EACH ROWID/COLUMM ID
5874C              WILL BE CONTAINED IN DCOLOR, DFILL, AND DSYMB
5875C              (DSIZE IS BEING RESERVED FOR AN "ALPHA" CHANNEL,
5876C              THE ALPHA CHANNEL IS NOT YET IMPLEMENTED, BUT
5877C              IS BEING RESERVED FOR FUTURE IMPLEMENTATION).
5878C              GREYSCALE IMAGES WILL ONLY USE DCOLOR.
5879C
5880C
5881C              COLORS WILL BE SCALED TO A (0,1) SCALE (THE
5882C              ROUTINES THAT ACTUALLY RENDER THE IMAGE WILL
5883C              CONVERT TO THE APPROPRIATE RESOLUTION FOR A
5884C              SPECIFIC DEVICE).
5885C     EXAMPLE--IMAGE PLOT RED BLUE GREEN ROWID COLID
5886C     WRITTEN BY--JAMES J. FILLIBEN
5887C                 STATISTICAL ENGINEERING DIVISION
5888C                 INFORMATION TECHNOLOGY LABORATORY
5889C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5890C                 GAITHERSBURG, MD 20899-8980
5891C                 PHONE--301-975-2899
5892C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5893C           OF THE NATIONAL BUREAU OF STANDARDS.
5894C     LANGUAGE--ANSI FORTRAN (1977)
5895C     VERSION NUMBER--2008/3
5896C     ORIGINAL VERSION--MARCH     2008.
5897C
5898C-----COMMON----------------------------------------------------------
5899C
5900C---------------------------------------------------------------------
5901C
5902      CHARACTER*4 ICASCO
5903      CHARACTER*4 IBUGG3
5904      CHARACTER*4 ISUBRO
5905      CHARACTER*4 IERROR
5906C
5907      CHARACTER*4 ISTEPN
5908      CHARACTER*4 ISUBN1
5909      CHARACTER*4 ISUBN2
5910      CHARACTER*4 IWRITE
5911C
5912      DIMENSION YRED(*)
5913      DIMENSION YBLUE(*)
5914      DIMENSION YGREEN(*)
5915      DIMENSION YALPHA(*)
5916      DIMENSION ROWID(*)
5917      DIMENSION COLID(*)
5918      DIMENSION Y2(*)
5919      DIMENSION X2(*)
5920      DIMENSION D2(*)
5921      DIMENSION DCOLOR(*)
5922      DIMENSION DFILL(*)
5923      DIMENSION DSYMB(*)
5924      DIMENSION DSIZE(*)
5925      DIMENSION TEMP1(*)
5926      DIMENSION TEMP2(*)
5927C
5928C---------------------------------------------------------------------
5929C
5930      INCLUDE 'DPCOP2.INC'
5931C
5932C-----START POINT-----------------------------------------------------
5933C
5934C
5935      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IMA2')THEN
5936        WRITE(ICOUT,999)
5937  999   FORMAT(1X)
5938        CALL DPWRST('XXX','BUG ')
5939        WRITE(ICOUT,51)
5940   51   FORMAT('***** AT THE BEGINNING OF DPIMA2--')
5941        CALL DPWRST('XXX','BUG ')
5942        WRITE(ICOUT,52)IBUGG3,ISUBRO,ICASCO,N,PCOLMX
5943   52   FORMAT('IBUGG3,ICASCO,ISUBRO,N,PCOLMX = ',3(A4,2X),I8,F10.5)
5944        CALL DPWRST('XXX','BUG ')
5945        DO55I=1,MIN(N,100)
5946          WRITE(ICOUT,56)I,YRED(I),YBLUE(I),YGREEN(I),YALPHA(I),
5947     1                   ROWID(I),COLID(I)
5948   56     FORMAT('I,YRED(I),YBLUE(I),YGREEN(I),YALPHA(I),ROWID(I),',
5949     1           'COLID(I) = ',I8,6G12.4)
5950          CALL DPWRST('XXX','BUG ')
5951   55   CONTINUE
5952      ENDIF
5953C
5954C               *******************************************************
5955C               **  STEP 1--                                         **
5956C               **  CREATE RED, BLUE, AND GREEN COMPONENTS           **
5957C               *******************************************************
5958C
5959      ISTEPN='1'
5960      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IMA2')
5961     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5962C
5963C     NOTE: IMAGE WILL BE DRAWN FROM TOP TO BOTTOM,
5964C           LEFT TO RIGHT.  SO CODE X2 AND Y2 APPROPRIATELY.
5965C
5966      IWRITE='OFF'
5967      CALL CODE(ROWID,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
5968      DO910I=1,N
5969        ROWID(I)=TEMP1(I)
5970  910 CONTINUE
5971      CALL CODE(COLID,N,IWRITE,TEMP1,TEMP2,MAXOBV,IBUGG3,IERROR)
5972      DO920I=1,N
5973        COLID(I)=TEMP1(I)
5974  920 CONTINUE
5975C
5976      AMAX=CPUMIN
5977      DO1000I=1,N
5978C
5979        X2(I)=COLID(I)
5980        Y2(I)=ROWID(I)
5981        D2(I)=1.0
5982        IF(ICASCO.EQ.'GREY')THEN
5983          DCOLOR(I)=ABS(YRED(I))
5984          IF(YRED(I).GT.AMAX)AMAX=YRED(I)
5985        ELSE
5986          DCOLOR(I)=ABS(YRED(I))
5987          DFILL(I)=ABS(YBLUE(I))
5988          DSYMB(I)=ABS(YGREEN(I))
5989          IF(YRED(I).GT.AMAX)AMAX=YRED(I)
5990          IF(YBLUE(I).GT.AMAX)AMAX=YBLUE(I)
5991          IF(YGREEN(I).GT.AMAX)AMAX=YGREEN(I)
5992        ENDIF
5993C
5994 1000 CONTINUE
5995C
5996C               *******************************************************
5997C               **  STEP 2--                                         **
5998C               **  NOW SCALE TO (0,1) SCALE                         **
5999C               *******************************************************
6000C
6001      ISTEPN='2'
6002      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IMA2')
6003     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6004C
6005      AMAX=MAX(AMAX,PCOLMX)
6006      DO2000I=1,N
6007C
6008        IF(ICASCO.EQ.'GREY')THEN
6009          DCOLOR(I)=DCOLOR(I)/AMAX
6010        ELSE
6011          DCOLOR(I)=DCOLOR(I)/AMAX
6012          DFILL(I)=DFILL(I)/AMAX
6013          DSYMB(I)=DSYMB(I)/AMAX
6014        ENDIF
6015C
6016 2000 CONTINUE
6017C
6018      NPLOTP=N
6019      NPLOTV=2
6020C
6021C               *****************
6022C               **  STEP 90--  **
6023C               **  EXIT       **
6024C               *****************
6025C
6026      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'IMA2')THEN
6027        WRITE(ICOUT,999)
6028        CALL DPWRST('XXX','BUG ')
6029        WRITE(ICOUT,9011)
6030 9011   FORMAT('***** AT THE END       OF DPIMA2--')
6031        CALL DPWRST('XXX','BUG ')
6032        WRITE(ICOUT,9013)NPLOTP,NPLOTV
6033 9013   FORMAT('NPLOTP,NPLOTV = ',2I8)
6034        CALL DPWRST('XXX','BUG ')
6035        IF(NPLOTP.GE.1)THEN
6036          DO9015I=1,MIN(200,NPLOTP)
6037            WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
6038 9016       FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,3F10.5)
6039            CALL DPWRST('XXX','BUG ')
6040 9015     CONTINUE
6041          DO9025I=1,MIN(200,NPLOTP)
6042            WRITE(ICOUT,9026)I,DCOLOR(I),DFILL(I),DSYMB(I),DSIZE(I)
6043 9026       FORMAT('I,DCOLOR(I),DFILL(I),DSYMB(I),DSIZE(I) = ',
6044     1             I8,4G12.4)
6045            CALL DPWRST('XXX','BUG ')
6046 9025     CONTINUE
6047        ENDIF
6048      ENDIF
6049C
6050      RETURN
6051      END
6052      SUBROUTINE DPIMP1(IX2TSW,IY2TSW,IX2ZSW,IY2ZSW,NCY2LA,
6053     1IBUGS2,IFOUND,IERROR)
6054C
6055C     PURPOSE--THIS IS IMPLEMENTATION MODULE NUMBER 1.
6056C              THIS WILL RESULT IN--
6057C                 1) NO TIC MARKS OR TIC MARK LABELS ON UPPER FRAME LINE
6058C                 2) NO TIC MARKS OR TIC MARK LABELS ON RIGHT FRAME LINE
6059C                 3) NO VERTICAL LABEL (Y2LABEL) ON RIGHT FRAME LINE
6060C     NOTE--THIS SUBROUTINE WILL BE EXECUTED WHEN THE
6061C           ANALYST ENTERS THE COMMAND--
6062C                   IMPLEMENT 1
6063C     NOTE--THE IMPLEMENT COMMAND IS USEFUL FOR IMPLEMENTATION ,DEBUGGING,
6064C           AND FOR NON-STANDARD CONVENTIONS (E.G., PLOTS WITH NON-STANDARD
6065C           SIZE OR TIC MARK CONVENTIONS OTHER THAN DATAPLOT'S DEFAULT)
6066C     INPUT  ARGUMENTS--NONE
6067C     OUTPUT ARGUMENTS--
6068C                     --IX2TSW
6069C                     --IY2TSW
6070C                     --IX2ZSW
6071C                     --IY2ZSW
6072C                     --NCY2LA
6073C                     --IFOUND ('YES' OR 'NO' )
6074C                     --IERROR ('YES' OR 'NO' )
6075C     WRITTEN BY--JAMES J. FILLIBEN
6076C                 STATISTICAL ENGINEERING DIVISION
6077C                 INFORMATION TECHNOLOGY LABORATORY
6078C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6079C                 GAITHERSBURG, MD 20899-8980
6080C                 PHONE--301-975-2855
6081C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6082C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6083C     LANGUAGE--ANSI FORTRAN (1977)
6084C     VERSION NUMBER--82/7
6085C     ORIGINAL VERSION--OCTOBER   1981.
6086C     UPDATED         --APRIL     1982.
6087C     UPDATED         --MAY       1982.
6088C
6089C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6090C
6091      CHARACTER*4 IBUGS2
6092C
6093      CHARACTER*4 IX2TSW
6094      CHARACTER*4 IY2TSW
6095C
6096      CHARACTER*4 IX2ZSW
6097      CHARACTER*4 IY2ZSW
6098C
6099      CHARACTER*4 IFOUND
6100      CHARACTER*4 IERROR
6101C
6102C---------------------------------------------------------------------
6103C
6104      INCLUDE 'DPCOP2.INC'
6105C
6106C-----START POINT-----------------------------------------------------
6107C
6108      IERROR='NO'
6109      IFOUND='YES'
6110C
6111      IF(IBUGS2.EQ.'OFF')GOTO90
6112      WRITE(ICOUT,999)
6113  999 FORMAT(1X)
6114      CALL DPWRST('XXX','BUG ')
6115      WRITE(ICOUT,51)
6116   51 FORMAT('***** AT THE BEGINNING OF DPIMP1--')
6117      CALL DPWRST('XXX','BUG ')
6118      WRITE(ICOUT,52)IX2TSW,IY2TSW
6119   52 FORMAT('IX2TSW,IY2TSW = ',A4,2X,A4)
6120      CALL DPWRST('XXX','BUG ')
6121      WRITE(ICOUT,53)IX2ZSW,IY2ZSW
6122   53 FORMAT('IX2ZSW,IY2ZSW = ',A4,2X,A4)
6123      CALL DPWRST('XXX','BUG ')
6124      WRITE(ICOUT,54)NCY2LA
6125   54 FORMAT('NCY2LA = ',I8)
6126      CALL DPWRST('XXX','BUG ')
6127      WRITE(ICOUT,59)IBUGS2,IFOUND,IERROR
6128   59 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
6129      CALL DPWRST('XXX','BUG ')
6130   90 CONTINUE
6131C               ***********************************************
6132C               **  STEP 1--                                 **
6133C               **  DEFINE PARAMETER CHANGES TO BE MADE      **
6134C               **  FOR THIS IMPLEMENTATION MODULE NUMBER 1  **
6135C               ***********************************************
6136C
6137      IX2TSW='ON'
6138      IY2TSW='ON'
6139C
6140      IX2ZSW='ON'
6141      IY2ZSW='ON'
6142C
6143CCCCC NCY2LA=0
6144C
6145C               ***************************
6146C               **  STEP 2--             **
6147C               **  WRITE OUT A MESSAGE. **
6148C               ***************************
6149C
6150      IF(IFEEDB.EQ.'OFF')GOTO1169
6151      WRITE(ICOUT,999)
6152      CALL DPWRST('XXX','BUG ')
6153      WRITE(ICOUT,1151)
6154 1151 FORMAT('THE IMPLEMENTATION MODULE ')
6155      CALL DPWRST('XXX','BUG ')
6156      WRITE(ICOUT,1152)
6157 1152 FORMAT('      HAS JUST BEEN ACTIVATED')
6158      CALL DPWRST('XXX','BUG ')
6159      WRITE(ICOUT,1153)
6160 1153 FORMAT('      WHICH ALLOWS TIC MARKS ')
6161      CALL DPWRST('XXX','BUG ')
6162      WRITE(ICOUT,1154)
6163 1154 FORMAT('      AND TIC MARK LABELS ')
6164      CALL DPWRST('XXX','BUG ')
6165      WRITE(ICOUT,1155)
6166 1155 FORMAT('      ON THE TOP AND RIGHT FRAME LINES')
6167      CALL DPWRST('XXX','BUG ')
6168      WRITE(ICOUT,1156)
6169 1156 FORMAT('      OF ALL SUBSEQUENT PLOTS.')
6170      CALL DPWRST('XXX','BUG ')
6171 1169 CONTINUE
6172C
6173C               *****************
6174C               **  STEP 90--  **
6175C               **  EXIT       **
6176C               *****************
6177C
6178      IF(IBUGS2.EQ.'ON')THEN
6179        WRITE(ICOUT,999)
6180        CALL DPWRST('XXX','BUG ')
6181        WRITE(ICOUT,9011)
6182 9011   FORMAT('***** AT THE END       OF DPIMP1--')
6183        CALL DPWRST('XXX','BUG ')
6184        WRITE(ICOUT,9012)IX2TSW,IY2TSW,IX2ZSW,IY2ZSW
6185 9012   FORMAT('IX2TSW,IY2TSW,IX2ZSW,IY2ZSW = ',3(A4,2X),A4)
6186        CALL DPWRST('XXX','BUG ')
6187        WRITE(ICOUT,9014)NCY2LA
6188 9014   FORMAT('NCY2LA = ',I8)
6189        CALL DPWRST('XXX','BUG ')
6190      ENDIF
6191C
6192      RETURN
6193      END
6194      SUBROUTINE DPIMP2(ANUMVP,ANUMHP,
6195     1ISQUAR,
6196     1PXMIN,PYMIN,PXMAX,PYMAX,
6197     1IBUGS2,IFOUND,IERROR)
6198C
6199C     PURPOSE--THIS IS IMPLEMENTATION MODULE NUMBER 2.
6200C              THIS WILL RESULT IN--
6201C                    THE PLOT FRAME CHANGED FROM RECTANGULAR
6202C                    TO SQUARE FOR ALL FUTURE PLOTS
6203C                    ON TEKTRONIX GRAPHICS DEVICES.
6204C     NOTE--THIS SUBROUTINE WILL BE EXECUTED WHEN THE
6205C           ANALYST ENTERS THE COMMAND--
6206C                   IMPLEMENT 2
6207C     NOTE--THE IMPLEMENT COMMAND IS USEFUL FOR IMPLEMENTATION ,DEBUGGING,
6208C           AND FOR NON-STANDARD CONVENTIONS (E.G., PLOTS WITH NON-STANDARD
6209C           SIZE OR TIC MARK CONVENTIONS OTHER THAN DATAPLOT'S DEFAULT)
6210C     INPUT  ARGUMENTS--NONE
6211C     OUTPUT ARGUMENTS--
6212C                     --PXMIN
6213C                     --PYMIN
6214C                     --PXMAX
6215C                     --PYMAX
6216C                     --IFOUND ('YES' OR 'NO' )
6217C                     --IERROR ('YES' OR 'NO' )
6218C     WRITTEN BY--JAMES J. FILLIBEN
6219C                 STATISTICAL ENGINEERING DIVISION
6220C                 INFORMATION TECHNOLOGY LABORATORY
6221C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6222C                 GAITHERSBURG, MD 20899-8980
6223C                 PHONE--301-975-2855
6224C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6225C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6226C     LANGUAGE--ANSI FORTRAN (1977)
6227C     VERSION NUMBER--82/7
6228C     ORIGINAL VERSION--OCTOBER   1981.
6229C     UPDATED         --APRIL     1982.
6230C     UPDATED         --MAY       1982.
6231C
6232C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6233C
6234      CHARACTER*4 ISQUAR
6235C
6236      CHARACTER*4 IBUGS2
6237      CHARACTER*4 IFOUND
6238      CHARACTER*4 IERROR
6239C
6240C---------------------------------------------------------------------
6241C
6242      INCLUDE 'DPCOP2.INC'
6243C
6244C-----START POINT-----------------------------------------------------
6245C
6246      IERROR='NO'
6247      IFOUND='YES'
6248C
6249      IF(IBUGS2.EQ.'OFF')GOTO90
6250      WRITE(ICOUT,999)
6251  999 FORMAT(1X)
6252      CALL DPWRST('XXX','BUG ')
6253      WRITE(ICOUT,51)
6254   51 FORMAT('***** AT THE BEGINNING OF DPIMP2--')
6255      CALL DPWRST('XXX','BUG ')
6256      WRITE(ICOUT,52)ANUMVP,ANUMHP
6257   52 FORMAT('ANUMVP,ANUMHP = ',2E15.7)
6258      CALL DPWRST('XXX','BUG ')
6259      WRITE(ICOUT,53)ISQUAR
6260   53 FORMAT('ISQUAR = ',A4)
6261      CALL DPWRST('XXX','BUG ')
6262      WRITE(ICOUT,54)PXMIN,PXMAX,PYMIN,PYMAX
6263   54 FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4E15.7)
6264      CALL DPWRST('XXX','BUG ')
6265      WRITE(ICOUT,59)IBUGS2,IFOUND,IERROR
6266   59 FORMAT('IBUGS2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
6267      CALL DPWRST('XXX','BUG ')
6268   90 CONTINUE
6269C
6270C               ***********************************************
6271C               **  STEP 1--                                 **
6272C               **  DEFINE PARAMETER CHANGES TO BE MADE      **
6273C               **  FOR THIS IMPLEMENTATION MODULE NUMBER 2  **
6274C               ***********************************************
6275C
6276      ISQUAR='ON'
6277C
6278CCCCC PXMIN=15.0
6279CCCCC PYMIN=20.0
6280CCCCC PYMAX=90.0
6281C
6282CCCCC PYDEL=PYMAX-PYMIN
6283CCCCC PXDEL=PYDEL*(ANUMVP/ANUMHP)
6284CCCCC PXMAX=PXMIN+PXDEL
6285C
6286C               ***************************
6287C               **  STEP 2--             **
6288C               **  WRITE OUT A MESSAGE. **
6289C               ***************************
6290C
6291      IF(IFEEDB.EQ.'OFF')GOTO1169
6292      WRITE(ICOUT,999)
6293      CALL DPWRST('XXX','BUG ')
6294      WRITE(ICOUT,1151)
6295 1151 FORMAT('THE IMPLEMENTATION MODULE ',I8)
6296      CALL DPWRST('XXX','BUG ')
6297      WRITE(ICOUT,1152)
6298 1152 FORMAT('      HAS JUST BEEN ACTIVATED')
6299      CALL DPWRST('XXX','BUG ')
6300      WRITE(ICOUT,1153)
6301 1153 FORMAT('      WHICH YIELDS A SQUARE PLOT FRAME')
6302      CALL DPWRST('XXX','BUG ')
6303      WRITE(ICOUT,1154)
6304 1154 FORMAT('      FOR ALL SUBSEQUENT PLOTS')
6305      CALL DPWRST('XXX','BUG ')
6306      WRITE(ICOUT,1155)
6307 1155 FORMAT('      ON (CONTINUOUS) GRAPHICS DEVICES.')
6308      CALL DPWRST('XXX','BUG ')
6309 1169 CONTINUE
6310C
6311C               *****************
6312C               **  STEP 90--  **
6313C               **  EXIT       **
6314C               *****************
6315C
6316      IF(IBUGS2.EQ.'ON')THEN
6317        WRITE(ICOUT,999)
6318        CALL DPWRST('XXX','BUG ')
6319        WRITE(ICOUT,9011)
6320 9011   FORMAT('***** AT THE END       OF DPIMP2--')
6321        CALL DPWRST('XXX','BUG ')
6322        WRITE(ICOUT,9012)ISQUAR,ANUMVP,ANUMHP
6323 9012   FORMAT('ISQUAR,ANUMVP,ANUMHP = ',A4,2X,2G15.7)
6324        CALL DPWRST('XXX','BUG ')
6325        WRITE(ICOUT,9014)PXMIN,PXMAX,PYMIN,PYMAX
6326 9014   FORMAT('PXMIN,PXMAX,PYMIN,PYMAX = ',4G15.7)
6327        CALL DPWRST('XXX','BUG ')
6328        WRITE(ICOUT,9019)IBUGS2,IFOUND,IERROR
6329 9019   FORMAT('IBUGS2,IFOUND,IERROR = ',2(A4,2X),A4)
6330        CALL DPWRST('XXX','BUG ')
6331      ENDIF
6332C
6333      RETURN
6334      END
6335      SUBROUTINE DPIMPL(IHARG,IARGT,IARG,NUMARG,
6336     1                  IX2TSW,IY2TSW,IX2ZSW,IY2ZSW,NCY2LA,
6337     1                  ISQUAR,
6338     1                  PXMIN,PYMIN,PXMAX,PYMAX,
6339     1                  IBUGS2,IFOUND,IERROR)
6340C
6341C     PURPOSE--REINITIALIZE A SET OF UNDERLYING
6342C              FORTRAN PARAMETERS SO AS TO ACHIEVE
6343C              ALTERNATE SETTINGS FOR SUCH PARAMETERS.
6344C     NOTE--THIS CAPABILITY IS USEFUL FOR IMPLEMENTATION ,DEBUGGING,
6345C           AND FOR NON-STANDARD CONVENTIONS (E.G., PLOTS WITH NON-STANDARD
6346C           SIZE OR NO TIC MARKS ON UPPER AND RIGHT FRAME).
6347C     INPUT  ARGUMENTS--
6348C                     --IHARG
6349C                     --IARGT
6350C                     --IARG
6351C                     --NUMARG
6352C                     --IBUGS2
6353C     OUTPUT ARGUMENTS--
6354C                     --IX2TSW
6355C                     --IY2TSW
6356C                     --IX2ZSW
6357C                     --IY2ZSW
6358C                     --NCY2LA
6359C
6360C                     --PXMIN
6361C                     --PYMIN
6362C                     --PXMAX
6363C                     --PYMAX
6364C
6365C                     --IFOUND ('YES' OR 'NO' )
6366C                     --IERROR ('YES' OR 'NO' )
6367C     WRITTEN BY--JAMES J. FILLIBEN
6368C                 STATISTICAL ENGINEERING DIVISION
6369C                 INFORMATION TECHNOLOGY LABORATORY
6370C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6371C                 GAITHERSBURG, MD 20899-8980
6372C                 PHONE--301-975-2855
6373C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6374C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6375C     LANGUAGE--ANSI FORTRAN (1977)
6376C     VERSION NUMBER--82/7
6377C     ORIGINAL VERSION--OCTOBER   1981.
6378C     UPDATED         --APRIL     1982.
6379C     UPDATED         --MAY       1982.
6380C
6381C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6382C
6383      CHARACTER*4 ISQUAR
6384C
6385      CHARACTER*4 IHARG
6386      CHARACTER*4 IARGT
6387C
6388      CHARACTER*4 IX2TSW
6389      CHARACTER*4 IY2TSW
6390C
6391      CHARACTER*4 IX2ZSW
6392      CHARACTER*4 IY2ZSW
6393C
6394      CHARACTER*4 IBUGS2
6395      CHARACTER*4 IFOUND
6396      CHARACTER*4 IERROR
6397C
6398      DIMENSION IHARG(*)
6399      DIMENSION IARGT(*)
6400      DIMENSION IARG(*)
6401C
6402C-----COMMON VARIABLES (GENERAL)-----------------------------------------------
6403C
6404      INCLUDE 'DPCOP2.INC'
6405C
6406C-----START POINT-----------------------------------------------------
6407C
6408      IHOLD=(-999)
6409      IMPLNU=(-999)
6410C
6411      IFOUND='NO'
6412      IERROR='NO'
6413C
6414      IF(NUMARG.LE.0)GOTO1050
6415      IF(IHARG(NUMARG).EQ.'ON')GOTO1050
6416      IF(IHARG(NUMARG).EQ.'OFF')GOTO1050
6417      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1050
6418      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1050
6419      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1060
6420      GOTO1040
6421C
6422 1040 CONTINUE
6423      IF(IHARG(NUMARG).EQ.'TICS')GOTO1100
6424      IF(IHARG(NUMARG).EQ.'SQUA')GOTO1200
6425      GOTO8000
6426C
6427 1050 CONTINUE
6428      IHOLD=0
6429      GOTO1070
6430C
6431 1060 CONTINUE
6432      IHOLD=IARG(NUMARG)
6433      GOTO1070
6434C
6435 1070 CONTINUE
6436      IFOUND='YES'
6437      IMPLNU=IHOLD
6438C
6439      IF(IMPLNU.EQ.1)GOTO1100
6440      IF(IMPLNU.EQ.2)GOTO1200
6441      GOTO8000
6442C
6443 1100 CONTINUE
6444      CALL DPIMP1(IX2TSW,IY2TSW,IX2ZSW,IY2ZSW,NCY2LA,
6445     1IBUGS2,IFOUND,IERROR)
6446      GOTO9000
6447C
6448 1200 CONTINUE
6449      CALL DPIMP2(ANUMVP,ANUMHP,
6450     1ISQUAR,
6451     1PXMIN,PYMIN,PXMAX,PYMAX,
6452     1IBUGS2,IFOUND,IERROR)
6453      GOTO9000
6454C
6455 8000 CONTINUE
6456      IERROR='YES'
6457      WRITE(ICOUT,999)
6458  999 FORMAT(1X)
6459      CALL DPWRST('XXX','BUG ')
6460      WRITE(ICOUT,8111)
6461 8111 FORMAT('***** ERROR IN DPIMPL--')
6462      CALL DPWRST('XXX','BUG ')
6463      WRITE(ICOUT,8112)
6464 8112 FORMAT('      AN ATTEMPT WAS MADE TO ACTIVATE')
6465      CALL DPWRST('XXX','BUG ')
6466      WRITE(ICOUT,8113)IHARG(NUMARG)
6467 8113 FORMAT('      IMPLEMENTATION MODULE ',A4)
6468      CALL DPWRST('XXX','BUG ')
6469      WRITE(ICOUT,8114)
6470 8114 FORMAT('      BUT SUCH A MODULE DOES NOT EXIST.')
6471      CALL DPWRST('XXX','BUG ')
6472      GOTO9000
6473C
6474 9000 CONTINUE
6475      IF(IBUGS2.EQ.'ON')THEN
6476        WRITE(ICOUT,999)
6477        CALL DPWRST('XXX','BUG ')
6478        WRITE(ICOUT,9011)
6479 9011   FORMAT('***** AT THE END OF DPIMPL--')
6480        CALL DPWRST('XXX','BUG ')
6481        WRITE(ICOUT,9016)IMPLNU,IHOLD
6482 9016   FORMAT('IMPLNU,IHOLD = ',2I8)
6483        CALL DPWRST('XXX','BUG ')
6484        WRITE(ICOUT,9029)IBUGS2,IFOUND,IERROR
6485 9029   FORMAT('IBUGS2,IFOUND,IERROR = ',2(A4,2X),A4)
6486        CALL DPWRST('XXX','BUG ')
6487      ENDIF
6488C
6489      RETURN
6490      END
6491      SUBROUTINE DPINCU(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
6492     1                  MAXNXT,
6493     1                  ISEED,
6494     1                  ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
6495C
6496C     PURPOSE--GENERATE ONE OF THE FOLLOWING INFLUENCE CURVES--
6497C              AN INFLUENCE CURVE IS A MEASURE OF ROBUSTNESS.
6498C              IT PLOTS THE VALUE OF A STATISTIC WHEN ONE ADDITIONAL
6499C              VALUE IS ADDED.  FOR EXAMPLE,
6500C                 MEAN INFLUENCE CURVE Y XSEQ
6501C              CYCLES THROUGH THE POINTS IN XSEQ.  THE VERTICAL
6502C              AXIS IS THE VALUE OF THE MEAN FOR THE POINTS IN Y
6503C              WITH THE SINGLE VALUE IN XSEQ ADDED TO Y.
6504C
6505C              FOR THIS PLOT, ONLY ONE VARIABLE STATISTICS ARE
6506C              SUPPORTED (I.E., NO CORRELATION, ETC.).
6507C
6508C     WRITTEN BY--JAMES J. FILLIBEN
6509C                 STATISTICAL ENGINEERING DIVISION
6510C                 INFORMATION TECHNOLOGY LABORATORY
6511C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6512C                 GAITHERSBURG, MD 20899-8980
6513C                 PHONE--301-975-2855
6514C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6515C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6516C     LANGUAGE--ANSI FORTRAN (1977)
6517C     VERSION NUMBER--2002/7
6518C     ORIGINAL VERSION--JULY      2002.
6519C     UPDATED         --MAY       2007. TRIMMED STANDARD DEVIATION
6520C     UPDATED         --AUGUST    2007. MOVE SOME ARRAY STORAGE TO
6521C                                       COMMON
6522C     UPDATED         --NOVEMBER  2007. DOUBLE PRECISION ARRAYS FOR
6523C                                       CMPSTA
6524C     UPDATED         --NOVEMBER  2007. LP LOCATION
6525C     UPDATED         --NOVEMBER  2007. VARIANCE LP LOCATION
6526C     UPDATED         --NOVEMBER  2007. SD LP LOCATION
6527C     UPDATED         --SEPTEMBER 2008. BINOMIAL PROBABILITY
6528C     UPDATED         --FEBRUARY  2009. GRUBB
6529C     UPDATED         --FEBRUARY  2009. ONE SAMPLE T TEST
6530C     UPDATED         --FEBRUARY  2009. CHI-SQUARE SD TEST
6531C     UPDATED         --FEBRUARY  2009. FREQUENCY TEST
6532C     UPDATED         --FEBRUARY  2009. FREQUENCY WITHIN A BLOCK TEST
6533C     UPDATED         --MARCH     2009. PARSE WITH "EXTSTA"
6534C     UPDATED         --MARCH     2011. USE DPPARS AND DPPAR3
6535C     UPDATED         --MARCH     2011. SUPPORT MULTIPLE CURVES (BUT
6536C                                       NOT REPLICATION)
6537C
6538C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6539C
6540      CHARACTER*4 ICASPL
6541      CHARACTER*4 IAND1
6542      CHARACTER*4 IAND2
6543      CHARACTER*4 ICONT
6544      CHARACTER*4 ISUBRO
6545      CHARACTER*4 IBUGG2
6546      CHARACTER*4 IBUGG3
6547      CHARACTER*4 IBUGQ
6548      CHARACTER*4 IFOUND
6549      CHARACTER*4 IERROR
6550C
6551      CHARACTER*4 IH
6552      CHARACTER*4 IH2
6553      CHARACTER*4  ISTADF
6554      CHARACTER*60 ISTANM
6555      CHARACTER*4 ISUBN0
6556      CHARACTER*4 ISUBN1
6557      CHARACTER*4 ISUBN2
6558      CHARACTER*4 ISTEPN
6559C
6560      CHARACTER*4 ICASE
6561      PARAMETER (MAXSPN=30)
6562      CHARACTER*40 INAME
6563      CHARACTER*4 IVARN1(MAXSPN)
6564      CHARACTER*4 IVARN2(MAXSPN)
6565      CHARACTER*4 IVARTY(MAXSPN)
6566      REAL PVAR(MAXSPN)
6567      INTEGER ILIS(MAXSPN)
6568      INTEGER NRIGHT(MAXSPN)
6569      INTEGER ICOLR(MAXSPN)
6570C
6571C---------------------------------------------------------------------
6572C
6573      INCLUDE 'DPCOPA.INC'
6574C
6575      DIMENSION Y1(MAXOBV)
6576      DIMENSION X1(MAXOBV)
6577      DIMENSION XTEMP3(MAXOBV)
6578C
6579      DIMENSION TEMP(MAXOBV)
6580      DIMENSION TEMP2(MAXOBV)
6581      DIMENSION XTEMP1(MAXOBV)
6582      DIMENSION XTEMP2(MAXOBV)
6583C
6584      INCLUDE 'DPCOZZ.INC'
6585      EQUIVALENCE (GARBAG(IGARB1),X1(1))
6586      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
6587      EQUIVALENCE (GARBAG(IGARB3),XTEMP3(1))
6588      EQUIVALENCE (GARBAG(IGARB4),TEMP(1))
6589      EQUIVALENCE (GARBAG(IGARB5),TEMP2(1))
6590      EQUIVALENCE (GARBAG(IGARB6),XTEMP1(1))
6591      EQUIVALENCE (GARBAG(IGARB7),XTEMP2(1))
6592C
6593      INCLUDE 'DPCOZI.INC'
6594      INCLUDE 'DPCOZD.INC'
6595C
6596      INTEGER ITEMP1(MAXOBV)
6597      INTEGER ITEMP2(MAXOBV)
6598      INTEGER ITEMP3(MAXOBV)
6599      INTEGER ITEMP4(MAXOBV)
6600      INTEGER ITEMP5(MAXOBV)
6601      INTEGER ITEMP6(MAXOBV)
6602      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
6603      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
6604      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
6605      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
6606      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
6607      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
6608C
6609      DOUBLE PRECISION DTEMP1(MAXOBV)
6610      DOUBLE PRECISION DTEMP2(MAXOBV)
6611      DOUBLE PRECISION DTEMP3(MAXOBV)
6612      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
6613      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
6614      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
6615C
6616C-----COMMON----------------------------------------------------------
6617C
6618      INCLUDE 'DPCOHK.INC'
6619      INCLUDE 'DPCODA.INC'
6620      INCLUDE 'DPCOHO.INC'
6621      INCLUDE 'DPCOST.INC'
6622      INCLUDE 'DPCOP2.INC'
6623C
6624C-----START POINT-----------------------------------------------------
6625C
6626      IERROR='NO'
6627      IFOUND='NO'
6628      ISUBN1='INCU'
6629      ISUBN2='    '
6630C
6631      MAXCP1=MAXCOL+1
6632      MAXCP2=MAXCOL+2
6633      MAXCP3=MAXCOL+3
6634      MAXCP4=MAXCOL+4
6635      MAXCP5=MAXCOL+5
6636      MAXCP6=MAXCOL+6
6637      IMAXIN=0
6638      IMININ=0
6639C
6640C               **************************************
6641C               **  TREAT THE INFLUENCE CURVE CASE  **
6642C               **************************************
6643C
6644      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU')THEN
6645        WRITE(ICOUT,999)
6646  999   FORMAT(1X)
6647        CALL DPWRST('XXX','BUG ')
6648        WRITE(ICOUT,51)
6649   51   FORMAT('***** AT THE BEGINNING OF DPINCU--')
6650        CALL DPWRST('XXX','BUG ')
6651        WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ
6652   52   FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',4(A4,2X)A4)
6653        CALL DPWRST('XXX','BUG ')
6654        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
6655   53   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
6656        CALL DPWRST('XXX','BUG ')
6657      ENDIF
6658C
6659C               ***************************
6660C               **  STEP 1--             **
6661C               **  EXTRACT THE COMMAND  **
6662C               ***************************
6663C
6664      ISTEPN='1'
6665      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'DPINCU')
6666     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6667C
6668C               *********************************
6669C               **  STEP 1--                   **
6670C               **  DETERMINE IF OF THIS TYPE  **
6671C               **  AND BRANCH ACCORDINGLY.    **
6672C               *********************************
6673C
6674      ISTEPN='1'
6675      IF(IBUGG2.EQ.'ON'.AND.ISUBRO.NE.'INCU')
6676     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6677C
6678      IF(NUMARG.LE.1)GOTO9000
6679C
6680C     MARCH 2009: USE EXTSTA TO PARSE STATISTIC
6681C
6682      JMIN=0
6683      JMAX=NUMARG
6684C
6685      DO200I=1,NUMARG
6686        IF(IHARG(I).EQ.'INFL')THEN
6687          JMAX=I-1
6688          ILASTC=I+1
6689          GOTO209
6690        ENDIF
6691  200 CONTINUE
6692      IFOUND='NO'
6693      GOTO9000
6694  209 CONTINUE
6695C
6696      CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
6697     1            ICASPL,ISTANM,ISTANR,ISTADF,IFOUND,ILOCV,
6698     1            ISUBRO,IBUGG3,IERROR)
6699C
6700      IF(ISTANR.GE.2)IFOUND='NO'
6701      IF(IFOUND.EQ.'NO')GOTO9000
6702      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
6703C
6704C               ****************************************
6705C               **  STEP 2--                          **
6706C               **  EXTRACT THE VARIABLE LIST         **
6707C               ****************************************
6708C
6709      ISTEPN='2'
6710      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU')
6711     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6712C
6713      INAME='INFLUENCE CURVE'
6714      MINNA=1
6715      MAXNA=100
6716      MINN2=2
6717      IFLAGE=0
6718      IFLAGM=1
6719      IFLAGP=0
6720      JMIN=1
6721      JMAX=NUMARG
6722      MINNVA=2
6723      MAXNVA=MAXSPN
6724C
6725      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
6726     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
6727     1            JMIN,JMAX,
6728     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
6729     1            IVARN1,IVARN2,IVARTY,PVAR,
6730     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
6731     1            MINNVA,MAXNVA,
6732     1            IFLAGM,IFLAGP,
6733     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
6734      IF(IERROR.EQ.'YES')GOTO9000
6735C
6736      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU')THEN
6737        WRITE(ICOUT,999)
6738        CALL DPWRST('XXX','BUG ')
6739        WRITE(ICOUT,281)
6740  281   FORMAT('***** AFTER CALL DPPARS--')
6741        CALL DPWRST('XXX','BUG ')
6742        WRITE(ICOUT,282)NQ,NUMVAR
6743  282   FORMAT('NQ,NUMVAR = ',2I8)
6744        CALL DPWRST('XXX','BUG ')
6745        IF(NUMVAR.GT.0)THEN
6746          DO285I=1,NUMVAR
6747            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
6748     1                      ICOLR(I)
6749  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
6750     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
6751            CALL DPWRST('XXX','BUG ')
6752  285     CONTINUE
6753        ENDIF
6754      ENDIF
6755C
6756C     EXTRACT THE "SEQUENCE" VARIABLE.
6757C
6758      ICOL=NUMVAR
6759      NUMVA2=1
6760      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
6761     1            INAME,IVARN1,IVARN2,IVARTY,
6762     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
6763     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
6764     1            MAXCP4,MAXCP5,MAXCP6,
6765     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
6766     1            X1,X1,X1,NX,NX,NX,ICASE,
6767     1            IBUGG3,ISUBRO,IFOUND,IERROR)
6768      IF(IERROR.EQ.'YES')GOTO9000
6769C
6770C               ***********************************************
6771C               **  STEP 8A--                                **
6772C               **  MULTIPLE RESPONSE VARIABLES.  THESE CAN  **
6773C               **  BE EITHER VARIABLE OR MATRIX ARGUMENTS.  **
6774C               ***********************************************
6775C
6776      ISTEPN='8A'
6777      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU')
6778     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6779C
6780C     LOOP THROUGH EACH OF THE RESPONSE VARIABLES
6781C
6782      NPLOTP=0
6783      NUMVA2=1
6784      NUMVA3=2
6785C
6786      DO810IRESP=1,NUMVAR-1
6787        ICOL=IRESP
6788        NCURVE=IRESP
6789        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
6790     1              INAME,IVARN1,IVARN2,IVARTY,
6791     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
6792     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
6793     1              MAXCP4,MAXCP5,MAXCP6,
6794     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
6795     1              Y1,Y1,Y1,NY,NY,NY,ICASE,
6796     1              IBUGG3,ISUBRO,IFOUND,IERROR)
6797        IF(IERROR.EQ.'YES')GOTO9000
6798C
6799C               *******************************************************
6800C               **  STEP 8B--                                        **
6801C               **  COMPUTE THE APPROPRIATE INFLUENCE CURVE --       **
6802C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
6803C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
6804C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
6805C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
6806C               *******************************************************
6807C
6808        ISTEPN='8B'
6809        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU')
6810     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6811C
6812        CALL DPINC2(Y1,X1,NX,NY,NUMVA3,ICASPL,ISIZE,ICONT,
6813     1              TEMP,TEMP2,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
6814     1              ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
6815     1              DTEMP1,DTEMP2,DTEMP3,
6816     1              Y,X,D,NPLOTP,NPLOTV,NCURVE,
6817     1              ISUBRO,IBUGG3,IERROR)
6818C
6819C               *************************************************
6820C               **  STEP 29--                                  **
6821C               **  SAVE DIFFERENCE BETWEEN HIGHEST VALUE AND  **
6822C               **  LOWEST VALUE OF STATISTIC IN INTERNAL      **
6823C               **  PARAMETER ALOWHIGH                         **
6824C               *************************************************
6825C
6826C       CURRENTLY, ONLY DO THIS FOR FIRST CURVE.
6827C
6828        IF(NCURVE.EQ.1)THEN
6829          AMINS=CPUMAX
6830          AMAXS=CPUMIN
6831          DO2910I=1,NPLOTP
6832            IF(D(I).NE.1.0)GOTO2910
6833            IF(Y(I).GT.AMAXS)THEN
6834              AMAXS=Y(I)
6835              IMAXIN=I
6836            ENDIF
6837            IF(Y(I).LT.AMINS)THEN
6838              AMINS=Y(I)
6839              IMININ=I
6840            ENDIF
6841 2910     CONTINUE
6842          ADIFF=AMAXS-AMINS
6843          IF(IMAXIN.GT.IMININ)ADIFF=-ADIFF
6844C
6845          ISUBN0='INCU'
6846C
6847          IH='ALOW'
6848          IH2='HIGH'
6849          VALUE0=ADIFF
6850          CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
6851     1                IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
6852     1                IANS,IWIDTH,IBUGG3,IERROR)
6853        ENDIF
6854C
6855  810  CONTINUE
6856C
6857C               *****************
6858C               **  STEP 90--  **
6859C               **  EXIT       **
6860C               *****************
6861C
6862 9000 CONTINUE
6863      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INCU')THEN
6864        WRITE(ICOUT,999)
6865        CALL DPWRST('XXX','BUG ')
6866        WRITE(ICOUT,9011)
6867 9011   FORMAT('***** AT THE END       OF DPINCU--')
6868        CALL DPWRST('XXX','BUG ')
6869        WRITE(ICOUT,9013)IFOUND,IERROR,ISIZE
6870 9013   FORMAT('IFOUND,IERROR,ISIZE = ',2(A4,2X),I8)
6871        CALL DPWRST('XXX','BUG ')
6872        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
6873 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
6874     1         3I8,2X,2(A4,2X),A4)
6875        CALL DPWRST('XXX','BUG ')
6876        IF(IFOUND.EQ.'YES'.AND.NPLOTP.GT.0)THEN
6877          DO9025I=1,NPLOTP
6878            WRITE(ICOUT,9026)I,Y(I),X(I),D(I)
6879 9026       FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
6880            CALL DPWRST('XXX','BUG ')
6881 9025     CONTINUE
6882        ENDIF
6883      ENDIF
6884C
6885      RETURN
6886      END
6887      SUBROUTINE DPINC2(Y,X,NX,NY,NUMV2,ICASPL,ISIZE,ICONT,
6888     1                  TEMP,TEMPZ,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
6889     1                  ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
6890     1                  DTEMP1,DTEMP2,DTEMP3,
6891     1                  Y2,X2,D2,N2,NPLOTV,NCURVE,
6892     1                  ISUBRO,IBUGG3,IERROR)
6893C
6894C     PURPOSE--GENERATE ONE OF THE FOLLOWING INFLUENCE CURVES--
6895C              AN INFLUENCE CURVE IS A MEASURE OF ROBUSTNESS.
6896C              IT PLOTS THE VALUE OF A STATISTIC WHEN ONE ADDITIONAL
6897C              VALUE IS ADDED.  FOR EXAMPLE,
6898C                 MEAN INFLUENCE CURVE Y XSEQ
6899C              CYCLES THROUGH THE POINTS IN XSEQ.  THE VERTICAL
6900C              AXIS IS THE VALUE OF THE MEAN FOR THE POINTS IN Y
6901C              WITH THE SINGLE VALUE IN XSEQ ADDED TO Y.
6902C
6903C              FOR THIS PLOT, ONLY ONE VARIABLE STATISTICS ARE
6904C              SUPPORTED (I.E., NO CORRELATION, ETC.).
6905C
6906C     WRITTEN BY--ALAN HECKERT
6907C                 STATISTICAL ENGINEERING DIVISION
6908C                 INFORMATION TECHNOLOGY LABORATORY
6909C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6910C                 GAITHERSBURG, MD 20899-8980
6911C                 PHONE--301-975-2899
6912C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6913C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6914C     REFERENCE--MOSTELLER AND TUKEY, "EXPLORATORY DATA ANALYSIS".
6915C     LANGUAGE--ANSI FORTRAN (1977)
6916C     VERSION NUMBER--2002/7
6917C     ORIGINAL VERSION--JULY      2002.
6918C     UPDATED         --AUGUST    2002. USE CMPSTA TO COMPUTE THE
6919C                                       STATISTIC.
6920C     UPDATED         --APRIL     2003. ADD SN AND QN.  REQUIRED
6921C                                       ADDITIONAL SCRATCH ARRAYS
6922C     UPDATED         --NOVEMBER  2007. DOUBLE PRECISION ARRAYS FOR
6923C                                       CMPSTA
6924C     UPDATED         --NOVEMBER  2007. LP LOCATION
6925C
6926C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6927C
6928      CHARACTER*4 ICASPL
6929      CHARACTER*4 ICONT
6930      CHARACTER*4 ISUBRO
6931      CHARACTER*4 IBUGG3
6932      CHARACTER*4 IERROR
6933C
6934      CHARACTER*4 IWRITE
6935      CHARACTER*4 ISUBN1
6936      CHARACTER*4 ISUBN2
6937      CHARACTER*4 ISTEPN
6938C
6939C---------------------------------------------------------------------
6940C
6941      DIMENSION Y(*)
6942      DIMENSION X(*)
6943      DIMENSION Y2(*)
6944      DIMENSION X2(*)
6945      DIMENSION D2(*)
6946C
6947      DIMENSION TEMP(*)
6948      DIMENSION TEMPZ(*)
6949      DIMENSION XTEMP1(*)
6950      DIMENSION XTEMP2(*)
6951      DIMENSION XTEMP3(*)
6952      DIMENSION ITEMP1(*)
6953      DIMENSION ITEMP2(*)
6954      DIMENSION ITEMP3(*)
6955      DIMENSION ITEMP4(*)
6956      DIMENSION ITEMP5(*)
6957      DIMENSION ITEMP6(*)
6958      DOUBLE PRECISION DTEMP1(*)
6959      DOUBLE PRECISION DTEMP2(*)
6960      DOUBLE PRECISION DTEMP3(*)
6961C
6962C-----COMMON----------------------------------------------------------
6963C
6964      INCLUDE 'DPCOPA.INC'
6965      INCLUDE 'DPCOHK.INC'
6966      INCLUDE 'DPCOP2.INC'
6967C
6968C-----START POINT-----------------------------------------------------
6969C
6970      ISUBN1='DPIN'
6971      ISUBN2='C2  '
6972      IWRITE='OFF'
6973C
6974      I2=0
6975      ISIZE2=0
6976C
6977C     CHECK THE INPUT ARGUMENTS FOR ERRORS
6978C
6979      IF(NY.LT.2)THEN
6980        WRITE(ICOUT,999)
6981  999   FORMAT(1X)
6982        CALL DPWRST('XXX','BUG ')
6983        WRITE(ICOUT,31)
6984   31   FORMAT('***** ERROR IN INFLUENCE CURVE--')
6985        CALL DPWRST('XXX','BUG ')
6986        WRITE(ICOUT,32)
6987   32   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
6988     1         'VARIABLE MUST BE AT LEAST 2.')
6989        CALL DPWRST('XXX','BUG ')
6990        WRITE(ICOUT,34)NY
6991   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
6992        CALL DPWRST('XXX','BUG ')
6993        WRITE(ICOUT,999)
6994        CALL DPWRST('XXX','BUG ')
6995        IERROR='YES'
6996        GOTO9000
6997      ENDIF
6998C
6999      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'INC2')THEN
7000        WRITE(ICOUT,70)
7001   70   FORMAT('AT THE BEGINNING OF DPINC2--')
7002        CALL DPWRST('XXX','BUG ')
7003        WRITE(ICOUT,71)IBUGG3,ISUBRO
7004   71   FORMAT('IBUGG3,ISUBRO = ',A4,2X,A4)
7005        CALL DPWRST('XXX','BUG ')
7006        WRITE(ICOUT,72)NY,NX,NUMV2,ISIZE,ICASPL,ICONT
7007   72   FORMAT('NY,NX,NUMV2,ISIZE,ICASPL,ICONT = ',4I8,2X,A4,2X,A4)
7008        CALL DPWRST('XXX','BUG ')
7009        DO73I=1,MAX(NY,NX)
7010          WRITE(ICOUT,74)I,Y(I),X(I)
7011   74     FORMAT('I, Y(I),X(I) = ',I8,2F15.7)
7012          CALL DPWRST('XXX','BUG ')
7013   73   CONTINUE
7014      ENDIF
7015C
7016C               ********************************************************
7017C               **  STEP 1--                                          **
7018C               **  SORT THE HORIZONTAL AXIS VARIABLE, EXTRACT        **
7019C               **  THE DISTINCT VALUES.                              **
7020C               ********************************************************
7021C
7022      ISTEPN='1'
7023      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'INC2')
7024     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7025C
7026      IWRITE='OFF'
7027      CALL SORT(X,NX,X)
7028      CALL DISTIN(X,NX,IWRITE,X,NXDIST,IBUGG3,IERROR)
7029C
7030C               ******************************************
7031C               **  STEP 2--                            **
7032C               **  COMPUTE THE SPECIFIED STATISTIC     **
7033C               **  FOR EACH DISTINCT VALUE OF X ADDED  **
7034C               **  TO THE Y VARIABLE.                  **
7035C               ******************************************
7036C
7037      ISTEPN='11'
7038      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'INC2')
7039     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7040C
7041      J=0
7042C
7043      DO11000ISET=1,NXDIST
7044C
7045      ILAST=NY+1
7046      DO11011I=1,NY
7047        TEMP(I)=Y(I)
704811011 CONTINUE
7049      TEMP(ILAST)=X(ISET)
7050      NS2=ILAST
7051C
7052      CALL CMPSTA(TEMP,TEMPZ,TEMPZ,XTEMP1,XTEMP2,XTEMP3,
7053     1            MAXNXT,NS2,NS2,NS2,NUMV2,ICASPL,
7054     1            ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
7055     1            DTEMP1,DTEMP2,DTEMP3,
7056     1            RIGHT,
7057     1            ISUBRO,IBUGG3,IERROR)
7058C
7059C     ---------------------------
7060C
7061      N2=N2+1
7062      Y2(N2)=RIGHT
7063      X2(N2)=X(ISET)
7064      D2(N2)=REAL(NCURVE)
7065C
706611000 CONTINUE
7067      NPLOTV=3
7068      GOTO9000
7069C
7070C               ******************
7071C               **   STEP 90--  **
7072C               **   EXIT       **
7073C               ******************
7074C
7075 9000 CONTINUE
7076      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'INC2')THEN
7077        WRITE(ICOUT,999)
7078        CALL DPWRST('XXX','BUG ')
7079        WRITE(ICOUT,9011)
7080 9011   FORMAT('***** AT THE END       OF DPINC2--')
7081        CALL DPWRST('XXX','BUG ')
7082        DO9020I=1,N2
7083          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
7084 9021     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2)
7085          CALL DPWRST('XXX','BUG ')
7086 9020   CONTINUE
7087      ENDIF
7088C
7089      RETURN
7090      END
7091      SUBROUTINE DPIND2(X1,Y1,X2,Y2,PX,PY,
7092     1                  IFIG,ILINPA,ILINCO,PLINTH,
7093     1                  AREGBA,IREBLI,IREBCO,PREBTH,
7094     1                  IREFSW,IREFCO,
7095     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
7096     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG)
7097C
7098C     PURPOSE--DRAW A INDUCTOR WITH ONE END AT (X1,Y1)
7099C              AND THE OTHER END AT (X2,Y2).
7100C     NOTE--THE HEIGHT OF EACH LOOP IS PTEXHE.
7101C           THE WIDTH  OF EACH LOOP IS PTEXWI.
7102C     WRITTEN BY--JAMES J. FILLIBEN
7103C                 STATISTICAL ENGINEERING DIVISION
7104C                 INFORMATION TECHNOLOGY LABORATORY
7105C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7106C                 GAITHERSBURG, MD 20899-8980
7107C                 PHONE--301-975-2855
7108C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7109C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7110C     LANGUAGE--ANSI FORTRAN (1977)
7111C     VERSION NUMBER--82/7
7112C     ORIGINAL VERSION--APRIL     1981.
7113C     UPDATED         --MAY       1982.
7114C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
7115C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPINDU
7116C                                       RATHER THAN DPIND2
7117C
7118C-----NON-COMMON VARIABLES-------------------------------------
7119C
7120      DIMENSION PX(*)
7121      DIMENSION PY(*)
7122C
7123      CHARACTER*4 IFIG
7124C
7125      CHARACTER*4 ILINPA
7126      CHARACTER*4 ILINCO
7127C
7128      CHARACTER*4 IREBLI
7129      CHARACTER*4 IREBCO
7130      CHARACTER*4 IREFSW
7131      CHARACTER*4 IREFCO
7132      CHARACTER*4 IREPTY
7133      CHARACTER*4 IREPLI
7134      CHARACTER*4 IREPCO
7135C
7136      CHARACTER*4 IPATT
7137      CHARACTER*4 ICOL
7138      CHARACTER*4 IFLAG
7139C
7140      DIMENSION ILINPA(*)
7141      DIMENSION ILINCO(*)
7142      DIMENSION PLINTH(*)
7143C
7144      DIMENSION AREGBA(*)
7145      DIMENSION IREBLI(*)
7146      DIMENSION IREBCO(*)
7147      DIMENSION PREBTH(*)
7148      DIMENSION IREFSW(*)
7149      DIMENSION IREFCO(*)
7150      DIMENSION IREPTY(*)
7151      DIMENSION IREPLI(*)
7152      DIMENSION IREPCO(*)
7153      DIMENSION PREPTH(*)
7154      DIMENSION PREPSP(*)
7155C
7156C-----COMMON----------------------------------------------------------
7157C
7158      INCLUDE 'DPCOGR.INC'
7159      INCLUDE 'DPCOBE.INC'
7160      INCLUDE 'DPCOP2.INC'
7161C
7162C-----START POINT-----------------------------------------------------
7163C
7164      IPATT=ILINPA(1)
7165      PTHICK=PLINTH(1)
7166      ICOL=ILINCO(1)
7167C
7168      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'IND2')THEN
7169        WRITE(ICOUT,999)
7170  999   FORMAT(1X)
7171        CALL DPWRST('XXX','BUG ')
7172        WRITE(ICOUT,51)
7173   51   FORMAT('***** AT THE BEGINNING OF DPIND2--')
7174        CALL DPWRST('XXX','BUG ')
7175        WRITE(ICOUT,53)X1,Y1,X2,Y2
7176   53   FORMAT('X1,Y1,X2,Y2 = ',4G15.7)
7177        CALL DPWRST('XXX','BUG ')
7178        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
7179   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',A4,2X,A4,G15.7)
7180        CALL DPWRST('XXX','BUG ')
7181        WRITE(ICOUT,62)IFIG,AREGBA(1)
7182   62   FORMAT('IFIG,AREGBA(1) = ',A4,2X,G15.7)
7183        CALL DPWRST('XXX','BUG ')
7184        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
7185   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',2(A4,2X),G15.7)
7186        CALL DPWRST('XXX','BUG ')
7187        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
7188   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
7189        CALL DPWRST('XXX','BUG ')
7190        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
7191   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
7192     1         3(A4,2X),2G15.7)
7193        CALL DPWRST('XXX','BUG ')
7194        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG
7195   69   FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG = ',4G15.7)
7196        CALL DPWRST('XXX','BUG ')
7197        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
7198   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
7199        CALL DPWRST('XXX','BUG ')
7200      ENDIF
7201C
7202C               *********************************
7203C               **  STEP 1--                   **
7204C               **  DETERMINE THE COORDINATES  **
7205C               **  FOR THE FIGURE             **
7206C               *********************************
7207C
7208      DELX=X2-X1
7209      DELY=Y2-Y1
7210      ALEN=0.0
7211      TERM=(X2-X1)**2+(Y2-Y1)**2
7212      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
7213      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
7214      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
7215      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
7216C
7217      AJXMIN=PTEXWI
7218      AJXDEL=PTEXWI
7219      AJYDEL=PTEXHE
7220      AJXMAX=ALEN-2*AJXDEL
7221C
7222      XMIN=AJXMIN
7223      XDEL=AJXDEL
7224      YDEL=AJYDEL
7225      XMAX=AJXMAX
7226C
7227      K=0
7228C
7229      X=0
7230      Y=0
7231      K=K+1
7232      PX(K)=X1
7233      PY(K)=Y1
7234C
7235      X=XMIN
7236      Y=0
7237      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
7238      K=K+1
7239      PX(K)=XP
7240      PY(K)=YP
7241C
7242      AJX=AJXMIN-AJXDEL
7243CCCCC DO1450JX=JXMIN,JXMAX,JXDEL
7244 1440 CONTINUE
7245      AJX=AJX+AJXDEL
7246      IF(AJX.GT.AJXMAX)GOTO1460
7247C
7248      X=AJX
7249      Y=0
7250      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
7251      AJX3=XP
7252      AJY3=YP
7253C
7254      X=AJX+AJXDEL
7255      Y=0
7256      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
7257      AJX4=XP
7258      AJY4=YP
7259C
7260      CALL DPIND3(AJX3,AJY3,AJX4,AJY4,PX,PY,K,
7261     1            IFIG,IPATT,PTHICK,ICOL)
7262C
7263      GOTO1440
7264C
7265 1460 CONTINUE
7266C
7267CCCCC X=XMAX
7268      X=ALEN
7269      Y=0
7270      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
7271      K=K+1
7272      PX(K)=XP
7273      PY(K)=YP
7274C
7275      NP=K
7276C
7277C               ***********************
7278C               **  STEP 2--         **
7279C               **  FILL THE FIGURE  **
7280C               **  (IF CALLED FOR)  **
7281C               ***********************
7282C
7283CCCCC IF(IREFSW(1).EQ.'OFF')GOTO2190
7284CCCCC IPATT=IREPTY(1)
7285CCCCC PTHICK=PREPTH(1)
7286CCCCC PXGAP=PREPSP(1)
7287CCCCC PYGAP=PREPSP(1)
7288CCCCC ICOLF=IREFCO(1)
7289CCCCC ICOLP=IREPCO(1)
7290CCCCC CALL DPFIRE(PX,PY,NP,
7291CCCCC1            IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP)
7292C2190 CONTINUE
7293C
7294C               ***************************
7295C               **  STEP 3--             **
7296C               **  DRAW OUT THE FIGURE  **
7297C               ***************************
7298C
7299      IPATT=ILINPA(1)
7300      PTHICK=PLINTH(1)
7301      ICOL=ILINCO(1)
7302      IFLAG='ON'
7303      CALL DPDRPL(PX,PY,NP,
7304     1            IFIG,IPATT,PTHICK,ICOL,
7305     1            JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
7306C
7307C               *****************
7308C               **  STEP 90--  **
7309C               **  EXIT       **
7310C               *****************
7311C
7312      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'IND2')THEN
7313        WRITE(ICOUT,999)
7314        CALL DPWRST('XXX','BUG ')
7315        WRITE(ICOUT,9011)
7316 9011   FORMAT('***** AT THE END       OF DPIND2--')
7317        CALL DPWRST('XXX','BUG ')
7318        DO9015I=1,NP
7319          WRITE(ICOUT,9016)I,PX(I),PY(I)
7320 9016     FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
7321          CALL DPWRST('XXX','BUG ')
7322 9015   CONTINUE
7323        WRITE(ICOUT,9039)IERRG4
7324 9039   FORMAT('IERRG4 = ',A4)
7325        CALL DPWRST('XXX','BUG ')
7326      ENDIF
7327C
7328      RETURN
7329      END
7330      SUBROUTINE DPIND3(X1,Y1,X2,Y2,PX,PY,K,
7331     1                  IFIG,IPATT,PTHICK,ICOL)
7332C
7333C     PURPOSE--DRAW A SEMI-CIRCLE FOR AN INDUCTOR
7334C              WITH ONE END OF THE DIAGONAL AT (X1,Y1)
7335C              AND THE OTHER END AT (X2,Y2).
7336C     WRITTEN BY--JAMES J. FILLIBEN
7337C                 STATISTICAL ENGINEERING DIVISION
7338C                 INFORMATION TECHNOLOGY LABORATORY
7339C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7340C                 GAITHERSBURG, MD 20899-8980
7341C                 PHONE--301-975-2855
7342C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7343C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7344C     LANGUAGE--ANSI FORTRAN (1977)
7345C     VERSION NUMBER--82/7
7346C     ORIGINAL VERSION--APRIL     1981.
7347C     UPDATED         --MAY       1982.
7348C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
7349C
7350C-----NON-COMMON VARIABLES-----------------------------------------
7351C
7352      CHARACTER*4 IFIG
7353      CHARACTER*4 IPATT
7354      CHARACTER*4 ICOL
7355      CHARACTER*4 IFLAG
7356C
7357      DIMENSION PX(*)
7358      DIMENSION PY(*)
7359C
7360C-----COMMON----------------------------------------------------------
7361C
7362      INCLUDE 'DPCOGR.INC'
7363      INCLUDE 'DPCOBE.INC'
7364      INCLUDE 'DPCOP2.INC'
7365C
7366C-----START POINT-----------------------------------------------------
7367C
7368      IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'IND3')THEN
7369        WRITE(ICOUT,999)
7370  999   FORMAT(1X)
7371        CALL DPWRST('XXX','BUG ')
7372        WRITE(ICOUT,51)
7373   51   FORMAT('***** AT THE BEGINNING OF DPIND3--')
7374        CALL DPWRST('XXX','BUG ')
7375        WRITE(ICOUT,53)X1,Y1,X2,Y2,K
7376   53   FORMAT('X1,Y1,X2,Y2,K = ',4G15.7,I8)
7377        CALL DPWRST('XXX','BUG ')
7378        WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
7379   79   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
7380        CALL DPWRST('XXX','BUG ')
7381      ENDIF
7382C
7383      DELX=X2-X1
7384      DELY=Y2-Y1
7385      ALEN=0.0
7386      TERM=(X2-X1)**2+(Y2-Y1)**2
7387      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
7388      R=ALEN/2.0
7389      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
7390      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
7391      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
7392C
7393      X=0.0
7394      Y=0.0
7395      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
7396      K=K+1
7397      PX(K)=XP
7398      PY(K)=YP
7399C
7400      DO3010I=1,181,5
7401      IREV=181-I+1
7402      PHI2=IREV-1
7403      PHI2=PHI2*(2.0*3.1415926)/360.0
7404      X=R*COS(PHI2)+R
7405      Y=R*SIN(PHI2)
7406      CALL TRANS(X,Y,X1,Y1,THETA,DELX,DELY,XP,YP,KXP,KYP)
7407      K=K+1
7408      PX(K)=XP
7409      PY(K)=YP
7410C
7411      IF(K.LE.490)GOTO3010
7412      NP=K
7413      IFLAG='ON'
7414CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
7415CCCCC1IFIG,IPATT,PTHICK,ICOL)
7416      CALL DPDRPL(PX,PY,NP,
7417     1IFIG,IPATT,PTHICK,ICOL,
7418     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
7419      K=0
7420      K=K+1
7421      PX(K)=XP
7422      PY(K)=YP
7423C
7424 3010 CONTINUE
7425C
7426C               *****************
7427C               **  STEP 90--  **
7428C               **  EXIT       **
7429C               *****************
7430C
7431      IF(IBUGG4.EQ.'ON' .OR. ISUBG4.EQ.'IND3')THEN
7432        WRITE(ICOUT,999)
7433        CALL DPWRST('XXX','BUG ')
7434        WRITE(ICOUT,9011)
7435 9011   FORMAT('***** AT THE END       OF DPIND3--')
7436        CALL DPWRST('XXX','BUG ')
7437        DO9015I=1,K
7438          WRITE(ICOUT,9016)I,PX(I),PY(I)
7439 9016     FORMAT('I,PX(I),PY(I) = ',I8,2G15.7)
7440          CALL DPWRST('XXX','BUG ')
7441 9015   CONTINUE
7442        WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
7443 9039   FORMAT('IBUGG4,ISUBG4,IERRG4 = ',2(A4,2X),A4)
7444        CALL DPWRST('XXX','BUG ')
7445      ENDIF
7446C
7447      RETURN
7448      END
7449      SUBROUTINE DPINDM(Y1,N1,Y2,N2,ICASE,
7450     1                  STATVA,
7451     1                  IBUGA3,ISUBRO,IERROR)
7452C
7453C     PURPOSE--THIS ROUTINE IMPLEMENTS THE FOLLOWING COMMANDS:
7454C
7455C                 LET A = INDEX FIRST MATCH Y1 Y2
7456C                 LET A = INDEX LAST  MATCH Y1 Y2
7457C                 LET A = INDEX FIRST NOT MATCH Y1 Y2
7458C                 LET A = INDEX LAST  NOT MATCH Y1 Y2
7459C
7460C              THAT IS, RETURN THE INDEX OF EITHER THE FIRST OR LAST
7461C              MATCHING (OR NON-MATCHING) ENTRIES FOR TWO ARRAYS.
7462C              NOTE THAT THE INPUT ARRAYS NEED NOT BE OF THE SAME
7463C              SIZE.
7464C     WRITTEN BY--ALAN HECKERT
7465C                 STATISTICAL ENGINEERING DIVISION
7466C                 INFORMATION TECHNOLOGY LABORATORY
7467C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7468C                 GAITHERSBURG, MD 20899-8980
7469C                 PHONE--301-975-2899
7470C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7471C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7472C     LANGUAGE--ANSI FORTRAN (1977)
7473C     VERSION NUMBER--2011/11
7474C     ORIGINAL VERSION--NOVEMBER  2011
7475C
7476C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7477C
7478      CHARACTER*4 ICASE
7479      CHARACTER*4 IBUGA3
7480      CHARACTER*4 ISUBRO
7481      CHARACTER*4 IERROR
7482C
7483      CHARACTER*4 ISUBN1
7484      CHARACTER*4 ISUBN2
7485      CHARACTER*4 ISTEPN
7486C
7487C---------------------------------------------------------------------
7488C
7489      DIMENSION Y1(*)
7490      DIMENSION Y2(*)
7491C
7492C---------------------------------------------------------------------
7493C
7494      INCLUDE 'DPCOP2.INC'
7495C
7496C-----START POINT-----------------------------------------------------
7497C
7498      ISUBN1='DPIN'
7499      ISUBN2='DM  '
7500      IERROR='NO'
7501C
7502      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'INDM')THEN
7503        WRITE(ICOUT,999)
7504  999   FORMAT(1X)
7505        CALL DPWRST('XXX','WRIT')
7506        WRITE(ICOUT,51)
7507   51   FORMAT('**** AT THE BEGINNING OF DPINDM--')
7508        CALL DPWRST('XXX','WRIT')
7509        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,N2
7510   52   FORMAT('IBUGA3,ISUBRO,N1,N2 = ',2(A4,2X),2I8)
7511        CALL DPWRST('XXX','WRIT')
7512        DO56I=1,N1
7513          WRITE(ICOUT,57)I,Y1(I)
7514   57     FORMAT('I,Y1(I) = ',I8,G15.7)
7515          CALL DPWRST('XXX','WRIT')
7516   56   CONTINUE
7517        DO66I=1,N2
7518          WRITE(ICOUT,67)I,Y2(I)
7519   67     FORMAT('I,Y2(I) = ',I8,E15.7)
7520          CALL DPWRST('XXX','WRIT')
7521   66   CONTINUE
7522      ENDIF
7523C
7524C               ********************************************
7525C               **  STEP 11--                             **
7526C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
7527C               ********************************************
7528C
7529      ISTEPN='11'
7530      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INDM')
7531     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7532C
7533      IF(N1.LT.1)THEN
7534        WRITE(ICOUT,999)
7535        CALL DPWRST('XXX','WRIT')
7536        WRITE(ICOUT,1111)
7537 1111   FORMAT('***** ERROR IN INDEX ... MATCH')
7538        CALL DPWRST('XXX','WRIT')
7539        WRITE(ICOUT,1113)
7540 1113   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE FIRST ',
7541     1         'RESPONSE VARIABLE IS LESS THAN ONE.')
7542        CALL DPWRST('XXX','WRIT')
7543        WRITE(ICOUT,1115)N1
7544 1115   FORMAT('SAMPLE SIZE = ',I8)
7545        CALL DPWRST('XXX','WRIT')
7546        IERROR='YES'
7547        GOTO9000
7548      ELSEIF(N2.LT.1)THEN
7549        WRITE(ICOUT,999)
7550        CALL DPWRST('XXX','WRIT')
7551        WRITE(ICOUT,1111)
7552        CALL DPWRST('XXX','WRIT')
7553        WRITE(ICOUT,1123)
7554 1123   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE SECOND ',
7555     1         'RESPONSE VARIABLE IS LESS THAN ONE.')
7556        CALL DPWRST('XXX','WRIT')
7557        WRITE(ICOUT,1115)N2
7558        CALL DPWRST('XXX','WRIT')
7559        IERROR='YES'
7560        GOTO9000
7561      ENDIF
7562C
7563C               ******************************
7564C               **  STEP 21--               **
7565C               **  DETERMINE THE INDEX     **
7566C               ******************************
7567C
7568      ISTEPN='21'
7569      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INDM')
7570     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7571C
7572      STATVA=0.0
7573C
7574      IF(ICASE.EQ.'FMAT')THEN
7575        DO100I=1,MIN(N1,N2)
7576          IF(Y1(I).EQ.Y2(I))THEN
7577            STATVA=REAL(I)
7578            GOTO9000
7579          ENDIF
7580  100   CONTINUE
7581      ELSEIF(ICASE.EQ.'LMAT')THEN
7582        DO200I=MIN(N1,N2),1,-1
7583          IF(Y1(I).EQ.Y2(I))THEN
7584            STATVA=REAL(I)
7585            GOTO9000
7586          ENDIF
7587  200   CONTINUE
7588      ELSEIF(ICASE.EQ.'FNOM')THEN
7589        DO300I=1,MIN(N1,N2)
7590          IF(Y1(I).NE.Y2(I))THEN
7591            STATVA=REAL(I)
7592            GOTO9000
7593          ENDIF
7594  300   CONTINUE
7595        IF(N1.NE.N2)STATVA=REAL(MIN(N1,N2)+1)
7596      ELSEIF(ICASE.EQ.'LNOM')THEN
7597        DO400I=MIN(N1,N2),1,-1
7598          IF(Y1(I).NE.Y2(I))THEN
7599            STATVA=REAL(I)
7600            GOTO9000
7601          ENDIF
7602  400   CONTINUE
7603        IF(N1.NE.N2)STATVA=REAL(MAX(N1,N2))
7604      ENDIF
7605C
7606C               *****************
7607C               **  STEP 90--  **
7608C               **  EXIT       **
7609C               *****************
7610C
7611 9000 CONTINUE
7612      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'INDM')THEN
7613        WRITE(ICOUT,999)
7614        CALL DPWRST('XXX','WRIT')
7615        WRITE(ICOUT,9011)
7616 9011   FORMAT('***** AT THE END       OF DPINDM--')
7617        CALL DPWRST('XXX','WRIT')
7618        WRITE(ICOUT,9012)IERROR,STATVA
7619 9012   FORMAT('IERROR,STATVA = ',A4,2X,G15.7)
7620        CALL DPWRST('XXX','WRIT')
7621      ENDIF
7622C
7623      RETURN
7624      END
7625      SUBROUTINE DPINDU(IHARG,IARGT,ARG,NUMARG,
7626     1                  PXSTAR,PYSTAR,PXEND,PYEND,
7627     1                  ILINPA,ILINCO,PLINTH,
7628     1                  AREGBA,IREBLI,IREBCO,PREBTH,
7629     1                  IREFSW,IREFCO,
7630     1                  IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
7631     1                  PTEXHE,PTEXWI,PTEXVG,PTEXHG,
7632     1                  IGRASW,IDIASW,
7633     1                  PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
7634     1                  PDIAHE,PDIAWI,PDIAVG,PDIAHG,
7635     1                  NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
7636     1                  IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
7637     1                  IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
7638     1                  IBUGD2,IFOUND,IERROR)
7639C
7640C     PURPOSE--DRAW ONE OR MORE INDUCTORS (DEPENDING ON HOW MANY NUMBERS ARE
7641C              PROVIDED).  THE COORDINATES ARE IN STANDARDIZED UNITS
7642C              OF 0 TO 100.
7643C     NOTE--THE INPUT COORDINATES DEFINE THE 2 ENDS OF THE INDUCTOR.
7644C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2
7645C          AND THEREFORE THE USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
7646C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN INDUCTOR WILL GO FROM THE
7647C           LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER ABSOLUTE OR
7648C           RELATIVE) AS DEFINED BY THE 2 NUMBERS.
7649C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN INDUCTOR WILL GO FROM THE
7650C           ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2 NUMBERS TO THE
7651C           (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE THIRD
7652C           AND FOURTH NUMBERS.
7653C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN INDUCTOR WILL GO FROM THE
7654C           (X,Y) POSITION AS RESULTING FROM THE THIRD AND FOURTH NUMBERS TO
7655C           THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED BY THE
7656C           FIFTH AND SIXTH NUMBERS.
7657C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
7658C     INPUT  ARGUMENTS--IHARG
7659C                     --IARGT
7660C                     --ARG
7661C                     --NUMARG
7662C                     --PXSTAR
7663C                     --PYSTAR
7664C     OUTPUT ARGUMENTS--PXEND
7665C                     --PYEND
7666C                     --IFOUND ('YES' OR 'NO' )
7667C                     --IERROR ('YES' OR 'NO' )
7668C     WRITTEN BY--JAMES J. FILLIBEN
7669C                 STATISTICAL ENGINEERING DIVISION
7670C                 INFORMATION TECHNOLOGY LABORATORY
7671C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7672C                 GAITHERSBURG, MD 20899-8980
7673C                 PHONE--301-975-2855
7674C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7675C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7676C     LANGUAGE--ANSI FORTRAN (1977)
7677C     VERSION NUMBER--82/7
7678C     ORIGINAL VERSION--APRIL     1981.
7679C     UPDATED         --MARCH     1982.
7680C     UPDATED         --MAY       1982.
7681C     UPDATED         --NOVEMBER  1982.
7682C     UPDATED         --JANUARY   1989. CALL LIST FOR OFFSET VAR (ALAN)
7683C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
7684C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
7685C     UPDATED         --DECEMBER  2018. CHECK FOR DISCRETE, NULL, OR
7686C                                       NONE DEVICE
7687C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
7688C                                       COMMAND
7689C     UPDATED         --JULY      2019. CREATE SCRATCH STORAGE IN DPINDU
7690C                                       RATHER THAN DPIND2
7691C
7692C-----NON-COMMON VARIABLES-----------------------------------------
7693C
7694      CHARACTER*4 IHARG
7695      CHARACTER*4 IARGT
7696C
7697      CHARACTER*4 ILINPA
7698      CHARACTER*4 ILINCO
7699C
7700      CHARACTER*4 IREBLI
7701      CHARACTER*4 IREBCO
7702      CHARACTER*4 IREFSW
7703      CHARACTER*4 IREFCO
7704      CHARACTER*4 IREPTY
7705      CHARACTER*4 IREPLI
7706      CHARACTER*4 IREPCO
7707C
7708      CHARACTER*4 IGRASW
7709      CHARACTER*4 IDIASW
7710C
7711      CHARACTER*4 IDMANU
7712      CHARACTER*4 IDMODE
7713      CHARACTER*4 IDMOD2
7714      CHARACTER*4 IDMOD3
7715      CHARACTER*4 IDPOWE
7716      CHARACTER*4 IDCONT
7717      CHARACTER*4 IDFONT
7718      CHARACTER*4 UNITSW
7719      CHARACTER*4 IDCOLO
7720C
7721      CHARACTER*4 IFOUND
7722      CHARACTER*4 IBUGD2
7723      CHARACTER*4 IERROR
7724      CHARACTER*4 ISUBRO
7725C
7726      CHARACTER*4 IFIG
7727      CHARACTER*4 IBELSW
7728      CHARACTER*4 IERASW
7729      CHARACTER*4 IBACCO
7730      CHARACTER*4 ICOPSW
7731      CHARACTER*4 ITYPEO
7732C
7733      DIMENSION IHARG(*)
7734      DIMENSION IARGT(*)
7735      DIMENSION ARG(*)
7736C
7737      DIMENSION ILINPA(*)
7738      DIMENSION ILINCO(*)
7739      DIMENSION PLINTH(*)
7740C
7741      DIMENSION AREGBA(*)
7742      DIMENSION IREBLI(*)
7743      DIMENSION IREBCO(*)
7744      DIMENSION PREBTH(*)
7745      DIMENSION IREFSW(*)
7746      DIMENSION IREFCO(*)
7747      DIMENSION IREPTY(*)
7748      DIMENSION IREPLI(*)
7749      DIMENSION IREPCO(*)
7750      DIMENSION PREPTH(*)
7751      DIMENSION PREPSP(*)
7752      DIMENSION PDSCAL(*)
7753C
7754      DIMENSION IDMANU(*)
7755      DIMENSION IDMODE(*)
7756      DIMENSION IDMOD2(*)
7757      DIMENSION IDMOD3(*)
7758      DIMENSION IDPOWE(*)
7759      DIMENSION IDCONT(*)
7760      DIMENSION IDCOLO(*)
7761      DIMENSION IDFONT(*)
7762      DIMENSION IDNVPP(*)
7763      DIMENSION IDNHPP(*)
7764      DIMENSION IDUNIT(*)
7765      DIMENSION IDNVOF(*)
7766      DIMENSION IDNHOF(*)
7767C
7768C-----COMMON----------------------------------------------------------
7769C
7770      INCLUDE 'DPCOPA.INC'
7771      INCLUDE 'DPCOZZ.INC'
7772      DIMENSION PX(1000)
7773      DIMENSION PY(1000)
7774      EQUIVALENCE (GARBAG(IGARB1),PX(1))
7775      EQUIVALENCE (GARBAG(IGARB2),PY(1))
7776C
7777C-----COMMON VARIABLES (GENERAL)--------------------------------------
7778C
7779      INCLUDE 'DPCOGR.INC'
7780      INCLUDE 'DPCOBE.INC'
7781      INCLUDE 'DPCOP2.INC'
7782C
7783C-----START POINT-----------------------------------------------------
7784C
7785      IFOUND='NO'
7786      IERROR='NO'
7787      IERRG4=IERROR
7788C
7789      ILOCFN=0
7790      NUMNUM=0
7791C
7792      X1=0.0
7793      Y1=0.0
7794      X2=0.0
7795      Y2=0.0
7796C
7797      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'INDU')THEN
7798        WRITE(ICOUT,999)
7799  999   FORMAT(1X)
7800        CALL DPWRST('XXX','BUG ')
7801        WRITE(ICOUT,51)
7802   51   FORMAT('***** AT THE BEGINNING OF DPINDU--')
7803        CALL DPWRST('XXX','BUG ')
7804        WRITE(ICOUT,53)NUMARG,NUMDEV
7805   53   FORMAT('NUMARG,NUMDEV = ',2I8)
7806        CALL DPWRST('XXX','BUG ')
7807        DO55I=1,NUMARG
7808          WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
7809   56     FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2(2X,A4),G15.7)
7810          CALL DPWRST('XXX','BUG ')
7811   55   CONTINUE
7812        WRITE(ICOUT,57)PXSTAR,PYSTAR,PXEND,PYEND
7813   57   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
7814        CALL DPWRST('XXX','BUG ')
7815        WRITE(ICOUT,61)ILINPA(1),ILINCO(1),PLINTH(1)
7816   61   FORMAT('ILINPA(1),ILINCO(1),PLINTH(1) = ',2(A4,2X),G15.7)
7817        CALL DPWRST('XXX','BUG ')
7818        WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1)
7819   63   FORMAT('IREBLI(1),IREBCO(1),PREBTH(1),AREGBA(1) = ',
7820     1         2(A4,2X),2G15.7)
7821        CALL DPWRST('XXX','BUG ')
7822        WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
7823   64   FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
7824        CALL DPWRST('XXX','BUG ')
7825        WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
7826   65   FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
7827     1         3(A4,2X),2G15.7)
7828        CALL DPWRST('XXX','BUG ')
7829        WRITE(ICOUT,69)PTEXHE,PTEXWI,PTEXVG,PTEXHG
7830   69   FORMAT('PTEXHE,PTEXWI,PTEXVG,PTEXHG= ',4G15.7)
7831        CALL DPWRST('XXX','BUG ')
7832        WRITE(ICOUT,76)IGRASW,IDIASW
7833   76   FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
7834        CALL DPWRST('XXX','BUG ')
7835        WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
7836   77   FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4G15.7)
7837        CALL DPWRST('XXX','BUG ')
7838        WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
7839   78   FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4G15.7)
7840        CALL DPWRST('XXX','BUG ')
7841        DO81I=1,NUMDEV
7842          WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
7843   82     FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
7844     1           3(A4,2X),A4)
7845          CALL DPWRST('XXX','BUG ')
7846          WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
7847   83     FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',2(A4,2X),A4)
7848          CALL DPWRST('XXX','BUG ')
7849          WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
7850   84     FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',3I8)
7851          CALL DPWRST('XXX','BUG ')
7852   81   CONTINUE
7853        WRITE(ICOUT,88)IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR
7854   88   FORMAT('IBUGG4,IBUGD2,ISUBG4,IERRG4,IFOUND,IERROR = ',
7855     1         5(A4,2X),A4)
7856        CALL DPWRST('XXX','BUG ')
7857      ENDIF
7858C
7859      IFIG='INDU'
7860      NUMPT=2
7861      NUMPT2=2*NUMPT
7862C
7863C               ********************************
7864C               **  STEP 0--                  **
7865C               **  STEP THROUGH EACH DEVICE  **
7866C               ********************************
7867C
7868      IF(NUMDEV.LE.0)GOTO9000
7869      DO8000IDEVIC=1,NUMDEV
7870C
7871        IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
7872        IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
7873        IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
7874        IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
7875        IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
7876C
7877        IMANUF=IDMANU(IDEVIC)
7878        IMODEL=IDMODE(IDEVIC)
7879        IMODE2=IDMOD2(IDEVIC)
7880        IMODE3=IDMOD3(IDEVIC)
7881        IGCONT=IDCONT(IDEVIC)
7882        IGCOLO=IDCOLO(IDEVIC)
7883        IGFONT=IDFONT(IDEVIC)
7884        NUMVPP=IDNVPP(IDEVIC)
7885        NUMHPP=IDNHPP(IDEVIC)
7886        ANUMVP=NUMVPP
7887        ANUMHP=NUMHPP
7888        IOFFSV=IDNVOF(IDEVIC)
7889        IOFFSH=IDNHOF(IDEVIC)
7890        IGUNIT=IDUNIT(IDEVIC)
7891        PCHSCA=PDSCAL(IDEVIC)
7892C
7893C               ************************************
7894C               **  STEP 1--                      **
7895C               **  CARRY OUT OPENING OPERATIONS  **
7896C               **  ON THE GRAPHICS DEVICES       **
7897C               ************************************
7898C
7899        CALL DPOPDE
7900C
7901        IBELSW='OFF'
7902        NUMRIN=0
7903        IERASW='OFF'
7904        IBACCO='JUNK'
7905C
7906        CALL DPOPPL(IGRASW,IBELSW,NUMRIN,IERASW,IBACCO)
7907C
7908C               *****************************************
7909C               **  STEP 2--                           **
7910C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
7911C               *****************************************
7912C
7913        IF(NUMARG.GE.2.AND.
7914     1     IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')THEN
7915          ITYPEO='ABSO'
7916          ILOCFN=1
7917        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
7918     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
7919          ITYPEO='ABSO'
7920          ILOCFN=2
7921        ELSEIF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
7922     1         IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')THEN
7923          ITYPEO='RELA'
7924          ILOCFN=2
7925        ELSE
7926          GOTO1130
7927        ENDIF
7928C
7929        IF(ILOCFN.GT.NUMARG)GOTO1130
7930        DO1120I=ILOCFN,NUMARG
7931          IF(IARGT(I).NE.'NUMB')GOTO1130
7932 1120   CONTINUE
7933        IFOUND='YES'
7934C
7935C               ****************************
7936C               **  STEP 3--              **
7937C               **  DRAW OUT THE LINE(S)  **
7938C               ****************************
7939C
7940        NUMNUM=NUMARG-ILOCFN+1
7941        IF(NUMNUM.LT.NUMPT2)THEN
7942          J=ILOCFN-1
7943          X1=PXSTAR
7944          Y1=PYSTAR
7945        ELSE
7946          J=ILOCFN
7947          IF(J.GT.NUMARG)GOTO1190
7948          X1=ARG(J)
7949          IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,
7950     1       IBUGD2,ISUBRO,IERROR)
7951          J=J+1
7952          IF(J.GT.NUMARG)GOTO1190
7953          Y1=ARG(J)
7954          IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,
7955     1       IBUGD2,ISUBRO,IERROR)
7956        ENDIF
7957C
7958 1160   CONTINUE
7959        J=J+1
7960        IF(J.GT.NUMARG)GOTO1190
7961        X2=ARG(J)
7962        IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
7963        IF(ITYPEO.EQ.'RELA')X2=X1+X2
7964        J=J+1
7965        IF(J.GT.NUMARG)GOTO1190
7966        Y2=ARG(J)
7967        IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
7968        IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
7969C
7970        CALL DPIND2(X1,Y1,X2,Y2,PX,PY,
7971     1              IFIG,ILINPA,ILINCO,PLINTH,
7972     1              AREGBA,IREBLI,IREBCO,PREBTH,
7973     1              IREFSW,IREFCO,
7974     1              IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
7975     1              PTEXHE,PTEXWI,PTEXVG,PTEXHG)
7976C
7977        X1=X2
7978        Y1=Y2
7979C
7980        GOTO1160
7981 1190   CONTINUE
7982C
7983        PXEND=X2
7984        PYEND=Y2
7985C
7986C               ************************************
7987C               **  STEP 4--                      **
7988C               **  CARRY OUT CLOSING OPERATIONS  **
7989C               **  ON THE GRAPHICS DEVICES       **
7990C               ************************************
7991C
7992        ICOPSW='OFF'
7993        NUMCOP=0
7994        CALL DPCLPL(ICOPSW,NUMCOP,
7995     1              PGRAXF,PGRAYF,
7996     1              IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
7997     1              PDIAHE,PDIAWI,PDIAVG,PDIAHG)
7998C
7999        CALL DPCLDE
8000C
8001 8000 CONTINUE
8002      GOTO9000
8003C
8004 1130 CONTINUE
8005      IERRG4='YES'
8006      WRITE(ICOUT,1131)
8007 1131 FORMAT('***** ERROR IN INDUCTOR (DPINDU)--')
8008      CALL DPWRST('XXX','BUG ')
8009      WRITE(ICOUT,1132)
8010 1132 FORMAT('      ILLEGAL FORM FOR THE INDUCTOR COMMAND.')
8011      CALL DPWRST('XXX','BUG ')
8012      WRITE(ICOUT,1134)
8013 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE PROPER FORM--')
8014      CALL DPWRST('XXX','BUG ')
8015      WRITE(ICOUT,1135)
8016 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A INDUCTOR ')
8017      CALL DPWRST('XXX','BUG ')
8018      WRITE(ICOUT,1136)
8019 1136 FORMAT('      FROM THE POINT 20 20 ')
8020      CALL DPWRST('XXX','BUG ')
8021      WRITE(ICOUT,1137)
8022 1137 FORMAT('      TO THE POINT 40 60')
8023      CALL DPWRST('XXX','BUG ')
8024      WRITE(ICOUT,1141)
8025 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
8026      CALL DPWRST('XXX','BUG ')
8027      WRITE(ICOUT,1142)
8028 1142 FORMAT('      INDUCTOR 20 20 40 60 ')
8029      CALL DPWRST('XXX','BUG ')
8030      WRITE(ICOUT,1143)
8031 1143 FORMAT('      INDUCTOR ABSOLUTE 20 20 40 60 ')
8032      CALL DPWRST('XXX','BUG ')
8033      WRITE(ICOUT,1145)
8034 1145 FORMAT('      INDUCTOR RELATIVE 20 20 40 60 ')
8035      CALL DPWRST('XXX','BUG ')
8036      GOTO9000
8037C               *****************
8038C               **  STEP 90--  **
8039C               **  EXIT       **
8040C               *****************
8041C
8042 9000 CONTINUE
8043      IF(IBUGG4.EQ.'ON'.OR.ISUBG4.EQ.'INDU')THEN
8044        WRITE(ICOUT,999)
8045        CALL DPWRST('XXX','BUG ')
8046        WRITE(ICOUT,9011)
8047 9011   FORMAT('***** AT THE END       OF DPINDU--')
8048        CALL DPWRST('XXX','BUG ')
8049        WRITE(ICOUT,9012)IFOUND,IERROR,ILOCFN,NUMNUM
8050 9012   FORMAT('IFOUND,IERROR,ILOCFN,NUMNUM = ',2(A4,2X),2I8)
8051        CALL DPWRST('XXX','BUG ')
8052        WRITE(ICOUT,9013)X1,Y1,X2,Y2,X3,Y3
8053 9013   FORMAT('X1,Y1,X2,Y2,X3,Y3 = ',6G15.7)
8054        CALL DPWRST('XXX','BUG ')
8055        WRITE(ICOUT,9015)PXSTAR,PYSTAR,PXEND,PYEND
8056 9015   FORMAT('PXSTAR,PYSTAR,PXEND,PYEND = ',4G15.7)
8057        CALL DPWRST('XXX','BUG ')
8058      ENDIF
8059C
8060      RETURN
8061      END
8062      SUBROUTINE DPINFU(IFUNC3,N3,IHNAME,IHNAM2,IUSE,IN,IVSTAR,IVSTOP,
8063     1                  NUMNAM,IANS,IWIDTH,IHLEFT,IHLEF2,ILISTL,
8064     1                  NEWNAM,MAXN3,
8065     1                  IFUNC,NUMCHF,MAXCHF,IBUGA3,IERROR)
8066C
8067C     PURPOSE--INSERT (IF NECESSARY) THE FUNCTION IN IFUNC3(.) INTO THE
8068C              GENERAL DATAPLOT INTERNAL FUNCTION TABLE IFUNC(.).
8069C              ALSO, UPDATE INTERNAL DATAPLOT LISTS (IF NECESSARY).
8070C
8071C     INPUT  FUNCTION--IN IFUNC3(.)
8072C     OUTPUT FUNCTION--SOMEWHERE IN IFUNC(.).
8073C     WRITTEN BY--JAMES J. FILLIBEN
8074C                 STATISTICAL ENGINEERING DIVISION
8075C                 INFORMATION TECHNOLOGY LABORATORY
8076C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8077C                 GAITHERSBURG, MD 20899-8980
8078C                 PHONE--301-975-2855
8079C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8080C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8081C     LANGUAGE--ANSI FORTRAN (1977)
8082C     VERSION NUMBER--82/7
8083C     ORIGINAL VERSION--DECEMBER  1978.
8084C     UPDATED         --JANUARY   1979.
8085C     UPDATED         --JULY      1981.
8086C     UPDATED         --MAY       1982.
8087C     UPDATED         --DECEMBER  1993. FIX BUG STATEMENT
8088C                                       MAXCHF => 120
8089C     UPDATED         --JANUARY   2012. IF N3 < 0, THEN DELETE THE
8090C                                       STRING
8091C     UPDATED         --MARCH     2015. UPDATE "IN" ARRAY TO 0 WHEN
8092C                                       DEFINING A NEW STRING
8093C
8094C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8095C
8096      CHARACTER*4 IFUNC3
8097      CHARACTER*4 IHNAME
8098      CHARACTER*4 IHNAM2
8099      CHARACTER*4 IUSE
8100      CHARACTER*4 IANS
8101      CHARACTER*4 IHLEFT
8102      CHARACTER*4 IHLEF2
8103      CHARACTER*4 IFUNC
8104      CHARACTER*4 IBUGA3
8105      CHARACTER*4 IERROR
8106C
8107      CHARACTER*4 NEWNAM
8108C
8109      CHARACTER*4 ISUBN1
8110      CHARACTER*4 ISUBN2
8111      CHARACTER*4 ISTEPN
8112C
8113C---------------------------------------------------------------------
8114C
8115      DIMENSION IHNAME(*)
8116      DIMENSION IHNAM2(*)
8117      DIMENSION IUSE(*)
8118      DIMENSION IN(*)
8119      DIMENSION IVSTAR(*)
8120      DIMENSION IVSTOP(*)
8121C
8122      DIMENSION IANS(*)
8123C
8124      DIMENSION IFUNC3(*)
8125      DIMENSION IFUNC(*)
8126C
8127C---------------------------------------------------------------------
8128C
8129      INCLUDE 'DPCOP2.INC'
8130C
8131C-----START POINT-----------------------------------------------------
8132C
8133      ISUBN1='DPIN'
8134      ISUBN2='FU  '
8135      IERROR='NO'
8136C
8137      IDEL=0
8138C
8139C               ******************************************
8140C               **  INSERT A FUNCTION                   **
8141C               **  INTO THE GENERAL DATAPLOT FUNCTION  **
8142C               **  TABLE IFUNC(.).                     **
8143C               **  MAKE ADJUSTMENTS TO THE             **
8144C               **  INTERNAL DATAPLOT LISTS.            **
8145C               ******************************************
8146C
8147      IF(IBUGA3.EQ.'ON')THEN
8148        WRITE(ICOUT,999)
8149  999   FORMAT(1X)
8150        CALL DPWRST('XXX','BUG ')
8151        WRITE(ICOUT,51)
8152   51   FORMAT('***** AT THE BEGINNING OF DPINFU--')
8153        CALL DPWRST('XXX','BUG ')
8154        WRITE(ICOUT,53)NUMNAM,ILISTL,NEWNAM,IBUGA3
8155   53   FORMAT('NUMNAM,ILISTL,NEWNAM,IBUGA3 = ',2I8,2X,A4,2X,A4)
8156        CALL DPWRST('XXX','BUG ')
8157        DO55I=1,NUMNAM
8158          WRITE(ICOUT,56)I,IHNAME(I),IHNAM2(I),IUSE(I),
8159     1                   IVSTAR(I),IVSTOP(I)
8160   56     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=',
8161     1           I8,2X,A4,A4,2X,A4,2I8)
8162          CALL DPWRST('XXX','BUG ')
8163   55   CONTINUE
8164        WRITE(ICOUT,57)N3,NUMCHF,MAXN3,MAXCHF
8165   57   FORMAT('N3,NUMCHF,MAXN3,MAXCHF = ',4I8)
8166        CALL DPWRST('XXX','BUG ')
8167        IF(N3.GE.1)THEN
8168          WRITE(ICOUT,59)(IFUNC3(I),I=1,MIN(N3,120))
8169   59     FORMAT('IFUNC3(.) = ',120A1)
8170          CALL DPWRST('XXX','BUG ')
8171        ENDIF
8172CCCCC   THE FOLLOWING LINE WAS CHANGED     DECEMBER 1993
8173CCCCC   WRITE(ICOUT,60)(IFUNC(I),I=1,MAXCHF)
8174        WRITE(ICOUT,60)(IFUNC(I),I=1,MIN(MAXCHF,120))
8175   60   FORMAT('IFUNC(.)  = ',120A1)
8176        CALL DPWRST('XXX','BUG ')
8177      ENDIF
8178C
8179C               **********************************
8180C               **  STEP 1--                    **
8181C               **  INITIALIZE SOME VARIABLES.  **
8182C               **********************************
8183C
8184      ISTEPN='1'
8185      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8186C
8187      IERROR='NO'
8188      NUMCH0=NUMCHF
8189C
8190C               *****************************************************
8191C               **  STEP 2--                                       **
8192C               **  DETERMINE IF THE ADDITION OF THE NEW FUNCTION  **
8193C               **  TO THE INTERNAL DATAPLOT TABLE                 **
8194C               **  WILL OVERFLOW THE TABLE (TYPICALLY             **
8195C               **  THERE IS A MAXCHF CHARACTER LIMIT                **
8196C               **  FOR THE SUM TOTAL OVER ALL FUNCTIONS).         **
8197C               *****************************************************
8198C
8199      ISTEPN='2'
8200      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8201C
8202      IF(NEWNAM.EQ.'YES')THEN
8203        IF(NUMNAM.GE.MAXN3)THEN
8204          WRITE(ICOUT,999)
8205          CALL DPWRST('XXX','BUG ')
8206          WRITE(ICOUT,1001)
8207 1001     FORMAT('***** ERROR IN DPINFU--')
8208          CALL DPWRST('XXX','BUG ')
8209          WRITE(ICOUT,1003)IHLEFT,IHLEF2
8210 1003     FORMAT('      MAXIMUM NUMBER OF NAMES EXCEEDED.  STRING ',
8211     1           2A4,' NOT UPDATED.')
8212          CALL DPWRST('XXX','BUG ')
8213          IERROR='YES'
8214          GOTO9000
8215        ENDIF
8216        N0TEST=NUMCHF+N3
8217      ELSE
8218        IMIN=IVSTAR(ILISTL)
8219        IMAX=IVSTOP(ILISTL)
8220        N3OLD=IMAX-IMIN+1
8221        IF(N3.GE.0)THEN
8222          IDEL=N3-N3OLD
8223          N0TEST=NUMCHF+IDEL
8224        ELSE
8225          IDEL=N3OLD
8226          N0TEST=NUMCHF-N3OLD
8227        ENDIF
8228      ENDIF
8229C
8230      IF(N0TEST.GT.MAXCHF)THEN
8231        WRITE(ICOUT,2301)
8232 2301   FORMAT('***** ERROR IN DPINFU--')
8233        CALL DPWRST('XXX','BUG ')
8234        WRITE(ICOUT,2302)
8235 2302   FORMAT('      ERROR CAUSED IN ENTERING THE FUNCTION INTO THE')
8236        CALL DPWRST('XXX','BUG ')
8237        WRITE(ICOUT,2304)
8238 2304   FORMAT('      INTERNAL DATAPLOT FUNCTION TABLE.  THE TOTAL ',
8239     1         'NUMBER OF')
8240        CALL DPWRST('XXX','BUG ')
8241        WRITE(ICOUT,2306)MAXCHF
8242 2306   FORMAT('      CHARACTERS IN THAT TABLE (FOR ALL FUNCTIONS) ',
8243     1         'MAY NOT EXCEED ',I8,'.')
8244        CALL DPWRST('XXX','BUG ')
8245        WRITE(ICOUT,2307)
8246 2307   FORMAT('      SUCH AN OVERFLOW CONDITION HAS JUST BEEN ',
8247     1         'ENCOUNTERED.')
8248        CALL DPWRST('XXX','BUG ')
8249        WRITE(ICOUT,2309)
8250 2309   FORMAT('      THE FUNCTION TABLE HAS BEEN RESET TO ITS STATUS')
8251        CALL DPWRST('XXX','BUG ')
8252        WRITE(ICOUT,2311)
8253 2311   FORMAT('      BEFORE ATTEMPTING TO ENTER THE LAST FUNCTION.')
8254        CALL DPWRST('XXX','BUG ')
8255        WRITE(ICOUT,2313)
8256 2313   FORMAT('      THE TOTAL NUMBER OF CHARACTERS IN THE FUNCTION ',
8257     1         'TABLE')
8258        CALL DPWRST('XXX','BUG ')
8259        WRITE(ICOUT,2315)NUMCHF
8260 2315   FORMAT('      HAS BEEN RESET TO ITS PREVIOUS VALUE = ',I8)
8261        CALL DPWRST('XXX','BUG ')
8262        WRITE(ICOUT,2316)
8263 2316   FORMAT('      THE NUMBER OF CHARACTERS IN THE FUNCTION')
8264        CALL DPWRST('XXX','BUG ')
8265        WRITE(ICOUT,2317)N3
8266 2317   FORMAT('      THAT WAS ATTEMPTED TO BE ENTERED = ',I8)
8267        CALL DPWRST('XXX','BUG ')
8268        WRITE(ICOUT,2318)
8269 2318   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
8270        CALL DPWRST('XXX','BUG ')
8271        WRITE(ICOUT,2319)(IANS(I),I=1,MIN(IWIDTH,100))
8272 2319   FORMAT('      ',100A1)
8273        CALL DPWRST('XXX','BUG ')
8274        WRITE(ICOUT,999)
8275        CALL DPWRST('XXX','BUG ')
8276        WRITE(ICOUT,2321)
8277 2321   FORMAT('      SUGGESTED POSSIBLE SOLUTION--')
8278        CALL DPWRST('XXX','BUG ')
8279        WRITE(ICOUT,2322)
8280 2322   FORMAT('      REDEFINE SOME OF THE OTHER ALREADY DEFINED')
8281        CALL DPWRST('XXX','BUG ')
8282        WRITE(ICOUT,2324)
8283 2324   FORMAT('      FUNCTIONS THAT MAY NO LONGER BE NEEDED')
8284        CALL DPWRST('XXX','BUG ')
8285        WRITE(ICOUT,2325)
8286 2325   FORMAT('      SO THAT THEY ARE ONLY 1 CHARACTER LONG')
8287        CALL DPWRST('XXX','BUG ')
8288        WRITE(ICOUT,2326)
8289 2326   FORMAT('      EXAMPLE--LET FUNCTION F3=C')
8290        CALL DPWRST('XXX','BUG ')
8291        IERROR='YES'
8292        GOTO9000
8293      ENDIF
8294C
8295C               ***************************************************
8296C               **  STEP 3--                                     **
8297C               **  MOVE THE SEGMENT OF THE STRING IN IFUNC(.)   **
8298C               **  WHICH IS BEYOND THE FUNCTION OF INTEREST     **
8299C               **  OVER AN APPROPRIATE NUMBER OF SPACES.        **
8300C               ***************************************************
8301C
8302      ISTEPN='3'
8303      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8304C
8305      IF(NEWNAM.EQ.'YES')THEN
8306        ISTART=NUMCHF+1
8307        ISTOP=ISTART+N3-1
8308      ELSEIF(N3.GE.0)THEN
8309        ISTART=IVSTAR(ILISTL)
8310        ISTOP=ISTART+N3-1
8311      ELSE
8312        ISTART=IVSTAR(ILISTL)
8313        ISTOP=ISTART+N3OLD-1
8314      ENDIF
8315C
8316      IF(IBUGA3.EQ.'ON')THEN
8317        WRITE(ICOUT,2401)N3,N3OLD,IDEL,ISTART,ISTOP
8318 2401   FORMAT('N3,N3OLD,IDEL,ISTART,ISTOP = ',5I8)
8319        CALL DPWRST('XXX','BUG ')
8320      ENDIF
8321C
8322      IF(NEWNAM.EQ.'YES')GOTO3290
8323      IF(N3.LT.0)THEN
8324        KMIN=ISTART
8325        KMAX=NUMCHF-IDEL
8326        DO3205K=KMIN,KMAX
8327          L=K+IDEL
8328          IFUNC(K)=IFUNC(L)
8329 3205   CONTINUE
8330      ELSE
8331        KMIN=ISTOP+1
8332        KMAX=NUMCHF+IDEL
8333C
8334        IF(IDEL.EQ.0)GOTO3290
8335        IF(IDEL.GT.0)THEN
8336          DO3215K=KMIN,KMAX
8337            KREV=KMAX-K+KMIN
8338            LREV=KREV-IDEL
8339            IFUNC(KREV)=IFUNC(LREV)
8340 3215     CONTINUE
8341        ELSEIF(IDEL.LT.0)THEN
8342          DO3225K=KMIN,KMAX
8343            L=K-IDEL
8344            IFUNC(K)=IFUNC(L)
8345 3225     CONTINUE
8346        ENDIF
8347      ENDIF
8348C
8349 3290 CONTINUE
8350C
8351      IF(IBUGA3.EQ.'ON')THEN
8352        WRITE(ICOUT,3291)(IFUNC(I),I=1,MIN(MAXCHF,120))
8353 3291   FORMAT('AT 3290: IFUNC(.) = ',120A1)
8354        CALL DPWRST('XXX','BUG ')
8355      ENDIF
8356C
8357C
8358C               **************************************************
8359C               **  STEP 4--                                    **
8360C               **  MOVE THE NEW FUNCTION INTO THE APPROPRIATE  **
8361C               **  PLACE IN IFUNC(.).                          **
8362C               **************************************************
8363C
8364      ISTEPN='4'
8365      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8366C
8367      IF(N3.GE.0)THEN
8368        L=0
8369        DO4200K=ISTART,ISTOP
8370          L=L+1
8371          IFUNC(K)=IFUNC3(L)
8372 4200    CONTINUE
8373      ENDIF
8374C
8375C               ************************************
8376C               **  STEP 5--                      **
8377C               **  REDEFINE NUMCHF = THE UPDATED **
8378C               **  LENGTH OF IFUNC(.).           **
8379C               ************************************
8380C
8381      ISTEPN='5'
8382      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8383C
8384      NUMCHF=N0TEST
8385C
8386C               *************************************************
8387C               **  STEP 6--                                   **
8388C               **  MAKE THE ADJUSTMENTS TO THE INTERNAL LIST  **
8389C               *************************************************
8390C
8391      ISTEPN='6'
8392      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8393C
8394      IF(NEWNAM.EQ.'YES')THEN
8395        IHNAME(ILISTL)=IHLEFT
8396        IHNAM2(ILISTL)=IHLEF2
8397        IUSE(ILISTL)='F'
8398        IN(ILISTL)=0
8399        IVSTAR(ILISTL)=ISTART
8400        IVSTOP(ILISTL)=ISTOP
8401        NUMNAM=NUMNAM+1
8402        GOTO9000
8403      ELSEIF(N3.GE.0)THEN
8404        N3OLD=IVSTOP(ILISTL)-IVSTAR(ILISTL)+1
8405        IDEL=N3-N3OLD
8406C
8407        DO6210I=1,NUMNAM
8408          IF(IUSE(I).EQ.'F')THEN
8409            IF(IVSTAR(I).GT.ISTART)IVSTAR(I)=IVSTAR(I)+IDEL
8410            IF(IVSTOP(I).GE.ISTART)IVSTOP(I)=IVSTOP(I)+IDEL
8411          ENDIF
8412 6210   CONTINUE
8413      ELSE
8414        N3OLD=IVSTOP(ILISTL)-IVSTAR(ILISTL)+1
8415        IDEL=N3OLD
8416C
8417        DO6220I=1,NUMNAM
8418          IF(IUSE(I).EQ.'F')THEN
8419            IF(IVSTAR(I).GT.ISTART)IVSTAR(I)=IVSTAR(I)-IDEL
8420            IF(IVSTOP(I).GE.ISTART)IVSTOP(I)=IVSTOP(I)-IDEL
8421          ENDIF
8422 6220   CONTINUE
8423      ENDIF
8424C
8425C               *****************
8426C               **  STEP 90--  **
8427C               **  EXIT       **
8428C               *****************
8429C
8430 9000 CONTINUE
8431      IF(IBUGA3.EQ.'ON')THEN
8432        WRITE(ICOUT,9011)
8433 9011   FORMAT('***** AT THE END       OF DPINFU--')
8434        CALL DPWRST('XXX','BUG ')
8435        WRITE(ICOUT,9013)IERROR,NEWNAM,NUMNAM
8436 9013   FORMAT('IERROR,NEWNAM,NUMNAM = ',2(A4,2X),I8)
8437        CALL DPWRST('XXX','BUG ')
8438        DO9015I=1,NUMNAM
8439          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
8440     1                     IVSTAR(I),IVSTOP(I)
8441 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=',
8442     1           I8,2X,A4,A4,2X,A4,2I8)
8443          CALL DPWRST('XXX','BUG ')
8444 9015   CONTINUE
8445        WRITE(ICOUT,9018)NUMCH0,N3,NUMCHF,MAXN3,MAXCHF
8446 9018   FORMAT('NUMCH0,N3,NUMCHF,MAXN3,MAXCHF = ',5I8)
8447        CALL DPWRST('XXX','BUG ')
8448        WRITE(ICOUT,9019)(IFUNC3(I),I=1,MIN(N3,120))
8449 9019   FORMAT('IFUNC3(.) = ',120A1)
8450        CALL DPWRST('XXX','BUG ')
8451CCCCC   THE FOLLOWING LINE WAS CHANGED     DECEMBER 1993
8452CCCCC   WRITE(ICOUT,9020)(IFUNC(I),I=1,MAXCHF)
8453        WRITE(ICOUT,9020)(IFUNC(I),I=1,MIN(MAXCHF,120))
8454 9020   FORMAT('IFUNC(.)  = ',120A1)
8455        CALL DPWRST('XXX','BUG ')
8456      ENDIF
8457C
8458      RETURN
8459      END
8460      SUBROUTINE DPINLE(ILEGN2,ISTH,N2,ILEGNA,ILEGST,ILEGSP,
8461     1NUMLEG,MAXLEG,ILEGTE,NCLEG,MXCLEG,IANS,IWIDTH,IBUGIL,IERROR)
8462C
8463C     PURPOSE--INSERT(IF NECESSARY) THE HOLLERITH LEGEND
8464C              IN ISTH(.)
8465C              INTO (RESPECTIVELY) THE PACKED
8466C              INTERNAL DATAPLOT TABLES ILEGTE(.)
8467C              ALSO, UPDATE INTERNAL DATAPLOT LISTS
8468C              ILEGNA(.), ILEGST(.), AND ILEGSP(.).
8469C              A CHECK FOR N2 BEING POSITIVE IS DONE HEREIN.
8470C
8471C     NOTE--IT IS ASSUMED IN ALL CASES (EVEN FOR
8472C           A BLANKED-OUT LEGEND) THAT THE NUMBER
8473C           OF CHARACTERS IN THE LEGEND IS AT LEAST 1;
8474C           (THAT IS, THE INPUT N2 IS 1 OR LARGER).
8475C
8476C     INPUT  LEGENDS --IN ISTH(.)
8477C     OUTPUT LEGENDS --SOMEWHERE IN ILEGTE(.)
8478C
8479C     ILEGN2 = NAME FOR THE INPUT LEGEND.
8480C     ISTH   = VECTOR CONTAINING INPUT LEGEND STRING (IN HOLLERITH)
8481C     N2     = LENGTH OF INPUT LEGEND STRING.
8482C     ILEGNA = TABLE OF EXISTING LEGEND NAMES.
8483C     ILEGST = TABLE OF EXISTING START POSITIONS IN ILEGTE.
8484C     ILEGSP = TABLE OF EXISTING STOP  POSITIONS IN ILEGTE.
8485C     NUMLEG = NUMBER OF EXISTING LEGENDS.
8486C     MAXLEG = MAXIMUM NUMBER OF ALLOWABLE LEGENDS.
8487C     ILEGTE  = VECTOR OF PACKED LEGENDS (HOLLERITH) WHERE FINAL STORAGE IS DONE
8488C     NCLEG = NUMBER OF PACKED CHARACTERS IN ILEGTE(.)
8489C     MXCLEG = MAX NUMBER OF ALLOWABLE CHARACTERS IN ILEGTE(.)
8490C
8491C     WRITTEN BY--JAMES J. FILLIBEN
8492C                 STATISTICAL ENGINEERING DIVISION
8493C                 INFORMATION TECHNOLOGY LABORATORY
8494C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8495C                 GAITHERSBURG, MD 20899-8980
8496C                 PHONE--301-975-2855
8497C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8498C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
8499C     LANGUAGE--ANSI FORTRAN (1977)
8500C     VERSION NUMBER--82/7
8501C     ORIGINAL VERSION--MARCH     1979.
8502C     UPDATED         --SEPTEMBER 1980.
8503C     UPDATED         --JANUARY   1981.
8504C     UPDATED         --MARCH     1982.
8505C     UPDATED         --MAY       1982.
8506C     UPDATED         --JUNE      1994.  BUG FIX
8507C
8508C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
8509C
8510      CHARACTER*4 ILEGN2
8511      CHARACTER*4 ISTH
8512      CHARACTER*4 ILEGNA
8513      CHARACTER*4 ILEGTE
8514      CHARACTER*4 IANS
8515      CHARACTER*4 IBUGIL
8516      CHARACTER*4 IERROR
8517C
8518      CHARACTER*4 NEWNAM
8519C
8520      CHARACTER*4 ISUBN1
8521      CHARACTER*4 ISUBN2
8522      CHARACTER*4 ISTEPN
8523C
8524C---------------------------------------------------------------------
8525C
8526      DIMENSION ISTH(*)
8527      DIMENSION ILEGNA(*)
8528      DIMENSION ILEGST(*)
8529      DIMENSION ILEGSP(*)
8530      DIMENSION ILEGTE(*)
8531      DIMENSION IANS(*)
8532C
8533C---------------------------------------------------------------------
8534C
8535      INCLUDE 'DPCOP2.INC'
8536C
8537C-----START POINT-----------------------------------------------------
8538C
8539      ISUBN1='DPIN'
8540      ISUBN2='LE  '
8541C
8542      ILISTL=0
8543      IDEL=0
8544C
8545      NEWNAM='UNKN'
8546C
8547C               ******************************************
8548C               **  INSERT A LEGEND                     **
8549C               **  INTO THE GENERAL DATAPLOT LEGEND    **
8550C               **  TABLES ILEGTE(.)        **
8551C               **  MAKE ADJUSTMENTS TO THE             **
8552C               **  INTERNAL DATAPLOT LISTS.            **
8553C               ******************************************
8554C
8555      IF(IBUGIL.EQ.'OFF')GOTO90
8556      WRITE(ICOUT,999)
8557  999 FORMAT(1X)
8558      CALL DPWRST('XXX','BUG ')
8559      WRITE(ICOUT,71)
8560   71 FORMAT('***** AT THE BEGINNING OF DPINLE--')
8561      CALL DPWRST('XXX','BUG ')
8562      WRITE(ICOUT,72)ILEGN2,N2
8563   72 FORMAT('ILEGN2,N2 = ',A4,3X,I8)
8564      CALL DPWRST('XXX','BUG ')
8565      WRITE(ICOUT,73)(ISTH(I),I=1,N2)
8566   73 FORMAT('ISTH(.) = ',55A2)
8567      CALL DPWRST('XXX','BUG ')
8568      WRITE(ICOUT,75)NCLEG,MXCLEG
8569   75 FORMAT('NCLEG,MXCLEG = ',2I8)
8570      CALL DPWRST('XXX','BUG ')
8571      WRITE(ICOUT,76)(ILEGTE(I),I=1,NCLEG)
8572   76 FORMAT('ILEGTE(.) = ',55A2)
8573      CALL DPWRST('XXX','BUG ')
8574      WRITE(ICOUT,81)NUMLEG,MAXLEG
8575   81 FORMAT('NUMLEG,MAXLEG = ',2I8)
8576      CALL DPWRST('XXX','BUG ')
8577      DO82I=1,NUMLEG
8578      WRITE(ICOUT,83)I,ILEGNA(I),ILEGST(I),ILEGSP(I)
8579   83 FORMAT('I,ILEGNA(I),ILEGST(I),ILEGSP(I) = ',I4,3X,A4,I8,I8)
8580      CALL DPWRST('XXX','BUG ')
8581   82 CONTINUE
8582   90 CONTINUE
8583C
8584C               **********************************
8585C               **  STEP 1--                    **
8586C               **  INITIALIZE SOME VARIABLES.  **
8587C               **********************************
8588C
8589      ISTEPN='1'
8590      IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8591C
8592      IERROR='NO'
8593      NUMCH0=NCLEG
8594C
8595      IF(N2.GE.1)GOTO190
8596C
8597      WRITE(ICOUT,111)
8598  111 FORMAT('***** INTERNAL ERROR IN DPLEG--')
8599      CALL DPWRST('XXX','BUG ')
8600      WRITE(ICOUT,112)
8601  112 FORMAT('      THE INPUT LENGTH N2 OF THE STRING IS ',
8602     1'NON-POSITIVE.')
8603      CALL DPWRST('XXX','BUG ')
8604      WRITE(ICOUT,113)N2
8605  113 FORMAT('      N2 = ',I8)
8606      CALL DPWRST('XXX','BUG ')
8607      IERROR='YES'
8608      GOTO9000
8609C
8610  190 CONTINUE
8611C
8612C               ************************************
8613C               **  STEP 2--                      **
8614C               **  DETERMINE IF THE LEGEND NAME  **
8615C               **  ALREADY EXISTS IN THE TABLE.  **
8616C               ************************************
8617C
8618      ISTEPN='2'
8619      IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8620C
8621      NEWNAM='YES'
8622      IF(NUMLEG.LE.0)GOTO250
8623      DO210I=1,NUMLEG
8624      I2=I
8625      IF(ILEGN2.EQ.ILEGNA(I))GOTO220
8626  210 CONTINUE
8627      GOTO250
8628C
8629  220 CONTINUE
8630      NEWNAM='NO'
8631      ILISTL=I2
8632      GOTO290
8633C
8634  250 CONTINUE
8635      NEWNAM='YES'
8636      ILISTL=NUMLEG+1
8637      GOTO290
8638C
8639  290 CONTINUE
8640C
8641C               ***********************************************************
8642C               **  STEP 3--                                             **
8643C               **  FOR THE CASE WHEN HAVE A NEW NAME,                   **
8644C               **  DETERMINE IF THIS NEW NAME                           **
8645C               **  WILL OVERFLOW THE ALLOWABLE NUMBER OF LEGEND NAMES   **
8646C               **   IN TABLE ILEGNA(.).                                 **
8647C               ***********************************************************
8648C
8649      ISTEPN='3'
8650      IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8651C
8652      IF(NEWNAM.EQ.'NO')GOTO390
8653      IF(ILISTL.LE.MAXLEG)GOTO390
8654C
8655      WRITE(ICOUT,301)
8656  301 FORMAT('***** ERROR IN DPINLE--')
8657      CALL DPWRST('XXX','BUG ')
8658      WRITE(ICOUT,302)
8659  302 FORMAT('      ERROR CAUSED IN ENTERING')
8660      CALL DPWRST('XXX','BUG ')
8661      WRITE(ICOUT,303)
8662  303 FORMAT('      THE LEGEND   INTO THE')
8663      CALL DPWRST('XXX','BUG ')
8664      WRITE(ICOUT,304)
8665  304 FORMAT('      INTERNAL DATAPLOT LEGEND   TABLE.')
8666      CALL DPWRST('XXX','BUG ')
8667      WRITE(ICOUT,305)
8668  305 FORMAT('      THE TOTAL NUMBER OF LEGENDS IN THAT')
8669      CALL DPWRST('XXX','BUG ')
8670      WRITE(ICOUT,306)MAXLEG
8671  306 FORMAT('      TABLE (FOR ALL LEGENDS) MAY NOT EXCEED ',
8672     1I8)
8673      CALL DPWRST('XXX','BUG ')
8674      WRITE(ICOUT,307)
8675  307 FORMAT('      SUCH AN OVERFLOW CONDITION HAS JUST')
8676      CALL DPWRST('XXX','BUG ')
8677      WRITE(ICOUT,308)
8678  308 FORMAT('      BEEN ENCOUNTERED.')
8679      CALL DPWRST('XXX','BUG ')
8680      WRITE(ICOUT,309)
8681  309 FORMAT('      THE LEGEND   TABLE HAS JUST BEEN RESET')
8682      CALL DPWRST('XXX','BUG ')
8683      WRITE(ICOUT,310)
8684  310 FORMAT('      TO  ITS STATUS BEFORE THE')
8685      CALL DPWRST('XXX','BUG ')
8686      WRITE(ICOUT,311)
8687  311 FORMAT('      LAST LEGEND   WAS ATTEMPTED')
8688      CALL DPWRST('XXX','BUG ')
8689      WRITE(ICOUT,312)
8690  312 FORMAT('      TO BE ENTERED.')
8691      CALL DPWRST('XXX','BUG ')
8692      WRITE(ICOUT,313)
8693  313 FORMAT('      THE TOTAL NUMBER OF LEGENDS')
8694      CALL DPWRST('XXX','BUG ')
8695      WRITE(ICOUT,314)
8696  314 FORMAT('      IN THE LEGEND   TABLE')
8697      CALL DPWRST('XXX','BUG ')
8698      WRITE(ICOUT,315)NUMLEG
8699  315 FORMAT('      HAS JUST BEEN RESET TO ITS PREVIOUS VALUE =',I8)
8700      CALL DPWRST('XXX','BUG ')
8701      WRITE(ICOUT,318)
8702  318 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
8703      CALL DPWRST('XXX','BUG ')
8704      WRITE(ICOUT,319)(IANS(I),I=1,IWIDTH)
8705  319 FORMAT('      ',100A1)
8706      CALL DPWRST('XXX','BUG ')
8707      WRITE(ICOUT,999)
8708      CALL DPWRST('XXX','BUG ')
8709      WRITE(ICOUT,321)
8710  321 FORMAT('      SUGGESTED POSSIBLE SOLUTION--')
8711      CALL DPWRST('XXX','BUG ')
8712      WRITE(ICOUT,322)
8713  322 FORMAT('      REDEFINE SOME OF THE OTHER ')
8714      CALL DPWRST('XXX','BUG ')
8715      WRITE(ICOUT,323)
8716  323 FORMAT('      ALREADY-DEFINED LEGENDS')
8717      CALL DPWRST('XXX','BUG ')
8718      WRITE(ICOUT,324)
8719  324 FORMAT('      THAT MAY NO LONGER BE NEEDED.')
8720      CALL DPWRST('XXX','BUG ')
8721      IERROR='YES'
8722      GOTO9000
8723C
8724  390 CONTINUE
8725C
8726C               *****************************************************
8727C               **  STEP 4--                                       **
8728C               **  DETERMINE IF THE ADDITION OF THE NEW LEGEND    **
8729C               **  STRING TO THE INTERNAL DATAPLOT TABLES         **
8730C               **  ILEGTE(.)                                  **
8731C               **  WILL OVERFLOW THE TABLE (TYPICALLY             **
8732C               **  THERE IS A 500 CHARACTER LIMIT                 **
8733C               **  FOR THE SUM TOTAL OVER ALL LEGENDS).           **
8734C               *****************************************************
8735C
8736      ISTEPN='4'
8737      IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8738C
8739      IF(NEWNAM.EQ.'YES')GOTO2100
8740      GOTO2200
8741C
8742 2100 CONTINUE
8743      N0TEST=NCLEG+N2
8744      GOTO2300
8745C
8746 2200 CONTINUE
8747      IMIN=ILEGST(ILISTL)
8748      IMAX=ILEGSP(ILISTL)
8749      N2OLD=IMAX-IMIN+1
8750      IDEL=N2-N2OLD
8751      N0TEST=NCLEG+IDEL
8752      GOTO2300
8753C
8754 2300 CONTINUE
8755      IF(N0TEST.LE.MXCLEG)GOTO2390
8756      WRITE(ICOUT,2301)
8757 2301 FORMAT('***** ERROR IN DPINLE--')
8758      CALL DPWRST('XXX','BUG ')
8759      WRITE(ICOUT,2302)
8760 2302 FORMAT('      ERROR CAUSED IN ENTERING')
8761      CALL DPWRST('XXX','BUG ')
8762      WRITE(ICOUT,2303)
8763 2303 FORMAT('      THE LEGEND   INTO THE')
8764      CALL DPWRST('XXX','BUG ')
8765      WRITE(ICOUT,2304)
8766 2304 FORMAT('      INTERNAL DATAPLOT LEGEND   TABLE.')
8767      CALL DPWRST('XXX','BUG ')
8768      WRITE(ICOUT,2305)
8769 2305 FORMAT('      THE TOTAL NUMBER OF CHARACTERS IN THAT')
8770      CALL DPWRST('XXX','BUG ')
8771      WRITE(ICOUT,2306)MXCLEG
8772 2306 FORMAT('      TABLE (FOR ALL LEGEND  S) MAY NOT EXCEED ',
8773     1I8)
8774      CALL DPWRST('XXX','BUG ')
8775      WRITE(ICOUT,2307)
8776 2307 FORMAT('      SUCH AN OVERFLOW CONDITION HAS JUST')
8777      CALL DPWRST('XXX','BUG ')
8778      WRITE(ICOUT,2308)
8779 2308 FORMAT('      BEEN ENCOUNTERED.')
8780      CALL DPWRST('XXX','BUG ')
8781      WRITE(ICOUT,2309)
8782 2309 FORMAT('      THE LEGEND   TABLE HAS JUST BEEN RESET')
8783      CALL DPWRST('XXX','BUG ')
8784      WRITE(ICOUT,2310)
8785 2310 FORMAT('      TO  ITS STATUS BEFORE THE')
8786      CALL DPWRST('XXX','BUG ')
8787      WRITE(ICOUT,2311)
8788 2311 FORMAT('      LAST LEGEND   WAS ATTEMPTED')
8789      CALL DPWRST('XXX','BUG ')
8790      WRITE(ICOUT,2312)
8791 2312 FORMAT('      TO BE ENTERED.')
8792      CALL DPWRST('XXX','BUG ')
8793      WRITE(ICOUT,2313)
8794 2313 FORMAT('      THE TOTAL NUMBER OF CHARACTERS')
8795      CALL DPWRST('XXX','BUG ')
8796      WRITE(ICOUT,2314)
8797 2314 FORMAT('      IN THE LEGEND   TABLE')
8798      CALL DPWRST('XXX','BUG ')
8799      WRITE(ICOUT,2315)NCLEG
8800 2315 FORMAT('      HAS JUST BEEN RESET TO ITS PREVIOUS VALUE =',I8)
8801      CALL DPWRST('XXX','BUG ')
8802      WRITE(ICOUT,2316)
8803 2316 FORMAT('      THE NUMBER OF CHARACTERS IN THE LEGEND  ')
8804      CALL DPWRST('XXX','BUG ')
8805      WRITE(ICOUT,2317)N2
8806 2317 FORMAT('      THAT WAS ATTEMPTED TO BE ENTERED = ',I8)
8807      CALL DPWRST('XXX','BUG ')
8808      WRITE(ICOUT,2318)
8809 2318 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
8810      CALL DPWRST('XXX','BUG ')
8811      WRITE(ICOUT,2319)(IANS(I),I=1,IWIDTH)
8812 2319 FORMAT('      ',100A1)
8813      CALL DPWRST('XXX','BUG ')
8814      WRITE(ICOUT,999)
8815      CALL DPWRST('XXX','BUG ')
8816      WRITE(ICOUT,2321)
8817 2321 FORMAT('      SUGGESTED POSSIBLE SOLUTION--')
8818      CALL DPWRST('XXX','BUG ')
8819      WRITE(ICOUT,2322)
8820 2322 FORMAT('      REDEFINE (SHORTEN) SOME OF THE OTHER ')
8821      CALL DPWRST('XXX','BUG ')
8822      WRITE(ICOUT,2323)
8823 2323 FORMAT('      ALREADY-DEFINED LEGENDS')
8824      CALL DPWRST('XXX','BUG ')
8825      WRITE(ICOUT,2324)
8826 2324 FORMAT('      THAT MAY NO LONGER BE NEEDED')
8827      CALL DPWRST('XXX','BUG ')
8828      WRITE(ICOUT,2325)
8829 2325 FORMAT('      SO THAT THEY ARE ONLY 1 CHARACTER LONG')
8830      CALL DPWRST('XXX','BUG ')
8831      WRITE(ICOUT,2326)
8832 2326 FORMAT('      EXAMPLE--LEGEND 4    ')
8833      CALL DPWRST('XXX','BUG ')
8834      IERROR='YES'
8835      GOTO9000
8836 2390 CONTINUE
8837C
8838C               ***************************************************
8839C               **  STEP 5--                                     **
8840C               **  MOVE THE SEGMENT OF THE STRING IN ILEGTE(.)   **
8841C               **  WHICH IS BEYOND THE LEGEND   OF INTEREST     **
8842C               **  OVER AN APPROPRIATE NUMBER OF SPACES.        **
8843C               ***************************************************
8844C
8845      ISTEPN='5'
8846      IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8847C
8848      IF(NEWNAM.EQ.'YES')GOTO3110
8849      GOTO3120
8850C
8851 3110 CONTINUE
8852      ISTART=NCLEG+1
8853      ISTOP=ISTART+N2-1
8854      GOTO3190
8855C
8856 3120 CONTINUE
8857      ISTART=ILEGST(ILISTL)
8858      ISTOP=ISTART+N2-1
8859      GOTO3190
8860C
8861 3190 CONTINUE
8862C
8863      IF(NEWNAM.EQ.'YES')GOTO3290
8864      KMIN=ISTOP+1
8865      KMAX=NCLEG+IDEL
8866CCCCC JUNE 1994.  FOLLOWING LINE CAUSED SPURIOUS CHARACTERS IF
8867CCCCC HIGHER LEGENDS BLANKED OUT, EARLIER LEGEND LONGER THAN THE
8868CCCCC ORIGINAL.
8869CCCCC IF(KMIN.GT.NCLEG)GOTO3290
8870      IF(IDEL.LE.0)GOTO3210
8871      GOTO3220
8872C
8873 3210 CONTINUE
8874      NCLEGP=NCLEG+1
8875      DO3211K=KMIN,KMAX
8876      L=K-IDEL
8877      IF(L.GE.NCLEGP)GOTO3211
8878      ILEGTE(K)=ILEGTE(L)
8879 3211 CONTINUE
8880      GOTO3290
8881C
8882 3220 CONTINUE
8883      DO3221K=KMIN,KMAX
8884      KREV=KMAX-K+KMIN
8885      L=KREV-IDEL
8886      IF(L.LE.0)GOTO3221
8887      ILEGTE(KREV)=ILEGTE(L)
8888 3221 CONTINUE
8889      GOTO3290
8890C
8891 3290 CONTINUE
8892C
8893C               **************************************************
8894C               **  STEP 6--                                    **
8895C               **  MOVE THE NEW LEGEND   INTO THE APPROPRIATE  **
8896C               **  PLACE IN ILEGTE(.).                          **
8897C               **************************************************
8898C
8899      ISTEPN='6'
8900      IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8901C
8902      L=0
8903      DO4200K=ISTART,ISTOP
8904      L=L+1
8905      ILEGTE(K)=ISTH(L)
8906 4200 CONTINUE
8907C
8908C               ************************************
8909C               **  STEP 7--                      **
8910C               **  REDEFINE NCLEG = THE UPDATED **
8911C               **  LENGTH OF ILEGTE(.).           **
8912C               ************************************
8913C
8914      ISTEPN='7'
8915      IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8916C
8917      NCLEG=N0TEST
8918C
8919C               *************************************************
8920C               **  STEP 8--                                   **
8921C               **  MAKE THE ADJUSTMENTS TO THE INTERNAL LIST  **
8922C               *************************************************
8923C
8924      ISTEPN='8'
8925      IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8926C
8927      IF(NEWNAM.EQ.'YES')GOTO6100
8928      GOTO6200
8929C
8930 6100 CONTINUE
8931      ILEGNA(ILISTL)=ILEGN2
8932      ILEGST(ILISTL)=ISTART
8933      ILEGSP(ILISTL)=ISTOP
8934      NUMLEG=NUMLEG+1
8935      GOTO9000
8936C
8937 6200 CONTINUE
8938      N2OLD=ILEGSP(ILISTL)-ILEGST(ILISTL)+1
8939      IDEL=N2-N2OLD
8940C
8941      DO6210I=1,NUMLEG
8942      IF(ILEGST(I).GT.ISTART)ILEGST(I)=ILEGST(I)+IDEL
8943      IF(ILEGSP(I).GE.ISTART)ILEGSP(I)=ILEGSP(I)+IDEL
8944 6210 CONTINUE
8945      GOTO9000
8946C
8947C               ****************
8948C               **  STEP 90-- **
8949C               **  EXIT.     **
8950C               ****************
8951C
8952 9000 CONTINUE
8953C
8954      ISTEPN='9'
8955      IF(IBUGIL.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8956C
8957      IF(IBUGIL.EQ.'OFF')GOTO9090
8958      WRITE(ICOUT,999)
8959      CALL DPWRST('XXX','BUG ')
8960      WRITE(ICOUT,9011)
8961 9011 FORMAT('***** AT THE END OF DPINLE--')
8962      CALL DPWRST('XXX','BUG ')
8963      WRITE(ICOUT,9012)N2,N2OLD,IDEL,KMIN,KMAX
8964 9012 FORMAT('N2,N2OLD,IDEL,KMIN,KMAX = ',5I8)
8965      CALL DPWRST('XXX','BUG ')
8966      WRITE(ICOUT,9013)NCLEG,MXCLEG,NUMCH0
8967 9013 FORMAT('NCLEG,MXCLEG,NUMCH0 = ',3I8)
8968      CALL DPWRST('XXX','BUG ')
8969      WRITE(ICOUT,9014)(ILEGTE(I),I=1,NCLEG)
8970 9014 FORMAT('ILEGTE(.) = ',55A2)
8971      CALL DPWRST('XXX','BUG ')
8972      WRITE(ICOUT,9015)NEWNAM,ILISTL,NUMLEG
8973 9015 FORMAT('NEWNAM,ILISTL,NUMLEG = ',A4,2I8)
8974      CALL DPWRST('XXX','BUG ')
8975      WRITE(ICOUT,9021)NEWNAM,NUMLEG
8976 9021 FORMAT('NEWNAM,NUMLEG = ',A4,3X,I8)
8977      CALL DPWRST('XXX','BUG ')
8978      DO9022I=1,NUMLEG
8979      WRITE(ICOUT,9023)I,ILEGNA(I),ILEGST(I),ILEGSP(I)
8980 9023 FORMAT('I,ILEGNA(I),ILEGST(I),ILEGSP(I) = ',I4,3X,A4,I8,I8)
8981      CALL DPWRST('XXX','BUG ')
8982 9022 CONTINUE
8983 9090 CONTINUE
8984C
8985      RETURN
8986      END
8987      SUBROUTINE DPINPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
8988     1                  MAXNPP,
8989     1                  ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
8990C
8991C     PURPOSE--FORM AN INTERACTION PLOT, I.E.
8992C              INTERACTION PLOT Y X1 X2
8993C              IS A PLOT OF Y VERSUS X1*X2
8994C     WRITTEN BY--JAMES J. FILLIBEN
8995C                 STATISTICAL ENGINEERING DIVISION
8996C                 INFORMATION TECHNOLOGY LABORATORY
8997C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8998C                 GAITHERSBURG, MD 20899-8980
8999C                 PHONE--301-975-2855
9000C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9001C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9002C     LANGUAGE--ANSI FORTRAN (1977)
9003C     VERSION NUMBER--99/10
9004C     ORIGINAL VERSION--OCTOBER   1999.
9005C     UPDATED         --NOVEMBER  2009. UPDATE PARSING TO USE DPPARS
9006C
9007C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9008C
9009      CHARACTER*4 ICASPL
9010      CHARACTER*4 IAND1
9011      CHARACTER*4 IAND2
9012      CHARACTER*4 ISUBRO
9013      CHARACTER*4 IBUGG2
9014      CHARACTER*4 IBUGG3
9015      CHARACTER*4 IBUGQ
9016      CHARACTER*4 IFOUND
9017      CHARACTER*4 IERROR
9018C
9019      CHARACTER*4 ISTEPN
9020      CHARACTER*4 ISUBN1
9021      CHARACTER*4 ISUBN2
9022C
9023      PARAMETER (MAXSPN=30)
9024      CHARACTER*4 IVARN1(MAXSPN)
9025      CHARACTER*4 IVARN2(MAXSPN)
9026      CHARACTER*4 IVARTY(MAXSPN)
9027      REAL PVAR(MAXSPN)
9028      INTEGER ILIS(MAXSPN)
9029      INTEGER NRIGHT(MAXSPN)
9030      INTEGER ICOLR(MAXSPN)
9031      CHARACTER*40 INAME
9032C
9033C-----COMMON----------------------------------------------------------
9034C
9035      INCLUDE 'DPCOPA.INC'
9036      INCLUDE 'DPCOHK.INC'
9037      INCLUDE 'DPCODA.INC'
9038      INCLUDE 'DPCOP2.INC'
9039C
9040C-----START POINT-----------------------------------------------------
9041C
9042      ISUBN1='DPIN'
9043      ISUBN2='PL  '
9044      IFOUND='YES'
9045      IAND2='NO'
9046      ICASPL='INTE'
9047C
9048      MAXCP1=MAXCOL+1
9049      MAXCP2=MAXCOL+2
9050      MAXCP3=MAXCOL+3
9051      MAXCP4=MAXCOL+4
9052      MAXCP5=MAXCOL+5
9053      MAXCP6=MAXCOL+6
9054C
9055      ATEMP=CPUMIN
9056C
9057      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'INPL')THEN
9058        WRITE(ICOUT,999)
9059  999   FORMAT(1X)
9060        CALL DPWRST('XXX','BUG ')
9061        WRITE(ICOUT,51)
9062   51   FORMAT('***** AT THE BEGINNING OF DPINPL--')
9063        CALL DPWRST('XXX','BUG ')
9064        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXNPP,NS
9065   53   FORMAT('ICASPL,IAND1,IAND2,MAXNPP,NS = ',3(A4,2X),2I8)
9066        CALL DPWRST('XXX','BUG ')
9067        WRITE(ICOUT,54)IBUGG3,IBUGG2,ISUBRO,IFOUND,IERROR
9068   54   FORMAT('IBUGG3,IBUGG2,ISUBRO,IFOUND,IERROR = ',4(A4,2X),A4)
9069        CALL DPWRST('XXX','BUG ')
9070      ENDIF
9071C
9072C               ***************************
9073C               **  STEP 1--             **
9074C               **  EXTRACT THE COMMAND  **
9075C               ***************************
9076C
9077      ISTEPN='1'
9078      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INPL')
9079     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9080C
9081      IF(NUMARG.LT.1)GOTO9000
9082C
9083C               *********************************
9084C               **  STEP 2--                   **
9085C               **  EXTRACT THE VARIABLE LIST  **
9086C               *********************************
9087C
9088      INAME='INTERACTION PLOT'
9089      MINNA=1
9090      MAXNA=100
9091      MINN2=2
9092      IFLAGE=1
9093      IFLAGM=0
9094      IFLAGP=0
9095      JMIN=1
9096      JMAX=NUMARG
9097      MINNVA=2
9098      MAXNVA=MAXSPN
9099C
9100      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
9101     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
9102     1            JMIN,JMAX,
9103     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
9104     1            IVARN1,IVARN2,IVARTY,PVAR,
9105     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
9106     1            MINNVA,MAXNVA,
9107     1            IFLAGM,IFLAGP,
9108     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
9109      IF(IERROR.EQ.'YES')GOTO9000
9110C
9111      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'INPL')THEN
9112        WRITE(ICOUT,999)
9113        CALL DPWRST('XXX','BUG ')
9114        WRITE(ICOUT,281)
9115  281   FORMAT('***** AFTER CALL DPPARS--')
9116        CALL DPWRST('XXX','BUG ')
9117        WRITE(ICOUT,282)NQ,NUMVAR
9118  282   FORMAT('NQ,NUMVAR = ',2I8)
9119        CALL DPWRST('XXX','BUG ')
9120        IF(NUMVAR.GT.0)THEN
9121          DO285I=1,NUMVAR
9122            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
9123     1                      ICOLR(I)
9124  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
9125     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
9126            CALL DPWRST('XXX','BUG ')
9127  285     CONTINUE
9128        ENDIF
9129      ENDIF
9130C
9131C               *******************************************************
9132C               **  STEP 16--                                        **
9133C               **  FORM THE PLOT COORIDINATES                       **
9134C               *******************************************************
9135C
9136      ISTEPN='15.2'
9137      IF(ISUBRO.EQ.'INPL'.OR.IBUGG3.EQ.'ON')
9138     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9139C
9140      L=0
9141      NLOCAL=NRIGHT(1)
9142C
9143      DO1520I=1,NLOCAL
9144        IF(ISUB(I).EQ.0)GOTO1520
9145        L=L+1
9146C
9147        IF(L.GT.MAXNPP)THEN
9148          IERROR='YES'
9149          WRITE(ICOUT,999)
9150          CALL DPWRST('XXX','BUG ')
9151          WRITE(ICOUT,1521)
9152 1521     FORMAT('***** ERROR IN INTERACTION PLOT--')
9153          CALL DPWRST('XXX','BUG ')
9154          WRITE(ICOUT,1523)MAXNPP
9155 1523     FORMAT('      THE NUMBER OF PLOT POINTS HAS JUST EXCEEDED ',
9156     1           I8)
9157          CALL DPWRST('XXX','BUG ')
9158C
9159          IF(ISUBRO.EQ.'INPL' .OR. IBUGG2.EQ.'ON')THEN
9160             WRITE(ICOUT,1525)I,NLOCAL,L,MAXN,MAXNPP,NPLOTP
9161 1525        FORMAT('I,NLOCAL,L,MAXN,MAXNPP,NPLOTP = ',6I8)
9162             CALL DPWRST('XXX','BUG ')
9163          ENDIF
9164C
9165          GOTO9000
9166        ENDIF
9167C
9168        IVAV=ICOLR(1)
9169        IJ=MAXN*(IVAV-1)+I
9170        IF(IVAV.LE.MAXCOL)Y(L)=V(IJ)
9171        IF(IVAV.EQ.MAXCP1)Y(L)=PRED(I)
9172        IF(IVAV.EQ.MAXCP2)Y(L)=RES(I)
9173        IF(IVAV.EQ.MAXCP3)Y(L)=YPLOT(I)
9174        IF(IVAV.EQ.MAXCP4)Y(L)=XPLOT(I)
9175        IF(IVAV.EQ.MAXCP5)Y(L)=X2PLOT(I)
9176        IF(IVAV.EQ.MAXCP6)Y(L)=TAGPLO(I)
9177        X(L)=1.0
9178C
9179        IF(NUMVAR.GE.2)THEN
9180          DO1530K=2,NUMVAR
9181            IVAV=ICOLR(K)
9182            IJ=MAXN*(IVAV-1)+I
9183            IF(IVAV.LE.MAXCOL)ATEMP=V(IJ)
9184            IF(IVAV.EQ.MAXCP1)ATEMP=PRED(I)
9185            IF(IVAV.EQ.MAXCP2)ATEMP=RES(I)
9186            IF(IVAV.EQ.MAXCP3)ATEMP=YPLOT(I)
9187            IF(IVAV.EQ.MAXCP4)ATEMP=XPLOT(I)
9188            IF(IVAV.EQ.MAXCP5)ATEMP=X2PLOT(I)
9189            IF(IVAV.EQ.MAXCP6)ATEMP=TAGPLO(I)
9190            X(L)=X(L)*ATEMP
9191 1530     CONTINUE
9192C
9193          D(L)=1.0
9194          NPLOTP=L
9195        ENDIF
9196C
9197 1520 CONTINUE
9198      NPLOTV=2
9199      GOTO9000
9200C
9201C               *****************
9202C               **  STEP 90--  **
9203C               **  EXIT       **
9204C               *****************
9205C
9206 9000 CONTINUE
9207      IF(ISUBRO.EQ.'INPL' .OR. IBUGG3.EQ.'ON')THEN
9208        WRITE(ICOUT,999)
9209        CALL DPWRST('XXX','BUG ')
9210        WRITE(ICOUT,9011)
9211 9011   FORMAT('***** AT THE END       OF DPINPL--')
9212        CALL DPWRST('XXX','BUG ')
9213        WRITE(ICOUT,9012)IFOUND,IERROR,MAXNPP
9214 9012   FORMAT('IFOUND,IERROR,MAXNPP = ',2(A4,2X),I8)
9215        CALL DPWRST('XXX','BUG ')
9216        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2
9217 9013   FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ',
9218     1         3I8,2X,2(A4,2X),A4)
9219        CALL DPWRST('XXX','BUG ')
9220        WRITE(ICOUT,9020)
9221 9020   FORMAT('I,Y(.),X(.),D(.),ISUB(.)--')
9222        CALL DPWRST('XXX','BUG ')
9223        DO9021I=1,NPLOTP
9224          WRITE(ICOUT,9022)I,Y(I),X(I),D(I),ISUB(I)
9225 9022     FORMAT(I8,F15.7,F15.7,F15.7,I8)
9226          CALL DPWRST('XXX','BUG ')
9227 9021   CONTINUE
9228      ENDIF
9229C
9230      RETURN
9231      END
9232      SUBROUTINE DPINQU(IBUGA3,ISUBRO,IFOUND,IERROR)
9233C
9234C     PURPOSE--SUPPORTS THE FOLLOWING COMMAND:
9235C
9236C                 LET IFLAG = INQUIRE <FILE>
9237C
9238C              WHERE IFLAG IS SET TO "1" IF FILE EXISTS AND SET TO "0"
9239C              IF IT DOES NOT.
9240C     WRITTEN BY--ALAN HECKERT
9241C                 STATISTICAL ENGINEERING DIVISION
9242C                 INFORMATION TECHNOLOGY LABORATORY
9243C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9244C                 GAITHERSBURG, MD 20899-8980
9245C                 PHONE--301-975-2899
9246C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9247C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9248C     LANGUAGE--ANSI FORTRAN (1977)
9249C     VERSION NUMBER--2015/12
9250C     ORIGINAL VERSION--DECEMBER  2015.
9251C     UPDATED         --FEBRUARY  2016. SUPPORT QUOTES
9252C     UPDATED         --JUNE      2016. SUPPORT FOR INTEGER VALUE
9253C
9254C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9255C
9256      CHARACTER*4 IBUGA3
9257      CHARACTER*4 ISUBRO
9258      CHARACTER*4 IFOUND
9259      CHARACTER*4 IERROR
9260C
9261      CHARACTER*4 IOFILE
9262      CHARACTER*4 IHLEFT
9263      CHARACTER*4 IHLEF2
9264      CHARACTER*4 NEWNAM
9265      CHARACTER*4 NEWCOL
9266      CHARACTER*4 ISUBN0
9267      CHARACTER*4 ISUBN1
9268      CHARACTER*4 ISUBN2
9269      CHARACTER*4 ISTEPN
9270      CHARACTER*4 IEXIST
9271      CHARACTER*4 IOPEN
9272      CHARACTER*8 IACC
9273      CHARACTER*4 IFILSV
9274      CHARACTER*4 IH
9275      CHARACTER*4 IH2
9276C
9277      INCLUDE 'DPCOPA.INC'
9278C
9279CCCCC CHARACTER*80 IFILE
9280CCCCC CHARACTER*255 ICANS
9281      CHARACTER (LEN=MAXFNC) :: IFILE
9282      CHARACTER (LEN=MAXSTR) :: ICANS
9283C
9284      LOGICAL LEXIST
9285      LOGICAL LOPEN
9286C
9287C-----COMMON VARIABLES (GENERAL)--------------------------------------
9288C
9289      INCLUDE 'DPCOHK.INC'
9290      INCLUDE 'DPCODA.INC'
9291      INCLUDE 'DPCOST.INC'
9292      INCLUDE 'DPCOHO.INC'
9293      INCLUDE 'DPCOP2.INC'
9294C
9295C-----START POINT-----------------------------------------------------
9296C
9297      ISUBN0='INQU'
9298      ISUBN1='DPIN'
9299      ISUBN2='QU  '
9300      IFOUND='YES'
9301      IERROR='NO'
9302      IEXIST='NO'
9303      IFILSV=IFILQU
9304      IFILQU='ON'
9305C
9306      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')THEN
9307        WRITE(ICOUT,999)
9308  999   FORMAT(1X)
9309        CALL DPWRST('XXX','BUG ')
9310        WRITE(ICOUT,51)
9311   51   FORMAT('***** AT THE BEGINNING OF DPINQU--')
9312        CALL DPWRST('XXX','BUG ')
9313      ENDIF
9314C
9315C               ****************************************************
9316C               **  STEP 1--                                      **
9317C               **  CHECK FOR VALID COMMAND.                      **
9318C               ****************************************************
9319C
9320      ISTEPN='1'
9321      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')
9322     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9323C
9324      IF(IHARG(2).NE.'=' .OR. IHARG(3).NE.'INQU')THEN
9325        WRITE(ICOUT,999)
9326        CALL DPWRST('XXX','BUG ')
9327        WRITE(ICOUT,101)
9328  101   FORMAT('***** ERROR IN INQUIRE COMMAND--')
9329        CALL DPWRST('XXX','BUG ')
9330        WRITE(ICOUT,103)
9331  103   FORMAT('      INVALID FORM FOR THE COMMAND.')
9332        CALL DPWRST('XXX','BUG ')
9333        IERROR='YES'
9334        GOTO9000
9335      ENDIF
9336C
9337C               *********************************************************
9338C               **  STEP 2--                                            *
9339C               **  EXAMINE THE LEFT-HAND SIDE--                        *
9340C               **  IS THE PARAMETER NAME TO LEFT OF = SIGN             *
9341C               **  ALREADY IN THE NAME LIST?                           *
9342C               **  NOTE THAT     IHLEFT    IS THE NAME OF THE VARIABLE *
9343C               **  ON THE LEFT.                                        *
9344C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE    *
9345C               **  OF THE NAME ON THE LEFT.                            *
9346C               **  NOTE THAT     ICOLL    IS THE DATA COLUMN (1 TO 12) *
9347C               **  FOR THE NAME OF THE LEFT.                           *
9348C               *********************************************************
9349C
9350      ISTEPN='2'
9351      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')
9352     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9353C
9354      NEWNAM='NO'
9355      NEWCOL='NO'
9356      IHLEFT=IHARG(1)
9357      IHLEF2=IHARG2(1)
9358      DO200I=1,NUMNAM
9359        I2=I
9360        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
9361          IF(IUSE(I).EQ.'P')THEN
9362            ILISTL=I2
9363            GOTO290
9364          ELSE
9365            WRITE(ICOUT,999)
9366            CALL DPWRST('XXX','BUG ')
9367            WRITE(ICOUT,101)
9368            CALL DPWRST('XXX','BUG ')
9369            WRITE(ICOUT,201)
9370  201       FORMAT('      THE NAME ON THE LEFT HAND SIDE WAS FOUND IN')
9371            CALL DPWRST('XXX','BUG ')
9372            WRITE(ICOUT,202)
9373  202       FORMAT('      THE NAME TABLE, BUT NOT AS A PARAMETER.')
9374            CALL DPWRST('XXX','BUG ')
9375            IERROR='YES'
9376            GOTO9000
9377          ENDIF
9378        ENDIF
9379  200 CONTINUE
9380C
9381      ISTEPN='2B'
9382      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')
9383     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9384C
9385      NEWNAM='YES'
9386      ILISTL=NUMNAM+1
9387      IF(ILISTL.GT.MAXNAM)THEN
9388        WRITE(ICOUT,999)
9389        CALL DPWRST('XXX','BUG ')
9390        WRITE(ICOUT,101)
9391        CALL DPWRST('XXX','BUG ')
9392        WRITE(ICOUT,222)
9393  222   FORMAT('      THE NUMBER OF VARIABLE AND/OR PARAMETER NAMES ',
9394     1         'HAS JUST')
9395        CALL DPWRST('XXX','BUG ')
9396        WRITE(ICOUT,223)MAXNAM
9397  223   FORMAT('      EXCEEDED THE MAX ALLOWABLE ',I8,'  .  ')
9398        CALL DPWRST('XXX','BUG ')
9399        IERROR='YES'
9400        GOTO9000
9401      ENDIF
9402C
9403  290 CONTINUE
9404C               ********************************************************
9405C               **  STEP 3--                                          **
9406C               **  EXTRACT THE FILE NAME                             **
9407C               ********************************************************
9408C
9409      ISTEPN='3'
9410      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')
9411     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9412C
9413C     2016/02: DATAPLOT COMMANDS THAT USE FILE NAMES HAVE A COUPLE OF
9414C              SPECIFIC CRITERION:
9415C
9416C                 1. A "." IS REQUIRED IN THE NAME TO IDENTIFY THE
9417C                    STRING AS A FILE.  THE INQUIRE COMMAND DOES NOT
9418C                    HAVE THIS RESTRICTION.
9419C
9420C                 2. FILE NAMES THAT CONTAIN SPACES OR HYPHENS SHOULD
9421C                    BE ENCLOSED IN QUOTES.  THIS ALSO APPLIES TO THE
9422C                    INQUIRE COMMAND.
9423C
9424C                 3. DATAPLOT WILL LOOK IN THE DATAPLOT AUXILLARY
9425C                    DIRECTORIES IF IT DOES FIND THE FILE IN CURRENT
9426C                    DIRECTORY.  IN ADDITION, DATAPLOT WILL CHECK FOR
9427C                    ALL LOWER CASE OR ALL UPPER CASE CHARACTERS IN
9428C                    THE NAME.  THE INQUIRE COMMAND WILL ONLY CHECK THE
9429C                    FILE NAME AS GIVEN.
9430C
9431C     2016/06: CHECK IF THE ARGUMENT TYPE IS NUMERIC.  CAN DO AN INQUIRE
9432C              OF A UNIT NUMBER.
9433C
9434      IWORD=5
9435      IF(IARGT(IWORD-1).EQ.'NUMB')THEN
9436        IUNIT=INT(ARG(IWORD-1)+0.1)
9437        IF(IUNIT.LT.1 .OR. IUNIT.GT.99)THEN
9438          IEXIST='NO'
9439        ELSE
9440          INQUIRE(UNIT=IUNIT,EXIST=LEXIST,OPENED=LOPEN,ACTION=IACC)
9441          IEXIST='NO'
9442          IOPEN='NO'
9443          IF(LEXIST)IEXIST='YES'
9444          IF(LOPEN)IOPEN='YES'
9445        ENDIF
9446        GOTO400
9447      ENDIF
9448C
9449CCCCC CALL DPFILE(IANSLC,IWIDTH,IWORD,
9450CCCCC1            IOFILE,IBUGA3,ISUBRO,IERROR)
9451      IOFILE='YES'
9452C
9453      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')THEN
9454        WRITE(ICOUT,301)IWORD,IWIDTH,IOFILE
9455  301   FORMAT('IWORD,IWIDTH,IOFILE = ',2I8,2X,A4)
9456        CALL DPWRST('XXX','BUG ')
9457      ENDIF
9458C
9459C               **********************************************
9460C               **  STEP 31--                               **
9461C               **  IF NO FILE NAME GIVEN,                  **
9462C               **  THEN GENERATE AN ERROR MESSAGE.         **
9463C               **********************************************
9464C
9465      ISTEPN='31'
9466      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')
9467     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9468C
9469      IF(IOFILE.EQ.'NO')THEN
9470        WRITE(ICOUT,999)
9471        CALL DPWRST('XXX','BUG ')
9472        WRITE(ICOUT,101)
9473        CALL DPWRST('XXX','BUG ')
9474        WRITE(ICOUT,312)
9475  312   FORMAT('      NO FILE NAME WAS GIVEN.')
9476        CALL DPWRST('XXX','BUG ')
9477        IERROR='YES'
9478        GOTO9000
9479      ENDIF
9480C
9481C               *************************************
9482C               **  STEP 32--                      **
9483C               **  COPY THE FILE INTO THE STRING  **
9484C               **  "FILE"                         **
9485C               *************************************
9486C
9487      ISTEPN='32'
9488      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')
9489     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9490C
9491      DO320I=1,MAXSTR
9492        ICANS(I:I)=IANSLC(I)(1:1)
9493  320 CONTINUE
9494C
9495      NCFILE=0
9496      IFILE=' '
9497      ISTART=1
9498      ISTOP=IWIDTH
9499      IWORD=5
9500      CALL DPEXWO(ICANS,ISTART,ISTOP,IWORD,
9501     1            ICOL1,ICOL2,IFILE,NCFILE,
9502     1            IBUGA3,ISUBRO,IERROR)
9503C
9504      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')THEN
9505        WRITE(ICOUT,321)NCFILE,IFILE
9506  321   FORMAT('NCFILE,IFILE = ',I6,2X,A80)
9507        CALL DPWRST('XXX','BUG ')
9508      ENDIF
9509C
9510      IF(NCFILE.GE.3)THEN
9511        IF(IFILE(1:1).EQ.'"' .AND. IFILE(NCFILE:NCFILE).EQ.'"')THEN
9512          ICNT=0
9513          DO401J=2,NCFILE-1
9514            ICNT=ICNT+1
9515            IFILE(ICNT:ICNT)=IFILE(J:J)
9516 401      CONTINUE
9517          NCFILE=NCFILE-2
9518          IFILE(NCFILE+1:NCFILE+2)=' '
9519        ENDIF
9520      ENDIF
9521C
9522      IF(IERROR.EQ.'YES')GOTO9000
9523C
9524      IF(NCFILE.LT.1)THEN
9525        WRITE(ICOUT,999)
9526        CALL DPWRST('XXX','BUG ')
9527        WRITE(ICOUT,101)
9528        CALL DPWRST('XXX','BUG ')
9529        WRITE(ICOUT,322)
9530  322   FORMAT('      A USER FILE NAME IS REQUIRED IN THE ',
9531     1         'LET ... = INQUIRE ...  COMMAND')
9532        CALL DPWRST('XXX','BUG ')
9533        WRITE(ICOUT,324)
9534  324   FORMAT('      (FOR EXAMPLE,    LET Y = INQUIRE  SAMPLE.TXT)')
9535        CALL DPWRST('XXX','BUG ')
9536        WRITE(ICOUT,325)
9537  325   FORMAT('      BUT NONE WAS GIVEN HERE.')
9538        CALL DPWRST('XXX','BUG ')
9539        WRITE(ICOUT,326)
9540  326   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
9541        CALL DPWRST('XXX','BUG ')
9542        IF(IWIDTH.GE.1)THEN
9543          WRITE(ICOUT,327)(IANSLC(I),I=1,MIN(IWIDTH,100))
9544  327     FORMAT('      ',100A1)
9545          CALL DPWRST('XXX','BUG ')
9546        ELSE
9547          WRITE(ICOUT,999)
9548          CALL DPWRST('XXX','BUG ')
9549        ENDIF
9550        IERROR='YES'
9551        GOTO9000
9552      ENDIF
9553C
9554      IF(IERROR.EQ.'YES')GOTO9000
9555C
9556C               ******************************************
9557C               **  STEP 33--                           **
9558C               **  INQUIRE ABOUT EXISTENCE OF          **
9559C               **  SPECIFIED FILE                      **
9560C               ******************************************
9561C
9562      ISTEPN='33'
9563      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')
9564     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9565C
9566      CALL DPINFI(IFILE,IEXIST,IOPEN,IACC,ISUBN0,IBUGA3,ISUBRO,IERROR)
9567C
9568C               *******************************************
9569C               **  STEP 4--                             **
9570C               **  UPDATE THE LHS PARAMETER             **
9571C               *******************************************
9572C
9573  400 CONTINUE
9574C
9575      ISTEPN='4'
9576      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')
9577     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9578C
9579CCCCC IHNAME(ILISTL)=IHLEFT
9580CCCCC IHNAM2(ILISTL)=IHLEF2
9581CCCCC IUSE(ILISTL)='P'
9582CCCCC VALUE(ILISTL)=1.0
9583CCCCC IF(IEXIST.EQ.'NO')VALUE(ILISTL)=0.0
9584CCCCC IVALUE(ILISTL)=VALUE(ILISTL)+0.5
9585CCCCC IN(ILISTL)=1
9586CCCCC IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
9587C
9588      IF(IEXIST.EQ.'NO')THEN
9589        VALUE0=0.0
9590      ELSE
9591        VALUE0=1.0
9592        IF(IOPEN.EQ.'YES')VALUE0=2.0
9593      ENDIF
9594      CALL DPADDP(IHLEFT,IHLEF2,VALUE0,IHOST1,ISUBN0,
9595     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
9596     1            IANS,IWIDTH,IBUGA3,IERROR)
9597C
9598      IH='FILE'
9599      IH2='ACCE'
9600      IF(IACC.EQ.'READWRIT')THEN
9601        VALUE0=1.0
9602      ELSEIF(IACC.EQ.'READ')THEN
9603        VALUE0=2.0
9604      ELSEIF(IACC.EQ.'WRITE')THEN
9605        VALUE0=3.0
9606      ELSE
9607        VALUE0=0.0
9608      ENDIF
9609      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
9610     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
9611     1            IANS,IWIDTH,IBUGA3,IERROR)
9612C
9613      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
9614        WRITE(ICOUT,999)
9615        CALL DPWRST('XXX','BUG ')
9616        IF(IEXIST.EQ.'YES')THEN
9617          WRITE(ICOUT,601)IHLEFT,IHLEF2,IVALUE(ILISTL)
9618  601     FORMAT('THE SPECIFIED FILE EXISTS, THE PARAMETER ',
9619     1           A4,A4,' = ',I8)
9620          CALL DPWRST('XXX','BUG ')
9621        ELSE
9622          WRITE(ICOUT,602)IHLEFT,IHLEF2,IVALUE(ILISTL)
9623  602     FORMAT('THE SPECIFIED FILE DOES NOT EXIST, THE PARAMETER ',
9624     1           A4,A4,' = ',I8)
9625          CALL DPWRST('XXX','BUG ')
9626        ENDIF
9627        WRITE(ICOUT,999)
9628        CALL DPWRST('XXX','BUG ')
9629      ENDIF
9630C
9631C               ****************
9632C               **  STEP 90-- **
9633C               **  EXIT.     **
9634C               ****************
9635C
9636 9000 CONTINUE
9637C
9638      IFILQU=IFILSV
9639C
9640      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INQU')THEN
9641        WRITE(ICOUT,999)
9642        CALL DPWRST('XXX','BUG ')
9643        WRITE(ICOUT,9011)
9644 9011   FORMAT('***** AT THE END       OF DPINQU--')
9645        CALL DPWRST('XXX','BUG ')
9646        WRITE(ICOUT,9013)IFOUND,IERROR,IEXIST,IOPEN,IACC
9647 9013   FORMAT('IFOUND,IERROR,IEXIST,IOPEN,IACC = ',4(A4,2X),A8)
9648        CALL DPWRST('XXX','BUG ')
9649      ENDIF
9650C
9651      RETURN
9652      END
9653      SUBROUTINE DPINT2(MODEL,NUMCHA,PARAM,IPARN,IPARN2,NUMPV,
9654     1                  IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
9655     1                  IVARN,IVARN2,NUMVAR,XMIN,XMAX,XINT,
9656     1                  IFLGFB,IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
9657     1                  NUMNAM,MAXNAM,IFTEXP,IFTORD,IFORSW,
9658     1                  PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,V,MAXN,
9659     1                  MAXCOL,MAXCP1,MAXCP2,MAXCP3,MAXCP4,MAXCP5,
9660     1                  MAXCP6,
9661     1                  IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR)
9662C
9663C     2015/09: ADD LINES TO ARGUMENT LIST FOR FUNCTION BLOCK
9664C              AUGMENTATION
9665C
9666C     PURPOSE--COMPUTE THE INTEGRAL OF A FUNCTION
9667C              FROM THE LIMITS XMIN TO XMAX.
9668C     WRITTEN BY--JAMES J. FILLIBEN
9669C                 STATISTICAL ENGINEERING DIVISION
9670C                 INFORMATION TECHNOLOGY LABORATORY
9671C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
9672C                 GAITHERSBURG, MD 20899-8980
9673C                 PHONE--301-975-2855
9674C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
9675C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
9676C     LANGUAGE--ANSI FORTRAN (1977)
9677C     VERSION NUMBER--82/7
9678C     ORIGINAL VERSION--NOVEMBER  1978.
9679C     UPDATED         --JULY      1981.
9680C     UPDATED         --MARCH     1982.
9681C     UPDATED         --MAY       1982.
9682C     UPDATED         --SEPTEMBER 2015. SUPPORT FUNCTION BLOCKS
9683C
9684C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9685C
9686      CHARACTER*4 MODEL
9687      CHARACTER*4 IPARN
9688      CHARACTER*4 IPARN2
9689      CHARACTER*4 IANGLU
9690      CHARACTER*4 IFTEXP
9691      CHARACTER*4 IFTORD
9692      CHARACTER*4 IFORSW
9693      CHARACTER*4 ITYPEH
9694      CHARACTER*4 IW21HO
9695      CHARACTER*4 IW22HO
9696      CHARACTER*4 IVARN
9697      CHARACTER*4 IVARN2
9698      CHARACTER*4 IBUGA3
9699      CHARACTER*4 IBUGCO
9700      CHARACTER*4 IBUGEV
9701      CHARACTER*4 ISUBRO
9702      CHARACTER*4 IERROR
9703C
9704      CHARACTER*4 IH
9705      CHARACTER*4 IH2
9706C
9707      CHARACTER*4 ISUBN1
9708      CHARACTER*4 ISUBN2
9709      CHARACTER*4 IFOUND
9710C
9711C---------------------------------------------------------------------
9712C
9713      DOUBLE PRECISION W,Z
9714      DOUBLE PRECISION DMIN,DMAX,DNUMSE,DINT,DJ,DELTA2,DMIN2,DMAX2
9715      DOUBLE PRECISION DB0,DB1,DSUM2,DX,DY,DINT2
9716C
9717      DIMENSION MODEL(*)
9718      DIMENSION PARAM(*)
9719      DIMENSION IPARN(*)
9720      DIMENSION IPARN2(*)
9721      DIMENSION IVARN(*)
9722      DIMENSION IVARN2(*)
9723C
9724      DIMENSION ITYPEH(*)
9725      DIMENSION IW21HO(*)
9726      DIMENSION IW22HO(*)
9727      DIMENSION W2HOLD(*)
9728C
9729      DIMENSION PRED(*)
9730      DIMENSION RES(*)
9731      DIMENSION XPLOT(*)
9732      DIMENSION YPLOT(*)
9733      DIMENSION X2PLOT(*)
9734      DIMENSION TAGPLO(*)
9735      DIMENSION V(*)
9736C
9737      DIMENSION IN(*)
9738      DIMENSION IVALUE(*)
9739      DIMENSION VALUE(*)
9740C
9741      CHARACTER*4 IHNAME(*)
9742      CHARACTER*4 IHNAM2(*)
9743      CHARACTER*4 IUSE(*)
9744C
9745      DIMENSION ILOCV(10)
9746C
9747      DIMENSION W(16)
9748      DIMENSION Z(16)
9749C
9750C     2015/08: FUNCTION BLOCK
9751C
9752      INCLUDE 'DPCOFB.INC'
9753C
9754      CHARACTER*8 IFBNAM
9755      CHARACTER*8 IFBANS
9756C
9757      COMMON/IFBL2/IFLGF2
9758C
9759      CHARACTER*4 IFEESV
9760      COMMON/IFEED/IFEESV
9761C
9762C---------------------------------------------------------------------
9763C
9764      INCLUDE 'DPCOP2.INC'
9765C
9766C-----DATA STATEMENTS-------------------------------------------------
9767C
9768      DATA Z(1),Z(2),Z(3),Z(4),Z(5),Z(6),Z(7),Z(8)
9769     1                   /-0.98940093499165D0,-0.944575023073233D0,
9770     1-0.865631202387832D0,-0.755404408355003D0,-0.617876244402644D0,
9771     1-0.458016777657227D0,-0.281603550779259D0,-0.095012509837637D0/
9772      DATA Z(9),Z(10),Z(11),Z(12),Z(13),Z(14),Z(15),Z(16)
9773     1/0.095012509837637D0,0.281603550779259D0,0.458016777657227D0,
9774     10.617876244402644D0,0.755404408355003D0,0.865631202387832D0,
9775     10.944575023073233D0,0.989400934991650D0/
9776      DATA W(1),W(2),W(3),W(4),W(5),W(6),W(7),W(8)
9777     1                  /0.027152459411754D0,0.062253523938648D0,
9778     10.095158511682493D0,0.124628971255534D0,0.149595988816577D0,
9779     10.169156519395003D0,0.182603415044924D0,0.189450610455069D0/
9780      DATA W(9),W(10),W(11),W(12),W(13),W(14),W(15),W(16)
9781     1/0.189450610455069D0,0.182603415044924D0,0.169156519395003D0,
9782     10.149595988816577D0,0.124628971255534D0,0.095158511682493D0,
9783     10.062253523938648D0,0.027152459411754D0/
9784C
9785C-----START POINT-----------------------------------------------------
9786C
9787      ISUBN1='DPIN'
9788      ISUBN2='T2  '
9789      IFOUND='NO  '
9790C
9791      CUTOFF=0.001
9792      ACCUR=0.0000001
9793      MAXSEG=20
9794      IPASS=2
9795      J2=0
9796      IFLGF2=IFLGFB
9797C
9798      ABSXIN=0.0
9799      XINT2=0.0
9800      DIFF=0.0
9801      RATIO=0.0
9802C
9803      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'INT2')THEN
9804        WRITE(ICOUT,999)
9805  999   FORMAT(1X)
9806        CALL DPWRST('XXX','BUG ')
9807        WRITE(ICOUT,51)
9808   51   FORMAT('***** AT THE BEGINNING OF DPINT2--')
9809        CALL DPWRST('XXX','BUG ')
9810        WRITE(ICOUT,52)IBUGA3,IBUGCO,IBUGEV,ISUBRO,IANGLU
9811   52   FORMAT('IBUGA3,IBUGCO,IBUGEV,ISUBRO,IANGLU = ',4(A4,2X),A4)
9812        CALL DPWRST('XXX','BUG ')
9813        WRITE(ICOUT,53)NUMCHA,NUMPV,NUMVAR,XMIN,XMAX
9814   53   FORMAT('NUMCHA,NUMPV,NUMVAR,XMIN,XMAX = ',3I8,2G15.7)
9815        CALL DPWRST('XXX','BUG ')
9816        WRITE(ICOUT,54)(MODEL(J),J=1,MIN(100,NUMCHA))
9817   54   FORMAT('MODEL(I) = ',100A1)
9818        CALL DPWRST('XXX','BUG ')
9819        DO55I=1,NUMPV
9820          WRITE(ICOUT,56)I,PARAM(I),IPARN(I),IPARN2(I)
9821   56     FORMAT('I,PARAM(I),IPARN(I),IPARN2(I) = ',I8,G15.7,2A4)
9822          CALL DPWRST('XXX','BUG ')
9823   55   CONTINUE
9824        DO60I=1,NUMVAR
9825          WRITE(ICOUT,61)I,IN(I),IVARN(I),IVARN2(I)
9826   61     FORMAT('I,IN(I),IVARN(I) = ',2I8,2X,2A4)
9827          CALL DPWRST('XXX','BUG ')
9828   60   CONTINUE
9829      ENDIF
9830C
9831C               ***************************************************
9832C               **  STEP 1--                                     **
9833C               **  DETERMINE THE LOCATIONS (IN THE LIST IPARN)  **
9834C               **  OF THE VARIABLES OF INTEGRATION.             **
9835C               ***************************************************
9836C
9837      IF(IFLGFB.LE.0)THEN
9838        DO100I=1,NUMVAR
9839          IH=IVARN(I)
9840          IH2=IVARN2(I)
9841          DO200J=1,NUMPV
9842            J2=J
9843            IF(IH.EQ.IPARN(J).AND.IH2.EQ.IPARN2(J))GOTO210
9844  200     CONTINUE
9845  210     CONTINUE
9846          ILOCV(I)=J2
9847  100   CONTINUE
9848      ENDIF
9849C
9850      IFBNAM=' '
9851      IFBANS=' '
9852      IF(IFLGFB.EQ.1)THEN
9853        IFBNAM=IFBNA1
9854        IFBANS=IFBAN1
9855        IH=IFBPL1(1)(1:4)
9856        IH2=IFBPL1(1)(5:8)
9857      ELSEIF(IFLGFB.EQ.2)THEN
9858        IFBNAM=IFBNA2
9859        IFBANS=IFBAN2
9860        IH=IFBPL2(1)(1:4)
9861        IH2=IFBPL2(1)(5:8)
9862      ELSEIF(IFLGFB.EQ.3)THEN
9863        IFBNAM=IFBNA3
9864        IFBANS=IFBAN3
9865        IH=IFBPL3(1)(1:4)
9866        IH2=IFBPL3(1)(5:8)
9867      ENDIF
9868C
9869C               **************************************************
9870C               **  STEP 2--                                    **
9871C               **  WRITE OUT  PRELIMINARY SUMMARY INFORMATION  **
9872C               **************************************************
9873C
9874      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
9875        WRITE(ICOUT,999)
9876        CALL DPWRST('XXX','BUG ')
9877        WRITE(ICOUT,401)
9878  401   FORMAT('INTEGRAL EVALUATION')
9879        CALL DPWRST('XXX','BUG ')
9880        IF(IFLGFB.LE.0)THEN
9881          WRITE(ICOUT,402)(MODEL(I),I=1,MIN(80,NUMCHA))
9882  402     FORMAT('      FUNCTION--',80A1)
9883          CALL DPWRST('XXX','BUG ')
9884        ENDIF
9885        WRITE(ICOUT,403)XMIN
9886  403   FORMAT('      SPECIFIED LOWER LIMIT OF INTEGRAL  = ',F20.10)
9887        CALL DPWRST('XXX','BUG ')
9888        WRITE(ICOUT,404)XMAX
9889  404   FORMAT('      SPECIFIED UPPER LIMIT OF INTEGRAL  = ',F20.10)
9890        CALL DPWRST('XXX','BUG ')
9891        WRITE(ICOUT,405)NUMVAR
9892  405   FORMAT('      NUMBER OF VARIABLES OF INTEGRATION = ',I8)
9893        CALL DPWRST('XXX','BUG ')
9894        WRITE(ICOUT,999)
9895        CALL DPWRST('XXX','BUG ')
9896        WRITE(ICOUT,406)
9897  406   FORMAT('NUMBER OF    *       VALUE OF        ')
9898        CALL DPWRST('XXX','BUG ')
9899        WRITE(ICOUT,407)
9900  407   FORMAT('PARTITIONS   *       INTEGRAL      ')
9901        CALL DPWRST('XXX','BUG ')
9902        WRITE(ICOUT,408)
9903  408   FORMAT('-------------*--------------------')
9904        CALL DPWRST('XXX','BUG ')
9905        WRITE(ICOUT,999)
9906        CALL DPWRST('XXX','BUG ')
9907      ENDIF
9908C
9909C               ***********************************************
9910C               **  STEP 3--                                 **
9911C               **  STEP THROUGH 10 DIFFERENT SEGMENTATIONS  **
9912C               **  OF THE DOMAIN OF THE INTEGRAL.           **
9913C               ***********************************************
9914C
9915      DMIN=XMIN
9916      DMAX=XMAX
9917      DO3100NUMSEG=1,MAXSEG
9918C
9919C               ****************************************************
9920C               **  STEP 4--                                      **
9921C               **  WITHIN A GIVEN SEGMENTATION,                  **
9922C               **  APPLY THE 16-POINT GAUSSIAN QUADRATURE RULE.  **
9923C               ****************************************************
9924C
9925        DNUMSE=NUMSEG
9926        DELTA2=(DMAX-DMIN)/DNUMSE
9927        DINT=0.0D0
9928        DO3200J=1,NUMSEG
9929        DJ=J
9930        DMIN2=DMIN+(DJ-1.0D0)*DELTA2
9931        DMAX2=DMIN+DJ*DELTA2
9932        DB1=(DMAX2-DMIN2)/2.0D0
9933        DB0=(DMAX2+DMIN2)/2.0D0
9934C
9935        DSUM2=0.0D0
9936        DO3300I=1,16
9937          DX=DB0+DB1*Z(I)
9938          X=DX
9939C
9940          IF(IFLGFB.LE.0)THEN
9941            DO3303K=1,NUMVAR
9942              JLOC=ILOCV(K)
9943              PARAM(JLOC)=X
9944 3303       CONTINUE
9945            CALL COMPIM(MODEL,NUMCHA,IPASS,PARAM,IPARN,IPARN2,NUMPV,
9946     1                  IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,Y,
9947     1                  IBUGCO,IBUGEV,IERROR)
9948            IF(IERROR.EQ.'YES')GOTO9000
9949          ELSE
9950C
9951C           FUNCTION BLOCK CASE:
9952C
9953C           STEP 1: COMPUTE FUNCTION BLOCK (BUT FIRST SET CURRENT
9954C                   VALUE OF DESIRED PARAMETER)
9955C
9956            DO3305II=1,NUMNAM
9957              IF(IH.EQ.IHNAME(II) .AND. IH2.EQ.IHNAM2(II) .AND.
9958     1           IUSE(II).EQ.'P')THEN
9959                VALUE(II)=X
9960                IVALUE(II)=INT(X+0.5)
9961                GOTO3309
9962              ENDIF
9963 3305       CONTINUE
9964C
9965C           PARAMETER NAME NOT FOUND IN CURRENT LIST, SO NEED TO ADD
9966C           TO NAME LIST
9967C
9968            IF(NUMNAM.LT.MAXNAM)THEN
9969              NUMNAM=NUMNAM+1
9970              IHNAME(NUMNAM)=IH
9971              IHNAM2(NUMNAM)=IH2
9972              IUSE(NUMNAM)='P'
9973              VALUE(NUMNAM)=X
9974              IVALUE(NUMNAM)=INT(X+ 0.5)
9975            ELSE
9976              WRITE(ICOUT,999)
9977              CALL DPWRST('XXX','BUG ')
9978              WRITE(ICOUT,3306)
9979 3306         FORMAT('***** ERROR IN INTEGRATION--')
9980              CALL DPWRST('XXX','BUG ')
9981              WRITE(ICOUT,3307)
9982 3307         FORMAT('      MAXIMUM NUMBER OF NAMES EXCEEDED.')
9983              CALL DPWRST('XXX','BUG ')
9984            ENDIF
9985C
9986 3309       CONTINUE
9987C
9988            IFEEDB='OFF'
9989            CALL DPFBEX(IFBNAM,IANGLU,ISEED,IFTEXP,IFTORD,IFORSW,
9990     1                  IBUGA3,IBUGA3,IBUGCO,IBUGEV,IBUGEV,
9991     1                  ISUBRO,IFOUND,IERROR)
9992            IFEEDB=IFEESV
9993C
9994C           STEP 2: RETRIEVE RESPONSE
9995C
9996            DO3320II=1,NUMNAM
9997              IF(IFBANS(1:4).EQ.IHNAME(II) .AND.
9998     1           IFBANS(5:8).EQ.IHNAM2(II))THEN
9999                IF(IUSE(II).EQ.'P')THEN
10000                  Y=VALUE(II)
10001                  GOTO3329
10002                ELSEIF(IUSE(II).EQ.'V')THEN
10003                  ICOLR=IVALUE(II)
10004                  IJ=MAXN*(ICOLR-1)+1
10005                  IF(ICOLR.LE.MAXCOL)Y=V(IJ)
10006                  IF(ICOLR.EQ.MAXCP1)Y=PRED(1)
10007                  IF(ICOLR.EQ.MAXCP2)Y=RES(1)
10008                  IF(ICOLR.EQ.MAXCP3)Y=YPLOT(1)
10009                  IF(ICOLR.EQ.MAXCP4)Y=XPLOT(1)
10010                  IF(ICOLR.EQ.MAXCP5)Y=X2PLOT(1)
10011                  IF(ICOLR.EQ.MAXCP6)Y=TAGPLO(1)
10012                  GOTO3329
10013                ENDIF
10014              ENDIF
10015 3320       CONTINUE
10016C
10017C           PARAMETER/VARIABLE NAME NOT FOUND
10018C
10019            WRITE(ICOUT,3306)
10020            CALL DPWRST('XXX','BUG ')
10021            WRITE(ICOUT,3321)
10022 3321       FORMAT('      EXPECTED PARAMETER/VARIABLE NOT FOUND IN ',
10023     1           'NAME TABLE.')
10024            CALL DPWRST('XXX','BUG ')
10025            WRITE(ICOUT,3323)IFBANS
10026 3323       FORMAT('      EXPECTED NAME = ',A8)
10027            CALL DPWRST('XXX','BUG ')
10028C
10029 3329       CONTINUE
10030C
10031          ENDIF
10032C
10033          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'INT2')THEN
10034            WRITE(ICOUT,3352)X,Y
10035 3352       FORMAT('X,Y = ',2G15.7)
10036            CALL DPWRST('XXX','BUG ')
10037          ENDIF
10038C
10039          DY=Y
10040          DSUM2=DSUM2+W(I)*DY
10041 3300   CONTINUE
10042        DINT2=DB1*DSUM2
10043        DINT=DINT+DINT2
10044C
10045        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'INT2')THEN
10046          WRITE(ICOUT,3361)NUMSEG,J,DSUM2,DB0,DB1,DINT2
10047 3361     FORMAT('NUMSEG,J,DSUM2,DB0,DB1,DINT2=',2I3,4D12.5)
10048          CALL DPWRST('XXX','BUG ')
10049        ENDIF
10050C
10051 3200 CONTINUE
10052C
10053C               ******************************
10054C               **  STEP 5--                **
10055C               **  WRITE OUT THE INTEGRAL  **
10056C               ******************************
10057C
10058        XINT=DINT
10059        IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
10060          WRITE(ICOUT,3503)NUMSEG,XINT
10061 3503     FORMAT(I8,'     * ',G15.7)
10062          CALL DPWRST('XXX','BUG ')
10063        ENDIF
10064C
10065        IF(NUMSEG.EQ.1)GOTO3550
10066          ABSXIN=ABS(XINT)
10067          DIFF=ABS(XINT-XINT2)
10068          IF(ABSXIN.LE.CUTOFF.AND.DIFF.LE.ACCUR)GOTO3500
10069          IF(ABSXIN.LE.CUTOFF.AND.DIFF.GT.ACCUR)GOTO3550
10070          RATIO=ABS(DIFF/XINT)
10071          IF(ABSXIN.GT.CUTOFF.AND.RATIO.LE.ACCUR)GOTO3500
10072          IF(ABSXIN.GT.CUTOFF.AND.RATIO.GT.ACCUR)GOTO3550
10073 3550   CONTINUE
10074C
10075      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'INT2')THEN
10076        WRITE(ICOUT,3555)CUTOFF,ACCUR,DIFF,RATIO,ABSXIN
10077 3555   FORMAT('CUTOFF,ACCUR,DIFF,RATIO,ABSXIN = ',5G15.7)
10078        CALL DPWRST('XXX','BUG ')
10079      ENDIF
10080C
10081      XINT2=XINT
10082C
10083 3100 CONTINUE
10084C
10085 3500 CONTINUE
10086      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON')THEN
10087        WRITE(ICOUT,999)
10088        CALL DPWRST('XXX','BUG ')
10089        WRITE(ICOUT,3511)XINT
10090 3511   FORMAT('INTEGRAL VALUE        = ',G15.7)
10091        CALL DPWRST('XXX','BUG ')
10092        WRITE(ICOUT,999)
10093        CALL DPWRST('XXX','BUG ')
10094      ENDIF
10095C
10096C               *****************
10097C               **  STEP 90--  **
10098C               **  EXIT       **
10099C               *****************
10100C
10101 9000 CONTINUE
10102      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'INT2')THEN
10103        WRITE(ICOUT,999)
10104        CALL DPWRST('XXX','BUG ')
10105        WRITE(ICOUT,9011)
10106 9011   FORMAT('***** AT THE END       OF DPINT2--')
10107        CALL DPWRST('XXX','BUG ')
10108        WRITE(ICOUT,9012)CUTOFF,ACCUR,DIFF,RATIO,ABSXIN
10109 9012   FORMAT('CUTOFF,ACCUR,DIFF,RATIO,ABSXIN = ',5G15.7)
10110        CALL DPWRST('XXX','BUG ')
10111        WRITE(ICOUT,9014)IERROR
10112 9014   FORMAT('IERROR = ',A4)
10113        CALL DPWRST('XXX','BUG ')
10114      ENDIF
10115C
10116      RETURN
10117      END
10118      SUBROUTINE DPINTE(ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
10119     1                  PARAM,IPARN,IPARN2,TEMP1,ITEMP1,
10120     1                  IANGLU,IFTEXP,IFTORD,IFORSW,
10121     1                  IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,IERROR)
10122C
10123C     PURPOSE--TREAT THE LET CASE FOR
10124C              FINDING THE DEFINITE INTEGRAL OF AN FUNCTION.
10125C     EXAMPLE--LET A = INTEGRAL X**3+2*X**2-4*X+5 FOR X = 1 3
10126C            --LET X = INTEGRAL F1 FOR X = 0 B
10127C     WRITTEN BY--JAMES J. FILLIBEN
10128C                 STATISTICAL ENGINEERING DIVISION
10129C                 INFORMATION TECHNOLOGY LABORATORY
10130C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
10131C                 GAITHERSBURG, MD 20899-8980
10132C                 PHONE--301-975-2855
10133C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
10134C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
10135C     LANGUAGE--ANSI FORTRAN (1977)
10136C     VERSION NUMBER--82/7
10137C     ORIGINAL VERSION--NOVEMBER  1978.
10138C     UPDATED         --JULY      1981.
10139C     UPDATED         --SEPTEMBER 1981.
10140C     UPDATED         --MARCH     1982.
10141C     UPDATED         --MAY       1982.
10142C     UPDATED         --NOVEMBER  1989. FIX AJUNK & BJUNK DIMENSIONS
10143C     UPDATED         --JUNE      2013. SUPPORT INDEFINITE INTEGRALS
10144C                                       (USE QUADPACK ROUTINE QAGI)
10145C     UPDATED         --SEPTEMBER 2015. SUPPORT FOR FUNCTION BLOCKS
10146C
10147C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
10148C
10149      CHARACTER*4 ITYPEH
10150      CHARACTER*4 IW21HO
10151      CHARACTER*4 IW22HO
10152      CHARACTER*4 IPARN
10153      CHARACTER*4 IPARN2
10154      CHARACTER*4 IANGLU
10155      CHARACTER*4 IFTEXP
10156      CHARACTER*4 IFTORD
10157      CHARACTER*4 IFORSW
10158      CHARACTER*4 IBUGA3
10159      CHARACTER*4 IBUGCO
10160      CHARACTER*4 IBUGEV
10161      CHARACTER*4 IBUGQ
10162      CHARACTER*4 ISUBRO
10163      CHARACTER*4 IERROR
10164C
10165      CHARACTER*4 NEWNAM
10166      CHARACTER*4 IHOUT
10167      CHARACTER*4 IHOUT2
10168      CHARACTER*4 IUOUT
10169      CHARACTER*4 IDUMV
10170      CHARACTER*4 IDUMV2
10171      CHARACTER*4 IHPARN
10172      CHARACTER*4 IHPAR2
10173      CHARACTER*4 IHL
10174      CHARACTER*4 IHL2
10175      CHARACTER*4 IWD1
10176      CHARACTER*4 IWD2
10177      CHARACTER*4 IWD12
10178      CHARACTER*4 IWD22
10179      CHARACTER*4 ILAB
10180      CHARACTER*4 IKEY
10181      CHARACTER*4 IKEY2
10182      CHARACTER*4 INCLUN
10183      CHARACTER*4 IHWUSE
10184      CHARACTER*4 MESSAG
10185      CHARACTER*4 ICASEL
10186      CHARACTER*4 IFOUND
10187      CHARACTER*4 IFOUN1
10188      CHARACTER*4 IFOUN2
10189      CHARACTER*4 IERRO2
10190      CHARACTER*4 IHLEFT
10191      CHARACTER*4 IHLEF2
10192      CHARACTER*4 IOLD
10193      CHARACTER*4 IOLD2
10194      CHARACTER*4 INEW
10195      CHARACTER*4 INEW2
10196C
10197      CHARACTER*4 ISUBN1
10198      CHARACTER*4 ISUBN2
10199      CHARACTER*4 ISTEPN
10200C
10201      DIMENSION TEMP1(*)
10202      DIMENSION ITEMP1(*)
10203C
10204C---------------------------------------------------------------------
10205C
10206      DIMENSION ITYPEH(*)
10207      DIMENSION IW21HO(*)
10208      DIMENSION IW22HO(*)
10209      DIMENSION W2HOLD(*)
10210C
10211      DIMENSION PARAM(*)
10212      DIMENSION IPARN(*)
10213      DIMENSION IPARN2(*)
10214C
10215      DIMENSION IDUMV(100)
10216      DIMENSION IDUMV2(100)
10217C
10218      DIMENSION ILAB(10)
10219      DIMENSION IOLD(10)
10220      DIMENSION IOLD2(10)
10221      DIMENSION INEW(10)
10222      DIMENSION INEW2(10)
10223C
10224CCCCC THE FOLLOWING LINE WAS ADDED NOVEMBER 1989
10225      DIMENSION BJUNK(1)
10226C
10227C-----MAKE DUMMY COMMON BLOCK-----------
10228C
10229      PARAMETER (IOPTCH=1000)
10230      PARAMETER (IOPTC2=100)
10231C
10232      CHARACTER*4 IBUGAZ
10233      CHARACTER*4 ZTYPEH
10234      CHARACTER*4 ZW21HO
10235      CHARACTER*4 ZW22HO
10236      CHARACTER*4 ZIPARN
10237      CHARACTER*4 ZPARN2
10238      CHARACTER*4 ZMODEL
10239      CHARACTER*4 ZIDUMV
10240      CHARACTER*4 ZDUMV2
10241C
10242      DIMENSION ZMODEL(IOPTCH)
10243      DIMENSION ZTYPEH(IOPTCH)
10244      DIMENSION ZW21HO(IOPTCH)
10245      DIMENSION ZW22HO(IOPTCH)
10246      DIMENSION Z2HOLD(IOPTCH)
10247C
10248      DIMENSION ZPARAM(IOPTC2)
10249      DIMENSION ZIPARN(IOPTC2)
10250      DIMENSION ZPARN2(IOPTC2)
10251      DIMENSION ZIDUMV(IOPTC2)
10252      DIMENSION ZDUMV2(IOPTC2)
10253      DIMENSION LOCDUM(IOPTC2)
10254C
10255      COMMON /OPTCMC/ IBUGAZ, ZTYPEH, ZW21HO, ZW22HO, ZIPARN, ZPARN2,
10256     &                ZIDUMV, ZDUMV2, ZMODEL
10257      COMMON /OPTCMR/ ZPARAM, Z2HOLD,
10258     &                NUMCHZ, NUMPVZ, NWHOLZ, NUMDVZ, LOCDUM
10259C
10260C-----COMMON----------------------------------------------------------
10261C
10262      INCLUDE 'DPCOPA.INC'
10263      INCLUDE 'DPCOHK.INC'
10264      INCLUDE 'DPCODA.INC'
10265      INCLUDE 'DPCOFB.INC'
10266C
10267C-----COMMON VARIABLES (GENERAL)--------------------------------------
10268C
10269      INCLUDE 'DPCOMC.INC'
10270      INCLUDE 'DPCOP2.INC'
10271C
10272C-----START POINT-----------------------------------------------------
10273C
10274C               *******************************************
10275C               **  TREAT THE DEFINITE INTEGRAL SUBCASE  **
10276C               **  OF THE LET COMMAND                   **
10277C               *******************************************
10278C
10279      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'INTE')THEN
10280        WRITE(ICOUT,999)
10281  999   FORMAT(1X)
10282        CALL DPWRST('XXX','BUG ')
10283        WRITE(ICOUT,51)
10284   51   FORMAT('***** AT THE BEGINNING OF DPINTE--')
10285        CALL DPWRST('XXX','BUG ')
10286        WRITE(ICOUT,53)IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO
10287   53   FORMAT('IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO = ',4(A4,2X),A4)
10288        CALL DPWRST('XXX','BUG ')
10289      ENDIF
10290C
10291C               **********************************
10292C               **  STEP 1--                    **
10293C               **  INITIALIZE SOME VARIABLES.  **
10294C               **********************************
10295C
10296      ISTEPN='1'
10297      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10298     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10299C
10300      NEWNAM='NO'
10301      ISUBN1='DPIN'
10302      ISUBN2='TE  '
10303      IHLEFT='UNKN'
10304      IHLEF2='UNKN'
10305      IERROR='NO'
10306C
10307      MAXN2=MAXCHF
10308      MAXN3=MAXCHF
10309      MAXCP1=MAXCOL+1
10310      MAXCP2=MAXCOL+2
10311      MAXCP3=MAXCOL+3
10312      MAXCP4=MAXCOL+4
10313      MAXCP5=MAXCOL+5
10314      MAXCP6=MAXCOL+6
10315      ILOCMX=0
10316      NUMLIM=0
10317      ILOC3=0
10318      IP=0
10319      IV=0
10320      LOCDUM=0
10321      XMIN=CPUMIN
10322      XMAX=CPUMAX
10323C
10324C               *******************************************************
10325C               **  STEP 2--                                         **
10326C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
10327C               *******************************************************
10328C
10329      ISTEPN='2'
10330      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10331     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10332C
10333      MINNA=1
10334      MAXNA=100
10335      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
10336      IF(IERROR.EQ.'YES')GOTO9000
10337C
10338C               ******************************************************
10339C               **  STEP 2--                                         *
10340C               **  EXAMINE THE LEFT-HAND SIDE--                     *
10341C               **  IS THE NAME     NAME TO LEFT OF = SIGN           *
10342C               **  ALREADY IN THE NAME LIST?                        *
10343C               **  NOTE THAT     ILISTL    IS THE LINE IN THE TABLE *
10344C               **  OF THE NAME ON THE LEFT.                         *
10345C               ******************************************************
10346C
10347      ISTEPN='2'
10348      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10349     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10350C
10351      IHLEFT=IHARG(1)
10352      IHLEF2=IHARG2(1)
10353      DO2000I=1,NUMNAM
10354        I2=I
10355        IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))THEN
10356          ILISTL=I2
10357          GOTO2900
10358        ENDIF
10359 2000 CONTINUE
10360      NEWNAM='YES'
10361      ILISTL=NUMNAM+1
10362      IF(ILISTL.GT.MAXNAM)THEN
10363        WRITE(ICOUT,999)
10364        CALL DPWRST('XXX','BUG ')
10365        WRITE(ICOUT,2201)
10366 2201   FORMAT('***** ERROR IN INTEGRAL--')
10367        CALL DPWRST('XXX','BUG ')
10368        WRITE(ICOUT,2202)
10369 2202   FORMAT('      THE NUMBER OF VARIABLE, PARAMETER, AND FUNCTION')
10370        CALL DPWRST('XXX','BUG ')
10371        WRITE(ICOUT,2203)MAXNAM
10372 2203   FORMAT('      NAMES HAS JUST EXCEEDED THE ALLOWABLE ',I8)
10373        CALL DPWRST('XXX','BUG ')
10374        WRITE(ICOUT,2204)
10375 2204   FORMAT('      ENTER      STATUS')
10376        CALL DPWRST('XXX','BUG ')
10377        WRITE(ICOUT,2205)
10378 2205   FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES, AND ',
10379     1         'THEN')
10380        CALL DPWRST('XXX','BUG ')
10381        WRITE(ICOUT,2206)
10382 2206   FORMAT('      REDEFINE (REUSE) SOME OF THE ALREADY USED NAMES')
10383        CALL DPWRST('XXX','BUG ')
10384        IERROR='YES'
10385        GOTO9000
10386      ENDIF
10387C
10388 2900 CONTINUE
10389C
10390C               ************************************************************
10391C               **  STEP 3.1--                                            **
10392C               **  EXTRACT THE RIGHT-SIDE FUNCTIONAL EXPRESSION FROM THE **
10393C               **  INPUT COMMAND LINE (STARTING WITH THE FIRST NON-BLANK **
10394C               **  LOCATION AFTER THE EQUAL SIGN AND ENDING WITH THE END **
10395C               **  OF THE LINE OR WITH THE LAST NON-BLANK CHARACTER      **
10396C               **  BEFORE     WRT  .  PLACE THE FUNCTION IN IFUNC2(.) .  **
10397C               ************************************************************
10398C
10399      ISTEPN='3.1'
10400      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10401     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10402C
10403C     2015/09: CHECK TO SEE IF THE FIRST ARGUMENT ON RHS IS A FUNCTION
10404C              BLOCK NAME.
10405C
10406      IF(IHARG(4).EQ.IFBNA1(1:4) .AND. IHARG2(4).EQ.IFBNA1(5:8))THEN
10407        IFLGFB=1
10408      ELSEIF(IHARG(4).EQ.IFBNA2(1:4) .AND. IHARG2(4).EQ.IFBNA2(5:8))THEN
10409        IFLGFB=2
10410      ELSEIF(IHARG(4).EQ.IFBNA3(1:4) .AND. IHARG2(4).EQ.IFBNA3(5:8))THEN
10411        IFLGFB=3
10412      ELSE
10413        IFLGFB=0
10414      ENDIF
10415C
10416C
10417      IWD1=IHARG(3)
10418      IWD12=IHARG2(3)
10419      IWD2='WRT '
10420      IWD22='    '
10421      CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
10422     1            IFUNC2,N2,IBUGA3,IFOUND,IERROR)
10423      IF(IERROR.EQ.'YES')GOTO9000
10424      IF(IFOUND.EQ.'YES')GOTO3500
10425C
10426      IWD1=IHARG(3)
10427      IWD12=IHARG2(3)
10428      IWD2='FOR '
10429      IWD22='    '
10430      CALL DPEXST(IANS,IWIDTH,IWD1,IWD12,IWD2,IWD22,MAXN2,
10431     1            IFUNC2,N2,IBUGA3,IFOUND,IERROR)
10432      IF(IERROR.EQ.'YES')GOTO9000
10433      IF(IFOUND.EQ.'YES')GOTO3500
10434C
10435      WRITE(ICOUT,999)
10436      CALL DPWRST('XXX','BUG ')
10437      WRITE(ICOUT,2201)
10438      CALL DPWRST('XXX','BUG ')
10439      WRITE(ICOUT,3102)
10440 3102 FORMAT('      INVALID COMMAND FORM FOR INTEGRATION.')
10441      CALL DPWRST('XXX','BUG ')
10442      WRITE(ICOUT,3103)
10443 3103 FORMAT('      GENERAL FORM--')
10444      CALL DPWRST('XXX','BUG ')
10445      WRITE(ICOUT,3104)
10446 3104 FORMAT('      LET ... = INTEGRAL ... WRT  ... ',
10447     1       'FOR ... = ... TO ...')
10448      CALL DPWRST('XXX','BUG ')
10449      WRITE(ICOUT,3105)
10450 3105 FORMAT('      THE ENTIRE COMMAND LINE WAS AS FOLLOWS--')
10451      CALL DPWRST('XXX','BUG ')
10452      IF(IWIDTH.GE.1)THEN
10453        WRITE(ICOUT,3106)(IANS(I),I=1,MIN(IWIDTH,100))
10454 3106   FORMAT('      ',100A1)
10455        CALL DPWRST('XXX','BUG ')
10456      ENDIF
10457      IERROR='YES'
10458      GOTO9000
10459C
10460 3500 CONTINUE
10461C
10462C               *********************************************************
10463C               **  STEP 4--                                            *
10464C               **  DETERMINE IF THE EXPRESSION HAS ANY FUNCTION NAMES  *
10465C               **  INBEDDED.  IF SO, REPLACE THE FUNCTION NAMES        *
10466C               **  BY EACH FUNCTION'S DEFINITION.  DO SO REPEATEDLY    *
10467C               **  UNTIL ALL FUNCTION REFERENCES HAVE BEEN ANNIHILATED *
10468C               **  AND THE EXPRESSION IS LEFT ONLY WITH CONSTANTS,     *
10469C               **  PARAMETERS, AND VARIABLES--NO FUNCTIONS.  PLACE THE *
10470C               **  RESULTING FUNCTIONAL EXPRESSION INTO IFUNC3(.)      *
10471C               *********************************************************
10472C
10473      ISTEPN='4'
10474      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10475     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10476C
10477      IF(IFLGFB.LT.1)THEN
10478        CALL DPEXFU(IFUNC2,N2,IHNAME,IHNAM2,IUSE,IVSTAR,IVSTOP,
10479     1              NUMNAM,IANS,IWIDTH,IFUNC,NUMCHF,MAXCHF,
10480     1              IFUNC3,N3,MAXN3,
10481     1              IBUGA3,IERROR)
10482        IF(IERROR.EQ.'YES')GOTO9000
10483C
10484        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')THEN
10485          WRITE(ICOUT,999)
10486          CALL DPWRST('XXX','BUG ')
10487          ILAB(1)='INPU'
10488          ILAB(2)='T FU'
10489          ILAB(3)='NCTI'
10490          ILAB(4)='ON  '
10491          ILAB(5)='    '
10492          ILAB(6)='  = '
10493          NUMWDL=6
10494          CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
10495          WRITE(ICOUT,5081)IDUMV(1),IDUMV2(1)
10496 5081     FORMAT('INTEGRATION VARIABLE  = ',A4,A4)
10497          CALL DPWRST('XXX','BUG ')
10498        ENDIF
10499C
10500      ENDIF
10501C
10502C               *************************************
10503C               **  STEP 5--                       **
10504C               **  EXTRACT QUALIFIER INFORMATION. **
10505C               *************************************
10506C
10507      ISTEPN='5'
10508      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10509     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10510C
10511C               *********************************************************
10512C               **  STEP 5.1--                                         **
10513C               **  DETERMINE THE DUMMY VARIABLE FOR THE INTEGRATION.  **
10514C               *********************************************************
10515C
10516      IKEY='WRT '
10517      IKEY2='    '
10518      ISHIFT=1
10519      ILOCA=1
10520      ILOCB=NUMARG
10521      INCLUN='NO'
10522      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
10523     1            IHARG,IHARG2,NUMARG,
10524     1            INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
10525     1            IUSE,IN,NUMNAM,
10526     1            IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,
10527     1            IVOUT,VOUT,IUOUT,
10528     1            INOUT,IBUGA3,IERROR)
10529      IF(IFOUN1.EQ.'NO' .OR. IFOUN2.EQ.'NO')THEN
10530        IKEY='FOR '
10531        IKEY2='    '
10532        ISHIFT=1
10533        ILOCA=1
10534        ILOCB=NUMARG
10535        INCLUN='NO'
10536        CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
10537     1              IHARG,IHARG2,NUMARG,
10538     1              INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
10539     1              IUSE,IN,NUMNAM,
10540     1              IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,
10541     1              IVOUT,VOUT,IUOUT,
10542     1              INOUT,IBUGA3,IERROR)
10543        IF(IFOUN1.EQ.'NO' .OR. IFOUN2.EQ.'NO')THEN
10544          WRITE(ICOUT,999)
10545          CALL DPWRST('XXX','BUG ')
10546          WRITE(ICOUT,2201)
10547          CALL DPWRST('XXX','BUG ')
10548          WRITE(ICOUT,5182)
10549 5182     FORMAT('      INVALID COMMAND FORM FOR INTEGRATION.')
10550          CALL DPWRST('XXX','BUG ')
10551          WRITE(ICOUT,5183)
10552 5183     FORMAT('      NO VARIABLE OF INTEGRATION DEFINED.')
10553          CALL DPWRST('XXX','BUG ')
10554          WRITE(ICOUT,3103)
10555          CALL DPWRST('XXX','BUG ')
10556          WRITE(ICOUT,3104)
10557          CALL DPWRST('XXX','BUG ')
10558          WRITE(ICOUT,3105)
10559          CALL DPWRST('XXX','BUG ')
10560          IF(IWIDTH.GE.1)THEN
10561            WRITE(ICOUT,3106)(IANS(I),I=1,MIN(IWIDTH,100))
10562            CALL DPWRST('XXX','BUG ')
10563          ENDIF
10564          IERROR='YES'
10565          GOTO9000
10566        ELSE
10567          IDUMV(1)=IHOUT
10568          IDUMV2(1)=IHOUT2
10569          NUMDV=1
10570        ENDIF
10571      ELSE
10572        IDUMV(1)=IHOUT
10573        IDUMV2(1)=IHOUT2
10574        NUMDV=1
10575      ENDIF
10576C
10577C               **************************************************
10578C               **  STEP 5.2--                                  **
10579C               **  DETERMINE THE LIMITS FOR   THE INTEGRATION. **
10580C               **************************************************
10581C
10582      ISTEPN='5.2'
10583      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10584     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10585C
10586      NUMLIM=0
10587C
10588      IKEY='FOR '
10589      IKEY2='    '
10590      ISHIFT=3
10591      ILOCA=1
10592      ILOCB=NUMARG
10593      INCLUN='NO'
10594      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
10595     1            IHARG,IHARG2,NUMARG,
10596     1            INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
10597     1            IUSE,IN,NUMNAM,
10598     1            IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,
10599     1            VOUT,IUOUT,
10600     1            INOUT,IBUGA3,IERROR)
10601      IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')THEN
10602        XMIN=VOUT
10603        NUMLIM=NUMLIM+1
10604      ENDIF
10605C
10606      IKEY='FOR '
10607      IKEY2='    '
10608      ISHIFT=4
10609      ILOCA=1
10610      ILOCB=NUMARG
10611      INCLUN='NO'
10612      CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
10613     1            IHARG,IHARG2,NUMARG,
10614     1            INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
10615     1            IUSE,IN,NUMNAM,
10616     1            IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,
10617     1            VOUT,IUOUT,
10618     1            INOUT,IBUGA3,IERROR)
10619      IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')THEN
10620        IF(IHOUT.EQ.'TO  ' .AND. IHOUT2.EQ.'    ')THEN
10621          CONTINUE
10622        ELSE
10623          XMAX=VOUT
10624          ILOCMX=ILOC2
10625          NUMLIM=NUMLIM+1
10626        ENDIF
10627      ENDIF
10628C
10629      IF(NUMLIM.LE.1)THEN
10630        IKEY='FOR '
10631        IKEY2='    '
10632        ISHIFT=5
10633        ILOCA=1
10634        ILOCB=NUMARG
10635        INCLUN='NO'
10636        CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
10637     1              IHARG,IHARG2,NUMARG,
10638     1              INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
10639     1              IUSE,IN,NUMNAM,
10640     1              IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,
10641     1              ILOUT,IVOUT,VOUT,IUOUT,
10642     1              INOUT,IBUGA3,IERROR)
10643        IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')THEN
10644          XMAX=VOUT
10645          ILOCMX=ILOC2
10646          NUMLIM=NUMLIM+1
10647        ENDIF
10648      ENDIF
10649C
10650      IF(NUMLIM.LE.1)THEN
10651        WRITE(ICOUT,999)
10652        CALL DPWRST('XXX','BUG ')
10653        WRITE(ICOUT,2201)
10654        CALL DPWRST('XXX','BUG ')
10655        WRITE(ICOUT,5182)
10656        CALL DPWRST('XXX','BUG ')
10657        IF(NUMLIM.EQ.0)THEN
10658          WRITE(ICOUT,5283)
10659 5283     FORMAT('      NO LIMITS OF INTEGRATION DEFINED.')
10660          CALL DPWRST('XXX','BUG ')
10661        ELSEIF(NUMLIM.EQ.1)THEN
10662          WRITE(ICOUT,5284)
10663 5284     FORMAT('      ONLY ONE LIMIT OF INTEGRATION DEFINED.')
10664          CALL DPWRST('XXX','BUG ')
10665        ELSE
10666          WRITE(ICOUT,5285)NUMLIM
10667 5285     FORMAT('      NUMBER OF LIMITS DEFINED = ',I8)
10668          CALL DPWRST('XXX','BUG ')
10669        ENDIF
10670        WRITE(ICOUT,3103)
10671        CALL DPWRST('XXX','BUG ')
10672        WRITE(ICOUT,3104)
10673        CALL DPWRST('XXX','BUG ')
10674        WRITE(ICOUT,3105)
10675        CALL DPWRST('XXX','BUG ')
10676        IF(IWIDTH.GE.1)THEN
10677          WRITE(ICOUT,3106)(IANS(I),I=1,MIN(IWIDTH,100))
10678          CALL DPWRST('XXX','BUG ')
10679        ENDIF
10680        IERROR='YES'
10681        GOTO9000
10682      ENDIF
10683C
10684C               **********************************************
10685C               **  STEP 6.3--                              **
10686C               **  SCAN THE QUALIFIERS FOR VARIABLE,       **
10687C               **  PARAMETER, FUNCTION, AND VALUE CHANGES  **
10688C               **  IN THE FUNCTION.                        **
10689C               **********************************************
10690C
10691      ISTEPN='6.3'
10692      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10693     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10694C
10695      NCHANG=0
10696      DO6300IFORI=1,10
10697C
10698        IKEY='FOR '
10699        IKEY2='    '
10700        ISHIFT=1
10701        IF(IFORI.EQ.1)ILOCA=ILOCMX
10702        IF(IFORI.NE.1)ILOCA=ILOC3
10703        ILOCB=NUMARG
10704        INCLUN='NO'
10705        CALL DPEXQU(IKEY,IKEY2,ISHIFT,ILOCA,ILOCB,
10706     1              IHARG,IHARG2,NUMARG,
10707     1              INCLUN,IANS,IWIDTH,IHNAME,IHNAM2,IVALUE,VALUE,
10708     1              IUSE,IN,NUMNAM,
10709     1              IFOUN1,IFOUN2,ILOC1,ILOC2,IHOUT,IHOUT2,ILOUT,IVOUT,
10710     1              VOUT,IUOUT,
10711     1              INOUT,IBUGA3,IERROR)
10712        IF(IERROR.EQ.'YES')GOTO6380
10713        IF(IFOUN1.EQ.'NO'.OR.IFOUN2.EQ.'NO')GOTO6390
10714C
10715        ILOC3=ILOC2+2
10716        IF(ILOC3.GT.NUMARG)GOTO6380
10717        NCHANG=NCHANG+1
10718        IOLD(NCHANG)=IHARG(ILOC2)
10719        IOLD2(NCHANG)=IHARG2(ILOC2)
10720        INEW(NCHANG)=IHARG(ILOC3)
10721        INEW2(NCHANG)=IHARG2(ILOC3)
10722C
10723 6300 CONTINUE
10724      GOTO6390
10725C
10726 6380 CONTINUE
10727      WRITE(ICOUT,999)
10728      CALL DPWRST('XXX','BUG ')
10729      WRITE(ICOUT,2201)
10730      CALL DPWRST('XXX','BUG ')
10731      WRITE(ICOUT,6302)
10732 6302 FORMAT('      INVALID COMMAND FORM FOR INTEGRATION.')
10733      CALL DPWRST('XXX','BUG ')
10734      WRITE(ICOUT,3103)
10735      CALL DPWRST('XXX','BUG ')
10736      WRITE(ICOUT,3104)
10737      CALL DPWRST('XXX','BUG ')
10738      WRITE(ICOUT,3105)
10739      CALL DPWRST('XXX','BUG ')
10740      IF(IWIDTH.GE.1)THEN
10741        WRITE(ICOUT,3106)(IANS(I),I=1,MIN(IWIDTH,100))
10742        CALL DPWRST('XXX','BUG ')
10743      ENDIF
10744      IERROR='YES'
10745      GOTO9000
10746C
10747 6390 CONTINUE
10748C
10749C               **********************************************
10750C               **  STEP 6.4--                              **
10751C               **  CARRY OUT THE VARIABLE,                 **
10752C               **  PARAMETER, AND FUNCTION CHANGES         **
10753C               **  AND THEN PRINT OUT A BRIEF MESSAGE      **
10754C               **  INDICATING THAT THE CHANGES             **
10755C               **  HAVE BEEN MADE.                         **
10756C               **********************************************
10757C
10758      ISTEPN='6.4'
10759      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10760     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10761C
10762      IF(IPRINT.EQ.'ON' .AND. IFEEDB.EQ.'ON' .AND. NCHANG.GT.0 .AND.
10763     1   IFLGFB.LE.0)THEN
10764C
10765        WRITE(ICOUT,999)
10766        CALL DPWRST('XXX','BUG ')
10767        ILAB(1)='PRE '
10768        ILAB(2)='-CHA'
10769        ILAB(3)='NGE '
10770        ILAB(4)='FUNC'
10771        ILAB(5)='TION'
10772        ILAB(6)='  = '
10773        NUMWDL=6
10774        CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
10775C
10776        CALL COMPIC(IFUNC3,N3,IOLD,IOLD2,INEW,INEW2,NCHANG,IFUNC3,N3,
10777     1              IBUGA3,IERROR)
10778        IF(IERROR.EQ.'YES')GOTO9000
10779C
10780        ILAB(1)='POST'
10781        ILAB(2)='-CHA'
10782        ILAB(3)='NGE '
10783        ILAB(4)='FUNC'
10784        ILAB(5)='TION'
10785        ILAB(6)='  = '
10786        NUMWDL=6
10787        CALL DPPRIF(ILAB,NUMWDL,IFUNC3,N3,IBUGA3)
10788C
10789      ENDIF
10790C
10791C               *********************************************************
10792C               **  STEP 6.7--                                         **
10793C               **  MAKE A NON-CALCULATING PASS AT THE FUNCTION        **
10794C               **  SO AS TO EXTRACT ALL PARAMETER AND VARIABLE NAMES. **
10795C               *********************************************************
10796C
10797      ISTEPN='6.8'
10798      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10799     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10800C
10801C
10802      IPASS=1
10803      IF(IFLGFB.LE.0)THEN
10804        CALL COMPIM(IFUNC3,N3,IPASS,PARAM,IPARN,IPARN2,NUMPV,
10805     1              IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,AJUNK,
10806     1              IBUGCO,IBUGEV,IERROR)
10807        IF(IERROR.EQ.'YES')GOTO9000
10808      ELSE
10809        GOTO7650
10810      ENDIF
10811C
10812C               ***********************************************
10813C               **  STEP 7--                                 **
10814C               **  CHECK THAT ALL PARAMETERS                **
10815C               **  IN THE FUNCTION ARE ALREADY PRESENT      **
10816C               **  IN THE AVAILABLE NAME LIST IHNAME(.).    **
10817C               ***********************************************
10818C
10819      ISTEPN='7'
10820      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
10821     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10822C
10823      IP=0
10824      IV=0
10825      IF(NUMPV.LE.0)GOTO7650
10826      DO7600J=1,NUMPV
10827        IHPARN=IPARN(J)
10828        IHPAR2=IPARN2(J)
10829        IF(IHPARN.EQ.IDUMV(1).AND.IHPAR2.EQ.IDUMV2(1))THEN
10830           IV=IV+1
10831           LOCDUM=J
10832           GOTO7600
10833        ENDIF
10834        IHWUSE='P'
10835        MESSAG='YES'
10836        CALL CHECKN(IHPARN,IHPAR2,IHWUSE,
10837     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
10838     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
10839        IF(IERRO2.EQ.'YES')THEN
10840          WRITE(ICOUT,999)
10841          CALL DPWRST('XXX','BUG ')
10842          WRITE(ICOUT,2201)
10843          CALL DPWRST('XXX','BUG ')
10844          WRITE(ICOUT,7612)
10845 7612     FORMAT('      A PARAMETER/FUNCTION HAS BEEN ENCOUNTERED IN ',
10846     1           'THE')
10847          CALL DPWRST('XXX','BUG ')
10848          WRITE(ICOUT,7613)
10849 7613     FORMAT('      FUNCTION TO BE INTEGRATED WHICH HAS NOT YET ',
10850     1           'BEEN DEFINED')
10851          CALL DPWRST('XXX','BUG ')
10852          WRITE(ICOUT,7615)IHPARN,IHPAR2
10853 7615     FORMAT('      THE UNKNOWN PARAMETER/FUNCTION = ',A4,A4)
10854          CALL DPWRST('XXX','BUG ')
10855          WRITE(ICOUT,3105)
10856          CALL DPWRST('XXX','BUG ')
10857          IF(IWIDTH.GE.1)THEN
10858            WRITE(ICOUT,3106)(IANS(I),I=1,MIN(IWIDTH,100))
10859            CALL DPWRST('XXX','BUG ')
10860          ENDIF
10861          IERROR='YES'
10862          GOTO9000
10863        ENDIF
10864C
10865        IP=IP+1
10866        PARAM(J)=VALUE(ILOCP)
10867C
10868 7600 CONTINUE
10869 7650 CONTINUE
10870C
10871C               ******************************
10872C               **  STEP 8--                **
10873C               **  DETERMINE THE INTEGRAL  **
10874C               ******************************
10875C
10876      ISTEPN='8'
10877      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')THEN
10878        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10879        WRITE(ICOUT,999)
10880        CALL DPWRST('XXX','BUG ')
10881        WRITE(ICOUT,7711)
10882 7711   FORMAT('***** FROM DPINTE, IMMEDIATELY BEFORE CALLING DPINT2--')
10883        CALL DPWRST('XXX','BUG ')
10884        WRITE(ICOUT,7712)N3,NUMPV
10885 7712   FORMAT('N3,NUMPV = ',2I8)
10886        CALL DPWRST('XXX','BUG ')
10887        WRITE(ICOUT,7713)NUMDV,XMIN,XMAX,XINT
10888 7713   FORMAT('NUMDV,XMIN,XMAX,XINT = ',I8,3G15.7)
10889        CALL DPWRST('XXX','BUG ')
10890        DO7714I=1,NUMDV
10891          WRITE(ICOUT,7715)I,IDUMV(I),IDUMV2(I)
10892 7715     FORMAT('I,IDUMV(I),IDUMV2(I) = ',I8,2X,A4,A4)
10893          CALL DPWRST('XXX','BUG ')
10894 7714   CONTINUE
10895      ENDIF
10896C
10897C     2013/06: CALL QUADPACK ROUTINE "QAGI" IF AN INDEFINITE INTEGRAL
10898C              DETECTED.
10899C
10900      IF(XMIN.EQ.CPUMIN .OR. XMAX.EQ.CPUMAX)THEN
10901C
10902C       COPY OVER DUMMY COMMON BLOCKS FOR OPTFUN ROUTINE
10903C
10904        DO7805KK=1,MAXF3
10905          ZMODEL(KK)=IFUNC3(KK)
10906 7805   CONTINUE
10907        DO7810KK=1,IOPTCH
10908          ZTYPEH(KK)=ITYPEH(KK)
10909          ZW21HO(KK)=IW21HO(KK)
10910          ZW22HO(KK)=IW22HO(KK)
10911          Z2HOLD(KK)=W2HOLD(KK)
10912 7810   CONTINUE
10913        DO7820KK=1,IOPTC2
10914          ZPARAM(KK)=PARAM(KK)
10915          ZIPARN(KK)=IPARN(KK)
10916          ZPARN2(KK)=IPARN2(KK)
10917          ZIDUMV(KK)=IDUMV(KK)
10918          ZDUMV2(KK)=IDUMV2(KK)
10919 7820   CONTINUE
10920        NUMCHZ=N3
10921        NUMPVZ=NUMPV
10922        NWHOLZ=NWHOLD
10923        NUMDVZ=NUMDV
10924        IBUGAZ=IBUGA3
10925C
10926        IF(XMIN.EQ.CPUMIN .AND. XMAX.EQ.CPUMAX)THEN
10927          INF=2
10928          BOUND=XMIN
10929        ELSEIF(XMIN.EQ.CPUMIN)THEN
10930          INF=-1
10931          BOUND=XMAX
10932        ELSE
10933          INF=1
10934          BOUND=XMIN
10935        ENDIF
10936        EPSABS=0.0
10937        EPSREL=1.0E-7
10938        AVAL=50.0*R1MACH(4)
10939        IF(EPSREL.LT.AVAL)THEN
10940          EPSREL=1.0E-04
10941        ENDIF
10942        IER=0
10943        XINT=0.0
10944        LIMIT=500
10945        LENW=4*LIMIT
10946C
10947        CALL QAGI(BOUND,INF,EPSABS,EPSREL,XINT,ABSERR,NEVAL,
10948     1            IER,LIMIT,LENW,LAST,ITEMP1,TEMP1)
10949C
10950        IF(IER.EQ.0 .AND. IFEEDB.EQ.'ON')THEN
10951          WRITE(ICOUT,999)
10952          CALL DPWRST('XXX','BUG ')
10953          WRITE(ICOUT,8091)XINT
10954 8091     FORMAT('      INDEFINITE INTERGRAL RESULT  = ',G15.7)
10955          CALL DPWRST('XXX','BUG ')
10956          WRITE(ICOUT,8093)ABSERR
10957 8093     FORMAT('      ABSOLUTE ERROR              = ',G15.7)
10958          CALL DPWRST('XXX','BUG ')
10959          WRITE(ICOUT,8095)NEVAL
10960 8095     FORMAT('      NUMBER OF EVALUATIONS       = ',I8)
10961          CALL DPWRST('XXX','BUG ')
10962          WRITE(ICOUT,999)
10963          CALL DPWRST('XXX','BUG ')
10964        ENDIF
10965C
10966        IF(IER.GE.1)THEN
10967          WRITE(ICOUT,999)
10968          CALL DPWRST('XXX','BUG ')
10969          WRITE(ICOUT,2201)
10970          CALL DPWRST('XXX','BUG ')
10971          IERROR='YES'
10972        ENDIF
10973C
10974        IF(IER.EQ.1)THEN
10975          WRITE(ICOUT,8103)
10976 8103     FORMAT('      QAGI: MAXIMUM AKMBER OF SUBDIVISIONS EXCEEDED.')
10977          CALL DPWRST('XXX','BUG ')
10978        ELSEIF(IER.EQ.2)THEN
10979          WRITE(ICOUT,8105)
10980 8105     FORMAT('      QAGI: ROUNDOFF ERROR PREVENTS REQUESTED ',
10981     1           'TOLERANCE FROM BEING ACHIEVED.')
10982          CALL DPWRST('XXX','BUG ')
10983        ELSEIF(IER.EQ.3)THEN
10984          WRITE(ICOUT,8107)
10985 8107     FORMAT('      QAGI: BAD INTEGRAND BEHAVIOUR DETECTED.')
10986          CALL DPWRST('XXX','BUG ')
10987        ELSEIF(IER.EQ.4)THEN
10988          WRITE(ICOUT,8109)
10989 8109     FORMAT('      QAGI: INTEGRATION DID NOT CONVERGE.')
10990          CALL DPWRST('XXX','BUG ')
10991        ELSEIF(IER.EQ.5)THEN
10992          WRITE(ICOUT,8111)
10993 8111     FORMAT('      QAIG: THE INTEGRATION IS PROBABLY DIVERGENT.')
10994          CALL DPWRST('XXX','BUG ')
10995        ELSEIF(IER.EQ.6)THEN
10996          CALL DPWRST('XXX','BUG ')
10997          WRITE(ICOUT,8113)
10998 8113     FORMAT('      QAGI: INVALID INPUT TO THE INTEGRATION ',
10999     1           'ROUTINE.')
11000          CALL DPWRST('XXX','BUG ')
11001        ENDIF
11002C
11003      ELSE
11004        CALL DPINT2(IFUNC3,N3,PARAM,IPARN,IPARN2,NUMPV,
11005     1              IANGLU,ITYPEH,IW21HO,IW22HO,W2HOLD,NWHOLD,
11006     1              IDUMV,IDUMV2,NUMDV,XMIN,XMAX,XINT,
11007     1              IFLGFB,IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,
11008     1              NUMNAM,MAXNAM,IFTEXP,IFTORD,IFORSW,
11009     1              PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,V,MAXN,
11010     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,MAXCP4,MAXCP5,MAXCP6,
11011     1              IBUGA3,IBUGCO,IBUGEV,ISUBRO,IERROR)
11012      ENDIF
11013C
11014C               *****************************************************
11015C               **  STEP 9--                                       **
11016C               **  ENTER THE INTEGRATION VALUE INTO THE DATAPLOT  **
11017C               **  HOUSEKEEPING ARRAY                             **
11018C               *****************************************************
11019C
11020      ISTEPN='9'
11021      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'INTE')
11022     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11023C
11024      IHL=IHLEFT
11025      IHL2=IHLEF2
11026      ICASEL='P'
11027      IXINT=INT(XINT+0.5)
11028CCCCC THE FOLLOWING 2 LINES WERE ADDED NOVEMBER 1989
11029      BJUNK(1)=AJUNK
11030      NJUNK=1
11031CCCCC THE FOLLOWING LINE WAS CHANGED NOVEMBER 1989
11032CCCCC CALL DPINVP(IHL,IHL2,ICASEL,AJUNK,NJUNK,XINT,IXINT,
11033      CALL DPINVP(IHL,IHL2,ICASEL,BJUNK,NJUNK,XINT,IXINT,
11034     1            ISUBN1,ISUBN2,IBUGA3,IERROR)
11035C
11036C               ****************
11037C               **  STEP 90-- **
11038C               **  EXIT      **
11039C               ****************
11040C
11041 9000 CONTINUE
11042      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'INTE')THEN
11043        WRITE(ICOUT,999)
11044        CALL DPWRST('XXX','BUG ')
11045        WRITE(ICOUT,9011)
11046 9011   FORMAT('***** AT THE END OF DPINTE--')
11047        CALL DPWRST('XXX','BUG ')
11048        DO9015I=1,NUMNAM
11049          WRITE(ICOUT,9016)I,IHNAME(I),IHNAM2(I),IUSE(I),
11050     1                     IVSTAR(I),IVSTOP(I)
11051 9016     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IVSTAR(I),IVSTOP(I)=',
11052     1           I8,2X,A4,A4,2X,A4,2I8)
11053          CALL DPWRST('XXX','BUG ')
11054 9015   CONTINUE
11055        WRITE(ICOUT,9017)NUMCHF,MAXCHF,IWIDTH,N2,N3,NUMPV
11056 9017   FORMAT('NUMCHF,MAXCHF,IWIDTH,N2,N3,NUMPV = ',6I8)
11057        CALL DPWRST('XXX','BUG ')
11058        WRITE(ICOUT,9018)(IFUNC(I),I=1,MIN(115,IWIDTH))
11059 9018   FORMAT('IFUNC(.) = ',115A1)
11060        CALL DPWRST('XXX','BUG ')
11061        WRITE(ICOUT,9019)(IFUNC2(I),I=1,MIN(115,N2))
11062 9019   FORMAT('IFUNC2(.) = ',115A1)
11063        CALL DPWRST('XXX','BUG ')
11064        WRITE(ICOUT,9021)(IFUNC3(I),I=1,MIN(115,N3))
11065 9021   FORMAT('IFUNC3(.) = ',115A1)
11066        CALL DPWRST('XXX','BUG ')
11067        WRITE(ICOUT,9023)IP,IV,IDUMV(1),IDUMV2(1),LOCDUM
11068 9023   FORMAT('IP,IV,IDUMV(1),IDUMV2(1),LOCDUM = ',2I8,2X,A4,A4,I8)
11069        CALL DPWRST('XXX','BUG ')
11070        WRITE(ICOUT,9025)IHLEFT,IHLEF2,ICASEL,IFOUND,IERROR
11071 9025   FORMAT('IHLEFT,IHLEF2,ICASEL,IFOUND,IERROR = ',4(A4,2X),A4)
11072        CALL DPWRST('XXX','BUG ')
11073        WRITE(ICOUT,9026)XMIN,XMAX,XINT
11074 9026   FORMAT('XMIN,XMAX,XINT = ',3E15.7)
11075        CALL DPWRST('XXX','BUG ')
11076      ENDIF
11077C
11078      RETURN
11079      END
11080      SUBROUTINE DPINVP(IHLEFT,IHLEF2,ICASEL,VLEFT,NLEFT,PLEFT,ILEFT,
11081     1ISUBN3,ISUBN4,IBUGA3,IERROR)
11082C
11083C     PURPOSE--INSERT THE VARIABLE OR PARAMETER
11084C              WITH NAME   IHLEFT
11085C              INTO THE INTERNAL DATAPLOT TABLE.
11086C              ALSO, UPDATE INTERNAL DATAPLOT
11087C              LISTS (IF NECESSARY).
11088C
11089C     WRITTEN BY--JAMES J. FILLIBEN
11090C                 STATISTICAL ENGINEERING DIVISION
11091C                 INFORMATION TECHNOLOGY LABORATORY
11092C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11093C                 GAITHERSBURG, MD 20899-8980
11094C                 PHONE--301-975-2855
11095C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11096C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11097C     LANGUAGE--ANSI FORTRAN (1977)
11098C     VERSION NUMBER--82/7
11099C     ORIGINAL VERSION--JANUARY   1979.
11100C     UPDATED         --FEBRUARY  1979.
11101C     UPDATED         --JULY      1981.
11102C     UPDATED         --MAY       1982.
11103C
11104C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11105C
11106      CHARACTER*4 IHLEFT
11107      CHARACTER*4 IHLEF2
11108      CHARACTER*4 ICASEL
11109      CHARACTER*4 ISUBN3
11110      CHARACTER*4 ISUBN4
11111      CHARACTER*4 IBUGA3
11112      CHARACTER*4 IERROR
11113C
11114      CHARACTER*4 NEWNAM
11115      CHARACTER*4 NEWCOL
11116C
11117      CHARACTER*4 ISUBN1
11118      CHARACTER*4 ISUBN2
11119      CHARACTER*4 ISTEPN
11120C
11121C---------------------------------------------------------------------
11122C
11123      DIMENSION VLEFT(*)
11124C
11125C-----COMMON----------------------------------------------------------
11126C
11127      INCLUDE 'DPCOPA.INC'
11128      INCLUDE 'DPCOHK.INC'
11129      INCLUDE 'DPCODA.INC'
11130      INCLUDE 'DPCOP2.INC'
11131C
11132C-----START POINT-----------------------------------------------------
11133C
11134      ISUBN1='DPIN'
11135      ISUBN2='VP  '
11136C
11137      MAXCP1=MAXCOL+1
11138      MAXCP2=MAXCOL+2
11139C
11140      IERROR='NO'
11141C
11142      ICOLL=0
11143C
11144C               ******************************************
11145C               **  INSERT A VARIABLE                   **
11146C               **  INTO THE GENERAL DATAPLOT           **
11147C               **  ARRAY V(.)  ; OR                    **
11148C               **  INSERT A PARAMETER VALUE            **
11149C               **  INTO THE INTERNAL DATAPLOT TABLE.   **
11150C               **  MAKE ADJUSTMENTS TO THE             **
11151C               **  INTERNAL DATAPLOT LISTS.            **
11152C               ******************************************
11153C
11154      IF(IBUGA3.EQ.'OFF')GOTO90
11155      WRITE(ICOUT,999)
11156  999 FORMAT(1X)
11157      CALL DPWRST('XXX','BUG ')
11158      WRITE(ICOUT,51)
11159   51 FORMAT('***** AT THE BEGINNING OF DPINVP--')
11160      CALL DPWRST('XXX','BUG ')
11161      WRITE(ICOUT,52)IHLEFT,IHLEF2,ICASEL,NLEFT,PLEFT
11162   52 FORMAT('IHLEFT,IHLEF2,ICASEL,NLEFT,PLEFT = ',
11163     1A4,A4,2X,A4,I8,E15.7)
11164      CALL DPWRST('XXX','BUG ')
11165      WRITE(ICOUT,53)VLEFT(1),VLEFT(NLEFT)
11166   53 FORMAT('VLEFT(1),VLEFT(NLEFT) = ',2E15.7)
11167      CALL DPWRST('XXX','BUG ')
11168      WRITE(ICOUT,54)NUMNAM,MAXNAM,NUMCOL,MAXN,MAXCOL
11169   54 FORMAT('NUMNAM,MAXNAM,NUMCOL,MAXN,MAXCOL = ',5I8)
11170      CALL DPWRST('XXX','BUG ')
11171   90 CONTINUE
11172C
11173C               **********************************
11174C               **  STEP 1--                    **
11175C               **  INITIALIZE SOME VARIABLES.  **
11176C               **********************************
11177C
11178      ISTEPN='1'
11179      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11180C
11181      NEWNAM='NO'
11182      NEWCOL='NO'
11183C
11184C               *******************************************************
11185C               **  STEP 2--                                         **
11186C               **  DETERMINE WHETHER OR NOT THE NAME IN IHLEFT      **
11187C               **  ALREADY EXISTS IN THE INTERNAL IHNAME(.) TABLE.  **
11188C               **  THE 'YES' OR 'NO' RESULT IS PLACED IN    NEWNAM. **
11189C               **  THE LINE IN THE TABLE IS PLACED INTO ILISTL.     **
11190C               **  DETERMINE ALSO IF THE NUMBER OF NAMES            **
11191C               **  IN THE IHNAME(.) TABLE EXCEEDS THE               **
11192C               **  MAXIMUM ALLOWABLE NUMBER (MAXNAM).               **
11193C               *******************************************************
11194C
11195      ISTEPN='2'
11196      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11197C
11198      DO2000I=1,NUMNAM
11199      I2=I
11200      IF(IHLEFT.EQ.IHNAME(I).AND.IHLEF2.EQ.IHNAM2(I))GOTO2030
11201 2000 CONTINUE
11202      NEWNAM='YES'
11203      ILISTL=NUMNAM+1
11204      GOTO2050
11205 2030 CONTINUE
11206      NEWNAM='NO'
11207      ILISTL=I2
11208 2050 CONTINUE
11209C
11210      IF(ILISTL.LE.MAXNAM)GOTO2090
11211      WRITE(ICOUT,2051)ISUBN1,ISUBN2,ISUBN3,ISUBN4
11212 2051 FORMAT('***** ERROR IN ',A4,A4,'AS CALLED FROM ',A4,A4,'--')
11213      CALL DPWRST('XXX','BUG ')
11214      WRITE(ICOUT,2052)
11215 2052 FORMAT('      THE NUMBER OF VARIABLE/PARAMETER',
11216     1'/FUNCTION NAMES')
11217      CALL DPWRST('XXX','BUG ')
11218      WRITE(ICOUT,2053)MAXNAM
11219 2053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE (= ',
11220     1I8,')   .')
11221      CALL DPWRST('XXX','BUG ')
11222      WRITE(ICOUT,2054)
11223 2054 FORMAT('      SUGGESTED ACTION--')
11224      CALL DPWRST('XXX','BUG ')
11225      WRITE(ICOUT,2055)
11226 2055 FORMAT('      ENTER      STAT')
11227      CALL DPWRST('XXX','BUG ')
11228      WRITE(ICOUT,2056)
11229 2056 FORMAT('      TO FIND OUT THE FULL LIST OF USED NAMES')
11230      CALL DPWRST('XXX','BUG ')
11231      WRITE(ICOUT,2057)
11232 2057 FORMAT('      AND THEN REUSE SOME NAME.   ')
11233      CALL DPWRST('XXX','BUG ')
11234      WRITE(ICOUT,2058)
11235 2058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
11236      CALL DPWRST('XXX','BUG ')
11237      IF(IWIDTH.GE.1)WRITE(ICOUT,2059)(IANS(I),I=1,IWIDTH)
11238 2059 FORMAT(80A1)
11239      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
11240      IERROR='YES'
11241      GOTO9000
11242 2090 CONTINUE
11243C
11244C               ***************************************
11245C               **  STEP 3--                         **
11246C               **  IF OUTPUT IS TO BE A VARIABLE,   **
11247C               **  DETERMINE WHAT COLUMN IN V(.)    **
11248C               **  THE OUTPUT WILL GO.              **
11249C               **  THE RESULT WILL BE PLACED        **
11250C               **  INTO  ICOLL    .                 **
11251C               ***************************************
11252C
11253      ISTEPN='3'
11254      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11255C
11256      IF(ICASEL.NE.'V')GOTO3099
11257C
11258      IF(NEWNAM.EQ.'YES')NEWCOL='YES'
11259      IF(NEWNAM.EQ.'YES')ICOLL=NUMCOL+1
11260C
11261      IF(NEWNAM.EQ.'NO'.AND.IUSE(ILISTL).NE.'V')NEWCOL='YES'
11262      IF(NEWNAM.EQ.'NO'.AND.IUSE(ILISTL).NE.'V')ICOLL=NUMCOL+1
11263C
11264      IF(NEWNAM.EQ.'NO'.AND.IUSE(ILISTL).EQ.'V')NEWCOL='NO'
11265      IF(NEWNAM.EQ.'NO'.AND.IUSE(ILISTL).EQ.'V')ICOLL=IVALUE(ILISTL)
11266C
11267 3099 CONTINUE
11268C
11269C               *****************************************
11270C               **  STEP 4--                           **
11271C               **  DETERMINE IF THE COLUMN IN V(.)    **
11272C               **  WOULD EXCEED THE MAX ALLOWABLE     **
11273C               **  NUMBER OF COLUMNS.                 **
11274C               *****************************************
11275C
11276      ISTEPN='4'
11277      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11278C
11279      IF(ICASEL.NE.'V')GOTO4099
11280      IF(ICASEL.EQ.'V'.AND.ICOLL.LE.MAXCOL)GOTO4099
11281C
11282      WRITE(ICOUT,4051)ISUBN1,ISUBN2,ISUBN3,ISUBN4
11283 4051 FORMAT('***** ERROR IN ',A4,A4,'AS CALLED FROM ',A4,A4,'--')
11284      CALL DPWRST('XXX','BUG ')
11285      WRITE(ICOUT,4052)
11286 4052 FORMAT('      THE NUMBER OF DATA COLUMNS')
11287      CALL DPWRST('XXX','BUG ')
11288      WRITE(ICOUT,4053)MAXCOL
11289 4053 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
11290      CALL DPWRST('XXX','BUG ')
11291      WRITE(ICOUT,4054)
11292 4054 FORMAT('      SUGGESTED ACTION--')
11293      CALL DPWRST('XXX','BUG ')
11294      WRITE(ICOUT,4055)
11295 4055 FORMAT('      ENTER      STAT')
11296      CALL DPWRST('XXX','BUG ')
11297      WRITE(ICOUT,4056)
11298 4056 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
11299      CALL DPWRST('XXX','BUG ')
11300      WRITE(ICOUT,4057)
11301 4057 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
11302      CALL DPWRST('XXX','BUG ')
11303      WRITE(ICOUT,4058)
11304 4058 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
11305      CALL DPWRST('XXX','BUG ')
11306      IF(IWIDTH.GE.1)WRITE(ICOUT,4059)(IANS(I),I=1,IWIDTH)
11307 4059 FORMAT(80A1)
11308      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
11309      IERROR='YES'
11310      GOTO9000
11311 4099 CONTINUE
11312C
11313C               *******************************************
11314C               **  STEP 5--                             **
11315C               **  IF OUTPUT IS TO BE A VARIABLE,       **
11316C               **  ENTER THE CONTENTS OF VLEFT(.)       **
11317C               **  (ALL NLEFT ELEMENTS OF VLEFT(.))     **
11318C               **  INTO COLUMN     ICOLL    OF V(.)  .  **
11319C               *******************************************
11320C
11321      ISTEPN='5'
11322      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11323C
11324      IF(ICASEL.NE.'V')GOTO5099
11325      IF(NLEFT.LE.0)GOTO5099
11326      IF(NLEFT.LE.MAXN)GOTO5039
11327C
11328      WRITE(ICOUT,5021)ISUBN1,ISUBN2,ISUBN3,ISUBN4
11329 5021 FORMAT('***** ERROR IN ',A4,A4,'AS CALLED FROM ',A4,A4,'--')
11330      CALL DPWRST('XXX','BUG ')
11331      WRITE(ICOUT,5022)NLEFT
11332 5022 FORMAT('      THE NUMBER (= ',I8,') OF ELEMENTS ')
11333      CALL DPWRST('XXX','BUG ')
11334      WRITE(ICOUT,5023)IHLEFT,IHLEF2
11335 5023 FORMAT('      FOR VARIABLE ',A4,A4)
11336      CALL DPWRST('XXX','BUG ')
11337      WRITE(ICOUT,5024)MAXN
11338 5024 FORMAT('      HAS JUST EXCEEDED THE MAX ALLOWABLE ',I8,'  .')
11339      CALL DPWRST('XXX','BUG ')
11340      WRITE(ICOUT,5025)
11341 5025 FORMAT('      SUGGESTED ACTION--')
11342      CALL DPWRST('XXX','BUG ')
11343      WRITE(ICOUT,5026)
11344 5026 FORMAT('      ENTER      STAT')
11345      CALL DPWRST('XXX','BUG ')
11346      WRITE(ICOUT,5027)
11347 5027 FORMAT('      TO FIND OUT THE FULL LIST OF USED COLUMNS')
11348      CALL DPWRST('XXX','BUG ')
11349      WRITE(ICOUT,5028)
11350 5028 FORMAT('      AND THEN OVERWRITE SOME COLUMN.   ')
11351      CALL DPWRST('XXX','BUG ')
11352      WRITE(ICOUT,5029)
11353 5029 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
11354      CALL DPWRST('XXX','BUG ')
11355      IF(IWIDTH.GE.1)WRITE(ICOUT,5030)(IANS(I),I=1,IWIDTH)
11356 5030 FORMAT(80A1)
11357      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
11358      IERROR='YES'
11359      GOTO9000
11360 5039 CONTINUE
11361C
11362      DO5070I=1,NLEFT
11363      IJ=MAXN*(ICOLL-1)+I
11364      IF(ICOLL.LE.MAXCOL)V(IJ)=VLEFT(I)
11365      IF(ICOLL.EQ.MAXCP1)PRED(I)=VLEFT(I)
11366      IF(ICOLL.EQ.MAXCP2)RES(I)=VLEFT(I)
11367 5070 CONTINUE
11368C
11369 5099 CONTINUE
11370C
11371C               *******************************************
11372C               **  STEP 7--                             **
11373C               **  CARRY OUT THE LIST UPDATING AND      **
11374C               **  GENERATE THE INFORMATIVE PRINTING    **
11375C               *******************************************
11376C
11377      ISTEPN='7'
11378      IF(IBUGA3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11379C
11380      IF(ICASEL.EQ.'P')GOTO7010
11381      IF(ICASEL.EQ.'V')GOTO7020
11382      GOTO9000
11383C
11384 7010 CONTINUE
11385      IHNAME(ILISTL)=IHLEFT
11386      IHNAM2(ILISTL)=IHLEF2
11387      VALUE(ILISTL)=PLEFT
11388      IVALUE(ILISTL)=ILEFT
11389      IN(ILISTL)=ILEFT
11390      IUSE(ILISTL)='P'
11391      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
11392C
11393      IF(IFEEDB.EQ.'OFF')GOTO7019
11394      WRITE(ICOUT,999)
11395      CALL DPWRST('XXX','BUG ')
11396      WRITE(ICOUT,7011)IHLEFT,IHLEF2,VALUE(ILISTL)
11397 7011 FORMAT('THE COMPUTED VALUE OF THE CONSTANT   ',A4,A4,
11398     1' = ',E15.7)
11399      CALL DPWRST('XXX','BUG ')
11400      WRITE(ICOUT,999)
11401      CALL DPWRST('XXX','BUG ')
11402 7019 CONTINUE
11403      GOTO7190
11404C
11405 7020 CONTINUE
11406      IHNAME(ILISTL)=IHLEFT
11407      IHNAM2(ILISTL)=IHLEF2
11408      IUSE(ILISTL)='V'
11409      IVALUE(ILISTL)=ICOLL
11410      VALUE(ILISTL)=ICOLL
11411      IN(ILISTL)=NLEFT
11412C
11413CCCCC IUSE(ICOLL)='V'
11414CCCCC IVALUE(ICOLL)=ICOLL
11415CCCCC VALUE(ICOLL)=ICOLL
11416CCCCC IN(ICOLL)=NLEFT
11417C
11418      IF(NEWNAM.EQ.'YES')NUMNAM=NUMNAM+1
11419      IF(NEWCOL.EQ.'YES')NUMCOL=NUMCOL+1
11420C
11421      DO7100I=1,NUMNAM
11422      I2=I
11423      IF(IUSE(I).EQ.'V'.AND.IVALUE(I).EQ.ICOLL)GOTO7105
11424      GOTO7100
11425 7105 CONTINUE
11426      IUSE(I2)='V'
11427      IVALUE(I2)=ICOLL
11428      VALUE(I2)=ICOLL
11429      IN(I2)=NLEFT
11430 7100 CONTINUE
11431C
11432      NS=NLEFT
11433      IF(IFEEDB.EQ.'OFF')GOTO7119
11434      WRITE(ICOUT,999)
11435      CALL DPWRST('XXX','BUG ')
11436      WRITE(ICOUT,7111)IHLEFT,IHLEF2,NS
11437 7111 FORMAT('THE NUMBER OF VALUES GENERATED FOR ',
11438     1'THE VARIABLE ',A4,A4,' = ',I8)
11439      CALL DPWRST('XXX','BUG ')
11440 7119 CONTINUE
11441C
11442      IROW1=1
11443      IROWN=NLEFT
11444C
11445      IF(IFEEDB.EQ.'OFF')GOTO7149
11446      WRITE(ICOUT,999)
11447      CALL DPWRST('XXX','BUG ')
11448      IJ1=MAXN*(ICOLL-1)+IROW1
11449      IF(ICOLL.LE.MAXCOL)WRITE(ICOUT,7121)IHLEFT,IHLEF2,V(IJ1),
11450     1IROW1
11451 7121 FORMAT('THE FIRST          COMPUTED VALUE OF ',A4,A4,
11452     1' = ',E15.7,' (ROW ',I5,')')
11453      IF(ICOLL.LE.MAXCOL)CALL DPWRST('XXX','BUG ')
11454      IF(ICOLL.EQ.MAXCP1)WRITE(ICOUT,7121)IHLEFT,IHLEF2,PRED(IROW1),
11455     1IROW1
11456      IF(ICOLL.EQ.MAXCP1)CALL DPWRST('XXX','BUG ')
11457      IF(ICOLL.EQ.MAXCP2)WRITE(ICOUT,7121)IHLEFT,IHLEF2,RES(IROW1),
11458     1IROW1
11459      IF(ICOLL.EQ.MAXCP2)CALL DPWRST('XXX','BUG ')
11460      IJN=MAXN*(ICOLL-1)+IROWN
11461      IF(ICOLL.LE.MAXCOL.AND.
11462     1NS.NE.1)WRITE(ICOUT,7131)NS,IHLEFT,IHLEF2,V(IJN),IROWN
11463      IF(ICOLL.LE.MAXCOL.AND.
11464     1NS.NE.1)CALL DPWRST('XXX','BUG ')
11465      IF(ICOLL.EQ.MAXCP1.AND.
11466     1NS.NE.1)WRITE(ICOUT,7131)NS,IHLEFT,IHLEF2,PRED(IROWN),IROWN
11467      IF(ICOLL.EQ.MAXCP1.AND.
11468     1NS.NE.1)CALL DPWRST('XXX','BUG ')
11469      IF(ICOLL.EQ.MAXCP2.AND.
11470     1NS.NE.1)WRITE(ICOUT,7131)NS,IHLEFT,IHLEF2,RES(IROWN),IROWN
11471 7131 FORMAT('THE LAST (',I5,'TH) COMPUTED VALUE OF ',A4,A4,
11472     1' = ',E15.7,' (ROW ',I5,')')
11473      IF(ICOLL.EQ.MAXCP2.AND.
11474     1NS.NE.1)CALL DPWRST('XXX','BUG ')
11475      IF(NS.NE.1)GOTO7180
11476C
11477      WRITE(ICOUT,7142)
11478 7142 FORMAT('NOTE--THE ABOVE VALUE WAS THE ONLY VALUE COMPUTED ',
11479     1'FOR THIS VARIABLE.')
11480      CALL DPWRST('XXX','BUG ')
11481 7149 CONTINUE
11482 7180 CONTINUE
11483C
11484      IF(IFEEDB.EQ.'OFF')GOTO7189
11485      WRITE(ICOUT,999)
11486      CALL DPWRST('XXX','BUG ')
11487      WRITE(ICOUT,7182)IHLEFT,IHLEF2,ICOLL
11488 7182 FORMAT('THE CURRENT COLUMN FOR ',
11489     1'THE VARIABLE ',A4,A4,'  = ',I8)
11490      CALL DPWRST('XXX','BUG ')
11491      WRITE(ICOUT,7183)IHLEFT,IHLEF2,NLEFT
11492 7183 FORMAT('THE CURRENT LENGTH OF  ',
11493     1'THE VARIABLE ',A4,A4,'  = ',I8)
11494      CALL DPWRST('XXX','BUG ')
11495      WRITE(ICOUT,999)
11496      CALL DPWRST('XXX','BUG ')
11497 7189 CONTINUE
11498C
11499 7190 CONTINUE
11500C
11501C               ****************
11502C               **  STEP 90-- **
11503C               **  EXIT      **
11504C               ****************
11505C
11506 9000 CONTINUE
11507      IF(IBUGA3.EQ.'OFF')GOTO9090
11508      WRITE(ICOUT,999)
11509      CALL DPWRST('XXX','BUG ')
11510      WRITE(ICOUT,9011)
11511 9011 FORMAT('AT THE END       OF DPINVP--')
11512      CALL DPWRST('XXX','BUG ')
11513      WRITE(ICOUT,9012)IHLEFT,IHLEF2,ICASEL,NLEFT,PLEFT,ILEFT
11514 9012 FORMAT('IHLEFT,IHLEF2,ICASEL,NLEFT,PLEFT,ILEFT = ',
11515     1A4,A4,2X,A4,I8,E15.7,I8)
11516      CALL DPWRST('XXX','BUG ')
11517      WRITE(ICOUT,9013)VLEFT(1),VLEFT(NLEFT)
11518 9013 FORMAT('VLEFT(1),VLEFT(NLEFT) = ',2E15.7)
11519      CALL DPWRST('XXX','BUG ')
11520      WRITE(ICOUT,9015)NEWNAM,ILISTL,ICOLL,NUMNAM
11521 9015 FORMAT('NEWNAM,ILISTL,ICOLL,NUMNAM = ',A4,I8,I8,I8)
11522      CALL DPWRST('XXX','BUG ')
11523      WRITE(ICOUT,9016)IHNAME(ILISTL),IHNAM2(ILISTL),IVALUE(ILISTL),
11524     1VALUE(ILISTL)
11525 9016 FORMAT('IHNAME(ILISTL),IHNAM2(ILISTL),IVALUE(ILISTL),',
11526     1'VALUE(ILISTL) = ',A4,A4,2X,I8,2X,E15.7)
11527      CALL DPWRST('XXX','BUG ')
11528      WRITE(ICOUT,9017)IUSE(ILISTL),IN(ILISTL)
11529 9017 FORMAT('IUSE(ILISTL),IN(ILISTL) = ',A4,2X,I8)
11530      CALL DPWRST('XXX','BUG ')
11531      IJ1=MAXN*(ICOLL-1)+1
11532      IJN=MAXN*(ICOLL-1)+NLEFT
11533      WRITE(ICOUT,9018)IJ1,IJN,V(IJ1),V(IJN)
11534 9018 FORMAT('IJ1,IJN,V(IJ1),V(IJN) = ',2I8,2E15.7)
11535      CALL DPWRST('XXX','BUG ')
11536 9090 CONTINUE
11537C
11538      RETURN
11539      END
11540      SUBROUTINE DPISOP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
11541     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
11542C
11543C     PURPOSE--GENERATE A Z-SCORE VERSUS LAB AVERAGE PLOT AS GIVEN
11544C              IN THE ISO 13528 STANDARD.
11545C
11546C              THE COMMAND HAS THE FOLLOWING FORMAT:
11547C
11548C                  ISO 13528 PLOT Y Z ROUND LABID LAB
11549C
11550C              WHERE Y IS THE ORIGINAL RESPONSE, Z IS THE Z-SCORE OF THE
11551C              RESPONSE, ROUND IS THE ROUND-ID, LABID IS THE LAB-ID FOR
11552C              ALL LABS, AND LAB IDENTIFIES THE LABS FOR WHICH THE PLOT
11553C              WILL BE GENERATED (TYPICALLY, THIS WILL BE A SINGLE LAB).
11554C
11555C              IN SOME CASES, ONLY THE Z-SCORES WILL BE AVAILABLE.
11556C              IN THIS CASE, Y WILL DENOTE THE LAB AVERAGES IN THE
11557C              ORIGINAL UNITS.
11558C
11559C              THE PLOT IS:
11560C
11561C                  VERTICAL AXIS: FOR A GIVEN LAB, THE Z-SCORES FOR EACH
11562C                                 ROUND.
11563C                  HORIZONRAL AXIS: FOR EACH ROUND, COMPUTE THE AVERAGE
11564C                                   OVER ALL LABORATORIES.
11565C
11566C              YOU CAN OPTIONALLY PROVIDE A MATERIAL-ID VARIABLE.
11567C              THIS IS ESSENTIALLY A HIGHLIGHTING VARIABLE (I.E.,
11568C              DIFFERENT MATERIALS CAN BE PLOTTED WITH DIFFERENT
11569C              PLOT CHARACTERS).  THIS FORM HAS THE SYNTAX
11570C
11571C                  ISO 13528 PLOT Y Z ROUND LABID MATID LAB
11572C
11573C     EXAMPLE--ISO 13528 PLOT Y Z LAB LABA
11574C     WRITTEN BY--ALAN HECKERT
11575C                 STATISTICAL ENGINEERING DIVISION
11576C                 INFORMATION TECHNOLOGY LABORATORY
11577C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11578C                 GAITHERSBURG, MD 20899-8980
11579C                 PHONE--301-975-2899
11580C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11581C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11582C     LANGUAGE--ANSI FORTRAN (1977)
11583C     VERSION NUMBER--2012/2
11584C     ORIGINAL VERSION--FEBRUARY   2012.
11585C
11586C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11587C
11588      CHARACTER*4 ICASPL
11589      CHARACTER*4 IAND1
11590      CHARACTER*4 IAND2
11591      CHARACTER*4 IBUGG2
11592      CHARACTER*4 IBUGG3
11593      CHARACTER*4 IBUGQ
11594      CHARACTER*4 ISUBRO
11595      CHARACTER*4 IFOUND
11596      CHARACTER*4 IERROR
11597C
11598      CHARACTER*4 ISUBN1
11599      CHARACTER*4 ISUBN2
11600      CHARACTER*4 ISTEPN
11601C
11602      CHARACTER*4 ICASE
11603      CHARACTER*40 INAME
11604      PARAMETER (MAXSPN=10)
11605      CHARACTER*4 IVARN1(MAXSPN)
11606      CHARACTER*4 IVARN2(MAXSPN)
11607      CHARACTER*4 IVARTY(MAXSPN)
11608      REAL PVAR(MAXSPN)
11609      INTEGER ILIS(MAXSPN)
11610      INTEGER NRIGHT(MAXSPN)
11611      INTEGER ICOLR(MAXSPN)
11612C
11613C---------------------------------------------------------------------
11614C
11615      INCLUDE 'DPCOPA.INC'
11616      INCLUDE 'DPCOZZ.INC'
11617C
11618      DIMENSION Z(MAXOBV)
11619      DIMENSION YRAW(MAXOBV)
11620      DIMENSION ROUND(MAXOBV)
11621      DIMENSION ALABID(MAXOBV)
11622      DIMENSION ALAB(MAXOBV)
11623      DIMENSION TEMP1(MAXOBV)
11624      DIMENSION TEMP2(MAXOBV)
11625      DIMENSION TEMP3(MAXOBV)
11626      DIMENSION TEMP4(MAXOBV)
11627      DIMENSION TEMP5(MAXOBV)
11628      DIMENSION TEMP6(MAXOBV)
11629      DIMENSION PPA0(MAXOBV)
11630      DIMENSION PPA1(MAXOBV)
11631      DIMENSION PPA0SD(MAXOBV)
11632      DIMENSION PPA1SD(MAXOBV)
11633      DIMENSION AMATID(MAXOBV)
11634C
11635      EQUIVALENCE (GARBAG(IGARB1),Z(1))
11636      EQUIVALENCE (GARBAG(IGARB2),YRAW(1))
11637      EQUIVALENCE (GARBAG(IGARB3),ROUND(1))
11638      EQUIVALENCE (GARBAG(IGARB4),ALABID(1))
11639      EQUIVALENCE (GARBAG(IGARB5),ALAB(1))
11640      EQUIVALENCE (GARBAG(IGARB6),TEMP1(1))
11641      EQUIVALENCE (GARBAG(IGARB7),TEMP2(1))
11642      EQUIVALENCE (GARBAG(IGARB8),PPA0(1))
11643      EQUIVALENCE (GARBAG(IGARB9),PPA1(1))
11644      EQUIVALENCE (GARBAG(IGAR10),PPA0SD(1))
11645      EQUIVALENCE (GARBAG(JGAR11),PPA1SD(1))
11646      EQUIVALENCE (GARBAG(JGAR12),AMATID(1))
11647      EQUIVALENCE (GARBAG(JGAR13),TEMP3(1))
11648      EQUIVALENCE (GARBAG(JGAR14),TEMP4(1))
11649      EQUIVALENCE (GARBAG(JGAR15),TEMP5(1))
11650      EQUIVALENCE (GARBAG(JGAR16),TEMP6(1))
11651C
11652C-----COMMON----------------------------------------------------------
11653C
11654      INCLUDE 'DPCOST.INC'
11655      INCLUDE 'DPCOHO.INC'
11656      INCLUDE 'DPCOHK.INC'
11657      INCLUDE 'DPCODA.INC'
11658      INCLUDE 'DPCOP2.INC'
11659C
11660C-----START POINT-----------------------------------------------------
11661C
11662      IERROR='NO'
11663      IFOUND='NO'
11664      ISUBN1='DPIS'
11665      ISUBN2='OP  '
11666C
11667      MAXCP1=MAXCOL+1
11668      MAXCP2=MAXCOL+2
11669      MAXCP3=MAXCOL+3
11670      MAXCP4=MAXCOL+4
11671      MAXCP5=MAXCOL+5
11672      MAXCP6=MAXCOL+6
11673C
11674C               ****************************************
11675C               **  TREAT THE DEX CONTOUR PLOT CASE   **
11676C               ****************************************
11677C
11678      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ISOP')THEN
11679        WRITE(ICOUT,999)
11680  999   FORMAT(1X)
11681        CALL DPWRST('XXX','BUG ')
11682        WRITE(ICOUT,51)
11683   51   FORMAT('***** AT THE BEGINNING OF DPISOP--')
11684        CALL DPWRST('XXX','BUG ')
11685        WRITE(ICOUT,52)IBUGG2,IBUGG3,IBUGQ,ISUBRO
11686   52   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
11687        CALL DPWRST('XXX','BUG ')
11688        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXN
11689   53   FORMAT('ICASPL,IAND1,IAND2,MAXN = ',3(A4,2X),I8)
11690        CALL DPWRST('XXX','BUG ')
11691      ENDIF
11692C
11693C               ***************************
11694C               **  STEP 1--             **
11695C               **  EXTRACT THE COMMAND  **
11696C               ***************************
11697C
11698      ISTEPN='11'
11699      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ISOP')
11700     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11701C
11702      IF(NUMARG.GE.2 .AND. ICOM.EQ.'ISO ' .AND.IHARG(1).EQ.'1352' .AND.
11703     1   IHARG(2).EQ.'PLOT')THEN
11704        ILASTC=2
11705        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
11706        IFOUND='YES'
11707        ICASPL='1352'
11708      ELSE
11709        GOTO9000
11710      ENDIF
11711C
11712C               ****************************************
11713C               **  STEP 2--                          **
11714C               **  EXTRACT THE VARIABLE LIST         **
11715C               ****************************************
11716C
11717      ISTEPN='2'
11718      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ISOP')
11719     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11720C
11721      INAME='ISO 13528 PLOT'
11722      MINNA=4
11723      MAXNA=100
11724      MINN2=2
11725      IFLAGE=98
11726      IFLAGM=0
11727      IFLAGP=0
11728      JMIN=1
11729      JMAX=NUMARG
11730      MINNVA=5
11731      MAXNVA=6
11732C
11733      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
11734     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
11735     1            JMIN,JMAX,
11736     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
11737     1            IVARN1,IVARN2,IVARTY,PVAR,
11738     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
11739     1            MINNVA,MAXNVA,
11740     1            IFLAGM,IFLAGP,
11741     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
11742      IF(IERROR.EQ.'YES')GOTO9000
11743C
11744      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ISOP')THEN
11745        WRITE(ICOUT,999)
11746        CALL DPWRST('XXX','BUG ')
11747        WRITE(ICOUT,281)
11748  281   FORMAT('***** AFTER CALL DPPARS--')
11749        CALL DPWRST('XXX','BUG ')
11750        WRITE(ICOUT,282)NQ,NUMVAR
11751  282   FORMAT('NQ,NUMVAR = ',2I8)
11752        CALL DPWRST('XXX','BUG ')
11753        IF(NUMVAR.GT.0)THEN
11754          DO285I=1,NUMVAR
11755            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
11756     1                      ICOLR(I),IVARTY(I)
11757  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
11758     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
11759            CALL DPWRST('XXX','BUG ')
11760  285     CONTINUE
11761        ENDIF
11762      ENDIF
11763C
11764C               **********************************************
11765C               **  STEP 33--                               **
11766C               **  FORM THE SUBSETTED VARIABLES            **
11767C               **       Y(.)                               **
11768C               **       Z(.)                               **
11769C               **       ROUND(.)                           **
11770C               **       ALABID(.)                          **
11771C               **       AMATID(.)                          **
11772C               **  CONTAINING                              **
11773C               **       THE RESPONSE VARIABLE (ORIGINAL    **
11774C               **           UNITS)                         **
11775C               **       THE Z-SCORE OF THE RESPONSE        **
11776C               **       THE ROUND-ID                       **
11777C               **       THE LAB-ID                         **
11778C               **       THE MATERIAL-ID                    **
11779C               **  RESPECTIVELY.                           **
11780C               **********************************************
11781C
11782      ISTEPN='33'
11783      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ISOP')
11784     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11785C
11786      IF(NRIGHT(1).EQ.NRIGHT(2))THEN
11787        ICOL=1
11788        NUMVA2=NUMVAR-1
11789        CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
11790     1              INAME,IVARN1,IVARN2,IVARTY,
11791     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
11792     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
11793     1              MAXCP4,MAXCP5,MAXCP6,
11794     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
11795     1              YRAW,Z,ROUND,ALABID,AMATID,TEMP1,TEMP1,NS,
11796     1              IBUGG3,ISUBRO,IFOUND,IERROR)
11797        IF(IERROR.EQ.'YES')GOTO9000
11798        NAVE=NS
11799      ELSE
11800        ICOL=2
11801        NUMVA2=NUMVAR-2
11802        CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
11803     1              INAME,IVARN1,IVARN2,IVARTY,
11804     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
11805     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
11806     1              MAXCP4,MAXCP5,MAXCP6,
11807     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
11808     1              Z,ROUND,ALABID,TEMP1,TEMP1,TEMP1,TEMP1,NS,
11809     1              IBUGG3,ISUBRO,IFOUND,IERROR)
11810        IF(IERROR.EQ.'YES')GOTO9000
11811C
11812        ICOL=1
11813        NUMVA2=1
11814        CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
11815     1              INAME,IVARN1,IVARN2,IVARTY,
11816     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
11817     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
11818     1              MAXCP4,MAXCP5,MAXCP6,
11819     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
11820     1              YRAW,TEMP1,TEMP1,TEMP1,TEMP1,TEMP1,TEMP1,NAVE,
11821     1              IBUGG3,ISUBRO,IFOUND,IERROR)
11822        IF(IERROR.EQ.'YES')GOTO9000
11823      ENDIF
11824C
11825      IF(NUMVAR.EQ.5)THEN
11826        DO3310I=1,NS
11827          AMATID(I)=1.0
11828 3310   CONTINUE
11829      ENDIF
11830C
11831C               **********************************************
11832C               **  STEP 34--                               **
11833C               **  FORM THE FULL VARIABLE                  **
11834C               **       ALAB(.)                            **
11835C               **  CONTAINING THE VALUES OF THE LABS FOR   **
11836C               **  WHICH THE PLOT WILL BE GENERATED.       **
11837C               **********************************************
11838C
11839      ISTEPN='34'
11840      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ISOP')
11841     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11842C
11843      ICOL=NUMVAR
11844      NUMVA2=1
11845      NQ=NRIGHT(ICOL)
11846      DO3410I=1,NQ
11847        ISUB(I)=1
11848 3410 CONTINUE
11849C
11850      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
11851     1            INAME,IVARN1,IVARN2,IVARTY,
11852     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
11853     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
11854     1            MAXCP4,MAXCP5,MAXCP6,
11855     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
11856     1            ALAB,TEMP1,TEMP1,NLAB,NLAB,NLAB,ICASE,
11857     1            IBUGG3,ISUBRO,IFOUND,IERROR)
11858        IF(IERROR.EQ.'YES')GOTO9000
11859C
11860C               *******************************************************
11861C               **  STEP 8--                                         **
11862C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
11863C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
11864C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
11865C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
11866C               *******************************************************
11867C
11868      ISTEPN='5'
11869      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ISOP')THEN
11870        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11871        WRITE(ICOUT,5001)NS,NAVE,NLAB,ICASPL
11872 5001   FORMAT('NS,NAVE,NLAB,ICASPL=',3I8,1X,A4)
11873        CALL DPWRST('XXX','BUG ')
11874      ENDIF
11875C
11876      CALL DPISO2(YRAW,Z,ROUND,ALABID,AMATID,ALAB,NS,NLAB,NAVE,
11877     1            ICASPL,NUMVAR,MAXOBV,IISOLA,IISOME,
11878     1            TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,
11879     1            PPA0,PPA1,PPA0SD,PPA1SD,
11880     1            Y,X,D,
11881     1            NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
11882C
11883C               ***************************************
11884C               **  STEP 9--                         **
11885C               **  GENERATE FIT FOR EACH LAB IN     **
11886C               **  ALAB VARIABLE.                   **
11887C               ***************************************
11888C
11889      ISTEPN='9'
11890      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ISOP')
11891     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11892C
11893      CALL DPISO4(PPA0,PPA1,PPA0SD,PPA1SD,NLAB,
11894     1            IBUGG3,ISUBRO,IERROR)
11895C
11896C               *****************
11897C               **  STEP 9--   **
11898C               **  EXIT       **
11899C               *****************
11900C
11901 9000 CONTINUE
11902      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'ISOP')THEN
11903        WRITE(ICOUT,999)
11904        CALL DPWRST('XXX','BUG ')
11905        WRITE(ICOUT,9011)
11906 9011   FORMAT('***** AT THE END       OF DPISOP--')
11907        CALL DPWRST('XXX','BUG ')
11908        WRITE(ICOUT,9013)IFOUND,IERROR
11909 9013   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
11910        CALL DPWRST('XXX','BUG ')
11911        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2
11912 9014   FORMAT('NPLOTV,NPLOTP,NLOCAL,ICASPL,IAND1,IAND2 = ',
11913     1         3I8,2X,2(A4,2X),A4)
11914        CALL DPWRST('XXX','BUG ')
11915      ENDIF
11916C
11917      RETURN
11918      END
11919      SUBROUTINE DPISO2(YRAW,Z,ROUND,ALABID,AMATID,ALAB,N,NLAB,NAVE,
11920     1                  ICASPL,NUMVAR,MAXOBV,IISOLA,IISOME,
11921     1                  YMEAN,XIDTEM,XIDTE2,TEMP1,TEMP2,TEMP3,
11922     1                  PPA0,PPA1,PPA0SD,PPA1SD,
11923     1                  Y,X,D,
11924     1                  NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
11925C
11926C     PURPOSE--GENERATE A Z-SCORE VERSUS LAB AVERAGE PLOT AS GIVEN
11927C              IN THE ISO 13528 STANDARD.
11928C
11929C              THE COMMAND HAS THE FOLLOWING FORMAT:
11930C
11931C                  ISO 13528 PLOT Y Z ROUND LABID MATID LAB
11932C
11933C              WHERE Y IS THE ORIGINAL RESPONSE, Z IS THE Z-SCORE OF THE
11934C              RESPONSE, ROUND IS THE ROUND-ID, LABID IS THE LAB-ID FOR
11935C              ALL LABS, MATID IS THE MATERIAL ID, AND LAB IDENTIFIES
11936C              THE LABS FOR WHICH THE PLOT WILL BE GENERATED (TYPICALLY,
11937C              THIS WILL BE A SINGLE LAB).
11938C
11939C              THE PLOT IS:
11940C
11941C                  VERTICAL AXIS: FOR A GIVEN LAB, THE Z-SCORES FOR EACH
11942C                                 ROUND.
11943C                  HORIZONRAL AXIS: FOR EACH ROUND, COMPUTE THE AVERAGE
11944C                                   OVER ALL LABORATORIES.
11945C
11946C     REFERENCE--ISO 13528 (2005), "Statistical Methods for use in
11947C                proficiency testing by interlaboratory comparisons,"
11948C                First Edition, 2005-09-01, pp. 56-57.
11949C     WRITTEN BY--ALAN HECKERT
11950C                 STATISTICAL ENGINEERING DIVISION
11951C                 INFORMATION TECHNOLOGY LABORATORY
11952C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11953C                 GAITHERSBURG, MD 20899-8980
11954C                 PHONE--301-975-2899
11955C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11956C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11957C     LANGUAGE--ANSI FORTRAN (1977)
11958C     VERSION NUMBER--2012/2
11959C     ORIGINAL VERSION--FEBRUARY  2012.
11960C
11961C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11962C
11963      CHARACTER*4 ICASPL
11964      CHARACTER*4 IISOLA
11965      CHARACTER*4 IISOME
11966      CHARACTER*4 IBUGG3
11967      CHARACTER*4 ISUBRO
11968      CHARACTER*4 IERROR
11969C
11970      CHARACTER*4 IWRITE
11971      CHARACTER*4 ISUBN1
11972      CHARACTER*4 ISUBN2
11973C
11974C---------------------------------------------------------------------
11975C
11976      DIMENSION Z(*)
11977      DIMENSION YRAW(*)
11978      DIMENSION ROUND(*)
11979      DIMENSION ALABID(*)
11980      DIMENSION AMATID(*)
11981      DIMENSION ALAB(*)
11982C
11983      DIMENSION YMEAN(*)
11984      DIMENSION XIDTEM(*)
11985      DIMENSION XIDTE2(*)
11986      DIMENSION TEMP1(*)
11987      DIMENSION TEMP2(*)
11988      DIMENSION TEMP3(*)
11989      DIMENSION PPA0(*)
11990      DIMENSION PPA1(*)
11991      DIMENSION PPA0SD(*)
11992      DIMENSION PPA1SD(*)
11993C
11994      DIMENSION Y(*)
11995      DIMENSION X(*)
11996      DIMENSION D(*)
11997C
11998      DOUBLE PRECISION DSUM1
11999C
12000C---------------------------------------------------------------------
12001C
12002      INCLUDE 'DPCOP2.INC'
12003C
12004C-----START POINT-----------------------------------------------------
12005C
12006      ISUBN1='DPIS'
12007      ISUBN2='O2  '
12008      IWRITE='OFF'
12009      IERROR='NO'
12010C
12011      NPLOTP=0
12012      NPLOTV=3
12013C
12014      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ISO2')THEN
12015        WRITE(ICOUT,999)
12016        CALL DPWRST('XXX','BUG ')
12017        WRITE(ICOUT,71)
12018   71   FORMAT('***** AT THE BEGINNING OF DPISO2--')
12019        CALL DPWRST('XXX','BUG ')
12020        WRITE(ICOUT,72)IBUGG3,ISUBRO,ICASPL,IISOLA,N,NLAB,NAVE,NUMVAR
12021   72   FORMAT('IBUGG3,ISUBRO,ICASPL,IISOLA,N,NLAB,NUMVAR = ',
12022     1         4(A4,2X),4I8)
12023        CALL DPWRST('XXX','BUG ')
12024        IF(N.GT.0)THEN
12025          DO81I=1,N
12026            WRITE(ICOUT,82)I,YRAW(I),Z(I),ROUND(I),ALABID(I),AMATID(I)
12027   82       FORMAT('I,YRAW(I),Z(I),ROUND(I),ALABID(I),AMATID(I) = ',
12028     1             I8,5G15.7)
12029            CALL DPWRST('XXX','BUG ')
12030   81     CONTINUE
12031        ENDIF
12032        IF(NLAB.GT.0)THEN
12033          DO86I=1,NLAB
12034            WRITE(ICOUT,87)I,ALAB(I)
12035   87       FORMAT('I,ALAB(I) = ',I8,G15.7)
12036            CALL DPWRST('XXX','BUG ')
12037   86     CONTINUE
12038        ENDIF
12039      ENDIF
12040C
12041C               ********************************************
12042C               **  STEP 1--                              **
12043C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
12044C               ********************************************
12045C
12046      IF(N.LT.2)THEN
12047        WRITE(ICOUT,999)
12048  999   FORMAT(1X)
12049        CALL DPWRST('XXX','BUG ')
12050        WRITE(ICOUT,31)
12051   31   FORMAT('***** ERROR IN ISO 13528 PLOT--')
12052        CALL DPWRST('XXX','BUG ')
12053        WRITE(ICOUT,32)
12054   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
12055        CALL DPWRST('XXX','BUG ')
12056        WRITE(ICOUT,34)N
12057   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
12058        CALL DPWRST('XXX','BUG ')
12059        WRITE(ICOUT,999)
12060        CALL DPWRST('XXX','BUG ')
12061        IERROR='YES'
12062        GOTO9000
12063      ENDIF
12064C
12065C               ********************************************
12066C               **  STEP 2--                              **
12067C               **  COMPUTE LAB AVERAGES (IN ORIGINAL     **
12068C               **  UNITS) FOR EACH ROUND OVER ALL LABS.  **
12069C               ********************************************
12070C
12071      IWRITE='OFF'
12072      CALL CODE(AMATID,N,IWRITE,XIDTEM,XIDTE2,MAXOBV,IBUGG3,IERROR)
12073      AMAX=CPUMIN
12074      DO110I=1,N
12075        AMATID(I)=XIDTEM(I)
12076        IF(AMATID(I).GT.AMAX)AMAX=AMATID(I)
12077  110 CONTINUE
12078C
12079      CALL DISTIN(ROUND,N,IWRITE,XIDTEM,NROUND,IBUGG3,IERROR)
12080      CALL SORT(XIDTEM,NROUND,XIDTEM)
12081      CALL DISTIN(AMATID,N,IWRITE,XIDTE2,NMAT,IBUGG3,IERROR)
12082      CALL SORT(XIDTE2,NMAT,XIDTE2)
12083C
12084      IF(NAVE.EQ.N)THEN
12085        ICNT=0
12086        DO1010IRND=1,NROUND
12087          HOLD=XIDTEM(IRND)
12088          DO1020IMAT=1,NMAT
12089            HOLD2=XIDTE2(IMAT)
12090            DSUM1=0.0D0
12091            K=0
12092C
12093            DO1030J=1,N
12094              IF(ROUND(J).EQ.HOLD .AND.AMATID(J).EQ.HOLD2)THEN
12095                K=K+1
12096                TEMP1(K)=YRAW(J)
12097              ENDIF
12098 1030       CONTINUE
12099            IF(IISOLA.EQ.'RESP')THEN
12100              IF(K.EQ.0)THEN
12101                XMEAN=CPUMIN
12102              ELSE
12103                IF(IISOME.EQ.'MEAN')THEN
12104                  CALL MEAN(TEMP1,K,IWRITE,XMEAN,IBUGG3,IERROR)
12105                ELSEIF(IISOME.EQ.'H15')THEN
12106                  C=1.5
12107                  NCUT=0
12108                  CALL H15(TEMP1,K,C,NCUT,XMEAN,XSC,TEMP2,TEMP3,
12109     1                     MAXOBV,ISUBRO,IBUGG3)
12110                ELSEIF(IISOME.EQ.'MEDI')THEN
12111                  CALL MEDIAN(TEMP1,K,IWRITE,TEMP2,MAXOBV,XMEAN,
12112     1                        IBUGG3,IERROR)
12113                ENDIF
12114              ENDIF
12115            ELSEIF(IISOLA.EQ.'LAVE')THEN
12116              IF(K.EQ.0)THEN
12117                XMEAN=CPUMIN
12118              ELSE
12119                XMEAN=TEMP1(1)
12120              ENDIF
12121            ENDIF
12122C
12123            ICNT=ICNT+1
12124            YMEAN(ICNT)=XMEAN
12125C
12126            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ISO2')THEN
12127              WRITE(ICOUT,1096)IRND,IMAT,ICNT,K,YMEAN(ICNT)
12128 1096         FORMAT('IRND,IMAT,ICNT,K,YMEAN(ICNT) = ',4I8,2G15.7)
12129              CALL DPWRST('XXX','BUG ')
12130            ENDIF
12131C
12132 1020     CONTINUE
12133 1010   CONTINUE
12134      ELSE
12135        IF(NAVE.NE.NROUND)THEN
12136          WRITE(ICOUT,999)
12137          CALL DPWRST('XXX','BUG ')
12138          WRITE(ICOUT,31)
12139          CALL DPWRST('XXX','BUG ')
12140          WRITE(ICOUT,1032)
12141 1032     FORMAT('      THE NUMBER OF LAB AVERAGES DOES NOT EQUAL')
12142          CALL DPWRST('XXX','BUG ')
12143          WRITE(ICOUT,1034)
12144 1034     FORMAT('      THE NUMBER OF ROUNDS.')
12145          CALL DPWRST('XXX','BUG ')
12146          WRITE(ICOUT,999)
12147          CALL DPWRST('XXX','BUG ')
12148          WRITE(ICOUT,1036)NAVE
12149 1036     FORMAT('      THE NUMBER OF LAB AVERAGES = ',I8)
12150          CALL DPWRST('XXX','BUG ')
12151          WRITE(ICOUT,1038)NROUND
12152 1038     FORMAT('      THE NUMBER OF ROUNDS       = ',I8)
12153          CALL DPWRST('XXX','BUG ')
12154          IERROR='YES'
12155          GOTO9000
12156        ENDIF
12157        ICNT=0
12158        DO1040I=1,NROUND
12159          HOLD=YRAW(I)
12160          DO1050J=1,NMAT
12161            ICNT=ICNT+1
12162            YMEAN(ICNT)=HOLD
12163 1050     CONTINUE
12164 1040   CONTINUE
12165      ENDIF
12166C
12167C               ********************************************
12168C               **  STEP 3--                              **
12169C               **  GENERATE THE PLOT COORDINATES.        **
12170C               ********************************************
12171C
12172      DO2010J=1,NLAB
12173        HOLD3=ALAB(J)
12174        NOLD=NPLOTP
12175        NTEMP=0
12176        ICNT=(J-1)*NMAT
12177C
12178        ICNT2=0
12179        DO2020IRND=1,NROUND
12180          HOLD=XIDTEM(IRND)
12181          DO2030IMAT=1,NMAT
12182            HOLD2=XIDTE2(IMAT)
12183            ICNT2=ICNT2+1
12184            AMEAN=YMEAN(ICNT2)
12185            DO2035IROW=1,N
12186              IF(ROUND(IROW).EQ.HOLD .AND. AMATID(IROW).EQ.HOLD2 .AND.
12187     1           ALABID(IROW).EQ.HOLD3)THEN
12188                NPLOTP=NPLOTP+1
12189                Y(NPLOTP)=Z(IROW)
12190                X(NPLOTP)=AMEAN
12191                IINDX=ICNT+INT(AMATID(IROW)+0.1)
12192                D(NPLOTP)=REAL(IINDX)
12193                NTEMP=NTEMP+1
12194              ENDIF
12195 2035       CONTINUE
12196 2030     CONTINUE
12197 2020   CONTINUE
12198C
12199C       NOW COMPUTE A LINEAR FIT AND SAVE THE PARAMETER ESTIMATES
12200C       AND STANDARD ERRORS.  ADD OPTIONAL FITTED LINE TO GRAPH.
12201C
12202        ICNT=NLAB*NMAT + J
12203        IF(NTEMP.GE.2)THEN
12204          CALL LINFIT(Y(NOLD+1),X(NOLD+1),NTEMP,
12205     1                ALOC,SLOPE,XRESSD,XRESDF,PPCC,A0SD,A1SD,CCALBE,
12206     1                ISUBRO,IBUGG3,IERROR)
12207          PPA0(J)=ALOC
12208          PPA1(J)=SLOPE
12209          PPA0SD(J)=A0SD
12210          PPA1SD(J)=A1SD
12211          CALL MINIM(X(NOLD+1),NTEMP,IWRITE,XMIN,IBUGG3,IERROR)
12212          CALL MAXIM(X(NOLD+1),NTEMP,IWRITE,XMAX,IBUGG3,IERROR)
12213          NPLOTP=NPLOTP+1
12214          Y(NPLOTP)=ALOC + SLOPE*XMIN
12215          X(NPLOTP)=XMIN
12216          D(NPLOTP)=REAL(ICNT)
12217          NPLOTP=NPLOTP+1
12218          Y(NPLOTP)=ALOC + SLOPE*XMAX
12219          X(NPLOTP)=XMAX
12220          D(NPLOTP)=REAL(ICNT)
12221        ELSE
12222          PPA0(J)=CPUMIN
12223          PPA1(J)=CPUMIN
12224          PPA0SD(J)=CPUMIN
12225          PPA1SD(J)=CPUMIN
12226        ENDIF
12227C
12228 2010 CONTINUE
12229C
12230C               *****************
12231C               **  STEP 90--  **
12232C               **  EXIT       **
12233C               *****************
12234C
12235 9000 CONTINUE
12236      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'ISO2')THEN
12237        WRITE(ICOUT,999)
12238        CALL DPWRST('XXX','BUG ')
12239        WRITE(ICOUT,9011)
12240 9011   FORMAT('***** AT THE END       OF DPISO2--')
12241        CALL DPWRST('XXX','BUG ')
12242        WRITE(ICOUT,9013)IERROR,NPLOTP,NPLOTV
12243 9013   FORMAT('IERROR,NPLOTP,NPLOTV = ',A4,2X,2I8)
12244        CALL DPWRST('XXX','BUG ')
12245        IF(NPLOTP.GT.0)THEN
12246          DO9035I=1,NPLOTP
12247            WRITE(ICOUT,9036)I,Y(I),X(I),D(I)
12248 9036       FORMAT('I,Y(I),X(I),D(I) = ',I8,2E15.7,F9.2)
12249            CALL DPWRST('XXX','BUG ')
12250 9035     CONTINUE
12251        ENDIF
12252      ENDIF
12253C
12254      RETURN
12255      END
12256      SUBROUTINE DPISO4(PPA0,PPA1,PPA0SD,PPA1SD,NLAB,
12257     1                  IBUGG3,ISUBRO,IERROR)
12258C
12259C     PURPOSE--UTILITY ROUTINE USED BY DPISOP.  FOR EACH LAB, WRITE VALUES
12260C              OF FITTED LINE (INTERCEPT AND SLOPE WITH THEIR STANDARD ERRORS)
12261C              TO EXTERNAL FILE.
12262C     WRITTEN BY--ALAN HECKERT
12263C                 STATISTICAL ENGINEERING DIVISION
12264C                 INFORMATION TECHNOLOGY LABORAOTRY
12265C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
12266C                 GAITHERSBURG, MD 20899-8980
12267C                 PHONE--301-975-2899
12268C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12269C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
12270C     LANGUAGE--ANSI FORTRAN (1977)
12271C     VERSION NUMBER--2012/2
12272C     ORIGINAL VERSION--FEBRUARY  2012.
12273C
12274C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12275C
12276      CHARACTER*4 IBUGG3
12277      CHARACTER*4 ISUBRO
12278      CHARACTER*4 IERROR
12279C
12280      CHARACTER*4 ISUBN1
12281      CHARACTER*4 ISUBN2
12282      CHARACTER*4 ISTEPN
12283      CHARACTER*4 IOP
12284C
12285      DIMENSION PPA0(*)
12286      DIMENSION PPA1(*)
12287      DIMENSION PPA0SD(*)
12288      DIMENSION PPA1SD(*)
12289C
12290C-----COMMON VARIABLES (GENERAL)--------------------------------------
12291C
12292      INCLUDE 'DPCOPA.INC'
12293      INCLUDE 'DPCOHK.INC'
12294      INCLUDE 'DPCOHO.INC'
12295      INCLUDE 'DPCOF2.INC'
12296      INCLUDE 'DPCOP2.INC'
12297C
12298C-----START POINT-----------------------------------------------------
12299C
12300C               ***************************************
12301C               **  STEP 1--                         **
12302C               **  UPDATE INTERNAL DATAPLOT TABLES  **
12303C               ***************************************
12304C
12305      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ISO4')THEN
12306        ISTEPN='1'
12307        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12308        WRITE(ICOUT,999)
12309  999   FORMAT(1X)
12310        CALL DPWRST('XXX','BUG ')
12311        WRITE(ICOUT,51)
12312   51   FORMAT('***** AT THE BEGINNING OF DPISO4--')
12313        CALL DPWRST('XXX','BUG ')
12314      ENDIF
12315C
12316      IERROR='NO'
12317C
12318      IOP='OPEN'
12319      IFLAG1=1
12320      IFLAG2=0
12321      IFLAG3=0
12322      IFLAG4=0
12323      IFLAG5=0
12324      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
12325     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
12326     1            IBUGG3,ISUBRO,IERROR)
12327      IF(IERROR.EQ.'YES')GOTO9000
12328C
12329      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ISO4')THEN
12330        ISTEPN='2A'
12331        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12332        WRITE(ICOUT,999)
12333        CALL DPWRST('XXX','BUG ')
12334        WRITE(ICOUT,201)IOUNI1
12335  201   FORMAT('AFTER CALL DPOPFI, IOUNI1 = ',I8)
12336        CALL DPWRST('XXX','BUG ')
12337      ENDIF
12338C
12339      WRITE(IOUNI1,299)
12340  299 FORMAT(13X,'A0',13X,'A1',11X,'A0SD',11X,'A1SD',
12341     1       5X,'A0 t-VALUE',5X,'A1 t-VALUE')
12342C
12343      DO1010I=1,NLAB
12344        TVAL1=CPUMIN
12345        TVAL2=CPUMIN
12346        IF(PPA0SD(I).NE.CPUMIN .AND. PPA0SD(I).NE.0.0)THEN
12347          TVAL1=PPA0(I)/PPA0SD(I)
12348        ENDIF
12349        IF(PPA1SD(I).NE.CPUMIN .AND. PPA1SD(I).NE.0.0)THEN
12350          TVAL2=PPA1(I)/PPA1SD(I)
12351        ENDIF
12352        WRITE(IOUNI1,1031)PPA0(I),PPA1(I),PPA0SD(I),PPA1SD(I),
12353     1                    TVAL1,TVAL2
12354 1031   FORMAT(6E15.7)
12355 1010 CONTINUE
12356C
12357      IOP='CLOS'
12358      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
12359     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
12360     1            IBUGG3,ISUBRO,IERROR)
12361      IF(IERROR.EQ.'YES')GOTO9000
12362C
12363      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ISO4')THEN
12364        ISTEPN='3A'
12365        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12366        WRITE(ICOUT,999)
12367        CALL DPWRST('XXX','BUG ')
12368        WRITE(ICOUT,301)
12369  301   FORMAT('AFTER CALL DPCLFI')
12370        CALL DPWRST('XXX','BUG ')
12371      ENDIF
12372C
12373C               *****************
12374C               **  STEP 90--  **
12375C               **  EXIT       **
12376C               *****************
12377C
12378 9000 CONTINUE
12379C
12380      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'ISO4')THEN
12381        WRITE(ICOUT,999)
12382        CALL DPWRST('XXX','BUG ')
12383        WRITE(ICOUT,9011)
12384 9011   FORMAT('***** AT THE END OF DPISO4--')
12385        CALL DPWRST('XXX','BUG ')
12386      ENDIF
12387C
12388      RETURN
12389      END
12390      SUBROUTINE DPISP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
12391     1                 MAXNXT,ISEED,ICONT,
12392     1                 ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
12393C
12394C     PURPOSE--GENERATE A <STAT> INTERACTION PLOT
12395C              (SEE ROUTINE  EXTSTA  FOR A LIST OF SUPPORTED STATISTICS).
12396C              THESE DIFFER FROM THE STATISTIC PLOT CASE IN THAT THERE
12397C              CAN BE MORE THAN 1 X VARIABLE AND THESE ARE MULTIPLIED
12398C              TO GET THE INTERACTION X TERM.  THE MAIN APPLICATION
12399C              IS IN DESIGN OF EXPERIMENTS.
12400C     WRITTEN BY--JAMES J. FILLIBEN
12401C                 STATISTICAL ENGINEERING DIVISION
12402C                 INFORMATION TECHNOLOGY LABORATORY
12403C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12404C                 GAITHERSBURG, MD 20899-8980
12405C                 PHONE--301-975-2855
12406C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12407C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12408C     LANGUAGE--ANSI FORTRAN (1977)
12409C     VERSION NUMBER--99/10
12410C     ORIGINAL VERSION--OCTOBER   1999.
12411C     UPDATED         --JULY      2002. BIWEIGHT LOCATION
12412C     UPDATED         --JULY      2002. BIWEIGHT SCALE
12413C     UPDATED         --JULY      2002. WINSORIZED VARIANCE
12414C     UPDATED         --JULY      2002. WINSORIZED SD
12415C     UPDATED         --JULY      2002. ADD WINSORIZED COVARIANCE PLOT
12416C     UPDATED         --JULY      2002. ADD WINSORIZED CORRELATION PLOT
12417C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDVARIANCE PLOT
12418C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCOVARIANCE PLOT
12419C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCORRELATION PLOT
12420C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND MIDVARIANCE
12421C                                           PLOT
12422C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND CORRELATION
12423C                                           PLOT
12424C     UPDATED         --JULY      2002. ADD HODGES LEHMAN PLOT
12425C     UPDATED         --JULY      2002. ADD QUANTILE PLOT
12426C     UPDATED         --JULY      2002. ADD QUANTILE STANDARD ERROR PLOT
12427C     UPDATED         --JULY      2002. ADD TRIMMED MEAN STANDARD
12428C                                       ERROR PLOT
12429C     UPDATED         --APRIL     2003. ADD SN AND QN, REQUIRED
12430C                                       ADDITIONAL SCRATCH ARRAYS
12431C     UPDATED         --AUGUST    2007. MOVE SOME ARRAY STORAGE TO COMMON
12432C     UPDATED         --NOVEMBER  2009. UPDATE PARSING:
12433C                                       1) USE "EXTSTA"
12434C                                       2) USE DPPARS
12435C     UPDATED         --NOVEMBER  2009. UPDATE CALL LIST TO DPSP2
12436C                                       (DPSP2 WAS MODIFIED TO ADD
12437C                                       SOME ENHANCEMENTS FOR THE
12438C                                       <STAT> PLOT COMMAND)
12439C     UPDATED         --JUNE      2010. UPDATE CALL LIST TO DPSP2
12440C     UPDATED         --APRIL     2015. UPDATE CALL LIST TO DPSP2
12441C     UPDATED         --FEBRUARY  2018. UPDATE CALL LIST TO DPSP2
12442C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
12443C
12444C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12445C
12446      CHARACTER*4 ICASPL
12447      CHARACTER*4 IAND1
12448      CHARACTER*4 IAND2
12449      CHARACTER*4 ICONT
12450      CHARACTER*4 ISUBRO
12451      CHARACTER*4 IBUGG2
12452      CHARACTER*4 IBUGG3
12453      CHARACTER*4 IBUGQ
12454      CHARACTER*4 IFOUND
12455      CHARACTER*4 IERROR
12456C
12457      CHARACTER*4 IHWUSE
12458      CHARACTER*4 MESSAG
12459      CHARACTER*4 IERRO2
12460      CHARACTER*4 IH
12461      CHARACTER*4 IH2
12462      CHARACTER*4 IGROUP
12463C
12464      CHARACTER*4 ISUBN0
12465      CHARACTER*4 ISUBN1
12466      CHARACTER*4 ISUBN2
12467      CHARACTER*4 ISTEPN
12468C
12469      CHARACTER*4 ICASE
12470      PARAMETER (MAXSPN=30)
12471      CHARACTER*4 IVARN1(MAXSPN)
12472      CHARACTER*4 IVARN2(MAXSPN)
12473      CHARACTER*4 IVARTY(MAXSPN)
12474      REAL PVAR(MAXSPN)
12475      INTEGER ILIS(MAXSPN)
12476      INTEGER NRIGHT(MAXSPN)
12477      INTEGER ICOLR(MAXSPN)
12478C
12479      CHARACTER*40 INAME
12480      CHARACTER*60 ISTANM
12481      CHARACTER*4  ISTADF
12482C
12483C---------------------------------------------------------------------
12484C
12485      INCLUDE 'DPCOPA.INC'
12486      INCLUDE 'DPCOZZ.INC'
12487      INCLUDE 'DPCOZI.INC'
12488      INCLUDE 'DPCOZD.INC'
12489C
12490      PARAMETER (MAXRES=25)
12491C
12492      DIMENSION Z(MAXOBV,MAXRES)
12493C
12494      DIMENSION TEMP1(MAXOBV)
12495      DIMENSION TEMP2(MAXOBV)
12496      DIMENSION TEMP3(MAXOBV)
12497      DIMENSION TEMP4(MAXOBV)
12498      DIMENSION TEMP5(MAXOBV)
12499      DIMENSION TEMP6(MAXOBV)
12500      DIMENSION TEMP7(MAXOBV)
12501      DIMENSION TEMP8(MAXOBV)
12502C
12503      INTEGER ITEMP1(MAXOBV)
12504      INTEGER ITEMP2(MAXOBV)
12505      INTEGER ITEMP3(MAXOBV)
12506      INTEGER ITEMP4(MAXOBV)
12507      INTEGER ITEMP5(MAXOBV)
12508      INTEGER ITEMP6(MAXOBV)
12509C
12510      DOUBLE PRECISION DTEMP1(MAXOBV)
12511      DOUBLE PRECISION DTEMP2(MAXOBV)
12512      DOUBLE PRECISION DTEMP3(MAXOBV)
12513C
12514      EQUIVALENCE (GARBAG(IGARB1),TEMP1(1))
12515      EQUIVALENCE (GARBAG(IGARB2),TEMP2(1))
12516      EQUIVALENCE (GARBAG(IGARB3),TEMP3(1))
12517      EQUIVALENCE (GARBAG(IGARB4),TEMP4(1))
12518      EQUIVALENCE (GARBAG(IGARB5),TEMP5(1))
12519      EQUIVALENCE (GARBAG(IGARB6),TEMP6(1))
12520      EQUIVALENCE (GARBAG(IGARB7),TEMP7(1))
12521      EQUIVALENCE (GARBAG(IGARB8),TEMP8(1))
12522      EQUIVALENCE (GARBAG(IGARB9),Z(1,1))
12523C
12524      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
12525      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
12526      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
12527      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
12528      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
12529      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
12530C
12531      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
12532      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
12533      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
12534C
12535C-----COMMON----------------------------------------------------------
12536C
12537      INCLUDE 'DPCOHK.INC'
12538      INCLUDE 'DPCODA.INC'
12539      INCLUDE 'DPCOHO.INC'
12540      INCLUDE 'DPCOST.INC'
12541      INCLUDE 'DPCOP2.INC'
12542C
12543C-----START POINT-----------------------------------------------------
12544C
12545      IERROR='NO'
12546      IGROUP='OFF'
12547      ISUBN1='DPIS'
12548      ISUBN2='P   '
12549C
12550      MAXCP1=MAXCOL+1
12551      MAXCP2=MAXCOL+2
12552      MAXCP3=MAXCOL+3
12553      MAXCP4=MAXCOL+4
12554      MAXCP5=MAXCOL+5
12555      MAXCP6=MAXCOL+6
12556      IMININ=0
12557      IMAXIN=0
12558C
12559C               *************************************************
12560C               **  TREAT THE INTERACTION STATISTIC PLOT CASE  **
12561C               *************************************************
12562C
12563      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP')THEN
12564        WRITE(ICOUT,999)
12565  999   FORMAT(1X)
12566        CALL DPWRST('XXX','BUG ')
12567        WRITE(ICOUT,51)
12568   51   FORMAT('***** AT THE BEGINNING OF DPISP--')
12569        CALL DPWRST('XXX','BUG ')
12570        WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ
12571   52   FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',4(A4,2X),A4)
12572        CALL DPWRST('XXX','BUG ')
12573        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
12574   53   FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4)
12575        CALL DPWRST('XXX','BUG ')
12576      ENDIF
12577C
12578C               **************************************
12579C               **  STEP 1--                       **
12580C               **  EXTRACT THE DESIRED STATISTIC  **
12581C               *************************************
12582C
12583      ISTEPN='1'
12584      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP')
12585     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12586C
12587      IF(NUMARG.LE.2)GOTO9000
12588C
12589      JMIN=0
12590      JMAX=NUMARG
12591      IFLAGZ=0
12592      IFLAGU=0
12593C
12594      DO200I=1,NUMARG-1
12595        IF(I.LT.NUMARG.AND.IHARG(I).EQ.'INTE'.AND.
12596     1         IHARG(I+1).EQ.'PLOT')THEN
12597          IF(JMAX.EQ.NUMARG)JMAX=I-1
12598          ILASTC=I+1
12599          GOTO209
12600        ENDIF
12601  200 CONTINUE
12602      GOTO9000
12603  209 CONTINUE
12604C
12605      CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
12606     1            ICASPL,ISTANM,ISTANR,ISTADF,IFOUND,ILOCV,
12607     1            ISUBRO,IBUGG3,IERROR)
12608C
12609      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP')THEN
12610        WRITE(ICOUT,999)
12611        CALL DPWRST('XXX','BUG ')
12612        WRITE(ICOUT,251)
12613  251   FORMAT('***** AFTER CALL EXTSTA--')
12614        CALL DPWRST('XXX','BUG ')
12615        WRITE(ICOUT,252)ICASPL,ISTANR,ILOCV,IFOUND
12616  252   FORMAT('ICASPL,ISTANR,ILOCV,IFOUND = ',A4,2I8,2X,A4)
12617        CALL DPWRST('XXX','BUG ')
12618      ENDIF
12619C
12620      IF(IFOUND.EQ.'NO')GOTO9000
12621      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
12622C
12623C               *********************************
12624C               **  STEP 2--                   **
12625C               **  EXTRACT THE VARIABLE LIST  **
12626C               *********************************
12627C
12628      INAME='<stat> INTERACTION PLOT'
12629      MINNA=1
12630      MAXNA=100
12631      MINN2=2
12632      IFLAGE=1
12633      IFLAGM=0
12634      IFLAGP=0
12635      JMIN=1
12636      JMAX=NUMARG
12637      MINNVA=1
12638      MAXNVA=MAXSPN
12639C
12640      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
12641     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
12642     1            JMIN,JMAX,
12643     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
12644     1            IVARN1,IVARN2,IVARTY,PVAR,
12645     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
12646     1            MINNVA,MAXNVA,
12647     1            IFLAGM,IFLAGP,
12648     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
12649C
12650      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP')THEN
12651        WRITE(ICOUT,999)
12652        CALL DPWRST('XXX','BUG ')
12653        WRITE(ICOUT,281)
12654  281   FORMAT('***** AFTER CALL DPPARS--')
12655        CALL DPWRST('XXX','BUG ')
12656        WRITE(ICOUT,282)NQ,NUMVAR
12657  282   FORMAT('NQ,NUMVAR = ',2I8)
12658        CALL DPWRST('XXX','BUG ')
12659        IF(NUMVAR.GT.0)THEN
12660          DO285I=1,NUMVAR
12661            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
12662     1                      ICOLR(I)
12663  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
12664     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
12665            CALL DPWRST('XXX','BUG ')
12666  285     CONTINUE
12667        ENDIF
12668      ENDIF
12669      IF(IERROR.EQ.'YES')GOTO9000
12670C
12671C     NEED FOLLOWING VARIABLES:
12672C     1) ONE RESPONSE VARIABLE FOR STATISTICS REQUIRING ONE VARIABLE
12673C     2) TWO RESPONSE VARIABLES FOR STATISTICS REQUIRING TWO VARIABLES
12674C     3) ONE OR MORE FACTOR VARIABLES (TYPICALLY THERE ARE TWO)
12675C
12676      ISIZE=-99
12677      MINVAR=1+ISTANR
12678      IF(NUMVAR.LT.MINVAR)THEN
12679C
12680        IF(NUMVAR.EQ.MINVAR-1)THEN
12681          IH='NI  '
12682          IH2='    '
12683          IHWUSE='P'
12684          MESSAG='NO'
12685          CALL CHECKN(IH,IH2,IHWUSE,
12686     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
12687     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
12688          IF(IERROR.EQ.'NO')THEN
12689            ISIZE=INT(VALUE(ILOCP)+0.5)
12690            GOTO219
12691          ENDIF
12692        ENDIF
12693C
12694        WRITE(ICOUT,999)
12695        CALL DPWRST('XXX','BUG ')
12696        WRITE(ICOUT,211)
12697  211   FORMAT('***** ERROR IN INTERACTION PLOT COMMAND--')
12698        CALL DPWRST('XXX','BUG ')
12699        WRITE(ICOUT,212)MINVAR
12700  212   FORMAT('      AT LEAST ',I5,' VARIABLES REQUIRED, BUT ONLY')
12701        CALL DPWRST('XXX','BUG ')
12702        WRITE(ICOUT,213)NUMVAR
12703  213   FORMAT('      ',I8,' VARIABLES WERE GIVEN.')
12704        CALL DPWRST('XXX','BUG ')
12705        WRITE(ICOUT,215)
12706  215   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
12707        CALL DPWRST('XXX','BUG ')
12708        IF(IWIDTH.GE.1)THEN
12709          WRITE(ICOUT,216)(IANS(J),J=1,MIN(80,IWIDTH))
12710  216     FORMAT('      ',80A1)
12711          CALL DPWRST('XXX','BUG ')
12712          IERROR='YES'
12713          GOTO9000
12714        ENDIF
12715      ENDIF
12716C
12717  219 CONTINUE
12718C
12719C               *********************************
12720C               **  STEP 3--                   **
12721C               **  EXTRACT THE DATA           **
12722C               *********************************
12723C
12724      J=0
12725      IMAX=NRIGHT(1)
12726      IF(NQ.LT.NRIGHT(1))IMAX=NQ
12727      NFACT=NUMVAR-ISTANR
12728      EPS=1.0E-7
12729C
12730      NUMVA2=1
12731      DO3010K=1,ISTANR
12732        ICOL=K
12733        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12734     1              INAME,IVARN1,IVARN2,IVARTY,
12735     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
12736     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12737     1              MAXCP4,MAXCP5,MAXCP6,
12738     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12739     1              Z(1,K),TEMP1,TEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
12740     1              IBUGG3,ISUBRO,IFOUND,IERROR)
12741 3010 CONTINUE
12742C
12743C     THE "INTERACTION" VARIABLE IS THE PRODUCT OF ALL THE FACTOR
12744C     VARIABLES.  NOTE THAT FOR THE INTERACTION PLOT, THIS PRODUCT
12745C     SHOULD BE "0", "+1", OR "-1".  REPORT AN ERROR IF IT IS NOT.
12746C
12747C     INTIALIZE COLUMN TO 1 AND THEN MULTIPLY BY EACH COLUMN.
12748C
12749      DO3015II=1,MAXOBV
12750        Z(II,ISTANR+1)=1.0
12751 3015 CONTINUE
12752C
12753      DO3020K=ISTANR+1,NUMVAR
12754        ICOL=K
12755        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12756     1              INAME,IVARN1,IVARN2,IVARTY,
12757     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
12758     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12759     1              MAXCP4,MAXCP5,MAXCP6,
12760     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12761     1              TEMP1,TEMP2,TEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
12762     1              IBUGG3,ISUBRO,IFOUND,IERROR)
12763C
12764        DO3025II=1,NLOCAL
12765          Z(II,ISTANR+1)=Z(II,ISTANR+1)*TEMP1(II)
12766          IFLAG=1
12767          IF(ABS(Z(II,ISTANR+1)).LE.EPS)IFLAG=0
12768          IF(ABS(Z(II,ISTANR+1)-1.0).LE.EPS)IFLAG=0
12769          IF(ABS(Z(II,ISTANR+1)+1.0).LE.EPS)IFLAG=0
12770C
12771          IF(IFLAG.EQ.1)THEN
12772            WRITE(ICOUT,999)
12773            CALL DPWRST('XXX','BUG ')
12774            WRITE(ICOUT,211)
12775            CALL DPWRST('XXX','BUG ')
12776            WRITE(ICOUT,3301)
12777 3301       FORMAT('      A PRODUCT OF THE INDEPENDENT VARIABLES IS ',
12778     1             'NOT EQUAL TO -1, 0, +1')
12779            CALL DPWRST('XXX','BUG ')
12780            IERROR='YES'
12781            GOTO9000
12782          ENDIF
12783 3025   CONTINUE
12784C
12785 3020 CONTINUE
12786C
12787      IF(ISIZE.GT.0)THEN
12788        NUMVAR=NUMVAR+1
12789        DO3600J=1,NLOCAL
12790          ITEMP=MOD(J,ISIZE)
12791          IF(ITEMP.EQ.0)ITEMP=ISIZE
12792          Z(J,NUMVAR)=REAL(ITEMP)
12793 3600   CONTINUE
12794      ENDIF
12795C
12796      NUMVA2=ISTANR+1
12797C
12798C               *****************************************************
12799C               **  STEP 28--                                      **
12800C               **  COMPUTE THE APPROPRIATE INTERACTION STATISTIC  **
12801C               **  PLOT STATISTIC--                               **
12802C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
12803C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
12804C               *****************************************************
12805C
12806      ISTEPN='28'
12807      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PISP')THEN
12808        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12809        WRITE(ICOUT,2811)NLOCAL,NUMVAR,ISTANR,IFLAGZ,IFLAGU
12810 2811   FORMAT('NLOCAL,NUMVAR,ISTANR,IFLAGZ,IFLAGU = ',5I5)
12811        CALL DPWRST('XXX','BUG ')
12812        WRITE(ICOUT,2813)ICASPL
12813 2813   FORMAT('ICASPL = ',A4)
12814        CALL DPWRST('XXX','BUG ')
12815        IF(NLOCAL.GE.1)THEN
12816          DO2815I=1,NLOCAL
12817            WRITE(ICOUT,2817)I,Z(I,1),Z(I,2),Z(I,3)
12818 2817       FORMAT('I,Z(I,1),Z(I,2),Z(I,3) = ',I8,3G15.7)
12819            CALL DPWRST('XXX','BUG ')
12820 2815     CONTINUE
12821        ENDIF
12822      ENDIF
12823C
12824      CALL DPSP2(Z,MAXOBV,MAXRES,NLOCAL,NUMVA2,ISTANR,IFLAGZ,IFLAGU,
12825     1           ICASPL,ISIZE,ICONT,
12826     1           TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,TEMP6,TEMP7,TEMP8,MAXNXT,
12827     1           ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
12828     1           DTEMP1,DTEMP2,DTEMP3,
12829     1           IQUAME,IQUASE,PSTAMV,ISTAFO,ISTASM,ISPLRL,IGROUP,
12830     1           Y,X,D,NPLOTP,NPLOTV,NUMSET,GRAND,
12831     1           ISUBRO,IBUGG3,IERROR)
12832C
12833C               *************************************************
12834C               **  STEP 29--                                  **
12835C               **  SAVE DIFFERENCE BETWEEN HIGHEST VALUE AND  **
12836C               **  LOWEST VALUE OF STATISTIC IN INTERNAL      **
12837C               **  PARAMETER ALOWHIGH                         **
12838C               *************************************************
12839C
12840      AMINS=CPUMAX
12841      AMAXS=CPUMIN
12842      DO2910I=1,NPLOTP
12843        IF(D(I).NE.1.0)GOTO2910
12844        IF(Y(I).GT.AMAXS)THEN
12845          AMAXS=Y(I)
12846          IMAXIN=I
12847        ENDIF
12848        IF(Y(I).LT.AMINS)THEN
12849          AMINS=Y(I)
12850          IMININ=I
12851        ENDIF
12852 2910 CONTINUE
12853      ADIFF=AMAXS-AMINS
12854      IF(IMAXIN.GT.IMININ)ADIFF=-ADIFF
12855C
12856      ISUBN0='PISP'
12857C
12858      IH='ALOW'
12859      IH2='HIGH'
12860      VALUE0=ADIFF
12861      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
12862     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
12863     1IANS,IWIDTH,IBUGG3,IERROR)
12864C
12865      IF(GRAND.NE.CPUMIN)THEN
12866        IH='GRAN'
12867        IH2='DSTA'
12868        VALUE0=GRAND
12869        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
12870     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
12871     1              IANS,IWIDTH,IBUGG3,IERROR)
12872      ENDIF
12873C
12874C               *****************
12875C               **  STEP 90--  **
12876C               **  EXIT       **
12877C               *****************
12878C
12879 9000 CONTINUE
12880      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PISP')THEN
12881        WRITE(ICOUT,999)
12882        CALL DPWRST('XXX','BUG ')
12883        WRITE(ICOUT,9011)
12884 9011   FORMAT('***** AT THE END       OF DPISP--')
12885        CALL DPWRST('XXX','BUG ')
12886        WRITE(ICOUT,9013)IFOUND,IERROR
12887 9013   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
12888        CALL DPWRST('XXX','BUG ')
12889        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
12890 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
12891     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
12892        CALL DPWRST('XXX','BUG ')
12893        IF(IFOUND.EQ.'YES' .AND. NPLOTP.GT.0)THEN
12894          DO9025I=1,NPLOTP
12895            WRITE(ICOUT,9026)I,Y(I),X(I),D(I)
12896 9026       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
12897            CALL DPWRST('XXX','BUG ')
12898 9025     CONTINUE
12899        ENDIF
12900      ENDIF
12901C
12902      RETURN
12903      END
12904      SUBROUTINE DPJAB2(Y,N,
12905     1                  TEMP1,TEMP2,MAXNXT,
12906     1                  PID,IVARID,IVARI2,NREPL,
12907     1                  STATVA,PVAL,CDF,
12908     1                  ICAPSW,ICAPTY,IFORSW,ISEED,IRANAL,
12909     1                  ISUBRO,IBUGA3,IERROR)
12910C
12911C     PURPOSE--THIS ROUTINE CARRIES OUT THE JARQUE BERA TEST
12912C              FOR NORMALITY.  THIS TEST IS BASED ON THE SKEWNESS
12913C              AND KURTOSIS PARAMETERS.
12914C     EXAMPLE--JARQUE BERA NORMALITY TEST Y
12915C     REFERENCE--BRANI VIDAKOVIC (2011), "STATISTICS FOR
12916C                BIOENGINEERING SCIENCES: WITH MATLAB AND WINBUGS
12917C                SUPPORT", SPRINGER, PP. 521-522.
12918C     WRITTEN BY--ALAN HECKERT
12919C                 STATISTICAL ENGINEERING DIVISION
12920C                 INFORMATION TECHNOLOGY LABORATORY
12921C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12922C                 GAITHERSBURG, MD 20899-8980
12923C                 PHONE--301-975-2899
12924C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12925C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12926C     LANGUAGE--ANSI FORTRAN (1977)
12927C     VERSION NUMBER--2012/6
12928C     ORIGINAL VERSION--JUNE      2012.
12929C
12930C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12931C
12932      CHARACTER*4 IVARID(*)
12933      CHARACTER*4 IVARI2(*)
12934      CHARACTER*4 IRANAL
12935      CHARACTER*4 ISUBRO
12936      CHARACTER*4 IBUGA3
12937      CHARACTER*4 IERROR
12938C
12939      CHARACTER*4 IWRITE
12940C
12941      CHARACTER*4 ICAPSW
12942      CHARACTER*4 ICAPTY
12943      CHARACTER*4 IFORSW
12944C
12945      CHARACTER*4 ISUBN1
12946      CHARACTER*4 ISUBN2
12947      CHARACTER*4 ISTEPN
12948C
12949C---------------------------------------------------------------------
12950C
12951      DIMENSION Y(*)
12952      DIMENSION TEMP1(*)
12953      DIMENSION TEMP2(*)
12954      DIMENSION PID(*)
12955C
12956      PARAMETER (NUMALP=7)
12957CCCCC REAL ALPHA(NUMALP)
12958C
12959      PARAMETER(NUMCLI=4)
12960      PARAMETER(MAXLIN=2)
12961      PARAMETER (MAXROW=50)
12962      CHARACTER*60 ITITLE
12963      CHARACTER*60 ITITLZ
12964      CHARACTER*1  ITITL9
12965      CHARACTER*60 ITEXT(MAXROW)
12966      CHARACTER*4  ALIGN(NUMCLI)
12967      CHARACTER*4  VALIGN(NUMCLI)
12968      REAL         AVALUE(MAXROW)
12969      INTEGER      NCTEXT(MAXROW)
12970      INTEGER      IDIGIT(MAXROW)
12971      INTEGER      NTOT(MAXROW)
12972      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
12973      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
12974      CHARACTER*4  ITYPCO(NUMCLI)
12975      INTEGER      NCTIT2(MAXLIN,NUMCLI)
12976      INTEGER      NCVALU(MAXROW,NUMCLI)
12977      INTEGER      IWHTML(NUMCLI)
12978      INTEGER      IWRTF(NUMCLI)
12979      REAL         AMAT(MAXROW,NUMCLI)
12980      LOGICAL IFRST
12981      LOGICAL ILAST
12982C
12983C---------------------------------------------------------------------
12984C
12985      INCLUDE 'DPCOP2.INC'
12986C
12987CCCCC DATA ALPHA /50.0, 80.0, 90.0, 95.0, 97.5, 99.0, 99.9/
12988C
12989C-----START POINT-----------------------------------------------------
12990C
12991      ISUBN1='DPJA'
12992      ISUBN2='B2  '
12993      IWRITE='OFF'
12994      IERROR='NO'
12995C
12996      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB2')THEN
12997        WRITE(ICOUT,999)
12998  999   FORMAT(1X)
12999        CALL DPWRST('XXX','WRIT')
13000        WRITE(ICOUT,51)
13001   51   FORMAT('**** AT THE BEGINNING OF DPJAB2--')
13002        CALL DPWRST('XXX','WRIT')
13003        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
13004   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
13005        CALL DPWRST('XXX','WRIT')
13006        DO56I=1,N
13007          WRITE(ICOUT,57)I,Y(I)
13008   57     FORMAT('I,Y(I) = ',I8,G15.7)
13009          CALL DPWRST('XXX','WRIT')
13010   56   CONTINUE
13011      ENDIF
13012C
13013C               ********************************************
13014C               **  STEP 11--                             **
13015C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
13016C               ********************************************
13017C
13018      ISTEPN='11'
13019      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'JAB2')
13020     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13021C
13022      IF(N.LT.3)THEN
13023        WRITE(ICOUT,999)
13024        CALL DPWRST('XXX','WRIT')
13025        WRITE(ICOUT,101)
13026  101   FORMAT('***** ERROR: JARQUE-BERA TEST--')
13027        CALL DPWRST('XXX','WRIT')
13028        WRITE(ICOUT,102)
13029  102   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 3.',
13030     1         '  SUCH WAS NOT THE CASE HERE.')
13031        CALL DPWRST('XXX','WRIT')
13032        WRITE(ICOUT,103)N
13033  103   FORMAT('      SAMPLE SIZE = ',I8)
13034        CALL DPWRST('XXX','WRIT')
13035        IERROR='YES'
13036        GOTO9000
13037      ENDIF
13038C
13039      HOLD=Y(1)
13040      DO135I=2,N
13041        IF(Y(I).NE.HOLD)GOTO139
13042  135 CONTINUE
13043      WRITE(ICOUT,999)
13044      CALL DPWRST('XXX','WRIT')
13045      WRITE(ICOUT,101)
13046      CALL DPWRST('XXX','WRIT')
13047      WRITE(ICOUT,131)HOLD
13048  131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
13049      CALL DPWRST('XXX','WRIT')
13050      GOTO9000
13051  139 CONTINUE
13052C
13053C               ******************************
13054C               **  STEP 11--               **
13055C               **  CARRY OUT CALCULATIONS  **
13056C               **  FOR JARQUE BERA         **
13057C               **  TEST                    **
13058C               ******************************
13059C
13060      ISTEPN='11'
13061      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'JAB2')
13062     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13063C
13064      CALL MEAN(Y,N,IWRITE,YMEAN,IBUGA3,IERROR)
13065      CALL SD(Y,N,IWRITE,YSD,IBUGA3,IERROR)
13066      CALL MINIM(Y,N,IWRITE,YMIN,IBUGA3,IERROR)
13067      CALL MAXIM(Y,N,IWRITE,YMAX,IBUGA3,IERROR)
13068C
13069      CALL DPJAB3(Y,N,ISEED,IRANAL,MAXNXT,
13070     1            TEMP1,TEMP2,
13071     1            YSKEW,YKURT,
13072     1            STATVA,PVAL,CDF,
13073     1            CUT25,CUT50,CUT75,CUT80,CUT90,
13074     1            CUT95,CUT975,CUT99,CUT999,
13075     1            ISUBRO,IBUGA3,IERROR)
13076C
13077C               *********************************
13078C               **   STEP 42--                 **
13079C               **   WRITE OUT EVERYTHING      **
13080C               **   FOR JARQUE BERA TEST      **
13081C               *********************************
13082C
13083      ISTEPN='42'
13084      IF(IBUGA3.EQ.'ON'.AND.ISUBRO.EQ.'JAB2')
13085     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13086C
13087      IF(IPRINT.EQ.'OFF')GOTO9000
13088C
13089      NUMDIG=7
13090      IF(IFORSW.EQ.'1')NUMDIG=1
13091      IF(IFORSW.EQ.'2')NUMDIG=2
13092      IF(IFORSW.EQ.'3')NUMDIG=3
13093      IF(IFORSW.EQ.'4')NUMDIG=4
13094      IF(IFORSW.EQ.'5')NUMDIG=5
13095      IF(IFORSW.EQ.'6')NUMDIG=6
13096      IF(IFORSW.EQ.'7')NUMDIG=7
13097      IF(IFORSW.EQ.'8')NUMDIG=8
13098      IF(IFORSW.EQ.'9')NUMDIG=9
13099      IF(IFORSW.EQ.'0')NUMDIG=0
13100      IF(IFORSW.EQ.'E')NUMDIG=-2
13101      IF(IFORSW.EQ.'-2')NUMDIG=-2
13102      IF(IFORSW.EQ.'-3')NUMDIG=-3
13103      IF(IFORSW.EQ.'-4')NUMDIG=-4
13104      IF(IFORSW.EQ.'-5')NUMDIG=-5
13105      IF(IFORSW.EQ.'-6')NUMDIG=-6
13106      IF(IFORSW.EQ.'-7')NUMDIG=-7
13107      IF(IFORSW.EQ.'-8')NUMDIG=-8
13108      IF(IFORSW.EQ.'-9')NUMDIG=-9
13109C
13110      ITITLE='Jarque-Bera Test for Normality'
13111      NCTITL=30
13112      ITITLZ=' '
13113      NCTITZ=0
13114C
13115      ICNT=1
13116      ITEXT(ICNT)=' '
13117      NCTEXT(ICNT)=0
13118      AVALUE(ICNT)=0.0
13119      IDIGIT(ICNT)=-1
13120C
13121      ICNT=ICNT+1
13122      ITEXT(ICNT)='Response Variable: '
13123      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
13124      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
13125      NCTEXT(ICNT)=27
13126      AVALUE(ICNT)=0.0
13127      IDIGIT(ICNT)=-1
13128C
13129      IF(NREPL.GT.0)THEN
13130        IADD=1
13131        DO4101I=1,NREPL
13132          ICNT=ICNT+1
13133          ITEMP=I+IADD
13134          ITEXT(ICNT)='Factor Variable  : '
13135          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
13136          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
13137          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
13138          NCTEXT(ICNT)=27
13139          AVALUE(ICNT)=PID(ITEMP)
13140          IDIGIT(ICNT)=NUMDIG
13141 4101   CONTINUE
13142      ENDIF
13143C
13144      ICNT=ICNT+1
13145      ITEXT(ICNT)=' '
13146      NCTEXT(ICNT)=1
13147      AVALUE(ICNT)=0.0
13148      IDIGIT(ICNT)=-1
13149C
13150      ICNT=ICNT+1
13151      ITEXT(ICNT)='H0: The Data Are Normally Distributed'
13152      NCTEXT(ICNT)=37
13153      AVALUE(ICNT)=0.0
13154      IDIGIT(ICNT)=-1
13155      ICNT=ICNT+1
13156      ITEXT(ICNT)='Ha: The Data Are Not Normally Distributed'
13157      NCTEXT(ICNT)=41
13158      AVALUE(ICNT)=0.0
13159      IDIGIT(ICNT)=-1
13160C
13161      ICNT=ICNT+1
13162      ITEXT(ICNT)=' '
13163      NCTEXT(ICNT)=1
13164      AVALUE(ICNT)=0.0
13165      IDIGIT(ICNT)=-1
13166      ICNT=ICNT+1
13167      ITEXT(ICNT)='Summary Statistics:'
13168      NCTEXT(ICNT)=19
13169      AVALUE(ICNT)=0.0
13170      IDIGIT(ICNT)=-1
13171      ICNT=ICNT+1
13172      ITEXT(ICNT)='Total Number of Observations:'
13173      NCTEXT(ICNT)=29
13174      AVALUE(ICNT)=REAL(N)
13175      IDIGIT(ICNT)=0
13176      ICNT=ICNT+1
13177      ITEXT(ICNT)='Sample Mean:'
13178      NCTEXT(ICNT)=12
13179      AVALUE(ICNT)=YMEAN
13180      IDIGIT(ICNT)=NUMDIG
13181      ICNT=ICNT+1
13182      ITEXT(ICNT)='Sample Standard Deviation:'
13183      NCTEXT(ICNT)=26
13184      AVALUE(ICNT)=YSD
13185      IDIGIT(ICNT)=NUMDIG
13186      ICNT=ICNT+1
13187      ITEXT(ICNT)='Sample Skewness:'
13188      NCTEXT(ICNT)=16
13189      AVALUE(ICNT)=YSKEW
13190      IDIGIT(ICNT)=NUMDIG
13191      ICNT=ICNT+1
13192      ITEXT(ICNT)='Sample Kurtosis:'
13193      NCTEXT(ICNT)=16
13194      AVALUE(ICNT)=YKURT
13195      IDIGIT(ICNT)=NUMDIG
13196      ICNT=ICNT+1
13197      ITEXT(ICNT)='Sample Minimum:'
13198      NCTEXT(ICNT)=15
13199      AVALUE(ICNT)=YMIN
13200      IDIGIT(ICNT)=NUMDIG
13201      ICNT=ICNT+1
13202      ITEXT(ICNT)='Sample Maximum:'
13203      NCTEXT(ICNT)=15
13204      AVALUE(ICNT)=YMAX
13205      IDIGIT(ICNT)=NUMDIG
13206      ICNT=ICNT+1
13207      ITEXT(ICNT)=' '
13208      NCTEXT(ICNT)=1
13209      AVALUE(ICNT)=0.0
13210      IDIGIT(ICNT)=-1
13211C
13212      ICNT=ICNT+1
13213      ITEXT(ICNT)='Test Statistic Value:'
13214      NCTEXT(ICNT)=21
13215      AVALUE(ICNT)=STATVA
13216      IDIGIT(ICNT)=NUMDIG
13217      ICNT=ICNT+1
13218      ITEXT(ICNT)='CDF Value:'
13219      NCTEXT(ICNT)=10
13220      AVALUE(ICNT)=CDF
13221      IDIGIT(ICNT)=NUMDIG
13222      ICNT=ICNT+1
13223      ITEXT(ICNT)='P-Value:'
13224      NCTEXT(ICNT)=8
13225      AVALUE(ICNT)=PVAL
13226      IDIGIT(ICNT)=NUMDIG
13227C
13228      NUMROW=ICNT
13229      DO5010I=1,NUMROW
13230        NTOT(I)=15
13231 5010 CONTINUE
13232C
13233      IFRST=.TRUE.
13234      ILAST=.TRUE.
13235C
13236      ISTEPN='42A'
13237      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB2')
13238     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13239C
13240      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
13241     1            AVALUE,IDIGIT,
13242     1            NTOT,NUMROW,
13243     1            ICAPSW,ICAPTY,ILAST,IFRST,
13244     1            ISUBRO,IBUGA3,IERROR)
13245C
13246      ISTEPN='42D'
13247      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB2')
13248     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13249C
13250      ITITLE=' '
13251      NCTITL=0
13252C
13253      ITITL9=' '
13254      NCTIT9=0
13255      ITITLE(1:44)='Percent Points of the Reference Distribution'
13256      NCTITL=44
13257      NUMLIN=1
13258      NUMROW=8
13259      NUMCOL=3
13260      ITITL2(1,1)='Percent Point'
13261      ITITL2(1,2)=' '
13262      ITITL2(1,3)='Value'
13263      NCTIT2(1,1)=13
13264      NCTIT2(1,2)=1
13265      NCTIT2(1,3)=5
13266C
13267      NMAX=0
13268      DO4221I=1,NUMCOL
13269        VALIGN(I)='b'
13270        ALIGN(I)='r'
13271        NTOT(I)=15
13272        IF(I.EQ.2)NTOT(I)=5
13273        NMAX=NMAX+NTOT(I)
13274        IDIGIT(I)=NUMDIG
13275        ITYPCO(I)='NUME'
13276 4221 CONTINUE
13277      ITYPCO(2)='ALPH'
13278      IDIGIT(1)=1
13279      IDIGIT(3)=3
13280      DO4223I=1,NUMROW
13281        DO4225J=1,NUMCOL
13282          NCVALU(I,J)=0
13283          IVALUE(I,J)=' '
13284          NCVALU(I,J)=0
13285          AMAT(I,J)=0.0
13286          IF(J.EQ.2)THEN
13287            IVALUE(I,J)='='
13288            NCVALU(I,J)=1
13289          ELSEIF(J.EQ.3)THEN
13290            IF(I.EQ.1)THEN
13291              AMAT(I,1)=25.0
13292              AMAT(I,J)=RND(CUT25,IDIGIT(J))
13293            ELSEIF(I.EQ.2)THEN
13294              AMAT(I,1)=50.0
13295              AMAT(I,J)=RND(CUT50,IDIGIT(J))
13296            ELSEIF(I.EQ.3)THEN
13297              AMAT(I,1)=75.0
13298              AMAT(I,J)=RND(CUT75,IDIGIT(J))
13299            ELSEIF(I.EQ.4)THEN
13300              AMAT(I,1)=80.0
13301              AMAT(I,J)=RND(CUT80,IDIGIT(J))
13302            ELSEIF(I.EQ.5)THEN
13303              AMAT(I,1)=90.0
13304              AMAT(I,J)=RND(CUT90,IDIGIT(J))
13305            ELSEIF(I.EQ.6)THEN
13306              AMAT(I,1)=95.0
13307              AMAT(I,J)=RND(CUT95,IDIGIT(J))
13308            ELSEIF(I.EQ.7)THEN
13309              AMAT(I,1)=97.5
13310              AMAT(I,J)=RND(CUT975,IDIGIT(J))
13311            ELSEIF(I.EQ.8)THEN
13312              AMAT(I,1)=99.0
13313              AMAT(I,J)=RND(CUT99,IDIGIT(J))
13314            ENDIF
13315          ENDIF
13316 4225   CONTINUE
13317 4223 CONTINUE
13318C
13319      IWHTML(1)=150
13320      IWHTML(2)=50
13321      IWHTML(3)=150
13322      IWRTF(1)=2000
13323      IWRTF(2)=IWRTF(1)+500
13324      IWRTF(3)=IWRTF(2)+2000
13325      IFRST=.TRUE.
13326      ILAST=.FALSE.
13327C
13328      ISTEPN='42C'
13329      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB2')
13330     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13331C
13332      CALL DPDTA4(ITITL9,NCTIT9,
13333     1            ITITLE,NCTITL,ITITL2,NCTIT2,
13334     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
13335     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
13336     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
13337     1            ICAPSW,ICAPTY,IFRST,ILAST,
13338     1            ISUBRO,IBUGA3,IERROR)
13339C
13340      ISTEPN='42D'
13341      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'GRU2')
13342     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13343C
13344      CDF1=CUT90
13345      CDF2=CUT95
13346      CDF3=CUT975
13347      CDF4=CUT99
13348C
13349      ITITL9=' '
13350      NCTIT9=0
13351      ITITLE='Conclusions (Upper 1-Tailed Test)'
13352      NCTITL=33
13353      NUMLIN=1
13354      NUMROW=4
13355      NUMCOL=4
13356      ITITL2(1,1)='Alpha'
13357      ITITL2(1,2)='CDF'
13358      ITITL2(1,3)='Critical Value'
13359      ITITL2(1,4)='Conclusion'
13360      NCTIT2(1,1)=5
13361      NCTIT2(1,2)=3
13362      NCTIT2(1,3)=14
13363      NCTIT2(1,4)=10
13364C
13365      NMAX=0
13366      DO4321I=1,NUMCOL
13367        VALIGN(I)='b'
13368        ALIGN(I)='r'
13369        NTOT(I)=15
13370        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
13371        IF(I.EQ.3)NTOT(I)=17
13372        NMAX=NMAX+NTOT(I)
13373        IDIGIT(I)=3
13374        ITYPCO(I)='ALPH'
13375 4321 CONTINUE
13376      ITYPCO(3)='NUME'
13377      IDIGIT(1)=0
13378      IDIGIT(2)=0
13379      DO4323I=1,NUMROW
13380        DO4325J=1,NUMCOL
13381          NCVALU(I,J)=0
13382          IVALUE(I,J)=' '
13383          NCVALU(I,J)=0
13384          AMAT(I,J)=0.0
13385 4325   CONTINUE
13386 4323 CONTINUE
13387      IVALUE(1,1)='10%'
13388      IVALUE(2,1)='5%'
13389      IVALUE(3,1)='2.5%'
13390      IVALUE(4,1)='1%'
13391      IVALUE(1,2)='90%'
13392      IVALUE(2,2)='95%'
13393      IVALUE(3,2)='97.5%'
13394      IVALUE(4,2)='99%'
13395      NCVALU(1,1)=3
13396      NCVALU(2,1)=2
13397      NCVALU(3,1)=4
13398      NCVALU(4,1)=2
13399      NCVALU(1,2)=3
13400      NCVALU(2,2)=3
13401      NCVALU(3,2)=5
13402      NCVALU(4,2)=3
13403      IVALUE(1,4)='Accept H0'
13404      IVALUE(2,4)='Accept H0'
13405      IVALUE(3,4)='Accept H0'
13406      IVALUE(4,4)='Accept H0'
13407      NCVALU(1,4)=9
13408      NCVALU(2,4)=9
13409      NCVALU(3,4)=9
13410      NCVALU(4,4)=9
13411      IF(STATVA.GT.CDF1)IVALUE(1,4)='Reject H0'
13412      IF(STATVA.GT.CDF2)IVALUE(2,4)='Reject H0'
13413      IF(STATVA.GT.CDF3)IVALUE(3,4)='Reject H0'
13414      IF(STATVA.GT.CDF4)IVALUE(4,4)='Reject H0'
13415      AMAT(1,3)=RND(CDF1,IDIGIT(3))
13416      AMAT(2,3)=RND(CDF2,IDIGIT(3))
13417      AMAT(3,3)=RND(CDF3,IDIGIT(3))
13418      AMAT(4,3)=RND(CDF4,IDIGIT(3))
13419C
13420      IWHTML(1)=150
13421      IWHTML(2)=150
13422      IWHTML(3)=150
13423      IWHTML(4)=150
13424      IWRTF(1)=1500
13425      IWRTF(2)=IWRTF(1)+1500
13426      IWRTF(3)=IWRTF(2)+2000
13427      IWRTF(4)=IWRTF(3)+2000
13428      IFRST=.FALSE.
13429      ILAST=.TRUE.
13430C
13431      ISTEPN='42E'
13432      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB2')
13433     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13434C
13435      CALL DPDTA4(ITITL9,NCTIT9,
13436     1            ITITLE,NCTITL,ITITL2,NCTIT2,
13437     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
13438     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
13439     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
13440     1            ICAPSW,ICAPTY,IFRST,ILAST,
13441     1            ISUBRO,IBUGA3,IERROR)
13442C
13443C
13444C               *****************
13445C               **  STEP 90--  **
13446C               **  EXIT       **
13447C               *****************
13448C
13449 9000 CONTINUE
13450      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB2')THEN
13451        WRITE(ICOUT,999)
13452        CALL DPWRST('XXX','BUG ')
13453        WRITE(ICOUT,9011)
13454 9011   FORMAT('***** AT THE END       OF DPJAB2--')
13455        CALL DPWRST('XXX','BUG ')
13456        WRITE(ICOUT,9012)N,IBUGA3,IERROR
13457 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
13458        CALL DPWRST('XXX','BUG ')
13459        DO9016I=1,N
13460          WRITE(ICOUT,9017)I,Y(I)
13461 9017     FORMAT('I,Y(I) = ',I8,G15.7)
13462          CALL DPWRST('XXX','BUG ')
13463 9016   CONTINUE
13464      ENDIF
13465C
13466      RETURN
13467      END
13468      SUBROUTINE DPJAB3(Y,N,ISEED,IRANAL,MAXNXT,
13469     1                  TEMP1,TEMP2,
13470     1                  YSKEW,YKURT,
13471     1                  STATVA,PVAL,CDF,
13472     1                  CUT25,CUT50,CUT75,CUT80,CUT90,
13473     1                  CUT95,CUT975,CUT99,CUT999,
13474     1                  ISUBRO,IBUGA3,IERROR)
13475C
13476C     PURPOSE--THIS ROUTINE CARRIES OUT THE JARQUE-BERA TEST
13477C              FOR NORMALITY.  EXTRACT FROM DPJAB3 IN ORDER TO
13478C              ALSO CALL BASIC COMPUTATION FROM CMPSTA.
13479C     REFERENCE--BRANI VIDAKOVIC (2011), "STATISTICS FOR
13480C                BIOENGINEERING SCIENCES: WITH MATLAB AND WINBUGS
13481C                SUPPORT", SPRINGER, PP. 521-522.
13482C     WRITTEN BY--ALAN HECKERT
13483C                 STATISTICAL ENGINEERING DIVISION
13484C                 INFORMATION TECHNOLOGY LABORATORY
13485C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13486C                 GAITHERSBURG, MD 20899-8980
13487C                 PHONE--301-975-2899
13488C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13489C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13490C     LANGUAGE--ANSI FORTRAN (1977)
13491C     VERSION NUMBER--2011/12
13492C     ORIGINAL VERSION--DECEMBER  2011.
13493C
13494C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13495C
13496      CHARACTER*4 IRANAL
13497      CHARACTER*4 ISUBRO
13498      CHARACTER*4 IBUGA3
13499      CHARACTER*4 IERROR
13500C
13501      CHARACTER*4 IBUGAZ
13502      CHARACTER*4 IWRITE
13503      CHARACTER*4 IDIR
13504      CHARACTER*4 IRANSV
13505C
13506      CHARACTER*4 ISUBN1
13507      CHARACTER*4 ISUBN2
13508      CHARACTER*4 ISTEPN
13509C
13510C---------------------------------------------------------------------
13511C
13512      DIMENSION Y(*)
13513      DIMENSION TEMP1(*)
13514      DIMENSION TEMP2(*)
13515C
13516C---------------------------------------------------------------------
13517C
13518      INCLUDE 'DPCOP2.INC'
13519C
13520C-----START POINT-----------------------------------------------------
13521C
13522      ISUBN1='DPJA'
13523      ISUBN2='B3  '
13524      IWRITE='OFF'
13525      IERROR='NO'
13526C
13527      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB3')THEN
13528        WRITE(ICOUT,999)
13529  999   FORMAT(1X)
13530        CALL DPWRST('XXX','WRIT')
13531        WRITE(ICOUT,51)
13532   51   FORMAT('**** AT THE BEGINNING OF DPJAB3--')
13533        CALL DPWRST('XXX','WRIT')
13534        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
13535   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
13536        CALL DPWRST('XXX','WRIT')
13537        DO56I=1,N
13538          WRITE(ICOUT,57)I,Y(I)
13539   57     FORMAT('I,Y(I) = ',I8,G15.7)
13540          CALL DPWRST('XXX','WRIT')
13541   56   CONTINUE
13542      ENDIF
13543C
13544C               ********************************************
13545C               **  STEP 11--                             **
13546C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
13547C               ********************************************
13548C
13549      ISTEPN='11'
13550      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB3')
13551     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13552C
13553      IF(N.LT.5)THEN
13554        WRITE(ICOUT,999)
13555        CALL DPWRST('XXX','WRIT')
13556        WRITE(ICOUT,101)
13557  101   FORMAT('***** ERROR: JARQUE-BARE TEST--')
13558        CALL DPWRST('XXX','WRIT')
13559        WRITE(ICOUT,102)
13560  102   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 5.',
13561     1         '  SUCH WAS NOT THE CASE HERE.')
13562        CALL DPWRST('XXX','WRIT')
13563        WRITE(ICOUT,103)N
13564  103   FORMAT('      SAMPLE SIZE = ',I8)
13565        CALL DPWRST('XXX','WRIT')
13566        IERROR='YES'
13567        GOTO9000
13568      ENDIF
13569C
13570      HOLD=Y(1)
13571      DO135I=2,N
13572        IF(Y(I).NE.HOLD)GOTO139
13573  135 CONTINUE
13574      WRITE(ICOUT,999)
13575      CALL DPWRST('XXX','WRIT')
13576      WRITE(ICOUT,101)
13577      CALL DPWRST('XXX','WRIT')
13578      WRITE(ICOUT,131)HOLD
13579  131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
13580      CALL DPWRST('XXX','WRIT')
13581      GOTO9000
13582  139 CONTINUE
13583C
13584C               ******************************
13585C               **  STEP 11--               **
13586C               **  CARRY OUT CALCULATIONS  **
13587C               **  FOR JARQUE-BERA         **
13588C               **  TEST                    **
13589C               ******************************
13590C
13591      ISTEPN='11'
13592      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB3')
13593     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
13594C
13595      IBUGAZ='ON'
13596      IF(IBUGA3.EQ.'NO')IBUGAZ='OFF'
13597      IF(IBUGA3.EQ.'OFF')IBUGAZ='OFF'
13598      CALL STMOM3(Y,N,IWRITE,YSKEW,IBUGAZ,IERROR)
13599      CALL STMOM4(Y,N,IWRITE,YKURT,IBUGAZ,IERROR)
13600      AN=REAL(N)
13601      STATVA=(AN/6.0)*(YSKEW**2 + (YKURT - 3.0)**2/4.0)
13602C
13603C     FOR LARGE N, OBTAIN P-VALUE FROM CHI-SQUARE.  OTHERWISE,
13604C     PERFORM A SIMULATION.
13605C
13606      IF(N.LT.2000)THEN
13607        CALL MEAN(Y,N,IWRITE,YMEAN,IBUGAZ,IERROR)
13608        CALL SD(Y,N,IWRITE,YSD,IBUGAZ,IERROR)
13609C
13610C       NOW PERFORM 10,000 SIMULATIONS
13611C
13612        ISEESV=ISEED
13613        ISEED=2503
13614        IRANSV=IRANAL
13615        IRANAL='FINC'
13616        NSIM=100000
13617        DO1000I=1,NSIM
13618          CALL NORRAN(N,ISEED,TEMP1)
13619          DO1010J=1,N
13620            TEMP1(I)=YMEAN + YSD*TEMP1(I)
13621 1010     CONTINUE
13622          CALL STMOM3(TEMP1,N,IWRITE,YSKEW2,IBUGAZ,IERROR)
13623          CALL STMOM4(TEMP1,N,IWRITE,YKURT2,IBUGAZ,IERROR)
13624          AN=REAL(N)
13625          STATV2=(AN/6.0)*(YSKEW2**2 + (YKURT2 - 3.0)**2/4.0)
13626          TEMP2(I)=STATV2
13627 1000   CONTINUE
13628        IDIR='UPPE'
13629CCCCC   IDIR='LOWE'
13630        CALL DPGOF8(TEMP2,NSIM,STATVA,PVAL,IDIR,
13631     1              IBUGAZ,ISUBRO,IERROR)
13632        CDF=1.0 - PVAL
13633        ISEED=ISEESV
13634        IRANAL=IRANSV
13635        PTEMP=25.0
13636        CALL PERCEN(PTEMP,TEMP2,NSIM,IWRITE,TEMP1,MAXNXT,CUT25,
13637     1              IBUGA3,IERROR)
13638        PTEMP=50.0
13639        CALL PERCEN(PTEMP,TEMP2,NSIM,IWRITE,TEMP1,MAXNXT,CUT50,
13640     1              IBUGA3,IERROR)
13641        PTEMP=75.0
13642        CALL PERCEN(PTEMP,TEMP2,NSIM,IWRITE,TEMP1,MAXNXT,CUT75,
13643     1              IBUGA3,IERROR)
13644        PTEMP=80.0
13645        CALL PERCEN(PTEMP,TEMP2,NSIM,IWRITE,TEMP1,MAXNXT,CUT80,
13646     1              IBUGA3,IERROR)
13647        PTEMP=90.0
13648        CALL PERCEN(PTEMP,TEMP2,NSIM,IWRITE,TEMP1,MAXNXT,CUT90,
13649     1              IBUGA3,IERROR)
13650        PTEMP=95.0
13651        CALL PERCEN(PTEMP,TEMP2,NSIM,IWRITE,TEMP1,MAXNXT,CUT95,
13652     1              IBUGA3,IERROR)
13653        PTEMP=97.5
13654        CALL PERCEN(PTEMP,TEMP2,NSIM,IWRITE,TEMP1,MAXNXT,CUT975,
13655     1              IBUGA3,IERROR)
13656        PTEMP=99.0
13657        CALL PERCEN(PTEMP,TEMP2,NSIM,IWRITE,TEMP1,MAXNXT,CUT99,
13658     1              IBUGA3,IERROR)
13659        PTEMP=99.9
13660        CALL PERCEN(PTEMP,TEMP2,NSIM,IWRITE,TEMP1,MAXNXT,CUT999,
13661     1              IBUGA3,IERROR)
13662      ELSE
13663        NU=2
13664        CALL CHSCDF(STATVA,NU,CDF)
13665        PVAL=1.0 - CDF
13666        CALL CHSPPF(0.25,NU,CUT25)
13667        CALL CHSPPF(0.50,NU,CUT50)
13668        CALL CHSPPF(0.75,NU,CUT75)
13669        CALL CHSPPF(0.80,NU,CUT80)
13670        CALL CHSPPF(0.90,NU,CUT90)
13671        CALL CHSPPF(0.95,NU,CUT95)
13672        CALL CHSPPF(0.975,NU,CUT975)
13673        CALL CHSPPF(0.99,NU,CUT99)
13674        CALL CHSPPF(0.999,NU,CUT999)
13675      ENDIF
13676C
13677C               *****************
13678C               **  STEP 90--  **
13679C               **  EXIT       **
13680C               *****************
13681C
13682 9000 CONTINUE
13683      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'JAB3')THEN
13684        WRITE(ICOUT,999)
13685        CALL DPWRST('XXX','BUG ')
13686        WRITE(ICOUT,9011)
13687 9011   FORMAT('***** AT THE END       OF DPJAB3--')
13688        CALL DPWRST('XXX','BUG ')
13689        WRITE(ICOUT,9012)N,IBUGA3,IERROR
13690 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
13691        CALL DPWRST('XXX','BUG ')
13692        WRITE(ICOUT,9013)YSKEW,YKURT,STATVA,CDF
13693 9013   FORMAT('YSKEW,YKURT,STATVA,CDF = ',4G15.7)
13694        CALL DPWRST('XXX','BUG ')
13695      ENDIF
13696C
13697      RETURN
13698      END
13699      SUBROUTINE DPJBSP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
13700     1                  IBOOSS,ISEED,IBCABT,MAXNXT,
13701     1                  ICAPSW,ICAPTY,IFORSW,
13702     1                  CLLIMI,CLWIDT,
13703     1                  ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ,
13704     1                  IFOUND,IERROR)
13705C
13706C     PURPOSE--GENERATE A JACKNIFE OR BOOTSTRAP PLOT OF:
13707C
13708C              1) ANY DATAPLOT STATISTIC THAT REQUIRES
13709C                 EITHER ONE OR TWO RESPONSE VARIABLES
13710C                 (I.E., EXTSTA/CMPSTA)
13711C
13712C              2) GOODNESS OF FIT FOR DISTRIBUTIONS (FOR
13713C                 DISTRIBUTIONS WITH 0, 1, OR 2 SHAPE PARAMETERS).
13714C                 THE CURRENTLY SUPPORTED GOODNESS OF FIT
13715C                 STATISTCS ARE PPCC, KOLMOGOROV-SMIRNOV, AND
13716C                 ANDERSON-DARLING.
13717C
13718C              3) MAXIMUM LIKELIHOOD FOR DISTRIBUTIONS.
13719C
13720C              4) STATISTICS THAT ARE CURRENTLY SPECIFIC TO
13721C                 THE JACKNIFE/BOOTSTRAP.  THIS CURRENTY
13722C                 INCLUDES:
13723C
13724C                 a) LINEAR CALIBRATION
13725C                 b) QUADRATIC CALIBRATION
13726C
13727C     WRITTEN BY--JAMES J. FILLIBEN
13728C                 STATISTICAL ENGINEERING DIVISION
13729C                 INFORMATION TECHNOLOGY LABORATORY
13730C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13731C                 GAITHERSBURG, MD 20899-8980
13732C                 PHONE--301-975-2855
13733C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13734C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13735C     LANGUAGE--ANSI FORTRAN (1977)
13736C     VERSION NUMBER--89/2
13737C     ORIGINAL VERSION--JANUARY   1989.
13738C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO G2RBAGE COMMON
13739C     UPDATED         --FEBRUARY  1994. SYNONYMS FOR TAGUCHI
13740C     UPDATED         --MARCH     1995. MAD AND AAD PLOTS
13741C     UPDATED         --MARCH     1998. SAVE CERTAIN PERCENTILE PARAMETERS
13742C                                       AUTOMATICALLY
13743C     UPDATED         --MARCH     1998. ACTIVATE RELATIVE VARIANCE AND
13744C                                       COEFFICENT OF VARIATION
13745C     UPDATED         --NOVEMBER  1998. ADD PERCENTILE PLOTS
13746C     UPDATED         --MARCH     1999. ADD GEOMETRIC MEAN
13747C     UPDATED         --MARCH     1999. ADD GEOMETRIC STAND DEVIATION
13748C     UPDATED         --MARCH     1999. ADD HARMONIC MEAN
13749C     UPDATED         --SEPTEMBER 2001. ADD IQ RANGE
13750C     UPDATED         --NOVEMBER  2001. ADD BIWEIGHT LOCATION
13751C     UPDATED         --NOVEMBER  2001. ADD BIWEIGHT SCALE
13752C     UPDATED         --JULY      2002. ADD WINSORIZED VARIANCE
13753C     UPDATED         --JULY      2002. ADD WINSORIZED SD
13754C     UPDATED         --JULY      2002. ADD WINSORIZED COVARIANCE
13755C     UPDATED         --JULY      2002. ADD WINSORIZED CORRELATION
13756C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDVARIANCE
13757C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCOVARIANCE
13758C     UPDATED         --JULY      2002. ADD BIWEIGHT MIDCORRELATION
13759C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND MIDVARIANCE
13760C     UPDATED         --JULY      2002. ADD PERCENTAGE BEND CORRELATION
13761C     UPDATED         --JULY      2002. ADD HODGES LEHMAN
13762C     UPDATED         --JULY      2002. ADD QUANTILE
13763C     UPDATED         --JULY      2002. ADD QUANTILE STANDARD ERROR
13764C     UPDATED         --JULY      2002. ADD TRIMMED MEAN STANDARD ERROR
13765C     UPDATED         --JULY      2002. ADD LINEAR CALIBRATION
13766C     UPDATED         --JULY      2002. ADD QUADRATIC CALIBRATION
13767C     UPDATED         --MARCH     2003. ADD 34 "DIFFERENCE OF" STATS
13768C     UPDATED         --MARCH     2003. FOR "DIFFERENCE OF" STATS,
13769C                                       DISTINGUISH BETWEEN INDEPENDENT
13770C                                       AND DEPENDENT GROUPS
13771C     UPDATED         --APRIL     2003. ADD SN AND QN (AND DIFFERENCE
13772C                                       OF).  REQUIRED ADDITIONAL
13773C                                       SCRATCH ARRAYS.
13774C     UPDATED         --JULY      2003. SUPPORT FOR TWO GROUP VARIABLES
13775C     UPDATED         --SEPTEMBER 2003. SUPPORT FOR BCA CONFIDENCE INTERVAL
13776C     UPDATED         --JANUARY   2005. MAKE COMMAND SEARCH TABLE
13777C                                       DRIVEN
13778C     UPDATED         --JANUARY   2005. SUPPORT FOR BOOTSTRAPPING OF
13779C                                       DISTRIBUTIONAL MODELS
13780C     UPDATED         --MARCH     2005. ADD GENERALIZED PARETO MLE
13781C                                       AND MOMENTS
13782C     UPDATED         --MAY       2005. ADD FRECHET MLE
13783C     UPDATED         --AUGUST    2005. ADD INVERTED WEIBULL MLE
13784C     UPDATED         --SEPTEMBER 2005. ADD RATIO
13785C     UPDATED         --MARCH     2006. UNIFORM MLE PLOT AS SYNONYM
13786C                                       FOR UNIFORM MAXI LIKE
13787C     UPDATED         --MARCH     2006. ADD GENERALIZIED LOGISTIC
13788C                                       TYPE 2 - TYPE 5
13789C     UPDATED         --MARCH     2006. ADD BETA NORMAL
13790C     UPDATED         --OCTOBER   2006. MAXWELL KS PLOT
13791C     UPDATED         --FEBRUARY  2007. ADD SOME ADDITIONAL
13792C                                       DISTRIBUTUIONS
13793C     UPDATED         --MARCH     2007. ADD RELATIVE RISK
13794C     UPDATED         --MARCH     2007. ADD CRAMER CONTINCENCY COEFF
13795C     UPDATED         --MARCH     2007. ADD PEARSON CONTINCENCY COEFF
13796C     UPDATED         --MARCH     2007. FALSE POSITIVE
13797C     UPDATED         --MARCH     2007. FALSE NEGATIVE
13798C     UPDATED         --MARCH     2007. TRUE POSITIVE
13799C     UPDATED         --MARCH     2007. TRUE NEGATIVE
13800C     UPDATED         --MARCH     2007. TEST SENSITIVITY
13801C     UPDATED         --MARCH     2007. TEST SPECIFICITY
13802C     UPDATED         --APRIL     2007. POSITIVE PREDICTIVE VALUE
13803C     UPDATED         --APRIL     2007. NEGATIVE PREDICTIVE VALUE
13804C     UPDATED         --APRIL     2007. ADD LOG ODDS RATIO
13805C     UPDATED         --APRIL     2007. ADD LOG ODDS RATIO SE
13806C     UPDATED         --MAY       2007. ADD TRIMMED STAND DEVI
13807C     UPDATED         --MAY       2007. ADD TRIANGULAR MAXIMUM LIKELIHOOD
13808C     UPDATED         --JUNE      2007. ADD SLASH MAXIMUM LIKELIHOOD
13809C     UPDATED         --AUGUST    2007. ADD BETA NORMAL AND LOG BETA MLE
13810C     UPDATED         --SEPTEMBER 2007. ADD REFLECTED GENERALIZED TOPP
13811C                                       LEONE MLE
13812C     UPDATED         --OCTOBER   2007. ADD SLOPE, OGIVE
13813C     UPDATED         --OCTOBER   2007. ADD TWO-SIDED SLOPE
13814C     UPDATED         --OCTOBER   2007. ADD TWO-SIDED OGIVE
13815C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 2
13816C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 3
13817C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 5
13818C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 6
13819C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 7
13820C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 8
13821C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 9
13822C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 10
13823C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 11
13824C     UPDATED         --OCTOBER   2007. ADD BURR TYPE 12
13825C     UPDATED         --NOVEMBER  2007. ADD DOUBLE PARETO UNIFORM
13826C     UPDATED         --NOVEMBER  2007. ADD KUMARASWAMY
13827C     UPDATED         --NOVEMBER  2007. ADD ALPHA
13828C     UPDATED         --NOVEMBER  2007. ADD EXPONENTIAL POWER
13829C     UPDATED         --NOVEMBER  2007. ADD FOLDED CAUCHY
13830C     UPDATED         --NOVEMBER  2007. LP LOCATION
13831C     UPDATED         --NOVEMBER  2007. VARIANCE OF LP LOCATION
13832C     UPDATED         --NOVEMBER  2007. SD OF LP LOCATION
13833C     UPDATED         --NOVEMBER  2007. DIFFERENCE OF LP LOCATION
13834C     UPDATED         --NOVEMBER  2007. DIFFERENCE OF VARI OF LP LOCATION
13835C     UPDATED         --NOVEMBER  2007. DIFFERENCE OF SD OF LP LOCATION
13836C     UPDATED         --DECEMBER  2007. POWER MLE
13837C     UPDATED         --DECEMBER  2007. REFLECTED POWER PPCC/KS
13838C     UPDATED         --JANUARY   2008. MUTH PPCC/KS
13839C     UPDATED         --FEBRUARY  2008. LOGISTIC-EXPONENTIAL PPCC/KS
13840C     UPDATED         --FEBRUARY  2008. LOGISTIC-EXPONENTIAL MLE
13841C     UPDATED         --MARCH     2008. TRUNCATED PARETO MLE
13842C     UPDATED         --MARCH     2008. REFLECTED POWER MLE
13843C     UPDATED         --JULY      2008. INVERTED GAMMA MLE
13844C     UPDATED         --JULY      2008. VON MISES MLE
13845C     UPDATED         --JULY      2008. MIELKE BETA-KAPPA PPCC/KS
13846C     UPDATED         --JULY      2008. KAPPA PPCC/KS/MLE
13847C     UPDATED         --JULY      2008. PEARSON TYPE 3 PPCC/KS/MLE
13848C     UPDATED         --FEBRUARY  2009. BINOMIAL PROPORTION
13849C     UPDATED         --FEBRUARY  2009. GRUBB
13850C     UPDATED         --FEBRUARY  2009. ONE SAMPLE T TEST
13851C     UPDATED         --FEBRUARY  2009. CHI-SQUARE SD TEST
13852C     UPDATED         --FEBRUARY  2009. FREQUENCY TEST
13853C     UPDATED         --FEBRUARY  2009. FREQUENCY WITHIN A BLOCK TEST
13854C     UPDATED         --MARCH     2010. RE-WRITE TO:
13855C                                       1) USE DPPARS
13856C                                       2) USE EXTSTA
13857C                                       3) USE EXTDIS
13858C                                       4) USE DIFFERENT SUBROUTINES
13859C                                          FOR DIFFERENT CASES TO KEEP
13860C                                          OVERALL CODE MORE DIGESTABLE
13861C     UPDATED         --SEPTEMBER 2010. SUPPORT A "LEVEL" VARIABLE
13862C                                       FOR BRITTLE FIBER WEIBULL
13863C                                       (MAY ADD TO A FEW OTHERS AT
13864C                                       A LATER TIME).  NOTE THAT THIS
13865C                                       IS CURRENTLY ONLY SUPPORTED
13866C                                       FOR THE SINGLE RESPONSE
13867C                                       VARIABLE RAW DATA CASE
13868C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE
13869C     UPDATED         --JULY      2019. CALL LIST TO DPJBS7, REDUCE
13870C                                       NUMBER OF SCRATCH ARRAYS
13871C
13872C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13873C
13874      CHARACTER*4 ICAPSW
13875      CHARACTER*4 ICAPTY
13876      CHARACTER*4 IFORSW
13877      CHARACTER*4 IRELAT
13878      CHARACTER*4 ICASPL
13879      CHARACTER*4 IAND1
13880      CHARACTER*4 IAND2
13881      CHARACTER*4 ICONT
13882      CHARACTER*4 ISUBRO
13883      CHARACTER*4 IBUGG2
13884      CHARACTER*4 IBUGG3
13885      CHARACTER*4 IBUGQ
13886      CHARACTER*4 IFOUND
13887      CHARACTER*4 IERROR
13888C
13889      CHARACTER*4 ICASP2
13890      CHARACTER*4 ICASJB
13891      CHARACTER*4 ICASEB
13892      CHARACTER*4 IFLAGD
13893      CHARACTER*4 IFLAGV
13894      CHARACTER*4 IFLAGI
13895      CHARACTER*4 IBCABT
13896      CHARACTER*4 ICENSO
13897      CHARACTER*4 IMETHD
13898      CHARACTER*4 ILEVEL
13899      CHARACTER*4 IWRITE
13900C
13901      CHARACTER*4 ISUBN1
13902      CHARACTER*4 ISUBN2
13903      CHARACTER*4 ISTEPN
13904C
13905      CHARACTER*4 IHWUSE
13906      CHARACTER*4 MESSAG
13907      CHARACTER*4 IH
13908      CHARACTER*4 IH2
13909      CHARACTER*4 IHP
13910      CHARACTER*4 IHP2
13911      CHARACTER*4 IH41
13912      CHARACTER*4 IH42
13913C
13914      CHARACTER*4 ISTATN(17)
13915      CHARACTER*4 ISTAT2(17)
13916C
13917      PARAMETER (MAXSPN=30)
13918      CHARACTER*4 IVARN1(MAXSPN)
13919      CHARACTER*4 IVARN2(MAXSPN)
13920      CHARACTER*4 IVARTY(MAXSPN)
13921      REAL PVAR(MAXSPN)
13922      INTEGER ILIS(MAXSPN)
13923      INTEGER NRIGHT(MAXSPN)
13924      INTEGER ICOLR(MAXSPN)
13925C
13926      CHARACTER*40 INAME
13927      CHARACTER*60 ISTANM
13928      CHARACTER*60 IDIST
13929      CHARACTER*4  ISTADF
13930C
13931      DIMENSION CLLIMI(*)
13932      DIMENSION CLWIDT(*)
13933C
13934      REAL KSLOC
13935      REAL KSSCAL
13936C
13937C---------------------------------------------------------------------
13938C
13939      PARAMETER (NUMCHS=2)
13940      CHARACTER*4 INAM2(NUMCHS,6)
13941      CHARACTER*4 INCASE(NUMCHS)
13942      CHARACTER*4 INFLAV(NUMCHS)
13943      CHARACTER*4 INFLAD(NUMCHS)
13944C
13945      INCLUDE 'DPCOPA.INC'
13946      INCLUDE 'DPCOZZ.INC'
13947      INCLUDE 'DPCOZD.INC'
13948      INCLUDE 'DPCOZI.INC'
13949      PARAMETER (MAXBGR=2)
13950C
13951      DIMENSION Y1(MAXOBV)
13952      DIMENSION Z1(MAXOBV)
13953      DIMENSION X1(MAXOBV)
13954      DIMENSION XLEVEL(MAXOBV)
13955C
13956      DIMENSION TEMP0(MAXOBV)
13957      DIMENSION TEMPZ0(MAXOBV)
13958      DIMENSION TEMPL(MAXOBV)
13959      DIMENSION TEMPZL(MAXOBV)
13960      DIMENSION RES1(MAXOBV)
13961      DIMENSION RES2(MAXOBV)
13962      DIMENSION XTEMP3(MAXOBV)
13963      DIMENSION TEMP4(MAXOBV)
13964      DIMENSION TEMP5(MAXOBV)
13965      DIMENSION TEMPTH(MAXOBV)
13966      DIMENSION TEMPT2(MAXOBV)
13967      DIMENSION TEMP6(MAXOBV)
13968      DIMENSION TEMP7(MAXOBV)
13969      DIMENSION TEMP8(MAXOBV)
13970      DIMENSION QP(MAXOBV)
13971      DIMENSION XQP(MAXOBV)
13972      DIMENSION XQPLCL(MAXOBV)
13973      DIMENSION XQPUCL(MAXOBV)
13974      DIMENSION WEIGHH(MAXOBV)
13975      DIMENSION WEIGHV(MAXOBV)
13976      DIMENSION TEMP(MAXOBV)
13977      DIMENSION TEMP2(MAXOBV)
13978      DIMENSION TEMP3(MAXOBV)
13979      DIMENSION XTEMP1(MAXOBV)
13980      DIMENSION XTEMP2(MAXOBV)
13981      DIMENSION ZTEMP1(MAXOBV)
13982      DIMENSION ZTEMP2(MAXOBV)
13983      DIMENSION ZTEMP3(MAXOBV)
13984      DIMENSION XDESGN(MAXOBV,2)
13985C
13986      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
13987      EQUIVALENCE (GARBAG(IGARB2),Z1(1))
13988      EQUIVALENCE (GARBAG(IGARB3),X1(1))
13989      EQUIVALENCE (GARBAG(IGARB4),XLEVEL(1))
13990      EQUIVALENCE (GARBAG(IGARB5),TEMP0(1))
13991      EQUIVALENCE (GARBAG(IGARB6),TEMPZ0(1))
13992      EQUIVALENCE (GARBAG(IGARB7),RES1(1))
13993      EQUIVALENCE (GARBAG(IGARB8),RES2(1))
13994      EQUIVALENCE (GARBAG(IGAR10),XTEMP3(1))
13995      EQUIVALENCE (GARBAG(JGAR11),TEMP4(1))
13996      EQUIVALENCE (GARBAG(JGAR12),TEMP5(1))
13997      EQUIVALENCE (GARBAG(JGAR13),TEMPTH(1))
13998      EQUIVALENCE (GARBAG(JGAR14),TEMP6(1))
13999      EQUIVALENCE (GARBAG(JGAR15),TEMP7(1))
14000      EQUIVALENCE (GARBAG(JGAR16),TEMP8(1))
14001      EQUIVALENCE (GARBAG(JGAR17),TEMPT2(1))
14002      EQUIVALENCE (GARBAG(JGAR18),QP(1))
14003      EQUIVALENCE (GARBAG(JGAR19),XQP(1))
14004      EQUIVALENCE (GARBAG(JGAR20),WEIGHH(1))
14005      EQUIVALENCE (GARBAG(IGAR11),WEIGHV(1))
14006      EQUIVALENCE (GARBAG(IGAR12),TEMP(1))
14007      EQUIVALENCE (GARBAG(IGAR13),TEMP2(1))
14008      EQUIVALENCE (GARBAG(IGAR14),TEMP3(1))
14009      EQUIVALENCE (GARBAG(IGAR15),XTEMP1(1))
14010      EQUIVALENCE (GARBAG(IGAR16),XTEMP2(1))
14011      EQUIVALENCE (GARBAG(IGAR17),ZTEMP1(1))
14012      EQUIVALENCE (GARBAG(IGAR18),ZTEMP2(1))
14013      EQUIVALENCE (GARBAG(IGAR19),ZTEMP3(1))
14014      EQUIVALENCE (GARBAG(IGAR20),XQPLCL(1))
14015      EQUIVALENCE (GARBAG(IGAR21),XQPUCL(1))
14016      EQUIVALENCE (GARBAG(IGAR22),TEMPL(1))
14017      EQUIVALENCE (GARBAG(IGAR23),TEMPZL(1))
14018      EQUIVALENCE (GARBAG(IGAR24),XDESGN(1,1))
14019C
14020      INTEGER ITEMP1(MAXOBV)
14021      INTEGER ITEMP2(MAXOBV)
14022      INTEGER ITEMP3(MAXOBV)
14023      INTEGER ITEMP4(MAXOBV)
14024      INTEGER ITEMP5(MAXOBV)
14025      INTEGER ITEMP6(MAXOBV)
14026      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
14027      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
14028      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
14029      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
14030      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
14031      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
14032C
14033      DOUBLE PRECISION DTEMP1(MAXOBV)
14034      DOUBLE PRECISION DTEMP2(MAXOBV)
14035      DOUBLE PRECISION DTEMP3(MAXOBV)
14036      DOUBLE PRECISION DTEMP4(MAXOBV)
14037      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
14038      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
14039      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
14040      EQUIVALENCE (DGARBG(IDGAR4),DTEMP4(1))
14041C
14042      PARAMETER(NPERC2=15)
14043      DIMENSION APERC(NPERC2)
14044      DIMENSION BPERC(NPERC2)
14045C
14046C-----COMMON----------------------------------------------------------
14047C
14048      INCLUDE 'DPCOHK.INC'
14049      INCLUDE 'DPCODA.INC'
14050      INCLUDE 'DPCOST.INC'
14051      INCLUDE 'DPCOS2.INC'
14052      INCLUDE 'DPCOMC.INC'
14053      INCLUDE 'DPCOP2.INC'
14054C
14055      DATA (ISTATN(I),I=1,17)/
14056     1'BSD ',
14057     1'BMEA',
14058     1'B975',
14059     1'B025',
14060     1'B001',
14061     1'B005',
14062     1'B01 ',
14063     1'B05 ',
14064     1'B10 ',
14065     1'B20 ',
14066     1'B50 ',
14067     1'B80 ',
14068     1'B90 ',
14069     1'B95 ',
14070     1'B99 ',
14071     1'B995',
14072     1'B999'/
14073      DATA (ISTAT2(I),I=1,17)/
14074     1'    ',
14075     1'N   ',
14076     1'    ',
14077     1'    ',
14078     1'    ',
14079     1'    ',
14080     1'    ',
14081     1'    ',
14082     1'    ',
14083     1'    ',
14084     1'    ',
14085     1'    ',
14086     1'    ',
14087     1'    ',
14088     1'    ',
14089     1'    ',
14090     1'    '/
14091C
14092      DATA APERC/ 0.1,  0.5,  1.0,  2.5,  5.0, 10.0, 20.0, 50.0,
14093     1           80.0, 90.0, 95.0, 97.5, 99.0, 99.5, 99.9/
14094C
14095      DATA INCASE(1)/'LICA'/
14096      DATA (INAM2(1,J),J=1,6)/
14097     1'LINE','CALI','    ','    ','    ','    '/
14098      DATA INFLAV(1)/'TWO '/
14099      DATA INFLAD(1)/'OFF '/
14100C
14101      DATA INCASE(2)/'QUCA'/
14102      DATA (INAM2(2,J),J=1,6)/
14103     1'QUAD','CALI','    ','    ','    ','    '/
14104      DATA INFLAV(2)/'TWO '/
14105      DATA INFLAD(2)/'OFF '/
14106C
14107C-----START POINT-----------------------------------------------------
14108C
14109      IERROR='NO'
14110      IFLAGD='OFF'
14111      IFLAGV='ONE'
14112      NGRPV=0
14113      ICENSO='OFF'
14114      ILEVEL='OFF'
14115      IMETHD='UNIM'
14116      IF(IPPLCN.EQ.'KAPL')IMETHD=IPPLCN
14117      ICASEB='NULL'
14118      ISUBN1='DPJB'
14119      ISUBN2='SP  '
14120C
14121      MAXCP1=MAXCOL+1
14122      MAXCP2=MAXCOL+2
14123      MAXCP3=MAXCOL+3
14124      MAXCP4=MAXCOL+4
14125      MAXCP5=MAXCOL+5
14126      MAXCP6=MAXCOL+6
14127C
14128      MAXV2=5
14129      MINN2=2
14130      ICOLL=0
14131      ICOLH=0
14132      ICOLX=0
14133      IVAL=0
14134C
14135C               **********************************************
14136C               **  TREAT THE BOOTSTRAP/JACKNIFE PLOT CASE  **
14137C               **********************************************
14138C
14139      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN
14140        WRITE(ICOUT,999)
14141  999   FORMAT(1X)
14142        CALL DPWRST('XXX','BUG ')
14143        WRITE(ICOUT,51)
14144   51   FORMAT('***** AT THE BEGINNING OF DPJBSP--')
14145        CALL DPWRST('XXX','BUG ')
14146        WRITE(ICOUT,52)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ
14147   52   FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',
14148     1         A4,2X,A4,2X,A4,2X,A4,2X,A4)
14149        CALL DPWRST('XXX','BUG ')
14150        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
14151   53   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
14152        CALL DPWRST('XXX','BUG ')
14153        WRITE(ICOUT,54)IBOOSS
14154   54   FORMAT('IBOOSS = ',I8)
14155        CALL DPWRST('XXX','BUG ')
14156      ENDIF
14157C
14158C               *********************************
14159C               **  STEP 1--                   **
14160C               **  DETERMINE IF OF THIS TYPE  **
14161C               **  AND BRANCH ACCORDINGLY.    **
14162C               *********************************
14163C
14164      ISTEPN='1'
14165      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')
14166     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14167C
14168      IF(ICOM.EQ.'JACK')THEN
14169        ICASJB='JACK'
14170      ELSEIF(ICOM.EQ.'BOOT')THEN
14171        ICASJB='BOOT'
14172      ELSE
14173        IFOUND='NO'
14174        GOTO9000
14175      ENDIF
14176C
14177      IF(NUMARG.LE.1)GOTO9000
14178C
14179C
14180C               ***********************************************
14181C               **  STEP 1B--                                **
14182C               **  EXTRACT THE COMMAND                      **
14183C               **  1) CHECK FOR STATISTICS/CASES UNIQUE TO  **
14184C               **     BOOTSTRAP/JACKNIFE COMMAND            **
14185C               **  2) CHECK FOR SUPPORTED STATISTICS IN     **
14186C               **     EXTSTA                                **
14187C               **  3) CHECK FOR SUPPORTED DISTRIBUTIONS IN  **
14188C               **     EXTDIS                                **
14189C               ***********************************************
14190C
14191      ISTEPN='1B'
14192      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')
14193     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14194C
14195C     CASE 1: STATISTICS UNIQUE TO BOOTSTRAP/JACKNIFE COMMAND
14196C             (I.E., NOT IN EXTSTA OR EXTDIS)
14197C
14198      DO100I=1,NUMCHS
14199        IROW=I
14200        IF(INAM2(I,1).NE.ICOM)GOTO100
14201        DO102J=2,6
14202          IF(INAM2(I,J).NE.'    ')GOTO102
14203          ITEMP=J-1
14204          GOTO104
14205  102   CONTINUE
14206        ITEMP=6
14207  104   CONTINUE
14208        ILASTC=0
14209        IF(ITEMP.GT.1)THEN
14210          DO108J=2,ITEMP
14211            IF(INAM2(I,J).NE.IHARG(J-1))GOTO100
14212  108     CONTINUE
14213          ILASTC=ITEMP-1
14214        ENDIF
14215        I1=ILASTC+1
14216        I2=ILASTC+2
14217        I3=ILASTC+3
14218        IF(IHARG(I1).EQ.'PLOT')THEN
14219          ILASTC=I1
14220          ICASPL=INCASE(IROW)
14221          IFLAGV=INFLAV(IROW)
14222          IFLAGD=INFLAD(IROW)
14223          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
14224          ICASEB='STAT'
14225          IFOUND='YES'
14226          GOTO1000
14227        ELSEIF(IHARG(I1).EQ.'STAT'.AND.IHARG(I2).EQ.'PLOT')THEN
14228          ILASTC=I2
14229          ICASPL=INCASE(IROW)
14230          IFLAGV=INFLAV(IROW)
14231          IFLAGD=INFLAD(IROW)
14232          CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
14233          ICASEB='STAT'
14234          IFOUND='YES'
14235          GOTO1000
14236        END IF
14237C
14238  100 CONTINUE
14239C
14240C     CASE 2: SUPPORTED STATISTICS
14241C
14242C             EXTRACT THE DESIRED STATISTIC
14243C
14244C             SEARCH FOR WORD "PLOT".
14245C
14246      JMIN=1
14247      JMAX=NUMARG
14248C
14249      DO200I=1,NUMARG
14250        IF(IHARG(I).EQ.'PLOT')THEN
14251          JMAX=I-1
14252          ILASTC=I
14253          IFOUND='YES'
14254          GOTO209
14255        ENDIF
14256  200 CONTINUE
14257      IFOUND='NO'
14258      GOTO9000
14259  209 CONTINUE
14260C
14261      IFOUND='NO'
14262      CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
14263     1            ICASPL,ISTANM,ISTANR,ISTADF,IFOUND,ILOCV,
14264     1            ISUBRO,IBUGG3,IERROR)
14265C
14266      IF(IFOUND.EQ.'YES')THEN
14267        ICASEB='STAT'
14268        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
14269      ENDIF
14270C
14271      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN
14272        WRITE(ICOUT,999)
14273        CALL DPWRST('XXX','BUG ')
14274        WRITE(ICOUT,251)
14275  251   FORMAT('***** AFTER CALL EXTSTA--')
14276        CALL DPWRST('XXX','BUG ')
14277        WRITE(ICOUT,252)ICASPL,ISTANR,ILOCV,IFOUND,ICASEB
14278  252   FORMAT('ICASPL,ISTANR,ILOCV,IFOUND,ICASEB = ',
14279     1         A4,2I8,2X,A4,2X,A4)
14280        CALL DPWRST('XXX','BUG ')
14281      ENDIF
14282C
14283      IF(IFOUND.EQ.'YES')GOTO1000
14284C
14285C     CASE 3: DISTRIBUTIONAL BOOTSTRAP CASES
14286C
14287C             SEARCH FOR:
14288C
14289C             1) PPCC PLOT (DEFAULT)
14290C             2) KS PLOT
14291C             3) ANDERSON-DARLING PLOT
14292C             4) CENSORED (CURRENTLY SUPPORTED FOR PPCC PLOT ONLY)
14293C             5) MAXIMUM LIKELIHOOD
14294C
14295      ICASP2='PPCC'
14296      JMAX2=JMAX
14297C
14298      DO300I=1,JMAX2
14299        IF(I.LT.NUMARG .AND. IHARG(I).EQ.'STAT' .AND.
14300     1         IHARG(I+1).EQ.'PLOT')THEN
14301          JMAX=MIN(JMAX,I-1)
14302          ILASTC=MAX(ILASTC,I)
14303        ELSEIF(IHARG(I).EQ.'CENS')THEN
14304          ICENSO='ON'
14305          JMAX=MIN(JMAX,I-1)
14306          ILASTC=MAX(ILASTC,I)
14307        ELSEIF(IHARG(I).EQ.'KS')THEN
14308          ICASP2='KS'
14309          JMAX=MIN(JMAX,I-1)
14310          ILASTC=MAX(ILASTC,I)
14311        ELSEIF(I.LT.NUMARG .AND. IHARG(I).EQ.'KOLM' .AND.
14312     1         IHARG(I+1).EQ.'SMIR')THEN
14313          ICASP2='KS'
14314          JMAX=MIN(JMAX,I-1)
14315          ILASTC=MAX(ILASTC,I)
14316        ELSEIF(IHARG(I).EQ.'AD')THEN
14317          ICASP2='AD'
14318          JMAX=MIN(JMAX,I-1)
14319          ILASTC=MAX(ILASTC,I)
14320        ELSEIF(I.LT.NUMARG .AND. IHARG(I).EQ.'ANDE' .AND.
14321     1         IHARG(I+1).EQ.'DARL')THEN
14322          ICASP2='AD'
14323          JMAX=MIN(JMAX,I-1)
14324          ILASTC=MAX(ILASTC,I)
14325        ELSEIF(IHARG(I).EQ.'PPCC')THEN
14326          ICASP2='PPCC'
14327          JMAX=MIN(JMAX,I-1)
14328          ILASTC=MAX(ILASTC,I)
14329        ELSEIF(I.LT.NUMARG .AND. IHARG(I).EQ.'MAXI' .AND.
14330     1         IHARG(I+1).EQ.'LIKE')THEN
14331          ICASP2='MLE'
14332          JMAX=MIN(JMAX,I-1)
14333          ILASTC=MAX(ILASTC,I)
14334        ELSEIF(IHARG(I).EQ.'MLE ')THEN
14335          ICASP2='MLE '
14336          JMAX=MIN(JMAX,I-1)
14337          ILASTC=MAX(ILASTC,I)
14338        ELSEIF(IHARG(I).EQ.'ML  ')THEN
14339          ICASP2='MLE '
14340          JMAX=MIN(JMAX,I-1)
14341          ILASTC=MAX(ILASTC,I)
14342        ENDIF
14343  300 CONTINUE
14344      IFLAGV='ONE'
14345      IF(ICENSO.EQ.'ON')IFLAGV='TWO'
14346C
14347      CALL EXTDIS(ICOM,ICOM2,IHARG,IHARG2,NUMARG,JMIN,JMAX,
14348     1            ICASPL,IDIST,NUMSHA,IFOUND,ILOCV,
14349     1            ISUBRO,IBUGG3,IERROR)
14350C
14351      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN
14352        WRITE(ICOUT,999)
14353        CALL DPWRST('XXX','BUG ')
14354        WRITE(ICOUT,351)
14355  351   FORMAT('***** AFTER CALL EXTDIS--')
14356        CALL DPWRST('XXX','BUG ')
14357        WRITE(ICOUT,352)ICASPL,ICASP2,NUMSHA,IDIST
14358  352   FORMAT('ICASPL,ICASP2,NUMSHA,IDIST = ',2(A4,2X),I8,2X,A60)
14359        CALL DPWRST('XXX','BUG ')
14360      ENDIF
14361C
14362      IF(IFOUND.EQ.'YES')THEN
14363        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
14364      ELSE
14365        GOTO9000
14366      ENDIF
14367C
14368C               ***************************************************
14369C               **  STEP 3--EXTRACT THE SHAPE PARAMETERS FOR     **
14370C               **          THE SPECIFIED DISTRIBUTION.          **
14371C               ***************************************************
14372C
14373      ISTEPN='3'
14374      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')
14375     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14376C
14377      IHP='PPLO'
14378      IHP2='C   '
14379      IHWUSE='P'
14380      MESSAG='NO'
14381      CALL CHECKN(IHP,IHP2,IHWUSE,
14382     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14383     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
14384      IF(IERROR.EQ.'YES')THEN
14385        PPLOC=0.0
14386      ELSE
14387        PPLOC=VALUE(ILOCV)
14388      ENDIF
14389      IHP='PPSC'
14390      IHP2='ALE '
14391      IHWUSE='P'
14392      MESSAG='NO'
14393      CALL CHECKN(IHP,IHP2,IHWUSE,
14394     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14395     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
14396      IF(IERROR.EQ.'YES')THEN
14397        PPSCAL=1.0
14398      ELSE
14399        PPSCAL=VALUE(ILOCV)
14400        IF(PPSCAL.LE.0.0)PPSCAL=1.0
14401      ENDIF
14402C
14403      IHP='KSLO'
14404      IHP2='C   '
14405      IHWUSE='P'
14406      MESSAG='NO'
14407      CALL CHECKN(IHP,IHP2,IHWUSE,
14408     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14409     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
14410      IF(IERROR.EQ.'YES')THEN
14411        KSLOC=CPUMIN
14412      ELSE
14413        KSLOC=VALUE(ILOCV)
14414      ENDIF
14415      IHP='KSSC'
14416      IHP2='ALE '
14417      IHWUSE='P'
14418      MESSAG='NO'
14419      CALL CHECKN(IHP,IHP2,IHWUSE,
14420     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14421     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
14422      IF(IERROR.EQ.'YES')THEN
14423        KSSCAL=CPUMIN
14424      ELSE
14425        KSSCAL=VALUE(ILOCV)
14426        IF(KSSCAL.LE.0.0)KSSCAL=1.0
14427      ENDIF
14428C
14429      IFLAGL=0
14430      AL=CPUMIN
14431      IF(ICASPL.EQ.'WEIB' .OR. ICASPL.EQ.'3WEI')THEN
14432        IF(IWEIGL.EQ.'ON')THEN
14433          IHP='L   '
14434          IHP2='    '
14435          IHWUSE='P'
14436          MESSAG='NO'
14437          CALL CHECKN(IHP,IHP2,IHWUSE,
14438     1                IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14439     1                ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
14440          IF(IERROR.EQ.'NO')AL=VALUE(ILOCP)
14441          IF(AL.LE.0.0)THEN
14442            AL=CPUMIN
14443          ELSE
14444            IFLAGL=1
14445          ENDIF
14446        ENDIF
14447      ENDIF
14448C
14449      IF(ICASPL.EQ.'GMCL' .OR. ICASPL.EQ.'TRAP' .OR.
14450     1       ICASPL.EQ.'GTRA' .OR. ICASPL.EQ.'UTSP' .OR.
14451     1       ICASPL.EQ.'GLGP' .OR.
14452     1       ICASPL.EQ.'PARE' .OR. ICASPL.EQ.'PAR2'
14453     1  )THEN
14454        CONTINUE
14455      ELSE
14456        IHP='A   '
14457        IHP2='    '
14458        IHWUSE='P'
14459        MESSAG='NO'
14460        CALL CHECKN(IHP,IHP2,IHWUSE,
14461     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14462     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
14463        IF(IERROR.EQ.'YES')THEN
14464          A=0.0
14465        ELSE
14466          A=VALUE(ILOCV)
14467        ENDIF
14468C
14469        IHP='B   '
14470        IHP2='    '
14471        IHWUSE='P'
14472        MESSAG='NO'
14473        CALL CHECKN(IHP,IHP2,IHWUSE,
14474     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14475     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
14476        IF(IERROR.EQ.'YES')THEN
14477          B=1.0
14478        ELSE
14479          B=VALUE(ILOCV)
14480        ENDIF
14481C
14482      ENDIF
14483C
14484      IF(NUMSHA.GE.1)THEN
14485        CALL EXTPA2(ICASPL,IDIST,A,B,
14486     1              SHAP11,SHAP12,SHAP21,SHAP22,
14487     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
14488     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
14489     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,
14490     1              IGETDF,ICONDF,IGOMDF,IKATDF,
14491     1              IGIGDF,IGEODF,
14492     1              ISUBRO,IBUGG2,IERROR)
14493        IF(IERROR.EQ.'YES')GOTO9000
14494C
14495        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN
14496          WRITE(ICOUT,999)
14497          CALL DPWRST('XXX','BUG ')
14498          WRITE(ICOUT,361)
14499  361     FORMAT('***** AFTER CALL EXTPA2--')
14500          CALL DPWRST('XXX','BUG ')
14501          WRITE(ICOUT,362)SHAP11,SHAP12
14502  362     FORMAT('SHAP11,SHAP12 = ',2G15.7)
14503          CALL DPWRST('XXX','BUG ')
14504        ENDIF
14505      ENDIF
14506C
14507      ISTANR=1
14508C
14509 1000 CONTINUE
14510C
14511C               *********************************
14512C               **  STEP 2--                   **
14513C               **  EXTRACT THE VARIABLE LIST  **
14514C               *********************************
14515C
14516      INAME='BOOTSTRAP PLOT'
14517      IF(ICASPL.EQ.'JACK')INAME='JACKNIFE PLOT'
14518      MINNA=1
14519      MAXNA=100
14520      MINN2=2
14521CCCCC IFLAGE=1
14522      IFLAGE=0
14523      IFLAGM=0
14524      IFLAGP=0
14525      JMIN=1
14526      JMAX=NUMARG
14527      MINNVA=-99
14528      MAXNVA=-99
14529C
14530      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
14531     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
14532     1            JMIN,JMAX,
14533     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
14534     1            IVARN1,IVARN2,IVARTY,PVAR,
14535     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
14536     1            MINNVA,MAXNVA,
14537     1            IFLAGM,IFLAGP,
14538     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
14539      IF(IERROR.EQ.'YES')GOTO9000
14540C
14541      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN
14542        WRITE(ICOUT,999)
14543        CALL DPWRST('XXX','BUG ')
14544        WRITE(ICOUT,1001)
14545 1001   FORMAT('***** AFTER CALL DPPARS--')
14546        CALL DPWRST('XXX','BUG ')
14547        WRITE(ICOUT,1002)NQ,NUMVAR
14548 1002   FORMAT('NQ,NUMVAR = ',2I8)
14549        CALL DPWRST('XXX','BUG ')
14550        IF(NUMVAR.GT.0)THEN
14551          DO1005I=1,NUMVAR
14552            WRITE(ICOUT,1007)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
14553     1                      ICOLR(I)
14554 1007       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
14555     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
14556            CALL DPWRST('XXX','BUG ')
14557 1005     CONTINUE
14558        ENDIF
14559      ENDIF
14560C
14561C               *********************************
14562C               **  STEP 3--                   **
14563C               **  CREATE THE VARIABLES       **
14564C               *********************************
14565C
14566      IF(ICASEB.EQ.'STAT')THEN
14567        NRESP=ISTANR
14568        NGRPV=NUMVAR-NRESP
14569      ELSE
14570        NRESP=1
14571        NCEN=0
14572        NLEVEL=0
14573        IF(ICENSO.EQ.'ON')NCEN=1
14574        IF(ICASPL.EQ.'BFWE')THEN
14575          IF(IBFWTY.EQ.'ON' .AND. NUMVAR.GT.1 .AND.
14576     1       IFLAGM.EQ.0)THEN
14577             NLEVEL=1
14578             ILEVEL='ON'
14579          ENDIF
14580          NGRPV=NUMVAR-NRESP-NCEN-NLEVEL
14581        ELSE
14582          NGRPV=NUMVAR-NRESP-NCEN
14583        ENDIF
14584C
14585        IF(NGRPV.LT.0 .OR. NGRPV.GT.2)THEN
14586          WRITE(ICOUT,999)
14587          CALL DPWRST('XXX','BUG ')
14588          WRITE(ICOUT,2510)
14589          CALL DPWRST('XXX','BUG ')
14590          WRITE(ICOUT,521)
14591  521     FORMAT('      THE NUMBER OF CLASS VARIABLES IS LESS THAN ',
14592     1           'ZERO OR GREATER THAN TWO.')
14593          CALL DPWRST('XXX','BUG ')
14594          WRITE(ICOUT,523)NGROUP
14595  523     FORMAT('      THE NUMBER OF CLASS VARIABLES = ',I5)
14596          CALL DPWRST('XXX','BUG ')
14597          IERROR='YES'
14598          GOTO9000
14599        ENDIF
14600      ENDIF
14601C
14602      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN
14603        WRITE(ICOUT,999)
14604        CALL DPWRST('XXX','BUG ')
14605        WRITE(ICOUT,1101)NRESP,NGRPV,ICASPL,IBOOGR
14606 1101   FORMAT('NRESP,NGRPV,ICASPL,IBOOGR = ',2I8,2(2X,A4))
14607        CALL DPWRST('XXX','BUG ')
14608      ENDIF
14609C
14610      IFLAGI='DEPE'
14611      IF(NRESP.GE.2 .AND. NGRPV.EQ.0)THEN
14612        IF(ISTADF.EQ.'ON'   .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14613        IF(ICASPL.EQ.'DMEA' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14614        IF(ICASPL.EQ.'DMDM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14615        IF(ICASPL.EQ.'DMED' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14616        IF(ICASPL.EQ.'DTRM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14617        IF(ICASPL.EQ.'DWNM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14618        IF(ICASPL.EQ.'DGEO' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14619        IF(ICASPL.EQ.'DHAR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14620        IF(ICASPL.EQ.'DHDL' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14621        IF(ICASPL.EQ.'DBIW' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14622        IF(ICASPL.EQ.'DSD ' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14623        IF(ICASPL.EQ.'DRMS' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14624        IF(ICASPL.EQ.'DVAR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14625        IF(ICASPL.EQ.'DAAD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14626        IF(ICASPL.EQ.'DAAM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14627        IF(ICASPL.EQ.'DMAD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14628        IF(ICASPL.EQ.'DIQR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14629        IF(ICASPL.EQ.'DBIM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14630        IF(ICASPL.EQ.'DBIS' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14631        IF(ICASPL.EQ.'DPBN' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14632        IF(ICASPL.EQ.'DGSD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14633        IF(ICASPL.EQ.'DRAN' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14634        IF(ICASPL.EQ.'DMDR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14635        IF(ICASPL.EQ.'DQSE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14636        IF(ICASPL.EQ.'DQUA' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14637        IF(ICASPL.EQ.'DSKE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14638        IF(ICASPL.EQ.'DGSK' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14639        IF(ICASPL.EQ.'DPSK' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14640        IF(ICASPL.EQ.'DKUR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14641        IF(ICASPL.EQ.'DEKU' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14642        IF(ICASPL.EQ.'DRSD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14643        IF(ICASPL.EQ.'DSDM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14644        IF(ICASPL.EQ.'DRVA' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14645        IF(ICASPL.EQ.'DVAM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14646        IF(ICASPL.EQ.'DMIN' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14647        IF(ICASPL.EQ.'DMAX' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14648        IF(ICASPL.EQ.'DEXT' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14649        IF(ICASPL.EQ.'DCVA' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14650        IF(ICASPL.EQ.'DCOU' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14651        IF(ICASPL.EQ.'DSUM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14652        IF(ICASPL.EQ.'DPRO' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14653        IF(ICASPL.EQ.'10LD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14654        IF(ICASPL.EQ.'12LD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14655        IF(ICASPL.EQ.'15LD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14656        IF(ICASPL.EQ.'17LD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14657        IF(ICASPL.EQ.'20LD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14658        IF(ICASPL.EQ.'10SD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14659        IF(ICASPL.EQ.'12SD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14660        IF(ICASPL.EQ.'15SD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14661        IF(ICASPL.EQ.'17SD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14662        IF(ICASPL.EQ.'20SD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14663        IF(ICASPL.EQ.'DSN ' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14664        IF(ICASPL.EQ.'DQN ' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14665        IF(ICASPL.EQ.'DLPL' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14666        IF(ICASPL.EQ.'DLPV' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14667        IF(ICASPL.EQ.'DLPS' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14668        IF(ICASPL.EQ.'DBOR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14669        IF(ICASPL.EQ.'DTSD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14670        IF(ICASPL.EQ.'DPER' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14671        IF(ICASPL.EQ.'D1DE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14672        IF(ICASPL.EQ.'D2DE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14673        IF(ICASPL.EQ.'D3DE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14674        IF(ICASPL.EQ.'D4DE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14675        IF(ICASPL.EQ.'D5DE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14676        IF(ICASPL.EQ.'D6DE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14677        IF(ICASPL.EQ.'D7DE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14678        IF(ICASPL.EQ.'D8DE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14679        IF(ICASPL.EQ.'D9DE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14680        IF(ICASPL.EQ.'DLHI' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14681        IF(ICASPL.EQ.'DUHI' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14682        IF(ICASPL.EQ.'DLQU' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14683        IF(ICASPL.EQ.'DUQU' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14684        IF(ICASPL.EQ.'DSSQ' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14685        IF(ICASPL.EQ.'DRSC' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14686        IF(ICASPL.EQ.'DQQR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14687        IF(ICASPL.EQ.'ORSE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14688        IF(ICASPL.EQ.'ODRA' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14689        IF(ICASPL.EQ.'RATI' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14690        IF(ICASPL.EQ.'LOSE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14691        IF(ICASPL.EQ.'LODR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14692        IF(ICASPL.EQ.'KS2S' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14693        IF(ICASPL.EQ.'KSCV' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14694        IF(ICASPL.EQ.'CS2S' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14695        IF(ICASPL.EQ.'CC2S' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14696        IF(ICASPL.EQ.'CP2S' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14697        IF(ICASPL.EQ.'FTES' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14698        IF(ICASPL.EQ.'FTPV' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14699        IF(ICASPL.EQ.'FTCD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14700        IF(ICASPL.EQ.'2TTE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14701        IF(ICASPL.EQ.'2TCD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14702        IF(ICASPL.EQ.'2T2P' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14703        IF(ICASPL.EQ.'2TLP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14704        IF(ICASPL.EQ.'2TUP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14705        IF(ICASPL.EQ.'MWTE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14706        IF(ICASPL.EQ.'MWUS' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14707        IF(ICASPL.EQ.'MWCD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14708        IF(ICASPL.EQ.'MW2P' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14709        IF(ICASPL.EQ.'MWLP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14710        IF(ICASPL.EQ.'MWUP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14711        IF(ICASPL.EQ.'KLTE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14712        IF(ICASPL.EQ.'KLCD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14713        IF(ICASPL.EQ.'KL2P' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14714        IF(ICASPL.EQ.'KLLP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14715        IF(ICASPL.EQ.'KLUP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14716        IF(ICASPL.EQ.'SRTE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14717        IF(ICASPL.EQ.'SRCD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14718        IF(ICASPL.EQ.'SR2P' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14719        IF(ICASPL.EQ.'SRLP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14720        IF(ICASPL.EQ.'SRUP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14721        IF(ICASPL.EQ.'METE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14722        IF(ICASPL.EQ.'MECD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14723        IF(ICASPL.EQ.'ME2P' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14724        IF(ICASPL.EQ.'2SFR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14725        IF(ICASPL.EQ.'2F2P' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14726        IF(ICASPL.EQ.'FMAT' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14727        IF(ICASPL.EQ.'LMAT' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14728        IF(ICASPL.EQ.'FNOM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14729        IF(ICASPL.EQ.'LNOM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14730        IF(ICASPL.EQ.'WOSM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14731        IF(ICASPL.EQ.'PDIF' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14732        IF(ICASPL.EQ.'2CTE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14733        IF(ICASPL.EQ.'2CCD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14734        IF(ICASPL.EQ.'2C2P' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14735        IF(ICASPL.EQ.'2CLP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14736        IF(ICASPL.EQ.'2CUP' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14737        IF(ICASPL.EQ.'DCDI' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14738        IF(ICASPL.EQ.'DIDI' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14739        IF(ICASPL.EQ.'DQDI' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14740        IF(ICASPL.EQ.'DAMD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14741        IF(ICASPL.EQ.'DPRE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14742        IF(ICASPL.EQ.'DSNR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14743        IF(ICASPL.EQ.'DSHM' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14744        IF(ICASPL.EQ.'DSHR' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14745        IF(ICASPL.EQ.'HEDG' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14746        IF(ICASPL.EQ.'BCHG' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14747        IF(ICASPL.EQ.'COHD' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14748        IF(ICASPL.EQ.'GLAS' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14749        IF(ICASPL.EQ.'DBLC' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14750        IF(ICASPL.EQ.'DBUC' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14751        IF(ICASPL.EQ.'HESE' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14752        IF(ICASPL.EQ.'HELC' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14753        IF(ICASPL.EQ.'HEUC' .AND. IBOOGR.EQ.'INDE')IFLAGI='INDE'
14754        IF(IFLAGI.EQ.'INDE')IFLAGD='INDE'
14755      ENDIF
14756C
14757C     NOTE 2011/10: IDENTIFY "SUMMARY" STATISTICS THAT ARE BASED
14758C                   ON MEAN, SD, AND SAMPLE SIZE VALUES.
14759C
14760      IF(ICASPL.EQ.'DHHD' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14761      IF(ICASPL.EQ.'DSSE' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14762      IF(ICASPL.EQ.'DSMM' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14763      IF(ICASPL.EQ.'DSLA' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14764      IF(ICASPL.EQ.'MPSE' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14765      IF(ICASPL.EQ.'MPSE' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14766      IF(ICASPL.EQ.'MPAU' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14767      IF(ICASPL.EQ.'MMPS' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14768      IF(ICASPL.EQ.'MMPA' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14769      IF(ICASPL.EQ.'VRSE' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14770      IF(ICASPL.EQ.'VARU' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14771      IF(ICASPL.EQ.'GCIS' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14772      IF(ICASPL.EQ.'GCIN' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14773      IF(ICASPL.EQ.'BOBS' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14774      IF(ICASPL.EQ.'BOB ' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14775      IF(ICASPL.EQ.'BCPS' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14776      IF(ICASPL.EQ.'BCP ' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14777      IF(ICASPL.EQ.'MMES' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14778      IF(ICASPL.EQ.'MMEA' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14779      IF(ICASPL.EQ.'SESE' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14780      IF(ICASPL.EQ.'SCEB' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14781      IF(ICASPL.EQ.'GDSE' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14782      IF(ICASPL.EQ.'GNSE' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14783      IF(ICASPL.EQ.'GDS1' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14784      IF(ICASPL.EQ.'GDS2' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14785      IF(ICASPL.EQ.'GDEA' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14786      IF(ICASPL.EQ.'FWSE' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14787      IF(ICASPL.EQ.'FAIR' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14788      IF(ICASPL.EQ.'1LNT' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14789      IF(ICASPL.EQ.'1UNT' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14790      IF(ICASPL.EQ.'1KNT' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14791      IF(ICASPL.EQ.'2LNT' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14792      IF(ICASPL.EQ.'2UNT' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14793      IF(ICASPL.EQ.'2KNT' .AND. NUMVAR.EQ.3)IFLAGI='SUMM'
14794C
14795      IF(NRESP.GT.NUMVAR)THEN
14796        WRITE(ICOUT,999)
14797        CALL DPWRST('XXX','BUG ')
14798        WRITE(ICOUT,2510)
14799 2510   FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--')
14800        CALL DPWRST('XXX','BUG ')
14801        WRITE(ICOUT,2511)NRESP
14802 2511   FORMAT('      THE NUMBER OF RESPONSE VARIABLES EXPECTED: ',I5)
14803        CALL DPWRST('XXX','BUG ')
14804        WRITE(ICOUT,2513)NUMVAR
14805 2513   FORMAT('      THE NUMBER OF RESPONSE VARIABLES GIVEN:    ',I5)
14806        CALL DPWRST('XXX','BUG ')
14807        IERROR='YES'
14808        GOTO9000
14809      ELSEIF(NGRPV.LT.0 .OR. NGRPV.GT.2)THEN
14810        WRITE(ICOUT,999)
14811        CALL DPWRST('XXX','BUG ')
14812        WRITE(ICOUT,2510)
14813        CALL DPWRST('XXX','BUG ')
14814        WRITE(ICOUT,2521)
14815 2521   FORMAT('      THE NUMBER OF GROUP VARIABLES IS LESS THAN ',
14816     1         'ZERO OR GREATER THAN TWO.')
14817        CALL DPWRST('XXX','BUG ')
14818        WRITE(ICOUT,2523)NGRPV
14819 2523   FORMAT('      THE NUMBER OF GROUP VARIABLES GIVEN: ',I5)
14820        CALL DPWRST('XXX','BUG ')
14821        IERROR='YES'
14822        GOTO9000
14823      ENDIF
14824C
14825      NMAX=NRIGHT(1)
14826      IF(IFLAGI.EQ.'DEPE')THEN
14827        DO2530I=1,NUMVAR
14828          IF(NRIGHT(I).NE.NMAX)THEN
14829            WRITE(ICOUT,999)
14830            CALL DPWRST('XXX','BUG ')
14831            WRITE(ICOUT,2510)
14832            CALL DPWRST('XXX','BUG ')
14833            WRITE(ICOUT,2531)IVARN1(I),IVARN2(I),NRIGHT(I)
14834 2531       FORMAT('      VARIABLE ',A4,A4,' HAS ',I8,' OBSERVATIONS.')
14835            CALL DPWRST('XXX','BUG ')
14836            WRITE(ICOUT,2533)NRIGHT(1)
14837 2533       FORMAT('      THE EXPECTED NUMBER OF OBSERVATIONS: ',I8)
14838            CALL DPWRST('XXX','BUG ')
14839            IERROR='YES'
14840            GOTO9000
14841          ENDIF
14842 2530   CONTINUE
14843      ELSE
14844        NMAX=MAX(NRIGHT(1),NRIGHT(2))
14845      ENDIF
14846C
14847      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN
14848        ISTEPN='26'
14849        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14850        WRITE(ICOUT,1111)NMAX,IFLAGI
14851 1111   FORMAT('NMAX,IFLAGI = ',I8,2X,A4)
14852        CALL DPWRST('XXX','BUG ')
14853      ENDIF
14854C
14855      J=0
14856      J2=0
14857      J3=0
14858      IMAX=NMAX
14859      IF(NQ.LT.NMAX)IMAX=NQ
14860      ICNT=1
14861      IF(NRESP.EQ.2 .OR. ICENSO.EQ.'ON')ICNT=2
14862C
14863      DO2660I=1,IMAX
14864C
14865C       FIRST RESPONSE VARIABLE
14866C
14867        IF(ISUB(I).EQ.1 .AND. I.LE.NRIGHT(1))THEN
14868          J=J+1
14869          IJ=MAXN*(ICOLR(1)-1)+I
14870          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
14871          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
14872          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
14873          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
14874          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
14875          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
14876          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
14877        ENDIF
14878        ICOLC=1
14879C
14880C       SECOND RESPONSE VARIABLE
14881C
14882        IF(NRESP.GE.2 .AND. ISUB(I).EQ.1 .AND. I.LE.NRIGHT(2))THEN
14883          ICOLC=ICOLC+1
14884          J2=J2+1
14885          IJ=MAXN*(ICOLR(ICOLC)-1)+I
14886          IF(ICOLR(ICOLC).LE.MAXCOL)Z1(J2)=V(IJ)
14887          IF(ICOLR(ICOLC).EQ.MAXCP1)Z1(J2)=PRED(I)
14888          IF(ICOLR(ICOLC).EQ.MAXCP2)Z1(J2)=RES(I)
14889          IF(ICOLR(ICOLC).EQ.MAXCP3)Z1(J2)=YPLOT(I)
14890          IF(ICOLR(ICOLC).EQ.MAXCP4)Z1(J2)=XPLOT(I)
14891          IF(ICOLR(ICOLC).EQ.MAXCP5)Z1(J2)=X2PLOT(I)
14892          IF(ICOLR(ICOLC).EQ.MAXCP6)Z1(J2)=TAGPLO(I)
14893        ENDIF
14894C
14895C       THIRD RESPONSE VARIABLE
14896C
14897        IF(NRESP.GE.3 .AND. ISUB(I).EQ.1 .AND. I.LE.NRIGHT(3))THEN
14898          ICOLC=ICOLC+1
14899          J3=J3+1
14900          IJ=MAXN*(ICOLR(ICOLC)-1)+I
14901          IF(ICOLR(ICOLC).LE.MAXCOL)X1(J3)=V(IJ)
14902          IF(ICOLR(ICOLC).EQ.MAXCP1)X1(J3)=PRED(I)
14903          IF(ICOLR(ICOLC).EQ.MAXCP2)X1(J3)=RES(I)
14904          IF(ICOLR(ICOLC).EQ.MAXCP3)X1(J3)=YPLOT(I)
14905          IF(ICOLR(ICOLC).EQ.MAXCP4)X1(J3)=XPLOT(I)
14906          IF(ICOLR(ICOLC).EQ.MAXCP5)X1(J3)=X2PLOT(I)
14907          IF(ICOLR(ICOLC).EQ.MAXCP6)X1(J3)=TAGPLO(I)
14908        ENDIF
14909C
14910C       LENGTH VARIABLE
14911C
14912        IF(ILEVEL.EQ.'ON' .AND. ISUB(I).EQ.1)THEN
14913          ICOLC=ICOLC+1
14914          IJ=MAXN*(NRIGHT(ICOLC)-1)+I
14915          IF(NRIGHT(ICOLC).LE.MAXCOL)X1(J)=V(IJ)
14916          IF(NRIGHT(ICOLC).EQ.MAXCP1)X1(J)=PRED(I)
14917          IF(NRIGHT(ICOLC).EQ.MAXCP2)X1(J)=RES(I)
14918          IF(NRIGHT(ICOLC).EQ.MAXCP3)X1(J)=YPLOT(I)
14919          IF(NRIGHT(ICOLC).EQ.MAXCP4)X1(J)=XPLOT(I)
14920          IF(NRIGHT(ICOLC).EQ.MAXCP5)X1(J)=X2PLOT(I)
14921          IF(NRIGHT(ICOLC).EQ.MAXCP6)X1(J)=TAGPLO(I)
14922        ENDIF
14923C
14924C
14925C       CENSORING VARIABLE
14926C
14927        IF(ICENSO.EQ.'ON' .AND. ISUB(I).EQ.1)THEN
14928          ICOLC=ICOLC+1
14929          IJ=MAXN*(NRIGHT(ICOLC)-1)+I
14930          IF(NRIGHT(ICOLC).LE.MAXCOL)X1(J)=V(IJ)
14931          IF(NRIGHT(ICOLC).EQ.MAXCP1)X1(J)=PRED(I)
14932          IF(NRIGHT(ICOLC).EQ.MAXCP2)X1(J)=RES(I)
14933          IF(NRIGHT(ICOLC).EQ.MAXCP3)X1(J)=YPLOT(I)
14934          IF(NRIGHT(ICOLC).EQ.MAXCP4)X1(J)=XPLOT(I)
14935          IF(NRIGHT(ICOLC).EQ.MAXCP5)X1(J)=X2PLOT(I)
14936          IF(NRIGHT(ICOLC).EQ.MAXCP6)X1(J)=TAGPLO(I)
14937        ENDIF
14938C
14939        IF(NGRPV.GE.1 .AND. ISUB(I).EQ.1)THEN
14940          DO2665K=1,NGRPV
14941            IJ=MAXN*(ICOLR(ICOLC+K)-1)+I
14942            IF(ICOLR(ICOLC+K).LE.MAXCOL)XDESGN(J,K)=V(IJ)
14943            IF(ICOLR(ICOLC+K).EQ.MAXCP1)XDESGN(J,K)=PRED(I)
14944            IF(ICOLR(ICOLC+K).EQ.MAXCP2)XDESGN(J,K)=RES(I)
14945            IF(ICOLR(ICOLC+K).EQ.MAXCP3)XDESGN(J,K)=YPLOT(I)
14946            IF(ICOLR(ICOLC+K).EQ.MAXCP4)XDESGN(J,K)=XPLOT(I)
14947            IF(ICOLR(ICOLC+K).EQ.MAXCP5)XDESGN(J,K)=X2PLOT(I)
14948            IF(ICOLR(ICOLC+K).EQ.MAXCP6)XDESGN(J,K)=TAGPLO(I)
14949 2665     CONTINUE
14950        ENDIF
14951C
14952 2660 CONTINUE
14953C
14954      NLOCAL=J
14955      NLOCA2=J2
14956C
14957C               *******************************************************
14958C               **  STEP 28--                                        **
14959C               **  COMPUTE THE APPROPRIATE STATISTIC PLOT STATISTIC--*
14960C               **  (MEAN, STANDARD DEVIATION, RANGE, OR CUSUM).     **
14961C               **  COMPUTE CONFIDENCE LINES.                        **
14962C               **  FORM THE VERTICAL AND HORIZONTAL AXIS            **
14963C               **  VALUES Y(.) AND X(.) FOR THE PLOT.               **
14964C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S      **
14965C               **  FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE,**
14966C               **  AND THE UPPER CONFIDENCE LINE.                   **
14967C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).    **
14968C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).    **
14969C               *******************************************************
14970C
14971      ISTEPN='28'
14972      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')
14973     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
14974C
14975      IHP='ALPH'
14976      IHP2='A   '
14977      IHWUSE='P'
14978      MESSAG='NO'
14979      CALL CHECKN(IHP,IHP2,IHWUSE,
14980     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14981     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
14982      IF(IERROR.EQ.'YES')THEN
14983        ALPHA=0.05
14984      ELSE
14985        ALPHA=VALUE(ILOCP)
14986      ENDIF
14987      IF(ALPHA.LT.0.0 .OR. ALPHA.GT.1.0)ALPHA=0.05
14988      IF(ALPHA.GT.0.5)ALPHA=1.0-ALPHA
14989C
14990      IHP='LOWL'
14991      IHP2='IMIT'
14992      IHWUSE='P'
14993      MESSAG='NO'
14994      CALL CHECKN(IHP,IHP2,IHWUSE,
14995     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
14996     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
14997      IF(IERROR.EQ.'YES')THEN
14998        ALOWLM=CPUMIN
14999      ELSE
15000        ALOWLM=VALUE(ILOCP)
15001      ENDIF
15002C
15003      IHP='UPPL'
15004      IHP2='IMIT'
15005      IHWUSE='P'
15006      MESSAG='NO'
15007      CALL CHECKN(IHP,IHP2,IHWUSE,
15008     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
15009     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
15010      IF(IERROR.EQ.'YES')THEN
15011        AUPPLM=CPUMIN
15012      ELSE
15013        AUPPLM=VALUE(ILOCP)
15014      ENDIF
15015C
15016      IHP='ALPH'
15017      IHP2='ASV '
15018      IHWUSE='P'
15019      MESSAG='NO'
15020      CALL CHECKN(IHP,IHP2,IHWUSE,
15021     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
15022     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
15023      IF(IERROR.EQ.'YES')THEN
15024        ALPHSV=CPUMIN
15025      ELSE
15026        ALPHSV=VALUE(ILOCP)
15027      ENDIF
15028C
15029      NPERC=0
15030      IF(IQUAVR.EQ.'NONE')THEN
15031        NPERC=0
15032      ELSEIF(IQUAVR.EQ.'DEFAULT')THEN
15033        QP(1)=0.5/100.0
15034        QP(2)=1.0/100.0
15035        QP(3)=2.5/100.
15036        QP(4)=5.0/100.0
15037        QP(5)=10.0/100.0
15038        QP(6)=20.0/100.0
15039        QP(7)=30.0/100.0
15040        QP(8)=40.0/100.0
15041        QP(9)=50.0/100.0
15042        QP(10)=60.0/100.0
15043        QP(11)=70.0/100.0
15044        QP(12)=80.0/100.0
15045        QP(13)=90.0/100.0
15046        QP(14)=95.0/100.0
15047        QP(15)=97.5/100.0
15048        QP(16)=99.0/100.0
15049        QP(17)=99.5/100.0
15050        NPERC=17
15051      ELSE
15052        IH41=IQUAVR(1:4)
15053        IH42=IQUAVR(5:8)
15054        IHWUSE='V'
15055        MESSAG='NO'
15056        CALL CHECKN(IH41,IH42,IHWUSE,
15057     1       IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
15058     1       ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
15059C
15060        IF(IERROR.EQ.'YES')THEN
15061          NPERC=0
15062        ELSE
15063          ICOLQP=IVALUE(ILOCV)
15064          NPERC=IN(ILOCV)
15065          ICNT=0
15066          DO4180I=1,NPERC
15067            IJ=MAXN*(ICOLQP-1)+I
15068            ICNT=ICNT+1
15069            IF(ICOLQP.LE.MAXCOL)QP(ICNT)=V(IJ)
15070            IF(ICOLQP.EQ.MAXCP1)QP(ICNT)=PRED(I)
15071            IF(ICOLQP.EQ.MAXCP2)QP(ICNT)=RES(I)
15072            IF(ICOLQP.EQ.MAXCP3)QP(ICNT)=YPLOT(I)
15073            IF(ICOLQP.EQ.MAXCP4)QP(ICNT)=XPLOT(I)
15074            IF(ICOLQP.EQ.MAXCP5)QP(ICNT)=X2PLOT(I)
15075            IF(ICOLQP.EQ.MAXCP6)QP(ICNT)=TAGPLO(I)
15076            IF(QP(ICNT).LE.0.0 .OR. QP(ICNT).GE.100.0)THEN
15077              ICNT=ICNT-1
15078            ENDIF
15079 4180     CONTINUE
15080          NPERC=ICNT
15081          IWRITE='OFF'
15082          CALL MAXIM(QP,NPERC,IWRITE,QPMAX,IBUGG3,IERROR)
15083          IF(QPMAX.GT.1.0 .AND. QPMAX.LE.100.0)THEN
15084            DO4183II=1,NPERC
15085              QP(II)=QP(II)/100.0
15086 4183       CONTINUE
15087          ENDIF
15088C
15089        ENDIF
15090      ENDIF
15091C
15092      ISTEPN='41'
15093      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')
15094     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15095C
15096      IF(ICASEB.EQ.'STAT')THEN
15097C
15098        CALL DPJBS6(Y1,Z1,X1,XDESGN,NLOCAL,NLOCA2,
15099     1              NRESP,NGRPV,ICASPL,
15100     1              ISIZE,ICONT,
15101     1              ICASJB,IBOOSS,ISEED,IBCABT,ALPHA,IFLAGI,IFLAGD,
15102     1              TEMP,TEMP2,TEMPL,TEMP3,XTEMP1,XTEMP2,XTEMP3,
15103     1              MAXNXT,MAXBGR,
15104     1              ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
15105     1              Y,X,D,NPLOTP,NPLOTV,
15106     1              TEMP0,TEMPZ0,TEMPZL,RES1,RES2,TEMP4,TEMPTH,TEMP6,
15107     1              DTEMP1,DTEMP2,DTEMP3,
15108     1              APERC,BPERC,NPERC2,
15109     1              BMEAN,BSD,B001,B005,B01,B025,B05,B10,B20,B50,
15110     1              B80,B90,B95,B975,B99,B995,B999,
15111     1              ICAPSW,ICAPTY,IFORSW,IVARN1,IVARN2,ISTANM,
15112     1              ISUBRO,IBUGG3,IERROR)
15113      ELSE
15114        CALL DPJBS7(Y1,X1,XLEVEL,XDESGN,NLOCAL,NRESP,NGRPV,
15115     1              ICASPL,ICASP2,IDIST,
15116     1              ICENSO,ISIZE,ICONT,NPERC,KSLOC,KSSCAL,
15117     1              IMETHD,ILEVEL,
15118     1              ICASJB,IBOOSS,ISEED,IBCABT,ALPHA,
15119     1              TEMP,TEMP2,TEMP0,TEMPZ0,TEMPL,TEMPZL,
15120     1              QP,XQP,XQPLCL,XQPUCL,
15121     1              TEMP3,XTEMP1,XTEMP2,XTEMP3,TEMP4,
15122     1              ZTEMP1,ZTEMP2,ZTEMP3,TEMP5,TEMPT2,TEMP7,
15123     1              TEMP8,WEIGHH,RES1,RES2,TEMP6,TEMPTH,
15124     1              MAXNXT,MAXBGR,
15125     1              ITEMP1,DTEMP1,DTEMP2,DTEMP3,
15126     1              YLOWLM,YUPPLM,A,B,MINMAX,
15127     1              SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
15128     1              SHAPE6,SHAPE7,NUMSHA,
15129     1              SHAP11,SHAP12,SHAP21,SHAP22,
15130     1              Y,X,D,NPLOTP,NPLOTV,
15131     1              APERC,BPERC,NPERC2,
15132     1              BMEAN,BSD,B001,B005,B01,B025,B05,B10,B20,B50,
15133     1              B80,B90,B95,B975,B99,B995,B999,
15134     1              ICAPSW,ICAPTY,IFORSW,IVARN1,IVARN2,
15135     1              CLLIMI,CLWIDT,IRELAT,
15136     1              IFLAGL,AL,
15137     1              ISUBRO,IBUGG3,IERROR)
15138      ENDIF
15139C
15140C  AUTOMATICALLY SAVE CERTAIN PERCENTILE PARAMETERS.  MARCH 1998
15141C  JANUARY 2005: ONLY SAVE IF 1 PARAMETER IS ESTIMARED (E.G.,
15142C                DISTRIBUTIONAL FITTING HAS 2 TO 4 PARAMETERS)
15143C
15144C
15145C               ***************************************
15146C               **  STEP 51--                        **
15147C               **  UPDATE INTERNAL DATAPLOT TABLES  **
15148C               ***************************************
15149C
15150      CUTOFF=REAL(I1MACH(9))
15151C
15152      ISTEPN='51'
15153      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')
15154     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15155C
15156CCCCC IF(NUMPAR.GT.1)GOTO5199
15157      IF(ICASEB.NE.'STAT')GOTO5199
15158      DO5100IPASS=1,17
15159        IH=ISTATN(IPASS)
15160        IH2=ISTAT2(IPASS)
15161        DO5150I=1,NUMNAM
15162          I2=I
15163          IF(IH.EQ.IHNAME(I).AND.IH2.EQ.IHNAM2(I).AND.
15164     1       IUSE(I).EQ.'P')GOTO5180
15165 5150   CONTINUE
15166        IF(NUMNAM.GE.MAXNAM)THEN
15167          WRITE(ICOUT,5151)
15168 5151     FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--')
15169          CALL DPWRST('XXX','BUG ')
15170          WRITE(ICOUT,5152)
15171 5152     FORMAT('      THE TOTAL NUMBER OF (VARIABLE + PARAMETER)')
15172          CALL DPWRST('XXX','BUG ')
15173          WRITE(ICOUT,5153)MAXNAM
15174 5153     FORMAT('      NAMES MUST BE AT MOST ',I8,'.  SUCH WAS NOT')
15175          CALL DPWRST('XXX','BUG ')
15176          WRITE(ICOUT,5155)
15177 5155     FORMAT('      THE CASE HERE--THE MAXIMUM ALLOWABLE NUMBER OF')
15178          CALL DPWRST('XXX','BUG ')
15179          WRITE(ICOUT,5156)
15180 5156     FORMAT('      NAMES HAS JUST BEEN EXCEEDED.')
15181          CALL DPWRST('XXX','BUG ')
15182          WRITE(ICOUT,5157)
15183 5157     FORMAT('      SUGGESTED ACTION--ENTER     STATUS     TO')
15184          CALL DPWRST('XXX','BUG ')
15185          WRITE(ICOUT,5158)
15186 5158     FORMAT('      DETERMINE THE IMPORTANT (VERSUS UNIMPORTANT)')
15187          CALL DPWRST('XXX','BUG ')
15188          WRITE(ICOUT,5160)
15189 5160     FORMAT('      VARIABLES AND PARAMETERS, AND THEN REUSE SOME')
15190          CALL DPWRST('XXX','BUG ')
15191          WRITE(ICOUT,5161)
15192 5161     FORMAT('      OF THE NAMES.')
15193          CALL DPWRST('XXX','BUG ')
15194          WRITE(ICOUT,5162)
15195 5162     FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
15196          CALL DPWRST('XXX','BUG ')
15197          IF(IWIDTH.GE.1)THEN
15198            WRITE(ICOUT,5163)(IANS(II),II=1,MIN(80,IWIDTH))
15199 5163       FORMAT('      ',80A1)
15200            CALL DPWRST('XXX','BUG ')
15201          ENDIF
15202          IERROR='YES'
15203          GOTO9000
15204        ENDIF
15205C
15206        NUMNAM=NUMNAM+1
15207        ILOC=NUMNAM
15208        IHNAME(ILOC)=IH
15209        IHNAM2(ILOC)=IH2
15210        IUSE(ILOC)='P'
15211        IF(IPASS.EQ.1)VALUE(ILOC)=BSD
15212        IF(IPASS.EQ.2)VALUE(ILOC)=BMEAN
15213        IF(IPASS.EQ.3)VALUE(ILOC)=B975
15214        IF(IPASS.EQ.4)VALUE(ILOC)=B025
15215        IF(IPASS.EQ.5)VALUE(ILOC)=B001
15216        IF(IPASS.EQ.6)VALUE(ILOC)=B005
15217        IF(IPASS.EQ.7)VALUE(ILOC)=B01
15218        IF(IPASS.EQ.8)VALUE(ILOC)=B05
15219        IF(IPASS.EQ.9)VALUE(ILOC)=B10
15220        IF(IPASS.EQ.10)VALUE(ILOC)=B20
15221        IF(IPASS.EQ.11)VALUE(ILOC)=B50
15222        IF(IPASS.EQ.12)VALUE(ILOC)=B80
15223        IF(IPASS.EQ.13)VALUE(ILOC)=B90
15224        IF(IPASS.EQ.14)VALUE(ILOC)=B95
15225        IF(IPASS.EQ.15)VALUE(ILOC)=B99
15226        IF(IPASS.EQ.16)VALUE(ILOC)=B995
15227        IF(IPASS.EQ.17)VALUE(ILOC)=B999
15228        VAL=VALUE(ILOC)
15229        IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=INT(VAL+0.5)
15230        IF(VAL.GT.CUTOFF)IVAL=INT(CUTOFF)
15231        IF(VAL.LT.(-CUTOFF))IVAL=INT(-CUTOFF)
15232        IVALUE(ILOC)=IVAL
15233        GOTO5100
15234C
15235 5180   CONTINUE
15236        IF(IPASS.EQ.1)VALUE(I2)=BSD
15237        IF(IPASS.EQ.2)VALUE(I2)=BMEAN
15238        IF(IPASS.EQ.3)VALUE(I2)=B975
15239        IF(IPASS.EQ.4)VALUE(I2)=B025
15240        IF(IPASS.EQ.5)VALUE(I2)=B001
15241        IF(IPASS.EQ.6)VALUE(I2)=B005
15242        IF(IPASS.EQ.7)VALUE(I2)=B01
15243        IF(IPASS.EQ.8)VALUE(I2)=B05
15244        IF(IPASS.EQ.9)VALUE(I2)=B10
15245        IF(IPASS.EQ.10)VALUE(I2)=B20
15246        IF(IPASS.EQ.11)VALUE(I2)=B50
15247        IF(IPASS.EQ.12)VALUE(I2)=B80
15248        IF(IPASS.EQ.13)VALUE(I2)=B90
15249        IF(IPASS.EQ.14)VALUE(I2)=B95
15250        IF(IPASS.EQ.15)VALUE(I2)=B99
15251        IF(IPASS.EQ.16)VALUE(I2)=B995
15252        IF(IPASS.EQ.17)VALUE(I2)=B999
15253        VAL=VALUE(I2)
15254        IF((-CUTOFF).LE.VAL.AND.VAL.LE.CUTOFF)IVAL=INT(VAL+0.5)
15255        IF(VAL.GT.CUTOFF)IVAL=INT(CUTOFF)
15256        IF(VAL.LT.(-CUTOFF))IVAL=INT(-CUTOFF)
15257        IVALUE(I2)=IVAL
15258        GOTO5100
15259C
15260 5100 CONTINUE
15261 5199 CONTINUE
15262C
15263C
15264C               *****************
15265C               **  STEP 90--  **
15266C               **  EXIT       **
15267C               *****************
15268C
15269 9000 CONTINUE
15270      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'JBSP')THEN
15271        WRITE(ICOUT,999)
15272        CALL DPWRST('XXX','BUG ')
15273        WRITE(ICOUT,9011)
15274 9011   FORMAT('***** AT THE END       OF DPJBSP--')
15275        CALL DPWRST('XXX','BUG ')
15276        WRITE(ICOUT,9012)ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ
15277 9012   FORMAT('ICONT,ISUBRO,IBUGG2,IBUGG3,IBUGQ  = ',
15278     1         A4,2X,A4,2X,A4,2X,A4,2X,A4)
15279        CALL DPWRST('XXX','BUG ')
15280        WRITE(ICOUT,9013)IFOUND,IERROR,IBOOSS,ICASJB
15281 9013   FORMAT('IFOUND,IERROR,IBOOSS,ICASJB = ',A4,2X,A4,2X,A4,2X,A4)
15282        CALL DPWRST('XXX','BUG ')
15283        WRITE(ICOUT,9014)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
15284 9014   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
15285     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
15286        CALL DPWRST('XXX','BUG ')
15287        WRITE(ICOUT,9015)ISIZE,NUMVAR,NRESP,NGRPV
15288 9015   FORMAT('ISIZE,NUMVAR,NRESP,NGRPV = ',4I8)
15289        CALL DPWRST('XXX','BUG ')
15290        IF(NPLOTP.LE.0)THEN
15291          DO9025I=1,NPLOTP
15292            WRITE(ICOUT,9026)I,Y(I),X(I),D(I)
15293 9026       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
15294            CALL DPWRST('XXX','BUG ')
15295 9025     CONTINUE
15296        ENDIF
15297      ENDIF
15298C
15299      RETURN
15300      END
15301      SUBROUTINE DPJBS3(TEMP1,N1,ICASJB,IJACIN,ISEED,TEMP2,N2,
15302     1                  INDX,AINDEX,
15303     1                  IBUGG3,IERROR)
15304C
15305C     PURPOSE--GENERATE 1 JACKNIFE  SUBSAMPLE OF SIZE N1-1
15306C              OR       1 BOOTSTRAP SUBSAMPLE OF SIZE N1
15307C     WRITTEN BY--JAMES J. FILLIBEN
15308C                 STATISTICAL ENGINEERING DIVISION
15309C                 INFORMATION TECHNOLOGY LABORATORY
15310C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15311C                 GAITHERSBURG, MD 20899-8980
15312C                 PHONE--301-975-2855
15313C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15314C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15315C     LANGUAGE--ANSI FORTRAN (1977)
15316C     VERSION NUMBER--89/2
15317C     ORIGINAL VERSION--JANUARY   1989.
15318C     UPDATED         --JULY      2002. ADD AN INDEX VARIABLE.  USE
15319C                                       FOR CASES WHERE NEED TO
15320C                                       KEEP TWO OR MORE RESPONSE
15321C                                       VARIABLES DEPENDENT (E.G.,
15322C                                       CORRELATION KEEPS PAIRING
15323C                                       INTACT).
15324C     UPDATED         --AUGUST    2005. DUNRAN WAS FIXED TO GO FROM
15325C                                       0 TO N.  THIS ROUTINE WAS
15326C                                       MODIFIED TO CALL A VERSION
15327C                                       THAT GOES FROM 1 TO N.
15328C
15329C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15330C
15331      CHARACTER*4 ICASJB
15332      CHARACTER*4 IBUGG3
15333      CHARACTER*4 IERROR
15334C
15335C---------------------------------------------------------------------
15336C
15337CCCCC INCLUDE 'DPCOPA.INC'
15338C
15339      DIMENSION TEMP1(*)
15340      DIMENSION TEMP2(*)
15341      DIMENSION AINDEX(*)
15342      DIMENSION INDX(*)
15343C
15344C---------------------------------------------------------------------
15345C
15346      INCLUDE 'DPCOP2.INC'
15347C
15348C-----START POINT-----------------------------------------------------
15349C
15350      IERROR='NO'
15351C
15352      IF(IBUGG3.EQ.'ON')THEN
15353        WRITE(ICOUT,999)
15354  999   FORMAT(1X)
15355        CALL DPWRST('XXX','BUG ')
15356        WRITE(ICOUT,51)
15357   51   FORMAT('***** AT THE BEGINNING OF DPJBS3--')
15358        CALL DPWRST('XXX','BUG ')
15359        WRITE(ICOUT,52)N1,IJACIN,ICASJB,IBUGG3
15360   52   FORMAT('N1,IJACIN,ICASJB,IBUGG3 = ',2I8,2(2X,A4))
15361        CALL DPWRST('XXX','BUG ')
15362        WRITE(ICOUT,54)ISEED
15363   54   FORMAT('ISEED = ',I8)
15364        CALL DPWRST('XXX','BUG ')
15365        IF(N1.GT.0)THEN
15366          DO55I=1,N1
15367            WRITE(ICOUT,56)I,TEMP1(I)
15368   56       FORMAT('I,TEMP1(I) = ',I8,G15.7)
15369            CALL DPWRST('XXX','BUG ')
15370   55     CONTINUE
15371        ENDIF
15372      ENDIF
15373C
15374C               **************************************************
15375C               **  STEP 11--                                   **
15376C               **  CHECK THE INPUT NUMBER FOR ERRORS           **
15377C               **************************************************
15378C
15379      IF(N1.LT.1)THEN
15380        WRITE(ICOUT,999)
15381        CALL DPWRST('XXX','BUG ')
15382        WRITE(ICOUT,1111)
15383 1111   FORMAT('***** ERROR IN DPJBS3--')
15384        CALL DPWRST('XXX','BUG ')
15385        WRITE(ICOUT,1112)
15386 1112   FORMAT('      THE INPUT RAW DATA SAMPLE SIZE WAS NON-POSITIVE.')
15387        CALL DPWRST('XXX','BUG ')
15388        WRITE(ICOUT,1113)N1
15389 1113   FORMAT('      THE INPUT RAW DATA SAMPLE SIZE = ',I8)
15390        CALL DPWRST('XXX','BUG ')
15391        IERROR='YES'
15392        GOTO9000
15393      ENDIF
15394C
15395      IF(ICASJB.EQ.'JACK')THEN
15396        IF(IJACIN.LT.1)THEN
15397          WRITE(ICOUT,999)
15398          CALL DPWRST('XXX','BUG ')
15399          WRITE(ICOUT,1111)
15400          CALL DPWRST('XXX','BUG ')
15401          WRITE(ICOUT,1122)
15402 1122     FORMAT('      THE INPUT JACKNIFE INDEX WAS NON-POSITIVE.')
15403          CALL DPWRST('XXX','BUG ')
15404          WRITE(ICOUT,1123)N1
15405 1123     FORMAT('      THE INPUT JACKNIFE INDEX = ',I8)
15406          CALL DPWRST('XXX','BUG ')
15407          IERROR='YES'
15408          GOTO9000
15409        ENDIF
15410      ENDIF
15411C
15412C               **************************************************
15413C               **  STEP 12--                                   **
15414C               **  GENERATE THE JACKNIFE OR BOOTSTRAP SAMPLE   **
15415C               **************************************************
15416C
15417      IF(ICASJB.EQ.'JACK')THEN
15418        J=0
15419        DO1211I=1,N1
15420          IF(I.EQ.IJACIN)GOTO1211
15421          J=J+1
15422          TEMP2(J)=TEMP1(I)
15423          INDX(J)=I
15424 1211   CONTINUE
15425        N2=J
15426      ELSE
15427        CALL DUNRA2(N1,N1,ISEED,AINDEX)
15428        DO1221I=1,N1
15429          J=INT(AINDEX(I)+0.5)
15430          TEMP2(I)=TEMP1(J)
15431          INDX(I)=J
15432 1221   CONTINUE
15433        N2=N1
15434      ENDIF
15435C
15436C               *******************
15437C               **   STEP 90--   **
15438C               **   EXIT        **
15439C               *******************
15440C
15441 9000 CONTINUE
15442      IF(IBUGG3.EQ.'ON')THEN
15443        WRITE(ICOUT,999)
15444        CALL DPWRST('XXX','BUG ')
15445        WRITE(ICOUT,9011)
15446 9011   FORMAT('***** AT THE END       OF DPJBS3--')
15447        CALL DPWRST('XXX','BUG ')
15448        WRITE(ICOUT,9012)N1,N2,IJACIN,ISEED,ICASJB
15449 9012   FORMAT('N1,N2,IJACIN,ISEED,ICASJB = ',4I8,2X,A4)
15450        CALL DPWRST('XXX','BUG ')
15451        IF(N1.GT.0)THEN
15452          DO9021I=1,N1
15453            WRITE(ICOUT,9022)I,TEMP1(I),AINDEX(I),INDX(I)
15454 9022       FORMAT('I,TEMP1(I),AINDEX(I),INDX(I) = ',I8,2G15.7,I8)
15455            CALL DPWRST('XXX','BUG ')
15456 9021     CONTINUE
15457        ENDIF
15458        IF(N2.GT.0)THEN
15459          DO9031I=1,N2
15460            WRITE(ICOUT,9032)I,TEMP2(I)
15461 9032       FORMAT('I,TEMP2(I) = ',I8,G15.7)
15462            CALL DPWRST('XXX','BUG ')
15463 9031     CONTINUE
15464        ENDIF
15465      ENDIF
15466C
15467      RETURN
15468      END
15469      SUBROUTINE DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM,Y2,X2,D2)
15470C
15471C     PURPOSE--ADD A COMPUTED POINT TO THE OUTPUT PLOT VECTORS
15472C              FOR THE JACKNIFE AND BOOTSTRAP PLOTS.
15473C     CAUTION--THE INPUT ARGUMENT J CHANGES WITHIN
15474C              THIS ROUTINE AND IS ALSO AN OUTPUT ARGUMENT.
15475C     WRITTEN BY--JAMES J. FILLIBEN
15476C                 STATISTICAL ENGINEERING DIVISION
15477C                 INFORMATION TECHNOLOGY LABORATORY
15478C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15479C                 GAITHERSBURG, MD 20899-8980
15480C                 PHONE--301-975-2855
15481C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15482C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15483C     LANGUAGE--ANSI FORTRAN (1977)
15484C     VERSION NUMBER--89/2
15485C     ORIGINAL VERSION--JANUARY   1989.
15486C     UPDATED         --MARCH     2003. FOR REPLICATION CASE, SET
15487C                                       TAGPLOT (D2) TO REFLECT
15488C                                       REPLICATION NUMBER
15489C     UPDATED         --JANUARY   2005. SET D2 FOR CASE WHERE MORE
15490C                                       THAN ONE STATISTIC ESTIMATED
15491C                                       (E.G., DISTRIBUTIONAL FITS),
15492C                                       TAGID IDENTIFIES WHICH
15493C                                       STATISTIC
15494C
15495C---------------------------------------------------------------------
15496C
15497      DIMENSION XIDTEM(*)
15498      DIMENSION Y2(*)
15499      DIMENSION X2(*)
15500      DIMENSION D2(*)
15501C
15502C---------------------------------------------------------------------
15503C
15504      INCLUDE 'DPCOP2.INC'
15505C
15506C-----START POINT-----------------------------------------------------
15507C
15508      IF(NUMSET.LE.0)GOTO1100
15509      GOTO1200
15510C
15511C               **************************************************
15512C               **  STEP 11--                                   **
15513C               **  TREAT THE CASE WHEN HAVE NO (= FULL DATA) SUBSET  **
15514C               **************************************************
15515C
15516 1100 CONTINUE
15517CCCCC IF(ISET.LE.NUMSET)GOTO1110
15518CCCCC GOTO1120
15519C1110 CONTINUE
15520      J=J+1
15521      Y2(J)=RIGHT
15522      IF(TAGID.EQ.1.0)THEN
15523        J2=J2+1
15524      ENDIF
15525      X2(J)=J2
15526CCCCC D2(J)=1.0
15527      D2(J)=TAGID
15528      GOTO1190
15529C1120 CONTINUE
15530CCCCC GOTO9000
15531CCCCC J=J+1
15532CCCCC Y2(J)=RIGHT
15533CCCCC X2(J)=XIDTEM(1)
15534CCCCC D2(J)=2.0
15535CCCCC J=J+1
15536CCCCC Y2(J)=RIGHT
15537CCCCC X2(J)=XIDTEM(NUMSET)
15538CCCCC D2(J)=2.0
15539CCCCC GOTO1190
15540 1190 CONTINUE
15541      GOTO9000
15542C
15543C               **************************************************
15544C               **  STEP 12--                                   **
15545C               **  TREAT THE CASE WHEN HAVE 2 OR MORE SUBSETS  **
15546C               **************************************************
15547C
15548 1200 CONTINUE
15549      IF(ISET.LE.NUMSET)GOTO1210
15550      GOTO1220
15551 1210 CONTINUE
15552      J=J+1
15553      Y2(J)=RIGHT
15554      X2(J)=XIDTEM(ISET) + (TAGID-1.0)/10.0
15555CCCCC D2(J)=1.0
15556      D2(J)=(TAGID-1.0)*REAL(NUMSET) + REAL(ISET)
15557      GOTO1290
15558 1220 CONTINUE
15559      GOTO9000
15560CCCCC J=J+1
15561CCCCC Y2(J)=RIGHT
15562CCCCC X2(J)=XIDTEM(1)
15563CCCCC D2(J)=2.0
15564CCCCC J=J+1
15565CCCCC Y2(J)=RIGHT
15566CCCCC X2(J)=XIDTEM(NUMSET)
15567CCCCC D2(J)=2.0
15568CCCCC GOTO1290
15569 1290 CONTINUE
15570      GOTO9000
15571C
15572C               *******************
15573C               **   STEP 90--   **
15574C               **   EXIT        **
15575C               *******************
15576C
15577 9000 CONTINUE
15578C
15579      RETURN
15580      END
15581      SUBROUTINE DPJBS5(ISET1,ISET2,NUMSE2,J,RIGHT,XIDTEM,
15582     1                  Y2,X2,D2)
15583C
15584C     PURPOSE--ADD A COMPUTED POINT TO THE OUTPUT PLOT VECTORS
15585C              FOR THE JACKNIFE AND BOOTSTRAP PLOTS.
15586C              THIS IS A SPECIAL VERSION OF DPJBS4 FOR THE CASE
15587C              WHEN THERE ARE EXACTLY TWO GROUP VRIABLES.
15588C     CAUTION--THE INPUT ARGUMENT J CHANGES WITHIN
15589C              THIS ROUTINE AND IS ALSO AN OUTPUT ARGUMENT.
15590C     WRITTEN BY--JAMES J. FILLIBEN
15591C                 STATISTICAL ENGINEERING DIVISION
15592C                 INFORMATION TECHNOLOGY LABORATORY
15593C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15594C                 GAITHERSBURG, MD 20899-8980
15595C                 PHONE--301-975-2899
15596C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15597C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15598C     LANGUAGE--ANSI FORTRAN (1977)
15599C     VERSION NUMBER--2003/7
15600C     ORIGINAL VERSION--JULY      2003.
15601C
15602C---------------------------------------------------------------------
15603C
15604      DIMENSION XIDTEM(*)
15605      DIMENSION Y2(*)
15606      DIMENSION X2(*)
15607      DIMENSION D2(*)
15608C
15609C---------------------------------------------------------------------
15610C
15611      INCLUDE 'DPCOP2.INC'
15612C
15613C-----START POINT-----------------------------------------------------
15614C
15615      IF(ISET1.LE.0 .OR. ISET2.LE.0)GOTO9000
15616C
15617C               **************************************************
15618C               **  STEP 12--                                   **
15619C               **  TREAT THE CASE WHEN HAVE 2 GROUPS           **
15620C               **************************************************
15621C
15622      AINC=0.4/REAL(NUMSE2)
15623      ASTRT=XIDTEM(ISET1) - 0.2
15624      XTEMP=ASTRT + REAL(ISET2-1)*AINC
15625      J=J+1
15626      Y2(J)=RIGHT
15627      X2(J)=XTEMP
15628      ITEMP=(ISET1-1)*NUMSE2 + ISET2
15629      D2(J)=REAL(ITEMP)
15630C
15631C               *******************
15632C               **   STEP 90--   **
15633C               **   EXIT        **
15634C               *******************
15635C
15636 9000 CONTINUE
15637C
15638      RETURN
15639      END
15640      SUBROUTINE DPJBS6(Y,Z,Z2,XDESGN,N,N2,NUMV2,NGRPV,ICASPL,
15641     1                  ISIZE,ICONT,
15642     1                  ICASJB,IBOOSS,ISEED,IBCABT,ALPHA,IFLAGI,IFLAGD,
15643     1                  TEMP,TEMPZ,TEMPZ2,XIDTEM,XTEMP1,XTEMP2,XTEMP3,
15644     1                  MAXNXT,MAXBGR,
15645     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
15646     1                  Y2,X2,D2,NPLOTP,NPLOTV,
15647     1                  TEMP0,TEMPZ0,TMPZ20,RES1,RES2,
15648     1                  TEMP4,TEMPTH,TEMP6,
15649     1                  DTEMP1,DTEMP2,DTEMP3,
15650     1                  APERC,BPERC,NPERC,
15651     1                  BMEAN,BSD,B001,B005,B01,B025,B05,B10,B20,B50,
15652     1                  B80,B90,B95,B975,B99,B995,B999,
15653     1                  ICAPSW,ICAPTY,IFORSW,IVARID,IVARI2,ISTANM,
15654     1                  ISUBRO,IBUGG3,IERROR)
15655C
15656C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
15657C              THAT WILL DEFINE A JACKNIFE OR BOOTSTRAP PLOT
15658C              (SEE DPJBSP FOR ALLOWABLE TYPES)
15659C
15660C              NOTE: THIS ROUTINE EXTRACTED FROM ORIGINAL DPJBS2.
15661C                    IT PERFORMS THE BOOTSTRAP FOR "STATISTICS" AND
15662C                    A FEW SPECIAL FITTING/CALIBRATION CASES.  THE
15663C                    DISTRIBUTIONAL BOOTSTRAP IS EXTRACTED TO DPJBS7.
15664C
15665C                    WITH THIS EXTRACTION, TAKE THE OPPORTUNITY TO
15666C                    SIMPLIFY THE CODE A BIT AS WELL.
15667C
15668C     WRITTEN BY--JAMES J. FILLIBEN
15669C                 STATISTICAL ENGINEERING DIVISION
15670C                 INFORMATION TECHNOLOGY LABORATORY
15671C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15672C                 GAITHERSBURG, MD 20899-8980
15673C                 PHONE--301-975-2899
15674C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15675C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15676C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
15677C     LANGUAGE--ANSI FORTRAN (1977)
15678C     VERSION NUMBER--2010/02
15679C     ORIGINAL VERSION--FEBRUARY  2010. EXTRACTED FROM DPJBS2
15680C     UPDATED         --JULY      2010. IN ADDITION TO PLOT,
15681C                                       GENERATE A NUMERIC TABLE
15682C     UPDATED         --SEPTEMBER 2010. ACCOMODATE UP TO 3 RESPONSE
15683C                                       VARIABLES
15684C     UPDATED         --OCTOBER   2011. SUPPORT FOR PERCENTILE-t
15685C                                       CONFIDENCE INTERVALS
15686C     UPDATED         --OCTOBER   2011. SUPPORT FOR SMOOTHED BOOTSTRAP
15687C     UPDATED         --OCTOBER   2011. SUPPORT FOR "SUMMARY" STATISTICS
15688C     UPDATED         --JUNE      2017. FIX BUG IN "UNPAIRED" SAMPLES
15689C
15690C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15691C
15692      CHARACTER*4 IBCABT
15693      CHARACTER*4 ICAPSW
15694      CHARACTER*4 ICAPTY
15695      CHARACTER*4 IFORSW
15696      CHARACTER*4 ICASPL
15697      CHARACTER*4 ICONT
15698      CHARACTER*4 IFLAGD
15699      CHARACTER*4 IFLAGI
15700      CHARACTER*4 ISUBRO
15701      CHARACTER*4 IBUGG3
15702      CHARACTER*4 IERROR
15703C
15704      CHARACTER*4 IVARID(*)
15705      CHARACTER*4 IVARI2(*)
15706      CHARACTER*(*) ISTANM
15707C
15708      CHARACTER*4 IHP
15709      CHARACTER*4 IHP2
15710      CHARACTER*4 IHWUSE
15711      CHARACTER*4 MESSAG
15712      CHARACTER*4 IWRITE
15713      CHARACTER*4 IBCASV
15714      CHARACTER*4 IBOOC2
15715      CHARACTER*4 ICASZZ
15716      CHARACTER*4 IOP
15717      CHARACTER*4 ICASJB
15718      CHARACTER*4 ISUBN1
15719      CHARACTER*4 ISUBN2
15720      CHARACTER*4 ISTEPN
15721      CHARACTER*4 IVRBSV
15722      CHARACTER*4 IDS4SV
15723C
15724      DOUBLE PRECISION DTERM1
15725      DOUBLE PRECISION DTERM2
15726      DOUBLE PRECISION DSUM1
15727      DOUBLE PRECISION DSUM2
15728C
15729C---------------------------------------------------------------------
15730C
15731      INCLUDE 'DPCOPA.INC'
15732C
15733      DIMENSION Y(*)
15734      DIMENSION Z(*)
15735      DIMENSION Z2(*)
15736      DIMENSION XDESGN(MAXNXT,MAXBGR)
15737      DIMENSION Y2(*)
15738      DIMENSION X2(*)
15739      DIMENSION D2(*)
15740C
15741      DIMENSION TEMP(*)
15742      DIMENSION TEMPZ(*)
15743      DIMENSION TEMPZ2(*)
15744      DIMENSION XIDTEM(MAXNXT,MAXBGR)
15745      DIMENSION XTEMP1(*)
15746      DIMENSION XTEMP2(*)
15747      DIMENSION XTEMP3(*)
15748      DIMENSION TEMP4(*)
15749      DIMENSION TEMPTH(*)
15750      DIMENSION TEMP6(*)
15751C
15752      DOUBLE PRECISION DTEMP1(*)
15753      DOUBLE PRECISION DTEMP2(*)
15754      DOUBLE PRECISION DTEMP3(*)
15755C
15756      INTEGER N
15757      INTEGER NUMSE1(10)
15758      INTEGER ITEMP1(*)
15759      INTEGER ITEMP2(*)
15760      INTEGER ITEMP3(*)
15761      INTEGER ITEMP4(*)
15762      INTEGER ITEMP5(*)
15763      INTEGER ITEMP6(*)
15764C
15765      DIMENSION TEMP0(*)
15766      DIMENSION TEMPZ0(*)
15767      DIMENSION TMPZ20(*)
15768      DIMENSION RES1(*)
15769      DIMENSION RES2(*)
15770C
15771      PARAMETER (MAXPAR=1)
15772      DIMENSION ZMEAN(MAXPAR)
15773      DIMENSION ZMED(MAXPAR)
15774      DIMENSION ZSD(MAXPAR)
15775      DIMENSION ZMAD(MAXPAR)
15776      DIMENSION NFAIL(MAXPAR)
15777C
15778      PARAMETER(NUMCLI=3)
15779      PARAMETER(MAXLIN=2)
15780      PARAMETER (MAXROW=20)
15781      CHARACTER*80 ITITLE
15782      CHARACTER*60 ITITLZ
15783      CHARACTER*1  ITITL9
15784      CHARACTER*50 ITEXT(MAXROW)
15785      CHARACTER*4  ALIGN(NUMCLI)
15786      CHARACTER*4  VALIGN(NUMCLI)
15787      REAL         AVALUE(MAXROW)
15788      INTEGER      NCTEXT(MAXROW)
15789      INTEGER      IDIGIT(MAXROW)
15790      INTEGER      NTOT(MAXROW)
15791      INTEGER      IWHTML(NUMCLI)
15792      INTEGER      IWRTF(NUMCLI)
15793      CHARACTER*50 ITITL2(MAXLIN,NUMCLI)
15794      CHARACTER*15 IVALUZ(MAXROW,NUMCLI)
15795      CHARACTER*4  ITYPCO(NUMCLI)
15796      INTEGER      NCTIT2(MAXLIN,NUMCLI)
15797      INTEGER      NCVALU(MAXROW,NUMCLI)
15798      REAL         AMAT(MAXROW,NUMCLI)
15799      LOGICAL IFRST
15800      LOGICAL ILAST
15801C
15802      DIMENSION APERC(*)
15803      DIMENSION BPERC(*)
15804C
15805      PARAMETER (NUMALP=6)
15806      DIMENSION ALPHAV(NUMALP)
15807      DIMENSION ALOWPA(NUMALP,1)
15808      DIMENSION AUPPPA(NUMALP,1)
15809C
15810C-----COMMON----------------------------------------------------------
15811C
15812      INCLUDE 'DPCOHK.INC'
15813      INCLUDE 'DPCOST.INC'
15814      INCLUDE 'DPCOP2.INC'
15815C
15816      DATA ALPHAV /0.50, 0.25, 0.10, 0.05, 0.01, 0.001/
15817C
15818C-----START POINT-----------------------------------------------------
15819C
15820      ISUBN1='JBS6'
15821      ISUBN2='    '
15822      IVRBSV=IVRBCM
15823      IDS4SV=IDS4CM
15824      IVRBCM='OFF'
15825      IDS4CM='OFF'
15826C
15827      RIGH1=CPUMIN
15828      RIGH2=CPUMIN
15829      RIGHT0=CPUMIN
15830      NRESAM=0
15831      NBELOW=0
15832C
15833      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'JBS6')THEN
15834        WRITE(ICOUT,70)
15835   70   FORMAT('AT THE BEGINNING OF DPJBS6--')
15836        CALL DPWRST('XXX','BUG ')
15837        WRITE(ICOUT,71)IBUGG3,ISUBRO,ICASJB,IBCABT,IBOOSS
15838   71   FORMAT('IBUGG3,ISUBRO,ICASJB,IBCABT,IBOOSS = ',4(A4,2X),I8)
15839        CALL DPWRST('XXX','BUG ')
15840        WRITE(ICOUT,72)N,N2,NUMV2,ISIZE,NGRPV
15841   72   FORMAT('N,N2,NUMV2,ISIZE,NGRPV = ',4I8,I4)
15842        CALL DPWRST('XXX','BUG ')
15843        WRITE(ICOUT,79)ICASPL,ICONT,IFLAGI,IFLAGD
15844   79   FORMAT('ICASPL,ICONT,IFLAGI,IFLAGD = ',3(A4,2X),A4)
15845        CALL DPWRST('XXX','BUG ')
15846        DO73I=1,N
15847          WRITE(ICOUT,74)I,Y(I),XDESGN(I,1),Z(I),Z2(I)
15848   74     FORMAT('I, Y(I),XDESGN(I,1),Z(I),Z2(I) = ',I8,4G15.7)
15849          CALL DPWRST('XXX','BUG ')
15850   73   CONTINUE
15851        WRITE(ICOUT,78)IBOOCI,PBOOTS,IBOOSM,PBOOSM
15852   78   FORMAT('IBOOCI,PBOOTS,IBOOSM,PBOOSM = ',2(A4,2X,G15.7))
15853        CALL DPWRST('XXX','BUG ')
15854      ENDIF
15855C
15856      IWRITE='OFF'
15857CCCCC NOTE 2011/10: FOR STATISTIC CASE, THERE IS A SINGLE PARAMETER
15858CCCCC               COMPUTED.
15859CCCCC NUMPAR=NUMV2
15860      NUMPAR=1
15861      I2=0
15862      ISIZE2=0
15863      NUMSET=0
15864      DO120I=1,NGRPV
15865        NUMSE1(I)=0
15866  120 CONTINUE
15867C
15868      NACC=0
15869      NREJ=0
15870C
15871C     1) IF t-PERCENTILE REQUESTED, CHECK THAT A POSITIVE
15872C        STANDARD DEVIATION HAS BEEN ENTERED
15873C     2) IF BCA AND t-PERCENTILE BOTH SPECIFIED, USE t-PERCENTILE
15874C
15875      IBCASV=IBCABT
15876      IBOOC2=IBOOCI
15877C
15878      IF(IBOOCI.EQ.'T   ')THEN
15879        IF(PBOOTS.LE.0.0)THEN
15880          WRITE(ICOUT,999)
15881          CALL DPWRST('XXX','BUG ')
15882          WRITE(ICOUT,111)
15883  111     FORMAT('***** WARNING IN BOOTSTRAP/JACKNIFE PLOT--')
15884          CALL DPWRST('XXX','BUG ')
15885          WRITE(ICOUT,112)
15886  112     FORMAT('      WHEN THE t-PERCENTILE CONFIDENCE INTERVALS ',
15887     1           'ARE RESQUESTED,')
15888          CALL DPWRST('XXX','BUG ')
15889          WRITE(ICOUT,113)
15890  113     FORMAT('      A POSITIVE STANDARD DEVIATION FOR THE ',
15891     1           'SPECIFIED STATISTIC MUST BE GIVEN.')
15892          CALL DPWRST('XXX','BUG ')
15893          WRITE(ICOUT,114)
15894  114     FORMAT('      TO DO THIS, ENTER THE COMMAND:')
15895          CALL DPWRST('XXX','BUG ')
15896          WRITE(ICOUT,999)
15897          CALL DPWRST('XXX','BUG ')
15898          WRITE(ICOUT,115)
15899  115     FORMAT('          SET BOOTSTRP T PERCENTILE STANDARD ',
15900     1           'DEVIATION  <value>')
15901          CALL DPWRST('XXX','BUG ')
15902          IBOOCI='PERC'
15903        ELSE
15904          IBCABT='OFF'
15905        ENDIF
15906      ENDIF
15907C
15908C     CHECK THE INPUT ARGUMENTS FOR ERRORS
15909C
15910      IF(N.LT.1)THEN
15911        WRITE(ICOUT,999)
15912  999   FORMAT(1X)
15913        CALL DPWRST('XXX','BUG ')
15914        WRITE(ICOUT,131)
15915  131   FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--')
15916        CALL DPWRST('XXX','BUG ')
15917        WRITE(ICOUT,132)
15918  132   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
15919     1         'VARIABLE MUST BE AT LEAST 1;')
15920        CALL DPWRST('XXX','BUG ')
15921        WRITE(ICOUT,134)N
15922  134   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
15923        CALL DPWRST('XXX','BUG ')
15924        WRITE(ICOUT,999)
15925        CALL DPWRST('XXX','BUG ')
15926        IERROR='YES'
15927        GOTO9000
15928      ENDIF
15929C
15930C               ********************************************************
15931C               **  STEP 1--                                          **
15932C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
15933C               **  FOR THE GROUP VARIABLE (USUALLY VAR. 2)           **
15934C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
15935C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
15936C               **  WHICH IS AN ERROR CONDITION FOR A PLOT.           **
15937C               ********************************************************
15938C
15939      ISTEPN='1'
15940      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS6')
15941     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15942C
15943      IF(NGRPV.GE.1)THEN
15944        NUMSET=1
15945        DO170J=1,NGRPV
15946          CALL DISTIN(XDESGN(1,J),N,IWRITE,XIDTEM(1,J),NUMSE1(J),
15947     1                IBUGG3,IERROR)
15948          CALL SORT(XIDTEM(1,J),NUMSE1(J),XIDTEM(1,J))
15949          NUMSET=NUMSET*NUMSE1(J)
15950C
15951          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS6')THEN
15952            WRITE(ICOUT,171)NGRPV,J,NUMSE1(J),NUMSET
15953  171       FORMAT('NGRPV,J,NUMSE1(J),NUMSET = ',4I8)
15954            CALL DPWRST('XXX','BUG ')
15955            DO172K=1,NUMSE1(J)
15956              WRITE(ICOUT,173)K,XIDTEM(K,J)
15957  173         FORMAT('K,XIDTEM(K,J) = ',I8,G15.7)
15958              CALL DPWRST('XXX','BUG ')
15959  172       CONTINUE
15960          ENDIF
15961C
15962          IF(NUMSE1(J).LT.1 .OR. NUMSE1(J).GE.N)THEN
15963            WRITE(ICOUT,999)
15964            CALL DPWRST('XXX','BUG ')
15965            WRITE(ICOUT,181)
15966  181       FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--')
15967            CALL DPWRST('XXX','BUG ')
15968            WRITE(ICOUT,182)
15969  182       FORMAT('      THE NUMBER OF SETS FOR THE GROUP ONE ',
15970     1             'VARIABLE')
15971            CALL DPWRST('XXX','BUG ')
15972            WRITE(ICOUT,183)
15973  183       FORMAT('      IS ZERO OR EQUAL TO THE NUMBER OF POINTS.')
15974            CALL DPWRST('XXX','BUG ')
15975            WRITE(ICOUT,184)NUMSE1(J)
15976  184       FORMAT('      NUMBER OF SETS = ',I8)
15977            CALL DPWRST('XXX','BUG ')
15978            IERROR='YES'
15979            GOTO9000
15980          ENDIF
15981C
15982  170   CONTINUE
15983C
15984      ENDIF
15985C
15986      AN=N
15987C
15988      IOP='OPEN'
15989      IFLAG1=1
15990      IFLAG2=1
15991      IFLAG3=0
15992      IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')IFLAG3=1
15993      IFLAG4=0
15994      IFLAG5=0
15995      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
15996     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
15997     1            IBUGG3,ISUBRO,IERROR)
15998      IF(IERROR.EQ.'YES')GOTO9000
15999C
16000      IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN
16001        WRITE(IOUNI3,203)100.0*(1.0-ALPHA)
16002  203   FORMAT('      BCa BOOTSTRAP ',F7.2,'% CONFIDENCE INTERVALS:')
16003        WRITE(IOUNI3,205)ALPHA/2.0,(1.0-ALPHA/2)
16004  205   FORMAT('SIGNIFICANCE LEVELS = (',F6.3,',',F6.3,')')
16005        WRITE(IOUNI3,207)
16006  207   FORMAT(6X,'LOWER',11X,'UPPER')
16007        WRITE(IOUNI3,209)
16008  209   FORMAT(3X,'CONFIDENCE',5X,'CONFIDENCE',11X,'^',14X,'^')
16009        WRITE(IOUNI3,211)
16010  211   FORMAT(6X,'LIMIT',11X,'LIMIT',12X,'Z0',13X,'A0',6X,'ALPHA1',
16011     1         3X,'ALPHA2')
16012        WRITE(IOUNI3,213)
16013  213   FORMAT('---------------------------------------------------',
16014     1         '-------------------------')
16015      ENDIF
16016C
16017C               ******************************************
16018C               **  STEP 11--                           **
16019C               **  COMPUTE THE SPECIFIED STATISTIC     **
16020C               **  FOR EACH SUBSET OF THE DATA, AND    **
16021C               **  THEN FOR THE FULL DATA SET          **
16022C               ******************************************
16023C
16024      ISTEPN='11'
16025      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS6')
16026     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16027C
16028      NUMDIG=7
16029      IF(IFORSW.EQ.'1')NUMDIG=1
16030      IF(IFORSW.EQ.'2')NUMDIG=2
16031      IF(IFORSW.EQ.'3')NUMDIG=3
16032      IF(IFORSW.EQ.'4')NUMDIG=4
16033      IF(IFORSW.EQ.'5')NUMDIG=5
16034      IF(IFORSW.EQ.'6')NUMDIG=6
16035      IF(IFORSW.EQ.'7')NUMDIG=7
16036      IF(IFORSW.EQ.'8')NUMDIG=8
16037      IF(IFORSW.EQ.'9')NUMDIG=9
16038      IF(IFORSW.EQ.'0')NUMDIG=0
16039      IF(IFORSW.EQ.'E')NUMDIG=-2
16040      IF(IFORSW.EQ.'-2')NUMDIG=-2
16041      IF(IFORSW.EQ.'-3')NUMDIG=-3
16042      IF(IFORSW.EQ.'-4')NUMDIG=-4
16043      IF(IFORSW.EQ.'-5')NUMDIG=-5
16044      IF(IFORSW.EQ.'-6')NUMDIG=-6
16045      IF(IFORSW.EQ.'-7')NUMDIG=-7
16046      IF(IFORSW.EQ.'-8')NUMDIG=-8
16047      IF(IFORSW.EQ.'-9')NUMDIG=-9
16048      ICNT9=0
16049C
16050      J=0
16051      J2=0
16052      ISETMX=NUMSET+1
16053      NMAX=MAX(N,N2)
16054C
16055      DO11000ISET=1,ISETMX
16056C
16057        CALL DPJBS8(ISETMX,ISET,NUMSET,NUMSE1,N,N2,NGRPV,
16058     1              MAXNXT,MAXBGR,NUMV2,
16059     1              Y,Z,Z2,XDESGN,XIDTEM,TEMP0,TEMPZ0,TMPZ20,
16060     1              NS2,NSS2,NI,NI2,ISET1,ISET2,
16061     1              ISUBRO,IBUGG3,IERROR)
16062
16063C
16064        NRESAM=NS2
16065        IF(ICASJB.EQ.'BOOT')NRESAM=IBOOSS
16066C
16067C       AUGUST 2002.  SIMPLIFY CODE BY USING "CMPSTA" TO COMPUTE
16068C       STATISTIC.  NOTE THAT THE FOLLOWING DISTINCT CASES ARE
16069C       SUPPORTED:
16070C
16071C       1) STATISTIC COMPUTED FROM A SINGLE RESPONSE VARIABLE
16072C          (MOST CASES IN THIS CATEGORY, E.G., THE MEAN)
16073C       2) STATISTIC COMPUTED FROM TWO RESPONSE VARIABLES,
16074C          RESPONSES ARE PAIRED (E.G., THE CORRELATION).
16075C       3) STATISTIC COMPUTED FROM TWO RESPONSE VARIABLES, THE
16076C          RESPONSES ARE NOT PAIRED (I.E., SAMPLE THE TWO VARIABLES
16077C          SEPARATELY).  CURRENTLY, NO CASES FOR THIS.
16078C       4) LINEAR AND QUADRATIC CALIBRATION HANDLED SEPARATELY.
16079C       5) LINEAR SLOPE, LINEAR CORRELATION, LINEAR RESSD,
16080C          LINEAR INTERCEPT HANDLED SEPARATELY.
16081C       6) SUMMARY STATISTIC CASE HANDLED SEPARATELY (USE THE
16082C          PARAMETERIC BOOTSTRAP)
16083C
16084C
16085C       HANDLE LINEAR CALIBRATION, QUADRATIC CALIBRATION SEPARATELY.
16086C
16087        IF(ICASPL.EQ.'LICA')GOTO12240
16088        IF(ICASPL.EQ.'QUCA')GOTO12240
16089C
16090C       FOR REMAINING CASES, DEFINE
16091C
16092C       ICASE = 1  - SINGLE RESPONSE VARIABLE
16093C       ICASE = 2  - PAIRED RESPONSE VARIABLES
16094C       ICASE = 3  - UNPAIRED RESPONSE VARIABLES
16095C       ICASE = 4  - LINEAR CORRELATION, LINEAR INTERCEPT,
16096C                    LINEAR SLOPE, LINEAR RESSD
16097C       ICASE = 5  - SUMMARY STATISTICS
16098C
16099        ICASE=1
16100        IF(NUMV2.GE.2)ICASE=2
16101        IF(IFLAGD.EQ.'DEPE')THEN
16102          ICASE=2
16103        ELSEIF(IFLAGD.EQ.'INDE')THEN
16104           IF(IBOOGR.EQ.'DEPE')THEN
16105             ICASE=2
16106           ELSE
16107             ICASE=3
16108           ENDIF
16109        ENDIF
16110        IF(IFLAGI.EQ.'SUMM')ICASE=5
16111C
16112        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS6')THEN
16113          WRITE(ICOUT,1107)ICASE,IBOOGR,IFLAGD
16114 1107     FORMAT('ICASE,IBOOGR,IFLAGD ',I5,2(2X,A4))
16115          CALL DPWRST('XXX','BUG ')
16116        ENDIF
16117C
16118C  CASES WITH TWO UNPAIRED RESPONSE VARIABLES (NOT NECESSARILY OF
16119C  SAME SIZE)
16120C
16121        IF(ICASPL.EQ.'ORSE' .OR. ICASPL.EQ.'ODRA' .OR.
16122     1     ICASPL.EQ.'LOSE' .OR. ICASPL.EQ.'LODR' .OR.
16123     1     ICASPL.EQ.'DBPR' .OR. ICASPL.EQ.'WOSM')THEN
16124           ICASE=3
16125           IBCABT='OFF'
16126        ENDIF
16127C
16128        IF(ICASPL.EQ.'LIIN' .OR. ICASPL.EQ.'LISL' .OR.
16129     1     ICASPL.EQ.'LIIS' .OR. ICASPL.EQ.'LISS' .OR.
16130     1     ICASPL.EQ.'CINT' .OR. ICASPL.EQ.'CSD ' .OR.
16131     1     ICASPL.EQ.'LIRE' .OR. ICASPL.EQ.'LICO')ICASE=4
16132C
16133C       FOR BCA OR t-PERCENTILE CONFIDENCE INTERVALS, COMPUTE
16134C       FULL-SAMPLE STATISTIC.
16135C
16136        IF(IBCABT.EQ.'ON'.AND.ICASJB.EQ.'BOOT')THEN
16137          CALL CMPSTA(
16138     1         TEMP0,TEMPZ0,TMPZ20,XTEMP1,XTEMP2,XTEMP3,
16139     1         MAXNXT,NS2,NS2,NS2,NUMV2,ICASPL,
16140     1         ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
16141     1         DTEMP1,DTEMP2,DTEMP3,
16142CCCCC1         IQUAME,IQUASE,PSTAMV,
16143     1         THETHT,
16144     1         ISUBRO,IBUGG3,IERROR)
16145          NBELOW=0
16146        ELSEIF(IBOOCI.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN
16147          CALL CMPSTA(
16148     1         TEMP0,TEMPZ0,TMPZ20,XTEMP1,XTEMP2,XTEMP3,
16149     1         MAXNXT,NS2,NS2,NS2,NUMV2,ICASPL,
16150     1         ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
16151     1         DTEMP1,DTEMP2,DTEMP3,
16152     1         STATD,
16153     1         ISUBRO,IBUGG3,IERROR)
16154          STATSD=PBOOTS
16155        ENDIF
16156C
16157        IF(ICASE.EQ.4)THEN
16158          IF(ICASPL.EQ.'CINT' .OR. ICASPL.EQ.'CSD')THEN
16159            CALL MEAN(TEMP0,NS2,IWRITE,ALPHA,IBUGG3,IERROR)
16160            CALL SD(TEMP0,NS2,IWRITE,SDALPH,IBUGG3,IERROR)
16161            BETA0=0.0
16162            SDBETA=0.0
16163          ELSE
16164            CALL LINFIT(TEMP0,TEMPZ0,NS2,
16165     1                  ALPHA,BETA,XRESSD,XRESDF,
16166     1                  CCXY,SDALPH,SDBETA,CCALBE,
16167     1                  ISUBRO,IBUGG3,IERROR)
16168            ALPHA0=ALPHA
16169            BETA0=BETA
16170          ENDIF
16171          DO11031I=1,NS2
16172            RES1(I)=TEMP0(I)-(ALPHA0+BETA0*TEMPZ0(I))
1617311031     CONTINUE
16174        ELSE
16175          DO11033I=1,NS2
16176            RES1(I)=TEMP0(I)
1617711033     CONTINUE
16178        ENDIF
16179C
16180        TAGID=1.0
16181        DO11361IRESAM=1,NRESAM
16182C
16183C         STEP 1: RESAMPLE ORIGINAL DATA.
16184C
16185          IF(ICASE.EQ.5)THEN
16186            DO11300IROW=1,NS2
16187              NTEMP=INT(TMPZ20(IROW)+0.5)
16188              AMEAN=TEMP0(IROW)
16189              ASD=TEMPZ0(IROW)
16190              CALL NORRAN(NTEMP,ISEED,XTEMP1)
16191              DO11301IJ=1,NTEMP
16192                XTEMP1(IJ)=AMEAN + ASD*XTEMP1(IJ)
1619311301         CONTINUE
16194              CALL MEAN(XTEMP1,NTEMP,IWRITE,XMEAN,IBUGG3,IERROR)
16195              CALL SD(XTEMP1,NTEMP,IWRITE,XSD,IBUGG3,IERROR)
16196              TEMP(IROW)=XMEAN
16197              TEMPZ(IROW)=XSD
16198              TEMPZ2(IROW)=REAL(NTEMP)
1619911300       CONTINUE
16200            NS3=NS2
16201            NS32=NS3
16202          ELSE
16203            CALL DPJBS3(RES1,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1,
16204     1                  TEMP4,IBUGG3,IERROR)
16205            IF(IBOOSM.EQ.'ON')THEN
16206              CALL NORRAN(NS3,ISEED,XTEMP1)
16207              IF(PBOOSM.EQ.CPUMIN)THEN
16208                AFACT=1.0/SQRT(REAL(NS3))
16209              ELSE
16210                AFACT=PBOOSM
16211              ENDIF
16212              DO11311IJ=1,NS3
16213                TEMP(IJ)=TEMP(IJ) + AFACT*XTEMP1(IJ)
1621411311         CONTINUE
16215            ENDIF
16216          ENDIF
16217C
16218C         CREATE ADDITIONAL RESPONSE VARIABLES FOR SPECIAL CASES
16219C         WHERE NEEDED.
16220C
16221          IF(ICASE.EQ.2)THEN
16222            NS32=NS3
16223            DO11363IJ=1,NS3
16224              TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ))
1622511363       CONTINUE
16226          ELSEIF(ICASE.EQ.3)THEN
16227            NS32=NSS2
16228            IF(ICASPL.EQ.'WOSM')THEN
16229              DO11323IJ=1,NS3
16230                TEMPZ(IJ)=TEMPZ0(IJ)
1623111323         CONTINUE
16232            ELSE
16233              CALL DPJBS3(TEMPZ0,NSS2,ICASJB,IRESAM,ISEED,TEMPZ,NS32,
16234     1                    ITEMP1,TEMP4,IBUGG3,IERROR)
16235              IF(IBOOSM.EQ.'ON')THEN
16236                CALL NORRAN(NS32,ISEED,XTEMP1)
16237                IF(PBOOSM.EQ.CPUMIN)THEN
16238                  AFACT=1.0/SQRT(REAL(NS32))
16239                ELSE
16240                  AFACT=PBOOSM
16241                ENDIF
16242                DO11321IJ=1,NS3
16243                  TEMPZ(IJ)=TEMPZ(IJ) + AFACT*XTEMP1(IJ)
1624411321           CONTINUE
16245              ENDIF
16246            ENDIF
16247          ELSEIF(ICASE.EQ.4)THEN
16248            DO11368I=1,NS3
16249              TEMP0(I)=(ALPHA0+BETA0*TEMPZ0(I))+TEMP(I)
1625011368       CONTINUE
16251          ENDIF
16252C
16253C         STEP 2: COMPUTE THE STATISTIC
16254C
16255          CALL CMPSTA(
16256     1         TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
16257     1         MAXNXT,NS3,NS32,NS32,NUMV2,ICASPL,
16258     1         ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
16259     1         DTEMP1,DTEMP2,DTEMP3,
16260CCCCC1         IQUAME,IQUASE,PSTAMV,
16261     1         RIGHT,
16262     1         ISUBRO,IBUGG3,IERROR)
16263C
16264C         STEP 3: COMPARE COMPUTED STATISTIC FROM BOOTSTRAP SAMPLE
16265C                 TO STATISTIC FROM ORIGINAL DATA (FOR BCA) AND ALSO
16266C                 COMPUTE PLOT COORDINATES.
16267C
16268          IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN
16269            IF(RIGHT.LT.THETHT)NBELOW=NBELOW+1
16270            TEMP6(IRESAM)=RIGHT
16271          ENDIF
16272          IF(NGRPV.LE.1)THEN
16273            CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,XIDTEM(1,1),
16274     1                  Y2,X2,D2)
16275          ELSEIF(NGRPV.EQ.2)THEN
16276            CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,RIGHT,
16277     1                  XIDTEM(1,1),Y2,X2,D2)
16278          ENDIF
1627911361   CONTINUE
16280C
16281C       FOR BCA CONFIDENCE INTERVAL, COMPUTE:
16282C       1) Z0HAT
16283C       2) JACKNIFE ESTIMATES
16284C
16285        IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN
16286          CALL NORPPF(REAL(NBELOW)/REAL(NRESAM),Z0HAT)
16287          ICASZZ='JACK'
16288          DO11371IRESAM=1,NS2
16289C
16290            CALL DPJBS3(RES1,NS2,ICASZZ,IRESAM,ISEED,TEMP,NS3,ITEMP1,
16291     1                  TEMP4,IBUGG3,IERROR)
16292            IF(ICASE.EQ.2)THEN
16293              DO11373IJ=1,NS2
16294                TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ))
16295                IF(NUMV2.GE.3)THEN
16296                  TEMPZ2(IJ)=TMPZ20(ITEMP1(IJ))
16297                ENDIF
1629811373         CONTINUE
16299            ELSEIF(ICASE.EQ.3)THEN
16300              CALL DPJBS3(TEMPZ0,NS22,ICASJB,IRESAM,ISEED,TEMPZ,NS32,
16301     1                    ITEMP1,TEMP4,IBUGG3,IERROR)
16302              IF(NUMV2.GE.3)THEN
16303                CALL DPJBS3(TMPZ20,NS22,ICASJB,IRESAM,ISEED,TEMPZ2,NS32,
16304     1                      ITEMP1,TEMP4,IBUGG3,IERROR)
16305              ENDIF
16306            ELSEIF(ICASE.EQ.4)THEN
16307              DO11378I=1,NS3
16308                TEMP0(I)=(ALPHA0+BETA0*TEMPZ0(I))+TEMP(I)
1630911378         CONTINUE
16310            ENDIF
16311C
16312            CALL CMPSTA(
16313     1           TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,
16314     1           MAXNXT,NS3,NS3,NS3,NUMV2,ICASPL,
16315     1           ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
16316     1           DTEMP1,DTEMP2,DTEMP3,
16317CCCCC1           IQUAME,IQUASE,PSTAMV,
16318     1           RIGHT,
16319     1           ISUBRO,IBUGG3,IERROR)
16320            TEMPTH(IRESAM)=RIGHT
1632111371     CONTINUE
16322          CALL MEAN(TEMPTH,NS2,IWRITE,THETDT,IBUGG3,IERROR)
16323          DSUM1=0.0D0
16324          DSUM2=0.0D0
16325          DTHETM=DBLE(THETDT)
16326          DO11365I=1,NS2
16327            DTERM1=DBLE(TEMPTH(I))
16328            DSUM1 = DSUM1 + (DTHETM - DTERM1)**3
16329            DSUM2 = DSUM2 + (DTHETM - DTERM1)**2
1633011365     CONTINUE
16331          DTERM2 = DSUM1/(6.0D0*(DSUM2**1.5))
16332          A0HAT=REAL(DTERM2)
16333          CALL NORPPF(ALPHA/2.0,ALOWSL)
16334          CALL NORPPF(1.0 - ALPHA/2.0,AUPPSL)
16335          TERM1=Z0HAT + (Z0HAT + AUPPSL)/(1.0 - A0HAT*(Z0HAT+AUPPSL))
16336          CALL NORCDF(TERM1,ALPHA2)
16337          TERM1=Z0HAT + (Z0HAT + ALOWSL)/(1.0 - A0HAT*(Z0HAT+ALOWSL))
16338          CALL NORCDF(TERM1,ALPHA1)
16339          CALL PERCEN(100.0*ALPHA2,TEMP6,NS2,IWRITE,TEMP4,MAXNXT,
16340     1                BCAUL,IBUGG3,IERROR)
16341          CALL PERCEN(100.0*ALPHA1,TEMP6,NS2,IWRITE,TEMP4,MAXNXT,
16342     1                BCALL,IBUGG3,IERROR)
16343          IF(NGRPV.EQ.1)THEN
16344            WRITE(IOUNI3,11388)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2,
16345     1                         XIDTEM(ISET,1)
16346          ELSEIF(NGRPV.EQ.2)THEN
16347            WRITE(IOUNI3,11388)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2,
16348     1                         XIDTEM(ISET1,1),XIDTEM(ISET2,2)
16349          ELSE
16350            WRITE(IOUNI3,11388)BCALL,BCAUL,Z0HAT,A0HAT,ALPHA1,ALPHA2
16351          ENDIF
1635211388     FORMAT(4E15.7,2F8.4,2F10.0)
16353C
16354C       2011/10: IMPLEMENT PERCENTILE T BOOTSTRAP:
16355C
16356C                   Z = (STAT(data) - STAT(boot))/SD(boot)
16357C
16358C                   LOWER CI: STAT(data) + SD(data)*Q(Z,alpha/2)
16359C                   UPPER CI: STAT(data) + SD(data)*Q(Z,1 - alpha/2)
16360C
16361        ELSEIF(IBOOCI.EQ.'T   ')THEN
16362        ENDIF
16363C
16364        GOTO79000
16365C
16366CCCCC   NOTE: FOR CALIBRATION, THERE ARE TWO METHODS FOR PERFORMING
16367CCCCC         THE BOOTSTRAP.
16368CCCCC
16369CCCCC         1) "RESI" USES EFROM METHOD OF RESAMPLING THE RESIDUALS.
16370CCCCC
16371CCCCC         2) "DATA" USES WU METHOD OF RESAMPLING THE ORIGINAL
16372CCCCC            Y AND X.
16373CCCCC
16374CCCCC         IN EITHER CASE, THE PARAMETER Y0 SHOULD BE PRE-DEFINED.
16375CCCCC
16376CCCCC         AFTER QUADRATIC FIT, QUADRATIC FORMULA IS:
16377CCCCC             X = (-b +/- SQRT(b**2 - 4*a*c))/(2*a)
16378C
1637912240   CONTINUE
16380C
16381        IHP='Y0  '
16382        IHP2='    '
16383        IHWUSE='P'
16384        MESSAG='YES'
16385        CALL CHECKN(IHP,IHP2,IHWUSE,
16386     1       IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
16387     1       ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
16388        IF(IERROR.EQ.'YES')THEN
16389          GOTO9000
16390        ELSE
16391          Y0=VALUE(ILOCP)
16392        ENDIF
16393C
16394        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN
16395          DO12249I=1,NS2
16396            WRITE(ICOUT,12242)I,TEMP0(I),TEMPZ0(I)
1639712242       FORMAT('I,TEMP0(I),TEMPZ0(I) = ',I8,2G15.7)
16398            CALL DPWRST('XXX','BUG ')
1639912249     CONTINUE
16400        ENDIF
16401C
16402        CALL MINIM(TEMPZ0,NS2,IWRITE,XLEFT,IBUGG3,IERROR)
16403        CALL MAXIM(TEMPZ0,NS2,IWRITE,XRIGHT,IBUGG3,IERROR)
16404C
16405        IF(IBOOME.EQ.'RESI')THEN
16406C
16407C  GENERATE FIT AND RESIDUALS FROM ORIGINAL DATA.
16408C
16409          IF(ICASPL.EQ.'LICA')THEN
16410            CALL LINFIT(TEMP0,TEMPZ0,NS2,
16411     1                  ALPHA,BETA,XRESSD,XRESDF,
16412     1                  CCXY,SDALPH,SDBETA,CCALBE,
16413     1                  ISUBRO,IBUGG3,IERROR)
16414            ALPHA0=ALPHA
16415            BETA0=BETA
16416            DO12251I=1,NS2
16417              RES1(I)=TEMP0(I)-(ALPHA0+BETA0*TEMPZ0(I))
1641812251       CONTINUE
16419C
16420            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN
16421              WRITE(ICOUT,12533)ALPHA0,BETA0
1642212533         FORMAT('ALPHA0,BETA0 = ',2G15.7)
16423              CALL DPWRST('XXX','BUG ')
16424            ENDIF
16425          ELSEIF(ICASPL.EQ.'QUCA')THEN
16426            CALL QUAFI2(TEMPZ0,TEMP0,NS2,
16427     1                  XTEMP1,
16428     1                  ALPHA,BETA1,BETA2,
16429     1                  ISUBRO,IBUGG3,IERROR)
16430            ALPHA0=ALPHA
16431            BETA10=BETA1
16432            BETA20=BETA2
16433C
16434            C=ALPHA - Y0
16435            B=BETA1
16436            A=BETA2
16437            TERM1=B**2 - 4.0*A*C
16438            RIGH10=0.0
16439            RIGH20=0.0
16440            IF(TERM1.GE.0.0)THEN
16441              TERM1=SQRT(TERM1)
16442              RIGH10=(-B + TERM1)/(2*A)
16443              RIGH20=(-B - TERM1)/(2*A)
16444            ENDIF
16445            IF(RIGH10.GE.XLEFT .AND. RIGH10.LE.XRIGHT)THEN
16446              RIGHT0=RIGH10
16447            ELSEIF(RIGH20.GE.XLEFT .AND. RIGH20.LE.XRIGHT)THEN
16448              RIGHT0=RIGH20
16449            ELSE
16450              RIGHT0=RIGH10
16451            ENDIF
16452C
16453            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB6')THEN
16454              WRITE(ICOUT,12262)RIGH10,RIGH20
1645512262         FORMAT('FULL SAMPLE ROOTS: RIGH10,RIGH20 = ',2E15.7)
16456              CALL DPWRST('XXX','BUG ')
16457            ENDIF
16458C
16459            DO12271I=1,NS2
16460              AJUNK1=TEMPZ0(I)
16461              RES1(I)=TEMP0(I)-(ALPHA0+BETA10*AJUNK1+BETA20*AJUNK1**2)
1646212271       CONTINUE
16463C
16464            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN
16465              WRITE(ICOUT,12273)ALPHA0,BETA10,BETA20
1646612273         FORMAT('ALPHA0,BETA10,BETA20 = ',3G15.7)
16467              CALL DPWRST('XXX','BUG ')
16468            ENDIF
16469C
16470          ENDIF
16471C
16472C         RESAMPLE RESIDUALS.
16473C
16474          NREJ=0
16475          NNEG=0
16476          DO12281IRESAM=1,NRESAM
16477            CALL DPJBS3(RES1,NS2,ICASJB,IRESAM,ISEED,RES2,NS3,ITEMP1,
16478     1                  TEMP4,IBUGG3,IERROR)
16479            IF(ICASPL.EQ.'LICA')THEN
16480              DO12282I=1,NS3
16481                TEMP(I)=(ALPHA0+BETA0*TEMPZ0(I))+RES2(I)
1648212282         CONTINUE
16483              CALL LINFIT(TEMP,TEMPZ0,NS3,
16484     1                    ALPHA,BETA,XRESSD,XRESDF,
16485     1                    CCXY,SDALPH,SDBETA,CCALBE,
16486     1                    ISUBRO,IBUGG3,IERROR)
16487              A0=ALPHA
16488              A1=BETA
16489              RIGHT=(Y0-A0)/A1
16490C
16491              IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN
16492                WRITE(ICOUT,12283)IRESAM,ALPHA,BETA,RIGHT
1649312283           FORMAT('IRESAM,ALPHA0,BETA0,RIGHT = ',I8,3G15.7)
16494                CALL DPWRST('XXX','BUG ')
16495              ENDIF
16496C
16497            ELSEIF(ICASPL.EQ.'QUCA')THEN
16498              DO12286I=1,NS3
16499                AJUNK1=TEMPZ0(I)
16500                TEMP(I)=(ALPHA0+BETA10*AJUNK1+BETA20*AJUNK1**2)+RES2(I)
1650112286         CONTINUE
16502              CALL QUAFI2(TEMPZ0,TEMP,NS3,
16503     1                    XTEMP1,
16504     1                    ALPHA,BETA1,BETA2,
16505     1                    ISUBRO,IBUGG3,IERROR)
16506              C=ALPHA - Y0
16507              B=BETA1
16508              A=BETA2
16509              TERM1=B**2 - 4.0*A*C
16510              IF(TERM1.EQ.0.0)THEN
16511                RIGHT=(-B + TERM1)/(2*A)
16512              ELSEIF(TERM1.GT.0.0)THEN
16513                TERM1=SQRT(TERM1)
16514                RIGH1=(-B + TERM1)/(2*A)
16515                RIGH2=(-B - TERM1)/(2*A)
16516                IF(RIGH1.GE.XLEFT .AND. RIGH1.LE.XRIGHT)THEN
16517                  IF(RIGH2.GE.XLEFT .AND. RIGH2.LE.XRIGHT)THEN
16518                    D1DIFF=ABS(RIGH1-RIGHT0)
16519                    D2DIFF=ABS(RIGH2-RIGHT0)
16520                    IF(D1DIFF.LE.D2DIFF)THEN
16521                      RIGHT=RIGH1
16522                    ELSE
16523                      RIGHT=RIGH2
16524                    ENDIF
16525                  ELSE
16526                    RIGHT=RIGH1
16527                  ENDIF
16528                ELSEIF(RIGH2.GE.XLEFT .AND. RIGH2.LE.XRIGHT)THEN
16529                  RIGHT=RIGH2
16530                ELSE
16531                  IF(RIGH1.GT.0.0 .AND. RIGH2.LE.0.0)THEN
16532                    RIGHT=RIGH1
16533                  ELSEIF(RIGH2.GT.0.0 .AND. RIGH1.LE.0.0)THEN
16534                    RIGHT=RIGH2
16535                  ELSE
16536                    D1DIFF=ABS(RIGH1-RIGHT0)
16537                    D2DIFF=ABS(RIGH2-RIGHT0)
16538                    IF(D1DIFF.LE.D2DIFF)THEN
16539                      RIGHT=RIGH1
16540                    ELSE
16541                      RIGHT=RIGH2
16542                    ENDIF
16543                  ENDIF
16544                ENDIF
16545                IF(RIGHT.LT.0)NNEG=NNEG+1
16546              ELSEIF(TERM1.LT.0.0)THEN
16547                NREJ=NREJ+1
16548                GOTO12281
16549              ENDIF
16550C
16551              IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN
16552                WRITE(ICOUT,12287)IRESAM,ALPHA,BETA1,BETA2,RIGHT
1655312287           FORMAT('IRESAM,ALPHA,BETA1,BETA2,RIGHT = ',I8,3G15.7)
16554                CALL DPWRST('XXX','BUG ')
16555                WRITE(ICOUT,12288)A,B,C,TERM1
1655612288           FORMAT('A, B, C, TERM1 = ',4G15.7)
16557                CALL DPWRST('XXX','BUG ')
16558              ENDIF
16559C
16560            ENDIF
16561C
16562            TAGID=1.0
16563            IF(NGRPV.LE.1)THEN
16564              CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,
16565     1                    XIDTEM(1,1),Y2,X2,D2)
16566            ELSE
16567              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,RIGHT,
16568     1                    XIDTEM(1,1),Y2,X2,D2)
16569            ENDIF
1657012281     CONTINUE
16571C
16572        ELSE
16573C
16574C         RESAMPLE ORIGINAL Y AND X VALUES (ROWS OF Y AND X SHOULD
16575C         REMAIN PAIRED).
16576C
16577          NNEG=0
16578          NREJ=0
16579          DO12291IRESAM=1,NRESAM
16580            CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1,
16581     1                  TEMP4,IBUGG3,IERROR)
16582            DO12292IJ=1,NS3
16583              TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ))
1658412292       CONTINUE
16585            IF(ICASPL.EQ.'LICA')THEN
16586              CALL LINFIT(TEMP,TEMPZ,NS3,
16587     1                    ALPHA,BETA,XRESSD,XRESDF,
16588     1                    CCXY,SDALPH,SDBETA,CCALBE,
16589     1                    ISUBRO,IBUGG3,IERROR)
16590              A0=ALPHA
16591              A1=BETA
16592              RIGHT=(Y0-A0)/A1
16593C
16594              IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB6')THEN
16595                WRITE(ICOUT,12293)IRESAM,ALPHA,BETA,RIGHT
1659612293           FORMAT('IRESAM,ALPHA0,BETA0,RIGHT = ',I8,3G15.7)
16597                CALL DPWRST('XXX','BUG ')
16598              ENDIF
16599C
16600            ELSEIF(ICASPL.EQ.'QUCA')THEN
16601              CALL QUAFI2(TEMPZ,TEMP,NS3,
16602     1             XTEMP1,
16603     1             ALPHA,BETA1,BETA2,
16604     1             ISUBRO,IBUGG3,IERROR)
16605              C=ALPHA - Y0
16606              B=BETA1
16607              A=BETA2
16608              TERM1=B**2 - 4.0*A*C
16609              IF(TERM1.EQ.0.0)THEN
16610                RIGHT=(-B + TERM1)/(2*A)
16611              ELSEIF(TERM1.GT.0.0)THEN
16612                TERM1=SQRT(TERM1)
16613                RIGH1=(-B + TERM1)/(2*A)
16614                RIGH2=(-B - TERM1)/(2*A)
16615                IF(RIGH1.GE.XLEFT .AND. RIGH1.LE.XRIGHT)THEN
16616                  IF(RIGH2.GE.XLEFT .AND. RIGH2.LE.XRIGHT)THEN
16617                    IF(RIGH1.GT.0.0 .AND. RIGH2.LE.0.0)THEN
16618                      RIGHT=RIGH1
16619                    ELSEIF(RIGH2.GT.0.0 .AND. RIGH1.LE.0.0)THEN
16620                      RIGHT=RIGH2
16621                    ELSE
16622                      D1DIFF=ABS(RIGH1-RIGHT0)
16623                      D2DIFF=ABS(RIGH2-RIGHT0)
16624                      IF(D1DIFF.LE.D2DIFF)THEN
16625                        RIGHT=RIGH1
16626                      ELSE
16627                        RIGHT=RIGH2
16628                      ENDIF
16629                    ENDIF
16630                  ELSE
16631                    RIGHT=RIGH1
16632                  ENDIF
16633                ELSEIF(RIGH2.GE.XLEFT .AND. RIGH2.LE.XRIGHT)THEN
16634                  RIGHT=RIGH2
16635                ELSE
16636                  D1DIFF=ABS(RIGH1-RIGHT0)
16637                  D2DIFF=ABS(RIGH2-RIGHT0)
16638                  IF(D1DIFF.LE.D2DIFF)THEN
16639                    RIGHT=RIGH1
16640                  ELSE
16641                    RIGHT=RIGH2
16642                  ENDIF
16643                ENDIF
16644                IF(RIGHT.LT.0)NNEG=NNEG+1
16645              ELSEIF(TERM1.LT.0.0)THEN
16646                NREJ=NREJ+1
16647                GOTO12291
16648              ENDIF
16649C
16650              IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JSB2')THEN
16651                WRITE(ICOUT,12287)IRESAM,ALPHA,BETA1,BETA2,RIGHT
16652                CALL DPWRST('XXX','BUG ')
16653              ENDIF
16654C
16655            ENDIF
16656C
16657            TAGID=1.0
16658            IF(NGRPV.LE.1)THEN
16659              CALL DPJBS4(ISET,NUMSET,J,J2,RIGHT,TAGID,
16660     1                    XIDTEM(1,1),Y2,X2,D2)
16661            ELSE
16662              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,RIGHT,
16663     1                    XIDTEM(1,1),Y2,X2,D2)
16664            ENDIF
16665C
1666612291     CONTINUE
16667C
16668        ENDIF
16669C
16670        IF(NREJ.GT.0)THEN
16671          WRITE(ICOUT,12301)
1667212301     FORMAT('***** WARNING FROM BOOTSTRAP PLOT--',
16673     1           'QUADRATIC CALIBRATION')
16674          CALL DPWRST('XXX','BUG ')
16675          WRITE(ICOUT,12303)NREJ
1667612303     FORMAT('      FOR ',I8,' BOOTSTRAP SAMPLES, NO REAL ROOTS ',
16677     1           'FOR THE QUADRATIC EQUATION.')
16678          CALL DPWRST('XXX','BUG ')
16679        ENDIF
16680        IF(NNEG.GT.0)THEN
16681          WRITE(ICOUT,12301)
16682          CALL DPWRST('XXX','BUG ')
16683          WRITE(ICOUT,12305)NREJ
1668412305     FORMAT('      FOR ',I8,' BOOTSTRAP SAMPLES, NEGATIVE ROOT ',
16685     1           'SELECTED.')
16686          CALL DPWRST('XXX','BUG ')
16687        ENDIF
16688        GOTO79000
16689C
1669079000   CONTINUE
16691C
16692C               ************************************************
16693C               **   STEP 19--                                **
16694C               **   FOR GROUPED DATA, WRITE GROUP-ID, MEAN,  **
16695C               **   MEDIAN, B025, B975, B05, B90, B005, B995 **
16696C               **   TO DPST1F.DAT.                           **
16697C               ************************************************
16698C
16699CCCCC JANUARY 2005.  FOR UNGROUPED DATA, WRITE BOOTSTRAP ESTIMATES
16700CCCCC                TO FILE.  ALSO, ACCOMODATE CASE WHERE MORE
16701CCCCC                THAN ONE PARAMETER IS ESTIMATED.
16702C
16703        CALL DPJBS9(Y2,D2,TEMP,XTEMP1,XTEMP2,MAXNXT,IOUNI1,IOUNI2,
16704     1              NUMPAR,NGRPV,NUMSET,ISET,ISET1,ISET2,NUMSE1,J,
16705     1              APERC,BPERC,NPERC,
16706     1              BMEAN,BSD,BMIN,BMAX,BMAD,
16707     1              B001,B005,B01,B025,B05,B10,B20,B50,
16708     1              B80,B90,B95,B975,B99,B995,B999,
16709     1              ALOWPA,AUPPPA,ALPHAV,NUMALP,
16710     1              ZMEAN,ZMED,ZSD,ZMAD,NFAIL,
16711     1              ISUBRO,IBUGG3,IERROR)
16712C
16713         DO79003II=1,NUMPAR
16714           NFAIL(II)=NRESAM - NFAIL(II)
1671579003    CONTINUE
16716C
16717C       ************************************************
16718C       **   STEP 20--                                **
16719C       **   GENERATE  A NUMERIC TABLE OF THE RESULTS **
16720C       ************************************************
16721C
16722        IF(IPRINT.EQ.'OFF')GOTO11000
16723C
16724        ICNT9=ICNT9+1
16725        IF(ICNT9.EQ.1)THEN
16726          ITITLE(1:27)='Bootstrap Analysis for the '
16727           DO8211II=60,1,-1
16728            IF(ISTANM(II:II).NE.' ')THEN
16729               NCSTAT=II
16730               GOTO8219
16731            ENDIF
16732 8211     CONTINUE
16733          NCSTAT=1
16734 8219     CONTINUE
16735          IF(NCSTAT.GT.53)NCSTAT=53
16736          NSTRT=28
16737          NCTITL=NSTRT+NCSTAT-1
16738          ITITLE(NSTRT:NCTITL)=ISTANM(1:NCSTAT)
16739        ELSE
16740          ITITLE=' '
16741          NCTITL=0
16742        ENDIF
16743        ITITLZ=' '
16744        NCTITZ=0
16745        IF(IBOOSM.EQ.'ON')THEN
16746          IF(PBOOSM.EQ.CPUMIN)THEN
16747            ITITLZ='(Smoothed bootstrap with SD = 1/SQRT(N))'
16748            NCTITZ=40
16749          ELSE
16750            ITITLZ='(Smoothed bootstrap with SD = '
16751            WRITE(ITITLZ(31:45),'(G15.7)')PBOOSM
16752            ITITLZ(46:46)=')'
16753            NCTITZ=46
16754          ENDIF
16755        ELSEIF(IFLAGI.EQ.'SUMM')THEN
16756            ITITLZ='(Parametric Bootstrap for Summary Data)'
16757            NCTITZ=39
16758        ENDIF
16759C
16760        ICNT=1
16761        ITEXT(ICNT)=' '
16762        NCTEXT(ICNT)=0
16763        AVALUE(ICNT)=0.0
16764        IDIGIT(ICNT)=-1
16765        ICNT=ICNT+1
16766        ITEXT(ICNT)='Response Variable One: '
16767        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARID(1)(1:4)
16768        WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI2(1)(1:4)
16769        NCTEXT(ICNT)=31
16770        AVALUE(ICNT)=0.0
16771        IDIGIT(ICNT)=-1
16772        IF(NUMV2.GE.2)THEN
16773          ICNT=ICNT+1
16774          ITEXT(ICNT)='Response Variable Two: '
16775          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARID(2)(1:4)
16776          WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI2(2)(1:4)
16777          NCTEXT(ICNT)=31
16778          AVALUE(ICNT)=0.0
16779          IDIGIT(ICNT)=-1
16780        ENDIF
16781        IF(NUMV2.GE.3)THEN
16782          ICNT=ICNT+1
16783          ITEXT(ICNT)='Response Variable Three: '
16784          WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(3)(1:4)
16785          WRITE(ITEXT(ICNT)(30:33),'(A4)')IVARI2(3)(1:4)
16786          NCTEXT(ICNT)=33
16787          AVALUE(ICNT)=0.0
16788          IDIGIT(ICNT)=-1
16789        ENDIF
16790        IF(NGRPV.EQ.1)THEN
16791          ICNT=ICNT+1
16792          ITEXT(ICNT)='Group ID Variable One (        ): '
16793          IF(ISET.LE.0 .OR. ISET.EQ.ISETMX)THEN
16794            ITEXT(ICNT)(24:31)='All Data'
16795            AVALUE(ICNT)=0.0
16796            IDIGIT(ICNT)=-1
16797          ELSE
16798            WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARID(NUMV2+1)(1:4)
16799            WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI2(NUMV2+1)(1:4)
16800            AVALUE(ICNT)=XIDTEM(ISET,1)
16801            IDIGIT(ICNT)=NUMDIG
16802          ENDIF
16803          NCTEXT(ICNT)=34
16804        ENDIF
16805C
16806        IF(NGRPV.GE.2)THEN
16807          ICNT=ICNT+1
16808          ITEXT(ICNT)='Group ID Variable One (        ): '
16809          IF(ISET1.LE.0 .OR. ISET1.EQ.ISETMX)THEN
16810            ITEXT(ICNT)(24:31)='All Data'
16811          ELSE
16812            WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARID(NUMV2+1)(1:4)
16813            WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI2(NUMV2+1)(1:4)
16814          ENDIF
16815          NCTEXT(ICNT)=34
16816          AVALUE(ICNT)=XIDTEM(ISET1,1)
16817          IDIGIT(ICNT)=NUMDIG
16818          ICNT=ICNT+1
16819          ITEXT(ICNT)='Group ID Variable Two (        ): '
16820          IF(ISET2.LE.0 .OR. ISET2.EQ.ISETMX)THEN
16821            ITEXT(ICNT)(24:31)='All Data'
16822          ELSE
16823            WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARID(NUMV2+2)(1:4)
16824            WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI2(NUMV2+2)(1:4)
16825          ENDIF
16826          NCTEXT(ICNT)=34
16827          AVALUE(ICNT)=XIDTEM(ISET2,2)
16828          IDIGIT(ICNT)=NUMDIG
16829        ENDIF
16830C
16831        ICNT=ICNT+1
16832        ITEXT(ICNT)=' '
16833        NCTEXT(ICNT)=1
16834        AVALUE(ICNT)=0.0
16835        IDIGIT(ICNT)=-1
16836C
16837        ICNT=ICNT+1
16838        ITEXT(ICNT)='Number of Bootstrap Samples:'
16839        NCTEXT(ICNT)=28
16840        AVALUE(ICNT)=REAL(NRESAM)
16841        IDIGIT(ICNT)=0
16842        ICNT=ICNT+1
16843        ITEXT(ICNT)='Number of Observations:'
16844        NCTEXT(ICNT)=23
16845        AVALUE(ICNT)=REAL(NS3)
16846        IDIGIT(ICNT)=0
16847        ICNT=ICNT+1
16848        ITEXT(ICNT)='Mean of Bootstrap Samples:'
16849        NCTEXT(ICNT)=26
16850        AVALUE(ICNT)=BMEAN
16851        IDIGIT(ICNT)=NUMDIG
16852        ICNT=ICNT+1
16853        ITEXT(ICNT)='Standard Deviation of Bootstrap Samples:'
16854        NCTEXT(ICNT)=40
16855        AVALUE(ICNT)=BSD
16856        IDIGIT(ICNT)=NUMDIG
16857        ICNT=ICNT+1
16858        ITEXT(ICNT)='Median of Bootstrap Samples:'
16859        NCTEXT(ICNT)=28
16860        AVALUE(ICNT)=B50
16861        IDIGIT(ICNT)=NUMDIG
16862        ICNT=ICNT+1
16863        ITEXT(ICNT)='MAD of Bootstrap Samples:'
16864        NCTEXT(ICNT)=25
16865        AVALUE(ICNT)=BMAD
16866        IDIGIT(ICNT)=NUMDIG
16867        ICNT=ICNT+1
16868        ITEXT(ICNT)='Minimum of Bootstrap Samples:'
16869        NCTEXT(ICNT)=29
16870        AVALUE(ICNT)=BMIN
16871        IDIGIT(ICNT)=NUMDIG
16872        ICNT=ICNT+1
16873        ITEXT(ICNT)='Maximum of Bootstrap Samples:'
16874        NCTEXT(ICNT)=29
16875        AVALUE(ICNT)=BMAX
16876        IDIGIT(ICNT)=NUMDIG
16877        ICNT=ICNT+1
16878        ITEXT(ICNT)=' '
16879        NCTEXT(ICNT)=0
16880        AVALUE(ICNT)=0.0
16881        IDIGIT(ICNT)=-1
16882C
16883        NUMROW=ICNT
16884        DO8321II=1,NUMROW
16885          NTOT(II)=15
16886 8321   CONTINUE
16887C
16888        IFRST=.TRUE.
16889        ILAST=.TRUE.
16890        CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
16891     1              AVALUE,IDIGIT,
16892     1              NTOT,NUMROW,
16893     1              ICAPSW,ICAPTY,ILAST,IFRST,
16894     1              ISUBRO,IBUGG3,IERROR)
16895        ITITLE=' '
16896        NCTITL=0
16897        ITITL9=' '
16898        NCTIT9=0
16899C
16900        ITITLE='Percent Points of the Bootstrap Samples'
16901        NCTITL=39
16902        NUMLIN=1
16903        NUMROW=15
16904        NUMCOL=3
16905        ITITL2(1,1)='Percent Point'
16906        ITITL2(1,2)=' '
16907        ITITL2(1,3)='Value'
16908        NCTIT2(1,1)=13
16909        NCTIT2(1,2)=1
16910        NCTIT2(1,3)=5
16911C
16912        NMAX=0
16913        DO2521II=1,NUMCOL
16914          VALIGN(II)='b'
16915          ALIGN(II)='r'
16916          NTOT(II)=15
16917          IF(II.EQ.2)NTOT(II)=5
16918          NMAX=NMAX+NTOT(II)
16919          IDIGIT(II)=NUMDIG
16920          ITYPCO(II)='NUME'
16921 2521   CONTINUE
16922        ITYPCO(2)='ALPH'
16923        IDIGIT(1)=1
16924        DO2523II=1,NUMROW
16925          DO2525JJ=1,NUMCOL
16926            NCVALU(II,JJ)=0
16927            IVALUZ(II,JJ)=' '
16928            NCVALU(II,JJ)=0
16929            AMAT(II,JJ)=0.0
16930            IF(JJ.EQ.2)THEN
16931              IVALUZ(II,JJ)='='
16932              NCVALU(II,JJ)=1
16933            ELSEIF(JJ.EQ.1)THEN
16934              AMAT(II,JJ)=APERC(II)
16935            ELSEIF(JJ.EQ.3)THEN
16936              AMAT(II,JJ)=BPERC(II)
16937            ENDIF
16938 2525     CONTINUE
16939 2523   CONTINUE
16940C
16941        IWHTML(1)=150
16942        IWHTML(2)=50
16943        IWHTML(3)=150
16944        IWRTF(1)=2000
16945        IWRTF(2)=IWRTF(1)+500
16946        IWRTF(3)=IWRTF(2)+2000
16947        IFRST=.TRUE.
16948        ILAST=.TRUE.
16949C
16950        CALL DPDTA4(ITITL9,NCTIT9,
16951     1              ITITLE,NCTITL,ITITL2,NCTIT2,
16952     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
16953     1              IVALUZ,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
16954     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
16955     1              ICAPSW,ICAPTY,IFRST,ILAST,
16956     1              ISUBRO,IBUGG3,IERROR)
16957C
16958        CALL DPDT8B(ALOWPA(1,1),AUPPPA(1,1),ALPHAV,NUMALP,
16959     1              ICAPSW,ICAPTY,NUMDIG,
16960     1              ISUBRO,IBUGG3,IERROR)
16961C
1696211000 CONTINUE
16963C
16964      NPLOTP=J
16965      NPLOTV=3
16966C
16967      IOP='CLOS'
16968      IFLAG1=1
16969      IFLAG2=1
16970      IFLAG3=0
16971      IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')IFLAG3=1
16972      IFLAG4=0
16973      IFLAG5=0
16974      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
16975     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
16976     1            IBUGG3,ISUBRO,IERROR)
16977      IF(IERROR.EQ.'YES')GOTO9000
16978C
16979        IF(IFEEDB.EQ.'ON')THEN
16980C
16981          WRITE(ICOUT,8102)
16982 8102     FORMAT('THE FOLLOWING INFORMATION IS WRITTEN TO FILES.')
16983          CALL DPWRST('XXX','BUG ')
16984          WRITE(ICOUT,999)
16985          CALL DPWRST('XXX','BUG ')
16986          WRITE(ICOUT,8104)
16987 8104     FORMAT('DPST1F.DAT: THE BOOTSTRAP VALUES.')
16988          CALL DPWRST('XXX','BUG ')
16989          WRITE(ICOUT,8106)
16990 8106     FORMAT('            FOR GROUPED DATA, THE FIRST ONE (OR ',
16991     1           'TWO) COLUMNS IDENTIFY THE GROUP(S).')
16992          CALL DPWRST('XXX','BUG ')
16993          WRITE(ICOUT,999)
16994          CALL DPWRST('XXX','BUG ')
16995          WRITE(ICOUT,8112)
16996 8112     FORMAT('DPST2F.DAT: STATISTICS BASED ON BOOTSTRAP VALUES.')
16997          CALL DPWRST('XXX','BUG ')
16998          WRITE(ICOUT,8114)
16999 8114     FORMAT('            MEAN, SD, MEDIAN, B025, ',
17000     1           'B975, B05, B95, B005, B995')
17001          CALL DPWRST('XXX','BUG ')
17002          IF(NUMPAR.GT.1)THEN
17003            WRITE(ICOUT,8118)
17004 8118       FORMAT('            THE FIRST COLUMN IDENTIFIES THE ',
17005     1             'PARAMETER.')
17006            CALL DPWRST('XXX','BUG ')
17007            WRITE(ICOUT,999)
17008            CALL DPWRST('XXX','BUG ')
17009          ENDIF
17010          WRITE(ICOUT,8116)
17011 8116     FORMAT('            FOR GROUPED DATA, THE FIRST ONE (OR ',
17012     1           'TWO) COLUMNS')
17013          CALL DPWRST('XXX','BUG ')
17014          WRITE(ICOUT,8117)
17015 8117     FORMAT('            (AFTER THE PARAMETER ID) IDENTIFY ',
17016     1           'THE GROUP(S).')
17017          CALL DPWRST('XXX','BUG ')
17018          WRITE(ICOUT,999)
17019          CALL DPWRST('XXX','BUG ')
17020C
17021        ENDIF
17022C
17023CCCCC ENDIF
17024C
17025      IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')THEN
17026C
17027        IF(IFEEDB.EQ.'ON')THEN
17028C
17029          WRITE(ICOUT,8102)
17030          CALL DPWRST('XXX','BUG ')
17031          WRITE(ICOUT,999)
17032          CALL DPWRST('XXX','BUG ')
17033          WRITE(ICOUT,8131)
17034 8131     FORMAT('DPST3F.DAT: BCa CONFIDENCE INTERVALS')
17035          CALL DPWRST('XXX','BUG ')
17036          WRITE(ICOUT,8132)
17037 8132     FORMAT('LOWER INTERVAL, UPPER INTERVAL, Z0HAT, A0HAT, ',
17038     1         'ALPHA1, ALPHA2, GROUP 1 ID, GROUP 2 ID')
17039          CALL DPWRST('XXX','BUG ')
17040          WRITE(ICOUT,8134)
17041 8134     FORMAT('WITH 4E15.7,2F8.4,2F10.0 FORMAT')
17042          CALL DPWRST('XXX','BUG ')
17043          WRITE(ICOUT,999)
17044          CALL DPWRST('XXX','BUG ')
17045C
17046        ENDIF
17047C
17048      ENDIF
17049C
17050C               ******************
17051C               **   STEP 90--  **
17052C               **   EXIT       **
17053C               ******************
17054C
17055 9000 CONTINUE
17056      IBCABT=IBCASV
17057      IBOOCI=IBOOC2
17058      IVRBCM=IVRBSV
17059      IDS4CM=IDS4SV
17060C
17061      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS6')THEN
17062        WRITE(ICOUT,999)
17063        CALL DPWRST('XXX','BUG ')
17064        WRITE(ICOUT,9011)
17065 9011   FORMAT('***** AT THE END       OF DPJBS6--')
17066        CALL DPWRST('XXX','BUG ')
17067        WRITE(ICOUT,9012)IBUGG3,ISUBRO,ICASJB,IBOOSS
17068 9012   FORMAT('IBUGG3,ISUBRO,ICASJB,IBOOSS = ',A4,2X,A4,2X,A4,I8)
17069        CALL DPWRST('XXX','BUG ')
17070        WRITE(ICOUT,9013)ICASPL,N,NUMSET,N2,IERROR
17071 9013   FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4)
17072        CALL DPWRST('XXX','BUG ')
17073        WRITE(ICOUT,9014)NPLOTV,NPLOTP
17074 9014   FORMAT('NPLOTV,NPLOTP = ',2I8)
17075        CALL DPWRST('XXX','BUG ')
17076        DO9020I=1,NPLOTP
17077          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
17078 9021     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
17079          CALL DPWRST('XXX','BUG ')
17080 9020   CONTINUE
17081      ENDIF
17082C
17083      RETURN
17084      END
17085      SUBROUTINE DPJBS7(Y,Z,XLEVEL,XDESGN,N,NUMV2,NGRPV,
17086     1                  ICASPL,ICASP2,IDIST,
17087     1                  ICENSO,ISIZE,ICONT,NPERC,KSLOC,KSSCAL,
17088     1                  IMETHD,ILEVEL,
17089     1                  ICASJB,IBOOSS,ISEED,IBCABT,ALPHA,
17090     1                  TEMP,TEMPZ,TEMP0,TEMPZ0,TEMPL,TEMPZL,
17091     1                  QP,XQP,XQPLCL,XQPUCL,
17092     1                  XIDTEM,XTEMP1,XTEMP2,XTEMP3,TEMP4,
17093     1                  ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,ZTEMP6,
17094     1                  ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,ZTMP12,
17095     1                  MAXNXT,MAXBGR,
17096     1                  ITEMP1,DTEMP1,DTEMP2,DTEMP3,
17097     1                  YLOWLM,YUPPLM,A,B,MINMAX,
17098     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
17099     1                  SHAPE6,SHAPE7,NUMSHA,
17100     1                  SHAP11,SHAP12,SHAP21,SHAP22,
17101     1                  Y2,X2,D2,NPLOTP,NPLOTV,
17102     1                  APERC,BPERC,NPERC2,
17103     1                  BMEAN,BSD,B001,B005,B01,B025,B05,B10,B20,B50,
17104     1                  B80,B90,B95,B975,B99,B995,B999,
17105     1                  ICAPSW,ICAPTY,IFORSW,IVARID,IVARI2,
17106     1                  CLLIMI,CLWIDT,IRELAT,
17107     1                  IFLAGL,AL,
17108     1                  ISUBRO,IBUGG3,IERROR)
17109C
17110C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
17111C              THAT WILL DEFINE A JACKNIFE OR BOOTSTRAP PLOT
17112C              (SEE DPJBSP FOR ALLOWABLE TYPES)
17113C
17114C              NOTE: THIS ROUTINE EXTRACTED FROM ORIGINAL DPJBS2.
17115C                    IT PERFORMS THE BOOTSTRAP FOR "DISTRIBUTIONS".
17116C                    THE BOOTSTRAP FOR STATISTICS WAS EXTRACTED TO
17117C                    DPJBS6.
17118C
17119C                    WITH THIS EXTRACTION, TAKE THE OPPORTUNITY TO
17120C                    SIMPLIFY THE CODE A BIT AS WELL.
17121C
17122C     WRITTEN BY--JAMES J. FILLIBEN
17123C                 STATISTICAL ENGINEERING DIVISION
17124C                 INFORMATION TECHNOLOGY LABORATORY
17125C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17126C                 GAITHERSBURG, MD 20899-8980
17127C                 PHONE--301-975-2899
17128C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17129C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17130C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
17131C     LANGUAGE--ANSI FORTRAN (1977)
17132C     VERSION NUMBER--2010/05
17133C     ORIGINAL VERSION--MAY       2010. EXTRACTED FROM DPJBS2
17134C     UPDATED         --AUGUST    2011. OPTION FOR ONE-SIDED PERCENTILES
17135C                                       (= ONE-SIDED TOLERANCE INTERVALS)
17136C     UPDATED         --AUGUST    2011. SOME MODIFICATIONS FOR BETTER
17137C                                       HANDLING CASES WHERE THERE ARE
17138C                                       ERRORS IN THE PARAMETER
17139C                                       ESTIMATES
17140C     UPDATED         --MARCH     2013. FOR WEIBULL, ADJUST SCALE
17141C                                       PARAMETER IF GAUGE LENGTH
17142C                                       OPTION SPECIFIED
17143C     UPDATED         --JULY      2019. CALL LIST TO CMPDIS
17144C     UPDATED         --JULY      2019. REMOVE ZTMP13, ZTMP14 FROM
17145C                                       CALL LIST
17146C
17147C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17148C
17149      CHARACTER*4 ICASPL
17150      CHARACTER*4 ICASP2
17151      CHARACTER*4 ICONT
17152      CHARACTER*4 ICENSO
17153      CHARACTER*4 IMETHD
17154      CHARACTER*4 ILEVEL
17155      CHARACTER*4 ICAPSW
17156      CHARACTER*4 ICAPTY
17157      CHARACTER*4 IFORSW
17158      CHARACTER*4 IRELAT
17159      CHARACTER*4 ISUBRO
17160      CHARACTER*4 IBUGG3
17161      CHARACTER*4 IERROR
17162C
17163      CHARACTER*60 IDIST
17164C
17165      CHARACTER*4 IFOUND
17166      CHARACTER*4 IWRITE
17167      CHARACTER*4 IBCABT
17168      CHARACTER*4 IOP
17169      CHARACTER*4 ICASJB
17170      CHARACTER*4 ILIMIT
17171      CHARACTER*4 ISUBN1
17172      CHARACTER*4 ISUBN2
17173      CHARACTER*4 ISTEPN
17174      CHARACTER*25 IFORMT
17175      CHARACTER*25 IFORMZ
17176C
17177      CHARACTER*4 IVARID(*)
17178      CHARACTER*4 IVARI2(*)
17179C
17180C---------------------------------------------------------------------
17181C
17182      INCLUDE 'DPCOPA.INC'
17183C
17184      DIMENSION Y(*)
17185      DIMENSION Z(*)
17186      DIMENSION XLEVEL(*)
17187      DIMENSION XDESGN(MAXNXT,MAXBGR)
17188      DIMENSION Y2(*)
17189      DIMENSION X2(*)
17190      DIMENSION D2(*)
17191C
17192      DIMENSION QP(*)
17193      DIMENSION XQP(*)
17194      DIMENSION XQPLCL(*)
17195      DIMENSION XQPUCL(*)
17196C
17197      DIMENSION TEMP(*)
17198      DIMENSION TEMPZ(*)
17199      DIMENSION TEMP0(*)
17200      DIMENSION TEMPZ0(*)
17201      DIMENSION TEMPL(*)
17202      DIMENSION TEMPZL(*)
17203      DIMENSION TEMP4(*)
17204      DIMENSION XIDTEM(MAXNXT,MAXBGR)
17205      DIMENSION XTEMP1(*)
17206      DIMENSION XTEMP2(*)
17207      DIMENSION XTEMP3(*)
17208C
17209      DIMENSION ZTEMP1(*)
17210      DIMENSION ZTEMP2(*)
17211      DIMENSION ZTEMP3(*)
17212      DIMENSION ZTEMP4(*)
17213      DIMENSION ZTEMP5(*)
17214      DIMENSION ZTEMP6(*)
17215      DIMENSION ZTEMP7(*)
17216      DIMENSION ZTEMP8(*)
17217      DIMENSION ZTEMP9(*)
17218      DIMENSION ZTMP10(*)
17219      DIMENSION ZTMP11(*)
17220      DIMENSION ZTMP12(*)
17221C
17222      DIMENSION CLWIDT(*)
17223      DIMENSION CLLIMI(*)
17224C
17225      PARAMETER (MAXPAR=9)
17226      DIMENSION APERC(*)
17227      DIMENSION BPERC(*)
17228      PARAMETER (NUMALP=8)
17229      DIMENSION ALPHAV(NUMALP)
17230      DIMENSION ALOWPA(NUMALP,MAXPAR)
17231      DIMENSION AUPPPA(NUMALP,MAXPAR)
17232      DIMENSION ZMEAN(MAXPAR)
17233      DIMENSION ZMED(MAXPAR)
17234      DIMENSION ZSD(MAXPAR)
17235      DIMENSION ZMAD(MAXPAR)
17236      INTEGER   NFAIL(MAXPAR)
17237C
17238      CHARACTER*25 IPAR
17239C
17240      DOUBLE PRECISION DTEMP1(*)
17241      DOUBLE PRECISION DTEMP2(*)
17242      DOUBLE PRECISION DTEMP3(*)
17243C
17244      INTEGER N
17245      INTEGER NUMSE1(10)
17246      INTEGER ITEMP1(*)
17247C
17248      REAL KSLOC
17249      REAL KSSCAL
17250      REAL KSLSAV
17251      REAL KSSSAV
17252C
17253      PARAMETER(NUMCLI=3)
17254      PARAMETER(MAXLIN=2)
17255      PARAMETER (MAXROW=20)
17256      CHARACTER*80 ITITLE
17257      CHARACTER*60 ITITLZ
17258      CHARACTER*1  ITITL9
17259      CHARACTER*50 ITEXT(MAXROW)
17260      REAL         AVALUE(MAXROW)
17261      INTEGER      NCTEXT(MAXROW)
17262      INTEGER      IDIGIT(MAXROW)
17263      INTEGER      NTOT(MAXROW)
17264      LOGICAL IFRST
17265      LOGICAL ILAST
17266C
17267C-----COMMON----------------------------------------------------------
17268C
17269      INCLUDE 'DPCOHK.INC'
17270      INCLUDE 'DPCOST.INC'
17271      INCLUDE 'DPCOP2.INC'
17272C
17273      DATA ALPHAV /0.50, 0.25, 0.10, 0.05, 0.025, 0.01, 0.005, 0.001/
17274C
17275C-----START POINT-----------------------------------------------------
17276C
17277      ISUBN1='JBS7'
17278      ISUBN2='    '
17279C
17280      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')THEN
17281        WRITE(ICOUT,70)
17282   70   FORMAT('AT THE BEGINNING OF DPJBS7--')
17283        CALL DPWRST('XXX','BUG ')
17284        WRITE(ICOUT,71)IBUGG3,ISUBRO,ICASJB,IBOOSS
17285   71   FORMAT('IBUGG3,ISUBRO,ICASJB,IBOOSS = ',A4,2X,A4,2X,A4,I8)
17286        CALL DPWRST('XXX','BUG ')
17287        WRITE(ICOUT,72)N,ICASPL,NUMV2,ISIZE,ICONT,NGRPV,NUMSHA
17288   72   FORMAT('N,ICASPL,NUMV2,ISIZE,ICONT,NGRPV,NUMSHA = ',
17289     1         I8,2X,A4,I8,I8,2X,A4,2X,2I4)
17290        CALL DPWRST('XXX','BUG ')
17291        DO73I=1,MIN(N,100)
17292          WRITE(ICOUT,74)I,Y(I),XDESGN(I,1),Z(I)
17293   74     FORMAT('I, Y(I),XDESGN(I,1),Z(I) = ',I8,3F15.7)
17294          CALL DPWRST('XXX','BUG ')
17295   73   CONTINUE
17296      ENDIF
17297C
17298      IWRITE='OFF'
17299      NUMPAR=NUMV2
17300      I2=0
17301      ISIZE2=0
17302      NUMSET=0
17303      DO120I=1,NGRPV
17304        NUMSE1(I)=0
17305  120 CONTINUE
17306C
17307      NACC=0
17308      NREJ=0
17309C
17310C     SPECIFY DISTRIBUTIONS THAT ESTIMATE LOWER/UPPER LIMIT
17311C     PARAMETERS RATHER THAN LOCATION/SCALE
17312C
17313      ILIMIT='OFF'
17314      IF(ICASPL.EQ.'UNIF')ILIMIT='ON'
17315      IF(ICASPL.EQ.'BETA')ILIMIT='ON'
17316      IF(ICASPL.EQ.'TRIA')ILIMIT='ON'
17317      IF(ICASPL.EQ.'POWF')ILIMIT='ON'
17318      IF(ICASPL.EQ.'RPOW')ILIMIT='ON'
17319      IF(ICASPL.EQ.'JOSB')ILIMIT='ON'
17320      IF(ICASPL.EQ.'TSPO')ILIMIT='ON'
17321      IF(ICASPL.EQ.'TOPL')ILIMIT='ON'
17322      IF(ICASPL.EQ.'GTOL')ILIMIT='ON'
17323      IF(ICASPL.EQ.'RGTL')ILIMIT='ON'
17324      IF(ICASPL.EQ.'SLOP')ILIMIT='ON'
17325      IF(ICASPL.EQ.'OGIV')ILIMIT='ON'
17326      IF(ICASPL.EQ.'TSSL')ILIMIT='ON'
17327      IF(ICASPL.EQ.'TSOG')ILIMIT='ON'
17328      IF(ICASPL.EQ.'KUMA')ILIMIT='ON'
17329      IF(ICASPL.EQ.'UTSP')ILIMIT='ON'
17330C
17331C     CHECK THE INPUT ARGUMENTS FOR ERRORS
17332C
17333      IF(N.LT.5)THEN
17334        WRITE(ICOUT,999)
17335  999   FORMAT(1X)
17336        CALL DPWRST('XXX','BUG ')
17337        WRITE(ICOUT,131)
17338  131   FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--')
17339        CALL DPWRST('XXX','BUG ')
17340        WRITE(ICOUT,132)
17341  132   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
17342     1         'VARIABLE MUST BE AT LEAST 5;')
17343        CALL DPWRST('XXX','BUG ')
17344        WRITE(ICOUT,134)N
17345  134   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
17346        CALL DPWRST('XXX','BUG ')
17347        WRITE(ICOUT,999)
17348        CALL DPWRST('XXX','BUG ')
17349        IERROR='YES'
17350        GOTO9000
17351      ENDIF
17352C
17353C               ********************************************************
17354C               **  STEP 1--                                          **
17355C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
17356C               **  FOR THE GROUP VARIABLE (USUALLY VAR. 2)           **
17357C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
17358C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
17359C               **  WHICH IS AN ERROR CONDITION FOR A PLOT.           **
17360C               ********************************************************
17361C
17362      ISTEPN='1'
17363      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')
17364     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17365C
17366      IF(NGRPV.GE.1)THEN
17367        NUMSET=1
17368        DO170J=1,NGRPV
17369          CALL DISTIN(XDESGN(1,J),N,IWRITE,XIDTEM(1,J),NUMSE1(J),
17370     1                IBUGG3,IERROR)
17371          CALL SORT(XIDTEM(1,J),NUMSE1(J),XIDTEM(1,J))
17372          NUMSET=NUMSET*NUMSE1(J)
17373C
17374          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')THEN
17375            WRITE(ICOUT,171)NGRPV,J,NUMSE1(J),NUMSET
17376  171       FORMAT('NGRPV,J,NUMSE1(J),NUMSET = ',4I8)
17377            CALL DPWRST('XXX','BUG ')
17378            DO172K=1,NUMSE1(J)
17379              WRITE(ICOUT,173)K,XIDTEM(K,J)
17380  173         FORMAT('K,XIDTEM(K,J) = ',I8,G15.7)
17381              CALL DPWRST('XXX','BUG ')
17382  172       CONTINUE
17383          ENDIF
17384C
17385          IF(NUMSE1(J).LT.1 .OR. NUMSE1(J).GE.N)THEN
17386            WRITE(ICOUT,999)
17387            CALL DPWRST('XXX','BUG ')
17388            WRITE(ICOUT,181)
17389  181       FORMAT('***** ERROR IN BOOTSTRAP/JACKNIFE PLOT--')
17390            CALL DPWRST('XXX','BUG ')
17391            WRITE(ICOUT,182)
17392  182       FORMAT('      THE NUMBER OF SETS FOR THE GROUP ONE ',
17393     1             'VARIABLE')
17394            CALL DPWRST('XXX','BUG ')
17395            WRITE(ICOUT,183)
17396  183       FORMAT('      IS ZERO OR EQUAL TO THE NUMBER OF POINTS.')
17397            CALL DPWRST('XXX','BUG ')
17398            WRITE(ICOUT,184)NUMSE1(J)
17399  184       FORMAT('      NUMBER OF SETS = ',I8)
17400            CALL DPWRST('XXX','BUG ')
17401            IERROR='YES'
17402            GOTO9000
17403          ENDIF
17404C
17405  170   CONTINUE
17406C
17407      ENDIF
17408C
17409      NUMDIG=7
17410      IF(IFORSW.EQ.'1')NUMDIG=1
17411      IF(IFORSW.EQ.'2')NUMDIG=2
17412      IF(IFORSW.EQ.'3')NUMDIG=3
17413      IF(IFORSW.EQ.'4')NUMDIG=4
17414      IF(IFORSW.EQ.'5')NUMDIG=5
17415      IF(IFORSW.EQ.'6')NUMDIG=6
17416      IF(IFORSW.EQ.'7')NUMDIG=7
17417      IF(IFORSW.EQ.'8')NUMDIG=8
17418      IF(IFORSW.EQ.'9')NUMDIG=9
17419      IF(IFORSW.EQ.'0')NUMDIG=0
17420      IF(IFORSW.EQ.'E')NUMDIG=-2
17421      IF(IFORSW.EQ.'-2')NUMDIG=-2
17422      IF(IFORSW.EQ.'-3')NUMDIG=-3
17423      IF(IFORSW.EQ.'-4')NUMDIG=-4
17424      IF(IFORSW.EQ.'-5')NUMDIG=-5
17425      IF(IFORSW.EQ.'-6')NUMDIG=-6
17426      IF(IFORSW.EQ.'-7')NUMDIG=-7
17427      IF(IFORSW.EQ.'-8')NUMDIG=-8
17428      IF(IFORSW.EQ.'-9')NUMDIG=-9
17429      ICNT9=0
17430C
17431      AN=N
17432      IF(NPERC.GT.999)NPEC=0
17433C
17434      IOP='OPEN'
17435      IFLAG1=1
17436      IFLAG2=1
17437      IFLAG3=0
17438      IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')IFLAG3=1
17439      IFLAG4=0
17440      IFLAG5=0
17441      IF(NPERC.GE.1)THEN
17442        IFLAG4=1
17443      ENDIF
17444      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
17445     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17446     1            IBUGG3,ISUBRO,IERROR)
17447      IF(IERROR.EQ.'YES')GOTO9000
17448C
17449C     HEADER FOR PERCENTILE FILE IF NEEDED
17450C
17451      IF(NPERC.GT.0)THEN
17452        IF(NGRPV.EQ.0)THEN
17453          IFORMT='(    E15.7)'
17454          IFORMZ='(    F15.3)'
17455          WRITE(IFORMT(3:5),'(I3)')NPERC
17456          WRITE(IFORMZ(3:5),'(I3)')NPERC
17457        ELSEIF(NGRPV.EQ.1)THEN
17458          IFORMT='(I8,1X,    E15.7)'
17459          IFORMZ='(9X,    F15.3)'
17460          WRITE(IFORMT(9:11),'(I3)')NPERC
17461          WRITE(IFORMZ(7:8),'(I3)')NPERC
17462        ELSEIF(NGRPV.EQ.2)THEN
17463          IFORMT='(I8,1X,I8,1X,    E15.7)'
17464          IFORMZ='(18X,    F15.3)'
17465          WRITE(IFORMT(15:17),'(I3)')NPERC
17466          WRITE(IFORMZ(8:9),'(I3)')NPERC
17467        ENDIF
17468        WRITE(IOUNI4,IFORMZ)(QP(JJ),JJ=1,NPERC)
17469      ENDIF
17470C
17471C               ******************************************
17472C               **  STEP 11--                           **
17473C               **  COMPUTE THE SPECIFIED STATISTIC     **
17474C               **  FOR EACH SUBSET OF THE DATA, AND    **
17475C               **  THEN FOR THE FULL DATA SET          **
17476C               ******************************************
17477C
17478      ISTEPN='11'
17479      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')
17480     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17481C
17482C     FOR PARAMETRIC BOOTSTRAP, COMPUTE INITIAL PARAMETER
17483C     ESTIMATES BASED ON FULL SAMPLE.
17484C
17485      KSLSAV=KSLOC
17486      KSSSAV=KSSCAL
17487CCCCC IF(IBOOPA.EQ.'PARA' .AND. ICENSO.EQ.'OFF')THEN
17488      IF(IBOOPA.EQ.'PARA' .AND. ICENSO.EQ.'OFF' .AND.
17489     1   ICASJB.EQ.'BOOT')THEN
17490        CALL CMPDIS(Y,Z,XLEVEL,N,MAXNXT,ICASPL,ICASP2,
17491     1              XTEMP1,XTEMP2,XTEMP3,
17492     1              DTEMP1,DTEMP2,DTEMP3,ITEMP1,
17493     1              ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,ZTEMP6,
17494     1              ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
17495     1              YLOWLM,YUPPLM,A,B,MINMAX,NUMSHA,
17496     1              SHAP11,SHAP12,SHAP21,SHAP22,
17497     1              IADEDF,IGEPDF,IMAKDF,IBEIDF,
17498     1              ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
17499     1              IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
17500     1              IEXPBC,IWEIBC,ICENTY,IDFTTY,
17501     1              MAXNXT,ICENSO,KSLOC,KSSCAL,IFORSW,ISEED,
17502     1              IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
17503     1              IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
17504     1              CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
17505     1              SH1,SH2,SH3,SH4,SH5,SH6,SH7,ALOC,ASCALE,STATVA,
17506     1              IBUGG3,ISUBRO,IERROR)
17507        IF(IERROR.EQ.'YES')THEN
17508          WRITE(ICOUT,999)
17509          CALL DPWRST('XXX','BUG ')
17510          WRITE(ICOUT,131)
17511          CALL DPWRST('XXX','BUG ')
17512          WRITE(ICOUT,901)
17513  901     FORMAT('      FOR PARAMETRIC BOOTSTRAP, UNABLE TO COMPUTE')
17514          CALL DPWRST('XXX','BUG ')
17515          WRITE(ICOUT,903)
17516  903     FORMAT('      PARAMETER ESTIMATES FROM ORIGINAL SAMPLE.')
17517          CALL DPWRST('XXX','BUG ')
17518          GOTO9000
17519        ENDIF
17520C
17521        IF(IFLAGL.EQ.1 .AND. AL.GT.0.0 .AND. SH1.GT.0.0)THEN
17522          ASCALE=AL**(1.0/SH1)*ASCALE
17523        ENDIF
17524C
17525        IF(ILIMIT.EQ.'ON' .AND.
17526     1    (ICASP2.EQ.'PPCC' .OR. ICASP2.EQ.'AD  ' .OR.
17527     1     ICASP2.EQ.'KS  '))THEN
17528          AVAL=KSLOC + KSSCAL
17529          KSSCAL=AVAL
17530        ENDIF
17531      ENDIF
17532C
17533      J=0
17534      J2=0
17535      ISETMX=NUMSET+1
17536      NMAX=N
17537C
17538      DO11000ISET=1,ISETMX
17539C
17540        ISTEPN='12'
17541        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')
17542     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17543C
17544        CALL DPJBS8(ISETMX,ISET,NUMSET,NUMSE1,N,N,NGRPV,
17545     1              MAXNXT,MAXBGR,NUMV2,
17546     1              Y,Z,XLEVEL,XDESGN,XIDTEM,TEMP0,TEMPZ0,TEMPL,
17547     1              NS2,NSS2,NI,NI2,ISET1,ISET2,
17548     1              ISUBRO,IBUGG3,IERROR)
17549C
17550        NRESAM=NS2
17551        IF(ICASJB.EQ.'BOOT')NRESAM=IBOOSS
17552C
17553        IF(NPERC.GE.1)THEN
17554          IOP='OPEN'
17555          IFLAG1=0
17556          IFLAG2=0
17557          IFLAG3=0
17558          IFLAG4=0
17559          IFLAG5=1
17560          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
17561     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17562     1                IBUGG3,ISUBRO,IERROR)
17563          IF(IERROR.EQ.'YES')GOTO9000
17564        ENDIF
17565C
17566C       SIMPLIFY CODE BY USING "CMPDIS" TO COMPUTE DISTRIBUTION
17567C       PARAMETERS.  NOTE THAT THE DISTRIBUTIONAL BOOTSTRAP
17568C       ASSUMES A SINGLE RESPONSE VARIABLE.  ALSO THE BCA CONFIDENCE
17569C       INTERVAL METHOD IS NOT CURRENTLY SUPPORTED FOR THE
17570C       DISTRIBUTIONAL BOOTSTRAP.
17571C
17572        TAGID=1.0
17573        DO11361IRESAM=1,NRESAM
17574C
17575C         STEP 1: THERE ARE TWO METHODS FOR RESAMPLING:
17576C
17577C                 1) RESAMPLE THE ORIGINAL DATA.
17578C                 2) GENERATE A RANDOM SAMPLE BASED ON PARAMETER
17579C                    ESTIMATES FROM FULL SAMPLE.
17580C
17581C                    THIS METHOD IS NOT SUPPORTED FOR CENSORED DATA.
17582C
17583          IF(IBOOPA.EQ.'PARA' .AND. ICENSO.EQ.'OFF' .AND.
17584     1       ICASJB.EQ.'BOOT')THEN
17585            CALL DPRAN2(ICASP2,ISEED,TEMP,NS2,ZTMP12,
17586     1                  A,B,MINMAX,
17587     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
17588     1                  SHAPE6,SHAPE7,
17589     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
17590     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
17591     1                  IGOMDF,IKATDF,IGIGDF,IGEODF,
17592     1                  IBUGG3,ISUBRO,IFOUND,IERROR)
17593          ELSE
17594            CALL DPJBS3(TEMP0,NS2,ICASJB,IRESAM,ISEED,TEMP,NS3,ITEMP1,
17595     1                  TEMP4,IBUGG3,IERROR)
17596            IF(ICENSO.EQ.'ON')THEN
17597              NS32=NS3
17598              DO11363IJ=1,NS3
17599                TEMPZ(IJ)=TEMPZ0(ITEMP1(IJ))
17600                IF(ILEVEL.EQ.'ON')THEN
17601                  TEMPZL(IJ)=TEMPL(ITEMP1(IJ))
17602                ENDIF
1760311363         CONTINUE
17604            ENDIF
17605          ENDIF
17606C
17607C         STEP 2: COMPUTE THE STATISTIC
17608C
17609          KSLOC=KSLSAV
17610          KSSCAL=KSSSAV
17611          IF(ICASPL.EQ.'BFWE')SH2=SHAPE2
17612          CALL CMPDIS(TEMP,TEMPZ,TEMPZL,NS2,MAXNXT,ICASPL,ICASP2,
17613     1                XTEMP1,XTEMP2,XTEMP3,
17614     1                DTEMP1,DTEMP2,DTEMP3,ITEMP1,
17615     1                ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,ZTEMP6,
17616     1                ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,ZTMP11,
17617     1                YLOWLM,YUPPLM,A,B,MINMAX,NUMSHA,
17618     1                SHAP11,SHAP12,SHAP21,SHAP22,
17619     1                IADEDF,IGEPDF,IMAKDF,IBEIDF,
17620     1                ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
17621     1                IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
17622     1                IEXPBC,IWEIBC,ICENTY,IDFTTY,
17623     1                MAXNXT,ICENSO,KSLOC,KSSCAL,IFORSW,ISEED,
17624     1                IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,
17625     1                IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,
17626     1                CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
17627     1                SH1,SH2,SH3,SH4,SH5,SH6,SH7,ALOC,ASCALE,STATVA,
17628     1                IBUGG3,ISUBRO,IERROR)
17629CCCCC     IF(IERROR.EQ.'YES')GOTO9000
17630C
17631C         NOTE 09/2010: WHEN THERE IS A "LENGTH" VARIABLE, (I.E., THE
17632C                       BRITTLE FIBER WEIBULL DISTRIBUTION), THE
17633C                       STANDARD METHOD FOR COMPUTING THE PERCENTILES
17634C                       (USE ESTIMATES OF DISTRIBUTIONAL PARAMETERS IN
17635C                       THE PERCENT POINT FUNCTION) CANNOT BE
17636C                       IMPLEMENTED.
17637C
17638C                       AN ALTERNATIVE IS TO COMPUTE DATA PERCENTILES.
17639C
17640C                       SET QUANTILE TO CPUMIN IF THERE WAS AN ERROR
17641C                       IN THE ESTIMATION STEP.
17642C
17643          IF(IFLAGL.EQ.1 .AND. AL.GT.0.0 .AND. SH1.GT.0.0)THEN
17644            ASCALE=AL**(1.0/SH1)*ASCALE
17645          ENDIF
17646C
17647          IF(NPERC.GT.0 .AND. NPERC.LE.1000)THEN
17648            IF(IERROR.EQ.'YES')THEN
17649              DO12112I=1,NPERC
17650                XQP(I)=CPUMIN
1765112112         CONTINUE
17652            ELSE
17653              IF(IBOOPE.EQ.'DATA' .OR. ILEVEL.EQ.'YES')THEN
17654                DO12110I=1,NPERC
17655                  ATEMP=QP(I)
17656                  CALL PERCEN(ATEMP,TEMP,NS2,IWRITE,ZTMP12,MAXNXT,
17657     1                        BTEMP,IBUGG3,IERROR)
17658                  XQP(I)=BTEMP
1765912110           CONTINUE
17660              ELSE
17661                CALL DPPPF1(QP,XQP,NPERC,ICASPL,
17662     1                      SH1,SH2,SH3,SH4,
17663     1                      SH5,SH6,SH7,
17664     1                      YLOWLM,YUPPLM,A,B,MINMAX,
17665     1                      ICAPSW,ICAPTY,
17666     1                      IADEDF,IGEPDF,IMAKDF,IBEIDF,
17667     1                      ILGADF,ISKNDF,IGLDDF,IBGEDF,
17668     1                      IGETDF,ICONDF,IGOMDF,IKATDF,
17669     1                      IGIGDF,IGEODF,
17670     1                      ALOC,ASCALE,
17671     1                      IBUGG3,ISUBRO,IERROR)
17672              ENDIF
17673            ENDIF
17674C
17675            IF((NGRPV.GE.1 .AND. NPERC.GT.0 .AND. ISET.LE.NUMSET) .OR.
17676     1         (NPERC.GT.0 .AND. NGRPV.EQ.0 .AND. ISET.EQ.1))THEN
17677              IF(NGRPV.EQ.0)THEN
17678                WRITE(IOUNI4,IFORMT)(XQP(JJ),JJ=1,NPERC)
17679                WRITE(IOUNI5,'(30E15.7)')(XQP(JJ),JJ=1,MIN(30,NPERC))
17680              ELSEIF(NGRPV.EQ.1)THEN
17681                WRITE(IOUNI4,IFORMT)ISET,(XQP(JJ),JJ=1,NPERC)
17682                WRITE(IOUNI5,'(30E15.7)')(XQP(JJ),JJ=1,MIN(30,NPERC))
17683              ELSEIF(NGRPV.EQ.2)THEN
17684                WRITE(IOUNI4,IFORMT)ISET1,ISET2,(XQP(JJ),JJ=1,NPERC)
17685                WRITE(IOUNI5,'(30E15.7)')(XQP(JJ),JJ=1,MIN(30,NPERC))
17686              ENDIF
17687            ENDIF
17688          ENDIF
17689C
17690          IF(ILIMIT.EQ.'ON' .AND.
17691     1      (ICASP2.EQ.'PPCC' .OR. ICASP2.EQ.'AD  ' .OR.
17692     1       ICASP2.EQ.'KS  '))THEN
17693            AVAL=ALOC + ASCALE
17694            ASCALE=AVAL
17695          ENDIF
17696          IF(NGRPV.LE.1)THEN
17697            TAGID=0.0
17698            IF(ALOC.NE.CPUMIN)THEN
17699              TAGID=TAGID+1.0
17700              CALL DPJBS4(ISET,NUMSET,J,J2,ALOC,TAGID,XIDTEM(1,1),
17701     1                    Y2,X2,D2)
17702            ENDIF
17703            IF(ASCALE.NE.CPUMIN)THEN
17704              TAGID=TAGID+1.0
17705              CALL DPJBS4(ISET,NUMSET,J,J2,ASCALE,TAGID,XIDTEM(1,1),
17706     1                    Y2,X2,D2)
17707            ENDIF
17708            IF(NUMSHA.GE.1 .AND. SH1.NE.CPUMIN)THEN
17709              TAGID=TAGID+1.0
17710              CALL DPJBS4(ISET,NUMSET,J,J2,SH1,TAGID,XIDTEM(1,1),
17711     1                    Y2,X2,D2)
17712            ENDIF
17713            IF(NUMSHA.GE.2 .AND. SH2.NE.CPUMIN)THEN
17714              TAGID=TAGID+1.0
17715              CALL DPJBS4(ISET,NUMSET,J,J2,SH2,TAGID,XIDTEM(1,1),
17716     1                    Y2,X2,D2)
17717            ENDIF
17718            IF(NUMSHA.GE.3 .AND. SH3.NE.CPUMIN)THEN
17719              TAGID=TAGID+1.0
17720              CALL DPJBS4(ISET,NUMSET,J,J2,SH3,TAGID,XIDTEM(1,1),
17721     1                    Y2,X2,D2)
17722            ENDIF
17723            IF(NUMSHA.GE.4 .AND. SH4.NE.CPUMIN)THEN
17724              TAGID=TAGID+1.0
17725              CALL DPJBS4(ISET,NUMSET,J,J2,SH4,TAGID,XIDTEM(1,1),
17726     1                    Y2,X2,D2)
17727            ENDIF
17728            IF(NUMSHA.GE.5 .AND. SH5.NE.CPUMIN)THEN
17729              TAGID=TAGID+1.0
17730              CALL DPJBS4(ISET,NUMSET,J,J2,SH5,TAGID,XIDTEM(1,1),
17731     1                    Y2,X2,D2)
17732            ENDIF
17733            IF(ICASP2.EQ.'PPCC' .OR. ICASP2.EQ.'KS' .OR.
17734     1         ICASP2.EQ.'AD' .AND. STATVA.NE.CPUMIN)THEN
17735              TAGID=TAGID+1.0
17736              CALL DPJBS4(ISET,NUMSET,J,J2,STATVA,TAGID,XIDTEM(1,1),
17737     1                    Y2,X2,D2)
17738            ENDIF
17739            NUMPAR=INT(TAGID+0.1)
17740          ELSEIF(NGRPV.EQ.2)THEN
17741            NUMPAR=0
17742            IF(ALOC.NE.CPUMIN)THEN
17743              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,ALOC,
17744     1                    XIDTEM(1,1),Y2,X2,D2)
17745              NUMPAR=NUMPAR+1
17746            ENDIF
17747            IF(ASCALE.NE.CPUMIN)THEN
17748              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,ASCALE,
17749     1                    XIDTEM(1,1),Y2,X2,D2)
17750              NUMPAR=NUMPAR+1
17751            ENDIF
17752            IF(NUMSHA.GE.1 .AND. SH1.NE.CPUMIN)THEN
17753              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,SH1,
17754     1                    XIDTEM(1,1),Y2,X2,D2)
17755              NUMPAR=NUMPAR+1
17756            ENDIF
17757            IF(NUMSHA.GE.2 .AND. SH2.NE.CPUMIN)THEN
17758              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,SH2,
17759     1                    XIDTEM(1,1),Y2,X2,D2)
17760              NUMPAR=NUMPAR+1
17761            ENDIF
17762            IF(NUMSHA.GE.3 .AND. SH3.NE.CPUMIN)THEN
17763              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,SH3,
17764     1                    XIDTEM(1,1),Y2,X2,D2)
17765              NUMPAR=NUMPAR+1
17766            ENDIF
17767            IF(NUMSHA.GE.4 .AND. SH4.NE.CPUMIN)THEN
17768              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,SH4,
17769     1                    XIDTEM(1,1),Y2,X2,D2)
17770              NUMPAR=NUMPAR+1
17771            ENDIF
17772            IF(NUMSHA.GE.5 .AND. SH5.NE.CPUMIN)THEN
17773              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,SH5,
17774     1                    XIDTEM(1,1),Y2,X2,D2)
17775              NUMPAR=NUMPAR+1
17776            ENDIF
17777            IF(ICASP2.EQ.'PPCC' .OR. ICASP2.EQ.'KS' .OR.
17778     1         ICASP2.EQ.'AD' .AND. STATVA.NE.CPUMIN)THEN
17779              CALL DPJBS5(ISET1,ISET2,NUMSE1(2),J,STATVA,
17780     1                    XIDTEM(1,1),Y2,X2,D2)
17781              NUMPAR=NUMPAR+1
17782            ENDIF
17783          ENDIF
1778411361   CONTINUE
17785C
17786C               ************************************************
17787C               **   STEP 19--                                **
17788C               **   FOR GROUPED DATA, WRITE GROUP-ID, MEAN,  **
17789C               **   MEDIAN, B025, B975, B05, B90, B005, B995 **
17790C               **   TO DPST1F.DAT.                           **
17791C               ************************************************
17792C
17793CCCCC JANUARY 2005.  FOR UNGROUPED DATA, WRITE BOOTSTRAP ESTIMATES
17794CCCCC                TO FILE.  ALSO, ACCOMODATE CASE WHERE MORE
17795CCCCC                THAN ONE PARAMETER IS ESTIMATED.
17796C
17797        IF(NPERC.GE.1)THEN
17798          IOP='CLOS'
17799          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
17800     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17801     1                IBUGG3,ISUBRO,IERROR)
17802        ENDIF
17803C
17804        DO6131II=1,NUMALP
17805          DO6133JJ=1,9
17806            ALOWPA(II,JJ)=CPUMIN
17807            AUPPPA(II,JJ)=CPUMIN
17808 6133     CONTINUE
17809 6131     CONTINUE
17810C
17811        ISTEPN='19'
17812        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')
17813     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17814C
17815        CALL DPJBS9(Y2,D2,TEMP,XTEMP1,XTEMP2,MAXNXT,IOUNI1,IOUNI2,
17816     1              NUMPAR,NGRPV,NUMSET,ISET,ISET1,ISET2,NUMSE1,J,
17817     1              APERC,BPERC,NPERC2,
17818     1              BMEAN,BSD,BMIN,BMAX,BMAD,
17819     1              B001,B005,B01,B025,B05,B10,B20,B50,
17820     1              B80,B90,B95,B975,B99,B995,B999,
17821     1              ALOWPA,AUPPPA,ALPHAV,NUMALP,
17822     1              ZMEAN,ZMED,ZSD,ZMAD,NFAIL,
17823     1              ISUBRO,IBUGG3,IERROR)
17824C
17825         DO6139II=1,NUMPAR
17826           NFAIL(II)=NRESAM - NFAIL(II)
17827 6139    CONTINUE
17828C
17829C       ************************************************
17830C       **   STEP 20--                                **
17831C       **   GENERATE  A NUMERIC TABLE OF THE RESULTS **
17832C       ************************************************
17833C
17834        IF(IPRINT.EQ.'OFF')GOTO11000
17835C
17836        ISTEPN='20'
17837        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')
17838     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17839C
17840        ICNT9=ICNT9+1
17841        IF(ICNT9.EQ.1)THEN
17842          IF(ICASP2.EQ.'PPCC')THEN
17843            ITITLE(1:32)='PPCC Bootstrap Analysis for the '
17844            NCTITL=32
17845          ELSEIF(ICASP2.EQ.'KS')THEN
17846            ITITLE(1:19)='Kolmogorov-Smirnov '
17847            ITITLE(20:46)='Bootstrap Analysis for the '
17848            NCTITL=46
17849          ELSEIF(ICASP2.EQ.'AD')THEN
17850            ITITLE(1:17)='Anderson-Darling '
17851            ITITLE(18:44)='Bootstrap Analysis for the '
17852            NCTITL=44
17853          ELSEIF(ICASP2.EQ.'MLE')THEN
17854            ITITLE(1:19)='Maximum Likelihood '
17855            ITITLE(20:46)='Bootstrap Analysis for the '
17856            NCTITL=46
17857          ENDIF
17858          DO8211II=60,1,-1
17859            IF(IDIST(II:II).NE.' ')THEN
17860               NCDIST=II
17861               GOTO8219
17862            ENDIF
17863 8211     CONTINUE
17864          NCDIST=1
17865 8219     CONTINUE
17866          ITITLZ(1:NCDIST)=IDIST(1:NCDIST)
17867          NSTRT=NCDIST+1
17868          NCTITZ=NSTRT+12
17869          ITITLZ(NSTRT:NCTITZ)=' Distribution'
17870        ELSE
17871          ITITLE=' '
17872          NCTITL=0
17873          ITITLZ=' '
17874          NCTITZ=0
17875        ENDIF
17876C
17877        ICNT=1
17878        ITEXT(ICNT)=' '
17879        NCTEXT(ICNT)=0
17880        AVALUE(ICNT)=0.0
17881        IDIGIT(ICNT)=-1
17882        ICNT=ICNT+1
17883        ITEXT(ICNT)='Response Variable: '
17884        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
17885        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
17886        NCTEXT(ICNT)=27
17887        AVALUE(ICNT)=0.0
17888        IDIGIT(ICNT)=-1
17889        IF(NGRPV.EQ.1)THEN
17890          ICNT=ICNT+1
17891          ITEXT(ICNT)='Group ID Variable One (        ): '
17892          IF(ISET.LE.0 .OR. ISET.EQ.ISETMX)THEN
17893            ITEXT(ICNT)(24:31)='All Data'
17894            AVALUE(ICNT)=0.0
17895            IDIGIT(ICNT)=-1
17896          ELSE
17897            WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARID(NUMV2+1)(1:4)
17898            WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI2(NUMV2+1)(1:4)
17899            AVALUE(ICNT)=XIDTEM(ISET,1)
17900            IDIGIT(ICNT)=NUMDIG
17901          ENDIF
17902          NCTEXT(ICNT)=34
17903        ENDIF
17904C
17905        IF(NGRPV.GE.2)THEN
17906          ICNT=ICNT+1
17907          ITEXT(ICNT)='Group ID Variable One (        ): '
17908          IF(ISET1.LE.0 .OR. ISET1.EQ.ISETMX)THEN
17909            ITEXT(ICNT)(24:31)='All Data'
17910          ELSE
17911            WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARID(NUMV2+1)(1:4)
17912            WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI2(NUMV2+1)(1:4)
17913          ENDIF
17914          NCTEXT(ICNT)=34
17915          AVALUE(ICNT)=XIDTEM(ISET1,1)
17916          IDIGIT(ICNT)=NUMDIG
17917          ICNT=ICNT+1
17918          ITEXT(ICNT)='Group ID Variable Two (        ): '
17919          IF(ISET2.LE.0 .OR. ISET2.EQ.ISETMX)THEN
17920            ITEXT(ICNT)(24:31)='All Data'
17921          ELSE
17922            WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARID(NUMV2+2)(1:4)
17923            WRITE(ITEXT(ICNT)(28:31),'(A4)')IVARI2(NUMV2+2)(1:4)
17924          ENDIF
17925          NCTEXT(ICNT)=34
17926          AVALUE(ICNT)=XIDTEM(ISET2,2)
17927          IDIGIT(ICNT)=NUMDIG
17928        ENDIF
17929C
17930        ICNT=ICNT+1
17931        ITEXT(ICNT)=' '
17932        NCTEXT(ICNT)=1
17933        AVALUE(ICNT)=0.0
17934        IDIGIT(ICNT)=-1
17935C
17936        ICNT=ICNT+1
17937        ITEXT(ICNT)='Number of Bootstrap Samples:'
17938        NCTEXT(ICNT)=28
17939        AVALUE(ICNT)=REAL(NRESAM)
17940        IDIGIT(ICNT)=0
17941        ICNT=ICNT+1
17942        ITEXT(ICNT)='Number of Observations:'
17943        NCTEXT(ICNT)=23
17944        AVALUE(ICNT)=REAL(NS3)
17945        IDIGIT(ICNT)=0
17946C
17947        IF(ICASP2.EQ.'PPCC' .OR. ICASP2.EQ.'AD' .OR.
17948     1     ICASP2.EQ.'KS')THEN
17949          IF(NUMSHA.GE.1)THEN
17950            ICNT=ICNT+1
17951            ITEXT(ICNT)='Lower Limit for Shape Parameter 1:'
17952            NCTEXT(ICNT)=34
17953            AVALUE(ICNT)=SHAP11
17954            IDIGIT(ICNT)=NUMDIG
17955            ICNT=ICNT+1
17956            ITEXT(ICNT)='Upper Limit for Shape Parameter 1:'
17957            NCTEXT(ICNT)=34
17958            AVALUE(ICNT)=SHAP12
17959            IDIGIT(ICNT)=NUMDIG
17960          ENDIF
17961          IF(NUMSHA.GE.2)THEN
17962            ICNT=ICNT+1
17963            ITEXT(ICNT)='Lower Limit for Shape Parameter 2:'
17964            NCTEXT(ICNT)=34
17965            AVALUE(ICNT)=SHAP21
17966            IDIGIT(ICNT)=NUMDIG
17967            ICNT=ICNT+1
17968            ITEXT(ICNT)='Upper Limit for Shape Parameter 2:'
17969            NCTEXT(ICNT)=34
17970            AVALUE(ICNT)=SHAP22
17971            IDIGIT(ICNT)=NUMDIG
17972          ENDIF
17973        ENDIF
17974C
17975        ICNT=ICNT+1
17976        ITEXT(ICNT)=' '
17977        NCTEXT(ICNT)=0
17978        AVALUE(ICNT)=0.0
17979        IDIGIT(ICNT)=-1
17980C
17981        NUMROW=ICNT
17982        DO8311II=1,NUMROW
17983          NTOT(II)=15
17984 8311   CONTINUE
17985C
17986        IFRST=.TRUE.
17987        ILAST=.TRUE.
17988        CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
17989     1              AVALUE,IDIGIT,
17990     1              NTOT,NUMROW,
17991     1              ICAPSW,ICAPTY,ILAST,IFRST,
17992     1              ISUBRO,IBUGG3,IERROR)
17993        ITITLE=' '
17994        NCTITL=0
17995        ITITL9=' '
17996        NCTIT9=0
17997C
17998C       PRINT CONFIDENCE LIMITS FOR:
17999C
18000C       1) LOCATION PARAMETER
18001C       2) SCALE PARAMETER
18002C       3) SHAPE PARAMETER 1 - SHAPE PARAMETER 5
18003C       4) VALUE OF TEST STATISTIC
18004C
18005        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')THEN
18006          WRITE(ICOUT,8321)
18007 8321     FORMAT('ALOWPA MATRIX:')
18008          CALL DPWRST('XXX','BUG ')
18009          DO8320L=1,NUMALP
18010            WRITE(ICOUT,8322)(ALOWPA(L,JJ),JJ=1,NUMPAR)
18011 8322       FORMAT(7G15.7)
18012            CALL DPWRST('XXX','BUG ')
18013 8320     CONTINUE
18014          WRITE(ICOUT,8331)
18015 8331     FORMAT('AUPPPA MATRIX:')
18016          CALL DPWRST('XXX','BUG ')
18017          DO8330L=1,NUMALP
18018            WRITE(ICOUT,8322)(AUPPPA(L,JJ),JJ=1,NUMPAR)
18019            CALL DPWRST('XXX','BUG ')
18020 8330     CONTINUE
18021        ENDIF
18022C
18023        ITAG=0
18024        ITITLE=' '
18025        NCTITL=0
18026        ITITL9=' '
18027        NCTIT9=0
18028        ITITLZ=' '
18029        NCTITZ=0
18030C
18031C       LOCATION PARAMETER:
18032C
18033        IF(ALOC.NE.CPUMIN)THEN
18034          ITAG=ITAG+1
18035C
18036          ICNT=1
18037          ITEXT(ICNT)=' '
18038          NCTEXT(ICNT)=0
18039          AVALUE(ICNT)=0.0
18040          IDIGIT(ICNT)=-1
18041          ICNT=ICNT+1
18042          ITEXT(ICNT)='Location Parameter:'
18043          NCTEXT(ICNT)=19
18044          AVALUE(ICNT)=0.0
18045          IDIGIT(ICNT)=-1
18046C
18047          ICNT=ICNT+1
18048          ITEXT(ICNT)='Number of Failed Bootstrap Samples:'
18049          NCTEXT(ICNT)=35
18050          AVALUE(ICNT)=REAL(NFAIL(ITAG))
18051          IDIGIT(ICNT)=0
18052          ICNT=ICNT+1
18053          ITEXT(ICNT)='Mean:'
18054          NCTEXT(ICNT)=5
18055          AVALUE(ICNT)=ZMEAN(ITAG)
18056          IDIGIT(ICNT)=NUMDIG
18057          ICNT=ICNT+1
18058          ITEXT(ICNT)='Median:'
18059          NCTEXT(ICNT)=7
18060          AVALUE(ICNT)=ZMED(ITAG)
18061          IDIGIT(ICNT)=NUMDIG
18062          ICNT=ICNT+1
18063          ITEXT(ICNT)='Standard Deviation:'
18064          NCTEXT(ICNT)=19
18065          AVALUE(ICNT)=ZSD(ITAG)
18066          IDIGIT(ICNT)=NUMDIG
18067          ICNT=ICNT+1
18068          ITEXT(ICNT)='Median Absolute Deviation:'
18069          NCTEXT(ICNT)=27
18070          AVALUE(ICNT)=ZMAD(ITAG)
18071          IDIGIT(ICNT)=NUMDIG
18072C
18073          ICNT=ICNT+1
18074          ITEXT(ICNT)=' '
18075          NCTEXT(ICNT)=0
18076          AVALUE(ICNT)=0.0
18077          IDIGIT(ICNT)=-1
18078C
18079          NUMROW=ICNT
18080          DO8312II=1,NUMROW
18081            NTOT(II)=15
18082 8312     CONTINUE
18083C
18084          IFRST=.TRUE.
18085          ILAST=.TRUE.
18086          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
18087     1                AVALUE,IDIGIT,
18088     1                NTOT,NUMROW,
18089     1                ICAPSW,ICAPTY,ILAST,IFRST,
18090     1                ISUBRO,IBUGG3,IERROR)
18091C
18092          IPAR='Location'
18093          NCPAR=8
18094          IF(ILIMIT.EQ.'ON')THEN
18095            IPAR='Lower Limit'
18096            NCPAR=11
18097          ENDIF
18098          CALL DPDT8C(ALOWPA(1,ITAG),AUPPPA(1,ITAG),ALPHAV,NUMALP,
18099     1                ICAPSW,ICAPTY,NUMDIG,IPAR,NCPAR,
18100     1                ISUBRO,IBUGG3,IERROR)
18101        ENDIF
18102C
18103C       SCALE PARAMETER:
18104C
18105        IF(ASCALE.NE.CPUMIN)THEN
18106          ITAG=ITAG+1
18107C
18108          ICNT=1
18109          ITEXT(ICNT)=' '
18110          NCTEXT(ICNT)=0
18111          AVALUE(ICNT)=0.0
18112          IDIGIT(ICNT)=-1
18113          ICNT=ICNT+1
18114          ITEXT(ICNT)='Scale Parameter:'
18115          NCTEXT(ICNT)=16
18116          AVALUE(ICNT)=0.0
18117          IDIGIT(ICNT)=-1
18118C
18119          ICNT=ICNT+1
18120          ITEXT(ICNT)='Number of Failed Bootstrap Samples:'
18121          NCTEXT(ICNT)=35
18122          AVALUE(ICNT)=REAL(NFAIL(ITAG))
18123          IDIGIT(ICNT)=0
18124          ICNT=ICNT+1
18125          ITEXT(ICNT)='Mean:'
18126          NCTEXT(ICNT)=5
18127          AVALUE(ICNT)=ZMEAN(ITAG)
18128          IDIGIT(ICNT)=NUMDIG
18129          ICNT=ICNT+1
18130          ITEXT(ICNT)='Median:'
18131          NCTEXT(ICNT)=7
18132          AVALUE(ICNT)=ZMED(ITAG)
18133          IDIGIT(ICNT)=NUMDIG
18134          ICNT=ICNT+1
18135          ITEXT(ICNT)='Standard Deviation:'
18136          NCTEXT(ICNT)=19
18137          AVALUE(ICNT)=ZSD(ITAG)
18138          IDIGIT(ICNT)=NUMDIG
18139          ICNT=ICNT+1
18140          ITEXT(ICNT)='Median Absolute Deviation:'
18141          NCTEXT(ICNT)=27
18142          AVALUE(ICNT)=ZMAD(ITAG)
18143          IDIGIT(ICNT)=NUMDIG
18144C
18145          ICNT=ICNT+1
18146          ITEXT(ICNT)=' '
18147          NCTEXT(ICNT)=0
18148          AVALUE(ICNT)=0.0
18149          IDIGIT(ICNT)=-1
18150C
18151          NUMROW=ICNT
18152          DO8313II=1,NUMROW
18153            NTOT(II)=15
18154 8313     CONTINUE
18155C
18156          IFRST=.TRUE.
18157          ILAST=.TRUE.
18158          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
18159     1                AVALUE,IDIGIT,
18160     1                NTOT,NUMROW,
18161     1                ICAPSW,ICAPTY,ILAST,IFRST,
18162     1                ISUBRO,IBUGG3,IERROR)
18163C
18164          IPAR='Scale'
18165          NCPAR=5
18166          IF(ILIMIT.EQ.'ON')THEN
18167            IPAR='Upper Limit'
18168            NCPAR=11
18169          ENDIF
18170          CALL DPDT8C(ALOWPA(1,ITAG),AUPPPA(1,ITAG),ALPHAV,NUMALP,
18171     1                ICAPSW,ICAPTY,NUMDIG,IPAR,NCPAR,
18172     1                ISUBRO,IBUGG3,IERROR)
18173        ENDIF
18174C
18175C       SHAPE PARAMETER ONE:
18176C
18177        IF(NUMSHA.GE.1 .AND. SH1.NE.CPUMIN)THEN
18178          ITAG=ITAG+1
18179C
18180          ICNT=1
18181          ITEXT(ICNT)=' '
18182          NCTEXT(ICNT)=0
18183          AVALUE(ICNT)=0.0
18184          IDIGIT(ICNT)=-1
18185          ICNT=ICNT+1
18186          ITEXT(ICNT)='Shape Parameter 1:'
18187          NCTEXT(ICNT)=18
18188          AVALUE(ICNT)=0.0
18189          IDIGIT(ICNT)=-1
18190C
18191          ICNT=ICNT+1
18192          ITEXT(ICNT)='Number of Failed Bootstrap Samples:'
18193          NCTEXT(ICNT)=35
18194          AVALUE(ICNT)=REAL(NFAIL(ITAG))
18195          IDIGIT(ICNT)=0
18196          ICNT=ICNT+1
18197          ITEXT(ICNT)='Mean:'
18198          NCTEXT(ICNT)=5
18199          AVALUE(ICNT)=ZMEAN(ITAG)
18200          IDIGIT(ICNT)=NUMDIG
18201          ICNT=ICNT+1
18202          ITEXT(ICNT)='Median:'
18203          NCTEXT(ICNT)=7
18204          AVALUE(ICNT)=ZMED(ITAG)
18205          IDIGIT(ICNT)=NUMDIG
18206          ICNT=ICNT+1
18207          ITEXT(ICNT)='Standard Deviation:'
18208          NCTEXT(ICNT)=19
18209          AVALUE(ICNT)=ZSD(ITAG)
18210          IDIGIT(ICNT)=NUMDIG
18211          ICNT=ICNT+1
18212          ITEXT(ICNT)='Median Absolute Deviation:'
18213          NCTEXT(ICNT)=27
18214          AVALUE(ICNT)=ZMAD(ITAG)
18215          IDIGIT(ICNT)=NUMDIG
18216C
18217          ICNT=ICNT+1
18218          ITEXT(ICNT)=' '
18219          NCTEXT(ICNT)=0
18220          AVALUE(ICNT)=0.0
18221          IDIGIT(ICNT)=-1
18222C
18223          NUMROW=ICNT
18224          DO8314II=1,NUMROW
18225            NTOT(II)=15
18226 8314     CONTINUE
18227C
18228          IFRST=.TRUE.
18229          ILAST=.TRUE.
18230          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
18231     1                AVALUE,IDIGIT,
18232     1                NTOT,NUMROW,
18233     1                ICAPSW,ICAPTY,ILAST,IFRST,
18234     1                ISUBRO,IBUGG3,IERROR)
18235C
18236          IF(ALOWPA(1,ITAG).NE.CPUMIN)THEN
18237            IPAR='Shape Parameter 1'
18238            NCPAR=17
18239            CALL DPDT8C(ALOWPA(1,ITAG),AUPPPA(1,ITAG),ALPHAV,NUMALP,
18240     1                  ICAPSW,ICAPTY,NUMDIG,IPAR,NCPAR,
18241     1                  ISUBRO,IBUGG3,IERROR)
18242          ENDIF
18243        ENDIF
18244C
18245C       SHAPE PARAMETER TWO:
18246C
18247        IF(NUMSHA.GE.2 .AND. SH2.NE.CPUMIN)THEN
18248          ITAG=ITAG+1
18249C
18250          ICNT=1
18251          ITEXT(ICNT)=' '
18252          NCTEXT(ICNT)=0
18253          AVALUE(ICNT)=0.0
18254          IDIGIT(ICNT)=-1
18255          ICNT=ICNT+1
18256          ITEXT(ICNT)='Shape Parameter 2:'
18257          NCTEXT(ICNT)=18
18258          AVALUE(ICNT)=0.0
18259          IDIGIT(ICNT)=-1
18260C
18261          ICNT=ICNT+1
18262          ITEXT(ICNT)='Number of Failed Bootstrap Samples:'
18263          NCTEXT(ICNT)=35
18264          AVALUE(ICNT)=REAL(NFAIL(ITAG))
18265          IDIGIT(ICNT)=0
18266          ICNT=ICNT+1
18267          ITEXT(ICNT)='Mean:'
18268          NCTEXT(ICNT)=5
18269          AVALUE(ICNT)=ZMEAN(ITAG)
18270          IDIGIT(ICNT)=NUMDIG
18271          ICNT=ICNT+1
18272          ITEXT(ICNT)='Median:'
18273          NCTEXT(ICNT)=7
18274          AVALUE(ICNT)=ZMED(ITAG)
18275          IDIGIT(ICNT)=NUMDIG
18276          ICNT=ICNT+1
18277          ITEXT(ICNT)='Standard Deviation:'
18278          NCTEXT(ICNT)=19
18279          AVALUE(ICNT)=ZSD(ITAG)
18280          IDIGIT(ICNT)=NUMDIG
18281          ICNT=ICNT+1
18282          ITEXT(ICNT)='Median Absolute Deviation:'
18283          NCTEXT(ICNT)=27
18284          AVALUE(ICNT)=ZMAD(ITAG)
18285          IDIGIT(ICNT)=NUMDIG
18286C
18287          ICNT=ICNT+1
18288          ITEXT(ICNT)=' '
18289          NCTEXT(ICNT)=0
18290          AVALUE(ICNT)=0.0
18291          IDIGIT(ICNT)=-1
18292C
18293          NUMROW=ICNT
18294          DO8315II=1,NUMROW
18295            NTOT(II)=15
18296 8315     CONTINUE
18297C
18298          IFRST=.TRUE.
18299          ILAST=.TRUE.
18300          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
18301     1                AVALUE,IDIGIT,
18302     1                NTOT,NUMROW,
18303     1                ICAPSW,ICAPTY,ILAST,IFRST,
18304     1                ISUBRO,IBUGG3,IERROR)
18305C
18306          IF(ALOWPA(1,ITAG).NE.CPUMIN)THEN
18307            IPAR='Shape Parameter 2'
18308            NCPAR=17
18309            CALL DPDT8C(ALOWPA(1,ITAG),AUPPPA(1,ITAG),ALPHAV,NUMALP,
18310     1                  ICAPSW,ICAPTY,NUMDIG,IPAR,NCPAR,
18311     1                  ISUBRO,IBUGG3,IERROR)
18312          ENDIF
18313        ENDIF
18314C
18315C       SHAPE PARAMETER THREE:
18316C
18317        IF(NUMSHA.GE.3 .AND. SH3.NE.CPUMIN)THEN
18318          ITAG=ITAG+1
18319C
18320          ICNT=1
18321          ITEXT(ICNT)=' '
18322          NCTEXT(ICNT)=0
18323          AVALUE(ICNT)=0.0
18324          IDIGIT(ICNT)=-1
18325          ICNT=ICNT+1
18326          ITEXT(ICNT)='Shape Parameter 3:'
18327          NCTEXT(ICNT)=18
18328          AVALUE(ICNT)=0.0
18329          IDIGIT(ICNT)=-1
18330C
18331          ICNT=ICNT+1
18332          ITEXT(ICNT)='Number of Failed Bootstrap Samples:'
18333          NCTEXT(ICNT)=35
18334          AVALUE(ICNT)=REAL(NFAIL(ITAG))
18335          IDIGIT(ICNT)=0
18336          ICNT=ICNT+1
18337          ITEXT(ICNT)='Mean:'
18338          NCTEXT(ICNT)=5
18339          AVALUE(ICNT)=ZMEAN(ITAG)
18340          IDIGIT(ICNT)=NUMDIG
18341          ICNT=ICNT+1
18342          ITEXT(ICNT)='Median:'
18343          NCTEXT(ICNT)=7
18344          AVALUE(ICNT)=ZMED(ITAG)
18345          IDIGIT(ICNT)=NUMDIG
18346          ICNT=ICNT+1
18347          ITEXT(ICNT)='Standard Deviation:'
18348          NCTEXT(ICNT)=19
18349          AVALUE(ICNT)=ZSD(ITAG)
18350          IDIGIT(ICNT)=NUMDIG
18351          ICNT=ICNT+1
18352          ITEXT(ICNT)='Median Absolute Deviation:'
18353          NCTEXT(ICNT)=27
18354          AVALUE(ICNT)=ZMAD(ITAG)
18355          IDIGIT(ICNT)=NUMDIG
18356C
18357          ICNT=ICNT+1
18358          ITEXT(ICNT)=' '
18359          NCTEXT(ICNT)=0
18360          AVALUE(ICNT)=0.0
18361          IDIGIT(ICNT)=-1
18362C
18363          NUMROW=ICNT
18364          DO8316II=1,NUMROW
18365            NTOT(II)=15
18366 8316     CONTINUE
18367C
18368          IFRST=.TRUE.
18369          ILAST=.TRUE.
18370          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
18371     1                AVALUE,IDIGIT,
18372     1                NTOT,NUMROW,
18373     1                ICAPSW,ICAPTY,ILAST,IFRST,
18374     1                ISUBRO,IBUGG3,IERROR)
18375C
18376          IF(ALOWPA(1,ITAG).NE.CPUMIN)THEN
18377            IPAR='Shape Parameter 3'
18378            NCPAR=17
18379            CALL DPDT8C(ALOWPA(1,ITAG),AUPPPA(1,ITAG),ALPHAV,NUMALP,
18380     1                  ICAPSW,ICAPTY,NUMDIG,IPAR,NCPAR,
18381     1                  ISUBRO,IBUGG3,IERROR)
18382          ENDIF
18383        ENDIF
18384C
18385C       SHAPE PARAMETER FOUR:
18386C
18387        IF(NUMSHA.GE.4 .AND. SH4.NE.CPUMIN)THEN
18388          ITAG=ITAG+1
18389C
18390          ICNT=1
18391          ITEXT(ICNT)=' '
18392          NCTEXT(ICNT)=0
18393          AVALUE(ICNT)=0.0
18394          IDIGIT(ICNT)=-1
18395          ICNT=ICNT+1
18396          ITEXT(ICNT)='Shape Parameter 4:'
18397          NCTEXT(ICNT)=18
18398          AVALUE(ICNT)=0.0
18399          IDIGIT(ICNT)=-1
18400C
18401          ICNT=ICNT+1
18402          ITEXT(ICNT)='Number of Failed Bootstrap Samples:'
18403          NCTEXT(ICNT)=35
18404          AVALUE(ICNT)=REAL(NFAIL(ITAG))
18405          IDIGIT(ICNT)=0
18406          ICNT=ICNT+1
18407          ITEXT(ICNT)='Mean:'
18408          NCTEXT(ICNT)=5
18409          AVALUE(ICNT)=ZMEAN(ITAG)
18410          IDIGIT(ICNT)=NUMDIG
18411          ICNT=ICNT+1
18412          ITEXT(ICNT)='Median:'
18413          NCTEXT(ICNT)=7
18414          AVALUE(ICNT)=ZMED(ITAG)
18415          IDIGIT(ICNT)=NUMDIG
18416          ICNT=ICNT+1
18417          ITEXT(ICNT)='Standard Deviation:'
18418          NCTEXT(ICNT)=19
18419          AVALUE(ICNT)=ZSD(ITAG)
18420          IDIGIT(ICNT)=NUMDIG
18421          ICNT=ICNT+1
18422          ITEXT(ICNT)='Median Absolute Deviation:'
18423          NCTEXT(ICNT)=27
18424          AVALUE(ICNT)=ZMAD(ITAG)
18425          IDIGIT(ICNT)=NUMDIG
18426C
18427          ICNT=ICNT+1
18428          ITEXT(ICNT)=' '
18429          NCTEXT(ICNT)=0
18430          AVALUE(ICNT)=0.0
18431          IDIGIT(ICNT)=-1
18432C
18433          NUMROW=ICNT
18434          DO8317II=1,NUMROW
18435            NTOT(II)=15
18436 8317     CONTINUE
18437C
18438          IFRST=.TRUE.
18439          ILAST=.TRUE.
18440          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
18441     1                AVALUE,IDIGIT,
18442     1                NTOT,NUMROW,
18443     1                ICAPSW,ICAPTY,ILAST,IFRST,
18444     1                ISUBRO,IBUGG3,IERROR)
18445C
18446          IF(ALOWPA(1,ITAG).NE.CPUMIN)THEN
18447            IPAR='Shape Parameter 4'
18448            NCPAR=17
18449            CALL DPDT8C(ALOWPA(1,ITAG),AUPPPA(1,ITAG),ALPHAV,NUMALP,
18450     1                  ICAPSW,ICAPTY,NUMDIG,IPAR,NCPAR,
18451     1                  ISUBRO,IBUGG3,IERROR)
18452          ENDIF
18453        ENDIF
18454C
18455C       SHAPE PARAMETER FIVE:
18456C
18457        IF(NUMSHA.GE.5 .AND. SH5.NE.CPUMIN)THEN
18458          ITAG=ITAG+1
18459C
18460          ICNT=1
18461          ITEXT(ICNT)=' '
18462          NCTEXT(ICNT)=0
18463          AVALUE(ICNT)=0.0
18464          IDIGIT(ICNT)=-1
18465          ICNT=ICNT+1
18466          ITEXT(ICNT)='Shape Parameter 5:'
18467          NCTEXT(ICNT)=18
18468          AVALUE(ICNT)=0.0
18469          IDIGIT(ICNT)=-1
18470C
18471          ICNT=ICNT+1
18472          ITEXT(ICNT)='Number of Failed Bootstrap Samples:'
18473          NCTEXT(ICNT)=35
18474          AVALUE(ICNT)=REAL(NFAIL(ITAG))
18475          IDIGIT(ICNT)=0
18476          ICNT=ICNT+1
18477          ITEXT(ICNT)='Mean:'
18478          NCTEXT(ICNT)=5
18479          AVALUE(ICNT)=ZMEAN(ITAG)
18480          IDIGIT(ICNT)=NUMDIG
18481          ICNT=ICNT+1
18482          ITEXT(ICNT)='Median:'
18483          NCTEXT(ICNT)=7
18484          AVALUE(ICNT)=ZMED(ITAG)
18485          IDIGIT(ICNT)=NUMDIG
18486          ICNT=ICNT+1
18487          ITEXT(ICNT)='Standard Deviation:'
18488          NCTEXT(ICNT)=19
18489          AVALUE(ICNT)=ZSD(ITAG)
18490          IDIGIT(ICNT)=NUMDIG
18491          ICNT=ICNT+1
18492          ITEXT(ICNT)='Median Absolute Deviation:'
18493          NCTEXT(ICNT)=27
18494          AVALUE(ICNT)=ZMAD(ITAG)
18495          IDIGIT(ICNT)=NUMDIG
18496C
18497          ICNT=ICNT+1
18498          ITEXT(ICNT)=' '
18499          NCTEXT(ICNT)=0
18500          AVALUE(ICNT)=0.0
18501          IDIGIT(ICNT)=-1
18502C
18503          NUMROW=ICNT
18504          DO8318II=1,NUMROW
18505            NTOT(II)=15
18506 8318     CONTINUE
18507C
18508          IFRST=.TRUE.
18509          ILAST=.TRUE.
18510          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
18511     1                AVALUE,IDIGIT,
18512     1                NTOT,NUMROW,
18513     1                ICAPSW,ICAPTY,ILAST,IFRST,
18514     1                ISUBRO,IBUGG3,IERROR)
18515C
18516          IF(ALOWPA(1,ITAG).NE.CPUMIN)THEN
18517            IPAR='Shape Parameter 5'
18518            NCPAR=17
18519            CALL DPDT8C(ALOWPA(1,ITAG),AUPPPA(1,ITAG),ALPHAV,NUMALP,
18520     1                  ICAPSW,ICAPTY,NUMDIG,IPAR,NCPAR,
18521     1                  ISUBRO,IBUGG3,IERROR)
18522          ENDIF
18523        ENDIF
18524C
18525C       VALUE OF TEST STATISTIC FOR PPCC, AD, KS
18526C
18527        IF(ICASP2.EQ.'PPCC' .OR. ICASP2.EQ.'AD' .OR.
18528     1     ICASP2.EQ.'KS')THEN
18529          ITAG=ITAG+1
18530C
18531          ICNT=1
18532          ITEXT(ICNT)=' '
18533          NCTEXT(ICNT)=0
18534          AVALUE(ICNT)=0.0
18535          IDIGIT(ICNT)=-1
18536          ICNT=ICNT+1
18537          ITEXT(ICNT)='Value of Test Statistic:'
18538          NCTEXT(ICNT)=24
18539          AVALUE(ICNT)=0.0
18540          IDIGIT(ICNT)=-1
18541C
18542          ICNT=ICNT+1
18543          ITEXT(ICNT)='Number of Failed Bootstrap Samples:'
18544          NCTEXT(ICNT)=35
18545          AVALUE(ICNT)=REAL(NFAIL(ITAG))
18546          IDIGIT(ICNT)=0
18547          ICNT=ICNT+1
18548          ITEXT(ICNT)='Mean:'
18549          NCTEXT(ICNT)=5
18550          AVALUE(ICNT)=ZMEAN(ITAG)
18551          IDIGIT(ICNT)=NUMDIG
18552          ICNT=ICNT+1
18553          ITEXT(ICNT)='Median:'
18554          NCTEXT(ICNT)=7
18555          AVALUE(ICNT)=ZMED(ITAG)
18556          IDIGIT(ICNT)=NUMDIG
18557          ICNT=ICNT+1
18558          ITEXT(ICNT)='Standard Deviation:'
18559          NCTEXT(ICNT)=19
18560          AVALUE(ICNT)=ZSD(ITAG)
18561          IDIGIT(ICNT)=NUMDIG
18562          ICNT=ICNT+1
18563          ITEXT(ICNT)='Median Absolute Deviation:'
18564          NCTEXT(ICNT)=27
18565          AVALUE(ICNT)=ZMAD(ITAG)
18566          IDIGIT(ICNT)=NUMDIG
18567C
18568          ICNT=ICNT+1
18569          ITEXT(ICNT)=' '
18570          NCTEXT(ICNT)=0
18571          AVALUE(ICNT)=0.0
18572          IDIGIT(ICNT)=-1
18573C
18574          NUMROW=ICNT
18575          DO8319II=1,NUMROW
18576            NTOT(II)=15
18577 8319     CONTINUE
18578C
18579          IFRST=.TRUE.
18580          ILAST=.TRUE.
18581          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
18582     1                AVALUE,IDIGIT,
18583     1                NTOT,NUMROW,
18584     1                ICAPSW,ICAPTY,ILAST,IFRST,
18585     1                ISUBRO,IBUGG3,IERROR)
18586C
18587          IF(ALOWPA(1,ITAG).NE.CPUMIN)THEN
18588            IPAR='Value of Test Statistic'
18589            NCPAR=23
18590            CALL DPDT8C(ALOWPA(1,ITAG),AUPPPA(1,ITAG),ALPHAV,NUMALP,
18591     1                  ICAPSW,ICAPTY,NUMDIG,IPAR,NCPAR,
18592     1                  ISUBRO,IBUGG3,IERROR)
18593          ENDIF
18594        ENDIF
18595C
18596C       IF PERCENTILES REQUESTED, GENERATE CONFIDENCE LIMITS FOR
18597C       PERCENTILES
18598C
18599        IF(NPERC.GE.1 .AND. IBOODP.NE.'OFF')THEN
18600          NPERCT=MIN(30,NPERC)
18601          IFLAG1=0
18602          IFLAG2=0
18603          IFLAG3=0
18604          IFLAG4=0
18605          IFLAG5=1
18606          IOP='OPEN'
18607          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
18608     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
18609     1                IBUGG3,ISUBRO,IERROR)
18610C
18611C         NOTE: SOMETIMES ESTIMATION METHODS CAN FAIL.  SO SKIP
18612C               OVER FAILED READS.
18613C
18614          DO7010L=1,NPERCT
18615C
18616            REWIND(IOUNI5)
18617            ICNT=0
18618            DO7020II=1,NRESAM
18619              READ(IOUNI5,'(30E15.7)',ERR=7020)(XTEMP2(JJ),JJ=1,NPERCT)
18620              IF(XTEMP2(L).LE.CPUMIN+100.0)GOTO7020
18621              ICNT=ICNT+1
18622              XTEMP1(ICNT)=XTEMP2(L)
18623 7020       CONTINUE
18624            CALL MEDIAN(XTEMP1,ICNT,IWRITE,XTEMP3,MAXNXT,XQPMED,
18625     1                  IBUGG3,IERROR)
18626            XQP(L)=XQPMED
18627            IF(IBOODP.EQ.'TWOS')THEN
18628              P100=100.0*(ALPHA/2.0)
18629              CALL PERCEN(P100,XTEMP1,ICNT,IWRITE,XTEMP3,MAXNXT,
18630     1                    BTEMP,IBUGG3,IERROR)
18631              XQPLCL(L)=BTEMP
18632              P100=100.0*(1.0 - (ALPHA/2.0))
18633              CALL PERCEN(P100,XTEMP1,ICNT,IWRITE,XTEMP3,MAXNXT,
18634     1                    BTEMP,IBUGG3,IERROR)
18635              XQPUCL(L)=BTEMP
18636            ELSEIF(IBOODP.EQ.'LOWE')THEN
18637              P100=100.0*(ALPHA)
18638              CALL PERCEN(P100,XTEMP1,ICNT,IWRITE,XTEMP3,MAXNXT,
18639     1                    BTEMP,IBUGG3,IERROR)
18640              XQPLCL(L)=BTEMP
18641              XQPUCL(L)=CPUMIN
18642            ELSEIF(IBOODP.EQ.'UPPE')THEN
18643              P100=100.0*(1.0 - ALPHA)
18644              CALL PERCEN(P100,XTEMP1,ICNT,IWRITE,XTEMP3,MAXNXT,
18645     1                    BTEMP,IBUGG3,IERROR)
18646              XQPUCL(L)=BTEMP
18647              XQPLCL(L)=CPUMIN
18648          ENDIF
18649C
18650 7010     CONTINUE
18651C
18652          CALL DPDT9B(QP,XQP,XQPLCL,XQPUCL,NPERC,
18653     1                ICAPSW,ICAPTY,NUMDIG,ALPHA,
18654     1                ISUBRO,IBUGG3,IERROR)
18655C
18656          IFLAG5=1
18657          IOP='CLOS'
18658          CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
18659     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
18660     1                IBUGG3,ISUBRO,IERROR)
18661        ENDIF
18662C
1866311000 CONTINUE
18664C
18665      NPLOTP=J
18666      NPLOTV=3
18667C
18668      IOP='CLOS'
18669      IFLAG1=1
18670      IFLAG2=1
18671      IFLAG3=0
18672      IF(IBCABT.EQ.'ON' .AND. ICASJB.EQ.'BOOT')IFLAG3=1
18673      IFLAG4=0
18674      IF(NPERC.GT.0)IFLAG4=1
18675      IFLAG5=0
18676      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
18677     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
18678     1            IBUGG3,ISUBRO,IERROR)
18679      IF(IERROR.EQ.'YES')GOTO9000
18680C
18681        IF(IFEEDB.EQ.'ON')THEN
18682C
18683          WRITE(ICOUT,8102)
18684 8102     FORMAT('THE FOLLOWING INFORMATION IS WRITTEN TO FILES.')
18685          CALL DPWRST('XXX','BUG ')
18686          WRITE(ICOUT,999)
18687          CALL DPWRST('XXX','BUG ')
18688          WRITE(ICOUT,8104)
18689 8104     FORMAT('DPST1F.DAT: THE BOOTSTRAP VALUES.')
18690          CALL DPWRST('XXX','BUG ')
18691          WRITE(ICOUT,8106)
18692 8106     FORMAT('            FOR GROUPED DATA, THE FIRST ONE (OR ',
18693     1           'TWO) COLUMNS IDENTIFY THE GROUP(S).')
18694          CALL DPWRST('XXX','BUG ')
18695          WRITE(ICOUT,999)
18696          CALL DPWRST('XXX','BUG ')
18697          WRITE(ICOUT,8112)
18698 8112     FORMAT('DPST2F.DAT: STATISTICS BASED ON BOOTSTRAP VALUES.')
18699          CALL DPWRST('XXX','BUG ')
18700          WRITE(ICOUT,8114)
18701 8114     FORMAT('            MEAN, SD, MEDIAN, B025, ',
18702     1           'B975, B05, B95, B005, B995')
18703          CALL DPWRST('XXX','BUG ')
18704          IF(NUMPAR.GT.1)THEN
18705            WRITE(ICOUT,8118)
18706 8118       FORMAT('            THE FIRST COLUMN IDENTIFIES THE ',
18707     1             'PARAMETER.')
18708            CALL DPWRST('XXX','BUG ')
18709            WRITE(ICOUT,999)
18710            CALL DPWRST('XXX','BUG ')
18711          ENDIF
18712          WRITE(ICOUT,8116)
18713 8116     FORMAT('            FOR GROUPED DATA, THE FIRST ONE (OR ',
18714     1           'TWO) COLUMNS')
18715          CALL DPWRST('XXX','BUG ')
18716          WRITE(ICOUT,8117)
18717 8117     FORMAT('            (AFTER THE PARAMETER ID) IDENTIFY ',
18718     1           'THE GROUP(S).')
18719          CALL DPWRST('XXX','BUG ')
18720          WRITE(ICOUT,999)
18721          CALL DPWRST('XXX','BUG ')
18722C
18723        ENDIF
18724C
18725CCCCC ENDIF
18726C
18727C               ******************
18728C               **   STEP 90--  **
18729C               **   EXIT       **
18730C               ******************
18731C
18732 9000 CONTINUE
18733C
18734C     REMOVE FAILED SAMPLES FROM PLOT
18735C
18736      ICOUNT=0
18737      DO9005I=1,NPLOTP
18738        IF(Y2(I).NE.CPUMIN)THEN
18739          ICOUNT=ICOUNT+1
18740          Y2(ICOUNT)=Y2(I)
18741          X2(ICOUNT)=X2(I)
18742          D2(ICOUNT)=D2(I)
18743C
18744          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')THEN
18745            WRITE(ICOUT,9008)I,ICOUNT,Y2(ICOUNT),X2(ICOUNT),D2(ICOUNT)
18746 9008       FORMAT('I,ICOUNT,Y2(ICOUNT),X2(ICOUNT),D2(ICOUNT) = ',
18747     1             2I8,2G15.7,F9.2)
18748            CALL DPWRST('XXX','BUG ')
18749          ENDIF
18750C
18751        ENDIF
18752 9005 CONTINUE
18753      NPLOTP=ICOUNT
18754C
18755      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS7')THEN
18756        WRITE(ICOUT,999)
18757        CALL DPWRST('XXX','BUG ')
18758        WRITE(ICOUT,9011)
18759 9011   FORMAT('***** AT THE END       OF DPJBS7--')
18760        CALL DPWRST('XXX','BUG ')
18761        WRITE(ICOUT,9012)IBUGG3,ISUBRO,ICASJB,IBOOSS
18762 9012   FORMAT('IBUGG3,ISUBRO,ICASJB,IBOOSS = ',2(A4,2X),A4,I8)
18763        CALL DPWRST('XXX','BUG ')
18764        WRITE(ICOUT,9013)ICASPL,N,NUMSET,IERROR
18765 9013   FORMAT('ICASPL,N,NUMSET,IERROR = ',A4,2I8,2X,A4)
18766        CALL DPWRST('XXX','BUG ')
18767        WRITE(ICOUT,9014)NPLOTV,NPLOTP
18768 9014   FORMAT('NPLOTV,NPLOTP = ',2I8)
18769        CALL DPWRST('XXX','BUG ')
18770        DO9020I=1,NPLOTP
18771          WRITE(ICOUT,9021)I,Y2(I),X2(I),D2(I)
18772 9021     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2)
18773          CALL DPWRST('XXX','BUG ')
18774 9020   CONTINUE
18775      ENDIF
18776C
18777      RETURN
18778      END
18779      SUBROUTINE DPJBS8(ISETMX,ISET,NUMSET,NUMSE2,N1,N2,NGRP,
18780     1                  MAXOBV,MAXGRP,NUMV2,
18781     1                  Y,Z,TEMPL,XDESGN,XIDTEM,TEMP0,TEMPZ0,TEMPZL,
18782     1                  NS2,NSS2,NI,NI2,ISET1,ISET2,
18783     1                  ISUBRO,IBUGG3,IERROR)
18784C
18785C     PURPOSE--UTILITY ROUTINE FOR DPJBS6 AND DPJBS7.  FOR A
18786C              GIVEN REPLICATION, EXTRACT THE APPROPRIATE DATA.
18787C
18788C     WRITTEN BY--JAMES J. FILLIBEN
18789C                 STATISTICAL ENGINEERING DIVISION
18790C                 INFORMATION TECHNOLOGY LABORATORY
18791C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18792C                 GAITHERSBURG, MD 20899-8980
18793C                 PHONE--301-975-2899
18794C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18795C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18796C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
18797C     LANGUAGE--ANSI FORTRAN (1977)
18798C     VERSION NUMBER--2010/02
18799C     ORIGINAL VERSION--FEBRUARY  2010. EXTRACTED FROM DPJBS2
18800C
18801C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18802C
18803      CHARACTER*4 ISUBRO
18804      CHARACTER*4 IBUGG3
18805      CHARACTER*4 IERROR
18806C
18807C---------------------------------------------------------------------
18808C
18809      DIMENSION Y(*)
18810      DIMENSION Z(*)
18811      DIMENSION TEMPL(*)
18812      DIMENSION TEMP0(*)
18813      DIMENSION TEMPZ0(*)
18814      DIMENSION TEMPZL(*)
18815      DIMENSION XDESGN(MAXOBV,MAXGRP)
18816      DIMENSION XIDTEM(MAXOBV,MAXGRP)
18817C
18818      INTEGER NUMSE2(*)
18819C
18820      CHARACTER*4 ISUBN1
18821      CHARACTER*4 ISUBN2
18822      CHARACTER*4 ISTEPN
18823C
18824C-----COMMON VARIABLES (GENERAL)--------------------------------------
18825C
18826      INCLUDE 'DPCOP2.INC'
18827C
18828C-----START POINT-----------------------------------------------------
18829C
18830      ISUBN1='JBS8'
18831      ISUBN2='    '
18832      IERROR='NO'
18833C
18834      IF(IBUGG3.GE.'ON'.OR.ISUBRO.EQ.'JBS8')THEN
18835        WRITE(ICOUT,70)
18836   70   FORMAT('AT THE BEGINNING OF DPJBS8--')
18837        CALL DPWRST('XXX','BUG ')
18838        WRITE(ICOUT,71)ISETMX,ISET,NUMSET,NGRP,MAXGRP
18839   71   FORMAT('ISETMX,ISET,NUMSET,NGRP,MAXGRP = ',5I8)
18840        CALL DPWRST('XXX','BUG ')
18841        WRITE(ICOUT,72)N1,N2,NUMV2,NUMSE2(1),NUMSE2(2)
18842   72   FORMAT('N1,N2,NUMV2,NUMSE2(1),NUMSE2(2) = ',5I8)
18843        CALL DPWRST('XXX','BUG ')
18844        WRITE(ICOUT,73)XIDTEM(ISET,1),XIDTEM(ISET,2)
18845   73   FORMAT('XIDTEM(ISET,1),XIDTEM(ISET,2) = ',2G15.7)
18846        CALL DPWRST('XXX','BUG ')
18847      ENDIF
18848C
18849C               ******************************************
18850C               **  STEP 11--                           **
18851C               **  EXTRACT THE APPROPRIATE DATA        **
18852C               ******************************************
18853C
18854      ISTEPN='11'
18855      IF(IBUGG3.GE.'ON'.OR.ISUBRO.EQ.'JBS8')
18856     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18857C
18858      IF(ISET.EQ.ISETMX)THEN
18859        DO1002I=1,N1
18860          TEMP0(I)=Y(I)
18861 1002   CONTINUE
18862        IF(NUMV2.GE.2)THEN
18863          DO1004I=1,N2
18864            TEMPZ0(I)=Z(I)
18865 1004     CONTINUE
18866        ENDIF
18867        IF(NUMV2.GE.3)THEN
18868          DO1006I=1,N2
18869            TEMPZL(I)=TEMPL(I)
18870 1006     CONTINUE
18871        ENDIF
18872        NS2=N1
18873        NSS2=N2
18874        NI=N1
18875        NI2=N2
18876        ISET1=0
18877        ISET2=0
18878C
18879C       NOTE: FOR GROUPED CASE, BOTH RESPONSE VARIABLES
18880C             MUST HAVE THE SAME LENGTH.
18881C
18882      ELSEIF(NGRP.EQ.1 .AND. ISET.LT.ISETMX)THEN
18883        K=0
18884        DO1102I=1,N1
18885          IF(XDESGN(I,1).NE.XIDTEM(ISET,1))GOTO1102
18886          K=K+1
18887          TEMP0(K)=Y(I)
18888          IF(NUMV2.GE.2)TEMPZ0(K)=Z(I)
18889          IF(NUMV2.GE.3)TEMPZL(K)=TEMPL(I)
18890C
18891          IF(IBUGG3.GE.'ON'.OR.ISUBRO.EQ.'JBS8')THEN
18892            WRITE(ICOUT,1108)I,K,XDESGN(I,1),TEMP0(K),Y(I)
18893 1108       FORMAT('AT 1102: I,K,XDESGN(I,1),TEMP0(K),Y(I) = ',
18894     1             2I8,3G15.7)
18895            CALL DPWRST('XXX','BUG ')
18896          ENDIF
18897C
18898 1102   CONTINUE
18899        NS2=K
18900        NS22=NS2
18901        NI=K
18902        NI2=K
18903        ISET1=0
18904        ISET2=0
18905      ELSEIF(NGRP.EQ.2 .AND. ISET.LT.NUMSET)THEN
18906        K=0
18907        ISET1=INT((ISET-1)/NUMSE2(2)) + 1
18908        ISET2=MOD((ISET-1),NUMSE2(2)) + 1
18909        DO1202I=1,N1
18910          IF(XDESGN(I,1).NE.XIDTEM(ISET1,1) .OR.
18911     1       XDESGN(I,2).NE.XIDTEM(ISET2,2))GOTO1202
18912          K=K+1
18913          TEMP0(K)=Y(I)
18914          IF(NUMV2.GE.2)TEMPZ0(K)=Z(I)
18915          IF(NUMV2.GE.3)TEMPZL(K)=TEMPL(I)
18916 1202   CONTINUE
18917        NS2=K
18918        NS22=NS2
18919        NI=K
18920        NI2=K
18921      ENDIF
18922C
18923C               ******************
18924C               **   STEP 90--  **
18925C               **   EXIT       **
18926C               ******************
18927C
18928      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS8')THEN
18929        WRITE(ICOUT,999)
18930  999   FORMAT(1X)
18931        CALL DPWRST('XXX','BUG ')
18932        WRITE(ICOUT,9011)
18933 9011   FORMAT('***** AT THE END       OF DPJBS8--')
18934        CALL DPWRST('XXX','BUG ')
18935        WRITE(ICOUT,9012)ISET,ISETMX,ISET1,ISET2
18936 9012   FORMAT('ISET,ISETMX,ISET1,ISET2 = ',4I8)
18937        CALL DPWRST('XXX','BUG ')
18938        WRITE(ICOUT,9014)NS2,NSS2,NI,NI2
18939 9014   FORMAT('NS2,NSS2,NI,NI2 = ',4I8)
18940        CALL DPWRST('XXX','BUG ')
18941        DO9020I=1,MAX(NS2,NSS2)
18942          WRITE(ICOUT,9021)I,TEMP0(I),TEMPZ0(I),TEMPZL(I)
18943 9021     FORMAT('I,TEMP0(I),TEMPZ0(I),TEMPZL(I) = ',I8,3G15.7)
18944          CALL DPWRST('XXX','BUG ')
18945 9020   CONTINUE
18946      ENDIF
18947C
18948      RETURN
18949      END
18950      SUBROUTINE DPJBS9(Y2,D2,TEMP,XTEMP1,XTEMP2,MAXNXT,IOUNI1,IOUNI2,
18951     1                  NUMPAR,NGRPV,NUMSET,ISET,ISET1,ISET2,NUMSE1,J,
18952     1                  APERC,BPERC,NPERC,
18953     1                  BMEAN,BSD,BMIN,BMAX,BMAD,
18954     1                  B001,B005,B01,B025,B05,B10,B20,B50,
18955     1                  B80,B90,B95,B975,B99,B995,B999,
18956     1                  ALOWPA,AUPPPA,ALPHA,NUMALP,
18957     1                  ZMEAN,ZMED,ZSD,ZMAD,NFAIL,
18958     1                  ISUBRO,IBUGG3,IERROR)
18959C
18960C     PURPOSE--UTILITY ROUTINE FOR BOOTSTRAP/JACKNIFE PLOT.  THIS
18961C              ROUTINE WRITES INFORMATION TO DPST1F.DAT AND DPST2F.DAT
18962C              AND COMPUTES CERTAIN PARAMETERS (E.G., BMEAN, B10).
18963C
18964C              NOTE: THIS ROUTINE EXTRACTED FROM ORIGINAL DPJBS2.
18965C                    WITH THIS EXTRACTION, TAKE THE OPPORTUNITY TO
18966C                    SIMPLIFY THE CODE A BIT AS WELL.
18967C
18968C     WRITTEN BY--JAMES J. FILLIBEN
18969C                 STATISTICAL ENGINEERING DIVISION
18970C                 INFORMATION TECHNOLOGY LABORATORY
18971C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
18972C                 GAITHERSBURG, MD 20899-8980
18973C                 PHONE--301-975-2899
18974C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18975C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18976C     LANGUAGE--ANSI FORTRAN (1977)
18977C     VERSION NUMBER--2010/03
18978C     ORIGINAL VERSION--MARCH     2010. EXTRACTED FROM DPJBS2
18979C     UPDATED         --OCTOBER   2010. SAVE MEAN, MEDIAN, SD, AND MAD
18980C                                       FOR EACH PARAMETER FOR PRINT
18981C                                       ROUTINES
18982C
18983C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18984C
18985      CHARACTER*4 ISUBRO
18986      CHARACTER*4 IBUGG3
18987      CHARACTER*4 IERROR
18988C
18989      DIMENSION Y2(*)
18990      DIMENSION D2(*)
18991      DIMENSION TEMP(*)
18992      DIMENSION XTEMP1(*)
18993      DIMENSION XTEMP2(*)
18994      DIMENSION APERC(*)
18995      DIMENSION BPERC(*)
18996      DIMENSION ALPHA(NUMALP)
18997      DIMENSION ALOWPA(NUMALP,*)
18998      DIMENSION AUPPPA(NUMALP,*)
18999      DIMENSION ZMEAN(*)
19000      DIMENSION ZMED(*)
19001      DIMENSION ZSD(*)
19002      DIMENSION ZMAD(*)
19003      INTEGER   NFAIL(*)
19004C
19005      INTEGER NUMSE1(*)
19006C
19007      CHARACTER*4 IWRITE
19008C
19009C-----COMMON----------------------------------------------------------
19010C
19011C-----COMMON VARIABLES (GENERAL)--------------------------------------
19012C
19013      INCLUDE 'DPCOP2.INC'
19014C
19015C-----START POINT-----------------------------------------------------
19016C
19017      IWRITE='OFF'
19018C
19019      IF(IBUGG3.GE.'ON'.OR.ISUBRO.EQ.'JBS9')THEN
19020        WRITE(ICOUT,999)
19021  999   FORMAT(1X)
19022        CALL DPWRST('XXX','BUG ')
19023        WRITE(ICOUT,60)
19024   60   FORMAT('AT THE BEGINNING OF DPJBS9--')
19025        CALL DPWRST('XXX','BUG ')
19026        WRITE(ICOUT,61)IBUGG3,ISUBRO,IOUNI1,IOUNI2
19027   61   FORMAT('IBUGG3,ISUBRO,IOUNI1,IOUNI2 = ',A4,2X,A4,2I5)
19028        CALL DPWRST('XXX','BUG ')
19029        WRITE(ICOUT,62)NGRPV,NUMPAR,NUMSET,J
19030   62   FORMAT('NGRPV,NUMPAR,NUMSET,J = ',4I8)
19031        CALL DPWRST('XXX','BUG ')
19032        WRITE(ICOUT,63)ISET,ISET1,ISET2,NUMSET
19033   63   FORMAT('ISET,ISET1,ISET2,NUMSET = ',4I8)
19034        CALL DPWRST('XXX','BUG ')
19035        DO73I=1,J
19036          WRITE(ICOUT,74)I,Y2(I),D2(I)
19037   74     FORMAT('I,Y2(I),D2(I) = ',I8,2G15.7)
19038          CALL DPWRST('XXX','BUG ')
19039   73   CONTINUE
19040      ENDIF
19041C
19042C               ************************************************
19043C               **   STEP 19--                                **
19044C               **   FOR GROUPED DATA, WRITE GROUP-ID, MEAN,  **
19045C               **   MEDIAN, B025, B975, B05, B90, B005, B995 **
19046C               **   TO DPST1F.DAT.                           **
19047C               ************************************************
19048C
19049C       CASE 1: NO GROUPS OR DATA AGGREGATED OVER ALL GROUPS FOR
19050C               GROUPED CASE.
19051C
19052        IF(NGRPV.LE.0 .OR. (NGRPV.GE.1.AND.ISET.GT.NUMSET))THEN
19053C
19054CCCCC     NLAST=J*NUMPAR
19055          DO110I=1,J,NUMPAR
19056            NSTOP=I+NUMPAR-1
19057            WRITE(IOUNI1,112)(Y2(K),K=I,NSTOP)
19058  112       FORMAT(8E15.7)
19059  110     CONTINUE
19060C
19061C         2014/04: SET NFAIL TO NUMBER OF SUCCESSFUL BOOTSTRAP.
19062C                  IN CALLING ROUTINE, WILL SUBTRACT THIS FROM
19063C                  NUMBER OF BOOTSTRAP SAMPLES TO OBTAIN THE NUMBER
19064C                  OF FAILURES.
19065C
19066          DO115IPAR=1,NUMPAR
19067            ICOUNT=0
19068            NFAIL(IPAR)=0
19069            DO116I=1,J,NUMPAR
19070              ATEMP=Y2(I+IPAR-1)
19071              IF(ATEMP.NE.CPUMIN)THEN
19072                ICOUNT=ICOUNT+1
19073                TEMP(ICOUNT)=Y2(I+IPAR-1)
19074                NFAIL(IPAR)=NFAIL(IPAR)+1
19075              ELSE
19076CCCCC           NFAIL(IPAR)=NFAIL(IPAR)+1
19077              ENDIF
19078  116       CONTINUE
19079C
19080            IF(IBUGG3.GE.'ON'.OR.ISUBRO.EQ.'JBS9')THEN
19081              WRITE(ICOUT,3118)I,ICOUNT,NFAIL(IPAR)
19082 3118         FORMAT('I,ICOUNT,NFAIL(IPAR)=',3I8)
19083              CALL DPWRST('XXX','BUG ')
19084              DO3119II=1,ICOUNT
19085                WRITE(ICOUT,3120)II,TEMP(ICOUNT)
19086 3120           FORMAT('II,TEMP(ICOUNT) = ',I8,G15.7)
19087              CALL DPWRST('XXX','BUG ')
19088 3119         CONTINUE
19089            ENDIF
19090C
19091C           NOTE OCTOBER 2010: FOR SOME DISTRIBUTIONS, PARAMETER
19092C           ESTIMATION CAN FAIL.  TO AVOID FAILURE IN GENERATING
19093C           PLOT/STATISTICS, KEEP TRACK OF NUMBER OF FAILURES AND
19094C           OMIT THESE FROM PLOT OUTPUT.
19095C
19096            CALL SORT(TEMP,ICOUNT,TEMP)
19097            BMIN=TEMP(1)
19098            BMAX=TEMP(ICOUNT)
19099            CALL MEAN(TEMP,ICOUNT,IWRITE,BMEANZ,IBUGG3,IERROR)
19100            CALL SD(TEMP,ICOUNT,IWRITE,BSDZ,IBUGG3,IERROR)
19101            CALL MEDIAN(TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B50Z,
19102     1                  IBUGG3,IERROR)
19103            CALL MAD(TEMP,ICOUNT,IWRITE,XTEMP1,XTEMP2,MAXNXT,BMAD,
19104     1                  IBUGG3,IERROR)
19105            ZMEAN(IPAR)=BMEANZ
19106            ZMED(IPAR)=B50Z
19107            ZSD(IPAR)=BSDZ
19108            ZMAD(IPAR)=BMAD
19109C
19110C           COMPUTE SELECT PERCENTILES
19111C
19112CCCCC       IF(NUMPAR.EQ.1)THEN
19113              DO117L=1,NPERC
19114                ATEMP=APERC(L)
19115                CALL PERCEN(ATEMP,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,
19116     1                      BTEMP,IBUGG3,IERROR)
19117                BPERC(L)=BTEMP
19118  117         CONTINUE
19119CCCCC       ENDIF
19120C
19121C           COMPUTE SELECT CONFIDENCE INTERVALS
19122C
19123            DO1118L=1,NUMALP
19124              ALP=ALPHA(L)
19125              ATEMP1=100.0*(ALP/2.0)
19126              CALL PERCEN(ATEMP1,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,
19127     1                    BTEMP1,IBUGG3,IERROR)
19128              ALOWPA(L,IPAR)=BTEMP1
19129              ATEMP2=100.0*(1.0 - (ALP/2.0))
19130              CALL PERCEN(ATEMP2,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,
19131     1                    BTEMP2,IBUGG3,IERROR)
19132              AUPPPA(L,IPAR)=BTEMP2
19133 1118       CONTINUE
19134C
19135            IF(NUMPAR.EQ.1)THEN
19136              WRITE(IOUNI2,119)BMEANZ,BSDZ,B50Z,
19137     1                         (BPERC(LL),LL=1,15)
19138  119         FORMAT(18E15.7)
19139              BMEAN=BMEANZ
19140              BSD=BSDZ
19141              B50=B50Z
19142              B001=BPERC(1)
19143              B005=BPERC(2)
19144              B01=BPERC(3)
19145              B025=BPERC(4)
19146              B05=BPERC(5)
19147              B10=BPERC(6)
19148              B20=BPERC(7)
19149              B80=BPERC(9)
19150              B90=BPERC(10)
19151              B95=BPERC(11)
19152              B975=BPERC(12)
19153              B99=BPERC(13)
19154              B995=BPERC(14)
19155              B999=BPERC(15)
19156            ELSE
19157              WRITE(IOUNI2,118)IPAR,BMEANZ,BSDZ,B50Z,
19158     1                         (BPERC(LL),LL=1,15)
19159  118         FORMAT(I8,18E15.7)
19160            ENDIF
19161  115     CONTINUE
19162C
19163C       CASE 2: ONE GROUP CASE
19164C
19165        ELSEIF(NGRPV.EQ.1 .AND. ISET.LE.NUMSET)THEN
19166C
19167          DO120I=1,J,NUMPAR
19168            NSTOP=I+NUMPAR-1
19169            IF(INT(D2(I)+0.01).EQ.ISET)THEN
19170              WRITE(IOUNI1,122)ISET,(Y2(K),K=I,NSTOP)
19171  122         FORMAT(I8,8E15.7)
19172            ENDIF
19173  120     CONTINUE
19174C
19175          DO125IPAR=1,NUMPAR
19176            ICOUNT=0
19177            DO126I=1,J,NUMPAR
19178              IF(INT(D2(I)+0.01).EQ.ISET)THEN
19179                ICOUNT=ICOUNT+1
19180                TEMP(ICOUNT)=Y2(I+IPAR-1)
19181              ENDIF
19182  126       CONTINUE
19183C
19184            CALL SORT(TEMP,ICOUNT,TEMP)
19185            BMIN=TEMP(1)
19186            BMAX=TEMP(ICOUNT)
19187            CALL MEAN(TEMP,ICOUNT,IWRITE,BMEAN,IBUGG3,IERROR)
19188            CALL SD(TEMP,ICOUNT,IWRITE,BSD,IBUGG3,IERROR)
19189            CALL MEDIAN(TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B50,
19190     1                  IBUGG3,IERROR)
19191            CALL MAD(TEMP,ICOUNT,IWRITE,XTEMP1,XTEMP2,MAXNXT,BMAD,
19192     1               IBUGG3,IERROR)
19193C
19194C           COMPUTE SELECT PERCENTILES
19195C
19196            DO127L=1,NPERC
19197              ATEMP=APERC(L)
19198              CALL PERCEN(ATEMP,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,
19199     1                    BTEMP,IBUGG3,IERROR)
19200              BPERC(L)=BTEMP
19201  127       CONTINUE
19202C
19203C           COMPUTE SELECT CONFIDENCE INTERVALS
19204C
19205            DO1128L=1,NUMALP
19206              ALP=ALPHA(L)
19207              ATEMP1=100.0*(ALP/2.0)
19208              CALL PERCEN(ATEMP1,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,
19209     1                    BTEMP1,IBUGG3,IERROR)
19210              ALOWPA(L,IPAR)=BTEMP1
19211              ATEMP2=100.0*(1.0 - (ALP/2.0))
19212              CALL PERCEN(ATEMP2,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,
19213     1                    BTEMP2,IBUGG3,IERROR)
19214              AUPPPA(L,IPAR)=BTEMP2
19215 1128       CONTINUE
19216C
19217            IF(NUMPAR.EQ.1)THEN
19218              WRITE(IOUNI2,129)ISET,BMEAN,BSD,B50,
19219     1                         (BPERC(LL),LL=1,15)
19220  129         FORMAT(I8,18E15.7)
19221            ELSE
19222              WRITE(IOUNI2,128)IPAR,ISET,BMEAN,BSD,B50,
19223     1                         (BPERC(LL),LL=1,15)
19224  128         FORMAT(2I8,18E15.7)
19225            ENDIF
19226  125     CONTINUE
19227C
19228C       CASE 3: TWO GROUPS CASE
19229C
19230        ELSEIF(NGRPV.EQ.2 .AND.ISET.LE.NUMSET)THEN
19231C
19232          ITAG=(ISET1-1)*NUMSE1(2) + ISET2
19233          DO130I=1,J,NUMPAR
19234            NSTOP=I+NUMPAR-1
19235            IF(INT(D2(I)+0.01).EQ.ITAG)THEN
19236              WRITE(IOUNI1,132)ISET1,ISET2,(Y2(K),K=I,NSTOP)
19237  132         FORMAT(2I8,8E15.7)
19238            ENDIF
19239  130     CONTINUE
19240C
19241          DO135IPAR=1,NUMPAR
19242            ICOUNT=0
19243            DO136I=1,J,NUMPAR
19244              IF(INT(D2(I)+0.01).EQ.ITAG)THEN
19245                ICOUNT=ICOUNT+1
19246                TEMP(ICOUNT)=Y2(I+IPAR-1)
19247              ENDIF
19248  136       CONTINUE
19249C
19250            CALL SORT(TEMP,ICOUNT,TEMP)
19251            BMIN=TEMP(1)
19252            BMAX=TEMP(ICOUNT)
19253            CALL MEAN(TEMP,ICOUNT,IWRITE,BMEAN,IBUGG3,IERROR)
19254            CALL SD(TEMP,ICOUNT,IWRITE,BSD,IBUGG3,IERROR)
19255            CALL MEDIAN(TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,B50,
19256     1                  IBUGG3,IERROR)
19257            CALL MAD(TEMP,ICOUNT,IWRITE,XTEMP1,XTEMP2,MAXNXT,BMAD,
19258     1               IBUGG3,IERROR)
19259C
19260C           COMPUTE SELECT PERCENTILES
19261C
19262            DO137L=1,NPERC
19263              ATEMP=APERC(L)
19264              CALL PERCEN(APERC(L),TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,
19265     1                    BTEMP,IBUGG3,IERROR)
19266              BPERC(L)=BTEMP
19267  137       CONTINUE
19268C
19269C           COMPUTE SELECT CONFIDENCE INTERVALS
19270C
19271            DO1130II=1,NUMALP
19272              ALP=ALPHA(L)
19273              ATEMP1=100.0*(ALP/2.0)
19274              CALL PERCEN(ATEMP1,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,
19275     1                    BTEMP1,IBUGG3,IERROR)
19276              ALOWPA(L,IPAR)=BTEMP1
19277              ATEMP2=100.0*(1.0 - (ALP/2.0))
19278              CALL PERCEN(ATEMP2,TEMP,ICOUNT,IWRITE,XTEMP1,MAXNXT,
19279     1                    BTEMP2,IBUGG3,IERROR)
19280              AUPPPA(L,IPAR)=BTEMP2
19281 1130       CONTINUE
19282C
19283            IF(NUMPAR.EQ.1)THEN
19284              WRITE(IOUNI2,139)ISET1,ISET2,BMEAN,BSD,B50,
19285     1                         (BPERC(LL),LL=1,15)
19286  139         FORMAT(2I8,18E15.7)
19287            ELSE
19288              WRITE(IOUNI2,138)IPAR,ISET1,ISET2,BMEAN,BSD,B50,
19289     1                         (BPERC(LL),LL=1,15)
19290  138         FORMAT(3I8,18E15.7)
19291            ENDIF
19292  135     CONTINUE
19293        ENDIF
19294C
19295C               ******************
19296C               **   STEP 90--  **
19297C               **   EXIT       **
19298C               ******************
19299C
19300      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'JBS9')THEN
19301        WRITE(ICOUT,999)
19302        CALL DPWRST('XXX','BUG ')
19303        WRITE(ICOUT,9011)
19304 9011   FORMAT('***** AT THE END       OF DPJBS9--')
19305        CALL DPWRST('XXX','BUG ')
19306      ENDIF
19307C
19308      RETURN
19309      END
19310      SUBROUTINE DPJUST(ICOM,IHARG,NUMARG,
19311     1IDEFJU,
19312     1ITEXJU,
19313     1IBUGD2,ISUBRO,IFOUND,IERROR)
19314C
19315C     PURPOSE--DEFINE THE JUSTIFICATION TYPE FOR
19316C              TEXT SCRIPT
19317C              ON A PLOT.
19318C              THE JUSTIFICATION FOR THE TEXT WILL BE PLACED
19319C              IN THE CHARACTER VARIABLE ITEXJU.
19320C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
19321C                     --NUMARG
19322C                     --IDEFJU
19323C                     --IBUGD2
19324C     OUTPUT ARGUMENTS--ITEXJU
19325C                     --IFOUND ('YES' OR 'NO' )
19326C                     --IERROR ('YES' OR 'NO' )
19327C     WRITTEN BY--JAMES J. FILLIBEN
19328C                 STATISTICAL ENGINEERING DIVISION
19329C                 INFORMATION TECHNOLOGY LABORATORY
19330C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19331C                 GAITHERSBURG, MD 20899-8980
19332C                 PHONE--301-975-2855
19333C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19334C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19335C     LANGUAGE--ANSI FORTRAN (1977)
19336C     VERSION NUMBER--82/7
19337C     ORIGINAL VERSION--APRIL     1981.
19338C     UPDATED         --MAY       1982.
19339C
19340C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19341C
19342      CHARACTER*4 ICOM
19343      CHARACTER*4 IHARG
19344      CHARACTER*4 IDEFJU
19345      CHARACTER*4 ITEXJU
19346      CHARACTER*4 IBUGD2
19347      CHARACTER*4 ISUBRO
19348      CHARACTER*4 IFOUND
19349      CHARACTER*4 IERROR
19350C
19351C---------------------------------------------------------------------
19352C
19353      DIMENSION IHARG(*)
19354C
19355C---------------------------------------------------------------------
19356C
19357      INCLUDE 'DPCOP2.INC'
19358C
19359C-----START POINT-----------------------------------------------------
19360C
19361      IFOUND='NO'
19362      IERROR='NO'
19363C
19364      IF(IBUGD2.EQ.'OFF')GOTO90
19365      WRITE(ICOUT,999)
19366  999 FORMAT(1X)
19367      CALL DPWRST('XXX','BUG ')
19368      WRITE(ICOUT,51)
19369   51 FORMAT('***** AT THE BEGINNING OF DPJUST--')
19370      CALL DPWRST('XXX','BUG ')
19371      WRITE(ICOUT,53)ICOM,NUMARG,IDEFJU
19372   53 FORMAT('ICOM,NUMARG,IDEFJU = ',A4,2X,I8,2X,A4)
19373      CALL DPWRST('XXX','BUG ')
19374      DO55I=1,NUMARG
19375      WRITE(ICOUT,56)I,IHARG(I)
19376   56 FORMAT('I,IHARG(I) = ',I8,2X,A4)
19377      CALL DPWRST('XXX','BUG ')
19378   55 CONTINUE
19379   90 CONTINUE
19380C
19381C               ************************************
19382C               **  TREAT THE JUSTIFICATION CASE  **
19383C               ************************************
19384C
19385      IF(ICOM.EQ.'JUST')GOTO1120
19386      IF(ICOM.EQ.'LEFT')GOTO1130
19387      IF(ICOM.EQ.'CENT')GOTO1140
19388      IF(ICOM.EQ.'RIGH')GOTO1150
19389C
19390 1120 CONTINUE
19391      IF(NUMARG.LE.0)GOTO1161
19392      IF(IHARG(NUMARG).EQ.'ON')GOTO1161
19393      IF(IHARG(NUMARG).EQ.'OFF')GOTO1161
19394      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161
19395      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
19396      IF(IHARG(NUMARG).EQ.'?')GOTO8100
19397      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'LEFT')GOTO1161
19398      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CENT')GOTO1162
19399      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'RIGH')GOTO1163
19400      GOTO1170
19401C
19402 1130 CONTINUE
19403      IF(NUMARG.LE.0)GOTO9000
19404      IF(IHARG(NUMARG).EQ.'ON')GOTO1161
19405      IF(IHARG(NUMARG).EQ.'OFF')GOTO1161
19406      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1161
19407      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
19408      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'JUST')GOTO1161
19409      GOTO9000
19410C
19411 1140 CONTINUE
19412      IF(NUMARG.LE.0)GOTO9000
19413      IF(IHARG(NUMARG).EQ.'ON')GOTO1162
19414      IF(IHARG(NUMARG).EQ.'OFF')GOTO1162
19415      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1162
19416      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
19417      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'JUST')GOTO1162
19418      GOTO9000
19419C
19420 1150 CONTINUE
19421      IF(NUMARG.LE.0)GOTO9000
19422      IF(IHARG(NUMARG).EQ.'ON')GOTO1163
19423      IF(IHARG(NUMARG).EQ.'OFF')GOTO1163
19424      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1163
19425      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1165
19426      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'JUST')GOTO1163
19427      GOTO9000
19428C
19429 1161 CONTINUE
19430      ITEXJU='LEFT'
19431      GOTO1180
19432C
19433 1162 CONTINUE
19434      ITEXJU='CENT'
19435      GOTO1180
19436C
19437 1163 CONTINUE
19438      ITEXJU='RIGH'
19439      GOTO1180
19440C
19441 1165 CONTINUE
19442      ITEXJU=IDEFJU
19443      GOTO1180
19444C
19445 1170 CONTINUE
19446CCCCC IERROR='YES'
19447CCCCC WRITE(ICOUT,1171)
19448C1171 FORMAT('***** ERROR IN DPJUST--')
19449CCCCC CALL DPWRST('XXX','BUG ')
19450CCCCC WRITE(ICOUT,1172)
19451C1172 FORMAT('      ILLEGAL ENTRY FOR JUSTIFICATION ',
19452CCCCC CALL DPWRST('XXX','BUG ')
19453CCCCC1'COMMAND.')
19454CCCCC WRITE(ICOUT,1173)
19455C1173 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
19456CCCCC CALL DPWRST('XXX','BUG ')
19457CCCCC1'PROPER FORM--')
19458CCCCC WRITE(ICOUT,1174)
19459C1174 FORMAT('      SUPPOSE THE THE ANALYST WISHES ')
19460CCCCC CALL DPWRST('XXX','BUG ')
19461CCCCC WRITE(ICOUT,1175)
19462C1175 FORMAT('      TO HAVE ALL LEGENDS CENTERED,')
19463CCCCC CALL DPWRST('XXX','BUG ')
19464CCCCC WRITE(ICOUT,1177)
19465C1177 FORMAT('      THEN ALLOWABLE FORMS ARE--')
19466CCCCC CALL DPWRST('XXX','BUG ')
19467CCCCC WRITE(ICOUT,1178)
19468C1178 FORMAT('           JUSTIFICATION CENTER ')
19469CCCCC CALL DPWRST('XXX','BUG ')
19470CCCCC WRITE(ICOUT,1179)
19471C1179 FORMAT('           CENTER JUSTIFICATION ')
19472CCCCC CALL DPWRST('XXX','BUG ')
19473CCCCC GOTO9000
19474      ITEXJU=IHARG(NUMARG)
19475      GOTO1180
19476C
19477 1180 CONTINUE
19478      IFOUND='YES'
19479C
19480      IF(IFEEDB.EQ.'OFF')GOTO1189
19481      WRITE(ICOUT,999)
19482      CALL DPWRST('XXX','BUG ')
19483      WRITE(ICOUT,1181)
19484 1181 FORMAT('THE JUSTIFICATION (FOR PLOT SCRIPT AND TEXT) ')
19485      CALL DPWRST('XXX','BUG ')
19486      WRITE(ICOUT,1182)ITEXJU
19487 1182 FORMAT('HAS JUST BEEN SET TO ',A4)
19488      CALL DPWRST('XXX','BUG ')
19489 1189 CONTINUE
19490      GOTO9000
19491C
19492C               ********************************************
19493C               **  STEP 81--                             **
19494C               **  TREAT THE    ?    CASE--              **
19495C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
19496C               ********************************************
19497C
19498 8100 CONTINUE
19499      IFOUND='YES'
19500      WRITE(ICOUT,999)
19501      CALL DPWRST('XXX','BUG ')
19502      WRITE(ICOUT,8111)ITEXJU
19503 8111 FORMAT('THE CURRENT JUSTIFICATION IS ',A4)
19504      CALL DPWRST('XXX','BUG ')
19505      WRITE(ICOUT,8112)IDEFJU
19506 8112 FORMAT('THE DEFAULT JUSTIFICATION IS ',A4)
19507      CALL DPWRST('XXX','BUG ')
19508      GOTO9000
19509C
19510C               *****************
19511C               **  STEP 90--  **
19512C               **  EXIT       **
19513C               *****************
19514C
19515 9000 CONTINUE
19516      IF(IBUGD2.EQ.'OFF')GOTO9090
19517      WRITE(ICOUT,999)
19518      CALL DPWRST('XXX','BUG ')
19519      WRITE(ICOUT,9011)
19520 9011 FORMAT('***** AT THE END       OF DPJUST')
19521      CALL DPWRST('XXX','BUG ')
19522      WRITE(ICOUT,9012)IBUGD2,ISUBRO,IFOUND,IERROR
19523 9012 FORMAT('IBUGD2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
19524      CALL DPWRST('XXX','BUG ')
19525      WRITE(ICOUT,9013)ITEXJU,IDEFJU
19526 9013 FORMAT('ITEXJU,IDEFJU = ',A4,2X,A4)
19527      CALL DPWRST('XXX','BUG ')
19528 9090 CONTINUE
19529C
19530      RETURN
19531      END
19532      SUBROUTINE DPKAPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
19533     1                  IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
19534C
19535C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
19536C              THAT WILL DEFINE AN KAPLAN-MEIER PLOT
19537C     WRITTEN BY--ALAN HECKERT
19538C                 STATISTICAL ENGINEERING DIVISION
19539C                 INFORMATION TECHNOLOGY LABORATORY
19540C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19541C                 GAITHERSBURG, MD 20899-8980
19542C                 PHONE--301-975-2855
19543C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19544C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19545C     LANGUAGE--ANSI FORTRAN (1977)
19546C     VERSION NUMBER--98/5
19547C     ORIGINAL VERSION--MAY       1998.
19548C     UPDATED         --JULY      2005. SUPPORT SWITCH FOR WHETHER
19549C                                       SURVIVAL CURVE (DEFAULT) OR
19550C                                       CDF CURVE DRAWN
19551C     UPDATED         --JANUARY   2012. USE DPPARS
19552C
19553C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19554C
19555      CHARACTER*4 ICASPL
19556      CHARACTER*4 IAND1
19557      CHARACTER*4 IAND2
19558      CHARACTER*4 IBUGG2
19559      CHARACTER*4 IBUGG3
19560      CHARACTER*4 ISUBRO
19561      CHARACTER*4 IBUGQ
19562      CHARACTER*4 IFOUND
19563      CHARACTER*4 IERROR
19564C
19565      CHARACTER*4 ISUBN1
19566      CHARACTER*4 ISUBN2
19567      CHARACTER*4 ISTEPN
19568C
19569      CHARACTER*4 ICASE
19570      CHARACTER*40 INAME
19571      PARAMETER (MAXSPN=10)
19572      CHARACTER*4 IVARN1(MAXSPN)
19573      CHARACTER*4 IVARN2(MAXSPN)
19574      CHARACTER*4 IVARTY(MAXSPN)
19575      REAL PVAR(MAXSPN)
19576      INTEGER ILIS(MAXSPN)
19577      INTEGER NRIGHT(MAXSPN)
19578      INTEGER ICOLR(MAXSPN)
19579C
19580C---------------------------------------------------------------------
19581C
19582      INCLUDE 'DPCOPA.INC'
19583      INCLUDE 'DPCOZZ.INC'
19584C
19585      DIMENSION Y1(MAXOBV)
19586      DIMENSION TAG1(MAXOBV)
19587      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
19588      EQUIVALENCE (GARBAG(IGARB2),TAG1(1))
19589C
19590C-----COMMON----------------------------------------------------------
19591C
19592      INCLUDE 'DPCOHK.INC'
19593      INCLUDE 'DPCODA.INC'
19594      INCLUDE 'DPCOST.INC'
19595      INCLUDE 'DPCOP2.INC'
19596C
19597C-----START POINT-----------------------------------------------------
19598C
19599      IFOUND='NO'
19600      IERROR='NO'
19601      ISUBN1='DPKA'
19602      ISUBN2='PL  '
19603C
19604      MAXCP1=MAXCOL+1
19605      MAXCP2=MAXCOL+2
19606      MAXCP3=MAXCOL+3
19607      MAXCP4=MAXCOL+4
19608      MAXCP5=MAXCOL+5
19609      MAXCP6=MAXCOL+6
19610C
19611      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KAPL')THEN
19612        WRITE(ICOUT,999)
19613  999   FORMAT(1X)
19614        CALL DPWRST('XXX','BUG ')
19615        WRITE(ICOUT,51)
19616   51   FORMAT('***** AT THE BEGINNING OF DPKAPL--')
19617        CALL DPWRST('XXX','BUG ')
19618        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,MAXCOL
19619   52   FORMAT('ICASPL,IAND1,IAND2,MAXCOL = ',3(A4,2X),I8)
19620        CALL DPWRST('XXX','BUG ')
19621        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
19622   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
19623        CALL DPWRST('XXX','BUG ')
19624      ENDIF
19625C
19626C
19627C               **********************************
19628C               **  TREAT THE KAPLAN-MEIER PLOT **
19629C               **********************************
19630C
19631C               *******************************************
19632C               **  STEP 1--                             **
19633C               **  SEARCH FOR KAPLAN MEIER, KAPLAN-MEIER**
19634C               **  MODIFIED KAPLAN MEIER, OR MODIFIED   **
19635C               **  KAPLAN-MEIER                         **
19636C               *******************************************
19637C
19638      ISTEPN='11'
19639      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KAPL')
19640     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19641C
19642      IF(NUMARG.GE.1.AND.ICOM.EQ.'KAPL'.AND.IHARG(1).EQ.'PLOT')THEN
19643        ILASTC=1
19644        ICASPL='KAPL'
19645      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'KAPL'.AND.
19646     1       IHARG(1).EQ.'MEIE'.AND.IHARG(2).EQ.'PLOT')THEN
19647        ILASTC=2
19648        ICASPL='KAPL'
19649      ELSEIF(NUMARG.GE.2.AND.ICOM.EQ.'MODI'.AND.
19650     1       IHARG(1).EQ.'KAPL'.AND.IHARG(2).EQ.'PLOT')THEN
19651        ILASTC=2
19652        ICASPL='MKAP'
19653      ELSEIF(NUMARG.GE.3.AND.ICOM.EQ.'MODI'.AND.
19654     1       IHARG(1).EQ.'KAPL'.AND.IHARG(2).EQ.'MEIE'.AND.
19655     1       IHARG(3).EQ.'PLOT')THEN
19656        ILASTC=3
19657        ICASPL='MKAP'
19658      ELSE
19659        ICASPL='    '
19660        IFOUND='NO'
19661        GOTO9000
19662      ENDIF
19663C
19664      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
19665      IFOUND='YES'
19666C
19667C               ****************************************
19668C               **  STEP 2--                          **
19669C               **  EXTRACT THE VARIABLE LIST         **
19670C               ****************************************
19671C
19672      ISTEPN='2'
19673      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KAPL')
19674     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19675C
19676      INAME='KAPLAN-MEIER PLOT'
19677      MINNA=1
19678      MAXNA=100
19679      MINN2=1
19680      IFLAGE=1
19681      IFLAGM=0
19682      IFLAGP=0
19683      JMIN=1
19684      JMAX=NUMARG
19685      MINNVA=1
19686      MAXNVA=2
19687C
19688      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
19689     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
19690     1            JMIN,JMAX,
19691     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
19692     1            IVARN1,IVARN2,IVARTY,PVAR,
19693     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
19694     1            MINNVA,MAXNVA,
19695     1            IFLAGM,IFLAGP,
19696     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
19697      IF(IERROR.EQ.'YES')GOTO9000
19698C
19699      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KAPL')THEN
19700        WRITE(ICOUT,999)
19701        CALL DPWRST('XXX','BUG ')
19702        WRITE(ICOUT,281)
19703  281   FORMAT('***** AFTER CALL DPPARS--')
19704        CALL DPWRST('XXX','BUG ')
19705        WRITE(ICOUT,282)NQ,NUMVAR
19706  282   FORMAT('NQ,NUMVAR = ',2I8)
19707        CALL DPWRST('XXX','BUG ')
19708        IF(NUMVAR.GT.0)THEN
19709          DO285I=1,NUMVAR
19710            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
19711     1                      ICOLR(I)
19712  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
19713     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
19714            CALL DPWRST('XXX','BUG ')
19715  285     CONTINUE
19716        ENDIF
19717      ENDIF
19718C
19719C
19720C               *********************************************************
19721C               **  STEP 41--                                          **
19722C               **  FORM THE VERTICAL AND HORIZONTALAXIS               **
19723C               **  VARIABLES (Y(.) AND X(.), RESPECTIVELY)FOR THE     **
19724C               **  PLOT.  FORM THE CURVE DESIGNATION VARIABLED(.)  .  **
19725C               **  THIS WILL BE ALL ONES.                             **
19726C               **  DEFINE THE NUMBER OF PLOT POINTS   (NPLOTP).       **
19727C               **  DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV).       **
19728C               *********************************************************
19729C
19730      ISTEPN='41'
19731      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KAPL')
19732     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19733C
19734      ICOL=1
19735      CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
19736     1            INAME,IVARN1,IVARN2,IVARTY,
19737     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
19738     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
19739     1            MAXCP4,MAXCP5,MAXCP6,
19740     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
19741     1            Y1,TAG1,Y1,NS,NS,NS,ICASE,
19742     1            IBUGG3,ISUBRO,IFOUND,IERROR)
19743      IF(IERROR.EQ.'YES')GOTO9000
19744C
19745      CALL DPKAP2(Y1,TAG1,NS,NUMVAR,ICASPL,MAXN,
19746     1            IKAPSW,
19747     1            Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
19748C
19749C               *****************
19750C               **  STEP 90--  **
19751C               **  EXIT       **
19752C               *****************
19753C
19754 9000 CONTINUE
19755      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KAPL')THEN
19756        WRITE(ICOUT,999)
19757        CALL DPWRST('XXX','BUG ')
19758        WRITE(ICOUT,9011)
19759 9011   FORMAT('***** AT THE END       OF DPKAPL--')
19760        CALL DPWRST('XXX','BUG ')
19761        WRITE(ICOUT,9012)IFOUND,IERROR
19762 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
19763        CALL DPWRST('XXX','BUG ')
19764        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
19765 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',3I8,3(2X,A4))
19766        CALL DPWRST('XXX','BUG ')
19767        IF(NPLOTP.LE.0)THEN
19768          DO9015I=1,NPLOTP
19769            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
19770 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
19771            CALL DPWRST('XXX','BUG ')
19772 9015     CONTINUE
19773        ENDIF
19774      ENDIF
19775C
19776      RETURN
19777      END
19778      SUBROUTINE DPKAP2(Y1,TAG1,N,NUMV,ICASPL,MAXN,
19779     1                  IKAPSW,
19780     1                  Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
19781C
19782C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
19783C              THAT WILL DEFINE AN KAPLAN-MEIER PLOT
19784C     INPUT ARGUMENTS--Y1     = THE SINGLE PRECISION VECTOR OF
19785C                               (UNSORTED) OBSERVATIONS
19786C                               FOR THE FIRST  VARIABLE.
19787C                      TAG1   = 1 = FAILURE TIME, 0 = CENSORED
19788C                      N      = THE INTEGER NUMBER OF OBSERVATIONS
19789C                               IN THE VECTOR X.
19790C     CAUTION--THE INPUT VARIABLE Y1(.) WILL BE CHANGED HEREIN
19791C              (IT WILL BE SORTED)
19792C     WRITTEN BY--ALAN HECKERT
19793C                 STATISTICAL ENGINEERING DIVISION
19794C                 INFORMATION TECHNOLOGY LABORATORY
19795C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19796C                 GAITHERSBURG, MD 20899-8980
19797C                 PHONE--301-975-2855
19798C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19799C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19800C     LANGUAGE--ANSI FORTRAN (1977)
19801C     VERSION NUMBER--98/5
19802C     ORIGINAL VERSION--MAY       1998.
19803C     UPDATED         --JULY      2005. SWITCH TO SPECIFY WHETHER
19804C                                       SURVIVAL CURVE (DEFAULT) OR
19805C                                       CDF CURVE DRAWN
19806C     UPDATED         --JUNE      2008. ACCOMODATE NEGATIVE DATA
19807C                                       (E.G. FOR REVERSE WEIBULL
19808C                                       OR REVERSE FRECHET)
19809C
19810C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19811C
19812      CHARACTER*4 ICASPL
19813      CHARACTER*4 IKAPSW
19814      CHARACTER*4 IBUGG3
19815      CHARACTER*4 ISUBRO
19816      CHARACTER*4 IERROR
19817C
19818      CHARACTER*4 ISUBN1
19819      CHARACTER*4 ISUBN2
19820C
19821C---------------------------------------------------------------------
19822C
19823      DOUBLE PRECISION DPROD
19824      DOUBLE PRECISION DCURR
19825      DOUBLE PRECISION DN
19826      DOUBLE PRECISION DCORR
19827C
19828      DIMENSION Y1(*)
19829      DIMENSION TAG1(*)
19830C
19831      DIMENSION Y(*)
19832      DIMENSION X(*)
19833      DIMENSION D(*)
19834C
19835C---------------------------------------------------------------------
19836C
19837      INCLUDE 'DPCOP2.INC'
19838C
19839C-----START POINT-----------------------------------------------------
19840C
19841      ISUBN1='DPKA'
19842      ISUBN2='P2  '
19843      IERROR='NO'
19844C
19845      J=0
19846C
19847      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KAP2')THEN
19848        WRITE(ICOUT,999)
19849  999   FORMAT(1X)
19850        CALL DPWRST('XXX','BUG ')
19851        WRITE(ICOUT,51)
19852   51   FORMAT('***** AT THE BEGINNING OF DPKAP2--')
19853        CALL DPWRST('XXX','BUG ')
19854        WRITE(ICOUT,52)IBUGG3,ISUBRO,IERROR
19855   52   FORMAT('IBUGG3,ISUBRO,IERROR = ',2(A4,2X),A4)
19856        CALL DPWRST('XXX','BUG ')
19857        WRITE(ICOUT,53)ICASPL,N,MAXN,NUMV
19858   53   FORMAT('ICASPL,N,MAXN,NUMV = ',A4,2X,3I8)
19859        CALL DPWRST('XXX','BUG ')
19860        DO55I=1,N
19861          WRITE(ICOUT,56)I,Y1(I),TAG1(I)
19862   56     FORMAT('I, Y1(I), TAG1(I), = ',I8,2G15.7)
19863          CALL DPWRST('XXX','BUG ')
19864   55   CONTINUE
19865      ENDIF
19866C
19867C               ********************************************
19868C               **  STEP 1--                              **
19869C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
19870C               ********************************************
19871C
19872      IF(N.LT.2)THEN
19873        WRITE(ICOUT,999)
19874        CALL DPWRST('XXX','BUG ')
19875        WRITE(ICOUT,111)
19876  111   FORMAT('***** ERROR IN KAPLAN-MEIER PLOT--')
19877        CALL DPWRST('XXX','BUG ')
19878        WRITE(ICOUT,112)
19879  112   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2.')
19880        CALL DPWRST('XXX','BUG ')
19881        WRITE(ICOUT,114)N
19882  114   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
19883        CALL DPWRST('XXX','BUG ')
19884        WRITE(ICOUT,999)
19885        CALL DPWRST('XXX','BUG ')
19886        IERROR='YES'
19887        GOTO9000
19888      ENDIF
19889C
19890      HOLD=Y1(1)
19891      DO120I=1,N
19892        IF(Y1(I).NE.HOLD)GOTO129
19893  120 CONTINUE
19894      WRITE(ICOUT,999)
19895      CALL DPWRST('XXX','BUG ')
19896      WRITE(ICOUT,111)
19897      CALL DPWRST('XXX','BUG ')
19898      WRITE(ICOUT,122)HOLD
19899  122 FORMAT('      ALL ELEMENTS IN THE RESPONSE VARIABLE ARE ',
19900     1       'IDENTICALLY EQUAL TO ',G15.7)
19901      CALL DPWRST('XXX','BUG ')
19902      WRITE(ICOUT,999)
19903      CALL DPWRST('XXX','BUG ')
19904      IERROR='YES'
19905      GOTO9000
19906  129 CONTINUE
19907C
19908C               ***********************************************
19909C               **  STEP 12--                                **
19910C               **  COMPUTE COORDINATES FOR KAPLAN MEIER PLOT**
19911C               **  (INCORPORATE STAIR-STEP APPEARANCE)      **
19912C               ***********************************************
19913C
19914      CALL SORTC(Y1,TAG1,N,Y1,TAG1)
19915C
19916      XMIN=Y1(1)
19917      XMAX=Y1(N)
19918C
19919      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KAP2')THEN
19920        DO135I=1,N
19921        WRITE(ICOUT,136)I,Y1(I),TAG1(I)
19922  136   FORMAT('I, Y1(I), TAG1(I), = ',I8,2G15.7)
19923        CALL DPWRST('XXX','BUG ')
19924  135   CONTINUE
19925      ENDIF
19926C
19927      DN=DBLE(N)
19928      IF(ICASPL.EQ.'KAPL')THEN
19929        IR=0
19930        J=1
19931        IF(XMIN.LT.0.0)THEN
19932          X(J)=XMIN
19933        ELSE
19934          X(J)=0.0
19935        ENDIF
19936        Y(J)=1.0
19937        D(J)=1.0
19938C
19939        DPROD=1.0D0
19940        DO200I=1,N
19941          IF(NUMV.GE.2 .AND. ABS(TAG1(I)).LT.0.5)GOTO200
19942          J=J+1
19943          X(J)=Y1(I)
19944          Y(J)=Y(J-1)
19945          D(J)=1.0
19946C
19947          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KAP2')THEN
19948            WRITE(ICOUT,203)I,J,X(J),Y(J)
19949  203       FORMAT('I,J,X(J),Y(J)=',2I8,2G15.7)
19950            CALL DPWRST('XXX','BUG ')
19951          ENDIF
19952C
19953          DCURR=(DN - DBLE(I))/(DN - DBLE(I) + 1.0D0)
19954          DPROD=DPROD*DCURR
19955          J=J+1
19956          X(J)=Y1(I)
19957          Y(J)=REAL(DPROD)
19958          D(J)=1.0
19959C
19960          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KAP2')THEN
19961            WRITE(ICOUT,204)I,J,X(J),Y(J)
19962  204       FORMAT('I,J,X(J),Y(J)=',2I8,2G15.7)
19963            CALL DPWRST('XXX','BUG ')
19964          ENDIF
19965C
19966  200   CONTINUE
19967      ELSEIF(ICASPL.EQ.'MKAP')THEN
19968        IR=0
19969        J=1
19970        IF(XMIN.LT.0.0)THEN
19971          X(J)=XMIN
19972        ELSE
19973          X(J)=0.0
19974        ENDIF
19975        Y(J)=1.0
19976        D(J)=1.0
19977C
19978        DPROD=1.0D0
19979        DCORR=(DN + 0.7D0)/(DN + 0.4D0)
19980        DO400I=1,N
19981          IF(NUMV.GE.2 .AND. ABS(TAG1(I)).LT.0.5)GOTO400
19982          J=J+1
19983          X(J)=Y1(I)
19984          Y(J)=Y(J-1)
19985          D(J)=1.0
19986          DCURR=(DN - DBLE(I) + 0.7D0)/(DN - DBLE(I) + 1.7D0)
19987          DPROD=DPROD*DCURR
19988          J=J+1
19989          X(J)=Y1(I)
19990          Y(J)=REAL(DCORR*DPROD)
19991          D(J)=1.0
19992  400   CONTINUE
19993      ENDIF
19994C
19995      NPLOTP=J
19996      NPLOTV=2
19997C
19998CCCCC JULY 2005: CONVERT TO CDF FORMAT
19999C
20000      IF(IKAPSW.EQ.'CDF')THEN
20001        DO510I=1,NPLOTP
20002          Y(I)=1.0 - Y(I)
20003  510   CONTINUE
20004      ENDIF
20005C
20006C               ******************
20007C               **   STEP 90--  **
20008C               **   EXIT       **
20009C               ******************
20010C
20011 9000 CONTINUE
20012      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KAP2')THEN
20013        WRITE(ICOUT,999)
20014        CALL DPWRST('XXX','BUG ')
20015        WRITE(ICOUT,9011)
20016 9011   FORMAT('***** AT THE END       OF DPKAP2--')
20017        CALL DPWRST('XXX','BUG ')
20018        WRITE(ICOUT,9013)N,MAXN,NPLOTP,NPLOTV,ICASPL,IERROR
20019 9013   FORMAT('N,MAXN,NPLOTP,NPLOTV,ICASPL,IERROR = ',4I8,2(2X,A4))
20020        CALL DPWRST('XXX','BUG ')
20021        DO9022I=1,NPLOTP
20022          WRITE(ICOUT,9023)I,Y(I),X(I),D(I)
20023 9023     FORMAT('I,Y(I),X(I),D(I) = ',I8,3G15.7)
20024          CALL DPWRST('XXX','BUG ')
20025 9022   CONTINUE
20026      ENDIF
20027C
20028      RETURN
20029      END
20030      SUBROUTINE DPKAR3(Y,N,TEMP1,MAXNXT,
20031     1                  STATVA,CUTOFF,
20032     1                  ISUBRO,IBUGA3,IERROR)
20033C
20034C     PURPOSE--THIS SUBROUTINE COMPUTES KAPPENMAN'S STATISTIC FOR
20035C              DISTINGUISHING BETWEEN A WEIBULL AND A LOGNORMAL
20036C              DISTRIBUTION.  THE TEST STATISTIC IS:
20037C
20038C                 R = (A3 - A2)/(A2 - A1)
20039C
20040C              WHERE
20041C
20042C                 A1 = AVERAGE OF THE LOWER 5% OF THE ORDERED LOGARITHMS
20043C                      OF THE DATA
20044C                 A3 = AVERAGE OF THE UPPER 5% OF THE ORDERED LOGARITHMS
20045C                      OF THE DATA
20046C                 A2 = AVERAGE OF THE ORDERED LOGARITHMS OF THE DATA
20047C                      AFTER TRIMMING THE LOWER 20% AND THE UPPER 20%.
20048C              THEN IF R > 0.7477 SELECT LOGNORMAL AND IF R < 0.7477
20049C              CHOOSE WEIBULL.
20050C
20051C              RESTRICT THIS TEST TO A MINIMUM SAMPLE SIZE OF 20.
20052C
20053C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION RESPONSE VARIABLE.
20054C                     --N      = AN INTEGER PARAMETER THAT SPECIFIES THE
20055C                                NUMBER OF VALUES IN THE RESPONSE
20056C                                VARIABLE.
20057C     OUTPUT ARGUMENTS--R      = THE SINGLE PRECISION VALUE OF THE TEST
20058C                                STATISTIC.
20059C     OUTPUT--THE SINGLE PRECISION VALUE OF THE TEST STATISTIC.
20060C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
20061C     RESTRICTIONS--SAMPLE SIZE SHOULD BE AT LEAST 20.
20062C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, TRIMME.
20063C     FORTRAN LIBRARY SUBROUTINES NEEDED--LOG.
20064C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
20065C     LANGUAGE--ANSI FORTRAN (1977)
20066C     REFERENCE --KAPPENMAN (1988), "A SIMPLE METHOD FOR CHOOSING
20067C                 BETWEEN THE LOGNORMAL AND WEIBULL MODELS", STATISTICS
20068C                 & PROBABILITY LETTERS", VOL. 7, NO. 2, PP. 123-126.
20069C               --JOHN MCCOOL (2012), "USING THE WEIBULL DISTRIBUTION:
20070C                 RELIABILITY, MODELING, AND INFERENCE", WILEY,
20071C                 PP. 207-210.
20072C     WRITTEN BY--ALAN HECKERT
20073C                 STATISTICAL ENGINEERING DIVISION
20074C                 INFORMATION TECHNOLOGY LABORATORY
20075C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20076C                 GAITHERSBURG, MD 20899
20077C                 PHONE--301-975-2899
20078C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20079C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20080C     LANGUAGE--ANSI FORTRAN (1977)
20081C     VERSION NUMBER--2014/05
20082C     ORIGINAL VERSION--MAY       2014.
20083C
20084C---------------------------------------------------------------------
20085C
20086      REAL Y(*)
20087      REAL TEMP1(*)
20088C
20089      CHARACTER*4 ISUBRO
20090      CHARACTER*4 IBUGA3
20091      CHARACTER*4 IERROR
20092C
20093      CHARACTER*4 IWRITE
20094C
20095      INCLUDE 'DPCOP2.INC'
20096C
20097C-----START POINT-----------------------------------------------------
20098C
20099      IF(ISUBRO.EQ.'KAR3' .OR. IBUGA3.EQ.'ON')THEN
20100        WRITE(ICOUT,999)
20101        CALL DPWRST('XXX','BUG ')
20102        WRITE(ICOUT,51)
20103   51   FORMAT('AT THE BEGINNING OF DPKAR3')
20104        CALL DPWRST('XXX','BUG ')
20105        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
20106   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
20107        CALL DPWRST('XXX','BUG ')
20108        DO55I=1,N
20109          WRITE(ICOUT,57)I,Y(I)
20110   57     FORMAT('I,Y(I) = ',I8,G15.7)
20111          CALL DPWRST('XXX','BUG ')
20112   55   CONTINUE
20113      ENDIF
20114C
20115      STATVA=CPUMIN
20116      CUTOFF=0.7477
20117C
20118      IF(N.LT.20)THEN
20119        WRITE(ICOUT,999)
20120  999   FORMAT(1X)
20121        CALL DPWRST('XXX','BUG ')
20122        WRITE(ICOUT,91)
20123   91   FORMAT('***** ERROR IN KAPPENMAN R STATISTIC--')
20124        CALL DPWRST('XXX','BUG ')
20125        WRITE(ICOUT,93)
20126   93   FORMAT('      A MINIMUM SAMPLE SIZE OF 20 IS REQUIRED.')
20127        CALL DPWRST('XXX','BUG ')
20128        WRITE(ICOUT,95)N
20129   95   FORMAT('      THE NUMBER OF RESPONSE VALUES IS   ',I8)
20130        CALL DPWRST('XXX','BUG ')
20131        IERROR='YES'
20132        GOTO9000
20133      ELSE
20134        DO96I=1,N
20135          IF(Y(I).LE.0.0)THEN
20136            WRITE(ICOUT,999)
20137            CALL DPWRST('XXX','BUG ')
20138            WRITE(ICOUT,91)
20139            CALL DPWRST('XXX','BUG ')
20140            WRITE(ICOUT,98)I,Y(I)
20141   98       FORMAT('      ROW ',I8,' IS NON-POSITIVE.  IT HAS THE ',
20142     1             'VALUE ',G15.7)
20143            CALL DPWRST('XXX','BUG ')
20144            IERROR='YES'
20145            GOTO9000
20146          ELSE
20147            Y(I)=LOG(Y(I))
20148          ENDIF
20149   96   CONTINUE
20150      ENDIF
20151C
20152      CALL SORT(Y,N,Y)
20153C
20154C     TRIMMED MEAN WITH 20% TRIMMING ON EACH TAIL
20155C
20156      PROP1=20.0
20157      PROP2=20.0
20158      NTRIM1=0
20159      NTRIM2=0
20160      IWRITE='OFF'
20161      CALL TRIMME(Y,N,PROP1,PROP2,NTRIM1,NTRIM2,IWRITE,TEMP1,
20162     1            MAXNXT,A2,
20163     1            IBUGA3,ISUBRO,IERROR)
20164C
20165C     AVERAGE OF LOWER 5% OF VALUES
20166C
20167      AFRAC=0.05*REAL(N)
20168      IFRAC=INT(AFRAC)
20169      REM=AFRAC-REAL(IFRAC)
20170      IF(IFRAC.GE.1)THEN
20171        CALL MEAN(Y,IFRAC,IWRITE,XMEAN,IBUGA3,IERROR)
20172        A1=(XMEAN + REM*Y(IFRAC+1))/(REAL(IFRAC) + REM)
20173      ELSE
20174        A1=Y(1)
20175      ENDIF
20176C
20177C     AVERAGE OF UPPER 5% OF VALUES
20178C
20179      IF(IFRAC.GE.1)THEN
20180        NSTRT=N-IFRAC+1
20181        SUM=0.0
20182        DO110I=NSTRT,N
20183          SUM=SUM + Y(I)
20184  110   CONTINUE
20185        XMEAN=SUM/REAL(IFRAC)
20186        A3=(XMEAN + REM*Y(NSTRT-1))/(REAL(IFRAC) + REM)
20187      ELSE
20188        A3=Y(N)
20189      ENDIF
20190C
20191      STATVA=(A3-A2)/(A2-A1)
20192C
20193 9000 CONTINUE
20194      IF(ISUBRO.EQ.'KAR3' .OR. IBUGA3.EQ.'ON')THEN
20195        WRITE(ICOUT,999)
20196        CALL DPWRST('XXX','BUG ')
20197        WRITE(ICOUT,9001)
20198 9001   FORMAT('AT THE END OF DPKAR3')
20199        CALL DPWRST('XXX','BUG ')
20200        WRITE(ICOUT,9002)IERROR,STATVA
20201 9002   FORMAT('IERROR,STATVA = ',A4,2X,G15.7)
20202        CALL DPWRST('XXX','BUG ')
20203        WRITE(ICOUT,9003)IFRAC,REM,A1,A2,A3
20204 9003   FORMAT('IFRAC,REM,A1,A2,A3 = ',I8,4G15.7)
20205        CALL DPWRST('XXX','BUG ')
20206      ENDIF
20207C
20208      RETURN
20209      END
20210      SUBROUTINE DPKDEN(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
20211     1                  IKDENP,PKDEWI,ISEED,
20212     1                  ISUBRO,IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
20213C
20214C     PURPOSE--GENERATE A KERNEL DENSITY PLOT USING A
20215C              GAUSSIAN WINDOW.  USES APPLIED STATISTICS
20216C              ALGORITHM 176 (BY B. W. SILVERMAN).
20217C     WRITTEN BY--ALAN HECKERT
20218C                 STATISTICAL ENGINEERING DIVISION
20219C                 INFORMATION TECHNOLOGY LABORATORY
20220C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20221C                 GAITHERSBURG, MD 20899-8980
20222C                 PHONE--301-975-2899
20223C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20224C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20225C     LANGUAGE--ANSI FORTRAN (1977)
20226C     VERSION NUMBER--2001/8
20227C     ORIGINAL VERSION--AUGUST    2001.
20228C     UPDATED         --FEBRUARY  2010. USE DPPARS
20229C     UPDATED         --FEBRUARY  2010. SUPPORT FOR "MULTIPLE" AND
20230C                                       "REPLICATION"
20231C     UPDATED         --MARCH     2010. USE DPPAR3 FOR SINGLE RESPONSE
20232C                                       VARIABLE OR MULTIPLE CASES
20233C
20234C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20235C
20236      CHARACTER*4 ICASPL
20237      CHARACTER*4 IAND1
20238      CHARACTER*4 IAND2
20239      CHARACTER*4 ISUBRO
20240      CHARACTER*4 IBUGG2
20241      CHARACTER*4 IBUGG3
20242      CHARACTER*4 IBUGQ
20243      CHARACTER*4 IFOUND
20244      CHARACTER*4 IFOUN1
20245      CHARACTER*4 IFOUN2
20246      CHARACTER*4 IERROR
20247C
20248      CHARACTER*4 ICASE
20249      CHARACTER*4 ISUBN1
20250      CHARACTER*4 ISUBN2
20251      CHARACTER*4 ISTEPN
20252C
20253C---------------------------------------------------------------------
20254C
20255      INCLUDE 'DPCOPA.INC'
20256      INCLUDE 'DPCOZD.INC'
20257      INCLUDE 'DPCOZZ.INC'
20258C
20259      DOUBLE PRECISION Y1(MAXOBV)
20260      DOUBLE PRECISION SMOOTH(MAXOBV)
20261      DOUBLE PRECISION FT(MAXOBV)
20262      DOUBLE PRECISION ZY(MAXOBV)
20263      DIMENSION X1(MAXOBV)
20264      DIMENSION XIDTEM(MAXOBV)
20265      DIMENSION XIDTE2(MAXOBV)
20266      DIMENSION XIDTE3(MAXOBV)
20267      DIMENSION XTEMP1(MAXOBV)
20268      DIMENSION XTEMP2(MAXOBV)
20269      DIMENSION XDESGN(MAXOBV,2)
20270      DIMENSION TEMP1(MAXOBV)
20271      DIMENSION TEMP2(MAXOBV)
20272      DIMENSION TEMP3(MAXOBV)
20273      DIMENSION TEMP4(MAXOBV)
20274      DIMENSION WORK1(MAXOBV)
20275      DIMENSION WORK2(MAXOBV)
20276      DIMENSION WORK3(MAXOBV)
20277      DIMENSION WORK4(MAXOBV)
20278      DIMENSION WORK5(MAXOBV)
20279      DIMENSION WORK6(MAXOBV)
20280      DIMENSION WORK7(MAXOBV)
20281      DIMENSION WORK8(MAXOBV)
20282      DIMENSION WORK9(MAXOBV)
20283      DIMENSION WORK10(MAXOBV)
20284      DIMENSION WORK11(4,MAXOBV)
20285      DIMENSION WORK12(MAXOBV,3)
20286C
20287      EQUIVALENCE (DGARBG(IDGAR1),Y1(1))
20288      EQUIVALENCE (DGARBG(IDGAR2),SMOOTH(1))
20289      EQUIVALENCE (DGARBG(IDGAR3),FT(1))
20290      EQUIVALENCE (DGARBG(IDGAR4),ZY(1))
20291C
20292      EQUIVALENCE (GARBAG(IGARB1),X1(1))
20293      EQUIVALENCE (GARBAG(IGARB2),XTEMP1(1))
20294      EQUIVALENCE (GARBAG(IGARB3),XTEMP2(1))
20295      EQUIVALENCE (GARBAG(IGARB4),XIDTEM(1))
20296      EQUIVALENCE (GARBAG(IGARB5),XIDTE2(1))
20297      EQUIVALENCE (GARBAG(IGARB6),XIDTE3(1))
20298      EQUIVALENCE (GARBAG(IGARB7),TEMP1(1))
20299      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
20300      EQUIVALENCE (GARBAG(IGARB9),TEMP3(1))
20301      EQUIVALENCE (GARBAG(IGAR10),TEMP4(1))
20302      EQUIVALENCE (GARBAG(JGAR11),XDESGN(1,1))
20303      EQUIVALENCE (GARBAG(JGAR13),WORK1(1))
20304      EQUIVALENCE (GARBAG(JGAR14),WORK2(1))
20305      EQUIVALENCE (GARBAG(JGAR15),WORK3(1))
20306      EQUIVALENCE (GARBAG(JGAR16),WORK4(1))
20307      EQUIVALENCE (GARBAG(JGAR17),WORK5(1))
20308      EQUIVALENCE (GARBAG(JGAR18),WORK6(1))
20309      EQUIVALENCE (GARBAG(JGAR19),WORK7(1))
20310      EQUIVALENCE (GARBAG(IGAR11),WORK8(1))
20311      EQUIVALENCE (GARBAG(IGAR12),WORK9(1))
20312      EQUIVALENCE (GARBAG(IGAR13),WORK10(1))
20313      EQUIVALENCE (GARBAG(IGAR14),WORK11(1,1))
20314      EQUIVALENCE (GARBAG(IGAR18),WORK12(1,1))
20315C
20316      CHARACTER*4 IREPL
20317      CHARACTER*4 IMULT
20318C
20319      CHARACTER*40 INAME
20320      PARAMETER (MAXSPN=30)
20321      CHARACTER*4 IVARN1(MAXSPN)
20322      CHARACTER*4 IVARN2(MAXSPN)
20323      CHARACTER*4 IVARTY(MAXSPN)
20324      REAL PVAR(MAXSPN)
20325      INTEGER ILIS(MAXSPN)
20326      INTEGER NRIGHT(MAXSPN)
20327      INTEGER ICOLR(MAXSPN)
20328C
20329C-----COMMON----------------------------------------------------------
20330C
20331      INCLUDE 'DPCOHK.INC'
20332      INCLUDE 'DPCODA.INC'
20333      INCLUDE 'DPCOST.INC'
20334      INCLUDE 'DPCOP2.INC'
20335C
20336C-----START POINT-----------------------------------------------------
20337C
20338      IFOUND='NO'
20339      IERROR='NO'
20340      ISUBN1='DPKD'
20341      ISUBN2='EN  '
20342C
20343      MAXCP1=MAXCOL+1
20344      MAXCP2=MAXCOL+2
20345      MAXCP3=MAXCOL+3
20346      MAXCP4=MAXCOL+4
20347      MAXCP5=MAXCOL+5
20348      MAXCP6=MAXCOL+6
20349      MAXV2=1
20350      MINN2=20
20351C
20352C               ***************************************************
20353C               **  TREAT THE KERNEL DENSITY PLOT                **
20354C               ***************************************************
20355C
20356      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')THEN
20357        WRITE(ICOUT,999)
20358  999   FORMAT(1X)
20359        CALL DPWRST('XXX','BUG ')
20360        WRITE(ICOUT,51)
20361   51   FORMAT('***** AT THE BEGINNING OF DPKDEN--')
20362        CALL DPWRST('XXX','BUG ')
20363        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
20364   52   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
20365        CALL DPWRST('XXX','BUG ')
20366        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ
20367   53   FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4)
20368        CALL DPWRST('XXX','BUG ')
20369      ENDIF
20370C
20371C               ******************************************************
20372C               **  STEP 1--                                        **
20373C               **  EXTRACT THE COMMAND                             **
20374C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:         **
20375C               **    1) KERNEL DENSITY PLOT Y                      **
20376C               **    2) MULTIPLE KERNEL DENSITY PLOT Y1 ... YK     **
20377C               **    3) REPLICATED KERNEL DENSITY PLOT Y X1  X2    **
20378C               ******************************************************
20379C
20380C     NOTE: KERNEL DENSITY, KERNEL PLOT, DENSITY TRACE ARE SYNONYMS
20381C           FOR KERNEL DENSITY PLOT.
20382C
20383      ISTEPN='1'
20384      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')
20385     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20386C
20387      IF(ICOM.EQ.'KERN')GOTO89
20388      IF(ICOM.EQ.'MULT')GOTO89
20389      IF(ICOM.EQ.'REPL')GOTO89
20390      GOTO9000
20391C
20392   89 CONTINUE
20393      ICASPL='KDEN'
20394      IMULT='OFF'
20395      IREPL='OFF'
20396      ILASTC=-9999
20397C
20398      IF(ICOM.EQ.'KERN')THEN
20399        IFOUN1='YES'
20400      ELSEIF(ICOM.EQ.'MULT')THEN
20401        IMULT='ON'
20402      ELSEIF(ICOM.EQ.'REPL')THEN
20403        IREPL='ON'
20404      ENDIF
20405C
20406      ISTOP=NUMARG-1
20407      DO90I=1,NUMARG
20408        IF(IHARG(I).EQ.'PLOT' .OR. IHARG(I).EQ.'TRAC')THEN
20409          ISTOP=I
20410          GOTO99
20411        ENDIF
20412   90 CONTINUE
20413   99 CONTINUE
20414C
20415      IFOUND='NO'
20416      DO100I=1,ISTOP
20417        IF(IHARG(I).EQ.'=')THEN
20418          IFOUND='NO'
20419          GOTO9000
20420        ELSEIF(IHARG(I).EQ.'KERN')THEN
20421          IFOUN1='YES'
20422          IFOUN2='YES'
20423          ILASTC=MAX(ILASTC,I)
20424        ELSEIF(IHARG(I).EQ.'PLOT' .OR. IHARG(I).EQ.'TRAC')THEN
20425          IFOUN2='YES'
20426          ILASTC=MAX(ILASTC,I)
20427        ELSEIF(IHARG(I).EQ.'DENS')THEN
20428          IFOUN2='YES'
20429          ILASTC=MAX(ILASTC,I)
20430        ELSEIF(IHARG(I).EQ.'REPL')THEN
20431          IREPL='ON'
20432        ELSEIF(IHARG(I).EQ.'MULT')THEN
20433          IMULT='ON'
20434        ENDIF
20435  100 CONTINUE
20436C
20437      IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')IFOUND='YES'
20438      IF(IFOUND.EQ.'NO')GOTO9000
20439C
20440      IF(IMULT.EQ.'ON')THEN
20441        IF(IREPL.EQ.'ON')THEN
20442          WRITE(ICOUT,999)
20443          CALL DPWRST('XXX','BUG ')
20444          WRITE(ICOUT,101)
20445  101     FORMAT('***** ERROR IN KERNEL DENSITY PLOT--')
20446          CALL DPWRST('XXX','BUG ')
20447          WRITE(ICOUT,102)
20448  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
20449     1           '"REPLICATION" FOR THE KERNEL DENSITY PLOT.')
20450          CALL DPWRST('XXX','BUG ')
20451          IERROR='YES'
20452          GOTO9000
20453        ENDIF
20454      ENDIF
20455C
20456      IF(ILASTC.GE.1)THEN
20457        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
20458        ILASTC=0
20459      ENDIF
20460C
20461      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'KDEN')THEN
20462        WRITE(ICOUT,112)ICASPL,IMULT,IREPL
20463  112   FORMAT('ICASPL,IMULT,IREPL = ',2(A4,2X),A4)
20464        CALL DPWRST('XXX','BUG ')
20465      ENDIF
20466C
20467C               ****************************************
20468C               **  STEP 2--                          **
20469C               **  EXTRACT THE VARIABLE LIST         **
20470C               ****************************************
20471C
20472      ISTEPN='2'
20473      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')
20474     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20475C
20476      INAME='KERNEL DENSITY PLOT'
20477      MINNA=1
20478      MAXNA=100
20479      MINN2=1
20480      IFLAGE=1
20481      IF(IMULT.EQ.'ON')IFLAGE=0
20482      IFLAGM=1
20483      IFLAGP=0
20484      JMIN=1
20485      JMAX=NUMARG
20486      MINNVA=1
20487      MAXNVA=3
20488      IF(IREPL.EQ.'ON')THEN
20489        MINNVA=2
20490        MAXNVA=3
20491      ELSEIF(IMULT.EQ.'ON')THEN
20492        MINNVA=1
20493        MAXNVA=100
20494      ENDIF
20495C
20496      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
20497     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
20498     1            JMIN,JMAX,
20499     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
20500     1            IVARN1,IVARN2,IVARTY,PVAR,
20501     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
20502     1            MINNVA,MAXNVA,
20503     1            IFLAGM,IFLAGP,
20504     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
20505      IF(IERROR.EQ.'YES')GOTO9000
20506C
20507      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')THEN
20508        WRITE(ICOUT,999)
20509        CALL DPWRST('XXX','BUG ')
20510        WRITE(ICOUT,281)
20511  281   FORMAT('***** AFTER CALL DPPARS--')
20512        CALL DPWRST('XXX','BUG ')
20513        WRITE(ICOUT,282)NQ,NUMVAR
20514  282   FORMAT('NQ,NUMVAR = ',2I8)
20515        CALL DPWRST('XXX','BUG ')
20516        IF(NUMVAR.GT.0)THEN
20517          DO285I=1,NUMVAR
20518            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
20519     1                      ICOLR(I)
20520  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
20521     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
20522            CALL DPWRST('XXX','BUG ')
20523  285     CONTINUE
20524        ENDIF
20525      ENDIF
20526C
20527      NRESP=0
20528      NREPL=0
20529      IF(IREPL.EQ.'OFF' .AND. NUMVAR.GT.1)IMULT='ON'
20530      IF(IMULT.EQ.'ON')THEN
20531        NRESP=NUMVAR
20532      ELSEIF(IREPL.EQ.'ON')THEN
20533        NRESP=1
20534        NREPL=NUMVAR-NRESP
20535        IF(NREPL.LT.1 .OR. NREPL.GT.2)THEN
20536          WRITE(ICOUT,999)
20537          CALL DPWRST('XXX','BUG ')
20538          WRITE(ICOUT,101)
20539          CALL DPWRST('XXX','BUG ')
20540          WRITE(ICOUT,511)
20541  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
20542     1           'REPLICATION VARIABLES')
20543          CALL DPWRST('XXX','BUG ')
20544          WRITE(ICOUT,512)
20545  512     FORMAT('      MUST BE BETWEEN 1 AND 2;  SUCH WAS NOT THE ',
20546     1           'CASE HERE.')
20547          CALL DPWRST('XXX','BUG ')
20548          WRITE(ICOUT,513)NREPL
20549  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
20550          CALL DPWRST('XXX','BUG ')
20551          IERROR='YES'
20552          GOTO9000
20553        ENDIF
20554      ELSE
20555        NRESP=1
20556      ENDIF
20557C
20558C               ********************************************
20559C               **  STEP 6--                              **
20560C               **  GENERATE THE KERNEL DENISTY PLOTS FOR **
20561C               **  THE VARIOUS CASES.                    **
20562C               ********************************************
20563C
20564      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')THEN
20565        ISTEPN='6'
20566        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20567        WRITE(ICOUT,601)NRESP,NREPL
20568  601   FORMAT('NRESP,NREPL = ',2I5)
20569        CALL DPWRST('XXX','BUG ')
20570      ENDIF
20571C
20572C               *************************************************
20573C               **  STEP 7A--                                  **
20574C               **  CASE 1: SINGLE RESPONSE VARIABLE WITH NO   **
20575C               **          REPLICATION (RESPONSE VARIABLE CAN **
20576C               **          BE A MATRIX).                      **
20577C               *************************************************
20578C
20579      IF(NRESP.EQ.1 .AND. NREPL.EQ.0)THEN
20580        ISTEPN='7A'
20581        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')
20582     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20583C
20584        ICOL=1
20585        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
20586     1              INAME,IVARN1,IVARN2,IVARTY,
20587     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
20588     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
20589     1              MAXCP4,MAXCP5,MAXCP6,
20590     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
20591     1              XTEMP1,XTEMP2,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
20592     1              IBUGG3,ISUBRO,IFOUND,IERROR)
20593        DO701I=1,NLOCAL
20594          Y1(I)=DBLE(XTEMP1(I))
20595  701   CONTINUE
20596        IF(IERROR.EQ.'YES')GOTO9000
20597C
20598C               *****************************************************
20599C               **  STEP 7B--                                      **
20600C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
20601C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
20602C               **  RESET THE VECTOR D(.) TO ALL ONES.             **
20603C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
20604C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
20605C               *****************************************************
20606C
20607        NCURVE=1
20608        NPLOTP=0
20609        CALL DPKDE2(Y1,FT,SMOOTH,TEMP1,TEMP2,TEMP3,TEMP4,NCURVE,
20610     1              NLOCAL,ICASPL,IKDENP,PKDEWI,IKDERN,IKDEPF,
20611     1              ISEED,MINN2,
20612     1              WORK1,WORK2,WORK3,WORK4,WORK5,WORK6,WORK7,
20613     1              WORK8,WORK9,WORK10,WORK11,WORK12,MAXOBV,
20614     1              Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
20615C
20616C               ******************************************
20617C               **  STEP 8A--                           **
20618C               **  CASE 2: MULTIPLE RESPONSE VARIABLES **
20619C               ******************************************
20620C
20621      ELSEIF(NRESP.GT.1)THEN
20622        ISTEPN='8A'
20623        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')
20624     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20625C
20626C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
20627C
20628        NPLOTP=0
20629        DO810IRESP=1,NRESP
20630          NCURVE=IRESP
20631C
20632          IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')THEN
20633            WRITE(ICOUT,999)
20634            CALL DPWRST('XXX','BUG ')
20635            WRITE(ICOUT,811)IRESP,NCURVE
20636  811       FORMAT('IRESP,NCURVE = ',2I5)
20637            CALL DPWRST('XXX','BUG ')
20638          ENDIF
20639C
20640          ICOL=IRESP
20641          NUMVA2=1
20642          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
20643     1                INAME,IVARN1,IVARN2,IVARTY,
20644     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
20645     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
20646     1                MAXCP4,MAXCP5,MAXCP6,
20647     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
20648     1                XTEMP1,XTEMP2,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
20649     1                IBUGG3,ISUBRO,IFOUND,IERROR)
20650        DO801I=1,NLOCAL
20651          Y1(I)=DBLE(XTEMP1(I))
20652  801   CONTINUE
20653          IF(IERROR.EQ.'YES')GOTO9000
20654C
20655C               *****************************************************
20656C               **  STEP 8B--                                      **
20657C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
20658C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
20659C               *****************************************************
20660C
20661          CALL DPKDE2(Y1,FT,SMOOTH,TEMP1,TEMP2,TEMP3,TEMP4,NCURVE,
20662     1                NLOCAL,ICASPL,IKDENP,PKDEWI,IKDERN,IKDEPF,
20663     1                ISEED,MINN2,
20664     1                WORK1,WORK2,WORK3,WORK4,WORK5,WORK6,WORK7,
20665     1                WORK8,WORK9,WORK10,WORK11,WORK12,MAXOBV,
20666     1                Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
20667C
20668  810   CONTINUE
20669C
20670C               *****************************************************
20671C               **  STEP 9A--                                      **
20672C               **  CASE 3: ONE OR TWO  REPLICATION VARIABLES.     **
20673C               **          FOR THIS CASE, THE NUMBER OF RESPONSE  **
20674C               **          VARIABLES MUST BE EXACTLY 1.           **
20675C               **          CURRENTLY, GROUPED DATA NOT SUPPORTED  **
20676C               **          WITH REPLICATION.                      **
20677C               *****************************************************
20678C
20679      ELSEIF(NRESP.EQ.1 .AND. NREPL.GE.1)THEN
20680        ISTEPN='9A'
20681        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')
20682     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20683C
20684        J=0
20685        IMAX=NRIGHT(1)
20686        IF(NQ.LT.NRIGHT(1))IMAX=NQ
20687        DO910I=1,IMAX
20688          IF(ISUB(I).EQ.0)GOTO910
20689          J=J+1
20690C
20691C         RESPONSE VARIABLE IN Y1
20692C
20693          IJ=MAXN*(ICOLR(1)-1)+I
20694          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
20695          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
20696          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
20697          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
20698          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
20699          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
20700          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
20701C
20702          ICOLC=1
20703          DO920IR=1,MIN(NREPL,2)
20704            ICOLC=ICOLC+1
20705            ICOLT=ICOLR(ICOLC)
20706            IJ=MAXN*(ICOLT-1)+I
20707            IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
20708            IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
20709            IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
20710            IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
20711            IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
20712            IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
20713            IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
20714  920     CONTINUE
20715C
20716  910   CONTINUE
20717        NLOCAL=J
20718C
20719C       *****************************************************
20720C       **  STEP 9B--                                      **
20721C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
20722C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
20723C       **                                                 **
20724C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
20725C       **  VARIOUS REPLICATIONS.                          **
20726C       *****************************************************
20727C
20728        ISTEPN='9B'
20729        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')THEN
20730          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20731          WRITE(ICOUT,999)
20732          CALL DPWRST('XXX','BUG ')
20733          WRITE(ICOUT,931)
20734  931     FORMAT('***** FROM THE MIDDLE  OF FREQ--')
20735          CALL DPWRST('XXX','BUG ')
20736          WRITE(ICOUT,932)ICASPL,NUMVAR,NLOCAL
20737  932     FORMAT('ICASPL,NUMVAR,NQ = ',A4,2I8)
20738          CALL DPWRST('XXX','BUG ')
20739          IF(NLOCAL.GE.1)THEN
20740            DO935I=1,NLOCAL
20741              WRITE(ICOUT,936)I,Y1(I),XDESGN(I,1),XDESGN(I,2)
20742  936         FORMAT('I,Y1(I),XDESGN(I,1),XDESGN(I,2) = ',I8,3F12.5)
20743              CALL DPWRST('XXX','BUG ')
20744  935       CONTINUE
20745          ENDIF
20746        ENDIF
20747C
20748C       *****************************************************
20749C       **  STEP 9C--                                      **
20750C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
20751C       **  REPLICATION VARIABLES.                         **
20752C       *****************************************************
20753C
20754        CALL DPFRE5(XDESGN(1,1),XDESGN(1,2),
20755     1             NREPL,NLOCAL,MAXOBV,
20756     1             XIDTEM,XIDTE2,
20757     1             XTEMP1,XTEMP2,
20758     1             NUMSE1,NUMSE2,
20759     1             IBUGG3,ISUBRO,IERROR)
20760C
20761C       *****************************************************
20762C       **  STEP 9D--                                      **
20763C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
20764C       *****************************************************
20765C
20766        NPLOTP=0
20767        NCURVE=0
20768        IF(NREPL.EQ.1)THEN
20769          J=0
20770          DO1110ISET1=1,NUMSE1
20771            K=0
20772            DO1130I=1,NLOCAL
20773              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
20774                K=K+1
20775                ZY(K)=Y1(I)
20776              ENDIF
20777 1130       CONTINUE
20778            NTEMP=K
20779            NCURVE=NCURVE+1
20780            IF(NTEMP.GT.0)THEN
20781              CALL DPKDE2(ZY,FT,SMOOTH,TEMP1,TEMP2,TEMP3,TEMP4,NCURVE,
20782     1                    NTEMP,ICASPL,IKDENP,PKDEWI,
20783     1                    IKDERN,IKDEPF,ISEED,MINN2,
20784     1                    WORK1,WORK2,WORK3,WORK4,WORK5,WORK6,WORK7,
20785     1                    WORK8,WORK9,WORK10,WORK11,WORK12,MAXOBV,
20786     1                    Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
20787            ENDIF
20788 1110     CONTINUE
20789        ELSEIF(NREPL.EQ.2)THEN
20790          J=0
20791          NTOT=NUMSE1*NUMSE2
20792          DO1210ISET1=1,NUMSE1
20793          DO1220ISET2=1,NUMSE2
20794            K=0
20795            DO1290I=1,NLOCAL
20796              IF(
20797     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
20798     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
20799     1          )THEN
20800                K=K+1
20801                ZY(K)=Y1(I)
20802              ENDIF
20803 1290       CONTINUE
20804            NTEMP=K
20805            NCURVE=NCURVE+1
20806            IF(NTEMP.GT.0)THEN
20807              CALL DPKDE2(ZY,FT,SMOOTH,TEMP1,TEMP2,TEMP3,TEMP4,NCURVE,
20808     1                    NTEMP,ICASPL,IKDENP,PKDEWI,
20809     1                    IKDERN,IKDEPF,ISEED,MINN2,
20810     1                    WORK1,WORK2,WORK3,WORK4,WORK5,WORK6,WORK7,
20811     1                    WORK8,WORK9,WORK10,WORK11,WORK12,MAXOBV,
20812     1                    Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
20813            ENDIF
20814 1220     CONTINUE
20815 1210     CONTINUE
20816        ENDIF
20817      ENDIF
20818C
20819C               *****************
20820C               **  STEP 90--  **
20821C               **  EXIT       **
20822C               *****************
20823C
20824 9000 CONTINUE
20825      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'KDEN')THEN
20826        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20827        WRITE(ICOUT,999)
20828        CALL DPWRST('XXX','BUG ')
20829        WRITE(ICOUT,9011)
20830 9011   FORMAT('***** AT THE END       OF DPKDEN--')
20831        CALL DPWRST('XXX','BUG ')
20832        WRITE(ICOUT,9012)IFOUND,IERROR
20833 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
20834        CALL DPWRST('XXX','BUG ')
20835        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
20836 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
20837     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
20838        CALL DPWRST('XXX','BUG ')
20839        WRITE(ICOUT,9014)IKDENP,PKDEWI
20840 9014   FORMAT('IKDENP,PKDEWI = ',I8,2X,G15.7)
20841        CALL DPWRST('XXX','BUG ')
20842        IF(NPLOTP.LE.0)GOTO9090
20843        DO9015I=1,NPLOTP
20844          WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
20845 9016     FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
20846         CALL DPWRST('XXX','BUG ')
20847 9015   CONTINUE
20848 9090   CONTINUE
20849      ENDIF
20850C
20851      RETURN
20852      END
20853      SUBROUTINE DPKDE2(Y,FT,SMOOTH,TEMP1,TEMP2,TEMP3,TEMP4,NCURVE,
20854     1                  N,ICASPL,IKDENP,PKDEWI,
20855     1                  IKDERN,IKDEPF,ISEED,MINN2,
20856     1                  WORK1,WORK2,WORK3,WORK4,WORK5,WORK6,WORK7,
20857     1                  WORK8,WORK9,WORK10,WORK11,WORK12,MAXNXT,
20858     1                  Y2,X2,D2,N2,NPLOTV,IBUGG3,ISUBRO,IERROR)
20859C
20860C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
20861C              THAT WILL DEFINE A KERNEL DENSITY PLOT.  USES THE
20862C              APPLIED STATISTICS ALGORITHM 176 OF B. W. SILVERMAN
20863C              (COMPUTES KERNEL ESTIMATE USING THE FFT).
20864C              CURRENTLY, ONLY A GAUSSIAN KERNEL FUNCTION IS
20865C              SUPPORTED.
20866C     WRITTEN BY--ALAN HECKERT
20867C                 STATISTICAL ENGINEERING DIVISION
20868C                 INFORMATION TECHNOLOGY LABORATORY
20869C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20870C                 GAITHERSBURG, MD 20899-8980
20871C                 PHONE--301-975-2899
20872C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20873C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20874C     LANGUAGE--ANSI FORTRAN (1977)
20875C     VERSION NUMBER--2001/8
20876C     ORIGINAL VERSION--AUGUST    2001.
20877C     UPDATED         --FEBRUARY  2010. SUPPORT FOR "MULTIPLE" AND
20878C                                       "REPLICATION" CASES
20879C     UPDATED         --JULY      2018. OPTIONALLY GENERATE THE CDF
20880C                                       OR PPF INSTEAD OF PDF
20881C     UPDATED         --JULY      2018. OPTIONALLY GENERATE RANDOM
20882C                                       NUMBERS BASED ON KERNEL DENSITY
20883C     UPDATED         --JULY      2019. SCRATCH STORAGE FOR INTERP
20884C
20885C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20886C
20887      CHARACTER*4 ICASPL
20888      CHARACTER*4 IKDEPF
20889      CHARACTER*4 IBUGG3
20890      CHARACTER*4 ISUBRO
20891      CHARACTER*4 IERROR
20892C
20893      CHARACTER*4 ISUBN1
20894      CHARACTER*4 ISUBN2
20895      CHARACTER*4 ISTEPN
20896      CHARACTER*4 IWRITE
20897      CHARACTER*4 IOP
20898C
20899      DOUBLE PRECISION DH
20900      DOUBLE PRECISION DHI
20901      DOUBLE PRECISION DLO
20902      DOUBLE PRECISION DN
20903      DOUBLE PRECISION DSUM
20904      DOUBLE PRECISION DX
20905      DOUBLE PRECISION DMEAN
20906      DOUBLE PRECISION DVAR
20907      DOUBLE PRECISION DSD
20908C
20909C---------------------------------------------------------------------
20910C
20911      DOUBLE PRECISION Y(*)
20912      DOUBLE PRECISION FT(*)
20913      DOUBLE PRECISION SMOOTH(*)
20914      DIMENSION Y2(*)
20915      DIMENSION X2(*)
20916      DIMENSION D2(*)
20917      DIMENSION TEMP1(*)
20918      DIMENSION TEMP2(*)
20919      DIMENSION TEMP3(*)
20920      DIMENSION TEMP4(*)
20921C
20922      DIMENSION WORK1(*)
20923      DIMENSION WORK2(*)
20924      DIMENSION WORK3(*)
20925      DIMENSION WORK4(*)
20926      DIMENSION WORK5(*)
20927      DIMENSION WORK6(*)
20928      DIMENSION WORK7(*)
20929      DIMENSION WORK8(*)
20930      DIMENSION WORK9(*)
20931      DIMENSION WORK10(*)
20932      DIMENSION WORK11(4,MAXNXT)
20933      DIMENSION WORK12(MAXNXT,3)
20934C
20935C---------------------------------------------------------------------
20936C
20937      INCLUDE 'DPCOP2.INC'
20938C
20939C-----START POINT-----------------------------------------------------
20940C
20941      ISUBN1='DPKD'
20942      ISUBN2='E2  '
20943      IERROR='NO'
20944C
20945      DLO=0.0D0
20946      DHI=0.0D0
20947      DH=0.0D0
20948      DSD=0.0D0
20949C
20950C               ********************************************
20951C               **  STEP 1--                              **
20952C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
20953C               ********************************************
20954C
20955      ISTEPN='1'
20956      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KDE2')
20957     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20958C
20959      IF(N.LT.MINN2)THEN
20960        WRITE(ICOUT,999)
20961  999   FORMAT(1X)
20962        CALL DPWRST('XXX','BUG ')
20963        WRITE(ICOUT,31)
20964   31   FORMAT('***** ERROR IN KERNEL DENSITY PLOT--')
20965        CALL DPWRST('XXX','BUG ')
20966        WRITE(ICOUT,32)
20967   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;')
20968        CALL DPWRST('XXX','BUG ')
20969        WRITE(ICOUT,34)N
20970   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
20971        CALL DPWRST('XXX','BUG ')
20972        WRITE(ICOUT,999)
20973        CALL DPWRST('XXX','BUG ')
20974        IERROR='YES'
20975        GOTO9000
20976      ENDIF
20977C
20978      HOLD=Y(1)
20979      DO60I=1,N
20980      IF(Y(I).NE.HOLD)GOTO69
20981   60 CONTINUE
20982      WRITE(ICOUT,999)
20983      CALL DPWRST('XXX','BUG ')
20984      WRITE(ICOUT,31)
20985      CALL DPWRST('XXX','BUG ')
20986      WRITE(ICOUT,62)
20987   62 FORMAT('      ALL INPUT HORIZONTAL AXIS ELEMENTS')
20988      CALL DPWRST('XXX','BUG ')
20989      WRITE(ICOUT,63)HOLD
20990   63 FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
20991      CALL DPWRST('XXX','BUG ')
20992      WRITE(ICOUT,999)
20993      CALL DPWRST('XXX','BUG ')
20994      IERROR='YES'
20995      GOTO9000
20996   69 CONTINUE
20997C
20998      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'KDE2')THEN
20999        WRITE(ICOUT,999)
21000        CALL DPWRST('XXX','BUG ')
21001        WRITE(ICOUT,70)
21002   70   FORMAT('***** AT THE BEGINNING OF DPKDE2--')
21003        CALL DPWRST('XXX','BUG ')
21004        WRITE(ICOUT,72)N,IKDENP,PKDEWI
21005   72   FORMAT('N,IKDENP,PKDEWI = ',I6,2G15.7)
21006        CALL DPWRST('XXX','BUG ')
21007        DO73I=1,N
21008        WRITE(ICOUT,74)I,REAL(Y(I))
21009   74   FORMAT('I, Y(I) = ',I8,G15.7)
21010        CALL DPWRST('XXX','BUG ')
21011   73   CONTINUE
21012      ENDIF
21013C
21014C               **********************************************
21015C               **  STEP 2--                                **
21016C               **  CALL DENEST ROUTINE TO COMPUTE THE      **
21017C               **  KERNEL DENSITY ESTIMATE.                **
21018C               **********************************************
21019C
21020      ISTEPN='2'
21021      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KDE2')
21022     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21023C
21024      IERROR='NO'
21025      ICAL=0
21026      KFLAG=1
21027      CALL DSORT(Y,Y,N,KFLAG,IERROR)
21028      DH=DBLE(PKDEWI)
21029      IF(PKDEWI.LE.0)THEN
21030        DN=N
21031        DSUM=0.0D0
21032        DO200I=1,N
21033          DX=Y(I)
21034          DSUM=DSUM+DX
21035  200   CONTINUE
21036        DMEAN=DSUM/DN
21037        DSUM=0.0D0
21038        DO300I=1,N
21039          DX=Y(I)
21040          DSUM=DSUM+(DX-DMEAN)**2
21041  300   CONTINUE
21042        DVAR=DSUM/(DN-1.0D0)
21043        DSD=0.0D0
21044        IF(DVAR.GT.0.0D0)DSD=DSQRT(DVAR)
21045C
21046        P=0.25
21047        AN=REAL(N)
21048        ANI=P*(AN+1.0)
21049        NI=INT(ANI+0.1)
21050        A2NI=REAL(NI)
21051        REM=ANI-A2NI
21052        NIP1=NI+1
21053        IF(NI.LE.1)NI=1
21054        IF(NI.GE.N)NI=N
21055        IF(NIP1.LE.1)NIP1=1
21056        IF(NIP1.GE.N)NIP1=N
21057        XPERC1=(1.0-REM)*Y(NI)+REM*Y(NIP1)
21058C
21059        P=0.75
21060        ANI=P*(AN+1.0)
21061        NI=INT(ANI+0.1)
21062        A2NI=REAL(NI)
21063        REM=ANI-A2NI
21064        NIP1=NI+1
21065        IF(NI.LE.1)NI=1
21066        IF(NI.GE.N)NI=N
21067        IF(NIP1.LE.1)NIP1=1
21068        IF(NIP1.GE.N)NIP1=N
21069        XPERC2=(1.0-REM)*Y(NI)+REM*Y(NIP1)
21070        AIQ=(XPERC2-XPERC1)/1.34
21071C
21072CCCCC   DH=DBLE(1.06)*DSD*DN**(-1.0D0/5.0D0)
21073        DH=0.9D0*MIN(DSD,DBLE(AIQ))*DN**(-1.0D0/5.0D0)
21074      ENDIF
21075      DLO=Y(1) - 3.0D0*DH
21076      DHI=Y(N) + 3.0D0*DH
21077C
21078      CALL DENEST(Y,N,DLO,DHI,DH,FT,SMOOTH,IKDENP,ICAL,IERROR)
21079C
21080      IF(IERROR.EQ.'YES')GOTO9000
21081C
21082C               **********************************************
21083C               **  STEP 3--                                **
21084C               **  GENERATE CDF OR PPF IF REQUESTED        **
21085C               **********************************************
21086C
21087      ISTEPN='3'
21088      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KDE2')
21089     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21090C
21091      IFRST=N2+1
21092      ILAST=N2+IKDENP
21093      IF(IKDEPF.EQ.'PDF')THEN
21094        DO410I=1,IKDENP
21095          N2=N2+1
21096          Y2(N2)=REAL(SMOOTH(I))
21097          X2(N2)=REAL(DLO + (DBLE(I) - 0.5D0)*(DHI-DLO)/DBLE(IKDENP))
21098          D2(N2)=REAL(NCURVE)
21099  410   CONTINUE
21100      ELSEIF(IKDEPF.EQ.'CDF' .OR. IKDEPF.EQ.'PPF')THEN
21101        DO420I=1,IKDENP
21102          N2=N2+1
21103          X2(N2)=REAL(DLO + (DBLE(I) - 0.5D0)*(DHI-DLO)/DBLE(IKDENP))
21104          TEMP1(N2)=REAL(SMOOTH(I))
21105          D2(N2)=REAL(NCURVE)
21106  420   CONTINUE
21107        NTEMP=2
21108        IWRITE='OFF'
21109        CALL CUMINT(TEMP1,X2,IKDENP,NTEMP,IWRITE,Y2,IBUGG3,IERROR)
21110        IF(IKDEPF.EQ.'PPF')THEN
21111          DO430I=IFRST,ILAST
21112            AVAL=Y2(I)
21113            Y2(I)=X2(I)
21114            X2(I)=AVAL
21115  430     CONTINUE
21116        ENDIF
21117      ENDIF
21118C
21119C               **********************************************
21120C               **  STEP 4--                                **
21121C               **  GENERATE RANDOM NUMBERS BASED ON THE    **
21122C               **  KERNEL DENSITY APPROXIMATION            **
21123C               **********************************************
21124C
21125      ISTEPN='4'
21126      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KDE2')
21127     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21128C
21129      IF(IKDERN.GE.1)THEN
21130        IF(IKDEPF.EQ.'PDF')THEN
21131          NTEMP=2
21132          IWRITE='OFF'
21133          CALL CUMINT(Y2(IFRST+1),X2(IFRST+1),IKDENP,NTEMP,IWRITE,TEMP3,
21134     1                IBUGG3,IERROR)
21135          ICNT=0
21136          DO440I=IFRST,ILAST
21137            ICNT=ICNT+1
21138            TEMP1(ICNT)=X2(I)
21139            TEMP2(ICNT)=TEMP3(ICNT)
21140  440     CONTINUE
21141        ELSEIF(IKDEPF.EQ.'CDF')THEN
21142          ICNT=0
21143          DO460I=IFRST,ILAST
21144            ICNT=ICNT+1
21145            TEMP1(ICNT)=X2(I)
21146            TEMP2(ICNT)=Y2(I)
21147  460     CONTINUE
21148        ELSEIF(IKDEPF.EQ.'PPF')THEN
21149          ICNT=0
21150          DO470I=IFRST,ILAST
21151            ICNT=ICNT+1
21152            TEMP1(ICNT)=Y2(I)
21153            TEMP2(ICNT)=X2(I)
21154  470     CONTINUE
21155        ENDIF
21156C
21157        ISTEPN='4B'
21158        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KDE2')
21159     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21160C
21161        CALL UNIRAN(IKDERN,ISEED,TEMP3)
21162        CALL SORT(TEMP3,IKDERN,TEMP3)
21163        CALL INTERP(TEMP1,TEMP2,IKDENP,TEMP3,IKDERN,IWRITE,TEMP4,
21164     1              WORK1,WORK2,WORK3,WORK4,WORK5,WORK6,WORK7,
21165     1              WORK8,WORK9,WORK10,WORK11,WORK12,MAXNXT,
21166     1              IBUGG3,ISUBRO,IERROR)
21167C
21168C       WRITE RESULTS TO "dpst1f.dat"
21169C
21170        ISTEPN='4C'
21171        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'KDE2')
21172     1     CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21173C
21174        IOP='OPEN'
21175        IFLAG1=1
21176        IFLAG2=0
21177        IFLAG3=0
21178        IFLAG4=0
21179        IFLAG5=0
21180        CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
21181     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
21182     1              IBUGG3,ISUBRO,IERROR)
21183        IF(IERROR.EQ.'YES')GOTO9000
21184C
21185        DO490I=1,IKDERN
21186          WRITE(IOUNI1,'(E15.7)')TEMP4(I)
21187  490   CONTINUE
21188C
21189        IOP='CLOS'
21190        CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
21191     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
21192     1              IBUGG3,ISUBRO,IERROR)
21193      ENDIF
21194C
21195      NPLOTV=2
21196      GOTO9000
21197C
21198C               ******************
21199C               **   STEP 90--  **
21200C               **   EXIT       **
21201C               ******************
21202C
21203 9000 CONTINUE
21204      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'KDE2')THEN
21205        WRITE(ICOUT,999)
21206        CALL DPWRST('XXX','BUG ')
21207        WRITE(ICOUT,9011)
21208 9011   FORMAT('***** AT THE END       OF DPKDE2--')
21209        CALL DPWRST('XXX','BUG ')
21210        WRITE(ICOUT,9012)ICASPL,IERROR,N2
21211 9012   FORMAT('ICASPL,IERROR,N2 = ',A4,2X,A4,2X,I8)
21212        CALL DPWRST('XXX','BUG ')
21213        WRITE(ICOUT,9013)REAL(DLO),REAL(DHI),REAL(DH),REAL(DSD)
21214 9013   FORMAT('DLO,DHI,DH,DSD = ',4G15.7)
21215        CALL DPWRST('XXX','BUG ')
21216        DO9015I=1,N2
21217        WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
21218 9016   FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
21219        CALL DPWRST('XXX','BUG ')
21220 9015   CONTINUE
21221      ENDIF
21222C
21223      RETURN
21224      END
21225      SUBROUTINE DPKDNP(IHARG,IARGT,ARG,NUMARG,
21226     1IKDENP,IDEFKN,IFOUND,IERROR)
21227C
21228C     PURPOSE--DEFINE THE NUMBER OF POINTS USED FOR THE KERNEL DENSITY
21229C              CURVE IN THE KERNEL DENSITY PLOT COMMAND.
21230C              THE SPECIFIED KERNEL DENSITY POINTS VALUE WILL BE PLACED
21231C              IN THE FLOATING POINT VARIABLE IKDENP.
21232C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
21233C                     --IARGT  (A  HOLLERITH VECTOR)
21234C                     --ARG    (A  FLOATING POINT VECTOR)
21235C                     --NUMARG (AN INTEGER VARIABLE)
21236C                     --IDEFKN (A FLOATING POINT VARIABLE)
21237C     OUTPUT ARGUMENTS--IKDENP  (A  FLOATING POINT VARIABLE)
21238C                     --IFOUND ('YES' OR 'NO' )
21239C                     --IERROR ('YES' OR 'NO' )
21240C     WRITTEN BY--JAMES J. FILLIBEN
21241C                 STATISTICAL ENGINEERING DIVISION
21242C                 INFORMATION TECHNOLOGY LABORATORY
21243C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21244C                 GAITHERSBURG, MD 20899-8980
21245C                 PHONE--301-975-2855
21246C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21247C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
21248C     LANGUAGE--ANSI FORTRAN (1977)
21249C     VERSION NUMBER--2001/8
21250C     ORIGINAL VERSION--AUGUST    2001.
21251C
21252C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21253C
21254      CHARACTER*4 IHARG
21255      CHARACTER*4 IARGT
21256      CHARACTER*4 IFOUND
21257      CHARACTER*4 IERROR
21258C
21259C---------------------------------------------------------------------
21260C
21261      DIMENSION IHARG(*)
21262      DIMENSION IARGT(*)
21263      DIMENSION ARG(*)
21264C
21265C---------------------------------------------------------------------
21266C
21267      INCLUDE 'DPCOP2.INC'
21268C
21269C-----START POINT-----------------------------------------------------
21270C
21271      IFOUND='NO'
21272      IERROR='NO'
21273C
21274      IF(NUMARG.EQ.0)GOTO9000
21275      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO9000
21276      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'POIN')GOTO1110
21277      IF(IHARG(NUMARG).EQ.'?')GOTO8100
21278      GOTO9000
21279C
21280 1110 CONTINUE
21281      IF(IHARG(NUMARG).EQ.'POIN')GOTO1150
21282      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
21283      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
21284      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
21285      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
21286      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
21287      GOTO1120
21288C
21289 1120 CONTINUE
21290      IERROR='YES'
21291      WRITE(ICOUT,1121)
21292 1121 FORMAT('***** ERROR IN DPKDNP--')
21293      CALL DPWRST('XXX','BUG ')
21294      WRITE(ICOUT,1122)
21295 1122 FORMAT('      ILLEGAL FORM FOR KERNEL DENSITY POINTS COMMAND.')
21296      CALL DPWRST('XXX','BUG ')
21297      GOTO9000
21298C
21299 1150 CONTINUE
21300      HOLD=IDEFKN
21301      GOTO1180
21302C
21303 1160 CONTINUE
21304      HOLD=ARG(NUMARG)
21305      GOTO1180
21306C
21307 1180 CONTINUE
21308      IFOUND='YES'
21309      IKDENP=INT(HOLD+0.5)
21310      IKLOW=5
21311      IKHIGH=11
21312      IF(IKDENP.LE.2**IKLOW)THEN
21313        IKDENP=2**IKLOW
21314      ELSEIF(IKDENP.GT.2**IKHIGH)THEN
21315        IKDENP=2**IKHIGH
21316      ELSE
21317        DO1185K=IKLOW,IKHIGH
21318          IF(IKDENP.GT.2**(K-1).AND.IKDENP.LE.2**K)THEN
21319            IKDENP=2**K
21320            GOTO1189
21321          ENDIF
21322 1185   CONTINUE
21323      ENDIF
21324 1189 CONTINUE
21325C
21326      IF(IFEEDB.EQ.'OFF')GOTO1289
21327      WRITE(ICOUT,999)
21328  999 FORMAT(1X)
21329      CALL DPWRST('XXX','BUG ')
21330      WRITE(ICOUT,1281)IKDENP
21331 1281 FORMAT('THE KERNEL DENSITY POINTS HAS JUST BEEN SET ',
21332     1       'TO ',I8)
21333      CALL DPWRST('XXX','BUG ')
21334 1289 CONTINUE
21335      GOTO9000
21336C
21337C               ********************************************
21338C               **  STEP 81--                             **
21339C               **  TREAT THE    ?    CASE--              **
21340C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
21341C               ********************************************
21342C
21343 8100 CONTINUE
21344      IFOUND='YES'
21345      WRITE(ICOUT,999)
21346      CALL DPWRST('XXX','BUG ')
21347      WRITE(ICOUT,8111)IKDENP
21348 8111 FORMAT('THE CURRENT KERNEL DENSITY POINTS    IS ',I8)
21349      CALL DPWRST('XXX','BUG ')
21350      WRITE(ICOUT,8121)IDEFKN
21351 8121 FORMAT('THE DEFAULT KERNEL DENSITY POINTS    IS ',I8)
21352      CALL DPWRST('XXX','BUG ')
21353      GOTO9000
21354C
21355 9000 CONTINUE
21356      RETURN
21357      END
21358      SUBROUTINE DPKDWI(IHARG,IARGT,ARG,NUMARG,
21359     1PKDEWI,DEFKWI,IFOUND,IERROR)
21360C
21361C     PURPOSE--DEFINE THE SMOOTHING WIDTH FOR THE
21362C              TO BE USED FOR THE KERNEL DENSITY ESTIMATOR.
21363C              THE SPECIFIED KERNEL DENSITY WIDTH VALUE WILL BE PLACED
21364C              IN THE FLOATING POINT VARIABLE PKDEWI.
21365C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
21366C                     --IARGT  (A  HOLLERITH VECTOR)
21367C                     --ARG    (A  FLOATING POINT VECTOR)
21368C                     --NUMARG (AN INTEGER VARIABLE)
21369C                     --DEFKWI (A FLOATING POINT VARIABLE)
21370C     OUTPUT ARGUMENTS--PKDEWI  (A  FLOATING POINT VARIABLE)
21371C                     --IFOUND ('YES' OR 'NO' )
21372C                     --IERROR ('YES' OR 'NO' )
21373C     WRITTEN BY--JAMES J. FILLIBEN
21374C                 STATISTICAL ENGINEERING DIVISION
21375C                 INFORMATION TECHNOLOGY LABORATORY
21376C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21377C                 GAITHERSBURG, MD 20899-8980
21378C                 PHONE--301-975-2855
21379C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21380C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
21381C     LANGUAGE--ANSI FORTRAN (1977)
21382C     VERSION NUMBER--2001/8
21383C     ORIGINAL VERSION--AUGUST    2001.
21384C
21385C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21386C
21387      CHARACTER*4 IHARG
21388      CHARACTER*4 IARGT
21389      CHARACTER*4 IFOUND
21390      CHARACTER*4 IERROR
21391C
21392C---------------------------------------------------------------------
21393C
21394      DIMENSION IHARG(*)
21395      DIMENSION IARGT(*)
21396      DIMENSION ARG(*)
21397C
21398C---------------------------------------------------------------------
21399C
21400      INCLUDE 'DPCOP2.INC'
21401C
21402C-----START POINT-----------------------------------------------------
21403C
21404      IFOUND='NO'
21405      IERROR='NO'
21406C
21407      IF(NUMARG.EQ.0)GOTO9000
21408      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO9000
21409      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'WIDT')GOTO1110
21410      IF(IHARG(NUMARG).EQ.'?')GOTO8100
21411      GOTO9000
21412C
21413 1110 CONTINUE
21414      IF(IHARG(NUMARG).EQ.'WIDT')GOTO1150
21415      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
21416      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
21417      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
21418      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
21419      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
21420      GOTO1120
21421C
21422 1120 CONTINUE
21423      IERROR='YES'
21424      WRITE(ICOUT,1121)
21425 1121 FORMAT('***** ERROR IN DPKDWI--')
21426      CALL DPWRST('XXX','BUG ')
21427      WRITE(ICOUT,1122)
21428 1122 FORMAT('      ILLEGAL FORM FOR KERNEL DENSITY WIDTH COMMAND.')
21429      CALL DPWRST('XXX','BUG ')
21430      GOTO9000
21431C
21432 1150 CONTINUE
21433      HOLD=DEFKWI
21434      GOTO1180
21435C
21436 1160 CONTINUE
21437      HOLD=ARG(NUMARG)
21438      GOTO1180
21439C
21440 1180 CONTINUE
21441      IFOUND='YES'
21442      PKDEWI=HOLD
21443C
21444      IF(IFEEDB.EQ.'OFF')GOTO1289
21445      WRITE(ICOUT,999)
21446  999 FORMAT(1X)
21447      CALL DPWRST('XXX','BUG ')
21448      IF(PKDEWI.NE.DEFKWI)THEN
21449        WRITE(ICOUT,1281)PKDEWI
21450 1281   FORMAT('THE KERNEL DENSITY WIDTH HAS JUST BEEN SET ',
21451     1         'TO ',G15.7)
21452        CALL DPWRST('XXX','BUG ')
21453      ELSE
21454        WRITE(ICOUT,1291)
21455 1291   FORMAT('THE KERNEL DENSITY WIDTH HAS JUST BEEN SET ',
21456     1         'TO THE DEFAULT.')
21457        CALL DPWRST('XXX','BUG ')
21458        WRITE(ICOUT,1293)
21459 1293   FORMAT('DATAPLOT WILL SELECT THE WIDTH BASED ON THE DATA.')
21460        CALL DPWRST('XXX','BUG ')
21461      ENDIF
21462 1289 CONTINUE
21463      GOTO9000
21464C
21465C               ********************************************
21466C               **  STEP 81--                             **
21467C               **  TREAT THE    ?    CASE--              **
21468C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
21469C               ********************************************
21470C
21471 8100 CONTINUE
21472      IFOUND='YES'
21473      WRITE(ICOUT,999)
21474      CALL DPWRST('XXX','BUG ')
21475      WRITE(ICOUT,8111)PKDEWI
21476 8111 FORMAT('THE CURRENT KERNEL DENSITY WIDTH    IS ',G15.7)
21477      CALL DPWRST('XXX','BUG ')
21478      WRITE(ICOUT,8121)DEFKWI
21479 8121 FORMAT('THE DEFAULT KERNEL DENSITY WIDTH    IS ',G15.7)
21480      CALL DPWRST('XXX','BUG ')
21481      GOTO9000
21482C
21483 9000 CONTINUE
21484      RETURN
21485      END
21486      SUBROUTINE DPKEEP(X,N,XREF,NREF,IOP,TAG,IBUGA3,ISUBRO,IERROR)
21487C
21488C     PURPOSE--GIVEN A GROUP-ID VARIABLE (X), IT MAY BE CONVENIENT
21489C              AT TIMES TO CREATE A TAG VARIABLE BASED ON A LIST
21490C              OF LABS TO EITHER KEEP OR OMIT FROM AN ANALYSIS.
21491C              THE VARIABLE TAG WILL BE SET TO 1 IF THE LAB IS
21492C              TO BE KEPT OR TO 0 IF THE LAB IS TO BE OMITTED.
21493C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
21494C                                OBSERVATIONS CONTAINING THE GROUP-ID's.
21495C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
21496C                                IN THE VECTOR X AND TAG.
21497C                     --XREF   = THE SINGLE PRECISION VECTOR OF
21498C                                GROUP-ID's TO BE EITHER KEPT OR
21499C                                OMITTED.
21500C                     --NREF   = THE INTEGER NUMBER OF OBSERVATIONS
21501C                                IN THE VECTOR XREF.
21502C                     --IOP    = A CHARACTER SCALAR THAT SPECIFIES
21503C                                WHETHER TO KEEP OR OMIT LABS BASED
21504C                                ON XREF.
21505C     OUTPUT ARGUMENTS--TAG    = THE SINGLE PRECISION VECTOR WHICH WILL
21506C                                BE CODED AS EITHER 0 OR 1 DEPENDING ON
21507C                                WHETHER THE LAB WILL BE OMITTED OR
21508C                                RETAINED.
21509C     OUTPUT--THE SINGLE PRECISION VECTOR TAG
21510C     PRINTING--NONE UNLESS AN INPUT ARGUMENT ERROR CONDITION EXISTS.
21511C     OTHER DATAPAC   SUBROUTINES NEEDED--NONE.
21512C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
21513C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
21514C     LANGUAGE--ANSI FORTRAN (1977)
21515C     WRITTEN BY--ALAN HECKERT
21516C                 STATISTICAL ENGINEERING DIVISION
21517C                 INFORMATION TECHNOLOGY LABORATORY
21518C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21519C                 GAITHERSBURG, MD 20899-8980
21520C                 PHONE--301-975-2899
21521C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21522C           OF THE NATIONAL BUREAU OF STANDARDS.
21523C     ORIGINAL VERSION--APRIL     2011.
21524C
21525C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21526C
21527C---------------------------------------------------------------------
21528C
21529      DIMENSION X(*)
21530      DIMENSION XREF(*)
21531      DIMENSION TAG(*)
21532C
21533      CHARACTER*4 IOP
21534      CHARACTER*4 IBUGA3
21535      CHARACTER*4 ISUBRO
21536      CHARACTER*4 IERROR
21537C
21538C---------------------------------------------------------------------
21539C
21540      INCLUDE 'DPCOP2.INC'
21541C
21542C-----START POINT-----------------------------------------------------
21543C
21544C     INITIALIZE TAG VARIABLE
21545C
21546      IF(IOP.EQ.'KEEP')THEN
21547        ATEMP=0.0
21548        IF(NREF.LE.0)ATEMP=1.0
21549        DO21I=1,N
21550          TAG(I)=ATEMP
21551   21   CONTINUE
21552      ELSE
21553        ATEMP=1.0
21554        IF(NREF.LE.0)ATEMP=0.0
21555        DO26I=1,N
21556          TAG(I)=ATEMP
21557   26   CONTINUE
21558      ENDIF
21559C
21560C     CHECK THE INPUT ARGUMENTS FOR ERRORS
21561C
21562      IF(N.LT.1)THEN
21563        WRITE(ICOUT,15)
21564   15   FORMAT('***** ERROR IN DPKEEP--')
21565        CALL DPWRST('XXX','BUG ')
21566        WRITE(ICOUT,17)
21567   17   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
21568     1         'VARIABLE IS NON-POSITIVE.')
21569        CALL DPWRST('XXX','BUG ')
21570        WRITE(ICOUT,47)N
21571   47   FORMAT('***** THE VALUE OF THE ARGUMENT IS ',I8)
21572        CALL DPWRST('XXX','BUG ')
21573        IERROR='YES'
21574        GOTO9000
21575      ELSEIF(NREF.LE.0)THEN
21576C
21577C       IF NO LIST OF OMITTED/RETAINED ID'S GIVEN, SIMPLY RETURN.
21578C
21579        GOTO9000
21580      ENDIF
21581C
21582      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KEEP')THEN
21583        WRITE(ICOUT,999)
21584  999   FORMAT(1X)
21585        CALL DPWRST('XXX','BUG ')
21586        WRITE(ICOUT,110)
21587  110   FORMAT('***** AT THE BEGINNING OF DPKEEP--')
21588        CALL DPWRST('XXX','BUG ')
21589        WRITE(ICOUT,111)N,NREF
21590  111   FORMAT('N,NREF = ',I8,I8)
21591        CALL DPWRST('XXX','BUG ')
21592        DO112I=1,N
21593          WRITE(ICOUT,113)I,X(I)
21594  113     FORMAT('I,X(I) = ',I8,G15.7)
21595          CALL DPWRST('XXX','BUG ')
21596  112   CONTINUE
21597        DO117I=1,NREF
21598          WRITE(ICOUT,119)I,XREF(I)
21599  119     FORMAT('I,XREF(I) = ',I8,G15.7)
21600          CALL DPWRST('XXX','BUG ')
21601  117   CONTINUE
21602      ENDIF
21603C
21604      ATEMP=1.0
21605      IF(IOP.EQ.'OMIT')ATEMP=0.0
21606      DO1200I=1,NREF
21607        XREFI=XREF(I)
21608        DO1300J=1,N
21609          IF(X(J).EQ.XREFI)TAG(J)=ATEMP
21610 1300   CONTINUE
21611 1200 CONTINUE
21612C
21613 9000 CONTINUE
21614      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KEEP')THEN
21615        WRITE(ICOUT,999)
21616        CALL DPWRST('XXX','BUG ')
21617        WRITE(ICOUT,9011)
21618 9011   FORMAT('***** AT THE END       OF DPKEEP--')
21619        CALL DPWRST('XXX','BUG ')
21620        DO9015I=1,N
21621          WRITE(ICOUT,9016)I,X(I),TAG(I)
21622 9016     FORMAT('I,X(I),TAG(I) = ',I8,2G15.7)
21623          CALL DPWRST('XXX','BUG ')
21624 9015   CONTINUE
21625      ENDIF
21626C
21627      RETURN
21628      END
21629      SUBROUTINE DPKMEA(ICAPSW,IFORSW,ISEED,
21630     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
21631C
21632C     PURPOSE--PERFORM EITHER
21633C                 1. A K-MEANS CLUSTER ANALYSIS (HARTIGAN) OR
21634C                 2. A MIXTURE OF NORMALS CLUSTER ANALYSIS (HARTIGAN) OR
21635C                 3. A SINGLE LINKAGE (NEAREST NEIGHBORS) CLUSTER
21636C                    ANALYSIS (HARTIGAN)
21637C                 4. A K-MEDOIDS CLUSTER ANALYSIS (ROUSSEEUW AND
21638C                    KAUFFMAN, CLARA AND PAM)
21639C                 5. AGNES CLUSTER ANALYSIS (ROUSSEEUW AND
21640C                    KAUFFMAN, AGNES AND DIANA)
21641C     REFERENCES--JOHN HARTIGAN (1979), "ALGORITHM AS 136", APPLIED
21642C                 STATISTICS, VOL. 28, NO. 1.
21643C               --JOHN HARTIGAN (1975), "CLUSTERING ALGORITHMS",
21644C                 WILEY.
21645C               --KAUFMAN AND ROUSSEEUW (1990), "FINDING GROUPS IN
21646C                 DATA", WILEY.
21647C     WRITTEN BY--ALAN HECKERT
21648C                 STATISTICAL ENGINEERING DIVISION
21649C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21650C                 GAITHERSBURG, MD 20899-8980
21651C                 PHONE--301-975-2899
21652C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21653C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
21654C     LANGUAGE--ANSI FORTRAN (1977)
21655C     VERSION NUMBER--2017/03
21656C     ORIGINAL VERSION--MARCH     2017.
21657C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE
21658C
21659C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21660C
21661      CHARACTER*4 ICAPSW
21662      CHARACTER*4 IFORSW
21663      CHARACTER*4 IBUGA2
21664      CHARACTER*4 IBUGA3
21665      CHARACTER*4 IBUGQ
21666      CHARACTER*4 ISUBRO
21667      CHARACTER*4 IFOUND
21668      CHARACTER*4 IERROR
21669C
21670      CHARACTER*40 INAME
21671      PARAMETER (MAXSPN=100)
21672      CHARACTER*4 IVARN1(MAXSPN)
21673      CHARACTER*4 IVARN2(MAXSPN)
21674      CHARACTER*4 IVARTY(MAXSPN)
21675      REAL PVAR(MAXSPN)
21676      INTEGER ILIS(MAXSPN)
21677      INTEGER NRIGHT(MAXSPN)
21678      INTEGER ICOLR(MAXSPN)
21679C
21680      CHARACTER*4 IHP
21681      CHARACTER*4 IHP2
21682      CHARACTER*4 IHWUSE
21683      CHARACTER*4 MESSAG
21684      CHARACTER*4 ISUBN1
21685      CHARACTER*4 ISUBN2
21686      CHARACTER*4 ISTEPN
21687      CHARACTER*4 ICASAN
21688C
21689C---------------------------------------------------------------------
21690C
21691      INCLUDE 'DPCOPA.INC'
21692      INCLUDE 'DPCOZZ.INC'
21693      INCLUDE 'DPCOZI.INC'
21694      INCLUDE 'DPCOZC.INC'
21695C
21696      DIMENSION YA(20*MAXOBV)
21697      DIMENSION YC(MAXOBV)
21698      DIMENSION YD(MAXOBV)
21699      DIMENSION AN1(MAXOBV)
21700      DIMENSION AN2(MAXOBV)
21701      DIMENSION WSS(MAXOBV)
21702      DIMENSION TEMP1(3*MAXOBV)
21703C
21704      DIMENSION IC1(MAXOBV)
21705      DIMENSION IC2(MAXOBV)
21706      DIMENSION NC(MAXOBV)
21707      DIMENSION NCP(MAXOBV)
21708      DIMENSION ITRAN(MAXOBV)
21709      DIMENSION ILIVE(MAXOBV)
21710C
21711      CHARACTER*8 RLAB(MAXOBV)
21712C
21713      EQUIVALENCE (GARBAG(IGARB1),YC(1))
21714      EQUIVALENCE (GARBAG(IGARB2),YD(1))
21715      EQUIVALENCE (GARBAG(IGARB3),AN1(1))
21716      EQUIVALENCE (GARBAG(IGARB4),AN2(1))
21717      EQUIVALENCE (GARBAG(IGARB5),WSS(1))
21718      EQUIVALENCE (GARBAG(IGARB6),TEMP1(1))
21719      EQUIVALENCE (GARBAG(IGAR10),YA(1))
21720C
21721      EQUIVALENCE (IGARBG(IIGAR1),IC1(1))
21722      EQUIVALENCE (IGARBG(IIGAR2),IC2(1))
21723      EQUIVALENCE (IGARBG(IIGAR3),NC(1))
21724      EQUIVALENCE (IGARBG(IIGAR4),NCP(1))
21725      EQUIVALENCE (IGARBG(IIGAR5),ITRAN(1))
21726      EQUIVALENCE (IGARBG(IIGAR6),ILIVE(1))
21727C
21728      EQUIVALENCE (CGARBG(1),RLAB(1))
21729C
21730C-----COMMON----------------------------------------------------------
21731C
21732      INCLUDE 'DPCOSU.INC'
21733      INCLUDE 'DPCOHK.INC'
21734      INCLUDE 'DPCODA.INC'
21735      INCLUDE 'DPCOST.INC'
21736      INCLUDE 'DPCOP2.INC'
21737C
21738C-----START POINT-----------------------------------------------------
21739C
21740      IERROR='NO'
21741      ISUBN1='DPKM'
21742      ISUBN2='EA  '
21743C
21744      MAXCP1=MAXCOL+1
21745      MAXCP2=MAXCOL+2
21746      MAXCP3=MAXCOL+3
21747      MAXCP4=MAXCOL+4
21748      MAXCP5=MAXCOL+5
21749      MAXCP6=MAXCOL+6
21750C
21751C               *********************************************
21752C               **  TREAT THE K-MEANS                CASE  **
21753C               *********************************************
21754C
21755      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'KMEA')THEN
21756        WRITE(ICOUT,999)
21757  999   FORMAT(1X)
21758        CALL DPWRST('XXX','BUG ')
21759        WRITE(ICOUT,51)
21760   51   FORMAT('***** AT THE BEGINNING OF DPKMEA--')
21761        CALL DPWRST('XXX','BUG ')
21762        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGQ,ISUBRO
21763   53   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
21764        CALL DPWRST('XXX','BUG ')
21765        WRITE(ICOUT,55)ICOM,IHARG(1),IHARG(2)
21766   55   FORMAT('ICOM,IHARG(1),IHARG(2) = ',2(A4,2X),A4)
21767        CALL DPWRST('XXX','BUG ')
21768      ENDIF
21769C
21770C               ***************************
21771C               **  STEP 1--             **
21772C               **  EXTRACT THE COMMAND  **
21773C               ***************************
21774C
21775      ISTEPN='1'
21776      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KMEA')
21777     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21778C
21779      IF(ICOM.EQ.'K   ' .AND. IHARG(1).EQ.'MEAN' .AND.
21780     1   IHARG(2).EQ.'CLUS')THEN
21781        ILASTC=2
21782        ICASAN='KMEA'
21783      ELSEIF(ICOM.EQ.'K   ' .AND. IHARG(1).EQ.'MEAN')THEN
21784        ILASTC=1
21785        ICASAN='KMEA'
21786      ELSEIF(ICOM.EQ.'K   ' .AND. IHARG(1).EQ.'MEDO' .AND.
21787     1   IHARG(2).EQ.'CLUS')THEN
21788        ILASTC=2
21789        ICASAN='KMED'
21790      ELSEIF(ICOM.EQ.'K   ' .AND. IHARG(1).EQ.'MEDO')THEN
21791        ILASTC=1
21792        ICASAN='KMED'
21793      ELSEIF(ICOM.EQ.'K   ' .AND. IHARG(1).EQ.'MEDI' .AND.
21794     1   IHARG(2).EQ.'CLUS')THEN
21795        ILASTC=2
21796        ICASAN='KMED'
21797      ELSEIF(ICOM.EQ.'K   ' .AND. IHARG(1).EQ.'MEDI')THEN
21798        ILASTC=1
21799        ICASAN='KMED'
21800      ELSEIF(ICOM.EQ.'NORM' .AND. IHARG(1).EQ.'MIXT' .AND.
21801     1   IHARG(2).EQ.'CLUS')THEN
21802        ILASTC=2
21803        ICASAN='NMIX'
21804      ELSEIF(ICOM.EQ.'SING' .AND. IHARG(1).EQ.'LINK' .AND.
21805     1   IHARG(2).EQ.'CLUS')THEN
21806        ILASTC=2
21807        ICASAN='SLIN'
21808      ELSEIF(ICOM.EQ.'AGNE' .AND. IHARG(1).EQ.'CLUS')THEN
21809        ILASTC=1
21810        ICASAN='AGNE'
21811      ELSEIF(ICOM.EQ.'AGNE')THEN
21812        ILASTC=0
21813        ICASAN='AGNE'
21814      ELSEIF(ICOM.EQ.'DIAN' .AND. IHARG(1).EQ.'CLUS')THEN
21815        ILASTC=1
21816        ICASAN='DIAN'
21817      ELSEIF(ICOM.EQ.'DIAN')THEN
21818        ILASTC=0
21819        ICASAN='DIAN'
21820      ELSEIF(ICOM.EQ.'FANN' .AND. IHARG(1).EQ.'CLUS')THEN
21821        ILASTC=1
21822        ICASAN='FANN'
21823      ELSEIF(ICOM.EQ.'FANN')THEN
21824        ILASTC=0
21825        ICASAN='FANN'
21826      ELSEIF(ICOM.EQ.'FUZZ' .AND. IHARG(1).EQ.'CLUS')THEN
21827        ILASTC=1
21828        ICASAN='FANN'
21829      ELSEIF(ICOM.EQ.'FUZZ')THEN
21830        ILASTC=0
21831        ICASAN='FANN'
21832      ELSE
21833        IFOUND='NO'
21834        GOTO9000
21835      ENDIF
21836C
21837      IFOUND='YES'
21838      IF(ILASTC.GE.1)THEN
21839        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
21840      ENDIF
21841C
21842C               ****************************************
21843C               **  STEP 2--                          **
21844C               **  EXTRACT THE VARIABLE LIST         **
21845C               ****************************************
21846C
21847      ISTEPN='2'
21848      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KMEA')
21849     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21850C
21851      IF(ICASAN.EQ.'NMIX')THEN
21852        INAME='NORMAL MIXTURE CLUSTERING'
21853      ELSEIF(ICASAN.EQ.'SLIN')THEN
21854        INAME='SINGLE LINKAGE CLUSTERING'
21855      ELSEIF(ICASAN.EQ.'KMED')THEN
21856        INAME='K-MEDIODS CLUSTERING'
21857      ELSE
21858        INAME='K-MEANS CLUSTERING'
21859      ENDIF
21860      MINNA=1
21861      MAXNA=100
21862      MINN2=2
21863      IFLAGE=1
21864      IFLAGM=9
21865      IFLAGP=0
21866      JMIN=1
21867      JMAX=NUMARG
21868      MINNVA=1
21869      MAXNVA=MAXSPN
21870C
21871      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
21872     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
21873     1            JMIN,JMAX,
21874     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
21875     1            IVARN1,IVARN2,IVARTY,PVAR,
21876     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
21877     1            MINNVA,MAXNVA,
21878     1            IFLAGM,IFLAGP,
21879     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
21880      IF(IERROR.EQ.'YES')GOTO9000
21881C
21882      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KMEA')THEN
21883        WRITE(ICOUT,999)
21884        CALL DPWRST('XXX','BUG ')
21885        WRITE(ICOUT,281)
21886  281   FORMAT('***** AFTER CALL DPPARS--')
21887        CALL DPWRST('XXX','BUG ')
21888        WRITE(ICOUT,282)NQ,NUMVAR
21889  282   FORMAT('NQ,NUMVAR = ',2I8)
21890        CALL DPWRST('XXX','BUG ')
21891        IF(NUMVAR.GT.0)THEN
21892          DO285I=1,NUMVAR
21893            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
21894     1                      ICOLR(I)
21895  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
21896     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
21897            CALL DPWRST('XXX','BUG ')
21898  285     CONTINUE
21899        ENDIF
21900      ENDIF
21901C
21902C               ****************************************
21903C               **  STEP 3--                          **
21904C               **  EXTRACT THE DATA                  **
21905C               ****************************************
21906C
21907      ISTEPN='3'
21908      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KMEA')
21909     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21910C
21911      IF(ICASAN.NE.'AGNE' .AND. ICASAN.NE.'DIAN')THEN
21912        IHP='NCLU'
21913        IHP2='STER'
21914        IHWUSE='P'
21915        MESSAG='YES'
21916        CALL CHECKN(IHP,IHP2,IHWUSE,
21917     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21918     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
21919        IF(IERROR.EQ.'YES')GOTO9000
21920        AVAL=VALUE(ILOCV)
21921        NCLUST=INT(AVAL+0.1)
21922        IF(NCLUST.LT.2)THEN
21923          IERROR='YES'
21924          GOTO9000
21925        ENDIF
21926      ELSE
21927        NCLUST=0
21928      ENDIF
21929C
21930      MAXNXT=20*MAXOBV
21931      ICOL=1
21932      CALL DPPARY(ICOL,IVALUE,IVALU2,IN,MAXN,MAXNXT,
21933     1            INAME,IVARN1,IVARN2,IVARTY,
21934     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
21935     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
21936     1            MAXCP4,MAXCP5,MAXCP6,
21937     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
21938     1            YA,NLOCAL,NROW,NCOL,
21939     1            IBUGA3,ISUBRO,IFOUND,IERROR)
21940      IF(IERROR.EQ.'YES')GOTO9000
21941C
21942      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KMEA')THEN
21943        WRITE(ICOUT,352)NLOCAL,NROW,NCOL,NCLUST
21944  352   FORMAT('NLOCAL,NROW,NCOL,NCLUST = ',4I8)
21945        CALL DPWRST('XXX','BUG ')
21946        DO360II=1,MIN(NLOCAL,1000)
21947          WRITE(ICOUT,362)II,YA(II)
21948  362     FORMAT('II,YA(II) = ',I8,2X,G15.7)
21949          CALL DPWRST('XXX','BUG ')
21950  360   CONTINUE
21951      ENDIF
21952C
21953C               *****************************************************
21954C               **  STEP 4--                                       **
21955C               **  PERFORM THE CLUSTER ANALYSIS                   **
21956C               *****************************************************
21957C
21958      ISTEPN='4'
21959      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KMEA')
21960     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21961C
21962      IF(ICASAN.EQ.'KMEA')THEN
21963        IF(IKMERL.EQ.'ON')THEN
21964          J=0
21965          DO401II=1,NROW
21966            IF(ISUB(I).EQ.0)GOTO401
21967            J=J+1
21968            RLAB(J)(1:8)=IROWLB(II)(1:8)
21969  401     CONTINUE
21970        ELSE
21971          J=0
21972          DO403II=1,NQ
21973            IF(ISUB(I).EQ.0)GOTO403
21974            J=J+1
21975            WRITE(RLAB(J)(1:8),'(I8)')II
21976  403     CONTINUE
21977        ENDIF
21978        CALL DPKME2(YA,NROW,NCOL,NCLUST,
21979     1              YC,YD,AN1,AN2,WSS,TEMP1,
21980     1              IC1,IC2,NC,NCP,ITRAN,ILIVE,
21981     1              ICAPSW,ICAPTY,IFORSW,MAXOBV,ISEED,
21982     1              ISUBRO,IBUGA3,IERROR)
21983      ELSEIF(ICASAN.EQ.'NMIX')THEN
21984        IF(INMCRL.EQ.'ON')THEN
21985          J=0
21986          DO411II=1,NROW
21987            IF(ISUB(I).EQ.0)GOTO411
21988            J=J+1
21989            RLAB(J)(1:8)=IROWLB(II)(1:8)
21990  411     CONTINUE
21991        ELSE
21992          J=0
21993          DO413II=1,NROW
21994            IF(ISUB(I).EQ.0)GOTO413
21995            J=J+1
21996            WRITE(RLAB(J)(1:8),'(I8)')II
21997  413     CONTINUE
21998        ENDIF
21999        CALL DPNMI2(YA,NROW,NCOL,NCLUST,
22000     1              GARBAG(1),YC,AN1,AN2,IC1,
22001     1              IVARN1,IVARN2,RLAB,
22002     1              ICAPTY,ICAPSW,IFORSW,
22003     1              ISUBRO,IBUGA3,IERROR)
22004      ELSEIF(ICASAN.EQ.'KMED')THEN
22005        IF(IKMERL.EQ.'ON')THEN
22006          J=0
22007          DO421II=1,NROW
22008            IF(ISUB(I).EQ.0)GOTO421
22009            J=J+1
22010            RLAB(J)(1:8)=IROWLB(II)(1:8)
22011  421     CONTINUE
22012        ELSE
22013          J=0
22014          DO423II=1,NQ
22015            IF(ISUB(I).EQ.0)GOTO423
22016            J=J+1
22017            WRITE(RLAB(J)(1:8),'(I8)')II
22018  423     CONTINUE
22019        ENDIF
22020        IF(NROW.GT.IKMDPN)THEN
22021          CALL DPCLA2(YA,NROW,NCOL,NCLUST,IVARN1,IVARN2,
22022     1                TEMP1(1),AN1,AN2,YC,
22023     1                WSS(1),WSS(10000),WSS(20000),
22024     1                WSS(30000),WSS(40000),
22025     1                WSS(50000),WSS(60000),WSS(70000),
22026     1                IC1,IC2,NC,NCP,
22027     1                ITRAN(1),ITRAN(101),ITRAN(10001),
22028     1                ITRAN(30001),ITRAN(40001),ITRAN(50001),
22029     1                ITRAN(60001),
22030     1                TEMP1(MAXOBV+1),ILIVE,
22031     1                ICAPSW,ICAPTY,IFORSW,MAXOBV,ISEED,
22032     1                ISUBRO,IBUGA3,IERROR)
22033        ELSE
22034          CALL DPPAM2(YA,NROW,NCOL,NCLUST,IVARN1,IVARN2,
22035     1                YC,YD,AN1,AN2,WSS,
22036     1                TEMP1(1),TEMP1(MAXOBV+1),TEMP1(MAXOBV+2),
22037     1                IC1,IC2,NC,NCP,ITRAN,
22038     1                ICAPSW,ICAPTY,IFORSW,MAXOBV,
22039     1                ISUBRO,IBUGA3,IERROR)
22040        ENDIF
22041      ELSEIF(ICASAN.EQ.'AGNE' .OR. ICASAN.EQ.'DIAN')THEN
22042        IF(NROW.GT.IAGNMS)THEN
22043          WRITE(ICOUT,999)
22044          CALL DPWRST('XXX','BUG ')
22045          WRITE(ICOUT,436)
22046  436     FORMAT('***** ERROR IN AGNES CLUSTERING--')
22047          CALL DPWRST('XXX','BUG ')
22048          WRITE(ICOUT,437)NROW
22049  437     FORMAT('      NUMBER OF OBJECTS TO BE CLUSTERED (',I8,') ')
22050          CALL DPWRST('XXX','BUG ')
22051          WRITE(ICOUT,438)IAGNMS
22052  438     FORMAT('      IS GREATER THAN ',I5)
22053          CALL DPWRST('XXX','BUG ')
22054          IERROR='YES'
22055          GOTO9000
22056        ENDIF
22057C
22058        IF(IKMERL.EQ.'ON')THEN
22059          J=0
22060          DO431II=1,NROW
22061            IF(ISUB(I).EQ.0)GOTO431
22062            J=J+1
22063            RLAB(J)(1:8)=IROWLB(II)(1:8)
22064  431     CONTINUE
22065        ELSE
22066          J=0
22067          DO433II=1,NQ
22068            IF(ISUB(I).EQ.0)GOTO433
22069            J=J+1
22070            WRITE(RLAB(J)(1:8),'(I8)')II
22071  433     CONTINUE
22072        ENDIF
22073C
22074        CALL DPAGN2(YA,NROW,NCOL,IVARN1,IVARN2,
22075     1                YC,YD,AN1,AN2,WSS,TEMP1,TEMP1(MAXOBV+1),
22076     1                IC1,IC2,NC,NCP,ITRAN,
22077     1                ICASAN,ICAPSW,ICAPTY,IFORSW,MAXOBV,
22078     1                ISUBRO,IBUGA3,IERROR)
22079      ELSEIF(ICASAN.EQ.'FANN')THEN
22080        IF(NROW.GT.IFANMS)THEN
22081          WRITE(ICOUT,999)
22082          CALL DPWRST('XXX','BUG ')
22083          WRITE(ICOUT,446)
22084  446     FORMAT('***** ERROR IN FANNY CLUSTERING--')
22085          CALL DPWRST('XXX','BUG ')
22086          WRITE(ICOUT,437)NROW
22087          CALL DPWRST('XXX','BUG ')
22088          WRITE(ICOUT,438)IFANMS
22089          CALL DPWRST('XXX','BUG ')
22090          IERROR='YES'
22091          GOTO9000
22092        ENDIF
22093C
22094        IF(IKMERL.EQ.'ON')THEN
22095          J=0
22096          DO441II=1,NROW
22097            IF(ISUB(I).EQ.0)GOTO441
22098            J=J+1
22099            RLAB(J)(1:8)=IROWLB(II)(1:8)
22100  441     CONTINUE
22101        ELSE
22102          J=0
22103          DO443II=1,NQ
22104            IF(ISUB(I).EQ.0)GOTO443
22105            J=J+1
22106            WRITE(RLAB(J)(1:8),'(I8)')II
22107  443     CONTINUE
22108        ENDIF
22109        CALL DPFAN2(YA,NROW,NCOL,NCLUST,IVARN1,IVARN2,
22110     1              AN1,AN2,TEMP1(1),TEMP1(MAXOBV+1),
22111     1              TEMP1(2*MAXOBV+1),YC,YD,WSS,
22112     1              IC1,IC2,NC,
22113     1              ICAPSW,ICAPTY,IFORSW,MAXOBV,
22114     1              ISUBRO,IBUGA3,IERROR)
22115      ENDIF
22116C
22117C               *****************
22118C               **  STEP 90--  **
22119C               **  EXIT       **
22120C               *****************
22121C
22122 9000 CONTINUE
22123      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'KMEA')THEN
22124        WRITE(ICOUT,999)
22125        CALL DPWRST('XXX','BUG ')
22126        WRITE(ICOUT,9011)
22127 9011   FORMAT('***** AT THE END       OF DPKMEA--')
22128        CALL DPWRST('XXX','BUG ')
22129        WRITE(ICOUT,9012)IFOUND,IERROR
22130 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
22131        CALL DPWRST('XXX','BUG ')
22132      ENDIF
22133C
22134      RETURN
22135      END
22136      SUBROUTINE DPKME2(YA,NROW,NCOL,NCLUST,
22137     1                  YC,YD,AN1,AN2,WSS,TEMP1,
22138     1                  IC1,IC2,NC,NCP,ITRAN,ILIVE,
22139     1                  ICAPSW,ICAPTY,IFORSW,MAXNXT,ISEED,
22140     1                  ISUBRO,IBUGA3,IERROR)
22141C
22142C     PURPOSE--PERFORM A K-MEANS CLUSTER ANALYSIS USING HARTIGAN'S
22143C              APPLIED STATISTICS 136 ALGORITHM.
22144C     REFERENCES--JOHN HARTIGAN (1979), "ALGORITHM AS 136", APPLIED
22145C                 STATISTICS, VOL. 28, NO. 1.
22146C               --ROUSSEEUW (1987), "SILHOUETTES: A GRAPHICAL AID TO THE
22147C                 INTERPRETATION AND VALIDATION OF CLUSTER ANALYSIS",
22148C                 JOURNAL OF COMPUTATIONAL AND APPLIED MATHEMATICS,
22149C                 VOL. 20, PP. 53-65, NORTH HOLLAND.
22150C     WRITTEN BY--ALAN HECKERT
22151C                 STATISTICAL ENGINEERING DIVISION
22152C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22153C                 GAITHERSBURG, MD 20899-8980
22154C                 PHONE--301-975-2899
22155C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22156C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22157C     REFERENCE--ASTM MANUAL STP-15D, PAGES 78-84, 100-105
22158C     LANGUAGE--ANSI FORTRAN (1977)
22159C     VERSION NUMBER--2017/03
22160C     ORIGINAL VERSION--MARCH       2017.
22161C
22162C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22163C
22164      DIMENSION YA(NROW,NCOL)
22165      DIMENSION YC(NCLUST,NCOL)
22166      DIMENSION YD(*)
22167      DIMENSION AN1(*)
22168      DIMENSION AN2(*)
22169      DIMENSION WSS(*)
22170      DIMENSION TEMP1(*)
22171C
22172      INTEGER IC1(*)
22173      INTEGER IC2(*)
22174      INTEGER NC(*)
22175      INTEGER NCP(*)
22176      INTEGER ITRAN(*)
22177      INTEGER ILIVE(*)
22178C
22179      DIMENSION ALOCSV(200)
22180      DIMENSION SCALSV(200)
22181C
22182      CHARACTER*4 ICAPSW
22183      CHARACTER*4 ICAPTY
22184      CHARACTER*4 IFORSW
22185      CHARACTER*4 ISUBRO
22186      CHARACTER*4 IBUGA3
22187      CHARACTER*4 IERROR
22188C
22189      CHARACTER*4 IWRITE
22190      CHARACTER*4 ISUBN1
22191      CHARACTER*4 ISUBN2
22192      CHARACTER*4 ISTEPN
22193      CHARACTER*4 ICASPL
22194      CHARACTER*4 ITYP3
22195      CHARACTER*4 IOP
22196      CHARACTER*10 IFORMT
22197C
22198      INCLUDE 'DPCOST.INC'
22199C
22200      PARAMETER(NUMCLI=3)
22201      PARAMETER(MAXLIN=3)
22202      PARAMETER(MAXROW=35)
22203      CHARACTER*65 ITITLE
22204      CHARACTER*60 ITITL9
22205      CHARACTER*4  ALIGN(NUMCLI)
22206      CHARACTER*4  VALIGN(NUMCLI)
22207      INTEGER      IDIGI2(MAXROW,NUMCLI)
22208      INTEGER      NTOT(MAXROW)
22209      INTEGER      ROWSEP(MAXROW)
22210      CHARACTER*20 ITITL2(MAXLIN,NUMCLI)
22211      CHARACTER*20 IVALUE(MAXROW,NUMCLI)
22212      CHARACTER*4  ITYPCO(NUMCLI)
22213      INTEGER      NCTIT2(MAXLIN,NUMCLI)
22214      INTEGER      NCVALU(MAXROW,NUMCLI)
22215      INTEGER      NCOLSP(MAXLIN,NUMCLI)
22216      INTEGER      IWHTML(NUMCLI)
22217      INTEGER      IWRTF(NUMCLI)
22218      REAL         AMAT(MAXROW,NUMCLI)
22219      LOGICAL IFRST
22220      LOGICAL ILAST
22221      LOGICAL IFLAGS
22222      LOGICAL IFLAGE
22223C
22224C
22225C---------------------------------------------------------------------
22226C
22227      INCLUDE 'DPCOP2.INC'
22228C
22229C-----START POINT-----------------------------------------------------
22230C
22231      ISUBN1='DPKM'
22232      ISUBN2='E2  '
22233      IWRITE='OFF'
22234C
22235      ICNT=0
22236      ICNT2=0
22237      ICNT3=0
22238C
22239      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KME2')THEN
22240        WRITE(ICOUT,999)
22241  999   FORMAT(1X)
22242        CALL DPWRST('XXX','BUG ')
22243        WRITE(ICOUT,70)
22244   70   FORMAT('AT THE BEGINNING OF DPKME2--')
22245        CALL DPWRST('XXX','BUG ')
22246        WRITE(ICOUT,72)NROW,NCOL,NCLUST,IKMEIN
22247   72   FORMAT('NROW,NCOL,NCLUST,IKMEIN = ',3I8,2X,A4)
22248        CALL DPWRST('XXX','BUG ')
22249        DO75I=1,NROW
22250          WRITE(ICOUT,77)I,(YA(I,J),J=1,MIN(NCOL,3))
22251   77     FORMAT('I,YA(I,1),YA(I,2),YA(I,3) = ',I8,2X,3G15.7)
22252          CALL DPWRST('XXX','BUG ')
22253   75   CONTINUE
22254      ENDIF
22255C
22256C               ******************************
22257C               **   STEP 1A--              **
22258C               **   SCALE IF REQUESTED     **
22259C               ******************************
22260C
22261      ISTEPN='1'
22262      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KME2')
22263     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22264C
22265      DO90I=1,200
22266        ALOCSV(I)=0.0
22267        SCALSV(I)=1.0
22268   90 CONTINUE
22269C
22270      IF(IKMESC.EQ.'OFF')GOTO199
22271C
22272      DO101JJ=1,NCOL
22273        DO103II=1,NROW
22274          TEMP1(II)=YA(II,JJ)
22275  103   CONTINUE
22276        IF(ISTALO.EQ.'MEAN')THEN
22277          CALL MEAN(TEMP1,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
22278        ELSEIF(ISTALO.EQ.'MEDI')THEN
22279          CALL MEDIAN(TEMP1,NROW,IWRITE,AN1,MAXNXT,XMEAN,
22280     1                IBUGA3,IERROR)
22281        ELSEIF(ISTALO.EQ.'MIDM')THEN
22282          CALL MIDMEA(TEMP1,NROW,IWRITE,AN1,MAXNXT,XMEAN,
22283     1                IBUGA3,IERROR)
22284        ELSEIF(ISTALO.EQ.'HARM')THEN
22285          CALL HARMEA(TEMP1,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
22286        ELSEIF(ISTALO.EQ.'MINI')THEN
22287          CALL MINIM(TEMP1,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
22288        ELSEIF(ISTALO.EQ.'GEOM')THEN
22289          CALL GEOMEA(TEMP1,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
22290        ELSEIF(ISTALO.EQ.'BILO')THEN
22291          CALL BIWLOC(TEMP1,NROW,IWRITE,AN1,AN2,MAXNXT,XMEAN,
22292     1                IBUGA3,IERROR)
22293        ELSEIF(ISTALO.EQ.'H15 ')THEN
22294          NCUT=0
22295          C=1.5
22296          CALL H15(TEMP1,NROW,C,NCUT,XMEAN,XSC,AN1,AN2,MAXNXT,
22297     1                IBUGA3,IERROR)
22298        ELSEIF(ISTALO.EQ.'H10 ')THEN
22299          NCUT=0
22300          C=1.0
22301          CALL H15(TEMP1,NROW,C,NCUT,XMEAN,XSC,AN1,AN2,MAXNXT,
22302     1                IBUGA3,IERROR)
22303        ELSEIF(ISTALO.EQ.'H12 ')THEN
22304          NCUT=0
22305          C=1.2
22306          CALL H15(TEMP1,NROW,C,NCUT,XMEAN,XSC,AN1,AN2,MAXNXT,
22307     1                IBUGA3,IERROR)
22308        ELSEIF(ISTALO.EQ.'H17 ')THEN
22309          NCUT=0
22310          C=1.7
22311          CALL H15(TEMP1,NROW,C,NCUT,XMEAN,XSC,AN1,AN2,MAXNXT,
22312     1                IBUGA3,IERROR)
22313        ELSEIF(ISTALO.EQ.'H20 ')THEN
22314          NCUT=0
22315          C=2.0
22316          CALL H15(TEMP1,NROW,C,NCUT,XMEAN,XSC,AN1,AN2,MAXNXT,
22317     1                IBUGA3,IERROR)
22318        ELSE
22319          CALL MEAN(TEMP1,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
22320        ENDIF
22321C
22322        IF(ISTASC.EQ.'SD  ')THEN
22323          CALL SD(TEMP1,NROW,IWRITE,XSD,IBUGA3,IERROR)
22324        ELSEIF(ISTASC.EQ.'H15S')THEN
22325          NCUT=0
22326          C=1.5
22327          CALL H15(TEMP1,NROW,C,NCUT,XLOC,XSD,AN1,AN2,MAXNXT,
22328     1                IBUGA3,IERROR)
22329        ELSEIF(ISTASC.EQ.'H10S')THEN
22330          NCUT=0
22331          C=1.0
22332          CALL H15(TEMP1,NROW,C,NCUT,XLOC,XSD,AN1,AN2,MAXNXT,
22333     1                IBUGA3,IERROR)
22334        ELSEIF(ISTASC.EQ.'H12S')THEN
22335          NCUT=0
22336          C=1.2
22337          CALL H15(TEMP1,NROW,C,NCUT,XLOC,XSD,AN1,AN2,MAXNXT,
22338     1                IBUGA3,IERROR)
22339        ELSEIF(ISTASC.EQ.'H17S')THEN
22340          NCUT=0
22341          C=1.7
22342          CALL H15(TEMP1,NROW,C,NCUT,XLOC,XSD,AN1,AN2,MAXNXT,
22343     1                IBUGA3,IERROR)
22344        ELSEIF(ISTASC.EQ.'H20S')THEN
22345          NCUT=0
22346          C=2.0
22347          CALL H15(TEMP1,NROW,C,NCUT,XLOC,XSD,AN1,AN2,MAXNXT,
22348     1                IBUGA3,IERROR)
22349        ELSEIF(ISTASC.EQ.'BISC')THEN
22350          CALL BIWSCA(TEMP1,NROW,IWRITE,AN1,AN2,MAXNXT,XSD,
22351     1                IBUGA3,IERROR)
22352        ELSEIF(ISTASC.EQ.'MAD ')THEN
22353          CALL MAD(TEMP1,NROW,IWRITE,AN1,AN2,MAXNXT,XSD,
22354     1             IBUGA3,IERROR)
22355        ELSEIF(ISTASC.EQ.'MADN')THEN
22356          CALL MAD(TEMP1,NROW,IWRITE,AN1,AN2,MAXNXT,XSD,
22357     1             IBUGA3,IERROR)
22358          XSD=XSD/0.67449
22359        ELSEIF(ISTASC.EQ.'AAD ')THEN
22360          CALL AAD(TEMP1,NROW,IWRITE,AN1,MAXNXT,XSD,'MEAN',
22361     1             IBUGA3,IERROR)
22362        ELSEIF(ISTASC.EQ.'IQRA')THEN
22363          CALL LOWQUA(TEMP1,NROW,IWRITE,AN1,MAXNXT,RIGH1,
22364     1                IBUGA3,IERROR)
22365          CALL UPPQUA(TEMP1,NROW,IWRITE,AN1,MAXNXT,RIGH2,
22366     1                IBUGA3,IERROR)
22367          XSD=RIGH2-RIGH1
22368        ELSEIF(ISTASC.EQ.'NIQR')THEN
22369          CALL LOWQUA(TEMP1,NROW,IWRITE,AN1,MAXNXT,RIGH1,
22370     1                IBUGA3,IERROR)
22371          CALL UPPQUA(TEMP1,NROW,IWRITE,AN1,MAXNXT,RIGH2,
22372     1                IBUGA3,IERROR)
22373          XSD=0.7413*(RIGH2-RIGH1)
22374        ELSEIF(ISTASC.EQ.'SNSC')THEN
22375          XSD=SN(TEMP1,NROW,AN1,AN2,WSS)
22376        ELSEIF(ISTASC.EQ.'RANG')THEN
22377          CALL MINIM(TEMP1,NROW,IWRITE,XMIN,IBUGA3,IERROR)
22378          CALL MAXIM(TEMP1,NROW,IWRITE,XMAX,IBUGA3,IERROR)
22379          XSD=XMAX - XMIN
22380        ELSE
22381          CALL SD(TEMP1,NROW,IWRITE,XMEAN,IBUGA3,IERROR)
22382        ENDIF
22383C
22384        IF(XSD.LE.0.0)THEN
22385          WRITE(ICOUT,211)
22386          CALL DPWRST('XXX','BUG ')
22387          WRITE(ICOUT,106)JJ
22388  106     FORMAT('       VARIABLE ',I4,' HAS ZERO STANDARD DEVIATION ',
22389     1           'WHEN SCALING REQUESTED.')
22390          CALL DPWRST('XXX','BUG ')
22391          IERROR='YES'
22392          GOTO9000
22393        ENDIF
22394        ALOCSV(JJ)=XMEAN
22395        SCALSV(JJ)=XSD
22396        DO105II=1,NROW
22397          AVAL=(YA(II,JJ)-XMEAN)/XSD
22398          YA(II,JJ)=AVAL
22399  105   CONTINUE
22400  101 CONTINUE
22401C
22402  199 CONTINUE
22403C
22404C               ******************************
22405C               **   STEP 1B--              **
22406C               **   CREATE INITIAL CLUSTER **
22407C               ******************************
22408C
22409      ISTEPN='1'
22410      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KME2')
22411     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22412C
22413C
22414C     RANDOMLY SELECT ROWS TO USE AS INITIAL CLUSTER
22415C     CENTERS.
22416C
22417      IF(IKMEIN.EQ.'RAND')THEN
22418        CALL RANPER(NROW,ISEED,AN1)
22419        DO110II=1,NCLUST
22420          IROWT=INT(AN1(II)+0.1)
22421          DO120JJ=1,NCOL
22422            YC(II,JJ)=YA(IROWT,JJ)
22423  120     CONTINUE
22424  110   CONTINUE
22425      ELSE
22426C
22427C       USE ALGORITHM SUGGESTED BY HARTIGAN TO DEFINE
22428C       INITIAL CLUSTER CENTERS.
22429C
22430C       FIND COLUMN MEANS
22431C
22432        DO150II=1,NCOL
22433          CALL MEAN(YA(1,II),NROW,IWRITE,XMEAN,IBUGA3,IERROR)
22434          AN1(II)=XMEAN
22435  150   CONTINUE
22436C
22437C       FIND DISTANCE FROM EACH ROW TO MEAN MATRIX
22438C
22439        DO160II=1,NROW
22440          DO165JJ=1,NCOL
22441            AN2(JJ)=YA(II,JJ)
22442  165     CONTINUE
22443          ICASPL='VEDI'
22444          CALL VECARI(AN1,AN2,NCOL,ICASPL,IWRITE,
22445     1                TEMP1,N3,ADIST,ITYP3,
22446     1                IBUGA3,ISUBRO,IERROR)
22447          YD(II)=ADIST
22448  160   CONTINUE
22449        CALL SORTI(YD,NROW,YD,WSS)
22450C
22451C       SELECT ROW 1 + (L-1)*(NROW/NCLUST) FOR CLUSTER L
22452C
22453        DO170II=1,NCLUST
22454          AVAL=1.0 + REAL(II-1)*(REAL(NROW)/REAL(NCLUST))
22455          IVAL=INT(AVAL+0.1)
22456          IF(IVAL.LT.1)IVAL=1
22457          IF(IVAL.GT.NROW)IVAL=NROW
22458          DO180JJ=1,NROW
22459            JROWT=INT(WSS(JJ)+0.1)
22460            IF(IVAL.EQ.JROWT)THEN
22461              IROWT=JJ
22462              GOTO189
22463            ENDIF
22464  180     CONTINUE
22465          IROWT=NROW
22466  189     CONTINUE
22467          DO190JJ=1,NCOL
22468            YC(II,JJ)=YA(IROWT,JJ)
22469  190     CONTINUE
22470  170   CONTINUE
22471      ENDIF
22472C
22473C               ************************************
22474C               **   STEP 2--                     **
22475C               **   PERFORM THE CLUSTER ANALYSIS **
22476C               ************************************
22477C
22478      ITER=50
22479      CALL KMNS(YA,NROW,NCOL,YC,NCLUST,
22480     1          IC1,IC2,NC,AN1,AN2,NCP,YD,ITRAN,ILIVE,
22481     1          ITER,WSS,IFAULT)
22482C
22483      IF(IFAULT.EQ.1)THEN
22484        WRITE(ICOUT,211)
22485  211   FORMAT('****** ERROR IN K-MEANS CLUSTERING--')
22486        CALL DPWRST('XXX','BUG ')
22487        WRITE(ICOUT,213)
22488  213   FORMAT('       AT LEAST ONE CLUSTER IS EMPTY AFTER THE ',
22489     1         'INITIAL ASSIGNMENT.')
22490        CALL DPWRST('XXX','BUG ')
22491        IERROR='YES'
22492        GOTO9000
22493      ELSEIF(IFAULT.EQ.2)THEN
22494        WRITE(ICOUT,211)
22495        CALL DPWRST('XXX','BUG ')
22496        WRITE(ICOUT,221)ITER
22497  221   FORMAT('       THE MAXIMUM NUMBER IF ITERATIONS (',I3,') WAS ',
22498     1         'EXCEEDED.')
22499        CALL DPWRST('XXX','BUG ')
22500        IERROR='YES'
22501        GOTO9000
22502      ELSEIF(IFAULT.EQ.3)THEN
22503        WRITE(ICOUT,211)
22504        CALL DPWRST('XXX','BUG ')
22505        WRITE(ICOUT,231)NCLUST
22506  231   FORMAT('       THE NUMBER OF CLUSTERS (',I5,') IS LESS THAN ',
22507     1         'TWO')
22508        CALL DPWRST('XXX','BUG ')
22509        WRITE(ICOUT,233)NROW
22510  233   FORMAT('       OR GREATER THAN THE NUMBER OF OBSERVATIONS (',
22511     1         I8,').')
22512        CALL DPWRST('XXX','BUG ')
22513        IERROR='YES'
22514        GOTO9000
22515      ENDIF
22516C
22517C               ******************************
22518C               **   STEP 3--               **
22519C               **   WRITE OUT EVERYTHING   **
22520C               ******************************
22521C
22522      ISTEPN='3'
22523      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
22524     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22525C
22526      IF(IPRINT.EQ.'OFF')GOTO8000
22527C
22528      NUMDIG=7
22529      IF(IFORSW.EQ.'1')NUMDIG=1
22530      IF(IFORSW.EQ.'2')NUMDIG=2
22531      IF(IFORSW.EQ.'3')NUMDIG=3
22532      IF(IFORSW.EQ.'4')NUMDIG=4
22533      IF(IFORSW.EQ.'5')NUMDIG=5
22534      IF(IFORSW.EQ.'6')NUMDIG=6
22535      IF(IFORSW.EQ.'7')NUMDIG=7
22536      IF(IFORSW.EQ.'8')NUMDIG=8
22537      IF(IFORSW.EQ.'9')NUMDIG=9
22538      IF(IFORSW.EQ.'0')NUMDIG=0
22539      IF(IFORSW.EQ.'E')NUMDIG=-2
22540      IF(IFORSW.EQ.'-2')NUMDIG=-2
22541      IF(IFORSW.EQ.'-3')NUMDIG=-3
22542      IF(IFORSW.EQ.'-4')NUMDIG=-4
22543      IF(IFORSW.EQ.'-5')NUMDIG=-5
22544      IF(IFORSW.EQ.'-6')NUMDIG=-6
22545      IF(IFORSW.EQ.'-7')NUMDIG=-7
22546      IF(IFORSW.EQ.'-8')NUMDIG=-8
22547      IF(IFORSW.EQ.'-9')NUMDIG=-9
22548C
22549      ITITLE='Summary of K-Means Cluster Analysis'
22550      NCTITL=35
22551      ITITL9=' '
22552      NCTIT9=0
22553C
22554      NUMCOL=3
22555      NUMLIN=3
22556C
22557      ITITL2(1,1)=' '
22558      NCTIT2(1,1)=0
22559      NCOLSP(1,1)=1
22560      ITITL2(1,2)='Number'
22561      NCTIT2(1,2)=6
22562      NCOLSP(1,2)=1
22563      ITITL2(1,3)='Within'
22564      NCTIT2(1,3)=6
22565      NCOLSP(1,3)=1
22566C
22567      ITITL2(2,1)=' '
22568      NCTIT2(2,1)=0
22569      NCOLSP(2,1)=1
22570      ITITL2(2,2)='of Points'
22571      NCTIT2(2,2)=9
22572      NCOLSP(2,2)=1
22573      ITITL2(2,3)='Cluster'
22574      NCTIT2(2,3)=7
22575      NCOLSP(2,3)=1
22576C
22577      ITITL2(3,1)='Cluster'
22578      NCTIT2(3,1)=7
22579      NCOLSP(3,1)=1
22580      ITITL2(3,2)='in Cluster'
22581      NCTIT2(3,2)=10
22582      NCOLSP(3,2)=1
22583      ITITL2(3,3)='Sum of Squares'
22584      NCTIT2(3,3)=14
22585      NCOLSP(3,3)=1
22586C
22587      IWHTML(1)=150
22588      IWHTML(2)=200
22589      IWHTML(3)=200
22590      IINC1=1200
22591      IINC2=1800
22592      IWRTF(1)=IINC1
22593      IWRTF(2)=IWRTF(1)+IINC2
22594      IWRTF(3)=IWRTF(2)+IINC2
22595C
22596      NMAX=0
22597      ICNT=0
22598      ICNT2=0
22599      DO3010I=1,NUMCOL
22600        VALIGN(I)='b'
22601        ALIGN(I)='r'
22602        NTOT(I)=15
22603        IF(I.EQ.1)NTOT(I)=12
22604        IF(I.EQ.3)NTOT(I)=18
22605        NMAX=NMAX+NTOT(I)
22606        ITYPCO(I)='NUME'
22607 3010 CONTINUE
22608C
22609      DO3020J=1,NCLUST
22610C
22611        ICNT=ICNT+1
22612        IF(ICNT.GT.MAXROW)THEN
22613          ICNT=ICNT-1
22614          IF(ICAPTY.EQ.'LATE')THEN
22615            IFRST=.TRUE.
22616            ILAST=.TRUE.
22617            IFLAGS=.TRUE.
22618            IFLAGE=.TRUE.
22619          ELSE
22620            IFRST=.TRUE.
22621            IFLAGS=.TRUE.
22622            IF(ICNT2.GT.0)THEN
22623              IFRST=.FALSE.
22624              IFLAGS=.FALSE.
22625            ENDIF
22626            IFLAGE=.FALSE.
22627            ILAST=.FALSE.
22628            IF(J.EQ.NCLUST)THEN
22629              ILAST=.TRUE.
22630              IFLAGE=.TRUE.
22631            ENDIF
22632          ENDIF
22633          CALL DPDT5B(ITITLE,NCTITL,
22634     1                ITITL9,NCTIT9,ITITL2,NCTIT2,
22635     1                MAXLIN,NUMLIN,NUMCLI,NUMCOL,
22636     1                IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
22637     1                IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
22638     1                NCOLSP,ROWSEP,
22639     1                ICAPSW,ICAPTY,IFRST,ILAST,
22640     1                IFLAGS,IFLAGE,
22641     1                ISUBRO,IBUGA3,IERROR)
22642          ICNT=1
22643          ICNT2=ICNT2+1
22644        ENDIF
22645C
22646        DO3030I=1,NUMCOL
22647          IDIGI2(ICNT,I)=NUMDIG
22648          IF(I.LE.2)IDIGI2(ICNT,I)=0
22649          IVALUE(ICNT,I)=' '
22650          NCVALU(ICNT,I)=0
22651 3030   CONTINUE
22652        AMAT(ICNT,1)=REAL(J)
22653        AMAT(ICNT,2)=REAL(NC(J))
22654        AMAT(ICNT,3)=WSS(J)
22655        ROWSEP(ICNT)=0
22656 3020 CONTINUE
22657C
22658      IF(ICNT.GT.0)THEN
22659        IFRST=.TRUE.
22660        ILAST=.TRUE.
22661        IF(ICAPTY.EQ.'LATE')THEN
22662          IFLAGS=.TRUE.
22663        ELSE
22664          IFLAGS=.TRUE.
22665          IF(ICNT2.GT.0)IFLAGS=.FALSE.
22666        ENDIF
22667        IFLAGE=.TRUE.
22668        CALL DPDT5B(ITITLE,NCTITL,
22669     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
22670     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
22671     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
22672     1              IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
22673     1              NCOLSP,ROWSEP,
22674     1              ICAPSW,ICAPTY,IFRST,ILAST,
22675     1              IFLAGS,IFLAGE,
22676     1              ISUBRO,IBUGA3,IERROR)
22677      ENDIF
22678C
22679C               ************************************
22680C               **   STEP 4A--                    **
22681C               **   WRITE INFORMATION TO FILES   **
22682C               ************************************
22683C
22684 8000 CONTINUE
22685C
22686      ISTEPN='4A'
22687      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KME2')
22688     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22689C
22690      IOP='OPEN'
22691      IFLG11=1
22692      IFLG21=1
22693      IFLG31=1
22694      IFLAG4=0
22695      IF(IKMESI.EQ.'ON')IFLAG4=1
22696      IFLAG5=0
22697      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
22698     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
22699     1            IBUGA3,ISUBRO,IERROR)
22700      IF(IERROR.EQ.'YES')GOTO9000
22701C
22702      DO8010I=1,NROW
22703        WRITE(IOUNI1,'(E15.7)')REAL(IC1(I))
22704 8010 CONTINUE
22705C
22706      DO8020I=1,NCLUST
22707        WRITE(IOUNI2,'(2E15.7)')WSS(I),REAL(NC(I))
22708 8020 CONTINUE
22709C
22710      IFORMT='(   E15.7)'
22711      WRITE(IFORMT(2:4),'(I3)')NCOL
22712      DO8030I=1,NCLUST
22713        DO8035J=1,MIN(NCOL,200)
22714          YC(I,J)=ALOCSV(J) + SCALSV(J)*YC(I,J)
22715 8035   CONTINUE
22716        WRITE(IOUNI3,IFORMT)(YC(I,J),J=1,NCOL)
22717 8030 CONTINUE
22718C
22719C               *****************************************
22720C               **   STEP 4B--                         **
22721C               **   CREATE VALUES FOR SILHOUETTE PLOT **
22722C               *****************************************
22723C
22724      ISTEPN='4B'
22725      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CWS2')
22726     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22727C
22728C     COMPUTE THE s(i) VALUE AS
22729C
22730C        s(i) = (b(i) - a(i))/max{a(i),b(i)}
22731C
22732C     WHERE
22733C
22734C        a(i)   = AVERAGE DISSIMILARITY OF THE i-TH POINT WITHH
22735C                 ALL OTHER POINTS IN THE CLUSTER TO WHICH IT
22736C                 BELONGS
22737C
22738C        b(i)   = LOWEST AVERAGE DISSIMILARITY OF THE i-TH POINT
22739C                 WITH ALL OTHER CLUSTERS.
22740C
22741C     USE ONE-PASS MEAN ALGORITHMS TO KEEP TRACK OF AVERAGE
22742C     DISSIMILARITY OF ALL CLUSTERS.  THE ONE-PASS FORMUALA IS
22743C
22744C         M(K)=X1                            K = 1
22745C             =M(K-1) + (X(K) - M(K-1))/K    K = 2, ...., N
22746C
22747      IF(IKMESI.EQ.'ON')THEN
22748C
22749        DO8110II=1,NROW
22750          ICLUS1=IC1(II)
22751          DO8112JJ=1,NCOL
22752            AN1(JJ)=YA(II,JJ)
22753 8112     CONTINUE
22754          ICASPL='VEDI'
22755          DO8114KK=1,NCLUST
22756            YD(KK)=CPUMIN
22757            IC2(KK)=0
22758 8114     CONTINUE
22759C
22760          DO8120JJ=1,NROW
22761            IF(II.EQ.JJ)GOTO8120
22762            ICLUS2=IC1(JJ)
22763            DO8122KK=1,NCOL
22764              AN2(KK)=YA(JJ,KK)
22765 8122       CONTINUE
22766            CALL VECARI(AN1,AN2,NCOL,ICASPL,IWRITE,
22767     1                  TEMP1,N3,ADIST,ITYP3,
22768     1                  IBUGA3,ISUBRO,IERROR)
22769            IF(ICLUS1.EQ.ICLUS2)THEN
22770              IC2(ICLUS1)=IC2(ICLUS1)+1
22771              IF(IC2(ICLUS1).EQ.1)THEN
22772                YD(ICLUS1)=ADIST
22773              ELSE
22774                TERM1=(ADIST - YD(ICLUS1))/REAL(IC2(ICLUS1))
22775                YD(ICLUS1)=YD(ICLUS1) + TERM1
22776              ENDIF
22777            ELSE
22778              IC2(ICLUS2)=IC2(ICLUS2)+1
22779              IF(IC2(ICLUS2).EQ.1)THEN
22780                YD(ICLUS2)=ADIST
22781              ELSE
22782                TERM1=(ADIST - YD(ICLUS2))/REAL(IC2(ICLUS2))
22783                YD(ICLUS2)=YD(ICLUS2) + TERM1
22784              ENDIF
22785            ENDIF
22786 8120     CONTINUE
22787C
22788          AI=YD(ICLUS1)
22789          BI=CPUMAX
22790          DO8130JJ=1,NCLUST
22791            IF(JJ.EQ.ICLUS1)GOTO8130
22792            IF(YD(JJ).LT.BI)BI=YD(JJ)
22793 8130     CONTINUE
22794          WSS(II)=(BI - AI)/MAX(AI,BI)
22795C
22796 8110   CONTINUE
22797C
22798        DO8140I=1,NROW
22799          WRITE(IOUNI4,'(2E15.7)')REAL(IC1(I)),WSS(I)
22800 8140   CONTINUE
22801      ENDIF
22802C
22803      IOP='CLOS'
22804      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
22805     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
22806     1            IBUGA3,ISUBRO,IERROR)
22807C
22808      IF(IFEEDB.EQ.'ON')THEN
22809        WRITE(ICOUT,999)
22810        CALL DPWRST('XXX','BUG ')
22811        WRITE(ICOUT,8091)
22812 8091   FORMAT('THE CLUSTER ID VALUES ARE WRITTEN TO dpst1f.dat')
22813        CALL DPWRST('XXX','BUG ')
22814        WRITE(ICOUT,8093)
22815 8093   FORMAT('THE WITHIN-CLUSTER SUM OF SQUARES AND ',
22816     1         'THE NUMBER OF POINTS')
22817        CALL DPWRST('XXX','BUG ')
22818        WRITE(ICOUT,8095)
22819 8095   FORMAT('FOR EACH CLUSTER ARE WRITTEN TO dpst2f.dat')
22820        CALL DPWRST('XXX','BUG ')
22821        WRITE(ICOUT,8097)
22822 8097   FORMAT('THE CLUSTER CENTERS ARE WRITTEN TO dpst3f.dat')
22823        CALL DPWRST('XXX','BUG ')
22824        IF(IKMESI.EQ.'ON')THEN
22825          WRITE(ICOUT,8099)
22826 8099     FORMAT('THE SILHOUETTE VALUES ARE WRITTEN TO dpst4f.dat')
22827          CALL DPWRST('XXX','BUG ')
22828        ENDIF
22829      ENDIF
22830C
22831C               ******************
22832C               **   STEP 90--  **
22833C               **   EXIT       **
22834C               ******************
22835C
22836 9000 CONTINUE
22837      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KME2')THEN
22838        WRITE(ICOUT,999)
22839        CALL DPWRST('XXX','BUG ')
22840        WRITE(ICOUT,9011)
22841 9011   FORMAT('***** AT THE END       OF DPKME2--')
22842        CALL DPWRST('XXX','BUG ')
22843      ENDIF
22844C
22845      RETURN
22846      END
22847      SUBROUTINE DPKNOT(IHARG,IHARG2,NUMARG,IDEFK1,IDEFK2,
22848     1IKNOT1,IKNOT2,IFOUND,IERROR)
22849C
22850C     PURPOSE--DEFINE THE USER VARIABLE NAME IN WHICH
22851C              THE KNOTS FOR SPLINE FITTING RESIDE.
22852C              CHARACTERS 1 TO 4 OF THE SPECIFIED KNOT NAME
22853C              WILL BE PLACED IN THE HOLLERITH VARIABLE IKNOT1;
22854C              CHARACTERS 5 TO 8 OF THE SPECIFIED KNOT NAME
22855C              WILL BE PLACED IN THE HOLLERITH VARIABLE IKNOT2.
22856C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
22857C                     --IHARG2 (A  HOLLERITH VECTOR)
22858C                     --NUMARG (AN INTEGER VARIABLE)
22859C                     --IDEFK1 (A  HOLLERITH VARIABLE)
22860C                     --IDEFK2 (A  HOLLERITH VARIABLE)
22861C     OUTPUT ARGUMENTS--IKNOT1 (A  HOLLERITH VARIABLE)
22862C                     --IKNOT2 (A  HOLLERITH VARIABLE)
22863C                     --IFOUND ('YES' OR 'NO' )
22864C                     --IERROR ('YES' OR 'NO' )
22865C     WRITTEN BY--JAMES J. FILLIBEN
22866C                 STATISTICAL ENGINEERING DIVISION
22867C                 INFORMATION TECHNOLOGY LABORATORY
22868C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22869C                 GAITHERSBURG, MD 20899-8980
22870C                 PHONE--301-975-2855
22871C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22872C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22873C     LANGUAGE--ANSI FORTRAN (1977)
22874C     VERSION NUMBER--82/7
22875C     ORIGINAL VERSION--NOVEMBER 1980.
22876C     UPDATED         --MAY       1982.
22877C
22878C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22879C
22880      CHARACTER*4 IHARG
22881      CHARACTER*4 IHARG2
22882      CHARACTER*4 IDEFK1
22883      CHARACTER*4 IDEFK2
22884      CHARACTER*4 IKNOT1
22885      CHARACTER*4 IKNOT2
22886      CHARACTER*4 IFOUND
22887      CHARACTER*4 IERROR
22888C
22889      CHARACTER*4 IHOLD1
22890      CHARACTER*4 IHOLD2
22891C
22892C---------------------------------------------------------------------
22893C
22894      DIMENSION IHARG(*)
22895      DIMENSION IHARG2(*)
22896C
22897C---------------------------------------------------------------------
22898C
22899      INCLUDE 'DPCOP2.INC'
22900C
22901C-----START POINT-----------------------------------------------------
22902C
22903      IFOUND='NO'
22904      IERROR='NO'
22905C
22906      GOTO1110
22907C
22908 1110 CONTINUE
22909      IF(NUMARG.LE.0)GOTO1150
22910      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
22911      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
22912      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
22913      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
22914      GOTO1160
22915C
22916 1150 CONTINUE
22917      IHOLD1=IDEFK1
22918      IHOLD2=IDEFK2
22919      GOTO1180
22920C
22921 1160 CONTINUE
22922      IHOLD1=IHARG(NUMARG)
22923      IHOLD2=IHARG2(NUMARG)
22924      GOTO1180
22925C
22926 1180 CONTINUE
22927      IFOUND='YES'
22928      IKNOT1=IHOLD1
22929      IKNOT2=IHOLD2
22930C
22931      IF(IFEEDB.EQ.'OFF')GOTO1189
22932      WRITE(ICOUT,999)
22933  999 FORMAT(1X)
22934      CALL DPWRST('XXX','BUG ')
22935      WRITE(ICOUT,1181)IKNOT1,IKNOT2
22936 1181 FORMAT('THE KNOTS VARIABLE HAS JUST BEEN DESIGNATED AS ',
22937     1A4,A4)
22938      CALL DPWRST('XXX','BUG ')
22939      IF(IKNOT1.EQ.'    '.AND.IKNOT2.EQ.'    ')WRITE(ICOUT,1182)
22940 1182 FORMAT('(THAT IS, THE NO-KNOTS CASE IS BEING ASSUMED)')
22941      IF(IKNOT1.EQ.'    '.AND.IKNOT2.EQ.'    ')CALL DPWRST('XXX','BUG ')
22942 1189 CONTINUE
22943      GOTO1199
22944C
22945 1199 CONTINUE
22946      RETURN
22947      END
22948      SUBROUTINE DPKLOT(MAXNXT,ICAPSW,IFORSW,
22949     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
22950C
22951C     PURPOSE--CARRY OUT A 2-SAMPLE KLOTZ TEST FOR EQUAL VARIANCES
22952C     EXAMPLE--KLOTZ TEST Y1 Y2
22953C              KLOTZ TEST Y1 Y2 Y3 Y4
22954C              KLOTZ TEST Y1 TO Y10
22955C     WRITTEN BY--ALAN HECKERT
22956C                 STATISTICAL ENGINEERING DIVISION
22957C                 INFORMATION TECHNOLOGY LABORATORY
22958C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22959C                 GAITHERSBURG, MD 20899-8980
22960C                 PHONE--301-975-2899
22961C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22962C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22963C     LANGUAGE--ANSI FORTRAN (1977)
22964C     VERSION NUMBER--2011/5
22965C     ORIGINAL VERSION--MAY       2011.
22966C
22967C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22968C
22969      CHARACTER*4 ICAPSW
22970      CHARACTER*4 IFORSW
22971      CHARACTER*4 IBUGA2
22972      CHARACTER*4 IBUGA3
22973      CHARACTER*4 IBUGQ
22974      CHARACTER*4 ISUBRO
22975      CHARACTER*4 IFOUND
22976      CHARACTER*4 IERROR
22977C
22978      CHARACTER*4 ICASAN
22979      CHARACTER*4 ICASA2
22980      CHARACTER*4 ICTMP1
22981      CHARACTER*4 ICTMP2
22982      CHARACTER*4 ISUBN1
22983      CHARACTER*4 ISUBN2
22984      CHARACTER*4 ISTEPN
22985C
22986      CHARACTER*4 ICASE
22987      CHARACTER*4 IVARID
22988      CHARACTER*4 IVARI2
22989      CHARACTER*4 IVARI3
22990      CHARACTER*4 IVARI4
22991      CHARACTER*40 INAME
22992      PARAMETER (MAXSPN=30)
22993      CHARACTER*4 IVARN1(MAXSPN)
22994      CHARACTER*4 IVARN2(MAXSPN)
22995      CHARACTER*4 IVARTY(MAXSPN)
22996      REAL PVAR(MAXSPN)
22997      INTEGER ILIS(MAXSPN)
22998      INTEGER NRIGHT(MAXSPN)
22999      INTEGER ICOLR(MAXSPN)
23000C
23001      CHARACTER*4 IFLAGU
23002      LOGICAL IFRST
23003      LOGICAL ILAST
23004C
23005C---------------------------------------------------------------------
23006C
23007C-----COMMON----------------------------------------------------------
23008C
23009      INCLUDE 'DPCOPA.INC'
23010      INCLUDE 'DPCOZZ.INC'
23011      INCLUDE 'DPCOHK.INC'
23012      INCLUDE 'DPCOSU.INC'
23013      INCLUDE 'DPCODA.INC'
23014      INCLUDE 'DPCOHO.INC'
23015      INCLUDE 'DPCOST.INC'
23016C
23017      DIMENSION YRANK(2*MAXOBV)
23018      DIMENSION YTEMP(2*MAXOBV)
23019      DIMENSION XTEMP3(2*MAXOBV)
23020      EQUIVALENCE(GARBAG(IGARB1),YRANK(1))
23021      EQUIVALENCE(GARBAG(IGARB3),YTEMP(1))
23022      EQUIVALENCE(GARBAG(IGARB5),XTEMP3(1))
23023C
23024C-----COMMON VARIABLES (GENERAL)--------------------------------------
23025C
23026      INCLUDE 'DPCOP2.INC'
23027C
23028C-----START POINT-----------------------------------------------------
23029C
23030      ISUBN1='DPKL'
23031      ISUBN2='OT  '
23032C
23033      MAXCP1=MAXCOL+1
23034      MAXCP2=MAXCOL+2
23035      MAXCP3=MAXCOL+3
23036      MAXCP4=MAXCOL+4
23037      MAXCP5=MAXCOL+5
23038      MAXCP6=MAXCOL+6
23039C
23040      IFOUND='NO'
23041      IERROR='NO'
23042C
23043C               ************************************************
23044C               **  TREAT THE KLOTZ TEST CASE                 **
23045C               ************************************************
23046C
23047      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'KLOT')THEN
23048        WRITE(ICOUT,999)
23049  999   FORMAT(1X)
23050        CALL DPWRST('XXX','BUG ')
23051        WRITE(ICOUT,51)
23052   51   FORMAT('***** AT THE BEGINNING OF DPKLOT--')
23053        CALL DPWRST('XXX','BUG ')
23054        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
23055   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',4(A4,2X),I8)
23056        CALL DPWRST('XXX','BUG ')
23057      ENDIF
23058C
23059C               *********************************************************
23060C               **  STEP 1--                                           **
23061C               **  EXTRACT THE COMMAND                                **
23062C               *********************************************************
23063C
23064      ISTEPN='1'
23065      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KLOT')
23066     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23067C
23068      ILASTZ=9999
23069      ICASAN='KLOT'
23070      ICASA2='TWOT'
23071C
23072C     LOOK FOR:
23073C
23074C          KLOTZ TEST
23075C          LOWER TAILED
23076C          UPPER TAILED
23077C
23078      DO100I=0,NUMARG-1
23079C
23080        IF(I.EQ.0)THEN
23081          ICTMP1=ICOM
23082        ELSE
23083          ICTMP1=IHARG(I)
23084        ENDIF
23085        ICTMP2=IHARG(I+1)
23086C
23087        IF(ICTMP1.EQ.'=')THEN
23088          IFOUND='NO'
23089          GOTO9000
23090        ELSEIF(ICTMP1.EQ.'KLOT' .AND. ICTMP2.EQ.'TEST')THEN
23091          IFOUND='YES'
23092          ICASAN='KLOT'
23093          ILASTZ=I+1
23094        ELSEIF(ICTMP1.EQ.'LOWE' .AND. ICTMP2.EQ.'TAIL')THEN
23095          ICASA2='LOWE'
23096          ILASTZ=MAX(ILASTZ,I+1)
23097        ELSEIF(ICTMP1.EQ.'UPPE' .AND. ICTMP2.EQ.'TAIL')THEN
23098          ICASA2='UPPE'
23099          ILASTZ=MAX(ILASTZ,I+1)
23100        ENDIF
23101  100 CONTINUE
23102C
23103      IF(IFOUND.EQ.'NO')GOTO9000
23104C
23105      ISHIFT=ILASTZ
23106      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
23107     1            IBUGA2,IERROR)
23108C
23109      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KLOT')THEN
23110        WRITE(ICOUT,91)ICASAN,ICASA2,ISHIFT
23111   91   FORMAT('DPKLOT: ICASAN,ICASA2,ISHIFT = ',
23112     1         2(A4,2X),I5)
23113        CALL DPWRST('XXX','BUG ')
23114      ENDIF
23115C
23116C               ****************************************
23117C               **  STEP 2--                          **
23118C               **  EXTRACT THE VARIABLE LIST         **
23119C               ****************************************
23120C
23121      ISTEPN='2'
23122      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KLOT')
23123     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23124C
23125      INAME='KLOTZ TEST'
23126      MINNA=1
23127      MAXNA=100
23128      MINN2=2
23129      IFLAGE=0
23130      IFLAGM=1
23131      MINNVA=2
23132      MAXNVA=MAXSPN
23133      IFLAGP=0
23134      JMIN=1
23135      JMAX=NUMARG
23136C
23137      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
23138     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
23139     1            JMIN,JMAX,
23140     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
23141     1            IVARN1,IVARN2,IVARTY,PVAR,
23142     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
23143     1            MINNVA,MAXNVA,
23144     1            IFLAGM,IFLAGP,
23145     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
23146      IF(IERROR.EQ.'YES')GOTO9000
23147C
23148      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KLOT')THEN
23149        WRITE(ICOUT,999)
23150        CALL DPWRST('XXX','BUG ')
23151        WRITE(ICOUT,281)
23152  281   FORMAT('***** AFTER CALL DPPARS--')
23153        CALL DPWRST('XXX','BUG ')
23154        WRITE(ICOUT,282)NQ,NUMVAR
23155  282   FORMAT('NQ,NUMVAR = ',2I8)
23156        CALL DPWRST('XXX','BUG ')
23157        IF(NUMVAR.GT.0)THEN
23158          DO285I=1,NUMVAR
23159            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
23160     1                      ICOLR(I)
23161  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
23162     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
23163            CALL DPWRST('XXX','BUG ')
23164  285     CONTINUE
23165        ENDIF
23166      ENDIF
23167C
23168C               ******************************************************
23169C               **  STEP 3A--                                       **
23170C               **  CASE 1: TWO RESPONSE VARIABLES, NO REPLICATION  **
23171C               **          HANDLE MULTIPLE RESPONSE VARIABLES      **
23172C               **          DIFFERENTLY FOR ONE SAMPLE AND TWO      **
23173C               **          SAMPLE TESTS.                           **
23174C               ******************************************************
23175C
23176      ISTEPN='3A'
23177      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KLOT')
23178     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23179C
23180      NUMVA2=1
23181      DO5210I=1,NUMVAR
23182        ICOL=I
23183        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
23184     1              INAME,IVARN1,IVARN2,IVARTY,
23185     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
23186     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
23187     1              MAXCP4,MAXCP5,MAXCP6,
23188     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
23189     1              Y,Y,Y,NS1,NLOCA2,NLOCA3,ICASE,
23190     1              IBUGA3,ISUBRO,IFOUND,IERROR)
23191        IF(IERROR.EQ.'YES')GOTO9000
23192C
23193        ISTRT2=I+1
23194        ISTOP2=NUMVAR
23195C
23196        DO5220J=ISTRT2,ISTOP2
23197C
23198          ICOL=J
23199          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
23200     1                INAME,IVARN1,IVARN2,IVARTY,
23201     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
23202     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
23203     1                MAXCP4,MAXCP5,MAXCP6,
23204     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
23205     1                X,X,X,NS2,NLOCA2,NLOCA3,ICASE,
23206     1                IBUGA3,ISUBRO,IFOUND,IERROR)
23207          IF(IERROR.EQ.'YES')GOTO9000
23208C
23209C               *******************************************
23210C               **  STEP 52--                            **
23211C               **  PERFORM A KLOTZ RANK SUM TEST        **
23212C               *******************************************
23213C
23214          ISTEPN='52'
23215          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'KLOT')THEN
23216            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23217            WRITE(ICOUT,999)
23218            CALL DPWRST('XXX','BUG ')
23219            WRITE(ICOUT,5211)
23220 5211       FORMAT('***** FROM DPKLOT, BEFORE CALL DPKLO2--')
23221            CALL DPWRST('XXX','BUG ')
23222            WRITE(ICOUT,5212)I,J,NS1,NS2,MAXN
23223 5212       FORMAT('I,J,NS1,NS2,MAXN = ',5I8)
23224            CALL DPWRST('XXX','BUG ')
23225            DO5215II=1,MAX(NS1,NS2)
23226              WRITE(ICOUT,5216)II,Y(II),X(II)
23227 5216         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
23228              CALL DPWRST('XXX','BUG ')
23229 5215       CONTINUE
23230          ENDIF
23231C
23232          IVARID=IVARN1(I)
23233          IVARI2=IVARN2(I)
23234          IVARI3=IVARN1(J)
23235          IVARI4=IVARN2(J)
23236          CALL DPKLO2(Y,NS1,X,NS2,ICASA2,
23237     1               YRANK,YTEMP,XTEMP3,MAXNXT,
23238     1               ICAPSW,ICAPTY,IFORSW,
23239     1               IVARID,IVARI2,IVARI3,IVARI4,
23240     1               STATVA,STATCD,PVAL2T,PVALLT,PVALUT,
23241     1               CTL001,CTL005,CTL010,CTL025,CTL050,CTL100,
23242     1               CTU999,CTU995,CTU990,CT975,CTU950,CTU900,
23243     1               IBUGA3,ISUBRO,IERROR)
23244          IF(IERROR.EQ.'YES')GOTO9000
23245C
23246C               ***************************************
23247C               **  STEP 8C--                        **
23248C               **  UPDATE INTERNAL DATAPLOT TABLES  **
23249C               ***************************************
23250C
23251          ISTEPN='8C'
23252          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KLOT')
23253     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23254C
23255          IF(NUMVAR.GT.2)THEN
23256            IFLAGU='FILE'
23257          ELSE
23258            IFLAGU='ON'
23259          ENDIF
23260          IFRST=.FALSE.
23261          ILAST=.FALSE.
23262          IF(I.EQ.1 .AND. J.EQ.2)IFRST=.TRUE.
23263          IF(I.EQ.NUMVAR .AND. J.EQ.NUMVAR)ILAST=.TRUE.
23264          CALL DPMNN5(ICASA2,
23265     1                STATVA,STATCD,
23266     1                PVAL2T,PVALLT,PVALUT,
23267     1                CTL001,CTL005,CTL010,CTL025,CTL050,CTL100,
23268     1                CTU999,CTU995,CTU990,CT975,CTU950,CTU900,
23269     1                IFLAGU,IFRST,ILAST,
23270     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
23271C
23272 5220   CONTINUE
23273 5210 CONTINUE
23274C
23275C               *****************
23276C               **  STEP 90--  **
23277C               **  EXIT       **
23278C               *****************
23279C
23280 9000 CONTINUE
23281      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'KLOT')THEN
23282        WRITE(ICOUT,999)
23283        CALL DPWRST('XXX','BUG ')
23284        WRITE(ICOUT,9011)
23285 9011   FORMAT('***** AT THE END       OF DPKLOT--')
23286        CALL DPWRST('XXX','BUG ')
23287        WRITE(ICOUT,9016)IFOUND,IERROR
23288 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
23289        CALL DPWRST('XXX','BUG ')
23290      ENDIF
23291C
23292      RETURN
23293      END
23294      SUBROUTINE DPKLO2(Y1,N1,Y2,N2,ICASAN,
23295     1                  TEMP1,TEMP2,TEMP3,MAXNXT,
23296     1                  ICAPSW,ICAPTY,IFORSW,
23297     1                  IVARID,IVARI2,IVARI3,IVARI4,
23298     1                  STATVA,STATCD,PVAL2T,PVALLT,PVALUT,
23299     1                  CTL001,CTL005,CTL010,CTL025,CTL050,CTL100,
23300     1                  CTU999,CTU995,CTU990,CTU975,CTU950,CTU900,
23301     1                  IBUGA3,ISUBRO,IERROR)
23302C
23303C     PURPOSE--THIS ROUTINE CARRIES OUT A 2-SAMPLE KLOTZ TEST FOR
23304C              EQUAL VARIANCES
23305C     EXAMPLE--KLOTZ TEST Y1 Y2
23306C     SAMPLE 1 IS IN INPUT VECTOR Y1
23307C              (WITH N1 OBSERVATIONS).
23308C     SAMPLE 2 IS IN INPUT VECTOR Y2
23309C              (WITH N1 OBSERVATIONS).
23310C     WRITTEN BY--ALAN HECKERT
23311C                 STATISTICAL ENGINEERING DIVISION
23312C                 INFORMATION TECHNOLOGY LABORATORY
23313C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23314C                 GAITHERSBURG, MD 20899-8980
23315C                 PHONE--301-975-2899
23316C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23317C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23318C     LANGUAGE--ANSI FORTRAN (1977)
23319C     VERSION NUMBER--2011/5
23320C     ORIGINAL VERSION--MAY       2011.
23321C
23322C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23323C
23324      CHARACTER*4 IVARID
23325      CHARACTER*4 IVARI2
23326      CHARACTER*4 IVARI3
23327      CHARACTER*4 IVARI4
23328      CHARACTER*4 ICAPSW
23329      CHARACTER*4 ICAPTY
23330      CHARACTER*4 IFORSW
23331      CHARACTER*4 ICASAN
23332      CHARACTER*4 IBUGA3
23333      CHARACTER*4 ISUBRO
23334      CHARACTER*4 IERROR
23335C
23336      CHARACTER*4 IWRITE
23337C
23338      CHARACTER*4 ISUBN1
23339      CHARACTER*4 ISUBN2
23340      CHARACTER*4 ISTEPN
23341C
23342C---------------------------------------------------------------------
23343C
23344      DIMENSION Y1(*)
23345      DIMENSION Y2(*)
23346      DIMENSION TEMP1(*)
23347      DIMENSION TEMP2(*)
23348      DIMENSION TEMP3(*)
23349C
23350      PARAMETER (NUMALP=6)
23351      REAL ALPHA(NUMALP)
23352      PARAMETER (NUMAL2=4)
23353      REAL ALPHA2(NUMAL2)
23354C
23355      PARAMETER(NUMCLI=5)
23356      PARAMETER(MAXLIN=3)
23357      PARAMETER (MAXROW=25)
23358      CHARACTER*60 ITITLE
23359      CHARACTER*60 ITITLZ
23360      CHARACTER*60 ITITL9
23361      CHARACTER*60 ITEXT(MAXROW)
23362      CHARACTER*4  ALIGN(NUMCLI)
23363      CHARACTER*4  VALIGN(NUMCLI)
23364      REAL         AVALUE(MAXROW)
23365      INTEGER      NCTEXT(MAXROW)
23366      INTEGER      IDIGIT(MAXROW)
23367      INTEGER      NTOT(MAXROW)
23368      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
23369      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
23370      CHARACTER*4  ITYPCO(NUMCLI)
23371      INTEGER      NCTIT2(MAXLIN,NUMCLI)
23372      INTEGER      NCVALU(MAXROW,NUMCLI)
23373      INTEGER      IWHTML(NUMCLI)
23374      INTEGER      IWRTF(NUMCLI)
23375      REAL         AMAT(MAXROW,NUMCLI)
23376      LOGICAL IFRST
23377      LOGICAL ILAST
23378      LOGICAL IFLAGS
23379      LOGICAL IFLAGE
23380C
23381C---------------------------------------------------------------------
23382C
23383      INCLUDE 'DPCOP2.INC'
23384C
23385      DATA ALPHA/0.90, 0.95, 0.975, 0.99, 0.995, 0.999/
23386      DATA ALPHA2/0.80, 0.90, 0.95, 0.99/
23387C
23388C-----START POINT-----------------------------------------------------
23389C
23390      ISUBN1='DPKL'
23391      ISUBN2='O2  '
23392C
23393      IERROR='NO'
23394      IWRITE='OFF'
23395C
23396      NUMDIG=7
23397      IF(IFORSW.EQ.'1')NUMDIG=1
23398      IF(IFORSW.EQ.'2')NUMDIG=2
23399      IF(IFORSW.EQ.'3')NUMDIG=3
23400      IF(IFORSW.EQ.'4')NUMDIG=4
23401      IF(IFORSW.EQ.'5')NUMDIG=5
23402      IF(IFORSW.EQ.'6')NUMDIG=6
23403      IF(IFORSW.EQ.'7')NUMDIG=7
23404      IF(IFORSW.EQ.'8')NUMDIG=8
23405      IF(IFORSW.EQ.'9')NUMDIG=9
23406      IF(IFORSW.EQ.'0')NUMDIG=0
23407      IF(IFORSW.EQ.'E')NUMDIG=-2
23408      IF(IFORSW.EQ.'-2')NUMDIG=-2
23409      IF(IFORSW.EQ.'-3')NUMDIG=-3
23410      IF(IFORSW.EQ.'-4')NUMDIG=-4
23411      IF(IFORSW.EQ.'-5')NUMDIG=-5
23412      IF(IFORSW.EQ.'-6')NUMDIG=-6
23413      IF(IFORSW.EQ.'-7')NUMDIG=-7
23414      IF(IFORSW.EQ.'-8')NUMDIG=-8
23415      IF(IFORSW.EQ.'-9')NUMDIG=-9
23416C
23417      CTL001=CPUMIN
23418      CTL005=CPUMIN
23419      CTL010=CPUMIN
23420      CTL025=CPUMIN
23421      CTL050=CPUMIN
23422      CTL100=CPUMIN
23423      CTU900=CPUMIN
23424      CTU950=CPUMIN
23425      CTU975=CPUMIN
23426      CTU990=CPUMIN
23427      CTU995=CPUMIN
23428      CTU999=CPUMIN
23429C
23430      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KLO2')THEN
23431        WRITE(ICOUT,999)
23432  999   FORMAT(1X)
23433        CALL DPWRST('XXX','WRIT')
23434        WRITE(ICOUT,51)
23435   51   FORMAT('**** AT THE BEGINNING OF DPKLO2--')
23436        CALL DPWRST('XXX','WRIT')
23437        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN
23438   52   FORMAT('IBUGA3,ISUBRO,ICASAN = ',2(A4,2X),A4)
23439        CALL DPWRST('XXX','WRIT')
23440        WRITE(ICOUT,53)IVARID,IVARI2,IVARI3,IVARI4
23441   53   FORMAT('IVARID,IVARI2,IVARI3,IVARI4 = ',3(A4,2X),A4)
23442        CALL DPWRST('XXX','WRIT')
23443        WRITE(ICOUT,55)N1,N2,NUMDIG
23444   55   FORMAT('N1,N2,NUMDIG = ',3I8)
23445        CALL DPWRST('XXX','WRIT')
23446        DO56I=1,MAX(N1,N2)
23447          WRITE(ICOUT,57)I,Y1(I),Y2(I)
23448   57     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
23449          CALL DPWRST('XXX','WRIT')
23450   56   CONTINUE
23451      ENDIF
23452C
23453C               ************************************
23454C               **   STEP 1--                     **
23455C               **   CALL DPKLO3 TO COMPUTE THE   **
23456C               **   BASIC TEST STATISTIC.        **
23457C               ************************************
23458C
23459      ISTEPN='1'
23460      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO2')
23461     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23462C
23463      CALL DPKLO3(Y1,N1,Y2,N2,
23464     1            TEMP1,TEMP2,TEMP3,MAXNXT,
23465     1            STATVA,STATCD,PVAL2T,PVALLT,PVALUT,
23466     1            IBUGA3,ISUBRO,IERROR)
23467      CALL MEAN(Y1,N1,IWRITE,YMEAN1,IBUGA3,IERROR)
23468      CALL VAR(Y1,N1,IWRITE,YVAR1,IBUGA3,IERROR)
23469      CALL MEAN(Y2,N2,IWRITE,YMEAN2,IBUGA3,IERROR)
23470      CALL VAR(Y2,N2,IWRITE,YVAR2,IBUGA3,IERROR)
23471C
23472C               ***************************************
23473C               **  STEP 21--                        **
23474C               **  COMPUTE THE CRITICAL VALUES FOR  **
23475C               **  VARIOUS VALUES OF ALPHA          **
23476C               ***************************************
23477C
23478      ISTEPN='21'
23479      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO2')
23480     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23481C
23482C     LARGE SAMPLE NORMAL APPROXIMATION VALUES FIRST
23483C
23484      CALL NORPPF(.005,CTL005)
23485      CALL NORPPF(.010,CTL010)
23486      CALL NORPPF(.025,CTL025)
23487      CALL NORPPF(.050,CTL050)
23488      CALL NORPPF(.100,CTL100)
23489      CALL NORPPF(.200,CTL200)
23490      CALL NORPPF(.500,CTL500)
23491      CALL NORPPF(.500,CTU500)
23492      CALL NORPPF(.800,CTU800)
23493      CALL NORPPF(.900,CTU900)
23494      CALL NORPPF(.950,CTU950)
23495      CALL NORPPF(.975,CTU975)
23496      CALL NORPPF(.990,CTU990)
23497      CALL NORPPF(.995,CTU995)
23498C
23499C               *************************************************
23500C               **   STEP 22--                                 **
23501C               **   WRITE OUT EVERYTHING                      **
23502C               **   FOR A KLOTZ  TEST                         **
23503C               *************************************************
23504C
23505      ISTEPN='22'
23506      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO2')
23507     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23508C
23509      IF(IPRINT.EQ.'OFF')GOTO9000
23510C
23511      IF(ICASAN.EQ.'LOWE')THEN
23512        ITITLE='Two Sample Lower-Tailed Klotz Test'
23513        NCTITL=34
23514      ELSEIF(ICASAN.EQ.'UPPE')THEN
23515        ITITLE='Two Sample Upper-Tailed Klotz Test'
23516        NCTITL=34
23517      ELSE
23518        ITITLE='Two Sample Two-Sided Klotz Test'
23519        NCTITL=31
23520      ENDIF
23521      ITITLZ=' '
23522      NCTITZ=0
23523C
23524      ICNT=1
23525      ITEXT(ICNT)=' '
23526      NCTEXT(ICNT)=0
23527      AVALUE(ICNT)=0.0
23528      IDIGIT(ICNT)=-1
23529C
23530      ICNT=ICNT+1
23531      ITEXT(ICNT)='First Response Variable: '
23532      WRITE(ITEXT(ICNT)(26:29),'(A4)')IVARID(1:4)
23533      WRITE(ITEXT(ICNT)(30:33),'(A4)')IVARI2(1:4)
23534      NCTEXT(ICNT)=33
23535      AVALUE(ICNT)=0.0
23536      IDIGIT(ICNT)=-1
23537      ICNT=ICNT+1
23538      ITEXT(ICNT)='Second Response Variable: '
23539      WRITE(ITEXT(ICNT)(27:30),'(A4)')IVARI3(1:4)
23540      WRITE(ITEXT(ICNT)(31:34),'(A4)')IVARI4(1:4)
23541      NCTEXT(ICNT)=34
23542      AVALUE(ICNT)=0.0
23543      IDIGIT(ICNT)=-1
23544C
23545      ICNT=ICNT+1
23546      ITEXT(ICNT)=' '
23547      NCTEXT(ICNT)=1
23548      AVALUE(ICNT)=0.0
23549      IDIGIT(ICNT)=-1
23550C
23551      ICNT=ICNT+1
23552      ITEXT(ICNT)='H0: Var(Y1) = Var(Y2)'
23553      NCTEXT(ICNT)=21
23554      AVALUE(ICNT)=0.0
23555      IDIGIT(ICNT)=-1
23556      ICNT=ICNT+1
23557      ITEXT(ICNT)='Ha: Var(Y1) <> Var(Y2)'
23558      NCTEXT(ICNT)=22
23559      AVALUE(ICNT)=0.0
23560      IDIGIT(ICNT)=-1
23561C
23562      ICNT=ICNT+1
23563      ITEXT(ICNT)=' '
23564      NCTEXT(ICNT)=1
23565      AVALUE(ICNT)=0.0
23566      IDIGIT(ICNT)=-1
23567      ICNT=ICNT+1
23568      ITEXT(ICNT)='Summary Statistics:'
23569      NCTEXT(ICNT)=19
23570      AVALUE(ICNT)=0.0
23571      IDIGIT(ICNT)=-1
23572      ICNT=ICNT+1
23573      ITEXT(ICNT)='Number of Observations for Sample 1:'
23574      NCTEXT(ICNT)=36
23575      AVALUE(ICNT)=REAL(N1)
23576      IDIGIT(ICNT)=0
23577      ICNT=ICNT+1
23578      ITEXT(ICNT)='Mean for Sample 1:'
23579      NCTEXT(ICNT)=18
23580      AVALUE(ICNT)=YMEAN1
23581      IDIGIT(ICNT)=NUMDIG
23582      ICNT=ICNT+1
23583      ITEXT(ICNT)='Variance for Sample 1:'
23584      NCTEXT(ICNT)=20
23585      AVALUE(ICNT)=YVAR1
23586      IDIGIT(ICNT)=NUMDIG
23587      ICNT=ICNT+1
23588      ITEXT(ICNT)='Number of Observations for Sample 2:'
23589      NCTEXT(ICNT)=36
23590      AVALUE(ICNT)=REAL(N2)
23591      IDIGIT(ICNT)=0
23592      ICNT=ICNT+1
23593      ITEXT(ICNT)='Mean for Sample 2:'
23594      NCTEXT(ICNT)=18
23595      AVALUE(ICNT)=YMEAN2
23596      IDIGIT(ICNT)=NUMDIG
23597      ICNT=ICNT+1
23598      ITEXT(ICNT)='Variance for Sample 2:'
23599      NCTEXT(ICNT)=20
23600      AVALUE(ICNT)=YVAR2
23601      IDIGIT(ICNT)=NUMDIG
23602      ICNT=ICNT+1
23603      ITEXT(ICNT)=' '
23604      NCTEXT(ICNT)=1
23605      AVALUE(ICNT)=0.0
23606      IDIGIT(ICNT)=-1
23607C
23608      ICNT=ICNT+1
23609      ITEXT(ICNT)='Test (Normal Approximation):'
23610      NCTEXT(ICNT)=30
23611      AVALUE(ICNT)=0.0
23612      IDIGIT(ICNT)=-1
23613C
23614      ICNT=ICNT+1
23615      ITEXT(ICNT)='Test Statistic Value:'
23616      NCTEXT(ICNT)=21
23617      AVALUE(ICNT)=STATVA
23618      IDIGIT(ICNT)=NUMDIG
23619      ICNT=ICNT+1
23620      ITEXT(ICNT)='CDF Value:'
23621      NCTEXT(ICNT)=10
23622      AVALUE(ICNT)=STATCD
23623      IDIGIT(ICNT)=NUMDIG
23624      ICNT=ICNT+1
23625      ITEXT(ICNT)='P-Value (2-tailed test):'
23626      NCTEXT(ICNT)=24
23627      AVALUE(ICNT)=PVAL2T
23628      IDIGIT(ICNT)=NUMDIG
23629      ICNT=ICNT+1
23630      ITEXT(ICNT)='P-Value (lower-tailed test):'
23631      NCTEXT(ICNT)=28
23632      AVALUE(ICNT)=PVALLT
23633      IDIGIT(ICNT)=NUMDIG
23634      ICNT=ICNT+1
23635      ITEXT(ICNT)='P-Value (upper-tailed test):'
23636      NCTEXT(ICNT)=28
23637      AVALUE(ICNT)=PVALUT
23638      IDIGIT(ICNT)=NUMDIG
23639C
23640      NUMROW=ICNT
23641      DO2110I=1,NUMROW
23642        NTOT(I)=15
23643 2110 CONTINUE
23644C
23645      IFRST=.TRUE.
23646      ILAST=.TRUE.
23647C
23648      ISTEPN='21A'
23649      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO2')
23650     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23651C
23652      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
23653     1            AVALUE,IDIGIT,
23654     1            NTOT,NUMROW,
23655     1            ICAPSW,ICAPTY,ILAST,IFRST,
23656     1            ISUBRO,IBUGA3,IERROR)
23657C
23658      ISTEPN='21B'
23659      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO2')
23660     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23661C
23662      ITITLE='Two-Tailed Test: Normal Approximation'
23663      NCTITL=37
23664      ITITL9='H0: Var(Y1) = Var(Y2); Ha: Var(Y1) <> Var(Y2)'
23665      NCTIT9=45
23666C
23667      DO2130J=1,NUMCLI
23668        DO2140I=1,MAXLIN
23669          ITITL2(I,J)=' '
23670          NCTIT2(I,J)=0
23671 2140   CONTINUE
23672 2130 CONTINUE
23673C
23674      NUMCOL=4
23675      ITITL2(2,1)='Significance'
23676      NCTIT2(2,1)=12
23677      ITITL2(3,1)='Level'
23678      NCTIT2(3,1)=5
23679C
23680      ITITL2(2,2)='Test '
23681      NCTIT2(2,2)=4
23682      ITITL2(3,2)='Statistic'
23683      NCTIT2(3,2)=9
23684C
23685      ITITL2(2,3)='Critical'
23686      NCTIT2(2,3)=8
23687      ITITL2(3,3)='Value (+/-)'
23688      NCTIT2(3,3)=11
23689C
23690      ITITL2(1,4)='Null'
23691      NCTIT2(1,4)=4
23692      ITITL2(2,4)='Hypothesis'
23693      NCTIT2(2,4)=10
23694      ITITL2(3,4)='Conclusion'
23695      NCTIT2(3,4)=10
23696C
23697      NMAX=0
23698      DO2150I=1,NUMCOL
23699        VALIGN(I)='b'
23700        ALIGN(I)='r'
23701        NTOT(I)=15
23702        NMAX=NMAX+NTOT(I)
23703        ITYPCO(I)='NUME'
23704        IDIGIT(I)=NUMDIG
23705        IF(I.EQ.1 .OR. I.EQ.4)THEN
23706          ITYPCO(I)='ALPH'
23707        ENDIF
23708 2150 CONTINUE
23709C
23710      IWHTML(1)=125
23711      IWHTML(2)=175
23712      IWHTML(3)=175
23713      IWHTML(4)=175
23714      IINC=1800
23715      IINC2=1400
23716      IWRTF(1)=IINC
23717      IWRTF(2)=IWRTF(1)+IINC
23718      IWRTF(3)=IWRTF(2)+IINC
23719      IWRTF(4)=IWRTF(3)+IINC
23720C
23721      ICNT=NUMAL2
23722      DO2160J=1,NUMAL2
23723C
23724        AMAT(J,2)=STATVA
23725        ALPHAT=ALPHA2(J)
23726        ATEMP=(1.0 - ALPHAT)/2.0
23727        ATEMP=1.0 - ATEMP
23728        CALL NORPPF(ATEMP,CUTTMP)
23729        AMAT(J,3)=CUTTMP
23730        IVALUE(J,4)(1:6)='REJECT'
23731        IF(ABS(STATVA).LT.AMAT(J,3))THEN
23732          IVALUE(J,4)(1:6)='ACCEPT'
23733        ENDIF
23734        NCVALU(J,4)=6
23735C
23736        WRITE(IVALUE(J,1)(1:4),'(F4.1)')100.0*ALPHAT
23737        IVALUE(J,1)(5:5)='%'
23738        NCVALU(J,1)=5
23739 2160 CONTINUE
23740C
23741      NUMLIN=3
23742      IFRST=.TRUE.
23743      ILAST=.TRUE.
23744      IFLAGS=.TRUE.
23745      IFLAGE=.TRUE.
23746C
23747      IF(ICASAN.EQ.'TWOT')THEN
23748        CALL DPDTA5(ITITLE,NCTITL,
23749     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
23750     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
23751     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
23752     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
23753     1              ICAPSW,ICAPTY,IFRST,ILAST,
23754     1              IFLAGS,IFLAGE,
23755     1              ISUBRO,IBUGA3,IERROR)
23756      ENDIF
23757C
23758      IF(ICASAN.EQ.'LOWE')THEN
23759C
23760        ITITLE='Lower-Tailed Test: Normal Approximation'
23761        NCTITL=39
23762        ITITL9='H0: Var(Y1) = Var(Y2); Ha: Var(Y1) < Var(Y2)'
23763        NCTIT9=44
23764C
23765        ITITL2(2,3)='Critical'
23766        NCTIT2(2,3)=8
23767        ITITL2(3,3)='Value (<)'
23768        NCTIT2(3,3)=9
23769        NUMCOL=4
23770C
23771        NMAX=0
23772        DO2250I=1,NUMCOL
23773          NTOT(I)=15
23774          NMAX=NMAX+NTOT(I)
23775 2250   CONTINUE
23776C
23777        ICNT=NUMALP
23778        DO2260J=1,NUMALP
23779C
23780          AMAT(J,2)=STATVA
23781          ALPHAT=ALPHA(J)
23782          ATEMP=(1.0 - ALPHAT)
23783          CALL NORPPF(ATEMP,CUTTMP)
23784          AMAT(J,3)=CUTTMP
23785          IVALUE(J,4)(1:6)='ACCEPT'
23786          IF(ABS(STATVA).LT.AMAT(J,3))THEN
23787            IVALUE(J,4)(1:6)='REJECT'
23788          ENDIF
23789          NCVALU(J,4)=6
23790          WRITE(IVALUE(J,1)(1:4),'(F4.1)')100.0*ALPHAT
23791          IVALUE(J,1)(5:5)='%'
23792          NCVALU(J,1)=5
23793 2260   CONTINUE
23794C
23795        NUMLIN=3
23796        IFRST=.TRUE.
23797        ILAST=.TRUE.
23798        IFLAGS=.TRUE.
23799        IFLAGE=.TRUE.
23800        CALL DPDTA5(ITITLE,NCTITL,
23801     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
23802     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
23803     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
23804     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
23805     1              ICAPSW,ICAPTY,IFRST,ILAST,
23806     1              IFLAGS,IFLAGE,
23807     1              ISUBRO,IBUGA3,IERROR)
23808      ENDIF
23809C
23810      IF(ICASAN.EQ.'UPPE')THEN
23811C
23812        ITITLE='Upper-Tailed Test: Normal Approximation'
23813        NCTITL=39
23814        ITITL9='H0: Var(Y1) = Var(Y2); Ha: Var(Y1) > Var(Y2)'
23815        NCTIT9=44
23816C
23817        ITITL2(2,3)='Critical'
23818        NCTIT2(2,3)=8
23819        ITITL2(3,3)='Value (>)'
23820        NCTIT2(3,3)=9
23821        NUMCOL=4
23822C
23823        NMAX=0
23824        DO2350I=1,NUMCOL
23825          NTOT(I)=15
23826          NMAX=NMAX+NTOT(I)
23827 2350   CONTINUE
23828C
23829          ICNT=NUMALP
23830        DO2360J=1,NUMALP
23831C
23832          AMAT(J,2)=STATVA
23833          ALPHAT=ALPHA(J)
23834          ATEMP=ALPHAT
23835          CALL NORPPF(ATEMP,CUTTMP)
23836          AMAT(J,3)=CUTTMP
23837          IVALUE(J,4)(1:6)='ACCEPT'
23838          IF(ABS(STATVA).GT.AMAT(J,3))THEN
23839            IVALUE(J,4)(1:6)='REJECT'
23840          ENDIF
23841          NCVALU(J,4)=6
23842          WRITE(IVALUE(J,1)(1:4),'(F4.1)')100.0*ALPHAT
23843          IVALUE(J,1)(5:5)='%'
23844          NCVALU(J,1)=5
23845 2360   CONTINUE
23846C
23847        NUMLIN=3
23848        IFRST=.TRUE.
23849        ILAST=.TRUE.
23850        IFLAGS=.TRUE.
23851        IFLAGE=.TRUE.
23852        CALL DPDTA5(ITITLE,NCTITL,
23853     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
23854     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
23855     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
23856     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
23857     1              ICAPSW,ICAPTY,IFRST,ILAST,
23858     1              IFLAGS,IFLAGE,
23859     1              ISUBRO,IBUGA3,IERROR)
23860      ENDIF
23861C               *****************
23862C               **  STEP 90--  **
23863C               **  EXIT       **
23864C               *****************
23865C
23866 9000 CONTINUE
23867      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KLO2')THEN
23868        WRITE(ICOUT,999)
23869        CALL DPWRST('XXX','WRIT')
23870        WRITE(ICOUT,9011)
23871 9011   FORMAT('***** AT THE END       OF DPKLO2--')
23872        CALL DPWRST('XXX','WRIT')
23873        WRITE(ICOUT,9013)STATVA,STATV2,STATCD,PVAL2T,PVALLT,PVALUT
23874 9013   FORMAT('STATVA,STATV2,STATCD,PVAL2T,PVALLT,PVALUT = ',6G15.7)
23875        CALL DPWRST('XXX','WRIT')
23876      ENDIF
23877C
23878      RETURN
23879      END
23880      SUBROUTINE DPKLO3(Y1,N1,Y2,N2,
23881     1                  TEMP1,TEMP2,YRANK,MAXNXT,
23882     1                  STATVA,STATCD,PVAL2T,PVALLT,PVALUT,
23883     1                  IBUGA3,ISUBRO,IERROR)
23884C
23885C     PURPOSE--THIS ROUTINE COMPUTES THE KLOTZ 2-SAMPLE TEST STATISTIC
23886C              FOR EQUAL VARIANCES AND ASSOCIATED CDF AND P-VALUES.
23887C
23888C              THIS PART IS EXTRACTED FROM DPKLO2 IN ORDER TO
23889C              ALLOW IT TO BE COMPUTED FROM THE "STATISTICS" ROUTINES
23890C              (E.G., STATISTIC PLOT, BOOTSTRAP).
23891C
23892C     EXAMPLE--KLOTZ TEST Y1 Y2
23893C              SAMPLE 1 IS IN INPUT VECTOR Y1 (WITH N1 OBSERVATIONS)
23894C              SAMPLE 2 IS IN INPUT VECTOR Y2 (WITH N2 OBSERVATIONS).
23895C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
23896C                THIRD EDITION, WILEY, PP. 401 - 402.
23897C     WRITTEN BY--ALAN HECKERT
23898C                 STATISTICAL ENGINEERING DIVISION
23899C                 INFORMATION TECHNOLOGY LABORATORY
23900C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23901C                 GAITHERSBURG, MD 20899-8980
23902C                 PHONE--301-975-2855
23903C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23904C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23905C     LANGUAGE--ANSI FORTRAN (1977)
23906C     VERSION NUMBER--2011/5
23907C     ORIGINAL VERSION--MAY       2011.
23908C
23909C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23910C
23911      CHARACTER*4 IBUGA3
23912      CHARACTER*4 ISUBRO
23913      CHARACTER*4 IERROR
23914C
23915      CHARACTER*4 IWRITE
23916      CHARACTER*4 ISUBN1
23917      CHARACTER*4 ISUBN2
23918      CHARACTER*4 ISTEPN
23919C
23920      DOUBLE PRECISION RSUM1
23921      DOUBLE PRECISION RSUM2
23922      DOUBLE PRECISION RSUM3
23923      DOUBLE PRECISION C1
23924      DOUBLE PRECISION C2
23925      DOUBLE PRECISION DNUM
23926      DOUBLE PRECISION DENOM
23927      DOUBLE PRECISION DRANK
23928C
23929C---------------------------------------------------------------------
23930C
23931      DIMENSION Y1(*)
23932      DIMENSION Y2(*)
23933      DIMENSION TEMP1(*)
23934      DIMENSION TEMP2(*)
23935      DIMENSION YRANK(*)
23936C
23937C---------------------------------------------------------------------
23938C
23939      INCLUDE 'DPCOP2.INC'
23940C
23941C-----START POINT-----------------------------------------------------
23942C
23943      ISUBN1='DPKL'
23944      ISUBN2='O3  '
23945C
23946      IERROR='NO'
23947      IWRITE='OFF'
23948C
23949      STATVA=CPUMIN
23950      STATCD=CPUMIN
23951      PVAL2T=CPUMIN
23952      PVALLT=CPUMIN
23953      PVALUT=CPUMIN
23954C
23955      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO3')THEN
23956        WRITE(ICOUT,999)
23957  999   FORMAT(1X)
23958        CALL DPWRST('XXX','WRIT')
23959        WRITE(ICOUT,51)
23960   51   FORMAT('**** AT THE BEGINNING OF DPKLO3--')
23961        CALL DPWRST('XXX','WRIT')
23962        WRITE(ICOUT,52)IBUGA3,ISUBRO,N1,N2
23963   52   FORMAT('IBUGA3,ISUBRO,N1,N2 = ',2(A4,2X),2I8)
23964        CALL DPWRST('XXX','WRIT')
23965        DO56I=1,MAX(N1,N2)
23966          WRITE(ICOUT,57)I,Y1(I),Y2(I)
23967   57     FORMAT('I,Y1(I),Y2(I) = ',I8,2G15.7)
23968          CALL DPWRST('XXX','WRIT')
23969   56   CONTINUE
23970      ENDIF
23971C
23972C               ********************************************
23973C               **  STEP 01--                             **
23974C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
23975C               ********************************************
23976C
23977      ISTEPN='01'
23978      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO3')
23979     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23980C
23981      IF(N1.LE.1)THEN
23982        WRITE(ICOUT,999)
23983        CALL DPWRST('XXX','BUG ')
23984        WRITE(ICOUT,101)
23985  101   FORMAT('***** ERROR IN KLOTZ TEST--')
23986        CALL DPWRST('XXX','BUG ')
23987        WRITE(ICOUT,112)
23988  112   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE ',
23989     1         'FIRST RESPONSE')
23990        CALL DPWRST('XXX','BUG ')
23991        WRITE(ICOUT,113)
23992  113   FORMAT('      VARIABLE MUST BE 2 OR LARGER.  SUCH WAS NOT THE ',
23993     1         'CASE HERE.')
23994        CALL DPWRST('XXX','BUG ')
23995        WRITE(ICOUT,117)N1
23996  117   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS   = ',I8,'.')
23997        CALL DPWRST('XXX','BUG ')
23998        IERROR='YES'
23999        GOTO9000
24000      ENDIF
24001C
24002      IF(N2.LE.1)THEN
24003        WRITE(ICOUT,999)
24004        CALL DPWRST('XXX','BUG ')
24005        WRITE(ICOUT,101)
24006        CALL DPWRST('XXX','BUG ')
24007        WRITE(ICOUT,122)
24008  122   FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR THE ',
24009     1         'SECOND RESPONSE')
24010        CALL DPWRST('XXX','BUG ')
24011        WRITE(ICOUT,113)
24012        CALL DPWRST('XXX','BUG ')
24013        WRITE(ICOUT,117)N2
24014        CALL DPWRST('XXX','BUG ')
24015        IERROR='YES'
24016        GOTO9000
24017      ENDIF
24018C
24019      HOLD=Y1(1)
24020      DO135I=2,N1
24021        IF(Y1(I).NE.HOLD)GOTO139
24022  135 CONTINUE
24023      WRITE(ICOUT,999)
24024      CALL DPWRST('XXX','WRIT')
24025      WRITE(ICOUT,101)
24026      CALL DPWRST('XXX','WRIT')
24027      WRITE(ICOUT,131)HOLD
24028  131 FORMAT('      THE FIRST RESPONSE VARIABLE HAS ALL ELEMENTS = ',
24029     1       G15.7)
24030      CALL DPWRST('XXX','WRIT')
24031      IERROR='YES'
24032      GOTO9000
24033  139 CONTINUE
24034C
24035      HOLD=Y2(1)
24036      DO145I=2,N1
24037        IF(Y2(I).NE.HOLD)GOTO149
24038  145 CONTINUE
24039      WRITE(ICOUT,999)
24040      CALL DPWRST('XXX','WRIT')
24041      WRITE(ICOUT,101)
24042      CALL DPWRST('XXX','WRIT')
24043      WRITE(ICOUT,141)HOLD
24044  141 FORMAT('      THE SECOND RESPONSE VARIABLE HAS ALL ELEMENTS = ',
24045     1       G15.7)
24046      CALL DPWRST('XXX','WRIT')
24047      IERROR='YES'
24048      GOTO9000
24049  149 CONTINUE
24050C
24051C               ************************************
24052C               **   STEP 11--                    **
24053C               **   COMPUTE KLOTZ    TEST        **
24054C               ************************************
24055C
24056      ISTEPN='11'
24057      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO3')
24058     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24059C
24060C     COMPUTE RANKS, BUT SUBTRACT MEANS FROM DATA FIRST
24061C
24062      CALL MEAN(Y1,N1,IWRITE,YMEAN1,IBUGA3,IERROR)
24063      CALL MEAN(Y2,N2,IWRITE,YMEAN2,IBUGA3,IERROR)
24064      DO1100I=1,N1
24065        TEMP1(I)=Y1(I) - YMEAN1
24066 1100 CONTINUE
24067      NTOT=N1
24068      DO1110I=1,N2
24069        NTOT=NTOT+1
24070        TEMP1(NTOT)=Y2(I) - YMEAN2
24071 1110 CONTINUE
24072      CALL RANK(TEMP1,NTOT,IWRITE,YRANK,TEMP2,MAXNXT,IBUGA3,IERROR)
24073C
24074C     NOW COMPUTE NORMAL SCORES
24075C
24076      DO1120I=1,NTOT
24077        ATEMP=YRANK(I)/REAL(NTOT+1)
24078        CALL NORPPF(ATEMP,APPF)
24079        YRANK(I)=APPF
24080 1120 CONTINUE
24081C
24082C     COMPUTE KLOTZ TEST STATISTIC:
24083C
24084C         T = SUM[i=1 to N1][A(i)**2 - (N1/N)*SUM[i=1 to N][A(i)**2]/
24085C             SQRT{(N1*N2/(N*(N-1))*[SUM[i=1 to N][A(i)**4] -
24086C             (1/N)*(SUM[i=1 to N][A(i)**2)**2]}
24087C
24088      ISTEPN='12'
24089      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO3')
24090     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24091C
24092      RSUM1=0.0D0
24093      RSUM2=0.0D0
24094      RSUM3=0.0D0
24095C
24096      DO1210I=1,N1
24097        DRANK=DBLE(YRANK(I))
24098        RSUM1=RSUM1 + DRANK**2
24099 1210 CONTINUE
24100C
24101      DO1220I=1,NTOT
24102        DRANK=DBLE(YRANK(I))
24103        RSUM2=RSUM2 + DRANK**2
24104        RSUM3=RSUM3 + DRANK**4
24105 1220 CONTINUE
24106C
24107      AN1=REAL(N1)
24108      AN2=REAL(N2)
24109      AN=REAL(N1 + N2)
24110      DNUM=RSUM1 - DBLE(AN1/AN)*RSUM2
24111      C1=DBLE(AN1*AN2/(AN*(AN-1.0)))
24112      C2=DBLE(1.0/AN)
24113      DENOM=C1*(RSUM3 - C2*(RSUM2**2))
24114      IF(DENOM.GE.0.0D0)THEN
24115        STATVA=DNUM/DSQRT(DENOM)
24116      ELSE
24117        WRITE(ICOUT,999)
24118        CALL DPWRST('XXX','WRIT')
24119        WRITE(ICOUT,101)
24120        CALL DPWRST('XXX','WRIT')
24121        WRITE(ICOUT,1231)
24122 1231   FORMAT('      UNABLE TO COMPUTE THE KLOTZ STATISTIC.')
24123        CALL DPWRST('XXX','WRIT')
24124        IERROR='YES'
24125        GOTO9000
24126      ENDIF
24127C
24128C     CDF AND P-VALUES COMPUTED FROM STANDARD NORMAL APPROXIMATION
24129C
24130      CALL NORCDF(STATVA,VAL1)
24131      VAL2=1.0 - VAL1
24132      VAL=MIN(VAL1,VAL2)
24133      PVAL2T=2.0*VAL
24134      PVALLT=VAL1
24135      PVALUT=VAL2
24136      STATCD=VAL1
24137C
24138C               *****************
24139C               **  STEP 90--  **
24140C               **  EXIT       **
24141C               *****************
24142C
24143 9000 CONTINUE
24144      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KLO3')THEN
24145        WRITE(ICOUT,999)
24146        CALL DPWRST('XXX','WRIT')
24147        WRITE(ICOUT,9011)
24148 9011   FORMAT('***** AT THE END       OF DPKLO3--')
24149        CALL DPWRST('XXX','WRIT')
24150        WRITE(ICOUT,9013)STATVA,STATCD
24151 9013   FORMAT('STATVA,STATCD = ',2G15.7)
24152        CALL DPWRST('XXX','WRIT')
24153        WRITE(ICOUT,9014)PVALLT,PVALUT,PVAL2T
24154 9014   FORMAT('PVALLT,PVALUT,PVAL2T = ',3G15.7)
24155        CALL DPWRST('XXX','WRIT')
24156      ENDIF
24157C
24158      RETURN
24159      END
24160      SUBROUTINE DPKRUS(TEMP4,TEMP5,MAXNXT,
24161     1                  ICAPSW,IFORSW,IMULT,
24162     1                  ISUBRO,IBUGA2,IBUGA3,IBUGQ,IFOUND,IERROR)
24163C
24164C     PURPOSE--CARRY OUT KRUSKAL-WALLIS TEST
24165C              NON-PARAMETRIC ONE-WAY ANOVA
24166C     EXAMPLE--KRUSKAL-WALLIS TEST Y X
24167C     REFERENCE--CONOVER (1999), "PRACTICAL NONPARAMETRIC STATISTICS",
24168C                THIRD EDITION, WILEY, PP. 288-297.
24169C              --WALPOLE AND MEYERS (1978), "PROBABILITY AND
24170C                STATISTICS", SECOND EDITION, MACMILLIAN.
24171C     WRITTEN BY--ALAN HECKERT
24172C                 STATISTICAL ENGINEERING DIVISION
24173C                 INFORMATION TECHNOLOGY LABORATORY
24174C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24175C                 GAITHERSBURG, MD 20899-8980
24176C                 PHONE--301-975-2899
24177C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24178C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24179C     LANGUAGE--ANSI FORTRAN (1977)
24180C     VERSION NUMBER--99/6
24181C     ORIGINAL VERSION--JUNE      1999.
24182C     UPDATED         --OCTOBER   2004. SUPPORT FOR HTML AND LATEX
24183C                                       OUTPUT
24184C     UPDATED         --FEBRUARY  2011. USE DPPARS
24185C     UPDATED         --FEBRUARY  2011. SUPPORT FOR "MULTIPLE" CASE
24186C
24187C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24188C
24189      CHARACTER*4 ICAPSW
24190      CHARACTER*4 IFORSW
24191      CHARACTER*4 IMULT
24192      CHARACTER*4 ISUBRO
24193      CHARACTER*4 IBUGA2
24194      CHARACTER*4 IBUGA3
24195      CHARACTER*4 IBUGQ
24196      CHARACTER*4 IFOUND
24197      CHARACTER*4 IERROR
24198C
24199      CHARACTER*4 ICASE
24200      CHARACTER*4 ISUBN1
24201      CHARACTER*4 ISUBN2
24202      CHARACTER*4 ISTEPN
24203      CHARACTER*4 IFLAGU
24204C
24205      LOGICAL IFRST
24206      LOGICAL ILAST
24207C
24208      CHARACTER*40 INAME
24209      PARAMETER (MAXSPN=30)
24210      CHARACTER*4 IVARN1(MAXSPN)
24211      CHARACTER*4 IVARN2(MAXSPN)
24212      CHARACTER*4 IVARTY(MAXSPN)
24213      REAL PVAR(MAXSPN)
24214      INTEGER ILIS(MAXSPN)
24215      INTEGER NRIGHT(MAXSPN)
24216      INTEGER ICOLR(MAXSPN)
24217C
24218C---------------------------------------------------------------------
24219C
24220      DIMENSION TEMP4(*)
24221      DIMENSION TEMP5(*)
24222C
24223C-----COMMON----------------------------------------------------------
24224C
24225      INCLUDE 'DPCOST.INC'
24226      INCLUDE 'DPCOPA.INC'
24227C
24228      DIMENSION DTAG(MAXOBV)
24229      DIMENSION ARANK(MAXOBV)
24230      DIMENSION NRANK(MAXOBV)
24231      DIMENSION TEMP1(MAXOBV)
24232      DIMENSION TEMP2(MAXOBV)
24233      DIMENSION TEMP3(MAXOBV)
24234      DIMENSION RTEMP(MAXOBV)
24235C
24236      INCLUDE 'DPCOZZ.INC'
24237      EQUIVALENCE(GARBAG(IGARB1),DTAG(1))
24238      EQUIVALENCE(GARBAG(IGARB2),ARANK(1))
24239      EQUIVALENCE(GARBAG(IGARB3),TEMP1(1))
24240      EQUIVALENCE(GARBAG(IGARB4),TEMP2(1))
24241      EQUIVALENCE(GARBAG(IGARB5),TEMP3(1))
24242      EQUIVALENCE(GARBAG(IGARB6),RTEMP(1))
24243C
24244      INCLUDE 'DPCOZI.INC'
24245      EQUIVALENCE(IGARBG(IIGAR1),NRANK(1))
24246C
24247      INCLUDE 'DPCOHK.INC'
24248      INCLUDE 'DPCOSU.INC'
24249      INCLUDE 'DPCODA.INC'
24250      INCLUDE 'DPCOP2.INC'
24251C
24252C-----START POINT-----------------------------------------------------
24253C
24254      ISUBN1='DPKR'
24255      ISUBN2='US  '
24256C
24257      MAXCP1=MAXCOL+1
24258      MAXCP2=MAXCOL+2
24259      MAXCP3=MAXCOL+3
24260      MAXCP4=MAXCOL+4
24261      MAXCP5=MAXCOL+5
24262      MAXCP6=MAXCOL+6
24263C
24264      IFOUND='YES'
24265      IERROR='NO'
24266C
24267C               ******************************************
24268C               **  TREAT THE KRUSKAL-WALLIS TEST CASE  **
24269C               ******************************************
24270C
24271      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'KRUS')THEN
24272        WRITE(ICOUT,999)
24273  999   FORMAT(1X)
24274        CALL DPWRST('XXX','BUG ')
24275        WRITE(ICOUT,51)
24276   51   FORMAT('***** AT THE BEGINNING OF DPKRUS--')
24277        CALL DPWRST('XXX','BUG ')
24278        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
24279   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
24280        CALL DPWRST('XXX','BUG ')
24281        WRITE(ICOUT,55)IMULT,IKRUGS,MAXNXT
24282   55   FORMAT('IMULT,IKRUGS,MAXNXT = ',A4,2X,A4,2X,I8)
24283        CALL DPWRST('XXX','BUG ')
24284      ENDIF
24285C
24286C               *********************************
24287C               **  STEP 1--                   **
24288C               **  EXTRACT THE VARIABLE LIST  **
24289C               *********************************
24290C
24291      ISTEPN='1'
24292      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KRUS')
24293     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24294C
24295      INAME='KRUSKAL WALLIS TEST'
24296      MAXNA=100
24297      MINNVA=1
24298      MAXNVA=100
24299      MINNA=1
24300      IFLAGE=1
24301      IFLAGM=0
24302      IF(IMULT.EQ.'ON')THEN
24303        IFLAGE=0
24304        IFLAGM=1
24305      ENDIF
24306      MINN2=2
24307      IFLAGP=0
24308      JMIN=1
24309      JMAX=NUMARG
24310C
24311      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
24312     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
24313     1            JMIN,JMAX,
24314     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
24315     1            IVARN1,IVARN2,IVARTY,PVAR,
24316     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
24317     1            MINNVA,MAXNVA,
24318     1            IFLAGM,IFLAGP,
24319     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
24320      IF(IERROR.EQ.'YES')GOTO9000
24321C
24322      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KRUS')THEN
24323        WRITE(ICOUT,999)
24324        CALL DPWRST('XXX','BUG ')
24325        WRITE(ICOUT,181)
24326  181   FORMAT('***** AFTER CALL DPPARS--')
24327        CALL DPWRST('XXX','BUG ')
24328        WRITE(ICOUT,182)NQ,NUMVAR,IMULT
24329  182   FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4)
24330        CALL DPWRST('XXX','BUG ')
24331        IF(NUMVAR.GT.0)THEN
24332          DO185I=1,NUMVAR
24333            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
24334     1                      ICOLR(I)
24335  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
24336     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
24337            CALL DPWRST('XXX','BUG ')
24338  185     CONTINUE
24339        ENDIF
24340      ENDIF
24341C
24342C               *******************************************************
24343C               **  STEP 3--                                         **
24344C               **  GENERATE THE KRUSKAL WALLIS TEST FOR THE VARIOUS **
24345C               **  CASES                                            **
24346C               *******************************************************
24347C
24348      ISTEPN='3'
24349      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KRUS')
24350     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24351C
24352C               *****************************************
24353C               **  STEP 3A--                          **
24354C               **  CASE 1: TWO RESPONSE VARIABLES     **
24355C               **          WITH NO REPLICATION        **
24356C               *****************************************
24357C
24358      IF(IMULT.EQ.'OFF')THEN
24359        ISTEPN='3A'
24360        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KRUS')
24361     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24362C
24363        ICOL=1
24364        NUMVA2=2
24365        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
24366     1              INAME,IVARN1,IVARN2,IVARTY,
24367     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
24368     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
24369     1              MAXCP4,MAXCP5,MAXCP6,
24370     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
24371     1              Y,X,X,NLOCAL,NLOCA2,NLOCA2,ICASE,
24372     1              IBUGA3,ISUBRO,IFOUND,IERROR)
24373        IF(IERROR.EQ.'YES')GOTO9000
24374C
24375C
24376C               ******************************************************
24377C               **  STEP 3B--
24378C               **  PREPARE FOR ENTRANCE INTO DPKRU2--
24379C               ******************************************************
24380C
24381        ISTEPN='3B'
24382        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KRUS')THEN
24383          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24384          WRITE(ICOUT,999)
24385          CALL DPWRST('XXX','BUG ')
24386          WRITE(ICOUT,331)
24387  331     FORMAT('***** FROM DPKRUS, AS WE ARE ABOUT TO CALL DPKRU2--')
24388          CALL DPWRST('XXX','BUG ')
24389          WRITE(ICOUT,332)NLOCAL
24390  332     FORMAT('NLOCAL = ',I8)
24391          CALL DPWRST('XXX','BUG ')
24392          DO335I=1,NLOCAL
24393            WRITE(ICOUT,336)I,Y(I),X(I)
24394  336       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
24395            CALL DPWRST('XXX','BUG ')
24396  335     CONTINUE
24397        ENDIF
24398C
24399        CALL DPKRU2(Y,X,NLOCAL,IVARN1,IVARN2,
24400     1              DTAG,ARANK,NRANK,MAXNXT,
24401     1              RTEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
24402     1              STATVA,STATCD,PVAL,
24403     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT999,
24404     1              ICAPSW,ICAPTY,IFORSW,IMULT,IKRUGS,IKRUMC,
24405     1              ISUBRO,IBUGA3,IERROR)
24406C
24407C               ***************************************
24408C               **  STEP 8C--                        **
24409C               **  UPDATE INTERNAL DATAPLOT TABLES  **
24410C               ***************************************
24411C
24412          ISTEPN='8C'
24413          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KRUS')
24414     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24415C
24416          IFLAGU='ON'
24417          IFRST=.TRUE.
24418          ILAST=.TRUE.
24419          CALL DPFRT5(STATVA,STATCD,PVAL,
24420     1                CUT0,CUT50,CUT75,CUT90,CUT95,
24421     1                CUT975,CUT99,CUT999,
24422     1                IFLAGU,IFRST,ILAST,
24423     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
24424C
24425C               *******************************************************
24426C               **  STEP 4A--                                        **
24427C               **  CASE 2: MULTIPLE RESPONSE VARIABLES.  NOTE THAT  **
24428C               **          FOR KRUSKAL-WALLIS TEST, THE MULTIPLE    **
24429C               **          LABS ARE CONVERTED INTO A "Y X" STACKED  **
24430C               **          PAIR WHERE "X" IS THE LAB-ID VARIABLE.   **
24431C               *******************************************************
24432C
24433      ELSEIF(IMULT.EQ.'ON')THEN
24434        ISTEPN='4A'
24435        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KRUS')
24436     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24437C
24438        ICOL=1
24439        NUMVA2=NUMVAR
24440        CALL DPPAR8(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
24441     1              INAME,IVARN1,IVARN2,IVARTY,
24442     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
24443     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
24444     1              MAXCP4,MAXCP5,MAXCP6,
24445     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
24446     1              TEMP1,Y,X,NLOCAL,ICASE,
24447     1              IBUGA3,ISUBRO,IFOUND,IERROR)
24448        NUMVAR=2
24449        IF(IERROR.EQ.'YES')GOTO9000
24450C
24451        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'KRUS')THEN
24452          ISTEPN='4B'
24453          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24454          WRITE(ICOUT,999)
24455          CALL DPWRST('XXX','BUG ')
24456          WRITE(ICOUT,442)
24457  442     FORMAT('***** FROM THE MIDDLE  OF DPKRUS--')
24458          CALL DPWRST('XXX','BUG ')
24459          WRITE(ICOUT,443)ICASAN,NUMVAR,NLOCAL
24460  443     FORMAT('ICASAN,NUMVAR,NLOCAL = ',A4,2I8)
24461          CALL DPWRST('XXX','BUG ')
24462          IF(NLOCAL.GE.1)THEN
24463            DO445I=1,NLOCAL
24464              WRITE(ICOUT,446)I,Y(I),X(I)
24465  446         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
24466              CALL DPWRST('XXX','BUG ')
24467  445       CONTINUE
24468          ENDIF
24469        ENDIF
24470C
24471        CALL DPKRU2(Y,X,NLOCAL,IVARN1,IVARN2,
24472     1              DTAG,ARANK,NRANK,MAXNXT,
24473     1              RTEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
24474     1              STATVA,STATCD,PVAL,
24475     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,CUT99,CUT999,
24476     1              ICAPSW,ICAPTY,IFORSW,IMULT,IKRUGS,IKRUMC,
24477     1              ISUBRO,IBUGA3,IERROR)
24478C
24479C         ***************************************
24480C         **  STEP 8C--                        **
24481C         **  UPDATE INTERNAL DATAPLOT TABLES  **
24482C         ***************************************
24483C
24484          ISTEPN='8C'
24485          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'KRUS')
24486     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24487C
24488          IFLAGU='ON'
24489          IFRST=.TRUE.
24490          ILAST=.TRUE.
24491          CALL DPFRT5(STATVA,STATCD,PVAL,
24492     1                CUT0,CUT50,CUT75,CUT90,CUT95,
24493     1                CUT975,CUT99,CUT999,
24494     1                IFLAGU,IFRST,ILAST,
24495     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
24496C
24497      ENDIF
24498C
24499C               *****************
24500C               **  STEP 90--  **
24501C               **  EXIT       **
24502C               *****************
24503C
24504 9000 CONTINUE
24505      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'KRUS')THEN
24506        WRITE(ICOUT,999)
24507        CALL DPWRST('XXX','BUG ')
24508        WRITE(ICOUT,9011)
24509 9011   FORMAT('***** AT THE END       OF DPKRUS--')
24510        CALL DPWRST('XXX','BUG ')
24511        WRITE(ICOUT,9014)NLOCAL,STATVA,STATCD
24512 9014   FORMAT('NLOCAL,STATVA,STATCD = ',I8,2G15.7)
24513        CALL DPWRST('XXX','BUG ')
24514        WRITE(ICOUT,9016)IFOUND,IERROR
24515 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
24516        CALL DPWRST('XXX','BUG ')
24517      ENDIF
24518C
24519      RETURN
24520      END
24521      SUBROUTINE DPKRU2(Y,TAG,N,IVARID,IVARI2,
24522     1                  DTAG,ARANK,NRANK,MAXNXT,
24523     1                  RTEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
24524     1                  STATVA,STATCD,PVAL,
24525     1                  CUT0,CUT50,CUT75,CUT90,CUT95,CUT975,
24526     1                  CUT99,CUT999,
24527     1                  ICAPSW,ICAPTY,IFORSW,IMULT,IKRUGS,IKRUMC,
24528     1                  ISUBRO,IBUGA3,IERROR)
24529C
24530C     PURPOSE--THIS ROUTINE CARRIES OUT KRUSKALL-WALLIS'S TEST
24531C              NON-PARAMETRIC ONE-WAY ANOVA
24532C     EXAMPLE--KRUSKALL-WALLIS TEST Y TAG
24533C     REFERENCE--W. J. CONOVER, "PRACTICAL NONPARAMETRIC
24534C                STATISTICS", THIRD EDITION, 1999, WILEY,
24535C                PP. 288-297.
24536C     WRITTEN BY--ALAN HECKERT
24537C                 STATISTICAL ENGINEERING DIVISION
24538C                 INFORMATION TECHNOLOGY LABORATORY
24539C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24540C                 GAITHERSBURG, MD 20899-8980
24541C                 PHONE--301-975-2899
24542C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24543C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24544C     LANGUAGE--ANSI FORTRAN (1977)
24545C     VERSION NUMBER--99/6
24546C     ORIGINAL VERSION--JUNE      1999.
24547C     UPDATED         --OCTOBER   2004. SUPPORT FOR HTML AND LATEX
24548C                                       OUTPUT
24549C     UPDATED         --OCTOBER   2004. ADD MULTIPLE COMPARISONS
24550C     UPDATED         --OCTOBER   2006. CALL LIST TO TPPF
24551C     UPDATED         --JANUARY   2007. CALL LIST TO RANK
24552C     UPDATED         --FEBRUARY  2009. SORT BY GROUP-ID VARIABLE
24553C                                       FIRST (THIS INSURES MULTIPLE
24554C                                       COMPARISONS ARE PRINTED IN
24555C                                       CORRECT ORDER).
24556C     UPDATED         --FEBRUARY  2009. ADD SOME DEBUGGING CODE
24557C     UPDATED         --FEBRUARY  2011. USE DPDTA1 AND DPDTA4 TO PRINT
24558C                                       OUTPUT TABLES.  THIS ADDS RTF
24559C                                       SUPPORT AND SPECIFICATION OF
24560C                                       THE NUMBER OF DIGITS.
24561C     UPDATED         --FEBRUARY  2011. OPTION TO PRINT GROUP
24562C                                       STATISTICS
24563C     UPDATED         --JULY      2011. SPLIT OFF DPKRU3, MAKE MORE
24564C                                       EFFICIENT USE OF STORAGE
24565C
24566C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24567C
24568      CHARACTER*4 ICAPSW
24569      CHARACTER*4 ICAPTY
24570      CHARACTER*4 IFORSW
24571      CHARACTER*4 IMULT
24572      CHARACTER*4 IKRUGS
24573      CHARACTER*4 IKRUMC
24574      CHARACTER*4 ISUBRO
24575      CHARACTER*4 IBUGA3
24576      CHARACTER*4 IERROR
24577      CHARACTER*4 IVARID(*)
24578      CHARACTER*4 IVARI2(*)
24579C
24580      CHARACTER*4 IATEMP
24581      CHARACTER*4 ISUBN0
24582      CHARACTER*4 ISUBN1
24583      CHARACTER*4 ISUBN2
24584      CHARACTER*4 ISTEPN
24585      CHARACTER*4 IOP
24586C
24587C---------------------------------------------------------------------
24588C
24589      DIMENSION Y(*)
24590      DIMENSION TAG(*)
24591      DIMENSION DTAG(*)
24592      DIMENSION ARANK(*)
24593      DIMENSION NRANK(*)
24594      DIMENSION RTEMP(*)
24595      DIMENSION TEMP1(*)
24596      DIMENSION TEMP2(*)
24597      DIMENSION TEMP3(*)
24598      DIMENSION TEMP4(*)
24599      DIMENSION TEMP5(*)
24600C
24601C---------------------------------------------------------------------
24602C
24603      PARAMETER (NUMALP=8)
24604      REAL ALPHA(NUMALP)
24605C
24606      PARAMETER(NUMCLI=6)
24607      PARAMETER(MAXLIN=2)
24608      PARAMETER (MAXROW=50)
24609      CHARACTER*60 ITITLE
24610      CHARACTER*60 ITITLZ
24611      CHARACTER*1  ITITL9
24612      CHARACTER*60 ITEXT(MAXROW)
24613      CHARACTER*4  ALIGN(NUMCLI)
24614      CHARACTER*4  VALIGN(NUMCLI)
24615      REAL         AVALUE(MAXROW)
24616      INTEGER      NCTEXT(MAXROW)
24617      INTEGER      IDIGIT(MAXROW)
24618      INTEGER      NTOT(MAXROW)
24619      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
24620      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
24621      CHARACTER*4  ITYPCO(NUMCLI)
24622      INTEGER      NCTIT2(MAXLIN,NUMCLI)
24623      INTEGER      NCVALU(MAXROW,NUMCLI)
24624      INTEGER      IWHTML(NUMCLI)
24625      INTEGER      IWRTF(NUMCLI)
24626      REAL         AMAT(MAXROW,NUMCLI)
24627      LOGICAL IFRST
24628      LOGICAL ILAST
24629      LOGICAL IFLAGS
24630      LOGICAL IFLAGE
24631C
24632      INCLUDE 'DPCOP2.INC'
24633C
24634C-----START POINT-----------------------------------------------------
24635C
24636      DATA ALPHA/
24637     1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/
24638C
24639      ISUBN1='DPKR'
24640      ISUBN2='U2  '
24641      ISUBN0='    '
24642C
24643      IERROR='NO'
24644C
24645      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KRU2')THEN
24646        WRITE(ICOUT,999)
24647  999   FORMAT(1X)
24648        CALL DPWRST('XXX','WRIT')
24649        WRITE(ICOUT,51)
24650   51   FORMAT('**** AT THE BEGINNING OF DPKRU2--')
24651        CALL DPWRST('XXX','WRIT')
24652        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
24653   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
24654        CALL DPWRST('XXX','WRIT')
24655        DO56I=1,N
24656          WRITE(ICOUT,57)I,Y(I),TAG(I)
24657   57     FORMAT('I,Y(I),TAG(I) = ',I8,2G15.7)
24658          CALL DPWRST('XXX','WRIT')
24659   56   CONTINUE
24660      ENDIF
24661C
24662      CALL DPKRU3(Y,TAG,N,
24663     1            DTAG,ARANK,NRANK,MAXNXT,
24664     1            RTEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
24665     1            STATVA,STATCD,PVAL,NUMDF,NUMDIS,S2,
24666     1            IKRUGS,
24667     1            IBUGA3,ISUBRO,IERROR)
24668      IF(IERROR.EQ.'YES')GOTO9000
24669C
24670      CUT0=0.0
24671      CALL CHSPPF(.50,NUMDF,CUT50)
24672      CALL CHSPPF(.75,NUMDF,CUT75)
24673      CALL CHSPPF(.90,NUMDF,CUT90)
24674      CALL CHSPPF(.95,NUMDF,CUT95)
24675      CALL CHSPPF(.975,NUMDF,CUT975)
24676      CALL CHSPPF(.99,NUMDF,CUT99)
24677      CALL CHSPPF(.999,NUMDF,CUT999)
24678C
24679      IOP='OPEN'
24680      IFLG1=1
24681      IFLG2=0
24682      IFLG3=0
24683      IFLG4=0
24684      IFLG5=0
24685      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
24686     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24687     1            IBUGA3,ISUBRO,IERROR)
24688      IF(IERROR.EQ.'YES')GOTO9000
24689C
24690      WRITE(IOUNI1,2305)
24691 2305 FORMAT('     I       J    ',
24692     1       '|Ri/Ni-Rj/nj|      ',
24693     1       '90% CV        ',
24694     1       '95% CV        ',
24695     1       '99% CV        ')
24696C
24697      IDF=N-NUMDIS
24698      ALPHAT=0.05
24699      CALL TPPF(1.0-ALPHAT/2.0,REAL(IDF),AT95)
24700      ALPHAT=0.10
24701      CALL TPPF(1.0-ALPHAT/2.0,REAL(IDF),AT90)
24702      ALPHAT=0.01
24703      CALL TPPF(1.0-ALPHAT/2.0,REAL(IDF),AT99)
24704      AN=REAL(N)
24705      AFACT2=SQRT(S2*(REAL(N)-1.0-STATVA)/REAL(N-NUMDIS))
24706C
24707      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2')THEN
24708        WRITE(ICOUT,2321)AFACT2
24709 2321   FORMAT('BEFORE MULTIPLE COMPARISONS: AFACT2 = ',G15.7)
24710        CALL DPWRST('XXX','WRIT')
24711      ENDIF
24712C
24713      DO2330I=1,NUMDIS
24714        DO2339J=1,NUMDIS
24715          IF(I.LT.J)THEN
24716            ANI=REAL(NRANK(I))
24717            ANJ=REAL(NRANK(J))
24718            ADIFF=ABS((ARANK(I)/ANI) - (ARANK(J)/ANJ))
24719            AFACT3=SQRT((1.0/ANI) + (1.0/ANJ))
24720            ACV90=AT90*AFACT2*AFACT3
24721            ACV95=AT95*AFACT2*AFACT3
24722            ACV99=AT99*AFACT2*AFACT3
24723            IATEMP='    '
24724            IF(ADIFF.GE.ACV90)IATEMP(2:2)='*'
24725            IF(ADIFF.GE.ACV95)IATEMP(3:3)='*'
24726            IF(ADIFF.GE.ACV99)IATEMP(4:4)='*'
24727            WRITE(IOUNI1,2337)I,J,ADIFF,ACV90,ACV95,ACV99,IATEMP
24728 2337       FORMAT(I6,2X,I6,2X,4E15.7,A4)
24729C
24730            IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2')THEN
24731              WRITE(ICOUT,2341)I,J,ANI,ANJ,ARANK(I),ARANK(J)
24732 2341         FORMAT('I,J,ANI,ANJ,ARANK(I),ARANK(J) = ',2I8,4G15.7)
24733              CALL DPWRST('XXX','WRIT')
24734              WRITE(ICOUT,2343)AFACT3,ADIFF
24735 2343         FORMAT('AFACT3,ADIFF = ',2G15.7)
24736              CALL DPWRST('XXX','WRIT')
24737            ENDIF
24738C
24739          ENDIF
24740 2339   CONTINUE
24741 2330 CONTINUE
24742C
24743      IOP='CLOS'
24744      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
24745     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24746     1            IBUGA3,ISUBRO,IERROR)
24747      IF(IERROR.EQ.'YES')GOTO9000
24748C
24749C               ********************************
24750C               **   STEP 42--                **
24751C               **   WRITE OUT EVERYTHING     **
24752C               **   FOR KRUSKALL-WALLIS TEST **
24753C               ********************************
24754C
24755      ISTEPN='42'
24756      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2')
24757     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24758C
24759      IF(IPRINT.EQ.'OFF')GOTO9000
24760C
24761      NUMDIG=7
24762      IF(IFORSW.EQ.'1')NUMDIG=1
24763      IF(IFORSW.EQ.'2')NUMDIG=2
24764      IF(IFORSW.EQ.'3')NUMDIG=3
24765      IF(IFORSW.EQ.'4')NUMDIG=4
24766      IF(IFORSW.EQ.'5')NUMDIG=5
24767      IF(IFORSW.EQ.'6')NUMDIG=6
24768      IF(IFORSW.EQ.'7')NUMDIG=7
24769      IF(IFORSW.EQ.'8')NUMDIG=8
24770      IF(IFORSW.EQ.'9')NUMDIG=9
24771      IF(IFORSW.EQ.'0')NUMDIG=0
24772      IF(IFORSW.EQ.'E')NUMDIG=-2
24773      IF(IFORSW.EQ.'-2')NUMDIG=-2
24774      IF(IFORSW.EQ.'-3')NUMDIG=-3
24775      IF(IFORSW.EQ.'-4')NUMDIG=-4
24776      IF(IFORSW.EQ.'-5')NUMDIG=-5
24777      IF(IFORSW.EQ.'-6')NUMDIG=-6
24778      IF(IFORSW.EQ.'-7')NUMDIG=-7
24779      IF(IFORSW.EQ.'-8')NUMDIG=-8
24780      IF(IFORSW.EQ.'-9')NUMDIG=-9
24781C
24782      ITITLE='Kruskal-Wallis One Factor Test'
24783      NCTITL=32
24784      ITITLZ=' '
24785      NCTITZ=0
24786C
24787      ICNT=1
24788      ITEXT(ICNT)=' '
24789      NCTEXT(ICNT)=0
24790      AVALUE(ICNT)=0.0
24791      IDIGIT(ICNT)=-1
24792      IF(IMULT.EQ.'OFF')THEN
24793        ICNT=ICNT+1
24794        ITEXT(ICNT)='Response Variable: '
24795        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
24796        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
24797        NCTEXT(ICNT)=27
24798        AVALUE(ICNT)=0.0
24799        IDIGIT(ICNT)=-1
24800C
24801        ICNT=ICNT+1
24802        ITEXT(ICNT)='Group-ID Variable: '
24803        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(2)(1:4)
24804        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(2)(1:4)
24805        NCTEXT(ICNT)=27
24806        AVALUE(ICNT)=0.0
24807        IDIGIT(ICNT)=-1
24808      ENDIF
24809C
24810C     IF REQUESTED, PRINT OUT GROUP INFORMATION.  SINCE NUMBER
24811C     OF GROUPS IS UNKNOWN (AND POTENTIALLY LARGE, PRINT EACH
24812C     GROUP AS A SEPARATE TABLE.
24813C
24814      IF(IKRUGS.EQ.'ON')THEN
24815C
24816        DO2160I=1,NUMDIS
24817C
24818          NUMROW=ICNT
24819          DO2165II=1,NUMROW
24820            NTOT(II)=15
24821 2165     CONTINUE
24822C
24823          IFRST=.TRUE.
24824          ILAST=.TRUE.
24825C
24826          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
24827     1                AVALUE,IDIGIT,
24828     1                NTOT,NUMROW,
24829     1                ICAPSW,ICAPTY,ILAST,IFRST,
24830     1                ISUBRO,IBUGA3,IERROR)
24831          ICNT=0
24832          ITITLE=' '
24833          NCTITL=0
24834          ITITLZ=' '
24835          NCTITZ=0
24836C
24837          ICNT=ICNT+1
24838          ITEXT(ICNT)=' '
24839          NCTEXT(ICNT)=1
24840          AVALUE(ICNT)=0.0
24841          IDIGIT(ICNT)=-1
24842C
24843          IF(IMULT.EQ.'ON')THEN
24844            ICNT=ICNT+1
24845            ITEXT(ICNT)='Group Variable: '
24846            WRITE(ITEXT(ICNT)(17:20),'(A4)')IVARID(I)(1:4)
24847            WRITE(ITEXT(ICNT)(21:24),'(A4)')IVARI2(I)(1:4)
24848            NCTEXT(ICNT)=24
24849            AVALUE(ICNT)=0.0
24850            IDIGIT(ICNT)=-1
24851          ELSE
24852            ICNT=ICNT+1
24853            ITEXT(ICNT)='Group    '
24854            WRITE(ITEXT(ICNT)(7:9),'(I3)')I
24855            NCTEXT(ICNT)=9
24856            AVALUE(ICNT)=0.0
24857            IDIGIT(ICNT)=-1
24858          ENDIF
24859          ICNT=ICNT+1
24860          ITEXT(ICNT)='Number of Observations:'
24861          NCTEXT(ICNT)=23
24862          AVALUE(ICNT)=TEMP1(I)
24863          IDIGIT(ICNT)=0
24864          ICNT=ICNT+1
24865          ITEXT(ICNT)='Mean:'
24866          NCTEXT(ICNT)=5
24867          AVALUE(ICNT)=TEMP2(I)
24868          IDIGIT(ICNT)=NUMDIG
24869          ICNT=ICNT+1
24870          ITEXT(ICNT)='Median:'
24871          NCTEXT(ICNT)=7
24872          AVALUE(ICNT)=TEMP3(I)
24873          IDIGIT(ICNT)=NUMDIG
24874          ICNT=ICNT+1
24875          ITEXT(ICNT)='SD:'
24876          NCTEXT(ICNT)=3
24877          AVALUE(ICNT)=TEMP4(I)
24878          IDIGIT(ICNT)=NUMDIG
24879 2160   CONTINUE
24880C
24881        IF(ICNT.GT.0)THEN
24882          NUMROW=ICNT
24883          DO2168II=1,NUMROW
24884            NTOT(II)=15
24885 2168     CONTINUE
24886C
24887          IFRST=.TRUE.
24888          ILAST=.TRUE.
24889C
24890          CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
24891     1                AVALUE,IDIGIT,
24892     1                NTOT,NUMROW,
24893     1                ICAPSW,ICAPTY,ILAST,IFRST,
24894     1                ISUBRO,IBUGA3,IERROR)
24895          ICNT=0
24896        ENDIF
24897      ENDIF
24898C
24899      ICNT=ICNT+1
24900      ITEXT(ICNT)=' '
24901      NCTEXT(ICNT)=1
24902      AVALUE(ICNT)=0.0
24903      IDIGIT(ICNT)=-1
24904C
24905      ICNT=ICNT+1
24906      ITEXT(ICNT)='H0: Samples Come From Identical Populations'
24907      NCTEXT(ICNT)=43
24908      AVALUE(ICNT)=0.0
24909      IDIGIT(ICNT)=-1
24910      ICNT=ICNT+1
24911      ITEXT(ICNT)='Ha: Samples Do Not Come From Identical Populations'
24912      NCTEXT(ICNT)=50
24913      AVALUE(ICNT)=0.0
24914      IDIGIT(ICNT)=-1
24915C
24916      ICNT=ICNT+1
24917      ITEXT(ICNT)=' '
24918      NCTEXT(ICNT)=1
24919      AVALUE(ICNT)=0.0
24920      IDIGIT(ICNT)=-1
24921      ICNT=ICNT+1
24922      ITEXT(ICNT)='Summary Statistics:'
24923      NCTEXT(ICNT)=19
24924      AVALUE(ICNT)=0.0
24925      IDIGIT(ICNT)=-1
24926      ICNT=ICNT+1
24927      ITEXT(ICNT)='Total Number of Observations:'
24928      NCTEXT(ICNT)=29
24929      AVALUE(ICNT)=REAL(N)
24930      IDIGIT(ICNT)=0
24931      ICNT=ICNT+1
24932      ITEXT(ICNT)='Number of Groups:'
24933      NCTEXT(ICNT)=17
24934      AVALUE(ICNT)=REAL(NUMDIS)
24935      IDIGIT(ICNT)=0
24936      ICNT=ICNT+1
24937      ITEXT(ICNT)=' '
24938      NCTEXT(ICNT)=1
24939      AVALUE(ICNT)=0.0
24940      IDIGIT(ICNT)=-1
24941C
24942      ICNT=ICNT+1
24943      ITEXT(ICNT)='Kruskal-Wallis Test Statistic Value:'
24944      NCTEXT(ICNT)=36
24945      AVALUE(ICNT)=STATVA
24946      IDIGIT(ICNT)=NUMDIG
24947      ICNT=ICNT+1
24948      ITEXT(ICNT)='CDF of Test Statistic:'
24949      NCTEXT(ICNT)=22
24950      AVALUE(ICNT)=STATCD
24951      IDIGIT(ICNT)=NUMDIG
24952      ICNT=ICNT+1
24953      ITEXT(ICNT)='P-Value:'
24954      NCTEXT(ICNT)=8
24955      PVAL=1.0 - STATCD
24956      AVALUE(ICNT)=1.0 - STATCD
24957      IDIGIT(ICNT)=NUMDIG
24958C
24959      NUMROW=ICNT
24960      DO4210I=1,NUMROW
24961        NTOT(I)=15
24962 4210 CONTINUE
24963C
24964      IFRST=.TRUE.
24965      ILAST=.TRUE.
24966C
24967      ISTEPN='42A'
24968      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2')
24969     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24970C
24971      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
24972     1            AVALUE,IDIGIT,
24973     1            NTOT,NUMROW,
24974     1            ICAPSW,ICAPTY,ILAST,IFRST,
24975     1            ISUBRO,IBUGA3,IERROR)
24976C
24977      ITITLE=' '
24978      NCTITL=0
24979C
24980      ITITL9=' '
24981      NCTIT9=0
24982      ITITLE(1:55)=
24983     1'Percent Points of the Chi-Square Reference Distribution'
24984      NCTITL=55
24985      NUMLIN=1
24986      NUMROW=8
24987      NUMCOL=3
24988      ITITL2(1,1)='Percent Point'
24989      ITITL2(1,2)=' '
24990      ITITL2(1,3)='Value'
24991      NCTIT2(1,1)=13
24992      NCTIT2(1,2)=1
24993      NCTIT2(1,3)=5
24994C
24995      NMAX=0
24996      DO4221I=1,NUMCOL
24997        VALIGN(I)='b'
24998        ALIGN(I)='r'
24999        NTOT(I)=15
25000        IF(I.EQ.2)NTOT(I)=5
25001        NMAX=NMAX+NTOT(I)
25002        IDIGIT(I)=NUMDIG
25003        ITYPCO(I)='NUME'
25004 4221 CONTINUE
25005      ITYPCO(2)='ALPH'
25006      IDIGIT(1)=1
25007      IDIGIT(3)=3
25008      DO4223I=1,NUMROW
25009        DO4225J=1,NUMCOL
25010          NCVALU(I,J)=0
25011          IVALUE(I,J)=' '
25012          NCVALU(I,J)=0
25013          AMAT(I,J)=0.0
25014          IF(J.EQ.1)THEN
25015            AMAT(I,J)=ALPHA(I)
25016          ELSEIF(J.EQ.2)THEN
25017            IVALUE(I,J)='='
25018            NCVALU(I,J)=1
25019          ELSEIF(J.EQ.3)THEN
25020            IF(I.EQ.1)THEN
25021              AMAT(I,J)=RND(CUT0,IDIGIT(J))
25022            ELSEIF(I.EQ.2)THEN
25023              AMAT(I,J)=RND(CUT50,IDIGIT(J))
25024            ELSEIF(I.EQ.3)THEN
25025              AMAT(I,J)=RND(CUT75,IDIGIT(J))
25026            ELSEIF(I.EQ.4)THEN
25027              AMAT(I,J)=RND(CUT90,IDIGIT(J))
25028            ELSEIF(I.EQ.5)THEN
25029              AMAT(I,J)=RND(CUT95,IDIGIT(J))
25030            ELSEIF(I.EQ.6)THEN
25031              AMAT(I,J)=RND(CUT975,IDIGIT(J))
25032            ELSEIF(I.EQ.7)THEN
25033              AMAT(I,J)=RND(CUT99,IDIGIT(J))
25034            ELSEIF(I.EQ.8)THEN
25035              AMAT(I,J)=RND(CUT999,IDIGIT(J))
25036            ENDIF
25037          ENDIF
25038 4225   CONTINUE
25039 4223 CONTINUE
25040C
25041      IWHTML(1)=150
25042      IWHTML(2)=50
25043      IWHTML(3)=150
25044      IWRTF(1)=2000
25045      IWRTF(2)=IWRTF(1)+500
25046      IWRTF(3)=IWRTF(2)+2000
25047      IFRST=.TRUE.
25048      ILAST=.FALSE.
25049C
25050      ISTEPN='42C'
25051      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2')
25052     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25053C
25054      CALL DPDTA4(ITITL9,NCTIT9,
25055     1            ITITLE,NCTITL,ITITL2,NCTIT2,
25056     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
25057     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
25058     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
25059     1            ICAPSW,ICAPTY,IFRST,ILAST,
25060     1            ISUBRO,IBUGA3,IERROR)
25061C
25062      ISTEPN='42D'
25063      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2')
25064     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25065C
25066      CDF1=CUT90
25067      CDF2=CUT95
25068      CDF3=CUT975
25069      CDF4=CUT99
25070C
25071      ITITL9=' '
25072      NCTIT9=0
25073      ITITLE='Conclusions (Upper 1-Tailed Test)'
25074      NCTITL=33
25075      NUMLIN=1
25076      NUMROW=4
25077      NUMCOL=4
25078      ITITL2(1,1)='Alpha'
25079      ITITL2(1,2)='CDF'
25080      ITITL2(1,3)='Critical Value'
25081      ITITL2(1,4)='Conclusion'
25082      NCTIT2(1,1)=5
25083      NCTIT2(1,2)=3
25084      NCTIT2(1,3)=14
25085      NCTIT2(1,4)=10
25086C
25087      NMAX=0
25088      DO4321I=1,NUMCOL
25089        VALIGN(I)='b'
25090        ALIGN(I)='r'
25091        NTOT(I)=15
25092        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
25093        IF(I.EQ.3)NTOT(I)=17
25094        NMAX=NMAX+NTOT(I)
25095        IDIGIT(I)=3
25096        ITYPCO(I)='ALPH'
25097 4321 CONTINUE
25098      ITYPCO(3)='NUME'
25099      IDIGIT(1)=0
25100      IDIGIT(2)=0
25101      DO4323I=1,NUMROW
25102        DO4325J=1,NUMCOL
25103          NCVALU(I,J)=0
25104          IVALUE(I,J)=' '
25105          NCVALU(I,J)=0
25106          AMAT(I,J)=0.0
25107 4325   CONTINUE
25108 4323 CONTINUE
25109      IVALUE(1,1)='10%'
25110      IVALUE(2,1)='5%'
25111      IVALUE(3,1)='2.5%'
25112      IVALUE(4,1)='1%'
25113      IVALUE(1,2)='90%'
25114      IVALUE(2,2)='95%'
25115      IVALUE(3,2)='97.5%'
25116      IVALUE(4,2)='99%'
25117      NCVALU(1,1)=3
25118      NCVALU(2,1)=2
25119      NCVALU(3,1)=4
25120      NCVALU(4,1)=2
25121      NCVALU(1,2)=3
25122      NCVALU(2,2)=3
25123      NCVALU(3,2)=5
25124      NCVALU(4,2)=3
25125      IVALUE(1,4)='Accept H0'
25126      IVALUE(2,4)='Accept H0'
25127      IVALUE(3,4)='Accept H0'
25128      IVALUE(4,4)='Accept H0'
25129      NCVALU(1,4)=9
25130      NCVALU(2,4)=9
25131      NCVALU(3,4)=9
25132      NCVALU(4,4)=9
25133      IF(STATVA.GT.CUT90)IVALUE(1,4)='Reject H0'
25134      IF(STATVA.GT.CUT95)IVALUE(2,4)='Reject H0'
25135      IF(STATVA.GT.CUT975)IVALUE(3,4)='Reject H0'
25136      IF(STATVA.GT.CUT99)IVALUE(4,4)='Reject H0'
25137      AMAT(1,3)=RND(CUT90,IDIGIT(3))
25138      AMAT(2,3)=RND(CUT95,IDIGIT(3))
25139      AMAT(3,3)=RND(CUT975,IDIGIT(3))
25140      AMAT(4,3)=RND(CUT99,IDIGIT(3))
25141C
25142      IWHTML(1)=150
25143      IWHTML(2)=150
25144      IWHTML(3)=150
25145      IWHTML(4)=150
25146      IWRTF(1)=1500
25147      IWRTF(2)=IWRTF(1)+1500
25148      IWRTF(3)=IWRTF(2)+2000
25149      IWRTF(4)=IWRTF(3)+2000
25150      IFRST=.FALSE.
25151      ILAST=.TRUE.
25152C
25153      ISTEPN='42E'
25154      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU2')
25155     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25156C
25157      CALL DPDTA4(ITITL9,NCTIT9,
25158     1            ITITLE,NCTITL,ITITL2,NCTIT2,
25159     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
25160     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
25161     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
25162     1            ICAPSW,ICAPTY,IFRST,ILAST,
25163     1            ISUBRO,IBUGA3,IERROR)
25164C
25165      IF(IKRUMC.EQ.'OFF')GOTO9000
25166C
25167      ITITLE(1:26)='Multiple Comparisons Table'
25168      NCTITL=26
25169      ITITL9=' '
25170      NCTIT9=0
25171C
25172      ITITL2(1,1)='I'
25173      NCTIT2(1,1)=1
25174      ITITL2(1,2)='J'
25175      NCTIT2(1,2)=1
25176      ITITL2(1,3)='|Ri/Ni - Rj/Nj|'
25177      NCTIT2(1,3)=15
25178      ITITL2(1,4)='90% CV'
25179      NCTIT2(1,4)=6
25180      ITITL2(1,5)='95% CV'
25181      NCTIT2(1,5)=6
25182      ITITL2(1,6)='99% CV'
25183      NCTIT2(1,6)=6
25184C
25185      NMAX=0
25186      NUMCOL=6
25187      DO4010I=1,NUMCOL
25188        VALIGN(I)='b'
25189        ALIGN(I)='r'
25190        ITYPCO(I)='NUME'
25191        IDIGIT(I)=NUMDIG
25192        NTOT(I)=15
25193        IF(I.EQ.1 .OR. I.EQ.2)THEN
25194          NTOT(I)=5
25195          IDIGIT(I)=0
25196        ELSEIF(I.EQ.3)THEN
25197          NTOT(I)=17
25198        ENDIF
25199        NMAX=NMAX+NTOT(I)
25200 4010 CONTINUE
25201      IWHTML(1)=50
25202      IWHTML(2)=50
25203      IWHTML(3)=150
25204      IWHTML(4)=150
25205      IWHTML(5)=150
25206      IWHTML(6)=150
25207      IINC=1600
25208      IINC2=200
25209      IINC3=1000
25210      IWRTF(1)=IINC2
25211      IWRTF(2)=IWRTF(1)+IINC2
25212      IWRTF(3)=IWRTF(2)+IINC
25213      IWRTF(4)=IWRTF(3)+IINC
25214      IWRTF(5)=IWRTF(4)+IINC
25215      IWRTF(6)=IWRTF(5)+IINC
25216C
25217      ICNT=0
25218      DO4081I=1,NUMDIS
25219        DO4083J=1,NUMDIS
25220          IF(I.LT.J)THEN
25221C
25222            ANI=REAL(NRANK(I))
25223            ANJ=REAL(NRANK(J))
25224            ADIFF=ABS((ARANK(I)/ANI) - (ARANK(J)/ANJ))
25225            AFACT3=SQRT((1.0/ANI) + (1.0/ANJ))
25226            ACV90=AT90*AFACT2*AFACT3
25227            ACV95=AT95*AFACT2*AFACT3
25228            ACV99=AT99*AFACT2*AFACT3
25229C
25230            IF(ICNT.GE.MAXROW)THEN
25231              NUMLIN=1
25232              IFRST=.TRUE.
25233              ILAST=.TRUE.
25234              IFLAGS=.TRUE.
25235              IFLAGE=.TRUE.
25236              CALL DPDTA5(ITITLE,NCTITL,
25237     1                    ITITL9,NCTIT9,ITITL2,NCTIT2,
25238     1                    MAXLIN,NUMLIN,NUMCLI,NUMCOL,
25239     1                    IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
25240     1                    IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
25241     1                    ICAPSW,ICAPTY,IFRST,ILAST,
25242     1                    IFLAGS,IFLAGE,
25243     1                    ISUBRO,IBUGA3,IERROR)
25244              ICNT=0
25245            ENDIF
25246C
25247            ICNT=ICNT+1
25248            IVALUE(ICNT,1)=' '
25249            NCVALU(ICNT,1)=0
25250            AMAT(ICNT,1)=REAL(I)
25251            IVALUE(ICNT,2)=' '
25252            NCVALU(ICNT,2)=0
25253            AMAT(ICNT,2)=REAL(J)
25254            IVALUE(ICNT,3)=' '
25255            NCVALU(ICNT,3)=0
25256            AMAT(ICNT,3)=ADIFF
25257            IVALUE(ICNT,4)=' '
25258            NCVALU(ICNT,4)=0
25259            AMAT(ICNT,4)=ACV90
25260            IVALUE(ICNT,5)=' '
25261            NCVALU(ICNT,5)=0
25262            AMAT(ICNT,5)=ACV95
25263            IVALUE(ICNT,6)=' '
25264            NCVALU(ICNT,6)=0
25265            AMAT(ICNT,6)=ACV99
25266          ENDIF
25267 4083   CONTINUE
25268 4081 CONTINUE
25269C
25270      IF(ICNT.GE.1)THEN
25271        NUMLIN=1
25272        IFRST=.TRUE.
25273        ILAST=.TRUE.
25274        IFLAGS=.TRUE.
25275        IFLAGE=.TRUE.
25276        CALL DPDTA5(ITITLE,NCTITL,
25277     1              ITITL9,NCTIT9,ITITL2,NCTIT2,
25278     1              MAXLIN,NUMLIN,NUMCLI,NUMCOL,
25279     1              IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
25280     1              IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
25281     1              ICAPSW,ICAPTY,IFRST,ILAST,
25282     1              IFLAGS,IFLAGE,
25283     1              ISUBRO,IBUGA3,IERROR)
25284       ENDIF
25285C
25286C               *****************
25287C               **  STEP 90--  **
25288C               **  EXIT       **
25289C               *****************
25290C
25291 9000 CONTINUE
25292      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KRU2')THEN
25293        WRITE(ICOUT,999)
25294        CALL DPWRST('XXX','WRIT')
25295        WRITE(ICOUT,9011)
25296 9011   FORMAT('***** AT THE END       OF DPKRU2--')
25297        CALL DPWRST('XXX','WRIT')
25298        WRITE(ICOUT,9025)STATVA,STATCD
25299 9025   FORMAT('STATVA,STATCD = ',2G15.7)
25300        CALL DPWRST('XXX','WRIT')
25301      ENDIF
25302C
25303      RETURN
25304      END
25305      SUBROUTINE DPKRU3(Y,TAG,N,
25306     1                  DTAG,ARANK,NRANK,MAXNXT,
25307     1                  RTEMP,TEMP1,TEMP2,TEMP3,TEMP4,TEMP5,
25308     1                  STATVA,STATCD,PVAL,NUMDF,NUMDIS,S2,
25309     1                  IKRUGS,
25310     1                  IBUGA3,ISUBRO,IERROR)
25311C
25312C     PURPOSE--THIS ROUTINE CARRIES OUT KRUSKALL-WALLIS'S TEST
25313C              NON-PARAMETRIC ONE-WAY ANOVA
25314C     EXAMPLE--KRUSKALL-WALLIS TEST Y TAG
25315C     REFERENCE--W. J. CONOVER, "PRACTICAL NONPARAMETRIC
25316C                STATISTICS", THIRD EDITION, 1999, WILEY,
25317C                PP. 288-297.
25318C     WRITTEN BY--ALAN HECKERT
25319C                 STATISTICAL ENGINEERING DIVISION
25320C                 INFORMATION TECHNOLOGY LABORATORY
25321C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
25322C                 GAITHERSBURG, MD 20899-8980
25323C                 PHONE--301-975-2899
25324C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25325C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
25326C     LANGUAGE--ANSI FORTRAN (1977)
25327C     VERSION NUMBER--2011/7
25328C     ORIGINAL VERSION--JULY      2011. EXTRACTED FROM DPKRU3 TO ALLOW
25329C                                       IT TO BE CALLED FROM CMPSTA
25330C
25331C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25332C
25333      CHARACTER*4 IKRUGS
25334      CHARACTER*4 ISUBRO
25335      CHARACTER*4 IBUGA3
25336      CHARACTER*4 IERROR
25337C
25338      CHARACTER*4 IWRITE
25339      CHARACTER*4 ISUBN0
25340      CHARACTER*4 ISUBN1
25341      CHARACTER*4 ISUBN2
25342      CHARACTER*4 ISTEPN
25343C
25344      DOUBLE PRECISION DSUM1
25345      DOUBLE PRECISION DSUM2
25346      DOUBLE PRECISION DTERM1
25347C
25348C---------------------------------------------------------------------
25349C
25350      DIMENSION Y(*)
25351      DIMENSION TAG(*)
25352      DIMENSION DTAG(*)
25353      DIMENSION ARANK(*)
25354      DIMENSION NRANK(*)
25355      DIMENSION RTEMP(*)
25356      DIMENSION TEMP1(*)
25357      DIMENSION TEMP2(*)
25358      DIMENSION TEMP3(*)
25359      DIMENSION TEMP4(*)
25360      DIMENSION TEMP5(*)
25361C
25362C---------------------------------------------------------------------
25363C
25364      INCLUDE 'DPCOP2.INC'
25365C
25366C-----START POINT-----------------------------------------------------
25367C
25368      ISUBN1='DPKR'
25369      ISUBN2='U3  '
25370      ISUBN0='    '
25371C
25372      IERROR='NO'
25373      IWRITE='OFF'
25374C
25375      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KRU3')THEN
25376        WRITE(ICOUT,999)
25377  999   FORMAT(1X)
25378        CALL DPWRST('XXX','WRIT')
25379        WRITE(ICOUT,51)
25380   51   FORMAT('**** AT THE BEGINNING OF DPKRU3--')
25381        CALL DPWRST('XXX','WRIT')
25382        WRITE(ICOUT,52)IBUGA3,ISUBRO,N
25383   52   FORMAT('IBUGA3,ISUBRO,N = ',2(A4,2X),I8)
25384        CALL DPWRST('XXX','WRIT')
25385        DO56I=1,N
25386          WRITE(ICOUT,57)I,Y(I),TAG(I)
25387   57     FORMAT('I,Y(I),TAG(I) = ',I8,2G15.7)
25388          CALL DPWRST('XXX','WRIT')
25389   56   CONTINUE
25390      ENDIF
25391C
25392C               ********************************************
25393C               **  STEP 11--                             **
25394C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
25395C               ********************************************
25396C
25397      ISTEPN='11'
25398      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU3')
25399     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25400C
25401      IF(N.LE.1)THEN
25402        WRITE(ICOUT,999)
25403        CALL DPWRST('XXX','WRIT')
25404        WRITE(ICOUT,1111)
25405 1111   FORMAT('***** ERROR IN KRUSKAL-WALLIS TEST--')
25406        CALL DPWRST('XXX','WRIT')
25407        WRITE(ICOUT,1113)
25408 1113   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
25409     1         'VARIABLE IS LESS THAN 2.')
25410        WRITE(ICOUT,1115)N
25411 1115   FORMAT('      THE SAMPLE SIZE = ',I8)
25412        CALL DPWRST('XXX','WRIT')
25413        IERROR='YES'
25414        GOTO9000
25415      ENDIF
25416C
25417      HOLD=Y(1)
25418      DO1135I=2,N
25419        IF(Y(I).NE.HOLD)GOTO1139
25420 1135 CONTINUE
25421      WRITE(ICOUT,999)
25422      CALL DPWRST('XXX','WRIT')
25423      WRITE(ICOUT,1111)
25424      CALL DPWRST('XXX','WRIT')
25425      WRITE(ICOUT,1133)HOLD
25426 1133 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
25427      CALL DPWRST('XXX','WRIT')
25428      GOTO9000
25429 1139 CONTINUE
25430C
25431      HOLD=TAG(1)
25432      DO1235I=2,N
25433        IF(TAG(I).NE.HOLD)GOTO1239
25434 1235 CONTINUE
25435      WRITE(ICOUT,999)
25436      CALL DPWRST('XXX','WRIT')
25437      WRITE(ICOUT,1111)
25438      CALL DPWRST('XXX','WRIT')
25439      WRITE(ICOUT,1231)HOLD
25440 1231 FORMAT('      THE GROUP-ID VARIABLE HAS ALL ELEMENTS = ',G15.7)
25441      CALL DPWRST('XXX','WRIT')
25442      GOTO9000
25443 1239 CONTINUE
25444C
25445C               ********************************
25446C               **  STEP 41--                 **
25447C               **  CARRY OUT CALCULATIONS    **
25448C               **  FOR KRUSKALL-WALLIS TEST  **
25449C               ********************************
25450C
25451      ISTEPN='21'
25452      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU3')
25453     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25454C
25455      CALL SORTC(TAG,Y,N,TAG,TEMP1)
25456      DO2101I=1,N
25457        Y(I)=TEMP1(I)
25458 2101 CONTINUE
25459      CALL DISTIN(TAG,N,IWRITE,DTAG,NUMDIS,IBUGA3,IERROR)
25460      IF(IERROR.EQ.'YES')GOTO9000
25461      CALL RANK(Y,N,IWRITE,RTEMP,TEMP1,MAXNXT,IBUGA3,IERROR)
25462      IF(IERROR.EQ.'YES')GOTO9000
25463C
25464      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU3')THEN
25465        DO4110I=1,N
25466          WRITE(ICOUT,4133)I,TAG(I),Y(I),RTEMP(I)
25467 4133     FORMAT('I,TAG(I),Y(I),RTEMP(I) = ',I8,2X,3G15.7)
25468          CALL DPWRST('XXX','WRIT')
25469 4110   CONTINUE
25470      ENDIF
25471C
25472CCCCC OCTOBER 2004: THE KRUSKAL-WALLIS STATISTIC FOR THE CASE
25473CCCCC WITH NO TIES IS:
25474CCCCC
25475CCCCC    H = [12/(N*(N+1)]*SUM[i=1 to k][R(i)**2/N(i)] - 3*(N+1)
25476CCCCC
25477CCCCC THE FORMULA WITH TIES IS:
25478CCCCC
25479CCCCC    H = (1/S**2)*{SUM[i=1 to k][R(i)**2/N(i) - N*(N+1)**2/4}
25480CCCCC
25481CCCCC GO AHEAD AND USE THE TIES FORMULA SINCE IT IS JUST AS EASY
25482CCCCC AND IT ALSO FACILATES THE COMPUTATION OF MULTIPLE COMPARISONS.
25483C
25484CCCCC AFACT=12.0/(REAL(N)*REAL(N+1))
25485      AN=REAL(N)
25486      AFACT=AN*(AN+1.0)**2/4.0
25487C
25488      DSUM1=0.0D0
25489      DO2190I=1,N
25490        DSUM1=DSUM1 + DBLE(RTEMP(I))**2
25491 2190 CONTINUE
25492      S2=REAL((DSUM1 - DBLE(AFACT))/DBLE(N-1))
25493C
25494      DSUM1=0.0D0
25495      DO2200IDIS=1,NUMDIS
25496         J=0
25497         DSUM2=0.0D0
25498         DO2210I=1,N
25499            IF(TAG(I).EQ.DTAG(IDIS))THEN
25500               J=J+1
25501               DSUM2=DSUM2 + DBLE(RTEMP(I))
25502               IF(IKRUGS.EQ.'ON')TEMP1(J)=Y(I)
25503            ENDIF
25504 2210    CONTINUE
25505         IF(IKRUGS.EQ.'ON')THEN
25506           CALL MEDIAN(TEMP1,J,IWRITE,TEMP5,MAXNXT,YMED,
25507     1                 IBUGA3,IERROR)
25508           CALL MEAN(TEMP1,J,IWRITE,YMEANT,IBUGA3,IERROR)
25509           CALL SD(TEMP1,J,IWRITE,YSD,IBUGA3,IERROR)
25510           TEMP2(IDIS)=YMEANT
25511           TEMP3(IDIS)=YMED
25512           TEMP4(IDIS)=YSD
25513         ENDIF
25514         NRANK(IDIS)=J
25515         ARANK(IDIS)=REAL(DSUM2)
25516         DSUM1=DSUM1 + DSUM2**2/DBLE(NRANK(IDIS))
25517 2200 CONTINUE
25518C
25519      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KRU3')THEN
25520        WRITE(ICOUT,2221)NUMDIS,AFACT,S2
25521 2221   FORMAT('NUMDIS,AFACT,S2 = ',I8,2G15.7)
25522        CALL DPWRST('XXX','WRIT')
25523        DO2220I=1,NUMDIS
25524          WRITE(ICOUT,2223)I,NRANK(I),ARANK(I)
25525 2223     FORMAT('I,NRANK(I),ARANK(I) = ',2I8,2X,G15.7)
25526          CALL DPWRST('XXX','WRIT')
25527 2220   CONTINUE
25528      ENDIF
25529C
25530      DTERM1=DSUM1 - DBLE(AFACT)
25531      STATVA=DTERM1/DBLE(S2)
25532      NUMDF=NUMDIS-1
25533      CALL CHSCDF(STATVA,NUMDF,STATCD)
25534      PVAL=1.0 - STATCD
25535C
25536C               *****************
25537C               **  STEP 90--  **
25538C               **  EXIT       **
25539C               *****************
25540C
25541 9000 CONTINUE
25542      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KRU3')THEN
25543        WRITE(ICOUT,999)
25544        CALL DPWRST('XXX','WRIT')
25545        WRITE(ICOUT,9011)
25546 9011   FORMAT('***** AT THE END       OF DPKRU3--')
25547        CALL DPWRST('XXX','WRIT')
25548        WRITE(ICOUT,9025)STATVA,STATCD,PVAL
25549 9025   FORMAT('STATVA,STATCD,PVAL = ',3G15.7)
25550        CALL DPWRST('XXX','WRIT')
25551      ENDIF
25552C
25553      RETURN
25554      END
25555      SUBROUTINE DPKUO2(Y,X,N,MAXNXT,IKUOTA,
25556     1                  TEMP1,TEMP2,PID,IVARID,IVARI2,NREPL,NLABID,
25557     1                  ICAPSW,ICAPTY,IFORSW,
25558     1                  STATVA,STATCD,PVAL,
25559     1                  CUT80,CUT90,CUT95,
25560     1                  CUT975,CUT99,CUT995,
25561     1                  ISUBRO,IBUGA3,IERROR)
25562C
25563C     PURPOSE--THIS SUBROUTINE COMPUTES AN OUTLIER TEST BASED ON THE
25564C              SAMPLE KURTOSIS.  IF THE SAMPLE KURTOSIS IS ABOVE THE
25565C              CRITICAL VALUE, ASSUME THE OBSERVATION FURTHERST FROM
25566C              THE MEAN IS AN OUTLIER.  THIS TEST CAN BE REPEATED BY
25567C              REMOVING THE OUTLIER AND REPEATING THE TEST UNTIL THE
25568C              TEST INDICATES NO OUTLIER.  THIS TEST ASSUMES NORMALITY.
25569C              THIS ROUTINE ONLY TESTS FOR A SINGLE OUTLIER.  FOR
25570C              MULTIPLE OUTLIERS, THE USER SHOULD DELETE THE CURRENT
25571C              OUTLIER AND REPEAT THE TEST.
25572C
25573C              THIS TEST WAS ADDED TO SUPPORT THE ASTM E-178 STANDARD
25574C              (2016 EDITION).
25575C
25576C              CRITICAL VALUES CAN BE DETERMINED IN THE FOLLOWING
25577C              WAYS:
25578C
25579C                1. TABLES FROM ASTM E178 - 16a
25580C                2. SIMULATION
25581C
25582C     REFERENCE--E178 - 16A (2016), "Standard Practice for Dealing with
25583C                Outlying Observations", ASTM International, 100 Barr
25584C                Harbor Drive, PO BOX C700, West Conshohocken, PA
25585C                19428-2959, USA.
25586C     WRITTEN BY--ALAN HECKERT
25587C                 STATISTICAL ENGINEERING DIVISION
25588C                 INFORMATION TECHNOLOGY LABORATORY
25589C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
25590C                 GAITHERSBURG, MD 20899-8980
25591C                 PHONE--301-975-2899
25592C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25593C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
25594C     LANGUAGE--ANSI FORTRAN (1977)
25595C     VERSION NUMBER--2019/10
25596C     ORIGINAL VERSION--OCTOBER   2019.
25597C
25598C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25599C
25600      CHARACTER*4 ISUBRO
25601      CHARACTER*4 IBUGA3
25602      CHARACTER*4 IERROR
25603      CHARACTER*4 IVARID(*)
25604      CHARACTER*4 IVARI2(*)
25605      CHARACTER*4 ICAPSW
25606      CHARACTER*4 ICAPTY
25607      CHARACTER*4 IFORSW
25608      CHARACTER*4 IKUOTA
25609C
25610      CHARACTER*4 IWRITE
25611      CHARACTER*4 IKUOT2
25612      CHARACTER*4 ISUBN1
25613      CHARACTER*4 ISUBN2
25614      CHARACTER*4 ISTEPN
25615C
25616      REAL ALPHA(6)
25617      REAL CV(6)
25618C
25619      CHARACTER*4 IRTFMD
25620      COMMON/COMRTF/IRTFMD
25621C
25622      PARAMETER(NUMCLI=5)
25623      PARAMETER(MAXLIN=2)
25624      PARAMETER (MAXROW=30)
25625      CHARACTER*60 ITITLE
25626      CHARACTER*60 ITITLZ
25627      CHARACTER*1  ITITL9
25628      CHARACTER*60 ITEXT(MAXROW)
25629      CHARACTER*4  ALIGN(NUMCLI)
25630      CHARACTER*4  VALIGN(NUMCLI)
25631      REAL         AVALUE(MAXROW)
25632      INTEGER      NCTEXT(MAXROW)
25633      INTEGER      IDIGIT(MAXROW)
25634      INTEGER      NTOT(MAXROW)
25635      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
25636      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
25637      CHARACTER*4  ITYPCO(NUMCLI)
25638      INTEGER      NCTIT2(MAXLIN,NUMCLI)
25639      INTEGER      NCVALU(MAXROW,NUMCLI)
25640      INTEGER      IWHTML(NUMCLI)
25641      INTEGER      IWRTF(NUMCLI)
25642      REAL         AMAT(MAXROW,NUMCLI)
25643      LOGICAL IFRST
25644      LOGICAL ILAST
25645      LOGICAL IFLAGA
25646      LOGICAL IFLAGB
25647C
25648C---------------------------------------------------------------------
25649C
25650      DIMENSION Y(*)
25651      DIMENSION X(*)
25652      DIMENSION TEMP1(*)
25653      DIMENSION TEMP2(*)
25654      DIMENSION PID(*)
25655C
25656C---------------------------------------------------------------------
25657C
25658      INCLUDE 'DPCOP2.INC'
25659C
25660C-----START POINT-----------------------------------------------------
25661C
25662      ISUBN1='DPKU'
25663      ISUBN2='O2  '
25664      IERROR='NO'
25665      STATVA=CPUMIN
25666      STATCD=CPUMIN
25667      PVAL=CPUMIN
25668      CUT80=CPUMIN
25669      CUT90=CPUMIN
25670      CUT95=CPUMIN
25671      CUT975=CPUMIN
25672      CUT99=CPUMIN
25673      CUT995=CPUMIN
25674C
25675      IKUOT2=IKUOTA
25676      IF(IKUOTA.EQ.'ASTM' .AND. N.GT.50)IKUOT2='SIMU'
25677      IF(IKUOT2.EQ.'ASTM')THEN
25678        NALPHA=3
25679        ALPHA(1)=90.
25680        ALPHA(2)=95.
25681        ALPHA(3)=99.
25682      ELSE
25683        NALPHA=6
25684        ALPHA(1)=80.
25685        ALPHA(2)=90.
25686        ALPHA(3)=95.
25687        ALPHA(4)=97.5
25688        ALPHA(5)=99.
25689        ALPHA(6)=99.5
25690      ENDIF
25691C
25692      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')THEN
25693        WRITE(ICOUT,999)
25694  999   FORMAT(1X)
25695        CALL DPWRST('XXX','WRIT')
25696        WRITE(ICOUT,51)
25697   51   FORMAT('**** AT THE BEGINNING OF DPKUO2--')
25698        CALL DPWRST('XXX','WRIT')
25699        WRITE(ICOUT,52)ISUBRO,IBUGA3,IKUOTA,N,MAXNXT
25700   52   FORMAT('ISUBRO,IBUGA3,IKUOTA,N,MAXNXT = ',3(A4,2X),2I8)
25701        CALL DPWRST('XXX','WRIT')
25702        DO56I=1,N
25703          WRITE(ICOUT,57)I,Y(I),X(I)
25704   57     FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
25705          CALL DPWRST('XXX','WRIT')
25706   56   CONTINUE
25707      ENDIF
25708C
25709C               ********************************************
25710C               **  STEP 11--                             **
25711C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
25712C               ********************************************
25713C
25714      ISTEPN='11'
25715      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')
25716     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25717C
25718      IF(N.LT.4)THEN
25719        WRITE(ICOUT,999)
25720        CALL DPWRST('XXX','WRIT')
25721        WRITE(ICOUT,1111)
25722 1111   FORMAT('***** ERROR IN KURTOSIS OUTLIER TEST--')
25723        CALL DPWRST('XXX','WRIT')
25724        WRITE(ICOUT,1113)
25725 1113   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN 4.')
25726        CALL DPWRST('XXX','WRIT')
25727        WRITE(ICOUT,1114)N
25728 1114   FORMAT('SAMPLE SIZE = ',I8)
25729        CALL DPWRST('XXX','WRIT')
25730        IERROR='YES'
25731        GOTO9000
25732      ENDIF
25733C
25734      HOLD=Y(1)
25735      DO1135I=2,N
25736        IF(Y(I).NE.HOLD)GOTO1139
25737 1135 CONTINUE
25738      WRITE(ICOUT,999)
25739      CALL DPWRST('XXX','WRIT')
25740      WRITE(ICOUT,1111)
25741      CALL DPWRST('XXX','WRIT')
25742      WRITE(ICOUT,1131)HOLD
25743 1131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
25744      CALL DPWRST('XXX','WRIT')
25745      IERROR='YES'
25746      GOTO9000
25747 1139 CONTINUE
25748C
25749C               ***********************************
25750C               **  STEP 21--                    **
25751C               **  CARRY OUT CALCULATIONS       **
25752C               **  FOR  KURTOSIS OUTLIER  TEST  **
25753C               ***********************************
25754C
25755      ISTEPN='41'
25756      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KUO2')
25757     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25758C
25759      IWRITE='OFF'
25760      CALL DPKUO3(Y,N,TEMP1,TEMP2,IWRITE,PSTAMV,
25761     1            MAXNXT,IKUOT2,ISEED,
25762     1            ALPHA,CV,NALPHA,
25763     1            STATVA,YMEAN,YSD,YMIN,YMAX,YKURT,
25764     1            PVAL,STATCD,YIND,
25765     1            ISUBRO,IBUGA3,IERROR)
25766      IF(IERROR.EQ.'YES')GOTO9000
25767C
25768      IF(IKUOT2.EQ.'ASTM')THEN
25769        CUT90=CV(1)
25770        CUT95=CV(2)
25771        CUT99=CV(3)
25772        NCDF=3
25773      ELSE
25774        CUT80=CV(1)
25775        CUT90=CV(2)
25776        CUT95=CV(3)
25777        CUT975=CV(4)
25778        CUT99=CV(5)
25779        CUT995=CV(6)
25780        NCDF=6
25781      ENDIF
25782C
25783      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')THEN
25784        WRITE(ICOUT,2111)YMEAN,YSD,YKURT
25785 2111   FORMAT('YMEAN,YSD,YKURT=',3G15.7)
25786        CALL DPWRST('XXX','BUG ')
25787        WRITE(ICOUT,2113)STATVA,PVAL,CDF,YIND
25788 2113   FORMAT('STATVA,PVAL,CDF,YIND =',4G15.7)
25789        CALL DPWRST('XXX','BUG ')
25790      ENDIF
25791C
25792C
25793C               *********************************
25794C               **   STEP 42--                 **
25795C               **   WRITE OUT EVERYTHING      **
25796C               **   FOR KURTOSIS OUTLIER TEST **
25797C               *********************************
25798C
25799      ISTEPN='42'
25800      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')
25801     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25802C
25803      IF(IPRINT.EQ.'OFF')GOTO9000
25804C
25805      NUMDIG=7
25806      IF(IFORSW.EQ.'1')NUMDIG=1
25807      IF(IFORSW.EQ.'2')NUMDIG=2
25808      IF(IFORSW.EQ.'3')NUMDIG=3
25809      IF(IFORSW.EQ.'4')NUMDIG=4
25810      IF(IFORSW.EQ.'5')NUMDIG=5
25811      IF(IFORSW.EQ.'6')NUMDIG=6
25812      IF(IFORSW.EQ.'7')NUMDIG=7
25813      IF(IFORSW.EQ.'8')NUMDIG=8
25814      IF(IFORSW.EQ.'9')NUMDIG=9
25815      IF(IFORSW.EQ.'0')NUMDIG=0
25816      IF(IFORSW.EQ.'E')NUMDIG=-2
25817      IF(IFORSW.EQ.'-2')NUMDIG=-2
25818      IF(IFORSW.EQ.'-3')NUMDIG=-3
25819      IF(IFORSW.EQ.'-4')NUMDIG=-4
25820      IF(IFORSW.EQ.'-5')NUMDIG=-5
25821      IF(IFORSW.EQ.'-6')NUMDIG=-6
25822      IF(IFORSW.EQ.'-7')NUMDIG=-7
25823      IF(IFORSW.EQ.'-8')NUMDIG=-8
25824      IF(IFORSW.EQ.'-9')NUMDIG=-9
25825C
25826      ITITLE(1:26)='Kurtosis Test for Outliers'
25827      NCTITL=26
25828      ITITLZ='(Assumption: Normality)'
25829      NCTITZ=23
25830C
25831      ICNT=1
25832      ITEXT(ICNT)=' '
25833      NCTEXT(ICNT)=0
25834      AVALUE(ICNT)=0.0
25835      IDIGIT(ICNT)=-1
25836      ICNT=ICNT+1
25837      ITEXT(ICNT)='Response Variable: '
25838      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
25839      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
25840      NCTEXT(ICNT)=27
25841      AVALUE(ICNT)=0.0
25842      IDIGIT(ICNT)=-1
25843C
25844      IF(NREPL.GT.0)THEN
25845        NRESP=1
25846        IADD=NLABID+NRESP
25847        DO4101I=1,NREPL
25848          ICNT=ICNT+1
25849          ITEMP=I+IADD
25850          ITEXT(ICNT)='Factor Variable  : '
25851          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
25852          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
25853          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
25854          NCTEXT(ICNT)=27
25855          AVALUE(ICNT)=PID(ITEMP)
25856          IDIGIT(ICNT)=NUMDIG
25857 4101   CONTINUE
25858      ENDIF
25859C
25860      ICNT=ICNT+1
25861      ITEXT(ICNT)=' '
25862      NCTEXT(ICNT)=1
25863      AVALUE(ICNT)=0.0
25864      IDIGIT(ICNT)=-1
25865C
25866      ICNT=ICNT+1
25867      ITEXT(ICNT)='H0: The most extreme point is not'
25868      NCTEXT(ICNT)=33
25869      AVALUE(ICNT)=0.0
25870      IDIGIT(ICNT)=-1
25871      ICNT=ICNT+1
25872      ITEXT(ICNT)='    an outlier'
25873      NCTEXT(ICNT)=14
25874      AVALUE(ICNT)=0.0
25875      IDIGIT(ICNT)=-1
25876      AVALUE(ICNT)=0.0
25877      ICNT=ICNT+1
25878      ITEXT(ICNT)='Ha: The most extreme point is not'
25879      NCTEXT(ICNT)=33
25880      IDIGIT(ICNT)=-1
25881      AVALUE(ICNT)=0.0
25882      ICNT=ICNT+1
25883      ITEXT(ICNT)='    an outlier'
25884      NCTEXT(ICNT)=14
25885      IDIGIT(ICNT)=-1
25886      AVALUE(ICNT)=0.0
25887C
25888      IINDX=INT(YIND+0.1)
25889      YEXT=Y(IINDX)
25890      ICNT=ICNT+1
25891      ITEXT(ICNT)='Potential outlier value tested:'
25892      NCTEXT(ICNT)=31
25893      AVALUE(ICNT)=YEXT
25894      IDIGIT(ICNT)=NUMDIG
25895      ICNT=ICNT+1
25896      ITEXT(ICNT)='ID for potential outlier:'
25897      NCTEXT(ICNT)=25
25898      AVALUE(ICNT)=X(INT(YIND))
25899      IDIGIT(ICNT)=0
25900C
25901      ICNT=ICNT+1
25902      ITEXT(ICNT)=' '
25903      NCTEXT(ICNT)=1
25904      AVALUE(ICNT)=0.0
25905      IDIGIT(ICNT)=-1
25906      ICNT=ICNT+1
25907      ITEXT(ICNT)='Summary Statistics:'
25908      NCTEXT(ICNT)=19
25909      AVALUE(ICNT)=0.0
25910      IDIGIT(ICNT)=-1
25911      ICNT=ICNT+1
25912      ITEXT(ICNT)='Number of Observations:'
25913      NCTEXT(ICNT)=23
25914      AVALUE(ICNT)=REAL(N)
25915      IDIGIT(ICNT)=0
25916      ICNT=ICNT+1
25917      ITEXT(ICNT)='Sample Minimum:'
25918      NCTEXT(ICNT)=15
25919      AVALUE(ICNT)=YMIN
25920      IDIGIT(ICNT)=NUMDIG
25921      ICNT=ICNT+1
25922      ITEXT(ICNT)='Sample Maximum:'
25923      NCTEXT(ICNT)=15
25924      AVALUE(ICNT)=YMAX
25925      IDIGIT(ICNT)=NUMDIG
25926      ICNT=ICNT+1
25927      ITEXT(ICNT)='Sample Mean:'
25928      NCTEXT(ICNT)=12
25929      AVALUE(ICNT)=YMEAN
25930      IDIGIT(ICNT)=NUMDIG
25931      ICNT=ICNT+1
25932      ITEXT(ICNT)='Sample SD:'
25933      NCTEXT(ICNT)=10
25934      AVALUE(ICNT)=YSD
25935      IDIGIT(ICNT)=NUMDIG
25936      ICNT=ICNT+1
25937      ITEXT(ICNT)='Sample Kurtosis:'
25938      NCTEXT(ICNT)=16
25939      AVALUE(ICNT)=YKURT
25940      IDIGIT(ICNT)=NUMDIG
25941      ICNT=ICNT+1
25942      ITEXT(ICNT)=' '
25943      NCTEXT(ICNT)=1
25944      AVALUE(ICNT)=0.0
25945      IDIGIT(ICNT)=-1
25946      ICNT=ICNT+1
25947      ITEXT(ICNT)='Kurtosis Outlier Test Statistic Value:'
25948      NCTEXT(ICNT)=38
25949      AVALUE(ICNT)=STATVA
25950      IDIGIT(ICNT)=NUMDIG
25951C
25952CCCCC NOTE: CDF AND P-VALUE ONLY PRINTED IF CRITICAL
25953CCCCC       VALUES DETERMINED FROM SIMUMLATION
25954C
25955      IF(IKUOT2.EQ.'SIMU')THEN
25956        ICNT=ICNT+1
25957        ITEXT(ICNT)='CDF Value:'
25958        NCTEXT(ICNT)=10
25959        AVALUE(ICNT)=STATCD
25960        IDIGIT(ICNT)=NUMDIG
25961        ICNT=ICNT+1
25962        ITEXT(ICNT)='P-Value:'
25963        NCTEXT(ICNT)=7
25964        AVALUE(ICNT)=PVAL
25965        IDIGIT(ICNT)=NUMDIG
25966        ICNT=ICNT+1
25967        ITEXT(ICNT)=' '
25968        NCTEXT(ICNT)=1
25969        AVALUE(ICNT)=0.0
25970        IDIGIT(ICNT)=-1
25971      ENDIF
25972C
25973      NUMROW=ICNT
25974      DO4210I=1,NUMROW
25975        NTOT(I)=15
25976 4210 CONTINUE
25977C
25978      IFRST=.TRUE.
25979      ILAST=.TRUE.
25980C
25981      ISTEPN='42A'
25982      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')
25983     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25984C
25985      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
25986     1            AVALUE,IDIGIT,
25987     1            NTOT,NUMROW,
25988     1            ICAPSW,ICAPTY,ILAST,IFRST,
25989     1            ISUBRO,IBUGA3,IERROR)
25990C
25991      ISTEPN='42B'
25992      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')
25993     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25994C
25995      ISTEPN='42D'
25996      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')
25997     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25998C
25999      ITITL9=' '
26000      NCTIT9=0
26001      ITITLE='Conclusions (Upper 1-Tailed Test)'
26002      NCTITL=33
26003      NUMLIN=1
26004      NUMROW=NCDF
26005      NUMCOL=5
26006      ITITL2(1,1)='Alpha'
26007      ITITL2(1,2)='CDF'
26008      ITITL2(1,3)='Statistic'
26009      ITITL2(1,4)='Critical Value'
26010      ITITL2(1,5)='Conclusion'
26011      NCTIT2(1,1)=5
26012      NCTIT2(1,2)=3
26013      NCTIT2(1,3)=9
26014      NCTIT2(1,4)=14
26015      NCTIT2(1,5)=10
26016C
26017      NMAX=0
26018      DO4321I=1,NUMCOL
26019        VALIGN(I)='b'
26020        ALIGN(I)='r'
26021        NTOT(I)=15
26022        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
26023        IF(I.EQ.4)NTOT(I)=17
26024        NMAX=NMAX+NTOT(I)
26025        IDIGIT(I)=3
26026        ITYPCO(I)='ALPH'
26027 4321 CONTINUE
26028      ITYPCO(3)='NUME'
26029      ITYPCO(4)='NUME'
26030      IDIGIT(1)=0
26031      IDIGIT(2)=0
26032      DO4323I=1,NUMROW
26033        DO4325J=1,NUMCOL
26034          NCVALU(I,J)=0
26035          IVALUE(I,J)=' '
26036          NCVALU(I,J)=0
26037          AMAT(I,J)=0.0
26038 4325   CONTINUE
26039 4323 CONTINUE
26040      IF(IKUOT2.EQ.'ASTM')THEN
26041        IVALUE(1,1)='10%'
26042        IVALUE(2,1)='5%'
26043        IVALUE(3,1)='1%'
26044        IVALUE(1,2)='90%'
26045        IVALUE(2,2)='95%'
26046        IVALUE(3,2)='99%'
26047        NCVALU(1,1)=3
26048        NCVALU(2,1)=2
26049        NCVALU(3,1)=2
26050        NCVALU(1,2)=3
26051        NCVALU(2,2)=3
26052        NCVALU(3,2)=3
26053      ELSE
26054        IVALUE(1,1)='20%'
26055        IVALUE(2,1)='10%'
26056        IVALUE(3,1)='5%'
26057        IVALUE(4,1)='2.5%'
26058        IVALUE(5,1)='1%'
26059        IVALUE(6,1)='0.5%'
26060        IVALUE(1,2)='80%'
26061        IVALUE(2,2)='90%'
26062        IVALUE(3,2)='95%'
26063        IVALUE(4,2)='97.5%'
26064        IVALUE(5,2)='99%'
26065        IVALUE(6,2)='99.5%'
26066        NCVALU(1,1)=3
26067        NCVALU(2,1)=3
26068        NCVALU(3,1)=2
26069        NCVALU(4,1)=4
26070        NCVALU(5,1)=2
26071        NCVALU(6,1)=4
26072        NCVALU(1,2)=3
26073        NCVALU(2,2)=3
26074        NCVALU(3,2)=3
26075        NCVALU(4,2)=5
26076        NCVALU(5,2)=3
26077        NCVALU(6,2)=5
26078      ENDIF
26079      IVALUE(1,5)='Accept H0'
26080      IVALUE(2,5)='Accept H0'
26081      IVALUE(3,5)='Accept H0'
26082      IVALUE(4,5)='Accept H0'
26083      IVALUE(5,5)='Accept H0'
26084      IVALUE(6,5)='Accept H0'
26085      NCVALU(1,5)=9
26086      NCVALU(2,5)=9
26087      NCVALU(3,5)=9
26088      NCVALU(4,5)=9
26089      NCVALU(5,5)=9
26090      NCVALU(6,5)=9
26091      DO4410KK=1,NCDF
26092        AMAT(KK,3)=STATVA
26093        IF(STATVA.GT.CV(KK))IVALUE(KK,5)='Reject H0'
26094CCCC    AMAT(KK,4)=RND(CV(KK),IDIGIT(3))
26095        AMAT(KK,4)=CV(KK)
26096 4410 CONTINUE
26097C
26098      IWHTML(1)=150
26099      IWHTML(2)=150
26100      IWHTML(3)=150
26101      IWHTML(4)=150
26102      IWHTML(5)=150
26103      IWRTF(1)=1500
26104      IWRTF(2)=IWRTF(1)+1500
26105      IWRTF(3)=IWRTF(2)+2000
26106      IWRTF(4)=IWRTF(3)+2000
26107      IWRTF(5)=IWRTF(4)+2000
26108      IFRST=.FALSE.
26109      ILAST=.TRUE.
26110C
26111      ISTEPN='42E'
26112      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')
26113     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26114C
26115      CALL DPDTA4(ITITL9,NCTIT9,
26116     1            ITITLE,NCTITL,ITITL2,NCTIT2,
26117     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
26118     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
26119     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
26120     1            ICAPSW,ICAPTY,IFRST,ILAST,
26121     1            ISUBRO,IBUGA3,IERROR)
26122C
26123      IF(IKUOT2.EQ.'SIMU')THEN
26124        ITITLE='Critical Values Based on 50,000 Simulations'
26125        NCTEMP=43
26126      ELSEIF(IKUOT2.EQ.'ASTM')THEN
26127        ITITLE='Critical Values Based on ASTM E-178 Tables'
26128        NCTEMP=42
26129      ENDIF
26130      IRTFMD='OFF'
26131      IFNTSZ=-1
26132      IFLAGA=.TRUE.
26133      IFLAGB=.TRUE.
26134      ISIZE=-1
26135      NTOTAL=NCTEMP
26136      NBLNK1=2
26137      NBLNK2=1
26138      ITYPE=2
26139      AVAL=CPUMIN
26140      CALL DPDTXT(ITITLE,NCTEMP,AVAL,NUMDIG,
26141     1            NTOTAL,NBLNK1,NBLNK2,IFLAGA,IFLAGB,ISIZE,
26142     1            ICAPSW,ICAPTY,ITYPE,
26143     1            ISUBRO,IBUGA3,IERROR)
26144      ISIZE=-99
26145      IFNTSZ=0
26146C
26147      ISTEPN='42F'
26148      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')
26149     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26150C
26151C               *****************
26152C               **  STEP 90--  **
26153C               **  EXIT       **
26154C               *****************
26155C
26156 9000 CONTINUE
26157      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'KUO2')THEN
26158        WRITE(ICOUT,999)
26159        CALL DPWRST('XXX','WRIT')
26160        WRITE(ICOUT,9011)
26161 9011   FORMAT('***** AT THE END       OF DPKUO2--')
26162        CALL DPWRST('XXX','WRIT')
26163        WRITE(ICOUT,9013)IERROR,STATVA,STATCD,PVAL
26164 9013   FORMAT('IERROR,STATVA,STATCD,PVAL = ',A4,2X,3G15.7)
26165        CALL DPWRST('XXX','WRIT')
26166      ENDIF
26167C
26168      RETURN
26169      END
26170      SUBROUTINE DPKUO3(X,N,TEMP1,TEMP2,IWRITE,PSTAMV,
26171     1                  MAXNXT,IKUOTA,ISEED,
26172     1                  ALPHA,CV,NALPHA,
26173     1                  STATVA,XMEAN,XSD,XMIN,XMAX,XKURT,
26174     1                  PVAL,STATCD,XIND,
26175     1                  ISUBRO,IBUGA3,IERROR)
26176C
26177C     PURPOSE--THIS SUBROUTINE COMPUTES AN OUTLIER TEST BASED ON THE
26178C              SAMPLE KURTOSIS.  IF THE SAMPLE KURTOSIS IS ABOVE THE
26179C              CRITICAL VALUE, ASSUME THE OBSERVATION FURTHERST FROM
26180C              THE MEAN IS AN OUTLIER.  THIS TEST CAN BE REPEATED BY
26181C              REMOVING THE OUTLIER AND REPEATING THE TEST UNTIL THE
26182C              TEST INDICATES NO OUTLIER.  THIS TEST ASSUMES NORMALITY.
26183C              THIS ROUTINE ONLY TESTS FOR A SINGLE OUTLIER.  FOR
26184C              MULTIPLE OUTLIERS, THE USER SHOULD DELETE THE CURRENT
26185C              OUTLIER AND REPEAT THE TEST.
26186C
26187C              THIS TEST WAS ADDED TO SUPPORT THE ASTM E-178 STANDARD
26188C              (2016 EDITION).
26189C
26190C              CRITICAL VALUES CAN BE DETERMINED IN THE FOLLOWING
26191C              WAYS:
26192C
26193C                1. TABLES FROM ASTM E178 - 16a
26194C                2. SIMULATION
26195C
26196C     REFERENCE--E178 - 16A (2016), "Standard Practice for Dealing with
26197C                Outlying Observations", ASTM International, 100 Barr
26198C                Harbor Drive, PO BOX C700, West Conshohocken, PA
26199C                19428-2959, USA.
26200C     INPUT  ARGUMENTS--X      = THE SINGLE PRECISION VECTOR OF
26201C                                (UNSORTED OR SORTED) OBSERVATIONS.
26202C                     --N      = THE INTEGER NUMBER OF OBSERVATIONS
26203C                                IN THE VECTOR X.
26204C     OUTPUT ARGUMENTS--STATVA = THE SINGLE PRECISION VALUE OF THE
26205C                                COMPUTED DAVID STATISTIC.
26206C                     --STATCD = THE SINGLE PRECISION VALUE OF THE
26207C                                COMPUTED CDF OF THE TEST STATISTIC.
26208C                     --PVAL   = THE SINGLE PRECISION VALUE OF THE
26209C                                COMPUTED P-VALUE OF THE TEST STATISTIC.
26210C                     --XIND   = THE SINGLE PRECISION VALUE OF THE
26211C                                COMPUTED INDEX OF THE POTENTIAL
26212C                                OUTLIER.
26213C     OUTPUT--THE COMPUTED SINGLE PRECISION VALUE OF THE STATISTIC.
26214C     RESTRICTIONS--THERE IS NO RESTRICTION ON THE MAXIMUM VALUE
26215C                   OF N FOR THIS SUBROUTINE.
26216C     OTHER DATAPAC   SUBROUTINES NEEDED--SORT, MEAN, SD.
26217C     FORTRAN LIBRARY SUBROUTINES NEEDED--NONE.
26218C     MODE OF INTERNAL OPERATIONS--SINGLE PRECISION.
26219C     LANGUAGE--ANSI FORTRAN (1977)
26220C     WRITTEN BY--ALAN HECKERT
26221C                 STATISTICAL ENGINEERING DIVISION
26222C                 INFORMATION TECHNOLOGY LABORATORY
26223C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
26224C                 GAITHERSBURG, MD 20899-8980
26225C                 PHONE--301-975-2899
26226C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
26227C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
26228C     LANGUAGE--ANSI FORTRAN (1977)
26229C     VERSION NUMBER--2019.10
26230C     ORIGINAL VERSION--OCTOBER   2019.
26231C
26232C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
26233C
26234      CHARACTER*4 IWRITE
26235      CHARACTER*4 IKUOTA
26236      CHARACTER*4 ISUBRO
26237      CHARACTER*4 IBUGA3
26238      CHARACTER*4 IERROR
26239C
26240      CHARACTER*4 IKUOT2
26241      CHARACTER*4 IOP
26242      CHARACTER*4 IDIR
26243      CHARACTER*4 ISUBN1
26244      CHARACTER*4 ISUBN2
26245C
26246C---------------------------------------------------------------------
26247C
26248      DIMENSION X(*)
26249      DIMENSION TEMP1(*)
26250      DIMENSION TEMP2(*)
26251      DIMENSION ALPHA(*)
26252      DIMENSION CV(*)
26253C
26254      REAL LININ3
26255      EXTERNAL LININ3
26256C
26257      DOUBLE PRECISION DN
26258      DOUBLE PRECISION DCORR
26259      DOUBLE PRECISION DFACT
26260      DOUBLE PRECISION DSUM1
26261      DOUBLE PRECISION DENOM
26262C
26263C---------------------------------------------------------------------
26264C
26265      INCLUDE 'DPCOP2.INC'
26266C
26267C-----START POINT-----------------------------------------------------
26268C
26269      ISUBN1='DPKU'
26270      ISUBN2='O3  '
26271      IERROR='NO'
26272      IKUOT2=IKUOTA
26273      IF(IKUOTA.EQ.'ASTM')THEN
26274        IF(N.GT.50)IKUOT2='SIMU'
26275        IF(NALPHA.EQ.1)THEN
26276          ALPT=ALPHA(1)
26277          IF(ALPT.GT.1.0 .AND. ALPT.LT.100.0)ALPT=ALPT/100.0
26278          IF(ALPT.LT.0.5)ALPT=1.0 - ALPT
26279          IF(ALPT.NE.0.90 .AND. ALPT.NE.0.95 .AND.
26280     1       ALPT.NE.0.99)IKUOT2='SIMU'
26281        ENDIF
26282      ENDIF
26283C
26284      STATVA=CPUMIN
26285      XSD=CPUMIN
26286      XMEAN=CPUMIN
26287      XMIN=CPUMIN
26288      XMAX=CPUMIN
26289      XIND=CPUMIN
26290      XKURT=CPUMIN
26291      STATCD=CPUMIN
26292      PVAL=CPUMIN
26293      XIND=0.0
26294C
26295      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KUO3')THEN
26296        WRITE(ICOUT,999)
26297  999   FORMAT(1X)
26298        CALL DPWRST('XXX','BUG ')
26299        WRITE(ICOUT,51)
26300   51   FORMAT('***** AT THE BEGINNING OF DPKUO3--')
26301        CALL DPWRST('XXX','BUG ')
26302        WRITE(ICOUT,52)IBUGA3,ISUBRO,IKUOTA,IKUOT2,ISEED,N
26303   52   FORMAT('IBUGA3,ISUBRO,IKUOTA,IKUOT2,ISEED,N = ',4(A4,2X),2I8)
26304        CALL DPWRST('XXX','BUG ')
26305        WRITE(ICOUT,54)NALPHA,ALPHA(1)
26306   54   FORMAT('NALPHA,ALPHA(1) = ',I5,F10.5)
26307        CALL DPWRST('XXX','BUG ')
26308        DO55I=1,N
26309          WRITE(ICOUT,56)I,X(I)
26310   56     FORMAT('I,X(I) = ',I8,G15.7)
26311          CALL DPWRST('XXX','BUG ')
26312   55   CONTINUE
26313      ENDIF
26314C
26315C               ********************************************
26316C               **  STEP 1--                              **
26317C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
26318C               ********************************************
26319C
26320      AN=N
26321C
26322      IF(N.LT.4)THEN
26323        IERROR='YES'
26324        WRITE(ICOUT,999)
26325        CALL DPWRST('XXX','BUG ')
26326        WRITE(ICOUT,111)
26327  111   FORMAT('***** ERROR IN KURTOSIS OUTLIER TEST STATISTIC--')
26328        CALL DPWRST('XXX','BUG ')
26329        WRITE(ICOUT,112)
26330  112   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
26331     1         'VARIABLE MUST BE AT LEAST 4.')
26332        CALL DPWRST('XXX','BUG ')
26333        WRITE(ICOUT,117)N
26334  117   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8,'.')
26335        CALL DPWRST('XXX','BUG ')
26336        GOTO9000
26337      ENDIF
26338C
26339C               ******************************************
26340C               **  STEP 2--                            **
26341C               **  COMPUTE THE SKEW OUTLIER STATISTIC. **
26342C               ******************************************
26343C
26344      IWRITE='OFF'
26345      CALL SORT(X,N,TEMP1)
26346      XMIN=TEMP1(1)
26347      XMAX=TEMP1(N)
26348      CALL MEAN(X,N,IWRITE,XMEAN,IBUGA3,IERROR)
26349      CALL SD(X,N,IWRITE,XSD,IBUGA3,IERROR)
26350C
26351C     USE DEFINITION OF KURTOSIS GIVEN IN ASTM E-178
26352C
26353C         N*(N+1)*SUM[(X(i)-XBAR)**2]/((N-1)*(N-2)*(N-3)*S**4) -
26354C         3*(N-1)**2/((N-2)*(N-3))
26355C
26356      DN=DBLE(N)
26357      DCORR=3.0D0*(DN - 1.0D0)**2/((DN - 2.0D0)*(DN - 3.0D0))
26358      DFACT=DN*(DN + 1.0D0)/((DN - 1.0D0)*(DN - 2.0D0)*(DN - 3.D0))
26359C
26360      DENOM=DBLE(XSD)**4
26361      DSUM1=0.0D0
26362      DO210II=1,N
26363        DSUM1=DSUM1 + (DBLE(X(II)) - DBLE(XMEAN))**4
26364  210 CONTINUE
26365      XKURT=REAL((DFACT*DSUM1/DENOM) - DCORR)
26366      STATVA=XKURT
26367C
26368      CALL MAXIND(X,N,IWRITE,PSTAMV,XINDMX,ISUBRO,IBUGA3,IERROR)
26369      CALL MININD(X,N,IWRITE,PSTAMV,XINDMN,ISUBRO,IBUGA3,IERROR)
26370      D1=XMEAN - XMIN
26371      D2=XMAX - XMEAN
26372      IF(D1.GT.D2)THEN
26373        XIND=XINDMN
26374      ELSE
26375        XIND=XINDMX
26376      ENDIF
26377C
26378C               *****************************************
26379C               **  STEP 3--                           **
26380C               **  COMPUTE THE CRITICAL VALUES        **
26381C               *****************************************
26382C
26383      IF(IKUOT2.EQ.'SIMU')THEN
26384        IOP='OPEN'
26385        IFLAG1=0
26386        IFLAG2=1
26387        IFLAG3=0
26388        IFLAG4=0
26389        IFLAG5=0
26390        CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
26391     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
26392     1              IBUGA3,ISUBRO,IERROR)
26393        IF(IERROR.EQ.'YES')GOTO9000
26394C
26395        NSIM=50000
26396        DO3200II=1,NSIM
26397          CALL NORRAN(N,ISEED,TEMP2)
26398          CALL MEAN(TEMP2,N,IWRITE,XMEAN2,IBUGA3,IERROR)
26399          CALL SD(TEMP2,N,IWRITE,XSD2,IBUGA3,IERROR)
26400          DENOM=DBLE(XSD2)**4
26401          DSUM1=0.0D0
26402          DO3201JJ=1,N
26403            DSUM1=DSUM1 + (DBLE(TEMP2(JJ)) - DBLE(XMEAN2))**4
26404 3201     CONTINUE
26405          TEMP1(II)=REAL((DFACT*DSUM1/DENOM) - DCORR)
26406          WRITE(IOUNI2,'(E15.7)')TEMP1(II)
26407 3200   CONTINUE
26408C
26409        IOP='CLOS'
26410        CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
26411     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
26412     1              IBUGA3,ISUBRO,IERROR)
26413        IF(IERROR.EQ.'YES')GOTO9000
26414C
26415        CALL SORT(TEMP1,NSIM,TEMP1)
26416C
26417        DO3210II=1,NALPHA
26418          ALPT=ALPHA(II)
26419          IF(ALPT.GT.1.0 .AND. ALPT.LT.100.0)ALPT=ALPT/100.0
26420          IF(ALPT.LE.0.0 .OR. ALPT.GT.1.0)THEN
26421            WRITE(ICOUT,999)
26422            CALL DPWRST('XXX','WRIT')
26423            WRITE(ICOUT,111)
26424            CALL DPWRST('XXX','WRIT')
26425            WRITE(ICOUT,3111)ALPHA(II)
26426 3111       FORMAT('      INVALID VALUE OF ALPHA (',G15.7,'),')
26427            CALL DPWRST('XXX','WRIT')
26428            IERROR='YES'
26429            GOTO9000
26430          ENDIF
26431          IF(ALPT.LT.0.5)ALPT=1.0 - ALPT
26432          P100=100.0*ALPT
26433          CALL PERCEN(P100,TEMP1,NSIM,IWRITE,TEMP2,MAXNXT,
26434     1                XPERC,IBUGA3,IERROR)
26435          CV(II)=XPERC
26436 3210   CONTINUE
26437        IDIR='UPPE'
26438        CALL DPGOF8(TEMP1,NSIM,STATVA,PVAL,IDIR,IBUGA3,ISUBRO,IERROR)
26439        STATCD=1.0 - PVAL
26440      ELSEIF(IKUOT2.EQ.'ASTM')THEN
26441        DO3300II=1,NALPHA
26442          ALPT=ALPHA(II)
26443          IF(ALPT.GT.1.0 .AND. ALPT.LT.100.0)ALPT=ALPT/100.0
26444          IF(ALPT.LE.0.0 .OR. ALPT.GT.1.0)THEN
26445            WRITE(ICOUT,999)
26446            CALL DPWRST('XXX','WRIT')
26447            WRITE(ICOUT,111)
26448            CALL DPWRST('XXX','WRIT')
26449            WRITE(ICOUT,3111)ALPHA(II)
26450            CALL DPWRST('XXX','WRIT')
26451            IERROR='YES'
26452            GOTO9000
26453          ENDIF
26454          IF(ALPT.LT.0.5)ALPT=1.0 - ALPT
26455          IF(ALPT.EQ.0.90)THEN
26456            IF(N.EQ.4)THEN
26457              CV(II)=3.075
26458            ELSEIF(N.EQ.5)THEN
26459              CV(II)=2.772
26460            ELSEIF(N.EQ.6)THEN
26461              CV(II)=2.482
26462            ELSEIF(N.EQ.7)THEN
26463              CV(II)=2.257
26464            ELSEIF(N.EQ.8)THEN
26465              CV(II)=2.067
26466            ELSEIF(N.EQ.9)THEN
26467              CV(II)=1.904
26468            ELSEIF(N.EQ.10)THEN
26469              CV(II)=1.778
26470            ELSEIF(N.EQ.11)THEN
26471              CV(II)=1.678
26472            ELSEIF(N.EQ.12)THEN
26473              CV(II)=1.597
26474            ELSEIF(N.EQ.13)THEN
26475              CV(II)=1.529
26476            ELSEIF(N.EQ.14)THEN
26477              CV(II)=1.471
26478            ELSEIF(N.EQ.15)THEN
26479              CV(II)=1.422
26480            ELSEIF(N.EQ.16)THEN
26481              CV(II)=1.378
26482            ELSEIF(N.EQ.17)THEN
26483              CV(II)=1.340
26484            ELSEIF(N.EQ.18)THEN
26485              CV(II)=1.303
26486            ELSEIF(N.EQ.19)THEN
26487              CV(II)=1.271
26488            ELSEIF(N.EQ.20)THEN
26489              CV(II)=1.243
26490            ELSEIF(N.EQ.21)THEN
26491              CV(II)=1.214
26492            ELSEIF(N.EQ.22)THEN
26493              CV(II)=1.188
26494            ELSEIF(N.EQ.23)THEN
26495              CV(II)=1.167
26496            ELSEIF(N.EQ.24)THEN
26497              CV(II)=1.143
26498            ELSEIF(N.EQ.25)THEN
26499              CV(II)=1.123
26500            ELSEIF(N.EQ.26)THEN
26501              CV(II)=1.102
26502            ELSEIF(N.EQ.27)THEN
26503              CV(II)=1.085
26504            ELSEIF(N.EQ.28)THEN
26505              CV(II)=1.066
26506            ELSEIF(N.EQ.29)THEN
26507              CV(II)=1.052
26508            ELSEIF(N.EQ.30)THEN
26509              CV(II)=1.035
26510            ELSEIF(N.GE.31 .AND. N.LE.34)THEN
26511              X1=30.
26512              X2=35.
26513              X3=REAL(N)
26514              Y1=1.035
26515              Y2=0.969
26516              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26517              CV(II)=AVAL
26518            ELSEIF(N.EQ.35)THEN
26519              CV(II)=0.969
26520            ELSEIF(N.GE.36 .AND. N.LE.39)THEN
26521              X1=35.
26522              X2=40.
26523              X3=REAL(N)
26524              Y1=0.969
26525              Y2=0.913
26526              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26527              CV(II)=AVAL
26528            ELSEIF(N.EQ.40)THEN
26529              CV(II)=0.913
26530            ELSEIF(N.GE.41 .AND. N.LE.44)THEN
26531              X1=40.
26532              X2=45.
26533              X3=REAL(N)
26534              Y1=0.913
26535              Y2=0.867
26536              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26537              CV(II)=AVAL
26538            ELSEIF(N.EQ.45)THEN
26539              CV(II)=0.867
26540            ELSEIF(N.GE.46 .AND. N.LE.49)THEN
26541              X1=45.
26542              X2=50.
26543              X3=REAL(N)
26544              Y1=0.867
26545              Y2=0.830
26546              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26547              CV(II)=AVAL
26548            ELSEIF(N.EQ.50)THEN
26549              CV(II)=0.830
26550            ENDIF
26551          ELSEIF(ALPT.EQ.0.95)THEN
26552            IF(N.EQ.4)THEN
26553              CV(II)=3.518
26554            ELSEIF(N.EQ.5)THEN
26555              CV(II)=3.506
26556            ELSEIF(N.EQ.6)THEN
26557              CV(II)=3.319
26558            ELSEIF(N.EQ.7)THEN
26559              CV(II)=3.110
26560            ELSEIF(N.EQ.8)THEN
26561              CV(II)=2.935
26562            ELSEIF(N.EQ.9)THEN
26563              CV(II)=2.772
26564            ELSEIF(N.EQ.10)THEN
26565              CV(II)=2.627
26566            ELSEIF(N.EQ.11)THEN
26567              CV(II)=2.505
26568            ELSEIF(N.EQ.12)THEN
26569              CV(II)=2.399
26570            ELSEIF(N.EQ.13)THEN
26571              CV(II)=2.300
26572            ELSEIF(N.EQ.14)THEN
26573              CV(II)=2.217
26574            ELSEIF(N.EQ.15)THEN
26575              CV(II)=2.145
26576            ELSEIF(N.EQ.16)THEN
26577              CV(II)=2.081
26578            ELSEIF(N.EQ.17)THEN
26579              CV(II)=2.021
26580            ELSEIF(N.EQ.18)THEN
26581              CV(II)=1.966
26582            ELSEIF(N.EQ.19)THEN
26583              CV(II)=1.921
26584            ELSEIF(N.EQ.20)THEN
26585              CV(II)=1.873
26586            ELSEIF(N.EQ.21)THEN
26587              CV(II)=1.831
26588            ELSEIF(N.EQ.22)THEN
26589              CV(II)=1.788
26590            ELSEIF(N.EQ.23)THEN
26591              CV(II)=1.757
26592            ELSEIF(N.EQ.24)THEN
26593              CV(II)=1.719
26594            ELSEIF(N.EQ.25)THEN
26595              CV(II)=1.690
26596            ELSEIF(N.EQ.26)THEN
26597              CV(II)=1.658
26598            ELSEIF(N.EQ.27)THEN
26599              CV(II)=1.630
26600            ELSEIF(N.EQ.28)THEN
26601              CV(II)=1.601
26602            ELSEIF(N.EQ.29)THEN
26603              CV(II)=1.578
26604            ELSEIF(N.EQ.30)THEN
26605              CV(II)=1.550
26606            ELSEIF(N.GE.31 .AND. N.LE.34)THEN
26607              X1=30.
26608              X2=35.
26609              X3=REAL(N)
26610              Y1=1.550
26611              Y2=1.446
26612              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26613              CV(II)=AVAL
26614            ELSEIF(N.EQ.35)THEN
26615              CV(II)=1.446
26616            ELSEIF(N.GE.36 .AND. N.LE.39)THEN
26617              X1=35.
26618              X2=40.
26619              X3=REAL(N)
26620              Y1=1.446
26621              Y2=1.358
26622              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26623              CV(II)=AVAL
26624            ELSEIF(N.EQ.40)THEN
26625              CV(II)=1.358
26626            ELSEIF(N.GE.41 .AND. N.LE.44)THEN
26627              X1=40.
26628              X2=45.
26629              X3=REAL(N)
26630              Y1=1.358
26631              Y2=1.285
26632              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26633              CV(II)=AVAL
26634            ELSEIF(N.EQ.45)THEN
26635              CV(II)=1.285
26636            ELSEIF(N.GE.46 .AND. N.LE.49)THEN
26637              X1=45.
26638              X2=50.
26639              X3=REAL(N)
26640              Y1=1.285
26641              Y2=1.223
26642              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26643              CV(II)=AVAL
26644            ELSEIF(N.EQ.50)THEN
26645              CV(II)=1.223
26646            ENDIF
26647          ELSEIF(ALPT.EQ.0.99)THEN
26648            IF(N.EQ.4)THEN
26649              CV(II)=3.900
26650            ELSEIF(N.EQ.5)THEN
26651              CV(II)=4.454
26652            ELSEIF(N.EQ.6)THEN
26653              CV(II)=4.685
26654            ELSEIF(N.EQ.7)THEN
26655              CV(II)=4.735
26656            ELSEIF(N.EQ.8)THEN
26657              CV(II)=4.687
26658            ELSEIF(N.EQ.9)THEN
26659              CV(II)=4.586
26660            ELSEIF(N.EQ.10)THEN
26661              CV(II)=4.467
26662            ELSEIF(N.EQ.11)THEN
26663              CV(II)=4.350
26664            ELSEIF(N.EQ.12)THEN
26665              CV(II)=4.234
26666            ELSEIF(N.EQ.13)THEN
26667              CV(II)=4.106
26668            ELSEIF(N.EQ.14)THEN
26669              CV(II)=4.000
26670            ELSEIF(N.EQ.15)THEN
26671              CV(II)=3.887
26672            ELSEIF(N.EQ.16)THEN
26673              CV(II)=3.784
26674            ELSEIF(N.EQ.17)THEN
26675              CV(II)=3.702
26676            ELSEIF(N.EQ.18)THEN
26677              CV(II)=3.605
26678            ELSEIF(N.EQ.19)THEN
26679              CV(II)=3.524
26680            ELSEIF(N.EQ.20)THEN
26681              CV(II)=3.450
26682            ELSEIF(N.EQ.21)THEN
26683              CV(II)=3.370
26684            ELSEIF(N.EQ.22)THEN
26685              CV(II)=3.298
26686            ELSEIF(N.EQ.23)THEN
26687              CV(II)=3.233
26688            ELSEIF(N.EQ.24)THEN
26689              CV(II)=3.169
26690            ELSEIF(N.EQ.25)THEN
26691              CV(II)=3.116
26692            ELSEIF(N.EQ.26)THEN
26693              CV(II)=3.051
26694            ELSEIF(N.EQ.27)THEN
26695              CV(II)=2.995
26696            ELSEIF(N.EQ.28)THEN
26697              CV(II)=2.943
26698            ELSEIF(N.EQ.29)THEN
26699              CV(II)=2.903
26700            ELSEIF(N.EQ.30)THEN
26701              CV(II)=2.845
26702            ELSEIF(N.GE.31 .AND. N.LE.34)THEN
26703              X1=30.
26704              X2=35.
26705              X3=REAL(N)
26706              Y1=2.845
26707              Y2=2.642
26708              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26709              CV(II)=AVAL
26710            ELSEIF(N.EQ.35)THEN
26711              CV(II)=2.642
26712            ELSEIF(N.GE.36 .AND. N.LE.39)THEN
26713              X1=35.
26714              X2=40.
26715              X3=REAL(N)
26716              Y1=2.642
26717              Y2=2.470
26718              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26719              CV(II)=AVAL
26720            ELSEIF(N.EQ.40)THEN
26721              CV(II)=2.470
26722            ELSEIF(N.GE.41 .AND. N.LE.44)THEN
26723              X1=40.
26724              X2=45.
26725              X3=REAL(N)
26726              Y1=2.470
26727              Y2=2.322
26728              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26729              CV(II)=AVAL
26730            ELSEIF(N.EQ.45)THEN
26731              CV(II)=2.322
26732            ELSEIF(N.GE.46 .AND. N.LE.49)THEN
26733              X1=45.
26734              X2=50.
26735              X3=REAL(N)
26736              Y1=2.322
26737              Y2=2.210
26738              AVAL=LININ3(X1,Y1,X2,Y2,X3,IBUGA3,ISUBRO,IERROR)
26739              CV(II)=AVAL
26740            ELSEIF(N.EQ.50)THEN
26741              CV(II)=2.210
26742            ENDIF
26743          ELSE
26744            CV(II)=CPUMIN
26745          ENDIF
26746          IF(CV(II).NE.CPUMIN)CV(II)=CV(II)
26747 3300   CONTINUE
26748      ENDIF
26749C
26750C               *******************************
26751C               **  STEP 3--                 **
26752C               **  WRITE OUT A LINE         **
26753C               **  OF SUMMARY INFORMATION.  **
26754C               *******************************
26755C
26756      IF(IFEEDB.EQ.'ON' .AND. IWRITE.EQ.'ON')THEN
26757        WRITE(ICOUT,999)
26758        CALL DPWRST('XXX','BUG ')
26759        WRITE(ICOUT,811)N,STATVA
26760  811   FORMAT('THE VALUE OF THE KURTOSIS OUTLIER STATISTIC OF THE ',
26761     1         I8,' OBSERVATIONS = ',G15.7)
26762        CALL DPWRST('XXX','BUG ')
26763      ENDIF
26764C
26765C               *****************
26766C               **  STEP 90--  **
26767C               **  EXIT.      **
26768C               *****************
26769C
26770 9000 CONTINUE
26771C
26772      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'KUO3')THEN
26773        WRITE(ICOUT,999)
26774        CALL DPWRST('XXX','BUG ')
26775        WRITE(ICOUT,9011)
26776 9011   FORMAT('***** AT THE END       OF DPKUO3--')
26777        CALL DPWRST('XXX','BUG ')
26778        WRITE(ICOUT,9012)IBUGA3,IERROR
26779 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
26780        CALL DPWRST('XXX','BUG ')
26781        WRITE(ICOUT,9013)N
26782 9013   FORMAT('N = ',I8)
26783        CALL DPWRST('XXX','BUG ')
26784        WRITE(ICOUT,9015)XMIN,XMAX,XMEAN,XSD,XKURT
26785 9015   FORMAT('XMIN,XMAX,XMEAN,XSD,XKURT = ',5G15.7)
26786        CALL DPWRST('XXX','BUG ')
26787        WRITE(ICOUT,9016)STATVA,CDF,PVAL,XIND
26788 9016   FORMAT('STATVA,CDF,PVAL,XIND = ',4G15.7)
26789        CALL DPWRST('XXX','BUG ')
26790      ENDIF
26791C
26792      RETURN
26793      END
26794