1      SUBROUTINE DPBABA(ADEBBA,MAXBAR,ABARBA,
2CCCCC OCTOBER 1993.  ABOVE LINE MODIFIED (DPCOHK.INC NOW INCLUDED
3CCCCC IN THIS ROUTINE, SO NO NEED TO PASS).
4CCCCC SUBROUTINE DPBABA(IHARG,IARGT,ARG,NUMARG,ADEBBA,MAXBAR,ABARBA,
5     1IBUGP2,IFOUND,IERROR)
6C
7C     PURPOSE--DEFINE THE BAR BASES.
8C              THESE ARE LOCATED IN THE VECTOR ABARBA(.).
9C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
10C                     --IARGT  (A  CHARACTER VECTOR)
11C                     --ARG
12C                     --NUMARG
13C                     --ADEBBA
14C                     --MAXBAR
15C                     --IBUGP2 ('ON' OR 'OFF' )
16C     OUTPUT ARGUMENTS--ABARBA (A FLOATING POINT VECTOR)
17C                     --IFOUND ('YES' OR 'NO' )
18C                     --IERROR ('YES' OR 'NO' )
19C     WRITTEN BY--JAMES J. FILLIBEN
20C                 STATISTICAL ENGINEERING DIVISION
21C                 INFORMATION TECHNOLOGY LABORATORY
22C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23C                 GAITHERSBURG, MD 20899-8980
24C                 PHONE--301-975-2855
25C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
26C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
27C     LANGUAGE--ANSI FORTRAN (1977)
28C     VERSION NUMBER--82/7
29C     ORIGINAL VERSION--DECEMBER  1983.
30C     UPDATED         --OCTOBER   1993.  ADD BAR BASE AUTOMATIC Y
31C                                            BAR BASE AUTO DISTINCT Y
32C                                        THESE USEFUL FOR STACKED BARS
33C     UPDATED         --NOVEMBER  1994. DECLARATION OF IBUGQ
34C
35C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
36C
37CCCCC OCTOBER 1993.  COMMENT OUT FOLLOWING 2 LINES
38CCCCC CHARACTER*4 IHARG
39CCCCC CHARACTER*4 IARGT
40C
41      CHARACTER*4 IBUGP2
42      CHARACTER*4 IFOUND
43      CHARACTER*4 IERROR
44C
45      CHARACTER*4 IHOLD1
46C
47      CHARACTER*4 ISUBN1
48      CHARACTER*4 ISUBN2
49      CHARACTER*4 ISTEPN
50CCCCC OCTOBER 1993.  COMMNET OUT FOLLOWING 3 LINES
51CCCCC DIMENSION IHARG(*)
52CCCCC DIMENSION IARGT(*)
53CCCCC DIMENSION ARG(*)
54      DIMENSION ABARBA(*)
55CCCCC OCTOBER 1993.  ADD FOLLOWING SECTION.
56      CHARACTER*4 IHLEFT
57      CHARACTER*4 IHLEF2
58      CHARACTER*4 IHWUSE
59      CHARACTER*4 MESSAG
60      CHARACTER*4 ICASEQ
61      CHARACTER*4 IWRITE
62CCCCC NOVEMBER 1994.  ADD FOLLOWING LINE.
63      CHARACTER*4 IBUGQ
64C
65C
66CCCCC OCTOBER 1993.  ADD FOLLOWING COMMON BLOCKS
67C-----COMMON----------------------------------------------------------
68C
69      INCLUDE 'DPCOPA.INC'
70      INCLUDE 'DPCOHK.INC'
71      INCLUDE 'DPCODA.INC'
72      INCLUDE 'DPCOP2.INC'
73C
74C-----START POINT-----------------------------------------------------
75C
76      IFOUND='NO'
77      IERROR='NO'
78      ISUBN1='DPBA'
79      ISUBN2='BA  '
80C
81      NUMBAR=0
82      IHOLD1='-999'
83      HOLD1=-999.0
84      HOLD2=-999.0
85C
86      IF(IBUGP2.EQ.'OFF')GOTO90
87      WRITE(ICOUT,999)
88  999 FORMAT(1X)
89      CALL DPWRST('XXX','BUG ')
90      WRITE(ICOUT,51)
91   51 FORMAT('***** AT THE BEGINNING OF DPBABA--')
92      CALL DPWRST('XXX','BUG ')
93      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
94   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
95      CALL DPWRST('XXX','BUG ')
96      WRITE(ICOUT,53)MAXBAR,NUMBAR
97   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
98      CALL DPWRST('XXX','BUG ')
99      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
100   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
101      CALL DPWRST('XXX','BUG ')
102      WRITE(ICOUT,55)ADEBBA
103   55 FORMAT('ADEBBA = ',E15.7)
104      CALL DPWRST('XXX','BUG ')
105      WRITE(ICOUT,60)NUMARG
106   60 FORMAT('NUMARG = ',I8)
107      CALL DPWRST('XXX','BUG ')
108      DO65I=1,NUMARG
109      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
110   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
111      CALL DPWRST('XXX','BUG ')
112   65 CONTINUE
113      WRITE(ICOUT,70)ABARBA(1)
114   70 FORMAT('ABARBA(1) = ',E15.7)
115      CALL DPWRST('XXX','BUG ')
116      DO75I=1,10
117      WRITE(ICOUT,76)I,ABARBA(I)
118   76 FORMAT('I,ABARBA(I) = ',I8,2X,E15.7)
119      CALL DPWRST('XXX','BUG ')
120   75 CONTINUE
121   90 CONTINUE
122C
123C               **************************************
124C               **  STEP 1--                        **
125C               **  BRANCH TO THE APPROPRIATE CASE  **
126C               **************************************
127C
128      ISTEPN='1'
129      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
130C
131      IF(NUMARG.LE.0)GOTO9000
132CCCCC OCTOBER 1993.  ADD BAR BASE AUTOMATIC <VAR>
133      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000
134      IF(NUMARG.GE.4.AND.IHARG(3).EQ.'AUTO')GOTO3000
135C
136      IF(NUMARG.EQ.1)GOTO1110
137      IF(NUMARG.EQ.2)GOTO1120
138      IF(NUMARG.EQ.3)GOTO1130
139      GOTO1140
140C
141 1110 CONTINUE
142      GOTO1200
143C
144 1120 CONTINUE
145      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
146      IF(IHARG(2).EQ.'ALL')HOLD1=ADEBBA
147      IF(IHARG(2).EQ.'ALL')GOTO1300
148      GOTO1200
149C
150 1130 CONTINUE
151      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
152      IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3)
153      IF(IHARG(2).EQ.'ALL')GOTO1300
154      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
155      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2)
156      IF(IHARG(3).EQ.'ALL')GOTO1300
157      GOTO1200
158C
159 1140 CONTINUE
160      GOTO1200
161C
162C               *************************************************
163C               **  STEP 2--                                   **
164C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
165C               *************************************************
166C
167 1200 CONTINUE
168      ISTEPN='2'
169      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
170C
171      IF(NUMARG.LE.1)GOTO1210
172      GOTO1220
173C
174 1210 CONTINUE
175      NUMBAR=1
176      ABARBA(1)=ADEBBA
177      GOTO1270
178C
179 1220 CONTINUE
180      NUMBAR=NUMARG-1
181      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
182      DO1225I=1,NUMBAR
183      J=I+1
184      IHOLD1=IHARG(J)
185      HOLD1=ARG(J)
186      HOLD2=HOLD1
187      IF(IHOLD1.EQ.'ON')HOLD2=ADEBBA
188      IF(IHOLD1.EQ.'OFF')HOLD2=ADEBBA
189      IF(IHOLD1.EQ.'AUTO')HOLD2=ADEBBA
190      IF(IHOLD1.EQ.'DEFA')HOLD2=ADEBBA
191      ABARBA(I)=HOLD2
192 1225 CONTINUE
193      GOTO1270
194C
195 1270 CONTINUE
196      IF(IFEEDB.EQ.'OFF')GOTO1279
197      WRITE(ICOUT,999)
198      CALL DPWRST('XXX','BUG ')
199      DO1278I=1,NUMBAR
200      WRITE(ICOUT,1276)I,ABARBA(I)
201 1276 FORMAT('THE BASE OF BAR ',I6,
202     1' HAS JUST BEEN SET TO ',E15.7)
203      CALL DPWRST('XXX','BUG ')
204 1278 CONTINUE
205 1279 CONTINUE
206      IFOUND='YES'
207      GOTO9000
208C
209C               **************************
210C               **  STEP 3--            **
211C               **  TREAT THE ALL CASE  **
212C               **************************
213C
214 1300 CONTINUE
215      ISTEPN='3'
216      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
217C
218      NUMBAR=MAXBAR
219      HOLD2=HOLD1
220      IF(IHOLD1.EQ.'ON')HOLD2=ADEBBA
221      IF(IHOLD1.EQ.'OFF')HOLD2=ADEBBA
222      IF(IHOLD1.EQ.'AUTO')HOLD2=ADEBBA
223      IF(IHOLD1.EQ.'DEFA')HOLD2=ADEBBA
224      DO1315I=1,NUMBAR
225      ABARBA(I)=HOLD2
226 1315 CONTINUE
227      GOTO1370
228C
229 1370 CONTINUE
230      IF(IFEEDB.EQ.'OFF')GOTO1319
231      WRITE(ICOUT,999)
232      CALL DPWRST('XXX','BUG ')
233      I=1
234      WRITE(ICOUT,1316)ABARBA(I)
235 1316 FORMAT('THE BASE OF ALL BARS',
236     1' HAS JUST BEEN SET TO ',E15.7)
237      CALL DPWRST('XXX','BUG ')
238 1319 CONTINUE
239      IFOUND='YES'
240      GOTO9000
241C
242C               ******************************************************
243C               **  STEP 30--                                       **
244C               **  TREAT THE BAR BASE   AUTOMATIC <VARIABLE>   CASE**
245C               ******************************************************
246C
247 3000 CONTINUE
248C
249C               ********************************************
250C               **  STEP 31--                             **
251C               **  CHECK THE VALIDITY OF ARGUMENT 2 (OR 3)**
252C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
253C               ********************************************
254C
255      ISTEPN='31'
256      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
257C
258      IHLEFT=IHARG(3)
259      IHLEF2=IHARG2(3)
260      IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')IHLEFT=IHARG(4)
261      IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')IHLEF2=IHARG2(4)
262      IHWUSE='V'
263      MESSAG='YES'
264      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
265     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
266     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
267      IF(IERROR.EQ.'YES')GOTO9000
268      ICOLL=IVALUE(ILOCV)
269      NLEFT=IN(ILOCV)
270C
271C               *****************************************
272C               **  STEP 32--                          **
273C               **  CHECK TO SEE THE TYPE CASE--       **
274C               **    1) UNQUALIFIED (THAT IS, FULL);  **
275C               **    2) SUBSET/EXCEPT; OR             **
276C               **    3) FOR.                          **
277C               *****************************************
278C
279      ISTEPN='32'
280      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
281C
282      ICASEQ='FULL'
283      ILOCQ=NUMARG+1
284      IF(NUMARG.LT.1)GOTO3290
285      DO3200J=1,NUMARG
286      J1=J
287      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO3210
288      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO3210
289      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO3220
290 3200 CONTINUE
291      GOTO3290
292 3210 CONTINUE
293      ICASEQ='SUBS'
294      ILOCQ=J1
295      GOTO3290
296 3220 CONTINUE
297      ICASEQ='FOR'
298      ILOCQ=J1
299      GOTO3290
300 3290 CONTINUE
301      IF(IBUGP2.EQ.'OFF')GOTO3295
302      WRITE(ICOUT,3291)NUMARG,ILOCQ
303 3291 FORMAT('NUMARG,ILOCQ = ',2I8)
304      CALL DPWRST('XXX','BUG ')
305 3295 CONTINUE
306C
307C               *********************************************
308C               **  STEP 33--                              **
309C               **  TEMPORARILY FORM THE VARIABLE Y(.)     **
310C               **  WHICH WILL HOLD THE RESPONSE VARIABLE. **
311C               **  FORM THIS VARIABLE BY                  **
312C               **  BRANCHING TO THE APPROPRIATE SUBCASE   **
313C               **  (FULL, SUBSET, OR FOR).                **
314C               *********************************************
315C
316      ISTEPN='33'
317      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
318C
319      IF(ICASEQ.EQ.'FULL')GOTO3310
320      IF(ICASEQ.EQ.'SUBS')GOTO3320
321      IF(ICASEQ.EQ.'FOR')GOTO3330
322C
323 3310 CONTINUE
324      DO3315I=1,NLEFT
325      ISUB(I)=1
326 3315 CONTINUE
327      NQ=NLEFT
328      GOTO3350
329C
330 3320 CONTINUE
331      NIOLD=NLEFT
332      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
333      NQ=NIOLD
334      GOTO3350
335C
336 3330 CONTINUE
337      NIOLD=NLEFT
338      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
339     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
340      NQ=NFOR
341      GOTO3350
342C
343 3350 CONTINUE
344      MINN2=1
345      IF(NQ.GE.MINN2)GOTO3360
346      WRITE(ICOUT,999)
347      CALL DPWRST('XXX','BUG ')
348      WRITE(ICOUT,3351)
349 3351 FORMAT('***** ERROR IN DPBABA--')
350      CALL DPWRST('XXX','BUG ')
351      WRITE(ICOUT,3352)
352 3352 FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
353     1'EXTRACTED,')
354      CALL DPWRST('XXX','BUG ')
355      WRITE(ICOUT,3353)IHLEFT,IHLEF2
356 3353 FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
357     1'FROM VARIABLE ',A4,A4)
358      CALL DPWRST('XXX','BUG ')
359      WRITE(ICOUT,3354)
360 3354 FORMAT('      (FOR WHICH BAR BASE DEFINITIONS ')
361      CALL DPWRST('XXX','BUG ')
362      WRITE(ICOUT,3355)
363 3355 FORMAT('      ARE TO BE GENERATED)')
364      CALL DPWRST('XXX','BUG ')
365      WRITE(ICOUT,3356)MINN2
366 3356 FORMAT('      MUST BE ',I8,' OR LARGER;')
367      CALL DPWRST('XXX','BUG ')
368      WRITE(ICOUT,3357)
369 3357 FORMAT('      SUCH WAS NOT THE CASE HERE.')
370      CALL DPWRST('XXX','BUG ')
371      WRITE(ICOUT,3358)
372 3358 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
373      CALL DPWRST('XXX','BUG ')
374      IF(IWIDTH.GE.1)WRITE(ICOUT,3359)(IANS(I),I=1,IWIDTH)
375 3359 FORMAT('      ',80A1)
376      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
377      IERROR='YES'
378      GOTO9000
379C
380 3360 CONTINUE
381      MAXCP1=MAXCOL+1
382      MAXCP2=MAXCOL+2
383      MAXCP3=MAXCOL+3
384      MAXCP4=MAXCOL+4
385      MAXCP5=MAXCOL+5
386      MAXCP6=MAXCOL+6
387      J=0
388      IMAX=NLEFT
389      IF(NQ.LT.NLEFT)IMAX=NQ
390      DO3370I=1,IMAX
391      IF(ISUB(I).EQ.0)GOTO3370
392      J=J+1
393C
394      IJ=MAXN*(ICOLL-1)+I
395      IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ)
396      IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I)
397      IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I)
398      IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I)
399      IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I)
400      IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I)
401      IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I)
402C
403 3370 CONTINUE
404      NS=J
405      NY=J
406C
407C               *****************************************
408C               **  STEP 34--                          **
409C               **  IF HAVE THE FORM--                 **
410C               **  BAR BASE   AUTOMATIC DISTINCT X    **
411C               **  EXTRACT THE DISTINCT VALUES        **
412C               **  FROM THE TARGET VARIABLE Y(.)   .  **
413C               **  STORE THEM IN X(.)   .             **
414C               **  IF HAVE THE FORM--                 **
415C               **  CHARACTERS AUTOMATIC X             **
416C               **  DO NOTHING                         **
417C               *****************************************
418C
419      IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')GOTO3420
420C
421      DO3411I=1,NY
422      X(I)=Y(I)
423 3411 CONTINUE
424      NX=NY
425      GOTO3490
426C
427 3420 CONTINUE
428      IWRITE='OFF'
429      CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR)
430      GOTO3490
431C
432 3490 CONTINUE
433C
434C               ******************************************
435C               **  STEP 36--                           **
436C               **  COPY VALUES IN X(.) TO ABARBA       **
437C               **        MAX NUMBER OF BARS    = 100   **
438C               ******************************************
439C
440      IMAX=NX
441      IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
442      DO3650I=1,IMAX
443      ABARBA(I)=X(I)
444 3650 CONTINUE
445C
446      IF(IFEEDB.EQ.'OFF')GOTO3679
447      WRITE(ICOUT,999)
448      CALL DPWRST('XXX','BUG ')
449      DO3675I=1,IMAX
450      WRITE(ICOUT,3676)I,ABARBA(I)
451 3676 FORMAT('BAR BASE ',I6,' HAS JUST BEEN SET TO ',
452     1E15.7)
453      CALL DPWRST('XXX','BUG ')
454 3675 CONTINUE
455 3679 CONTINUE
456      IFOUND='YES'
457      GOTO9000
458C
459C               *****************
460C               **  STEP 90--  **
461C               **  EXIT       **
462C               *****************
463C
464 9000 CONTINUE
465      IF(IBUGP2.EQ.'OFF')GOTO9090
466      WRITE(ICOUT,9011)
467 9011 FORMAT('***** AT THE END       OF DPBABA--')
468      CALL DPWRST('XXX','BUG ')
469      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
470 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
471      CALL DPWRST('XXX','BUG ')
472      WRITE(ICOUT,9013)MAXBAR,NUMBAR
473 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
474      CALL DPWRST('XXX','BUG ')
475      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
476 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
477      CALL DPWRST('XXX','BUG ')
478      WRITE(ICOUT,9015)ADEBBA
479 9015 FORMAT('ADEBBA = ',E15.7)
480      CALL DPWRST('XXX','BUG ')
481      WRITE(ICOUT,9020)NUMARG
482 9020 FORMAT('NUMARG = ',I8)
483      CALL DPWRST('XXX','BUG ')
484      DO9025I=1,NUMARG
485      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
486 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
487      CALL DPWRST('XXX','BUG ')
488 9025 CONTINUE
489      WRITE(ICOUT,9030)ABARBA(1)
490 9030 FORMAT('ABARBA(1) = ',E15.7)
491      CALL DPWRST('XXX','BUG ')
492      DO9035I=1,10
493      WRITE(ICOUT,9036)I,ABARBA(I)
494 9036 FORMAT('I,ABARBA(I) = ',I8,2X,E15.7)
495      CALL DPWRST('XXX','BUG ')
496 9035 CONTINUE
497 9090 CONTINUE
498C
499      RETURN
500      END
501      SUBROUTINE DPBACL(IHARG,NUMARG,IDEFBK,IBACCO,IFOUND,IERROR)
502C
503C     PURPOSE--DEFINE THE COLOR FOR THE BACKGROUND
504C              (THE REGION WITHIN THE FRAME LINES).
505C              THE COLOR FOR THE BACKGROUND WILL BE PLACED
506C              IN THE HOLLERITH VARIABLE IBACCO.
507C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
508C                     --NUMARG
509C                     --IDEFBK
510C     OUTPUT ARGUMENTS--IBACCO
511C                     --IFOUND ('YES' OR 'NO' )
512C                     --IERROR ('YES' OR 'NO' )
513C     WRITTEN BY--JAMES J. FILLIBEN
514C                 STATISTICAL ENGINEERING DIVISION
515C                 INFORMATION TECHNOLOGY LABORATORY
516C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
517C                 GAITHERSBURG, MD 20899-8980
518C                 PHONE--301-975-2855
519C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
520C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
521C     LANGUAGE--ANSI FORTRAN (1977)
522C     VERSION NUMBER--82/7
523C     ORIGINAL VERSION--SEPTEMBER 1980.
524C     UPDATED         --MAY       1982.
525C
526C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
527C
528      CHARACTER*4 IHARG
529      CHARACTER*4 IDEFBK
530      CHARACTER*4 IBACCO
531      CHARACTER*4 IFOUND
532      CHARACTER*4 IERROR
533C
534C---------------------------------------------------------------------
535C
536      DIMENSION IHARG(*)
537C
538C---------------------------------------------------------------------
539C
540      INCLUDE 'DPCOP2.INC'
541C
542C-----START POINT-----------------------------------------------------
543C
544      IFOUND='NO'
545      IERROR='NO'
546C
547      IF(NUMARG.EQ.0)GOTO1150
548      IF(NUMARG.EQ.1.AND.IHARG(1).EQ.'COLO')GOTO1150
549      GOTO1110
550C
551 1110 CONTINUE
552      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
553      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
554      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
555      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
556      GOTO1160
557C
558 1150 CONTINUE
559      IBACCO=IDEFBK
560      GOTO1180
561C
562 1160 CONTINUE
563      IBACCO=IHARG(NUMARG)
564      GOTO1180
565C
566 1180 CONTINUE
567      IFOUND='YES'
568C
569      IF(IFEEDB.EQ.'OFF')GOTO1189
570      WRITE(ICOUT,999)
571  999 FORMAT(1X)
572      CALL DPWRST('XXX','BUG ')
573      WRITE(ICOUT,1181)IBACCO
574 1181 FORMAT('THE BACKGROUND COLOR HAS JUST BEEN SET TO ',
575     1A4)
576      CALL DPWRST('XXX','BUG ')
577 1189 CONTINUE
578      GOTO1199
579C
580 1199 CONTINUE
581      RETURN
582      END
583      SUBROUTINE DPBACO(IHARG,NUMARG,IDEFBC,MAXBAR,IBARCO,
584     1IBUGP2,IFOUND,IERROR)
585C
586C     PURPOSE--DEFINE THE BAR COLORS.
587C              THESE ARE LOCATED IN THE VECTOR IBARCO(.).
588C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
589C                     --NUMARG
590C                     --IDEFBC
591C                     --MAXBAR
592C                     --IBUGP2 ('ON' OR 'OFF' )
593C     OUTPUT ARGUMENTS--IBARCO (A CHARACTER VECTOR)
594C                     --IFOUND ('YES' OR 'NO' )
595C                     --IERROR ('YES' OR 'NO' )
596C     WRITTEN BY--JAMES J. FILLIBEN
597C                 STATISTICAL ENGINEERING DIVISION
598C                 INFORMATION TECHNOLOGY LABORATORY
599C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
600C                 GAITHERSBURG, MD 20899-8980
601C                 PHONE--301-975-2855
602C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
603C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
604C     LANGUAGE--ANSI FORTRAN (1977)
605C     VERSION NUMBER--82/7
606C     ORIGINAL VERSION--DECEMBER  1983.
607C
608C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
609C
610      CHARACTER*4 IHARG
611      CHARACTER*4 IDEFBC
612      CHARACTER*4 IBARCO
613C
614      CHARACTER*4 IBUGP2
615      CHARACTER*4 IFOUND
616      CHARACTER*4 IERROR
617C
618      CHARACTER*4 IHOLD1
619      CHARACTER*4 IHOLD2
620C
621      CHARACTER*4 ISUBN1
622      CHARACTER*4 ISUBN2
623      CHARACTER*4 ISTEPN
624C
625      DIMENSION IHARG(*)
626      DIMENSION IBARCO(*)
627C
628C---------------------------------------------------------------------
629C
630      INCLUDE 'DPCOP2.INC'
631C
632C-----START POINT-----------------------------------------------------
633C
634      IFOUND='NO'
635      IERROR='NO'
636C
637      NUMBAR=0
638      IHOLD1='-999'
639      IHOLD2='-999'
640C
641      IF(IBUGP2.EQ.'OFF')GOTO90
642      WRITE(ICOUT,999)
643  999 FORMAT(1X)
644      CALL DPWRST('XXX','BUG ')
645      WRITE(ICOUT,51)
646   51 FORMAT('***** AT THE BEGINNING OF DPBACO--')
647      CALL DPWRST('XXX','BUG ')
648      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
649   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
650      CALL DPWRST('XXX','BUG ')
651      WRITE(ICOUT,53)MAXBAR,NUMBAR
652   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
653      CALL DPWRST('XXX','BUG ')
654      WRITE(ICOUT,54)IHOLD1,IHOLD2
655   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
656      CALL DPWRST('XXX','BUG ')
657      WRITE(ICOUT,55)IDEFBC
658   55 FORMAT('IDEFBC = ',A4)
659      CALL DPWRST('XXX','BUG ')
660      WRITE(ICOUT,60)NUMARG
661   60 FORMAT('NUMARG = ',I8)
662      CALL DPWRST('XXX','BUG ')
663      DO65I=1,NUMARG
664      WRITE(ICOUT,66)IHARG(I)
665   66 FORMAT('IHARG(I) = ',A4)
666      CALL DPWRST('XXX','BUG ')
667   65 CONTINUE
668      WRITE(ICOUT,70)IBARCO(1)
669   70 FORMAT('IBARCO(1) = ',A4)
670      CALL DPWRST('XXX','BUG ')
671      DO75I=1,10
672      WRITE(ICOUT,76)I,IBARCO(I)
673   76 FORMAT('I,IBARCO(I) = ',I8,2X,A4)
674      CALL DPWRST('XXX','BUG ')
675   75 CONTINUE
676   90 CONTINUE
677C
678C               **************************************
679C               **  STEP 1--                        **
680C               **  BRANCH TO THE APPROPRIATE CASE  **
681C               **************************************
682C
683      ISTEPN='1'
684      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
685C
686      IF(NUMARG.LE.0)GOTO9000
687      IF(NUMARG.EQ.1)GOTO1110
688      IF(NUMARG.EQ.2)GOTO1120
689      IF(NUMARG.EQ.3)GOTO1130
690      GOTO1140
691C
692 1110 CONTINUE
693      GOTO1200
694C
695 1120 CONTINUE
696      IF(IHARG(2).EQ.'ALL')IHOLD1=IDEFBC
697      IF(IHARG(2).EQ.'ALL')GOTO1300
698      GOTO1200
699C
700 1130 CONTINUE
701      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
702      IF(IHARG(2).EQ.'ALL')GOTO1300
703      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
704      IF(IHARG(3).EQ.'ALL')GOTO1300
705      GOTO1200
706C
707 1140 CONTINUE
708      GOTO1200
709C
710C               *************************************************
711C               **  STEP 2--                                   **
712C               **  TREAT THE INDIVIDUAL SPECIFICATIONS CASE  **
713C               *************************************************
714C
715 1200 CONTINUE
716      ISTEPN='2'
717      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
718C
719      IF(NUMARG.LE.1)GOTO1210
720      GOTO1220
721C
722 1210 CONTINUE
723      NUMBAR=1
724      IBARCO(1)=IDEFBC
725      GOTO1270
726C
727 1220 CONTINUE
728      NUMBAR=NUMARG-1
729      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
730      DO1225I=1,NUMBAR
731      J=I+1
732      IHOLD1=IHARG(J)
733      IHOLD2=IHOLD1
734      IF(IHOLD1.EQ.'ON')IHOLD2=IDEFBC
735      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFBC
736      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFBC
737      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFBC
738      IBARCO(I)=IHOLD2
739 1225 CONTINUE
740      GOTO1270
741C
742 1270 CONTINUE
743      IF(IFEEDB.EQ.'OFF')GOTO1279
744      WRITE(ICOUT,999)
745      CALL DPWRST('XXX','BUG ')
746      DO1278I=1,NUMBAR
747      WRITE(ICOUT,1276)I,IBARCO(I)
748 1276 FORMAT('BAR (LINE) COLOR ',I6,' HAS JUST BEEN SET TO ',
749     1A4)
750      CALL DPWRST('XXX','BUG ')
751 1278 CONTINUE
752 1279 CONTINUE
753      IFOUND='YES'
754      GOTO9000
755C
756C               **************************
757C               **  STEP 2--            **
758C               **  TREAT THE ALL CASE  **
759C               **************************
760C
761 1300 CONTINUE
762      ISTEPN='3'
763      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
764C
765      NUMBAR=MAXBAR
766      IHOLD2=IHOLD1
767      IF(IHOLD1.EQ.'ON')IHOLD2=IDEFBC
768      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEFBC
769      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEFBC
770      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEFBC
771      DO1315I=1,NUMBAR
772      IBARCO(I)=IHOLD2
773 1315 CONTINUE
774      GOTO1370
775C
776 1370 CONTINUE
777      IF(IFEEDB.EQ.'OFF')GOTO1319
778      WRITE(ICOUT,999)
779      CALL DPWRST('XXX','BUG ')
780      I=1
781      WRITE(ICOUT,1316)IBARCO(I)
782 1316 FORMAT('ALL BAR (LINE) COLORS HAVE JUST BEEN SET TO ',
783     1A4)
784      CALL DPWRST('XXX','BUG ')
785 1319 CONTINUE
786      IFOUND='YES'
787      GOTO9000
788C
789C               *****************
790C               **  STEP 90--  **
791C               **  EXIT       **
792C               *****************
793C
794 9000 CONTINUE
795      IF(IBUGP2.EQ.'OFF')GOTO9090
796      WRITE(ICOUT,9011)
797 9011 FORMAT('***** AT THE END       OF DPBACO--')
798      CALL DPWRST('XXX','BUG ')
799      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
800 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
801      CALL DPWRST('XXX','BUG ')
802      WRITE(ICOUT,9013)MAXBAR,NUMBAR
803 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
804      CALL DPWRST('XXX','BUG ')
805      WRITE(ICOUT,9014)IHOLD1,IHOLD2
806 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
807      CALL DPWRST('XXX','BUG ')
808      WRITE(ICOUT,9015)IDEFBC
809 9015 FORMAT('IDEFBC = ',A4)
810      CALL DPWRST('XXX','BUG ')
811      WRITE(ICOUT,9020)NUMARG
812 9020 FORMAT('NUMARG = ',I8)
813      CALL DPWRST('XXX','BUG ')
814      DO9025I=1,NUMARG
815      WRITE(ICOUT,9026)IHARG(I)
816 9026 FORMAT('IHARG(I) = ',A4)
817      CALL DPWRST('XXX','BUG ')
818 9025 CONTINUE
819      WRITE(ICOUT,9030)IBARCO(1)
820 9030 FORMAT('IBARCO(1) = ',A4)
821      CALL DPWRST('XXX','BUG ')
822      DO9035I=1,10
823      WRITE(ICOUT,9036)I,IBARCO(I)
824 9036 FORMAT('I,IBARCO(I) = ',I8,2X,A4)
825      CALL DPWRST('XXX','BUG ')
826 9035 CONTINUE
827 9090 CONTINUE
828C
829      RETURN
830      END
831      SUBROUTINE DPBADI(IHARG,NUMARG,IDEBDI,MAXBAR,IBARDI,
832     1IBUGP2,IFOUND,IERROR)
833C
834C     PURPOSE--DEFINE THE BAR DIRECTION--
835C              VERT = VERTICAL
836C              HORI = HORIZONTAL
837C              HOR2 = HORIZONTAL TOWARD X2-X3 PLANE (FOR 3D PLOTS)
838C              THESE ARE LOCATED IN THE VECTOR IBARDI(.).
839C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
840C                     --NUMARG
841C                     --IDEBDI
842C                     --MAXBAR
843C                     --IBUGP2 ('ON' OR 'OFF' )
844C     OUTPUT ARGUMENTS--IBARDI (A CHARACTER VECTOR)
845C                     --IFOUND ('YES' OR 'NO' )
846C                     --IERROR ('YES' OR 'NO' )
847C     WRITTEN BY--JAMES J. FILLIBEN
848C                 STATISTICAL ENGINEERING DIVISION
849C                 INFORMATION TECHNOLOGY LABORATORY
850C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
851C                 GAITHERSBURG, MD 20899-8980
852C                 PHONE--301-975-2855
853C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
854C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
855C     LANGUAGE--ANSI FORTRAN (1977)
856C     VERSION NUMBER--87/5
857C     ORIGINAL VERSION--MAY       1987.
858C
859C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
860C
861      CHARACTER*4 IHARG
862      CHARACTER*4 IDEBDI
863      CHARACTER*4 IBARDI
864C
865      CHARACTER*4 IBUGP2
866      CHARACTER*4 IFOUND
867      CHARACTER*4 IERROR
868C
869      CHARACTER*4 IHOLD1
870      CHARACTER*4 IHOLD2
871C
872      CHARACTER*4 ISUBN1
873      CHARACTER*4 ISUBN2
874      CHARACTER*4 ISTEPN
875C
876      DIMENSION IHARG(*)
877      DIMENSION IBARDI(*)
878C
879C---------------------------------------------------------------------
880C
881      INCLUDE 'DPCOP2.INC'
882C
883C-----START POINT-----------------------------------------------------
884C
885      IFOUND='NO'
886      IERROR='NO'
887C
888      ISUBN1='DPBA'
889      ISUBN2='DI  '
890C
891      NUMBAR=0
892      IHOLD1='-999'
893      IHOLD2='-999'
894C
895      IF(IBUGP2.EQ.'OFF')GOTO90
896      WRITE(ICOUT,999)
897  999 FORMAT(1X)
898      CALL DPWRST('XXX','BUG ')
899      WRITE(ICOUT,51)
900   51 FORMAT('***** AT THE BEGINNING OF DPBADI--')
901      CALL DPWRST('XXX','BUG ')
902      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
903   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
904      CALL DPWRST('XXX','BUG ')
905      WRITE(ICOUT,53)MAXBAR,NUMBAR
906   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
907      CALL DPWRST('XXX','BUG ')
908      WRITE(ICOUT,54)IHOLD1,IHOLD2
909   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
910      CALL DPWRST('XXX','BUG ')
911      WRITE(ICOUT,55)IDEBDI
912   55 FORMAT('IDEBDI = ',A4)
913      CALL DPWRST('XXX','BUG ')
914      WRITE(ICOUT,60)NUMARG
915   60 FORMAT('NUMARG = ',I8)
916      CALL DPWRST('XXX','BUG ')
917      DO65I=1,NUMARG
918      WRITE(ICOUT,66)IHARG(I)
919   66 FORMAT('IHARG(I) = ',A4)
920      CALL DPWRST('XXX','BUG ')
921   65 CONTINUE
922      WRITE(ICOUT,70)IBARDI(1)
923   70 FORMAT('IBARDI(1) = ',A4)
924      CALL DPWRST('XXX','BUG ')
925      DO75I=1,10
926      WRITE(ICOUT,76)I,IBARDI(I)
927   76 FORMAT('I,IBARDI(I) = ',I8,2X,A4)
928      CALL DPWRST('XXX','BUG ')
929   75 CONTINUE
930   90 CONTINUE
931C
932C               **************************************
933C               **  STEP 1--                        **
934C               **  BRANCH TO THE APPROPRIATE CASE  **
935C               **************************************
936C
937      ISTEPN='1'
938      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
939C
940      IF(NUMARG.LE.0)GOTO9000
941      IF(NUMARG.EQ.1)GOTO1110
942      IF(NUMARG.EQ.2)GOTO1120
943      IF(NUMARG.EQ.3)GOTO1130
944      GOTO1140
945C
946 1110 CONTINUE
947      GOTO1200
948C
949 1120 CONTINUE
950      IF(IHARG(2).EQ.'ALL')IHOLD1='VERT'
951      IF(IHARG(2).EQ.'ALL')GOTO1300
952      GOTO1200
953C
954 1130 CONTINUE
955      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
956      IF(IHARG(2).EQ.'ALL')GOTO1300
957      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
958      IF(IHARG(3).EQ.'ALL')GOTO1300
959      GOTO1200
960C
961 1140 CONTINUE
962      GOTO1200
963C
964C               *************************************************
965C               **  STEP 2--                                   **
966C               **  TREAT THE SINGLE     SPECIFICATION   CASE  **
967C               *************************************************
968C
969 1200 CONTINUE
970      ISTEPN='2'
971      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
972C
973      IF(NUMARG.LE.1)GOTO1210
974      GOTO1220
975C
976 1210 CONTINUE
977      NUMBAR=1
978      IBARDI(1)='VERT'
979      GOTO1270
980C
981 1220 CONTINUE
982      NUMBAR=NUMARG-1
983      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
984      DO1225I=1,NUMBAR
985      J=I+1
986      IHOLD1=IHARG(J)
987      IHOLD2=IHOLD1
988C???? IF(IHOLD1.EQ.'VERT')IHOLD2='VERT'
989C???? IF(IHOLD1.EQ.'3')IHOLD2='3'
990CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBDI
991CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBDI
992      IBARDI(I)=IHOLD2
993 1225 CONTINUE
994      GOTO1270
995C
996 1270 CONTINUE
997      IF(IFEEDB.EQ.'OFF')GOTO1279
998      WRITE(ICOUT,999)
999      CALL DPWRST('XXX','BUG ')
1000      DO1278I=1,NUMBAR
1001      WRITE(ICOUT,1276)I,IBARDI(I)
1002 1276 FORMAT('BAR DIRECTION ',I6,
1003     1' HAS JUST BEEN SET TO ',A4)
1004      CALL DPWRST('XXX','BUG ')
1005 1278 CONTINUE
1006 1279 CONTINUE
1007      IFOUND='YES'
1008      GOTO9000
1009C
1010C               **************************
1011C               **  STEP 3--            **
1012C               **  TREAT THE ALL CASE  **
1013C               **************************
1014C
1015 1300 CONTINUE
1016      ISTEPN='3'
1017      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1018C
1019      NUMBAR=MAXBAR
1020      IHOLD2=IHOLD1
1021C???? IF(IHOLD1.EQ.'2')IHOLD2='2'
1022C???? IF(IHOLD1.EQ.'3')IHOLD2='3'
1023CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBDI
1024CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBDI
1025      DO1315I=1,NUMBAR
1026      IBARDI(I)=IHOLD2
1027 1315 CONTINUE
1028      GOTO1370
1029C
1030 1370 CONTINUE
1031      IF(IFEEDB.EQ.'OFF')GOTO1319
1032      WRITE(ICOUT,999)
1033      CALL DPWRST('XXX','BUG ')
1034      I=1
1035      WRITE(ICOUT,1316)IBARDI(I)
1036 1316 FORMAT('ALL BAR DIRECTIONS',
1037     1'HAVE JUST BEEN SET TO ',A4)
1038      CALL DPWRST('XXX','BUG ')
1039 1319 CONTINUE
1040      IFOUND='YES'
1041      GOTO9000
1042C
1043C               *****************
1044C               **  STEP 90--  **
1045C               **  EXIT       **
1046C               *****************
1047C
1048 9000 CONTINUE
1049      IF(IBUGP2.EQ.'OFF')GOTO9090
1050      WRITE(ICOUT,9011)
1051 9011 FORMAT('***** AT THE END       OF DPBADI--')
1052      CALL DPWRST('XXX','BUG ')
1053      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
1054 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
1055      CALL DPWRST('XXX','BUG ')
1056      WRITE(ICOUT,9013)MAXBAR,NUMBAR
1057 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
1058      CALL DPWRST('XXX','BUG ')
1059      WRITE(ICOUT,9014)IHOLD1,IHOLD2
1060 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
1061      CALL DPWRST('XXX','BUG ')
1062      WRITE(ICOUT,9015)IDEBDI
1063 9015 FORMAT('IDEBDI = ',A4)
1064      CALL DPWRST('XXX','BUG ')
1065      WRITE(ICOUT,9020)NUMARG
1066 9020 FORMAT('NUMARG = ',I8)
1067      CALL DPWRST('XXX','BUG ')
1068      DO9025I=1,NUMARG
1069      WRITE(ICOUT,9026)IHARG(I)
1070 9026 FORMAT('IHARG(I) = ',A4)
1071      CALL DPWRST('XXX','BUG ')
1072 9025 CONTINUE
1073      WRITE(ICOUT,9030)IBARDI(1)
1074 9030 FORMAT('IBARDI(1) = ',A4)
1075      CALL DPWRST('XXX','BUG ')
1076      DO9035I=1,10
1077      WRITE(ICOUT,9036)I,IBARDI(I)
1078 9036 FORMAT('I,IBARDI(I) = ',I8,2X,A4)
1079      CALL DPWRST('XXX','BUG ')
1080 9035 CONTINUE
1081 9090 CONTINUE
1082C
1083      RETURN
1084      END
1085      SUBROUTINE DPBAEF(IHARG,IARGT,ARG,NUMARG,BARHEF,BARWEF,
1086     1IBUGP2,IFOUND,IERROR)
1087C
1088C     PURPOSE--DEFINE BAR EXPANSION FACTORS
1089C              FOR THE HEIGHT AND WIDTH OF BARS IN BLOCK PLOTS (ONLY)
1090C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
1091C                     --IARGT  (A  CHARACTER VECTOR)
1092C                     --ARG
1093C                     --NUMARG
1094C                     --IBUGP2 ('ON' OR 'OFF' )
1095C     OUTPUT ARGUMENTS--BARHEF = BAR HEIGHT EXPANSION FACTOR
1096C                     --BARWEF = BAR WIDTH EXPANSION FACTOR
1097C                     --IFOUND ('YES' OR 'NO' )
1098C                     --IERROR ('YES' OR 'NO' )
1099C     WRITTEN BY--JAMES J. FILLIBEN
1100C                 NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY
1101C                 GAITHERSBURG, MARYLAND 20899
1102C                 PHONE--301-975-2855
1103C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1104C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1105C     LANGUAGE--ANSI FORTRAN (1977)
1106C     ORIGINAL VERSION--APRIL     1992.
1107C
1108C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1109C
1110      CHARACTER*4 IHARG
1111      CHARACTER*4 IARGT
1112C
1113      CHARACTER*4 IBUGP2
1114      CHARACTER*4 IFOUND
1115      CHARACTER*4 IERROR
1116C
1117      CHARACTER*4 ISUBN1
1118      CHARACTER*4 ISUBN2
1119      CHARACTER*4 ISTEPN
1120C
1121      DIMENSION IHARG(*)
1122      DIMENSION IARGT(*)
1123      DIMENSION ARG(*)
1124C
1125C---------------------------------------------------------------------
1126C
1127      INCLUDE 'DPCOP2.INC'
1128C
1129C-----START POINT-----------------------------------------------------
1130C
1131      IFOUND='NO'
1132      IERROR='NO'
1133C
1134      ISUBN1='DPBA'
1135      ISUBN2='EF  '
1136C
1137      IF(IBUGP2.EQ.'OFF')GOTO90
1138      WRITE(ICOUT,999)
1139  999 FORMAT(1X)
1140      CALL DPWRST('XXX','BUG ')
1141      WRITE(ICOUT,51)
1142   51 FORMAT('***** AT THE BEGINNING OF DPBAEF--')
1143      CALL DPWRST('XXX','BUG ')
1144      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
1145   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
1146      CALL DPWRST('XXX','BUG ')
1147      WRITE(ICOUT,60)NUMARG
1148   60 FORMAT('NUMARG = ',I8)
1149      CALL DPWRST('XXX','BUG ')
1150      DO65I=1,NUMARG
1151      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
1152   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
1153      CALL DPWRST('XXX','BUG ')
1154   65 CONTINUE
1155      WRITE(ICOUT,70)BARHEF,BARWEF
1156   70 FORMAT('BARHEF,BARWEF = ',2E15.7)
1157      CALL DPWRST('XXX','BUG ')
1158   90 CONTINUE
1159C
1160C               **************************************
1161C               **  STEP 1--                        **
1162C               **  BRANCH TO THE APPROPRIATE CASE  **
1163C               **************************************
1164C
1165      ISTEPN='1'
1166      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1167C
1168      IF(NUMARG.GE.1)THEN
1169         IF(IHARG(NUMARG).EQ.'ON')GOTO1100
1170         IF(IHARG(NUMARG).EQ.'OFF')GOTO1100
1171         IF(IHARG(NUMARG).EQ.'AUTO')GOTO1100
1172         IF(IHARG(NUMARG).EQ.'DEFA')GOTO1100
1173      ENDIF
1174      GOTO1900
1175 1100 CONTINUE
1176      BARHEF=1.0
1177      BARWEF=1.0
1178      GOTO8000
1179 1900 CONTINUE
1180C
1181      IF(NUMARG.EQ.1)THEN
1182         BARHEF=1.0
1183         BARWEF=1.0
1184         GOTO8000
1185      ENDIF
1186C
1187      IF(NUMARG.GE.2)THEN
1188         IF(IARGT(NUMARG-1).EQ.'NUMB'.AND.IARGT(NUMARG).EQ.'NUMB')THEN
1189            BARHEF=ARG(NUMARG-1)
1190            BARWEF=ARG(NUMARG)
1191            GOTO8000
1192         ELSE
1193            WRITE(ICOUT,999)
1194      CALL DPWRST('XXX','BUG ')
1195            WRITE(ICOUT,1041)
1196 1041       FORMAT('***** ERROR IN DPBAEF--')
1197      CALL DPWRST('XXX','BUG ')
1198            WRITE(ICOUT,1042)
1199 1042       FORMAT('      THE LAST 2 ARGUMENTS OF THE ')
1200      CALL DPWRST('XXX','BUG ')
1201            WRITE(ICOUT,1043)
1202 1043       FORMAT('      BAR EXPANSION FACTORS     COMMAND')
1203      CALL DPWRST('XXX','BUG ')
1204            WRITE(ICOUT,1044)
1205 1044       FORMAT('      MUST BE NUMBERS.')
1206      CALL DPWRST('XXX','BUG ')
1207            WRITE(ICOUT,1045)
1208 1045       FORMAT('      SUCH WAS NOT THE CASE HERE')
1209      CALL DPWRST('XXX','BUG ')
1210            WRITE(ICOUT,1046)
1211 1046       FORMAT('      EXAMPLE--BAR EXPANSION FACTORS 1.1 0.8')
1212      CALL DPWRST('XXX','BUG ')
1213            IERROR='YES'
1214            GOTO9000
1215         ENDIF
1216      ENDIF
1217C
1218 8000 CONTINUE
1219      IF(IFEEDB.EQ.'OFF')GOTO8090
1220      WRITE(ICOUT,999)
1221      CALL DPWRST('XXX','BUG ')
1222      WRITE(ICOUT,8011)
1223 8011 FORMAT('THE BAR EXPANSION FACTORS (HEIGHT & WIDTH)')
1224      CALL DPWRST('XXX','BUG ')
1225      WRITE(ICOUT,8012)
1226 8012 FORMAT('(FOR BLOCK PLOTS ONLY)')
1227      CALL DPWRST('XXX','BUG ')
1228      WRITE(ICOUT,8013)BARHEF,BARWEF
1229 8013 FORMAT('HAVE JUST BEEN SET TO ',E15.7,E15.7)
1230      CALL DPWRST('XXX','BUG ')
1231 8090 CONTINUE
1232      IFOUND='YES'
1233      GOTO9000
1234C
1235C               *****************
1236C               **  STEP 90--  **
1237C               **  EXIT       **
1238C               *****************
1239C
1240 9000 CONTINUE
1241      IF(IBUGP2.EQ.'OFF')GOTO9090
1242      WRITE(ICOUT,9011)
1243 9011 FORMAT('***** AT THE END       OF DPBAEF--')
1244      CALL DPWRST('XXX','BUG ')
1245      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
1246 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
1247      CALL DPWRST('XXX','BUG ')
1248      WRITE(ICOUT,9020)NUMARG
1249 9020 FORMAT('NUMARG = ',I8)
1250      CALL DPWRST('XXX','BUG ')
1251      DO9030I=1,NUMARG
1252      WRITE(ICOUT,9031)IHARG(I),IARGT(I),ARG(I)
1253 9031 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
1254      CALL DPWRST('XXX','BUG ')
1255 9030 CONTINUE
1256      WRITE(ICOUT,9041)BARHEF,BARWEF
1257 9041 FORMAT('BARHEF,BARWEF = ',2E15.7)
1258      CALL DPWRST('XXX','BUG ')
1259 9090 CONTINUE
1260C
1261      RETURN
1262      END
1263      SUBROUTINE DPBAPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
1264     1                  IANGLU,ISEED,IBOOSS,MAXNPP,
1265     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1266C
1267C     PURPOSE--FORM A BLAND ALTMAN PLOT (Y(I) - X(I) VERSUS
1268C              (Y(I) + X(I))/2 FOR PAIRED DATA IN Y AND X.
1269C     REFERENCES--GIAVARINA (2015), "UNDERSTANDING BLAND ALTMAN
1270C                 ANALYSIS", BIOCHEMIA MEDICA, VOL. 25, NO. 2),
1271C                 PP. 141-151.
1272C               --BLAND AND ALTMAN (1983), "MEASUREMENT IN MEDICINE:
1273C                 THE ANALYSIS OF METHOD COMPARISON STUDIES",
1274C                 STATISTICIAN, VOL. 32, PP. 307-317.
1275C     WRITTEN BY--ALAN HECKERT
1276C                 STATISTICAL ENGINEERING DIVISION
1277C                 INFORMATION TECHNOLOGY LABORATORY
1278C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1279C                 GAITHERSBURG, MD 20899-8980
1280C                 PHONE--301-975-2855
1281C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1282C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1283C     LANGUAGE--ANSI FORTRAN (1977)
1284C     VERSION NUMBER--2017/07
1285C     ORIGINAL VERSION--JULY      2017 .
1286C
1287C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1288C
1289      CHARACTER*4 ICASPL
1290      CHARACTER*4 IAND1
1291      CHARACTER*4 IAND2
1292      CHARACTER*4 IANGLU
1293      CHARACTER*4 IBUGG2
1294      CHARACTER*4 IBUGG3
1295      CHARACTER*4 IBUGQ
1296      CHARACTER*4 ISUBRO
1297      CHARACTER*4 IFOUND
1298      CHARACTER*4 IERROR
1299C
1300      CHARACTER*4 ISUBN0
1301      CHARACTER*4 IHOST1
1302      CHARACTER*4 ISUBN1
1303      CHARACTER*4 ISUBN2
1304      CHARACTER*4 ISTEPN
1305      CHARACTER*4 IHIGH
1306      CHARACTER*4 IH
1307      CHARACTER*4 IH2
1308      CHARACTER*4 ICASAN
1309      CHARACTER*4 ICASE
1310C
1311      CHARACTER*40 INAME
1312      PARAMETER (MAXSPN=20)
1313      CHARACTER*4 IVARN1(MAXSPN)
1314      CHARACTER*4 IVARN2(MAXSPN)
1315      CHARACTER*4 IVARTY(MAXSPN)
1316      REAL PVAR(MAXSPN)
1317      INTEGER ILIS(MAXSPN)
1318      INTEGER NRIGHT(MAXSPN)
1319      INTEGER ICOLR(MAXSPN)
1320C
1321C---------------------------------------------------------------------
1322C
1323      INCLUDE 'DPCOPA.INC'
1324      DIMENSION Y1(MAXOBV)
1325      DIMENSION Y2(MAXOBV)
1326      DIMENSION X1(MAXOBV)
1327      DIMENSION X2(MAXOBV)
1328      DIMENSION XHIGH(MAXOBV)
1329      DIMENSION XDIST(MAXOBV)
1330      DIMENSION TEMP1(MAXOBV)
1331      DIMENSION TEMP2(MAXOBV)
1332      DIMENSION XIDTEM(MAXOBV)
1333      DIMENSION XIDTE2(MAXOBV)
1334      DIMENSION YDIFF(MAXOBV)
1335      DIMENSION ZMEAN(MAXOBV)
1336      DIMENSION Z25(MAXOBV)
1337      DIMENSION Z975(MAXOBV)
1338      DIMENSION ITEMP1(MAXOBV)
1339C
1340      INCLUDE 'DPCOZZ.INC'
1341      INCLUDE 'DPCOZI.INC'
1342      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
1343      EQUIVALENCE (GARBAG(IGARB2),X1(1))
1344      EQUIVALENCE (GARBAG(IGARB3),Y2(1))
1345      EQUIVALENCE (GARBAG(IGARB4),X2(1))
1346      EQUIVALENCE (GARBAG(IGARB5),XHIGH(1))
1347      EQUIVALENCE (GARBAG(IGARB6),XDIST(1))
1348      EQUIVALENCE (GARBAG(IGARB7),TEMP1(1))
1349      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
1350      EQUIVALENCE (GARBAG(IGARB9),XIDTEM(1))
1351      EQUIVALENCE (GARBAG(IGAR10),XIDTE2(1))
1352      EQUIVALENCE (GARBAG(JGAR11),YDIFF(1))
1353      EQUIVALENCE (GARBAG(JGAR12),ZMEAN(1))
1354      EQUIVALENCE (GARBAG(JGAR13),Z25(1))
1355      EQUIVALENCE (GARBAG(JGAR14),Z975(1))
1356      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
1357C
1358C-----COMMON----------------------------------------------------------
1359C
1360      INCLUDE 'DPCOHK.INC'
1361      INCLUDE 'DPCODA.INC'
1362      INCLUDE 'DPCOST.INC'
1363C
1364C-----COMMON VARIABLES (GENERAL)--------------------------------------
1365C
1366      INCLUDE 'DPCOP2.INC'
1367C
1368C-----START POINT-----------------------------------------------------
1369C
1370      ISUBN1='DPBA'
1371      ISUBN2='PL  '
1372      IFOUND='NO'
1373      IERROR='NO'
1374C
1375      MAXCP1=MAXCOL+1
1376      MAXCP2=MAXCOL+2
1377      MAXCP3=MAXCOL+3
1378      MAXCP4=MAXCOL+4
1379      MAXCP5=MAXCOL+5
1380      MAXCP6=MAXCOL+6
1381C
1382      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAPL')THEN
1383        WRITE(ICOUT,999)
1384  999   FORMAT(1X)
1385        CALL DPWRST('XXX','BUG ')
1386        WRITE(ICOUT,51)
1387   51   FORMAT('***** AT THE BEGINNING OF DPBAPL--')
1388        CALL DPWRST('XXX','BUG ')
1389        WRITE(ICOUT,52)NPLOTV,NPLOTP,NS,MAXN,MAXNPP
1390   52   FORMAT('NPLOTV,NPLOTP,NS,MAXN,MAXNPP = ',5I8)
1391        CALL DPWRST('XXX','BUG ')
1392        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,IFOUND,IERROR
1393   53   FORMAT('ICASPL,IAND1,IAND2,IFOUND,IERROR = ',4(A4,2X),A4)
1394        CALL DPWRST('XXX','BUG ')
1395        WRITE(ICOUT,54)IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO
1396   54   FORMAT('IANGLU,IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',4(A4,2X),A4)
1397        CALL DPWRST('XXX','BUG ')
1398      ENDIF
1399C
1400C               *******************************************
1401C               **  TREAT THE BLAND ALTMAN          CASE **
1402C               *******************************************
1403C
1404C               ***************************
1405C               **  STEP 11--            **
1406C               **  EXTRACT THE COMMAND  **
1407C               ***************************
1408C
1409      ISTEPN='11'
1410      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAPL')
1411     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1412C
1413      IHIGH='OFF'
1414      ICASAN='SUMM'
1415      IF(ICOM.EQ.'BLAN' .AND. IHARG(1).EQ.'ALTM')THEN
1416        IF((IHARG(2).EQ.'HIGH' .OR. IHARG(2).EQ.'SUBS') .AND.
1417     1      IHARG(3).EQ.'PLOT')THEN
1418          IHIGH='ON'
1419          ILASTC=3
1420        ELSEIF(IHARG(2).EQ.'PLOT')THEN
1421          ILASTC=2
1422        ELSE
1423          GOTO9000
1424        ENDIF
1425      ELSEIF(ICOM.EQ.'HIGH' .OR. ICOM.EQ.'SUBS')THEN
1426        IHIGH='ON'
1427        IF(IHARG(1).EQ.'BLAN'.AND. IHARG(2).EQ.'ALTM' .AND.
1428     1     IHARG(3).EQ.'PLOT')THEN
1429          ILASTC=3
1430        ELSE
1431          GOTO9000
1432        ENDIF
1433      ELSE
1434        GOTO9000
1435      ENDIF
1436C
1437      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
1438      IFOUND='YES'
1439      ICASPL='BAPL'
1440C
1441C               ****************************************
1442C               **  STEP 2--                          **
1443C               **  EXTRACT THE VARIABLE LIST         **
1444C               ****************************************
1445C
1446      ISTEPN='2'
1447      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAPL')
1448     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1449C
1450      INAME='BLAND ALTMAN PLOT'
1451      MAXNA=100
1452      MINN2=2
1453      IFLAGE=0
1454      IFLAGM=1
1455      IFLAGP=0
1456      JMIN=1
1457      JMAX=NUMARG
1458      IF(IHIGH.EQ.'ON')THEN
1459        MINNA=3
1460        MINNVA=3
1461        MAXNVA=3
1462        IFLAGE=1
1463      ELSE
1464        MINNA=2
1465        MINNVA=2
1466        MAXNVA=4
1467      ENDIF
1468C
1469      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
1470     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
1471     1            JMIN,JMAX,
1472     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
1473     1            IVARN1,IVARN2,IVARTY,PVAR,
1474     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
1475     1            MINNVA,MAXNVA,
1476     1            IFLAGM,IFLAGP,
1477     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
1478      IF(IERROR.EQ.'YES')GOTO9000
1479C
1480      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAPL')THEN
1481        WRITE(ICOUT,999)
1482        CALL DPWRST('XXX','BUG ')
1483        WRITE(ICOUT,281)
1484  281   FORMAT('***** AFTER CALL DPPARS--')
1485        CALL DPWRST('XXX','BUG ')
1486        WRITE(ICOUT,282)NQ,NUMVAR
1487  282   FORMAT('NQ,NUMVAR = ',2I8)
1488        CALL DPWRST('XXX','BUG ')
1489        IF(NUMVAR.GT.0)THEN
1490          DO285I=1,NUMVAR
1491            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
1492     1                      ICOLR(I)
1493  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
1494     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
1495            CALL DPWRST('XXX','BUG ')
1496  285     CONTINUE
1497        ENDIF
1498      ENDIF
1499C
1500      IF(IHIGH.EQ.'OFF')THEN
1501        IF(NUMVAR.EQ.3)THEN
1502          WRITE(ICOUT,999)
1503          CALL DPWRST('XXX','BUG ')
1504          WRITE(ICOUT,301)
1505  301     FORMAT('***** ERROR IN BLAND ALTMAN PLOT--')
1506          CALL DPWRST('XXX','BUG ')
1507          WRITE(ICOUT,313)
1508  313     FORMAT('      YOU SHOULD HAVE EITHER TWO VARIABLES')
1509          CALL DPWRST('XXX','BUG ')
1510          WRITE(ICOUT,315)
1511  315     FORMAT('      VARIABLES (SUMMARY CASE) OR FOUR VARIABLES ',
1512     1           '(RAW CASE).')
1513          CALL DPWRST('XXX','BUG ')
1514          WRITE(ICOUT,317)
1515  317     FORMAT('      THREE VARIABLES WERE GIVEN.')
1516          CALL DPWRST('XXX','BUG ')
1517          IERROR='YES'
1518          GOTO9000
1519        ELSEIF(NUMVAR.EQ.4)THEN
1520          ICASAN='RAW'
1521          IF(NRIGHT(1).NE.NRIGHT(2))THEN
1522            WRITE(ICOUT,999)
1523            CALL DPWRST('XXX','BUG ')
1524            WRITE(ICOUT,301)
1525            CALL DPWRST('XXX','BUG ')
1526            WRITE(ICOUT,321)IVARN1(1),IVARN2(1),NRIGHT(1)
1527  321       FORMAT('      VARIABLE ',2A4,' HAS ',I8,' ELEMENTS.')
1528            CALL DPWRST('XXX','BUG ')
1529            WRITE(ICOUT,323)IVARN1(2),IVARN2(2),NRIGHT(2)
1530  323       FORMAT('      VARIABLE ',2A4,' HAS ',I8,' ELEMENTS.')
1531            CALL DPWRST('XXX','BUG ')
1532            WRITE(ICOUT,325)
1533  325       FORMAT('      THESE VARIABLES SHOULD HAVE THE SAME ',
1534     1             'NUMBER OF ELEMENTS.')
1535            CALL DPWRST('XXX','BUG ')
1536            IERROR='YES'
1537            GOTO9000
1538          ELSEIF(NRIGHT(3).NE.NRIGHT(4))THEN
1539            WRITE(ICOUT,999)
1540            CALL DPWRST('XXX','BUG ')
1541            WRITE(ICOUT,301)
1542            CALL DPWRST('XXX','BUG ')
1543            WRITE(ICOUT,331)IVARN1(3),IVARN2(3),NRIGHT(3)
1544  331       FORMAT('      VARIABLE ',2A4,' HAS ',I8,' ELEMENTS.')
1545            CALL DPWRST('XXX','BUG ')
1546            WRITE(ICOUT,333)IVARN1(4),IVARN2(4),NRIGHT(4)
1547  333       FORMAT('      VARIABLE ',2A4,' HAS ',I8,' ELEMENTS.')
1548            CALL DPWRST('XXX','BUG ')
1549            WRITE(ICOUT,335)
1550  335       FORMAT('      THESE VARIABLES SHOULD HAVE THE SAME ',
1551     1             'NUMBER OF ELEMENTS.')
1552            CALL DPWRST('XXX','BUG ')
1553            IERROR='YES'
1554            GOTO9000
1555          ENDIF
1556        ELSEIF(NUMVAR.EQ.2)THEN
1557          IF(NRIGHT(1).NE.NRIGHT(2))THEN
1558            WRITE(ICOUT,999)
1559            CALL DPWRST('XXX','BUG ')
1560            WRITE(ICOUT,301)
1561            CALL DPWRST('XXX','BUG ')
1562            WRITE(ICOUT,321)IVARN1(1),IVARN2(1),NRIGHT(1)
1563            CALL DPWRST('XXX','BUG ')
1564            WRITE(ICOUT,323)IVARN1(2),IVARN2(2),NRIGHT(2)
1565            CALL DPWRST('XXX','BUG ')
1566            WRITE(ICOUT,325)
1567            CALL DPWRST('XXX','BUG ')
1568            IERROR='YES'
1569            GOTO9000
1570          ENDIF
1571        ENDIF
1572      ENDIF
1573
1574C     IN ORDER TO ACCOMODATE MATRIX ARGUMENTS, CALL EACH
1575C     VARIABLE SEPARATELY.
1576C
1577      IF(ICASAN.EQ.'SUMM')THEN
1578        NUMVA2=1
1579        ICOL=1
1580        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1581     1              INAME,IVARN1,IVARN2,IVARTY,
1582     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1583     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1584     1              MAXCP4,MAXCP5,MAXCP6,
1585     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1586     1              Y1,Y1,Y1,NS1,NTEMP,NTEMP,ICASE,
1587     1              IBUGG3,ISUBRO,IFOUND,IERROR)
1588        IF(IERROR.EQ.'YES')GOTO9000
1589C
1590        ICOL=2
1591        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1592     1              INAME,IVARN1,IVARN2,IVARTY,
1593     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1594     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1595     1              MAXCP4,MAXCP5,MAXCP6,
1596     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1597     1              Y2,Y2,Y2,NS2,NTEMP,NTEMP,ICASE,
1598     1              IBUGG3,ISUBRO,IFOUND,IERROR)
1599C
1600        IF(IHIGH.EQ.'ON')THEN
1601          ICOL=3
1602          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1603     1                INAME,IVARN1,IVARN2,IVARTY,
1604     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1605     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1606     1                MAXCP4,MAXCP5,MAXCP6,
1607     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1608     1                XHIGH,XHIGH,XHIGH,NHIGH,NTEMP,NTEMP,ICASE,
1609     1                IBUGG3,ISUBRO,IFOUND,IERROR)
1610        ELSE
1611          NHIGH=0
1612        ENDIF
1613      ELSE
1614        NHIGH=0
1615        IHIGH='OFF'
1616        NUMVA2=2
1617        ICOL=1
1618        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1619     1              INAME,IVARN1,IVARN2,IVARTY,
1620     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1621     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1622     1              MAXCP4,MAXCP5,MAXCP6,
1623     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1624     1              Y1,X1,Y1,NS1,NTEMP,NTEMP,ICASE,
1625     1              IBUGG3,ISUBRO,IFOUND,IERROR)
1626        IF(IERROR.EQ.'YES')GOTO9000
1627C
1628        NUMVA2=2
1629        ICOL=3
1630        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
1631     1              INAME,IVARN1,IVARN2,IVARTY,
1632     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
1633     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
1634     1              MAXCP4,MAXCP5,MAXCP6,
1635     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
1636     1              Y2,X2,Y2,NS2,NTEMP,NTEMP,ICASE,
1637     1              IBUGG3,ISUBRO,IFOUND,IERROR)
1638        IF(IERROR.EQ.'YES')GOTO9000
1639C
1640      ENDIF
1641C
1642C               ****************************************************
1643C               **  STEP 41--                                      *
1644C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          *
1645C               **  VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR    *
1646C               **   THE PLOT.                                     *
1647C               **  FORM THE CURVE DESIGNATION VARIABLE D(.)  .    *
1648C               **  THIS WILL BE BOTH ONES FOR BOTH CASES          *
1649C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  *
1650C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  *
1651C               ****************************************************
1652C
1653      ISTEPN='41'
1654      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAPL')
1655     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1656C
1657      CALL DPBAP2(Y1,X1,NS1,Y2,X2,NS2,MAXN,ICASAN,
1658     1            XIDTEM,XIDTE2,TEMP1,TEMP2,ITEMP1,
1659     1            XHIGH,NHIGH,XDIST,
1660     1            YDIFF,ZMEAN,Z25,Z975,
1661     1            IBAPPE,IBAPST,IBAPBO,IBAPCL,ISEED,IBOOSS,
1662     1            Y,X,D,NPLOTP,NPLOTV,
1663     1            YMEAN,YSD,YMLCL,YMUCL,
1664     1            YUPPER,YUPLCL,YUPUCL,YLOWER,YLOLCL,YLOUCL,
1665     1            IBUGG3,ISUBRO,IERROR)
1666C
1667      IH='DIFF'
1668      IH2='MEAN'
1669      VALUE0=YMEAN
1670      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1671     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1672     1            IANS,IWIDTH,IBUGG3,IERROR)
1673C
1674      IH='DIFF'
1675      IH2='SD  '
1676      VALUE0=YSD
1677      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1678     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1679     1            IANS,IWIDTH,IBUGG3,IERROR)
1680C
1681      IH='DIFF'
1682      IH2='MLCL'
1683      VALUE0=YMLCL
1684      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1685     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1686     1            IANS,IWIDTH,IBUGG3,IERROR)
1687C
1688      IH='DIFF'
1689      IH2='MUCL'
1690      VALUE0=YMUCL
1691      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1692     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1693     1            IANS,IWIDTH,IBUGG3,IERROR)
1694C
1695      IH='LOWL'
1696      IH2='IMIT'
1697      VALUE0=YLOWER
1698      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1699     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1700     1            IANS,IWIDTH,IBUGG3,IERROR)
1701C
1702      IH='LOWL'
1703      IH2='MLCL'
1704      VALUE0=YLOLCL
1705      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1706     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1707     1            IANS,IWIDTH,IBUGG3,IERROR)
1708C
1709      IH='LOWL'
1710      IH2='MUCL'
1711      VALUE0=YLOUCL
1712      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1713     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1714     1            IANS,IWIDTH,IBUGG3,IERROR)
1715C
1716      IH='UPPL'
1717      IH2='IMIT'
1718      VALUE0=YUPPER
1719      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1720     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1721     1            IANS,IWIDTH,IBUGG3,IERROR)
1722C
1723      IH='UPPL'
1724      IH2='MLCL'
1725      VALUE0=YUPLCL
1726      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1727     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1728     1            IANS,IWIDTH,IBUGG3,IERROR)
1729C
1730      IH='UPPL'
1731      IH2='MUCL'
1732      VALUE0=YUPUCL
1733      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
1734     1            IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
1735     1            IANS,IWIDTH,IBUGG3,IERROR)
1736C
1737C               *****************
1738C               **  STEP 90--  **
1739C               **  EXIT       **
1740C               *****************
1741C
1742 9000 CONTINUE
1743      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BAPL')THEN
1744        WRITE(ICOUT,999)
1745        CALL DPWRST('XXX','BUG ')
1746        WRITE(ICOUT,9011)
1747 9011   FORMAT('***** AT THE END       OF DPBAPL--')
1748        CALL DPWRST('XXX','BUG ')
1749        WRITE(ICOUT,9012)IFOUND,IERROR
1750 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
1751        CALL DPWRST('XXX','BUG ')
1752        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NUMVAR,NS,ICASPL,IAND1,IAND2
1753 9013   FORMAT('NPLOTV,NPLOTP,NUMVAR,NS,ICASPL,IAND1,IAND2 = ',
1754     1         4I8,2X,2(A4,2X),A4)
1755        CALL DPWRST('XXX','BUG ')
1756        WRITE(ICOUT,9014)ICASPL,MAXN,NUMVAR
1757 9014   FORMAT('ICASPL,MAXN,NUMVAR = ',A4,I8,I8)
1758        CALL DPWRST('XXX','BUG ')
1759        IF(NPLOTP.GE.1)THEN
1760          DO9020I=1,NPLOTP
1761            WRITE(ICOUT,9021)I,Y(I),X(I),D(I)
1762 9021       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
1763            CALL DPWRST('XXX','BUG ')
1764 9020     CONTINUE
1765        ENDIF
1766      ENDIF
1767C
1768      RETURN
1769      END
1770      SUBROUTINE DPBAP2(Y1,X1,N1,Y2,X2,N2,MAXN,ICASAN,
1771     1                  XIDTEM,XIDTE2,TEMP1,TEMP2,ITEMP1,
1772     1                  XHIGH,NHIGH,XDIST,
1773     1                  YDIFF,ZMEAN,Z25,Z975,
1774     1                  IBAPPE,IBAPST,IBAPBO,IBAPCL,ISEED,IBOOSS,
1775     1                  Y2OUT,X2OUT,D2,NPLOTP,NPLOTV,
1776     1                  YMEAN,YSD,YMLCL,YMUCL,
1777     1                  YUPPER,YUPLCL,YUPUCL,YLOWER,YLOLCL,YLOUCL,
1778     1                  IBUGG3,ISUBRO,IERROR)
1779C
1780C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS THAT WILL DEFINE
1781C              A BLAND ALTMAN PLOT.  THIS IS A PLOT OF Y(I) - X(I)
1782C              VERSUS THEIR AVERAGE (Y(I) + X(I))/2.  THIS IS A
1783C              SIMILAR IDEA TO THE TUKEY MEAN DIFFERENCE PLOT.  BUT
1784C              THERE ARE SOME DIFFERENCES.
1785C
1786C                 1. THE BLAND ALTMAN PLOTS RAW DATA WHILE THE
1787C                    TUKEY MEAN DIFFERENCE PLOT IS BASED ON THE
1788C                    PERCENTILES OF THE DATA.
1789C
1790C                 2. THE BLAND ALTMAN PLOT ASSUMES PAIRED DATA
1791C                    WHILE THE TUKEY MEAN DIFFERENCE DOES NOT (AND
1792C                    IT DOES NOT REQUIRE THE TWO SAMPLES TO HAVE
1793C                    THE SAME LENGTH).
1794C
1795C                 3. THE TUKEY MEAN DIFFERENCE PLOT IS PRIMARILY
1796C                    FOCUSED ON THE QUESTION: DO THESE TWO SAMPLES
1797C                    HAVE SIMILAR DISTRIBUTIONS?  THE BLAND ALTMAN
1798C                    PLOT IS PRIMARILY FOCUSED ON THE DIFFERENCES
1799C                    BETWEEN THE PAIRS.
1800C
1801C     REFERENCES--GIAVARINA (2015), "UNDERSTANDING BLAND ALTMAN
1802C                 ANALYSIS", BIOCHEMIA MEDICA, VOL. 25, NO. 2),
1803C                 PP. 141-151.
1804C               --BLAND AND ALTMAN (1983), "MEASUREMENT IN MEDICINE:
1805C                 THE ANALYSIS OF METHOD COMPARISON STUDIES",
1806C                 STATISTICIAN, VOL. 32, PP. 307-317.
1807C     WRITTEN BY--ALAN HECKERT
1808C                 STATISTICAL ENGINEERING DIVISION
1809C                 INFORMATION TECHNOLOGY LABORATORY
1810C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
1811C                 GAITHERSBURG, MD 20899-8980
1812C                 PHONE--301-975-2899
1813C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
1814C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
1815C     LANGUAGE--ANSI FORTRAN (1977)
1816C     VERSION NUMBER--2017/07
1817C     ORIGINAL VERSION--JULY      2017.
1818C
1819C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
1820C
1821      CHARACTER*4 ICASAN
1822      CHARACTER*4 IBAPPE
1823      CHARACTER*4 IBAPST
1824      CHARACTER*4 IBAPBO
1825      CHARACTER*4 IBAPCL
1826      CHARACTER*4 IBUGG3
1827      CHARACTER*4 ISUBRO
1828      CHARACTER*4 IERROR
1829C
1830      CHARACTER*4 ISUBN1
1831      CHARACTER*4 ISUBN2
1832      CHARACTER*4 ISTEPN
1833      CHARACTER*4 IWRITE
1834      CHARACTER*4 ICASJB
1835      CHARACTER*4 IOP
1836C
1837C---------------------------------------------------------------------
1838C
1839      DIMENSION Y1(*)
1840      DIMENSION X1(*)
1841      DIMENSION Y2(*)
1842      DIMENSION X2(*)
1843      DIMENSION XHIGH(*)
1844      DIMENSION Y2OUT(*)
1845      DIMENSION X2OUT(*)
1846      DIMENSION D2(*)
1847      DIMENSION XDIST(*)
1848      DIMENSION XIDTEM(*)
1849      DIMENSION XIDTE2(*)
1850      DIMENSION TEMP1(*)
1851      DIMENSION TEMP2(*)
1852      DIMENSION YDIFF(*)
1853      DIMENSION ZMEAN(*)
1854      DIMENSION Z25(*)
1855      DIMENSION Z975(*)
1856      DIMENSION ITEMP1(*)
1857C
1858C---------------------------------------------------------------------
1859C
1860      INCLUDE 'DPCOP2.INC'
1861C
1862C-----START POINT-----------------------------------------------------
1863C
1864      ISUBN1='DPBA'
1865      ISUBN2='P2  '
1866      IERROR='NO'
1867      IWRITE='OFF'
1868      ICASJB='BOOT'
1869C
1870      ZMEANT=CPUMIN
1871      AMEAN=CPUMIN
1872C
1873      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BAP2')THEN
1874        WRITE(ICOUT,999)
1875  999   FORMAT(1X)
1876        CALL DPWRST('XXX','BUG ')
1877        WRITE(ICOUT,51)
1878   51   FORMAT('***** AT THE BEGINNING OF DPBAP2--')
1879        CALL DPWRST('XXX','BUG ')
1880        WRITE(ICOUT,52)IBUGG3,ISUBRO,ICASAN,N,NHIGH
1881   52   FORMAT('IBUGG3,ISUBRO,ICASAN,N = ',3(A4,2X),2I8)
1882        CALL DPWRST('XXX','BUG ')
1883        IF(ICASAN.EQ.'SUMM')THEN
1884          DO61I=1,N1
1885            WRITE(ICOUT,62)I,Y1(I),Y2(I),XHIGH(I)
1886   62       FORMAT('I,Y1(I),Y2(I),XHIGH(I) = ',I8,3G15.7)
1887            CALL DPWRST('XXX','BUG ')
1888   61     CONTINUE
1889        ELSE
1890          DO71I=1,MAX(N1,N2)
1891            WRITE(ICOUT,72)I,Y1(I),X1(I),Y2(I),X2(I)
1892   72       FORMAT('I,Y1(I),X1(I),Y2(I),X2(I) = ',I8,4G15.7)
1893            CALL DPWRST('XXX','BUG ')
1894   71     CONTINUE
1895        ENDIF
1896      ENDIF
1897C
1898C               ********************************************
1899C               **  STEP 11--                             **
1900C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
1901C               ********************************************
1902C
1903      IF(ICASAN.EQ.'SUMM' .AND. N1.LT.1)THEN
1904        WRITE(ICOUT,999)
1905        CALL DPWRST('XXX','BUG ')
1906        WRITE(ICOUT,1111)
1907 1111   FORMAT('***** ERROR IN BLAND ALTMAN PLOT--')
1908        CALL DPWRST('XXX','BUG ')
1909        WRITE(ICOUT,1112)
1910 1112   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1.')
1911        CALL DPWRST('XXX','BUG ')
1912        WRITE(ICOUT,1114)N1
1913 1114   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I6)
1914        CALL DPWRST('XXX','BUG ')
1915        IERROR='YES'
1916        GOTO9000
1917      ELSEIF(NHIGH.GT.0 .AND. NHIGH.NE.N1)THEN
1918        WRITE(ICOUT,999)
1919        CALL DPWRST('XXX','BUG ')
1920        WRITE(ICOUT,1111)
1921        CALL DPWRST('XXX','BUG ')
1922        WRITE(ICOUT,1125)
1923 1125   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE HIGHLIGHTING ',
1924     1         'VARIABLE IS')
1925        CALL DPWRST('XXX','BUG ')
1926        WRITE(ICOUT,1126)
1927 1126   FORMAT('      NOT EQUAL TO THE NUMBER OF OBSERVATIONS IN THE ',
1928     1         'RESPONSE VARIABLES.')
1929        CALL DPWRST('XXX','BUG ')
1930        WRITE(ICOUT,1127)N
1931 1127   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE ',
1932     1         'RESPONSE VARIABLES = ',I8)
1933        CALL DPWRST('XXX','BUG ')
1934        WRITE(ICOUT,1129)NHIGH
1935 1129   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE HIGHLIGHT ',
1936     1         'VARIABLE = ',I8)
1937        CALL DPWRST('XXX','BUG ')
1938        IERROR='YES'
1939        GOTO9000
1940      ELSEIF(ICASAN.EQ.'RAW' .AND. N1.LT.1)THEN
1941        WRITE(ICOUT,999)
1942        CALL DPWRST('XXX','BUG ')
1943        WRITE(ICOUT,1111)
1944        CALL DPWRST('XXX','BUG ')
1945        WRITE(ICOUT,1131)
1946 1131   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1.')
1947        CALL DPWRST('XXX','BUG ')
1948        WRITE(ICOUT,1134)N1
1949 1134   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I6)
1950        CALL DPWRST('XXX','BUG ')
1951        IERROR='YES'
1952        GOTO9000
1953      ELSEIF(ICASAN.EQ.'RAW' .AND. N2.LT.1)THEN
1954        WRITE(ICOUT,999)
1955        CALL DPWRST('XXX','BUG ')
1956        WRITE(ICOUT,1111)
1957        CALL DPWRST('XXX','BUG ')
1958        WRITE(ICOUT,1141)
1959 1141   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1.')
1960        CALL DPWRST('XXX','BUG ')
1961        WRITE(ICOUT,1144)N2
1962 1144   FORMAT('      THE NUMBER OF OBSERVATIONS HERE = ',I6)
1963        CALL DPWRST('XXX','BUG ')
1964        IERROR='YES'
1965        GOTO9000
1966      ENDIF
1967C
1968C               ****************************************************
1969C               **  STEP 21--COMPUTE THE DIFFERENCES AND THE MEAN **
1970C               ****************************************************
1971C
1972      ISTEPN='21'
1973      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BAP2')
1974     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
1975C
1976      IF(ICASAN.EQ.'RAW')THEN
1977C
1978C       FOR RAW DATA, COMPUTE THE MEANS (OR MEDIANS) FOR
1979C       EACH SET OF DATA (Y1, X1 AND Y2, X2).
1980C
1981C       NOTE THAT FOR RAW DATA CASE, THE GROUP-ID'S MUST BE THE
1982C       SAME FOR EACH SET.
1983C
1984        CALL DISTIN(X1,N1,IWRITE,XIDTEM,NX1,IBUGG3,IERROR)
1985        CALL DISTIN(X2,N2,IWRITE,XIDTE2,NX2,IBUGG3,IERROR)
1986        IF(NX1.NE.NX2)THEN
1987          WRITE(ICOUT,999)
1988          CALL DPWRST('XXX','BUG ')
1989          WRITE(ICOUT,1111)
1990          CALL DPWRST('XXX','BUG ')
1991          WRITE(ICOUT,1201)
1992 1201     FORMAT('      FOR THE RAW DATA CASE, THE NUMBER OF GROUP ',
1993     1           'MUST BE THE SAME.')
1994          CALL DPWRST('XXX','BUG ')
1995          WRITE(ICOUT,1203)NX1
1996 1203     FORMAT('      THE NUMBER OF GROUPS FOR SET 1 = ',I8)
1997          CALL DPWRST('XXX','BUG ')
1998          WRITE(ICOUT,1205)NX2
1999 1205     FORMAT('      THE NUMBER OF GROUPS FOR SET 2 = ',I8)
2000          CALL DPWRST('XXX','BUG ')
2001          IERROR='YES'
2002          GOTO9000
2003        ENDIF
2004        CALL SORT(XIDTEM,NX1,XIDTEM)
2005        CALL SORT(XIDTE2,NX2,XIDTE2)
2006        NX=NX1
2007        DO1210II=1,NX
2008          IF(XIDTEM(II).NE.XIDTE2(II))THEN
2009            WRITE(ICOUT,999)
2010            CALL DPWRST('XXX','BUG ')
2011            WRITE(ICOUT,1111)
2012            CALL DPWRST('XXX','BUG ')
2013            WRITE(ICOUT,1207)
2014 1207       FORMAT('      FOR THE RAW DATA CASE, THE GROUP IDs ',
2015     1           'MUST BE THE SAME.')
2016            CALL DPWRST('XXX','BUG ')
2017            WRITE(ICOUT,1208)II,XIDTEM(II)
2018 1208       FORMAT('      FOR SET ONE, GROUP ',I5,' IS ',I8)
2019            CALL DPWRST('XXX','BUG ')
2020            WRITE(ICOUT,1209)II,XIDTE2(II)
2021 1209       FORMAT('      FOR SET TWO, GROUP ',I5,' IS ',I8)
2022            CALL DPWRST('XXX','BUG ')
2023            IERROR='YES'
2024            GOTO9000
2025          ENDIF
2026 1210   CONTINUE
2027C
2028        DO1220JJ=1,NX
2029          HOLD=XIDTEM(JJ)
2030          K=0
2031          DO1230II=1,N1
2032            IF(X1(II).EQ.HOLD)THEN
2033              K=K+1
2034              TEMP1(K)=Y1(II)
2035            ENDIF
2036 1230     CONTINUE
2037          IF(IBAPST.EQ.'MEAN')THEN
2038            CALL MEAN(TEMP1,K,IWRITE,YMEAN,IBUGG3,IERROR)
2039            XHIGH(JJ)=YMEAN
2040          ELSEIF(IBAPST.EQ.'MEDI')THEN
2041            CALL MEDIAN(TEMP1,K,IWRITE,TEMP2,MAXN,YMED,IBUGG3,IERROR)
2042            XHIGH(JJ)=YMED
2043          ENDIF
2044 1220   CONTINUE
2045        DO1240JJ=1,NX
2046          Y1(JJ)=XHIGH(JJ)
2047 1240   CONTINUE
2048C
2049        DO1320JJ=1,NX
2050          HOLD=XIDTE2(JJ)
2051          K=0
2052          DO1330II=1,N2
2053            IF(X2(II).EQ.HOLD)THEN
2054              K=K+1
2055              TEMP1(K)=Y2(II)
2056            ENDIF
2057 1330     CONTINUE
2058          IF(IBAPST.EQ.'MEAN')THEN
2059            CALL MEAN(TEMP1,K,IWRITE,YMEAN,IBUGG3,IERROR)
2060            XHIGH(JJ)=YMEAN
2061          ELSEIF(IBAPST.EQ.'MEDI')THEN
2062            CALL MEDIAN(TEMP1,K,IWRITE,TEMP2,MAXN,YMED,IBUGG3,IERROR)
2063            XHIGH(JJ)=YMED
2064          ENDIF
2065 1320   CONTINUE
2066        DO1340JJ=1,NX
2067          Y2(JJ)=XHIGH(JJ)
2068 1340   CONTINUE
2069        N1=NX
2070        N2=NX
2071      ELSE
2072        IF(NHIGH.GT.0)THEN
2073          CALL CODE(XHIGH,NHIGH,IWRITE,XDIST,D2,MAXN,IBUGG3,IERROR)
2074          CALL MAXIM(XDIST,NHIGH,IWRITE,TMAX,IBUGG3,IERROR)
2075        ELSE
2076          DO2005I=1,N1
2077            XDIST(I)=1.0
2078 2005     CONTINUE
2079          TMAX=1.0
2080        ENDIF
2081      ENDIF
2082C
2083      NPLOTP=0
2084      XMIN=CPUMAX
2085      XMAX=CPUMIN
2086      N=N1
2087      AN=REAL(N1)
2088      IF(IBAPPE.EQ.'PERC')THEN
2089        SUM1=0.0
2090        DO2020I=1,N
2091          AY=Y1(I) - Y2(I)
2092          AX=(Y1(I) + Y2(I))/2.0
2093          AYPERC=(AY/AX)*100.
2094          SUM1=SUM1 + AYPERC
2095          NPLOTP=NPLOTP+1
2096          Y2OUT(NPLOTP)=AYPERC
2097          X2OUT(NPLOTP)=AX
2098          D2(NPLOTP)=XDIST(I)
2099          IF(AX.LT.XMIN)XMIN=AX
2100          IF(AX.GT.XMAX)XMAX=AX
2101 2020   CONTINUE
2102        AMEAN=SUM1/AN
2103      ELSE
2104        DO2010I=1,N
2105          AY=Y1(I) - Y2(I)
2106          AX=(Y1(I) + Y2(I))/2.0
2107          NPLOTP=NPLOTP+1
2108          Y2OUT(NPLOTP)=AY
2109          X2OUT(NPLOTP)=AX
2110          D2(NPLOTP)=XDIST(I)
2111          IF(AX.LT.XMIN)XMIN=AX
2112          IF(AX.GT.XMAX)XMAX=AX
2113 2010   CONTINUE
2114      ENDIF
2115C
2116C     WRITE VALUES TO FILE (TO ALLOW AFTER THE FACT FITTING)
2117C
2118      IOP='OPEN'
2119      IFLAG1=1
2120      IFLAG2=0
2121      IFLAG3=0
2122      IFLAG4=0
2123      IFLAG5=0
2124      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
2125     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2126     1            IBUGG3,ISUBRO,IERROR)
2127      IF(IERROR.EQ.'YES')GOTO2019
2128      DO2015I=1,NPLOTP
2129        WRITE(IOUNI1,'(2E15.7)')Y2OUT(I),X2OUT(I)
2130 2015 CONTINUE
2131      IOP='CLOS'
2132      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
2133     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2134     1            IBUGG3,ISUBRO,IERROR)
2135C
2136 2019 CONTINUE
2137C
2138C     NOW ADD SOME REFERENCE LINES
2139C
2140      IWRITE='OFF'
2141      CALL MEAN(Y2OUT,NPLOTP,IWRITE,YMEAN,IBUGG3,IERROR)
2142      CALL SD(Y2OUT,NPLOTP,IWRITE,YSD,IBUGG3,IERROR)
2143C
2144      TMAX=TMAX+1.0
2145      NPLOTP=NPLOTP+1
2146      X2OUT(NPLOTP)=XMIN
2147      Y2OUT(NPLOTP)=0.0
2148      D2(NPLOTP)=TMAX
2149      NPLOTP=NPLOTP+1
2150      X2OUT(NPLOTP)=XMAX
2151      Y2OUT(NPLOTP)=0.0
2152      D2(NPLOTP)=TMAX
2153C
2154      IF(IBAPCL.EQ.'ANAL')THEN
2155        IF(IBAPPE.EQ.'PERC')THEN
2156          ZMEANT=AMEAN
2157        ELSE
2158          ZMEANT=YMEAN
2159        ENDIF
2160        AN=REAL(N1)
2161        TMAX=TMAX+1.0
2162        NPLOTP=NPLOTP+1
2163        X2OUT(NPLOTP)=XMIN
2164        Y2OUT(NPLOTP)=ZMEANT
2165        D2(NPLOTP)=TMAX
2166        NPLOTP=NPLOTP+1
2167        X2OUT(NPLOTP)=XMAX
2168        Y2OUT(NPLOTP)=ZMEANT
2169        D2(NPLOTP)=TMAX
2170C
2171        ADF=REAL(N1-1)
2172        P=0.975
2173        CALL TPPF(P,ADF,PPF)
2174        YMLCL=ZMEANT - PPF*YSD/SQRT(AN)
2175        YMUCL=ZMEANT + PPF*YSD/SQRT(AN)
2176        TMAX=TMAX+1.0
2177        NPLOTP=NPLOTP+1
2178        X2OUT(NPLOTP)=XMIN
2179        Y2OUT(NPLOTP)=YMLCL
2180        D2(NPLOTP)=TMAX
2181        NPLOTP=NPLOTP+1
2182        X2OUT(NPLOTP)=XMAX
2183        Y2OUT(NPLOTP)=YMLCL
2184        D2(NPLOTP)=TMAX
2185        TMAX=TMAX+1.0
2186        NPLOTP=NPLOTP+1
2187        X2OUT(NPLOTP)=XMIN
2188        Y2OUT(NPLOTP)=YMUCL
2189        D2(NPLOTP)=TMAX
2190        NPLOTP=NPLOTP+1
2191        X2OUT(NPLOTP)=XMAX
2192        Y2OUT(NPLOTP)=YMUCL
2193        D2(NPLOTP)=TMAX
2194C
2195        YUPPER=ZMEANT + 2.0*YSD
2196        TMAX=TMAX+1.0
2197        NPLOTP=NPLOTP+1
2198        X2OUT(NPLOTP)=XMIN
2199        Y2OUT(NPLOTP)=YUPPER
2200        D2(NPLOTP)=TMAX
2201        NPLOTP=NPLOTP+1
2202        X2OUT(NPLOTP)=XMAX
2203        Y2OUT(NPLOTP)=YUPPER
2204        D2(NPLOTP)=TMAX
2205C
2206        YUPLCL=YUPPER - PPF*YSD*SQRT(3.0/AN)
2207        YUPUCL=YUPPER + PPF*YSD*SQRT(3.0/AN)
2208        TMAX=TMAX+1.0
2209        NPLOTP=NPLOTP+1
2210        X2OUT(NPLOTP)=XMIN
2211        Y2OUT(NPLOTP)=YUPLCL
2212        D2(NPLOTP)=TMAX
2213        NPLOTP=NPLOTP+1
2214        X2OUT(NPLOTP)=XMAX
2215        Y2OUT(NPLOTP)=YUPLCL
2216        D2(NPLOTP)=TMAX
2217        TMAX=TMAX+1.0
2218        NPLOTP=NPLOTP+1
2219        X2OUT(NPLOTP)=XMIN
2220        Y2OUT(NPLOTP)=YUPUCL
2221        D2(NPLOTP)=TMAX
2222        NPLOTP=NPLOTP+1
2223        X2OUT(NPLOTP)=XMAX
2224        Y2OUT(NPLOTP)=YUPUCL
2225        D2(NPLOTP)=TMAX
2226C
2227        YLOWER=ZMEANT - 2.0*YSD
2228        TMAX=TMAX+1.0
2229        NPLOTP=NPLOTP+1
2230        X2OUT(NPLOTP)=XMIN
2231        Y2OUT(NPLOTP)=YLOWER
2232        D2(NPLOTP)=TMAX
2233        NPLOTP=NPLOTP+1
2234        X2OUT(NPLOTP)=XMAX
2235        Y2OUT(NPLOTP)=YLOWER
2236        D2(NPLOTP)=TMAX
2237C
2238        YLOLCL=YLOWER - PPF*YSD*SQRT(3.0/AN)
2239        YLOUCL=YLOWER + PPF*YSD*SQRT(3.0/AN)
2240        TMAX=TMAX+1.0
2241        NPLOTP=NPLOTP+1
2242        X2OUT(NPLOTP)=XMIN
2243        Y2OUT(NPLOTP)=YLOLCL
2244        D2(NPLOTP)=TMAX
2245        NPLOTP=NPLOTP+1
2246        X2OUT(NPLOTP)=XMAX
2247        Y2OUT(NPLOTP)=YLOLCL
2248        D2(NPLOTP)=TMAX
2249        TMAX=TMAX+1.0
2250        NPLOTP=NPLOTP+1
2251        X2OUT(NPLOTP)=XMIN
2252        Y2OUT(NPLOTP)=YLOUCL
2253        D2(NPLOTP)=TMAX
2254        NPLOTP=NPLOTP+1
2255        X2OUT(NPLOTP)=XMAX
2256        Y2OUT(NPLOTP)=YLOUCL
2257        D2(NPLOTP)=TMAX
2258      ELSE
2259C
2260C       BOOTSTRAP BASED CONFIDENCE INTERVALS.  IF "RAW" DATA WAS GIVEN,
2261C       CAN BOOTSTRAP EITHER THE RAW DATA OR THE DIFFERENCES.  IF
2262C       SUMMARY DATA WAS GIVEN, CAN ONLY BOOTSTRAP THE DIFFERENCES.
2263C
2264        IF(ICASAN.EQ.'RAW ' .AND. IBAPBO.EQ.'RAW ')THEN
2265C
2266C         BOOTSTRAP RAW DATA
2267C
2268        ELSE
2269C
2270C         COMPUTE DIFFERENCES AND STATISTICS FOR ORIGINAL DATA
2271C
2272          DO4010II=1,N1
2273            YDIFF(II)=Y1(II) - Y2(II)
2274 4010     CONTINUE
2275C
2276          CALL MEAN(YDIFF,N1,IWRITE,YMEANF,IBUGG3,IERROR)
2277          CALL SD(YDIFF,N1,IWRITE,YSDF,IBUGG3,IERROR)
2278C
2279C         NOW GENERATE THE BOOTSTRAP SAMPLES.  FROM EACH
2280C         BOOTSTRAP SAMPLE, COMPUTE
2281C
2282C            1. MEAN (OR MEDIAN)
2283C            2.  2.5 PERCENTILE
2284C            3. 97.5 PERCENTILE
2285C
2286C         THE BOOTSTRAP SAMPLES WILL BE USED TO COMPUTE CONFIDENCE
2287C         INTERVALS FOR EACH OF THESE STATISTICS.
2288C
2289          DO4020IRESAM=1,IBOOSS
2290C
2291            IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BAP2')THEN
2292              WRITE(ICOUT,4021)IRESAM
2293 4021         FORMAT('FROM DPBAP2, IRESAM = ',I8)
2294              CALL DPWRST('XXX','BUG ')
2295            ENDIF
2296C
2297            IRESA2=IRESAM
2298            CALL DPJBS3(YDIFF,N1,ICASJB,IRESA2,ISEED,TEMP1,NTEMP,
2299     1                  ITEMP1,TEMP2,IBUGG3,IERROR)
2300            IF(IBAPST.EQ.'MEAN')THEN
2301              CALL MEAN(TEMP1,N1,IWRITE,YMEAN,IBUGG3,IERROR)
2302              ZMEAN(IRESAM)=YMEAN
2303            ELSEIF(IBAPST.EQ.'MEDI')THEN
2304              CALL MEDIAN(TEMP1,N1,IWRITE,TEMP2,MAXN,YMED,IBUGG3,IERROR)
2305              ZMEAN(IRESAM)=YMED
2306            ENDIF
2307            CALL SD(TEMP1,N1,IWRITE,YSD,IBUGG3,IERROR)
2308            Z25(IRESAM)=ZMEAN(IRESAM) - 2.0*YSD
2309            Z975(IRESAM)=ZMEAN(IRESAM) + 2.0*YSD
2310CCCCC       P100=2.5
2311CCCCC       CALL PERCEN(P100,TEMP1,N1,IWRITE,TEMP2,MAXN,
2312CCCCC1                  YPERC,IBUGG3,IERROR)
2313CCCCC       Z25(IRESAM)=YPERC
2314CCCCC       P100=97.5
2315CCCCC       CALL PERCEN(P100,TEMP1,N1,IWRITE,TEMP2,MAXN,
2316CCCCC1                  YPERC,IBUGG3,IERROR)
2317CCCCC       Z975(IRESAM)=YPERC
2318C
2319 4020     CONTINUE
2320C
2321      IOP='OPEN'
2322      IFLAG1=0
2323      IFLAG2=1
2324      IFLAG3=0
2325      IFLAG4=0
2326      IFLAG5=0
2327      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
2328     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2329     1            IBUGG3,ISUBRO,IERROR)
2330      IF(IERROR.EQ.'YES')GOTO2019
2331      DO4025I=1,IRESAM
2332        WRITE(IOUNI2,'(2E15.7)')ZMEAN(I),Z975(I)
2333 4025 CONTINUE
2334      IOP='CLOS'
2335      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
2336     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
2337     1            IBUGG3,ISUBRO,IERROR)
2338C
2339C         NOW GENERATE THE LINES FOR THE VARIOUS CURVES ON THE PLOT
2340C
2341          AN=REAL(N1)
2342          TMAX=TMAX+1.0
2343          NPLOTP=NPLOTP+1
2344          X2OUT(NPLOTP)=XMIN
2345          Y2OUT(NPLOTP)=YMEANF
2346          D2(NPLOTP)=TMAX
2347          NPLOTP=NPLOTP+1
2348          X2OUT(NPLOTP)=XMAX
2349          Y2OUT(NPLOTP)=YMEANF
2350          D2(NPLOTP)=TMAX
2351C
2352          P100=2.5
2353          CALL PERCEN(P100,ZMEAN,IBOOSS,IWRITE,TEMP2,MAXN,
2354     1                YMLCL,IBUGG3,IERROR)
2355          P100=97.5
2356          CALL PERCEN(P100,ZMEAN,IBOOSS,IWRITE,TEMP2,MAXN,
2357     1                YMUCL,IBUGG3,IERROR)
2358          TMAX=TMAX+1.0
2359          NPLOTP=NPLOTP+1
2360          X2OUT(NPLOTP)=XMIN
2361          Y2OUT(NPLOTP)=YMLCL
2362          D2(NPLOTP)=TMAX
2363          NPLOTP=NPLOTP+1
2364          X2OUT(NPLOTP)=XMAX
2365          Y2OUT(NPLOTP)=YMLCL
2366          D2(NPLOTP)=TMAX
2367          TMAX=TMAX+1.0
2368          NPLOTP=NPLOTP+1
2369          X2OUT(NPLOTP)=XMIN
2370          Y2OUT(NPLOTP)=YMUCL
2371          D2(NPLOTP)=TMAX
2372          NPLOTP=NPLOTP+1
2373          X2OUT(NPLOTP)=XMAX
2374          Y2OUT(NPLOTP)=YMUCL
2375          D2(NPLOTP)=TMAX
2376C
2377          YUPPER=YMEANF + 2.0*YSDF
2378          TMAX=TMAX+1.0
2379          NPLOTP=NPLOTP+1
2380          X2OUT(NPLOTP)=XMIN
2381          Y2OUT(NPLOTP)=YUPPER
2382          D2(NPLOTP)=TMAX
2383          NPLOTP=NPLOTP+1
2384          X2OUT(NPLOTP)=XMAX
2385          Y2OUT(NPLOTP)=YUPPER
2386          D2(NPLOTP)=TMAX
2387C
2388          P100=2.5
2389          CALL PERCEN(P100,Z975,IBOOSS,IWRITE,TEMP2,MAXN,
2390     1                YUPLCL,IBUGG3,IERROR)
2391          P100=97.5
2392          CALL PERCEN(P100,Z975,IBOOSS,IWRITE,TEMP2,MAXN,
2393     1                YUPUCL,IBUGG3,IERROR)
2394          TMAX=TMAX+1.0
2395          NPLOTP=NPLOTP+1
2396          X2OUT(NPLOTP)=XMIN
2397          Y2OUT(NPLOTP)=YUPLCL
2398          D2(NPLOTP)=TMAX
2399          NPLOTP=NPLOTP+1
2400          X2OUT(NPLOTP)=XMAX
2401          Y2OUT(NPLOTP)=YUPLCL
2402          D2(NPLOTP)=TMAX
2403          TMAX=TMAX+1.0
2404          NPLOTP=NPLOTP+1
2405          X2OUT(NPLOTP)=XMIN
2406          Y2OUT(NPLOTP)=YUPUCL
2407          D2(NPLOTP)=TMAX
2408          NPLOTP=NPLOTP+1
2409          X2OUT(NPLOTP)=XMAX
2410          Y2OUT(NPLOTP)=YUPUCL
2411          D2(NPLOTP)=TMAX
2412C
2413          YLOWER=YMEANF - 2.0*YSDF
2414          TMAX=TMAX+1.0
2415          NPLOTP=NPLOTP+1
2416          X2OUT(NPLOTP)=XMIN
2417          Y2OUT(NPLOTP)=YLOWER
2418          D2(NPLOTP)=TMAX
2419          NPLOTP=NPLOTP+1
2420          X2OUT(NPLOTP)=XMAX
2421          Y2OUT(NPLOTP)=YLOWER
2422          D2(NPLOTP)=TMAX
2423C
2424          P100=2.5
2425          CALL PERCEN(P100,Z25,IBOOSS,IWRITE,TEMP2,MAXN,
2426     1                YLOLCL,IBUGG3,IERROR)
2427          P100=97.5
2428          CALL PERCEN(P100,Z25,IBOOSS,IWRITE,TEMP2,MAXN,
2429     1                YLOUCL,IBUGG3,IERROR)
2430          TMAX=TMAX+1.0
2431          NPLOTP=NPLOTP+1
2432          X2OUT(NPLOTP)=XMIN
2433          Y2OUT(NPLOTP)=YLOLCL
2434          D2(NPLOTP)=TMAX
2435          NPLOTP=NPLOTP+1
2436          X2OUT(NPLOTP)=XMAX
2437          Y2OUT(NPLOTP)=YLOLCL
2438          D2(NPLOTP)=TMAX
2439          TMAX=TMAX+1.0
2440          NPLOTP=NPLOTP+1
2441          X2OUT(NPLOTP)=XMIN
2442          Y2OUT(NPLOTP)=YLOUCL
2443          D2(NPLOTP)=TMAX
2444          NPLOTP=NPLOTP+1
2445          X2OUT(NPLOTP)=XMAX
2446          Y2OUT(NPLOTP)=YLOUCL
2447          D2(NPLOTP)=TMAX
2448C
2449        ENDIF
2450      ENDIF
2451C
2452      NPLOTV=3
2453C
2454C               *****************
2455C               **  STEP 90--  **
2456C               **  EXIT       **
2457C               *****************
2458C
2459 9000 CONTINUE
2460      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BAP2')THEN
2461        WRITE(ICOUT,999)
2462        CALL DPWRST('XXX','BUG ')
2463        WRITE(ICOUT,9011)
2464 9011   FORMAT('***** AT THE END       OF DPBAP2--')
2465        CALL DPWRST('XXX','BUG ')
2466        WRITE(ICOUT,9012)IERROR,N2
2467 9012   FORMAT('IERROR,N2 = ',A4,2X,I8)
2468        CALL DPWRST('XXX','BUG ')
2469        DO9015I=1,NPLOTP
2470          WRITE(ICOUT,9016)I,Y2OUT(I),X2OUT(I),D2(I)
2471 9016     FORMAT('I,Y2OUT(I),X2OUT(I),D2(I) = ',I8,2G15.7,F9.2)
2472          CALL DPWRST('XXX','BUG ')
2473 9015   CONTINUE
2474      ENDIF
2475C
2476      RETURN
2477      END
2478      SUBROUTINE DPBAR2(Y,X,N,NUMV2,ICASPL,ISIZE,ICONT,
2479     1                  XIDTEM,TEMP,
2480     1                  Y2,X2,D2,N2,NPLOTV,IBUGG3,IERROR)
2481C
2482C     PURPOSE--GENERATE A QUADRUPLE OF COORDINATE VECTORS
2483C              THAT WILL DEFINE AN BAR PLOT.
2484C              IF ONLY 1 Y VALUE EXISTS FOR EACH X VALUE,
2485C              THEN A HISTOGRAM WILL RESULT (THE BAR WILL
2486C              REST ON 0);
2487C              IF MORE THAN 1 Y VALUE EXISTS FOR EACH X VALUE,
2488C              THEN THE BARS WILL BE SUSPENDED BETWEEN THE
2489C              MINIMUM AND MAXIMUM AT EACH X VALUE.
2490C     WRITTEN BY--JAMES J. FILLIBEN
2491C                 STATISTICAL ENGINEERING DIVISION
2492C                 INFORMATION TECHNOLOGY LABORATORY
2493C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2494C                 GAITHERSBURG, MD 20899-8980
2495C                 PHONE--301-975-2855
2496C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
2497C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
2498C     LANGUAGE--ANSI FORTRAN (1977)
2499C     VERSION NUMBER--82/7
2500C     ORIGINAL VERSION--DECEMBER  1982.
2501C     UPDATED         --JANUARY   1989.   CLASS WIDTH, 0 FREQ BARS (ALAN)
2502C
2503C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
2504C
2505      CHARACTER*4 ICASPL
2506      CHARACTER*4 ICONT
2507      CHARACTER*4 IBUGG3
2508      CHARACTER*4 IERROR
2509C
2510      CHARACTER*4 ISUBN1
2511      CHARACTER*4 ISUBN2
2512      CHARACTER*4 ISTEPN
2513C
2514C---------------------------------------------------------------------
2515C
2516      DIMENSION Y(*)
2517      DIMENSION X(*)
2518      DIMENSION Y2(*)
2519      DIMENSION X2(*)
2520      DIMENSION D2(*)
2521C
2522      DIMENSION XIDTEM(*)
2523      DIMENSION TEMP(*)
2524C
2525C---------------------------------------------------------------------
2526C
2527      INCLUDE 'DPCOPA.INC'
2528      INCLUDE 'DPCOSU.INC'
2529      INCLUDE 'DPCOP2.INC'
2530C
2531C-----DATA STATEMENTS-------------------------------------------------
2532C
2533C-----START POINT-----------------------------------------------------
2534C
2535      ISUBN1='DPBA'
2536      ISUBN2='R2  '
2537C
2538      K=(-999)
2539      KP1=(-999)
2540      I2=0
2541      AN=0.0
2542      KP4=0
2543C
2544      AN3=0
2545      DENOM=0.0
2546      CLWID=0.0
2547      XSTART=0.0
2548      XSTOP=0.0
2549C
2550C     CHECK THE INPUT ARGUMENTS FOR ERRORS
2551C
2552      IF(N.LT.1)THEN
2553        WRITE(ICOUT,999)
2554  999   FORMAT(1X)
2555        CALL DPWRST('XXX','BUG ')
2556        WRITE(ICOUT,31)
2557   31   FORMAT('***** ERROR IN DPBAR2--')
2558        CALL DPWRST('XXX','BUG ')
2559        WRITE(ICOUT,32)
2560   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;')
2561        CALL DPWRST('XXX','BUG ')
2562        WRITE(ICOUT,34)N
2563   34   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I6)
2564        CALL DPWRST('XXX','BUG ')
2565        WRITE(ICOUT,999)
2566        CALL DPWRST('XXX','BUG ')
2567        IERROR='YES'
2568        GOTO9000
2569      ENDIF
2570C
2571      IF(IBUGG3.EQ.'ON')THEN
2572        WRITE(ICOUT,70)
2573   70   FORMAT('AT THE BEGINNING OF DPBAR2--')
2574        CALL DPWRST('XXX','BUG ')
2575        WRITE(ICOUT,71)ICASPL,ICONT,N,NUMV2,ISIZE
2576   71   FORMAT('ICASPL,ICONT,N,NUMV2,ISIZE = ',2(A4,2X),3I8)
2577        CALL DPWRST('XXX','BUG ')
2578        DO72I=1,N
2579          WRITE(ICOUT,73)I,Y(I),X(I)
2580   73     FORMAT('I, Y(I), X(I) = ',I8,2G15.7)
2581          CALL DPWRST('XXX','BUG ')
2582   72   CONTINUE
2583      ENDIF
2584C
2585C               ********************************************************
2586C               **  STEP 1--                                          **
2587C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
2588C               **  FOR VARIABLE 2 (THE GROUP VARIABLE).              **
2589C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
2590C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
2591C               **  WHICH MEANS THAT A HISTOGRAM SHOULD RESULT        **
2592C               ********************************************************
2593C
2594      ISTEPN='1'
2595      IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2596C
2597      IF(NUMV2.EQ.1)GOTO110
2598      IF(NUMV2.EQ.2)GOTO150
2599C
2600  110 CONTINUE
2601      NUMSET=0
2602      DO120I=ISIZE,N,ISIZE
2603      I2=I
2604      NUMSET=NUMSET+1
2605      XIDTEM(NUMSET)=NUMSET
2606  120 CONTINUE
2607      IF(I2.LT.N)GOTO130
2608      GOTO140
2609  130 CONTINUE
2610      NUMSET=NUMSET+1
2611      XIDTEM(NUMSET)=NUMSET
2612  140 CONTINUE
2613      DO145I=1,N
2614      IGROUP=1+((I-1)/ISIZE)
2615      IMID=(IGROUP-1)*ISIZE+(ISIZE/2)
2616      X(I)=IMID
2617  145 CONTINUE
2618      GOTO190
2619C
2620  150 CONTINUE
2621      NUMSET=0
2622      DO160I=1,N
2623      IF(NUMSET.EQ.0)GOTO165
2624      DO170J=1,NUMSET
2625      IF(X(I).EQ.XIDTEM(J))GOTO160
2626  170 CONTINUE
2627  165 CONTINUE
2628      NUMSET=NUMSET+1
2629      XIDTEM(NUMSET)=X(I)
2630  160 CONTINUE
2631      CALL SORT(XIDTEM,NUMSET,XIDTEM)
2632C
2633      XID1=XIDTEM(1)
2634      XID2=XIDTEM(NUMSET)
2635C
2636  190 CONTINUE
2637C
2638      IF(NUMSET.EQ.0)WRITE(ICOUT,191)
2639  191 FORMAT('ERROR IN DPBAR2   SUBROUTINE--NUMSET = 0')
2640      IF(NUMSET.EQ.0)CALL DPWRST('XXX','BUG ')
2641      IF(NUMSET.EQ.0)GOTO9000
2642      IF(NUMSET.EQ.0)IERROR='YES'
2643C
2644      IF(NUMSET.EQ.N)GOTO1000
2645      GOTO2000
2646C
2647C               ********************************
2648C               **  STEP 4--                  **
2649C               **  TREAT THE HISTOGRAM CASE  **
2650C               ********************************
2651C
2652 1000 CONTINUE
2653      ISTEPN='4'
2654      IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2655C
2656      KP3=0
2657C
2658      AN3=0.0
2659      DENOM=0.0
2660C
2661C               **********************************************
2662C               **  STEP 4.1--                               **
2663C               **  IF NECESSARY,                           **
2664C               **  DETERMINE CLASS WIDTH,                  **
2665C               **  START VALUE, STOP VALUE,                **
2666C               **  AND NUMBER OF CLASSES.                  **
2667C               **********************************************
2668C
2669      CALL SORT(X,N,D2)
2670      NM1=N-1
2671C  BUG FIX: (AUGUST, 1987) USE CLASS WIDTH PARAMETER IF SPECIFIED
2672      CLWID=CLWIDT(1)
2673      IF(CLWID.GT.0.0)GOTO1105
2674C  END FIX
2675      CLWID=D2(2)-D2(1)
2676      DO1100I=1,NM1
2677      IP1=I+1
2678      DELI=D2(IP1)-D2(I)
2679      IF(DELI.LT.CLWID)CLWID=DELI
2680 1100 CONTINUE
2681C  BUG FIX CONTINUED
2682 1105 CONTINUE
2683C  END FIX
2684      XSTART=D2(1)-(CLWID/2.0)
2685      XSTOP=D2(N)+(CLWID/2.0)
2686C
2687      TOTWID=XSTOP-XSTART
2688      ANUMCL=TOTWID/CLWID
2689      NUMCLA=INT(ANUMCL+1.0+0.1)
2690C
2691      J=NUMCLA-1
2692      AJ=J
2693      CLMAXJ=XSTART+AJ*CLWID
2694      ABSDEL=ABS(CLMAXJ-XSTOP)
2695      IF(ABSDEL.LE.0.0001)NUMCLA=NUMCLA-1
2696C
2697C               *******************************************************
2698C               **  STEP 4.2--                                       **
2699C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
2700C               *******************************************************
2701C
2702      DO1300J=1,NUMCLA
2703      D2(J)=0.0
2704 1300 CONTINUE
2705C
2706      DO1520I=1,N
2707      DO1530J=1,NUMCLA
2708      J2=J
2709      AJ=J
2710      CLMINJ=XSTART+(AJ-1.0)*CLWID
2711      CLMAXJ=XSTART+AJ*CLWID
2712      IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
2713      IF(CLMINJ.LE.X(I).AND.X(I).LT.CLMAXJ)GOTO1540
2714 1530 CONTINUE
2715      GOTO1520
2716 1540 CONTINUE
2717      D2(J2)=D2(J2)+Y(I)
2718 1520 CONTINUE
2719C
2720C     TREAT THE SPECIAL CASE OF EQUALITY
2721C     WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
2722C     (ALTHOUGH THIS SHOULD NOT HAPPEN)
2723C
2724      J=NUMCLA
2725      DO1550I=1,N
2726      AJ=J
2727      CLMAXJ=XSTART+AJ*CLWID
2728      IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
2729      IF(X(I).EQ.CLMAXJ)D2(J)=D2(J)+Y(I)
2730 1550 CONTINUE
2731      GOTO1590
2732C
2733 1590 CONTINUE
2734      IF(IBUGG3.EQ.'OFF')GOTO1595
2735      WRITE(ICOUT,999)
2736      CALL DPWRST('XXX','BUG ')
2737      WRITE(ICOUT,1591)
2738 1591 FORMAT('***** IN THE MIDDLE    OF DPBAR2--')
2739      CALL DPWRST('XXX','BUG ')
2740      WRITE(ICOUT,1592)CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA
2741 1592 FORMAT('CLWID,XSTART,XSTOP,TOTWID,ANUMCL,NUMCLA= ',5E11.4,I8)
2742      CALL DPWRST('XXX','BUG ')
2743      DO1593J=1,NUMCLA
2744      AJ=J
2745      CLMINJ=XSTART+(AJ-1.0)*CLWID
2746      CLMAXJ=XSTART+AJ*CLWID
2747      IF(CLMAXJ.GT.XSTOP)CLMAXJ=XSTOP
2748      FJ=D2(J)
2749      WRITE(ICOUT,1594)J,CLMINJ,CLMAXJ,FJ
2750 1594 FORMAT('J,CLMINJ,CLMAXJ,FJ = ',I8,3E15.7)
2751      CALL DPWRST('XXX','BUG ')
2752 1593 CONTINUE
2753 1595 CONTINUE
2754C
2755C               **********************************
2756C               **  STEP 4.3--                  **
2757C               **  DETERMINE PLOT COORDINATES  **
2758C               **********************************
2759C
2760CCCCC IF(BAWID.EQ.CPUMIN)BAWID=CLWID
2761C
2762      SUM=0.0
2763      DO1610J=1,NUMCLA
2764      FJ=D2(J)
2765      SUM=SUM+FJ
2766 1610 CONTINUE
2767      AN3=SUM
2768C
2769      DENOM=1.0
2770C  BUG FIX: AUGUST, 1987 DO NOT PLOT ZERO FREQUENCY BARS
2771      K=0
2772C  END BUG FIX
2773C
2774      DO1620J=1,NUMCLA
2775C
2776CCCCC K=4*(J-1)+1
2777CCCCC KP1=K+1
2778CCCCC KP2=K+2
2779CCCCC KP3=K+3
2780C  BUG FIX CONTINUED
2781CCCCC K=J
2782C  END BUG FIX
2783C
2784CCCCC AJ=J
2785CCCCC CLMIDJ=XSTART+(AJ-0.5)*CLWID
2786CCCCC BAMINJ=CLMIDJ-BAWID/2.0
2787CCCCC BAMAXJ=CLMIDJ+BAWID/2.0
2788      AJ=J
2789      CLMIDJ=XSTART+(AJ-0.5)*CLWID
2790C
2791      FJ=D2(J)
2792C  BUG FIX CONTINUED
2793      IF(ABS(FJ).LE.CPUMIN)GOTO1620
2794      K=K+1
2795C  END FIX
2796C
2797CCCCC X2(K)=BAMINJ
2798CCCCC X2(KP1)=BAMINJ
2799CCCCC X2(KP2)=BAMAXJ
2800CCCCC X2(KP3)=BAMAXJ
2801      X2(K)=CLMIDJ
2802C
2803CCCCC Y2(K)=0.0
2804CCCCC Y2(KP1)=FJ/DENOM
2805CCCCC Y2(KP2)=FJ/DENOM
2806CCCCC Y2(KP3)=0.0
2807      Y2(K)=FJ/DENOM
2808C
2809 1620 CONTINUE
2810C
2811C  BUG FIX CONTINUED
2812       NUMCLA=K
2813C  END FIX
2814      DO1720J=1,NUMCLA
2815C
2816CCCCC K=4*(J-1)+1
2817CCCCC KP1=K+1
2818CCCCC KP2=K+2
2819CCCCC KP3=K+3
2820      K=J
2821C
2822CCCCC D2(K)=J
2823CCCCC D2(KP1)=J
2824CCCCC D2(KP2)=J
2825CCCCC D2(KP3)=J
2826      D2(K)=J
2827C
2828 1720 CONTINUE
2829CCCCC N2=KP3
2830      N2=K
2831      NPLOTV=3
2832      GOTO9000
2833C
2834C               *****************************************************
2835C               **  STEP 14--                                       **
2836C               **  TREAT THE SUSPENDED BAR CASE.                  **
2837C               **  STEP THROUGH THE VARIOUS HORIZONTAL AXIS SETS  **
2838C               **  AND COMPUTE BAR COORDINATES FOR EACH SET.      **
2839C               *****************************************************
2840C
2841 2000 CONTINUE
2842C
2843      ISTEPN='14'
2844      IF(IBUGG3.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
2845C
2846      NUMSM1=NUMSET-1
2847C  CONTINUE BUG FIX
2848      CLWID=CLWIDT(1)
2849      IF(CLWID.GT.0.)GOTO2060
2850C  END FIX
2851      CLWID=XIDTEM(2)-XIDTEM(1)
2852      DO2050I=1,NUMSM1
2853      IP1=I+1
2854      DELI=XIDTEM(IP1)-XIDTEM(I)
2855      IF(DELI.LT.CLWID)CLWID=DELI
2856 2050 CONTINUE
2857C  CONTINUE BUG FIX
2858 2060 CONTINUE
2859C  END FIX
2860CCCCC IF(BAWID.EQ.CPUMIN)BAWID=CLWID
2861C
2862      AN=N
2863      ANUMSE=NUMSET
2864C
2865      J=0
2866      JD=0
2867      DO2100ISET=1,NUMSET
2868C
2869      K=0
2870      DO2120I=1,N
2871      IF(X(I).EQ.XIDTEM(ISET))K=K+1
2872      IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
2873 2120 CONTINUE
2874      NI=K
2875      ANI=NI
2876C
2877      IF(IBUGG3.EQ.'ON')THEN
2878        WRITE(ICOUT,2121)ISET,XIDTEM(ISET),NI
2879 2121   FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
2880        CALL DPWRST('XXX','BUG ')
2881      ENDIF
2882C
2883      IF(NI.LE.0)GOTO2140
2884      GOTO2149
2885C
2886 2140 CONTINUE
2887      WRITE(ICOUT,999)
2888      CALL DPWRST('XXX','BUG ')
2889      WRITE(ICOUT,2141)
2890 2141 FORMAT('***** INTERNAL ERROR IN DPBAR2--')
2891      CALL DPWRST('XXX','BUG ')
2892      WRITE(ICOUT,2142)
2893 2142 FORMAT('NI FOR SOME CLASS = 0')
2894      CALL DPWRST('XXX','BUG ')
2895      WRITE(ICOUT,2143)ISET,XIDTEM(ISET),NI
2896 2143 FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
2897      CALL DPWRST('XXX','BUG ')
2898      IERROR='YES'
2899      GOTO9000
2900 2149 CONTINUE
2901C
2902      CALL SORT(TEMP,NI,TEMP)
2903      YMIN=TEMP(1)
2904      YMAX=TEMP(NI)
2905      IF(IBUGG3.EQ.'ON')WRITE(ICOUT,2151)YMIN,YMAX,ISET,K,TEMP(K)
2906 2151 FORMAT('YMIN,YMAX,ISET,K,TEMP(K) = ',2E15.7,2I8,E15.7)
2907      IF(IBUGG3.EQ.'ON')CALL DPWRST('XXX','BUG ')
2908C
2909      J=ISET
2910C
2911CCCCC K=5*(J-1)+1
2912CCCCC KP1=K+1
2913CCCCC KP2=K+2
2914CCCCC KP3=K+3
2915CCCCC KP4=K+4
2916      K=2*(J-1)+1
2917      KP1=K+1
2918C
2919CCCCC CLMIDJ=XIDTEM(ISET)
2920CCCCC BAMINJ=CLMIDJ-BAWID/2.0
2921CCCCC BAMAXJ=CLMIDJ+BAWID/2.0
2922      CLMIDJ=XIDTEM(ISET)
2923C
2924CCCCC X2(K)=BAMINJ
2925CCCCC X2(KP1)=BAMINJ
2926CCCCC X2(KP2)=BAMAXJ
2927CCCCC X2(KP3)=BAMAXJ
2928CCCCC X2(KP4)=BAMINJ
2929      X2(K)=CLMIDJ
2930      X2(KP1)=CLMIDJ
2931C
2932CCCCC Y2(K)=YMIN
2933CCCCC Y2(KP1)=YMAX
2934CCCCC Y2(KP2)=YMAX
2935CCCCC Y2(KP3)=YMIN
2936CCCCC Y2(KP4)=YMIN
2937      Y2(K)=YMIN
2938      Y2(KP1)=YMAX
2939C
2940CCCCC D2(K)=J
2941CCCCC D2(KP1)=J
2942CCCCC D2(KP2)=J
2943CCCCC D2(KP3)=J
2944CCCCC D2(KP4)=J
2945      D2(K)=J
2946      D2(KP1)=J
2947C
2948C
2949 2100 CONTINUE
2950CCCCC N2=KP4
2951      N2=KP1
2952      NPLOTV=3
2953C
2954C               ******************
2955C               **   STEP 90--  **
2956C               **   EXIT       **
2957C               ******************
2958C
2959 9000 CONTINUE
2960      IF(IBUGG3.EQ.'ON')THEN
2961        WRITE(ICOUT,999)
2962        CALL DPWRST('XXX','BUG ')
2963        WRITE(ICOUT,9011)
2964 9011   FORMAT('***** AT THE END       OF DPBAR2--')
2965        CALL DPWRST('XXX','BUG ')
2966        WRITE(ICOUT,9012)NUMSET,N2,NUMV2,NI,IERROR
2967 9012   FORMAT('NUMSET,N2,NUMV2,NI,IERROR = ',4I8,2X,A4)
2968        CALL DPWRST('XXX','BUG ')
2969        DO9015I=1,N2
2970          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
2971 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2)
2972          CALL DPWRST('XXX','BUG ')
2973 9015   CONTINUE
2974        WRITE(ICOUT,9033)AN,AN3,DENOM
2975 9033   FORMAT('AN,AN3,DENOM = ',2F10.1,G15.7)
2976        CALL DPWRST('XXX','BUG ')
2977        WRITE(ICOUT,9037)N,CLWID,XSTART,XSTOP
2978 9037   FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3G15.7)
2979        CALL DPWRST('XXX','BUG ')
2980        DO9050I=1,NUMSET
2981          WRITE(ICOUT,9051)I,XIDTEM(I)
2982 9051     FORMAT('I,XIDTEM(I) = ',I8,E15.7)
2983          CALL DPWRST('XXX','BUG ')
2984 9050   CONTINUE
2985      ENDIF
2986C
2987      RETURN
2988      END
2989      SUBROUTINE DPBARP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
2990     1                  IBUGG2,IBUGG3,IBUGQ,IFOUND,IERROR)
2991C
2992C     PURPOSE--GENERATE A BAR PLOT = A BAR CHART =
2993C              A HISTOGRAM
2994C     WRITTEN BY--JAMES J. FILLIBEN
2995C                 STATISTICAL ENGINEERING DIVISION
2996C                 INFORMATION TECHNOLOGY LABORATORY
2997C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
2998C                 GAITHERSBURG, MD 20899-8980
2999C                 PHONE--301-975-2855
3000C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3001C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3002C     LANGUAGE--ANSI FORTRAN (1977)
3003C     VERSION NUMBER--82/7
3004C     ORIGINAL VERSION--DECEMBER  1982.
3005C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
3006C
3007C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3008C
3009      CHARACTER*4 ICASPL
3010      CHARACTER*4 IAND1
3011      CHARACTER*4 IAND2
3012      CHARACTER*4 IBUGG2
3013      CHARACTER*4 IBUGG3
3014      CHARACTER*4 IBUGQ
3015      CHARACTER*4 IFOUND
3016      CHARACTER*4 IERROR
3017C
3018      CHARACTER*4 IRELAT
3019      CHARACTER*4 IHWUSE
3020      CHARACTER*4 MESSAG
3021      CHARACTER*4 ICASEQ
3022      CHARACTER*4 IDATA
3023      CHARACTER*4 IHLEFT
3024      CHARACTER*4 IHLEF2
3025      CHARACTER*4 IHRIGH
3026      CHARACTER*4 IHRIG2
3027      CHARACTER*4 IERRO4
3028      CHARACTER*4 ICONT
3029C
3030      CHARACTER*4 ISUBN1
3031      CHARACTER*4 ISUBN2
3032      CHARACTER*4 ISTEPN
3033C
3034C---------------------------------------------------------------------
3035C
3036      INCLUDE 'DPCOPA.INC'
3037C
3038CCCCC DIMENSION BAWIDT(*)
3039C
3040      DIMENSION Y1(MAXOBV)
3041      DIMENSION X1(MAXOBV)
3042      DIMENSION XIDTEM(MAXOBV)
3043      DIMENSION TEMP(MAXOBV)
3044CCCCC FOLLOWING LINES ADDED JUNE, 1990
3045      INCLUDE 'DPCOZZ.INC'
3046      EQUIVALENCE (GARBAG(IGARB1),X1(1))
3047      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
3048      EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1))
3049      EQUIVALENCE (GARBAG(IGARB4),TEMP(1))
3050CCCCC END CHANGE
3051C
3052C-----COMMON----------------------------------------------------------
3053C
3054      INCLUDE 'DPCOHK.INC'
3055      INCLUDE 'DPCODA.INC'
3056C
3057C-----COMMON VARIABLES (GENERAL)--------------------------------------
3058C
3059      INCLUDE 'DPCOP2.INC'
3060C
3061C-----START POINT-----------------------------------------------------
3062C
3063      IFOUND='NO'
3064      IERROR='NO'
3065      ISUBN1='DPBA'
3066      ISUBN2='RP  '
3067C
3068      MAXCP1=MAXCOL+1
3069      MAXCP2=MAXCOL+2
3070C
3071      MAXV2=2
3072      MINN2=2
3073C
3074      ICOLR=0
3075C
3076C               *******************************
3077C               **  TREAT THE BAR PLOT CASE  **
3078C               *******************************
3079C
3080      IF(IBUGG2.EQ.'OFF')GOTO90
3081      WRITE(ICOUT,999)
3082      CALL DPWRST('XXX','BUG ')
3083      WRITE(ICOUT,51)
3084   51 FORMAT('***** AT THE BEGINNING OF DPBARP--')
3085      CALL DPWRST('XXX','BUG ')
3086      WRITE(ICOUT,52)ICASPL,IAND1,IAND2
3087   52 FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
3088      CALL DPWRST('XXX','BUG ')
3089      WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ
3090   53 FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4)
3091      CALL DPWRST('XXX','BUG ')
3092CCCCC WRITE(ICOUT,54)BAWIDT(1),BAWIDT(2)
3093CCC54 FORMAT('BAWIDT(1),BAWIDT(2) = ',2E15.7)
3094CCCCC CALL DPWRST('XXX','BUG ')
3095   90 CONTINUE
3096C
3097C               ***************************
3098C               **  STEP 1--             **
3099C               **  EXTRACT THE COMMAND  **
3100C               ***************************
3101C
3102      ISTEPN='1'
3103      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3104C
3105      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')GOTO110
3106      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'CHAR')GOTO110
3107C
3108      IFOUND='NO'
3109      GOTO9000
3110C
3111  110 CONTINUE
3112      ICASPL='BARP'
3113      IRELAT='OFF'
3114      ILASTC=1
3115      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
3116      GOTO180
3117C
3118  180 CONTINUE
3119      IFOUND='YES'
3120      GOTO190
3121C
3122  190 CONTINUE
3123C
3124C               *******************************************************
3125C               **  STEP 2--                                         **
3126C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
3127C               *******************************************************
3128C
3129      ISTEPN='1'
3130      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3131C
3132      MINNA=1
3133      MAXNA=100
3134      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
3135      IF(IERROR.EQ.'YES')GOTO9000
3136C
3137C               ********************************************
3138C               **  STEP 2--                              **
3139C               **  CHECK THE VALIDITY OF ARGUMENT 1      **
3140C               **  (THIS WILL BE THE RESPONSE VARIABLE)  **
3141C               ********************************************
3142C
3143      ISTEPN='2'
3144      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3145C
3146      IHLEFT=IHARG(1)
3147      IHLEF2=IHARG2(1)
3148      IHWUSE='V'
3149      MESSAG='YES'
3150      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
3151     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
3152     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
3153      IF(IERROR.EQ.'YES')GOTO9000
3154      ICOLL=IVALUE(ILOCV)
3155      NLEFT=IN(ILOCV)
3156      IF(IBUGG2.EQ.'ON')WRITE(ICOUT,211)IHLEFT,IHLEF2,ICOLL,NLEFT
3157  211 FORMAT('IHLEFT,IHLEF2,ICOLL,NLEFT = ',A4,2X,A4,I8,I8)
3158      IF(IBUGG2.EQ.'ON')CALL DPWRST('XXX','BUG ')
3159C
3160C               ***************************************************************
3161C               **  STEP 3--                                                 **
3162C               **  CHECK THAT THE INPUT NUMBER OF OBSERVATIONS (NLEFT)      **
3163C               **  FOR THE RESPONSE VARIABLE IS POSITIVE.                   **
3164C               ***************************************************************
3165C
3166      ISTEPN='3'
3167      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3168C
3169      IF(NLEFT.GE.MINN2)GOTO390
3170      WRITE(ICOUT,999)
3171  999 FORMAT(1X)
3172      CALL DPWRST('XXX','BUG ')
3173      WRITE(ICOUT,311)
3174  311 FORMAT('***** ERROR IN DPBARP--')
3175      CALL DPWRST('XXX','BUG ')
3176      WRITE(ICOUT,312)
3177  312 FORMAT('      THE INPUT NUMBER OF OBSERVATIONS')
3178      CALL DPWRST('XXX','BUG ')
3179      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,321)
3180  321 FORMAT('      (FOR WHICH A HISTOGRAM ')
3181      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ')
3182      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,322)
3183  322 FORMAT('      (FOR WHICH A RELATIVE HISTOGRAM ')
3184      IF(ICASPL.EQ.'HIST'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ')
3185      IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'OFF')WRITE(ICOUT,323)
3186  323 FORMAT('      (FOR WHICH A CUMULATIVE HISTOGRAM ')
3187      IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'OFF')CALL DPWRST('XXX','BUG ')
3188      IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'ON')WRITE(ICOUT,324)
3189  324 FORMAT('      (FOR WHICH A RELATIVE CUMULATIVE HISTOGRAM ')
3190      IF(ICASPL.EQ.'CUMH'.AND.IRELAT.EQ.'ON')CALL DPWRST('XXX','BUG ')
3191      WRITE(ICOUT,314)
3192  314 FORMAT('      WAS TO HAVE BEEN FORMED)')
3193      CALL DPWRST('XXX','BUG ')
3194      WRITE(ICOUT,315)MINN2
3195  315 FORMAT('      MUST BE ',I8,' OR LARGER;')
3196      CALL DPWRST('XXX','BUG ')
3197      WRITE(ICOUT,316)
3198  316 FORMAT('      SUCH WAS NOT THE CASE HERE.')
3199      CALL DPWRST('XXX','BUG ')
3200      WRITE(ICOUT,317)
3201  317 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
3202      CALL DPWRST('XXX','BUG ')
3203      IF(IWIDTH.GE.1)WRITE(ICOUT,318)(IANS(I),I=1,IWIDTH)
3204  318 FORMAT(80A1)
3205      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
3206      IERROR='YES'
3207      GOTO9000
3208  390 CONTINUE
3209C
3210C               *****************************************
3211C               **  STEP 4--                           **
3212C               **  CHECK TO SEE THE TYPE SUBCASE      **
3213C               **  (BASED ON THE QUALIFIER)--         **
3214C               **    1) UNQUALIFIED (THAT IS, FULL);  **
3215C               **    2) SUBSET/EXCEPT; OR             **
3216C               **    3) FOR.                          **
3217C               *****************************************
3218C
3219      ISTEPN='4'
3220      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3221C
3222      ICASEQ='FULL'
3223      ILOCQ=NUMARG+1
3224      IF(NUMARG.LT.1)GOTO480
3225      DO400J=1,NUMARG
3226      J1=J
3227      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO410
3228      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO410
3229      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO420
3230  400 CONTINUE
3231      GOTO490
3232  410 CONTINUE
3233      ICASEQ='SUBS'
3234      ILOCQ=J1
3235      GOTO490
3236  420 CONTINUE
3237      ICASEQ='FOR'
3238      ILOCQ=J1
3239      GOTO490
3240C
3241  480 CONTINUE
3242      WRITE(ICOUT,999)
3243      CALL DPWRST('XXX','BUG ')
3244      WRITE(ICOUT,481)
3245  481 FORMAT('***** INTERNAL ERROR IN DPBARP')
3246      CALL DPWRST('XXX','BUG ')
3247      WRITE(ICOUT,482)
3248  482 FORMAT('      AT BRANCH POINT 481--')
3249      CALL DPWRST('XXX','BUG ')
3250      WRITE(ICOUT,483)
3251  483 FORMAT('      NUMARG LESS THAN 1 EVEN THOUGH')
3252      CALL DPWRST('XXX','BUG ')
3253      WRITE(ICOUT,484)
3254  484 FORMAT('      NUMARG HAD PREVIOUSLY PASSED THIS TEST')
3255      CALL DPWRST('XXX','BUG ')
3256      WRITE(ICOUT,485)NUMARG
3257  485 FORMAT('      ONCE ALREADY.  VALUE OF NUMARG = ',I8)
3258      CALL DPWRST('XXX','BUG ')
3259      WRITE(ICOUT,486)
3260  486 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
3261      CALL DPWRST('XXX','BUG ')
3262      IF(IWIDTH.GE.1)WRITE(ICOUT,487)(IANS(I),I=1,IWIDTH)
3263  487 FORMAT(80A1)
3264      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
3265      IERROR='YES'
3266      GOTO9000
3267C
3268  490 CONTINUE
3269      IF(IBUGG2.EQ.'OFF')GOTO495
3270      WRITE(ICOUT,491)NUMARG,ILOCQ,ICASEQ
3271  491 FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
3272      CALL DPWRST('XXX','BUG ')
3273  495 CONTINUE
3274C
3275C               ******************************************************
3276C               **  STEP 5--                                        **
3277C               **  IF A SECOND ARGUMENT EXISTS (AS IT SHOULD), THEN THIS
3278C               **  INDICATES THAT THE VALUES IN THE                **
3279C               **  FIRST  VARIABLE ARE NOT DATA POINTS             **
3280C               **  BUT ALREADY-COMPUTED FREQUENCIES,               **
3281C               **  AND THE VALUES IN THE SECOND VARIABLE           **
3282C               **  ARE THE CORRESPONDING X VALUES FOR EACH         **
3283C               **  FREQUENCY.  IF WE HAVE THE 2-VARIABLE CASE,     **
3284C               **  CHECK THE VALIDITY OF THE SECOND (X) VARIABLE.  **
3285C               ******************************************************
3286C
3287      ISTEPN='5'
3288      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3289C
3290      NUMV2=ILOCQ-1
3291      IDATA='FREQ'
3292      IF(NUMV2.EQ.2)GOTO509
3293      GOTO550
3294C
3295  509 CONTINUE
3296      IHRIGH=IHARG(2)
3297      IHRIG2=IHARG2(2)
3298      IHWUSE='V'
3299      MESSAG='YES'
3300      CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
3301     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
3302     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
3303      IF(IERROR.EQ.'YES')GOTO9000
3304      ICOLR=IVALUE(ILOCV)
3305      NRIGHT=IN(ILOCV)
3306C
3307      IF(IBUGG2.EQ.'ON')THEN
3308        WRITE(ICOUT,511)IHRIGH,IHRIG2,ICOLR,NRIGHT
3309  511   FORMAT('IHRIGH,IHRIG2,ICOLR,NRIGHT = ',A4,2X,A4,I8,I8)
3310        CALL DPWRST('XXX','BUG ')
3311      ENDIF
3312C
3313      IF(NRIGHT.NE.NLEFT)GOTO570
3314      GOTO590
3315C
3316  550 CONTINUE
3317      WRITE(ICOUT,999)
3318      CALL DPWRST('XXX','BUG ')
3319      WRITE(ICOUT,551)
3320  551 FORMAT('***** ERROR IN DPBARP--')
3321      CALL DPWRST('XXX','BUG ')
3322      WRITE(ICOUT,552)
3323  552 FORMAT('      FOR A BAR PLOT, ')
3324      CALL DPWRST('XXX','BUG ')
3325      WRITE(ICOUT,558)
3326  558 FORMAT('      THE NUMBER OF VARIABLES ')
3327      CALL DPWRST('XXX','BUG ')
3328      WRITE(ICOUT,559)
3329  559 FORMAT('      MUST BE EXACTLY 2  ;')
3330      CALL DPWRST('XXX','BUG ')
3331      WRITE(ICOUT,560)
3332  560 FORMAT('      SUCH WAS NOT THE CASE HERE;')
3333      CALL DPWRST('XXX','BUG ')
3334      WRITE(ICOUT,561)
3335  561 FORMAT('      THE SPECIFIED NUMBER')
3336      CALL DPWRST('XXX','BUG ')
3337      WRITE(ICOUT,562)NUMV2
3338  562 FORMAT('      OF VARIABLES WAS ',I8)
3339      CALL DPWRST('XXX','BUG ')
3340      WRITE(ICOUT,563)
3341  563 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
3342      CALL DPWRST('XXX','BUG ')
3343      IF(IWIDTH.GE.1)WRITE(ICOUT,564)(IANS(I),I=1,IWIDTH)
3344  564 FORMAT(80A1)
3345      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
3346      IERROR='YES'
3347      GOTO9000
3348C
3349  570 CONTINUE
3350      WRITE(ICOUT,999)
3351      CALL DPWRST('XXX','BUG ')
3352      WRITE(ICOUT,571)
3353  571 FORMAT('***** ERROR IN DPBARP--')
3354      CALL DPWRST('XXX','BUG ')
3355      WRITE(ICOUT,572)
3356  572 FORMAT('      FOR A BAR PLOT, ')
3357      CALL DPWRST('XXX','BUG ')
3358      WRITE(ICOUT,579)
3359  579 FORMAT('      THE NUMBER OF ELEMENTS')
3360      CALL DPWRST('XXX','BUG ')
3361      WRITE(ICOUT,580)
3362  580 FORMAT('      IN THE 2 VARIABLES ')
3363      CALL DPWRST('XXX','BUG ')
3364      WRITE(ICOUT,581)
3365  581 FORMAT('      MUST BE THE SAME; ')
3366      CALL DPWRST('XXX','BUG ')
3367      WRITE(ICOUT,582)
3368  582 FORMAT('      SUCH WAS NOT THE CASE HERE.')
3369      CALL DPWRST('XXX','BUG ')
3370      WRITE(ICOUT,999)
3371      CALL DPWRST('XXX','BUG ')
3372      WRITE(ICOUT,583)
3373  583 FORMAT('      THE FIRST  VARIABLE  (FREQUENCIES)--')
3374      CALL DPWRST('XXX','BUG ')
3375      WRITE(ICOUT,584)IHLEFT,IHLEF2,NLEFT
3376  584 FORMAT('                  ',A4,A4,'  HAS ',I8,' ELEMENTS')
3377      CALL DPWRST('XXX','BUG ')
3378      WRITE(ICOUT,585)
3379  585 FORMAT('      THE SECOND VARIABLE  (HORIZ. AXIS VALUES)--')
3380      CALL DPWRST('XXX','BUG ')
3381      WRITE(ICOUT,586)IHRIGH,IHRIG2,NRIGHT
3382  586 FORMAT('                  ',A4,A4,'  HAS ',I8,' ELEMENTS')
3383      CALL DPWRST('XXX','BUG ')
3384      WRITE(ICOUT,999)
3385      CALL DPWRST('XXX','BUG ')
3386      WRITE(ICOUT,587)
3387  587 FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
3388      CALL DPWRST('XXX','BUG ')
3389      IF(IWIDTH.GE.1)WRITE(ICOUT,588)(IANS(I),I=1,IWIDTH)
3390  588 FORMAT(80A1)
3391      IF(IWIDTH.GE.1)CALL DPWRST('XXX','BUG ')
3392      IERROR='YES'
3393      GOTO9000
3394C
3395  590 CONTINUE
3396C
3397C               *****************************************
3398C               **  STEP 6--                           **
3399C               **  BRANCH TO THE APPROPRIATE SUBCASE; **
3400C               **  (BASED ON THE QUALIFIER)           **
3401C               **  THEN FORM THE RESPONSE VARIABLE    **
3402C               **  AND THE FACTORS                    **
3403C               **  AND CARRY OUT THE PLOTS.           **
3404C               *****************************************
3405C
3406      ISTEPN='6'
3407      IF(IBUGG2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3408C
3409      IF(ICASEQ.EQ.'FULL')GOTO610
3410      IF(ICASEQ.EQ.'SUBS')GOTO620
3411      IF(ICASEQ.EQ.'FOR')GOTO630
3412C
3413  610 CONTINUE
3414      DO615I=1,NLEFT
3415      ISUB(I)=1
3416  615 CONTINUE
3417      NQ=NLEFT
3418      GOTO650
3419C
3420  620 CONTINUE
3421      NIOLD=NLEFT
3422      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERRO4)
3423      NQ=NIOLD
3424      GOTO650
3425C
3426  630 CONTINUE
3427      NIOLD=NLEFT
3428      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
3429     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
3430      NQ=NFOR
3431      GOTO650
3432C
3433  650 CONTINUE
3434      J=0
3435      IMAX=NLEFT
3436      IF(NQ.LT.NLEFT)IMAX=NQ
3437      DO660I=1,IMAX
3438      IF(ISUB(I).EQ.0)GOTO660
3439      J=J+1
3440C
3441      IF(NUMV2.LE.1)GOTO651
3442      GOTO652
3443C
3444  651 CONTINUE
3445      IJ=MAXN*(ICOLL-1)+I
3446      IF(ICOLL.LE.MAXCOL)X1(J)=V(IJ)
3447      IF(ICOLL.EQ.MAXCP1)X1(J)=PRED(I)
3448      IF(ICOLL.EQ.MAXCP2)X1(J)=RES(I)
3449      GOTO660
3450C
3451  652 CONTINUE
3452      IJ=MAXN*(ICOLR-1)+I
3453      IF(ICOLR.LE.MAXCOL)X1(J)=V(IJ)
3454      IF(ICOLR.EQ.MAXCP1)X1(J)=PRED(I)
3455      IF(ICOLR.EQ.MAXCP2)X1(J)=RES(I)
3456      IJ=MAXN*(ICOLL-1)+I
3457      IF(ICOLL.LE.MAXCOL)Y1(J)=V(IJ)
3458      IF(ICOLL.EQ.MAXCP1)Y1(J)=PRED(I)
3459      IF(ICOLL.EQ.MAXCP2)Y1(J)=RES(I)
3460      GOTO660
3461C
3462  660 CONTINUE
3463      NLOCAL=J
3464C
3465C               *****************************************************
3466C               **  STEP 8--                                       **
3467C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
3468C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
3469C               **  RESET THE VECTOR D(.) TO ALL ONES.             **
3470C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
3471C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
3472C               *****************************************************
3473C
3474CCCCC BAWID=BAWIDT(1)
3475C
3476      NUMV2=2
3477      ISIZE=1
3478      ICONT='ON'
3479      CALL DPBAR2(Y1,X1,NLOCAL,NUMV2,ICASPL,ISIZE,ICONT,
3480     1XIDTEM,TEMP,
3481     1Y,X,D,NPLOTP,NPLOTV,IBUGG3,IERROR)
3482C
3483C               *****************
3484C               **  STEP 90--  **
3485C               **  EXIT       **
3486C               *****************
3487C
3488 9000 CONTINUE
3489      IF(IBUGG2.EQ.'OFF')GOTO9090
3490      WRITE(ICOUT,999)
3491      CALL DPWRST('XXX','BUG ')
3492      WRITE(ICOUT,9011)
3493 9011 FORMAT('***** AT THE END       OF DPBARP--')
3494      CALL DPWRST('XXX','BUG ')
3495      WRITE(ICOUT,9012)IFOUND,IERROR
3496 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
3497      CALL DPWRST('XXX','BUG ')
3498      WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
3499 9013 FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
3500     1I8,I8,I8,2X,A4,2X,A4,2X,A4)
3501      CALL DPWRST('XXX','BUG ')
3502CCCCC WRITE(ICOUT,9014)BAWIDT(1),BAWIDT(2)
3503C9014 FORMAT('BAWIDT(1),BAWIDT(2) = ',2E15.7)
3504CCCCC CALL DPWRST('XXX','BUG ')
3505CCCCC WRITE(ICOUT,9015)BAWID
3506C9015 FORMAT('BAWDI = ',E15.7)
3507CCCCC CALL DPWRST('XXX','BUG ')
3508 9090 CONTINUE
3509C
3510      RETURN
3511      END
3512      SUBROUTINE DPBASW(IHARG,NUMARG,IDEBSW,MAXBAR,IBARSW,
3513     1IBUGP2,IFOUND,IERROR)
3514C
3515C     PURPOSE--DEFINE THE BAR SWITCHES.
3516C              THESE ARE LOCATED IN THE VECTOR IBARSW(.).
3517C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
3518C                     --NUMARG
3519C                     --IDEBSW
3520C                     --MAXBAR
3521C                     --IBUGP2 ('ON' OR 'OFF' )
3522C     OUTPUT ARGUMENTS--IBARSW (A CHARACTER VECTOR)
3523C                     --IFOUND ('YES' OR 'NO' )
3524C                     --IERROR ('YES' OR 'NO' )
3525C     WRITTEN BY--JAMES J. FILLIBEN
3526C                 STATISTICAL ENGINEERING DIVISION
3527C                 INFORMATION TECHNOLOGY LABORATORY
3528C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3529C                 GAITHERSBURG, MD 20899-8980
3530C                 PHONE--301-975-2855
3531C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3532C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3533C     LANGUAGE--ANSI FORTRAN (1977)
3534C     VERSION NUMBER--82/7
3535C     ORIGINAL VERSION--DECEMBER  1983.
3536C
3537C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3538C
3539      CHARACTER*4 IHARG
3540      CHARACTER*4 IDEBSW
3541      CHARACTER*4 IBARSW
3542C
3543      CHARACTER*4 IBUGP2
3544      CHARACTER*4 IFOUND
3545      CHARACTER*4 IERROR
3546C
3547      CHARACTER*4 IHOLD1
3548      CHARACTER*4 IHOLD2
3549C
3550      CHARACTER*4 ISUBN1
3551      CHARACTER*4 ISUBN2
3552      CHARACTER*4 ISTEPN
3553C
3554      DIMENSION IHARG(*)
3555      DIMENSION IBARSW(*)
3556C
3557C---------------------------------------------------------------------
3558C
3559      INCLUDE 'DPCOP2.INC'
3560C
3561C-----START POINT-----------------------------------------------------
3562C
3563      IFOUND='NO'
3564      IERROR='NO'
3565C
3566      ISUBN1='DPBA'
3567      ISUBN2='SW  '
3568C
3569      NUMBAR=0
3570      IHOLD1='-999'
3571      IHOLD2='-999'
3572C
3573      IF(IBUGP2.EQ.'OFF')GOTO90
3574      WRITE(ICOUT,999)
3575  999 FORMAT(1X)
3576      CALL DPWRST('XXX','BUG ')
3577      WRITE(ICOUT,51)
3578   51 FORMAT('***** AT THE BEGINNING OF DPBASW--')
3579      CALL DPWRST('XXX','BUG ')
3580      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
3581   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3582      CALL DPWRST('XXX','BUG ')
3583      WRITE(ICOUT,53)MAXBAR,NUMBAR
3584   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
3585      CALL DPWRST('XXX','BUG ')
3586      WRITE(ICOUT,54)IHOLD1,IHOLD2
3587   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
3588      CALL DPWRST('XXX','BUG ')
3589      WRITE(ICOUT,55)IDEBSW
3590   55 FORMAT('IDEBSW = ',A4)
3591      CALL DPWRST('XXX','BUG ')
3592      WRITE(ICOUT,60)NUMARG
3593   60 FORMAT('NUMARG = ',I8)
3594      CALL DPWRST('XXX','BUG ')
3595      DO65I=1,NUMARG
3596      WRITE(ICOUT,66)IHARG(I)
3597   66 FORMAT('IHARG(I) = ',A4)
3598      CALL DPWRST('XXX','BUG ')
3599   65 CONTINUE
3600      WRITE(ICOUT,70)IBARSW(1)
3601   70 FORMAT('IBARSW(1) = ',A4)
3602      CALL DPWRST('XXX','BUG ')
3603      DO75I=1,10
3604      WRITE(ICOUT,76)I,IBARSW(I)
3605   76 FORMAT('I,IBARSW(I) = ',I8,2X,A4)
3606      CALL DPWRST('XXX','BUG ')
3607   75 CONTINUE
3608   90 CONTINUE
3609C
3610C               **************************************
3611C               **  STEP 1--                        **
3612C               **  BRANCH TO THE APPROPRIATE CASE  **
3613C               **************************************
3614C
3615      ISTEPN='1'
3616      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3617C
3618      IF(NUMARG.LE.0)GOTO9000
3619      IF(NUMARG.EQ.1)GOTO1110
3620      IF(NUMARG.EQ.2)GOTO1120
3621      IF(NUMARG.EQ.3)GOTO1130
3622      GOTO1140
3623C
3624 1110 CONTINUE
3625      GOTO1200
3626C
3627 1120 CONTINUE
3628      IF(IHARG(2).EQ.'ALL')IHOLD1='ON'
3629      IF(IHARG(2).EQ.'ALL')GOTO1300
3630      GOTO1200
3631C
3632 1130 CONTINUE
3633      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
3634      IF(IHARG(2).EQ.'ALL')GOTO1300
3635      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
3636      IF(IHARG(3).EQ.'ALL')GOTO1300
3637      GOTO1200
3638C
3639 1140 CONTINUE
3640      GOTO1200
3641C
3642C               *************************************************
3643C               **  STEP 2--                                   **
3644C               **  TREAT THE SINGLE     SPECIFICATION   CASE  **
3645C               *************************************************
3646C
3647 1200 CONTINUE
3648      ISTEPN='2'
3649      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3650C
3651      IF(NUMARG.LE.1)GOTO1210
3652      GOTO1220
3653C
3654 1210 CONTINUE
3655      NUMBAR=1
3656      IBARSW(1)='ON'
3657      GOTO1270
3658C
3659 1220 CONTINUE
3660      NUMBAR=NUMARG-1
3661      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
3662      DO1225I=1,NUMBAR
3663      J=I+1
3664      IHOLD1=IHARG(J)
3665      IHOLD2=IHOLD1
3666      IF(IHOLD1.EQ.'ON')IHOLD2='ON'
3667      IF(IHOLD1.EQ.'OFF')IHOLD2='OFF'
3668CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBSW
3669CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBSW
3670      IBARSW(I)=IHOLD2
3671 1225 CONTINUE
3672      GOTO1270
3673C
3674 1270 CONTINUE
3675      IF(IFEEDB.EQ.'OFF')GOTO1279
3676      WRITE(ICOUT,999)
3677      CALL DPWRST('XXX','BUG ')
3678      DO1278I=1,NUMBAR
3679      WRITE(ICOUT,1276)I,IBARSW(I)
3680 1276 FORMAT('BAR ',I6,
3681     1' HAS JUST BEEN SET TO ',A4)
3682      CALL DPWRST('XXX','BUG ')
3683 1278 CONTINUE
3684 1279 CONTINUE
3685      IFOUND='YES'
3686      GOTO9000
3687C
3688C               **************************
3689C               **  STEP 3--            **
3690C               **  TREAT THE ALL CASE  **
3691C               **************************
3692C
3693 1300 CONTINUE
3694      ISTEPN='3'
3695      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3696C
3697      NUMBAR=MAXBAR
3698      IHOLD2=IHOLD1
3699      IF(IHOLD1.EQ.'ON')IHOLD2='ON'
3700      IF(IHOLD1.EQ.'OFF')IHOLD2='OFF'
3701CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBSW
3702CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBSW
3703      DO1315I=1,NUMBAR
3704      IBARSW(I)=IHOLD2
3705 1315 CONTINUE
3706      GOTO1370
3707C
3708 1370 CONTINUE
3709      IF(IFEEDB.EQ.'OFF')GOTO1319
3710      WRITE(ICOUT,999)
3711      CALL DPWRST('XXX','BUG ')
3712      I=1
3713      WRITE(ICOUT,1316)IBARSW(I)
3714 1316 FORMAT('ALL BARS ',
3715     1'HAVE JUST BEEN SET TO ',A4)
3716      CALL DPWRST('XXX','BUG ')
3717 1319 CONTINUE
3718      IFOUND='YES'
3719      GOTO9000
3720C
3721C               *****************
3722C               **  STEP 90--  **
3723C               **  EXIT       **
3724C               *****************
3725C
3726 9000 CONTINUE
3727      IF(IBUGP2.EQ.'OFF')GOTO9090
3728      WRITE(ICOUT,9011)
3729 9011 FORMAT('***** AT THE END       OF DPBASW--')
3730      CALL DPWRST('XXX','BUG ')
3731      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
3732 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3733      CALL DPWRST('XXX','BUG ')
3734      WRITE(ICOUT,9013)MAXBAR,NUMBAR
3735 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
3736      CALL DPWRST('XXX','BUG ')
3737      WRITE(ICOUT,9014)IHOLD1,IHOLD2
3738 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
3739      CALL DPWRST('XXX','BUG ')
3740      WRITE(ICOUT,9015)IDEBSW
3741 9015 FORMAT('IDEBSW = ',A4)
3742      CALL DPWRST('XXX','BUG ')
3743      WRITE(ICOUT,9020)NUMARG
3744 9020 FORMAT('NUMARG = ',I8)
3745      CALL DPWRST('XXX','BUG ')
3746      DO9025I=1,NUMARG
3747      WRITE(ICOUT,9026)IHARG(I)
3748 9026 FORMAT('IHARG(I) = ',A4)
3749      CALL DPWRST('XXX','BUG ')
3750 9025 CONTINUE
3751      WRITE(ICOUT,9030)IBARSW(1)
3752 9030 FORMAT('IBARSW(1) = ',A4)
3753      CALL DPWRST('XXX','BUG ')
3754      DO9035I=1,10
3755      WRITE(ICOUT,9036)I,IBARSW(I)
3756 9036 FORMAT('I,IBARSW(I) = ',I8,2X,A4)
3757      CALL DPWRST('XXX','BUG ')
3758 9035 CONTINUE
3759 9090 CONTINUE
3760C
3761      RETURN
3762      END
3763      SUBROUTINE DPBATY(IHARG,NUMARG,IDEBTY,MAXBAR,IBARTY,
3764     1IBUGP2,IFOUND,IERROR)
3765C
3766C     PURPOSE--DEFINE THE BAR DIMENSION (2 OR 3)
3767C              THESE ARE LOCATED IN THE VECTOR IBARTY(.).
3768C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
3769C                     --NUMARG
3770C                     --IDEBTY
3771C                     --MAXBAR
3772C                     --IBUGP2 ('ON' OR 'OFF' )
3773C     OUTPUT ARGUMENTS--IBARTY (A CHARACTER VECTOR)
3774C                     --IFOUND ('YES' OR 'NO' )
3775C                     --IERROR ('YES' OR 'NO' )
3776C     WRITTEN BY--JAMES J. FILLIBEN
3777C                 STATISTICAL ENGINEERING DIVISION
3778C                 INFORMATION TECHNOLOGY LABORATORY
3779C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
3780C                 GAITHERSBURG, MD 20899-8980
3781C                 PHONE--301-975-2855
3782C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
3783C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
3784C     LANGUAGE--ANSI FORTRAN (1977)
3785C     VERSION NUMBER--87/5
3786C     ORIGINAL VERSION--APRIL     1987.
3787C
3788C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
3789C
3790      CHARACTER*4 IHARG
3791      CHARACTER*4 IDEBTY
3792      CHARACTER*4 IBARTY
3793C
3794      CHARACTER*4 IBUGP2
3795      CHARACTER*4 IFOUND
3796      CHARACTER*4 IERROR
3797C
3798      CHARACTER*4 IHOLD1
3799      CHARACTER*4 IHOLD2
3800C
3801      CHARACTER*4 ISUBN1
3802      CHARACTER*4 ISUBN2
3803      CHARACTER*4 ISTEPN
3804C
3805      DIMENSION IHARG(*)
3806      DIMENSION IBARTY(*)
3807C
3808C---------------------------------------------------------------------
3809C
3810      INCLUDE 'DPCOP2.INC'
3811C
3812C-----START POINT-----------------------------------------------------
3813C
3814      IFOUND='NO'
3815      IERROR='NO'
3816C
3817      ISUBN1='DPBA'
3818      ISUBN2='TY  '
3819C
3820      NUMBAR=0
3821      IHOLD1='-999'
3822      IHOLD2='-999'
3823C
3824      IF(IBUGP2.EQ.'OFF')GOTO90
3825      WRITE(ICOUT,999)
3826  999 FORMAT(1X)
3827      CALL DPWRST('XXX','BUG ')
3828      WRITE(ICOUT,51)
3829   51 FORMAT('***** AT THE BEGINNING OF DPBATY--')
3830      CALL DPWRST('XXX','BUG ')
3831      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
3832   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3833      CALL DPWRST('XXX','BUG ')
3834      WRITE(ICOUT,53)MAXBAR,NUMBAR
3835   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
3836      CALL DPWRST('XXX','BUG ')
3837      WRITE(ICOUT,54)IHOLD1,IHOLD2
3838   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
3839      CALL DPWRST('XXX','BUG ')
3840      WRITE(ICOUT,55)IDEBTY
3841   55 FORMAT('IDEBTY = ',A4)
3842      CALL DPWRST('XXX','BUG ')
3843      WRITE(ICOUT,60)NUMARG
3844   60 FORMAT('NUMARG = ',I8)
3845      CALL DPWRST('XXX','BUG ')
3846      DO65I=1,NUMARG
3847      WRITE(ICOUT,66)IHARG(I)
3848   66 FORMAT('IHARG(I) = ',A4)
3849      CALL DPWRST('XXX','BUG ')
3850   65 CONTINUE
3851      WRITE(ICOUT,70)IBARTY(1)
3852   70 FORMAT('IBARTY(1) = ',A4)
3853      CALL DPWRST('XXX','BUG ')
3854      DO75I=1,10
3855      WRITE(ICOUT,76)I,IBARTY(I)
3856   76 FORMAT('I,IBARTY(I) = ',I8,2X,A4)
3857      CALL DPWRST('XXX','BUG ')
3858   75 CONTINUE
3859   90 CONTINUE
3860C
3861C               **************************************
3862C               **  STEP 1--                        **
3863C               **  BRANCH TO THE APPROPRIATE CASE  **
3864C               **************************************
3865C
3866      ISTEPN='1'
3867      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3868C
3869      IF(NUMARG.LE.0)GOTO9000
3870      IF(NUMARG.EQ.1)GOTO1110
3871      IF(NUMARG.EQ.2)GOTO1120
3872      IF(NUMARG.EQ.3)GOTO1130
3873      GOTO1140
3874C
3875 1110 CONTINUE
3876      GOTO1200
3877C
3878 1120 CONTINUE
3879      IF(IHARG(2).EQ.'ALL')IHOLD1='2'
3880      IF(IHARG(2).EQ.'ALL')GOTO1300
3881      GOTO1200
3882C
3883 1130 CONTINUE
3884      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
3885      IF(IHARG(2).EQ.'ALL')GOTO1300
3886      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
3887      IF(IHARG(3).EQ.'ALL')GOTO1300
3888      GOTO1200
3889C
3890 1140 CONTINUE
3891      GOTO1200
3892C
3893C               *************************************************
3894C               **  STEP 2--                                   **
3895C               **  TREAT THE SINGLE     SPECIFICATION   CASE  **
3896C               *************************************************
3897C
3898 1200 CONTINUE
3899      ISTEPN='2'
3900      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3901C
3902      IF(NUMARG.LE.1)GOTO1210
3903      GOTO1220
3904C
3905 1210 CONTINUE
3906      NUMBAR=1
3907      IBARTY(1)='2'
3908      GOTO1270
3909C
3910 1220 CONTINUE
3911      NUMBAR=NUMARG-1
3912      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
3913      DO1225I=1,NUMBAR
3914      J=I+1
3915      IHOLD1=IHARG(J)
3916      IHOLD2=IHOLD1
3917      IF(IHOLD1.EQ.'2')IHOLD2='2'
3918      IF(IHOLD1.EQ.'3')IHOLD2='3'
3919CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBTY
3920CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBTY
3921      IBARTY(I)=IHOLD2
3922 1225 CONTINUE
3923      GOTO1270
3924C
3925 1270 CONTINUE
3926      IF(IFEEDB.EQ.'OFF')GOTO1279
3927      WRITE(ICOUT,999)
3928      CALL DPWRST('XXX','BUG ')
3929      DO1278I=1,NUMBAR
3930      WRITE(ICOUT,1276)I,IBARTY(I)
3931 1276 FORMAT('BAR DIMENSION ',I6,
3932     1' HAS JUST BEEN SET TO ',A4)
3933      CALL DPWRST('XXX','BUG ')
3934 1278 CONTINUE
3935 1279 CONTINUE
3936      IFOUND='YES'
3937      GOTO9000
3938C
3939C               **************************
3940C               **  STEP 3--            **
3941C               **  TREAT THE ALL CASE  **
3942C               **************************
3943C
3944 1300 CONTINUE
3945      ISTEPN='3'
3946      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
3947C
3948      NUMBAR=MAXBAR
3949      IHOLD2=IHOLD1
3950      IF(IHOLD1.EQ.'2')IHOLD2='2'
3951      IF(IHOLD1.EQ.'3')IHOLD2='3'
3952CCCCC IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBTY
3953CCCCC IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBTY
3954      DO1315I=1,NUMBAR
3955      IBARTY(I)=IHOLD2
3956 1315 CONTINUE
3957      GOTO1370
3958C
3959 1370 CONTINUE
3960      IF(IFEEDB.EQ.'OFF')GOTO1319
3961      WRITE(ICOUT,999)
3962      CALL DPWRST('XXX','BUG ')
3963      I=1
3964      WRITE(ICOUT,1316)IBARTY(I)
3965 1316 FORMAT('ALL BAR DIMENSIONS',
3966     1'HAVE JUST BEEN SET TO ',A4)
3967      CALL DPWRST('XXX','BUG ')
3968 1319 CONTINUE
3969      IFOUND='YES'
3970      GOTO9000
3971C
3972C               *****************
3973C               **  STEP 90--  **
3974C               **  EXIT       **
3975C               *****************
3976C
3977 9000 CONTINUE
3978      IF(IBUGP2.EQ.'OFF')GOTO9090
3979      WRITE(ICOUT,9011)
3980 9011 FORMAT('***** AT THE END       OF DPBATY--')
3981      CALL DPWRST('XXX','BUG ')
3982      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
3983 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
3984      CALL DPWRST('XXX','BUG ')
3985      WRITE(ICOUT,9013)MAXBAR,NUMBAR
3986 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
3987      CALL DPWRST('XXX','BUG ')
3988      WRITE(ICOUT,9014)IHOLD1,IHOLD2
3989 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
3990      CALL DPWRST('XXX','BUG ')
3991      WRITE(ICOUT,9015)IDEBTY
3992 9015 FORMAT('IDEBTY = ',A4)
3993      CALL DPWRST('XXX','BUG ')
3994      WRITE(ICOUT,9020)NUMARG
3995 9020 FORMAT('NUMARG = ',I8)
3996      CALL DPWRST('XXX','BUG ')
3997      DO9025I=1,NUMARG
3998      WRITE(ICOUT,9026)IHARG(I)
3999 9026 FORMAT('IHARG(I) = ',A4)
4000      CALL DPWRST('XXX','BUG ')
4001 9025 CONTINUE
4002      WRITE(ICOUT,9030)IBARTY(1)
4003 9030 FORMAT('IBARTY(1) = ',A4)
4004      CALL DPWRST('XXX','BUG ')
4005      DO9035I=1,10
4006      WRITE(ICOUT,9036)I,IBARTY(I)
4007 9036 FORMAT('I,IBARTY(I) = ',I8,2X,A4)
4008      CALL DPWRST('XXX','BUG ')
4009 9035 CONTINUE
4010 9090 CONTINUE
4011C
4012      RETURN
4013      END
4014      SUBROUTINE DPBAUD(IHARG,IARGT,IARG,NUMARG,IDEFBA,
4015     1IBAUD,IFOUND,IERROR)
4016C
4017C     PURPOSE--DEFINE THE BAUD RATE AT WHICH THE TERMINAL
4018C              IS TRANSMITTING TO THE HOST.
4019C              THE SPECIFIED BAUD RATE VALUE WILL BE PLACED
4020C              IN THE INTEGER VARIABLE IBAUD.
4021C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
4022C                     --IARGT  (A  HOLLERITH VECTOR)
4023C                     --IARG   (AN INTEGER VECTOR)
4024C                     --NUMARG (AN INTEGER VARIABLE)
4025C                     --IDEFBA (AN INTEGER VARIABLE)
4026C     OUTPUT ARGUMENTS--IBAUD  (AN INTEGER VARIABLE)
4027C                     --IFOUND ('YES' OR 'NO' )
4028C                     --IERROR ('YES' OR 'NO' )
4029C     WRITTEN BY--JAMES J. FILLIBEN
4030C                 STATISTICAL ENGINEERING DIVISION
4031C                 INFORMATION TECHNOLOGY LABORATORY
4032C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4033C                 GAITHERSBURG, MD 20899-8980
4034C                 PHONE--301-975-2855
4035C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4036C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4037C     LANGUAGE--ANSI FORTRAN (1977)
4038C     VERSION NUMBER--82/7
4039C     ORIGINAL VERSION--NOVEMBER 1980.
4040C     UPDATED         --MAY       1982.
4041C
4042C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4043C
4044      CHARACTER*4 IHARG
4045      CHARACTER*4 IARGT
4046      CHARACTER*4 IFOUND
4047      CHARACTER*4 IERROR
4048C
4049C---------------------------------------------------------------------
4050C
4051      DIMENSION IHARG(*)
4052      DIMENSION IARGT(*)
4053      DIMENSION IARG(*)
4054C
4055C---------------------------------------------------------------------
4056C
4057      INCLUDE 'DPCOP2.INC'
4058C
4059C-----START POINT-----------------------------------------------------
4060C
4061      IFOUND='NO'
4062      IERROR='NO'
4063C
4064      IF(NUMARG.LE.0)GOTO1150
4065      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
4066      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
4067      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
4068      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
4069      IF(IHARG(NUMARG).EQ.'?')GOTO8100
4070      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
4071      GOTO1120
4072C
4073 1120 CONTINUE
4074      IERROR='YES'
4075      WRITE(ICOUT,1121)
4076 1121 FORMAT('***** ERROR IN DPBAUD--')
4077      CALL DPWRST('XXX','BUG ')
4078      WRITE(ICOUT,1122)
4079 1122 FORMAT('      ILLEGAL FORM FOR BAUD RATE ',
4080     1'COMMAND.')
4081      CALL DPWRST('XXX','BUG ')
4082      WRITE(ICOUT,1124)
4083 1124 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
4084     1'PROPER FORM--')
4085      CALL DPWRST('XXX','BUG ')
4086      WRITE(ICOUT,1125)
4087 1125 FORMAT('      SUPPOSE THE THE TERMINAL IS ')
4088      CALL DPWRST('XXX','BUG ')
4089      WRITE(ICOUT,1126)
4090 1126 FORMAT('      TRANSMITTING AT 9600 BAUD, ')
4091      CALL DPWRST('XXX','BUG ')
4092      WRITE(ICOUT,1127)
4093 1127 FORMAT('      THEN THE ALLOWABLE FORM IS--')
4094      CALL DPWRST('XXX','BUG ')
4095      WRITE(ICOUT,1128)
4096 1128 FORMAT('      BAUD RATE 9600 ')
4097      CALL DPWRST('XXX','BUG ')
4098      GOTO9000
4099C
4100 1150 CONTINUE
4101      IHOLD=IDEFBA
4102      GOTO1180
4103C
4104 1160 CONTINUE
4105      IHOLD=IARG(NUMARG)
4106      GOTO1180
4107C
4108 1180 CONTINUE
4109      IFOUND='YES'
4110      IBAUD=IHOLD
4111C
4112      IF(IFEEDB.EQ.'OFF')GOTO1189
4113      WRITE(ICOUT,999)
4114  999 FORMAT(1X)
4115      CALL DPWRST('XXX','BUG ')
4116      WRITE(ICOUT,1181)IBAUD
4117 1181 FORMAT('THE BAUD RATE HAS JUST BEEN SET TO ',
4118     1I8)
4119      CALL DPWRST('XXX','BUG ')
4120 1189 CONTINUE
4121      GOTO9000
4122C
4123C               ********************************************
4124C               **  STEP 81--                             **
4125C               **  TREAT THE    ?    CASE--              **
4126C               **  DUMP OUT CURRENT AND DEFAULT VALUES.  **
4127C               ********************************************
4128C
4129 8100 CONTINUE
4130      IFOUND='YES'
4131      WRITE(ICOUT,999)
4132      CALL DPWRST('XXX','BUG ')
4133      WRITE(ICOUT,8111)IBAUD
4134 8111 FORMAT('THE CURRENT BAUD RATE IS ',I8)
4135      CALL DPWRST('XXX','BUG ')
4136      WRITE(ICOUT,8112)IDEFBA
4137 8112 FORMAT('THE DEFAULT BAUD RATE IS ',I8)
4138      CALL DPWRST('XXX','BUG ')
4139      GOTO9000
4140C
4141C               *****************
4142C               **  STEP 90--  **
4143C               **  EXIT       **
4144C               *****************
4145C
4146 9000 CONTINUE
4147      RETURN
4148      END
4149      SUBROUTINE DPBAWI(ADEBWI,MAXBAR,ABARWI,
4150CCCCC SUBROUTINE DPBAWI(IHARG,IARGT,ARG,NUMARG,ADEBWI,MAXBAR,ABARWI,
4151     1IBUGP2,IFOUND,IERROR)
4152C
4153C     PURPOSE--DEFINE THE BAR WIDTHS.
4154C              THESE ARE LOCATED IN THE VECTOR ABARWI(.).
4155C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
4156C                     --IARGT  (A  CHARACTER VECTOR)
4157C                     --ARG
4158C                     --NUMARG
4159C                     --ADEBWI
4160C                     --MAXBAR
4161C                     --IBUGP2 ('ON' OR 'OFF' )
4162C     OUTPUT ARGUMENTS--ABARWI (A FLOATING POINT VECTOR)
4163C                     --IFOUND ('YES' OR 'NO' )
4164C                     --IERROR ('YES' OR 'NO' )
4165C     WRITTEN BY--JAMES J. FILLIBEN
4166C                 STATISTICAL ENGINEERING DIVISION
4167C                 INFORMATION TECHNOLOGY LABORATORY
4168C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4169C                 GAITHERSBURG, MD 20899-8980
4170C                 PHONE--301-975-2855
4171C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4172C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4173C     LANGUAGE--ANSI FORTRAN (1977)
4174C     VERSION NUMBER--82/7
4175C     ORIGINAL VERSION--DECEMBER  1983.
4176C     UPDATED         --APRIL     2008. BAR WIDTH AUTOMATIC
4177C
4178C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4179C
4180CCCCC CHARACTER*4 IHARG
4181CCCCC CHARACTER*4 IARGT
4182C
4183      CHARACTER*4 IBUGP2
4184      CHARACTER*4 IFOUND
4185      CHARACTER*4 IERROR
4186C
4187      CHARACTER*4 IHOLD1
4188C
4189      CHARACTER*4 ISUBN1
4190      CHARACTER*4 ISUBN2
4191      CHARACTER*4 ISTEPN
4192C
4193      CHARACTER*4 IHLEFT
4194      CHARACTER*4 IHLEF2
4195      CHARACTER*4 IHWUSE
4196      CHARACTER*4 MESSAG
4197      CHARACTER*4 ICASEQ
4198      CHARACTER*4 IWRITE
4199      CHARACTER*4 IBUGQ
4200C
4201CCCCC DIMENSION IHARG(*)
4202CCCCC DIMENSION IARGT(*)
4203CCCCC DIMENSION ARG(*)
4204      DIMENSION ABARWI(*)
4205C
4206      INCLUDE 'DPCOPA.INC'
4207      INCLUDE 'DPCOHK.INC'
4208      INCLUDE 'DPCODA.INC'
4209C
4210C---------------------------------------------------------------------
4211C
4212      INCLUDE 'DPCOP2.INC'
4213C
4214C-----START POINT-----------------------------------------------------
4215C
4216      IFOUND='NO'
4217      IERROR='NO'
4218C
4219      ISUBN1='DPBA'
4220      ISUBN2='WI  '
4221C
4222      NUMBAR=0
4223      IHOLD1='-999'
4224      HOLD1=-999.0
4225      HOLD2=-999.0
4226C
4227      IF(IBUGP2.EQ.'OFF')GOTO90
4228      WRITE(ICOUT,999)
4229  999 FORMAT(1X)
4230      CALL DPWRST('XXX','BUG ')
4231      WRITE(ICOUT,51)
4232   51 FORMAT('***** AT THE BEGINNING OF DPBAWI--')
4233      CALL DPWRST('XXX','BUG ')
4234      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
4235   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
4236      CALL DPWRST('XXX','BUG ')
4237      WRITE(ICOUT,53)MAXBAR,NUMBAR
4238   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
4239      CALL DPWRST('XXX','BUG ')
4240      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
4241   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
4242      CALL DPWRST('XXX','BUG ')
4243      WRITE(ICOUT,55)ADEBWI
4244   55 FORMAT('ADEBWI = ',E15.7)
4245      CALL DPWRST('XXX','BUG ')
4246      WRITE(ICOUT,60)NUMARG
4247   60 FORMAT('NUMARG = ',I8)
4248      CALL DPWRST('XXX','BUG ')
4249      DO65I=1,NUMARG
4250      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
4251   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
4252      CALL DPWRST('XXX','BUG ')
4253   65 CONTINUE
4254      WRITE(ICOUT,70)ABARWI(1)
4255   70 FORMAT('ABARWI(1) = ',E15.7)
4256      CALL DPWRST('XXX','BUG ')
4257      DO75I=1,10
4258      WRITE(ICOUT,76)I,ABARWI(I)
4259   76 FORMAT('I,ABARWI(I) = ',I8,2X,E15.7)
4260      CALL DPWRST('XXX','BUG ')
4261   75 CONTINUE
4262   90 CONTINUE
4263C
4264C               **************************************
4265C               **  STEP 1--                        **
4266C               **  BRANCH TO THE APPROPRIATE CASE  **
4267C               **************************************
4268C
4269      ISTEPN='1'
4270      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4271C
4272      IF(NUMARG.LE.0)GOTO9000
4273CCCCC APRIL 2008.  ADD BAR WIDTH AUTOMATIC <VAR>
4274      IF(NUMARG.GE.3.AND.IHARG(2).EQ.'AUTO')GOTO3000
4275      IF(NUMARG.GE.4.AND.IHARG(3).EQ.'AUTO')GOTO3000
4276C
4277      IF(NUMARG.EQ.1)GOTO1110
4278      IF(NUMARG.EQ.2)GOTO1120
4279      IF(NUMARG.EQ.3)GOTO1130
4280      GOTO1140
4281C
4282 1110 CONTINUE
4283      GOTO1200
4284C
4285 1120 CONTINUE
4286      IF(IHARG(2).EQ.'ALL')IHOLD1='    '
4287      IF(IHARG(2).EQ.'ALL')HOLD1=ADEBWI
4288      IF(IHARG(2).EQ.'ALL')GOTO1300
4289      GOTO1200
4290C
4291 1130 CONTINUE
4292      IF(IHARG(2).EQ.'ALL')IHOLD1=IHARG(3)
4293      IF(IHARG(2).EQ.'ALL')HOLD1=ARG(3)
4294      IF(IHARG(2).EQ.'ALL')GOTO1300
4295      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(2)
4296      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(2)
4297      IF(IHARG(3).EQ.'ALL')GOTO1300
4298      GOTO1200
4299C
4300 1140 CONTINUE
4301      GOTO1200
4302C
4303C               *************************************************
4304C               **  STEP 2--                                   **
4305C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
4306C               *************************************************
4307C
4308 1200 CONTINUE
4309      ISTEPN='2'
4310      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4311C
4312      IF(NUMARG.LE.1)GOTO1210
4313      GOTO1220
4314C
4315 1210 CONTINUE
4316      NUMBAR=1
4317      ABARWI(1)=ADEBWI
4318      GOTO1270
4319C
4320 1220 CONTINUE
4321      NUMBAR=NUMARG-1
4322      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
4323      DO1225I=1,NUMBAR
4324      J=I+1
4325      IHOLD1=IHARG(J)
4326      HOLD1=ARG(J)
4327      HOLD2=HOLD1
4328      IF(IHOLD1.EQ.'ON')HOLD2=ADEBWI
4329      IF(IHOLD1.EQ.'OFF')HOLD2=ADEBWI
4330      IF(IHOLD1.EQ.'AUTO')HOLD2=ADEBWI
4331      IF(IHOLD1.EQ.'DEFA')HOLD2=ADEBWI
4332      ABARWI(I)=HOLD2
4333 1225 CONTINUE
4334      GOTO1270
4335C
4336 1270 CONTINUE
4337      IF(IFEEDB.EQ.'OFF')GOTO1279
4338      WRITE(ICOUT,999)
4339      CALL DPWRST('XXX','BUG ')
4340      DO1278I=1,NUMBAR
4341      WRITE(ICOUT,1276)I,ABARWI(I)
4342 1276 FORMAT('THE WIDTH OF BAR ',I6,
4343     1' HAS JUST BEEN SET TO ',E15.7)
4344      CALL DPWRST('XXX','BUG ')
4345 1278 CONTINUE
4346 1279 CONTINUE
4347      IFOUND='YES'
4348      GOTO9000
4349C
4350C               **************************
4351C               **  STEP 3--            **
4352C               **  TREAT THE ALL CASE  **
4353C               **************************
4354C
4355 1300 CONTINUE
4356      ISTEPN='3'
4357      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4358C
4359      NUMBAR=MAXBAR
4360      HOLD2=HOLD1
4361      IF(IHOLD1.EQ.'ON')HOLD2=ADEBWI
4362      IF(IHOLD1.EQ.'OFF')HOLD2=ADEBWI
4363      IF(IHOLD1.EQ.'AUTO')HOLD2=ADEBWI
4364      IF(IHOLD1.EQ.'DEFA')HOLD2=ADEBWI
4365      DO1315I=1,NUMBAR
4366      ABARWI(I)=HOLD2
4367 1315 CONTINUE
4368      GOTO1370
4369C
4370 1370 CONTINUE
4371      IF(IFEEDB.EQ.'OFF')GOTO1319
4372      WRITE(ICOUT,999)
4373      CALL DPWRST('XXX','BUG ')
4374      I=1
4375      WRITE(ICOUT,1316)ABARWI(I)
4376 1316 FORMAT('THE WIDTH OF ALL BARS',
4377     1' HAS JUST BEEN SET TO ',E15.7)
4378      CALL DPWRST('XXX','BUG ')
4379 1319 CONTINUE
4380      IFOUND='YES'
4381      GOTO9000
4382C
4383C               ******************************************************
4384C               **  STEP 30--                                       **
4385C               **  TREAT THE BAR WIDTH  AUTOMATIC <VARIABLE>   CASE**
4386C               ******************************************************
4387C
4388 3000 CONTINUE
4389C
4390C               ***********************************************
4391C               **  STEP 31--                                **
4392C               **  CHECK THE VALIDITY OF ARGUMENT 2 (OR 3)  **
4393C               **  (THIS WILL BE THE RESPONSE VARIABLE)     **
4394C               ***********************************************
4395C
4396      ISTEPN='31'
4397      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4398C
4399      IHLEFT=IHARG(3)
4400      IHLEF2=IHARG2(3)
4401      IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')THEN
4402        IHLEFT=IHARG(4)
4403        IHLEF2=IHARG2(4)
4404      ENDIF
4405      IHWUSE='V'
4406      MESSAG='YES'
4407      CALL CHECKN(IHLEFT,IHLEF2,IHWUSE,
4408     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
4409     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
4410      IF(IERROR.EQ.'YES')GOTO9000
4411      ICOLL=IVALUE(ILOCV)
4412      NLEFT=IN(ILOCV)
4413C
4414C               *****************************************
4415C               **  STEP 32--                          **
4416C               **  CHECK TO SEE THE TYPE CASE--       **
4417C               **    1) UNQUALIFIED (THAT IS, FULL);  **
4418C               **    2) SUBSET/EXCEPT; OR             **
4419C               **    3) FOR.                          **
4420C               *****************************************
4421C
4422      ISTEPN='32'
4423      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4424C
4425      ICASEQ='FULL'
4426      ILOCQ=NUMARG+1
4427      IF(NUMARG.LT.1)GOTO3290
4428      DO3200J=1,NUMARG
4429      J1=J
4430      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ') GOTO3210
4431      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ') GOTO3210
4432      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ') GOTO3220
4433 3200 CONTINUE
4434      GOTO3290
4435 3210 CONTINUE
4436      ICASEQ='SUBS'
4437      ILOCQ=J1
4438      GOTO3290
4439 3220 CONTINUE
4440      ICASEQ='FOR'
4441      ILOCQ=J1
4442      GOTO3290
4443 3290 CONTINUE
4444      IF(IBUGP2.EQ.'OFF')GOTO3295
4445      WRITE(ICOUT,3291)NUMARG,ILOCQ
4446 3291 FORMAT('NUMARG,ILOCQ = ',2I8)
4447      CALL DPWRST('XXX','BUG ')
4448 3295 CONTINUE
4449C
4450C               *********************************************
4451C               **  STEP 33--                              **
4452C               **  TEMPORARILY FORM THE VARIABLE Y(.)     **
4453C               **  WHICH WILL HOLD THE RESPONSE VARIABLE. **
4454C               **  FORM THIS VARIABLE BY                  **
4455C               **  BRANCHING TO THE APPROPRIATE SUBCASE   **
4456C               **  (FULL, SUBSET, OR FOR).                **
4457C               *********************************************
4458C
4459      ISTEPN='33'
4460      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4461C
4462      IF(ICASEQ.EQ.'FULL')GOTO3310
4463      IF(ICASEQ.EQ.'SUBS')GOTO3320
4464      IF(ICASEQ.EQ.'FOR')GOTO3330
4465C
4466 3310 CONTINUE
4467      DO3315I=1,NLEFT
4468      ISUB(I)=1
4469 3315 CONTINUE
4470      NQ=NLEFT
4471      GOTO3350
4472C
4473 3320 CONTINUE
4474      NIOLD=NLEFT
4475      CALL DPSUBS(NIOLD,ILOCS,NS,IBUGQ,IERROR)
4476      NQ=NIOLD
4477      GOTO3350
4478C
4479 3330 CONTINUE
4480      NIOLD=NLEFT
4481      CALL DPFOR(NIOLD,NFOR,IROW1,IROWN,
4482     1NLOCAL,ILOCS,NS,IBUGQ,IERROR)
4483      NQ=NFOR
4484      GOTO3350
4485C
4486 3350 CONTINUE
4487      MINN2=1
4488      IF(NQ.LT.MINN2)THEN
4489        WRITE(ICOUT,999)
4490        CALL DPWRST('XXX','BUG ')
4491        WRITE(ICOUT,3351)
4492 3351   FORMAT('***** ERROR IN BAR WIDTH AUTOMATIC--')
4493        CALL DPWRST('XXX','BUG ')
4494        WRITE(ICOUT,3352)
4495 3352   FORMAT('      AFTER THE APPROPRIATE SUBSET HAS BEEN ',
4496     1         'EXTRACTED,')
4497        CALL DPWRST('XXX','BUG ')
4498        WRITE(ICOUT,3353)IHLEFT,IHLEF2
4499 3353   FORMAT('      THE NUMBER OF OBSERVATIONS REMAINING',
4500     1         'FROM VARIABLE ',A4,A4)
4501        CALL DPWRST('XXX','BUG ')
4502        WRITE(ICOUT,3354)
4503 3354   FORMAT('      (FOR WHICH BAR WIDTH DEFINITIONS ')
4504        CALL DPWRST('XXX','BUG ')
4505        WRITE(ICOUT,3355)
4506 3355   FORMAT('      ARE TO BE GENERATED)')
4507        CALL DPWRST('XXX','BUG ')
4508        WRITE(ICOUT,3356)MINN2
4509 3356   FORMAT('      MUST BE ',I8,' OR LARGER;')
4510        CALL DPWRST('XXX','BUG ')
4511        WRITE(ICOUT,3357)
4512 3357   FORMAT('      SUCH WAS NOT THE CASE HERE.')
4513        CALL DPWRST('XXX','BUG ')
4514        WRITE(ICOUT,3358)
4515 3358   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
4516        CALL DPWRST('XXX','BUG ')
4517        IF(IWIDTH.GE.1)THEN
4518          WRITE(ICOUT,3359)(IANS(I),I=1,MIN(80,IWIDTH))
4519 3359     FORMAT('      ',80A1)
4520          CALL DPWRST('XXX','BUG ')
4521        ENDIF
4522        IERROR='YES'
4523      ENDIF
4524C
4525      MAXCP1=MAXCOL+1
4526      MAXCP2=MAXCOL+2
4527      MAXCP3=MAXCOL+3
4528      MAXCP4=MAXCOL+4
4529      MAXCP5=MAXCOL+5
4530      MAXCP6=MAXCOL+6
4531      J=0
4532      IMAX=NLEFT
4533      IF(NQ.LT.NLEFT)IMAX=NQ
4534      DO3370I=1,IMAX
4535        IF(ISUB(I).EQ.0)GOTO3370
4536        J=J+1
4537C
4538        IJ=MAXN*(ICOLL-1)+I
4539        IF(ICOLL.LE.MAXCOL)Y(J)=V(IJ)
4540        IF(ICOLL.EQ.MAXCP1)Y(J)=PRED(I)
4541        IF(ICOLL.EQ.MAXCP2)Y(J)=RES(I)
4542        IF(ICOLL.EQ.MAXCP3)Y(J)=YPLOT(I)
4543        IF(ICOLL.EQ.MAXCP4)Y(J)=XPLOT(I)
4544        IF(ICOLL.EQ.MAXCP5)Y(J)=X2PLOT(I)
4545        IF(ICOLL.EQ.MAXCP6)Y(J)=TAGPLO(I)
4546C
4547 3370 CONTINUE
4548      NS=J
4549      NY=J
4550C
4551C               *****************************************
4552C               **  STEP 34--                          **
4553C               **  IF HAVE THE FORM--                 **
4554C               **  BAR WIDTH  AUTOMATIC DISTINCT X    **
4555C               **  EXTRACT THE DISTINCT VALUES        **
4556C               **  FROM THE TARGET VARIABLE Y(.)   .  **
4557C               **  STORE THEM IN X(.)   .             **
4558C               **  IF HAVE THE FORM--                 **
4559C               **  BAR WIDTH  AUTOMATIC X             **
4560C               **  DO NOTHING                         **
4561C               *****************************************
4562C
4563      IF(IHARG(3).EQ.'DIST'.AND.IHARG2(3).EQ.'INCT')THEN
4564        IWRITE='OFF'
4565        CALL DISTIN(Y,NY,IWRITE,X,NX,IBUGP2,IERROR)
4566      ELSE
4567        DO3411I=1,NY
4568          X(I)=Y(I)
4569 3411   CONTINUE
4570        NX=NY
4571      ENDIF
4572C
4573C               ******************************************
4574C               **  STEP 36--                           **
4575C               **  COPY VALUES IN X(.) TO ABARWI       **
4576C               **        MAX NUMBER OF BARS    = 100   **
4577C               ******************************************
4578C
4579      IMAX=NX
4580      IF(IMAX.GT.MAXBAR)IMAX=MAXBAR
4581      DO3650I=1,IMAX
4582      ABARWI(I)=X(I)
4583 3650 CONTINUE
4584C
4585      IF(IFEEDB.EQ.'ON')THEN
4586        WRITE(ICOUT,999)
4587        CALL DPWRST('XXX','BUG ')
4588        DO3675I=1,IMAX
4589          WRITE(ICOUT,3676)I,ABARWI(I)
4590 3676     FORMAT('BAR WIDTH ',I6,' HAS JUST BEEN SET TO ',
4591     1           G15.7)
4592          CALL DPWRST('XXX','BUG ')
4593 3675   CONTINUE
4594      ENDIF
4595      IFOUND='YES'
4596      GOTO9000
4597C               *****************
4598C               **  STEP 90--  **
4599C               **  EXIT       **
4600C               *****************
4601C
4602 9000 CONTINUE
4603      IF(IBUGP2.EQ.'OFF')GOTO9090
4604      WRITE(ICOUT,9011)
4605 9011 FORMAT('***** AT THE END       OF DPBAWI--')
4606      CALL DPWRST('XXX','BUG ')
4607      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
4608 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
4609      CALL DPWRST('XXX','BUG ')
4610      WRITE(ICOUT,9013)MAXBAR,NUMBAR
4611 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
4612      CALL DPWRST('XXX','BUG ')
4613      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
4614 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
4615      CALL DPWRST('XXX','BUG ')
4616      WRITE(ICOUT,9015)ADEBWI
4617 9015 FORMAT('ADEBWI = ',E15.7)
4618      CALL DPWRST('XXX','BUG ')
4619      WRITE(ICOUT,9020)NUMARG
4620 9020 FORMAT('NUMARG = ',I8)
4621      CALL DPWRST('XXX','BUG ')
4622      DO9025I=1,NUMARG
4623      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
4624 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
4625      CALL DPWRST('XXX','BUG ')
4626 9025 CONTINUE
4627      WRITE(ICOUT,9030)ABARWI(1)
4628 9030 FORMAT('ABARWI(1) = ',E15.7)
4629      CALL DPWRST('XXX','BUG ')
4630      DO9035I=1,10
4631      WRITE(ICOUT,9036)I,ABARWI(I)
4632 9036 FORMAT('I,ABARWI(I) = ',I8,2X,E15.7)
4633      CALL DPWRST('XXX','BUG ')
4634 9035 CONTINUE
4635 9090 CONTINUE
4636C
4637      RETURN
4638      END
4639      SUBROUTINE DPBBCO(IHARG,NUMARG,IDEBBC,MAXBAR,IBABCO,
4640     1IBUGP2,IFOUND,IERROR)
4641C
4642C     PURPOSE--DEFINE THE BAR BORDER COLORS = THE COLORS
4643C              OF THE BORDER LINE AROUND THE BARS.
4644C              THESE ARE LOCATED IN THE VECTOR IBABCO(.).
4645C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
4646C                     --NUMARG
4647C                     --IDEBBC
4648C                     --MAXBAR
4649C                     --IBUGP2 ('ON' OR 'OFF' )
4650C     OUTPUT ARGUMENTS--IBABCO (A CHARACTER VECTOR)
4651C                     --IFOUND ('YES' OR 'NO' )
4652C                     --IERROR ('YES' OR 'NO' )
4653C     WRITTEN BY--JAMES J. FILLIBEN
4654C                 STATISTICAL ENGINEERING DIVISION
4655C                 INFORMATION TECHNOLOGY LABORATORY
4656C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4657C                 GAITHERSBURG, MD 20899-8980
4658C                 PHONE--301-975-2855
4659C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4660C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4661C     LANGUAGE--ANSI FORTRAN (1977)
4662C     VERSION NUMBER--82/7
4663C     ORIGINAL VERSION--DECEMBER  1983.
4664C
4665C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4666C
4667      CHARACTER*4 IHARG
4668      CHARACTER*4 IDEBBC
4669      CHARACTER*4 IBABCO
4670C
4671      CHARACTER*4 IBUGP2
4672      CHARACTER*4 IFOUND
4673      CHARACTER*4 IERROR
4674C
4675      CHARACTER*4 IHOLD1
4676      CHARACTER*4 IHOLD2
4677C
4678      CHARACTER*4 ISUBN1
4679      CHARACTER*4 ISUBN2
4680      CHARACTER*4 ISTEPN
4681C
4682      DIMENSION IHARG(*)
4683      DIMENSION IBABCO(*)
4684C
4685C---------------------------------------------------------------------
4686C
4687      INCLUDE 'DPCOP2.INC'
4688C
4689C-----START POINT-----------------------------------------------------
4690C
4691      IFOUND='NO'
4692      IERROR='NO'
4693C
4694      ISUBN1='DPBB'
4695      ISUBN2='CO  '
4696C
4697      NUMBAR=0
4698      IHOLD1='-999'
4699      IHOLD2='-999'
4700C
4701      IF(IBUGP2.EQ.'OFF')GOTO90
4702      WRITE(ICOUT,999)
4703  999 FORMAT(1X)
4704      CALL DPWRST('XXX','BUG ')
4705      WRITE(ICOUT,51)
4706   51 FORMAT('***** AT THE BEGINNING OF DPBBCO--')
4707      CALL DPWRST('XXX','BUG ')
4708      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
4709   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
4710      CALL DPWRST('XXX','BUG ')
4711      WRITE(ICOUT,53)MAXBAR,NUMBAR
4712   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
4713      CALL DPWRST('XXX','BUG ')
4714      WRITE(ICOUT,54)IHOLD1,IHOLD2
4715   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
4716      CALL DPWRST('XXX','BUG ')
4717      WRITE(ICOUT,55)IDEBBC
4718   55 FORMAT('IDEBBC = ',A4)
4719      CALL DPWRST('XXX','BUG ')
4720      WRITE(ICOUT,60)NUMARG
4721   60 FORMAT('NUMARG = ',I8)
4722      CALL DPWRST('XXX','BUG ')
4723      DO65I=1,NUMARG
4724      WRITE(ICOUT,66)IHARG(I)
4725   66 FORMAT('IHARG(I) = ',A4)
4726      CALL DPWRST('XXX','BUG ')
4727   65 CONTINUE
4728      WRITE(ICOUT,70)IBABCO(1)
4729   70 FORMAT('IBABCO(1) = ',A4)
4730      CALL DPWRST('XXX','BUG ')
4731      DO75I=1,10
4732      WRITE(ICOUT,76)I,IBABCO(I)
4733   76 FORMAT('I,IBABCO(I) = ',I8,2X,A4)
4734      CALL DPWRST('XXX','BUG ')
4735   75 CONTINUE
4736   90 CONTINUE
4737C
4738C               **************************************
4739C               **  STEP 1--                        **
4740C               **  BRANCH TO THE APPROPRIATE CASE  **
4741C               **************************************
4742C
4743      ISTEPN='1'
4744      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4745C
4746      IF(NUMARG.LE.1)GOTO9000
4747      IF(NUMARG.EQ.2)GOTO1120
4748      IF(NUMARG.EQ.3)GOTO1130
4749      IF(NUMARG.EQ.4)GOTO1140
4750      GOTO1150
4751C
4752 1120 CONTINUE
4753      GOTO1200
4754C
4755 1130 CONTINUE
4756      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
4757      IF(IHARG(3).EQ.'ALL')GOTO1300
4758      GOTO1200
4759C
4760 1140 CONTINUE
4761      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
4762      IF(IHARG(3).EQ.'ALL')GOTO1300
4763      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
4764      IF(IHARG(4).EQ.'ALL')GOTO1300
4765      GOTO1200
4766C
4767 1150 CONTINUE
4768      GOTO1200
4769C
4770C               *************************************************
4771C               **  STEP 2--                                   **
4772C               **  TREAT THE SINGLE      SPECIFICATION  CASE  **
4773C               *************************************************
4774C
4775 1200 CONTINUE
4776      ISTEPN='2'
4777      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4778C
4779      IF(NUMARG.LE.2)GOTO1210
4780      GOTO1220
4781C
4782 1210 CONTINUE
4783      NUMBAR=1
4784      IBABCO(1)=IDEBBC
4785      GOTO1270
4786C
4787 1220 CONTINUE
4788      NUMBAR=NUMARG-2
4789      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
4790      DO1225I=1,NUMBAR
4791      J=I+2
4792      IHOLD1=IHARG(J)
4793      IHOLD2=IHOLD1
4794      IF(IHOLD1.EQ.'ON')IHOLD2=IDEBBC
4795      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBBC
4796      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBBC
4797      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBBC
4798      IBABCO(I)=IHOLD2
4799 1225 CONTINUE
4800      GOTO1270
4801C
4802 1270 CONTINUE
4803      IF(IFEEDB.EQ.'OFF')GOTO1279
4804      WRITE(ICOUT,999)
4805      CALL DPWRST('XXX','BUG ')
4806      DO1278I=1,NUMBAR
4807      WRITE(ICOUT,1276)I,IBABCO(I)
4808 1276 FORMAT('THE COLOR OF BAR BORDER ',I6,
4809     1' HAS JUST BEEN SET TO ',A4)
4810      CALL DPWRST('XXX','BUG ')
4811 1278 CONTINUE
4812 1279 CONTINUE
4813      IFOUND='YES'
4814      GOTO9000
4815C
4816C               **************************
4817C               **  STEP 3--            **
4818C               **  TREAT THE ALL CASE  **
4819C               **************************
4820C
4821 1300 CONTINUE
4822      ISTEPN='3'
4823      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
4824C
4825      NUMBAR=MAXBAR
4826      IHOLD2=IHOLD1
4827      IF(IHOLD1.EQ.'ON')IHOLD2=IDEBBC
4828      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBBC
4829      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBBC
4830      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBBC
4831      DO1315I=1,NUMBAR
4832      IBABCO(I)=IHOLD2
4833 1315 CONTINUE
4834      GOTO1370
4835C
4836 1370 CONTINUE
4837      IF(IFEEDB.EQ.'OFF')GOTO1319
4838      WRITE(ICOUT,999)
4839      CALL DPWRST('XXX','BUG ')
4840      I=1
4841      WRITE(ICOUT,1316)IBABCO(I)
4842 1316 FORMAT('THE COLOR OF ALL BAR BORDERS',
4843     1' HAS JUST BEEN SET TO ',A4)
4844      CALL DPWRST('XXX','BUG ')
4845 1319 CONTINUE
4846      IFOUND='YES'
4847      GOTO9000
4848C
4849C               *****************
4850C               **  STEP 90--  **
4851C               **  EXIT       **
4852C               *****************
4853C
4854 9000 CONTINUE
4855      IF(IBUGP2.EQ.'OFF')GOTO9090
4856      WRITE(ICOUT,9011)
4857 9011 FORMAT('***** AT THE END       OF DPBBCO--')
4858      CALL DPWRST('XXX','BUG ')
4859      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
4860 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
4861      CALL DPWRST('XXX','BUG ')
4862      WRITE(ICOUT,9013)MAXBAR,NUMBAR
4863 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
4864      CALL DPWRST('XXX','BUG ')
4865      WRITE(ICOUT,9014)IHOLD1,IHOLD2
4866 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
4867      CALL DPWRST('XXX','BUG ')
4868      WRITE(ICOUT,9015)IDEBBC
4869 9015 FORMAT('IDEBBC = ',A4)
4870      CALL DPWRST('XXX','BUG ')
4871      WRITE(ICOUT,9020)NUMARG
4872 9020 FORMAT('NUMARG = ',I8)
4873      CALL DPWRST('XXX','BUG ')
4874      DO9025I=1,NUMARG
4875      WRITE(ICOUT,9026)IHARG(I)
4876 9026 FORMAT('IHARG(I) = ',A4)
4877      CALL DPWRST('XXX','BUG ')
4878 9025 CONTINUE
4879      WRITE(ICOUT,9030)IBABCO(1)
4880 9030 FORMAT('IBABCO(1) = ',A4)
4881      CALL DPWRST('XXX','BUG ')
4882      DO9035I=1,10
4883      WRITE(ICOUT,9036)I,IBABCO(I)
4884 9036 FORMAT('I,IBABCO(I) = ',I8,2X,A4)
4885      CALL DPWRST('XXX','BUG ')
4886 9035 CONTINUE
4887 9090 CONTINUE
4888C
4889      RETURN
4890      END
4891      SUBROUTINE DPBBLI(IHARG,IHARG2,NUMARG,IDEBBL,MAXBAR,IBABLI,
4892CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
4893CCCCC SUBROUTINE DPBBLI(IHARG,NUMARG,IDEBBL,MAXBAR,IBABLI,
4894     1IBUGP2,IFOUND,IERROR)
4895C
4896C     PURPOSE--DEFINE THE BORDER LINES = THE LINES TYPES
4897C              OF THE BORDER AROUND THE BARS.
4898C              THESE ARE LOCATED IN THE VECTOR IBABLI(.).
4899C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
4900C                     --NUMARG
4901C                     --IDEBBL
4902C                     --MAXBAR
4903C                     --IBUGP2 ('ON' OR 'OFF' )
4904C     OUTPUT ARGUMENTS--IBABLI (A CHARACTER VECTOR)
4905C                     --IFOUND ('YES' OR 'NO' )
4906C                     --IERROR ('YES' OR 'NO' )
4907C     WRITTEN BY--JAMES J. FILLIBEN
4908C                 STATISTICAL ENGINEERING DIVISION
4909C                 INFORMATION TECHNOLOGY LABORATORY
4910C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
4911C                 GAITHERSBURG, MD 20899-8980
4912C                 PHONE--301-975-2855
4913C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
4914C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
4915C     LANGUAGE--ANSI FORTRAN (1977)
4916C     VERSION NUMBER--82/7
4917C     ORIGINAL VERSION--DECEMBER  1983.
4918C     UPDATED         --AUGUST    1995.  DASH2 BUG
4919C
4920C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
4921C
4922      CHARACTER*4 IHARG
4923CCCCC AUGUST 1995.  ADD FOLLOWING LINE
4924      CHARACTER*4 IHARG2
4925      CHARACTER*4 IDEBBL
4926      CHARACTER*4 IBABLI
4927C
4928      CHARACTER*4 IBUGP2
4929      CHARACTER*4 IFOUND
4930      CHARACTER*4 IERROR
4931C
4932      CHARACTER*4 IHOLD1
4933      CHARACTER*4 IHOLD2
4934C
4935      CHARACTER*4 ISUBN1
4936      CHARACTER*4 ISUBN2
4937      CHARACTER*4 ISTEPN
4938C
4939      DIMENSION IHARG(*)
4940CCCCC AUGUST 1995.  ADD FOLLOWING LINE
4941      DIMENSION IHARG2(*)
4942      DIMENSION IBABLI(*)
4943C
4944C---------------------------------------------------------------------
4945C
4946      INCLUDE 'DPCOP2.INC'
4947C
4948C-----START POINT-----------------------------------------------------
4949C
4950      IFOUND='NO'
4951      IERROR='NO'
4952C
4953      ISUBN1='DPBB'
4954      ISUBN2='LI  '
4955C
4956      NUMBAR=0
4957      IHOLD1='-999'
4958      IHOLD2='-999'
4959C
4960      IF(IBUGP2.EQ.'OFF')GOTO90
4961      WRITE(ICOUT,999)
4962  999 FORMAT(1X)
4963      CALL DPWRST('XXX','BUG ')
4964      WRITE(ICOUT,51)
4965   51 FORMAT('***** AT THE BEGINNING OF DPBBLI--')
4966      CALL DPWRST('XXX','BUG ')
4967      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
4968   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
4969      CALL DPWRST('XXX','BUG ')
4970      WRITE(ICOUT,53)MAXBAR,NUMBAR
4971   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
4972      CALL DPWRST('XXX','BUG ')
4973      WRITE(ICOUT,54)IHOLD1,IHOLD2
4974   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
4975      CALL DPWRST('XXX','BUG ')
4976      WRITE(ICOUT,55)IDEBBL
4977   55 FORMAT('IDEBBL = ',A4)
4978      CALL DPWRST('XXX','BUG ')
4979      WRITE(ICOUT,60)NUMARG
4980   60 FORMAT('NUMARG = ',I8)
4981      CALL DPWRST('XXX','BUG ')
4982      DO65I=1,NUMARG
4983      WRITE(ICOUT,66)IHARG(I)
4984   66 FORMAT('IHARG(I) = ',A4)
4985      CALL DPWRST('XXX','BUG ')
4986   65 CONTINUE
4987      WRITE(ICOUT,70)IBABLI(1)
4988   70 FORMAT('IBABLI(1) = ',A4)
4989      CALL DPWRST('XXX','BUG ')
4990      DO75I=1,10
4991      WRITE(ICOUT,76)I,IBABLI(I)
4992   76 FORMAT('I,IBABLI(I) = ',I8,2X,A4)
4993      CALL DPWRST('XXX','BUG ')
4994   75 CONTINUE
4995   90 CONTINUE
4996C
4997C               **************************************
4998C               **  STEP 1--                        **
4999C               **  BRANCH TO THE APPROPRIATE CASE  **
5000C               **************************************
5001C
5002      ISTEPN='1'
5003      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5004C
5005      IF(NUMARG.LE.2)GOTO9000
5006      IF(NUMARG.EQ.3)GOTO1130
5007      IF(NUMARG.EQ.4)GOTO1140
5008      IF(NUMARG.EQ.5)GOTO1150
5009      GOTO1160
5010C
5011 1130 CONTINUE
5012      GOTO1200
5013C
5014 1140 CONTINUE
5015      IF(IHARG(5).EQ.'ALL')IHOLD1='    '
5016      IF(IHARG(5).EQ.'ALL')GOTO1300
5017      GOTO1200
5018C
5019 1150 CONTINUE
5020CCCCC APRIL 1996.  CHANGE IHOLD TO IHOLD1 BELOW
5021      IF(IHARG(5).EQ.'ALL')THEN
5022        IHOLD1=IHARG(6)
5023        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2'
5024        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3'
5025        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4'
5026        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5'
5027        GOTO1300
5028      ENDIF
5029      IF(IHARG(6).EQ.'ALL')THEN
5030        IHOLD1=IHARG(5)
5031        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2'
5032        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3'
5033        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4'
5034        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5'
5035        GOTO1300
5036      ENDIF
5037      GOTO1200
5038C
5039 1160 CONTINUE
5040      GOTO1200
5041C
5042C               *************************************************
5043C               **  STEP 2--                                   **
5044C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
5045C               *************************************************
5046C
5047 1200 CONTINUE
5048      ISTEPN='2'
5049      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5050C
5051      IF(NUMARG.LE.3)GOTO1210
5052      GOTO1220
5053C
5054 1210 CONTINUE
5055      NUMBAR=1
5056      IBABLI(1)='    '
5057      GOTO1270
5058C
5059 1220 CONTINUE
5060      NUMBAR=NUMARG-3
5061      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
5062      DO1225I=1,NUMBAR
5063      J=I+3
5064      IHOLD1=IHARG(J)
5065      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2'
5066      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3'
5067      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4'
5068      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5'
5069      IHOLD2=IHOLD1
5070      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
5071      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
5072      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBBL
5073      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBBL
5074      IBABLI(I)=IHOLD2
5075 1225 CONTINUE
5076      GOTO1270
5077C
5078 1270 CONTINUE
5079      IF(IFEEDB.EQ.'OFF')GOTO1279
5080      WRITE(ICOUT,999)
5081      CALL DPWRST('XXX','BUG ')
5082      DO1278I=1,NUMBAR
5083      WRITE(ICOUT,1276)I,IBABLI(I)
5084 1276 FORMAT('THE LINE TYPE FOR BAR BORDER ',I6,
5085     1' HAS JUST BEEN SET TO ',A4)
5086      CALL DPWRST('XXX','BUG ')
5087 1278 CONTINUE
5088 1279 CONTINUE
5089      IFOUND='YES'
5090      GOTO9000
5091C
5092C               **************************
5093C               **  STEP 3--            **
5094C               **  TREAT THE ALL CASE  **
5095C               **************************
5096C
5097 1300 CONTINUE
5098      ISTEPN='3'
5099      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5100C
5101      NUMBAR=MAXBAR
5102      IHOLD2=IHOLD1
5103      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
5104      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
5105      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBBL
5106      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBBL
5107      DO1315I=1,NUMBAR
5108      IBABLI(I)=IHOLD2
5109 1315 CONTINUE
5110      GOTO1370
5111C
5112 1370 CONTINUE
5113      IF(IFEEDB.EQ.'OFF')GOTO1319
5114      WRITE(ICOUT,999)
5115      CALL DPWRST('XXX','BUG ')
5116      I=1
5117      WRITE(ICOUT,1316)IBABLI(I)
5118 1316 FORMAT('THE LINE TYPE FOR ALL BAR BORDERS',
5119     1' HAS JUST BEEN SET TO ',A4)
5120      CALL DPWRST('XXX','BUG ')
5121 1319 CONTINUE
5122      IFOUND='YES'
5123      GOTO9000
5124C
5125C               *****************
5126C               **  STEP 90--  **
5127C               **  EXIT       **
5128C               *****************
5129C
5130 9000 CONTINUE
5131      IF(IBUGP2.EQ.'OFF')GOTO9090
5132      WRITE(ICOUT,9011)
5133 9011 FORMAT('***** AT THE END       OF DPBBLI--')
5134      CALL DPWRST('XXX','BUG ')
5135      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
5136 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
5137      CALL DPWRST('XXX','BUG ')
5138      WRITE(ICOUT,9013)MAXBAR,NUMBAR
5139 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
5140      CALL DPWRST('XXX','BUG ')
5141      WRITE(ICOUT,9014)IHOLD1,IHOLD2
5142 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
5143      CALL DPWRST('XXX','BUG ')
5144      WRITE(ICOUT,9015)IDEBBL
5145 9015 FORMAT('IDEBBL = ',A4)
5146      CALL DPWRST('XXX','BUG ')
5147      WRITE(ICOUT,9020)NUMARG
5148 9020 FORMAT('NUMARG = ',I8)
5149      CALL DPWRST('XXX','BUG ')
5150      DO9025I=1,NUMARG
5151      WRITE(ICOUT,9026)IHARG(I)
5152 9026 FORMAT('IHARG(I) = ',A4)
5153      CALL DPWRST('XXX','BUG ')
5154 9025 CONTINUE
5155      WRITE(ICOUT,9030)IBABLI(1)
5156 9030 FORMAT('IBABLI(1) = ',A4)
5157      CALL DPWRST('XXX','BUG ')
5158      DO9035I=1,10
5159      WRITE(ICOUT,9036)I,IBABLI(I)
5160 9036 FORMAT('I,IBABLI(I) = ',I8,2X,A4)
5161      CALL DPWRST('XXX','BUG ')
5162 9035 CONTINUE
5163 9090 CONTINUE
5164C
5165      RETURN
5166      END
5167      SUBROUTINE DPBBTH(IHARG,IARGT,ARG,NUMARG,PDEBBT,MAXBAR,PBABTH,
5168     1IBUGP2,IFOUND,IERROR)
5169C
5170C     PURPOSE--DEFINE THE BAR (BORDER) LINE THICKNESSES = THE THICKNESSES
5171C              OF THE BORDER LINE AROUND THE BARS.
5172C              THESE ARE LOCATED IN THE VECTOR PBABTH(.).
5173C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
5174C                     --IARGT  (A  CHARACTER VECTOR)
5175C                     --ARG
5176C                     --NUMARG
5177C                     --PDEBBT
5178C                     --MAXBAR
5179C                     --IBUGP2 ('ON' OR 'OFF' )
5180C     OUTPUT ARGUMENTS--PBABTH (A FLOATING POINT VECTOR)
5181C                     --IFOUND ('YES' OR 'NO' )
5182C                     --IERROR ('YES' OR 'NO' )
5183C     WRITTEN BY--JAMES J. FILLIBEN
5184C                 STATISTICAL ENGINEERING DIVISION
5185C                 INFORMATION TECHNOLOGY LABORATORY
5186C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5187C                 GAITHERSBURG, MD 20899-8980
5188C                 PHONE--301-975-2855
5189C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5190C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5191C     LANGUAGE--ANSI FORTRAN (1977)
5192C     VERSION NUMBER--82/7
5193C     ORIGINAL VERSION--DECEMBER  1983.
5194C
5195C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5196C
5197      CHARACTER*4 IHARG
5198      CHARACTER*4 IARGT
5199C
5200      CHARACTER*4 IBUGP2
5201      CHARACTER*4 IFOUND
5202      CHARACTER*4 IERROR
5203C
5204      CHARACTER*4 IHOLD1
5205C
5206      CHARACTER*4 ISUBN1
5207      CHARACTER*4 ISUBN2
5208      CHARACTER*4 ISTEPN
5209C
5210      DIMENSION IHARG(*)
5211      DIMENSION IARGT(*)
5212      DIMENSION ARG(*)
5213      DIMENSION PBABTH(*)
5214C
5215C---------------------------------------------------------------------
5216C
5217      INCLUDE 'DPCOP2.INC'
5218C
5219C-----START POINT-----------------------------------------------------
5220C
5221      IFOUND='NO'
5222      IERROR='NO'
5223C
5224      ISUBN1='DPBB'
5225      ISUBN2='TH  '
5226C
5227      NUMBAR=0
5228      IHOLD1='-999'
5229      HOLD1=-999.0
5230      HOLD2=-999.0
5231C
5232      IF(IBUGP2.EQ.'OFF')GOTO90
5233      WRITE(ICOUT,999)
5234  999 FORMAT(1X)
5235      CALL DPWRST('XXX','BUG ')
5236      WRITE(ICOUT,51)
5237   51 FORMAT('***** AT THE BEGINNING OF DPBBTH--')
5238      CALL DPWRST('XXX','BUG ')
5239      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
5240   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
5241      CALL DPWRST('XXX','BUG ')
5242      WRITE(ICOUT,53)MAXBAR,NUMBAR
5243   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
5244      CALL DPWRST('XXX','BUG ')
5245      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
5246   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
5247      CALL DPWRST('XXX','BUG ')
5248      WRITE(ICOUT,55)PDEBBT
5249   55 FORMAT('PDEBBT = ',E15.7)
5250      CALL DPWRST('XXX','BUG ')
5251      WRITE(ICOUT,60)NUMARG
5252   60 FORMAT('NUMARG = ',I8)
5253      CALL DPWRST('XXX','BUG ')
5254      DO65I=1,NUMARG
5255      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
5256   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
5257      CALL DPWRST('XXX','BUG ')
5258   65 CONTINUE
5259      WRITE(ICOUT,70)PBABTH(1)
5260   70 FORMAT('PBABTH(1) = ',E15.7)
5261      CALL DPWRST('XXX','BUG ')
5262      DO75I=1,10
5263      WRITE(ICOUT,76)I,PBABTH(I)
5264   76 FORMAT('I,PBABTH(I) = ',I8,2X,E15.7)
5265      CALL DPWRST('XXX','BUG ')
5266   75 CONTINUE
5267   90 CONTINUE
5268C
5269C               **************************************
5270C               **  STEP 1--                        **
5271C               **  BRANCH TO THE APPROPRIATE CASE  **
5272C               **************************************
5273C
5274      ISTEPN='1'
5275      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5276C
5277      IF(NUMARG.LE.1)GOTO9000
5278      IF(NUMARG.EQ.2)GOTO1120
5279      IF(NUMARG.EQ.3)GOTO1130
5280      IF(NUMARG.EQ.4)GOTO1140
5281      GOTO1150
5282C
5283 1120 CONTINUE
5284      GOTO1200
5285C
5286 1130 CONTINUE
5287      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
5288      IF(IHARG(3).EQ.'ALL')HOLD1=PDEBBT
5289      IF(IHARG(3).EQ.'ALL')GOTO1300
5290      GOTO1200
5291C
5292 1140 CONTINUE
5293      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
5294      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4)
5295      IF(IHARG(3).EQ.'ALL')GOTO1300
5296      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
5297      IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3)
5298      IF(IHARG(4).EQ.'ALL')GOTO1300
5299      GOTO1200
5300C
5301 1150 CONTINUE
5302      GOTO1200
5303C
5304C               *************************************************
5305C               **  STEP 2--                                   **
5306C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
5307C               *************************************************
5308C
5309 1200 CONTINUE
5310      ISTEPN='2'
5311      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5312C
5313      IF(NUMARG.LE.2)GOTO1210
5314      GOTO1220
5315C
5316 1210 CONTINUE
5317      NUMBAR=1
5318      PBABTH(1)=PDEBBT
5319      GOTO1270
5320C
5321 1220 CONTINUE
5322      NUMBAR=NUMARG-2
5323      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
5324      DO1225I=1,NUMBAR
5325      J=I+2
5326      IHOLD1=IHARG(J)
5327      HOLD1=ARG(J)
5328      HOLD2=HOLD1
5329      IF(IHOLD1.EQ.'ON')HOLD2=PDEBBT
5330      IF(IHOLD1.EQ.'OFF')HOLD2=PDEBBT
5331      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBBT
5332      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBBT
5333      PBABTH(I)=HOLD2
5334 1225 CONTINUE
5335      GOTO1270
5336C
5337 1270 CONTINUE
5338      IF(IFEEDB.EQ.'OFF')GOTO1279
5339      WRITE(ICOUT,999)
5340      CALL DPWRST('XXX','BUG ')
5341      DO1278I=1,NUMBAR
5342      WRITE(ICOUT,1276)I,PBABTH(I)
5343 1276 FORMAT('THE THICKNESS OF BAR BORDER ',I6,
5344     1' HAS JUST BEEN SET TO ',E15.7)
5345      CALL DPWRST('XXX','BUG ')
5346 1278 CONTINUE
5347 1279 CONTINUE
5348      IFOUND='YES'
5349      GOTO9000
5350C
5351C               **************************
5352C               **  STEP 3--            **
5353C               **  TREAT THE ALL CASE  **
5354C               **************************
5355C
5356 1300 CONTINUE
5357      ISTEPN='3'
5358      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5359C
5360      NUMBAR=MAXBAR
5361      HOLD2=HOLD1
5362      IF(IHOLD1.EQ.'ON')HOLD2=PDEBBT
5363      IF(IHOLD1.EQ.'OFF')HOLD2=PDEBBT
5364      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBBT
5365      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBBT
5366      DO1315I=1,NUMBAR
5367      PBABTH(I)=HOLD2
5368 1315 CONTINUE
5369      GOTO1370
5370C
5371 1370 CONTINUE
5372      IF(IFEEDB.EQ.'OFF')GOTO1319
5373      WRITE(ICOUT,999)
5374      CALL DPWRST('XXX','BUG ')
5375      I=1
5376      WRITE(ICOUT,1316)PBABTH(I)
5377 1316 FORMAT('THE THICKNESS OF ALL BAR BORDERS',
5378     1' HAS JUST BEEN SET TO ',E15.7)
5379      CALL DPWRST('XXX','BUG ')
5380 1319 CONTINUE
5381      IFOUND='YES'
5382      GOTO9000
5383C
5384C               *****************
5385C               **  STEP 90--  **
5386C               **  EXIT       **
5387C               *****************
5388C
5389 9000 CONTINUE
5390      IF(IBUGP2.EQ.'OFF')GOTO9090
5391      WRITE(ICOUT,9011)
5392 9011 FORMAT('***** AT THE END       OF DPBBTH--')
5393      CALL DPWRST('XXX','BUG ')
5394      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
5395 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
5396      CALL DPWRST('XXX','BUG ')
5397      WRITE(ICOUT,9013)MAXBAR,NUMBAR
5398 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
5399      CALL DPWRST('XXX','BUG ')
5400      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
5401 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
5402      CALL DPWRST('XXX','BUG ')
5403      WRITE(ICOUT,9015)PDEBBT
5404 9015 FORMAT('PDEBBT = ',E15.7)
5405      CALL DPWRST('XXX','BUG ')
5406      WRITE(ICOUT,9020)NUMARG
5407 9020 FORMAT('NUMARG = ',I8)
5408      CALL DPWRST('XXX','BUG ')
5409      DO9025I=1,NUMARG
5410      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
5411 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
5412      CALL DPWRST('XXX','BUG ')
5413 9025 CONTINUE
5414      WRITE(ICOUT,9030)PBABTH(1)
5415 9030 FORMAT('PBABTH(1) = ',E15.7)
5416      CALL DPWRST('XXX','BUG ')
5417      DO9035I=1,10
5418      WRITE(ICOUT,9036)I,PBABTH(I)
5419 9036 FORMAT('I,PBABTH(I) = ',I8,2X,E15.7)
5420      CALL DPWRST('XXX','BUG ')
5421 9035 CONTINUE
5422 9090 CONTINUE
5423C
5424      RETURN
5425      END
5426      SUBROUTINE DPBCC2(Y1,X1,N1,ICASPL,MAXN,NCURVE,
5427     1                  ALAMB1,ALAMB2,
5428     1                  Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
5429     1                  Y2,X2,D2,N2,NPLOTV,
5430     1                  IBUGG3,ISUBRO,IERROR)
5431C
5432C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS THAT WILL DEFINE
5433C              THE BOX-COX CORRELATION PLOT TRACE WHICH IS A PLOT OF
5434C              THE CORRELATION COEFFICIENT OF THE CORRELATION
5435C              COEFFICIENT (Y,T(X)) VERSUS THE BOX-COX PARAMATER LAMBDA.
5436C     WRITTEN BY--JAMES J. FILLIBEN
5437C                 STATISTICAL ENGINEERING DIVISION
5438C                 INFORMATION TECHNOLOGY LABORATORY
5439C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5440C                 GAITHERSBURG, MD 20899-8980
5441C                 PHONE--301-975-2855
5442C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5443C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5444C     LANGUAGE--ANSI FORTRAN (1977)
5445C     VERSION NUMBER--87/6
5446C     ORIGINAL VERSION--MAY       1987.
5447C     UPDATED         --DECEMBER  1993. CHARACTER*4 ICASPL
5448C     UPDATED         --MAY       2010. SUPPORT FOR REPLICATION CASE
5449C
5450C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5451C
5452CCCCC THE FOLLOWING LINE WAS ADDED     DECEMBER 1993
5453      CHARACTER*4 ICASPL
5454      CHARACTER*4 IBUGG3
5455      CHARACTER*4 ISUBRO
5456      CHARACTER*4 IERROR
5457C
5458      CHARACTER*4 ISUBN1
5459      CHARACTER*4 ISUBN2
5460C
5461C---------------------------------------------------------------------
5462C
5463      DIMENSION Y1(*)
5464      DIMENSION X1(*)
5465C
5466      DIMENSION Y2(*)
5467      DIMENSION X2(*)
5468      DIMENSION D2(*)
5469      DIMENSION Y2TEMP(*)
5470      DIMENSION X2TEMP(*)
5471      DIMENSION D2TEMP(*)
5472C
5473      DIMENSION DISPAR(*)
5474      DIMENSION CORR(*)
5475C
5476C---------------------------------------------------------------------
5477C
5478      INCLUDE 'DPCOP2.INC'
5479C
5480C-----START POINT-----------------------------------------------------
5481C
5482      ISUBN1='DPBC'
5483      ISUBN2='C2  '
5484      IERROR='NO'
5485      AN1=0.0
5486C
5487      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BCC2')THEN
5488        WRITE(ICOUT,999)
5489  999   FORMAT(1X)
5490        CALL DPWRST('XXX','BUG ')
5491        WRITE(ICOUT,51)
5492   51   FORMAT('***** AT THE BEGINNING OF DPBCC2--')
5493        CALL DPWRST('XXX','BUG ')
5494        WRITE(ICOUT,53)IBUGG3,ISUBRO,ICASPL,MAXN,N1,NPLOTV
5495   53   FORMAT('IBUGG3,ISUBRO,ICASPL,MAXN,N1,NPLOTV = ',3(A4,2X),3I8)
5496        CALL DPWRST('XXX','BUG ')
5497        WRITE(ICOUT,54)ALAMB1,ALAMB2
5498   54   FORMAT('ALAMB1,ALAMB2 = ',2E15.7)
5499        CALL DPWRST('XXX','BUG ')
5500        IF(N1.GT.0)THEN
5501          DO60I=1,N1
5502            WRITE(ICOUT,61)I,Y1(I),X1(I)
5503   61       FORMAT('I,Y1(I),X1(I) = ',I8,2E12.5)
5504            CALL DPWRST('XXX','BUG ')
5505   60     CONTINUE
5506        ENDIF
5507      ENDIF
5508C
5509C               ********************************************
5510C               **  STEP 11--                             **
5511C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
5512C               ********************************************
5513C
5514      IF(N1.LT.3)THEN
5515        WRITE(ICOUT,999)
5516        CALL DPWRST('XXX','BUG ')
5517        WRITE(ICOUT,1121)
5518 1121   FORMAT('***** ERROR IN BOX-COX LINEARITY PLOT--')
5519        CALL DPWRST('XXX','BUG ')
5520        WRITE(ICOUT,1122)
5521 1122   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN THREE.')
5522        CALL DPWRST('XXX','BUG ')
5523        IERROR='YES'
5524        GOTO9000
5525      ENDIF
5526C
5527      HOLD=X1(1)
5528      DO1130I=1,N1
5529        IF(X1(I).NE.HOLD)GOTO1139
5530 1130 CONTINUE
5531      WRITE(ICOUT,999)
5532      CALL DPWRST('XXX','BUG ')
5533      WRITE(ICOUT,1121)
5534      CALL DPWRST('XXX','BUG ')
5535      WRITE(ICOUT,1132)
5536 1132 FORMAT('      ALL INPUT RESPONSE VARIABLE ELEMENTS')
5537      CALL DPWRST('XXX','BUG ')
5538      WRITE(ICOUT,1133)HOLD
5539 1133 FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
5540      CALL DPWRST('XXX','BUG ')
5541      WRITE(ICOUT,999)
5542      CALL DPWRST('XXX','BUG ')
5543      IERROR='YES'
5544      GOTO9000
5545 1139 CONTINUE
5546C
5547C               *******************************************************
5548C               **  STEP 21--                                        **
5549C               **  DETERMINE THE SET OF PARAMETER VALUES            **
5550C               **  TO BE USED FOR THE TRANSFORMATIONS               **
5551C               *******************************************************
5552C
5553      NUMDIS=41
5554      ANUMDI=NUMDIS
5555      DO2100IDIS=1,NUMDIS
5556        AIDIS=IDIS
5557        DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1)
5558 2100 CONTINUE
5559C
5560C               ****************************************
5561C               **  STEP 22--                         **
5562C               **  DETERMINE PLOT COORDINATES        **
5563C               ****************************************
5564C
5565      XMIN=X1(1)
5566      DO2210I=1,N1
5567        Y2TEMP(I)=Y1(I)
5568        IF(X1(I).LT.XMIN)XMIN=X1(I)
5569        D2TEMP(I)=X1(I)
5570 2210 CONTINUE
5571C
5572      IF(XMIN.GT.0.0)GOTO2249
5573      DO2240I=1,N1
5574        D2TEMP(I)=D2TEMP(I)-XMIN+1.0
5575 2240 CONTINUE
5576 2249 CONTINUE
5577C
5578      DO2300IDIS=1,NUMDIS
5579C
5580        ALAMBA=DISPAR(IDIS)
5581        IF(-0.001.LE.ALAMBA.AND.ALAMBA.LE.0.001)THEN
5582          DO2315I=1,N1
5583            X2TEMP(I)=LOG(D2TEMP(I))
5584 2315     CONTINUE
5585        ELSE
5586          DO2325I=1,N1
5587            X2TEMP(I)=((D2TEMP(I)**ALAMBA)-1.0)/ALAMBA
5588 2325     CONTINUE
5589        ENDIF
5590C
5591        AN1=N1
5592        SUMX=0.0
5593        SUMY=0.0
5594        DO2410I=1,N1
5595          SUMX=SUMX+X2TEMP(I)
5596          SUMY=SUMY+Y2TEMP(I)
5597 2410   CONTINUE
5598        XBAR=SUMX/AN1
5599        YBAR=SUMY/AN1
5600C
5601        SUMX=0.0
5602        SUMY=0.0
5603        SUMXY=0.0
5604        DO2420I=1,N1
5605          SUMX=SUMX+(X2TEMP(I)-XBAR)*(X2TEMP(I)-XBAR)
5606          SUMY=SUMY+(Y2TEMP(I)-YBAR)*(Y2TEMP(I)-YBAR)
5607          SUMXY=SUMXY+(X2TEMP(I)-XBAR)*(Y2TEMP(I)-YBAR)
5608 2420   CONTINUE
5609        ARG=SUMX*SUMY
5610        CC=0.0
5611        IF(ARG.GT.0.0)CC=SUMXY/SQRT(ARG)
5612        CORR(IDIS)=CC
5613C
5614        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BCC2')THEN
5615          WRITE(ICOUT,999)
5616          CALL DPWRST('XXX','BUG ')
5617          DO2431I=1,N1
5618            WRITE(ICOUT,2433)I,Y1(I),X1(I),Y2TEMP(I),X2TEMP(I),
5619     1                       D2TEMP(I),CORR(I)
5620 2433       FORMAT('I,Y1(I),X1(I),Y2TEMP(I),X2TEMP(I),',
5621     1             'D2TEMP(I),CORR(I) = ',I8,6E12.5)
5622            CALL DPWRST('XXX','BUG ')
5623 2431     CONTINUE
5624          WRITE(ICOUT,2434)ICASPL,XBAR,YBAR,SUMX,SUMY,SUMXY
5625 2434     FORMAT('ICASPL,XBAR,YBAR,SUMX,SUMY,SUMXY = ',
5626     1           A4,2X,5G15.7)
5627          CALL DPWRST('XXX','BUG ')
5628        ENDIF
5629C
5630 2300 CONTINUE
5631      DO2510IDIS=1,NUMDIS
5632        N2=N2+1
5633        Y2(N2)=CORR(IDIS)
5634        X2(N2)=DISPAR(IDIS)
5635        D2(N2)=REAL(NCURVE)
5636 2510 CONTINUE
5637      NPLOTV=2
5638      GOTO9000
5639C
5640C               *****************
5641C               **  STEP 90--  **
5642C               **  EXIT       **
5643C               *****************
5644C
5645 9000 CONTINUE
5646      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BCC2')THEN
5647        WRITE(ICOUT,999)
5648        CALL DPWRST('XXX','BUG ')
5649        WRITE(ICOUT,9011)
5650 9011   FORMAT('***** AT THE END       OF DPBCC2--')
5651        CALL DPWRST('XXX','BUG ')
5652        WRITE(ICOUT,9012)ICASPL,MAXN,N2,IERROR
5653 9012   FORMAT('ICASPL,MAXN,N2,IERROR = ',A4,I8,I8,2X,A4)
5654        CALL DPWRST('XXX','BUG ')
5655        DO9015I=1,N2
5656          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
5657 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
5658          CALL DPWRST('XXX','BUG ')
5659 9015   CONTINUE
5660      ENDIF
5661C
5662      RETURN
5663      END
5664      SUBROUTINE DPBCH2(Y1,X1,N1,ICASPL,MAXN,NCURVE,
5665     1                  ALAMB1,ALAMB2,
5666     1                  Y2TEMP,X2TEMP,D2TEMP,DISPAR,RATIO,
5667     1                  Y3,DISTX,DISTX3,SDY3,
5668     1                  Y2,X2,D2,N2,NPLOTV,
5669     1                  IBUGG3,ISUBRO,IERROR)
5670C
5671C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS THAT WILL DEFINE
5672C              THE BOX-COX HOMOSCEDASTICITY PLOT TRACE WHICH IS A PLOT
5673C              OF THE RATIO  MIN(SD(T(Y)) / MAX(SD(T(Y)) VERSUS THE
5674C              BOX-COX PARAMATER LAMBDA.
5675C     NOTE--THE RATIO MUST BE BETWEEN 0 AND 1.  THE CLOSER TO 1, THE
5676C            MORE CONSTANT THE VARIANCE.
5677C     WRITTEN BY--JAMES J. FILLIBEN
5678C                 STATISTICAL ENGINEERING DIVISION
5679C                 INFORMATION TECHNOLOGY LABORATORY
5680C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5681C                 GAITHERSBURG, MD 20899-8980
5682C                 PHONE--301-975-2855
5683C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5684C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5685C     LANGUAGE--ANSI FORTRAN (1977)
5686C     VERSION NUMBER--87/6
5687C     ORIGINAL VERSION--MAY       1987.
5688C     UPDATED         --DECEMBER  1993. CHARACTER*4 ICASPL
5689C     UPDATED         --FEBRUARY  1994. CHANGE STAT TO RATIO
5690C     UPDATED         --MAY       2010. SUPPORT FOR "REPLICATION" CASE
5691C
5692C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5693C
5694CCCCC THE FOLLOWING LINE WAS ADDED     DECEMBER 1993
5695      CHARACTER*4 ICASPL
5696      CHARACTER*4 IBUGG3
5697      CHARACTER*4 ISUBRO
5698      CHARACTER*4 IERROR
5699C
5700      CHARACTER*4 IWRITE
5701C
5702      CHARACTER*4 ISUBN1
5703      CHARACTER*4 ISUBN2
5704      CHARACTER*4 ISTEPN
5705C
5706C---------------------------------------------------------------------
5707C
5708      DIMENSION Y1(*)
5709      DIMENSION X1(*)
5710C
5711      DIMENSION Y2(*)
5712      DIMENSION X2(*)
5713      DIMENSION D2(*)
5714      DIMENSION Y2TEMP(*)
5715      DIMENSION X2TEMP(*)
5716      DIMENSION D2TEMP(*)
5717C
5718      DIMENSION DISPAR(*)
5719      DIMENSION RATIO(*)
5720C
5721CCCCC THE FOLLOWING DIMENSIONS ARE TEMPORARY
5722      DIMENSION Y3(*)
5723      DIMENSION DISTX(*)
5724      DIMENSION DISTX3(*)
5725      DIMENSION SDY3(*)
5726C
5727C---------------------------------------------------------------------
5728C
5729      INCLUDE 'DPCOP2.INC'
5730C
5731C-----START POINT-----------------------------------------------------
5732C
5733      ISUBN1='DPBC'
5734      ISUBN2='H2  '
5735      IERROR='NO'
5736      AN1=0.0
5737C
5738      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BCH2')THEN
5739        WRITE(ICOUT,999)
5740  999   FORMAT(1X)
5741        CALL DPWRST('XXX','BUG ')
5742        WRITE(ICOUT,51)
5743   51   FORMAT('***** AT THE BEGINNING OF DPBCH2--')
5744        CALL DPWRST('XXX','BUG ')
5745        WRITE(ICOUT,53)IBUGG3,ISUBRO,ICASPL,MAXN,N1,NPLOTV
5746   53   FORMAT('IBUGG3,ISUBRO,ICASPL,MAXN,N1,NPLOTV = ',A4,2X,3I8)
5747        CALL DPWRST('XXX','BUG ')
5748        WRITE(ICOUT,54)ALAMB1,ALAMB2
5749   54   FORMAT('ALAMB1,ALAMB2 = ',2G15.7)
5750        CALL DPWRST('XXX','BUG ')
5751        IF(N1.GT.0)THEN
5752          DO60I=1,N1
5753            WRITE(ICOUT,61)I,Y1(I),X1(I)
5754   61       FORMAT('I,Y1(I),X1(I) = ',I8,2E12.5)
5755            CALL DPWRST('XXX','BUG ')
5756   60     CONTINUE
5757        ENDIF
5758      ENDIF
5759C
5760C               ********************************************
5761C               **  STEP 11--                             **
5762C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
5763C               ********************************************
5764C
5765      IF(N1.LT.3)THEN
5766        WRITE(ICOUT,999)
5767        CALL DPWRST('XXX','BUG ')
5768        WRITE(ICOUT,1121)
5769 1121   FORMAT('***** ERROR IN BOX-COX HOMOGENEITY PLOT--')
5770        CALL DPWRST('XXX','BUG ')
5771        WRITE(ICOUT,1122)
5772 1122   FORMAT('      THE NUMBER OF OBSERVATIONS WAS LESS THAN THREE.')
5773        CALL DPWRST('XXX','BUG ')
5774        IERROR='YES'
5775        GOTO9000
5776      ENDIF
5777C
5778      HOLD=X1(1)
5779      DO1130I=1,N1
5780      IF(X1(I).NE.HOLD)GOTO1139
5781 1130 CONTINUE
5782      WRITE(ICOUT,999)
5783      CALL DPWRST('XXX','BUG ')
5784      WRITE(ICOUT,1121)
5785      CALL DPWRST('XXX','BUG ')
5786      WRITE(ICOUT,1132)
5787 1132 FORMAT('      ALL INPUT RESPONSE VARIABLE ELEMENTS')
5788      CALL DPWRST('XXX','BUG ')
5789      WRITE(ICOUT,1133)HOLD
5790 1133 FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
5791      CALL DPWRST('XXX','BUG ')
5792      WRITE(ICOUT,999)
5793      CALL DPWRST('XXX','BUG ')
5794      IERROR='YES'
5795      GOTO9000
5796 1139 CONTINUE
5797C
5798C               *******************************************************
5799C               **  STEP 21--                                        **
5800C               **  DETERMINE THE SET OF PARAMETER VALUES            **
5801C               **  TO BE USED FOR THE TRANSFORMATIONS               **
5802C               *******************************************************
5803C
5804      NUMDIS=41
5805      ANUMDI=NUMDIS
5806      DO2100IDIS=1,NUMDIS
5807        AIDIS=IDIS
5808        DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1)
5809 2100 CONTINUE
5810C
5811C               ********************************************************
5812C               **  STEP 22--                                         **
5813C               **  DETERMINE THE NUMBER OF DISTINCT SUBSETS          **
5814C               **  FOR VARIABLE 1;                                   **
5815C               **  IF ALL VALUES ARE DISTINCT, THEN THIS             **
5816C               **  IMPLIES WE HAVE THE NO REPLICATION CASE           **
5817C               **  WHICH IS AN ERROR CONDITION FOR THIS COMMAND **
5818C               ********************************************************
5819C
5820      ISTEPN='22'
5821      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BCH2')
5822     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
5823C
5824      IWRITE='OFF'
5825C
5826      NUMSET=0
5827      DO2200I=1,N1
5828         IF(NUMSET.GE.1)THEN
5829            DO2300J=1,NUMSET
5830               IF(X1(I).EQ.DISTX(J))GOTO2200
5831 2300       CONTINUE
5832         ENDIF
5833         NUMSET=NUMSET+1
5834         DISTX(NUMSET)=X1(I)
5835 2200 CONTINUE
5836C
5837      IF(NUMSET.EQ.0.OR.NUMSET.EQ.N1)THEN
5838         WRITE(ICOUT,999)
5839         CALL DPWRST('XXX','BUG ')
5840         WRITE(ICOUT,1121)
5841         CALL DPWRST('XXX','BUG ')
5842         WRITE(ICOUT,2206)
5843 2206    FORMAT('     FOR A BOX-COX HOMOSCEDASTICITY PLOT,')
5844         CALL DPWRST('XXX','BUG ')
5845         WRITE(ICOUT,2207)
5846 2207    FORMAT('     THERE MUST BE REPLICATION--BUT NO REPLICATION')
5847         CALL DPWRST('XXX','BUG ')
5848         WRITE(ICOUT,2208)
5849 2208    FORMAT('     WAS FOUND--ALL VALUES OF X WERE DISTINCT.')
5850         CALL DPWRST('XXX','BUG ')
5851         WRITE(ICOUT,2209)NUMSET
5852 2209    FORMAT('     NUMSET = ',I8)
5853         CALL DPWRST('XXX','BUG ')
5854         IERROR='YES'
5855         GOTO9000
5856      ENDIF
5857C
5858C               ****************************************
5859C               **  STEP 32--                         **
5860C               **  DETERMINE PLOT COORDINATES        **
5861C               ****************************************
5862C
5863      DO3210I=1,N1
5864         X2TEMP(I)=X1(I)
5865 3210 CONTINUE
5866C
5867      YMIN=Y1(1)
5868      DO3220I=1,N1
5869         IF(Y1(I).LT.YMIN)YMIN=Y1(I)
5870         D2TEMP(I)=Y1(I)
5871 3220 CONTINUE
5872C
5873      IF(YMIN.LE.0.0)THEN
5874         DO3240I=1,N1
5875            D2TEMP(I)=D2TEMP(I)-YMIN+1.0
5876 3240    CONTINUE
5877      ENDIF
5878C
5879      DO3300IDIS=1,NUMDIS
5880C
5881         ALAMBA=DISPAR(IDIS)
5882         IF(-0.001.LE.ALAMBA.AND.ALAMBA.LE.0.001)THEN
5883            DO3315I=1,N1
5884               Y2TEMP(I)=LOG(D2TEMP(I))
5885 3315       CONTINUE
5886         ELSE
5887            DO3325I=1,N1
5888               Y2TEMP(I)=((D2TEMP(I)**ALAMBA)-1.0)/ALAMBA
5889 3325       CONTINUE
5890         ENDIF
5891C
5892         ISET3=0
5893         DO3410ISET=1,NUMSET
5894            I3=0
5895            DO3420I=1,N1
5896               IF(X2TEMP(I).EQ.DISTX(ISET))THEN
5897                  I3=I3+1
5898                  Y3(I3)=Y2TEMP(I)
5899               ENDIF
5900 3420       CONTINUE
5901            IF(I3.GE.2)THEN
5902               ISET3=ISET3+1
5903               DISTX3(ISET3)=DISTX(ISET)
5904               CALL SD(Y3,I3,IWRITE,SDY3(ISET3),IBUGG3,IERROR)
5905            ENDIF
5906 3410    CONTINUE
5907C
5908         CALL MINIM(SDY3,ISET3,IWRITE,AMINSD,IBUGG3,IERROR)
5909         CALL MAXIM(SDY3,ISET3,IWRITE,AMAXSD,IBUGG3,IERROR)
5910         RATIO(IDIS)=0.0
5911         IF(AMAXSD.GT.0.0)RATIO(IDIS)=AMINSD/AMAXSD
5912C
5913         IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BCH2')THEN
5914           WRITE(ICOUT,999)
5915           CALL DPWRST('XXX','BUG ')
5916           WRITE(ICOUT,3434)AMINSD,AMAXSD,RATIO(IDIS)
5917 3434      FORMAT('AMINSD,AMAXSD,RATIO(IDIS) = ',3G15.7)
5918           CALL DPWRST('XXX','BUG ')
5919         ENDIF
5920C
5921 3300 CONTINUE
5922C
5923      DO3510IDIS=1,NUMDIS
5924         N2=N2+1
5925         Y2(N2)=RATIO(IDIS)
5926         X2(N2)=DISPAR(IDIS)
5927         D2(N2)=REAL(NCURVE)
5928 3510 CONTINUE
5929      NPLOTV=2
5930      GOTO9000
5931C
5932C               *****************
5933C               **  STEP 90--  **
5934C               **  EXIT       **
5935C               *****************
5936C
5937 9000 CONTINUE
5938      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BCH2')THEN
5939        WRITE(ICOUT,999)
5940        CALL DPWRST('XXX','BUG ')
5941        WRITE(ICOUT,9011)
5942 9011   FORMAT('***** AT THE END       OF DPBCH2--')
5943        CALL DPWRST('XXX','BUG ')
5944        WRITE(ICOUT,9012)ICASPL,MAXN,N2,IERROR
5945 9012   FORMAT('ICASPL,MAXN,N2,IERROR = ',A4,I8,I8,2X,A4)
5946        CALL DPWRST('XXX','BUG ')
5947        DO9015I=1,N2
5948          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
5949 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2)
5950          CALL DPWRST('XXX','BUG ')
5951 9015   CONTINUE
5952      ENDIF
5953C
5954      RETURN
5955      END
5956      SUBROUTINE DPBCNP(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
5957     1IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
5958C
5959C     PURPOSE--GENERATE A BOX-COX NORMALITY PLOT
5960C     WRITTEN BY--JAMES J. FILLIBEN
5961C                 STATISTICAL ENGINEERING DIVISION
5962C                 INFORMATION TECHNOLOGY LABORATORY
5963C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
5964C                 GAITHERSBURG, MD 20899-8980
5965C                 PHONE--301-975-2855
5966C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
5967C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
5968C     LANGUAGE--ANSI FORTRAN (1977)
5969C     VERSION NUMBER--82/7
5970C     ORIGINAL VERSION--AUGUST    1981.
5971C     UPDATED         --MARCH     1982.
5972C     UPDATED         --MAY       1982.
5973C     UPDATED         --JUNE      1990. TEMPORARY ARRAYS TO GARBAGE COMMON
5974C     UPDATED         --MAY       2010. SUPPORT FOR "MULTIPLE" AND
5975C                                       "REPLICATION"
5976C     UPDATED         --MAY       2010. USE DPPARS AND DPPAR3 TO PERFORM
5977C                                       THE COMMAND PARSING
5978C     UPDATED         --MAY       2010. FOLD IN LINEARITY AND
5979C                                       HOMOGENEITY CASES
5980C
5981C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
5982C
5983      CHARACTER*4 ICASPL
5984      CHARACTER*4 IAND1
5985      CHARACTER*4 IAND2
5986      CHARACTER*4 IBUGG2
5987      CHARACTER*4 IBUGG3
5988      CHARACTER*4 IBUGQ
5989      CHARACTER*4 ISUBRO
5990      CHARACTER*4 IFOUND
5991      CHARACTER*4 IFOUN1
5992      CHARACTER*4 IFOUN2
5993      CHARACTER*4 IERROR
5994C
5995      CHARACTER*4 IHWUSE
5996      CHARACTER*4 MESSAG
5997      CHARACTER*4 IDATSW
5998      CHARACTER*4 ICASE
5999      CHARACTER*4 IHP
6000      CHARACTER*4 IHP2
6001      CHARACTER*4 IERRO2
6002      CHARACTER*4 ISUBN1
6003      CHARACTER*4 ISUBN2
6004      CHARACTER*4 ISTEPN
6005C
6006C---------------------------------------------------------------------
6007C
6008      INCLUDE 'DPCOPA.INC'
6009C
6010      DIMENSION Y1(MAXOBV)
6011      DIMENSION X1(MAXOBV)
6012      DIMENSION XIDTEM(MAXOBV)
6013      DIMENSION XIDTE2(MAXOBV)
6014      DIMENSION XTEMP1(MAXOBV)
6015      DIMENSION XTEMP2(MAXOBV)
6016      DIMENSION XDESGN(MAXOBV,2)
6017      DIMENSION Y2TEMP(MAXOBV)
6018      DIMENSION X2TEMP(MAXOBV)
6019      DIMENSION D2TEMP(MAXOBV)
6020      DIMENSION ZY(MAXOBV)
6021      DIMENSION ZX(MAXOBV)
6022      DIMENSION CORR(100)
6023      DIMENSION DISPAR(100)
6024      DIMENSION Y3(MAXOBV)
6025      DIMENSION DISTX(MAXOBV)
6026      DIMENSION DISTX3(MAXOBV)
6027      DIMENSION SDY3(MAXOBV)
6028CCCCC FOLLOWING LINES ADDED JUNE, 1990
6029      INCLUDE 'DPCOZZ.INC'
6030      EQUIVALENCE (GARBAG(IGARB1),X1(1))
6031      EQUIVALENCE (GARBAG(IGARB2),Y1(1))
6032      EQUIVALENCE (GARBAG(IGARB3),XIDTEM(1))
6033      EQUIVALENCE (GARBAG(IGARB4),XIDTE2(1))
6034      EQUIVALENCE (GARBAG(IGARB5),XTEMP1(1))
6035      EQUIVALENCE (GARBAG(IGARB6),XTEMP2(1))
6036      EQUIVALENCE (GARBAG(IGARB7),ZY(1))
6037      EQUIVALENCE (GARBAG(IGARB8),ZX(1))
6038      EQUIVALENCE (GARBAG(IGAR10),X2TEMP(1))
6039      EQUIVALENCE (GARBAG(JGAR11),Y2TEMP(1))
6040      EQUIVALENCE (GARBAG(JGAR12),D2TEMP(1))
6041      EQUIVALENCE (GARBAG(JGAR13),CORR(1))
6042      EQUIVALENCE (GARBAG(JGAR13+1000),DISPAR(1))
6043      EQUIVALENCE (GARBAG(JGAR14),Y3(1))
6044      EQUIVALENCE (GARBAG(JGAR15),DISTX(1))
6045      EQUIVALENCE (GARBAG(JGAR16),DISTX3(1))
6046      EQUIVALENCE (GARBAG(JGAR17),SDY3(1))
6047      EQUIVALENCE (GARBAG(JGAR18),XDESGN(1,1))
6048CCCCC END CHANGE
6049C
6050C-----COMMON----------------------------------------------------------
6051C
6052      INCLUDE 'DPCOHK.INC'
6053      INCLUDE 'DPCODA.INC'
6054C
6055      CHARACTER*4 IREPL
6056      CHARACTER*4 IMULT
6057C
6058      CHARACTER*40 INAME
6059      PARAMETER (MAXSPN=30)
6060      CHARACTER*4 IVARN1(MAXSPN)
6061      CHARACTER*4 IVARN2(MAXSPN)
6062      CHARACTER*4 IVARTY(MAXSPN)
6063      REAL PVAR(MAXSPN)
6064      INTEGER ILIS(MAXSPN)
6065      INTEGER NRIGHT(MAXSPN)
6066      INTEGER ICOLR(MAXSPN)
6067C
6068C-----COMMON VARIABLES (GENERAL)--------------------------------------
6069C
6070      INCLUDE 'DPCOP2.INC'
6071C
6072C-----START POINT-----------------------------------------------------
6073C
6074      IFOUND='NO'
6075      IERROR='NO'
6076C
6077      ISUBN1='DPBC'
6078      ISUBN2='NP  '
6079C
6080      MAXCP1=MAXCOL+1
6081      MAXCP2=MAXCOL+2
6082      MAXCP3=MAXCOL+3
6083      MAXCP4=MAXCOL+4
6084      MAXCP5=MAXCOL+5
6085      MAXCP6=MAXCOL+6
6086C
6087      MAXV2=2
6088      MINN2=3
6089C
6090C               *********************************************
6091C               **  TREAT THE BOX-COX NORMALITY PLOT CASE  **
6092C               *********************************************
6093C
6094      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BCNP')THEN
6095        WRITE(ICOUT,999)
6096  999   FORMAT(1X)
6097        CALL DPWRST('XXX','BUG ')
6098        WRITE(ICOUT,51)
6099   51   FORMAT('***** AT THE BEGINNING OF DPBCNP--')
6100        CALL DPWRST('XXX','BUG ')
6101        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
6102   52   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
6103        CALL DPWRST('XXX','BUG ')
6104        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
6105   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
6106        CALL DPWRST('XXX','BUG ')
6107      ENDIF
6108C
6109C               ******************************************************
6110C               **  STEP 1--                                        **
6111C               **  EXTRACT THE COMMAND                             **
6112C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:         **
6113C               **    1) BOX-COX NORMALITY PLOT Y                   **
6114C               **    2) MULTIPLE BOX-COX NORMALITY PLOT Y1 ... YK  **
6115C               **    3) REPLICATED BOX-COX NORMALITY PLOT Y X1  X2 **
6116C               ******************************************************
6117C
6118C     NOTE: KERNEL DENSITY, KERNEL PLOT, DENSITY TRACE ARE SYNONYMS
6119C           FOR KERNEL DENSITY PLOT.
6120C
6121      ISTEPN='1'
6122      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCNP')
6123     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6124C
6125      IF(ICOM.EQ.'BOX' .AND. IHARG(1).EQ.'COX' .AND.
6126     1   IHARG(2).EQ.'NORM' .AND.
6127     1   (IHARG(3).EQ.'PPCC' .OR. IHARG(3).EQ.'LAMB') .AND.
6128     1   IHARG(4).EQ.'PLOT')GOTO9000
6129C
6130      IF(ICOM.EQ.'BOX')GOTO89
6131      IF(ICOM.EQ.'MULT')GOTO89
6132      IF(ICOM.EQ.'REPL')GOTO89
6133      GOTO9000
6134C
6135   89 CONTINUE
6136      ICASPL='BCNP'
6137      IMULT='OFF'
6138      IREPL='OFF'
6139      ILASTC=-9999
6140C
6141      IF(ICOM.EQ.'BOX' .AND. IHARG(1).EQ.'COX')THEN
6142        IFOUN1='YES'
6143      ELSEIF(ICOM.EQ.'MULT')THEN
6144        IMULT='ON'
6145      ELSEIF(ICOM.EQ.'REPL')THEN
6146        IREPL='ON'
6147      ENDIF
6148C
6149      ISTOP=NUMARG-1
6150      DO90I=1,NUMARG
6151        IF(IHARG(I).EQ.'PLOT')THEN
6152          ISTOP=I
6153          GOTO99
6154        ENDIF
6155   90 CONTINUE
6156   99 CONTINUE
6157C
6158      IFOUND='NO'
6159      DO100I=1,ISTOP
6160        IF(IHARG(I).EQ.'=')THEN
6161          IFOUND='NO'
6162          GOTO9000
6163        ELSEIF(IHARG(I).EQ.'BOX' .AND. IHARG(I+1).EQ.'COX')THEN
6164          IF(IHARG(I+2).EQ.'TOLE' .AND. IHARG(I+3).EQ.'INTE')THEN
6165            IFOUND='NO'
6166            GOTO9000
6167          ELSEIF(IHARG(I+2).EQ.'TOLE' .AND. IHARG(I+3).EQ.'LIMI')THEN
6168            IFOUND='NO'
6169            GOTO9000
6170          ELSEIF(IHARG(I+2).EQ.'PRED' .AND. IHARG(I+3).EQ.'INTE')THEN
6171            IFOUND='NO'
6172            GOTO9000
6173          ELSEIF(IHARG(I+2).EQ.'PRED' .AND. IHARG(I+3).EQ.'LIMI')THEN
6174            IFOUND='NO'
6175            GOTO9000
6176          ENDIF
6177          IFOUN1='YES'
6178          IFOUN2='YES'
6179          ILASTC=MAX(ILASTC,I)
6180        ELSEIF(IHARG(I).EQ.'PLOT')THEN
6181          IFOUN2='YES'
6182          ILASTC=MAX(ILASTC,I)
6183        ELSEIF(IHARG(I).EQ.'NORM')THEN
6184          IFOUN2='YES'
6185          ILASTC=MAX(ILASTC,I)
6186          ICASPL='BCNP'
6187        ELSEIF(IHARG(I).EQ.'LINE' .OR. IHARG(1).EQ.'CORR')THEN
6188          IFOUN2='YES'
6189          ILASTC=MAX(ILASTC,I)
6190          ICASPL='BCCP'
6191        ELSEIF(IHARG(I).EQ.'HOMO')THEN
6192          IFOUN2='YES'
6193          ILASTC=MAX(ILASTC,I)
6194          ICASPL='BCHP'
6195        ELSEIF(IHARG(I).EQ.'REPL')THEN
6196          IREPL='ON'
6197        ELSEIF(IHARG(I).EQ.'MULT')THEN
6198          IMULT='ON'
6199        ENDIF
6200  100 CONTINUE
6201C
6202      IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')IFOUND='YES'
6203      IF(IFOUND.EQ.'NO')GOTO9000
6204C
6205      IF(IMULT.EQ.'ON')THEN
6206        IF(IREPL.EQ.'ON')THEN
6207          WRITE(ICOUT,999)
6208          CALL DPWRST('XXX','BUG ')
6209          IF(ICASPL.EQ.'BCNP')THEN
6210            WRITE(ICOUT,101)
6211  101       FORMAT('***** ERROR IN BOX COX NORMALITY PLOT--')
6212          ELSEIF(ICASPL.EQ.'BCCP')THEN
6213            WRITE(ICOUT,102)
6214  102       FORMAT('***** ERROR IN BOX COX NORMALITY PLOT--')
6215          ELSEIF(ICASPL.EQ.'BCHP')THEN
6216            WRITE(ICOUT,103)
6217  103       FORMAT('***** ERROR IN BOX COX HOMOGENEITY PLOT--')
6218          ENDIF
6219          CALL DPWRST('XXX','BUG ')
6220          WRITE(ICOUT,107)
6221  107     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
6222     1           '"REPLICATION" FOR THIS PLOT.')
6223          CALL DPWRST('XXX','BUG ')
6224          IERROR='YES'
6225          GOTO9000
6226        ELSEIF(ICASPL.EQ.'BCCP' .OR. ICASPL.EQ.'BCHP')THEN
6227          WRITE(ICOUT,999)
6228          CALL DPWRST('XXX','BUG ')
6229          IF(ICASPL.EQ.'BCCP')THEN
6230            WRITE(ICOUT,102)
6231          ELSEIF(ICASPL.EQ.'BCHP')THEN
6232            WRITE(ICOUT,103)
6233          ENDIF
6234          CALL DPWRST('XXX','BUG ')
6235          WRITE(ICOUT,109)
6236  109     FORMAT('      THE "MULTIPLE" OPTION IS NOT SUPPORTED FOR ',
6237     1           'THIS PLOT.')
6238          CALL DPWRST('XXX','BUG ')
6239          IERROR='YES'
6240          GOTO9000
6241        ENDIF
6242      ENDIF
6243C
6244      IF(ILASTC.GE.1)THEN
6245        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
6246        ILASTC=0
6247      ENDIF
6248C
6249      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BCNP')THEN
6250        WRITE(ICOUT,112)ICASPL,IMULT,IREPL
6251  112   FORMAT('ICASPL,IMULT,IREPL = ',2(A4,2X),A4)
6252        CALL DPWRST('XXX','BUG ')
6253      ENDIF
6254C
6255C               ****************************************
6256C               **  STEP 2--                          **
6257C               **  EXTRACT THE VARIABLE LIST         **
6258C               ****************************************
6259C
6260      ISTEPN='2'
6261      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCNP')
6262     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6263C
6264      INAME='BOX-COX NORMALITY PLOT'
6265      IF(ICASPL.EQ.'BCCP')INAME='BOX-COX LINEARITY PLOT'
6266      IF(ICASPL.EQ.'BCHP')INAME='BOX-COX HOMOGENEITY PLOT'
6267      MINNA=1
6268      MAXNA=100
6269      MINN2=1
6270      IFLAGE=1
6271      IF(IMULT.EQ.'ON')IFLAGE=0
6272      IFLAGM=1
6273      IF(ICASPL.EQ.'BCCP' .OR. ICASPL.EQ.'BCHP')IFLAGM=0
6274      IFLAGP=0
6275      JMIN=1
6276      JMAX=NUMARG
6277      IF(ICASPL.EQ.'BCNP')THEN
6278        MINNVA=1
6279        MAXNVA=2
6280      ELSEIF(ICASPL.EQ.'BCCP' .OR. ICASPL.EQ.'BCHP')THEN
6281        MINNVA=2
6282        MAXNVA=2
6283      ENDIF
6284      IF(IREPL.EQ.'ON')THEN
6285        MINNVA=MINNVA+1
6286        MAXNVA=MAXNVA+3
6287      ELSEIF(IMULT.EQ.'ON')THEN
6288        MAXNVA=100
6289      ENDIF
6290C
6291      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
6292     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
6293     1            JMIN,JMAX,
6294     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
6295     1            IVARN1,IVARN2,IVARTY,PVAR,
6296     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
6297     1            MINNVA,MAXNVA,
6298     1            IFLAGM,IFLAGP,
6299     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
6300      IF(IERROR.EQ.'YES')GOTO9000
6301C
6302      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCNP')THEN
6303        WRITE(ICOUT,999)
6304        CALL DPWRST('XXX','BUG ')
6305        WRITE(ICOUT,281)
6306  281   FORMAT('***** AFTER CALL DPPARS--')
6307        CALL DPWRST('XXX','BUG ')
6308        WRITE(ICOUT,282)NQ,NUMVAR
6309  282   FORMAT('NQ,NUMVAR = ',2I8)
6310        CALL DPWRST('XXX','BUG ')
6311        IF(NUMVAR.GT.0)THEN
6312          DO285I=1,NUMVAR
6313            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
6314     1                      ICOLR(I),IVARTY(I)
6315  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
6316     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
6317            CALL DPWRST('XXX','BUG ')
6318  285     CONTINUE
6319        ENDIF
6320      ENDIF
6321C
6322      NRESP=1
6323      IDATSW='RAW'
6324      IF(ICASPL.EQ.'BCCP' .OR. ICASPL.EQ.'BCHP')THEN
6325        NRESP=2
6326      ELSEIF(ICASPL.EQ.'BCNP')THEN
6327        IF(IREPL.EQ.'OFF' .AND. IMULT.EQ.'OFF' .AND.
6328     1     NUMVAR.EQ.2)THEN
6329          NRESP=2
6330          IDATSW='FREQ'
6331        ENDIF
6332      ENDIF
6333C
6334      NREPL=0
6335      IF(IREPL.EQ.'OFF' .AND. ICASPL.EQ.'BCNP' .AND.
6336     1   NUMVAR.GT.NRESP)IMULT='ON'
6337      IF(IMULT.EQ.'ON')THEN
6338        NRESP=NUMVAR
6339      ELSEIF(IREPL.EQ.'ON')THEN
6340        NRESP=1
6341        IF(ICASPL.EQ.'BCCP' .OR. ICASPL.EQ.'BCHP')NRESP=2
6342        NREPL=NUMVAR-NRESP
6343        IF(NREPL.LT.1 .OR. NREPL.GT.2)THEN
6344          WRITE(ICOUT,999)
6345          CALL DPWRST('XXX','BUG ')
6346          IF(ICASPL.EQ.'BCNP')THEN
6347            WRITE(ICOUT,101)
6348          ELSEIF(ICASPL.EQ.'BCCP')THEN
6349            WRITE(ICOUT,102)
6350          ELSEIF(ICASPL.EQ.'BCHP')THEN
6351            WRITE(ICOUT,103)
6352          ENDIF
6353          WRITE(ICOUT,511)
6354  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
6355     1           'REPLICATION VARIABLES')
6356          CALL DPWRST('XXX','BUG ')
6357          WRITE(ICOUT,512)
6358  512     FORMAT('      MUST BE BETWEEN 1 AND 2;  SUCH WAS NOT THE ',
6359     1           'CASE HERE.')
6360          CALL DPWRST('XXX','BUG ')
6361          WRITE(ICOUT,513)NREPL
6362  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
6363          CALL DPWRST('XXX','BUG ')
6364          IERROR='YES'
6365          GOTO9000
6366        ENDIF
6367      ELSE
6368        NRESP=1
6369        IF(ICASPL.EQ.'BCCP' .OR. ICASPL.EQ.'BCHP')NRESP=2
6370      ENDIF
6371C
6372      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCNP')THEN
6373        ISTEPN='6'
6374        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6375        WRITE(ICOUT,601)NRESP,NREPL
6376  601   FORMAT('NRESP,NREPL = ',2I5)
6377        CALL DPWRST('XXX','BUG ')
6378      ENDIF
6379C
6380C               ***********************************************
6381C               **  STEP 8--                                 **
6382C               **  DETERMINE IF THE ANALYST                 **
6383C               **  HAS SPECIFIED LIMITS                     **
6384C               **  FOR THE LAMBDA PARAMETER VALUES          **
6385C               **  (THIS WILL DICTATE WHAT WILL APPEAR      **
6386C               **  ON THE HORIZONTAL AXIS OF THE BOX-COX    **
6387C               **  NORMALITY PLOT)                          **
6388C               ***********************************************
6389C
6390      ISTEPN='8'
6391      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCN2')
6392     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6393C
6394      IHP='LAMB'
6395      IHP2='DA1 '
6396      IHWUSE='P'
6397      MESSAG='NO'
6398      CALL CHECKN(IHP,IHP2,IHWUSE,
6399     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6400     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
6401      ALAMB1=-2.0
6402      IF(IERRO2.EQ.'NO')ALAMB1=VALUE(ILOCP)
6403C
6404      IHP='LAMB'
6405      IHP2='DA2 '
6406      IHWUSE='P'
6407      MESSAG='NO'
6408      CALL CHECKN(IHP,IHP2,IHWUSE,
6409     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
6410     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERRO2)
6411      ALAMB2=2.0
6412      IF(IERRO2.EQ.'NO')ALAMB2=VALUE(ILOCP)
6413C
6414C               **************************************************
6415C               **  STEP 7A--                                   **
6416C               **  CASE 1: NO REPLICATION, NO "MULTIPLE" CASE  **
6417C               **          (RESPONSE VARIABLE CAN BE A         **
6418C               **          MATRIX FOR BOX-COX NORMALITY CASE). **
6419C               **************************************************
6420C
6421      IF(IMULT.EQ.'OFF' .AND. NREPL.EQ.0)THEN
6422        ISTEPN='7A'
6423        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCNP')
6424     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6425C
6426        ICOL=1
6427        IF(ICASPL.EQ.'BCNP' .AND. IDATSW.EQ.'RAW')THEN
6428          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
6429     1                INAME,IVARN1,IVARN2,IVARTY,
6430     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
6431     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
6432     1                MAXCP4,MAXCP5,MAXCP6,
6433     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
6434     1                X1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
6435     1                IBUGG3,ISUBRO,IFOUND,IERROR)
6436        ELSE
6437          IFLAGM=0
6438          IFLAGE=1
6439          CALL DPPAR4(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
6440     1                INAME,IVARN1,IVARN2,IVARTY,
6441     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
6442     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
6443     1                MAXCP4,MAXCP5,MAXCP6,
6444     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
6445     1                Y1,X1,NLOCAL,NLOCA2,IFLAGM,IFLAGE,
6446     1                IBUGG3,ISUBRO,IFOUND,IERROR)
6447        ENDIF
6448        IF(IERROR.EQ.'YES')GOTO9000
6449C
6450C               *****************************************************
6451C               **  STEP 7B--                                      **
6452C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
6453C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
6454C               **  RESET THE VECTOR D(.) TO ALL ONES.             **
6455C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).  **
6456C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).  **
6457C               *****************************************************
6458C
6459        NCURVE=1
6460        NPLOTP=0
6461        IF(ICASPL.EQ.'BCNP')THEN
6462          CALL DPBCN2(Y1,X1,NLOCAL,ICASPL,IDATSW,NCURVE,
6463     1                ALAMB1,ALAMB2,
6464     1                Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6465     1                Y,X,D,NPLOTP,NPLOTV,
6466     1                IBUGG3,ISUBRO,IERROR)
6467        ELSEIF(ICASPL.EQ.'BCCP')THEN
6468          CALL DPBCC2(Y1,X1,NLOCAL,ICASPL,MAXN,NCURVE,
6469     1                ALAMB1,ALAMB2,
6470     1                Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6471     1                Y,X,D,NPLOTP,NPLOTV,
6472     1                IBUGG3,ISUBRO,IERROR)
6473        ELSEIF(ICASPL.EQ.'BCHP')THEN
6474          CALL DPBCH2(Y1,X1,NLOCAL,ICASPL,MAXN,NCURVE,
6475     1                ALAMB1,ALAMB2,
6476     1                Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6477     1                Y3,DISTX,DISTX3,SDY3,
6478     1                Y,X,D,NPLOTP,NPLOTV,
6479     1                IBUGG3,ISUBRO,IERROR)
6480        ENDIF
6481C
6482C               ***********************************************
6483C               **  STEP 8A--                                **
6484C               **  CASE 2: MULTIPLE RESPONSE VARIABLES.     **
6485C               **          ONLY SUPPORTED FOR ONE-VARIABLE  **
6486C               **          BOX-COX NORMALITY CASE.          **
6487C               ***********************************************
6488C
6489      ELSEIF(NRESP.GT.1 .AND. ICASPL.EQ.'BCNP')THEN
6490        ISTEPN='8A'
6491        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCNP')
6492     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6493C
6494C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
6495C
6496        NPLOTP=0
6497        DO810IRESP=1,NRESP
6498          NCURVE=IRESP
6499C
6500          IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCNP')THEN
6501            WRITE(ICOUT,999)
6502            CALL DPWRST('XXX','BUG ')
6503            WRITE(ICOUT,811)IRESP,NCURVE
6504  811       FORMAT('IRESP,NCURVE = ',2I5)
6505            CALL DPWRST('XXX','BUG ')
6506          ENDIF
6507C
6508          ICOL=IRESP
6509          NUMVA2=1
6510          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
6511     1                INAME,IVARN1,IVARN2,IVARTY,
6512     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
6513     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
6514     1                MAXCP4,MAXCP5,MAXCP6,
6515     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
6516     1                X1,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
6517     1                IBUGG3,ISUBRO,IFOUND,IERROR)
6518          IF(IERROR.EQ.'YES')GOTO9000
6519C
6520C               *****************************************************
6521C               **  STEP 8B--                                      **
6522C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
6523C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
6524C               *****************************************************
6525C
6526          CALL DPBCN2(Y1,X1,NLOCAL,ICASPL,IDATSW,NCURVE,
6527     1                ALAMB1,ALAMB2,
6528     1                Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6529     1                Y,X,D,NPLOTP,NPLOTV,
6530     1                IBUGG3,ISUBRO,IERROR)
6531C
6532  810   CONTINUE
6533C
6534C               *****************************************************
6535C               **  STEP 9A--                                      **
6536C               **  CASE 3: ONE OR TWO  REPLICATION VARIABLES.     **
6537C               **          CURRENTLY, GROUPED DATA NOT SUPPORTED  **
6538C               **          WITH REPLICATION.                      **
6539C               *****************************************************
6540C
6541      ELSEIF(NREPL.GE.1)THEN
6542        ISTEPN='9A'
6543        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCNP')
6544     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6545C
6546        J=0
6547        IMAX=NRIGHT(1)
6548        IF(NQ.LT.NRIGHT(1))IMAX=NQ
6549        DO910I=1,IMAX
6550          IF(ISUB(I).EQ.0)GOTO910
6551          J=J+1
6552C
6553C         RESPONSE VARIABLE IN Y1
6554C
6555          IJ=MAXN*(ICOLR(1)-1)+I
6556          IF(ICOLR(1).LE.MAXCOL)Y1(J)=V(IJ)
6557          IF(ICOLR(1).EQ.MAXCP1)Y1(J)=PRED(I)
6558          IF(ICOLR(1).EQ.MAXCP2)Y1(J)=RES(I)
6559          IF(ICOLR(1).EQ.MAXCP3)Y1(J)=YPLOT(I)
6560          IF(ICOLR(1).EQ.MAXCP4)Y1(J)=XPLOT(I)
6561          IF(ICOLR(1).EQ.MAXCP5)Y1(J)=X2PLOT(I)
6562          IF(ICOLR(1).EQ.MAXCP6)Y1(J)=TAGPLO(I)
6563C
6564          IF(NRESP.EQ.2)THEN
6565            IJ=MAXN*(ICOLR(2)-1)+I
6566            IF(ICOLR(2).LE.MAXCOL)X1(J)=V(IJ)
6567            IF(ICOLR(2).EQ.MAXCP1)X1(J)=PRED(I)
6568            IF(ICOLR(2).EQ.MAXCP2)X1(J)=RES(I)
6569            IF(ICOLR(2).EQ.MAXCP3)X1(J)=YPLOT(I)
6570            IF(ICOLR(2).EQ.MAXCP4)X1(J)=XPLOT(I)
6571            IF(ICOLR(2).EQ.MAXCP5)X1(J)=X2PLOT(I)
6572            IF(ICOLR(2).EQ.MAXCP6)X1(J)=TAGPLO(I)
6573          ENDIF
6574C
6575          ICOLC=NRESP
6576          DO920IR=1,MIN(NREPL,2)
6577            ICOLC=ICOLC+1
6578            ICOLT=ICOLR(ICOLC)
6579            IJ=MAXN*(ICOLT-1)+I
6580            IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
6581            IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
6582            IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
6583            IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
6584            IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
6585            IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
6586            IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
6587  920     CONTINUE
6588C
6589  910   CONTINUE
6590        NLOCAL=J
6591C
6592C       *****************************************************
6593C       **  STEP 9B--                                      **
6594C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
6595C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
6596C       **                                                 **
6597C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
6598C       **  VARIOUS REPLICATIONS.                          **
6599C       *****************************************************
6600C
6601        ISTEPN='9B'
6602        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BCNP')THEN
6603          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6604          WRITE(ICOUT,999)
6605          CALL DPWRST('XXX','BUG ')
6606          WRITE(ICOUT,931)
6607  931     FORMAT('***** FROM THE MIDDLE  OF FREQ--')
6608          CALL DPWRST('XXX','BUG ')
6609          WRITE(ICOUT,932)ICASPL,NUMVAR,NLOCAL
6610  932     FORMAT('ICASPL,NUMVAR,NQ = ',A4,2I8)
6611          CALL DPWRST('XXX','BUG ')
6612          IF(NLOCAL.GE.1)THEN
6613            DO935I=1,NLOCAL
6614              WRITE(ICOUT,936)I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2)
6615  936         FORMAT('I,Y1(I),X1(I),XDESGN(I,1),XDESGN(I,2) = ',
6616     1               I8,4F12.5)
6617              CALL DPWRST('XXX','BUG ')
6618  935       CONTINUE
6619          ENDIF
6620        ENDIF
6621C
6622C       *****************************************************
6623C       **  STEP 9C--                                      **
6624C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
6625C       **  REPLICATION VARIABLES.                         **
6626C       *****************************************************
6627C
6628        CALL DPFRE5(XDESGN(1,1),XDESGN(1,2),
6629     1             NREPL,NLOCAL,MAXOBV,
6630     1             XIDTEM,XIDTE2,
6631     1             XTEMP1,XTEMP2,
6632     1             NUMSE1,NUMSE2,
6633     1             IBUGG3,ISUBRO,IERROR)
6634C
6635C       *****************************************************
6636C       **  STEP 9D--                                      **
6637C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
6638C       *****************************************************
6639C
6640        NPLOTP=0
6641        NCURVE=0
6642        IF(NREPL.EQ.1)THEN
6643          J=0
6644          DO1110ISET1=1,NUMSE1
6645            K=0
6646            DO1130I=1,NLOCAL
6647              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
6648                K=K+1
6649                ZY(K)=Y1(I)
6650                ZX(K)=X1(I)
6651              ENDIF
6652 1130       CONTINUE
6653            NTEMP=K
6654            NCURVE=NCURVE+1
6655            IF(NTEMP.GT.0)THEN
6656              IF(ICASPL.EQ.'BCNP')THEN
6657                CALL DPBCN2(ZX,ZY,NTEMP,ICASPL,IDATSW,NCURVE,
6658     1                      ALAMB1,ALAMB2,
6659     1                      Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6660     1                      Y,X,D,NPLOTP,NPLOTV,
6661     1                      IBUGG3,ISUBRO,IERROR)
6662              ELSEIF(ICASPL.EQ.'BCCP')THEN
6663                CALL DPBCC2(ZY,ZX,NTEMP,ICASPL,MAXN,NCURVE,
6664     1                      ALAMB1,ALAMB2,
6665     1                      Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6666     1                      Y,X,D,NPLOTP,NPLOTV,
6667     1                      IBUGG3,ISUBRO,IERROR)
6668              ELSEIF(ICASPL.EQ.'BCHP')THEN
6669                CALL DPBCH2(ZY,ZX,NTEMP,ICASPL,MAXN,NCURVE,
6670     1                      ALAMB1,ALAMB2,
6671     1                      Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6672     1                      Y3,DISTX,DISTX3,SDY3,
6673     1                      Y,X,D,NPLOTP,NPLOTV,
6674     1                      IBUGG3,ISUBRO,IERROR)
6675              ENDIF
6676            ENDIF
6677 1110     CONTINUE
6678        ELSEIF(NREPL.EQ.2)THEN
6679          J=0
6680          NTOT=NUMSE1*NUMSE2
6681          DO1210ISET1=1,NUMSE1
6682          DO1220ISET2=1,NUMSE2
6683            K=0
6684            DO1290I=1,NLOCAL
6685              IF(
6686     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
6687     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
6688     1          )THEN
6689                K=K+1
6690                ZY(K)=Y1(I)
6691                ZX(K)=X1(I)
6692              ENDIF
6693 1290       CONTINUE
6694            NTEMP=K
6695            NCURVE=NCURVE+1
6696            IF(NTEMP.GT.0)THEN
6697              IF(ICASPL.EQ.'BCNP')THEN
6698                CALL DPBCN2(ZX,ZY,NTEMP,ICASPL,IDATSW,NCURVE,
6699     1                      ALAMB1,ALAMB2,
6700     1                      Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6701     1                      Y,X,D,NPLOTP,NPLOTV,
6702     1                      IBUGG3,ISUBRO,IERROR)
6703              ELSEIF(ICASPL.EQ.'BCCP')THEN
6704                CALL DPBCC2(ZY,ZX,NTEMP,ICASPL,MAXN,NCURVE,
6705     1                      ALAMB1,ALAMB2,
6706     1                      Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6707     1                      Y,X,D,NPLOTP,NPLOTV,
6708     1                      IBUGG3,ISUBRO,IERROR)
6709              ELSEIF(ICASPL.EQ.'BCHP')THEN
6710                CALL DPBCH2(ZY,ZX,NTEMP,ICASPL,MAXN,NCURVE,
6711     1                      ALAMB1,ALAMB2,
6712     1                      Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6713     1                      Y3,DISTX,DISTX3,SDY3,
6714     1                      Y,X,D,NPLOTP,NPLOTV,
6715     1                      IBUGG3,ISUBRO,IERROR)
6716              ENDIF
6717            ENDIF
6718 1220     CONTINUE
6719 1210     CONTINUE
6720        ENDIF
6721      ENDIF
6722C
6723C               *****************
6724C               **  STEP 90--  **
6725C               **  EXIT       **
6726C               *****************
6727C
6728 9000 CONTINUE
6729      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BCNP')THEN
6730        WRITE(ICOUT,999)
6731        CALL DPWRST('XXX','BUG ')
6732        WRITE(ICOUT,9011)
6733 9011   FORMAT('***** AT THE END       OF DPBCNP--')
6734        CALL DPWRST('XXX','BUG ')
6735        WRITE(ICOUT,9012)IFOUND,IERROR
6736 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
6737        CALL DPWRST('XXX','BUG ')
6738        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
6739 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
6740     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
6741        CALL DPWRST('XXX','BUG ')
6742        WRITE(ICOUT,9014)ALAMB1,ALAMB2,NLOCAL,NPLOTP
6743 9014   FORMAT('ALAMB1,ALAMB2,NLOCAL,NPLOTP = ',2G15.7,2X,2I8)
6744        CALL DPWRST('XXX','BUG ')
6745        IF(NLOCAL.GE.1)THEN
6746          DO9022I=1,MIN(100,NLOCAL)
6747            WRITE(ICOUT,9023)I,Y1(I),X1(I)
6748 9023       FORMAT('I,Y1(I),X1(I) = ',I8,2F12.5)
6749            CALL DPWRST('XXX','BUG ')
6750 9022     CONTINUE
6751        ENDIF
6752        IF(NPLOTP.GE.1)THEN
6753          DO9032I=1,MIN(1000,NPLOTP)
6754            WRITE(ICOUT,9033)I,Y(I),X(I),D(I)
6755 9033       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
6756            CALL DPWRST('XXX','BUG ')
6757 9032     CONTINUE
6758        ENDIF
6759      ENDIF
6760
6761C
6762      RETURN
6763      END
6764      SUBROUTINE DPBCN2(Y1,X1,N1,ICASPL,IDATSW,NCURVE,
6765     1                  ALAMB1,ALAMB2,
6766     1                  Y2TEMP,X2TEMP,D2TEMP,DISPAR,CORR,
6767     1                  Y2,X2,D2,N2,NPLOTV,
6768     1                  IBUGG3,ISUBRO,IERROR)
6769C
6770C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS THAT WILL DEFINE
6771C              THE BOX-COX NORMALITY PLOT TRACE WHICH IS A PLOT OF THE
6772C              OF THE NORMAL PROBABILITY PLOT CORRELATION COEFFICIENT
6773C              VERSUS THE BOX-COX PARAMATER LAMBDA.
6774C     WRITTEN BY--JAMES J. FILLIBEN
6775C                 STATISTICAL ENGINEERING DIVISION
6776C                 INFORMATION TECHNOLOGY LABORATORY
6777C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
6778C                 GAITHERSBURG, MD 20899-8980
6779C                 PHONE--301-975-2855
6780C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
6781C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
6782C     LANGUAGE--ANSI FORTRAN (1977)
6783C     VERSION NUMBER--82/7
6784C     ORIGINAL VERSION--AUGUST    1981.
6785C     UPDATED         --DECEMBER  1981.
6786C     UPDATED         --MAY       1982.
6787C     UPDATED         --APRIL     1992. AN=N1  TO AN1=N1
6788C     UPDATED         --MAY       2010. SUPPORT FOR "REPLICATION" AND
6789C                                       "MULTIPLE" CASES
6790C
6791C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
6792C
6793      CHARACTER*4 ICASPL
6794      CHARACTER*4 IDATSW
6795      CHARACTER*4 IBUGG3
6796      CHARACTER*4 ISUBRO
6797      CHARACTER*4 IERROR
6798C
6799      CHARACTER*4 ISUBN1
6800      CHARACTER*4 ISUBN2
6801      CHARACTER*4 ISTEPN
6802C
6803C---------------------------------------------------------------------
6804C
6805      DIMENSION Y1(*)
6806      DIMENSION X1(*)
6807      DIMENSION Y2(*)
6808      DIMENSION X2(*)
6809      DIMENSION D2(*)
6810      DIMENSION Y2TEMP(*)
6811      DIMENSION X2TEMP(*)
6812      DIMENSION D2TEMP(*)
6813C
6814      DIMENSION DISPAR(*)
6815      DIMENSION CORR(*)
6816C
6817C---------------------------------------------------------------------
6818C
6819      INCLUDE 'DPCOP2.INC'
6820C
6821C-----START POINT-----------------------------------------------------
6822C
6823      ISUBN1='DPBC'
6824      ISUBN2='N2  '
6825      IERROR='NO'
6826      AN1=0.0
6827C
6828      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BCN2')THEN
6829        WRITE(ICOUT,999)
6830        CALL DPWRST('XXX','BUG ')
6831        WRITE(ICOUT,71)
6832   71   FORMAT('***** AT THE BEGINNING OF DPBCN2--')
6833        CALL DPWRST('XXX','BUG ')
6834        WRITE(ICOUT,72)ICASPL,IDATSW,N1,NPLOTV
6835   72   FORMAT('ICASPL,IDATSW,N1,NPLOTV = ',A4,2X,A4,2X,2I8)
6836        CALL DPWRST('XXX','BUG ')
6837        WRITE(ICOUT,73)ALAMB1,ALAMB2
6838   73   FORMAT('ALAMB1,ALAMB2 = ',2E15.7)
6839        CALL DPWRST('XXX','BUG ')
6840        IF(N1.GE.1)THEN
6841          DO85I=1,N1
6842            WRITE(ICOUT,86)I,Y1(I),X1(I)
6843   86       FORMAT('I,Y1(I),X1(I) = ',I8,2E12.5)
6844            CALL DPWRST('XXX','BUG ')
6845   85     CONTINUE
6846        ENDIF
6847      ENDIF
6848C
6849        ISTEPN='0'
6850        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BCN2')
6851     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6852C
6853C               ********************************************
6854C               **  STEP 1--                              **
6855C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
6856C               ********************************************
6857C
6858      IF(N1.LT.3)THEN
6859        WRITE(ICOUT,999)
6860  999   FORMAT(1X)
6861        CALL DPWRST('XXX','BUG ')
6862        WRITE(ICOUT,46)
6863   46   FORMAT('***** ERROR IN BOX-COX NORMALITY PLOT--')
6864        CALL DPWRST('XXX','BUG ')
6865        WRITE(ICOUT,47)
6866   47   FORMAT('      THE NUMBER OF OBSERVATIONS IS LESS THAN THREE.')
6867        CALL DPWRST('XXX','BUG ')
6868        WRITE(ICOUT,999)
6869        CALL DPWRST('XXX','BUG ')
6870        IERROR='YES'
6871        GOTO9000
6872      ENDIF
6873C
6874      HOLD=X1(1)
6875      DO60I=1,N1
6876        IF(X1(I).NE.HOLD)GOTO69
6877   60 CONTINUE
6878      WRITE(ICOUT,999)
6879      CALL DPWRST('XXX','BUG ')
6880      WRITE(ICOUT,46)
6881      CALL DPWRST('XXX','BUG ')
6882      WRITE(ICOUT,62)
6883   62 FORMAT('      ALL INPUT RESPONSE VARIABLE ELEMENTS')
6884      CALL DPWRST('XXX','BUG ')
6885      WRITE(ICOUT,63)HOLD
6886   63 FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
6887      CALL DPWRST('XXX','BUG ')
6888      WRITE(ICOUT,999)
6889      CALL DPWRST('XXX','BUG ')
6890      IERROR='YES'
6891      GOTO9000
6892   69 CONTINUE
6893C
6894        ISTEPN='1'
6895        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BCN2')
6896     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
6897C
6898C               *******************************************************
6899C               **  STEP 2--                                         **
6900C               **  DETERMINE THE SET OF PARAMETER VALUES            **
6901C               **  TO BE USED FOR THE TRANSFORMATIONS               **
6902C               *******************************************************
6903C
6904      NUMDIS=41
6905      ANUMDI=NUMDIS
6906      DO511IDIS=1,NUMDIS
6907        AIDIS=IDIS
6908        DISPAR(IDIS)=ALAMB1+((AIDIS-1.0)/(ANUMDI-1.0))*(ALAMB2-ALAMB1)
6909  511 CONTINUE
6910C
6911C               **************************************
6912C               **  STEP 4--                        **
6913C               **  BRANCH TO THE APPROPRIATE CASE  **
6914C               **  AND DETERMINE PLOT COORDINATES  **
6915C               **************************************
6916C
6917      IF(IDATSW.EQ.'FREQ')THEN
6918C
6919C               ********************************************
6920C               **  STEP 4.2--                            **
6921C               **  DETERMINE PLOT COORDINATES            **
6922C               **  FOR THE 2-VARIABLE CASE               **
6923C               **  (THAT IS, FOR THE GROUPED DATA CASE)  **
6924C               ********************************************
6925C
6926        CALL SORTC(X1,Y1,N1,D2TEMP,Y2TEMP)
6927        XMIN=D2TEMP(1)
6928        IF(XMIN.GT.0.0)GOTO2109
6929        DO2105I=1,N1
6930          D2TEMP(I)=D2TEMP(I)-XMIN+1.0
6931 2105   CONTINUE
6932 2109   CONTINUE
6933C
6934        I2=0
6935        DO2111I=1,N1
6936          NI=INT(Y2TEMP(I)+0.1)
6937          ANI=REAL(NI)
6938          I1=I2+1
6939          I2=I1+NI-1
6940          SUM=0.0
6941          DO2112K=I1,I2
6942            CALL UNIME2(NTOT,K,UNIOSM)
6943            CALL NORPPF(UNIOSM,DISOSM)
6944            SUM=SUM+DISOSM
6945 2112     CONTINUE
6946          X2TEMP(I)=SUM/ANI
6947 2111   CONTINUE
6948C
6949        SUM=0.0
6950        DO2115I=1,N1
6951          SUM=SUM+Y1(I)
6952 2115   CONTINUE
6953        NTOT=INT(SUM+0.5)
6954C
6955        DO2120IDIS=1,NUMDIS
6956          ALAMBA=DISPAR(IDIS)
6957          IF(-0.001.LE.ALAMBA.AND.ALAMBA.LE.0.001)THEN
6958            DO2135I=1,N1
6959              Y2TEMP(I)=LOG(D2TEMP(I))
6960 2135       CONTINUE
6961          ELSE
6962            DO2145I=1,N1
6963              Y2TEMP(I)=((D2TEMP(I)**ALAMBA)-1.0)/ALAMBA
6964 2145       CONTINUE
6965          ENDIF
6966C
6967CCCCC     THE FOLLOWING LINE WAS FIXED    APRIL 1992 (ALAN)
6968CCCCC     AN=N1
6969          AN1=N1
6970          SUMY=0.0
6971          DO2810I=1,N1
6972            SUMY=SUMY+Y2TEMP(I)
6973 2810     CONTINUE
6974          XBAR=0.0
6975          YBAR=SUMY/AN1
6976C
6977          SUMX=0.0
6978          SUMY=0.0
6979          SUMXY=0.0
6980          DO2820I=1,N1
6981            SUMX=SUMX+(X2TEMP(I)-XBAR)*(X2TEMP(I)-XBAR)
6982            SUMY=SUMY+(Y2TEMP(I)-YBAR)*(Y2TEMP(I)-YBAR)
6983            SUMXY=SUMXY+(X2TEMP(I)-XBAR)*(Y2TEMP(I)-YBAR)
6984 2820     CONTINUE
6985          ARG=SUMX*SUMY
6986          CC=0.0
6987          IF(ARG.GT.0.0)CC=SUMXY/SQRT(ARG)
6988          CORR(IDIS)=CC
6989C
6990 2120   CONTINUE
6991C
6992        DO2910IDIS=1,NUMDIS
6993          N2=N2+1
6994          Y2(N2)=CORR(IDIS)
6995          X2(N2)=DISPAR(IDIS)
6996          D2(N2)=REAL(NCURVE)
6997 2910   CONTINUE
6998        NPLOTV=2
6999C
7000      ELSE
7001C
7002C               ****************************************
7003C               **  STEP 4.1--                        **
7004C               **  DETERMINE PLOT COORDINATES        **
7005C               **  FOR THE 1-VARIABLE CASE           **
7006C               **  (THAT IS, FOR THE RAW DATA CASE)  **
7007C               ****************************************
7008C
7009        ISTEPN='41A'
7010        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BCN2')
7011     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7012C
7013        CALL UNIMED(N1,X2TEMP)
7014        DO1110I=1,N1
7015          CALL NORPPF(X2TEMP(I),X2OUT)
7016          X2TEMP(I)=X2OUT
7017 1110   CONTINUE
7018C
7019        ISTEPN='41B'
7020        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BCN2')
7021     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7022C
7023        CALL SORT(X1,N1,D2TEMP)
7024        XMIN=D2TEMP(1)
7025        IF(XMIN.GT.0.0)GOTO1119
7026        DO1115I=1,N1
7027          D2TEMP(I)=D2TEMP(I)-XMIN+1.0
7028 1115   CONTINUE
7029 1119   CONTINUE
7030C
7031        ISTEPN='41C'
7032        IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BCN2')
7033     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7034C
7035        DO1120IDIS=1,NUMDIS
7036C
7037          ISTEPN='41D'
7038          IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BCN2')THEN
7039            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7040            WRITE(ICOUT,1122)I,ALAMBA
7041 1122       FORMAT('I,ALAMBA=',I5,G15.7)
7042            CALL DPWRST('XXX','BUG ')
7043          ENDIF
7044C
7045          ALAMBA=DISPAR(IDIS)
7046          IF(-0.001.LE.ALAMBA.AND.ALAMBA.LE.0.001)THEN
7047            DO1135I=1,N1
7048              Y2TEMP(I)=LOG(D2TEMP(I))
7049 1135       CONTINUE
7050          ELSE
7051            DO1145I=1,N1
7052              Y2TEMP(I)=((D2TEMP(I)**ALAMBA)-1.0)/ALAMBA
7053 1145       CONTINUE
7054          ENDIF
7055C
7056          AN1=N1
7057          SUMY=0.0
7058          DO1810I=1,N1
7059            SUMY=SUMY+Y2TEMP(I)
7060 1810     CONTINUE
7061          XBAR=0.0
7062          YBAR=SUMY/AN1
7063C
7064          SUMX=0.0
7065          SUMY=0.0
7066          SUMXY=0.0
7067          DO1820I=1,N1
7068            SUMX=SUMX+(X2TEMP(I)-XBAR)*(X2TEMP(I)-XBAR)
7069            SUMY=SUMY+(Y2TEMP(I)-YBAR)*(Y2TEMP(I)-YBAR)
7070            SUMXY=SUMXY+(X2TEMP(I)-XBAR)*(Y2TEMP(I)-YBAR)
7071 1820     CONTINUE
7072          ARG=SUMX*SUMY
7073          CC=0.0
7074          IF(ARG.GT.0.0)CC=SUMXY/SQRT(ARG)
7075          CORR(IDIS)=CC
7076C
7077          IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BCN2')THEN
7078            WRITE(ICOUT,999)
7079            CALL DPWRST('XXX','BUG ')
7080            DO1831I=1,N1
7081              WRITE(ICOUT,1833)I,Y1(I),X1(I),Y2TEMP(I),X2TEMP(I),
7082     1                         D2TEMP(I),CORR(I)
7083 1833         FORMAT('I,Y1(I),X1(I),Y2TEMP(I),X2TEMP(I),D2TEMP(I),',
7084     1               'CORR(I) = ',I8,6E12.5)
7085              CALL DPWRST('XXX','BUG ')
7086 1831       CONTINUE
7087            WRITE(ICOUT,1834)ICASPL,IDATSW,XBAR,YBAR,SUMX,SUMY,SUMXY
7088 1834       FORMAT('ICASPL,IDATSW,XBAR,YBAR,SUMX,SUMY,SUMXY = ',
7089     1             A4,2X,A4,2X,5E15.7)
7090            CALL DPWRST('XXX','BUG ')
7091          ENDIF
7092C
7093 1120   CONTINUE
7094C
7095        DO1910IDIS=1,NUMDIS
7096          N2=N2+1
7097          Y2(N2)=CORR(IDIS)
7098          X2(N2)=DISPAR(IDIS)
7099          D2(N2)=REAL(NCURVE)
7100 1910   CONTINUE
7101        NPLOTV=2
7102      ENDIF
7103C
7104C               *****************
7105C               **  STEP 90--  **
7106C               **  EXIT       **
7107C               *****************
7108C
7109 9000 CONTINUE
7110      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BCN2')THEN
7111        WRITE(ICOUT,999)
7112        CALL DPWRST('XXX','BUG ')
7113        WRITE(ICOUT,9011)
7114 9011   FORMAT('***** AT THE END       OF DPBCN2--')
7115        CALL DPWRST('XXX','BUG ')
7116        WRITE(ICOUT,9012)ICASPL,IDATSW,N2,NTOT,IERROR
7117 9012   FORMAT('ICASPL,IDATSW,N2,IERROR = ',A4,2X,A4,2I8,2X,A4)
7118        CALL DPWRST('XXX','BUG ')
7119        DO9015I=1,N2
7120          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
7121 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
7122          CALL DPWRST('XXX','BUG ')
7123 9015   CONTINUE
7124      ENDIF
7125C
7126      RETURN
7127      END
7128      SUBROUTINE DPBCP(NPTS,NLAB,
7129     1AMEAN,ASD,N,AMNX,AMXX,
7130     1XBCP,XBCPSE,XBCPK1,XBCPK2,
7131     1DLOWBC,DHIGBC,
7132     1IWRITE,
7133     1ICAPSW,ICAPTY,NUMDIG,
7134     1ISUBRO,IBUGA3,IERROR)
7135C
7136C     PURPOSE--IMPLEMENT BAYESIAN CONSENSUS PROCEDURE (A
7137C              MODIFICATION OF THE BOUNDS ON BIAS (BOB) PROCEDURE).
7138C              PROCEDURE DESCRIBED IN THE GUTHRIE/HAGWOOD PAPER.
7139C     REFERENCE--CHARLES HAGWOOD AND WILLIAM GUTHRIE (2006),
7140C                "COMBINING DATA IN SMALL MULTIPLE-METHODS
7141C                STUDIES", TECHNOMETRICS, VOL. 48, NO. 2.
7142C     PRINTING--YES
7143C     SUBROUTINES NEEDED--NONE
7144C     WRITTEN BY--ALAN HECKERT
7145C                 STATISTICAL ENGINEERING DIVISION
7146C                 INFORMATION TECHNOLOGY LABORATORY
7147C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7148C                 GAITHERSBURG, MD 20899-8980
7149C                 PHONE--301-975-2855
7150C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7151C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7152C     LANGUAGE--ANSI FORTRAN (1977)
7153C     VERSION NUMBER--2006/6
7154C     ORIGINAL VERSION--JUNE      2006.
7155C     UPDATED         --FEBRUARY  2010.
7156C
7157C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------
7158C
7159      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
7160C
7161      CHARACTER*4 ICAPSW
7162      CHARACTER*4 ICAPTY
7163      CHARACTER*4 ISUBRO
7164      CHARACTER*4 IBUGA3
7165      CHARACTER*4 IERROR
7166C
7167      CHARACTER*4 IWRITE
7168      CHARACTER*4 ISUBN1
7169      CHARACTER*4 ISUBN2
7170C
7171      REAL APPF
7172      REAL XBCP
7173      REAL XBCPSE
7174      REAL XBCPK1
7175      REAL XBCPK2
7176      REAL AMNX
7177      REAL AMXX
7178      REAL AMEAN(*)
7179      REAL ASD(*)
7180      REAL CV
7181      REAL DELTA
7182C
7183      INTEGER N(*)
7184C
7185C----------------------------------------------------------------
7186C
7187      INCLUDE 'DPCOST.INC'
7188C
7189      PARAMETER (MAXROW=20)
7190      CHARACTER*60 ITITLE
7191      CHARACTER*60 ITITLZ
7192      CHARACTER*60 ITITL9
7193      CHARACTER*60 ITEXT(MAXROW)
7194      REAL         AVALUE(MAXROW)
7195      INTEGER      NCTEXT(MAXROW)
7196      INTEGER      IDIGIT(MAXROW)
7197      INTEGER      NTOT(MAXROW)
7198      LOGICAL IFRST
7199      LOGICAL ILAST
7200C
7201      INCLUDE 'DPCOP2.INC'
7202C
7203C-----START POINT------------------------------------------------
7204C
7205      IERROR='NO'
7206      ISUBN1='DPBC'
7207      ISUBN2='P   '
7208C
7209      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PBCP')THEN
7210        WRITE(ICOUT,999)
7211  999   FORMAT(1X)
7212        CALL DPWRST('XXX','BUG ')
7213        WRITE(ICOUT,51)
7214   51   FORMAT('***** AT THE BEGINNING OF DPBCP--')
7215        CALL DPWRST('XXX','BUG ')
7216        WRITE(ICOUT,52)NPTS,NLAB,SW,STXMU,ST2SB
7217   52   FORMAT('NPTS,NLAB,SW,STXMU,ST2SB = ',2I8,3G15.7)
7218        CALL DPWRST('XXX','BUG ')
7219        DO55I=1,NLAB
7220          WRITE(ICOUT,56)I,AMEAN(I)
7221   56     FORMAT('I,AMEAN(I) = ',2I8,G15.7)
7222          CALL DPWRST('XXX','BUG ')
7223   55   CONTINUE
7224      ENDIF
7225C
7226      CALL MEAN(AMEAN,NLAB,IWRITE,XBCP,IBUGA3,IERROR)
7227      DSB=DBLE(AMXX - AMNX)**2/12.0D0
7228C
7229      DSUM=0.0D0
7230      DO100I=1,NLAB
7231        NITEMP=ABS(N(I))
7232        DSUM=DSUM + DBLE(ASD(I)/REAL(NITEMP))**2
7233  100 CONTINUE
7234C
7235      DKU=DSUM/(DBLE(NLAB)**2) + DSB
7236      XBCPSE=REAL(DSQRT(DKU))
7237      XBCPK1=XBCPSE
7238      XBCPK2=2.0*XBCPSE
7239      DFNUM=DKU**2
7240      DSUM=0.0D0
7241      DO200I=1,NLAB
7242        NITEMP=ABS(N(I))
7243        DSUM=DSUM + DBLE(ASD(I)/REAL(NITEMP))**4/DBLE(NITEMP-1)
7244  200 CONTINUE
7245      W=DBLE(AMXX - AMNX)
7246      IF(NLAB.EQ.2)THEN
7247        DNU=1.0D0
7248      ELSEIF(NLAB.EQ.3)THEN
7249        DNU=1.9846D0
7250      ELSEIF(NLAB.EQ.4)THEN
7251        DNU=2.9291D0
7252      ELSEIF(NLAB.EQ.5)THEN
7253        DNU=3.8267D0
7254      ELSEIF(NLAB.EQ.6)THEN
7255        DNU=4.6772D0
7256      ELSE
7257        DNU=4.6772D0
7258      ENDIF
7259      DFDEN=(DSUM/DBLE(NLAB)**4) + W**4/(144.0D0*DNU)
7260      DF=DFNUM/DFDEN
7261      IDF=INT(DF+0.5D0)
7262      IF(IDF.LT.1)IDF=1
7263      DELTA=0.0
7264      CV=0.975
7265      CALL NCTPPF(CV,REAL(DF),DELTA,APPF)
7266      DLOWBC=DBLE(XBCP - APPF*XBCPSE)
7267      DHIGBC=DBLE(XBCP + APPF*XBCPSE)
7268C
7269      ITITLE=' '
7270      NCTITL=0
7271      ITITLZ=' '
7272      NCTITZ=0
7273C
7274      ICNT=1
7275      ITEXT(ICNT)='13. Method: BCP (Bayesian Consensus Procedure)'
7276      NCTEXT(ICNT)=46
7277      AVALUE(ICNT)=0.0
7278      IDIGIT(ICNT)=-1
7279C
7280      ICNT=ICNT+1
7281      ITEXT(ICNT)='    Estimate of Consensus Mean:'
7282      NCTEXT(ICNT)=31
7283      AVALUE(ICNT)=XBCP
7284      IDIGIT(ICNT)=NUMDIG
7285      ICNT=ICNT+1
7286      ITEXT(ICNT)='    Standard Deviation of Consensus Mean:'
7287      NCTEXT(ICNT)=41
7288      AVALUE(ICNT)=XBCPSE
7289      IDIGIT(ICNT)=NUMDIG
7290      ICNT=ICNT+1
7291      ITEXT(ICNT)='    Standard Uncertainty (k = 1):'
7292      NCTEXT(ICNT)=33
7293      AVALUE(ICNT)=XBCPK1
7294      IDIGIT(ICNT)=NUMDIG
7295      ICNT=ICNT+1
7296      ITEXT(ICNT)='    Expanded Uncertainty (k = 2):'
7297      NCTEXT(ICNT)=33
7298      AVALUE(ICNT)=XBCPK2
7299      IDIGIT(ICNT)=NUMDIG
7300      ICNT=ICNT+1
7301      ITEXT(ICNT)='    Degrees of Freedom:'
7302      NCTEXT(ICNT)=23
7303      AVALUE(ICNT)=DF
7304      IDIGIT(ICNT)=NUMDIG
7305      ICNT=ICNT+1
7306      ITEXT(ICNT)='    t Percent Point Value:'
7307      NCTEXT(ICNT)=26
7308      AVALUE(ICNT)=APPF
7309      IDIGIT(ICNT)=NUMDIG
7310      ICNT=ICNT+1
7311      ITEXT(ICNT)='    Lower 95% (t) Confidence Limit:'
7312      NCTEXT(ICNT)=35
7313      AVALUE(ICNT)=DLOWBC
7314      IDIGIT(ICNT)=NUMDIG
7315      ICNT=ICNT+1
7316      ITEXT(ICNT)='    Upper 95% (t) Confidence Limit:'
7317      NCTEXT(ICNT)=35
7318      AVALUE(ICNT)=DHIGBC
7319      IDIGIT(ICNT)=NUMDIG
7320      ICNT=ICNT+1
7321      ITEXT(ICNT)='    Note: BCP Best Usage:'
7322      NCTEXT(ICNT)=25
7323      AVALUE(ICNT)=0.0
7324      IDIGIT(ICNT)=-1
7325      ICNT=ICNT+1
7326      ITEXT(ICNT)='          6 or Fewer Labs:'
7327      NCTEXT(ICNT)=26
7328      AVALUE(ICNT)=0.0
7329      IDIGIT(ICNT)=-1
7330C
7331      NUMROW=ICNT
7332      DO310I=1,NUMROW
7333        NTOT(I)=15
7334  310 CONTINUE
7335C
7336      IFRST=.TRUE.
7337      ILAST=.TRUE.
7338      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
7339     1            AVALUE,IDIGIT,
7340     1            NTOT,NUMROW,
7341     1            ICAPSW,ICAPTY,ILAST,IFRST,
7342     1            ISUBRO,IBUGA3,IERROR)
7343      ITITLE=' '
7344      NCTITL=0
7345      ITITLZ=' '
7346      NCTITZ=0
7347      ITITL9=' '
7348      NCTIT9=0
7349C
7350C               *****************
7351C               **  STEP 90--  **
7352C               **  EXIT       **
7353C               *****************
7354C
7355      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PBCP')THEN
7356        WRITE(ICOUT,999)
7357        CALL DPWRST('XXX','BUG ')
7358        WRITE(ICOUT,9011)
7359 9011   FORMAT('***** AT THE END       OF DPBCP--')
7360        CALL DPWRST('XXX','BUG ')
7361        WRITE(ICOUT,9012)IERROR
7362 9012   FORMAT('IERROR = ',A4)
7363        CALL DPWRST('XXX','BUG ')
7364        WRITE(ICOUT,9013)NPTS,NLAB
7365 9013   FORMAT('NPTS,NLAB = ',2I8)
7366        CALL DPWRST('XXX','BUG ')
7367        WRITE(ICOUT,9015)DLOWBC,DHIGBC
7368 9015   FORMAT('DLOWBC,DHIGBC = ',2G15.7)
7369        CALL DPWRST('XXX','BUG ')
7370      ENDIF
7371C
7372      RETURN
7373      END
7374      SUBROUTINE DPBECP(ICAPSW,IFORSW,
7375     1                  IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
7376     1                  IFOUND,IERROR)
7377C
7378C     PURPOSE--FIND THE (10) BEST CANDIDATE MODELS FOR A LINEAR FIT
7379C              BASED ON MALLOW'S CP CRITERION.  CODE EXTRACTED
7380C              FROM OMNITAB, WHICH USES THE FURNIVAL AND WILSON
7381C              LEAP AND BOUND ALGORITHM.
7382C     WRITTEN BY--ALAN HECKERT
7383C                 STATISTICAL ENGINEERING DIVISION
7384C                 INFORMATION TECHNOLOGY LABORATORY
7385C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7386C                 GAITHERSBURG, MD 20899-8980
7387C                 PHONE--301-975-2855
7388C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7389C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7390C     LANGUAGE--ANSI FORTRAN (1977)
7391C     VERSION NUMBER--2002/6
7392C     ORIGINAL VERSION--JULY     2002.
7393C     UPDATED         --AUGUST   2011. USE DPPARS
7394C     UPDATED         --OCTOBER  2013. SUPPORT FOR HTML, LATEX,
7395C                                      RTF OUTPUT
7396C     UPDATED         --OCTOBER  2013. ADD "CONSTANT" MODEL
7397C     UPDATED         --OCTOBER  2013. ADD BIC/AIC TERMS
7398C     UPDATED         --JULY     2019. TWEAK SCRATCH SPACE
7399C
7400C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7401C
7402CCCCC SUPPORT MAXIMUM OF 38 INDPENDENT VARIABLES, CORRELATION
7403CCCCC MATRIX ALSO NEEDS TO INCLUDE CONSTANT TERM AND DEPENDENT
7404CCCCC VARIABLE.
7405C
7406C     2019/07: INCREASE MAXIMUM NUMBER OF COLUMNS, BUT BASE LIMITS
7407C              ON ROWS*COLUMNS RATHER THAN MAXROW*COLUMNS.  RESTRICT
7408C              TOTAL NUMBER OF POINTS TO 34*MAXROW.
7409C
7410      PARAMETER (MAXV=98)
7411      PARAMETER (MAXC=MAXV+2)
7412C
7413      CHARACTER*4 ICAPSW
7414      CHARACTER*4 IFORSW
7415      CHARACTER*4 IBUGA2
7416      CHARACTER*4 IBUGA3
7417      CHARACTER*4 IBUGCO
7418      CHARACTER*4 IBUGEV
7419      CHARACTER*4 IBUGQ
7420      CHARACTER*4 ISUBRO
7421      CHARACTER*4 IFOUND
7422      CHARACTER*4 IERROR
7423      CHARACTER*4 ICASFI
7424      CHARACTER*4 ISUBN1
7425      CHARACTER*4 ISUBN2
7426      CHARACTER*4 ISTEPN
7427C
7428      CHARACTER*40 INAME
7429      PARAMETER (MAXSPN=MAXV)
7430      CHARACTER*4 IVARN1(MAXSPN)
7431      CHARACTER*4 IVARN2(MAXSPN)
7432      CHARACTER*4 IVARTY(MAXSPN)
7433      REAL PVAR(MAXSPN)
7434      INTEGER ILIS(MAXSPN)
7435      INTEGER NRIGHT(MAXSPN)
7436      INTEGER ICOLR(MAXSPN)
7437C
7438C---------------------------------------------------------------------
7439C
7440      INCLUDE 'DPCOPA.INC'
7441      INCLUDE 'DPCOZZ.INC'
7442      INCLUDE 'DPCOZD.INC'
7443      INCLUDE 'DPCOHO.INC'
7444C
7445      DOUBLE PRECISION SQRTCT(MAXOBV)
7446      REAL RXY(MAXC,MAXC)
7447      REAL XYMAT(34*MAXOBV)
7448C
7449C-----COMMON----------------------------------------------------------
7450C
7451      INCLUDE 'DPCOST.INC'
7452      INCLUDE 'DPCOMC.INC'
7453      INCLUDE 'DPCOHK.INC'
7454      INCLUDE 'DPCOSU.INC'
7455      INCLUDE 'DPCODA.INC'
7456C
7457      CHARACTER*8 IVLIST
7458      COMMON/BESTC1/IOUNI1,IOUNI2
7459      COMMON/BESTC2/IVLIST(MAXV)
7460C
7461C-----COMMON VARIABLES (GENERAL)--------------------------------------
7462C
7463      EQUIVALENCE (GARBAG(IGARB1),RXY(1,1))
7464      EQUIVALENCE (GARBAG(IGARB2),XYMAT(1))
7465      EQUIVALENCE (DGARBG(IDGAR1),SQRTCT(1))
7466C
7467C---------------------------------------------------------------------
7468C
7469      INCLUDE 'DPCOP2.INC'
7470C
7471C-----START POINT-----------------------------------------------------
7472C
7473      ISUBN1='DPBE'
7474      ISUBN2='CP  '
7475      IERROR='NO'
7476C
7477      MAXCP1=MAXCOL+1
7478      MAXCP2=MAXCOL+2
7479      MAXCP3=MAXCOL+3
7480      MAXCP4=MAXCOL+4
7481      MAXCP5=MAXCOL+5
7482      MAXCP6=MAXCOL+6
7483C
7484C               ******************************
7485C               **  TREAT THE BEST CP CASE  **
7486C               ******************************
7487C
7488      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP')THEN
7489        WRITE(ICOUT,999)
7490  999   FORMAT(1X)
7491        CALL DPWRST('XXX','BUG ')
7492        WRITE(ICOUT,51)
7493   51   FORMAT('***** AT THE BEGINNING OF DPBECP--')
7494        CALL DPWRST('XXX','BUG ')
7495        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGCO,IBUGEV,ISUBRO,NUMNAM
7496   53   FORMAT('IBUGA2,IBUGA3,IBUGCO,IBUGEV,ISUBRO,NUMNAM = ',
7497     1         5(A4,2X),I8)
7498        CALL DPWRST('XXX','BUG ')
7499        DO57I=1,NUMNAM
7500          WRITE(ICOUT,58)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),
7501     1                   VALUE(I)
7502   58     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)',
7503     1           'VALUE(I) = ',I8,2X,2A4,2X,A4,2I8,G15.7)
7504          CALL DPWRST('XXX','BUG ')
7505   57   CONTINUE
7506      ENDIF
7507C
7508C     ***************************
7509C     **  STEP 1--             **
7510C     **  EXTRACT THE COMMAND  **
7511C     ***************************
7512C
7513      ISTEPN='1'
7514      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP')
7515     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7516C
7517      IF(ICOM.EQ.'BEST'.AND.IHARG(1).EQ.'CP  ')THEN
7518        ILASTC=1
7519        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
7520      ELSEIF(ICOM.EQ.'BEST'.AND.ICOM2.EQ.'CP  ')THEN
7521         CONTINUE
7522      ELSE
7523        IFOUND='NO'
7524        GOTO9000
7525      ENDIF
7526C
7527      IFOUND='YES'
7528      ICASFI='BECP'
7529C
7530C               *********************************
7531C               **  STEP 2--                   **
7532C               **  EXTRACT THE VARIABLE LIST  **
7533C               *********************************
7534C
7535      ISTEPN='2'
7536      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP')
7537     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7538C
7539      INAME='BEST CP'
7540      MINNA=1
7541      MAXNA=100
7542      MINN2=4
7543      IFLAGE=1
7544      IFLAGM=0
7545      IFLAGP=0
7546      JMIN=1
7547      JMAX=NUMARG
7548      MINNVA=4
7549      MAXNVA=MAXSPN
7550C
7551      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
7552     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
7553     1            JMIN,JMAX,
7554     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
7555     1            IVARN1,IVARN2,IVARTY,PVAR,
7556     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
7557     1            MINNVA,MAXNVA,
7558     1            IFLAGM,IFLAGP,
7559     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
7560      IF(IERROR.EQ.'YES')GOTO9000
7561C
7562      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')THEN
7563        WRITE(ICOUT,999)
7564        CALL DPWRST('XXX','BUG ')
7565        WRITE(ICOUT,281)
7566  281   FORMAT('***** AFTER CALL DPPARS--')
7567        CALL DPWRST('XXX','BUG ')
7568        WRITE(ICOUT,282)NQ,NUMVAR
7569  282   FORMAT('NQ,NUMVAR = ',2I8)
7570        CALL DPWRST('XXX','BUG ')
7571        IF(NUMVAR.GT.0)THEN
7572          DO285I=1,NUMVAR
7573            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
7574     1                      ICOLR(I)
7575  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
7576     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
7577            CALL DPWRST('XXX','BUG ')
7578  285     CONTINUE
7579        ENDIF
7580      ENDIF
7581C
7582      ICNT=0
7583      DO310I=2,NUMVAR
7584        ICNT=ICNT+1
7585        IVLIST(ICNT)(1:4)=IVARN1(I)(1:4)
7586        IVLIST(ICNT)(5:8)=IVARN2(I)(1:4)
7587  310 CONTINUE
7588      ICNT=ICNT+1
7589      IVLIST(ICNT)(1:4)=IVARN1(1)(1:4)
7590      IVLIST(ICNT)(5:8)=IVARN2(1)(1:4)
7591C
7592      IFACT=1
7593      IF(IFITAC.EQ.'OFF')IFACT=0
7594C
7595      NUMFAC=NUMVAR-1
7596      J=0
7597      IMAX=NRIGHT(1)
7598      IF(NQ.LT.NRIGHT(1))IMAX=NQ
7599      DO2560I=1,IMAX
7600        IF(ISUB(I).EQ.0)GOTO2560
7601        J=J+1
7602 2560 CONTINUE
7603      NS=J
7604      ISTRT=NS*NUMFAC
7605C
7606      DO2570I=1,IMAX
7607C
7608        IJ=MAXN*(ICOLR(1)-1)+I
7609        IF(ICOLR(1).LE.MAXCOL)XYMAT(ISTRT+I)=V(IJ)
7610        IF(ICOLR(1).EQ.MAXCP1)XYMAT(ISTRT+I)=PRED(I)
7611        IF(ICOLR(1).EQ.MAXCP2)XYMAT(ISTRT+I)=RES(I)
7612        IF(ICOLR(1).EQ.MAXCP3)XYMAT(ISTRT+I)=YPLOT(I)
7613        IF(ICOLR(1).EQ.MAXCP4)XYMAT(ISTRT+I)=XPLOT(I)
7614        IF(ICOLR(1).EQ.MAXCP5)XYMAT(ISTRT+I)=X2PLOT(I)
7615        IF(ICOLR(1).EQ.MAXCP6)XYMAT(ISTRT+I)=TAGPLO(I)
7616C
7617        DO2579LL=1,NUMFAC
7618          K=LL+1
7619          ICOLT=ICOLR(K)
7620          IJ=MAXN*(ICOLT-1)+I
7621          ISTRT2=NS*(LL-1)
7622          IF(ICOLT.LE.MAXCOL)XYMAT(ISTRT2+I)=V(IJ)
7623          IF(ICOLT.EQ.MAXCP1)XYMAT(ISTRT2+I)=PRED(I)
7624          IF(ICOLT.EQ.MAXCP2)XYMAT(ISTRT2+I)=RES(I)
7625          IF(ICOLT.EQ.MAXCP3)XYMAT(ISTRT2+I)=YPLOT(I)
7626          IF(ICOLT.EQ.MAXCP4)XYMAT(ISTRT2+I)=XPLOT(I)
7627          IF(ICOLT.EQ.MAXCP5)XYMAT(ISTRT2+I)=X2PLOT(I)
7628          IF(ICOLT.EQ.MAXCP6)XYMAT(ISTRT2+I)=TAGPLO(I)
7629 2579   CONTINUE
7630 2570 CONTINUE
7631C
7632C               ******************************************************
7633C               **  STEP 14--                                       **
7634C               **  CARRY OUT THE ACTUAL FIT                        **
7635C               **  VIA CALLING                                     **
7636C               **  DPBECP2 (FOR GENERAL MODELS), OR                **
7637C               ******************************************************
7638C
7639      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP')THEN
7640        ISTEPN='14'
7641        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7642        WRITE(ICOUT,999)
7643        CALL DPWRST('XXX','BUG ')
7644        WRITE(ICOUT,6081)
7645 6081   FORMAT('***** FROM DPBECP, AS ABOUT TO CALL DPBEC2--')
7646        CALL DPWRST('XXX','BUG ')
7647        DO6083I=1,NS*NUMVAR
7648          WRITE(ICOUT,6084)I,XYMAT(I)
7649 6084     FORMAT('I,(XYMAT(I) = ',I6,2X,G15.7)
7650          CALL DPWRST('XXX','BUG ')
7651 6083   CONTINUE
7652        WRITE(ICOUT,6082)MAXN,NS,NUMVAR
7653 6082   FORMAT('MAXN,NS,NUMVAR = ',3I8)
7654        CALL DPWRST('XXX','BUG ')
7655      ENDIF
7656C
7657      INTCPT=IFACT
7658      MBEST=INUMCP
7659      IF(NUMVAR-1.LE.3 .AND. MBEST.GT.7)MBEST=7
7660      CALL DPBEC2(XYMAT,NS,NUMVAR,SQRTCT,RXY,
7661     1            MAXC,MAXV,MAXOBV,
7662     1            MBEST,INTCPT,
7663     1            ICAPSW,ICAPTY,IFORSW,
7664     1            IBUGA3,ISUBRO,IERROR)
7665      IF(IERROR.EQ.'YES')GOTO9000
7666C
7667C               *****************
7668C               **  STEP 90--  **
7669C               **  EXIT       **
7670C               *****************
7671C
7672 9000 CONTINUE
7673      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BECP')THEN
7674        WRITE(ICOUT,999)
7675        CALL DPWRST('XXX','BUG ')
7676        WRITE(ICOUT,9011)
7677 9011   FORMAT('***** AT THE END       OF DPBECP--')
7678        CALL DPWRST('XXX','BUG ')
7679        WRITE(ICOUT,9016)IFOUND,IERROR,NS,NUMNAM
7680 9016   FORMAT('IFOUND,IERROR,NS,NUMNAM, = ',2(A4,2X),2I8)
7681        CALL DPWRST('XXX','BUG ')
7682        DO9017I=1,NUMNAM
7683          WRITE(ICOUT,9018)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),
7684     1                     IVALUE(I),VALUE(I)
7685 9018     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)',
7686     1           'VALUE(I) = ',I8,2X,2A4,2X,A4,2I8,G15.7)
7687          CALL DPWRST('XXX','BUG ')
7688 9017   CONTINUE
7689      ENDIF
7690C
7691      RETURN
7692      END
7693      SUBROUTINE DPBEC2(XYMAT,N,NVARS,SQRTCT,RXY,
7694     1                  MAXC,MAXV,MAXOBV,
7695     1                  MBEST,INTCPT,
7696     1                  ICAPSW,ICAPTY,IFORSW,
7697     1                  IBUGA3,ISUBRO,IERROR)
7698C
7699C     BEST CP: COMPUTE MBEST (DEFAULT=10) BEST CANDIDATE MODELS BASED
7700C     ON MALLOW'S CP CRITIERION.  CODE EXTRACTED FROM OMNITAB, WHICH
7701C     IMPLEMENTS THE FURNIVAL AND WILSON LEAP AND BOUND ALGORITHM.
7702C
7703C     WRITTEN BY--ALAN HECKERT
7704C                 STATISTICAL ENGINEERING DIVISION
7705C                 INFORMATION TECHNOLOGY LABORATORY
7706C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
7707C                 GAITHERSBURG, MD 20899-8980
7708C                 PHONE--301-975-2855
7709C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7710C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
7711C     LANGUAGE--ANSI FORTRAN (1977)
7712C     VERSION NUMBER--2002/6
7713C     ORIGINAL VERSION--JUNE      2002.
7714C     UPDATED         --AUGUST   2012. ADD "CONSTANT" MODEL
7715C     UPDATED         --DECEMBER 2013. ADD BIC TERMS
7716C
7717C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7718C
7719      CHARACTER*4 ICAPSW
7720      CHARACTER*4 ICAPTY
7721      CHARACTER*4 IFORSW
7722      CHARACTER*4 IBUGA3
7723      CHARACTER*4 ISUBRO
7724      CHARACTER*4 IERROR
7725C
7726      CHARACTER*4 ISUBN1
7727      CHARACTER*4 ISUBN2
7728      CHARACTER*4 ISTEPN
7729      CHARACTER*4 IOP
7730C
7731C---------------------------------------------------------------------
7732C
7733      INTEGER N, NVARS
7734C
7735      DOUBLE PRECISION SQRTCT(*)
7736      REAL RXY(MAXC,MAXC)
7737      REAL XYMAT(*)
7738C
7739      PARAMETER (MAXV2=98)
7740      CHARACTER*8 IVLIST
7741      COMMON/BESTC1/IOUNI1,IOUNI2
7742      COMMON/BESTC2/IVLIST(MAXV2)
7743C
7744C---------------------------------------------------------------------
7745C
7746      INCLUDE 'DPCOP2.INC'
7747C
7748C-----START POINT-----------------------------------------------------
7749C
7750      ISUBN1='DPBE'
7751      ISUBN2='C2  '
7752      IERROR='NO'
7753C
7754      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BEC2')THEN
7755        WRITE(ICOUT,999)
7756  999   FORMAT(1X)
7757        CALL DPWRST('XXX','BUG ')
7758        WRITE(ICOUT,51)
7759   51   FORMAT('***** AT THE BEGINNING OF DPBEC2--')
7760        CALL DPWRST('XXX','BUG ')
7761        WRITE(ICOUT,52)N,NVARS,MBEST,INTCPT,MAXV
7762   52   FORMAT('N,NVARS,MBEST,INTCPT,MAXV = ',5I8)
7763        CALL DPWRST('XXX','BUG ')
7764        WRITE(ICOUT,53)ICAPSW,ICAPTY,IFORSW
7765   53   FORMAT('ICAPSW,ICAPTY,IFORSW = ',2(A4,2X),A4)
7766        CALL DPWRST('XXX','BUG ')
7767        DO61I=1,N
7768          IINDX=(NVARS-1)*N + I
7769          WRITE(ICOUT,63)I,XYMAT(I),XYMAT(N+I),XYMAT(IINDX)
7770   63     FORMAT('I,X1(I),X2(I),Y(I) = ',I8,3G15.7)
7771          CALL DPWRST('XXX','BUG ')
7772   61   CONTINUE
7773      ENDIF
7774C
7775C               **************************************************
7776C               **  STEP 0.5--                                  **
7777C               **   OPEN THE STORAGE FILES                     **
7778C               **************************************************
7779C
7780      ISTEPN='0.5'
7781      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2')
7782     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7783C
7784      IOP='OPEN'
7785      IFLG1=1
7786      IFLG2=1
7787      IFLG3=0
7788      IFLG4=0
7789      IFLG5=0
7790      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
7791     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
7792     1            IBUGA3,ISUBRO,IERROR)
7793C
7794C               *****************************************************
7795C               **  STEP 2--                                       **
7796C               **  CALL OMNITAB ROUTINES CRSPRD AND SCREEN.       **
7797C               *****************************************************
7798C
7799      ISTEPN='2'
7800      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BEC2')
7801     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7802C
7803      CALL CRSPRD(XYMAT,N,NVARS,INTCPT,SQRTCT,RXY,MAXC)
7804C
7805      NDF=N-1
7806      NPARAM=NVARS-1
7807      ITYPE=3
7808CCCCC NSPAC=MAXC*20000
7809CCCCC NSPAC=MAXC*MAXOBV
7810      NSPAC=34*MAXOBV
7811C
7812      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BEC2')THEN
7813         WRITE(ICOUT,7112)N,NVARS
7814 7112    FORMAT(6X,'AFTER CALL TO CRSPRD, N, NVARS = ',2I8)
7815         CALL DPWRST('XXX','BUG ')
7816         WRITE(ICOUT,7113)NDF,NPARAM
7817 7113    FORMAT(6X,'NDF,NPARAM = ',2I8)
7818         CALL DPWRST('XXX','BUG ')
7819         DO7115I=1,NVARS
7820         WRITE(ICOUT,7117)I,(RXY(I,J),J=1,MIN(NVARS,7))
7821 7117    FORMAT('ROW ',I5,' = ',7(G15.7))
7822         CALL DPWRST('XXX','BUG ')
7823 7115    CONTINUE
7824      ENDIF
7825C
7826      CALL SCREEN(RXY,NPARAM,MAXC,NDF,ITYPE,MBEST,INTCPT,XYMAT,NSPAC,
7827     1            ICAPSW,ICAPTY,IFORSW,
7828     1            IBUGA3,ISUBRO,IERROR)
7829C
7830C               ****************************************************
7831C               **  STEP 3--                                      **
7832C               **  WRITE INFO OUT TO FILES--                     **
7833C               **     1) DPST1F.DAT--XXXXX                       **
7834C               ****************************************************
7835C
7836      ISTEPN='81'
7837      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BEC2')
7838     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7839C
7840      IF(IFEEDB.EQ.'ON')THEN
7841        WRITE(ICOUT,999)
7842        CALL DPWRST('XXX','BUG ')
7843        WRITE(ICOUT,8112)
7844 8112   FORMAT(6X,'NUMBER OF VARIABLES, CP VALUE, VARIABLE LIST ',
7845     1         'WRITTEN TO FILE DPST1F.DAT')
7846        CALL DPWRST('XXX','BUG ')
7847        WRITE(ICOUT,8114)
7848 8114   FORMAT(6X,'CODED VARIABLE LIST WRITTEN TO TO FILE DPST2F.DAT')
7849        CALL DPWRST('XXX','BUG ')
7850      ENDIF
7851C
7852C               **************************************
7853C               **  STEP 82--                       **
7854C               **  CLOSE       THE STORAGE FILES.  **
7855C               **************************************
7856C
7857      ISTEPN='82'
7858      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2')
7859     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
7860C
7861      IOP='CLOS'
7862      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
7863     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
7864     1            IBUGA3,ISUBRO,IERROR)
7865C
7866C               *****************
7867C               **  STEP 90--  **
7868C               **  EXIT       **
7869C               *****************
7870C
7871      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BEC2')THEN
7872        WRITE(ICOUT,999)
7873        CALL DPWRST('XXX','BUG ')
7874        WRITE(ICOUT,9011)
7875 9011   FORMAT('***** AT THE END       OF DPBEC2--')
7876        CALL DPWRST('XXX','BUG ')
7877        WRITE(ICOUT,9012)IERROR
7878 9012   FORMAT('IERROR = ',A4)
7879        CALL DPWRST('XXX','BUG ')
7880      ENDIF
7881C
7882      RETURN
7883      END
7884      SUBROUTINE DPBEFI(MAXNXT,ICAPSW,IFORSW,ISEED,
7885     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
7886C
7887C     PURPOSE--RETURN A RANKED LIST OF "BEST DISTRIBUTIONAL FIT".
7888C              THE USER CAN SPECIFY THE FIT METHOD USED AND THE
7889C              GOODNESS OF FIT CRITERION WITH THE COMMANDS
7890C
7891C                  SET BEST FIT METHOD <MAXIMUM LIKELIHOOD/PPCC/KS/
7892C                                       /ANDERSON DARLING>
7893C                  SET BEST FIT CRITERION <AIC/PPCC/AD/KS/CHI-SQUARE>
7894C
7895C     WRITTEN BY--ALAN HECKERT
7896C                 STATISTICAL ENGINEERING DIVISION
7897C                 INFORMATION TECHNOLOGY LABORAOTRY
7898C                 NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY
7899C                 GAITHERSBURG, MD 20899-8980
7900C                 PHONE--301-975-2899
7901C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
7902C           OF THE NATIONAL INSTITUTE OF STANDARDS OF TECHNOLOGY.
7903C     LANGUAGE--ANSI FORTRAN (1977)
7904C     VERSION NUMBER--2011/3
7905C     ORIGINAL VERSION--MARCH     2011.
7906C     UPDATED         --AUGUST    2014. MODIFICATIONS TO CALL LIST
7907C     UPDATED         --JULY      2019. TWEAK SCRATCH STORAGE,
7908C                                       REMOVE ZTMP15, ZTMP16, ZTMP17
7909C
7910C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
7911C
7912      CHARACTER*4 ICASAN
7913      CHARACTER*4 ICAPSW
7914      CHARACTER*4 IFORSW
7915      CHARACTER*4 IBUGA2
7916      CHARACTER*4 IBUGA3
7917      CHARACTER*4 IBUGQ
7918      CHARACTER*4 ISUBRO
7919      CHARACTER*4 IFOUND
7920      CHARACTER*4 IERROR
7921C
7922      CHARACTER*4 IHWUSE
7923      CHARACTER*4 MESSAG
7924      CHARACTER*4 IHP
7925      CHARACTER*4 IHP2
7926      CHARACTER*4 ISUBN1
7927      CHARACTER*4 ISUBN2
7928      CHARACTER*4 ISUBN3
7929      CHARACTER*4 ISTEPN
7930      CHARACTER*4 ICENSO
7931      CHARACTER*4 IMETHD
7932      CHARACTER*4 IREPL
7933      CHARACTER*4 IMULT
7934      CHARACTER*4 ILEVEL
7935      CHARACTER*4 IRELAT
7936      CHARACTER*4 ICTMP1
7937      CHARACTER*4 ICTMP2
7938      CHARACTER*4 ICTMP3
7939C
7940      CHARACTER*40 INAME
7941C
7942      CHARACTER*4 ICASE
7943      PARAMETER (MAXSPN=30)
7944      CHARACTER*4 IVARN1(MAXSPN)
7945      CHARACTER*4 IVARN2(MAXSPN)
7946      CHARACTER*4 IVARTY(MAXSPN)
7947      CHARACTER*4 IVARID(7)
7948      CHARACTER*4 IVARI2(7)
7949      REAL PVAR(MAXSPN)
7950      REAL PID(7)
7951      INTEGER ILIS(MAXSPN)
7952      INTEGER NRIGHT(MAXSPN)
7953      INTEGER ICOLR(MAXSPN)
7954C
7955C---------------------------------------------------------------------
7956C
7957      INCLUDE 'DPCOPA.INC'
7958      INCLUDE 'DPCOZZ.INC'
7959      INCLUDE 'DPCOZD.INC'
7960      INCLUDE 'DPCOZI.INC'
7961      INCLUDE 'DPCODA.INC'
7962C
7963      DIMENSION Y1(MAXOBV)
7964      DIMENSION X1(MAXOBV)
7965      DIMENSION XCENS(MAXOBV)
7966      DIMENSION XLEVEL(MAXOBV)
7967C
7968      DIMENSION XHIGH(MAXOBV)
7969      DIMENSION XTEMP1(MAXOBV)
7970      DIMENSION XTEMP2(MAXOBV)
7971      DIMENSION XTEMP5(MAXOBV)
7972C
7973      DIMENSION XDESGN(MAXOBV,6)
7974      DIMENSION XIDTEM(MAXOBV)
7975      DIMENSION XIDTE2(MAXOBV)
7976      DIMENSION XIDTE3(MAXOBV)
7977      DIMENSION XIDTE4(MAXOBV)
7978      DIMENSION XIDTE5(MAXOBV)
7979      DIMENSION XIDTE6(MAXOBV)
7980C
7981      DIMENSION TEMP1(MAXOBV)
7982      DIMENSION TEMP2(MAXOBV)
7983      DIMENSION TEMP3(MAXOBV)
7984      DOUBLE PRECISION DTEMP(MAXOBV)
7985      DOUBLE PRECISION DTEMP2(MAXOBV)
7986      DOUBLE PRECISION DTEMP3(MAXOBV)
7987C
7988      DIMENSION ZY(MAXOBV)
7989C
7990      DIMENSION ZTEMP1(MAXOBV)
7991      DIMENSION ZTEMP2(MAXOBV)
7992      DIMENSION ZTEMP3(MAXOBV)
7993      DIMENSION ZTEMP4(MAXOBV)
7994      DIMENSION ZTEMP5(MAXOBV)
7995      DIMENSION ZTEMP6(MAXOBV)
7996      DIMENSION ZTEMP7(MAXOBV)
7997      DIMENSION ZTEMP8(MAXOBV)
7998      DIMENSION ZTEMP9(MAXOBV)
7999      DIMENSION ZTMP10(MAXOBV)
8000      DIMENSION ZTMP11(MAXOBV)
8001      DIMENSION ZTMP12(MAXOBV)
8002      DIMENSION ZTMP13(MAXOBV)
8003      DIMENSION ZTMP14(MAXOBV)
8004C
8005      DIMENSION STATVA(100)
8006      CHARACTER*60 INLON2(100)
8007C
8008      DIMENSION ITEMP1(MAXOBV)
8009      DIMENSION ITEMP2(MAXOBV)
8010C
8011      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
8012      EQUIVALENCE (GARBAG(IGARB2),X1(1))
8013      EQUIVALENCE (GARBAG(IGARB3),XCENS(1))
8014      EQUIVALENCE (GARBAG(IGARB4),XHIGH(1))
8015      EQUIVALENCE (GARBAG(IGARB5),XTEMP1(1))
8016      EQUIVALENCE (GARBAG(IGARB6),XTEMP2(1))
8017      EQUIVALENCE (GARBAG(IGARB9),XTEMP5(1))
8018      EQUIVALENCE (GARBAG(IGAR10),TEMP1(1))
8019      EQUIVALENCE (GARBAG(JGAR11),TEMP2(1))
8020      EQUIVALENCE (GARBAG(JGAR12),TEMP3(1))
8021      EQUIVALENCE (GARBAG(JGAR13),XIDTEM(1))
8022      EQUIVALENCE (GARBAG(JGAR14),XIDTE2(1))
8023      EQUIVALENCE (GARBAG(JGAR15),XIDTE3(1))
8024      EQUIVALENCE (GARBAG(JGAR16),XIDTE4(1))
8025      EQUIVALENCE (GARBAG(JGAR17),XIDTE5(1))
8026      EQUIVALENCE (GARBAG(JGAR18),XIDTE6(1))
8027      EQUIVALENCE (GARBAG(JGAR19),ZY(1))
8028      EQUIVALENCE (GARBAG(JGAR20),ZTEMP1(1))
8029      EQUIVALENCE (GARBAG(IGAR11),ZTEMP2(1))
8030      EQUIVALENCE (GARBAG(IGAR12),ZTEMP3(1))
8031      EQUIVALENCE (GARBAG(IGAR13),ZTEMP4(1))
8032      EQUIVALENCE (GARBAG(IGAR14),ZTEMP5(1))
8033      EQUIVALENCE (GARBAG(IGAR15),ZTEMP6(1))
8034      EQUIVALENCE (GARBAG(IGAR16),ZTEMP7(1))
8035      EQUIVALENCE (GARBAG(IGAR17),ZTEMP8(1))
8036      EQUIVALENCE (GARBAG(IGAR18),ZTEMP9(1))
8037      EQUIVALENCE (GARBAG(IGAR19),ZTMP10(1))
8038      EQUIVALENCE (GARBAG(IGAR20),ZTMP11(1))
8039      EQUIVALENCE (GARBAG(IGAR21),ZTMP12(1))
8040      EQUIVALENCE (GARBAG(IGAR22),ZTMP13(1))
8041      EQUIVALENCE (GARBAG(IGAR23),ZTMP14(1))
8042      EQUIVALENCE (GARBAG(IGAR24),XLEVEL(1))
8043      EQUIVALENCE (DSYMB(1),XDESGN(1,1))
8044C
8045      EQUIVALENCE (DGARBG(IDGAR1),DTEMP(1))
8046      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
8047      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
8048      EQUIVALENCE (IGARBG(IDGAR1),ITEMP1(1))
8049      EQUIVALENCE (IGARBG(IDGAR2),ITEMP2(1))
8050C
8051C-----COMMON----------------------------------------------------------
8052C
8053      INCLUDE 'DPCOHK.INC'
8054      INCLUDE 'DPCOSU.INC'
8055      INCLUDE 'DPCOS2.INC'
8056      INCLUDE 'DPCOHO.INC'
8057      INCLUDE 'DPCOMC.INC'
8058      INCLUDE 'DPCOST.INC'
8059C
8060C-----COMMON VARIABLES (GENERAL)--------------------------------------
8061C
8062      INCLUDE 'DPCOP2.INC'
8063C
8064C-----START POINT-----------------------------------------------------
8065C
8066      IERROR='NO'
8067      ICASAN='    '
8068      ICENSO='OFF'
8069      IREPL='OFF'
8070      IMULT='OFF'
8071      ILEVEL='OFF'
8072      IMETHD='UNIM'
8073      IF(IPPCCN.EQ.'KAPL')IMETHD='KAPL'
8074C
8075      ISUBN1='DPBE'
8076      ISUBN2='FI  '
8077      ISUBN3='BEFI'
8078C
8079      MAXCP1=MAXCOL+1
8080      MAXCP2=MAXCOL+2
8081      MAXCP3=MAXCOL+3
8082      MAXCP4=MAXCOL+4
8083      MAXCP5=MAXCOL+5
8084      MAXCP6=MAXCOL+6
8085C
8086C               ***************************************************
8087C               **  TREAT THE BEST DISTRIBUTIONAL FIT   CASE     **
8088C               ***************************************************
8089C
8090      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'BEFI')THEN
8091        WRITE(ICOUT,999)
8092  999   FORMAT(1X)
8093        CALL DPWRST('XXX','BUG ')
8094        WRITE(ICOUT,51)
8095   51   FORMAT('***** AT THE BEGINNING OF DPBEFI--')
8096        CALL DPWRST('XXX','BUG ')
8097        WRITE(ICOUT,53)ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT
8098   53   FORMAT('ICASAN,IBUGA2,IBUGA3,IBUGQ,ISUBRO,MAXNXT = ',
8099     1         5(A4,2X),I8)
8100        CALL DPWRST('XXX','BUG ')
8101      ENDIF
8102C
8103C               *********************************************************
8104C               **  STEP 1--                                           **
8105C               **  EXTRACT THE COMMAND                                **
8106C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:            **
8107C               **    1) BEST DISTRIBUTIONAL FIT Y                     **
8108C               **    2) MULTIPLE BEST DISTRIBUTIONAL FIT Y1 ... YK    **
8109C               **    3) REPLICATED BEST DISTRIBUTIONAL FIT Y X1 ... XK**
8110C               *********************************************************
8111C
8112      ISTEPN='1'
8113      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')
8114     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8115C
8116C     NOTE: ML FIT WITH PPCC RANKING CRITERION NOT SUPPORTED.
8117C
8118      IF(IBFIME.EQ.'ML' .AND. IBFICR.EQ.'PPCC')THEN
8119        WRITE(ICOUT,999)
8120        CALL DPWRST('XXX','BUG ')
8121        WRITE(ICOUT,101)
8122        CALL DPWRST('XXX','BUG ')
8123        WRITE(ICOUT,112)
8124  112   FORMAT('      FITTING WITH MAXIMUM LIKELIHOOD AND RANKING ',
8125     1         'WITH PPCC IS NOT SUPPORTED.')
8126        CALL DPWRST('XXX','BUG ')
8127        WRITE(ICOUT,114)
8128  114   FORMAT('      THIS IS BECAUSE THE INVARIANCE OF LOCATION AND ',
8129     1         'SCALE WITH THE PPCC')
8130        CALL DPWRST('XXX','BUG ')
8131        WRITE(ICOUT,116)
8132  116   FORMAT('      MEANS THE ML PARAMETERS ARE IMPLICITLY BEING ',
8133     1         'MODIFIED BY THE RANKING PROCEDURE.')
8134        CALL DPWRST('XXX','BUG ')
8135        IERROR='YES'
8136        GOTO9000
8137      ENDIF
8138C
8139      ILASTC=9999
8140      ILASTZ=9999
8141      ICASAN='BEFI'
8142C
8143C     LOOK FOR:
8144C
8145C          BEST DISTRIBUTIONAL FIT
8146C          MULTIPLE
8147C          REPLICATED
8148C
8149      DO100I=0,NUMARG-1
8150C
8151        IF(I.EQ.0)THEN
8152          ICTMP1=ICOM
8153        ELSE
8154          ICTMP1=IHARG(I)
8155        ENDIF
8156        ICTMP2=IHARG(I+1)
8157        ICTMP3=IHARG(I+2)
8158C
8159        IF(ICTMP1.EQ.'=')THEN
8160          IFOUND='NO'
8161          GOTO9000
8162        ELSEIF(ICTMP1.EQ.'BEST' .AND. ICTMP2.EQ.'DIST' .AND.
8163     1         ICTMP3.EQ.'FIT ')THEN
8164          IFOUND='YES'
8165          ICASAN='BEFI'
8166          ILASTC=I
8167          ILASTZ=I+2
8168        ELSEIF(ICTMP1.EQ.'REPL')THEN
8169          IREPL='ON'
8170          ILASTC=MIN(ILASTC,I)
8171          ILASTZ=MAX(ILASTZ,I)
8172        ELSEIF(ICTMP1.EQ.'MULT')THEN
8173          IMULT='ON'
8174          ILASTC=MIN(ILASTC,I)
8175          ILASTZ=MAX(ILASTZ,I)
8176        ENDIF
8177  100 CONTINUE
8178C
8179      IF(IFOUND.EQ.'NO')GOTO9000
8180C
8181      ISHIFT=ILASTZ
8182      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
8183     1            IBUGA2,IERROR)
8184C
8185      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')THEN
8186        WRITE(ICOUT,91)ICASAN,IMULT,IREPL,ISHIFT
8187   91   FORMAT('DPCUSU: ICASAN,IMULT,IREPL,ISHIFT = ',3(A4,2X),I5)
8188        CALL DPWRST('XXX','BUG ')
8189      ENDIF
8190C
8191      IF(IFOUND.EQ.'NO')GOTO9000
8192      IF(IMULT.EQ.'ON')THEN
8193        IF(IREPL.EQ.'ON')THEN
8194          WRITE(ICOUT,999)
8195          CALL DPWRST('XXX','BUG ')
8196          WRITE(ICOUT,101)
8197  101     FORMAT('***** ERROR IN BEST DISTRIBUTIONAL FIT--')
8198          CALL DPWRST('XXX','BUG ')
8199          WRITE(ICOUT,102)
8200  102     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ')
8201          CALL DPWRST('XXX','BUG ')
8202          WRITE(ICOUT,103)
8203  103     FORMAT('      "REPLICATION" FOR THE BEST DISTRIBUTIONAL ',
8204     1           'FIT COMMAND.')
8205          CALL DPWRST('XXX','BUG ')
8206          IERROR='YES'
8207          GOTO9000
8208        ENDIF
8209      ENDIF
8210C
8211C               *********************************
8212C               **  STEP 4--                   **
8213C               **  EXTRACT THE VARIABLE LIST  **
8214C               *********************************
8215C
8216      ISTEPN='4'
8217      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')
8218     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8219C
8220      INAME='BEST DISTRIBUTIONAL FIT'
8221      MINNA=1
8222      MAXNA=100
8223      MINN2=2
8224      IFLAGE=0
8225      IFLAGM=1
8226      MINNVA=1
8227      MAXNVA=MAXSPN
8228      IF(IREPL.EQ.'ON')THEN
8229        IFLAGE=1
8230        IFLAGM=0
8231        MINNVA=2
8232        MAXNVA=7
8233      ENDIF
8234      IFLAGP=0
8235      JMIN=1
8236      JMAX=NUMARG
8237C
8238      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
8239     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
8240     1            JMIN,JMAX,
8241     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
8242     1            IVARN1,IVARN2,IVARTY,PVAR,
8243     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
8244     1            MINNVA,MAXNVA,
8245     1            IFLAGM,IFLAGP,
8246     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
8247      IF(IERROR.EQ.'YES')GOTO9000
8248C
8249      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')THEN
8250        WRITE(ICOUT,999)
8251        CALL DPWRST('XXX','BUG ')
8252        WRITE(ICOUT,281)
8253  281   FORMAT('***** AFTER CALL DPPARS--')
8254        CALL DPWRST('XXX','BUG ')
8255        WRITE(ICOUT,282)NQ,NUMVAR
8256  282   FORMAT('NQ,NUMVAR = ',2I8)
8257        CALL DPWRST('XXX','BUG ')
8258        IF(NUMVAR.GT.0)THEN
8259          DO285I=1,NUMVAR
8260            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
8261     1                      ICOLR(I)
8262  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
8263     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
8264            CALL DPWRST('XXX','BUG ')
8265  285     CONTINUE
8266        ENDIF
8267      ENDIF
8268C
8269C               ***********************************************
8270C               **  STEP 5--                                 **
8271C               **  DETERMINE:                               **
8272C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
8273C               **  2) NUMBER OF CENSORING   VARIABLES (0-1) **
8274C               **  3) NUMBER OF GROUPING    VARIABLES (0-2) **
8275C               **  4) NUMBER OF RESPONSE    VARIABLES (>= 1)**
8276C               ***********************************************
8277C
8278      ISTEPN='5'
8279      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')
8280     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8281C
8282      NRESP=1
8283      NREPL=0
8284      IF(IMULT.EQ.'ON')THEN
8285        NRESP=NUMVAR
8286      ELSEIF(IREPL.EQ.'ON')THEN
8287        NRESP=1
8288        NREPL=NUMVAR-NRESP
8289        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
8290          WRITE(ICOUT,999)
8291          CALL DPWRST('XXX','BUG ')
8292          WRITE(ICOUT,101)
8293          CALL DPWRST('XXX','BUG ')
8294          WRITE(ICOUT,511)
8295  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
8296     1           'REPLICATION VARIABLES')
8297          CALL DPWRST('XXX','BUG ')
8298          WRITE(ICOUT,513)NREPL
8299  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
8300          CALL DPWRST('XXX','BUG ')
8301          IERROR='YES'
8302          GOTO9000
8303        ENDIF
8304      ENDIF
8305C
8306      IFLAGL=0
8307      AL=CPUMIN
8308      IF(IWEIGL.EQ.'ON')THEN
8309        IHP='L   '
8310        IHP2='    '
8311        IHWUSE='P'
8312        MESSAG='NO'
8313        CALL CHECKN(IHP,IHP2,IHWUSE,
8314     1  IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
8315     1  ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
8316        IF(IERROR.EQ.'NO')AL=VALUE(ILOCP)
8317        IF(AL.LE.0.0)THEN
8318          AL=CPUMIN
8319        ELSE
8320          IFLAGL=1
8321        ENDIF
8322      ENDIF
8323C
8324C     CHECK IF LOWER LIMIT/UPPER LIMIT SPECIFIED FOR CERTAIN LIMIT
8325C     BASED DISTRIBUTIONS (AND WHERE NOT ESTIMATED BY THE DATA).
8326C
8327      IHP='LOWL'
8328      IHP2='IMIT'
8329      IHWUSE='P'
8330      MESSAG='NO'
8331      CALL CHECKN(IHP,IHP2,IHWUSE,
8332     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
8333     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
8334      IF(IERROR.EQ.'NO')THEN
8335        YLOWLM=VALUE(ILOCP)
8336      ELSE
8337        YLOWLM=CPUMIN
8338      ENDIF
8339C
8340      IHP='UPPL'
8341      IHP2='IMIT'
8342      IHWUSE='P'
8343      MESSAG='NO'
8344      CALL CHECKN(IHP,IHP2,IHWUSE,
8345     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
8346     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
8347      IF(IERROR.EQ.'NO')THEN
8348        YUPPLM=VALUE(ILOCP)
8349      ELSE
8350        YUPPLM=CPUMIN
8351      ENDIF
8352C
8353      IHP='MINS'
8354      IHP2='IZE '
8355      IHWUSE='P'
8356      MESSAG='NO'
8357      CALL CHECKN(IHP,IHP2,IHWUSE,
8358     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
8359     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
8360      IF(IERROR.EQ.'YES')THEN
8361        MINSIZ=5
8362      ELSE
8363        MINSIZ=INT(VALUE(ILOCP)+0.5)
8364        IF(MINSIZ.LE.0)MINSIZ=5
8365      ENDIF
8366C               ***********************************************
8367C               **  STEP 6--                                 **
8368C               **  GENERATE THE BEST DISTRIBUTIONAL FIT     **
8369C               **  FOR THE VARIOUS CASES.                   **
8370C               ***********************************************
8371C
8372      ISTEPN='6'
8373      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')
8374     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8375C
8376C               *****************************************
8377C               **  STEP 7A--                          **
8378C               **  CASE 1: NO REPLICATION VARIABLES   **
8379C               *****************************************
8380C
8381      IF(NREPL.EQ.0)THEN
8382        ISTEPN='7A'
8383        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')
8384     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8385C
8386C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
8387C
8388        NCURVE=0
8389        DO710IRESP=1,NRESP
8390          NCURVE=NCURVE+1
8391C
8392          IINDX=ICOLR(IRESP)
8393          PID(1)=CPUMIN
8394          IVARID(1)=IVARN1(IRESP)
8395          IVARI2(1)=IVARN2(IRESP)
8396C
8397          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')THEN
8398            WRITE(ICOUT,999)
8399            CALL DPWRST('XXX','BUG ')
8400            WRITE(ICOUT,711)IRESP,NCURVE
8401  711       FORMAT('IRESP,NCURVE = ',2I5)
8402            CALL DPWRST('XXX','BUG ')
8403          ENDIF
8404C
8405          ICOL=IRESP
8406          NUMVA2=1
8407          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
8408     1                INAME,IVARN1,IVARN2,IVARTY,
8409     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
8410     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
8411     1                MAXCP4,MAXCP5,MAXCP6,
8412     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
8413     1                Y1,XTEMP1,XTEMP1,NLOCAL,NLOCA2,NLOCA2,ICASE,
8414     1                IBUGA3,ISUBRO,IFOUND,IERROR)
8415          IF(IERROR.EQ.'YES')GOTO9000
8416C
8417C         *****************************************************
8418C         **  STEP 7B--                                      **
8419C         *****************************************************
8420C
8421          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'BEFI')THEN
8422            ISTEPN='7B'
8423            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8424            WRITE(ICOUT,999)
8425            CALL DPWRST('XXX','BUG ')
8426            WRITE(ICOUT,722)
8427  722       FORMAT('***** FROM THE MIDDLE  OF DPBEFI--')
8428            CALL DPWRST('XXX','BUG ')
8429            WRITE(ICOUT,723)ICASAN,NUMVAR,NLOCAL
8430  723       FORMAT('ICASAN,NUMVAR,NQ = ',A4,2I8)
8431            CALL DPWRST('XXX','BUG ')
8432            IF(NLOCAL.GE.1)THEN
8433              DO725I=1,NLOCAL
8434                WRITE(ICOUT,726)I,Y(I)
8435  726           FORMAT('I,Y(I) = ',I8,G15.7)
8436                CALL DPWRST('XXX','BUG ')
8437  725         CONTINUE
8438            ENDIF
8439          ENDIF
8440C
8441          CALL DPBEF2(Y1,XCENS,XLEVEL,NLOCAL,ICASAN,MAXOBV,ISEED,
8442     1                PID,IVARID,IVARI2,NREPL,
8443     1                XTEMP5,NOUT,
8444     1                TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,
8445     1                ITEMP1,ITEMP2,
8446     1                ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
8447     1                ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,
8448     1                ZTMP11,ZTMP12,ZTMP13,ZTMP14,
8449     1                YLOWLM,YUPPLM,A,B,MINMAX,
8450     1                IADEDF,IGEPDF,IMAKDF,IBEIDF,
8451     1                ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8452     1                IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
8453     1                IEXPBC,IWEIBC,ICENTY,
8454     1                CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
8455     1                IFLAGL,AL,
8456     1                ICAPSW,ICAPTY,IFORSW,
8457     1                IBFIME,IBFICR,IBFIFO,PBFILL,PBFIUL,
8458     1                IBFITY,PBFIXV,
8459     1                IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,IDFTTY,
8460     1                IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,IRTFPS,
8461     1                STATVA,INLON2,ISUBN3,NLIST,
8462     1                IBUGA3,ISUBRO,IERROR)
8463C
8464  710   CONTINUE
8465C
8466C               ***************************************************
8467C               **  STEP 9A--                                    **
8468C               **  CASE 2: ONE OR MORE REPLICATION VARIABLES.   **
8469C               **          FOR THIS CASE, THE NUMBER OF RESPONSE**
8470C               **          VARIABLES MUST BE EXACTLY 1.         **
8471C               **          FOR THIS CASE, ALL VARIABLES MUST    **
8472C               **          HAVE THE SAME LENGTH.                **
8473C               ***************************************************
8474C
8475      ELSEIF(NREPL.GE.1)THEN
8476        ISTEPN='9A'
8477        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')
8478     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8479C
8480        PID(1)=CPUMIN
8481        IVARID(1)=IVARN1(1)
8482        IVARI2(1)=IVARN2(1)
8483        IADD=1
8484        DO903II=1,NREPL
8485          IVARID(II+1)=IVARN1(II+IADD)
8486          IVARI2(II+1)=IVARN2(II+IADD)
8487  903   CONTINUE
8488C
8489        J=0
8490        IMAX=NRIGHT(1)
8491        IF(NQ.LT.NRIGHT(1))IMAX=NQ
8492        DO910I=1,IMAX
8493          IF(ISUB(I).EQ.0)GOTO910
8494          J=J+1
8495C
8496C         RESPONSE VARIABLE IN Y1
8497C
8498          ICOLC=1
8499          IJ=MAXN*(ICOLR(ICOLC)-1)+I
8500          IF(ICOLR(ICOLC).LE.MAXCOL)Y1(J)=V(IJ)
8501          IF(ICOLR(ICOLC).EQ.MAXCP1)Y1(J)=PRED(I)
8502          IF(ICOLR(ICOLC).EQ.MAXCP2)Y1(J)=RES(I)
8503          IF(ICOLR(ICOLC).EQ.MAXCP3)Y1(J)=YPLOT(I)
8504          IF(ICOLR(ICOLC).EQ.MAXCP4)Y1(J)=XPLOT(I)
8505          IF(ICOLR(ICOLC).EQ.MAXCP5)Y1(J)=X2PLOT(I)
8506          IF(ICOLR(ICOLC).EQ.MAXCP6)Y1(J)=TAGPLO(I)
8507C
8508          DO920IR=1,MIN(NREPL,6)
8509            ICOLC=ICOLC+1
8510            ICOLT=ICOLR(ICOLC)
8511            IJ=MAXN*(ICOLT-1)+I
8512            IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
8513            IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
8514            IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
8515            IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
8516            IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
8517            IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
8518            IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
8519  920     CONTINUE
8520C
8521  910   CONTINUE
8522        NLOCAL=J
8523C
8524C       *****************************************************
8525C       **  STEP 9B--                                      **
8526C       **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
8527C       **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
8528C       **                                                 **
8529C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
8530C       **  VARIOUS REPLICATIONS.                          **
8531C       *****************************************************
8532C
8533        ISTEPN='9B'
8534        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BEFI')
8535     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
8536C
8537        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'BEFI')THEN
8538          WRITE(ICOUT,999)
8539          CALL DPWRST('XXX','BUG ')
8540          WRITE(ICOUT,931)
8541  931     FORMAT('***** FROM THE MIDDLE  OF DPBEFI--')
8542          CALL DPWRST('XXX','BUG ')
8543          WRITE(ICOUT,932)ICASAN,NUMVAR,IDATSW,NLOCAL
8544  932     FORMAT('ICASAN,NUMVAR,IDATSW,NQ = ',
8545     1           A4,I8,2X,A4,I8)
8546          CALL DPWRST('XXX','BUG ')
8547          IF(NLOCAL.GE.1)THEN
8548            DO935I=1,NLOCAL
8549              WRITE(ICOUT,936)I,Y1(I),XDESGN(I,1),XDESGN(I,2)
8550  936         FORMAT('I,Y1(I),XDESGN(I,1),XDESGN(I,2) = ',I8,3F12.5)
8551              CALL DPWRST('XXX','BUG ')
8552  935       CONTINUE
8553          ENDIF
8554        ENDIF
8555C
8556C       *****************************************************
8557C       **  STEP 9C--                                      **
8558C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
8559C       **  REPLICATION VARIABLES.                         **
8560C       *****************************************************
8561C
8562        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
8563     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
8564     1             NREPL,NLOCAL,MAXOBV,
8565     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
8566     1             XTEMP1,XTEMP2,
8567     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
8568     1             IBUGA3,ISUBRO,IERROR)
8569C
8570C       *****************************************************
8571C       **  STEP 9D--                                      **
8572C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
8573C       *****************************************************
8574C
8575        NCURVE=0
8576        IF(NREPL.EQ.1)THEN
8577          J=0
8578          DO1110ISET1=1,NUMSE1
8579            K=0
8580            PID(2)=XIDTEM(ISET1)
8581            DO1130I=1,NLOCAL
8582              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
8583                K=K+1
8584                ZY(K)=Y1(I)
8585              ENDIF
8586 1130       CONTINUE
8587            NTEMP=K
8588            NCURVE=NCURVE+1
8589            IF(NTEMP.GT.0)THEN
8590              CALL DPBEF2(ZY,XCENS,XLEVEL,NTEMP,ICASAN,MAXOBV,ISEED,
8591     1                    PID,IVARID,IVARI2,NREPL,
8592     1                    XTEMP5,NOUT,
8593     1                    TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,
8594     1                    ITEMP1,ITEMP2,
8595     1                    ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
8596     1                    ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,
8597     1                    ZTMP11,ZTMP12,ZTMP13,ZTMP14,
8598     1                    YLOWLM,YUPPLM,A,B,MINMAX,
8599     1                    IADEDF,IGEPDF,IMAKDF,IBEIDF,
8600     1                    ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8601     1                    IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
8602     1                    IEXPBC,IWEIBC,ICENTY,
8603     1                    CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
8604     1                    IFLAGL,AL,
8605     1                    ICAPSW,ICAPTY,IFORSW,
8606     1                    IBFIME,IBFICR,IBFIFO,PBFILL,PBFIUL,
8607     1                    IBFITY,PBFIXV,
8608     1                    IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,IDFTTY,
8609     1                    IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,IRTFPS,
8610     1                    STATVA,INLON2,ISUBN3,NLIST,
8611     1                    IBUGA3,ISUBRO,IERROR)
8612            ENDIF
8613 1110     CONTINUE
8614        ELSEIF(NREPL.EQ.2)THEN
8615          J=0
8616          NTOT=NUMSE1*NUMSE2
8617          DO1210ISET1=1,NUMSE1
8618          DO1220ISET2=1,NUMSE2
8619            K=0
8620            PID(2)=XIDTEM(ISET1)
8621            PID(3)=XIDTE2(ISET2)
8622            DO1290I=1,NLOCAL
8623              IF(
8624     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
8625     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
8626     1          )THEN
8627                K=K+1
8628                ZY(K)=Y1(I)
8629              ENDIF
8630 1290       CONTINUE
8631            NTEMP=K
8632            NCURVE=NCURVE+1
8633            IF(NTEMP.GT.0)THEN
8634              CALL DPBEF2(ZY,XCENS,XLEVEL,NTEMP,ICASAN,MAXOBV,ISEED,
8635     1                    PID,IVARID,IVARI2,NREPL,
8636     1                    XTEMP5,NOUT,
8637     1                    TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,
8638     1                    ITEMP1,ITEMP2,
8639     1                    ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
8640     1                    ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,
8641     1                    ZTMP11,ZTMP12,ZTMP13,ZTMP14,
8642     1                    YLOWLM,YUPPLM,A,B,MINMAX,
8643     1                    IADEDF,IGEPDF,IMAKDF,IBEIDF,
8644     1                    ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8645     1                    IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
8646     1                    IEXPBC,IWEIBC,ICENTY,
8647     1                    CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
8648     1                    IFLAGL,AL,
8649     1                    ICAPSW,ICAPTY,IFORSW,
8650     1                    IBFIME,IBFICR,IBFIFO,PBFILL,PBFIUL,
8651     1                    IBFITY,PBFIXV,
8652     1                    IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,IDFTTY,
8653     1                    IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,IRTFPS,
8654     1                    STATVA,INLON2,ISUBN3,NLIST,
8655     1                    IBUGA3,ISUBRO,IERROR)
8656              ENDIF
8657 1220     CONTINUE
8658 1210     CONTINUE
8659        ELSEIF(NREPL.EQ.3)THEN
8660          J=0
8661          NTOT=NUMSE1*NUMSE2*NUMSE3
8662          DO1310ISET1=1,NUMSE1
8663          DO1320ISET2=1,NUMSE2
8664          DO1330ISET3=1,NUMSE3
8665            K=0
8666            PID(2)=XIDTEM(ISET1)
8667            PID(3)=XIDTE2(ISET2)
8668            PID(4)=XIDTE3(ISET3)
8669            DO1390I=1,NLOCAL
8670              IF(
8671     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
8672     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
8673     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
8674     1          )THEN
8675                K=K+1
8676                ZY(K)=Y1(I)
8677              ENDIF
8678 1390       CONTINUE
8679            NTEMP=K
8680            NCURVE=NCURVE+1
8681            IF(NTEMP.GT.0)THEN
8682              CALL DPBEF2(ZY,XCENS,XLEVEL,NTEMP,ICASAN,MAXOBV,ISEED,
8683     1                    PID,IVARID,IVARI2,NREPL,
8684     1                    XTEMP5,NOUT,
8685     1                    TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,
8686     1                    ITEMP1,ITEMP2,
8687     1                    ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
8688     1                    ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,
8689     1                    ZTMP11,ZTMP12,ZTMP13,ZTMP14,
8690     1                    YLOWLM,YUPPLM,A,B,MINMAX,
8691     1                    IADEDF,IGEPDF,IMAKDF,IBEIDF,
8692     1                    ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8693     1                    IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
8694     1                    IEXPBC,IWEIBC,ICENTY,
8695     1                    CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
8696     1                    IFLAGL,AL,
8697     1                    ICAPSW,ICAPTY,IFORSW,
8698     1                    IBFIME,IBFICR,IBFIFO,PBFILL,PBFIUL,
8699     1                    IBFITY,PBFIXV,
8700     1                    IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,IDFTTY,
8701     1                    IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,IRTFPS,
8702     1                    STATVA,INLON2,ISUBN3,NLIST,
8703     1                    IBUGA3,ISUBRO,IERROR)
8704              ENDIF
8705 1330     CONTINUE
8706 1320     CONTINUE
8707 1310     CONTINUE
8708        ELSEIF(NREPL.EQ.4)THEN
8709          J=0
8710          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
8711          DO1410ISET1=1,NUMSE1
8712          DO1420ISET2=1,NUMSE2
8713          DO1430ISET3=1,NUMSE3
8714          DO1440ISET4=1,NUMSE4
8715            K=0
8716            PID(2)=XIDTEM(ISET1)
8717            PID(3)=XIDTE2(ISET2)
8718            PID(4)=XIDTE3(ISET3)
8719            PID(5)=XIDTE4(ISET4)
8720            DO1490I=1,NLOCAL
8721              IF(
8722     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
8723     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
8724     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
8725     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
8726     1          )THEN
8727                K=K+1
8728                ZY(K)=Y1(I)
8729              ENDIF
8730 1490       CONTINUE
8731            NTEMP=K
8732            NCURVE=NCURVE+1
8733            IF(NTEMP.GT.0)THEN
8734              CALL DPBEF2(ZY,XCENS,XLEVEL,NTEMP,ICASAN,MAXOBV,ISEED,
8735     1                    PID,IVARID,IVARI2,NREPL,
8736     1                    XTEMP5,NOUT,
8737     1                    TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,
8738     1                    ITEMP1,ITEMP2,
8739     1                    ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
8740     1                    ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,
8741     1                    ZTMP11,ZTMP12,ZTMP13,ZTMP14,
8742     1                    YLOWLM,YUPPLM,A,B,MINMAX,
8743     1                    IADEDF,IGEPDF,IMAKDF,IBEIDF,
8744     1                    ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8745     1                    IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
8746     1                    IEXPBC,IWEIBC,ICENTY,
8747     1                    CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
8748     1                    IFLAGL,AL,
8749     1                    ICAPSW,ICAPTY,IFORSW,
8750     1                    IBFIME,IBFICR,IBFIFO,PBFILL,PBFIUL,
8751     1                    IBFITY,PBFIXV,
8752     1                    IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,IDFTTY,
8753     1                    IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,IRTFPS,
8754     1                    STATVA,INLON2,ISUBN3,NLIST,
8755     1                    IBUGA3,ISUBRO,IERROR)
8756              ENDIF
8757 1440     CONTINUE
8758 1430     CONTINUE
8759 1420     CONTINUE
8760 1410     CONTINUE
8761        ELSEIF(NREPL.EQ.5)THEN
8762          J=0
8763          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
8764          DO1510ISET1=1,NUMSE1
8765          DO1520ISET2=1,NUMSE2
8766          DO1530ISET3=1,NUMSE3
8767          DO1540ISET4=1,NUMSE4
8768          DO1550ISET5=1,NUMSE5
8769            K=0
8770            PID(2)=XIDTEM(ISET1)
8771            PID(3)=XIDTE2(ISET2)
8772            PID(4)=XIDTE3(ISET3)
8773            PID(5)=XIDTE4(ISET4)
8774            PID(6)=XIDTE5(ISET5)
8775            DO1590I=1,NLOCAL
8776              IF(
8777     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
8778     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
8779     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
8780     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
8781     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
8782     1          )THEN
8783                K=K+1
8784                ZY(K)=Y1(I)
8785              ENDIF
8786 1590       CONTINUE
8787            NTEMP=K
8788            NCURVE=NCURVE+1
8789            IF(NTEMP.GT.0)THEN
8790              CALL DPBEF2(ZY,XCENS,XLEVEL,NTEMP,ICASAN,MAXOBV,ISEED,
8791     1                    PID,IVARID,IVARI2,NREPL,
8792     1                    XTEMP5,NOUT,
8793     1                    TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,
8794     1                    ITEMP1,ITEMP2,
8795     1                    ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
8796     1                    ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,
8797     1                    ZTMP11,ZTMP12,ZTMP13,ZTMP14,
8798     1                    YLOWLM,YUPPLM,A,B,MINMAX,
8799     1                    IADEDF,IGEPDF,IMAKDF,IBEIDF,
8800     1                    ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8801     1                    IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
8802     1                    IEXPBC,IWEIBC,ICENTY,
8803     1                    CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
8804     1                    IFLAGL,AL,
8805     1                    ICAPSW,ICAPTY,IFORSW,
8806     1                    IBFIME,IBFICR,IBFIFO,PBFILL,PBFUL,
8807     1                    IBFITY,PBFIXV,
8808     1                    IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,IDFTTY,
8809     1                    IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,IRTFPS,
8810     1                    STATVA,INLON2,ISUBN3,NLIST,
8811     1                    IBUGA3,ISUBRO,IERROR)
8812              ENDIF
8813 1550     CONTINUE
8814 1540     CONTINUE
8815 1530     CONTINUE
8816 1520     CONTINUE
8817 1510     CONTINUE
8818        ELSEIF(NREPL.EQ.6)THEN
8819          J=0
8820          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
8821          DO1610ISET1=1,NUMSE1
8822          DO1620ISET2=1,NUMSE2
8823          DO1630ISET3=1,NUMSE3
8824          DO1640ISET4=1,NUMSE4
8825          DO1650ISET5=1,NUMSE5
8826          DO1660ISET6=1,NUMSE6
8827            K=0
8828            PID(2)=XIDTEM(ISET1)
8829            PID(3)=XIDTE2(ISET2)
8830            PID(4)=XIDTE3(ISET3)
8831            PID(5)=XIDTE4(ISET4)
8832            PID(6)=XIDTE5(ISET5)
8833            PID(7)=XIDTE6(ISET6)
8834            DO1690I=1,NLOCAL
8835              IF(
8836     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
8837     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
8838     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
8839     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
8840     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
8841     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
8842     1          )THEN
8843                K=K+1
8844                ZY(K)=Y1(I)
8845              ENDIF
8846 1690       CONTINUE
8847            NTEMP=K
8848            NCURVE=NCURVE+1
8849            IF(NTEMP.GT.0)THEN
8850              CALL DPBEF2(ZY,XCENS,XLEVEL,NTEMP,ICASAN,MAXOBV,ISEED,
8851     1                    PID,IVARID,IVARI2,NREPL,
8852     1                    XTEMP5,NOUT,
8853     1                    TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,
8854     1                    ITEMP1,ITEMP2,
8855     1                    ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
8856     1                    ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,
8857     1                    ZTMP11,ZTMP12,ZTMP13,ZTMP14,
8858     1                    YLOWLM,YUPPLM,A,B,MINMAX,
8859     1                    IADEDF,IGEPDF,IMAKDF,IBEIDF,
8860     1                    ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8861     1                    IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
8862     1                    IEXPBC,IWEIBC,ICENTY,
8863     1                    CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
8864     1                    IFLAGL,AL,
8865     1                    ICAPSW,ICAPTY,IFORSW,
8866     1                    IBFIME,IBFICR,IBFIFO,PBFILL,PBFIUL,
8867     1                    IBFITY,PBFIXV,
8868     1                    IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,IDFTTY,
8869     1                    IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,IRTFPS,
8870     1                    STATVA,INLON2,ISUBN3,NLIST,
8871     1                    IBUGA3,ISUBRO,IERROR)
8872              ENDIF
8873 1660     CONTINUE
8874 1650     CONTINUE
8875 1640     CONTINUE
8876 1630     CONTINUE
8877 1620     CONTINUE
8878 1610     CONTINUE
8879        ENDIF
8880C
8881      ENDIF
8882C
8883C               *****************
8884C               **  STEP 90--  **
8885C               **  EXIT       **
8886C               *****************
8887C
8888 9000 CONTINUE
8889C
8890      IF(IERROR.EQ.'YES')THEN
8891        IF(IWIDTH.GE.1)THEN
8892          WRITE(ICOUT,9001)(IANS(I),I=1,MIN(100,IWIDTH))
8893 9001     FORMAT(100A1)
8894          CALL DPWRST('XXX','BUG ')
8895        ENDIF
8896      ENDIF
8897C
8898      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'BEFI')THEN
8899        WRITE(ICOUT,999)
8900        CALL DPWRST('XXX','BUG ')
8901        WRITE(ICOUT,9011)
8902 9011   FORMAT('***** AT THE END       OF DPBEFI--')
8903        CALL DPWRST('XXX','BUG ')
8904        WRITE(ICOUT,9012)IFOUND,IERROR
8905 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
8906        CALL DPWRST('XXX','BUG ')
8907      ENDIF
8908C
8909      RETURN
8910      END
8911      SUBROUTINE DPBEF2(Y,CENSOR,XLEVEL,N,ICASPL,MAXOBV,ISEED,
8912     1                  PID,IVARID,IVARI2,NREPL,
8913     1                  YSTAT,N2,
8914     1                  TEMP1,TEMP2,TEMP3,DTEMP,DTEMP2,DTEMP3,
8915     1                  ITEMP1,ITEMP2,
8916     1                  ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,ZTEMP5,
8917     1                  ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,ZTMP10,
8918     1                  ZTMP11,ZTMP12,XLOW,XHIGH,
8919     1                  YLOWLM,YUPPLM,A,B,MINMAX,
8920     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
8921     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
8922     1                  IGOMDF,IKATDF,IGIGDF,IGEODF,IGAUDF,
8923     1                  IEXPBC,IWEIBC,ICENTY,
8924     1                  CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
8925     1                  IFLAGL,AL,
8926     1                  ICAPSW,ICAPTY,IFORSW,
8927     1                  IBFIME,IBFICR,IBFIFO,PBFILL,PBFIUL,
8928     1                  IBFITY,PBFIXV,
8929     1                  IPPLDP,IMETHD,IPPCBW,IPPCCC,IPPCFO,IDFTTY,
8930     1                  IPPCDP,IPPCAP,IPPCAO,PCHSLM,ILEVEL,IRTFPS,
8931     1                  STATVA,INLON2,ISUBN3,NLIST,
8932     1                  IBUGA3,ISUBRO,IERROR)
8933C
8934C     PURPOSE--PERFORM A "BEST FIT" ANALYSIS.  THAT IS, LOOP THROUGH
8935C              VARIOUS DISTRIBUTIONS AND RETURN A RANKED LIST OF
8936C              BEST FIT DISTRIBUTIONS.
8937C
8938C              NOTE THAT THIS IS CURRENTLY LIMITED TO UNGROUPED,
8939C              UNCENSORED, CONTINUOUS DISTRIBUTIONS
8940C
8941C              THERE ARE 2 USER-SPECIFIED OPTIONS:
8942C
8943C                  1) FIT METHOD:
8944C
8945C                     MAXIMUM LIKELIHOOD
8946C                     PPCC/ANDERSON DARLING/KOLM-SMIR/CHI-SQUARE
8947C
8948C                  2) RANKING CRITERION
8949C
8950C                     AIC/AICC/BIC
8951C                     PPCC
8952C                     ANDERSON DARLING
8953C                     KS
8954C                     CHI-SQUARE
8955C
8956C     WRITTEN BY--ALAN HECKERT
8957C                 STATISTICAL ENGINEERING DIVISION
8958C                 INFORMATION TECHNOLOGY LABORATORY
8959C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
8960C                 GAITHERSBURG, MD 20899-8980
8961C                 PHONE--301-975-2899
8962C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
8963C           OF THE NATIONAL BUREAU OF STANDARDS.
8964C     LANGUAGE--ANSI FORTRAN (1977)
8965C     VERSION NUMBER--2011/3
8966C     ORIGINAL VERSION--MARCH     2011.
8967C     UPDATED         --APRIL     2012. WRITE RESULTS TO DPST1F.DAT
8968C     UPDATED         --JANUARY   2013. OPTIONAL ADD 2 COLUMNS AT
8969C                                       REQUEST OF JEFF FONG
8970C     UPDATED         --MARCH     2013. FOR WEIBULL, ADJUST SCALE
8971C                                       PARAMETER IF GAUGE LENGTH
8972C                                       OPTION SPECIFIED
8973C     UPDATED         --JUNE      2013. IDENTIFY DISTRIBUTIONS THAT
8974C                                       REPORT LOWER/UPPER LIMIT RATHER
8975C                                       THAN LOCATION/SCALE
8976C     UPDATED         --JULY      2013. SOME TWEAKS TO "FONG" OPTION
8977C     UPDATED         --SEPTEMBER 2013. RESTORE TRIANGULAR FOR PPCC
8978C     UPDATED         --JANUARY   2014. BUG IN BOUNDED DISTRIBUTIONS
8979C                                       WHEN FIT BY PPCC BUT GOODNESS
8980C                                       OF FIT NOT PPCC
8981C     UPDATED         --JANUARY   2014. CHECK FOR "NAN" FOR GOODNESS
8982C                                       OF FIT STATISTIC
8983C     UPDATED         --APRIL     2014. SUPPORT 3-PARAMETER LOGNORMAL
8984C                                       FOR MAXIMUM LIKELIHOOD FIT
8985C     UPDATED         --MAY       2014. SUPPORT 2-PARAMETER AND 3-PARAMETER
8986C                                       INVERSE GAUSSIAN FOR MAXIMUM
8987C                                       LIKELIHOOD FIT
8988C     UPDATED         --JULY      2014. SUPPORT G DISTRIBUTION
8989C     UPDATED         --AUGUST    2014. NOW CALLED FROM DPDFP2 AS WELL,
8990C                                       FOR THIS CASE DO NOT SORT AND
8991C                                       DO NOT PRINT TABLE
8992C     UPDATED         --JULY      2019. CALL LIST TO DPPP2
8993C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE USE,
8994C                                       REMOVE ZTMP13, ZTMP14, ZTMP15
8995C     UPDATED         --APRIL     2020. ALLOW USER TO CONTROL LIST OF
8996C                                       DISTRIBUTIONS
8997C     UPDATED         --APRIL     2020. ADD HALF-NORMAL MAXIMUM
8998C                                       LIKELIHOOD
8999C
9000C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
9001C
9002      CHARACTER*4 ICASPL
9003      CHARACTER*4 ICASP2
9004      CHARACTER*4 ICASP3
9005      CHARACTER*4 IVARID(*)
9006      CHARACTER*4 IVARI2(*)
9007      CHARACTER*4 ICAPSW
9008      CHARACTER*4 ICAPTY
9009      CHARACTER*4 IFORSW
9010      CHARACTER*4 IBUGA3
9011      CHARACTER*4 ISUBRO
9012      CHARACTER*4 IWRITE
9013      CHARACTER*4 ICENSO
9014      CHARACTER*4 IADEDF
9015      CHARACTER*4 IGEPDF
9016      CHARACTER*4 IMAKDF
9017      CHARACTER*4 IBEIDF
9018      CHARACTER*4 ILGADF
9019      CHARACTER*4 ISKNDF
9020      CHARACTER*4 IGLDDF
9021      CHARACTER*4 IBGEDF
9022      CHARACTER*4 IGETDF
9023      CHARACTER*4 ICONDF
9024      CHARACTER*4 IGOMDF
9025      CHARACTER*4 IKATDF
9026      CHARACTER*4 IGIGDF
9027      CHARACTER*4 IGEODF
9028      CHARACTER*4 IGAUDF
9029      CHARACTER*4 IEXPBC
9030      CHARACTER*4 IWEIBC
9031      CHARACTER*4 ICENTY
9032      CHARACTER*4 IDFTTY
9033      CHARACTER*4 IDFTT2
9034      CHARACTER*4 IPPCCC
9035      CHARACTER*4 IPPCFO
9036      CHARACTER*4 IPPCAO
9037      CHARACTER*4 IPPCBW
9038      CHARACTER*4 IMETHD
9039      CHARACTER*4 ILEVEL
9040      CHARACTER*4 IBFIME
9041      CHARACTER*4 IBFICR
9042      CHARACTER*4 IBFIFO
9043      CHARACTER*4 IBFITY
9044      CHARACTER*4 IHSTCW
9045      CHARACTER*4 IHSTOU
9046      CHARACTER*4 IRELAT
9047      CHARACTER*4 IRHSTG
9048      CHARACTER*4 IERROR
9049C
9050      CHARACTER*4 IFLAGF
9051      CHARACTER*4 IADESV
9052      CHARACTER*4 IOP
9053      CHARACTER*4 IDATSW
9054      CHARACTER*4 ISUBN1
9055      CHARACTER*4 ISUBN2
9056      CHARACTER*4 ISUBN3
9057      CHARACTER*4 ISTEPN
9058C
9059      REAL KSLOC
9060      REAL KSSCAL
9061C
9062      DOUBLE PRECISION DM
9063C
9064C---------------------------------------------------------------------
9065C
9066      DIMENSION Y(*)
9067      DIMENSION CENSOR(*)
9068      DIMENSION XLEVEL(*)
9069      DIMENSION YSTAT(*)
9070      DIMENSION PID(*)
9071C
9072      DIMENSION TEMP1(*)
9073      DIMENSION TEMP2(*)
9074      DIMENSION TEMP3(*)
9075      DIMENSION ZTEMP1(*)
9076      DIMENSION ZTEMP2(*)
9077      DIMENSION ZTEMP3(*)
9078      DIMENSION ZTEMP4(*)
9079      DIMENSION ZTEMP5(*)
9080      DIMENSION ZTEMP6(*)
9081      DIMENSION ZTEMP7(*)
9082      DIMENSION ZTEMP8(*)
9083      DIMENSION ZTEMP9(*)
9084      DIMENSION ZTMP10(*)
9085      DIMENSION ZTMP11(*)
9086      DIMENSION ZTMP12(*)
9087      DIMENSION XLOW(*)
9088      DIMENSION XHIGH(*)
9089C
9090      DIMENSION CLLIMI(*)
9091      DIMENSION CLWIDT(*)
9092C
9093      DIMENSION STATVA(*)
9094C
9095      DOUBLE PRECISION DTEMP(*)
9096      DOUBLE PRECISION DTEMP2(*)
9097      DOUBLE PRECISION DTEMP3(*)
9098      INTEGER ITEMP1(*)
9099      INTEGER ITEMP2(*)
9100C
9101      INTEGER IPPCAP(2)
9102C
9103      PARAMETER (MAXDIS=64)
9104      DIMENSION SHAPV1(MAXDIS)
9105      DIMENSION SHAPV2(MAXDIS)
9106      DIMENSION SHAPV3(MAXDIS)
9107      DIMENSION SHAPV4(MAXDIS)
9108      DIMENSION SHAPV5(MAXDIS)
9109      DIMENSION ALOCV(MAXDIS)
9110      DIMENSION SCALEV(MAXDIS)
9111      DIMENSION DISTTA(MAXDIS)
9112      DIMENSION DISTZ(MAXDIS)
9113C
9114      DIMENSION INSHAP(MAXDIS)
9115      DIMENSION INTAIL(MAXDIS)
9116      DIMENSION IFLAG7(MAXDIS)
9117C
9118      CHARACTER*4 INCAST
9119      CHARACTER*4 INCASE(MAXDIS)
9120      CHARACTER*60 INLONG(MAXDIS)
9121      CHARACTER*60 INLON2(*)
9122      CHARACTER*60 IDIST
9123      CHARACTER*60 IDIST2
9124      CHARACTER*1  IBASLC
9125C
9126      PARAMETER(NUMCLI=8)
9127      PARAMETER(MAXLIN=3)
9128      PARAMETER (MAXROW=20)
9129      CHARACTER*60 ITITLE
9130      CHARACTER*60 ITITLZ
9131      CHARACTER*60 ITITL9
9132      CHARACTER*60 ITEXT(MAXROW)
9133      CHARACTER*4  ALIGN(NUMCLI)
9134      CHARACTER*4  VALIGN(NUMCLI)
9135      REAL         AVALUE(MAXROW)
9136      INTEGER      NCTEXT(MAXROW)
9137      INTEGER      IDIGIT(MAXROW)
9138      INTEGER      NTOT(MAXROW)
9139      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
9140      CHARACTER*25 IVALUE(MAXDIS,NUMCLI)
9141      CHARACTER*4  ITYPCO(NUMCLI)
9142      INTEGER      NCTIT2(MAXLIN,NUMCLI)
9143      INTEGER      NCVALU(MAXDIS,NUMCLI)
9144      INTEGER      IWHTML(NUMCLI)
9145      INTEGER      IWRTF(NUMCLI)
9146      REAL         AMAT(MAXDIS,NUMCLI)
9147      LOGICAL IFRST
9148      LOGICAL ILAST
9149      LOGICAL ISNANZ
9150C
9151      CHARACTER*4 IBFINO
9152      CHARACTER*4 IBFIUN
9153      CHARACTER*4 IBFI2B
9154      CHARACTER*4 IBFI4B
9155      CHARACTER*4 IBFIPW
9156      CHARACTER*4 IBFIRP
9157      CHARACTER*4 IBFIAR
9158      CHARACTER*4 IBFITR
9159      CHARACTER*4 IBFITO
9160      CHARACTER*4 IBFIRG
9161      CHARACTER*4 IBFITS
9162      CHARACTER*4 IBFINX
9163      CHARACTER*4 IBFGVX
9164      CHARACTER*4 IBFGVN
9165      CHARACTER*4 IBFGPX
9166      CHARACTER*4 IBFGPN
9167      CHARACTER*4 IBFIPA
9168      CHARACTER*4 IBFFRX
9169      CHARACTER*4 IBFFRN
9170      CHARACTER*4 IBFGUX
9171      CHARACTER*4 IBFGUN
9172      CHARACTER*4 IBFILO
9173      CHARACTER*4 IBFILL
9174      CHARACTER*4 IBFIHS
9175      CHARACTER*4 IBFIDX
9176      CHARACTER*4 IBFIAX
9177      CHARACTER*4 IBFIDW
9178      CHARACTER*4 IBFIDG
9179      CHARACTER*4 IBFITL
9180      CHARACTER*4 IBFIGT
9181      CHARACTER*4 IBFIER
9182      CHARACTER*4 IBFIGH
9183      CHARACTER*4 IBFIG
9184      CHARACTER*4 IBFISL
9185      CHARACTER*4 IBFICA
9186      CHARACTER*4 IBFICO
9187      CHARACTER*4 IBFIFN
9188      CHARACTER*4 IBFIHN
9189      CHARACTER*4 IBFIHL
9190      CHARACTER*4 IBFIBR
9191      CHARACTER*4 IBFIAN
9192      CHARACTER*4 IBFI2E
9193      CHARACTER*4 IBFI1E
9194      CHARACTER*4 IBFIRA
9195      CHARACTER*4 IBFIMX
9196      CHARACTER*4 IBF2WN
9197      CHARACTER*4 IBF2WX
9198      CHARACTER*4 IBF3WX
9199      CHARACTER*4 IBF3WN
9200      CHARACTER*4 IBFIIW
9201      CHARACTER*4 IBFI2L
9202      CHARACTER*4 IBFI3L
9203      CHARACTER*4 IBFIGA
9204      CHARACTER*4 IBFILG
9205      CHARACTER*4 IBFIIG
9206      CHARACTER*4 IBFIFL
9207      CHARACTER*4 IBFB10
9208      CHARACTER*4 IBFIWA
9209      CHARACTER*4 IBF2IG
9210      CHARACTER*4 IBF3IG
9211      CHARACTER*4 IBFILX
9212      CHARACTER*4 IBFILD
9213      CHARACTER*4 IBFIGX
9214      CHARACTER*4 IBF1HN
9215      CHARACTER*4 IBF2HN
9216      CHARACTER*4 IBF1HL
9217      CHARACTER*4 IBF2HL
9218      COMMON/CSETE/
9219     1IBFINO,IBFIUN,IBFI2B,IBFI4B,IBFIPW,IBFIRP,IBFIAR,IBFITR,IBFITO,
9220     1IBFIRG,IBFITS,IBFINX,IBFGVX,IBFGVN,IBFGPX,IBFGPN,IBFIPA,IBFFRX,
9221     1IBFFEN,IBFGUX,IBFGUN,IBFILO,IBFILL,IBFIHS,IBFIDX,IBFIAX,IBFIDW,
9222     1IBFIDG,IBFITL,IBFIGT,IBFIER,IBFIGH,IBFIG, IBFISL,IBFICA,IBFICO,
9223     1IBFIFN,IBFIHN,IBFIHL,IBFIBR,IBFIAN,IBFI2E,IBFI1E,IBFIRA,IBFIMX,
9224     1IBF3WX,IBF3WN,IBFIIW,IBFI2L,IBFI3L,IBFIGA,IBFILG,IBFIIG,IBFIFL,
9225     1IBFB10,IBFIWA,IBF2IG,IBF3IG,IBFILX,IBFILD,IBFIGX,IBFFRN,IBF2WN,
9226     1IBF2WX,IBF1HN,IBF2HN,IBF1HL,IBF2HL
9227C
9228C---------------------------------------------------------------------
9229C
9230      INCLUDE 'DPCOP2.INC'
9231C
9232C-----START POINT-----------------------------------------------------
9233C
9234      DATA INCASE(1)/'NORM'/
9235      DATA INLONG(1)/'NORMAL'/
9236      DATA INSHAP(1)/0/
9237      DATA INTAIL(1)/1/
9238C
9239      DATA INCASE(2)/'LOGI'/
9240      DATA INLONG(2)/'LOGISTIC'/
9241      DATA INSHAP(2)/0/
9242      DATA INTAIL(2)/1/
9243C
9244      DATA INCASE(3)/'HSEC'/
9245      DATA INLONG(3)/'HYPERBOLIC SECANT'/
9246      DATA INSHAP(3)/0/
9247      DATA INTAIL(3)/0/
9248C
9249      DATA INCASE(4)/'DEXP'/
9250      DATA INLONG(4)/'DOUBLE EXPONENTIAL'/
9251      DATA INSHAP(4)/0/
9252      DATA INTAIL(4)/1/
9253C
9254      DATA INCASE(5)/'ADEX'/
9255      DATA INLONG(5)/'ASYMM DOUBLE EXPO'/
9256      DATA INSHAP(5)/1/
9257      DATA INTAIL(5)/1/
9258C
9259      DATA INCASE(6)/'DWEI'/
9260      DATA INLONG(6)/'DOUBLE WEIBULL'/
9261      DATA INSHAP(6)/1/
9262      DATA INTAIL(6)/1/
9263C
9264      DATA INCASE(7)/'DGAM'/
9265      DATA INLONG(7)/'DOUBLE GAMMA'/
9266      DATA INSHAP(7)/1/
9267      DATA INTAIL(7)/1/
9268C
9269      DATA INCASE(8)/'TULA'/
9270      DATA INLONG(8)/'TUKEY-LAMBDA'/
9271      DATA INSHAP(8)/1/
9272      DATA INTAIL(8)/-1/
9273C
9274      DATA INCASE(9)/'GTLA'/
9275      DATA INLONG(9)/'GENE TUKEY LAMBDA'/
9276      DATA INSHAP(9)/2/
9277      DATA INTAIL(9)/-1/
9278C
9279      DATA INCASE(10)/'ERRO'/
9280      DATA INLONG(10)/'ERROR'/
9281      DATA INSHAP(10)/1/
9282      DATA INTAIL(10)/1/
9283C
9284      DATA INCASE(11)/'GPP'/
9285      DATA INLONG(11)/'G'/
9286      DATA INSHAP(11)/1/
9287      DATA INTAIL(11)/1/
9288C
9289      DATA INCASE(12)/'GHPP'/
9290      DATA INLONG(12)/'G AND H'/
9291      DATA INSHAP(12)/2/
9292      DATA INTAIL(12)/1/
9293C
9294      DATA INCASE(13)/'SLAS'/
9295      DATA INLONG(13)/'SLASH'/
9296      DATA INSHAP(13)/0/
9297      DATA INTAIL(13)/1/
9298C
9299      DATA INCASE(14)/'CAUC'/
9300      DATA INLONG(14)/'CAUCHY'/
9301      DATA INSHAP(14)/0/
9302      DATA INTAIL(14)/1/
9303C
9304      DATA INCASE(15)/'COSI'/
9305      DATA INLONG(15)/'COSINE'/
9306      DATA INSHAP(15)/0/
9307      DATA INTAIL(15)/0/
9308C
9309      DATA INCASE(16)/'ANGL'/
9310      DATA INLONG(16)/'ANGLIT'/
9311      DATA INSHAP(16)/0/
9312      DATA INTAIL(16)/0/
9313C
9314      DATA INCASE(17)/'EXPO'/
9315      DATA INLONG(17)/'2-PAR EXPONENTIAL'/
9316      DATA INSHAP(17)/0/
9317      DATA INTAIL(17)/0/
9318C
9319      DATA INCASE(18)/'RAYL'/
9320      DATA INLONG(18)/'RAYLEIGH'/
9321      DATA INSHAP(18)/0/
9322      DATA INTAIL(18)/0/
9323C
9324      DATA INCASE(19)/'MAXW'/
9325      DATA INLONG(19)/'MAXWELL'/
9326      DATA INSHAP(19)/0/
9327      DATA INTAIL(19)/0/
9328C
9329      DATA INCASE(20)/'WEIB'/
9330      DATA INLONG(20)/'2-PAR WEIBULL (MINIMUM)'/
9331      DATA INSHAP(20)/1/
9332      DATA INTAIL(20)/0/
9333C
9334      DATA INCASE(21)/'WEIB'/
9335      DATA INLONG(21)/'2-PAR WEIBULL (MAXIMUM)'/
9336      DATA INSHAP(21)/1/
9337      DATA INTAIL(21)/0/
9338C
9339      DATA INCASE(22)/'3WEI'/
9340      DATA INLONG(22)/'3-PAR WEIBULL (MINIMUM)'/
9341      DATA INSHAP(22)/1/
9342      DATA INTAIL(22)/0/
9343C
9344      DATA INCASE(23)/'3WEI'/
9345      DATA INLONG(23)/'3-PAR WEIBULL (MAXIMUM)'/
9346      DATA INSHAP(23)/1/
9347      DATA INTAIL(23)/0/
9348C
9349      DATA INCASE(24)/'IWEI'/
9350      DATA INLONG(24)/'INVERTED WEIBULL'/
9351      DATA INSHAP(24)/1/
9352      DATA INTAIL(24)/0/
9353C
9354      DATA INCASE(25)/'LOGN'/
9355      DATA INLONG(25)/'2-PAR LOGNORMAL'/
9356      DATA INSHAP(25)/1/
9357      DATA INTAIL(25)/0/
9358C
9359      DATA INCASE(26)/'3LGN'/
9360      DATA INLONG(26)/'3-PAR LOGNORMAL'/
9361      DATA INSHAP(26)/1/
9362      DATA INTAIL(26)/0/
9363C
9364      DATA INCASE(27)/'GAMM'/
9365      DATA INLONG(27)/'GAMMA'/
9366      DATA INSHAP(27)/1/
9367      DATA INTAIL(27)/0/
9368C
9369      DATA INCASE(28)/'LGAM'/
9370      DATA INLONG(28)/'LOG GAMMA'/
9371      DATA INSHAP(28)/1/
9372      DATA INTAIL(28)/0/
9373C
9374      DATA INCASE(29)/'IGAM'/
9375      DATA INLONG(29)/'INVERTED GAMMA'/
9376      DATA INSHAP(29)/1/
9377      DATA INTAIL(29)/0/
9378C
9379      DATA INCASE(30)/'FATL'/
9380      DATA INLONG(30)/'BIRNBAUM SAUNDERS'/
9381      DATA INSHAP(30)/1/
9382      DATA INTAIL(30)/0/
9383C
9384      DATA INCASE(31)/'BU10'/
9385      DATA INLONG(31)/'BURR TYPE 10'/
9386      DATA INSHAP(31)/1/
9387      DATA INTAIL(31)/0/
9388C
9389      DATA INCASE(32)/'WALD'/
9390      DATA INLONG(32)/'WALD'/
9391      DATA INSHAP(32)/1/
9392      DATA INTAIL(32)/0/
9393C
9394      DATA INCASE(33)/'INGA'/
9395      DATA INLONG(33)/'2-PAR INVERSE GAUSSIAN'/
9396      DATA INSHAP(33)/2/
9397      DATA INTAIL(33)/0/
9398C
9399      DATA INCASE(34)/'3IGA'/
9400      DATA INLONG(34)/'3-PAR INVERSE GAUSSIAN'/
9401      DATA INSHAP(34)/2/
9402      DATA INTAIL(34)/0/
9403C
9404      DATA INCASE(35)/'LEXP'/
9405      DATA INLONG(35)/'LOGISTIC EXPONENTIAL'/
9406      DATA INSHAP(35)/1/
9407      DATA INTAIL(35)/0/
9408C
9409      DATA INCASE(36)/'LDEX'/
9410      DATA INLONG(36)/'LOG DOUBLE EXPONENTIAL'/
9411      DATA INSHAP(36)/1/
9412      DATA INTAIL(36)/0/
9413C
9414      DATA INCASE(37)/'GEEX'/
9415      DATA INLONG(37)/'GEOM EXTREME EXPONENTIAL'/
9416      DATA INSHAP(37)/1/
9417      DATA INTAIL(37)/0/
9418C
9419      DATA INCASE(38)/'LOGL'/
9420      DATA INLONG(38)/'LOG LOGISTIC'/
9421      DATA INSHAP(38)/1/
9422      DATA INTAIL(38)/0/
9423C
9424      DATA INCASE(39)/'BRAD'/
9425      DATA INLONG(39)/'BRADFORD'/
9426      DATA INSHAP(39)/1/
9427      DATA INTAIL(39)/0/
9428C
9429      DATA INCASE(40)/'HNOR'/
9430      DATA INLONG(40)/'HALF-NORMAL'/
9431      DATA INSHAP(40)/0/
9432      DATA INTAIL(40)/0/
9433C
9434      DATA INCASE(41)/'1HNO'/
9435      DATA INLONG(41)/'1 PARAMETER HALF-NORMAL'/
9436      DATA INSHAP(41)/0/
9437      DATA INTAIL(41)/0/
9438C
9439      DATA INCASE(42)/'FNOR'/
9440      DATA INLONG(42)/'FOLDED NORMAL'/
9441      DATA INSHAP(42)/1/
9442      DATA INTAIL(42)/0/
9443C
9444      DATA INCASE(43)/'EV1'/
9445      DATA INLONG(43)/'GUMBEL (MININUM)'/
9446      DATA INSHAP(43)/0/
9447      DATA INTAIL(43)/1/
9448C
9449      DATA INCASE(44)/'EV1'/
9450      DATA INLONG(44)/'GUMBEL (MAXIMUM)'/
9451      DATA INSHAP(44)/0/
9452      DATA INTAIL(44)/1/
9453C
9454      DATA INCASE(45)/'EV2'/
9455      DATA INLONG(45)/'FRECHET (MINIMUM)'/
9456      DATA INSHAP(45)/1/
9457      DATA INTAIL(45)/0/
9458C
9459      DATA INCASE(46)/'EV2'/
9460      DATA INLONG(46)/'FRECHET (MAXIMUM)'/
9461      DATA INSHAP(46)/1/
9462      DATA INTAIL(46)/0/
9463C
9464      DATA INCASE(47)/'PARE'/
9465      DATA INLONG(47)/'PARETO'/
9466      DATA INSHAP(47)/2/
9467      DATA INTAIL(47)/0/
9468C
9469      DATA INCASE(48)/'GPAR'/
9470      DATA INLONG(48)/'GENE PARETO (MIN)'/
9471      DATA INSHAP(48)/1/
9472      DATA INTAIL(48)/-1/
9473C
9474      DATA INCASE(49)/'GPAR'/
9475      DATA INLONG(49)/'GENE PARETO (MAX)'/
9476      DATA INSHAP(49)/1/
9477      DATA INTAIL(49)/-1/
9478C
9479      DATA INCASE(50)/'GEV '/
9480      DATA INLONG(50)/'GENE EXT VAL (MIN)'/
9481      DATA INSHAP(50)/1/
9482      DATA INTAIL(50)/-1/
9483C
9484      DATA INCASE(51)/'GEV '/
9485      DATA INLONG(51)/'GENE EXT VAL (MAX)'/
9486      DATA INSHAP(51)/1/
9487      DATA INTAIL(51)/-1/
9488C
9489      DATA INCASE(52)/'UNIF'/
9490      DATA INLONG(52)/'UNIFORM'/
9491      DATA INSHAP(52)/0/
9492      DATA INTAIL(52)/0/
9493C
9494      DATA INCASE(53)/'BETA'/
9495      DATA INLONG(53)/'2-PAR BETA'/
9496      DATA INSHAP(53)/2/
9497      DATA INTAIL(53)/0/
9498C
9499      DATA INCASE(54)/'4BET'/
9500      DATA INLONG(54)/'4-PAR BETA (MOMENTS)'/
9501      DATA INSHAP(54)/4/
9502      DATA INTAIL(54)/0/
9503C
9504      DATA INCASE(55)/'POWF'/
9505      DATA INLONG(55)/'POWER'/
9506      DATA INSHAP(55)/1/
9507      DATA INTAIL(55)/0/
9508C
9509      DATA INCASE(56)/'RPOW'/
9510      DATA INLONG(56)/'REFLECTED POWER'/
9511      DATA INSHAP(56)/1/
9512      DATA INTAIL(56)/0/
9513C
9514      DATA INCASE(57)/'ARSI'/
9515      DATA INLONG(57)/'ARCSINE'/
9516      DATA INSHAP(57)/0/
9517      DATA INTAIL(57)/0/
9518C
9519      DATA INCASE(58)/'TRIA'/
9520      DATA INLONG(58)/'TRIANGULAR'/
9521      DATA INSHAP(58)/1/
9522      DATA INTAIL(58)/0/
9523C
9524      DATA INCASE(59)/'TOPL'/
9525      DATA INLONG(59)/'TOPP AND LEONE'/
9526      DATA INSHAP(59)/1/
9527      DATA INTAIL(59)/0/
9528C
9529      DATA INCASE(60)/'RGTL'/
9530      DATA INLONG(60)/'REFL GENE TOPP AND LEONE'/
9531      DATA INSHAP(60)/2/
9532      DATA INTAIL(60)/0/
9533C
9534      DATA INCASE(61)/'TSPO'/
9535      DATA INLONG(61)/'TWO-SIDED POWER'/
9536      DATA INSHAP(61)/2/
9537      DATA INTAIL(61)/0/
9538C
9539      DATA INCASE(62)/'NORX'/
9540      DATA INLONG(62)/'2-COMP NORMAL MIXTURE'/
9541      DATA INSHAP(62)/5/
9542      DATA INTAIL(62)/1/
9543C
9544      DATA INCASE(63)/'HALO'/
9545      DATA INLONG(63)/'HALF-LOGISTIC'/
9546      DATA INSHAP(63)/0/
9547      DATA INTAIL(63)/0/
9548C
9549      DATA INCASE(64)/'1HAL'/
9550      DATA INLONG(64)/'1 PARAMETER HALF-LOGISTIC'/
9551      DATA INSHAP(64)/0/
9552      DATA INTAIL(64)/0/
9553C
9554      ISUBN1='DPBE'
9555      ISUBN2='F2  '
9556      IERROR='NO'
9557      ICENSO='OFF'
9558      IRELAT='OFF'
9559      MINMX2=MINMAX
9560      IDFTT2=IDFTTY
9561      IDATSW='RAW'
9562      IADESV=IADEDF
9563C
9564      ALOW=0.0
9565C
9566      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
9567        WRITE(ICOUT,999)
9568        CALL DPWRST('XXX','BUG ')
9569        WRITE(ICOUT,71)
9570   71   FORMAT('***** AT THE BEGINNING OF DPBEF2--')
9571        CALL DPWRST('XXX','BUG ')
9572        WRITE(ICOUT,72)ICASPL,ICASP2,N,MAXV
9573   72   FORMAT('ICASPL,ICASP2,N,MAXV = ',2(A4,2X),2I8)
9574        CALL DPWRST('XXX','BUG ')
9575        WRITE(ICOUT,75)IDFTTY,IBFICR,IBFIME
9576   75   FORMAT('IDFTTY,IBFICR,IBFIME = ',2(A4,2X),A4)
9577        CALL DPWRST('XXX','BUG ')
9578        IF(N.GE.1)THEN
9579          DO85I=1,N
9580            WRITE(ICOUT,86)I,Y(I)
9581   86       FORMAT('I,Y(I) = ',I8,G15.7)
9582            CALL DPWRST('XXX','BUG ')
9583   85     CONTINUE
9584        ENDIF
9585      ENDIF
9586C
9587C               ********************************************
9588C               **  STEP 1--                              **
9589C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
9590C               ********************************************
9591C
9592      ISTEPN='1'
9593      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')
9594     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9595C
9596      IF(N.LT.5)THEN
9597        WRITE(ICOUT,999)
9598  999   FORMAT(1X)
9599        CALL DPWRST('XXX','BUG ')
9600        WRITE(ICOUT,31)
9601   31   FORMAT('***** ERROR IN BEST DISTRIBUTIONAL FIT--')
9602        CALL DPWRST('XXX','BUG ')
9603        WRITE(ICOUT,32)
9604   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 5.')
9605        CALL DPWRST('XXX','BUG ')
9606        WRITE(ICOUT,34)N
9607   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS = ',I6)
9608        CALL DPWRST('XXX','BUG ')
9609        WRITE(ICOUT,999)
9610        CALL DPWRST('XXX','BUG ')
9611        IERROR='YES'
9612        GOTO9000
9613      ENDIF
9614C
9615      HOLD=Y(1)
9616      DO60I=1,N
9617        IF(Y(I).NE.HOLD)GOTO69
9618   60 CONTINUE
9619      WRITE(ICOUT,999)
9620      CALL DPWRST('XXX','BUG ')
9621      WRITE(ICOUT,31)
9622      CALL DPWRST('XXX','BUG ')
9623      WRITE(ICOUT,62)HOLD
9624   62 FORMAT('      ALL ELEMENTS OF THE RESPONSE VARIABLE ARE ',
9625     1       'IDENTICALLY EQUAL TO ',G15.7)
9626
9627      CALL DPWRST('XXX','BUG ')
9628      WRITE(ICOUT,999)
9629      CALL DPWRST('XXX','BUG ')
9630      IERROR='YES'
9631      GOTO9000
9632   69 CONTINUE
9633C
9634C               ********************************************
9635C               **  STEP 2--                              **
9636C               **  COMPUTE SUMMARY STATISTICS            **
9637C               ********************************************
9638C
9639      ISTEPN='2'
9640      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')
9641     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9642C
9643      IDIST='BEST FIT DISTRIBUTION'
9644      IFLAG=0
9645      CALL SUMRAW(Y,N,IDIST,IFLAG,
9646     1            XMEAN,XVAR,XSD,XMIN,XMAX,
9647     1            ISUBRO,IBUGA3,IERROR)
9648      CALL STMOM3(Y,N,IWRITE,XSKEW,IBUGA3,IERROR)
9649      CALL MEDIAN(Y,N,IWRITE,TEMP1,MAXOBV,XMED,IBUGA3,IERROR)
9650C
9651      DO190I=1,MAXOBV
9652        ITEMP2(I)=I
9653  190 CONTINUE
9654C
9655      CALL SORT(Y,N,Y)
9656      DO195I=1,N
9657        ZTMP12(I)=Y(I)
9658  195 CONTINUE
9659C
9660      YLOWLS=YLOWLM
9661      YUPPLS=YUPPLM
9662C
9663C               *************************************************
9664C               **  STEP 3--                                   **
9665C               **  LOOP THROUGH THE DISTRIBUTIONS:            **
9666C               **    1) ESTIMATE DISTRIBUTION PARAMETERS      **
9667C               **    2) BASED ON FIT, EXTRACT GOODNESS OF FIT **
9668C               **       STATISTIC                             **
9669C               *************************************************
9670C
9671      NLIST=0
9672      DO200KDIST=1,MAXDIS
9673C
9674        NLIST=NLIST+1
9675        SHAPV1(KDIST)=CPUMIN
9676        SHAPV2(KDIST)=CPUMIN
9677        SHAPV3(KDIST)=CPUMIN
9678        SHAPV4(KDIST)=CPUMIN
9679        SHAPV5(KDIST)=CPUMIN
9680        ALOCV(KDIST)=CPUMIN
9681        SCALEV(KDIST)=CPUMIN
9682        STATVA(KDIST)=CPUMIN
9683        DISTTA(KDIST)=REAL(INTAIL(KDIST))
9684        DISTZ(KDIST)=CPUMIN
9685        ICASP2=INCASE(KDIST)
9686        A=CPUMIN
9687        B=CPUMIN
9688        IDFTTY='ML'
9689        INLON2(KDIST)=INLONG(KDIST)
9690C
9691C       2020/04: SKIP BASED ON USER-SUPPLIED SPECIFICATIONS
9692C
9693        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
9694          WRITE(ICOUT,999)
9695          CALL DPWRST('XXX','BUG ')
9696          WRITE(ICOUT,81)KDIST,INCASE(KDIST),INLONG(KDIST)
9697   81     FORMAT('KDIST,INCASE(KDIST),INLONG(KDIST) = ',
9698     1           I5,2X,A4,2X,A60)
9699          CALL DPWRST('XXX','BUG ')
9700        ENDIF
9701C
9702        IF(INCASE(KDIST).EQ.'NORM' .AND. IBFINO.EQ.'OFF')GOTO200
9703        IF(INCASE(KDIST).EQ.'LOGI' .AND. IBFILO.EQ.'OFF')GOTO200
9704        IF(INCASE(KDIST).EQ.'HSEC' .AND. IBFIHS.EQ.'OFF')GOTO200
9705        IF(INCASE(KDIST).EQ.'DEXP' .AND. IBFIDX.EQ.'OFF')GOTO200
9706        IF(INCASE(KDIST).EQ.'ADEX' .AND. IBFIAX.EQ.'OFF')GOTO200
9707        IF(INCASE(KDIST).EQ.'DWEI' .AND. IBFIDW.EQ.'OFF')GOTO200
9708        IF(INCASE(KDIST).EQ.'DGAM' .AND. IBFIDG.EQ.'OFF')GOTO200
9709        IF(INCASE(KDIST).EQ.'TULA' .AND. IBFITL.EQ.'OFF')GOTO200
9710        IF(INCASE(KDIST).EQ.'GTLA' .AND. IBFIGT.EQ.'OFF')GOTO200
9711        IF(INCASE(KDIST).EQ.'ERRO' .AND. IBFIER.EQ.'OFF')GOTO200
9712        IF(INCASE(KDIST).EQ.'GPP ' .AND. IBFIG .EQ.'OFF')GOTO200
9713        IF(INCASE(KDIST).EQ.'GHPP' .AND. IBFIGH.EQ.'OFF')GOTO200
9714        IF(INCASE(KDIST).EQ.'SLAS' .AND. IBFISL.EQ.'OFF')GOTO200
9715        IF(INCASE(KDIST).EQ.'CAUC' .AND. IBFICA.EQ.'OFF')GOTO200
9716        IF(INCASE(KDIST).EQ.'COSI' .AND. IBFICO.EQ.'OFF')GOTO200
9717        IF(INCASE(KDIST).EQ.'ANGL' .AND. IBFIAN.EQ.'OFF')GOTO200
9718        IF(INCASE(KDIST).EQ.'EXPO' .AND. IBFI2E.EQ.'OFF')GOTO200
9719        IF(INCASE(KDIST).EQ.'RAYL' .AND. IBFIRA.EQ.'OFF')GOTO200
9720        IF(INCASE(KDIST).EQ.'MAXW' .AND. IBFIMX.EQ.'OFF')GOTO200
9721C
9722        IF(INLONG(KDIST)(1:23).EQ.'2-PAR WEIBULL (MINIMUM)' .AND.
9723     1     IBF2WN.EQ.'OFF')GOTO200
9724        IF(INLONG(KDIST)(1:23).EQ.'2-PAR WEIBULL (MAXIMUM)' .AND.
9725     1     IBF2WX.EQ.'OFF')GOTO200
9726C
9727        IF(INLONG(KDIST)(1:23).EQ.'3-PAR WEIBULL (MINIMUM)' .AND.
9728     1     IBF3WN.EQ.'OFF')GOTO200
9729        IF(INLONG(KDIST)(1:23).EQ.'3-PAR WEIBULL (MAXIMUM)' .AND.
9730     1     IBF3WX.EQ.'OFF')GOTO200
9731C
9732        IF(INLONG(KDIST)(1:16).EQ.'GUMBEL (MINIMUM)' .AND.
9733     1     IBFGUN.EQ.'OFF')GOTO200
9734        IF(INLONG(KDIST)(1:16).EQ.'GUMBEL (MAXIMUM)' .AND.
9735     1     IBFGUX.EQ.'OFF')GOTO200
9736C
9737        IF(INLONG(KDIST)(1:17).EQ.'FRECHET (MINIMUM)' .AND.
9738     1     IBFFRN.EQ.'OFF')GOTO200
9739        IF(INLONG(KDIST)(1:17).EQ.'FRECHET (MAXIMUM)' .AND.
9740     1     IBFFRX.EQ.'OFF')GOTO200
9741C
9742        IF(INLONG(KDIST)(1:17).EQ.'GENE PARETO (MIN)' .AND.
9743     1     IBFGPN.EQ.'OFF')GOTO200
9744        IF(INLONG(KDIST)(1:17).EQ.'GENE PARETO (MAX)' .AND.
9745     1     IBFGPX.EQ.'OFF')GOTO200
9746C
9747        IF(INLONG(KDIST)(1:18).EQ.'GENE EXT VAL (MIN)' .AND.
9748     1     IBFGVN.EQ.'OFF')GOTO200
9749        IF(INLONG(KDIST)(1:18).EQ.'GENE EXT VAL (MAX)' .AND.
9750     1     IBFGVX.EQ.'OFF')GOTO200
9751C
9752        IF(INCASE(KDIST).EQ.'IWEI' .AND. IBFIIW.EQ.'OFF')GOTO200
9753        IF(INCASE(KDIST).EQ.'LOGN' .AND. IBFI2L.EQ.'OFF')GOTO200
9754        IF(INCASE(KDIST).EQ.'3LGN' .AND. IBFI3L.EQ.'OFF')GOTO200
9755        IF(INCASE(KDIST).EQ.'GAMM' .AND. IBFIGA.EQ.'OFF')GOTO200
9756        IF(INCASE(KDIST).EQ.'LGAM' .AND. IBFILG.EQ.'OFF')GOTO200
9757        IF(INCASE(KDIST).EQ.'IGAM' .AND. IBFIIG.EQ.'OFF')GOTO200
9758        IF(INCASE(KDIST).EQ.'FATL' .AND. IBFIFL.EQ.'OFF')GOTO200
9759        IF(INCASE(KDIST).EQ.'BU10' .AND. IBFB10.EQ.'OFF')GOTO200
9760        IF(INCASE(KDIST).EQ.'WALD' .AND. IBFIWA.EQ.'OFF')GOTO200
9761        IF(INCASE(KDIST).EQ.'INGA' .AND. IBF2IG.EQ.'OFF')GOTO200
9762        IF(INCASE(KDIST).EQ.'3IGA' .AND. IBF3IG.EQ.'OFF')GOTO200
9763        IF(INCASE(KDIST).EQ.'LEXP' .AND. IBFILX.EQ.'OFF')GOTO200
9764        IF(INCASE(KDIST).EQ.'LDEX' .AND. IBFILD.EQ.'OFF')GOTO200
9765        IF(INCASE(KDIST).EQ.'GEEX' .AND. IBFIGX.EQ.'OFF')GOTO200
9766        IF(INCASE(KDIST).EQ.'LOGL' .AND. IBFILL.EQ.'OFF')GOTO200
9767        IF(INCASE(KDIST).EQ.'BRAD' .AND. IBFIBR.EQ.'OFF')GOTO200
9768        IF(INCASE(KDIST).EQ.'HNOR' .AND. IBF2HN.EQ.'OFF')GOTO200
9769        IF(INCASE(KDIST).EQ.'1HNO' .AND. IBF1HN.EQ.'OFF')GOTO200
9770        IF(INCASE(KDIST).EQ.'HALO' .AND. IBF2HL.EQ.'OFF')GOTO200
9771        IF(INCASE(KDIST).EQ.'1HAL' .AND. IBF1HL.EQ.'OFF')GOTO200
9772        IF(INCASE(KDIST).EQ.'FNOR' .AND. IBFIFN.EQ.'OFF')GOTO200
9773        IF(INCASE(KDIST).EQ.'PARE' .AND. IBFIPA.EQ.'OFF')GOTO200
9774        IF(INCASE(KDIST).EQ.'UNIF' .AND. IBFIUN.EQ.'OFF')GOTO200
9775        IF(INCASE(KDIST).EQ.'BETA' .AND. IBFI2B.EQ.'OFF')GOTO200
9776        IF(INCASE(KDIST).EQ.'4BET' .AND. IBFI4B.EQ.'OFF')GOTO200
9777        IF(INCASE(KDIST).EQ.'POWF' .AND. IBFIPW.EQ.'OFF')GOTO200
9778        IF(INCASE(KDIST).EQ.'RPOW' .AND. IBFIRP.EQ.'OFF')GOTO200
9779        IF(INCASE(KDIST).EQ.'ARSI' .AND. IBFIAR.EQ.'OFF')GOTO200
9780        IF(INCASE(KDIST).EQ.'TRIA' .AND. IBFITR.EQ.'OFF')GOTO200
9781        IF(INCASE(KDIST).EQ.'TOPL' .AND. IBFITO.EQ.'OFF')GOTO200
9782        IF(INCASE(KDIST).EQ.'RGTL' .AND. IBFIRG.EQ.'OFF')GOTO200
9783        IF(INCASE(KDIST).EQ.'TSPO' .AND. IBFITS.EQ.'OFF')GOTO200
9784        IF(INCASE(KDIST).EQ.'NORX' .AND. IBFINX.EQ.'OFF')GOTO200
9785C
9786        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
9787          WRITE(ICOUT,83)
9788   83     FORMAT('PASSED INDIVIDUAL TESTS')
9789          CALL DPWRST('XXX','BUG ')
9790        ENDIF
9791C
9792C       SET FLAG FOR DISTRIBUTIONS THAT REPORT LOWER/UPPER LIMIT
9793C       RATHER THAN LOCATION/SCALE
9794C
9795C           1. UNIFORM                               = 52
9796C           2. 2-PARAMETER BETA                      = 53
9797C           3. 4-PARAMETER BETA (MOMENTS)            = 54
9798C           4. POWER                                 = 55
9799C           5. REFLECTED POWER                       = 56
9800C           6. TRIANGULAR                            = 58
9801C           7. TOPP AND LEONE                        = 59
9802C           8. REFLECTED GENERALIZED TOPP AND LEONE  = 60
9803C           9. TWO-SIDED POWER                       = 61
9804C
9805C       NOTE THAT FOR THESE DISTRIBUTIONS, THE BIC CAN GIVE DISTORTED
9806C       VALUES (ESPECIALLY FOR U-SHAPED DISTRIBUTIONS).  SO FOR SOME
9807C       OF THESE, SUPPRESS IF LOWER/UPPER LIMITS NOT ESTIMATED FROM
9808C       DATA (UNLESS USER SUPPLIES VALUES FOR THESE).  USER SUPPLIED
9809C       ESTIMATES ARE GIVEN IN YLOWLM AND YUPPLM.
9810C
9811        IFLAG8=0
9812        IFLAG6=0
9813        IFLAG7(KDIST)=0
9814        IF(KDIST.EQ.52)IFLAG7(KDIST)=1
9815        IF(KDIST.EQ.53)IFLAG7(KDIST)=1
9816        IF(KDIST.EQ.54)IFLAG7(KDIST)=1
9817        IF(KDIST.EQ.55)IFLAG7(KDIST)=1
9818        IF(KDIST.EQ.56)IFLAG7(KDIST)=1
9819        IF(KDIST.EQ.58)IFLAG7(KDIST)=1
9820        IF(KDIST.EQ.59)IFLAG7(KDIST)=1
9821        IF(KDIST.EQ.60)IFLAG7(KDIST)=1
9822        IF(KDIST.EQ.61)IFLAG7(KDIST)=1
9823C
9824        IF(KDIST.EQ.59 .OR. KDIST.EQ.55 .OR. KDIST.EQ.56 .OR.
9825     1     KDIST.EQ.53 .OR. KDIST.EQ.60 .OR. KDIST.EQ.61) THEN
9826          IF(PBFILL.NE.CPUMIN .AND. PBFIUL.NE.CPUMIN)THEN
9827            IF(PBFILL.LT.XMIN .AND. PBFIUL.GT.XMAX)THEN
9828              IFLAG6=0
9829            ELSE
9830              IFLAG6=1
9831            ENDIF
9832          ELSE
9833            IFLAG6=1
9834          ENDIF
9835        ENDIF
9836C
9837        IF(IFLAG6.EQ.1)THEN
9838          YLOWLM=YLOWLS
9839          YUPPLM=YUPPLS
9840        ELSE
9841          YLOWLM=CPUMIN
9842          YUPPLM=CPUMIN
9843        ENDIF
9844C
9845C       STEP 1: FIT THE DISTRIBUTION
9846C
9847        ISTEPN='3A'
9848        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
9849          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9850          WRITE(ICOUT,201)KDIST
9851  201     FORMAT('KDIST = ',I5)
9852          CALL DPWRST('XXX','BUG ')
9853          WRITE(ICOUT,202)INLONG(KDIST)(1:25)
9854  202     FORMAT('INLONG(KDIST) = ',A25)
9855          CALL DPWRST('XXX','BUG ')
9856        ENDIF
9857C
9858        INCAST=INCASE(KDIST)
9859        NSHAPE=INSHAP(KDIST)
9860        MINMAX=1
9861        IF(KDIST.EQ.21)MINMAX=2
9862        IF(KDIST.EQ.23)MINMAX=2
9863        IF(KDIST.EQ.44)MINMAX=2
9864        IF(KDIST.EQ.46)MINMAX=2
9865        IF(KDIST.EQ.49)MINMAX=2
9866        IF(KDIST.EQ.51)MINMAX=2
9867C
9868        IF(KDIST.EQ.24)THEN
9869          IF(IBFIME.EQ.'ML')THEN
9870            INLON2(24)='2-PAR INVERTED WEIBULL'
9871          ELSEIF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD' .OR.
9872     1           IBFIME.EQ.'KS'   .OR. IBFIME.EQ.'CHSQ')THEN
9873            INLON2(24)='3-PAR INVERTED WEIBULL'
9874          ENDIF
9875C
9876C       IF GENERALIZED PARETO FIT BY PPCC, MAY HAVE PROBLEMS
9877C       WITH LOG-LIKELIHOOD FUNCTION.  SO SKIP IF FIT BY PPCC
9878C       AND RANK WITH AIC.
9879C
9880        ELSEIF(KDIST.EQ.48 .OR. KDIST.EQ.49)THEN
9881          IF(IBFICR.EQ.'AIC')THEN
9882            IF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD' .OR.
9883     1         IBFIME.EQ.'KS'   .OR. IBFIME.EQ.'CHSQ')THEN
9884              GOTO200
9885            ENDIF
9886          ENDIF
9887        ELSEIF(KDIST.EQ.45)THEN
9888          IF(IBFIME.EQ.'ML')THEN
9889            INLON2(44)='2-PAR FRECHET (MIN)'
9890          ELSEIF(IBFIME.EQ.'PPCC')THEN
9891            INLON2(44)='3-PAR FRECHET (MIN)'
9892          ENDIF
9893        ELSEIF(KDIST.EQ.46)THEN
9894          IF(IBFIME.EQ.'ML')THEN
9895            INLON2(45)='2-PAR FRECHET (MAX)'
9896          ELSEIF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD' .OR.
9897     1           IBFIME.EQ.'KS'   .OR. IBFIME.EQ.'CHSQ')THEN
9898            INLON2(45)='3-PAR FRECHET (MAX)'
9899          ENDIF
9900        ELSEIF(KDIST.EQ.27)THEN
9901          IF(IBFIME.EQ.'ML')THEN
9902            INLON2(27)='2-PAR GAMMA'
9903          ELSEIF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD' .OR.
9904     1           IBFIME.EQ.'KS'   .OR. IBFIME.EQ.'CHSQ')THEN
9905            INLON2(27)='3-PAR GAMMA'
9906          ENDIF
9907        ELSEIF(KDIST.EQ.29)THEN
9908          IF(IBFIME.EQ.'ML')THEN
9909            INLON2(29)='2-PAR INVERTED GAMMA'
9910          ELSEIF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD' .OR.
9911     1           IBFIME.EQ.'KS'   .OR. IBFIME.EQ.'CHSQ')THEN
9912            INLON2(29)='3-PAR INVERTED GAMMA'
9913          ENDIF
9914        ELSEIF(KDIST.EQ.37)THEN
9915          IF(IBFIME.EQ.'ML')THEN
9916            INLON2(37)='2-PAR GEOM EXTREME EXPO'
9917          ELSEIF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD' .OR.
9918     1           IBFIME.EQ.'KS'   .OR. IBFIME.EQ.'CHSQ')THEN
9919            INLON2(37)='3-PAR GEOM EXTREME EXPO'
9920          ENDIF
9921        ELSEIF(KDIST.EQ.19)THEN
9922          IF(IBFIME.EQ.'ML')THEN
9923            ICASP2='1MAX'
9924            INLON2(19)='1-PAR MAXWELL'
9925          ELSEIF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD' .OR.
9926     1           IBFIME.EQ.'KS'   .OR. IBFIME.EQ.'CHSQ')THEN
9927            INLON2(19)='2-PAR MAXWELL'
9928          ENDIF
9929        ELSEIF(KDIST.EQ.31)THEN
9930          IF(IBFIME.EQ.'ML')THEN
9931            INLON2(31)='2-PAR BURR TYPE 10'
9932          ELSEIF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD' .OR.
9933     1           IBFIME.EQ.'KS'   .OR. IBFIME.EQ.'CHSQ')THEN
9934            INLON2(31)='3-PAR BURR TYPE 10'
9935          ENDIF
9936        ENDIF
9937C
9938        DO206I=1,N
9939          Y(I)=ZTMP12(I)
9940  206   CONTINUE
9941C
9942C       CASE 1: FIT VIA PPCC.
9943C
9944C               2016/07: ADD AD, KS AND CHI-SQUARE TO THIS
9945C
9946C                        NOTE THAT FOR LOCATION/SCALE DISTRIBUTIONS,
9947C                        THESE REVERT TO PPCC SINCE WE ARE USING THE
9948C                        PROBABILITY PLOT TO DETERMINE THE LOCATION/
9949C                        SCALE PARAMETERS.  THE ALTERNATIVE GOODNESS
9950C                        OF FIT STATISTICS ARE USED TO OPTIMIZE THE
9951C                        VALUE OF THE SHAPE PARAMETER(S).
9952C
9953C                        NOTE THAT THE CHI-SQUARE METHOD WILL
9954C                        AUTOMATICALLY BIN THE DATA.
9955C
9956C               CURRENTLY SUPPORT:
9957C
9958C               1) LOCATION/SCALE DISTRIBUTIONS - OBTAIN PARAMETER
9959C                  ESTIMATES FROM PROBABILITY PLOT
9960C
9961C               2) DISTRIBUTIONS WITH ONE SHAPE PARAMETER - OBTAIN
9962C                  SHAPE PARAMETER FROM PPCC PLOT AND THEN LOCATION/
9963C                  SCALE ESTIMATES FROM PROBABILITY PLOT.
9964C
9965        IF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD  ' .OR.
9966     1     IBFIME.EQ.'KS  ' .OR. IBFIME.EQ.'CHSQ')THEN
9967C
9968          ISTEPN='3B'
9969          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')
9970     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
9971C
9972          NCURVE=1
9973          NJUNK1=0
9974          NJUNK2=0
9975          NHIGH=0
9976          PPLOC=0.0
9977          PPSCAL=1.0
9978C
9979          CALL DPBEF3(ICASP2,IPPCAP,NUMSHA,XMIN,XMAX,IADEDF,
9980     1                SHAP11,SHAP12,SHAP21,SHAP22,
9981     1                ISKIP,
9982     1                IBUGA3,ISUBRO,IERROR)
9983          IF(ISKIP.EQ.1)GOTO200
9984C
9985          IF(NUMSHA.EQ.1 .OR. NUMSHA.EQ.2)THEN
9986C
9987            IF(KDIST.EQ.32)SHAPE2=XMIN
9988            PPLOC=0.0
9989            PPSCAL=1.0
9990            A=CPUMIN
9991            B=CPUMIN
9992            IF(ICASP2.EQ.'TRIA')THEN
9993              A=-1.0
9994              B=1.0
9995            ENDIF
9996            ICASP3=IBFIME
9997            IF(IBFIME.EQ.'CHSQ')THEN
9998              IDIST2=INLON2(KDIST)
9999              CALL DPPPC3(Y,CENSOR,XLOW,XHIGH,N,MAXOBV,
10000     1                    ICASP3,ICASP2,IDATSW,IDIST2,
10001     1                    SHAP11,SHAP12,SHAP21,SHAP22,
10002     1                    SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
10003     1                    YLOWLM,YUPPLM,A,B,MINMAX,
10004     1                    TEMP1(1),TEMP1(20001),TEMP1(40001),
10005     1                    TEMP1(60001),NUMSHA,
10006     1                    ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,TEMP1(80001),
10007     1                    ZTEMP5,ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,IPPCBW,
10008     1                    IADEDF,IGEPDF,IMAKDF,IBEIDF,
10009     1                    ILGADF,ISKNDF,IGLDDF,IBGEDF,
10010     1                    IGETDF,ICONDF,IGOMDF,IKATDF,
10011     1                    IGIGDF,IGEODF,
10012     1                    IPPCCC,IPPCFO,IPPLDP,PPLOC,PPSCAL,
10013     1                    IPPCDP,IPPCAP,IPPCAO,IMETHD,ICENSO,
10014     1                    IFLAGF,NCURVE,
10015     1                    PCHSLM,MINSIZ,IHSTCW,CLWIDT,CLLIMI,
10016     1                    ZTMP10,ZTMP11,TEMP2,TEMP3,NJUNK1,NJUNK2,
10017     1                    PPCC,SHA1MX,SHA2MX,PPA0,PPA1,
10018     1                    IBUGA3,ISUBRO,IERROR)
10019            ELSE
10020              CALL DPPPC2(Y,CENSOR,XLEVEL,N,MAXOBV,
10021     1                    ICASP3,ICASP2,
10022     1                    SHAP11,SHAP12,SHAP21,SHAP22,
10023     1                    SHAPE1,SHAPE2,SHAPE3,SHAPE4,SHAPE5,
10024     1                    YLOWLM,YUPPLM,A,B,MINMAX,
10025     1                    TEMP1(1),TEMP1(20001),TEMP1(40001),
10026     1                    TEMP1(60001),NUMSHA,
10027     1                    ZTEMP1,ZTEMP2,ZTEMP3,ZTEMP4,TEMP1(80001),
10028     1                    ZTEMP5,ZTEMP6,ZTEMP7,ZTEMP8,ZTEMP9,IPPCBW,
10029     1                    IADEDF,IGEPDF,IMAKDF,IBEIDF,
10030     1                    ILGADF,ISKNDF,IGLDDF,IBGEDF,
10031     1                    IGETDF,ICONDF,IGOMDF,IKATDF,
10032     1                    IGIGDF,IGEODF,
10033     1                    IPPCCC,IPPCFO,IPPLDP,PPLOC,PPSCAL,
10034     1                    IPPCDP,IPPCAP,IPPCAO,IMETHD,ICENSO,
10035     1                    IFLAGF,NCURVE,
10036     1                    PCHSLM,ILEVEL,
10037     1                    ZTMP10,ZTMP11,TEMP2,TEMP3,NJUNK1,NJUNK2,
10038     1                    PPCC,SHA1MX,SHA2MX,PPA0,PPA1,
10039     1                    PPA0BW,PPA1BW,
10040     1                    IBUGA3,ISUBRO,IERROR)
10041            ENDIF
10042            IF(IERROR.EQ.'YES')GOTO9000
10043C
10044C           NOTE 2013/09: IF THE TRIANGULAR DISTRIBUTION IS FIT BY PPCC,
10045C           THEN DO THE FOLLOWING:
10046C
10047C              1) MAKE SURE ESTIMATES FOR LOWER AND UPPER LIMIT INCLUDE
10048C                 THE MIN/MAX POINTS
10049C
10050C              2) TRANSFORM ESTIMATE OF SHAPE PARAMETER BY
10051C
10052C                 C' = LOWLIM + C*(UPPLIM - LOWLIM)
10053C
10054            IF(ICASP2.EQ.'TRIA' .AND. IBFICR.NE.'PPCC')THEN
10055              IF(PPA0.GT.XMIN)PPA0=XMIN
10056              AUPP=PPA0+PPA1
10057              IF(AUPP.LT.XMAX)PPA1=XMAX-PPA0
10058              SHA1SV=SHA1MX
10059              SHA1MX=PPA0 + SHA1MX*((PPA1-PPA0) - PPA0)
10060              A=PPA0
10061              B=PPA1
10062            ENDIF
10063C
10064            STATVA(KDIST)=PPCC
10065            ALOCV(KDIST)=PPA0
10066            SCALEV(KDIST)=PPA1
10067            SHAPV1(KDIST)=SHA1MX
10068            SHAPV2(KDIST)=CPUMIN
10069            IF(NUMSHA.GE.2)SHAPV2(KDIST)=SHA2MX
10070            IF(KDIST.EQ.46)SHAPV2(KDIST)=XMIN
10071            KSLOC=PPA0
10072            KSSCAL=PPA1
10073C
10074C           NOTE 2014/01: SAVE LOWER AND UPPER LIMITS ESTIMATES
10075C                         BASED ON LOCATION/SCALE ESTIMATES.
10076            ALOC=KSLOC
10077            ASCALE=KSLOC + KSSCAL
10078C
10079            ISTEPN='3BA'
10080            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
10081              CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10082              WRITE(ICOUT,203)ALOCV(KDIST),SCALEV(KDIST),SHAPV1(KDIST)
10083  203         FORMAT('AFTER DPPPC2: ALOCV(KDIST),SCALEV(KDIST),',
10084     1               'SHAPV1(KDIST)=',3G15.7)
10085              CALL DPWRST('XXX','BUG ')
10086            ENDIF
10087C
10088          ELSEIF(NSHAPE.EQ.0)THEN
10089C
10090            CALL DPPP2(Y,CENSOR,XLEVEL,N,ICASP2,NHIGH,
10091     1                 ZTEMP1,ZTEMP2,ZTEMP3,
10092     1                 YLOWLM,YUPPLM,A,B,MINMAX,
10093     1                 SHAP1Z,SHAP2Z,SHAPE3,SHAPE4,
10094     1                 SHAPE5,SHAPE6,SHAPE7,
10095     1                 IADEDF,IGEPDF,IMAKDF,IBEIDF,
10096     1                 ILGADF,ISKNDF,IGLDDF,IBGEDF,
10097     1                 IGETDF,ICONDF,IGOMDF,IKATDF,
10098     1                 IGIGDF,IGEODF,
10099     1                 IPPLDP,MAXOBV,ICENSO,IMETHD,ILEVEL,
10100     1                 PPLOC,PPSCAL,
10101     1                 PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
10102     1                 CCALBE,PPA0BW,PPA1BW,
10103     1                 ZTEMP4,ZTEMP5,
10104     1                 TEMP1,TEMP2,TEMP3,NJUNK1,NJUNK2,NCURVE,
10105     1                 IBUGA3,ISUBRO,IERROR)
10106            IF(IERROR.EQ.'YES')GOTO9000
10107            STATVA(KDIST)=PPCC
10108            ALOCV(KDIST)=PPA0
10109            SCALEV(KDIST)=PPA1
10110            KSLOC=PPA0
10111            KSSCAL=PPA1
10112C
10113C           NOTE 2014/01: SAVE LOWER AND UPPER LIMITS ESTIMATES
10114C                         BASED ON LOCATION/SCALE ESTIMATES.
10115            ALOC=KSLOC
10116            ASCALE=KSLOC + KSSCAL
10117C
10118            ISTEPN='3BB'
10119            IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
10120              CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10121              WRITE(ICOUT,204)ALOCV(KDIST),SCALEV(KDIST)
10122  204         FORMAT('AFTER DPPP2: ALOCV(KDIST),SCALEV(KDIST) = ',
10123     1               2G15.7)
10124              CALL DPWRST('XXX','BUG ')
10125            ENDIF
10126          ENDIF
10127C
10128C         FOR THE FOLLOWING "LOWER/UPPER LIMIT" DISTRIBUTIONS, ALOC AND
10129C         ASCALE RETURN THE UPPER AND LOWER LIMITS.  WE WANT TO REPORT
10130C         LOWER AND UPPER LIMITS IN THE REPORT TABLE, BUT NEED TO SET
10131C         CERTAIN PARAMETERS.
10132C
10133          IF(IBFICR.NE.'PPCC')THEN
10134            IF(ICASP2.EQ.'BETA' .OR. ICASP2.EQ.'TSPO' .OR.
10135     1         ICASP2.EQ.'RGTL' .OR. ICASP2.EQ.'TRIA' .OR.
10136     1         ICASP2.EQ.'TOPL' .OR. ICASP2.EQ.'4BET')THEN
10137              A=ALOC
10138              B=ASCALE
10139              ALOCV(KDIST)=A
10140              SCALEV(KDIST)=B
10141CCCCC         KSLOC=A
10142CCCCC         KSSCAL=B - A
10143              IFLAG8=1
10144C
10145C           FOR THE FOLLOWING "LOWER/UPPER LIMIT" DISTRIBUTIONS, ALOC AND
10146C           ASCALE RETURN THE UPPER AND LOWER LIMITS.  WE WANT TO REPORT
10147C           LOWER AND UPPER LIMITS IN THE REPORT TABLE, BUT THE GOODNESS
10148C           OF FIT ROUTINES ARE EXPECTING LOCATION/SCALE.
10149C
10150            ELSEIF(ICASP2.EQ.'POWF' .OR. ICASP2.EQ.'RPOW')THEN
10151              A=ALOC
10152              B=ASCALE
10153              ALOCV(KDIST)=A
10154              SCALEV(KDIST)=B
10155CCCCC         KSLOC=ALOC
10156CCCCC         KSSCAL=ASCALE - ALOC
10157              IFLAG8=2
10158C
10159C           FOR THE FOLLOWING "LOWER/UPPER LIMIT" DISTRIBUTIONS, ALOC AND
10160C           ASCALE RETURN THE LOCATION AND SCALE LIMITS.  WE WANT TO REPORT
10161C           LOWER AND UPPER LIMITS IN THE REPORT TABLE, BUT NEED TO SET
10162C           CERTAIN PARAMETERS.
10163C
10164            ELSEIF(ICASP2.EQ.'UNIF')THEN
10165              A=ALOC
10166              B=ALOC + ASCALE
10167              ALOCV(KDIST)=A
10168              SCALEV(KDIST)=B
10169CCCCC         KSLOC=ALOC
10170CCCCC         KSSCAL=ASCALE
10171              IFLAG8=1
10172            ENDIF
10173          ENDIF
10174C
10175          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
10176            WRITE(ICOUT,304)ALOC,ASCALE,A,B
10177  304       FORMAT('AFTER PPCC (BOUNDED) FIT: ALOC,ASCALE,A,B = ',
10178     1             4G15.7)
10179            CALL DPWRST('XXX','BUG ')
10180          ENDIF
10181C
10182C         CASE 2: FIT VIA MAXIMUM LIKELIHOOD.
10183C
10184        ELSEIF(IBFIME.EQ.'ML')THEN
10185C
10186          ISTEPN='3C'
10187          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')
10188     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10189C
10190C         NOTE: DPBEF4 MAY TRANSFORM THE DATA IN ORDER FOR
10191C               THE DATA TO BE IN AN APPROPRIATE RANGE.  NOTE
10192C               THAT DPML1 MAY ALSO TRANSFORM THE DATA, SO NEED
10193C               TO SAVE A COPY OF Y THAT IS USED FOR DPML1 SO THAT
10194C               WE CAN RESTORE IT FOR THE GOODNESS OF FIT TEST.
10195C
10196          CALL DPBEF4(ICASP2,IDFTTY,MINMAX,XMIN,XMAX,XSKEW,IBFICR,
10197     1                Y,ZTMP11,N,
10198     1                ISKIP,YLOWLM,YUPPLM,
10199     1                IBUGA3,ISUBRO,IERROR)
10200          DO240II=1,N
10201            AHOLD=Y(II)
10202            Y(II)=ZTMP11(II)
10203            ZTMP11(II)=AHOLD
10204            ZTMP10(II)=Y(II)
10205  240     CONTINUE
10206          IF(ISKIP.EQ.1)GOTO200
10207C
10208          CALL DPML1(Y,CENSOR,N,ICASP2,IFLAGD,IFLAG9,
10209     1               TEMP1,TEMP2,TEMP3,ZTEMP1,ZTEMP2,ZTEMP3,
10210     1               DTEMP,DTEMP2,DTEMP3,ITEMP1,MAXOBV,
10211     1               ALOC,ASCALE,ALOWLI,AUPPLI,
10212     1               SH1,SH2,SH3,SH4,
10213     1               SH5,SH6,S7,
10214     1               YLOWLM,YUPPLM,A,B,MINMAX,ISEED,
10215     1               IADEDF,IGEPDF,IMAKDF,IBEIDF,
10216     1               ILGADF,ISKNDF,IGLDDF,IGOMDF,IGIGDF,
10217     1               IGEODF,IBGEDF,IGAUDF,
10218     1               ICENSO,IEXPBC,IWEIBC,ICENTY,IDFTTY,
10219     1               CLLIMI,CLWIDT,IHSTCW,IHSTOU,IRELAT,IRHSTG,
10220     1               IBUGA3,ISUBRO,IERROR)
10221C
10222          IF(ICASP2.EQ.'INGA')THEN
10223            ALOC=0.0
10224            ASCALE=1.0
10225          ELSEIF(ICASP2.EQ.'3IGA')THEN
10226            ASCALE=1.0
10227          ENDIF
10228C
10229C         IF ERROR FLAG SET, THEN SKIP ML ESTIMATES FOR THIS
10230C         DISTRIBUTION.
10231C
10232          IF(IERROR.EQ.'YES')GOTO200
10233C
10234C         FOR
10235C
10236C            1. 2-PARAMETER BETA
10237C            2. REFLECTED GENERALIZED TOPP AND LEONE
10238C
10239C         SKIP BIC/AIC/AICC CASES IS EITHER SHAPE
10240C         PARAMETER IS LESS THAN OR EQUAL TO 1.
10241C
10242CCCCC     IF(ICASP2.EQ.'BETA')THEN
10243CCCCC       IF(IBFICR.EQ.'AIC' .OR. IBFICR.EQ.'AICC' .OR.
10244CCCCC1         IBFICR.EQ.'BIC ')THEN
10245CCCCC         IF(SH1.LE.1.0 .OR. SH2.LE.1.0)GOTO200
10246CCCCC       ENDIF
10247CCCCC     ELSEIF(ICASP2.EQ.'RGTL')THEN
10248CCCCC       IF(IBFICR.EQ.'AIC' .OR. IBFICR.EQ.'AICC' .OR.
10249CCCCC1         IBFICR.EQ.'BIC ')THEN
10250CCCCC         IF(SH1.LE.1.0 .OR. SH2.LE.1.0)GOTO200
10251CCCCC       ENDIF
10252CCCCC     ELSEIF(ICASP2.EQ.'TOPL')THEN
10253CCCCC       IF(IBFICR.EQ.'AIC' .OR. IBFICR.EQ.'AICC' .OR.
10254CCCCC1         IBFICR.EQ.'BIC ')THEN
10255CCCCC         IF(SH1.LE.1.0)GOTO200
10256CCCCC       ENDIF
10257CCCCC     ENDIF
10258C
10259          SHAPV1(KDIST)=SH1
10260          SHAPV2(KDIST)=SH2
10261          SHAPV3(KDIST)=SH3
10262          SHAPV4(KDIST)=SH4
10263          SHAPV5(KDIST)=SH5
10264          ALOCV(KDIST)=ALOC
10265          SCALEV(KDIST)=ASCALE
10266          KSLOC=ALOC
10267          KSSCAL=ASCALE
10268          IF(KSLOC.EQ.CPUMIN)KSLOC=0.0
10269          IF(ICASP2.EQ.'PARE')THEN
10270            KSLOC=0.0
10271            KSSCAL=1.0
10272            SHAPV1(KDIST)=SH2
10273            SHAPV2(KDIST)=SH1
10274            ALOCV(KDIST)=0.0
10275            SCALEV(KDIST)=1.0
10276          ELSEIF(ICASP2.EQ.'FNOR')THEN
10277            ALOCV(KDIST)=KSLOC
10278            SCALEV(KDIST)=KSSCAL
10279            SHAPV1(KDIST)=CPUMIN
10280            SHAPV2(KDIST)=CPUMIN
10281C
10282C         FOR THE FOLLOWING "LOWER/UPPER LIMIT" DISTRIBUTIONS, ALOC AND
10283C         ASCALE RETURN THE UPPER AND LOWER LIMITS.  WE WANT TO REPORT
10284C         LOWER AND UPPER LIMITS IN THE REPORT TABLE, BUT NEED TO SET
10285C         CERTAIN PARAMETERS.
10286C
10287          ELSEIF(ICASP2.EQ.'BETA' .OR. ICASP2.EQ.'TSPO' .OR.
10288     1           ICASP2.EQ.'RGTL' .OR. ICASP2.EQ.'TRIA' .OR.
10289     1           ICASP2.EQ.'TOPL' .OR. ICASP2.EQ.'4BET')THEN
10290            A=ALOC
10291            B=ASCALE
10292            ALOCV(KDIST)=A
10293            SCALEV(KDIST)=B
10294            KSLOC=A
10295            KSSCAL=B - A
10296            IFLAG8=1
10297C
10298C         FOR THE FOLLOWING "LOWER/UPPER LIMIT" DISTRIBUTIONS, ALOC AND
10299C         ASCALE RETURN THE UPPER AND LOWER LIMITS.  WE WANT TO REPORT
10300C         LOWER AND UPPER LIMITS IN THE REPORT TABLE, BUT THE GOODNESS
10301C         OF FIT ROUTINES ARE EXPECTING LOCATION/SCALE.
10302C
10303          ELSEIF(ICASP2.EQ.'POWF' .OR. ICASP2.EQ.'RPOW')THEN
10304            A=ALOC
10305            B=ASCALE
10306            ALOCV(KDIST)=A
10307            SCALEV(KDIST)=B
10308            KSLOC=ALOC
10309            KSSCAL=ASCALE - ALOC
10310            IFLAG8=2
10311C
10312C         FOR THE FOLLOWING "LOWER/UPPER LIMIT" DISTRIBUTIONS, ALOC AND
10313C         ASCALE RETURN THE LOCATION AND SCALE LIMITS.  WE WANT TO REPORT
10314C         LOWER AND UPPER LIMITS IN THE REPORT TABLE, BUT NEED TO SET
10315C         CERTAIN PARAMETERS.
10316C
10317          ELSEIF(ICASP2.EQ.'UNIF')THEN
10318            A=ALOC
10319            B=ALOC + ASCALE
10320            ALOCV(KDIST)=A
10321            SCALEV(KDIST)=B
10322            KSLOC=ALOC
10323            KSSCAL=ASCALE
10324            IFLAG8=1
10325          ENDIF
10326C
10327          DO245II=1,N
10328            Y(II)=ZTMP10(II)
10329  245     CONTINUE
10330C
10331          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
10332            WRITE(ICOUT,215)ALOC,ASCALE,SH1,SH2,ICASP2
10333  215       FORMAT('AFTER DPML1: ALOC,ASCALE,SH1,SH2 = ',
10334     1             4G15.7,2X,A4)
10335            CALL DPWRST('XXX','BUG ')
10336          ENDIF
10337C
10338        ENDIF
10339C
10340        IF(IBFIFO.EQ.'ON')THEN
10341          NTEMP=1
10342          AKSLOC=ALOCV(KDIST)
10343          AKSSCA=SCALEV(KDIST)
10344          SHAPE1=SHAPV1(KDIST)
10345          SHAPE2=SHAPV2(KDIST)
10346          SHAPE3=SHAPV3(KDIST)
10347          SHAPE4=SHAPV4(KDIST)
10348          SHAPE5=SHAPV5(KDIST)
10349          IF(IFLAG8.EQ.1)THEN
10350            ATEMP=A
10351            BTEMP=B
10352            AKSLOC=A
10353            AKSSCA=B - A
10354          ELSEIF(IFLAG8.EQ.2)THEN
10355            ATEMP=A
10356            BTEMP=B
10357            AKSLOC=A
10358            AKSSCA=B - A
10359          ELSE
10360            ATEMP=AKSLOC
10361            BTEMP=ATEMP + AKSSCA
10362          ENDIF
10363          IF(ICASP2.EQ.'ADEX' .AND. IBFIME.EQ.'ML')THEN
10364            IADESV=IADEDF
10365            IADEDF='K'
10366          ENDIF
10367          IF(ICASP2.EQ.'WALD')THEN
10368            SHAPE2=1.0
10369          ENDIF
10370C
10371C         FOR ML ESTIMATION, CERTAIN DISTRIBUTIONS EXPECT EITHER ALL
10372C         POSITIVE OR ALL NEGATIVE VALUES.  IN THESE CASES, THE DATA
10373C         IS TRANSFORMED BEFORE PERFORMING THE FIT.  IF THE DATA IS
10374C         TRANSFORMED, THEN PERFORM AN EQUIVALENT TRANSFORMATION ON
10375C         "XVALUE".
10376C
10377          XVALT=PBFIXV
10378          IF(IBFIME.EQ.'ML' .AND. XMIN.LE.0.0)THEN
10379            IMOD=0
10380            IF(ICASP2.EQ.'WEIB' .AND. MINMAX.EQ.1)IMOD=1
10381            IF(ICASP2.EQ.'GPAR' .AND. MINMAX.EQ.2)IMOD=1
10382            IF(ICASP2.EQ.'EV2 ' .AND. MINMAX.EQ.2)IMOD=1
10383            IF(ICASP2.EQ.'GEV ' .AND. MINMAX.EQ.2)IMOD=1
10384            IF(ICASP2.EQ.'IWEI')IMOD=1
10385            IF(ICASP2.EQ.'LOGN')IMOD=1
10386            IF(ICASP2.EQ.'GAMM')IMOD=1
10387            IF(ICASP2.EQ.'IGAM')IMOD=1
10388            IF(ICASP2.EQ.'GEEX')IMOD=1
10389            IF(ICASP2.EQ.'LEXP')IMOD=1
10390            IF(ICASP2.EQ.'FATL')IMOD=1
10391            IF(ICASP2.EQ.'PARE')IMOD=1
10392            IF(ICASP2.EQ.'FNOR')IMOD=1
10393            IF(ICASP2.EQ.'MAXW')IMOD=1
10394            IF(ICASP2.EQ.'1MAX')IMOD=1
10395            IF(ICASP2.EQ.'BU10')IMOD=1
10396            IF(IMOD.EQ.1)THEN
10397              EPS=0.000001
10398              XVALT=XVALT - XMIN + EPS
10399            ENDIF
10400          ENDIF
10401C
10402C         STEP 4: DISTRIBUTIONS EXPECTING NEGATIVE VALUES
10403C
10404C                 1) 2-PARAMETER WEIBULL (MAXIMUM)
10405C                 2) GENERALIZED PARETO (MINIMUM)
10406C                 3) FRECHET (MINIMUM)
10407C                 4) GENERALIZED EXTREME VALUE (MINIMUM)
10408C
10409          IF(IBFIME.EQ.'ML' .AND. XMAX.GE.0.0)THEN
10410            IF(XMAX.GE.0.0)THEN
10411              IMOD=0
10412              IF(ICASP2.EQ.'WEIB' .AND. MINMAX.EQ.2)IMOD=1
10413              IF(ICASP2.EQ.'GPAR' .AND. MINMAX.EQ.1)IMOD=1
10414              IF(ICASP2.EQ.'EV2 ' .AND. MINMAX.EQ.1)IMOD=1
10415              IF(ICASP2.EQ.'GEV ' .AND. MINMAX.EQ.1)IMOD=1
10416              IF(IMOD.EQ.1)THEN
10417                EPS=0.000001
10418                XVALT=XVALT - XMAX - EPS
10419              ENDIF
10420            ENDIF
10421          ENDIF
10422C
10423CCCCC     ZTEMP1(1)=0.0
10424          ZTEMP1(1)=XVALT
10425          AKSLOT=AKSLOC
10426          IF(AKSLOC.LE.CPUMIN .OR. AKSLOC.GE.CPUMAX)AKSLOT=0.0
10427          AKSSCT=AKSSCA
10428          IF(AKSSCA.LE.CPUMIN .OR. AKSSCA.GE.CPUMAX)AKSSCT=1.0
10429          NTEMP2=1
10430          IF(IBFITY.EQ.'CDF')THEN
10431            IFLAGD=1
10432            CALL DPCDF1(ZTEMP1,ZTEMP2,NTEMP2,ICASP2,IFLAGD,
10433     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
10434     1                  SHAPE5,SH6,SH7,
10435     1                  YLOWLM,YUPPLM,ATEMP,BTEMP,MINMAX,
10436     1                  ICAPSW,ICAPTY,
10437     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
10438     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,
10439     1                  IGETDF,ICONDF,IGOMDF,IKATDF,
10440     1                  IGIGDF,IGEODF,
10441     1                  AKSLOT,AKSSCT,
10442     1                  IBUGA3,ISUBRO,IERROR)
10443          ELSE
10444            CALL DPPDF1(ZTEMP1,ZTEMP2,NTEMP2,ICASP2,
10445     1                  SHAPE1,SHAPE2,SHAPE3,SHAPE4,
10446     1                  SHAPE5,SH6,SH7,
10447     1                  YLOWLM,YUPPLM,ATEMP,BTEMP,MINMAX,
10448     1                  ICAPSW,ICAPTY,
10449     1                  IADEDF,IGEPDF,IMAKDF,IBEIDF,
10450     1                  ILGADF,ISKNDF,IGLDDF,IBGEDF,
10451     1                  IGETDF,ICONDF,IGOMDF,IKATDF,
10452     1                  IGIGDF,IGEODF,
10453     1                  AKSLOT,AKSSCT,
10454     1                  IBUGA3,ISUBRO,IERROR)
10455          ENDIF
10456C
10457          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
10458            WRITE(ICOUT,217)AKSLOT,AKSSCT,SH1
10459  217       FORMAT('AFTER DPCDF1/DPPDF1: ALOC,ASCALE,SH1,SH2 = ',3G15.7)
10460            CALL DPWRST('XXX','BUG ')
10461            WRITE(ICOUT,218)ZTEMP1(1),ZTEMP2(1)
10462  218       FORMAT('ZTEMP1(1),ZTEMP2(1) = ',2G15.7)
10463            CALL DPWRST('XXX','BUG ')
10464          ENDIF
10465C
10466          IADEDF=IADESV
10467          IF(ZTEMP2(1).EQ.CPUMIN)THEN
10468            DISTZ(KDIST)=-99.0
10469          ELSE
10470            DISTZ(KDIST)=ZTEMP2(1)
10471          ENDIF
10472CCCCC     DISTZ(KDIST)=-99.0
10473        ENDIF
10474C
10475C       STEP 2: EXTRACT THE GOODNESS OF FIT STATISTIC.  CALL DPPP2
10476C               TO OBTAIN PPCC VALUE AND DPGOF9 TO OBTAIN
10477C               ANDERSON-DARLING, KOLMOGOROV-SMIRNOV, OR AIC (OR
10478C               RELATED) GOODNESS OF FIT.
10479C
10480        ISTEPN='3D'
10481        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')
10482     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
10483C
10484C       CASE 1: RANK BY PPCC, IF FIT PERFORMED BY PPCC,
10485C               ALREADY HAVE PPCC VALUE.  OTHERWISE, CALL
10486C               DPPP2 TO OBTAIN.
10487C
10488C               NOTE THAT IF FIT AND GOODNESS OF FIT CRITIERION ARE
10489C               BOTH PPCC, THEN NEED TO TRANSFORM THE SHAPE PARAMETER
10490C               FOR THE REPORT.
10491C
10492        IF(IBFICR.EQ.'PPCC')THEN
10493          IF(IBFIME.EQ.'PPCC')THEN
10494            IF(ICASP2.EQ.'TRIA')THEN
10495              ALOW=ALOCV(KDIST)
10496              AUPP=ALOW + SCALEV(KDIST)
10497              SHAPV1(KDIST)=ALOW + SHAPV1(KDIST)*(AUPP - ALOW)
10498            ENDIF
10499            IF(IFLAG7(KDIST).EQ.1)THEN
10500              SCALEV(KDIST)=ALOW + SCALEV(KDIST)
10501            ENDIF
10502          ELSE
10503            IF(ICASP2.EQ.'ADEX' .AND. IBFIME.EQ.'ML')THEN
10504              IADESV=IADEDF
10505              IADEDF='K'
10506            ENDIF
10507            SHAP1Z=SHAPV1(KDIST)
10508            SHAP2Z=SHAPV2(KDIST)
10509            SHAP3Z=SHAPV3(KDIST)
10510            SHAP4Z=SHAPV4(KDIST)
10511            SHAP5Z=SHAPV5(KDIST)
10512            NCURVE=1
10513            NJUNK1=0
10514            NJUNK2=0
10515            NHIGH=0
10516            PPLOC=0.0
10517            PPSCAL=1.0
10518            IF(KSLOC.NE.CPUMIN)PPLOC=KSLOC
10519            IF(KSSCAL.NE.CPUMIN)PPSCAL=KSSCAL
10520            CALL DPPP2(Y,CENSOR,XLEVEL,N,ICASP2,NHIGH,
10521     1                 ZTEMP1,ZTEMP2,ZTEMP3,
10522     1                 YLOWLM,YUPPLM,A,B,MINMAX,
10523     1                 SHAP1Z,SHAP2Z,SHAP3Z,SHAP4Z,
10524     1                 SHAP5Z,SHAPE6,SHAPE7,
10525     1                 IADEDF,IGEPDF,IMAKDF,IBEIDF,
10526     1                 ILGADF,ISKNDF,IGLDDF,IBGEDF,
10527     1                 IGETDF,ICONDF,IGOMDF,IKATDF,
10528     1                 IGIGDF,IGEODF,
10529     1                 IPPLDP,MAXOBV,ICENSO,IMETHD,ILEVEL,
10530     1                 PPLOC,PPSCAL,
10531     1                 PPA0,PPA1,PPCC,SDPPA0,SDPPA1,XRESSD,XRESDF,
10532     1                 CCALBE,PPA0BW,PPA1BW,
10533     1                 ZTEMP4,ZTEMP5,
10534     1                 TEMP1,TEMP2,TEMP3,NJUNK1,NJUNK2,NCURVE,
10535     1                 IBUGA3,ISUBRO,IERROR)
10536            STATVA(KDIST)=PPCC
10537            IF(ICASP2.EQ.'ADEX' .AND. IBFIME.EQ.'ML')THEN
10538              IADEDF=IADESV
10539            ENDIF
10540          ENDIF
10541        ELSE
10542CCCCC     IF(ICASP2.EQ.'TRIA' .AND. IBFIME.NE.'ML')GOTO200
10543          IF(ICASP2.EQ.'TSPO' .AND. IBFIME.NE.'ML')GOTO200
10544          ICASP3=IBFICR
10545          SHAPE1=SHAPV1(KDIST)
10546          SHAPE2=SHAPV2(KDIST)
10547          SHAPE3=SHAPV3(KDIST)
10548          SHAPE4=SHAPV4(KDIST)
10549          SHAPE5=SHAPV5(KDIST)
10550          STATVA(KDIST)=CPUMIN
10551          IF(IFLAG8.EQ.1)THEN
10552            YLOWLM=A
10553            YUPPLM=B
10554          ELSEIF(IFLAG8.EQ.2)THEN
10555            YLOWLM=A
10556            YUPPLM=B
10557            KSLOC=A
10558            KSSCAL=B - A
10559          ELSE
10560            A=KSLOC
10561            B=A + KSSCAL
10562            YLOWLM=A
10563            YUPPLM=B
10564          ENDIF
10565          IF(ICASP2.EQ.'ADEX' .AND. IBFIME.EQ.'ML')THEN
10566            IADESV=IADEDF
10567            IADEDF='K'
10568          ENDIF
10569          IF(ICASP2.EQ.'WALD')THEN
10570            SHAPE2=1.0
10571          ENDIF
10572C
10573C         IF FIT BY PPCC BUT RANKING CRITIERION NOT PPCC, THEN MAY
10574C         NEED TO TWEAK LOCATION/SCALE ESTIMATES SO THAT WE HAVE
10575C         A VALID DOMAIN FOR THE CDF/PDF FUNCTIONS.
10576C
10577          IF(IBFICR.NE.'PPCC')THEN
10578            IF(IBFIME.EQ.'PPCC' .OR. IBFIME.EQ.'AD  ' .OR.
10579     1         IBFIME.EQ.'KS  ' .OR. IBFIME.EQ.'CHSQ')THEN
10580              CALL DPBEF5(IBFIME,ICASP2,XMIN,XMAX,XMED,
10581     1                    KSLOC,KSSCAL,A,B,
10582     1                    SHAPE1,SHAPE2,
10583     1                    IBUGA3,ISUBRO,IERROR)
10584               ALOCV(KDIST)=KSLOC
10585               SCALEV(KDIST)=KSSCAL
10586            ENDIF
10587          ENDIF
10588C
10589          IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
10590            WRITE(ICOUT,225)KSLOC,KSSCAL,SHAPE1,MINMAX,ICASP2
10591  225       FORMAT('DPGOF9: KSLOC,KSSCAL,SHAPE1,MINMAX,ICASP2 = ',
10592     1             3G15.7,I8,2X,A4)
10593            CALL DPWRST('XXX','BUG ')
10594          ENDIF
10595C
10596          IERROR='NO'
10597          CALL DPGOF9(Y,N,ICASP2,ICASP3,
10598     1                TEMP1,TEMP2,TEMP3,N2,
10599     1                YLOWLM,YUPPLM,A,B,MINMAX,
10600     1                SHAPE1,SHAPE2,SHAPE3,SHAPE4,
10601     1                SHAPE5,SHAPE6,SHAPE7,
10602     1                IADEDF,IGEPDF,IMAKDF,IBEIDF,
10603     1                ILGADF,ISKNDF,IGLDDF,IBGEDF,IGETDF,ICONDF,
10604     1                IGOMDF,IKATDF,IGIGDF,IGEODF,
10605     1                MAXOBV,
10606     1                KSLOC,KSSCAL,
10607     1                STATZZ,DM,
10608     1                IBUGA3,ISUBRO,IERROR,IERRFL)
10609          IF(STATZZ.LE.CPUMIN .OR. STATZZ.GE.CPUMAX .OR.
10610     1       IERROR.EQ.'YES')THEN
10611            GOTO200
10612          ENDIF
10613          IF(ISNANZ(STATZZ)) GOTO200
10614          STATVA(KDIST)=STATZZ
10615C
10616          IF(ICASP2.EQ.'ADEX' .AND. IBFIME.EQ.'ML')THEN
10617            IADEDF=IADESV
10618          ENDIF
10619C
10620        ENDIF
10621C
10622        IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
10623          WRITE(ICOUT,291)KDIST,INLON2(KDIST)(1:25),STATVA(KDIST),ICASP2
10624  291     FORMAT('KDIST,INLON2(KDIST)(1:25),STATVA(KDIST),ICASP2 = ',
10625     1           I5,A25,G15.7,2X,A4)
10626          CALL DPWRST('XXX','BUG ')
10627        ENDIF
10628C
10629        IF(IBFIME.EQ.'ML')THEN
10630          DO280II=1,N
10631            Y(II)=ZTMP11(II)
10632  280     CONTINUE
10633        ENDIF
10634C
10635  200 CONTINUE
10636C
10637C               *************************************************
10638C               **  STEP 4--                                   **
10639C               **  NOW SORT THE DISTRIBUTIONS BASED ON THE    **
10640C               **  GOODNESS OF FIT STATISTIC                  **
10641C               *************************************************
10642C
10643C     IF CALLED FROM DPDFP2, THEN JUST RETURN UNSORTED LIST AND
10644C     DO NOT PRINT THE TABLE.
10645C
10646      IF(ISUBN3.EQ.'DFP2' .OR. ISUBN3.EQ.'DFP3')GOTO9000
10647C
10648      CALL SORTC3(STATVA,ITEMP2,MAXDIS,TEMP1,ITEMP1)
10649C
10650      IF(IBFICR.EQ.'PPCC')THEN
10651        DO401I=1,MAXDIS
10652          ITEMP2(I)=ITEMP1(I)
10653  401   CONTINUE
10654        DO403I=1,MAXDIS
10655          II=MAXDIS-I+1
10656          ITEMP1(I)=ITEMP2(II)
10657  403   CONTINUE
10658      ENDIF
10659C
10660      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
10661        DO410I=1,MAXDIS
10662          WRITE(ICOUT,411)I,STATVA(I),TEMP1(I),ITEMP2(I),ITEMP1(I)
10663  411     FORMAT('I,STATVA(I),TEMP1(I),ITEMP2(I),ITEMP1(I)=',
10664     1           I5,2G15.7,2I5)
10665          CALL DPWRST('XXX','BUG ')
10666  410   CONTINUE
10667      ENDIF
10668C
10669      IF(IPRINT.EQ.'OFF')GOTO9000
10670C
10671      NUMDIG=7
10672      IF(IFORSW.EQ.'1')NUMDIG=1
10673      IF(IFORSW.EQ.'2')NUMDIG=2
10674      IF(IFORSW.EQ.'3')NUMDIG=3
10675      IF(IFORSW.EQ.'4')NUMDIG=4
10676      IF(IFORSW.EQ.'5')NUMDIG=5
10677      IF(IFORSW.EQ.'6')NUMDIG=6
10678      IF(IFORSW.EQ.'7')NUMDIG=7
10679      IF(IFORSW.EQ.'8')NUMDIG=8
10680      IF(IFORSW.EQ.'9')NUMDIG=9
10681      IF(IFORSW.EQ.'0')NUMDIG=0
10682      IF(IFORSW.EQ.'E')NUMDIG=-2
10683      IF(IFORSW.EQ.'-2')NUMDIG=-2
10684      IF(IFORSW.EQ.'-3')NUMDIG=-3
10685      IF(IFORSW.EQ.'-4')NUMDIG=-4
10686      IF(IFORSW.EQ.'-5')NUMDIG=-5
10687      IF(IFORSW.EQ.'-6')NUMDIG=-6
10688      IF(IFORSW.EQ.'-7')NUMDIG=-7
10689      IF(IFORSW.EQ.'-8')NUMDIG=-8
10690      IF(IFORSW.EQ.'-9')NUMDIG=-9
10691C
10692      ICNT=1
10693      ITEXT(ICNT)=' '
10694      NCTEXT(ICNT)=0
10695      AVALUE(ICNT)=0.0
10696      IDIGIT(ICNT)=-1
10697      ICNT=ICNT+1
10698      ITEXT(ICNT)='Response Variable: '
10699      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
10700      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
10701      NCTEXT(ICNT)=27
10702      AVALUE(ICNT)=0.0
10703      IDIGIT(ICNT)=-1
10704C
10705      DO4101I=1,NREPL
10706        ICNT=ICNT+1
10707        ITEXT(ICNT)='Factor Variable  : '
10708        WRITE(ITEXT(ICNT)(17:17),'(I1)')I
10709        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(I+1)(1:4)
10710        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(I+1)(1:4)
10711        NCTEXT(ICNT)=27
10712        AVALUE(ICNT)=PID(I+1)
10713        IDIGIT(ICNT)=NUMDIG
10714 4101 CONTINUE
10715C
10716      ICNT=ICNT+1
10717      ITEXT(ICNT)=' '
10718      NCTEXT(ICNT)=1
10719      AVALUE(ICNT)=0.0
10720      IDIGIT(ICNT)=-1
10721      ICNT=ICNT+1
10722      IF(IBFIME.EQ.'PPCC')THEN
10723        ITEXT(ICNT)='Fit Method: PPCC'
10724        NCTEXT(ICNT)=16
10725      ELSEIF(IBFIME.EQ.'AD')THEN
10726        ITEXT(ICNT)='Fit Method: Anderson Darling'
10727        NCTEXT(ICNT)=28
10728      ELSEIF(IBFIME.EQ.'KS')THEN
10729        ITEXT(ICNT)='Fit Method: Kolmogorov Smirnov'
10730        NCTEXT(ICNT)=30
10731      ELSEIF(IBFIME.EQ.'ML')THEN
10732        ITEXT(ICNT)='Fit Method: Maximum Likelihood'
10733        NCTEXT(ICNT)=30
10734      ENDIF
10735      AVALUE(ICNT)=0.0
10736      IDIGIT(ICNT)=-1
10737      ICNT=ICNT+1
10738      IF(IBFICR.EQ.'PPCC')THEN
10739        ITEXT(ICNT)='Ranking Criterion: PPCC'
10740        NCTEXT(ICNT)=23
10741      ELSEIF(IBFICR.EQ.'AD')THEN
10742        ITEXT(ICNT)='Ranking Criterion: Anderson Darling'
10743        NCTEXT(ICNT)=35
10744      ELSEIF(IBFICR.EQ.'KS')THEN
10745        ITEXT(ICNT)='Ranking Criterion: Kolmogorov Smirnov'
10746        NCTEXT(ICNT)=35
10747      ELSEIF(IBFICR.EQ.'AIC')THEN
10748        ITEXT(ICNT)='Ranking Criterion: AIC'
10749        NCTEXT(ICNT)=22
10750      ELSEIF(IBFICR.EQ.'AICC')THEN
10751        ITEXT(ICNT)='Ranking Criterion: AICC'
10752        NCTEXT(ICNT)=23
10753      ELSEIF(IBFICR.EQ.'BIC')THEN
10754        ITEXT(ICNT)='Ranking Criterion: BIC'
10755        NCTEXT(ICNT)=22
10756      ENDIF
10757      AVALUE(ICNT)=0.0
10758      IDIGIT(ICNT)=-1
10759C
10760      ICNT=ICNT+1
10761      ITEXT(ICNT)=' '
10762      NCTEXT(ICNT)=1
10763      AVALUE(ICNT)=0.0
10764      IDIGIT(ICNT)=-1
10765      ICNT=ICNT+1
10766      ITEXT(ICNT)='Summary Statistics:'
10767      NCTEXT(ICNT)=19
10768      AVALUE(ICNT)=0.0
10769      IDIGIT(ICNT)=-1
10770      ICNT=ICNT+1
10771      ITEXT(ICNT)='Number of Observations:'
10772      NCTEXT(ICNT)=23
10773      AVALUE(ICNT)=REAL(N)
10774      IDIGIT(ICNT)=0
10775      ICNT=ICNT+1
10776      ITEXT(ICNT)='Sample Minimum:'
10777      NCTEXT(ICNT)=15
10778      AVALUE(ICNT)=XMIN
10779      IDIGIT(ICNT)=NUMDIG
10780      ICNT=ICNT+1
10781      ITEXT(ICNT)='Sample Maximum:'
10782      NCTEXT(ICNT)=15
10783      AVALUE(ICNT)=XMAX
10784      IDIGIT(ICNT)=NUMDIG
10785      ICNT=ICNT+1
10786      ITEXT(ICNT)='Sample Mean:'
10787      NCTEXT(ICNT)=12
10788      AVALUE(ICNT)=XMEAN
10789      IDIGIT(ICNT)=NUMDIG
10790      ICNT=ICNT+1
10791      ITEXT(ICNT)='Sample SD:'
10792      NCTEXT(ICNT)=10
10793      AVALUE(ICNT)=XSD
10794      IDIGIT(ICNT)=NUMDIG
10795      NUMROW=ICNT
10796      DO2310I=1,NUMROW
10797        NTOT(I)=15
10798 2310 CONTINUE
10799C
10800      ITITLE='Best Distributional Fit'
10801      NCTITL=24
10802      ITITLZ=' '
10803      NCTITZ=0
10804      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
10805     1            AVALUE,IDIGIT,
10806     1            NTOT,NUMROW,
10807     1            ICAPSW,ICAPTY,ILAST,IFRST,
10808     1            ISUBRO,IBUGA3,IERROR)
10809C
10810      ITITL9=' '
10811      NCTIT9=0
10812      ITITLE='Ranked List of Best Fit'
10813      NCTITL=23
10814      NUMLIN=3
10815      NUMROW=4
10816      NUMCOL=6
10817C
10818      ITITL2(1,1)=' '
10819      NCTIT2(1,1)=0
10820      ITITL2(2,1)=' '
10821      NCTIT2(2,1)=0
10822      ITITL2(3,1)='Distribution'
10823      NCTIT2(3,1)=12
10824C
10825      ITITL2(1,2)='Goodness'
10826      NCTIT2(1,2)=8
10827      ITITL2(2,2)='of Fit'
10828      NCTIT2(2,2)=6
10829      ITITL2(3,2)='Statistic'
10830      NCTIT2(3,2)=9
10831C
10832      ITITL2(1,3)='Estimate'
10833      NCTIT2(1,3)=8
10834      ITITL2(2,3)='of'
10835      NCTIT2(2,3)=2
10836      ITITL2(3,3)='Location'
10837      NCTIT2(3,3)=8
10838C
10839      ITITL2(1,4)='Estimate'
10840      NCTIT2(1,4)=8
10841      ITITL2(2,4)='of'
10842      NCTIT2(2,4)=2
10843      ITITL2(3,4)='Scale'
10844      NCTIT2(3,4)=5
10845C
10846      ITITL2(1,5)='Estimate'
10847      NCTIT2(1,5)=8
10848      ITITL2(2,5)='of Shape'
10849      NCTIT2(2,5)=8
10850      ITITL2(3,5)='Parameter 1'
10851      NCTIT2(3,5)=11
10852C
10853      ITITL2(1,6)='Estimate'
10854      NCTIT2(1,6)=8
10855      ITITL2(2,6)='of Shape'
10856      NCTIT2(2,6)=8
10857      ITITL2(3,6)='Parameter 2'
10858      NCTIT2(3,6)=11
10859C
10860      IF(IBFIFO.EQ.'ON')THEN
10861        IF(IBFITY.EQ.'PDF')THEN
10862          ITITL2(1,7)='PDF'
10863          NCTIT2(1,7)=3
10864        ELSEIF(IBFITY.EQ.'CDF')THEN
10865          ITITL2(1,7)='CDF'
10866          NCTIT2(1,7)=3
10867        ENDIF
10868        ITITL2(2,7)='Value At'
10869        NCTIT2(2,7)=8
10870        IF(PBFIXV.NE.0.0)THEN
10871          WRITE(ITITL2(3,7)(1:12),'(F12.3)')PBFIXV
10872          NCTIT2(3,7)=12
10873        ELSE
10874          ITITL2(3,7)='Zero'
10875          NCTIT2(3,7)=4
10876        ENDIF
10877C
10878        ITITL2(1,8)=' '
10879        NCTIT2(1,8)=0
10880        ITITL2(2,8)='Infinite'
10881        NCTIT2(2,8)=8
10882        ITITL2(3,8)='Lower Tail'
10883        NCTIT2(3,8)=10
10884C
10885       NUMCOL=8
10886C
10887      ENDIF
10888C
10889      NMAX=0
10890      DO2821I=1,NUMCOL
10891        IDIGIT(I)=NUMDIG
10892        ITYPCO(I)='NUME'
10893        VALIGN(I)='b'
10894        ALIGN(I)='r'
10895        NTOT(I)=15
10896        IF(I.EQ.1)THEN
10897          NTOT(I)=25
10898          ALIGN(I)='l'
10899          ITYPCO(I)='ALPH'
10900          IDIGIT(I)=0
10901        ELSEIF(I.EQ.2 .AND.
10902     1        (IBFICR.EQ.'AIC' .OR. IBFICR.EQ.'AICC' .OR.
10903     1         IBFICR.EQ.'BIC'))THEN
10904          IDIGIT(I)=-7
10905        ELSEIF(I.EQ.8)THEN
10906          IDIGIT(I)=0
10907        ENDIF
10908        NMAX=NMAX+NTOT(I)
10909 2821 CONTINUE
10910C
10911      DO2823I=1,MAXDIS
10912        DO2825J=1,NUMCOL
10913          NCVALU(I,J)=0
10914          IVALUE(I,J)=' '
10915          NCVALU(I,J)=0
10916          AMAT(I,J)=CPUMIN
10917 2825   CONTINUE
10918 2823 CONTINUE
10919C
10920      ICNT=0
10921      DO2910I=1,MAXDIS
10922        IRANK=ITEMP1(I)
10923        IF(STATVA(IRANK).EQ.CPUMIN)GOTO2910
10924        ICNT=ICNT+1
10925        IF(IFLAG7(IRANK).EQ.1)THEN
10926          IVALUE(ICNT,1)(2:25)=INLON2(IRANK)(1:24)
10927          IVALUE(ICNT,1)(1:1)='*'
10928        ELSE
10929          IVALUE(ICNT,1)(1:25)=INLON2(IRANK)(1:25)
10930        ENDIF
10931        NCVALU(ICNT,1)=25
10932        AMAT(ICNT,2)=STATVA(IRANK)
10933        AMAT(ICNT,3)=ALOCV(IRANK)
10934        IF(INLON2(IRANK)(1:13).EQ.'2-PAR WEIBULL' .OR.
10935     1     INLON2(IRANK)(1:13).EQ.'3-PAR WEIBULL')THEN
10936          IF(IFLAGL.EQ.1)THEN
10937            AVAL1=SCALEV(IRANK)
10938            AFACT=AL**(1.0/SHAPV1(IRANK))
10939            AVAL1=AFACT*AVAL1
10940            AMAT(ICNT,4)=AVAL1
10941          ELSE
10942            AMAT(ICNT,4)=SCALEV(IRANK)
10943          ENDIF
10944        ELSE
10945          AMAT(ICNT,4)=SCALEV(IRANK)
10946        ENDIF
10947        AMAT(ICNT,5)=SHAPV1(IRANK)
10948        AMAT(ICNT,6)=SHAPV2(IRANK)
10949        IF(IBFIFO.EQ.'ON')THEN
10950          AMAT(ICNT,7)=DISTZ(IRANK)
10951          AMAT(ICNT,8)=DISTTA(IRANK)
10952        ENDIF
10953 2910 CONTINUE
10954C
10955      IWHTML(1)=300
10956      IWHTML(2)=150
10957      IWHTML(3)=150
10958      IWHTML(4)=150
10959      IWHTML(5)=150
10960      IWHTML(6)=150
10961      IWHTML(7)=150
10962      IWHTML(8)=150
10963      IINC=1500
10964      IWRTF(1)=2500
10965      IWRTF(2)=IWRTF(1)+IINC
10966      IWRTF(3)=IWRTF(2)+IINC
10967      IWRTF(4)=IWRTF(3)+IINC
10968      IWRTF(5)=IWRTF(4)+IINC
10969      IWRTF(6)=IWRTF(5)+IINC
10970      IWRTF(7)=IWRTF(6)+IINC
10971      IWRTF(8)=IWRTF(7)+IINC
10972C
10973      IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN
10974        IPTSZ=14
10975        IF(IBFIFO.EQ.'ON')IPTSZ=10
10976        CALL DPCONA(92,IBASLC)
10977        WRITE(ICOUT,8199)IBASLC,IPTSZ
10978 8199   FORMAT(A1,'fs',I2)
10979        CALL DPWRST(ICOUT,'WRIT')
10980      ENDIF
10981C
10982      NUMROW=ICNT
10983      IFRST=.TRUE.
10984      ILAST=.TRUE.
10985C
10986      CALL DPDTA4(ITITL9,NCTIT9,
10987     1            ITITLE,NCTITL,ITITL2,NCTIT2,
10988     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
10989     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXDIS,NUMROW,
10990     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
10991     1            ICAPSW,ICAPTY,IFRST,ILAST,
10992     1            ISUBRO,IBUGA3,IERROR)
10993C
10994      IF(ICAPSW.EQ.'ON' .AND. ICAPTY.EQ.'RTF ')THEN
10995        IPTSZ=IRTFPS
10996        WRITE(ICOUT,8199)IBASLC,IPTSZ
10997        CALL DPWRST(ICOUT,'WRIT')
10998      ENDIF
10999C
11000      WRITE(ICOUT,999)
11001      CALL DPWRST(ICOUT,'WRIT')
11002      WRITE(ICOUT,8210)
11003 8210 FORMAT('* denotes lower/upper limit rather than location/scale')
11004      CALL DPWRST(ICOUT,'WRIT')
11005      WRITE(ICOUT,999)
11006      CALL DPWRST(ICOUT,'WRIT')
11007C
11008C               *****************
11009C               **  STEP 90--  **
11010C               **  EXIT       **
11011C               *****************
11012C
11013 9000 CONTINUE
11014C
11015      MINMAX=MINMX2
11016      IDFTTY=IDFTT2
11017C
11018C     WRITE RESULTS TO "dpst1f.dat"
11019C
11020      IF(IERROR.EQ.'YES')GOTO9009
11021      IF(ISUBN3.EQ.'DFP2' .OR. ISUBN3.EQ.'DFP3')GOTO9009
11022C
11023      IOP='OPEN'
11024      IFLG11=1
11025      IFLG21=0
11026      IFLG31=0
11027      IFLAG4=0
11028      IFLAG5=0
11029      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
11030     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
11031     1            IBUGA3,ISUBRO,IERROR)
11032      IF(IERROR.EQ.'YES')GOTO9009
11033C
11034      DO9001I=1,MAXDIS
11035        IRANK=ITEMP1(I)
11036        IF(STATVA(IRANK).EQ.CPUMIN)GOTO9001
11037        WRITE(IOUNI1,9003)N,STATVA(IRANK),ALOCV(IRANK),SCALEV(IRANK),
11038     1                    SHAPV1(IRANK),SHAPV2(IRANK),IRANK,
11039     1                    INLON2(IRANK)(1:25)
11040 9003   FORMAT(I8,2X,5E15.7,I5,2X,A25)
11041 9001 CONTINUE
11042C
11043      IOP='CLOS'
11044      CALL DPAUFI(IOP,IFLG11,IFLG21,IFLG31,IFLAG4,IFLAG5,
11045     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
11046     1            IBUGA3,ISUBRO,IERROR)
11047C
11048 9009 CONTINUE
11049      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF2')THEN
11050        WRITE(ICOUT,999)
11051        CALL DPWRST('XXX','BUG ')
11052        WRITE(ICOUT,9011)
11053 9011   FORMAT('***** AT THE END       OF DPBEF2--')
11054        CALL DPWRST('XXX','BUG ')
11055        WRITE(ICOUT,9013)YSTAT(1)
11056 9013   FORMAT('YSTAT(1) = ',G15.7)
11057        CALL DPWRST('XXX','BUG ')
11058      ENDIF
11059C
11060      RETURN
11061      END
11062      SUBROUTINE DPBEF3(IDIST,IPPCAP,NUMSHA,YMIN,YMAX,IADEDF,
11063     1                  SHAP11,SHAP12,SHAP21,SHAP22,
11064     1                  ISKIP,
11065     1                  IBUGA3,ISUBRO,IERROR)
11066C
11067C     PURPOSE--FOR THE "BEST DISTRIBUTIONAL FIT" COMMAND, THIS
11068C              ROUTINE SETS CERTAIN PARAMETERS FOR THE PPCC METHOD:
11069C
11070C                 1. DEFINE THE NUMBER OF SHAPE PARAMETERS
11071C
11072C                 2. SET THE LOWER AND UPPER LIMIT FOR THE SHAPE
11073C                    PARAMETER(S)
11074C
11075C                 3. SET THE VALUES WHERE THE SHAPE PARAMETER WILL
11076C                    BE EVALUATED.
11077C
11078C                 4. SPECIFY ANY DISTRIBUTIONS TO SKIP.
11079C
11080C              NOTE THAT CURRENTLY THESE VALUES ARE NOT SETTABLE
11081C              BY THE USER.
11082C
11083C     WRITTEN BY--ALAN HECKERT
11084C                 STATISTICAL ENGINEERING DIVISION
11085C                 INFORMATION TECHNOLOGY LABORATORY
11086C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11087C                 GAITHERSBURG, MD 20899-8980
11088C                 PHONE--301-975-2899
11089C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11090C           OF THE NATIONAL BUREAU OF STANDARDS.
11091C     LANGUAGE--ANSI FORTRAN (1977)
11092C     VERSION NUMBER--2011/3
11093C     ORIGINAL VERSION--MARCH     2011.
11094C
11095C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11096C
11097      CHARACTER*4 IDIST
11098      CHARACTER*4 IADEDF
11099      CHARACTER*4 IBUGA3
11100      CHARACTER*4 ISUBRO
11101      CHARACTER*4 IERROR
11102C
11103C---------------------------------------------------------------------
11104C
11105      DIMENSION IPPCAP(2)
11106C
11107      CHARACTER*4 ISTEPN
11108      CHARACTER*4 ISUBN1
11109      CHARACTER*4 ISUBN2
11110C
11111C---------------------------------------------------------------------
11112C
11113      INCLUDE 'DPCOP2.INC'
11114C
11115C-----START POINT-----------------------------------------------------
11116C
11117      IERROR='NO'
11118      ISUBN1='DPBE'
11119      ISUBN2='F3  '
11120C
11121      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF3')THEN
11122        WRITE(ICOUT,999)
11123  999   FORMAT(1X)
11124        CALL DPWRST('XXX','BUG ')
11125        WRITE(ICOUT,71)
11126   71   FORMAT('***** AT THE BEGINNING OF DPBEF3--')
11127        CALL DPWRST('XXX','BUG ')
11128        WRITE(ICOUT,72)IDIST,YMIN,YMAX
11129   72   FORMAT('IDIST,YMIN,YMAX = ',A4,2X,2G15.7)
11130        CALL DPWRST('XXX','BUG ')
11131        WRITE(ICOUT,74)SHAP11,SHAP12,SHAP21,SHAP22
11132   74   FORMAT('SHAP11,SHAP12,SHAP21,SHAP22 = ',4G15.7)
11133        CALL DPWRST('XXX','BUG ')
11134      ENDIF
11135C
11136C               ********************************************
11137C               **  STEP 1--                              **
11138C               **  SET THE PARAMETERS BASED ON THE       **
11139C               **  DISTRIBUTION                          **
11140C               ********************************************
11141C
11142      ISTEPN='1'
11143      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF3')
11144     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11145C
11146C     SPECIFY DISTRIBUTIONS TO SKIP
11147C
11148      ISKIP=0
11149      IF(IDIST.EQ.'WEIB')ISKIP=1
11150      IF(IDIST.EQ.'LOGN')ISKIP=1
11151      IF(IDIST.EQ.'FNOR')ISKIP=1
11152      IF(IDIST.EQ.'PARE')ISKIP=1
11153      IF(IDIST.EQ.'BETA')ISKIP=1
11154      IF(IDIST.EQ.'RGTL')ISKIP=1
11155CCCCC IF(IDIST.EQ.'GTLA')ISKIP=1
11156      IF(IDIST.EQ.'TSPO')ISKIP=1
11157CCCCC IF(IDIST.EQ.'TRIA')ISKIP=1
11158      IF(IDIST.EQ.'NORX')ISKIP=1
11159      IF(IDIST.EQ.'4BET')ISKIP=1
11160      IF(IDIST.EQ.'INGA')ISKIP=1
11161      IF(IDIST.EQ.'3IGA')ISKIP=1
11162      IF(ISKIP.EQ.1)GOTO9000
11163C
11164C     WEIBULL, INVERTED WEIBULL, LOGNORMAL, FRECHET, WALD,
11165C     GEOMETRIC EXTREME EXPONENTIAL, GAMMA, FATIGUE LIFE,
11166C     PARETO, DOUBLE WEIBULL, DOUBLE GAMMA, BURR TYPE 10:
11167C     GO FROM 0.1 TO 50 IN INCREMENTS OF 0.1.
11168C
11169      IF(IDIST.EQ.'WEIB' .OR. IDIST.EQ.'3WEI' .OR.
11170     1   IDIST.EQ.'IWEI' .OR. IDIST.EQ.'EV2'  .OR.
11171     1   IDIST.EQ.'3LGN' .OR. IDIST.EQ.'WALD' .OR.
11172     1   IDIST.EQ.'GEEX' .OR. IDIST.EQ.'FATL' .OR.
11173     1   IDIST.EQ.'PARE' .OR. IDIST.EQ.'GAMM' .OR.
11174     1   IDIST.EQ.'BU10' .OR.
11175     1   IDIST.EQ.'DWEI' .OR. IDIST.EQ.'DGAM'
11176     1  )THEN
11177        IPPCAP(1)=499
11178        SHAP11=0.1
11179        SHAP12=50.0
11180        NUMSHA=1
11181C
11182C     LOG GAMMA, LOG-LOGISTIC, BRADFORD:
11183C     GO FROM 0.1 TO 25 IN INCREMENTS OF 0.1.
11184C
11185      ELSEIF(
11186     1   IDIST.EQ.'LOGL' .OR. IDIST.EQ.'LGAM' .OR.
11187     1   IDIST.EQ.'BRAD'
11188     1  )THEN
11189        IPPCAP(1)=249
11190        SHAP11=0.1
11191        SHAP12=25.0
11192        NUMSHA=1
11193C
11194C     INVERTED GAMMA:
11195C     GO FROM 0.5 TO 50 IN INCREMENTS OF 0.1.
11196C
11197      ELSEIF(
11198     1   IDIST.EQ.'IGAM'
11199     1  )THEN
11200        IPPCAP(1)=496
11201        SHAP11=0.5
11202        SHAP12=50.0
11203        NUMSHA=1
11204C
11205C     LOGISTIC EXPONENTIAL, POWER, REFLECTED POWER, TOPP AND LEONE,
11206C     LOG DOUBLE EXPONENTIAL:
11207C     GO FROM 0.05 TO 10 IN INCREMENTS OF 0.05.
11208C
11209      ELSEIF(
11210     1   IDIST.EQ.'POWF' .OR. IDIST.EQ.'RPOW' .OR.
11211     1   IDIST.EQ.'LDEX' .OR.
11212     1   IDIST.EQ.'LEXP' .OR. IDIST.EQ.'TOPL'
11213     1  )THEN
11214        IPPCAP(1)=199
11215        SHAP11=0.05
11216        SHAP12=10.0
11217        NUMSHA=1
11218C
11219C     ERROR:
11220C     GO FROM 1 TO 5 IN INCREMENTS OF 0.02.
11221C
11222      ELSEIF(
11223     1   IDIST.EQ.'ERRO'
11224     1  )THEN
11225        IPPCAP(1)=201
11226        SHAP11=1.0
11227        SHAP12=5.0
11228        NUMSHA=1
11229C
11230C     GENERALIZED PARETO: GO FROM -10 TO 10 IN INCREMENTS OF 0.1.
11231C
11232      ELSEIF(IDIST.EQ.'GPAR')THEN
11233        IPPCAP(1)=201
11234        SHAP11=-10.0
11235        SHAP12=10.0
11236        NUMSHA=1
11237C
11238C     GENERALIZED EXTREME VALUE: GO FROM -25 TO 25 IN INCREMENTS OF 0.1.
11239C
11240      ELSEIF(IDIST.EQ.'GEV ')THEN
11241        IPPCAP(1)=500
11242        SHAP11=-25.0
11243        SHAP12=25.0
11244        NUMSHA=1
11245C
11246C     TUKEY-LAMBDA: GO FROM -2 TO 2 IN INCREMENTS OF 0.05
11247C
11248      ELSEIF(IDIST.EQ.'TULA')THEN
11249        IPPCAP(1)=81
11250        SHAP11=-2.0
11251        SHAP12=2.0
11252        NUMSHA=1
11253C
11254C     TRIANGUAR: GO FROM -1 TO 1 IN INCREMENTS OF 0.01
11255C
11256      ELSEIF(IDIST.EQ.'TRIA')THEN
11257        IPPCAP(1)=200
11258        SHAP11=-1.0
11259        SHAP12=1.0
11260        NUMSHA=1
11261C
11262C     ASYMMETRIC DOUBLE EXPONENTIAL: K PARAMETERIZATION
11263C
11264      ELSEIF(IDIST.EQ.'ADEX' .AND. IADEDF.EQ.'K')THEN
11265        IPPCAP(1)=198
11266        SHAP11=0.1
11267        SHAP12=10.0
11268        NUMSHA=1
11269C
11270C     ASYMMETRIC DOUBLE EXPONENTIAL: MU PARAMETERIZATION
11271C
11272      ELSEIF(IDIST.EQ.'ADEX' .AND. IADEDF.EQ.'MU')THEN
11273        IPPCAP(1)=198
11274        SHAP11=-5.0
11275        SHAP12=5.0
11276        NUMSHA=1
11277C
11278C     G AND H
11279C
11280      ELSEIF(IDIST.EQ.'GHPP')THEN
11281        IPPCAP(1)=101
11282        IPPCAP(2)=41
11283        SHAP11=-1.0
11284        SHAP12=1.0
11285        SHAP21=0.0
11286        SHAP22=1.0
11287        NUMSHA=2
11288C
11289C     G
11290C
11291      ELSEIF(IDIST.EQ.'GPP')THEN
11292        IPPCAP(1)=200
11293        SHAP11=-1.0
11294        SHAP12=1.0
11295        NUMSHA=1
11296C
11297C     GENERALIZED TUKEY-LAMBDA
11298C
11299      ELSEIF(IDIST.EQ.'GTLA')THEN
11300        IPPCAP(1)=101
11301        IPPCAP(2)=101
11302        SHAP11=-5.0
11303        SHAP12=5.0
11304        SHAP21=-5.0
11305        SHAP22=5.0
11306        NUMSHA=2
11307C
11308C     TWO-SIDED POWER
11309C
11310      ELSEIF(IDIST.EQ.'TSPO')THEN
11311        IPPCAP(1)=21
11312        IPPCAP(2)=249
11313        SHAP11=0.0
11314        SHAP12=1.0
11315        SHAP21=0.1
11316        SHAP22=25.0
11317        NUMSHA=2
11318C
11319C
11320      ELSE
11321        NUMSHA=0
11322      ENDIF
11323C               *****************
11324C               **  STEP 90--  **
11325C               **  EXIT       **
11326C               *****************
11327C
11328 9000 CONTINUE
11329      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF3')THEN
11330        WRITE(ICOUT,999)
11331        CALL DPWRST('XXX','BUG ')
11332        WRITE(ICOUT,9011)
11333 9011   FORMAT('***** AT THE END       OF DPBEF3--')
11334        CALL DPWRST('XXX','BUG ')
11335        WRITE(ICOUT,9013)
11336 9013   FORMAT('SHAP11,SHAP12,IPPCAP(1) = ',2G15.7,I8)
11337        CALL DPWRST('XXX','BUG ')
11338      ENDIF
11339C
11340      RETURN
11341      END
11342      SUBROUTINE DPBEF4(IDIST,IDFTTY,MINMAX,YMIN,YMAX,XSKEW,IBFICR,
11343     1                  Y,YOUT,N,
11344     1                  ISKIP,YLOWLM,YUPPLM,
11345     1                  IBUGA3,ISUBRO,IERROR)
11346C
11347C     PURPOSE--FOR THE "BEST DISTRIBUTIONAL FIT" COMMAND, THIS
11348C              ROUTINE PERFORMS CERTAIN CHECKS FOR MAXIMUM LIKELIHOOD
11349C              ESTIMATION:
11350C
11351C                 1. FOR DISTRIBUTIONS THAT EXPECT "POSITIVE" DATA,
11352C                    (OR "NEGATIVE" DATA), CHECK FOR NON-POSITIVE
11353C                    (OR NON-NEGATIVE) VALUES.
11354C
11355C                 2. FOR THE GENERALIZED PARETO AND GENERALIZED
11356C                    EXTREME VALUE, SPECIFY THAT THE "ELEMENTAL
11357C                    PERCENTILES" METHOD SHOULD BE USED SINCE
11358C                    MAXIMUM LIKELIHOOD ESTIMATES ARE ONLY
11359C                    AVAILABLE FOR A LIMITED RANGE OF PARAMETER
11360C                    VALUES.
11361C
11362C                 3. SET A FLAG IF ML METHOD CURRENTLY NOT
11363C                    AVAILABLE FOR THE GIVEN DISTRIBUTION.
11364C
11365C              NOTE THAT CURRENTLY THESE VALUES ARE NOT SETTABLE
11366C              BY THE USER.
11367C
11368C     WRITTEN BY--ALAN HECKERT
11369C                 STATISTICAL ENGINEERING DIVISION
11370C                 INFORMATION TECHNOLOGY LABORATORY
11371C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11372C                 GAITHERSBURG, MD 20899-8980
11373C                 PHONE--301-975-2899
11374C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11375C           OF THE NATIONAL BUREAU OF STANDARDS.
11376C     LANGUAGE--ANSI FORTRAN (1977)
11377C     VERSION NUMBER--2011/3
11378C     ORIGINAL VERSION--MARCH     2011.
11379C     UPDATED         --JUNE      2013. SOME TWEAKS
11380C
11381C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11382C
11383      CHARACTER*4 IDIST
11384      CHARACTER*4 IDFTTY
11385      CHARACTER*4 IBFICR
11386      CHARACTER*4 IBUGA3
11387      CHARACTER*4 ISUBRO
11388      CHARACTER*4 IERROR
11389C
11390C---------------------------------------------------------------------
11391C
11392      DIMENSION Y(*)
11393      DIMENSION YOUT(*)
11394C
11395      CHARACTER*4 ISTEPN
11396      CHARACTER*4 ISUBN1
11397      CHARACTER*4 ISUBN2
11398C
11399C---------------------------------------------------------------------
11400C
11401      INCLUDE 'DPCOP2.INC'
11402C
11403C-----START POINT-----------------------------------------------------
11404C
11405      IERROR='NO'
11406      ISUBN1='DPBE'
11407      ISUBN2='F4  '
11408C
11409      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF4')THEN
11410        WRITE(ICOUT,999)
11411  999   FORMAT(1X)
11412        CALL DPWRST('XXX','BUG ')
11413        WRITE(ICOUT,71)
11414   71   FORMAT('***** AT THE BEGINNING OF DPBEF4--')
11415        CALL DPWRST('XXX','BUG ')
11416        WRITE(ICOUT,72)IDIST,N,YMIN,YLOWLM,YUPPLM
11417   72   FORMAT('IDIST,N,YMIN,YLOWLM,YUPPLM = ',A4,2X,I8,3G15.7)
11418        CALL DPWRST('XXX','BUG ')
11419      ENDIF
11420C
11421C               ********************************************
11422C               **  STEP 1--                              **
11423C               **  PERFROM CHECKS FOR VARIOUS            **
11424C               **  DISTRIBUTIONS                         **
11425C               ********************************************
11426C
11427      ISTEPN='1'
11428      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF4')
11429     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11430C
11431      IDFTTY='ML'
11432      ISKIP=0
11433      DO110I=1,N
11434        YOUT(I)=Y(I)
11435  110 CONTINUE
11436C
11437C     STEP 1: SPECIFY METHOD
11438C             GENERALIZED PARETO, GENERALIZED EXTREME VALUE USE
11439C             ELEMENTAL PERCENTILES ESTIMATES.
11440C
11441C             FOR 4-PARAMETER BETA, USE METHOD OF MOMENTS
11442C
11443      IF(IDIST.EQ.'GPAR' .OR. IDIST.EQ.'GEV')THEN
11444        IDFTTY='EPER'
11445      ELSEIF(IDIST.EQ.'4BET')THEN
11446        IDFTTY='MOME'
11447      ENDIF
11448C
11449C     STEP 2: DETECT DISTRIBUTION WHERE ML NOT CURRENTLY SUPPORTED
11450C
11451C             FOR GENERALIZED PARETO, ONLY DO MAX CASE IF YMIN > 0
11452C             AND ONLY DO MIN CASE IF YMAX < 0
11453C
11454C             FOR BIC/AIC/AICC, SKIP POWER, REFLECTED POWER, AND
11455C             GENERALIZED REFLECTED TOPP AND LEONE DISTRIBUTIONS
11456C
11457      ISKIP=0
11458      IF(IDIST.EQ.'WALD')ISKIP=1
11459      IF(IDIST.EQ.'TULA')ISKIP=1
11460      IF(IDIST.EQ.'COSI')ISKIP=1
11461      IF(IDIST.EQ.'ANGL')ISKIP=1
11462      IF(IDIST.EQ.'HSEC')ISKIP=1
11463CCCCC IF(IDIST.EQ.'HNOR')ISKIP=1
11464      IF(IDIST.EQ.'GEV ')ISKIP=1
11465      IF(IDIST.EQ.'GHPP')ISKIP=1
11466      IF(IDIST.EQ.'GTLA')ISKIP=1
11467      IF(IDIST.EQ.'ARSI')ISKIP=1
11468      IF(IDIST.EQ.'LGAM')ISKIP=1
11469      IF(IDIST.EQ.'DGAM')ISKIP=1
11470      IF(IDIST.EQ.'DWEI')ISKIP=1
11471      IF(IDIST.EQ.'LOGL')ISKIP=1
11472      IF(IDIST.EQ.'BRAD')ISKIP=1
11473      IF(IDIST.EQ.'LDEX')ISKIP=1
11474      IF(IDIST.EQ.'ERRO')ISKIP=1
11475      IF(IDIST.EQ.'3WEI' .AND. MINMAX.EQ.2)ISKIP=1
11476CCCCC IF(IDIST.EQ.'PARE' .AND. YMIN.LE.0.0)ISKIP=1
11477      IF(IDIST.EQ.'GPAR' .AND. IBFICR.EQ.'AIC')ISKIP=1
11478      IF(IDIST.EQ.'GPAR' .AND. IBFICR.EQ.'AICC')ISKIP=1
11479      IF(IDIST.EQ.'GPAR' .AND. IBFICR.EQ.'BIC')ISKIP=1
11480      IF(IDIST.EQ.'TSPO')ISKIP=1
11481C
11482C     FOR INVERSE GAUSSIAN, ONLY COMPUTE ML ESTIMATES IF THE
11483C     SKEWNESS PARAMETER IS POSITIVE.
11484C
11485      IF(IDIST.EQ.'INGA' .OR. IDIST.EQ.'3IGA')THEN
11486        IF(XSKEW.LE.0.0)ISKIP=1
11487      ENDIF
11488C
11489C     2013/06: FOR FOLLOWING DISTRIBUTIONS, SKIP FOR
11490C              AIC/AICC/BIC UNLESS USER HAS SPECIFIED
11491C              LOWER/UPPER LIMITS.  USING THE MIN/MAX
11492C              (WITH POSSIBLY AN EPSILON FUDEGE FACTOR)
11493C              APPEARS TO DISTORT THE LOG-LIKLIHOOD IN
11494C              SOME CASES, WHICH IS WHY WE SKIP THESE.
11495C              THIS IS PARTICULARLY TRUE WHEN THE ESTIMATED
11496C              SHAPE PARAMETERS RESULT IN A U-SHAPED OR
11497C              J-SHAPED DISTRIBUTION.
11498C
11499C              FOR 2-PARAMETER BETA, TOPP AND LEONE, AND
11500C              REFLECTED GENERALIZED TOPP AND LEONE, CHECK
11501C              THE VALUE OF THE ESTIMATED SHAPE PARAMETERS
11502C              BEFORE DECIDING WHETHER TO SKIP.
11503C
11504C              IF LIMIT BASED DISTRIBUTION ESTIMATES THESE
11505C              LOWER/UPPER LIMITS (UNIFORM, TRIANGULAR), THEN
11506C              DON'T SKIP.
11507C
11508C              TWEAKED THE ML ROUTINES TO ADD A LITTLE MORE TO
11509C              THE LOWER/UPPER LIMITS AND MOFIFIED THE COMPUTATION
11510C              OF THE LOG LIKELIHOOD (WHEN DATA SCALED TO 0 - 1,
11511C              NEED TO ADJUST SO THAT LOG-LIKELIHOOD IN ORIGINAL
11512C              UNITS).
11513C
11514CCCCC IF(IDIST.EQ.'POWF' .OR. IDIST.EQ.'RPOW')THEN
11515CCCCC   IF(IBFICR.EQ.'AIC')ISKIP=1
11516CCCCC   IF(IBFICR.EQ.'AICC')ISKIP=1
11517CCCCC   IF(IBFICR.EQ.'BIC')ISKIP=1
11518CCCCC ENDIF
11519C
11520C     FOR NOW, SKIP GENERALIZED PARETO AS THIS SEEMS TO HAVE
11521C     PROBLEMS FOR SOME DATA SETS.  MAY RESTORE IF WE CAN FIND
11522C     WAY TO ENSURE ELEMENTAL PERCENTILE METHOD WILL NOT FAIL.
11523C
11524      IF(IDIST.EQ.'GPAR')THEN
11525        IF(MINMAX.NE.1)THEN
11526          IF(YMIN.LE.0.0)ISKIP=1
11527        ELSEIF(MINMAX.EQ.1)THEN
11528          IF(YMAX.GE.0.0)ISKIP=1
11529        ENDIF
11530      ENDIF
11531      IF(IDIST.EQ.'GPAR')ISKIP=1
11532C
11533      IF(ISKIP.EQ.1)GOTO9000
11534C
11535C     STEP 3: DISTRIBUTIONS EXPECTING POSITIVE VALUES
11536C
11537C             1) 2-PARAMETER WEIBULL (MINIMUM)
11538C             2) 2-PARAMETER INVERTED WEIBULL
11539C             3) GENERALIZED PARETO (MAXIMUM)
11540C             4) LOGNORMAL
11541C             5) FRECHET (MAXIMUM)
11542C             6) GAMMA
11543C             7) INVERTED GAMMA
11544C             8) GENERALIZED GEOMETRIC EXPONENTIAL
11545C             9) FATIGUE LIFE (BIRNBAUM SAUNDERS)
11546C            10) PARETO
11547C            11) LOGISTIC EXPONENTIAL
11548C            12) FOLDED NORMAL
11549C            13) 1-PARAMETER MAXWELL
11550C            14) GENERALIZED EXTREME VALUE (MAXIMUM)
11551C            15) BURR TYPE 10
11552C
11553      IF(YMIN.LE.0.0)THEN
11554        IMOD=0
11555        IF(IDIST.EQ.'WEIB' .AND. MINMAX.EQ.1)IMOD=1
11556        IF(IDIST.EQ.'GPAR' .AND. MINMAX.EQ.2)IMOD=1
11557        IF(IDIST.EQ.'EV2 ' .AND. MINMAX.EQ.2)IMOD=1
11558        IF(IDIST.EQ.'GEV ' .AND. MINMAX.EQ.2)IMOD=1
11559        IF(IDIST.EQ.'IWEI')IMOD=1
11560        IF(IDIST.EQ.'LOGN')IMOD=1
11561        IF(IDIST.EQ.'GAMM')IMOD=1
11562        IF(IDIST.EQ.'IGAM')IMOD=1
11563        IF(IDIST.EQ.'GEEX')IMOD=1
11564        IF(IDIST.EQ.'LEXP')IMOD=1
11565        IF(IDIST.EQ.'FATL')IMOD=1
11566        IF(IDIST.EQ.'PARE')IMOD=1
11567        IF(IDIST.EQ.'FNOR')IMOD=1
11568        IF(IDIST.EQ.'MAXW')IMOD=1
11569        IF(IDIST.EQ.'1MAX')IMOD=1
11570        IF(IDIST.EQ.'BU10')IMOD=1
11571        IF(IMOD.EQ.1)THEN
11572          EPS=0.000001
11573          DO310I=1,N
11574            YOUT(I)=Y(I) - YMIN + EPS
11575  310     CONTINUE
11576        ENDIF
11577      ENDIF
11578C
11579C     STEP 4: DISTRIBUTIONS EXPECTING NEGATIVE VALUES
11580C
11581C             1) 2-PARAMETER WEIBULL (MAXIMUM)
11582C             2) GENERALIZED PARETO (MINIMUM)
11583C             3) FRECHET (MINIMUM)
11584C             4) GENERALIZED EXTREME VALUE (MINIMUM)
11585C
11586      IF(YMAX.GE.0.0)THEN
11587        IMOD=0
11588        IF(IDIST.EQ.'WEIB' .AND. MINMAX.EQ.2)IMOD=1
11589        IF(IDIST.EQ.'GPAR' .AND. MINMAX.EQ.1)IMOD=1
11590        IF(IDIST.EQ.'EV2 ' .AND. MINMAX.EQ.1)IMOD=1
11591        IF(IDIST.EQ.'GEV ' .AND. MINMAX.EQ.1)IMOD=1
11592        IF(IMOD.EQ.1)THEN
11593          EPS=0.000001
11594          DO410I=1,N
11595            YOUT(I)=Y(I) - YMAX - EPS
11596  410     CONTINUE
11597        ENDIF
11598      ENDIF
11599C
11600C               *****************
11601C               **  STEP 90--  **
11602C               **  EXIT       **
11603C               *****************
11604C
11605 9000 CONTINUE
11606      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF4')THEN
11607        WRITE(ICOUT,999)
11608        CALL DPWRST('XXX','BUG ')
11609        WRITE(ICOUT,9011)
11610 9011   FORMAT('***** AT THE END       OF DPBEF4--')
11611        CALL DPWRST('XXX','BUG ')
11612        WRITE(ICOUT,9015)IDFTTY,ISKIP
11613 9015   FORMAT('IDFTTY,ISKIP = ',A4,2X,I5)
11614        CALL DPWRST('XXX','BUG ')
11615      ENDIF
11616C
11617      RETURN
11618      END
11619      SUBROUTINE DPBEF5(IBFIME,IDIST,XMIN,XMAX,XMED,
11620     1                  ALOC,ASCALE,A,B,
11621     1                  SHAPE1,SHAPE2,
11622     1                  IBUGA3,ISUBRO,IERROR)
11623C
11624C     PURPOSE--UTILITY ROUTINE FOR THE "BEST DISTRIBUTIONAL FIT" COMMAND.
11625C              IF THE FIT IS COMPUTED VIA PPCC, BUT THE RANKING IS PERFORMED
11626C              BY ANDERSON-DARLING, KOLMOGOROV-SMIRNOV, OR AIC, WE MAY NEED
11627C              TO TWEAK THE LOCATION AND SCALE PARAMETERS A BIT SO THAT THE
11628C              DATA VALUES ARE IN AN APPROPRIATE RANGE.  THERE ARE 2 BASIC
11629C              CASES TO CONSIDER:
11630C
11631C                 1. THE DATA ARE BOUNDED BELOW (TYPICALLY AT 0).
11632C
11633C                 2. THE DATA ARE BOUNDED AT BOTH ENDS (TYPICALLY (0,1)).
11634C
11635C
11636C     WRITTEN BY--ALAN HECKERT
11637C                 STATISTICAL ENGINEERING DIVISION
11638C                 INFORMATION TECHNOLOGY LABORATORY
11639C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11640C                 GAITHERSBURG, MD 20899-8980
11641C                 PHONE--301-975-2899
11642C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11643C           OF THE NATIONAL BUREAU OF STANDARDS.
11644C     LANGUAGE--ANSI FORTRAN (1977)
11645C     VERSION NUMBER--2012/9
11646C     ORIGINAL VERSION--SEPTEMBER 2012.
11647C     UPDATED         --JULY      2013. FOR BOUNDED BELOW, ONLY
11648C                                       TWEAK IF LOCATION GREATER
11649C                                       THAN MINIMUM VALUE
11650C     UPDATED         --JANUARY   2014. TWEAK BOUNDED IN BOTH DIRECTIONS
11651C                                       CASE A BIT
11652C
11653C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11654C
11655      CHARACTER*4 IBFIME
11656      CHARACTER*4 IDIST
11657      CHARACTER*4 IBUGA3
11658      CHARACTER*4 ISUBRO
11659      CHARACTER*4 IERROR
11660C
11661C---------------------------------------------------------------------
11662C
11663      CHARACTER*4 ISTEPN
11664      CHARACTER*4 ISUBN1
11665      CHARACTER*4 ISUBN2
11666C
11667C---------------------------------------------------------------------
11668C
11669      INCLUDE 'DPCOP2.INC'
11670C
11671      DATA PI / 3.1415926535 /
11672C
11673C-----START POINT-----------------------------------------------------
11674C
11675      IERROR='NO'
11676      ISUBN1='DPBE'
11677      ISUBN2='F5  '
11678C
11679      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF5')THEN
11680        WRITE(ICOUT,999)
11681  999   FORMAT(1X)
11682        CALL DPWRST('XXX','BUG ')
11683        WRITE(ICOUT,71)
11684   71   FORMAT('***** AT THE BEGINNING OF DPBEF5--')
11685        CALL DPWRST('XXX','BUG ')
11686        WRITE(ICOUT,72)IDIST,IBFIME
11687   72   FORMAT('IDIST,IBFIME = ',A4,2X,A4)
11688        CALL DPWRST('XXX','BUG ')
11689      ENDIF
11690C
11691C               ********************************************
11692C               **  STEP 1--                              **
11693C               **  SET THE PARAMETERS BASED ON THE       **
11694C               **  DISTRIBUTION                          **
11695C               ********************************************
11696C
11697      ISTEPN='1'
11698      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF5')
11699     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
11700C
11701C     DETERMINE WHICH CASE:
11702C
11703C       0 => NO CHECK NEEDED
11704C       1 => BOUNDED BELOW AT LOCACTION PARAMETER
11705C       2 => BOUNDED BOTH BELOW AND ABOVE, CHECK BASED ON A AND B
11706C            PARAMETERS
11707C       3 => SPECIAL CASES
11708C
11709C     NOTE THAT ONLY A FEW OF THE 2 SHAPE PARAMETER DISTRIBUTIONS
11710C     WILL FIT USING PPCC METHOD.
11711C
11712C     CASE 1: BOUNDED BELOW BY THE LOCATION PARAMETER, JUST SET LOCATION
11713C             PARAMETER TO DATA MINIMUM MINUS SOME EPSILON.
11714C
11715      EPS=1.0E-12
11716      IF(IDIST.EQ.'EXPO' .OR. IDIST.EQ.'RAYL' .OR. IDIST.EQ.'3WEI' .OR.
11717     1   IDIST.EQ.'IWEI' .OR. IDIST.EQ.'WALD' .OR. IDIST.EQ.'LOGN' .OR.
11718     1   IDIST.EQ.'EV2 ' .OR. IDIST.EQ.'GAMM' .OR. IDIST.EQ.'IGAM' .OR.
11719     1   IDIST.EQ.'HNOR' .OR. IDIST.EQ.'MAXW' .OR. IDIST.EQ.'LGAM' .OR.
11720     1   IDIST.EQ.'LOGL' .OR. IDIST.EQ.'LDEX' .OR. IDIST.EQ.'BU10' .OR.
11721     1   IDIST.EQ.'3LGN' .OR.
11722     1   IDIST.EQ.'GEEX' .OR. IDIST.EQ.'FATL' .OR. IDIST.EQ.'LEXP') THEN
11723         IF(ALOC.GT.XMIN)THEN
11724           ALOC=XMIN - EPS
11725         ENDIF
11726C
11727C     CASE 2: BOUNDED BOTH ABOVE AND BELOW.
11728C
11729C             2014/01: TWEAK THIS A BIT SO THAT IF OUT OF
11730C                      RANGE IN ONLY ONE DIRECTION, JUST CHANGE
11731C                      THAT DIRECTION.
11732C
11733C             2014/01: SET EPS BASED ON RANGE OF DATA.  SPECIFICALLY,
11734C                      SET TO 0.1% OF DATA RANGE.
11735C
11736      ELSEIF(IDIST.EQ.'UNIF' .OR. IDIST.EQ.'TOPL' .OR.
11737     1       IDIST.EQ.'TRIA' .OR.
11738     1       IDIST.EQ.'POWF' .OR. IDIST.EQ.'RPOW')THEN
11739        XRANGE=XMAX - XMIN
11740        EPS=0.001*XRANGE
11741        ZMIN=A
11742        ZMAX=B
11743        IF(ZMIN.GT.XMIN .AND. ZMAX.LT.XMAX)THEN
11744          A=XMIN-EPS
11745          B=XMAX+EPS
11746          ALOC=A
11747          ASCALE=B - A
11748        ELSEIF(ZMIN.GT.XMIN)THEN
11749          B=ZMAX
11750          A=XMIN-EPS
11751          ALOC=A
11752          ASCALE=B - A
11753        ELSEIF(ZMAX.LT.XMAX)THEN
11754          A=ZMIN
11755          B=XMAX+EPS
11756          ALOC=A
11757          ASCALE=B - A
11758        ENDIF
11759C
11760C     CASE 3: SPECIAL CASES
11761C
11762      ELSEIF(IDIST.EQ.'BRAD' .OR. IDIST.EQ.'ANGL' .OR.
11763     1       IDIST.EQ.'COSI' .OR. IDIST.EQ.'ARSI')THEN
11764        AMIN=0.0
11765        AMAX=1.0
11766        IF(IDIST.EQ.'ANGL')THEN
11767          AMIN=-PI/4.0
11768          AMAX=PI/4.0
11769        ELSEIF(IDIST.EQ.'COSI')THEN
11770          AMIN=-PI
11771          AMAX=PI
11772        ENDIF
11773        ZMIN=(XMIN-ALOC)/ASCALE
11774        ZMAX=(XMAX-ALOC)/ASCALE
11775        IF(ZMIN.LT.AMIN .OR. ZMAX.GT.AMAX)THEN
11776           CMIN=AMIN
11777           CMAX=AMAX
11778           CONST=CMIN/CMAX
11779           IF(CONST.NE.-1.0)THEN
11780             ALOC=(XMIN-CONST*XMAX)/(1.0+CONST) - EPS
11781             ASCALE=(XMAX-ALOC)/CMAX + EPS
11782           ELSE
11783             ALOC=XMIN - EPS
11784             ASCALE=(XMAX - ALOC)/AMAX
11785           ENDIF
11786        ENDIF
11787      ELSEIF(IDIST.EQ.'PARE')THEN
11788        IF(XMIN.GT.SHAPE2)THEN
11789          SHAPE2=XMIN
11790        ENDIF
11791      ELSEIF(IDIST.EQ.'TULA' .AND. SHAPE1.GT.0.0)THEN
11792        AMAX=ABS(1.0/SHAPE1)
11793        AMIN=-AMAX
11794        IF((XMIN-ALOC)/ASCALE.LT.AMIN .OR.
11795     1     (XMAX-ALOC)/ASCALE.GT.AMAX)THEN
11796           ALOC=XMED
11797           ATEMP1=SHAPE1*ABS(XMAX-ALOC) + 0.1
11798           ATEMP2=SHAPE2*ABS(XMIN-ALOC) + 0.1
11799           ASCALE=MAX(ATEMP1,ATEMP2)
11800        ENDIF
11801C
11802C     NO CHECK REQUIRED
11803C
11804      ELSE
11805        GOTO9000
11806      ENDIF
11807C
11808C               *****************
11809C               **  STEP 90--  **
11810C               **  EXIT       **
11811C               *****************
11812C
11813 9000 CONTINUE
11814      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BEF5')THEN
11815        WRITE(ICOUT,999)
11816        CALL DPWRST('XXX','BUG ')
11817        WRITE(ICOUT,9011)
11818 9011   FORMAT('***** AT THE END       OF DPBEF5--')
11819        CALL DPWRST('XXX','BUG ')
11820        WRITE(ICOUT,9013)
11821 9013   FORMAT('SHAP11,SHAP12,IPPCAP(1) = ',2G15.7,I8)
11822        CALL DPWRST('XXX','BUG ')
11823      ENDIF
11824C
11825      RETURN
11826      END
11827      SUBROUTINE DPBELL(IHARG,NUMARG,IBELSW,IFOUND,IERROR)
11828C
11829C     PURPOSE--DEFINE THE BELL SWITCH IBELSW.
11830C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
11831C                     --NUMARG
11832C     OUTPUT ARGUMENTS--IBELSW  ('ON'  OR 'OFF')
11833C                     --IFOUND ('YES' OR 'NO' )
11834C                     --IERROR ('YES' OR 'NO' )
11835C     WRITTEN BY--JAMES J. FILLIBEN
11836C                 STATISTICAL ENGINEERING DIVISION
11837C                 INFORMATION TECHNOLOGY LABORATORY
11838C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11839C                 GAITHERSBURG, MD 20899-8980
11840C                 PHONE--301-975-2855
11841C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11842C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11843C     LANGUAGE--ANSI FORTRAN (1977)
11844C     VERSION NUMBER--82/7
11845C     ORIGINAL VERSION--NOVEMBER  1978.
11846C     UPDATED         --SEPTEMBER 1980.
11847C     UPDATED         --MAY       1982.
11848C
11849C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11850C
11851      CHARACTER*4 IHARG
11852      CHARACTER*4 IBELSW
11853      CHARACTER*4 IFOUND
11854      CHARACTER*4 IERROR
11855C
11856C---------------------------------------------------------------------
11857C
11858      DIMENSION IHARG(*)
11859C
11860C---------------------------------------------------------------------
11861C
11862      INCLUDE 'DPCOP2.INC'
11863C
11864C-----START POINT-----------------------------------------------------
11865C
11866      IFOUND='NO'
11867      IERROR='NO'
11868C
11869      IF(NUMARG.EQ.0)GOTO1150
11870      IF(NUMARG.GE.1)GOTO1110
11871      GOTO1199
11872C
11873 1110 CONTINUE
11874      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
11875      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
11876      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
11877      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160
11878      GOTO1199
11879C
11880 1150 CONTINUE
11881      IBELSW='ON'
11882      GOTO1180
11883C
11884 1160 CONTINUE
11885      IBELSW='OFF'
11886      GOTO1180
11887C
11888 1180 CONTINUE
11889      IFOUND='YES'
11890C
11891      IF(IFEEDB.EQ.'OFF')GOTO1189
11892      WRITE(ICOUT,999)
11893  999 FORMAT(1X)
11894      CALL DPWRST('XXX','BUG ')
11895      WRITE(ICOUT,1181)IBELSW
11896 1181 FORMAT('THE BELL SWITCH HAS JUST BEEN TURNED ',
11897     1A4)
11898      CALL DPWRST('XXX','BUG ')
11899 1189 CONTINUE
11900      GOTO1199
11901C
11902 1199 CONTINUE
11903      RETURN
11904      END
11905      SUBROUTINE DPBFCO(IHARG,NUMARG,IDEBFC,MAXBAR,IBAFCO,
11906     1IBUGP2,IFOUND,IERROR)
11907C
11908C     PURPOSE--DEFINE THE BAR FILL COLORS = THE COLORS
11909C              OF THE (BACKGROUND) FILL WITHIN THE BARS.
11910C              THESE ARE LOCATED IN THE VECTOR IBAFCO(.).
11911C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
11912C                     --NUMARG
11913C                     --IDEBFC
11914C                     --MAXBAR
11915C                     --IBUGP2 ('ON' OR 'OFF' )
11916C     OUTPUT ARGUMENTS--IBAFCO (A CHARACTER VECTOR)
11917C                     --IFOUND ('YES' OR 'NO' )
11918C                     --IERROR ('YES' OR 'NO' )
11919C     WRITTEN BY--JAMES J. FILLIBEN
11920C                 STATISTICAL ENGINEERING DIVISION
11921C                 INFORMATION TECHNOLOGY LABORATORY
11922C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
11923C                 GAITHERSBURG, MD 20899-8980
11924C                 PHONE--301-975-2855
11925C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
11926C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
11927C     LANGUAGE--ANSI FORTRAN (1977)
11928C     VERSION NUMBER--82/7
11929C     ORIGINAL VERSION--DECEMBER  1983.
11930C
11931C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
11932C
11933      CHARACTER*4 IHARG
11934      CHARACTER*4 IDEBFC
11935      CHARACTER*4 IBAFCO
11936C
11937      CHARACTER*4 IBUGP2
11938      CHARACTER*4 IFOUND
11939      CHARACTER*4 IERROR
11940C
11941      CHARACTER*4 IHOLD1
11942      CHARACTER*4 IHOLD2
11943C
11944      CHARACTER*4 ISUBN1
11945      CHARACTER*4 ISUBN2
11946      CHARACTER*4 ISTEPN
11947C
11948      DIMENSION IHARG(*)
11949      DIMENSION IBAFCO(*)
11950C
11951C---------------------------------------------------------------------
11952C
11953      INCLUDE 'DPCOP2.INC'
11954C
11955C-----START POINT-----------------------------------------------------
11956C
11957      IFOUND='NO'
11958      IERROR='NO'
11959C
11960      ISUBN1='DPBF'
11961      ISUBN2='CO  '
11962C
11963      NUMBAR=0
11964      IHOLD1='-999'
11965      IHOLD2='-999'
11966C
11967      IF(IBUGP2.EQ.'OFF')GOTO90
11968      WRITE(ICOUT,999)
11969  999 FORMAT(1X)
11970      CALL DPWRST('XXX','BUG ')
11971      WRITE(ICOUT,51)
11972   51 FORMAT('***** AT THE BEGINNING OF DPBFCO--')
11973      CALL DPWRST('XXX','BUG ')
11974      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
11975   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
11976      CALL DPWRST('XXX','BUG ')
11977      WRITE(ICOUT,53)MAXBAR,NUMBAR
11978   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
11979      CALL DPWRST('XXX','BUG ')
11980      WRITE(ICOUT,54)IHOLD1,IHOLD2
11981   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
11982      CALL DPWRST('XXX','BUG ')
11983      WRITE(ICOUT,55)IDEBFC
11984   55 FORMAT('IDEBFC = ',A4)
11985      CALL DPWRST('XXX','BUG ')
11986      WRITE(ICOUT,60)NUMARG
11987   60 FORMAT('NUMARG = ',I8)
11988      CALL DPWRST('XXX','BUG ')
11989      DO65I=1,NUMARG
11990      WRITE(ICOUT,66)IHARG(I)
11991   66 FORMAT('IHARG(I) = ',A4)
11992      CALL DPWRST('XXX','BUG ')
11993   65 CONTINUE
11994      WRITE(ICOUT,70)IBAFCO(1)
11995   70 FORMAT('IBAFCO(1) = ',A4)
11996      CALL DPWRST('XXX','BUG ')
11997      DO75I=1,10
11998      WRITE(ICOUT,76)I,IBAFCO(I)
11999   76 FORMAT('I,IBAFCO(I) = ',I8,2X,A4)
12000      CALL DPWRST('XXX','BUG ')
12001   75 CONTINUE
12002   90 CONTINUE
12003C
12004C               **************************************
12005C               **  STEP 1--                        **
12006C               **  BRANCH TO THE APPROPRIATE CASE  **
12007C               **************************************
12008C
12009      ISTEPN='1'
12010      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12011C
12012      IF(NUMARG.LE.1)GOTO9000
12013      IF(NUMARG.EQ.2)GOTO1120
12014      IF(NUMARG.EQ.3)GOTO1130
12015      IF(NUMARG.EQ.4)GOTO1140
12016      GOTO1150
12017C
12018 1120 CONTINUE
12019      GOTO1200
12020C
12021 1130 CONTINUE
12022      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
12023      IF(IHARG(3).EQ.'ALL')GOTO1300
12024      GOTO1200
12025C
12026 1140 CONTINUE
12027      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
12028      IF(IHARG(3).EQ.'ALL')GOTO1300
12029      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
12030      IF(IHARG(4).EQ.'ALL')GOTO1300
12031      GOTO1200
12032C
12033 1150 CONTINUE
12034      GOTO1200
12035C
12036C               *************************************************
12037C               **  STEP 2--                                   **
12038C               **  TREAT THE SINGLE      SPECIFICATION  CASE  **
12039C               *************************************************
12040C
12041 1200 CONTINUE
12042      ISTEPN='2'
12043      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12044C
12045      IF(NUMARG.LE.2)GOTO1210
12046      GOTO1220
12047C
12048 1210 CONTINUE
12049      NUMBAR=1
12050      IBAFCO(1)=IDEBFC
12051      GOTO1270
12052C
12053 1220 CONTINUE
12054      NUMBAR=NUMARG-2
12055      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
12056      DO1225I=1,NUMBAR
12057      J=I+2
12058      IHOLD1=IHARG(J)
12059      IHOLD2=IHOLD1
12060      IF(IHOLD1.EQ.'ON')IHOLD2=IDEBFC
12061      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBFC
12062      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBFC
12063      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBFC
12064      IBAFCO(I)=IHOLD2
12065 1225 CONTINUE
12066      GOTO1270
12067C
12068 1270 CONTINUE
12069      IF(IFEEDB.EQ.'OFF')GOTO1279
12070      WRITE(ICOUT,999)
12071      CALL DPWRST('XXX','BUG ')
12072      DO1278I=1,NUMBAR
12073      WRITE(ICOUT,1276)I,IBAFCO(I)
12074 1276 FORMAT('THE FILL COLOR OF BAR ',I6,
12075     1' HAS JUST BEEN SET TO ',A4)
12076      CALL DPWRST('XXX','BUG ')
12077 1278 CONTINUE
12078 1279 CONTINUE
12079      IFOUND='YES'
12080      GOTO9000
12081C
12082C               **************************
12083C               **  STEP 3--            **
12084C               **  TREAT THE ALL CASE  **
12085C               **************************
12086C
12087 1300 CONTINUE
12088      ISTEPN='3'
12089      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12090C
12091      NUMBAR=MAXBAR
12092      IHOLD2=IHOLD1
12093      IF(IHOLD1.EQ.'ON')IHOLD2=IDEBFC
12094      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBFC
12095      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBFC
12096      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBFC
12097      DO1315I=1,NUMBAR
12098      IBAFCO(I)=IHOLD2
12099 1315 CONTINUE
12100      GOTO1370
12101C
12102 1370 CONTINUE
12103      IF(IFEEDB.EQ.'OFF')GOTO1319
12104      WRITE(ICOUT,999)
12105      CALL DPWRST('XXX','BUG ')
12106      I=1
12107      WRITE(ICOUT,1316)IBAFCO(I)
12108 1316 FORMAT('THE FILL COLOR OF ALL BARS',
12109     1' HAS JUST BEEN SET TO ',A4)
12110      CALL DPWRST('XXX','BUG ')
12111 1319 CONTINUE
12112      IFOUND='YES'
12113      GOTO9000
12114C
12115C               *****************
12116C               **  STEP 90--  **
12117C               **  EXIT       **
12118C               *****************
12119C
12120 9000 CONTINUE
12121      IF(IBUGP2.EQ.'OFF')GOTO9090
12122      WRITE(ICOUT,9011)
12123 9011 FORMAT('***** AT THE END       OF DPBFCO--')
12124      CALL DPWRST('XXX','BUG ')
12125      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
12126 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
12127      CALL DPWRST('XXX','BUG ')
12128      WRITE(ICOUT,9013)MAXBAR,NUMBAR
12129 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
12130      CALL DPWRST('XXX','BUG ')
12131      WRITE(ICOUT,9014)IHOLD1,IHOLD2
12132 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
12133      CALL DPWRST('XXX','BUG ')
12134      WRITE(ICOUT,9015)IDEBFC
12135 9015 FORMAT('IDEBFC = ',A4)
12136      CALL DPWRST('XXX','BUG ')
12137      WRITE(ICOUT,9020)NUMARG
12138 9020 FORMAT('NUMARG = ',I8)
12139      CALL DPWRST('XXX','BUG ')
12140      DO9025I=1,NUMARG
12141      WRITE(ICOUT,9026)IHARG(I)
12142 9026 FORMAT('IHARG(I) = ',A4)
12143      CALL DPWRST('XXX','BUG ')
12144 9025 CONTINUE
12145      WRITE(ICOUT,9030)IBAFCO(1)
12146 9030 FORMAT('IBAFCO(1) = ',A4)
12147      CALL DPWRST('XXX','BUG ')
12148      DO9035I=1,10
12149      WRITE(ICOUT,9036)I,IBAFCO(I)
12150 9036 FORMAT('I,IBAFCO(I) = ',I8,2X,A4)
12151      CALL DPWRST('XXX','BUG ')
12152 9035 CONTINUE
12153 9090 CONTINUE
12154C
12155      RETURN
12156      END
12157      SUBROUTINE DPBFSW(IHARG,NUMARG,IDEBFS,MAXBAR,IBAFSW,
12158     1IBUGP2,IFOUND,IERROR)
12159C
12160C     PURPOSE--DEFINE THE BAR FILL SWITCHES = THE ON/OFF SWITCHES
12161C              OF THE (BACKGROUND) FILL WITHIN THE BARS.
12162C              THESE ARE LOCATED IN THE VECTOR IBAFSW(.).
12163C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
12164C                     --NUMARG
12165C                     --IDEBFS
12166C                     --MAXBAR
12167C                     --IBUGP2 ('ON' OR 'OFF' )
12168C     OUTPUT ARGUMENTS--IBAFSW (A CHARACTER VECTOR)
12169C                     --IFOUND ('YES' OR 'NO' )
12170C                     --IERROR ('YES' OR 'NO' )
12171C     WRITTEN BY--JAMES J. FILLIBEN
12172C                 STATISTICAL ENGINEERING DIVISION
12173C                 INFORMATION TECHNOLOGY LABORATORY
12174C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12175C                 GAITHERSBURG, MD 20899-8980
12176C                 PHONE--301-975-2855
12177C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12178C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12179C     LANGUAGE--ANSI FORTRAN (1977)
12180C     VERSION NUMBER--82/7
12181C     ORIGINAL VERSION--DECEMBER  1983.
12182C
12183C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12184C
12185      CHARACTER*4 IHARG
12186      CHARACTER*4 IDEBFS
12187      CHARACTER*4 IBAFSW
12188C
12189      CHARACTER*4 IBUGP2
12190      CHARACTER*4 IFOUND
12191      CHARACTER*4 IERROR
12192C
12193      CHARACTER*4 IHOLD1
12194      CHARACTER*4 IHOLD2
12195C
12196      CHARACTER*4 ISUBN1
12197      CHARACTER*4 ISUBN2
12198      CHARACTER*4 ISTEPN
12199C
12200      DIMENSION IHARG(*)
12201      DIMENSION IBAFSW(*)
12202C
12203C---------------------------------------------------------------------
12204C
12205      INCLUDE 'DPCOP2.INC'
12206C
12207C-----START POINT-----------------------------------------------------
12208C
12209      IFOUND='NO'
12210      IERROR='NO'
12211C
12212      ISUBN1='DPBF'
12213      ISUBN2='SW  '
12214C
12215      NUMBAR=0
12216      IHOLD1='-999'
12217      IHOLD2='-999'
12218C
12219      IF(IBUGP2.EQ.'OFF')GOTO90
12220      WRITE(ICOUT,999)
12221  999 FORMAT(1X)
12222      CALL DPWRST('XXX','BUG ')
12223      WRITE(ICOUT,51)
12224   51 FORMAT('***** AT THE BEGINNING OF DPBFSW--')
12225      CALL DPWRST('XXX','BUG ')
12226      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
12227   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
12228      CALL DPWRST('XXX','BUG ')
12229      WRITE(ICOUT,53)MAXBAR,NUMBAR
12230   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
12231      CALL DPWRST('XXX','BUG ')
12232      WRITE(ICOUT,54)IHOLD1,IHOLD2
12233   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
12234      CALL DPWRST('XXX','BUG ')
12235      WRITE(ICOUT,55)IDEBFS
12236   55 FORMAT('IDEBFS = ',A4)
12237      CALL DPWRST('XXX','BUG ')
12238      WRITE(ICOUT,60)NUMARG
12239   60 FORMAT('NUMARG = ',I8)
12240      CALL DPWRST('XXX','BUG ')
12241      DO65I=1,NUMARG
12242      WRITE(ICOUT,66)IHARG(I)
12243   66 FORMAT('IHARG(I) = ',A4)
12244      CALL DPWRST('XXX','BUG ')
12245   65 CONTINUE
12246      WRITE(ICOUT,70)IBAFSW(1)
12247   70 FORMAT('IBAFSW(1) = ',A4)
12248      CALL DPWRST('XXX','BUG ')
12249      DO75I=1,10
12250      WRITE(ICOUT,76)I,IBAFSW(I)
12251   76 FORMAT('I,IBAFSW(I) = ',I8,2X,A4)
12252      CALL DPWRST('XXX','BUG ')
12253   75 CONTINUE
12254   90 CONTINUE
12255C
12256C               **************************************
12257C               **  STEP 1--                        **
12258C               **  BRANCH TO THE APPROPRIATE CASE  **
12259C               **************************************
12260C
12261      ISTEPN='1'
12262      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12263C
12264      IF(NUMARG.LE.1)GOTO9000
12265      IF(NUMARG.EQ.2)GOTO1120
12266      IF(NUMARG.EQ.3)GOTO1130
12267      IF(NUMARG.EQ.4)GOTO1140
12268      GOTO1150
12269C
12270 1120 CONTINUE
12271      GOTO1200
12272C
12273 1130 CONTINUE
12274      IF(IHARG(3).EQ.'ALL')IHOLD1='ON'
12275      IF(IHARG(3).EQ.'ALL')GOTO1300
12276      GOTO1200
12277C
12278 1140 CONTINUE
12279      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
12280      IF(IHARG(3).EQ.'ALL')GOTO1300
12281      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
12282      IF(IHARG(4).EQ.'ALL')GOTO1300
12283      GOTO1200
12284C
12285 1150 CONTINUE
12286      GOTO1200
12287C
12288C               *************************************************
12289C               **  STEP 2--                                   **
12290C               **  TREAT THE SINGLE      SPECIFICATION  CASE  **
12291C               *************************************************
12292C
12293 1200 CONTINUE
12294      ISTEPN='2'
12295      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12296C
12297      IF(NUMARG.LE.2)GOTO1210
12298      GOTO1220
12299C
12300 1210 CONTINUE
12301      NUMBAR=1
12302      IBAFSW(1)='ON'
12303      GOTO1270
12304C
12305 1220 CONTINUE
12306      NUMBAR=NUMARG-2
12307      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
12308      DO1225I=1,NUMBAR
12309      J=I+2
12310      IHOLD1=IHARG(J)
12311      IHOLD2=IHOLD1
12312      IF(IHOLD1.EQ.'ON')IHOLD2='ON'
12313      IF(IHOLD1.EQ.'OFF')IHOLD2='OFF'
12314      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBFS
12315      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBFS
12316      IBAFSW(I)=IHOLD2
12317 1225 CONTINUE
12318      GOTO1270
12319C
12320 1270 CONTINUE
12321      IF(IFEEDB.EQ.'OFF')GOTO1279
12322      WRITE(ICOUT,999)
12323      CALL DPWRST('XXX','BUG ')
12324      DO1278I=1,NUMBAR
12325      WRITE(ICOUT,1276)I,IBAFSW(I)
12326 1276 FORMAT('THE FILL SWITCH FOR BAR ',I6,
12327     1' HAS JUST BEEN SET TO ',A4)
12328      CALL DPWRST('XXX','BUG ')
12329 1278 CONTINUE
12330 1279 CONTINUE
12331      IFOUND='YES'
12332      GOTO9000
12333C
12334C               **************************
12335C               **  STEP 3--            **
12336C               **  TREAT THE ALL CASE  **
12337C               **************************
12338C
12339 1300 CONTINUE
12340      ISTEPN='3'
12341      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12342C
12343      NUMBAR=MAXBAR
12344      IHOLD2=IHOLD1
12345      IF(IHOLD1.EQ.'ON')IHOLD2='ON'
12346      IF(IHOLD1.EQ.'OFF')IHOLD2='OFF'
12347      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBFS
12348      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBFS
12349      DO1315I=1,NUMBAR
12350      IBAFSW(I)=IHOLD2
12351 1315 CONTINUE
12352      GOTO1370
12353C
12354 1370 CONTINUE
12355      IF(IFEEDB.EQ.'OFF')GOTO1319
12356      WRITE(ICOUT,999)
12357      CALL DPWRST('XXX','BUG ')
12358      I=1
12359      WRITE(ICOUT,1316)IBAFSW(I)
12360 1316 FORMAT('THE FILL SWITCH FOR ALL BARS',
12361     1' HAS JUST BEEN SET TO ',A4)
12362      CALL DPWRST('XXX','BUG ')
12363 1319 CONTINUE
12364      IFOUND='YES'
12365      GOTO9000
12366C
12367C               *****************
12368C               **  STEP 90--  **
12369C               **  EXIT       **
12370C               *****************
12371C
12372 9000 CONTINUE
12373      IF(IBUGP2.EQ.'OFF')GOTO9090
12374      WRITE(ICOUT,9011)
12375 9011 FORMAT('***** AT THE END       OF DPBFSW--')
12376      CALL DPWRST('XXX','BUG ')
12377      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
12378 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
12379      CALL DPWRST('XXX','BUG ')
12380      WRITE(ICOUT,9013)MAXBAR,NUMBAR
12381 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
12382      CALL DPWRST('XXX','BUG ')
12383      WRITE(ICOUT,9014)IHOLD1,IHOLD2
12384 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
12385      CALL DPWRST('XXX','BUG ')
12386      WRITE(ICOUT,9015)IDEBFS
12387 9015 FORMAT('IDEBFS = ',A4)
12388      CALL DPWRST('XXX','BUG ')
12389      WRITE(ICOUT,9020)NUMARG
12390 9020 FORMAT('NUMARG = ',I8)
12391      CALL DPWRST('XXX','BUG ')
12392      DO9025I=1,NUMARG
12393      WRITE(ICOUT,9026)IHARG(I)
12394 9026 FORMAT('IHARG(I) = ',A4)
12395      CALL DPWRST('XXX','BUG ')
12396 9025 CONTINUE
12397      WRITE(ICOUT,9030)IBAFSW(1)
12398 9030 FORMAT('IBAFSW(1) = ',A4)
12399      CALL DPWRST('XXX','BUG ')
12400      DO9035I=1,10
12401      WRITE(ICOUT,9036)I,IBAFSW(I)
12402 9036 FORMAT('I,IBAFSW(I) = ',I8,2X,A4)
12403      CALL DPWRST('XXX','BUG ')
12404 9035 CONTINUE
12405 9090 CONTINUE
12406C
12407      RETURN
12408      END
12409      SUBROUTINE DPBIHI(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
12410     1                  CLLIMI,CLWIDT,
12411     1                  IRHSTG,IHSTCW,IASHWT,IHSTEB,IHSTOU,
12412     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
12413C
12414C     PURPOSE--GENERATE ONE OF THE FOLLOWING 5 PLOTS--
12415C              1) BIHISTOGRAM;
12416C              2) RELATIVE BIHISTOGRAM;
12417C              3) CUMULATIVE BIHISTOGRAM;
12418C              4) RELATIVE CUMULATIVE BIHISTOGRAM;
12419C              5) HIGHLIGHTED BIHISTOGRAM (ALSO SUPPORTS
12420C                 RELATIVE/CUMULATIVE VARIANTS);
12421C     WRITTEN BY--JAMES J. FILLIBEN
12422C                 STATISTICAL ENGINEERING DIVISION
12423C                 INFORMATION TECHNOLOGY LABORATORY
12424C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
12425C                 GAITHERSBURG, MD 20899-8980
12426C                 PHONE--301-975-2855
12427C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12428C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
12429C     LANGUAGE--ANSI FORTRAN (1977)
12430C     VERSION NUMBER--88/10
12431C     ORIGINAL VERSION--SEPTEMBER 1988.
12432C     UPDATED         --MARCH     1996. IRHSTG SWITCH
12433C     UPDATED         --AUGUST    2007. MODIFY ARRAY STORAGE TO
12434C                                       USE DPCOZZ.INC
12435C     UPDATED         --JUNE      2011. USE DPPARS AND DPPAR3
12436C     UPDATED         --JUNE      2011. SUPPORT FOR "HIGHLIGHTED" OPTION
12437C     UPDATED         --JUNE      2011. SUPPORT FOR NON-EQUISPACED
12438C                                       HISTOGRAMS
12439C     UPDATED         --JUNE      2011. OPTION TO SUPPRESS EMPTY BINS
12440C     UPDATED         --JUNE      2011. OPTION TO INCLUDE OUTLIERS
12441C
12442C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
12443C
12444      CHARACTER*4 ICASPL
12445      CHARACTER*4 IAND1
12446      CHARACTER*4 IAND2
12447      CHARACTER*4 IBUGG2
12448      CHARACTER*4 IBUGG3
12449      CHARACTER*4 IBUGQ
12450      CHARACTER*4 ISUBRO
12451      CHARACTER*4 IFOUND
12452      CHARACTER*4 IERROR
12453C
12454      CHARACTER*4 IRELAT
12455      CHARACTER*4 ICUMUL
12456      CHARACTER*4 IHWUSE
12457      CHARACTER*4 MESSAG
12458CCCCC CHARACTER*4 IDATSW
12459      CHARACTER*4 IRHSTG
12460      CHARACTER*4 IHSTCW
12461      CHARACTER*4 IASHWT
12462      CHARACTER*4 IHSTEB
12463      CHARACTER*4 IHSTOU
12464      CHARACTER*4 IHIGH
12465      CHARACTER*4 IHP
12466      CHARACTER*4 IHP2
12467      CHARACTER*4 ISUBN1
12468      CHARACTER*4 ISUBN2
12469      CHARACTER*4 ISTEPN
12470C
12471      DOUBLE PRECISION DCLWID
12472      DOUBLE PRECISION DXSTAR
12473      DOUBLE PRECISION DXSTOP
12474C
12475      CHARACTER*4 ICASE
12476      PARAMETER (MAXSPN=10)
12477      CHARACTER*4 IVARN1(MAXSPN)
12478      CHARACTER*4 IVARN2(MAXSPN)
12479      CHARACTER*4 IVARTY(MAXSPN)
12480      REAL PVAR(MAXSPN)
12481      INTEGER ILIS(MAXSPN)
12482      INTEGER NRIGHT(MAXSPN)
12483      INTEGER ICOLR(MAXSPN)
12484      CHARACTER*40 INAME
12485C
12486C---------------------------------------------------------------------
12487C
12488C     AUGUST 2007.  EQUIVALENCE ARRAYS TO DPCOZZ
12489C                   INSTEAD OF PASSING IN FROM MAINGR
12490C
12491      INCLUDE 'DPCOPA.INC'
12492      INCLUDE 'DPCOZZ.INC'
12493C
12494      DIMENSION CLLIMI(*)
12495      DIMENSION CLWIDT(*)
12496      DIMENSION Y1TEMP(MAXOBV)
12497      DIMENSION Y2TEMP(MAXOBV)
12498      DIMENSION C1(MAXOBV)
12499      DIMENSION C2(MAXOBV)
12500      DIMENSION X1HIGH(MAXOBV)
12501      DIMENSION X2HIGH(MAXOBV)
12502      DIMENSION XIDTEM(MAXOBV)
12503      DIMENSION XTEMP1(2*MAXOBV)
12504      DIMENSION XTEMP2(2*MAXOBV)
12505C
12506      EQUIVALENCE (GARBAG(IGARB3),C1(1))
12507      EQUIVALENCE (GARBAG(IGARB4),C2(1))
12508      EQUIVALENCE (GARBAG(IGARB5),X1HIGH(1))
12509      EQUIVALENCE (GARBAG(IGARB6),X2HIGH(1))
12510      EQUIVALENCE (GARBAG(IGARB7),XIDTEM(1))
12511      EQUIVALENCE (GARBAG(IGARB8),Y1TEMP(1))
12512      EQUIVALENCE (GARBAG(IGARB9),Y2TEMP(1))
12513      EQUIVALENCE (GARBAG(IGAR10),XTEMP1(1))
12514      EQUIVALENCE (GARBAG(JGAR12),XTEMP2(1))
12515C
12516C-----COMMON----------------------------------------------------------
12517C
12518      INCLUDE 'DPCOHK.INC'
12519      INCLUDE 'DPCODA.INC'
12520C
12521C-----COMMON VARIABLES (GENERAL)--------------------------------------
12522C
12523      INCLUDE 'DPCOP2.INC'
12524C
12525C-----START POINT-----------------------------------------------------
12526C
12527      IFOUND='NO'
12528      IERROR='NO'
12529      ISUBN1='DPBI'
12530      ISUBN2='HI  '
12531C
12532      MAXCP1=MAXCOL+1
12533      MAXCP2=MAXCOL+2
12534      MAXCP3=MAXCOL+3
12535      MAXCP4=MAXCOL+4
12536      MAXCP5=MAXCOL+5
12537      MAXCP6=MAXCOL+6
12538      NLOCAL=0
12539C
12540C               *******************************************
12541C               **  TREAT THE BIHISTOGRAM AND RELATED    **
12542C               **  STATISTICAL DISTRIBUTION PLOTS CASE  **
12543C               *******************************************
12544C
12545      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BIHI')THEN
12546        WRITE(ICOUT,999)
12547  999   FORMAT(1X)
12548        CALL DPWRST('XXX','BUG ')
12549        WRITE(ICOUT,51)
12550   51   FORMAT('***** AT THE BEGINNING OF DPBIHI--')
12551        CALL DPWRST('XXX','BUG ')
12552        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,NS
12553   52   FORMAT('ICASPL,IAND1,IAND2,NS = ',3(A4,2X),I8)
12554        CALL DPWRST('XXX','BUG ')
12555        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ,ISUBRO
12556   53   FORMAT('IBUGG2,IBUGG3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
12557        CALL DPWRST('XXX','BUG ')
12558      ENDIF
12559C
12560C               ***************************
12561C               **  STEP 1--             **
12562C               **  EXTRACT THE COMMAND  **
12563C               ***************************
12564C
12565      ISTEPN='1'
12566      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIHI')
12567     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12568C
12569
12570      IF(ICOM.EQ.'BIHI')GOTO99
12571      IF(ICOM.EQ.'RELA')GOTO99
12572      IF(ICOM.EQ.'CUMU')GOTO99
12573      IF(ICOM.EQ.'HIGH')GOTO99
12574      IF(ICOM.EQ.'SUBS')GOTO99
12575      IF(ICOM.EQ.'BIRO')GOTO99
12576      IF(ICOM.EQ.'BIAS' .AND. ICOM2.EQ.'H   ')GOTO99
12577      GOTO9000
12578C
12579   99 CONTINUE
12580      IRELAT='OFF'
12581      IHIGH='OFF'
12582      ICUMUL='OFF'
12583      ICASPL='    '
12584      ILASTC=0
12585C
12586      IF(ICOM.EQ.'BIAS'.AND.ICOM2.EQ.'H   ')THEN
12587        IFOUND='YES'
12588        ICASPL='BIAS'
12589        IRELAT='ON'
12590        ILASTC=0
12591        GOTO119
12592      ENDIF
12593C
12594      IPOSH=NUMVAR
12595      IF(ICOM.EQ.'BIHI')THEN
12596        ICASPL='BIHI'
12597        IFOUND='YES'
12598        IPOSH=0
12599      ELSEIF(ICOM.EQ.'BIRO')THEN
12600        ICASPL='BIRO'
12601        IFOUND='YES'
12602        IPOSH=0
12603      ELSEIF(ICOM.EQ.'RELA')THEN
12604        IRELAT='ON'
12605      ELSEIF(ICOM.EQ.'CUMU')THEN
12606        ICUMUL='ON'
12607      ELSEIF(ICOM.EQ.'HIGH' .OR. ICOM.EQ.'SUBS')THEN
12608        IHIGH='ON'
12609      ENDIF
12610C
12611C     NOTE: "SUBSET" AND "=" CAN APPEAR AS PART OF SUBSET
12612C           CLAUSE, SO NEED TO BE CAREFUL WHERE IT OCCURS
12613C           IN THE COMMAND.  HANDLE THIS BY REQUIRING THAT
12614C           THEY APPEAR BEFORE THE "BIHISTOGRAM" CLAUSE.
12615C
12616      DO110I=1,NUMARG
12617        IF(IHARG(I).EQ.'=' .AND. I.LT.IPOSH)THEN
12618          IFOUND='NO'
12619          GOTO9000
12620        ELSEIF(IHARG(I).EQ.'BIHI')THEN
12621          ICASPL='BIHI'
12622          ILASTC=I
12623          IFOUND='YES'
12624          IPOSH=I
12625        ELSEIF(IHARG(I).EQ.'BIRO')THEN
12626          ICASPL='BIRO'
12627          ILASTC=I
12628          IFOUND='YES'
12629        ELSEIF(IHARG(I).EQ.'BIAS')THEN
12630          ICASPL='BIAS'
12631          ILASTC=I
12632          IFOUND='YES'
12633        ELSEIF(IHARG(I).EQ.'RELA')THEN
12634          ILASTC=I
12635          IRELAT='ON'
12636        ELSEIF(IHARG(I).EQ.'CUMU')THEN
12637          ILASTC=I
12638          ICUMUL='ON'
12639        ELSEIF(IHARG(I).EQ.'HIGH' .OR. IHARG(I).EQ.'SUBS')THEN
12640          IF(I.LT.IPOSH)THEN
12641            ILASTC=I
12642            IHIGH='ON'
12643          ENDIF
12644        ENDIF
12645  110 CONTINUE
12646C
12647      IF(ICASPL.EQ.'BIHI' .AND. ICUMUL.EQ.'ON')THEN
12648        ICASPL='CBIH'
12649      ELSEIF(ICASPL.EQ.'BIRO' .AND. ICUMUL.EQ.'ON')THEN
12650        ICASPL='CBIR'
12651      ENDIF
12652C
12653      IF((ICASPL.EQ.'BIRO' .OR. ICASPL.EQ.'CBIR') .AND.
12654     1   IRELAT.EQ.'ON')THEN
12655        WRITE(ICOUT,999)
12656        CALL DPWRST('XXX','BUG ')
12657        WRITE(ICOUT,130)
12658  130   FORMAT('****** ERROR IN BIROOTOGRAM--')
12659        CALL DPWRST('XXX','BUG ')
12660        WRITE(ICOUT,131)
12661  131   FORMAT('      RELATIVE OPTION NOT CURRENTLY SUPPORTED FOR ',
12662     1         'THE ROOTOGRAM COMMAND.')
12663        CALL DPWRST('XXX','BUG ')
12664        IERROR='YES'
12665        GOTO9000
12666      ENDIF
12667C
12668      IF(ICASPL.EQ.'BIAS' .AND. IHIGH.EQ.'ON')THEN
12669        WRITE(ICOUT,999)
12670        CALL DPWRST('XXX','BUG ')
12671        WRITE(ICOUT,140)
12672  140   FORMAT('****** ERROR IN BIASH--')
12673        CALL DPWRST('XXX','BUG ')
12674        WRITE(ICOUT,141)
12675  141   FORMAT('      HIGHLIGHT OPTION NOT SUPPORTED FOR BIASH ',
12676     1         'COMMAND.')
12677        CALL DPWRST('XXX','BUG ')
12678        IERROR='YES'
12679        GOTO9000
12680      ENDIF
12681C
12682  119 CONTINUE
12683      IF(ILASTC.GE.1)THEN
12684        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
12685        ILASTC=0
12686      ENDIF
12687C
12688      IF(IFOUND.EQ.'NO')GOTO9000
12689C
12690      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BIHI')THEN
12691        WRITE(ICOUT,112)ICASPL,IRELAT,IHIGH
12692  112   FORMAT('ICASPL,IRELAT,IHIGH = ',A4,2X,A4,2X,A4)
12693        CALL DPWRST('XXX','BUG ')
12694      ENDIF
12695C
12696C               ****************************************
12697C               **  STEP 2--                          **
12698C               **  EXTRACT THE VARIABLE LIST         **
12699C               ****************************************
12700C
12701      ISTEPN='2'
12702      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIHI')
12703     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12704C
12705      INAME='BIHISTOGRAM'
12706      MINNA=1
12707      MAXNA=100
12708      MINN2=2
12709      IFLAGE=0
12710      IFLAGM=1
12711      IFLAGP=0
12712      JMIN=1
12713      JMAX=NUMARG
12714      IF(IHIGH.EQ.'ON')THEN
12715        MINNVA=4
12716        MAXNVA=4
12717        IFLAGM=0
12718      ELSEIF(ICASPL.EQ.'BIAS')THEN
12719        MINNVA=2
12720        MAXNVA=2
12721      ELSE
12722        MINNVA=2
12723        MAXNVA=2
12724      ENDIF
12725C
12726      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
12727     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
12728     1            JMIN,JMAX,
12729     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
12730     1            IVARN1,IVARN2,IVARTY,PVAR,
12731     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
12732     1            MINNVA,MAXNVA,
12733     1            IFLAGM,IFLAGP,
12734     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
12735      IF(IERROR.EQ.'YES')GOTO9000
12736C
12737C     IF HIGHLIGHTING TURNED ON, THEN VARIABLES 1 AND 2 MUST HAVE
12738C     SAME LENGTH AND VARIABLES 3 AND 4 MUST HAVE SAME LENGTH.
12739C
12740      IF(IHIGH.EQ.'ON')THEN
12741        IF(NRIGHT(1).NE.NRIGHT(2))THEN
12742          WRITE(ICOUT,999)
12743          CALL DPWRST('XXX','BUG ')
12744          WRITE(ICOUT,150)
12745  150     FORMAT('****** ERROR IN BIHISTOGRAM--')
12746          CALL DPWRST('XXX','BUG ')
12747          WRITE(ICOUT,151)
12748  151     FORMAT('       FOR HIGHLIGHTED CASE, VARIABLES ONE AND TWO ',
12749     1           'MUST HAVE THE SAME LENGTH.')
12750          CALL DPWRST('XXX','BUG ')
12751          WRITE(ICOUT,153)IVARN1(1),IVARN2(1),NRIGHT(1)
12752  153     FORMAT('       THE NUMBER OF OBSERVATIONS FOR ',A4,A4,
12753     1           '   = ',I8)
12754          CALL DPWRST('XXX','BUG ')
12755          WRITE(ICOUT,153)IVARN1(2),IVARN1(2),NRIGHT(2)
12756          CALL DPWRST('XXX','BUG ')
12757          IERROR='YES'
12758          GOTO9000
12759        ENDIF
12760        IF(NRIGHT(3).NE.NRIGHT(4))THEN
12761          WRITE(ICOUT,999)
12762          CALL DPWRST('XXX','BUG ')
12763          WRITE(ICOUT,150)
12764          CALL DPWRST('XXX','BUG ')
12765          WRITE(ICOUT,161)
12766  161     FORMAT('       FOR HIGHLIGHTED CASE, VARIABLES THREE AND ',
12767     1           'FOUR MUST HAVE THE SAME LENGTH.')
12768          CALL DPWRST('XXX','BUG ')
12769          WRITE(ICOUT,153)IVARN1(3),IVARN2(3),NRIGHT(3)
12770          CALL DPWRST('XXX','BUG ')
12771          WRITE(ICOUT,153)IVARN1(4),IVARN2(4),NRIGHT(4)
12772          CALL DPWRST('XXX','BUG ')
12773          IERROR='YES'
12774          GOTO9000
12775        ENDIF
12776      ENDIF
12777C
12778      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIHI')THEN
12779        WRITE(ICOUT,999)
12780        CALL DPWRST('XXX','BUG ')
12781        WRITE(ICOUT,281)
12782  281   FORMAT('***** AFTER CALL DPPARS--')
12783        CALL DPWRST('XXX','BUG ')
12784        WRITE(ICOUT,282)NQ,NUMVAR
12785  282   FORMAT('NQ,NUMVAR = ',2I8)
12786        CALL DPWRST('XXX','BUG ')
12787        IF(NUMVAR.GT.0)THEN
12788          DO285I=1,NUMVAR
12789            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
12790     1                      ICOLR(I)
12791  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
12792     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
12793            CALL DPWRST('XXX','BUG ')
12794  285     CONTINUE
12795        ENDIF
12796      ENDIF
12797C
12798C               ****************************************
12799C               **  STEP 3--                          **
12800C               **  EXTRACT THE DATA                  **
12801C               ****************************************
12802C
12803      ISTEPN='3'
12804      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIHI')
12805     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12806C
12807      IF(IHIGH.EQ.'OFF')THEN
12808        ICOL=1
12809        NUMVA2=1
12810        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12811     1              INAME,IVARN1,IVARN2,IVARTY,
12812     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
12813     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12814     1              MAXCP4,MAXCP5,MAXCP6,
12815     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12816     1              Y1TEMP,Y1TEMP,Y1TEMP,NS1,NS1,NS1,ICASE,
12817     1              IBUGG3,ISUBRO,IFOUND,IERROR)
12818        IF(IERROR.EQ.'YES')GOTO9000
12819C
12820        ICOL=2
12821        NUMVA2=1
12822        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12823     1              INAME,IVARN1,IVARN2,IVARTY,
12824     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
12825     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12826     1              MAXCP4,MAXCP5,MAXCP6,
12827     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12828     1              Y2TEMP,Y2TEMP,Y2TEMP,NS2,NS2,NS2,ICASE,
12829     1              IBUGG3,ISUBRO,IFOUND,IERROR)
12830        IF(IERROR.EQ.'YES')GOTO9000
12831      ELSE
12832        ICOL=1
12833        NUMVA2=2
12834        CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12835     1              INAME,IVARN1,IVARN2,IVARTY,
12836     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
12837     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12838     1              MAXCP4,MAXCP5,MAXCP6,
12839     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12840     1              Y1TEMP,X1HIGH,
12841     1              Y1TEMP,Y1TEMP,Y1TEMP,Y1TEMP,Y1TEMP,NS1,
12842     1              IBUGG3,ISUBRO,IFOUND,IERROR)
12843        IF(IERROR.EQ.'YES')GOTO9000
12844        ICOL=3
12845        CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
12846     1              INAME,IVARN1,IVARN2,IVARTY,
12847     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
12848     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
12849     1              MAXCP4,MAXCP5,MAXCP6,
12850     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
12851     1              Y2TEMP,X2HIGH,
12852     1              Y2TEMP,Y2TEMP,Y2TEMP,Y2TEMP,Y2TEMP,NS2,
12853     1              IBUGG3,ISUBRO,IFOUND,IERROR)
12854        NLOCAL=NS2
12855        IF(IERROR.EQ.'YES')GOTO9000
12856      ENDIF
12857C
12858C               ****************************************
12859C               **  STEP 4--                          **
12860C               **  CALL DPBIH3 TO DETERMINE THE      **
12861C               **  BINNING (THIS IS BASED ON THE     **
12862C               **  COMBINED DATA).                   **
12863C               ****************************************
12864C
12865      ISTEPN='4'
12866      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIHI')
12867     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12868C
12869      CLWID=CLWIDT(1)
12870      XSTART=CLLIMI(1)
12871      XSTOP=CLLIMI(2)
12872C
12873C     PARAMETER FOR ASH HISTROGRAM
12874C
12875      IHP='M   '
12876      IHP2='    '
12877      IHWUSE='P'
12878      MESSAG='NO'
12879      CALL CHECKN(IHP,IHP2,IHWUSE,
12880     1            IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
12881     1            ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
12882      IF(IERROR.EQ.'YES')THEN
12883        IF(NLOCAL.LE.100)THEN
12884          M=4
12885        ELSEIF(NLOCAL.LE.1000)THEN
12886          M=8
12887        ELSE
12888          M=16
12889        ENDIF
12890      ELSE
12891        M=INT(VALUE(ILOCP)+0.5)
12892        IF(M.LE.0)M=1
12893        IF(M.GT.64)M=64
12894      ENDIF
12895C
12896C     NOTE: ASH BINNINNG ALGORITHM RETURNS THE BINNED DATA, NOT JUST
12897C           CLASS WIDTHS, SO HANDLE THAT CASE IN DPBIH2.
12898C
12899      CALL DPBIH3(Y1TEMP,X1HIGH,NS1,Y2TEMP,X2HIGH,NS2,
12900     1            ICASPL,IRELAT,IHIGH,CLWID,XSTART,XSTOP,
12901     1            XTEMP1,XTEMP2,MAXOBV,
12902     1            IRHSTG,IHSTCW,IHSTEB,IHSTOU,
12903     1            DCLWID,DXSTAR,DXSTOP,
12904     1            Y,X,D,N2,IFLAG,
12905     1            IBUGG3,ISUBRO,IERROR)
12906      IF(IERROR.EQ.'YES')GOTO9000
12907      IF(IFLAG.EQ.1)THEN
12908        NPLOTV=3
12909        NPLOTP=N2
12910        GOTO9000
12911      ENDIF
12912C
12913C               ****************************************
12914C               **  STEP 5--                          **
12915C               **  CALL DPBIH2 TO GENERATE THE CLASS **
12916C               **  FREQUENCIES FOR EACH SAMPLE.      **
12917C               ****************************************
12918C
12919      ISTEPN='5'
12920      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIHI')
12921     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
12922C
12923      N2=0
12924      ICASET=1
12925      CALL DPBIH2(Y1TEMP,X1HIGH,NS1,ICASPL,ICASET,
12926     1            XTEMP1,XTEMP2,XIDTEM,
12927     1            DCLWID,DXSTAR,DXSTOP,
12928     1            IHIGH,IRELAT,IRHSTG,IHSTCW,IHSTEB,IHSTOU,
12929     1            IASHWT,M,
12930     1            Y,X,X3D,D,N2,NPLOTV,
12931     1            IBUGG3,ISUBRO,IERROR)
12932C
12933      ICASET=2
12934      CALL DPBIH2(Y2TEMP,X2HIGH,NS2,ICASPL,ICASET,
12935     1            XTEMP1,XTEMP2,XIDTEM,
12936     1            DCLWID,DXSTAR,DXSTOP,
12937     1            IHIGH,IRELAT,IRHSTG,IHSTCW,IHSTEB,IHSTOU,
12938     1            IASHWT,M,
12939     1            Y,X,X3D,D,N2,NPLOTV,
12940     1            IBUGG3,ISUBRO,IERROR)
12941C
12942      NPLOTV=3
12943      NPLOTP=N2
12944C
12945C               ******************
12946C               **   STEP 90--  **
12947C               **   EXIT       **
12948C               ******************
12949C
12950 9000 CONTINUE
12951      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIHI')THEN
12952        WRITE(ICOUT,999)
12953        CALL DPWRST('XXX','BUG ')
12954        WRITE(ICOUT,9011)
12955 9011   FORMAT('***** AT THE END       OF DPBIHI--')
12956        CALL DPWRST('XXX','BUG ')
12957        WRITE(ICOUT,9012)ICASPL,IRELAT,IERROR,NPLOTP,NPLOTV
12958 9012   FORMAT('ICASPL,IRELAT,IERROR,NPLOTP,NPLOTV = ',3(A4,2X),2I8)
12959        CALL DPWRST('XXX','BUG ')
12960        DO9015I=1,NPLOTP
12961          WRITE(ICOUT,9014)I,X(I),Y(I),D(I)
12962 9014     FORMAT('I,X(I),Y(I),D(I) = ',I8,3G15.7)
12963          CALL DPWRST('XXX','BUG ')
12964 9015   CONTINUE
12965      ENDIF
12966C
12967      RETURN
12968      END
12969      SUBROUTINE DPBIH2(Y,XHIGH,N,ICASPL,ICASE,
12970     1                  XTEMP1,XTEMP2,XIDTEM,
12971     1                  DCLWID,DXSTAR,DXSTOP,
12972     1                  IHIGH,IRELAT,IRHSTG,IHSTCW,IHSTEB,IHSTOU,
12973     1                  IASHWT,M,
12974     1                  Y2,X2,X3D,D2,N2,NPLOTV,
12975     1                  IBUGG3,ISUBRO,IERROR)
12976C
12977C     PURPOSE--USED BY DPBIHI TO GENERATE THE CLASS FREQUENCIES
12978C              FOR ONE OF THE GROUPS.
12979C
12980C              NOTE THAT THE DPBIH3 ROUTINE IS CALLED FIRST TO DETERMINE
12981C              THE CLASS START, CLASS STOP, AND CLASS WIDTH.  ALSO, THE
12982C              VARIABLE ICASE SPECIFIES WHETHER THIS IS THE FOR THE
12983C              FIRST SAMPLE OR THE SECOND SAMPLE (IF THE SECOND SAMPLE,
12984C              THE Y-COORDINATE WILL BE NEGATED).  ALSO, DPBIH3 DOES THE
12985C              BASIC ERROR CHECKING, SO DO NOT REPEAT THAT HERE.
12986C
12987C              NOTE THAT BIHISTOGRAM CURRENTLY ONLY WORKS ON RAW
12988C              DATA (I.E., PRE-BINNED DATA NOT SUPPORTED).
12989C     WRITTEN BY--JAMES J. FILLIBEN
12990C                 STATISTICAL ENGINEERING DIVISION
12991C                 INFORMATION TECHNOLOGY LABORATORY
12992C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
12993C                 GAITHERSBURG, MD 20899-8980
12994C                 PHONE--301-975-2855
12995C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
12996C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
12997C     LANGUAGE--ANSI FORTRAN (1977)
12998C     VERSION NUMBER--2011/6
12999C     ORIGINAL VERSION--JUNE      2011. EXTRACTED FROM DPBIHI ROUTINE
13000C                                       SOME OPTIONS FROM STANDARD
13001C                                       HISTOGRAM INCORPORATED INTO
13002C                                       BIHISTOGRAM AS PART OF THIS
13003C                                       EXTENSION
13004C
13005C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13006C
13007      CHARACTER*4 ICASPL
13008      CHARACTER*4 IRELAT
13009      CHARACTER*4 IHIGH
13010      CHARACTER*4 IRHSTG
13011      CHARACTER*4 IHSTCW
13012      CHARACTER*4 IHSTEB
13013      CHARACTER*4 IHSTOU
13014      CHARACTER*4 IASHWT
13015      CHARACTER*4 IBUGG3
13016      CHARACTER*4 ISUBRO
13017      CHARACTER*4 IERROR
13018C
13019      CHARACTER*4 IWRIT2
13020C
13021      CHARACTER*4 ISUBN1
13022      CHARACTER*4 ISUBN2
13023C
13024C---------------------------------------------------------------------
13025
13026      DOUBLE PRECISION DCLWID
13027      DOUBLE PRECISION DXSTAR
13028      DOUBLE PRECISION DXSTOP
13029      DOUBLE PRECISION DCLMNJ
13030      DOUBLE PRECISION DCLMDJ
13031      DOUBLE PRECISION DCLMXJ
13032      DOUBLE PRECISION DJ
13033      DOUBLE PRECISION DXI
13034      DOUBLE PRECISION DABSDE
13035      DOUBLE PRECISION DTOTWI
13036      DOUBLE PRECISION DN3
13037      DOUBLE PRECISION DSUM
13038C
13039C---------------------------------------------------------------------
13040C
13041      DIMENSION Y(*)
13042      DIMENSION XHIGH(*)
13043      DIMENSION Y2(*)
13044      DIMENSION X2(*)
13045      DIMENSION X3D(*)
13046      DIMENSION D2(*)
13047      DIMENSION XTEMP1(*)
13048      DIMENSION XTEMP2(*)
13049      DIMENSION XIDTEM(*)
13050C
13051C---------------------------------------------------------------------
13052C
13053      INCLUDE 'DPCOP2.INC'
13054C
13055C-----START POINT-----------------------------------------------------
13056C
13057      ISUBN1='DPBI'
13058      ISUBN2='S2  '
13059C
13060      IERROR='NO'
13061      IWRIT2='OFF'
13062C
13063      K=(-999)
13064      DCLMDJ=(-999.0D0)
13065      KP3=0
13066      AN3=0.0
13067      DENOM=0.0
13068C
13069      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIH2')THEN
13070        WRITE(ICOUT,999)
13071  999   FORMAT(1X)
13072        CALL DPWRST('XXX','BUG ')
13073        WRITE(ICOUT,70)
13074   70   FORMAT('***** AT THE BEGINNING OF DPBIH2--')
13075        CALL DPWRST('XXX','BUG ')
13076        WRITE(ICOUT,81)IHIGH,IHSTCW,IHSTOU
13077   81   FORMAT('IHIGH,IHSTCW,IHSTOU = ',2(A4,2X),A4)
13078        CALL DPWRST('XXX','BUG ')
13079        WRITE(ICOUT,82)N,DCLWID,DXSTAR,DXSTOP
13080   82   FORMAT('N,DCLWID,DXSTAR,DXSTOP = ',I8,3G15.7)
13081        CALL DPWRST('XXX','BUG ')
13082        DO83I=1,N
13083          WRITE(ICOUT,84)I,Y(I),XHIGH(I)
13084   84     FORMAT('I,Y(I),XHIGH(I) = ',I8,2G15.7)
13085          CALL DPWRST('XXX','BUG ')
13086   83   CONTINUE
13087      ENDIF
13088C
13089C               **********************************************
13090C               **  STEP 2--                                **
13091C               **  HANDLE ASH CASE SEPARATELY.             **
13092C               **********************************************
13093C
13094      IF(ICASPL.EQ.'BIAS')THEN
13095        N2SAVE=N2
13096        CALL DPBINA(Y,N,REAL(DCLWID),REAL(DXSTAR),REAL(DXSTOP),M,
13097     1              XTEMP1,MAXOBV,
13098     1              IRELAT,IASHWT,IHSTCW,
13099     1              XTEMP2,XIDTEM,NTEMP,IBUGG3,IERROR)
13100        DO112I=1,NTEMP
13101          Y2(N2SAVE+I)=XTEMP2(I)
13102          X2(N2SAVE+I)=XIDTEM(I)
13103          D2(N2SAVE+I)=1.0
13104          IF(ICASE.EQ.2)THEN
13105            Y2(N2SAVE+I)=-Y2(N2SAVE+I)
13106            D2(N2SAVE+I)=2.0
13107          ENDIF
13108  112   CONTINUE
13109        N2=N2SAVE+NTEMP
13110        GOTO9000
13111      ENDIF
13112C
13113      DTOTWI=DXSTOP-DXSTAR
13114      ANUMCL=DTOTWI/DCLWID
13115      NUMCLA=INT(ANUMCL+1.0+0.1)
13116C
13117      J=NUMCLA-1
13118      DJ=J
13119      DCLMXJ=DXSTAR+DJ*DCLWID
13120      DABSDE=DABS(DCLMXJ-DXSTOP)
13121      IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1
13122C
13123C               *******************************************************
13124C               **  STEP 3--                                         **
13125C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
13126C               *******************************************************
13127C
13128      IF(IHIGH.EQ.'ON')THEN
13129        CALL DISTIN(XHIGH,N,IWRIT2,XIDTEM,NDIST,IBUGG3,IERROR)
13130        CALL SORT(XIDTEM,NDIST,XIDTEM)
13131      ELSE
13132        NDIST=1
13133      ENDIF
13134      NPOINT=N2
13135      N2SAVE=N2
13136C
13137      DO300IREPL=1,NDIST
13138C
13139        IF(IREPL.EQ.1)THEN
13140          DO301ISET=1,N
13141            XTEMP2(ISET)=Y(ISET)
13142  301     CONTINUE
13143          NTEMP=N
13144          ATAG=1.0
13145          IF(ICASE.EQ.2)ATAG=2.0
13146        ELSE
13147          ICNT=0
13148          AHOLD=XIDTEM(IREPL-1)
13149          DO306ISET=1,N
13150            IF(XHIGH(ISET).EQ.AHOLD)THEN
13151              ICNT=ICNT+1
13152              XTEMP2(ICNT)=Y(ISET)
13153            ENDIF
13154  306     CONTINUE
13155          NTEMP=ICNT
13156          ATAG=REAL(NDIST - IREPL + 2)
13157        ENDIF
13158C
13159        DO310J=1,NUMCLA
13160          XTEMP1(J)=0.0
13161  310   CONTINUE
13162C
13163        IBELOW=0
13164        IABOVE=0
13165        DO420I=1,NTEMP
13166          DXI=XTEMP2(I)
13167          IF(DXI.LT.DXSTAR)THEN
13168            IBELOW=IBELOW+1
13169            GOTO420
13170          ELSEIF(DXI.GT.DXSTOP)THEN
13171            IABOVE=IABOVE+1
13172            GOTO420
13173          ENDIF
13174          DO430J=1,NUMCLA
13175            J2=J
13176            DJ=J
13177            DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
13178            DCLMXJ=DXSTAR+DJ*DCLWID
13179            IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
13180            IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)GOTO440
13181  430     CONTINUE
13182          GOTO420
13183  440     CONTINUE
13184          XTEMP1(J2)=XTEMP1(J2)+1.0
13185  420   CONTINUE
13186C
13187C       TREAT THE SPECIAL CASE OF EQUALITY
13188C       WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
13189C
13190        J=NUMCLA
13191        DO450I=1,NTEMP
13192          DJ=J
13193          DCLMXJ=DXSTAR+DJ*DCLWID
13194          IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
13195          DXI=XTEMP2(I)
13196          IF(DXI.EQ.DCLMXJ)XTEMP1(J)=XTEMP1(J)+1.0
13197  450   CONTINUE
13198C
13199        IF(IBELOW.GE.1)THEN
13200          WRITE(ICOUT,999)
13201          CALL DPWRST('XXX','BUG ')
13202          WRITE(ICOUT,1591)IBELOW,DXSTAR
13203 1591     FORMAT('***** WARNING: ',I8,' DATA POINTS ARE BELOW THE ',
13204     1           'MINIMUM CLASS VALUE OF ',G15.7)
13205          CALL DPWRST('XXX','BUG ')
13206        ENDIF
13207        IF(IABOVE.GE.1)THEN
13208          WRITE(ICOUT,999)
13209          CALL DPWRST('XXX','BUG ')
13210          WRITE(ICOUT,1691)IABOVE,DXSTOP
13211 1691     FORMAT('***** WARNING: ',I8,' DATA POINTS ARE ABOVE THE ',
13212     1           'MAXIMUM CLASS VALUE OF ',G15.7)
13213          CALL DPWRST('XXX','BUG ')
13214        ENDIF
13215C
13216        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIH2')THEN
13217          WRITE(ICOUT,999)
13218          CALL DPWRST('XXX','BUG ')
13219          WRITE(ICOUT,591)
13220  591     FORMAT('***** IN THE MIDDLE    OF DPBIH2--')
13221          CALL DPWRST('XXX','BUG ')
13222          WRITE(ICOUT,592)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA
13223  592     FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ',
13224     1           4D11.4,F10.0,I8)
13225          CALL DPWRST('XXX','BUG ')
13226          DO593J=1,NUMCLA
13227            DJ=J
13228            DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
13229            DCLMXJ=DXSTAR+DJ*DCLWID
13230            IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
13231            FJ=XTEMP1(J)
13232            WRITE(ICOUT,594)J,DCLMNJ,DCLMXJ,FJ
13233  594       FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,3G15.7)
13234            CALL DPWRST('XXX','BUG ')
13235  593     CONTINUE
13236        ENDIF
13237C
13238C               **********************************
13239C               **  STEP 4--                    **
13240C               **  DETERMINE PLOT COORDINATES  **
13241C               **********************************
13242C
13243        DSUM=0.0D0
13244        IF(ICASPL.EQ.'BIRO' .OR. ICASPL.EQ.'CBIR')THEN
13245          DO1108J=1,NUMCLA
13246            FJ=SQRT(XTEMP1(J))
13247            DSUM=DSUM+DBLE(FJ)
13248 1108     CONTINUE
13249        ELSE
13250          DO1110J=1,NUMCLA
13251            FJ=XTEMP1(J)
13252            DSUM=DSUM+DBLE(FJ)
13253 1110     CONTINUE
13254        ENDIF
13255        DN3=DSUM
13256        AN3=DN3
13257C
13258        DENOM=1.0
13259        IF(IRELAT.EQ.'ON')THEN
13260          IF(IRHSTG.EQ.'PERC')THEN
13261            DENOM=DN3
13262          ELSE
13263            DENOM=DN3*DCLWID
13264          ENDIF
13265        ENDIF
13266C
13267        NSTRT=NPOINT+1
13268        DSUM=0.0D0
13269        DO1120J=1,NUMCLA
13270          K=J
13271          NPOINT=NPOINT+1
13272          D2(NPOINT)=ATAG
13273          DJ=J
13274          DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
13275          X2(NPOINT)=DCLMDJ
13276          FJ=XTEMP1(J)
13277          IF(ICASPL.EQ.'BIRO')FJ=SQRT(FJ)
13278C
13279          IF(IREPL.GT.2)THEN
13280            ABASE=Y2(NPOINT-NUMCLA)
13281          ELSE
13282            ABASE=0.0
13283          ENDIF
13284C
13285          IF(ICASPL.EQ.'BIHI' .OR. ICASPL.EQ.'BIRO')THEN
13286            Y2(NPOINT)=(FJ/DENOM) + ABASE
13287          ELSEIF(ICASPL.EQ.'CBIH')THEN
13288            IF(IRELAT.EQ.'ON' .AND. IRHSTG.EQ.'AREA')THEN
13289              Y2(NPOINT)=(FJ/DENOM) + ABASE
13290            ELSE
13291              DSUM=DSUM+FJ
13292              CUMFJ=(DSUM/DENOM)
13293              Y2(NPOINT)=CUMFJ + ABASE
13294            ENDIF
13295          ELSEIF(ICASPL.EQ.'CBIR')THEN
13296            IF(IRELAT.EQ.'ON' .AND. IRHSTG.EQ.'AREA')THEN
13297              Y2(NPOINT)=(SQRT(FJ)/DENOM) + ABASE
13298            ELSE
13299              DSUM=DSUM+FJ
13300              CUMFJ=(DSQRT(DSUM)/DENOM)
13301              Y2(NPOINT)=CUMFJ + ABASE
13302            ENDIF
13303          ENDIF
13304 1120   CONTINUE
13305C
13306C       FOR CUMULATIVE RELATIVE HISTOGRAM (AREA CASE), COMPUTE
13307C       CUMULATIVE INTEGRAL OF POINTS.
13308C
13309        IF((ICASPL.EQ.'CBIH' .OR. ICASPL.EQ.'CBIR') .AND.
13310     1    IRELAT.EQ.'ON' .AND. IRHSTG.EQ.'AREA')THEN
13311          NSTOP=NPOINT
13312          NTOT=NSTOP-NSTRT+1
13313          NJUNK=2
13314          IWRIT2='OFF'
13315          CALL CUMINT(Y2(NSTRT),X2(NSTRT),NTOT,NJUNK,IWRIT2,XTEMP1,
13316     1                IBUGG3,IERROR)
13317          IF(ICASPL.EQ.'CUMH')THEN
13318            DO1129II=NSTRT,NSTOP
13319              Y2(II)=XTEMP1(II)
13320 1129       CONTINUE
13321          ELSEIF(ICASPL.EQ.'CBIR')THEN
13322            DO1139II=NSTRT,NSTOP
13323              Y2(II)=SQRT(XTEMP1(II))
13324 1139       CONTINUE
13325          ENDIF
13326        ENDIF
13327C
13328  300 CONTINUE
13329C
13330      N2=NPOINT
13331      NPLOTV=2
13332C
13333      IF(IHSTEB.EQ.'OFF')THEN
13334        ICNT=0
13335        DO1140J=1,N2
13336          IF(Y2(J).GT.0.0)THEN
13337            ICNT=ICNT+1
13338            X2(ICNT)=X2(J)
13339            Y2(ICNT)=Y2(J)
13340            X3D(ICNT)=X3D(J)
13341            D2(ICNT)=D2(J)
13342          ENDIF
13343 1140   CONTINUE
13344        N2=ICNT
13345      ENDIF
13346C
13347      IF(ICASE.EQ.2)THEN
13348        DO2110I=N2SAVE+1,N2
13349          Y2(I)=-Y2(I)
13350 2110   CONTINUE
13351      ENDIF
13352C
13353C               ******************
13354C               **   STEP 90--  **
13355C               **   EXIT       **
13356C               ******************
13357C
13358 9000 CONTINUE
13359      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIH2')THEN
13360        WRITE(ICOUT,999)
13361        CALL DPWRST('XXX','BUG ')
13362        WRITE(ICOUT,9011)
13363 9011   FORMAT('***** AT THE END       OF DPBIH2--')
13364        CALL DPWRST('XXX','BUG ')
13365        WRITE(ICOUT,9012)IERROR,N2,AN3,DENOM
13366 9012   FORMAT('IERROR,N2,AN3,DENOM = ',A4,2X,I8,2G15.7)
13367        CALL DPWRST('XXX','BUG ')
13368        DO9015I=1,N2
13369          WRITE(ICOUT,9016)I,Y2(I),X2(I),D2(I)
13370 9016     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2G15.7,F9.2)
13371          CALL DPWRST('XXX','BUG ')
13372 9015   CONTINUE
13373      ENDIF
13374C
13375      RETURN
13376      END
13377      SUBROUTINE DPBIH3(Y1,X1HIGH,N1,Y2,X2HIGH,N2,
13378     1                  ICASPL,IRELAT,IHIGH,CLWID,XSTART,XSTOP,
13379     1                  XTEMP1,XTEMP2,MAXOBV,
13380     1                  IRHSTG,IHSTCW,IHSTEB,IHSTOU,
13381     1                  DCLWID,DXSTAR,DXSTOP,
13382     1                  Y3,X2,D2,N3,IFLAG,
13383     1                  IBUGG3,ISUBRO,IERROR)
13384C
13385C     PURPOSE--COMPUTE THE CLASS INTERVALS FOR THE BI-HISTOGRAM COMMAND
13386C              AND PERFORM BASIC ERROR CHECKING.  NOTE THAT THE CLASS
13387C              WIDTH WILL BE DETERMINED FROM THE COMBINED DATA.
13388C              NOTE THAT THE BIHISTOGRAM CURRENTLY ONLY WORKS ON RAW
13389C              DATA (I.E., PRE-BINNED DATA NOT SUPPORTED).
13390C     WRITTEN BY--JAMES J. FILLIBEN
13391C                 STATISTICAL ENGINEERING DIVISION
13392C                 INFORMATION TECHNOLOGY LABORATORY
13393C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY
13394C                 GAITHERSBURG, MD 20899-8980
13395C                 PHONE--301-975-2855
13396C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13397C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOOGY.
13398C     LANGUAGE--ANSI FORTRAN (1977)
13399C     VERSION NUMBER--2011/6
13400C     ORIGINAL VERSION--JUNE      2011. EXTRACTED FROM DPBIHI ROUTINE
13401C                                       SOME OPTIONS FROM STANDARD
13402C                                       HISTOGRAM INCORPORATED INTO
13403C                                       BIHISTOGRAM AS PART OF THIS
13404C                                       EXTENSION
13405C
13406C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13407C
13408      CHARACTER*4 ICASPL
13409      CHARACTER*4 IRELAT
13410      CHARACTER*4 IHIGH
13411      CHARACTER*4 IBUGG3
13412      CHARACTER*4 ISUBRO
13413      CHARACTER*4 IERROR
13414C
13415      CHARACTER*4 IRHSTG
13416      CHARACTER*4 IHSTCW
13417      CHARACTER*4 IHSTEB
13418      CHARACTER*4 IHSTOU
13419      CHARACTER*4 ISUBN1
13420      CHARACTER*4 ISUBN2
13421C
13422C---------------------------------------------------------------------
13423
13424      DOUBLE PRECISION DCLWID
13425      DOUBLE PRECISION DXSTAR
13426      DOUBLE PRECISION DXSTOP
13427C
13428C---------------------------------------------------------------------
13429C
13430      DIMENSION Y1(*)
13431      DIMENSION Y2(*)
13432      DIMENSION X1HIGH(*)
13433      DIMENSION X2HIGH(*)
13434      DIMENSION XTEMP1(*)
13435      DIMENSION XTEMP2(*)
13436      DIMENSION Y3(*)
13437      DIMENSION X2(*)
13438      DIMENSION D2(*)
13439C
13440C---------------------------------------------------------------------
13441C
13442      INCLUDE 'DPCOP2.INC'
13443C
13444C-----START POINT-----------------------------------------------------
13445C
13446      ISUBN1='DPBI'
13447      ISUBN2='S3  '
13448      IERROR='NO'
13449C
13450      IFLAG=0
13451      DCLWID=CLWID
13452      DXSTAR=XSTART
13453      DXSTOP=XSTOP
13454C
13455C               ********************************************
13456C               **  STEP 1--                              **
13457C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
13458C               ********************************************
13459C
13460      IF(N1.LT.2)THEN
13461        WRITE(ICOUT,999)
13462  999   FORMAT(1X)
13463        CALL DPWRST('XXX','BUG ')
13464        WRITE(ICOUT,31)
13465   31   FORMAT('***** ERROR IN BIHISTOGRAM--')
13466        CALL DPWRST('XXX','BUG ')
13467        WRITE(ICOUT,32)
13468   32   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE FIRST ',
13469     1         'RESPONSE VARIABLE MUST BE AT LEAST 2;')
13470        CALL DPWRST('XXX','BUG ')
13471        WRITE(ICOUT,34)N1
13472   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
13473        CALL DPWRST('XXX','BUG ')
13474        WRITE(ICOUT,999)
13475        CALL DPWRST('XXX','BUG ')
13476        IERROR='YES'
13477        GOTO9000
13478      ENDIF
13479C
13480      IF(N2.LT.2)THEN
13481        WRITE(ICOUT,999)
13482        CALL DPWRST('XXX','BUG ')
13483        WRITE(ICOUT,31)
13484        CALL DPWRST('XXX','BUG ')
13485        WRITE(ICOUT,42)
13486   42   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE SECOND ',
13487     1         'RESPONSE VARIABLE MUST BE AT LEAST 2;')
13488        CALL DPWRST('XXX','BUG ')
13489        WRITE(ICOUT,34)N2
13490        CALL DPWRST('XXX','BUG ')
13491        WRITE(ICOUT,999)
13492        CALL DPWRST('XXX','BUG ')
13493        IERROR='YES'
13494        GOTO9000
13495      ENDIF
13496C
13497C     NOW COMBINE THE DATA
13498C
13499      DO50I=1,N1
13500        XTEMP1(I)=Y1(I)
13501   50 CONTINUE
13502      DO55I=1,N2
13503        XTEMP1(N1+I)=Y2(I)
13504   55 CONTINUE
13505      N=N1+N2
13506C
13507C     NOW CHECK TO SEE IF THERE IS A SINGLE VALUE
13508C
13509      HOLD=XTEMP1(1)
13510      DO60I=1,N1+N2
13511        IF(XTEMP1(I).NE.HOLD)GOTO69
13512   60 CONTINUE
13513      WRITE(ICOUT,999)
13514      CALL DPWRST('XXX','BUG ')
13515      WRITE(ICOUT,61)
13516   61 FORMAT('***** WARNING IN BIHISTOGRAM--')
13517      CALL DPWRST('XXX','BUG ')
13518      WRITE(ICOUT,62)
13519   62 FORMAT('      ALL INPUT HORIZONTAL AXIS ELEMENTS')
13520      CALL DPWRST('XXX','BUG ')
13521      WRITE(ICOUT,63)HOLD
13522   63 FORMAT('      ARE IDENTICALLY EQUAL TO ',G15.7)
13523      CALL DPWRST('XXX','BUG ')
13524      WRITE(ICOUT,999)
13525      CALL DPWRST('XXX','BUG ')
13526C
13527      DCLWID=2.0
13528      DXSTAR=HOLD-1.0
13529      DXSTOP=HOLD+1.0
13530C
13531C     HANDLE AS SPECIAL CASE
13532C
13533      IFLAG=1
13534      N3=6
13535      X2(1)=HOLD-1.0
13536      X2(2)=HOLD
13537      X2(3)=HOLD+1.0
13538      IF(IRELAT.EQ.'ON')THEN
13539        Y3(1)=0.0
13540        Y3(2)=1.0
13541        Y3(3)=0.0
13542      ELSE
13543        Y3(1)=0.0
13544        Y3(2)=REAL(N1)
13545        Y3(3)=0.0
13546      ENDIF
13547      D2(1)=1.0
13548      D2(2)=1.0
13549      D2(3)=1.0
13550C
13551      X2(4)=HOLD-1.0
13552      X2(5)=HOLD
13553      X2(6)=HOLD+1.0
13554      IF(IRELAT.EQ.'ON')THEN
13555        Y3(4)=0.0
13556        Y3(5)=-1.0
13557        Y3(6)=0.0
13558      ELSE
13559        Y3(4)=0.0
13560        Y3(5)=-REAL(N2)
13561        Y3(6)=0.0
13562      ENDIF
13563      D2(4)=2.0
13564      D2(5)=2.0
13565      D2(6)=2.0
13566C
13567      GOTO9000
13568C
13569   69 CONTINUE
13570C
13571      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIH3')THEN
13572        WRITE(ICOUT,999)
13573        CALL DPWRST('XXX','BUG ')
13574        WRITE(ICOUT,70)
13575   70   FORMAT('***** AT THE BEGINNING OF DPBIH3--')
13576        CALL DPWRST('XXX','BUG ')
13577        WRITE(ICOUT,80)IRHSTG,IHIGH,IHSTCW,IHSTOU
13578   80   FORMAT('IRHSTG,IHIGH,IHSTCW,IHSTOU = ',3(A4,2X),A4)
13579        CALL DPWRST('XXX','BUG ')
13580        WRITE(ICOUT,81)ICASPL,IHSTEB
13581   81   FORMAT('ICASPL,IHSTEB = ',A4,2X,A4)
13582        CALL DPWRST('XXX','BUG ')
13583        WRITE(ICOUT,82)N1,N2,CLWID,XSTART,XSTOP
13584   82   FORMAT('N1,N2,CLWID,XSTART,XSTOP = ',2I8,3G15.7)
13585        CALL DPWRST('XXX','BUG ')
13586        DO83I=1,N1
13587          WRITE(ICOUT,84)I,Y1(I),X1HIGH(I)
13588   84     FORMAT('I,Y1(I),X1HIGH(I) = ',I8,2G15.7)
13589          CALL DPWRST('XXX','BUG ')
13590   83   CONTINUE
13591        DO88I=1,N1
13592          WRITE(ICOUT,89)I,Y2(I),X2HIGH(I)
13593   89     FORMAT('I,Y2(I),X2HIGH(I) = ',I8,2G15.7)
13594          CALL DPWRST('XXX','BUG ')
13595   88   CONTINUE
13596      ENDIF
13597C
13598C               **********************************************
13599C               **  STEP 2--                                **
13600C               **  IF NECESSARY, DETERMINE CLASS WIDTH,    **
13601C               **  START VALUE, AND STOP VALUE.            **
13602C               **********************************************
13603C
13604      CALL DPBINZ(XTEMP1,N,CLWID,XSTART,XSTOP,
13605     1            XTEMP2,MAXOBV,IHSTCW,IHSTOU,
13606     1            DCLWID,DXSTAR,DXSTOP,
13607     1            ISUBRO,IBUGG3,IERROR)
13608C
13609C               ******************
13610C               **   STEP 90--  **
13611C               **   EXIT       **
13612C               ******************
13613C
13614 9000 CONTINUE
13615      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIH3')THEN
13616        WRITE(ICOUT,999)
13617        CALL DPWRST('XXX','BUG ')
13618        WRITE(ICOUT,9011)
13619 9011   FORMAT('***** AT THE END       OF DPBIH3--')
13620        CALL DPWRST('XXX','BUG ')
13621        WRITE(ICOUT,9012)IERROR
13622 9012   FORMAT('IERROR = ',A4)
13623        CALL DPWRST('XXX','BUG ')
13624      ENDIF
13625C
13626      RETURN
13627      END
13628      SUBROUTINE DPBIN(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG,
13629CCCCC MARCH 2006: ADD FOLLOWING LINE TO ALLOW DIFFERENT
13630CCCCC             ALTERNATIVES TO BINNING
13631     1TEMP1,MAXNXT,IHSTCW,IHSTOU,
13632     1Y2,X2,N2,IBUGG3,IERROR)
13633C
13634C     PURPOSE--BIN A VARIABLE Y INTO X2 Y2.
13635C              THAT IS CONVERT RAW DATA TO FREQUENCY DATA.
13636C              BINNING CAN BE EITHER TO COUNTS OR TO RELATIVE
13637C              FREQUENCY.
13638C     WRITTEN BY--ALAN HECKERT
13639C                 STATISTICAL ENGINEERING DIVISION
13640C                 INFORMATION TECHNOLOGY LABORATORY
13641C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13642C                 GAITHERSBURG, MD 20899-8980
13643C                 PHONE--301-975-2899
13644C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13645C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13646C     LANGUAGE--ANSI FORTRAN (1977)
13647C     VERSION NUMBER--98/11
13648C     ORIGINAL VERSION--NOVEMBER  1998.
13649C     UPDATED         --MARCH     2006. SUPPORT FOR DIFFERENT
13650C                                       CLASS WIDTH ALGORITHMS
13651C     UPDATED         --JANUARY   2010. SET HISTOGRAM OUTLIERS
13652C     UPDATED         --JANUARY   2010. SPLIT CLASS WIDTH TO
13653C                                       DPBINZ
13654C     UPDATED         --JUNE      2016. BUG FIX FOR IQ RANGE METHOD
13655C     UPDATED         --JUNE      2016. LOWER AND UPPER CLASS LIMITS
13656C                                       FOR IQ RANGE METHOD
13657C
13658C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13659C
13660      CHARACTER*4 IRELAT
13661      CHARACTER*4 IBUGG3
13662      CHARACTER*4 ISUBRO
13663      CHARACTER*4 IERROR
13664C
13665      CHARACTER*4 IRHSTG
13666      CHARACTER*4 IHSTCW
13667      CHARACTER*4 IHSTOU
13668      CHARACTER*4 ISUBN1
13669      CHARACTER*4 ISUBN2
13670C
13671C---------------------------------------------------------------------
13672
13673      DOUBLE PRECISION DCLWID
13674      DOUBLE PRECISION DXSTAR
13675      DOUBLE PRECISION DXSTOP
13676      DOUBLE PRECISION DCLMNJ
13677      DOUBLE PRECISION DCLMDJ
13678      DOUBLE PRECISION DCLMXJ
13679      DOUBLE PRECISION DJ
13680      DOUBLE PRECISION DXI
13681      DOUBLE PRECISION DABSDE
13682      DOUBLE PRECISION DTOTWI
13683C
13684C---------------------------------------------------------------------
13685C
13686      DIMENSION Y(*)
13687      DIMENSION Y2(*)
13688      DIMENSION X2(*)
13689      DIMENSION TEMP1(*)
13690C
13691C---------------------------------------------------------------------
13692C
13693      INCLUDE 'DPCOP2.INC'
13694C
13695C-----START POINT-----------------------------------------------------
13696C
13697      ISUBN1='DPBI'
13698      ISUBN2='N   '
13699      ISUBRO='XXXX'
13700C
13701      IERROR='NO'
13702C
13703      K=(-999)
13704      DCLMDJ=(-999.0D0)
13705C
13706      KP3=0
13707C
13708      AN3=0.0
13709      DENOM=0.0
13710C
13711      DCLWID=CLWID
13712      DXSTAR=XSTART
13713      DXSTOP=XSTOP
13714C
13715C               ********************************************
13716C               **  STEP 1--                              **
13717C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
13718C               ********************************************
13719C
13720      IF(N.LT.1)THEN
13721        WRITE(ICOUT,999)
13722  999   FORMAT(1X)
13723        CALL DPWRST('XXX','BUG ')
13724        WRITE(ICOUT,31)
13725   31   FORMAT('***** ERROR IN BINNING DATA (DPBIN)--')
13726        CALL DPWRST('XXX','BUG ')
13727        WRITE(ICOUT,32)
13728   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;')
13729        CALL DPWRST('XXX','BUG ')
13730        WRITE(ICOUT,34)N
13731   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8)
13732        CALL DPWRST('XXX','BUG ')
13733        WRITE(ICOUT,999)
13734        CALL DPWRST('XXX','BUG ')
13735        IERROR='YES'
13736        GOTO9000
13737      ENDIF
13738C
13739      HOLD=Y(1)
13740      DO60I=1,N
13741        IF(Y(I).NE.HOLD)GOTO69
13742   60 CONTINUE
13743      N2=3
13744      X2(1)=HOLD-1.0
13745      X2(2)=HOLD
13746      X2(3)=HOLD+1
13747      IF(IRELAT.EQ.'ON')THEN
13748        Y2(1)=0.0
13749        Y2(2)=1.0
13750        Y2(3)=0.0
13751      ELSE
13752        Y2(1)=0.0
13753        Y2(2)=REAL(N)
13754        Y2(3)=0.0
13755      ENDIF
13756      GOTO9000
13757   69 CONTINUE
13758C
13759      IF(IBUGG3.EQ.'ON')THEN
13760        WRITE(ICOUT,999)
13761        CALL DPWRST('XXX','BUG ')
13762        WRITE(ICOUT,70)
13763   70   FORMAT('***** AT THE BEGINNING OF DPBIN--')
13764        CALL DPWRST('XXX','BUG ')
13765        WRITE(ICOUT,71)IRELAT,IRHSTG,IHSTCW
13766   71   FORMAT('IRELAT,IRHSTG,IHSTCW = ',3(A4,1X))
13767        CALL DPWRST('XXX','BUG ')
13768        WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP
13769   72   FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7)
13770        CALL DPWRST('XXX','BUG ')
13771        DO73I=1,N
13772          WRITE(ICOUT,74)I,Y(I)
13773   74     FORMAT('I, Y(I) = ',I8,E15.7)
13774          CALL DPWRST('XXX','BUG ')
13775   73   CONTINUE
13776      ENDIF
13777C
13778C               **********************************************
13779C               **  STEP 2--                                **
13780C               **  IF NECESSARY,                           **
13781C               **  DETERMINE CLASS WIDTH,                  **
13782C               **  START VALUE, STOP VALUE,                **
13783C               **  AND NUMBER OF CLASSES.                  **
13784C               **********************************************
13785C
13786C  MARCH 2006: ALLOW DIFFERENT DEFAULT BINNING ALGORITHMS (AS
13787C              SPECIFIED BY IHSTCW).
13788C
13789      CALL DPBINZ(Y,N,CLWID,XSTART,XSTOP,
13790     1            TEMP1,MAXNXT,IHSTCW,IHSTOU,
13791     1            DCLWID,DXSTAR,DXSTOP,
13792     1            ISUBRO,IBUGG3,IERROR)
13793C
13794      DTOTWI=DXSTOP-DXSTAR
13795      ANUMCL=DTOTWI/DCLWID
13796      NUMCLA=INT(ANUMCL+1.0+0.1)
13797C
13798      J=NUMCLA-1
13799      DJ=J
13800      DCLMXJ=DXSTAR+DJ*DCLWID
13801      DABSDE=DABS(DCLMXJ-DXSTOP)
13802      IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1
13803C
13804      DO181I=1,NUMCLA
13805        X2(I)=0.0
13806        Y2(I)=0.0
13807  181 CONTINUE
13808C
13809C               *******************************************************
13810C               **  STEP 3--                                         **
13811C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
13812C               *******************************************************
13813C
13814      DO420I=1,N
13815      DXI=Y(I)
13816      DO430J=1,NUMCLA
13817      J2=J
13818      DJ=J
13819      DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
13820      DCLMXJ=DXSTAR+DJ*DCLWID
13821      IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
13822      IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)GOTO440
13823  430 CONTINUE
13824      GOTO420
13825  440 CONTINUE
13826      Y2(J2)=Y2(J2)+1.0
13827  420 CONTINUE
13828C
13829C     FOR THIS RAW DATA CASE,
13830C     TREAT THE SPECIAL CASE OF EQUALITY
13831C     WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
13832C
13833      J=NUMCLA
13834      DO450I=1,N
13835      DJ=J
13836      DCLMXJ=DXSTAR+DJ*DCLWID
13837      IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
13838      DXI=Y(I)
13839      IF(DXI.EQ.DCLMXJ)Y2(J)=Y2(J)+1.0
13840  450 CONTINUE
13841C
13842      IF(IBUGG3.EQ.'ON')THEN
13843        WRITE(ICOUT,999)
13844        CALL DPWRST('XXX','BUG ')
13845        WRITE(ICOUT,591)
13846  591   FORMAT('***** IN THE MIDDLE    OF DPBIN--')
13847        CALL DPWRST('XXX','BUG ')
13848        WRITE(ICOUT,592)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA
13849  592   FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ',
13850     1        4D11.4,F10.0,I8)
13851        CALL DPWRST('XXX','BUG ')
13852        DO593J=1,NUMCLA
13853          DJ=J
13854          DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
13855          DCLMXJ=DXSTAR+DJ*DCLWID
13856          IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
13857          FJ=Y2(J)
13858          WRITE(ICOUT,594)J,DCLMNJ,DCLMXJ,FJ
13859  594     FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,2D15.7,E15.7)
13860          CALL DPWRST('XXX','BUG ')
13861  593   CONTINUE
13862      ENDIF
13863C
13864      SUM=0.0
13865      DO1110J=1,NUMCLA
13866      FJ=Y2(J)
13867      SUM=SUM+FJ
13868 1110 CONTINUE
13869      AN3=SUM
13870C
13871      DENOM=1.0
13872C
13873      IF(IRELAT.EQ.'ON')THEN
13874        IF(IRHSTG.EQ.'PERC')THEN
13875          DENOM=AN3
13876        ELSE
13877          DENOM=AN3*DCLWID
13878        ENDIF
13879      ENDIF
13880C
13881      DO1120J=1,NUMCLA
13882        K=J
13883        DJ=J
13884        DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
13885        FJ=Y2(J)
13886        X2(K)=DCLMDJ
13887        Y2(K)=FJ/DENOM
13888 1120 CONTINUE
13889      N2=K
13890C
13891      DO1130J=NUMCLA,1,-1
13892        IF(Y2(J).GT.0.0)THEN
13893          N2=J
13894          GOTO1139
13895        ENDIF
13896 1130 CONTINUE
13897      N2=1
13898 1139 CONTINUE
13899C
13900      DO1140J=1,N2
13901        IF(Y2(J).GT.0.0)THEN
13902          IFRST=J
13903          GOTO1149
13904        ENDIF
13905 1140 CONTINUE
13906      IFRST=1
13907 1149 CONTINUE
13908      K=0
13909      DO1150J=IFRST,N2
13910        K=K+1
13911        X2(K)=X2(J)
13912        Y2(K)=Y2(J)
13913 1150 CONTINUE
13914C
13915      IF(N2.LT.NUMCLA)THEN
13916        DO1160I=N2+1,NUMCLA
13917          Y2(I)=0.0
13918          X2(I)=0.0
13919 1160   CONTINUE
13920      ENDIF
13921      N2=K
13922      GOTO9000
13923C
13924C               ******************
13925C               **   STEP 90--  **
13926C               **   EXIT       **
13927C               ******************
13928C
13929 9000 CONTINUE
13930      IF(IBUGG3.EQ.'ON')THEN
13931        WRITE(ICOUT,999)
13932        CALL DPWRST('XXX','BUG ')
13933        WRITE(ICOUT,9011)
13934 9011   FORMAT('***** AT THE END       OF DPBIN--')
13935        CALL DPWRST('XXX','BUG ')
13936        WRITE(ICOUT,9012)IRELAT,IERROR,N2
13937 9012   FORMAT('IRELAT,IERROR,N2 = ',A4,2X,A4,2X,I8)
13938        CALL DPWRST('XXX','BUG ')
13939        WRITE(ICOUT,9013)AN3,DENOM
13940 9013   FORMAT('AN3,DENOM = ',E15.8,E15.8)
13941        CALL DPWRST('XXX','BUG ')
13942        DO9015I=1,N2
13943          WRITE(ICOUT,9016)I,X2(I),Y2(I)
13944 9016     FORMAT('I,X2(I),Y2(I) = ',I8,E15.7,F9.2)
13945          CALL DPWRST('XXX','BUG ')
13946 9015   CONTINUE
13947        WRITE(ICOUT,9017)N,DCLWID,DXSTAR,DXSTOP
13948 9017   FORMAT('N,DCLWID,DXSTAR,DXSTOP = ',I6,3D15.7)
13949        CALL DPWRST('XXX','BUG ')
13950      ENDIF
13951C
13952      RETURN
13953      END
13954      SUBROUTINE DPBINA(Y,N,CLWID,XSTART,XSTOP,M,
13955     1XTEMP1,MAXOBV,
13956     1IRELAT,IASHWT,IHSTCW,
13957     1Y2,X2,N2,IBUGG3,IERROR)
13958C
13959C     PURPOSE--COMPUTE HISTOGRAM BINS USING THE "AVERAGE SHIFTED
13960C              HISTOGRAM" (ASH) ALGORITHM DOCUMENTED BY DAVID SCOTT,
13961C              1992, "MULTIVARIATE DENSITY ESTIMATION: THEORY,
13962C              PRACTICE, AND VISUALIZATION", WILEY, CHAPTER 5.
13963C              WE IMPLEMENT THE ALGORITHMS BIN1 AND ASH1 GIVEN ON
13964C              PAGES 117-118.  THE BINNED DATA IS RETURNED IN
13965C              Y2 AND X2.
13966C
13967C              NOTE THAT SINCE THE ASH BINNING IS INTENDED TO BE A
13968C              SIMPLE DENSITY ESTIMATOR, THIS ALGORITHM IS
13969C              IMPLEMENTED FOR THE "RELATIVE FREQUENCY" CASE, NOT
13970C              RAW COUNTS.
13971C
13972C              THE BASIC IDEA IS:
13973C
13974C              1) GIVEN A CLASS WIDTH OF H
13975C              2) CHOOSE M WHERE WE CONSTRUCT A COLLECTION OF M
13976C                 HISTOGRAMS, EACH WITH A CLASS WIDTH OF H, BUT
13977C                 WITH START POINTS
13978C                 t0 = 0, h/m, 2*h/m, ... , (m-1)*h/m
13979C              3) THIS RESULTS IN A SMOOTHED HISTOGRAM WITH
13980C                 A BIN WIDTH OF DELTA=H/M.  HIGHER VALUES OF M
13981C                 RESULT IN A SMOOTHER ESTIMATE.  VALUES OF M ARE
13982C                 TYPICALLY IN THE RANGE 4 TO 32.  IN THIS
13983C                 SUBROUTINE, VALUES OF M < 1 ARE SET TO 1 AND
13984C                 VALUES OF M > 64 ARE SET TO 64.
13985C
13986C     WRITTEN BY--ALAN HECKERT
13987C                 STATISTICAL ENGINEERING DIVISION
13988C                 INFORMATION TECHNOLOGY LABORATORY
13989C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
13990C                 GAITHERSBURG, MD 20899-8980
13991C                 PHONE--301-975-2899
13992C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
13993C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
13994C     LANGUAGE--ANSI FORTRAN (1977)
13995C     VERSION NUMBER--2004/9
13996C     ORIGINAL VERSION--SEPTEMBER 2004.
13997C
13998C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
13999C
14000      PARAMETER(MAXM=64)
14001C
14002      CHARACTER*4 IBUGG3
14003      CHARACTER*4 IERROR
14004C
14005      CHARACTER*4 IWRIT2
14006      CHARACTER*4 IRELAT
14007      CHARACTER*4 IASHWT
14008      CHARACTER*4 IHSTCW
14009C
14010      CHARACTER*4 ISUBN1
14011      CHARACTER*4 ISUBN2
14012C
14013C---------------------------------------------------------------------
14014
14015      DOUBLE PRECISION DCLWID
14016      DOUBLE PRECISION DXSTAR
14017      DOUBLE PRECISION DXSTOP
14018      DOUBLE PRECISION DH
14019      DOUBLE PRECISION DELTA
14020      DOUBLE PRECISION DX
14021      DOUBLE PRECISION DNBIN
14022      DOUBLE PRECISION DN
14023C
14024C-----------------------------------------------------------------
14025C
14026      DIMENSION Y(*)
14027      DIMENSION Y2(*)
14028      DIMENSION X2(*)
14029      DIMENSION XTEMP1(*)
14030C
14031      DIMENSION WTM(2*MAXM)
14032C
14033C---------------------------------------------------------------------
14034C
14035      INCLUDE 'DPCOP2.INC'
14036C
14037C-----START POINT-----------------------------------------------------
14038C
14039      ISUBN1='DPBI'
14040      ISUBN2='N   '
14041      IERROR='NO'
14042C
14043      DCLWID=CLWID
14044      DXSTAR=XSTART
14045      DXSTOP=XSTOP
14046      XMEAN=CPUMIN
14047      XSD=CPUMIN
14048      XMIN=CPUMIN
14049      XMAX=CPUMIN
14050C
14051C               ********************************************
14052C               **  STEP 1--                              **
14053C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
14054C               ********************************************
14055C
14056      IF(N.LE.5)THEN
14057        WRITE(ICOUT,999)
14058  999   FORMAT(1X)
14059        CALL DPWRST('XXX','BUG ')
14060        WRITE(ICOUT,31)
14061   31   FORMAT('***** ERROR IN AVERAGE SHIFTED HISTOGRAM BINNING--')
14062        CALL DPWRST('XXX','BUG ')
14063        WRITE(ICOUT,32)
14064   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 5;')
14065        CALL DPWRST('XXX','BUG ')
14066        WRITE(ICOUT,34)N
14067   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
14068        CALL DPWRST('XXX','BUG ')
14069        WRITE(ICOUT,999)
14070        CALL DPWRST('XXX','BUG ')
14071        IERROR='YES'
14072        GOTO9000
14073      ENDIF
14074C
14075      IF(M.LT.1 .OR. M.GT.MAXM)THEN
14076        WRITE(ICOUT,999)
14077        CALL DPWRST('XXX','BUG ')
14078        WRITE(ICOUT,31)
14079        CALL DPWRST('XXX','BUG ')
14080        WRITE(ICOUT,42)
14081   42   FORMAT('      THE VALUE OF THE M PARAMETER MUST BE AT ',
14082     1         'LEAST 1 AND')
14083        CALL DPWRST('XXX','BUG ')
14084        WRITE(ICOUT,44)MAXM
14085   44   FORMAT('      LESS THAN OR EQUAL TO ',I5,' (RECOMMENDED ',
14086     1         'VALUES ARE 4, 8, 16, OR 32).')
14087        CALL DPWRST('XXX','BUG ')
14088        WRITE(ICOUT,46)M
14089   46   FORMAT('      THE ENTERED VALUE OF M HERE = ',I6)
14090        CALL DPWRST('XXX','BUG ')
14091        WRITE(ICOUT,999)
14092        CALL DPWRST('XXX','BUG ')
14093        IERROR='YES'
14094        GOTO9000
14095      ENDIF
14096C
14097      HOLD=Y(1)
14098      DO60I=1,N
14099        IF(Y(I).NE.HOLD)GOTO69
14100   60 CONTINUE
14101      WRITE(ICOUT,999)
14102      CALL DPWRST('XXX','BUG ')
14103      WRITE(ICOUT,31)
14104      CALL DPWRST('XXX','BUG ')
14105      WRITE(ICOUT,62)HOLD
14106   62 FORMAT('      ALL INPUT OBSERVATIONS ARE IDENTICALLY EQUAL ',
14107     1       'TO ',G15.7)
14108      CALL DPWRST('XXX','BUG ')
14109      WRITE(ICOUT,999)
14110      CALL DPWRST('XXX','BUG ')
14111      IERROR='YES'
14112      GOTO9000
14113   69 CONTINUE
14114C
14115      IF(IBUGG3.EQ.'ON')THEN
14116        WRITE(ICOUT,999)
14117        CALL DPWRST('XXX','BUG ')
14118        WRITE(ICOUT,70)
14119   70   FORMAT('***** AT THE BEGINNING OF DPBINA--')
14120        CALL DPWRST('XXX','BUG ')
14121        WRITE(ICOUT,71)N,M,CLWID,XSTART,XSTOP
14122   71   FORMAT('N,M,CLWID,XSTART,XSTOP = ',2I6,3G15.7)
14123        CALL DPWRST('XXX','BUG ')
14124        WRITE(ICOUT,72)IASHWT
14125   72   FORMAT('IASHWT = ',A4)
14126        CALL DPWRST('XXX','BUG ')
14127        DO73I=1,N
14128          WRITE(ICOUT,74)I,Y(I)
14129   74     FORMAT('I, Y(I) = ',I8,E15.7)
14130          CALL DPWRST('XXX','BUG ')
14131   73   CONTINUE
14132      ENDIF
14133C
14134C               ***********************************
14135C               **  STEP 2--                     **
14136C               **  IF NECESSARY, DETERMINE:     **
14137C               **  1) CLASS WIDTH               **
14138C               **  2) START VALUE               **
14139C               **  3) STOP VALUE                **
14140C               **  4) NUMBER OF BINS            **
14141C               ***********************************
14142C
14143      IF(CLWID.EQ.CPUMIN.OR.XSTART.EQ.CPUMIN.OR.
14144     1XSTOP.EQ.CPUMAX)THEN
14145        IWRIT2='OFF'
14146        CALL MEAN(Y,N,IWRIT2,XMEAN,IBUGG3,IERROR)
14147        CALL SD(Y,N,IWRIT2,XSD,IBUGG3,IERROR)
14148        CALL MINIM(Y,N,IWRIT2,XMIN,IBUGG3,IERROR)
14149        CALL MAXIM(Y,N,IWRIT2,XMAX,IBUGG3,IERROR)
14150        IF(IHSTCW.EQ.'DEFA')THEN
14151          IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD
14152        ELSEIF(IHSTCW.EQ.'NORM')THEN
14153          IF(CLWID.EQ.CPUMIN)DCLWID=3.5*XSD/(REAL(N)**(1./3.))
14154        ELSEIF(IHSTCW.EQ.'NCOR')THEN
14155          IF(CLWID.EQ.CPUMIN)THEN
14156            CALL STMOM3(Y,N,IWRIT2,XSKEW,IBUGG3,IERROR)
14157            CALL STMOM4(Y,N,IWRIT2,XKURT,IBUGG3,IERROR)
14158            TERM1=3.5*XSD/(REAL(N)**(1./3.))
14159            IF(XSKEW.GT.0.0 .AND. XSKEW.LT.3.0)THEN
14160              TERM2=1.0/(1.0 - 0.0060*XSKEW + 0.27*XSKEW**2 -
14161     1              0.0069*XSKEW**3)
14162            ELSE
14163              TERM2=1.0
14164            ENDIF
14165            XKURT=XKURT - 3.0
14166            IF(XKURT.GT.0.0 .AND. XKURT.LT.6.0)THEN
14167              TERM3=1.0 - 0.2*(1.0 - EXP(-0.7*XKURT))
14168            ELSE
14169              TERM3=1.0
14170            ENDIF
14171            DCLWID=DBLE(TERM1*TERM2*TERM3)
14172          ENDIF
14173        ELSEIF(IHSTCW.EQ.'IQ  ')THEN
14174          CALL LOWQUA(Y,N,IWRIT2,XTEMP1,MAXOBV,XLOWQ,IBUGG3,IERROR)
14175          CALL UPPQUA(Y,N,IWRIT2,XTEMP1,MAXOBV,XUPPQ,IBUGG3,IERROR)
14176          XIQ=XUPPQ - XLOWQ
14177          IF(CLWID.EQ.CPUMIN)DCLWID=2.603*XIQ/(REAL(N)**(1./3.))
14178        ELSE
14179          IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD
14180        ENDIF
14181C
14182        IF(XSTART.EQ.CPUMIN)THEN
14183CCCCC     DXSTAR=XMEAN-6.0*XSD
14184          ABIN=ABS((XMEAN-XMIN)/REAL(DCLWID))
14185          IBINL=INT(ABIN+1.0)
14186          DXSTAR=DBLE(XMEAN)-DBLE(IBINL)*DCLWID
14187        ELSE
14188          ABIN=ABS((XMEAN-XSTART)/REAL(DCLWID))
14189          IBINL=INT(ABIN+1.0)
14190          DXSTAR=DBLE(XMEAN)-DBLE(IBINL)*DCLWID
14191        ENDIF
14192        IF(XSTOP.EQ.CPUMAX)THEN
14193CCCCCC    DXSTOP=XMEAN+6.0*XSD
14194          ABIN=ABS((XMAX-XMEAN)/REAL(DCLWID))
14195          IBINU=INT(ABIN+1.0)
14196          DXSTOP=DBLE(XMEAN)+DBLE(IBINU)*DCLWID
14197        ELSE
14198          ABIN=ABS((XSTOP-XMEAN)/REAL(DCLWID))
14199          IBINU=INT(ABIN+1.0)
14200          DXSTOP=DBLE(XMEAN)+DBLE(IBINU)*DCLWID
14201        ENDIF
14202        NBIN=IBINL + IBINU
14203      ELSE
14204        ABIN=(XMEAN-XSTART)/REAL(DCLWID)
14205        IBINL=INT(ABIN+1.0)
14206        DXSTAR=DBLE(XMEAN)-DBLE(IBINL)*DCLWID
14207C
14208        ABIN=(XSTOP-XMEAN)/REAL(DCLWID)
14209        IBINU=INT(ABIN+1.0)
14210        DXSTOP=DBLE(XMEAN)+DBLE(IBINU)*DCLWID
14211C
14212        NBIN=IBINL + IBINU
14213      ENDIF
14214C
14215      IF(IBUGG3.EQ.'ON')THEN
14216        WRITE(ICOUT,999)
14217        CALL DPWRST('XXX','BUG ')
14218        WRITE(ICOUT,170)
14219  170   FORMAT('***** MIDDLE OF DPBINA--')
14220        CALL DPWRST('XXX','BUG ')
14221        WRITE(ICOUT,171)XMEAN,XSD,XMIN,XMAX
14222  171   FORMAT('XMEAN,XSD,XMIN,XMAX = ',4G15.7)
14223        CALL DPWRST('XXX','BUG ')
14224        WRITE(ICOUT,172)DCLWID,DXSTAR,DXSTOP
14225  172   FORMAT('DCLWID,DXSTAR,DXSTOP = ',3G15.7)
14226        CALL DPWRST('XXX','BUG ')
14227      ENDIF
14228C
14229C               ***********************************************
14230C               **  STEP 3--                                 **
14231C               **  IMPLEMENT BIN1 ALGORITHM FROM PAGE 117.  **
14232C               ***********************************************
14233C
14234      DELTA=DCLWID/DBLE(M)
14235      NBIN=INT((DXSTOP-DXSTAR)/DELTA + 0.5D0)
14236      DNBIN=DBLE(NBIN)
14237      DO410I=1,NBIN
14238        Y2(I)=0.0
14239  410 CONTINUE
14240C
14241      DO420I=1,N
14242        DX=DBLE(Y(I))
14243        DK=((DX - DXSTAR)/DELTA) + 1.0D0
14244        IK=INT(DK)
14245        IF(IK.GE.1 .AND. IK.LE.NBIN)Y2(IK)=Y2(IK)+1.0
14246  420 CONTINUE
14247C
14248      IF(IRELAT.EQ.'OFF')THEN
14249        DO430I=1,NBIN
14250          X2(I)=REAL(DXSTAR + (DBLE(I)-0.5D0)*DELTA)
14251  430   CONTINUE
14252        N2=NBIN
14253        GOTO9000
14254      ENDIF
14255C
14256C               ***********************************************
14257C               **  STEP 4--                                 **
14258C               **  IMPLEMENT ASH1 ALGORITHM FROM PAGE 118.  **
14259C               ***********************************************
14260C
14261      IF(IASHWT.EQ.'BIWE')THEN
14262        ISTRT=1-M
14263        ISTOP=M-1
14264        ASUM=0.0
14265        DO510I=ISTRT,ISTOP
14266          T=REAL(I)/REAL(M)
14267          IF(-1.0.LE.T .AND. T.LE.1.0)THEN
14268            ASUM=ASUM + (15./16.)*(1.0-T**2)**2
14269          ENDIF
14270  510   CONTINUE
14271C
14272        DO520I=ISTRT,ISTOP
14273          T=REAL(I)/REAL(M)
14274          IF(-1.0.LE.T .AND. T.LE.1.0)THEN
14275            TERM1=(15./16.)*(1.0-T**2)**2
14276          ELSE
14277            TERM1=0.0
14278          ENDIF
14279          WTM(I+M+1)=REAL(M)*TERM1/ASUM
14280  520   CONTINUE
14281      ELSE
14282        ISTRT=1-M
14283        ISTOP=M-1
14284        DO560I=ISTRT,ISTOP
14285          WTM(I+M)=1.0 - ABS(REAL(I))/REAL(M)
14286  560   CONTINUE
14287      ENDIF
14288C
14289      DH=DBLE(M)*DELTA
14290      DO610I=1,NBIN
14291        XTEMP1(I)=0.0
14292  610 CONTINUE
14293C
14294      DO620K=1,NBIN
14295        IF(Y2(K).GT.0.0)THEN
14296          IFRST=MAX(1,K-M+1)
14297          ILAST=MIN(NBIN,K+M-1)
14298          IF(ILAST.GE.IFRST)THEN
14299            DO630I=IFRST,ILAST
14300              XTEMP1(I)= XTEMP1(I) + Y2(K)*WTM(I-K+M)
14301  630       CONTINUE
14302          ENDIF
14303        ENDIF
14304  620 CONTINUE
14305C
14306      DN=DBLE(N)
14307      DO680I=1,NBIN
14308        Y2(I)=XTEMP1(I)/(REAL(DH*DN))
14309        X2(I)=REAL(DXSTAR + (DBLE(I)-0.5D0)*DELTA)
14310  680 CONTINUE
14311      N2=NBIN
14312C
14313C               ******************
14314C               **   STEP 90--  **
14315C               **   EXIT       **
14316C               ******************
14317C
14318 9000 CONTINUE
14319      IF(IBUGG3.EQ.'ON')THEN
14320        WRITE(ICOUT,999)
14321        CALL DPWRST('XXX','BUG ')
14322        WRITE(ICOUT,9011)
14323 9011   FORMAT('***** AT THE END       OF DPBINA--')
14324        CALL DPWRST('XXX','BUG ')
14325        WRITE(ICOUT,9012)IRELAT,IERROR,N2
14326 9012   FORMAT('IRELAT,IERROR,N2 = ',A4,2X,A4,2X,I8)
14327        CALL DPWRST('XXX','BUG ')
14328        DO9015I=1,N2
14329          WRITE(ICOUT,9016)I,X2(I),Y2(I)
14330 9016     FORMAT('I,X2(I),Y2(I) = ',I8,2G15.7)
14331          CALL DPWRST('XXX','BUG ')
14332 9015   CONTINUE
14333        DO9025I=1,M
14334          WRITE(ICOUT,9026)I,WTM(I)
14335 9026     FORMAT('I,WTM(I) = ',I8,G15.7)
14336          CALL DPWRST('XXX','BUG ')
14337 9025   CONTINUE
14338      ENDIF
14339C
14340      RETURN
14341      END
14342      SUBROUTINE DPBINC(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG,
14343     1                  TEMP1,MAXNXT,IHSTCW,IHSTOU,
14344     1                  Y2,X2,N2,YCODE,
14345     1                  ISUBRO,IBUGG3,IERROR)
14346C
14347C     PURPOSE--THIS ROUTINE IS SIMILAR TO DPBIN IN THAT IT WILL BIN A
14348C              VARIABLE Y INTO X2 Y2 (THAT IS CONVERT RAW DATA TO
14349C              FREQUENCY DATA).  HOWEVER, IT THEN TAKES AN ADDITIONAL
14350C              STEP TO GENERATE A CODED VARIABLE THAT IDENTIFIES THE
14351C              THE BIN THAT EACH OF THE ORIGINAL POINTS FALLS INTO.
14352C     WRITTEN BY--ALAN HECKERT
14353C                 STATISTICAL ENGINEERING DIVISION
14354C                 INFORMATION TECHNOLOGY LABORATORY
14355C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14356C                 GAITHERSBURG, MD 20899-8980
14357C                 PHONE--301-975-2899
14358C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14359C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14360C     LANGUAGE--ANSI FORTRAN (1977)
14361C     VERSION NUMBER--2012/11
14362C     ORIGINAL VERSION--NOVEMBER  2012.
14363C
14364C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14365C
14366      CHARACTER*4 IRELAT
14367      CHARACTER*4 IBUGG3
14368      CHARACTER*4 ISUBRO
14369      CHARACTER*4 IERROR
14370C
14371      CHARACTER*4 IRHSTG
14372      CHARACTER*4 IHSTCW
14373      CHARACTER*4 IHSTOU
14374      CHARACTER*4 ISUBN1
14375      CHARACTER*4 ISUBN2
14376C
14377C---------------------------------------------------------------------
14378
14379      DOUBLE PRECISION DCLWID
14380      DOUBLE PRECISION DXSTAR
14381      DOUBLE PRECISION DXSTOP
14382      DOUBLE PRECISION DCLMNJ
14383      DOUBLE PRECISION DCLMDJ
14384      DOUBLE PRECISION DCLMXJ
14385      DOUBLE PRECISION DJ
14386      DOUBLE PRECISION DXI
14387      DOUBLE PRECISION DABSDE
14388      DOUBLE PRECISION DTOTWI
14389C
14390C---------------------------------------------------------------------
14391C
14392      DIMENSION Y(*)
14393      DIMENSION Y2(*)
14394      DIMENSION X2(*)
14395      DIMENSION TEMP1(*)
14396      DIMENSION YCODE(*)
14397C
14398C---------------------------------------------------------------------
14399C
14400      INCLUDE 'DPCOP2.INC'
14401C
14402C-----START POINT-----------------------------------------------------
14403C
14404      ISUBN1='DPBI'
14405      ISUBN2='NC  '
14406      IERROR='NO'
14407C
14408      HOLD=CPUMIN
14409C
14410      IF(IBUGG3.EQ.'ON' .OR.ISUBRO.EQ.'BINC')THEN
14411        WRITE(ICOUT,999)
14412        CALL DPWRST('XXX','BUG ')
14413        WRITE(ICOUT,50)
14414   50   FORMAT('***** AT THE BEGINNING OF DPBINC--')
14415        CALL DPWRST('XXX','BUG ')
14416        WRITE(ICOUT,51)IRELAT,IRHSTG,IHSTCW
14417   51   FORMAT('IRELAT,IRHSTG,IHSTCW = ',3(A4,1X))
14418        CALL DPWRST('XXX','BUG ')
14419        WRITE(ICOUT,52)N,CLWID,XSTART,XSTOP
14420   52   FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3G15.7)
14421        CALL DPWRST('XXX','BUG ')
14422        DO53I=1,N
14423          WRITE(ICOUT,54)I,Y(I)
14424   54     FORMAT('I, Y(I) = ',I8,G15.7)
14425          CALL DPWRST('XXX','BUG ')
14426   53   CONTINUE
14427      ENDIF
14428C
14429      DO59I=1,N
14430        YCODE(I)=1.0
14431   59 CONTINUE
14432      K=(-999)
14433      DCLMDJ=(-999.0D0)
14434      KP3=0
14435      AN3=0.0
14436      DENOM=0.0
14437      DCLWID=CLWID
14438      DXSTAR=XSTART
14439      DXSTOP=XSTOP
14440C
14441C               ********************************************
14442C               **  STEP 1--                              **
14443C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
14444C               ********************************************
14445C
14446      IF(N.LT.1)THEN
14447        WRITE(ICOUT,999)
14448  999   FORMAT(1X)
14449        CALL DPWRST('XXX','BUG ')
14450        WRITE(ICOUT,31)
14451   31   FORMAT('***** ERROR IN BINNING CODED--')
14452        CALL DPWRST('XXX','BUG ')
14453        WRITE(ICOUT,32)
14454   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 1;')
14455        CALL DPWRST('XXX','BUG ')
14456        WRITE(ICOUT,34)N
14457   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8)
14458        CALL DPWRST('XXX','BUG ')
14459        WRITE(ICOUT,999)
14460        CALL DPWRST('XXX','BUG ')
14461        IERROR='YES'
14462        GOTO9000
14463      ELSEIF(N.EQ.1)THEN
14464        N2=1
14465        X2(1)=HOLD
14466        Y2(1)=1.0
14467        YCODE(1)=1.0
14468        GOTO9000
14469      ENDIF
14470C
14471      HOLD=Y(1)
14472      DO60I=1,N
14473        IF(Y(I).NE.HOLD)GOTO69
14474   60 CONTINUE
14475      N2=3
14476      X2(1)=HOLD-1.0
14477      X2(2)=HOLD
14478      X2(3)=HOLD+1
14479      IF(IRELAT.EQ.'ON')THEN
14480        Y2(1)=0.0
14481        Y2(2)=1.0
14482        Y2(3)=0.0
14483      ELSE
14484        Y2(1)=0.0
14485        Y2(2)=REAL(N)
14486        Y2(3)=0.0
14487      ENDIF
14488      DO67I=1,N
14489        YCODE(I)=1.0
14490   67 CONTINUE
14491      GOTO9000
14492   69 CONTINUE
14493C
14494C
14495C               **********************************************
14496C               **  STEP 2--                                **
14497C               **  IF NECESSARY,                           **
14498C               **  DETERMINE CLASS WIDTH,                  **
14499C               **  START VALUE, STOP VALUE,                **
14500C               **  AND NUMBER OF CLASSES.                  **
14501C               **********************************************
14502C
14503      CALL DPBINZ(Y,N,CLWID,XSTART,XSTOP,
14504     1            TEMP1,MAXNXT,IHSTCW,IHSTOU,
14505     1            DCLWID,DXSTAR,DXSTOP,
14506     1            ISUBRO,IBUGG3,IERROR)
14507C
14508      DTOTWI=DXSTOP-DXSTAR
14509      ANUMCL=DTOTWI/DCLWID
14510      NUMCLA=INT(ANUMCL+1.0+0.1)
14511C
14512      J=NUMCLA-1
14513      DJ=J
14514      DCLMXJ=DXSTAR+DJ*DCLWID
14515      DABSDE=DABS(DCLMXJ-DXSTOP)
14516      IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1
14517C
14518      DO181I=1,NUMCLA
14519        X2(I)=0.0
14520        Y2(I)=0.0
14521  181 CONTINUE
14522C
14523C               *******************************************************
14524C               **  STEP 3--                                         **
14525C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
14526C               *******************************************************
14527C
14528      DO420I=1,N
14529        DXI=Y(I)
14530        DO430J=1,NUMCLA
14531          J2=J
14532          DJ=J
14533          DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
14534          DCLMXJ=DXSTAR+DJ*DCLWID
14535          IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
14536          IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)THEN
14537            Y2(J2)=Y2(J2)+1.0
14538            GOTO420
14539          ENDIF
14540  430   CONTINUE
14541  420 CONTINUE
14542C
14543C     FOR THIS RAW DATA CASE,
14544C     TREAT THE SPECIAL CASE OF EQUALITY
14545C     WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
14546C
14547      J=NUMCLA
14548      DO450I=1,N
14549        DJ=J
14550        DCLMXJ=DXSTAR+DJ*DCLWID
14551        IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
14552        DXI=Y(I)
14553        IF(DXI.EQ.DCLMXJ)Y2(J)=Y2(J)+1.0
14554  450 CONTINUE
14555C
14556      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BINC')THEN
14557        WRITE(ICOUT,999)
14558        CALL DPWRST('XXX','BUG ')
14559        WRITE(ICOUT,591)
14560  591   FORMAT('***** IN THE MIDDLE    OF DPBINC--')
14561        CALL DPWRST('XXX','BUG ')
14562        WRITE(ICOUT,592)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA
14563  592   FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ',
14564     1        4D11.4,F10.0,I8)
14565        CALL DPWRST('XXX','BUG ')
14566        DO593J=1,NUMCLA
14567          DJ=J
14568          DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
14569          DCLMXJ=DXSTAR+DJ*DCLWID
14570          IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
14571          FJ=Y2(J)
14572          WRITE(ICOUT,594)J,DCLMNJ,DCLMXJ,FJ
14573  594     FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,3G15.7)
14574          CALL DPWRST('XXX','BUG ')
14575  593   CONTINUE
14576      ENDIF
14577C
14578      SUM=0.0
14579      DO1110J=1,NUMCLA
14580        FJ=Y2(J)
14581        SUM=SUM+FJ
14582 1110 CONTINUE
14583      AN3=SUM
14584C
14585      DENOM=1.0
14586C
14587      IF(IRELAT.EQ.'ON')THEN
14588        IF(IRHSTG.EQ.'PERC')THEN
14589          DENOM=AN3
14590        ELSE
14591          DENOM=AN3*DCLWID
14592        ENDIF
14593      ENDIF
14594C
14595      DO1120J=1,NUMCLA
14596        K=J
14597        DJ=J
14598        DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
14599        FJ=Y2(J)
14600        X2(K)=DCLMDJ
14601        Y2(K)=FJ/DENOM
14602 1120 CONTINUE
14603      N2=K
14604C
14605      DO1130J=NUMCLA,1,-1
14606        IF(Y2(J).GT.0.0)THEN
14607          N2=J
14608          GOTO1139
14609        ENDIF
14610 1130 CONTINUE
14611      N2=1
14612 1139 CONTINUE
14613C
14614      DO1140J=1,N2
14615        IF(Y2(J).GT.0.0)THEN
14616          IFRST=J
14617          GOTO1149
14618        ENDIF
14619 1140 CONTINUE
14620      IFRST=1
14621 1149 CONTINUE
14622      DJ=DBLE(IFRST)
14623      DXSTAR=DXSTAR+(DJ-1.0D0)*DCLWID
14624      K=0
14625      DO1150J=IFRST,N2
14626        K=K+1
14627        X2(K)=X2(J)
14628        Y2(K)=Y2(J)
14629 1150 CONTINUE
14630C
14631      IF(N2.LT.NUMCLA)THEN
14632        DO1160I=N2+1,NUMCLA
14633          Y2(I)=0.0
14634          X2(I)=0.0
14635 1160   CONTINUE
14636      ENDIF
14637      N2=K
14638C
14639C
14640C               *******************************************************
14641C               **  STEP 4--                                         **
14642C               **  NOW DETERMINE WHICH BIN EACH DATA POINT FALLS IN **
14643C               *******************************************************
14644C
14645      DO2050I=1,N
14646        DO2060J=1,N2
14647          DJ=J
14648          DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
14649          DCLMXJ=DXSTAR+DJ*DCLWID
14650          IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
14651          IF(Y(I).GE.DCLMNJ .AND. Y(I).LE.DCLMXJ)THEN
14652            YCODE(I)=REAL(J)
14653            GOTO2069
14654          ENDIF
14655 2060   CONTINUE
14656 2069   CONTINUE
14657 2050 CONTINUE
14658C
14659C               ******************
14660C               **   STEP 90--  **
14661C               **   EXIT       **
14662C               ******************
14663C
14664 9000 CONTINUE
14665      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BINC')THEN
14666        WRITE(ICOUT,999)
14667        CALL DPWRST('XXX','BUG ')
14668        WRITE(ICOUT,9011)
14669 9011   FORMAT('***** AT THE END       OF DPBINC--')
14670        CALL DPWRST('XXX','BUG ')
14671        WRITE(ICOUT,9013)IERROR,N2,IFRST,ILAST,AN3,DENOM
14672 9013   FORMAT('IERROR,N2,IFRST,ILAST,AN3,DENOM = ',A4,2X,3I8,2X,2G15.7)
14673        CALL DPWRST('XXX','BUG ')
14674        DO9015I=1,N2
14675          WRITE(ICOUT,9016)I,X2(I),Y2(I)
14676 9016     FORMAT('I,X2(I),Y2(I) = ',I8,2G15.7)
14677          CALL DPWRST('XXX','BUG ')
14678 9015   CONTINUE
14679        DO9017I=1,N
14680          WRITE(ICOUT,9018)I,YCODE(I)
14681 9018     FORMAT('I,YCODE(I) = ',I8,G15.7)
14682          CALL DPWRST('XXX','BUG ')
14683 9017   CONTINUE
14684      ENDIF
14685C
14686      RETURN
14687      END
14688      SUBROUTINE DPBINI(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG,
14689     1Y2,X2,N2,IBUGG3,IERROR)
14690C
14691C     PURPOSE--BIN A VARIABLE Y INTO X2 Y2.
14692C              THAT IS CONVERT RAW DATA TO FREQUENCY DATA.
14693C              BINNING IS TO COUNTS (AND NOT TO RELATIVE)
14694C              FREQUENCY.
14695C              THIS IS A SPECIFAL FORM OF BINNING WHERE THE
14696C              BINS ARE THE INTEGERS FROM THE MINIMUM TO THE MAXIMUM
14697C              VALUE.  THIS ROUTINE IS USED TO BIN FOR GOODNESS OF
14698C              FIT TESTS FOR DISCRETE DISTRIBUTIONS.
14699C
14700C     WRITTEN BY--ALAN HECKERT
14701C                 STATISTICAL ENGINEERING DIVISION
14702C                 INFORMATION TECHNOLOGY LABORATORY
14703C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
14704C                 GAITHERSBURG, MD 20899-8980
14705C                 PHONE--301-975-2899
14706C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
14707C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
14708C     LANGUAGE--ANSI FORTRAN (1977)
14709C     VERSION NUMBER--98/11
14710C     ORIGINAL VERSION--NOVEMBER  1998.
14711C
14712C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
14713C
14714      CHARACTER*4 IRELAT
14715      CHARACTER*4 IBUGG3
14716      CHARACTER*4 IERROR
14717C
14718      CHARACTER*4 IWRIT2
14719      CHARACTER*4 IRHSTG
14720C
14721      CHARACTER*4 ISUBN1
14722      CHARACTER*4 ISUBN2
14723C
14724C---------------------------------------------------------------------
14725
14726      DOUBLE PRECISION DCLWID
14727      DOUBLE PRECISION DXSTAR
14728      DOUBLE PRECISION DXSTOP
14729      DOUBLE PRECISION DCLMNJ
14730      DOUBLE PRECISION DCLMDJ
14731      DOUBLE PRECISION DCLMXJ
14732      DOUBLE PRECISION DJ
14733      DOUBLE PRECISION DXI
14734      DOUBLE PRECISION DABSDE
14735      DOUBLE PRECISION DTOTWI
14736C
14737C---------------------------------------------------------------------
14738C
14739      DIMENSION Y(*)
14740      DIMENSION Y2(*)
14741      DIMENSION X2(*)
14742C
14743C---------------------------------------------------------------------
14744C
14745      INCLUDE 'DPCOP2.INC'
14746C
14747C-----START POINT-----------------------------------------------------
14748C
14749      ISUBN1='DPBI'
14750      ISUBN2='NI  '
14751C
14752      IERROR='NO'
14753C
14754      K=(-999)
14755      DCLMDJ=(-999.0D0)
14756C
14757      KP3=0
14758C
14759      AN3=0.0
14760      DENOM=0.0
14761C
14762      DCLWID=CLWID
14763      DXSTAR=XSTART
14764      DXSTOP=XSTOP
14765C
14766C               ********************************************
14767C               **  STEP 1--                              **
14768C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
14769C               ********************************************
14770C
14771      IF(N.GE.1)GOTO39
14772      WRITE(ICOUT,999)
14773  999 FORMAT(1X)
14774      CALL DPWRST('XXX','BUG ')
14775      WRITE(ICOUT,31)
14776   31 FORMAT('***** ERROR IN DPBINI--')
14777      CALL DPWRST('XXX','BUG ')
14778      WRITE(ICOUT,32)
14779   32 FORMAT('      THE NUMBER OF OBSERVATIONS')
14780      CALL DPWRST('XXX','BUG ')
14781      WRITE(ICOUT,33)
14782   33 FORMAT('      MUST BE AT LEAST 1;')
14783      CALL DPWRST('XXX','BUG ')
14784      WRITE(ICOUT,34)N
14785   34 FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I6)
14786      CALL DPWRST('XXX','BUG ')
14787      WRITE(ICOUT,999)
14788      CALL DPWRST('XXX','BUG ')
14789      IERROR='YES'
14790      GOTO9000
14791   39 CONTINUE
14792C
14793      IF(N.GE.2)GOTO49
14794      WRITE(ICOUT,999)
14795      CALL DPWRST('XXX','BUG ')
14796      WRITE(ICOUT,46)
14797   46 FORMAT('***** ERROR IN DPBINI--')
14798      CALL DPWRST('XXX','BUG ')
14799      WRITE(ICOUT,47)
14800   47 FORMAT('      THE NUMBER OF OBSERVATIONS')
14801      CALL DPWRST('XXX','BUG ')
14802      WRITE(ICOUT,48)
14803   48 FORMAT('      WAS EXACTLY EQUAL TO 1.')
14804      CALL DPWRST('XXX','BUG ')
14805      WRITE(ICOUT,999)
14806      CALL DPWRST('XXX','BUG ')
14807      IERROR='YES'
14808      GOTO9000
14809   49 CONTINUE
14810C
14811      HOLD=Y(1)
14812      DO60I=1,N
14813      IF(Y(I).NE.HOLD)GOTO69
14814   60 CONTINUE
14815      WRITE(ICOUT,999)
14816      CALL DPWRST('XXX','BUG ')
14817      WRITE(ICOUT,61)
14818   61 FORMAT('***** ERROR IN DPBINI--')
14819      CALL DPWRST('XXX','BUG ')
14820      WRITE(ICOUT,62)
14821   62 FORMAT('      ALL INPUT AXIS ELEMENTS')
14822      CALL DPWRST('XXX','BUG ')
14823      WRITE(ICOUT,63)HOLD
14824   63 FORMAT('      ARE IDENTICALLY EQUAL TO ',E15.7)
14825      CALL DPWRST('XXX','BUG ')
14826      WRITE(ICOUT,999)
14827      CALL DPWRST('XXX','BUG ')
14828      IERROR='YES'
14829      GOTO9000
14830   69 CONTINUE
14831C
14832      IF(IBUGG3.EQ.'OFF')GOTO80
14833      WRITE(ICOUT,999)
14834      CALL DPWRST('XXX','BUG ')
14835      WRITE(ICOUT,70)
14836   70 FORMAT('***** AT THE BEGINNING OF DPBINI--')
14837      CALL DPWRST('XXX','BUG ')
14838      WRITE(ICOUT,72)N,CLWID,XSTART,XSTOP
14839   72 FORMAT('N,CLWID,XSTART,XSTOP = ',I6,3E15.7)
14840      CALL DPWRST('XXX','BUG ')
14841      DO73I=1,N
14842      WRITE(ICOUT,74)I,Y(I)
14843   74 FORMAT('I, Y(I) = ',I8,E15.7)
14844      CALL DPWRST('XXX','BUG ')
14845   73 CONTINUE
14846   80 CONTINUE
14847C
14848C               **********************************************
14849C               **  STEP 2--                                **
14850C               **  IF NECESSARY,                           **
14851C               **  DETERMINE CLASS WIDTH,                  **
14852C               **  START VALUE, STOP VALUE,                **
14853C               **  AND NUMBER OF CLASSES.                  **
14854C               **********************************************
14855C
14856      IF(CLWID.NE.CPUMIN.AND.XSTART.NE.CPUMIN.AND.
14857     1XSTOP.NE.CPUMAX)GOTO119
14858      IWRIT2='OFF'
14859      CALL MINIM(Y,N,IWRIT2,YMIN,IBUGG3,IERROR)
14860      CALL MAXIM(Y,N,IWRIT2,YMAX,IBUGG3,IERROR)
14861      IF(CLWID.EQ.CPUMIN)DCLWID=1.0
14862      IF(XSTART.EQ.CPUMIN)DXSTAR=REAL(INT(YMIN+0.5))-0.5
14863      IF(XSTOP.EQ.CPUMAX)DXSTOP=REAL(INT(YMAX+0.5))+0.5
14864  119 CONTINUE
14865C
14866      DO181I=1,N
14867        X2(I)=0.0
14868        Y2(I)=0.0
14869  181 CONTINUE
14870      DTOTWI=DXSTOP-DXSTAR
14871      ANUMCL=DTOTWI/DCLWID
14872      NUMCLA=INT(ANUMCL+1.0+0.1)
14873C
14874      J=NUMCLA-1
14875      DJ=J
14876      DCLMXJ=DXSTAR+DJ*DCLWID
14877      DABSDE=DABS(DCLMXJ-DXSTOP)
14878      IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1
14879C
14880C               *******************************************************
14881C               **  STEP 3--                                         **
14882C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
14883C               *******************************************************
14884C
14885      DO420I=1,N
14886      DXI=Y(I)
14887      DO430J=1,NUMCLA
14888      J2=J
14889      DJ=J
14890      DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
14891      DCLMXJ=DXSTAR+DJ*DCLWID
14892      IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
14893      IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)GOTO440
14894  430 CONTINUE
14895      GOTO420
14896  440 CONTINUE
14897      Y2(J2)=Y2(J2)+1.0
14898  420 CONTINUE
14899C
14900C     FOR THIS RAW DATA CASE,
14901C     TREAT THE SPECIAL CASE OF EQUALITY
14902C     WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
14903C
14904      J=NUMCLA
14905      DO450I=1,N
14906      DJ=J
14907      DCLMXJ=DXSTAR+DJ*DCLWID
14908      IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
14909      DXI=Y(I)
14910      IF(DXI.EQ.DCLMXJ)Y2(J)=Y2(J)+1.0
14911  450 CONTINUE
14912C
14913      IF(IBUGG3.EQ.'OFF')GOTO595
14914      WRITE(ICOUT,999)
14915      CALL DPWRST('XXX','BUG ')
14916      WRITE(ICOUT,591)
14917  591 FORMAT('***** IN THE MIDDLE    OF DPBINI--')
14918      CALL DPWRST('XXX','BUG ')
14919      WRITE(ICOUT,592)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA
14920  592 FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ',
14921     14D11.4,F10.0,I8)
14922      CALL DPWRST('XXX','BUG ')
14923      DO593J=1,NUMCLA
14924      DJ=J
14925      DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
14926      DCLMXJ=DXSTAR+DJ*DCLWID
14927      IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
14928      FJ=Y2(J)
14929      WRITE(ICOUT,594)J,DCLMNJ,DCLMXJ,FJ
14930  594 FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,2D15.7,E15.7)
14931      CALL DPWRST('XXX','BUG ')
14932  593 CONTINUE
14933  595 CONTINUE
14934C
14935      SUM=0.0
14936      DO1110J=1,NUMCLA
14937      FJ=Y2(J)
14938      SUM=SUM+FJ
14939 1110 CONTINUE
14940      AN3=SUM
14941C
14942      DENOM=1.0
14943C
14944      IF(IRELAT.EQ.'ON')THEN
14945        IF(IRHSTG.EQ.'PERC')THEN
14946          DENOM=AN3
14947        ELSE
14948          DENOM=AN3*DCLWID
14949        ENDIF
14950      ENDIF
14951C
14952      DO1120J=1,NUMCLA
14953        K=J
14954        DJ=J
14955        DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
14956        X2(K)=REAL(DCLMDJ)
14957        FJ=Y2(K)
14958        Y2(K)=FJ/DENOM
14959 1120 CONTINUE
14960      N2=K
14961C
14962      DO1130J=NUMCLA,1,-1
14963        IF(Y2(J).GT.0.0)THEN
14964          N2=J
14965          GOTO1139
14966        ENDIF
14967 1130 CONTINUE
14968      N2=1
14969 1139 CONTINUE
14970C
14971      DO1140J=1,N2
14972        IF(Y2(J).GT.0.0)THEN
14973          IFRST=J
14974          GOTO1149
14975        ENDIF
14976 1140 CONTINUE
14977      IFRST=1
14978 1149 CONTINUE
14979      K=0
14980      DO1150J=IFRST,N2
14981        K=K+1
14982        X2(K)=X2(J)
14983        Y2(K)=Y2(J)
14984 1150 CONTINUE
14985C
14986      IF(N2.LT.NUMCLA)THEN
14987        DO1160I=N2+1,NUMCLA
14988          Y2(I)=0.0
14989          X2(I)=0.0
14990 1160   CONTINUE
14991      ENDIF
14992      N2=K
14993      GOTO9000
14994C
14995C               ******************
14996C               **   STEP 90--  **
14997C               **   EXIT       **
14998C               ******************
14999C
15000 9000 CONTINUE
15001      IF(IBUGG3.EQ.'OFF')GOTO9090
15002      WRITE(ICOUT,999)
15003      CALL DPWRST('XXX','BUG ')
15004      WRITE(ICOUT,9011)
15005 9011 FORMAT('***** AT THE END       OF DPBINI--')
15006      CALL DPWRST('XXX','BUG ')
15007      WRITE(ICOUT,9012)IRELAT,IERROR,N2
15008 9012 FORMAT('IRELAT,IERROR,N2 = ',A4,2X,A4,2X,I8)
15009      CALL DPWRST('XXX','BUG ')
15010      WRITE(ICOUT,9013)AN3,DENOM
15011 9013 FORMAT('AN3,DENOM = ',E15.8,E15.8)
15012      CALL DPWRST('XXX','BUG ')
15013      DO9015I=1,N2
15014      WRITE(ICOUT,9016)I,X2(I),Y2(I)
15015 9016 FORMAT('I,X2(I),Y2(I) = ',I8,E15.7,F9.2)
15016      CALL DPWRST('XXX','BUG ')
15017 9015 CONTINUE
15018      WRITE(ICOUT,9017)N,DCLWID,DXSTAR,DXSTOP
15019 9017 FORMAT('N,DCLWID,DXSTAR,DXSTOP = ',I6,3D15.7)
15020      CALL DPWRST('XXX','BUG ')
15021 9090 CONTINUE
15022C
15023      RETURN
15024      END
15025      SUBROUTINE DPBINP(Y,N,IRELAT,CLWID,XSTART,XSTOP,IRHSTG,
15026     1                  TEMP1,DIFFY2,Y3,X3,MAXNXT,IHSTCW,
15027     1                  Y2,X2,N2,IBUGG3,ISUBRO,IERROR)
15028C
15029C     PURPOSE--BIN A VARIABLE Y INTO X2 Y2.  THEN THIN BY EXTRACTING THE
15030C              "PEAKS" IN THE FREQUENCY TABLE.  PEAKS ARE DETERMINED BY:
15031C
15032C              STEP 1: DIFFERENCE THE FREQUENCY COUNTS
15033C              STEP 2: WHERE THE DIFFERENCES CHANGE SIGN INDICATES
15034C                      A PEAK.
15035C
15036C              BINNING CAN BE EITHER TO COUNTS OR TO RELATIVE
15037C              FREQUENCY.
15038C     WRITTEN BY--ALAN HECKERT
15039C                 STATISTICAL ENGINEERING DIVISION
15040C                 INFORMATION TECHNOLOGY LABORATORY
15041C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15042C                 GAITHERSBURG, MD 20899-8980
15043C                 PHONE--301-975-2899
15044C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15045C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15046C     LANGUAGE--ANSI FORTRAN (1977)
15047C     VERSION NUMBER--2008/5
15048C     ORIGINAL VERSION--MAY       2008.
15049C
15050C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15051C
15052      CHARACTER*4 IRELAT
15053      CHARACTER*4 IBUGG3
15054      CHARACTER*4 ISUBRO
15055      CHARACTER*4 IERROR
15056C
15057      CHARACTER*4 IWRIT2
15058      CHARACTER*4 IRHSTG
15059      CHARACTER*4 IHSTCW
15060C
15061      CHARACTER*4 ISUBN1
15062      CHARACTER*4 ISUBN2
15063      CHARACTER*4 ISTAT
15064C
15065C---------------------------------------------------------------------
15066
15067      DOUBLE PRECISION DCLWID
15068      DOUBLE PRECISION DXSTAR
15069      DOUBLE PRECISION DXSTOP
15070      DOUBLE PRECISION DCLMNJ
15071      DOUBLE PRECISION DCLMDJ
15072      DOUBLE PRECISION DCLMXJ
15073      DOUBLE PRECISION DJ
15074      DOUBLE PRECISION DXI
15075      DOUBLE PRECISION DABSDE
15076      DOUBLE PRECISION DTOTWI
15077C
15078C---------------------------------------------------------------------
15079C
15080      DIMENSION Y(*)
15081      DIMENSION Y2(*)
15082      DIMENSION X2(*)
15083      DIMENSION TEMP1(*)
15084      DIMENSION DIFFY2(*)
15085      DIMENSION Y3(*)
15086      DIMENSION X3(*)
15087C
15088C---------------------------------------------------------------------
15089C
15090      INCLUDE 'DPCOP2.INC'
15091C
15092C-----START POINT-----------------------------------------------------
15093C
15094      ISUBN1='DPBI'
15095      ISUBN2='NP  '
15096      IERROR='NO'
15097      ISTAT='DIFF'
15098C
15099      KP3=0
15100      K=(-999)
15101      DCLMDJ=(-999.0D0)
15102C
15103      AN3=0.0
15104      DENOM=0.0
15105      DCLWID=CLWID
15106      DXSTAR=XSTART
15107      DXSTOP=XSTOP
15108C
15109C               ********************************************
15110C               **  STEP 1--                              **
15111C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
15112C               ********************************************
15113C
15114      IF(N.LE.1)THEN
15115        WRITE(ICOUT,999)
15116  999   FORMAT(1X)
15117        CALL DPWRST('XXX','BUG ')
15118        WRITE(ICOUT,31)
15119   31   FORMAT('***** ERROR IN BINNING DATA (DPBINP)--')
15120        CALL DPWRST('XXX','BUG ')
15121        WRITE(ICOUT,32)
15122   32   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST 2;')
15123        CALL DPWRST('XXX','BUG ')
15124        WRITE(ICOUT,34)N
15125   34   FORMAT('      THE ENTERED NUMBER OF OBSERVATIONS HERE = ',I8)
15126        CALL DPWRST('XXX','BUG ')
15127        WRITE(ICOUT,999)
15128        CALL DPWRST('XXX','BUG ')
15129        IERROR='YES'
15130        GOTO9000
15131      ENDIF
15132C
15133      HOLD=Y(1)
15134      DO60I=1,N
15135        IF(Y(I).NE.HOLD)GOTO69
15136   60 CONTINUE
15137      WRITE(ICOUT,999)
15138      CALL DPWRST('XXX','BUG ')
15139      WRITE(ICOUT,31)
15140      CALL DPWRST('XXX','BUG ')
15141      WRITE(ICOUT,62)HOLD
15142   62 FORMAT('      ALL INPUT DATA ELEMENTS ARE IDENTICALLY EQUAL ',
15143     1       'TO ',G15.7)
15144      CALL DPWRST('XXX','BUG ')
15145      WRITE(ICOUT,999)
15146      CALL DPWRST('XXX','BUG ')
15147      IERROR='YES'
15148      GOTO9000
15149   69 CONTINUE
15150C
15151      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BINP')THEN
15152        WRITE(ICOUT,999)
15153        CALL DPWRST('XXX','BUG ')
15154        WRITE(ICOUT,70)
15155   70   FORMAT('***** AT THE BEGINNING OF DPBINP--')
15156        CALL DPWRST('XXX','BUG ')
15157        WRITE(ICOUT,71)IRELAT,IRHSTG,IHSTCW
15158   71   FORMAT('IRELAT,IRHSTG,IHSTCW = ',3(A4,1X))
15159        CALL DPWRST('XXX','BUG ')
15160        WRITE(ICOUT,72)N,MAXNXT,CLWID,XSTART,XSTOP
15161   72   FORMAT('N,MAXNXT,CLWID,XSTART,XSTOP = ',2I8,3G15.7)
15162        CALL DPWRST('XXX','BUG ')
15163        DO73I=1,N
15164          WRITE(ICOUT,74)I,Y(I)
15165   74     FORMAT('I, Y(I) = ',I8,G15.7)
15166          CALL DPWRST('XXX','BUG ')
15167   73   CONTINUE
15168      ENDIF
15169C
15170C               **********************************************
15171C               **  STEP 2--                                **
15172C               **  IF NECESSARY,                           **
15173C               **  DETERMINE CLASS WIDTH,                  **
15174C               **  START VALUE, STOP VALUE,                **
15175C               **  AND NUMBER OF CLASSES.                  **
15176C               **********************************************
15177C
15178C  ALLOW DIFFERENT DEFAULT BINNING ALGORITHMS (AS
15179C  SPECIFIED BY IHSTCW).
15180C
15181      IF(CLWID.EQ.CPUMIN.OR.XSTART.EQ.CPUMIN.OR.
15182     1  XSTOP.EQ.CPUMAX)THEN
15183        IWRIT2='OFF'
15184        CALL MEAN(Y,N,IWRIT2,XMEAN,IBUGG3,IERROR)
15185        CALL SD(Y,N,IWRIT2,XSD,IBUGG3,IERROR)
15186C
15187        IF(IHSTCW.EQ.'DEFA')THEN
15188          IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD
15189        ELSEIF(IHSTCW.EQ.'NORM')THEN
15190          IF(CLWID.EQ.CPUMIN)DCLWID=3.5*XSD/(REAL(N)**(1./3.))
15191        ELSEIF(IHSTCW.EQ.'NCOR')THEN
15192          IF(CLWID.EQ.CPUMIN)THEN
15193            CALL STMOM3(Y,N,IWRIT2,XSKEW,IBUGG3,IERROR)
15194            CALL STMOM4(Y,N,IWRIT2,XKURT,IBUGG3,IERROR)
15195            TERM1=3.5*XSD/(REAL(N)**(1./3.))
15196            IF(XSKEW.GT.0.0 .AND. XSKEW.LT.3.0)THEN
15197              TERM2=1.0/(1.0 - 0.0060*XSKEW + 0.27*XSKEW**2 -
15198     1              0.0069*XSKEW**3)
15199            ELSE
15200              TERM2=1.0
15201            ENDIF
15202            XKURT=XKURT - 3.0
15203            IF(XKURT.GT.0.0 .AND. XKURT.LT.6.0)THEN
15204              TERM3=1.0 - 0.2*(1.0 - EXP(-0.7*XKURT))
15205            ELSE
15206              TERM3=1.0
15207            ENDIF
15208            DCLWID=DBLE(TERM1*TERM2*TERM3)
15209          ENDIF
15210        ELSEIF(IHSTCW.EQ.'IQ  ')THEN
15211          IF(CLWID.EQ.CPUMIN)THEN
15212            CALL LOWQUA(Y,N,IWRIT2,TEMP1,MAXOBV,XLOWQ,
15213     1                  IBUGG3,IERROR)
15214            CALL UPPQUA(Y,N,IWRIT2,TEMP1,MAXOBV,XUPPQ,
15215     1                  IBUGG3,IERROR)
15216            XIQ=XUPPQ - XLOWQ
15217            DCLWID=2.603*XIQ/(REAL(N)**(1./3.))
15218          ENDIF
15219        ELSE
15220          IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD
15221        ENDIF
15222C
15223        IF(XSTART.EQ.CPUMIN)DXSTAR=XMEAN-6.0*XSD
15224        IF(XSTOP.EQ.CPUMAX)DXSTOP=XMEAN+6.0*XSD
15225      ENDIF
15226C
15227      DO181I=1,N
15228        X2(I)=0.0
15229        Y2(I)=0.0
15230  181 CONTINUE
15231      DTOTWI=DXSTOP-DXSTAR
15232      ANUMCL=DTOTWI/DCLWID
15233      NUMCLA=INT(ANUMCL+1.0+0.1)
15234C
15235      J=NUMCLA-1
15236      DJ=J
15237      DCLMXJ=DXSTAR+DJ*DCLWID
15238      DABSDE=DABS(DCLMXJ-DXSTOP)
15239      IF(DABSDE.LE.0.0001D0)NUMCLA=NUMCLA-1
15240C
15241C               *******************************************************
15242C               **  STEP 3--                                         **
15243C               **  DETERMINE THE FREQUENCY (COUNTS) FOR EACH CLASS  **
15244C               *******************************************************
15245C
15246      DO420I=1,N
15247      DXI=Y(I)
15248      DO430J=1,NUMCLA
15249      J2=J
15250      DJ=J
15251      DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
15252      DCLMXJ=DXSTAR+DJ*DCLWID
15253      IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
15254      IF(DCLMNJ.LE.DXI.AND.DXI.LT.DCLMXJ)GOTO440
15255  430 CONTINUE
15256      GOTO420
15257  440 CONTINUE
15258      Y2(J2)=Y2(J2)+1.0
15259  420 CONTINUE
15260C
15261C     FOR THIS RAW DATA CASE,
15262C     TREAT THE SPECIAL CASE OF EQUALITY
15263C     WITH THE UPPER LIMIT OF THE LAST (RIGHT-MOST) CLASS
15264C
15265      J=NUMCLA
15266      DO450I=1,N
15267      DJ=J
15268      DCLMXJ=DXSTAR+DJ*DCLWID
15269      IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
15270      DXI=Y(I)
15271      IF(DXI.EQ.DCLMXJ)Y2(J)=Y2(J)+1.0
15272  450 CONTINUE
15273C
15274      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BINP')THEN
15275        WRITE(ICOUT,999)
15276        CALL DPWRST('XXX','BUG ')
15277        WRITE(ICOUT,591)
15278  591   FORMAT('***** IN THE MIDDLE    OF DPBINP--')
15279        CALL DPWRST('XXX','BUG ')
15280        WRITE(ICOUT,592)DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA
15281  592   FORMAT('DCLWID,DXSTAR,DXSTOP,DTOTWI,ANUMCL,NUMCLA= ',
15282     1        4D11.4,F10.0,I8)
15283        CALL DPWRST('XXX','BUG ')
15284        DO593J=1,NUMCLA
15285          DJ=J
15286          DCLMNJ=DXSTAR+(DJ-1.0D0)*DCLWID
15287          DCLMXJ=DXSTAR+DJ*DCLWID
15288          IF(DCLMXJ.GT.DXSTOP)DCLMXJ=DXSTOP
15289          FJ=Y2(J)
15290          WRITE(ICOUT,594)J,DCLMNJ,DCLMXJ,FJ
15291  594     FORMAT('J,DCLMNJ,DCLMXJ,FJ = ',I8,2D15.7,E15.7)
15292          CALL DPWRST('XXX','BUG ')
15293  593   CONTINUE
15294      ENDIF
15295C
15296      SUM=0.0
15297      DO1110J=1,NUMCLA
15298      FJ=Y2(J)
15299      SUM=SUM+FJ
15300 1110 CONTINUE
15301      AN3=SUM
15302C
15303      DENOM=1.0
15304C
15305      IF(IRELAT.EQ.'ON')THEN
15306        IF(IRHSTG.EQ.'PERC')THEN
15307          DENOM=AN3
15308        ELSE
15309          DENOM=AN3*DCLWID
15310        ENDIF
15311      ENDIF
15312C
15313      DO1120J=1,NUMCLA
15314        K=J
15315        DJ=J
15316        DCLMDJ=DXSTAR+(DJ-0.5D0)*DCLWID
15317        FJ=Y2(J)
15318        X2(K)=DCLMDJ
15319        Y2(K)=FJ/DENOM
15320 1120 CONTINUE
15321      N2=K
15322C
15323      DO1130J=NUMCLA,1,-1
15324        IF(Y2(J).GT.0.0)THEN
15325          N2=J
15326          GOTO1139
15327        ENDIF
15328 1130 CONTINUE
15329      N2=1
15330 1139 CONTINUE
15331C
15332      DO1140J=1,N2
15333        IF(Y2(J).GT.0.0)THEN
15334          IFRST=J
15335          GOTO1149
15336        ENDIF
15337 1140 CONTINUE
15338      IFRST=1
15339 1149 CONTINUE
15340      K=0
15341      DO1150J=IFRST,N2
15342        K=K+1
15343        X2(K)=X2(J)
15344        Y2(K)=Y2(J)
15345 1150 CONTINUE
15346C
15347      IF(N2.LT.NUMCLA)THEN
15348        DO1160I=N2+1,NUMCLA
15349          Y2(I)=0.0
15350          X2(I)=0.0
15351 1160   CONTINUE
15352      ENDIF
15353      N2=K
15354C
15355C     AT THIS POINT, WE HAVE THE INITIAL FREQUENCY TABLE.  NOW
15356C     NEED TO EXTRACT THE "PEAKS" (WHICH WILL BE BASED ON WHERE
15357C     THE DIFFERENCE OF SUCCESSIVE FREQUENCIES CHANGES SIGNS).
15358C
15359C     STEP 1: COMPUTE THE SEQUENTIAL DIFFERENCES OF THE
15360C             FREQUENCIES.  BUT FIRST, REMOVE ANY ZERO
15361C             FREQUENCY CELLS.
15362C
15363      ICNT=0
15364      DO1900I=1,N2
15365        IF(Y2(I).GT.0.0)THEN
15366          ICNT=ICNT+1
15367          Y2(ICNT)=Y2(I)
15368          X2(ICNT)=X2(I)
15369        ENDIF
15370 1900 CONTINUE
15371      N2=ICNT
15372C
15373      CALL SEQDIF(Y2,N2,IWRIT2,DIFFY2,NDIF,ISTAT,
15374     1            IBUGG3,ISUBRO,IERROR)
15375      DIFFY2(N2)=-1
15376C
15377C     STEP 2: LOOP THROUGH AND DETECT SIGN CHANGES
15378C
15379      INEG=1
15380      IPOS=0
15381      ICNTNG=0
15382      DO2100I=1,N2
15383        DEL=DIFFY2(I)
15384        IF(IPOS.EQ.1 .AND. DEL.LT.0.0)THEN
15385          ICNTNG=ICNTNG+1
15386          Y3(ICNTNG)=Y2(I)
15387          X3(ICNTNG)=X2(I)
15388          IPOS=0
15389          INEG=1
15390        ELSEIF(INEG.EQ.1 .AND. DEL.GT.0.0)THEN
15391          IPOS=1
15392          INEG=0
15393        ENDIF
15394 2100 CONTINUE
15395C
15396      IF(ICNTNG.LE.0)THEN
15397        WRITE(ICOUT,999)
15398        CALL DPWRST('XXX','BUG ')
15399        WRITE(ICOUT,2211)
15400 2211   FORMAT('***** ERROR IN PEAKS OF FREQUENCY TABLE--')
15401        CALL DPWRST('XXX','BUG ')
15402        WRITE(ICOUT,2213)
15403 2213   FORMAT('      NO PEAKS WERE DETECTED.')
15404        CALL DPWRST('XXX','BUG ')
15405        N2=1
15406        Y2(1)=-9999
15407        X2(1)=-9999
15408        IERROR='YES'
15409        GOTO9000
15410      ENDIF
15411C
15412C     STEP 3: COPY BACK TO Y2 AND X2
15413C
15414      DO2200I=1,ICNTNG
15415        Y2(I)=Y3(I)
15416        X2(I)=X3(I)
15417 2200 CONTINUE
15418      N2=ICNTNG
15419C
15420      GOTO9000
15421C
15422C               ******************
15423C               **   STEP 90--  **
15424C               **   EXIT       **
15425C               ******************
15426C
15427 9000 CONTINUE
15428      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BINP')THEN
15429        WRITE(ICOUT,999)
15430        CALL DPWRST('XXX','BUG ')
15431        WRITE(ICOUT,9011)
15432 9011   FORMAT('***** AT THE END       OF DPBIN--')
15433        CALL DPWRST('XXX','BUG ')
15434        WRITE(ICOUT,9012)IRELAT,IERROR,N2
15435 9012   FORMAT('IRELAT,IERROR,N2 = ',A4,2X,A4,2X,I8)
15436        CALL DPWRST('XXX','BUG ')
15437        WRITE(ICOUT,9013)AN3,DENOM
15438 9013   FORMAT('AN3,DENOM = ',E15.8,E15.8)
15439        CALL DPWRST('XXX','BUG ')
15440        DO9015I=1,N2
15441          WRITE(ICOUT,9016)I,X2(I),Y2(I)
15442 9016     FORMAT('I,X2(I),Y2(I) = ',I8,E15.7,F9.2)
15443          CALL DPWRST('XXX','BUG ')
15444 9015   CONTINUE
15445        WRITE(ICOUT,9017)N,DCLWID,DXSTAR,DXSTOP
15446 9017   FORMAT('N,DCLWID,DXSTAR,DXSTOP = ',I6,3D15.7)
15447        CALL DPWRST('XXX','BUG ')
15448      ENDIF
15449C
15450      RETURN
15451      END
15452      SUBROUTINE DPBINZ(Y,N,CLWID,XSTART,XSTOP,
15453     1                  TEMP1,MAXNXT,IHSTCW,IHSTOU,
15454     1                  DCLWID,DXSTAR,DXSTOP,
15455     1                  ISUBRO,IBUGG3,IERROR)
15456C
15457C     PURPOSE--UTILITY ROUTINE CALLED BY DPBIN AND DPHIS2.
15458C              FOR RAW DATA, DETERMINE THE APPROPRIATE CLASS WIDTH,
15459C              CLASS START, AND CLASS STOP.
15460C     WRITTEN BY--JAMES J. FILLIBEN
15461C                 STATISTICAL ENGINEERING DIVISION
15462C                 INFORMATION TECHNOLOGY LABORATORY
15463C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15464C                 GAITHERSBURG, MD 20899-8980
15465C                 PHONE--301-975-2855
15466C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15467C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15468C     LANGUAGE--ANSI FORTRAN (1977)
15469C     VERSION NUMBER--2010/1
15470C     ORIGINAL VERSION--JANUARY   2010. EXTRACTED AS A SEPARATE SUBROUTINE
15471C     ORIGINAL VERSION--JUNE      2016. MAXOBV ARGUMENT (FOR LOWQUA,
15472C                                       UPPQUA)
15473C
15474C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15475C
15476      CHARACTER*4 ISUBRO
15477      CHARACTER*4 IBUGG3
15478      CHARACTER*4 IERROR
15479C
15480      CHARACTER*4 IWRIT2
15481      CHARACTER*4 IHSTCW
15482      CHARACTER*4 IHSTOU
15483C
15484      CHARACTER*4 ISUBN1
15485      CHARACTER*4 ISUBN2
15486C
15487C---------------------------------------------------------------------
15488C
15489      DOUBLE PRECISION DCLWID
15490      DOUBLE PRECISION DXSTAR
15491      DOUBLE PRECISION DXSTOP
15492      DOUBLE PRECISION DXSTA2
15493      DOUBLE PRECISION DXSTO2
15494      DOUBLE PRECISION DARG1
15495      DOUBLE PRECISION DARG3
15496      DOUBLE PRECISION DARG4
15497      DOUBLE PRECISION DINT
15498C
15499C---------------------------------------------------------------------
15500C
15501      DIMENSION Y(*)
15502      DIMENSION TEMP1(*)
15503C
15504C---------------------------------------------------------------------
15505C
15506      INCLUDE 'DPCOP2.INC'
15507C
15508C-----START POINT-----------------------------------------------------
15509C
15510      ISUBN1='DPBI'
15511      ISUBN2='NZ  '
15512      IERROR='NO'
15513C
15514      XIQ=0.0
15515C
15516C     IF USER HAS SPECIFIED CLASS WIDTH AND CLASS LIMITS, THEN WE
15517C     JUST DEFAULT TO THESE VALUES.
15518C
15519      DCLWID=CLWID
15520      DXSTAR=XSTART
15521      DXSTOP=XSTOP
15522C
15523      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BINZ')THEN
15524        WRITE(ICOUT,999)
15525  999   FORMAT(1X)
15526        CALL DPWRST('XXX','BUG ')
15527        WRITE(ICOUT,70)
15528   70   FORMAT('***** AT THE BEGINNING OF DPBINZ--')
15529        CALL DPWRST('XXX','BUG ')
15530        WRITE(ICOUT,72)N,IHSTCW,IHSTOU,CLWID,XSTART,XSTOP
15531   72   FORMAT('N,IHSTCW,IHSTOU,CLWID,XSTART,XSTOP = ',
15532     1         I6,2(1X,A4),3G15.7)
15533        CALL DPWRST('XXX','BUG ')
15534        DO73I=1,N
15535          WRITE(ICOUT,74)I,Y(I)
15536   74     FORMAT('I, Y(I) = ',I8,G15.7)
15537          CALL DPWRST('XXX','BUG ')
15538   73   CONTINUE
15539      ENDIF
15540C
15541C               **********************************************
15542C               **  STEP 2--                                **
15543C               **  DETERMINE CLASS WIDTH,                  **
15544C               **  START VALUE, STOP VALUE,                **
15545C               **  AND NUMBER OF CLASSES.                  **
15546C               **********************************************
15547C
15548C     MARCH 2006: ALLOW DIFFERENT DEFAULT BINNING ALGORITHMS (AS
15549C                 SPECIFIED BY IHSTCW).
15550C
15551      IF(CLWID.EQ.CPUMIN.OR.XSTART.EQ.CPUMIN.OR.
15552     1   XSTOP.EQ.CPUMAX.OR.XSTOP.EQ.CPUMIN)THEN
15553        IWRIT2='OFF'
15554        CALL MINIM(Y,N,IWRIT2,XMIN,IBUGG3,IERROR)
15555        CALL MAXIM(Y,N,IWRIT2,XMAX,IBUGG3,IERROR)
15556        CALL MEAN(Y,N,IWRIT2,XMEAN,IBUGG3,IERROR)
15557        CALL SD(Y,N,IWRIT2,XSD,IBUGG3,IERROR)
15558C
15559        IF(IHSTCW.EQ.'DEFA')THEN
15560          IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD
15561        ELSEIF(IHSTCW.EQ.'NORM')THEN
15562          IF(CLWID.EQ.CPUMIN)DCLWID=3.5*XSD/(REAL(N)**(1./3.))
15563        ELSEIF(IHSTCW.EQ.'NCOR')THEN
15564          IF(CLWID.EQ.CPUMIN)THEN
15565            CALL STMOM3(Y,N,IWRIT2,XSKEW,IBUGG3,IERROR)
15566            CALL STMOM4(Y,N,IWRIT2,XKURT,IBUGG3,IERROR)
15567            TERM1=3.5*XSD/(REAL(N)**(1./3.))
15568            IF(XSKEW.GT.0.0 .AND. XSKEW.LT.3.0)THEN
15569              TERM2=1.0/(1.0 - 0.0060*XSKEW + 0.27*XSKEW**2 -
15570     1              0.0069*XSKEW**3)
15571            ELSE
15572              TERM2=1.0
15573            ENDIF
15574            XKURT=XKURT - 3.0
15575            IF(XKURT.GT.0.0 .AND. XKURT.LT.6.0)THEN
15576              TERM3=1.0 - 0.2*(1.0 - EXP(-0.7*XKURT))
15577            ELSE
15578              TERM3=1.0
15579            ENDIF
15580            DCLWID=DBLE(TERM1*TERM2*TERM3)
15581          ENDIF
15582        ELSEIF(IHSTCW.EQ.'IQ  ')THEN
15583          IF(CLWID.EQ.CPUMIN)THEN
15584            CALL LOWQUA(Y,N,IWRIT2,TEMP1,MAXNXT,XLOWQ,
15585     1                  IBUGG3,IERROR)
15586            CALL UPPQUA(Y,N,IWRIT2,TEMP1,MAXNXT,XUPPQ,
15587     1                  IBUGG3,IERROR)
15588            XIQ=XUPPQ - XLOWQ
15589            DCLWID=2.603*XIQ/(REAL(N)**(1./3.))
15590          ENDIF
15591        ELSE
15592          IF(CLWID.EQ.CPUMIN)DCLWID=0.3*XSD
15593        ENDIF
15594C
15595C       NOW THAT CLASS WIDTH IS DETERMINED, DETERMINE START AND STOP
15596C       VALUES.  DEFAULT IS +/- 6*STANDARD DEVIATION.  HOWEVER, IF
15597C       USER HAS SPECIFIED "OUTLIERS ON", EXTEND THESE DEFAULT LIMITS
15598C       TO INCORPORATE ALL THE DATA.
15599C
15600C       FOR "IQ RANGE" CLASS WIDTH, USE +/- 6*NORMALIZED IQR
15601C
15602        IF(IHSTOU.EQ.'ON')THEN
15603          IF(XSTART.EQ.CPUMIN)THEN
15604            IF(IHSTCW.EQ.'IQ  ')THEN
15605              ANIQ=0.7413*XIQ
15606              DXSTAR=XMEAN-6.0*ANIQ
15607            ELSE
15608              DXSTAR=XMEAN-6.0*XSD
15609            ENDIF
15610            DARG1=DBLE(XMEAN-XMIN)/DCLWID
15611            IARG2=INT(DARG1)
15612            DARG3=DBLE(IARG2)
15613            DARG4=DARG1-DARG3
15614            DINT=DARG3
15615            IF(DARG4.NE.0.0D0)DINT=DINT+1.0D0
15616            DXSTA2=DBLE(XMEAN)-DINT*DCLWID
15617            DXSTAR=MIN(DXSTAR,DXSTA2)
15618          ENDIF
15619          IF(XSTOP.EQ.CPUMAX .OR. XSTOP.EQ.CPUMIN)THEN
15620            IF(IHSTCW.EQ.'IQ  ')THEN
15621              ANIQ=0.7413*XIQ
15622              DXSTOP=XMEAN+6.0*ANIQ
15623            ELSE
15624              DXSTOP=XMEAN+6.0*XSD
15625            ENDIF
15626            DARG1=DBLE(XMAX-XMEAN)/DCLWID
15627            IARG2=INT(DARG1)
15628            DARG3=DBLE(IARG2)
15629            DARG4=DARG1-DARG3
15630            DINT=DARG3
15631            IF(DARG4.NE.0.0D0)DINT=DINT+1.0D0
15632            DXSTO2=DBLE(XMEAN)+DINT*DCLWID
15633            DXSTOP=MAX(DXSTOP,DXSTO2)
15634          ENDIF
15635        ELSE
15636          IF(IHSTCW.EQ.'IQ  ')THEN
15637            ANIQ=0.7413*XIQ
15638            IF(XSTART.EQ.CPUMIN)DXSTAR=XMEAN-6.0*ANIQ
15639            IF(XSTOP.EQ.CPUMAX.OR.XSTOP.EQ.CPUMIN)DXSTOP=XMEAN+6.0*ANIQ
15640          ELSE
15641            IF(XSTART.EQ.CPUMIN)DXSTAR=XMEAN-6.0*XSD
15642            IF(XSTOP.EQ.CPUMAX.OR.XSTOP.EQ.CPUMIN)DXSTOP=XMEAN+6.0*XSD
15643          ENDIF
15644        ENDIF
15645      ENDIF
15646C
15647C               ******************
15648C               **   STEP 90--  **
15649C               **   EXIT       **
15650C               ******************
15651C
15652      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BINZ')THEN
15653        WRITE(ICOUT,999)
15654        CALL DPWRST('XXX','BUG ')
15655        WRITE(ICOUT,9011)
15656 9011   FORMAT('***** AT THE END       OF DPBINZ--')
15657        CALL DPWRST('XXX','BUG ')
15658        WRITE(ICOUT,9012)XMEAN,XSD,XMIN,XMAX
15659 9012   FORMAT('XMEAN,XSD,XMIN,XMAX = ',4G15.7)
15660        CALL DPWRST('XXX','BUG ')
15661        WRITE(ICOUT,9013)XSKEW,XKURT
15662 9013   FORMAT('XSKEW,XKURT ',2G15.7)
15663        CALL DPWRST('XXX','BUG ')
15664        WRITE(ICOUT,9017)DCLWID,DXSTAR,DXSTOP
15665 9017   FORMAT('DCLWID,DXSTAR,DXSTOP = ',3G15.7)
15666        CALL DPWRST('XXX','BUG ')
15667      ENDIF
15668C
15669      RETURN
15670      END
15671      SUBROUTINE DPBIPL(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
15672     1                  IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
15673C
15674C     PURPOSE--GENERATE A BINARY <TYPE> PLOT Y1 Y2 X
15675C
15676C              WHERE <TYPE> IS ONE OF
15677C
15678C                 CORRECT MATCHES
15679C                 FALSE POSITIVES
15680C                 FALSE NEGATIVES
15681C                 TRUE POSITIVES
15682C                 TRUE NEGATIVES
15683C
15684C     WRITTEN BY--ALAN HECKERT
15685C                 STATISTICAL ENGINEERING DIVISION
15686C                 INFORMATION TECHNOLOGY LABORATORY
15687C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
15688C                 GAITHERSBURG, MD 20899-8980
15689C                 PHONE--301-975-2899
15690C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
15691C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
15692C     LANGUAGE--ANSI FORTRAN (1977)
15693C     VERSION NUMBER--2007/5
15694C     ORIGINAL VERSION--MAY       2007.
15695C     UPDATED         --MARCH     2011. USE DPPARS, DPPAR5
15696C
15697C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
15698C
15699      CHARACTER*4 ICASPL
15700      CHARACTER*4 IAND1
15701      CHARACTER*4 IAND2
15702      CHARACTER*4 IBUGG2
15703      CHARACTER*4 IBUGG3
15704      CHARACTER*4 ISUBRO
15705      CHARACTER*4 IBUGQ
15706      CHARACTER*4 IFOUND
15707      CHARACTER*4 IERROR
15708C
15709      CHARACTER*4 ICASP2
15710      CHARACTER*4 ICASE
15711      CHARACTER*4 ISUBN1
15712      CHARACTER*4 ISUBN2
15713      CHARACTER*4 ISTEPN
15714C
15715      CHARACTER*40 INAME
15716      PARAMETER (MAXSPN=10)
15717      CHARACTER*4 IVARN1(MAXSPN)
15718      CHARACTER*4 IVARN2(MAXSPN)
15719      CHARACTER*4 IVARTY(MAXSPN)
15720      REAL PVAR(MAXSPN)
15721      INTEGER ILIS(MAXSPN)
15722      INTEGER NRIGHT(MAXSPN)
15723      INTEGER ICOLR(MAXSPN)
15724C
15725C---------------------------------------------------------------------
15726C
15727C-----COMMON----------------------------------------------------------
15728C
15729      INCLUDE 'DPCOPA.INC'
15730C
15731      DIMENSION Y1(MAXOBV)
15732      DIMENSION Y2(MAXOBV)
15733      DIMENSION XGROUP(MAXOBV)
15734      DIMENSION XGROU2(MAXOBV)
15735      DIMENSION XIDTEM(MAXOBV)
15736      DIMENSION TEMP1(MAXOBV)
15737      DIMENSION TEMP2(MAXOBV)
15738      DIMENSION TEMP3(MAXOBV)
15739C
15740      INCLUDE 'DPCOZZ.INC'
15741      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
15742      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
15743      EQUIVALENCE (GARBAG(IGARB3),XGROUP(1))
15744      EQUIVALENCE (GARBAG(IGARB4),XGROU2(1))
15745      EQUIVALENCE (GARBAG(IGARB5),XIDTEM(1))
15746      EQUIVALENCE (GARBAG(IGARB6),TEMP1(1))
15747      EQUIVALENCE (GARBAG(IGARB7),TEMP2(1))
15748      EQUIVALENCE (GARBAG(IGARB8),TEMP3(1))
15749C
15750      INCLUDE 'DPCOHK.INC'
15751      INCLUDE 'DPCODA.INC'
15752C
15753C-----COMMON VARIABLES (GENERAL)--------------------------------------
15754C
15755      INCLUDE 'DPCOP2.INC'
15756C
15757C-----START POINT-----------------------------------------------------
15758C
15759      IFOUND='NO'
15760      IERROR='NO'
15761C
15762      ISUBN1='DPBI'
15763      ISUBN2='PL  '
15764C
15765      MAXCP1=MAXCOL+1
15766      MAXCP2=MAXCOL+2
15767      MAXCP3=MAXCOL+3
15768      MAXCP4=MAXCOL+4
15769      MAXCP5=MAXCOL+5
15770      MAXCP6=MAXCOL+6
15771C
15772C               **********************************
15773C               **  TREAT THE BINARY PLOT CASE  **
15774C               **********************************
15775C
15776      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BIPL')THEN
15777        WRITE(ICOUT,999)
15778  999   FORMAT(1X)
15779        CALL DPWRST('XXX','BUG ')
15780        WRITE(ICOUT,51)
15781   51   FORMAT('***** AT THE BEGINNING OF DPBIPL--')
15782        CALL DPWRST('XXX','BUG ')
15783        WRITE(ICOUT,53)ICASPL,IAND1,IAND2,MAXNPP
15784   53   FORMAT('ICASPL,IAND1,IAND2,MAXNPP = ',3(A4,2X),I8)
15785        CALL DPWRST('XXX','BUG ')
15786        WRITE(ICOUT,54)IBUGG2,IBUGG3,ISUBRO,IBUGQ,ISUBRO
15787   54   FORMAT('IBUGG2,IBUGG3,ISUBRO,IBUGQ,ISUBRO = ',3(A4,2X),A4)
15788        CALL DPWRST('XXX','BUG ')
15789      ENDIF
15790C
15791C               *******************************************
15792C               **  STEP 1--                             **
15793C               **  SEARCH FOR BINARY <TYPE> PLOT        **
15794C               *******************************************
15795C
15796      ISTEPN='1'
15797      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIPL')
15798     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
15799C
15800      ICASE='PERC'
15801      ICASPL='BIPL'
15802      ICASP2='CORM'
15803      ILASTC=0
15804C
15805      IF(IHARG(1).EQ.'PROP')THEN
15806        ICASE='PROP'
15807        ILASTC=ILASTC+1
15808      ELSEIF(IHARG(1).EQ.'PERC')THEN
15809        ICASE='PERC'
15810        ILASTC=ILASTC+1
15811      ENDIF
15812C
15813      IF(ILASTC.GT.0)THEN
15814        CALL SHIFTL(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
15815     1              IBUGG2,IERROR)
15816        IF(IERROR.EQ.'YES')GOTO9000
15817      ENDIF
15818C
15819      ILASTC=0
15820      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PLOT')THEN
15821        ILASTC=1
15822        IFOUND='YES'
15823        ICASP2='CORM'
15824      ELSEIF(NUMARG.GE.4.AND.
15825     1  IHARG(1).EQ.'CORR' .AND. IHARG(2).EQ.'MATC'.AND.
15826     1  IHARG(4).EQ.'PLOT')THEN
15827        IF(IHARG(3).EQ.'PROP')THEN
15828          ICASE='PROP'
15829        ELSEIF(IHARG(3).EQ.'PERC')THEN
15830          ICASE='PERC'
15831        ENDIF
15832        ILASTC=4
15833        IFOUND='YES'
15834        ICASP2='CORM'
15835      ELSEIF(NUMARG.GE.3.AND.
15836     1  IHARG(1).EQ.'CORR' .AND. IHARG(2).EQ.'MATC'.AND.
15837     1  IHARG(3).EQ.'PLOT')THEN
15838        ILASTC=3
15839        IFOUND='YES'
15840        ICASP2='CORM'
15841      ELSEIF(NUMARG.GE.3.AND.
15842     1  IHARG(1).EQ.'CORR' .AND. IHARG(2).EQ.'MATC'.AND.
15843     1  (IHARG(3).EQ.'PERC' .OR. IHARG(3).EQ.'PROP'))THEN
15844        IF(IHARG(3).EQ.'PROP')THEN
15845          ICASE='PROP'
15846        ELSEIF(IHARG(3).EQ.'PERC')THEN
15847          ICASE='PERC'
15848        ENDIF
15849        ILASTC=3
15850        IFOUND='YES'
15851        ICASP2='CORM'
15852      ELSEIF(NUMARG.GE.2.AND.
15853     1  IHARG(1).EQ.'CORR' .AND. IHARG(2).EQ.'MATC')THEN
15854        ILASTC=2
15855        IFOUND='YES'
15856        ICASP2='CORM'
15857      ELSEIF(NUMARG.GE.4.AND.
15858     1  IHARG(1).EQ.'FALS' .AND. IHARG(2).EQ.'POSI'.AND.
15859     1  IHARG(4).EQ.'PLOT')THEN
15860        IF(IHARG(3).EQ.'PROP')THEN
15861          ICASE='PROP'
15862        ELSEIF(IHARG(3).EQ.'PERC')THEN
15863          ICASE='PERC'
15864        ENDIF
15865        ILASTC=4
15866        IFOUND='YES'
15867        ICASP2='FALP'
15868      ELSEIF(NUMARG.GE.3.AND.
15869     1  IHARG(1).EQ.'FALS' .AND. IHARG(2).EQ.'POSI'.AND.
15870     1  IHARG(3).EQ.'PLOT')THEN
15871        ILASTC=3
15872        IFOUND='YES'
15873        ICASP2='FALP'
15874      ELSEIF(NUMARG.GE.3.AND.
15875     1  IHARG(1).EQ.'FALS' .AND. IHARG(2).EQ.'POSI' .AND.
15876     1  (IHARG(3).EQ.'PROP' .OR. IHARG(3).EQ.'PERC'))THEN
15877        IF(IHARG(3).EQ.'PROP')THEN
15878          ICASE='PROP'
15879        ELSEIF(IHARG(3).EQ.'PERC')THEN
15880          ICASE='PERC'
15881        ENDIF
15882        ILASTC=3
15883        IFOUND='YES'
15884        ICASP2='FALP'
15885      ELSEIF(NUMARG.GE.2.AND.
15886     1  IHARG(1).EQ.'FALS' .AND. IHARG(2).EQ.'POSI')THEN
15887        ILASTC=2
15888        IFOUND='YES'
15889        ICASP2='FALP'
15890      ELSEIF(NUMARG.GE.4.AND.
15891     1  IHARG(1).EQ.'FALS' .AND. IHARG(2).EQ.'NEGA'.AND.
15892     1  IHARG(4).EQ.'PLOT')THEN
15893        IF(IHARG(3).EQ.'PROP')THEN
15894          ICASE='PROP'
15895        ELSEIF(IHARG(3).EQ.'PERC')THEN
15896          ICASE='PERC'
15897        ENDIF
15898        ILASTC=4
15899        IFOUND='YES'
15900        ICASP2='FALN'
15901      ELSEIF(NUMARG.GE.3.AND.
15902     1  IHARG(1).EQ.'FALS' .AND. IHARG(2).EQ.'NEGA'.AND.
15903     1  IHARG(3).EQ.'PLOT')THEN
15904        ILASTC=3
15905        IFOUND='YES'
15906        ICASP2='FALN'
15907      ELSEIF(NUMARG.GE.3.AND.
15908     1  IHARG(1).EQ.'FALS' .AND. IHARG(2).EQ.'NEGA' .AND.
15909     1  (IHARG(3).EQ.'PROP' .OR. IHARG(3).EQ.'PERC'))THEN
15910        IF(IHARG(3).EQ.'PROP')THEN
15911          ICASE='PROP'
15912        ELSEIF(IHARG(3).EQ.'PERC')THEN
15913          ICASE='PERC'
15914        ENDIF
15915        ILASTC=3
15916        IFOUND='YES'
15917        ICASP2='FALN'
15918      ELSEIF(NUMARG.GE.2.AND.
15919     1  IHARG(1).EQ.'FALS' .AND. IHARG(2).EQ.'NEGA')THEN
15920        ILASTC=2
15921        IFOUND='YES'
15922        ICASP2='FALN'
15923      ELSEIF(NUMARG.GE.4.AND.
15924     1  IHARG(1).EQ.'TRUE' .AND. IHARG(2).EQ.'POSI'.AND.
15925     1  IHARG(4).EQ.'PLOT')THEN
15926        IF(IHARG(3).EQ.'PROP')THEN
15927          ICASE='PROP'
15928        ELSEIF(IHARG(3).EQ.'PERC')THEN
15929          ICASE='PERC'
15930        ENDIF
15931        ILASTC=4
15932        IFOUND='YES'
15933        ICASP2='TRUP'
15934      ELSEIF(NUMARG.GE.3.AND.
15935     1  IHARG(1).EQ.'TRUE' .AND. IHARG(2).EQ.'POSI'.AND.
15936     1  IHARG(3).EQ.'PLOT')THEN
15937        ILASTC=3
15938        IFOUND='YES'
15939        ICASP2='TRUP'
15940      ELSEIF(NUMARG.GE.3.AND.
15941     1  IHARG(1).EQ.'TRUE' .AND. IHARG(2).EQ.'POSI' .AND.
15942     1  (IHARG(3).EQ.'PROP' .OR. IHARG(3).EQ.'PERC'))THEN
15943        IF(IHARG(3).EQ.'PROP')THEN
15944          ICASE='PROP'
15945        ELSEIF(IHARG(3).EQ.'PERC')THEN
15946          ICASE='PERC'
15947        ENDIF
15948        ILASTC=3
15949        IFOUND='YES'
15950        ICASP2='TRUP'
15951      ELSEIF(NUMARG.GE.2.AND.
15952     1  IHARG(1).EQ.'TRUE' .AND. IHARG(2).EQ.'POSI')THEN
15953        ILASTC=2
15954        IFOUND='YES'
15955        ICASP2='TRUP'
15956      ELSEIF(NUMARG.GE.4.AND.
15957     1  IHARG(1).EQ.'TRUE' .AND. IHARG(2).EQ.'NEGA'.AND.
15958     1  IHARG(4).EQ.'PLOT')THEN
15959        IF(IHARG(3).EQ.'PROP')THEN
15960          ICASE='PROP'
15961        ELSEIF(IHARG(3).EQ.'PERC')THEN
15962          ICASE='PERC'
15963        ENDIF
15964        ILASTC=4
15965        IFOUND='YES'
15966        ICASP2='TRUN'
15967      ELSEIF(NUMARG.GE.3.AND.
15968     1  IHARG(1).EQ.'TRUE' .AND. IHARG(2).EQ.'NEGA'.AND.
15969     1  IHARG(3).EQ.'PLOT')THEN
15970        ILASTC=3
15971        IFOUND='YES'
15972        ICASP2='TRUN'
15973      ELSEIF(NUMARG.GE.3.AND.
15974     1  IHARG(1).EQ.'TRUE' .AND. IHARG(2).EQ.'NEGA' .AND.
15975     1  (IHARG(3).EQ.'PROP' .OR. IHARG(3).EQ.'PERC'))THEN
15976        IF(IHARG(3).EQ.'PROP')THEN
15977          ICASE='PROP'
15978        ELSEIF(IHARG(3).EQ.'PERC')THEN
15979          ICASE='PERC'
15980        ENDIF
15981        ILASTC=3
15982        IFOUND='YES'
15983        ICASP2='TRUN'
15984      ELSEIF(NUMARG.GE.2.AND.
15985     1  IHARG(1).EQ.'TRUE' .AND. IHARG(2).EQ.'NEGA')THEN
15986        ILASTC=2
15987        IFOUND='YES'
15988        ICASP2='TRUN'
15989      ELSE
15990        ICASPL='    '
15991        IFOUND='NO'
15992        GOTO9000
15993      ENDIF
15994C
15995      IF(ILASTC.GT.0)THEN
15996        CALL SHIFTL(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
15997     1              IBUGG2,IERROR)
15998        IF(IERROR.EQ.'YES')GOTO9000
15999      ENDIF
16000C
16001C               ****************************************
16002C               **  STEP 2--                          **
16003C               **  EXTRACT THE VARIABLE LIST         **
16004C               ****************************************
16005C
16006      ISTEPN='2'
16007      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIPL')
16008     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16009C
16010      INAME='BINARY PLOT'
16011      MINNA=3
16012      MAXNA=100
16013      MINN2=2
16014      IFLAGE=1
16015      IFLAGM=0
16016      IFLAGP=0
16017      JMIN=1
16018      JMAX=NUMARG
16019      MINNVA=3
16020      MAXNVA=3
16021C
16022      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
16023     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
16024     1            JMIN,JMAX,
16025     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
16026     1            IVARN1,IVARN2,IVARTY,PVAR,
16027     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
16028     1            MINNVA,MAXNVA,
16029     1            IFLAGM,IFLAGP,
16030     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
16031      IF(IERROR.EQ.'YES')GOTO9000
16032C
16033      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIPL')THEN
16034        WRITE(ICOUT,999)
16035        CALL DPWRST('XXX','BUG ')
16036        WRITE(ICOUT,281)
16037  281   FORMAT('***** AFTER CALL DPPARS--')
16038        CALL DPWRST('XXX','BUG ')
16039        WRITE(ICOUT,282)NQ,NUMVAR
16040  282   FORMAT('NQ,NUMVAR = ',2I8)
16041        CALL DPWRST('XXX','BUG ')
16042        IF(NUMVAR.GT.0)THEN
16043          DO285I=1,NUMVAR
16044            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
16045     1                      ICOLR(I),IVARTY(I)
16046  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
16047     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
16048            CALL DPWRST('XXX','BUG ')
16049  285     CONTINUE
16050        ENDIF
16051      ENDIF
16052C
16053C               **********************************************
16054C               **  STEP 33--                               **
16055C               **  FORM THE SUBSETTED VARIABLES            **
16056C               **********************************************
16057C
16058      ISTEPN='33'
16059      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIPL')
16060     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16061C
16062      ICOL=1
16063      CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
16064     1            INAME,IVARN1,IVARN2,IVARTY,
16065     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
16066     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
16067     1            MAXCP4,MAXCP5,MAXCP6,
16068     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
16069     1            Y1,Y2,XGROUP,TEMP1,TEMP1,TEMP1,TEMP1,NS,
16070     1            IBUGG3,ISUBRO,IFOUND,IERROR)
16071      IF(IERROR.EQ.'YES')GOTO9000
16072C
16073C               *****************************************************
16074C               **  STEP 41--                                      **
16075C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
16076C               **  VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR    **
16077C               **  THE PLOT.                                      **
16078C               **  FORM THE CURVE DESIGNATION VARIABLE D(.)  .    **
16079C               **  DEFINE THE NUMBER OF PLOT POINTS   (NPLOTP).   **
16080C               **  DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV).   **
16081C               *****************************************************
16082C
16083      ISTEPN='61'
16084      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BIPL')
16085     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16086C
16087      CALL DPBIP2(Y1,Y2,XGROUP,NS,NUMVAR,
16088     1            ICASPL,ICASP2,ICASE,MAXN,
16089     1            XIDTEM,TEMP1,TEMP2,TEMP3,
16090     1            Y,X,X3D,D,NPLOTP,NPLOTV,
16091     1            IBUGG3,ISUBRO,IERROR)
16092C
16093C               *****************
16094C               **  STEP 90--  **
16095C               **  EXIT.      **
16096C               *****************
16097C
16098 9000 CONTINUE
16099      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BIPL')THEN
16100        WRITE(ICOUT,999)
16101        CALL DPWRST('XXX','BUG ')
16102        WRITE(ICOUT,9011)
16103 9011   FORMAT('***** AT THE END OF DPBIPL--')
16104        CALL DPWRST('XXX','BUG ')
16105        WRITE(ICOUT,9012)IFOUND,IERROR
16106 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
16107        CALL DPWRST('XXX','BUG ')
16108        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
16109 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
16110     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
16111        CALL DPWRST('XXX','BUG ')
16112        WRITE(ICOUT,9020)
16113 9020   FORMAT('I,Y(.),X(.),D(.),ISUB(.)--')
16114        CALL DPWRST('XXX','BUG ')
16115        DO9021I=1,NPLOTP
16116          WRITE(ICOUT,9022)I,Y(I),X(I),D(I),ISUB(I)
16117 9022     FORMAT(I8,G15.7,G15.7,G15.7,I8)
16118          CALL DPWRST('XXX','BUG ')
16119 9021   CONTINUE
16120      ENDIF
16121C
16122      RETURN
16123      END
16124      SUBROUTINE DPBIP2(Y1,Y2,X,N,NUMV2,
16125     1                  ICASPL,ICASP2,ICASE,MAXN,
16126     1                  XIDTEM,TEMP1,TEMP2,TEMP3,
16127     1                  YPLOT,XPLOT,X3D,D2,NPLOTP,NPLOTV,
16128     1                  IBUGG3,ISUBRO,IERROR)
16129C
16130C     PURPOSE--FORM A BINARY <TYPE> PLOT WHERE
16131C              <TYPE> IS ONE OF:
16132C                  CORRECT MATCHES
16133C                  FALSE POSITIVES
16134C                  FALSE NEGATIVES
16135C                  TRUE POSITIVES
16136C                  TRUE NEGATIVES
16137C              THE Y-COORDINATE IS THE GROUP-ID AND THE X-COORDINATE
16138C              IS THE "PROPORTION" OR "PERCENTAGE" OF CORRECT
16139C              MATCHES (OR FALSE POSITIVES, ETC.).  THIS PLOT
16140C              IS USED BY THE "BINARY TABULATION PLOT" COMMAND.
16141C     WRITTEN BY--ALAN HECKERT
16142C                 STATISTICAL ENGINEERING DIVISION
16143C                 INFORMATION TECHNOLOGY LABORATORY
16144C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16145C                 GAITHERSBURG, MD 20899-8980
16146C                 PHONE--301-975-2899
16147C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16148C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16149C     LANGUAGE--ANSI FORTRAN (1977)
16150C     VERSION NUMBER--2007/4
16151C     ORIGINAL VERSION--APRIL     2007.
16152C
16153C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
16154C
16155      CHARACTER*4 ICASPL
16156      CHARACTER*4 ICASP2
16157      CHARACTER*4 ICASE
16158      CHARACTER*4 IBUGG3
16159      CHARACTER*4 ISUBRO
16160      CHARACTER*4 IERROR
16161C
16162      CHARACTER*4 ISUBN1
16163      CHARACTER*4 ISUBN2
16164      CHARACTER*4 ISTEPN
16165      CHARACTER*4 IWRITE
16166C
16167      DIMENSION Y1(*)
16168      DIMENSION Y2(*)
16169      DIMENSION X(*)
16170      DIMENSION XIDTEM(*)
16171      DIMENSION TEMP1(*)
16172      DIMENSION TEMP2(*)
16173      DIMENSION TEMP3(*)
16174      DIMENSION YPLOT(*)
16175      DIMENSION XPLOT(*)
16176      DIMENSION X3D(*)
16177      DIMENSION D2(*)
16178C
16179C-----COMMON----------------------------------------------------------
16180C
16181C-----COMMON VARIABLES (GENERAL)--------------------------------------
16182C
16183      INCLUDE 'DPCOP2.INC'
16184C
16185C-----START POINT-----------------------------------------------------
16186C
16187      ISUBN1='DPBI'
16188      ISUBN2='P2  '
16189      IERROR='NO'
16190      IWRITE='OFF'
16191C
16192      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIP2')THEN
16193        WRITE(ICOUT,999)
16194  999   FORMAT(1X)
16195        CALL DPWRST('XXX','BUG ')
16196        WRITE(ICOUT,51)
16197   51   FORMAT('***** AT THE BEGINNING OF DPBIP2--')
16198        CALL DPWRST('XXX','BUG ')
16199        WRITE(ICOUT,52)NUMV2,N,MAXN
16200   52   FORMAT('NUMV2,N,MAXN = ',3I8)
16201        CALL DPWRST('XXX','BUG ')
16202        WRITE(ICOUT,53)ICASPL,ICASP2,ICASE,IBUGG3,IERROR
16203   53   FORMAT('ICASPL,ICASP2,ICASE,IBUGG3,IERROR = ',4(A4,2X),A4)
16204        CALL DPWRST('XXX','BUG ')
16205        DO55I=1,MIN(N,100)
16206          WRITE(ICOUT,56)I,Y1(I),Y2(I),X(I)
16207   56     FORMAT('I,Y1(I),Y2(I),X(I) = ',I8,3G15.7)
16208          CALL DPWRST('XXX','BUG ')
16209   55   CONTINUE
16210      ENDIF
16211C
16212C               ********************************************
16213C               **  STEP 1--                              **
16214C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
16215C               ********************************************
16216C
16217      ISTEPN='1'
16218      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BIP2')
16219     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16220C
16221C               ****************************************************
16222C               **  STEP 2--                                      **
16223C               **  COMPUTE COORDINATES FOR BINARY PLOT           **
16224C               ****************************************************
16225C
16226      ISTEPN='2'
16227      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BIP2')
16228     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16229C
16230      CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR)
16231      CALL SORT(XIDTEM,NUMSET,XIDTEM)
16232C
16233      J=0
16234      ITAG=0
16235C
16236      DO1000ISET=1,NUMSET
16237        HOLD=XIDTEM(ISET)
16238C
16239        K=0
16240        DO1010I=1,N
16241          IF(X(I).EQ.HOLD)THEN
16242            K=K+1
16243            TEMP1(K)=Y1(I)
16244            TEMP2(K)=Y2(I)
16245          ENDIF
16246 1010   CONTINUE
16247C
16248        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIP2')THEN
16249          WRITE(ICOUT,999)
16250          CALL DPWRST('XXX','BUG ')
16251          WRITE(ICOUT,1051)ISET,K
16252 1051     FORMAT('***** SET ',I8,' HAS ',I8,' ELEMENTS.')
16253          CALL DPWRST('XXX','BUG ')
16254          IF(K.GT.0)THEN
16255            DO1055I=1,K
16256              WRITE(ICOUT,1057)I,TEMP1(I),TEMP2(I)
16257 1057         FORMAT('I,TEMP1(I),TEMP2(I) = ',I8,2G15.7)
16258              CALL DPWRST('XXX','BUG ')
16259 1055       CONTINUE
16260          ENDIF
16261        ENDIF
16262C
16263        J=J+1
16264        ITAG=ITAG+1
16265C
16266        IF(ICASP2.EQ.'CORM')THEN
16267          CALL CORMAT(TEMP1,TEMP2,K,IWRITE,TEMP3,STAT,IBUGG3,IERROR)
16268          IF(IERROR.EQ.'YES')GOTO9000
16269        ELSEIF(ICASP2.EQ.'FALP')THEN
16270          CALL FALPOS(TEMP1,TEMP2,K,IWRITE,TEMP3,STAT,IBUGG3,IERROR)
16271          IF(IERROR.EQ.'YES')GOTO9000
16272        ELSEIF(ICASP2.EQ.'FALN')THEN
16273          CALL FALNEG(TEMP1,TEMP2,K,IWRITE,TEMP3,STAT,IBUGG3,IERROR)
16274          IF(IERROR.EQ.'YES')GOTO9000
16275        ELSEIF(ICASP2.EQ.'TRUP')THEN
16276          CALL TRUPOS(TEMP1,TEMP2,K,IWRITE,TEMP3,STAT,IBUGG3,IERROR)
16277          IF(IERROR.EQ.'YES')GOTO9000
16278        ELSEIF(ICASP2.EQ.'TRUN')THEN
16279          CALL TRUNEG(TEMP1,TEMP2,K,IWRITE,TEMP3,STAT,IBUGG3,IERROR)
16280          IF(IERROR.EQ.'YES')GOTO9000
16281        ENDIF
16282C
16283        XCOOR=STAT
16284        IF(ICASE.EQ.'PERC')XCOOR=100.0*XCOOR
16285C
16286        YPLOT(J)=XIDTEM(ISET)
16287        XPLOT(J)=XCOOR
16288        D2(J)=1.0
16289C
16290        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIP2')THEN
16291          WRITE(ICOUT,1061)STAT,XCOOR
16292 1061     FORMAT('STAT,XCOOR = ',2G15.7)
16293          CALL DPWRST('XXX','BUG ')
16294        ENDIF
16295C
16296 1000 CONTINUE
16297C
16298        N2=J
16299        NPLOTP=N2
16300        NPLOTV=2
16301C
16302C               *****************
16303C               **  STEP 90--  **
16304C               **  EXIT       **
16305C               *****************
16306C
16307 9000 CONTINUE
16308      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BIP2')THEN
16309        WRITE(ICOUT,999)
16310        CALL DPWRST('XXX','BUG ')
16311        WRITE(ICOUT,9011)
16312 9011   FORMAT('***** AT THE END OF DPBIP2--')
16313        CALL DPWRST('XXX','BUG ')
16314        WRITE(ICOUT,9012)IFOUND,IERROR
16315 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
16316        CALL DPWRST('XXX','BUG ')
16317        WRITE(ICOUT,9013)NPLOTV,NPLOTP,N,ICASPL
16318 9013   FORMAT('NPLOTV,NPLOTP,N,ICASPL = ',
16319     1         I8,I8,I8,2X,A4)
16320        CALL DPWRST('XXX','BUG ')
16321        WRITE(ICOUT,9020)
16322 9020   FORMAT('I,YPLOT(.),XPLOT(.),X3D(.),D2(.)--')
16323        CALL DPWRST('XXX','BUG ')
16324        DO9021I=1,NPLOTP
16325          WRITE(ICOUT,9022)I,YPLOT(I),XPLOT(I),X3D(I),D2(I)
16326 9022     FORMAT(I8,4G15.7)
16327          CALL DPWRST('XXX','BUG ')
16328 9021   CONTINUE
16329      ENDIF
16330C
16331      RETURN
16332      END
16333      SUBROUTINE DPBITA(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
16334     1                  MAXNPP,ICONT,NUMHPP,NUMVPP,IMANUF,
16335     1                  XMATN,YMATN,XMITN,YMITN,
16336     1                  ISQUAR,IVGMSW,IHGMSW,ISU2SW,
16337     1                  IMPSW,IMPNR,IMPNC,IMPCO,
16338     1                  PMXMIN,PMXMAX,PMYMIN,PMYMAX,
16339CCCCC1                  TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
16340     1                  MAXNXT,IFORSW,
16341     1                  ANOPL1,ANOPL2,ISEED,IBOOSS,BARHEF,BARWEF,
16342     1                  ICAPSW,
16343     1                  IBUGG2,IBUGG3,IBUGQ,
16344     1                  IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
16345     1                  IFOUND,IERROR)
16346C
16347C     PURPOSE--GENERATE A BINARY TABULATION PLOT
16348C            --BINARY TABULATION PLOT Y1 Y2 X1 X2 TAG
16349C
16350C              THIS IS BASICALLY A TABULATION PLOT WHERE
16351C              Y1 AND Y2 ARE THE DATA FOR A 2X2 TABLE.
16352C              THAT IS, EACH VARIABLE HAS TWO MUTUALLY EXCLUSIVE
16353C              CHOICES CODED AS 1 (FOR SUCCESS) OR 0 (FOR
16354C              FAILURE).  THE FOLLOWING TABLE CAN BE DEFINED:
16355C
16356C                 Y1\Y2   |   SUCCESS    FAILURE   | ROW TOTAL
16357C                 ============================================
16358C                 SUCCES  |    N11        N12      | N11 + N12
16359C                 FAILURE |    N21        N22      | N21 + N22
16360C                 ============================================
16361C                 COL TOT |    N11+N21    N12+N22  | N
16362C
16363C              IN THIS TABLE, N11 AND N22 REPRESENT TRUE
16364C              POSITIVES AND TRUE NEGATIVES (I.E., CORRECT
16365C              MATCHED), N21 REPRESENTS THE NUMBER OF FALSE
16366C              POSITIVES, AND N12 REPRESENTS THE NUMBER OF
16367C              FALSE NEGATIVES.
16368C
16369C              A TYPICAL EXAMPLE WOULD BE WHERE VARIABLE ONE
16370C              DENOTES THE GROUND TRUTH AND A VALUE OF 1
16371C              INDICATES "PRESENT" AND A VALUE OF 0 INDICATES
16372C              "NOT PRESENT".  VARIABLE TWO REPRESENTS SOME TYPE
16373C              OF DETECTION DEVICE WHERE A VALUE OF 1 INDICATES
16374C              THE DEVICE DETECTED THE SPECIFIED OBJECT WHILE A
16375C              VALUE OF 0 INDICATES THAT THE OBJECT WAS NOT
16376C              DETECTED.  A FALSE POSITIVE THEN IS THE CASE WHERE
16377C              THE DEVICE DETECTED THE OBJECT WHEN IT WAS NOT
16378C              ACTUALY THERE.
16379C
16380C              THE X1 AND X2 DENOTE GROUP ID VARIABLES.  THIS
16381C              PLOT IS A MULTIPLOT WITH 3 CCOLUMNS:
16382C
16383C                 1) COLUMN 1 = PROPORTION OF CORRECT MATCHES
16384C                 2) COLUMN 2 = PROPORTION OF FALSE NEGATIVES
16385C                 3) COLUMN 3 = PROPORTION OF FALSE NEGATIVES
16386C
16387C              THE FIRST GROUP-ID VARIABLE IS USED WITHIN EACH
16388C              PLOT FRAME AND THE SECOND GROUP-ID VARIABLE IS
16389C              USED AS THE ROWS OF THE MULTI-PLOT.
16390C
16391C     WRITTEN BY--JAMES J. FILLIBEN
16392C                 STATISTICAL ENGINEERING DIVISION
16393C                 INFORMATiON TECHNOLOGY LABORATORY
16394C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
16395C                 GAITHERSBURG, MD 20899-8980
16396C                 PHONE--301-975-2899
16397C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
16398C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
16399C     LANGUAGE--ANSI FORTRAN (1977)
16400C     VERSION NUMBER--2007/5
16401C     ORIGINAL VERSION --MAY       2007.
16402C     UPDATED          --AUGUST    2007. CALL LIST TO MAINGR
16403C     UPDATED          --DECEMBER  2008. MAXIMUM SIZE OF GROUP
16404C                                        LABEL NOW SETTABLE IN
16405C                                        DPCOPA.INC
16406C
16407C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES---------------
16408C
16409      INCLUDE 'DPCOPA.INC'
16410C
16411      CHARACTER*4 ICASPL
16412      CHARACTER*4 ICAPSW
16413      CHARACTER*4 ICASEQ
16414      CHARACTER*4 ICONT
16415      CHARACTER*4 IPOWE
16416      CHARACTER*4 IAND1
16417      CHARACTER*4 IAND2
16418      CHARACTER*4 IFORSW
16419C
16420      CHARACTER*4 IBUGG2
16421      CHARACTER*4 IBUGG3
16422      CHARACTER*4 IBUGUG
16423      CHARACTER*4 IBUGU2
16424      CHARACTER*4 IBUGU3
16425      CHARACTER*4 IBUGU4
16426      CHARACTER*4 IBUGQ
16427C
16428      CHARACTER*4 ISUBRO
16429      CHARACTER*4 IFOUND
16430      CHARACTER*4 IERROR
16431C
16432      CHARACTER*4 ISQUAR
16433      CHARACTER*4 IVGMSW
16434      CHARACTER*4 IHGMSW
16435      CHARACTER*4 IREPCH
16436      CHARACTER*4 IMPSW
16437      CHARACTER*4 IMPSW3
16438C
16439      CHARACTER*4 IBTAPL
16440      CHARACTER*4 ICPLLD
16441      CHARACTER*4 ICPLDI
16442      CHARACTER*4 IEMPTY
16443      CHARACTER*4 IPPTB2
16444      CHARACTER*4 IFEED9
16445      CHARACTER*4 ICPLFZ
16446      CHARACTER*4 ICPLPZ
16447      CHARACTER*4 ICPLLZ
16448      CHARACTER*4 ICPLTZ
16449      CHARACTER*4 ICPLL2
16450      CHARACTER*4 ICPLXZ
16451      CHARACTER*4 ICPLYZ
16452      CHARACTER*4 ICPLDZ
16453      CHARACTER*4 ICPLZT
16454      CHARACTER*4 ICPLZ2
16455      CHARACTER*4 ICPLZ3
16456      CHARACTER*4 ICPLZ4
16457C
16458      CHARACTER*4 IMANUF
16459C
16460      CHARACTER*24 ICHAP2(100)
16461      CHARACTER*4 ILINP2(100)
16462      CHARACTER*4 ISPIS2(100)
16463      CHARACTER*4 IBARS2(100)
16464      CHARACTER*4 IERAS2
16465      CHARACTER*4 IX1TSV
16466      CHARACTER*4 IX2TSV
16467      CHARACTER*4 IY1TSV
16468      CHARACTER*4 IY2TSV
16469      CHARACTER*4 IX1ZSV
16470      CHARACTER*4 IX2ZSV
16471      CHARACTER*4 IY1ZSV
16472      CHARACTER*4 IY2ZSV
16473      CHARACTER*4 IY1MNS
16474      CHARACTER*4 IY1MXS
16475      CHARACTER*4 IY2MNS
16476      CHARACTER*4 IY2MXS
16477      CHARACTER*4 IX1MNS
16478      CHARACTER*4 IX1MXS
16479      CHARACTER*4 IX2MNS
16480      CHARACTER*4 IX2MXS
16481      CHARACTER*4 IX1FSV
16482      CHARACTER*4 IX2FSV
16483      CHARACTER*4 IY1FSV
16484      CHARACTER*4 IY2FSV
16485      CHARACTER*4 ISORS2
16486      CHARACTER*4 ILFLAX
16487      CHARACTER*4 ILFLAY
16488      CHARACTER*4 IY1LJ2
16489      CHARACTER*4 IY1LD2
16490      CHARACTER*4 IX1LT2(MAXCH)
16491      CHARACTER*4 IX2LT2(MAXCH)
16492      CHARACTER*4 IY1LT2(MAXCH)
16493      CHARACTER*4 IY2LT2(MAXCH)
16494      CHARACTER*4 ITITSV(MAXCH)
16495C
16496      CHARACTER*4 IPLTTY
16497      CHARACTER*4 IPLOTT
16498      CHARACTER*4 IFLGIN
16499      CHARACTER*4 IFLGX
16500      CHARACTER*4 IFLGY
16501      CHARACTER*4 IWRITE
16502      CHARACTER*4 IOP
16503C
16504      INCLUDE 'DPCOF2.INC'
16505C
16506      CHARACTER*4 ICT
16507      CHARACTER*4 IC2T
16508      CHARACTER*4 IHT(25)
16509      CHARACTER*4 IH2T(25)
16510      CHARACTER*4 IARGTT(25)
16511      REAL ARGT(25)
16512      CHARACTER*4 ISU2SW(MAXSUB)
16513C
16514C  MAXY IS THE MAXIMUM NUMBER OF VARIABLES TO USE IN CREATING THE
16515C  BINARY TABULATION PLOT   CURVE
16516C
16517      PARAMETER(MAXY=4)
16518C
16519      DIMENSION IVARN1(MAXY)
16520      DIMENSION IVARN2(MAXY)
16521      DIMENSION ILIS(MAXY)
16522      DIMENSION ICOLL(MAXY)
16523C
16524      CHARACTER*4 IHRIGH
16525      CHARACTER*4 IHRIG2
16526      CHARACTER*4 IHWUSE
16527      CHARACTER*4 MESSAG
16528      CHARACTER*4 ISTEPN
16529      CHARACTER*4 ISUBN1
16530      CHARACTER*4 ISUBN2
16531      CHARACTER*4 IVARN1
16532      CHARACTER*4 IVARN2
16533C
16534      DIMENSION TEMP(MAXOBV)
16535      DIMENSION TEMP3(MAXOBV)
16536C
16537C-----COMMON------------------------------------------------------
16538C
16539      INCLUDE 'DPCOZ3.INC'
16540      INCLUDE 'DPCOPC.INC'
16541      INCLUDE 'DPCOHK.INC'
16542      INCLUDE 'DPCODA.INC'
16543      INCLUDE 'DPCOST.INC'
16544C
16545      EQUIVALENCE (G3RBAG(KGARB1),TEMP(1))
16546      EQUIVALENCE (G3RBAG(KGARB2),TEMP3(1))
16547C
16548C-----COMMON VARIABLES (GENERAL)----------------------------------
16549C
16550      INCLUDE 'DPCOP2.INC'
16551C
16552C-----START POINT-------------------------------------------------
16553C
16554      IFOUND='YES'
16555      IERROR='NO'
16556      ISUBN1='DPBI'
16557      ISUBN2='TA  '
16558C
16559      ICASPL='BITA'
16560      ICPLLD='ON'
16561      ICPLDI='BLAN'
16562C
16563      IPLTTY='BIVA'
16564      IBTAPL='BINA'
16565      IBTAXV=1
16566C
16567      IBTARV=2
16568      ITAG=1
16569      IBTATV=1
16570      IFLAGV=IBTARV+IBTAXV+ITAG
16571      ICOL=3
16572      IROW=1
16573      IROWT=0
16574      NROWS=0
16575      ICOLT=0
16576      NRIGHT=0
16577      NRIGH2=0
16578      NTEMP=0
16579C
16580C               **********************************************
16581C               **  TREAT THE BINARY TABULATION PLOT   CASE **
16582C               **********************************************
16583C
16584      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BITA')THEN
16585        WRITE(ICOUT,999)
16586  999   FORMAT(1X)
16587        CALL DPWRST('XXX','BUG ')
16588        WRITE(ICOUT,51)
16589   51   FORMAT('***** AT THE BEGINNING OF DPBITA--')
16590        CALL DPWRST('XXX','BUG ')
16591        WRITE(ICOUT,52)ICASPL,IAND1,IAND2
16592   52   FORMAT('ICASPL,IAND1,IAND2 = ',A4,2X,A4,2X,A4)
16593        CALL DPWRST('XXX','BUG ')
16594        WRITE(ICOUT,53)IBUGG2,IBUGG3,IBUGQ
16595   53   FORMAT('IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4)
16596        CALL DPWRST('XXX','BUG ')
16597        WRITE(ICOUT,54)NUMARG
16598   54   FORMAT('NUMARG = ',I8)
16599        CALL DPWRST('XXX','BUG ')
16600        IF(NUMARG.GT.0)THEN
16601          DO61I=1,NUMARG
16602            WRITE(ICOUT,62)I,IHARG(I),IARGT(I)
16603   62       FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4)
16604            CALL DPWRST('XXX','BUG ')
16605   61     CONTINUE
16606        ENDIF
16607        WRITE(ICOUT,71)ICPLLA,ICPLTA,IBTAPL,ICPLFI,ICPLFR
16608   71   FORMAT('ICPLLA,ICPLTA,IBTAPL,ICPLFI,ICPLFR = ',5(A4,1X))
16609        CALL DPWRST('XXX','BUG ')
16610      ENDIF
16611C
16612C               ******************************************************
16613C               **  STEP 1--                                        **
16614C               **  SHIFT COMMAND LINE ARGMENTS                     **
16615C               ******************************************************
16616C
16617      ISTEPN='1'
16618      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
16619     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16620C
16621      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'TABU'.AND.
16622     1   IHARG(2).EQ.'PLOT')THEN
16623        ISHIFT=2
16624        CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
16625     1              IBUGG2,IERROR)
16626        IF(IERROR.EQ.'YES')GOTO9000
16627      ELSE
16628        IFOUND='NO'
16629        GOTO9000
16630      ENDIF
16631C
16632      ICOM='BINA'
16633      ICOM2='    '
16634      IFOUND='YES'
16635C
16636C               *******************************************************
16637C               **  STEP 2--                                         **
16638C               **  CHECK FOR THE PROPER NUMBER OF INPUT ARGUMENTS.  **
16639C               *******************************************************
16640C
16641      ISTEPN='2'
16642      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
16643     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16644C
16645      MINN2=2
16646      MINNA=4
16647      MAXNA=100
16648      CALL CHECKA(NUMARG,MINNA,MAXNA,IANS,IWIDTH,ISUBN1,ISUBN2,IERROR)
16649      IF(IERROR.EQ.'YES')GOTO9000
16650C
16651C               *****************************************
16652C               **  STEP 3--                           **
16653C               **  CHECK TO SEE THE TYPE SUBCASE      **
16654C               **  (BASED ON THE QUALIFIER)--         **
16655C               **    1) UNQUALIFIED (THAT IS, FULL);  **
16656C               **    2) SUBSET/EXCEPT; OR             **
16657C               **    3) FOR.                          **
16658C               *****************************************
16659C
16660      ISTEPN='3'
16661      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
16662     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16663C
16664      ICASEQ='FULL'
16665      ILOCQ=NUMARG+1
16666      IF(NUMARG.LT.1)GOTO1180
16667      DO1100J=1,NUMARG
16668      J1=J
16669      IF(IHARG(J).EQ.'SUBS'.AND.IHARG2(J).EQ.'ET  ')GOTO1110
16670      IF(IHARG(J).EQ.'EXCE'.AND.IHARG2(J).EQ.'PT  ')GOTO1110
16671      IF(IHARG(J).EQ.'FOR '.AND.IHARG2(J).EQ.'    ')GOTO1120
16672 1100 CONTINUE
16673      GOTO1180
16674 1110 CONTINUE
16675      ICASEQ='SUBS'
16676      ILOCQ=J1
16677      GOTO1190
16678 1120 CONTINUE
16679      ICASEQ='FOR'
16680      ILOCQ=J1
16681      GOTO1190
16682C
16683 1180 CONTINUE
16684      GOTO1190
16685C
16686 1190 CONTINUE
16687      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BITA')THEN
16688        WRITE(ICOUT,1191)NUMARG,ILOCQ,ICASEQ
16689 1191   FORMAT('NUMARG,ILOCQ,ICASEQ = ',I8,I8,2X,A4)
16690        CALL DPWRST('XXX','BUG ')
16691      ENDIF
16692C
16693C               **************************************************
16694C               **  STEP 4--                                    **
16695C               **  DETERMINE THE NUMBER OF VARIABLES           **
16696C               **  TO BE INCLUDED AS PLOT COMPONENTS           **
16697C               **  IF THE   TO   FEATURE IS USED IN THE        **
16698C               **  ARGUMENT LIST, TRANSLATE THE   TO   TO      **
16699C               **  EXPLICIT VARIABLE NAMES                     **
16700C               **************************************************
16701C
16702      ISTEPN='4'
16703      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
16704     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16705C
16706      JMIN=1
16707      JMAX=ILOCQ-1
16708      CALL EXTVAR(IHARG,IHARG2,NUMARG,JMIN,JMAX,MAXY,
16709     1IHNAME,IHNAM2,IUSE,NUMNAM,
16710     1IVARN1,IVARN2,NUMVAR,IBUGG2,ISUBRO,IERROR)
16711      IF(IERROR.EQ.'YES')GOTO9000
16712C
16713C               **************************************************
16714C               **  STEP 5--                                    **
16715C               **  NUMBER OF VARIABLES MUST EQUAL IFLAGV       **
16716C               **************************************************
16717C
16718      ISTEPN='5'
16719      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
16720     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16721C
16722      IF(NUMVAR.NE.IFLAGV)THEN
16723        WRITE(ICOUT,999)
16724        CALL DPWRST('XXX','BUG ')
16725        WRITE(ICOUT,1291)
16726        CALL DPWRST('XXX','BUG ')
16727        WRITE(ICOUT,1293)IBTARV
16728        CALL DPWRST('XXX','BUG ')
16729        WRITE(ICOUT,1294)IBTAXV
16730        CALL DPWRST('XXX','BUG ')
16731        WRITE(ICOUT,1296)ITAG
16732        CALL DPWRST('XXX','BUG ')
16733        WRITE(ICOUT,1297)NUMVAR
16734        CALL DPWRST('XXX','BUG ')
16735        WRITE(ICOUT,1328)
16736        CALL DPWRST('XXX','BUG ')
16737        IF(IWIDTH.GE.1)THEN
16738          WRITE(ICOUT,1329)(IANS(J),J=1,MIN(IWIDTH,100))
16739          CALL DPWRST('XXX','BUG ')
16740        ENDIF
16741        IERROR='YES'
16742        GOTO9000
16743      ENDIF
16744 1291 FORMAT('***** ERROR IN DPBITA--EXPECTED')
16745 1293 FORMAT('         ',I8,'RESPONSE VARIABLES')
16746 1294 FORMAT('         ',I8,'GROUP VARIABLES')
16747 1296 FORMAT('         ',I8,'TAG VARIABLES')
16748 1297 FORMAT('      DETECTED ',I8,' VARIABLES.')
16749C
16750C               ***************************************
16751C               **  STEP 6--                         **
16752C               **  CHECK THE VALIDITY OF EACH       **
16753C               **  OF THE VARIABLES.                **
16754C               **  ALSO CHECK TO ASSURE THAT EACH   **
16755C               **  OF THE VARIABLES HAS AT LEAST    **
16756C               **  2 OBSERVATIONS.                  **
16757C               ***************************************
16758C
16759      ISTEPN='6'
16760      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
16761     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16762C
16763      MAXCP1=MAXCOL+1
16764      MAXCP2=MAXCOL+2
16765      MAXCP3=MAXCOL+3
16766      MAXCP4=MAXCOL+4
16767      MAXCP5=MAXCOL+5
16768      MAXCP6=MAXCOL+6
16769C
16770      IFLAG=0
16771      IFLAG2=0
16772      DO1300I=1,NUMVAR
16773C
16774        IHRIGH=IVARN1(I)
16775        IHRIG2=IVARN2(I)
16776        IHWUSE='V'
16777        MESSAG='YES'
16778        CALL CHECKN(IHRIGH,IHRIG2,IHWUSE,
16779     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
16780     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCV,IERROR)
16781        IF(IERROR.EQ.'YES')GOTO9000
16782        ICOLL(I)=IVALUE(ILOCV)
16783C
16784        NTEMP=IN(ILOCV)
16785        IF(I.EQ.1)THEN
16786          NRIGHT=NTEMP
16787        ELSEIF(I.GE.2)THEN
16788          NRIGH2=NTEMP
16789          IF(NRIGH2.NE.NRIGHT)IFLAG=1
16790        ENDIF
16791C
16792        IF(I.EQ.4)THEN
16793          ICOL=IVALUE(ILOCV)
16794          J=0
16795          DO1261ITEMP=1,NRIGH2
16796            J=J+1
16797            NIN=J
16798            IJ=MAXN*(ICOL-1)+ITEMP
16799            IF(ICOL.LE.MAXCOL)TEMP(J)=V(IJ)
16800            IF(ICOL.EQ.MAXCP1)TEMP(J)=PRED(ITEMP)
16801            IF(ICOL.EQ.MAXCP2)TEMP(J)=RES(ITEMP)
16802            IF(ICOL.EQ.MAXCP3)TEMP(J)=YPLOT(ITEMP)
16803            IF(ICOL.EQ.MAXCP4)TEMP(J)=XPLOT(ITEMP)
16804            IF(ICOL.EQ.MAXCP5)TEMP(J)=X2PLOT(ITEMP)
16805            IF(ICOL.EQ.MAXCP6)TEMP(J)=TAGPLO(ITEMP)
16806 1261     CONTINUE
16807          IWRITE='OFF'
16808          CALL DISTIN(TEMP,NIN,IWRITE,TEMP3,NOUT,IBUGG3,IERROR)
16809          NROWS=NOUT
16810        ENDIF
16811        ILIS(I)=ILOCV
16812        IF(NTEMP.LE.MINN2)THEN
16813          WRITE(ICOUT,999)
16814          CALL DPWRST('XXX','BUG ')
16815          WRITE(ICOUT,1311)
16816 1311     FORMAT('***** ERROR IN BINARY TABULATION PLOT--')
16817          CALL DPWRST('XXX','BUG ')
16818          WRITE(ICOUT,1312)
16819 1312     FORMAT('      THE INPUT NUMBER OF OBSERVATIONS FOR WHICH A')
16820          CALL DPWRST('XXX','BUG ')
16821          WRITE(ICOUT,1321)
16822 1321     FORMAT('      BINARY TABULATION PLOT WAS TO HAVE BEEN ',
16823     1           'FORMED MUST')
16824          CALL DPWRST('XXX','BUG ')
16825          WRITE(ICOUT,1326)MINN2
16826 1326     FORMAT('      BE ',I8,' OR LARGER; SUCH WAS NOT THE CASE',
16827     1           ' HERE.')
16828          CALL DPWRST('XXX','BUG ')
16829          WRITE(ICOUT,1327)I,NTEMP
16830 1327     FORMAT('      VARIABLE ',I8,' HAS ',I8,' OBSERVATIONS.')
16831          WRITE(ICOUT,1328)
16832 1328     FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
16833          CALL DPWRST('XXX','BUG ')
16834          IF(IWIDTH.GE.1)THEN
16835            WRITE(ICOUT,1329)(IANS(J),J=1,MIN(IWIDTH,100))
16836 1329       FORMAT('      ',100A1)
16837            CALL DPWRST('XXX','BUG ')
16838          ENDIF
16839          IERROR='YES'
16840          GOTO9000
16841        ENDIF
16842C
16843 1300 CONTINUE
16844C
16845C               ******************************************************
16846C               **  STEP 7--                                        **
16847C               **  CHECK THAT VARIABLES HAVE THE SAME NUMBER OF    **
16848C               **  ELEMENTS.                                       **
16849C               ******************************************************
16850C
16851      ISTEPN='7'
16852      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
16853     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16854C
16855      IF(IFLAG.EQ.1)THEN
16856        WRITE(ICOUT,1411)
16857 1411   FORMAT('***** ERROR IN BINARY TABULATION PLOT--')
16858        CALL DPWRST('XXX','BUG ')
16859        WRITE(ICOUT,1413)
16860 1413   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE')
16861        CALL DPWRST('XXX','BUG ')
16862        WRITE(ICOUT,1414)
16863 1414   FORMAT('      AND TAG VARIABLES MUST BE THE SAME.')
16864        CALL DPWRST('XXX','BUG ')
16865        WRITE(ICOUT,1415)
16866        CALL DPWRST('XXX','BUG ')
16867 1415   FORMAT('      SUCH WAS NOT THE CASE HERE.')
16868C
16869        DO1417I=1,NUMVAR
16870          I2=ILIS(I)
16871          WRITE(ICOUT,1416)IVARN1(I2),IVARN2(I2),IN(I2)
16872 1416     FORMAT('           VARIABLE ',A4,A4,' HAS ',I8,
16873     1           ' OBSERVATIONS;')
16874          CALL DPWRST('XXX','BUG ')
16875 1417   CONTINUE
16876        WRITE(ICOUT,1420)
16877 1420   FORMAT('      THE ENTERED COMMAND LINE WAS AS FOLLOWS--')
16878        CALL DPWRST('XXX','BUG ')
16879        IF(IWIDTH.GE.1)THEN
16880          WRITE(ICOUT,1421)(IANS(I),I=1,MIN(IWIDTH,100))
16881 1421     FORMAT('      ',100A1)
16882          CALL DPWRST('XXX','BUG ')
16883        ENDIF
16884        IERROR='YES'
16885        GOTO9000
16886      ENDIF
16887C
16888C               **************************************************
16889C               **   STEP 8--                                   **
16890C               **   SAVE INITIAL SETTINGS                      **
16891C               **************************************************
16892C
16893      ISTEPN='8'
16894      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
16895     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
16896C
16897      PXMN2=PXMIN
16898      PXMX2=PXMAX
16899      PYMN2=PYMIN
16900      PYMX2=PYMAX
16901      PWXMN2=PWXMIN
16902      PWXMX2=PWXMAX
16903      PWYMN2=PWYMIN
16904      PWYMX2=PWYMAX
16905      IF(ICPLFR.EQ.'DEFA')THEN
16906        PXMIN=0.0
16907        PXMAX=100.0
16908        PYMIN=0.0
16909        PYMAX=100.0
16910      ENDIF
16911      GY1MNS=GY1MIN
16912      GY1MXS=GY1MAX
16913C
16914      IERAS2=IERASW
16915      IPPTB2=IPPTBI
16916      IPPTBI='UNBI'
16917      IX1TSV=IX1TSW
16918      IX2TSV=IX2TSW
16919      IY1TSV=IY1TSW
16920      IY2TSV=IY2TSW
16921      IX1ZSV=IX1ZSW
16922      IX2ZSV=IX2ZSW
16923      IY1ZSV=IY1ZSW
16924      IY2ZSV=IY2ZSW
16925      PX1LD2=PX1LDS
16926      PX2LD2=PX2LDS
16927      PY1LD2=PY1LDS
16928      PY1LA2=PY1LAN
16929      IY1LJ2=IY1LJU
16930      IY1LD2=IY1LDI
16931      GY1MNS=GY1MIN
16932      GY1MXS=GY1MAX
16933      GY2MNS=GY2MIN
16934      GY2MXS=GY2MAX
16935      GX1MNS=GX1MIN
16936      GX1MXS=GX1MAX
16937      GX2MNS=GX2MIN
16938      GX2MXS=GX2MAX
16939      IY1MNS=IY1MIN
16940      IY1MXS=IY1MAX
16941      IY2MNS=IY2MIN
16942      IY2MXS=IY2MAX
16943      IX1MNS=IX1MIN
16944      IX1MXS=IX1MAX
16945      IX2MNS=IX2MIN
16946      IX2MXS=IX2MAX
16947      IX1FSV=IX1FSW
16948      IX2FSV=IX2FSW
16949      IY1FSV=IY1FSW
16950      IY2FSV=IY2FSW
16951      PX1ZD2=PX1ZDS
16952      PX2ZD2=PX2ZDS
16953      PY1ZD2=PY1ZDS
16954      PY2ZD2=PY2ZDS
16955      ISORS2=ISORSW
16956C
16957      ICPLFZ=ICPLFR
16958      ICPLL2=ICPLLA
16959      IF(ICPLFR.EQ.'CONN')ICPLFR='DEFA'
16960      IF(ICPLFR.EQ.'USER'.AND.ICPLLA.EQ.'BOX')ICPLLA='ON'
16961      IF(ICPLLA.EQ.'BOX ')THEN
16962        ICPLLD='ON'
16963      ENDIF
16964      ICPLTZ=ICPLTA
16965      ICPLPZ=IBTAPL
16966      ICPLLZ=ICPLLD
16967      ICPLZT=ICPLST
16968      ICPLZ2=ICPLS2
16969      ICPLZ3=ICPLS3
16970      ICPLZ4=ICPLS4
16971      ICPLXZ=ICPLXA
16972      ICPLYZ=ICPLYA
16973      ICPLDZ=ICPLDI
16974C
16975      ILFLAX='OFF'
16976      ILFLAY='OFF'
16977      IF(IY1MIN.EQ.'FIXE'.AND.IY1MAX.EQ.'FIXE')THEN
16978        ILFLAY='ON'
16979      ENDIF
16980      IF(IX1MIN.EQ.'FIXE'.AND.IX2MAX.EQ.'FIXE')THEN
16981        ILFLAX='ON'
16982      ENDIF
16983C
16984      DO1495I=1,100
16985        ICHAP2(I)=ICHAPA(I)
16986        ILINP2(I)=ILINPA(I)
16987        IBARS2(I)=IBARSW(I)
16988        ISPIS2(I)=ISPISW(I)
16989 1495 CONTINUE
16990C
16991      DO1500I=1,MAXCH
16992        IX1LT2(I)=IX1LTE(I)
16993        IX2LT2(I)=IX2LTE(I)
16994        IY1LT2(I)=IY1LTE(I)
16995        IY2LT2(I)=IY2LTE(I)
16996 1500 CONTINUE
16997      NCX1L2=NCX1LA
16998      NCX2L2=NCX2LA
16999      NCY1L2=NCY1LA
17000      NCY2L2=NCY2LA
17001C
17002      IFEED9=IFEEDB
17003      IFLGIN='OFF'
17004      IFLGY='OFF'
17005      IFLGX='OFF'
17006C
17007      DO110I=1,MAXCH
17008        ITITSV(I)=ITITTE(I)
17009  110 CONTINUE
17010      NCTITS=NCTITL
17011      PTITDZ=PTITDS
17012C
17013      ISTEPN='8.1'
17014      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
17015     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17016C
17017      ISHIFT=ILOCQ-1
17018      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
17019     1            IBUGG2,IERROR)
17020      IF(IERROR.EQ.'YES')GOTO9000
17021      ISHIFT=NUMVAR-1
17022      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
17023     1            IBUGG2,IERROR)
17024      IF(IERROR.EQ.'YES')GOTO9000
17025      DO1509I=1,ISHIFT
17026        IHARG(I)=IVARN1(I)
17027        IHARG2(I)=IVARN2(I)
17028 1509 CONTINUE
17029      NUMVAR=NUMVAR-1
17030      ILOCQ=ISHIFT+1
17031C
17032      ISTEPN='8.2'
17033      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
17034     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17035C
17036      IOP='OPEN'
17037      IFLAG1=0
17038      IFLAG2=0
17039      IFLAG3=0
17040      IFLAG4=0
17041      IFLAG5=1
17042      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
17043     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17044     1            IBUGG3,ISUBRO,IERROR)
17045      IF(IERROR.EQ.'YES')GOTO9000
17046C
17047      IMPSW3=IMPSW
17048      IMPCO2=IMPCO
17049      IMPNR2=IMPNR
17050      IMPNC2=IMPNC
17051      IMPSW='ON'
17052      IMPCO=1
17053      IMPCO9=IMPCO
17054C
17055      IROWT=NROWS
17056      ICOLT=3
17057      IMPNR=IROWT
17058      IMPNC=ICOLT
17059C
17060      IXAXIS=0
17061      IYAXIS=0
17062C
17063C  THE SYNTAX OF THE COMMAND IS:
17064C
17065C     BINARY CORRECT MATCH PLOT Y1 Y2 X1  SUBSET X2 = VALUE
17066C
17067      ICT='BINA'
17068      IC2T='RY  '
17069      IHT(1)='CORR'
17070      IH2T(1)='ECT '
17071      IHT(2)='MATC'
17072      IH2T(2)='H   '
17073      IHT(3)='PLOT'
17074      IH2T(3)='    '
17075      IHT(4)=IVARN1(1)
17076      IH2T(4)=IVARN2(1)
17077      IHT(5)=IVARN1(2)
17078      IH2T(5)=IVARN2(2)
17079      IHT(6)=IVARN1(3)
17080      IH2T(6)=IVARN2(3)
17081      IHT(7)='SUBS'
17082      IH2T(7)='ET  '
17083      IHT(8)=IVARN1(4)
17084      IH2T(8)=IVARN2(4)
17085      IHT(9)='=   '
17086      IH2T(9)='    '
17087      IHT(10)='=   '
17088      IH2T(10)='    '
17089      NCCOMM=10
17090C
17091C     ADD ANY USER-SUPPLIED <SUBSET/EXCEPT/FOR> CLAUSES TO
17092C     END OF COMMAND LINE
17093C
17094      ISHIFT=ILOCQ-1
17095      CALL SHIFTL(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
17096     1IBUGG2,IERROR)
17097      IF(IERROR.EQ.'YES')GOTO8000
17098      ISHIFT=NCCOMM
17099      CALL SHIFTR(ISHIFT,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG,
17100     1            IBUGG2,IERROR)
17101C
17102      ICOM=ICT
17103      ICOM2=IC2T
17104      DO7006II=1,NCCOMM
17105        IHARG(II)=IHT(II)
17106        IHARG2(II)=IH2T(II)
17107        IARGT(II)='WORD'
17108 7006 CONTINUE
17109      IARGT(10)='NUMB'
17110      ARG(10)=0.0
17111C
17112      IPLOTT='BIPL'
17113      IFLGIN='NO'
17114      IF((IY1MIN.EQ.'FLOA'.AND.IY1MAX.EQ.'FLOA').OR.
17115     1   (IX1MIN.EQ.'FLOA'.AND.IX1MAX.EQ.'FLOA'))THEN
17116        IF((PCPYLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN).OR.
17117     1     (PCPXLL(1).EQ.CPUMIN.AND.PCPYUL(1).EQ.CPUMIN))THEN
17118          IFLGIN='YES'
17119          IFLGY='ON'
17120          IFLGX='ON'
17121        ENDIF
17122      ENDIF
17123C
17124C               **********************************************
17125C               **   STEP 9--                               **
17126C               **   GENERATE THE BINARY PLOT        PLOTS  **
17127C               **********************************************
17128C
17129      ISTEPN='9'
17130      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BITA')
17131     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17132C
17133      NARGT=NUMARG
17134C
17135      DO7020I=1,NARGT
17136        IHT(I)=IHARG(I)
17137        IH2T(I)=IHARG2(I)
17138        IARGTT(I)=IARGT(I)
17139        ARGT(I)=ARG(I)
17140 7020 CONTINUE
17141C
17142C     CHECK TO SEE IF A GROUP LABEL HAS BEEN DEFINED
17143C
17144      IGLCOL=-1
17145      IF(IBTAGN.NE.' ')THEN
17146        DO7810I=1,MAXGRP
17147          IF(IBTAGN(1:8).EQ.IGRPVN(I)(1:8))THEN
17148            IGLCOL=I
17149            GOTO7819
17150          ENDIF
17151 7810   CONTINUE
17152 7819   CONTINUE
17153      ENDIF
17154C
17155      IX=1
17156      IXLIST=1
17157      NPLOTS=IROWT*ICOLT
17158      IPLOT=0
17159      DO7200IRES=1,IROWT
17160      DO7100IFAC=1,ICOLT
17161C
17162C       RESTORE COMMAND LINE ARGUMENTS
17163C
17164        DO7105II=1,NARGT
17165          IHARG(II)=IHT(II)
17166          IHARG2(II)=IH2T(II)
17167          IARGT(II)=IARGTT(II)
17168          ARG(II)=ARGT(II)
17169 7105   CONTINUE
17170        ARG(10)=TEMP3(IRES)
17171        NUMARG=NARGT
17172C
17173        IPLOT=IPLOT+1
17174        IF(IFAC.EQ.1)THEN
17175          IHARG(1)='CORR'
17176          IHARG2(1)='ECT '
17177          IHARG(2)='MATC'
17178          IHARG2(2)='H   '
17179        ELSEIF(IFAC.EQ.2)THEN
17180          IHARG(1)='FALS'
17181          IHARG2(1)='E   '
17182          IHARG(2)='POSI'
17183          IHARG2(2)='TIVE'
17184        ELSEIF(IFAC.EQ.3)THEN
17185          IHARG(1)='FALS'
17186          IHARG2(1)='E   '
17187          IHARG(2)='NEGA'
17188          IHARG2(2)='TIVE'
17189        ENDIF
17190C
17191        IF(ISUBRO.EQ.'BITA' .OR. IBUGG2.EQ.'ON')THEN
17192          DO7706I=1,NUMARG
17193            WRITE(ICOUT,7707)I,IHARG(I),IHARG2(I)
17194 7707       FORMAT('I,IHARG(I),IHARG2(I) = ',I5,2X,A4,2X,A4)
17195            CALL DPWRST('XXX','BUG ')
17196 7706     CONTINUE
17197        ENDIF
17198C
17199        ICASPL='BITA'
17200        IROW=IRES
17201        ICOL=IFAC
17202        IF(IGLCOL.GT.0)THEN
17203          NCY1LA=0
17204          NCY2LA=0
17205        ENDIF
17206C
17207        CALL DPSPM1(ICASPL,IVARN1,IVARN2,ICOLL,
17208     1              IMPNR,IMPNC,IROW,ICOL,IRES,IX,IPLOT,
17209     1              NPLOTS,NUMVAR,
17210     1              ICHAP2,ILINP2,
17211     1              GY1MNS,GY1MXS,GY2MNS,GY2MXS,
17212     1              GX1MNS,GX1MXS,GX2MNS,GX2MXS,
17213     1              IY1MNS,IY1MXS,IY2MNS,IY2MXS,
17214     1              IX1MNS,IX1MXS,IX2MNS,IX2MXS,
17215     1              IX1TSV,IX2TSV,IY1TSV,IY2TSV,
17216     1              IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
17217     1              PX1LD2,PX2LD2,
17218     1              IY1LJ2,IY1LD2,PY1LD2,PY1LA2,
17219     1              IX1LT2,IX2LT2,IY1LT2,IY2LT2,
17220     1              NCX1L2,NCX2L2,NCY1L2,NCY2L2,
17221     1              PCPXLL,PCPXUL,PCPYLL,PCPYUL,IXLIST,
17222     1              ICPLLA,ISPMLD,IPLOTT,ICPLFR,ICPLXA,ICPLYA,
17223     1              ISPMDI,ISPX1L,
17224     1              ISPMXT,ISPMXL,ISPMYT,ISPMYL,
17225     1              ICPLTD,PCPLTD,IVNMEX,
17226     1              IBUGG2,ISUBRO)
17227C
17228        IF(IRES.EQ.1)THEN
17229          IF(IFAC.EQ.1)THEN
17230            ITITTE(1)='C'
17231            ITITTE(2)='o'
17232            ITITTE(3)='r'
17233            ITITTE(4)='r'
17234            ITITTE(5)='e'
17235            ITITTE(6)='c'
17236            ITITTE(7)='t'
17237            ITITTE(8)=' '
17238            ITITTE(9)='M'
17239            ITITTE(10)='a'
17240            ITITTE(11)='t'
17241            ITITTE(12)='c'
17242            ITITTE(13)='h'
17243            NCTEMP=13
17244          ELSEIF(IFAC.EQ.2)THEN
17245            ITITTE(1)='F'
17246            ITITTE(2)='a'
17247            ITITTE(3)='l'
17248            ITITTE(4)='s'
17249            ITITTE(5)='e'
17250            ITITTE(6)=' '
17251            ITITTE(7)='P'
17252            ITITTE(8)='o'
17253            ITITTE(9)='s'
17254            ITITTE(10)='i'
17255            ITITTE(11)='t'
17256            ITITTE(12)='i'
17257            ITITTE(13)='v'
17258            ITITTE(14)='e'
17259            NCTEMP=14
17260          ELSEIF(IFAC.EQ.3)THEN
17261            ITITTE(1)='F'
17262            ITITTE(2)='a'
17263            ITITTE(3)='l'
17264            ITITTE(4)='s'
17265            ITITTE(5)='e'
17266            ITITTE(6)=' '
17267            ITITTE(7)='N'
17268            ITITTE(8)='e'
17269            ITITTE(9)='g'
17270            ITITTE(10)='a'
17271            ITITTE(11)='t'
17272            ITITTE(12)='i'
17273            ITITTE(13)='v'
17274            ITITTE(14)='e'
17275            NCTEMP=14
17276          ENDIF
17277        ELSE
17278          NCTEMP=0
17279          ITITTE(1)=' '
17280        ENDIF
17281        NCTITL=NCTEMP
17282C
17283C       IF A GROUP LABEL HAS BEEN SPECIFIED, SET Y1LABEL OR
17284C       Y2LABEL IF APPROPRIATE
17285C
17286        IF(IGLCOL.GT.0 .AND. IGLCOL.LE.MAXGRP)THEN
17287          IFLAG=0
17288          IF(ICPLYA.EQ.'LEFT')THEN
17289            IF(IFAC.EQ.1)IFLAG=1
17290          ELSEIF(ICPLYA.EQ.'RIGH')THEN
17291            IF(IFAC.EQ.3)IFLAG=2
17292          ELSEIF(ICPLYA.EQ.'ALTE')THEN
17293            IF(MOD(IRES,2).EQ.1)THEN
17294              IF(IFAC.EQ.1)IFLAG=1
17295            ELSEIF(MOD(IRES,2).EQ.0)THEN
17296              IF(IFAC.EQ.3)IFLAG=2
17297            ENDIF
17298          ENDIF
17299        ENDIF
17300        IF(IFLAG.EQ.1)THEN
17301CCCCC     DO7860I=1,24
17302          DO7860I=1,MAXGR2
17303            IY1LTE(I)=' '
17304            IY1LTE(I)(1:1)=IGRPLA(IRES,IGLCOL)(I:I)
17305            IF(IY1LTE(I).NE.' ')NCY1LA=I
17306 7860     CONTINUE
17307        ELSEIF(IFLAG.EQ.2)THEN
17308CCCCC     DO7870I=1,24
17309          DO7870I=1,MAXGR2
17310            IY2LTE(I)=' '
17311            IY2LTE(I)(1:1)=IGRPLA(IRES,IGLCOL)(I:I)
17312            IF(IY2LTE(I).NE.' ')NCY2LA=I
17313 7870     CONTINUE
17314        ELSE
17315          NCY1LA=0
17316          NCY2LA=0
17317        ENDIF
17318C
17319        CALL MAINGR(ANOPL1,ANOPL2,NPLOTV,NPLOTP,NS,ICASPL,
17320     1              MAXNPP,ISEED,IBOOSS,
17321     1              IX1TSV,IX2TSV,IY1TSV,IY2TSV,
17322     1              IX1ZSV,IX2ZSV,IY1ZSV,IY2ZSV,
17323     1              BARHEF,BARWEF,
17324     1              IRHSTG,IHSTCW,IHSTEB,IHSTOU,IASHWT,IHSTMC,IHSTOP,
17325     1              ICAPSW,IFORSW,
17326     1              IGUIFL,IERRFA,
17327     1              IAND1,IAND2,ICONT,NUMHPP,NUMVPP,
17328CCCCC1              TEMP,TEMP2,TEMP3,XTEMP1,XTEMP2,MAXNXT,
17329     1              MAXNXT,
17330     1              ISUBRO,IFOUND,IERROR)
17331C
17332        ICONT=IDCONT(1)
17333        IPOWE=IDPOWE(1)
17334        NUMHPP=IDNHPP(1)
17335        IMPARG=2
17336        CALL DPGRAP(Y,X,X3D,D,N,NPLOTP,ICASPL,ICONT,IPOWE,NUMHPP,
17337     1              XMATN,YMATN,XMITN,YMITN,
17338     1              ISQUAR,
17339     1              IVGMSW,IHGMSW,
17340     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,
17341     1              IVSTAR,IVSTOP,IFUNC,NUMCHF,IREPCH,
17342     1              YPLOT,XPLOT,X2PLOT,TAGPLO,
17343     1              IMPSW,IMPNR,IMPNC,IMPCO,IMPCO9,
17344     1              IMPARG,
17345     1              PMXMIN,PMXMAX,PMYMIN,PMYMAX,
17346     1              MAXCOL,
17347     1              DSIZE,DSYMB,DCOLOR,DFILL,
17348     1              ICAPSW,
17349     1              IBUGUG,IBUGU2,IBUGU3,IBUGU4,ISUBRO,
17350     1              IERROR)
17351        IF(IERROR.EQ.'NO')IAND1=IAND2
17352        IF(IERROR.EQ.'YES')GOTO7199
17353C
17354 7199   CONTINUE
17355C
17356        PX1LDS=PX1LD2
17357        IF(IYAXIS.EQ.0.AND.IFLGIN.EQ.'NO')THEN
17358          GY1MNS=GY1MIN
17359          GY1MXS=GY1MAX
17360          GY2MNS=GY2MIN
17361          GY2MXS=GY2MAX
17362          IY1MNS=IY1MIN
17363          IY1MXS=IY1MAX
17364          IY2MNS=IY2MIN
17365          IY2MXS=IY2MAX
17366        ENDIF
17367        IF(IXAXIS.EQ.0.AND.IFLGIN.EQ.'NO')THEN
17368          GX1MNS=GX1MIN
17369          GX1MXS=GX1MAX
17370          GX2MNS=GX2MIN
17371          GX2MXS=GX2MAX
17372          IX1MNS=IX1MIN
17373          IX1MXS=IX1MAX
17374          IX2MNS=IX2MIN
17375          IX2MXS=IX2MAX
17376        ENDIF
17377        PX1ZDS=PX1ZD2
17378        PX2ZDS=PX2ZD2
17379        PY1ZDS=PY1ZD2
17380        PY2ZDS=PY2ZD2
17381        IF(IEMPTY.EQ.'YES')THEN
17382          DO7107I=1,MAXSUB
17383            ISUBSW(I)=ISU2SW(I)
17384 7107     CONTINUE
17385        ENDIF
17386        DO7108I=1,100
17387            ICHAPA(I)=ICHAP2(I)
17388            ILINPA(I)=ILINP2(I)
17389            ISPISW(I)=ISPIS2(I)
17390            IBARSW(I)=IBARS2(I)
17391 7108     CONTINUE
17392C
17393 7100 CONTINUE
17394 7200 CONTINUE
17395C
17396      IF(IYAXIS.EQ.1)THEN
17397        GY1MIN=GY1MNS
17398        GY1MAX=GY1MXS
17399        GY2MIN=GY2MNS
17400        GY2MAX=GY2MXS
17401        IY1MIN=IY1MNS
17402        IY1MAX=IY1MXS
17403        IY2MIN=IY2MNS
17404        IY2MAX=IY2MXS
17405      ENDIF
17406      IF(IXAXIS.EQ.1)THEN
17407        GX1MIN=GX1MNS
17408        GX1MAX=GX1MXS
17409        GX2MIN=GX2MNS
17410        GX2MAX=GX2MXS
17411        IX1MIN=IX1MNS
17412        IX1MAX=IX1MXS
17413        IX2MIN=IX2MNS
17414        IX2MAX=IX2MXS
17415      ENDIF
17416      GOTO8000
17417C
17418C               **************************************************
17419C               **   STEP 28--                                  **
17420C               **   REINSTATE INITIAL SETTINGS                 **
17421C               **************************************************
17422C
17423 8000 CONTINUE
17424      ISTEPN='28'
17425      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BITA')THEN
17426        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
17427        WRITE(ICOUT,8807)IMANUF,NUMDEV,IDMANU(1)
17428 8807   FORMAT('IMANUF,NUMDEV,IDMANU(1) = ',A4,I8,2X,A4)
17429        CALL DPWRST('XXX','BUG ')
17430      ENDIF
17431C
17432      PWXMIN=PWXMN2
17433      PWXMAX=PWXMX2
17434      PWYMIN=PWYMN2
17435      PWYMAX=PWYMX2
17436      PXMIN=PXMN2
17437      PXMAX=PXMX2
17438      PYMIN=PYMN2
17439      PYMAX=PYMX2
17440C
17441      DO8820I=1,100
17442        ICHAPA(I)=ICHAP2(I)
17443        ILINPA(I)=ILINP2(I)
17444        IBARSW(I)=IBARS2(I)
17445        ISPISW(I)=ISPIS2(I)
17446 8820 CONTINUE
17447C
17448CCCCC IMPSW=IMPSW3
17449      IMPSW='OFF'
17450      IMPCO=1
17451      IMPNR=IMPNR2
17452      IMPNC=IMPNC2
17453C
17454      IERASW='ON'
17455      IX1TSW=IX1TSV
17456      IX2TSW=IX2TSV
17457      IY1TSW=IY1TSV
17458      IY2TSW=IY2TSV
17459      IX1ZSW=IX1ZSV
17460      IX2ZSW=IX2ZSV
17461      IY1ZSW=IY1ZSV
17462      IY2ZSW=IY2ZSV
17463      GY1MIN=GY1MNS
17464      GY1MAX=GY1MXS
17465      GY2MIN=GY2MNS
17466      GY2MAX=GY2MXS
17467      GX1MIN=GX1MNS
17468      GX1MAX=GX1MXS
17469      GX2MIN=GX2MNS
17470      GX2MAX=GX2MXS
17471      IY1MIN=IY1MNS
17472      IY1MAX=IY1MXS
17473      IY2MIN=IY2MNS
17474      IY2MAX=IY2MXS
17475      IX1MIN=IX1MNS
17476      IX1MAX=IX1MXS
17477      IX2MIN=IX2MNS
17478      IX2MAX=IX2MXS
17479      PX1ZDS=PX1ZD2
17480      PX2ZDS=PX2ZD2
17481      PY1ZDS=PY1ZD2
17482      PY2ZDS=PY2ZD2
17483      ISORSW=ISORS2
17484      IPPTBI=IPPTB2
17485C
17486      ICPLFR=ICPLFZ
17487C
17488      DO8500I=1,MAXCH
17489        IX1LTE(I)=IX1LT2(I)
17490        IX2LTE(I)=IX2LT2(I)
17491        IY1LTE(I)=IY1LT2(I)
17492        IY2LTE(I)=IY2LT2(I)
17493 8500 CONTINUE
17494      NCX1LA=NCX1L2
17495      NCX2LA=NCX2L2
17496      NCY1LA=NCY1L2
17497      NCY2LA=NCY2L2
17498C
17499      IFEEDB=IFEED9
17500C
17501      DO8809I=1,MAXCH
17502        ITITTE(I)=ITITSV(I)
17503 8809 CONTINUE
17504      NCTITL=NCTITS
17505      PTITDS=PTITDZ
17506C
17507      IOP='CLOS'
17508      CALL DPAUFI(IOP,IFLAG1,IFLAG2,IFLAG3,IFLAG4,IFLAG5,
17509     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
17510     1            IBUGG3,ISUBRO,IERROR)
17511      IF(IERROR.EQ.'YES')GOTO9000
17512      GOTO9000
17513C
17514C               *****************
17515C               **  STEP 90--  **
17516C               **  EXIT       **
17517C               *****************
17518C
17519 9000 CONTINUE
17520      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BITA')THEN
17521        WRITE(ICOUT,999)
17522        CALL DPWRST('XXX','BUG ')
17523        WRITE(ICOUT,9011)
17524 9011   FORMAT('***** AT THE END       OF DPBITA--')
17525        CALL DPWRST('XXX','BUG ')
17526        WRITE(ICOUT,9012)IFOUND,IERROR
17527 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
17528        CALL DPWRST('XXX','BUG ')
17529        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
17530 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
17531     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
17532        CALL DPWRST('XXX','BUG ')
17533        WRITE(ICOUT,9014)NUMARG
17534 9014   FORMAT('NUMARG = ',I8)
17535        CALL DPWRST('XXX','BUG ')
17536        IF(NUMARG.GT.0)THEN
17537          DO9021I=1,NUMARG
17538            WRITE(ICOUT,9022)I,IHARG(I),IARGT(I)
17539 9022       FORMAT('I,IHARG(I),IARGT(I) = ',I8,2X,A4,2X,A4)
17540            CALL DPWRST('XXX','BUG ')
17541 9021     CONTINUE
17542        ENDIF
17543      ENDIF
17544C
17545      RETURN
17546      END
17547      SUBROUTINE DPBKCL(IHARG,NUMARG,IDBKCO,IBKPCO,IFOUND,IERROR)
17548C
17549C     PURPOSE--DEFINE THE COLOR FOR THE 3-D BACKPLANE.
17550C              THE COLOR FOR THE BACKPLANE WILL BE PLACED
17551C              IN THE CHARACTER VARIABLE IBKPCO.
17552C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
17553C                     --NUMARG
17554C                     --IDBKCO
17555C     OUTPUT ARGUMENTS--IBKPCO
17556C                     --IFOUND ('YES' OR 'NO' )
17557C                     --IERROR ('YES' OR 'NO' )
17558C     NOTE--THIS SUBROUTINE ASSUMES A
17559C           COMPLICATED-TO-SIMPLE CHECKING ORDER
17560C           (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS.
17561C     WRITTEN BY--JAMES J. FILLIBEN
17562C                 STATISTICAL ENGINEERING DIVISION
17563C                 INFORMATION TECHNOLOGY LABORATORY
17564C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17565C                 GAITHERSBURG, MD 20899-8980
17566C                 PHONE--301-975-2855
17567C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17568C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17569C     LANGUAGE--ANSI FORTRAN (1977)
17570C     VERSION NUMBER--88/10
17571C     ORIGINAL VERSION--SEPTEMBER 1988.
17572C
17573C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17574C
17575      CHARACTER*4 IHARG
17576      CHARACTER*4 IDBKCO
17577      CHARACTER*4 IBKPCO
17578      CHARACTER*4 IFOUND
17579      CHARACTER*4 IERROR
17580C
17581C---------------------------------------------------------------------
17582C
17583      DIMENSION IHARG(*)
17584C
17585C---------------------------------------------------------------------
17586C
17587      INCLUDE 'DPCOP2.INC'
17588C
17589C-----START POINT-----------------------------------------------------
17590C
17591      IFOUND='NO'
17592      IERROR='NO'
17593C
17594      IF(NUMARG.EQ.0)GOTO1199
17595      IF(NUMARG.EQ.1)GOTO1150
17596C
17597      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
17598      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
17599      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
17600      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
17601      GOTO1160
17602C
17603 1150 CONTINUE
17604      IBKPCO=IDBKCO
17605      GOTO1180
17606C
17607 1160 CONTINUE
17608      IBKPCO=IHARG(NUMARG)
17609      GOTO1180
17610C
17611 1180 CONTINUE
17612      IFOUND='YES'
17613C
17614      IF(IFEEDB.EQ.'OFF')GOTO1189
17615      WRITE(ICOUT,999)
17616  999 FORMAT(1X)
17617      CALL DPWRST('XXX','BUG ')
17618      WRITE(ICOUT,1181)IBKPCO
17619 1181 FORMAT('THE (3-D) BACKPLANE COLOR ',
17620     1'HAS JUST BEEN SET TO ',A4)
17621      CALL DPWRST('XXX','BUG ')
17622 1189 CONTINUE
17623      GOTO1199
17624C
17625 1199 CONTINUE
17626      RETURN
17627      END
17628      SUBROUTINE DPBKGC(IHARG,NUMARG,IDBKGC,IBKPGC,IFOUND,IERROR)
17629C
17630C     PURPOSE--DEFINE THE COLOR FOR THE 3-D BACKPLANE GRID.
17631C              THE COLOR FOR THE BACKPLANE GRID WILL BE PLACED
17632C              IN THE CHARACTER VARIABLE IBKPGC.
17633C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
17634C                     --NUMARG
17635C                     --IDBKGC
17636C     OUTPUT ARGUMENTS--IBKPGC
17637C                     --IFOUND ('YES' OR 'NO' )
17638C                     --IERROR ('YES' OR 'NO' )
17639C     NOTE--THIS SUBROUTINE ASSUMES A
17640C           COMPLICATED-TO-SIMPLE CHECKING ORDER
17641C           (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS.
17642C     WRITTEN BY--JAMES J. FILLIBEN
17643C                 STATISTICAL ENGINEERING DIVISION
17644C                 INFORMATION TECHNOLOGY LABORATORY
17645C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17646C                 WASHINGPON, D. C. 20234
17647C                 PHONE--301-975-2855
17648C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17649C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17650C     LANGUAGE--ANSI FORTRAN (1977)
17651C     VERSION NUMBER--88/10
17652C     ORIGINAL VERSION--SEPTEMBER 1988.
17653C
17654C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17655C
17656      CHARACTER*4 IHARG
17657      CHARACTER*4 IDBKGC
17658      CHARACTER*4 IBKPGC
17659      CHARACTER*4 IFOUND
17660      CHARACTER*4 IERROR
17661C
17662C---------------------------------------------------------------------
17663C
17664      DIMENSION IHARG(*)
17665C
17666C---------------------------------------------------------------------
17667C
17668      INCLUDE 'DPCOP2.INC'
17669C
17670C-----START POINT-----------------------------------------------------
17671C
17672      IFOUND='NO'
17673      IERROR='NO'
17674C
17675      IF(NUMARG.LE.1)GOTO1199
17676      IF(NUMARG.EQ.2)GOTO1150
17677C
17678      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
17679      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
17680      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
17681      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
17682      GOTO1160
17683C
17684 1150 CONTINUE
17685      IBKPGC=IDBKGC
17686      GOTO1180
17687C
17688 1160 CONTINUE
17689      IBKPGC=IHARG(NUMARG)
17690      GOTO1180
17691C
17692 1180 CONTINUE
17693      IFOUND='YES'
17694C
17695      IF(IFEEDB.EQ.'OFF')GOTO1189
17696      WRITE(ICOUT,999)
17697  999 FORMAT(1X)
17698      CALL DPWRST('XXX','BUG ')
17699      WRITE(ICOUT,1181)IBKPGC
17700 1181 FORMAT('THE (3-D) BACKPLANE GRID COLOR ',
17701     1'HAS JUST BEEN SET TO ',A4)
17702      CALL DPWRST('XXX','BUG ')
17703 1189 CONTINUE
17704      GOTO1199
17705C
17706 1199 CONTINUE
17707      RETURN
17708      END
17709      SUBROUTINE DPBKGP(IHARG,NUMARG,IDBKGP,IBKPGP,IFOUND,IERROR)
17710C
17711C     PURPOSE--DEFINE THE PATTERN FOR THE 3-D BACKPLANE GRID.
17712C              THE PATTERN FOR THE BACKPLANE GRID WILL BE PLACED
17713C              IN THE CHARACTER VARIABLE IBKPGP.
17714C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
17715C                     --NUMARG
17716C                     --IDBKGP
17717C     OUTPUT ARGUMENTS--IBKPGP
17718C                     --IFOUND ('YES' OR 'NO' )
17719C                     --IERROR ('YES' OR 'NO' )
17720C     NOTE--THIS SUBROUTINE ASSUMES A
17721C           COMPLICATED-TO-SIMPLE CHECKING ORDER
17722C           (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS.
17723C     WRITTEN BY--JAMES J. FILLIBEN
17724C                 STATISTICAL ENGINEERING DIVISION
17725C                 INFORMATION TECHNOLOGY LABORATORY
17726C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17727C                 WASHINGPON, D. C. 20234
17728C                 PHONE--301-975-2855
17729C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17730C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17731C     LANGUAGE--ANSI FORTRAN (1977)
17732C     VERSION NUMBER--88/10
17733C     ORIGINAL VERSION--SEPTEMBER 1988.
17734C
17735C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17736C
17737      CHARACTER*4 IHARG
17738      CHARACTER*4 IDBKGP
17739      CHARACTER*4 IBKPGP
17740      CHARACTER*4 IFOUND
17741      CHARACTER*4 IERROR
17742C
17743C---------------------------------------------------------------------
17744C
17745      DIMENSION IHARG(*)
17746C
17747C---------------------------------------------------------------------
17748C
17749      INCLUDE 'DPCOP2.INC'
17750C
17751C-----START POINT-----------------------------------------------------
17752C
17753      IFOUND='NO'
17754      IERROR='NO'
17755C
17756      IF(NUMARG.LE.1)GOTO1199
17757      IF(NUMARG.EQ.2)GOTO1160
17758C
17759      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
17760      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
17761      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
17762      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170
17763      GOTO1175
17764C
17765 1150 CONTINUE
17766      IBKPGP='SOLI'
17767      GOTO1180
17768C
17769 1160 CONTINUE
17770      IBKPGP='BLAN'
17771      GOTO1180
17772C
17773 1170 CONTINUE
17774      IBKPGP=IDBKGP
17775      GOTO1180
17776C
17777 1175 CONTINUE
17778      IBKPGP=IHARG(NUMARG)
17779      GOTO1180
17780C
17781 1180 CONTINUE
17782      IFOUND='YES'
17783C
17784      IF(IFEEDB.EQ.'OFF')GOTO1189
17785      WRITE(ICOUT,999)
17786  999 FORMAT(1X)
17787      CALL DPWRST('XXX','BUG ')
17788      WRITE(ICOUT,1181)IBKPGP
17789 1181 FORMAT('THE (3-D) BACKPLANE GRID PATTERN ',
17790     1'HAS JUST BEEN SET TO ',A4)
17791      CALL DPWRST('XXX','BUG ')
17792 1189 CONTINUE
17793      GOTO1199
17794C
17795 1199 CONTINUE
17796      RETURN
17797      END
17798      SUBROUTINE DPBKGR(IHARG,NUMARG,IDBKGR,IBKPGR,IFOUND,IERROR)
17799C
17800C     PURPOSE--DEFINE THE 3-D BACKPLANE GRID SWITCH IBKPGR.
17801C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
17802C                     --NUMARG
17803C                     --IDBKGR
17804C     OUTPUT ARGUMENTS--IBKPGR   ('ON'  OR 'OFF')
17805C                     --IFOUND ('YES' OR 'NO' )
17806C                     --IERROR ('YES' OR 'NO' )
17807C     NOTE--THIS SUBROUTINE ASSUMES A
17808C           COMPLICATED-TO-SIMPLE CHECKING ORDER
17809C           (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS.
17810C     WRITTEN BY--JAMES J. FILLIBEN
17811C                 STATISTICAL ENGINEERING DIVISION
17812C                 INFORMATION TECHNOLOGY LABORATORY
17813C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17814C                 GAITHERSBURG, MD 20899-8980
17815C                 PHONE--301-975-2855
17816C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17817C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17818C     LANGUAGE--ANSI FORTRAN (1977)
17819C     VERSION NUMBER--88/10
17820C     ORIGINAL VERSION--SEPTEMBER 1988.
17821C
17822C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17823C
17824      CHARACTER*4 IHARG
17825      CHARACTER*4 IDBKGR
17826      CHARACTER*4 IBKPGR
17827      CHARACTER*4 IFOUND
17828      CHARACTER*4 IERROR
17829C
17830C---------------------------------------------------------------------
17831C
17832      DIMENSION IHARG(*)
17833C
17834C---------------------------------------------------------------------
17835C
17836      INCLUDE 'DPCOP2.INC'
17837C
17838C-----START POINT-----------------------------------------------------
17839C
17840      IFOUND='NO'
17841      IERROR='NO'
17842C
17843      IF(NUMARG.EQ.0)GOTO1199
17844      IF(NUMARG.EQ.1)GOTO1150
17845C
17846      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
17847      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
17848      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
17849      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170
17850      GOTO1199
17851C
17852 1150 CONTINUE
17853      IBKPGR='ON'
17854      GOTO1180
17855C
17856 1160 CONTINUE
17857      IBKPGR='OFF'
17858      GOTO1180
17859C
17860 1170 CONTINUE
17861      IBKPGR=IDBKGR
17862      GOTO1180
17863C
17864 1180 CONTINUE
17865      IFOUND='YES'
17866C
17867      IF(IFEEDB.EQ.'OFF')GOTO1189
17868      WRITE(ICOUT,999)
17869  999 FORMAT(1X)
17870      CALL DPWRST('XXX','BUG ')
17871      WRITE(ICOUT,1181)IBKPGR
17872 1181 FORMAT('THE (3-D) BACKPLANE GRID SWITCH ',
17873     1'HAS JUST BEEN SET TO ',A4)
17874      CALL DPWRST('XXX','BUG ')
17875 1189 CONTINUE
17876      GOTO1199
17877C
17878 1199 CONTINUE
17879      RETURN
17880      END
17881      SUBROUTINE DPBKP(IHARG,NUMARG,IBKPSW,IFOUND,IERROR)
17882C
17883C     PURPOSE--DEFINE THE 3-D BACKPLANE SWITCH IBKPSW.
17884C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
17885C                     --NUMARG
17886C     OUTPUT ARGUMENTS--IBKPSW   ('ON'  OR 'OFF')
17887C                     --IFOUND ('YES' OR 'NO' )
17888C                     --IERROR ('YES' OR 'NO' )
17889C     NOTE--THIS SUBROUTINE ASSUMES A
17890C           COMPLICATED-TO-SIMPLE CHECKING ORDER
17891C           (IN MAIPC4) OF THE VARIOUS BACKPLANE COMMANDS.
17892C     WRITTEN BY--JAMES J. FILLIBEN
17893C                 STATISTICAL ENGINEERING DIVISION
17894C                 INFORMATION TECHNOLOGY LABORATORY
17895C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17896C                 GAITHERSBURG, MD 20899-8980
17897C                 PHONE--301-975-2855
17898C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17899C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17900C     LANGUAGE--ANSI FORTRAN (1977)
17901C     VERSION NUMBER--88/10
17902C     ORIGINAL VERSION--SEPTEMBER 1988.
17903C
17904C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
17905C
17906      CHARACTER*4 IHARG
17907      CHARACTER*4 IBKPSW
17908      CHARACTER*4 IFOUND
17909      CHARACTER*4 IERROR
17910C
17911C---------------------------------------------------------------------
17912C
17913      DIMENSION IHARG(*)
17914C
17915C---------------------------------------------------------------------
17916C
17917      INCLUDE 'DPCOP2.INC'
17918C
17919C-----START POINT-----------------------------------------------------
17920C
17921      IFOUND='NO'
17922      IERROR='NO'
17923C
17924      IF(NUMARG.EQ.0)GOTO1150
17925C
17926      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
17927      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
17928      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
17929      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160
17930      GOTO1199
17931C
17932 1150 CONTINUE
17933      IBKPSW='ON'
17934      GOTO1180
17935C
17936 1160 CONTINUE
17937      IBKPSW='OFF'
17938      GOTO1180
17939C
17940 1180 CONTINUE
17941      IFOUND='YES'
17942C
17943      IF(IFEEDB.EQ.'OFF')GOTO1189
17944      WRITE(ICOUT,999)
17945  999 FORMAT(1X)
17946      CALL DPWRST('XXX','BUG ')
17947      WRITE(ICOUT,1181)IBKPSW
17948 1181 FORMAT('THE (3-D) BACKPLANE SWITCH ',
17949     1'HAS JUST BEEN SET TO ',A4)
17950      CALL DPWRST('XXX','BUG ')
17951 1189 CONTINUE
17952      GOTO1199
17953C
17954 1199 CONTINUE
17955      RETURN
17956      END
17957      SUBROUTINE DPBLOC(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
17958CCCCC                   MARCH 1995.  ADD MAXNXT TO ARGUMENT LIST
17959     1                  BARHEF,BARWEF,MAXNXT,ISEED,ICHMAP,ICONT,
17960     1                  IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
17961C
17962C     PURPOSE--GENERATE A BLOCK PLOT
17963C
17964C     WRITTEN BY--JAMES J. FILLIBEN
17965C                 NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY
17966C                 GAITHERSBURG, MARYLAND 20899
17967C                 PHONE--301-975-2855
17968C                 INFORMATION TECHNOLOGY LABORATORY
17969C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
17970C                 GAITHERSBURG, MD 20899-8980
17971C                 PHONE--301-975-2855
17972C     SYNTAX FOR COMMAND (MUST HAVE 3 OR MORE ARGUMENTS)--
17973C           BLOCK PLOT Y <SEQ. OF VAR. DEFINING HOR. AXIS> CHAR-VAR.
17974C     EXAMPLES--
17975C           BLOCK PLOT Y BOY MAT
17976C           BLOCK PLOT Y X1 X2  MAD AND AAD PLOTS
17977C           BLOCK PLOT Y CONC QUENCH OVEN
17978C           BLOCK PLOT Y    X2 X3    X1
17979C           BLOCK PLOT Y    X2 X3 X4 X5 X6 X7    X1
17980C     NOTE--MAX NUMBER OF NUISANCE FACTORS = 20
17981C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
17982C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
17983C     LANGUAGE--ANSI FORTRAN (1977)
17984C     VERSION NUMBER--92/5
17985C     ORIGINAL VERSION--MAY       1992.
17986C     UPDATED         --MARCH     1995.  MAD AND AAD PLOTS
17987C     UPDATED         --MARCH     2002. ADD ROBUSTNESS PLOT AS
17988C                                       SYNONYM FOR BLOCK PLOT
17989C     UPDATED         --AUGUST    2002. USE "CMPSTA" TO COMPUTE
17990C                                       STATISTICS, EXPAND LIST OF
17991C                                       SUPPORTED STATISTICS
17992C     UPDATED         --APRIL     2003. ADD SN AND QN (ROBUST SCALE
17993C                                       STATISTICS)
17994C     UPDATED         --MAY       2007. ADD TRIMMED STAND DEVI
17995C     UPDATED         --NOVEMBER  2007. LP LOCATION
17996C     UPDATED         --NOVEMBER  2007. VARIANCE OF LP LOCATION
17997C     UPDATED         --NOVEMBER  2007. SD OF LP LOCATION
17998C     UPDATED         --SEPTEMBER 2008. BINOMIAL PROBABILITY
17999C     UPDATED         --FEBRUARY  2009. INDEX MINIMUM
18000C     UPDATED         --FEBRUARY  2009. INDEX MAXIMUM
18001C     UPDATED         --FEBRUARY  2009. INDEX EXTREME
18002C     UPDATED         --FEBRUARY  2009. GRUBB
18003C                                       GRUBB CDF
18004C                                       GRUBB DIRECTION
18005C                                       GRUBB INDEX
18006C     UPDATED         --FEBRUARY  2009. ONE SAMPLE T TEST
18007C                                       ONE SAMPLE T TEST CDF
18008C     UPDATED         --FEBRUARY  2009. CHI-SQUARE SD TEST
18009C                                       CHI-SQUARE SD TEST CDF
18010C     UPDATED         --FEBRUARY  2009. FREQUENCY TEST
18011C                                       FREQUENCY TEST CDF
18012C     UPDATED         --FEBRUARY  2009. FREQUENCY WITHIN A BLOCK TEST
18013C                                       FREQUENCY WITHIN A BLOCK TEST CDF
18014C     UPDATED         --MARCH     2009. PARSE WITH EXTSTA
18015C     UPDATED         --APRIL     2009. USE DPPARS ROUTINE
18016C     UPDATED         --JUNE      2010. CMPSTA NOW ACCOMODATES 3
18017C                                       RESPONSE VARIABLES
18018C     UPDATED         --APRIL     2012. SUPPORT FOR FIXED WIDTH BARS
18019C     UPDATED         --APRIL     2012. SUPPORT FOR FILTERING WHEN
18020C                                       ONLY ONE VALUE FOR A PARTICULAR
18021C                                       COMBINATION OF FACTOR LEVELS
18022C     UPDATED         --DECEMBER  2012. BUG FIX INTRODUCDED WITH 4/2012
18023C                                       UPDATES
18024C     UPDATED         --DECEMBER  2012. SUPPORT FOR "BACKGROUND" FOR
18025C                                       BLOCKS
18026C     UPDATED         --NOVEMBER  2016. SUPPORT FOR "JITTER"
18027C     UPDATED         --MARCH     2019. ADD ICHMAP TO CALL LIST
18028C     UPDATED         --JULY      2019. TWEAK SCRATCH SPACE
18029C
18030C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18031C
18032      CHARACTER*4 ICASPL
18033      CHARACTER*4 IAND1
18034      CHARACTER*4 IAND2
18035      CHARACTER*4 ICHMAP
18036      CHARACTER*4 ICONT
18037      CHARACTER*4 IBUGG2
18038      CHARACTER*4 IBUGG3
18039      CHARACTER*4 IBUGQ
18040      CHARACTER*4 ISUBRO
18041      CHARACTER*4 IFOUND
18042      CHARACTER*4 IERROR
18043C
18044      PARAMETER (MAXSPN=30)
18045      CHARACTER*4 IVARN1(MAXSPN)
18046      CHARACTER*4 IVARN2(MAXSPN)
18047      CHARACTER*4 IVARTY(MAXSPN)
18048      REAL PVAR(MAXSPN)
18049      INTEGER ILIS(MAXSPN)
18050      INTEGER NRIGHT(MAXSPN)
18051      INTEGER ICOLR(MAXSPN)
18052C
18053      CHARACTER*40 INAME
18054      CHARACTER*4  ISTADF
18055      CHARACTER*60 ISTANM
18056C
18057      CHARACTER*4 ISUBN1
18058      CHARACTER*4 ISUBN2
18059      CHARACTER*4 ISTEPN
18060      CHARACTER*4 IWRITE
18061C
18062C---------------------------------------------------------------------
18063C
18064      INCLUDE 'DPCOPA.INC'
18065C
18066      DIMENSION Y1(MAXOBV)
18067      DIMENSION X1(MAXOBV)
18068      DIMENSION TAG(MAXOBV)
18069      DIMENSION TEMP(MAXOBV)
18070      DIMENSION TEMP2(MAXOBV)
18071      DIMENSION TEMP3(MAXOBV)
18072C
18073      DIMENSION Y2(MAXOBV)
18074      DIMENSION X2(MAXOBV)
18075      DIMENSION TAG2(MAXOBV)
18076      DIMENSION TAG9(MAXOBV)
18077      DIMENSION DTAG(MAXOBV)
18078      DIMENSION DTAG2(MAXOBV)
18079      DIMENSION DTAG9(MAXOBV)
18080      DIMENSION DIST(MAXOBV)
18081      DIMENSION DISTLA(MAXOBV)
18082      DIMENSION DISTL2(MAXOBV)
18083C
18084      DIMENSION XTEMP1(MAXOBV)
18085      DIMENSION XTEMP2(MAXOBV)
18086      DIMENSION XTEMP3(MAXOBV)
18087      DIMENSION X2JITT(MAXOBV)
18088C
18089      INTEGER ITEMP1(MAXOBV)
18090      INTEGER ITEMP2(MAXOBV)
18091      INTEGER ITEMP3(MAXOBV)
18092      INTEGER ITEMP4(MAXOBV)
18093      INTEGER ITEMP5(MAXOBV)
18094      INTEGER ITEMP6(MAXOBV)
18095      DOUBLE PRECISION DTEMP1(MAXOBV)
18096      DOUBLE PRECISION DTEMP2(MAXOBV)
18097      DOUBLE PRECISION DTEMP3(MAXOBV)
18098C
18099      INCLUDE 'DPCOZZ.INC'
18100      INCLUDE 'DPCOZI.INC'
18101      INCLUDE 'DPCOZD.INC'
18102      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
18103      EQUIVALENCE (GARBAG(IGARB2),X1(1))
18104      EQUIVALENCE (GARBAG(IGARB4),TAG(1))
18105      EQUIVALENCE (GARBAG(IGARB5),TEMP(1))
18106      EQUIVALENCE (GARBAG(IGARB6),TEMP2(1))
18107      EQUIVALENCE (GARBAG(IGARB7),DIST(1))
18108      EQUIVALENCE (GARBAG(IGARB8),Y2(1))
18109      EQUIVALENCE (GARBAG(IGARB9),X2(1))
18110      EQUIVALENCE (GARBAG(IGAR10),TAG2(1))
18111      EQUIVALENCE (GARBAG(JGAR11),DTAG(1))
18112      EQUIVALENCE (GARBAG(JGAR12),DTAG2(1))
18113      EQUIVALENCE (GARBAG(JGAR13),XTEMP1(1))
18114      EQUIVALENCE (GARBAG(JGAR14),XTEMP2(1))
18115      EQUIVALENCE (GARBAG(JGAR15),XTEMP3(1))
18116      EQUIVALENCE (GARBAG(JGAR16),DTAG9(1))
18117      EQUIVALENCE (GARBAG(JGAR17),TEMP3(1))
18118      EQUIVALENCE (GARBAG(JGAR18),TAG9(1))
18119      EQUIVALENCE (GARBAG(JGAR19),DISTLA(1))
18120      EQUIVALENCE (GARBAG(JGAR20),DISTL2(1))
18121      EQUIVALENCE (GARBAG(IGAR11),X2JITT(1))
18122C
18123      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
18124      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
18125      EQUIVALENCE (IGARBG(IIGAR3),ITEMP3(1))
18126      EQUIVALENCE (IGARBG(IIGAR4),ITEMP4(1))
18127      EQUIVALENCE (IGARBG(IIGAR5),ITEMP5(1))
18128      EQUIVALENCE (IGARBG(IIGAR6),ITEMP6(1))
18129      EQUIVALENCE (DGARBG(IDGAR1),DTEMP1(1))
18130      EQUIVALENCE (DGARBG(IDGAR2),DTEMP2(1))
18131      EQUIVALENCE (DGARBG(IDGAR3),DTEMP3(1))
18132C
18133C-----COMMON----------------------------------------------------------
18134C
18135      INCLUDE 'DPCOHK.INC'
18136      INCLUDE 'DPCODA.INC'
18137      INCLUDE 'DPCOST.INC'
18138C
18139C-----COMMON VARIABLES (GENERAL)--------------------------------------
18140C
18141      INCLUDE 'DPCOP2.INC'
18142C
18143C-----START POINT-----------------------------------------------------
18144C
18145      IERROR='NO'
18146      ISUBN1='DPBL'
18147      ISUBN2='OC  '
18148C
18149      MAXCP1=MAXCOL+1
18150      MAXCP2=MAXCOL+2
18151      MAXCP3=MAXCOL+3
18152      MAXCP4=MAXCOL+4
18153      MAXCP5=MAXCOL+5
18154      MAXCP6=MAXCOL+6
18155C
18156C               *********************************
18157C               **  TREAT THE BLOCK PLOT CASE  **
18158C               *********************************
18159C
18160      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BLOC')THEN
18161        WRITE(ICOUT,999)
18162  999   FORMAT(1X)
18163        CALL DPWRST('XXX','BUG ')
18164        WRITE(ICOUT,51)
18165   51   FORMAT('***** AT THE BEGINNING OF DPBLOC--')
18166        CALL DPWRST('XXX','BUG ')
18167        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,ISUBRO
18168   52   FORMAT('ICASPL,IAND1,IAND2,ISUBRO = ',A4,2X,A4,2X,A4,2X,A4)
18169        CALL DPWRST('XXX','BUG ')
18170        WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ
18171   53   FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',A4,2X,A4,2X,A4,2X,A4)
18172        CALL DPWRST('XXX','BUG ')
18173        WRITE(ICOUT,54)BARHEF,BARWEF
18174   54   FORMAT('BARHEF,BARWEF = ',2G15.7)
18175        CALL DPWRST('XXX','BUG ')
18176      ENDIF
18177C
18178C               ***************************
18179C               **  STEP 1--             **
18180C               **  EXTRACT THE COMMAND  **
18181C               ***************************
18182C
18183      ISTEPN='1'
18184      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BLOC')
18185     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18186C
18187      IF(NUMARG.LE.1)GOTO9000
18188C
18189      ICASPL='RAW '
18190      IFOUND='YES'
18191      IF(ICOM.EQ.'BLOC'.OR.ICOM.EQ.'ROBU')THEN
18192         ICASPL='RAW '
18193         ILASTC=1
18194      ELSE
18195C
18196C       MARCH 2009: USE EXTSTA TO PARSE STATISTIC
18197C
18198        JMIN=0
18199        JMAX=NUMARG
18200C
18201        DO200I=1,NUMARG-1
18202          IF((IHARG(I).EQ.'BLOC'.OR.IHARG(I).EQ.'ROBU') .AND.
18203     1        IHARG(I+1).EQ.'PLOT')THEN
18204            JMAX=I-1
18205            ILASTC=I+1
18206            GOTO209
18207          ENDIF
18208  200   CONTINUE
18209        IFOUND='NO'
18210        GOTO9000
18211  209   CONTINUE
18212C
18213        CALL EXTSTA(ICOM,ICOM2,IHARG,IHARG2,IARGT,ARG,NUMARG,JMIN,JMAX,
18214     1              ICASPL,ISTANM,ISTANR,ISTADF,IFOUND,ILOCV,
18215     1              ISUBRO,IBUGG3,IERROR)
18216C
18217        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BLOC')THEN
18218          WRITE(ICOUT,999)
18219          CALL DPWRST('XXX','BUG ')
18220          WRITE(ICOUT,251)
18221  251     FORMAT('***** AFTER CALL EXTSTA--')
18222          CALL DPWRST('XXX','BUG ')
18223          WRITE(ICOUT,252)ICASPL,ISTANR,ILOCV,IFOUND
18224  252     FORMAT('ICASPL,ISTANR,ILOCV,IFOUND = ',A4,2I8,2X,A4)
18225          CALL DPWRST('XXX','BUG ')
18226        ENDIF
18227C
18228        IF(ISTANR.GE.2)IFOUND='NO'
18229        IF(IFOUND.EQ.'NO')GOTO9000
18230      ENDIF
18231      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
18232C
18233C               *********************************
18234C               **  STEP 2--                   **
18235C               **  EXTRACT THE VARIABLE LIST  **
18236C               *********************************
18237C
18238      ISTEPN='2'
18239      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BLOC')
18240     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18241C
18242      INAME='BLOCK PLOT'
18243      MINNA=3
18244      MAXNA=100
18245      MINN2=2
18246      IFLAGE=1
18247      IFLAGM=0
18248      IFLAGP=0
18249      JMIN=1
18250      JMAX=NUMARG
18251      MINNVA=-99
18252      MAXNVA=-99
18253C
18254      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
18255     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
18256     1            JMIN,JMAX,
18257     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
18258     1            IVARN1,IVARN2,IVARTY,PVAR,
18259     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
18260     1            MINNVA,MAXNVA,
18261     1            IFLAGM,IFLAGP,
18262     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
18263      IF(IERROR.EQ.'YES')GOTO9000
18264C
18265      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BLOC')THEN
18266        WRITE(ICOUT,999)
18267        CALL DPWRST('XXX','BUG ')
18268        WRITE(ICOUT,281)
18269  281   FORMAT('***** AFTER CALL DPPARS--')
18270        CALL DPWRST('XXX','BUG ')
18271        WRITE(ICOUT,282)NQ,NUMVAR
18272  282   FORMAT('NQ,NUMVAR = ',2I8)
18273        CALL DPWRST('XXX','BUG ')
18274        IF(NUMVAR.GT.0)THEN
18275          DO285I=1,NUMVAR
18276            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
18277     1                      ICOLR(I)
18278  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
18279     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
18280            CALL DPWRST('XXX','BUG ')
18281  285     CONTINUE
18282        ENDIF
18283      ENDIF
18284C
18285C               *********************************
18286C               **  STEP 3--                   **
18287C               **  EXTRACT THE DATA           **
18288C               *********************************
18289C
18290      ISTEPN='3'
18291      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BLOC')
18292     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18293C
18294C
18295C     STEP 3A--EXTRACT THE VERTICAL AXIS AND TAG VARIABLES
18296C
18297      ICOLV=ICOLR(1)
18298      ICOLT=ICOLR(NUMVAR)
18299      IMAX=NQ
18300      J=0
18301      DO660I=1,IMAX
18302         IF(ISUB(I).EQ.1)THEN
18303C
18304            J=J+1
18305            IJ=MAXN*(ICOLV-1)+I
18306            IF(ICOLV.LE.MAXCOL)Y1(J)=V(IJ)
18307            IF(ICOLV.EQ.MAXCP1)Y1(J)=PRED(I)
18308            IF(ICOLV.EQ.MAXCP2)Y1(J)=RES(I)
18309            IF(ICOLV.EQ.MAXCP3)Y1(J)=YPLOT(I)
18310            IF(ICOLV.EQ.MAXCP4)Y1(J)=XPLOT(I)
18311            IF(ICOLV.EQ.MAXCP5)Y1(J)=X2PLOT(I)
18312            IF(ICOLV.EQ.MAXCP6)Y1(J)=TAGPLO(I)
18313C
18314            IJ=MAXN*(ICOLT-1)+I
18315            IF(ICOLT.LE.MAXCOL)XTEMP1(J)=V(IJ)
18316            IF(ICOLT.EQ.MAXCP1)XTEMP1(J)=PRED(I)
18317            IF(ICOLT.EQ.MAXCP2)XTEMP1(J)=RES(I)
18318            IF(ICOLT.EQ.MAXCP3)XTEMP1(J)=YPLOT(I)
18319            IF(ICOLT.EQ.MAXCP4)XTEMP1(J)=XPLOT(I)
18320            IF(ICOLT.EQ.MAXCP5)XTEMP1(J)=X2PLOT(I)
18321            IF(ICOLT.EQ.MAXCP6)XTEMP1(J)=TAGPLO(I)
18322C
18323         ENDIF
18324  660 CONTINUE
18325      NLOCAL=J
18326C
18327C     2013/06: CODE THE PRIMARY VARIABLE
18328C     2019/03: TURN OFF CODING IF CHARACTER MAPPING
18329C              SET TO EXACT
18330C
18331      IF(ICHMAP.EQ.'EXAC')THEN
18332        DO662II=1,NLOCAL
18333          TAG(II)=XTEMP1(II)
18334  662   CONTINUE
18335      ELSE
18336        IWRITE='OFF'
18337        CALL CODE(XTEMP1,NLOCAL,IWRITE,TAG,XTEMP2,MAXOBV,
18338     1            IBUGG3,IERROR)
18339      ENDIF
18340C
18341C     STEP 3B--FORM THE HORIZONTAL AXIS VARIABLE
18342C              BY COMBINING ALL NUISANCE AXIS VARIABLES
18343C
18344      SHRINK=0.20
18345      NUMV2M=NUMVAR-1
18346      DO680K=2,NUMV2M
18347C
18348         IF(K.GE.3)THEN
18349            CALL DISTIN(X1,NLOCAL,'OFF ',DIST,NDIST,IBUGG3,IERROR)
18350            CALL SORT(DIST,NDIST,DIST)
18351            DELMIN=CPUMAX
18352            NDISTM=NDIST-1
18353            DO682I=1,NDISTM
18354               IP1=I+1
18355               DEL=DIST(IP1)-DIST(I)
18356               IF(DEL.LT.DELMIN)DELMIN=DEL
18357  682       CONTINUE
18358         ENDIF
18359C
18360         ICOLH=ICOLR(K)
18361         J=0
18362         DO684I=1,IMAX
18363            IF(ISUB(I).EQ.1)THEN
18364               J=J+1
18365               IJ=MAXN*(ICOLH-1)+I
18366               IF(ICOLH.LE.MAXCOL)TEMP(J)=V(IJ)
18367               IF(ICOLH.EQ.MAXCP1)TEMP(J)=PRED(I)
18368               IF(ICOLH.EQ.MAXCP2)TEMP(J)=RES(I)
18369               IF(ICOLH.EQ.MAXCP3)TEMP(J)=YPLOT(I)
18370               IF(ICOLH.EQ.MAXCP4)TEMP(J)=XPLOT(I)
18371               IF(ICOLH.EQ.MAXCP5)TEMP(J)=X2PLOT(I)
18372               IF(ICOLH.EQ.MAXCP6)TEMP(J)=TAGPLO(I)
18373            ENDIF
18374  684    CONTINUE
18375         NTEMP=J
18376C
18377C        FOR LAST NUISANCE VARIABLE, CREATE A CODED VALUE THAT CAN
18378C        USED TO LABEL THE INDIVIDUAL BLOCKS.
18379C
18380         IF(K.EQ.NUMV2M)THEN
18381            IWRITE='OFF'
18382            CALL CODE(TEMP,NTEMP,IWRITE,DISTL2,XTEMP1,MAXOBV,
18383     1                IBUGG3,IERROR)
18384            CALL MAXIM(DISTL2,NTEMP,IWRITE,XMAX,IBUGG3,IERROR)
18385            NLABEL=INT(XMAX+0.1)
18386C
18387            IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BLOC')THEN
18388              DO710II=1,NTEMP
18389                WRITE(ICOUT,712)II,TEMP(II),DISTL2(II)
18390  712           FORMAT('II,TEMP(II),DISTL2(II) = ',I8,2G15.7)
18391                CALL DPWRST('XXX','BUG ')
18392  710         CONTINUE
18393              WRITE(ICOUT,715)NLABEL
18394  715         FORMAT('NLABEL = ',I8)
18395              CALL DPWRST('XXX','BUG ')
18396           ENDIF
18397C
18398         ENDIF
18399C
18400         IF(K.EQ.2)THEN
18401            DO686I=1,NTEMP
18402               X1(I)=TEMP(I)
18403  686       CONTINUE
18404         ELSE
18405C
18406            CALL MINIM(TEMP,NTEMP,'OFF ',XMIN,IBUGG3,IERROR)
18407            CALL MAXIM(TEMP,NTEMP,'OFF ',XMAX,IBUGG3,IERROR)
18408            DENOM=XMAX-XMIN
18409C
18410            IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BLOC')THEN
18411              WRITE(ICOUT,687)K,DENOM,DELMIN,SHRINK
18412  687         FORMAT('K,DENOM,DELMIN,SHRINK = ',I8,3G15.7)
18413              CALL DPWRST('XXX','BUG ')
18414            ENDIF
18415C
18416            DO688I=1,NTEMP
18417               TEMP(I)=2.0*((TEMP(I)-XMIN)/DENOM)-1.0
18418               TEMP(I)=TEMP(I)*DELMIN
18419               TEMP(I)=TEMP(I)*SHRINK
18420               X1(I)=X1(I)+TEMP(I)
18421  688       CONTINUE
18422         ENDIF
18423  680 CONTINUE
18424C
18425C               ********************************************************
18426C               **  STEP 8--                                          **
18427C               **  COMPUTE THE APPROPRIATE BLOCK PLOT                **
18428C               **  FORM THE VERTICAL AND HORIZONTAL AXIS             **
18429C               **  VALUES Y(.) AND X(.) FOR THE PLOT.                **
18430C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S       **
18431C               **  FORM THE PLOTTED VALUE AND THE SURROUNDING BAR.   **
18432C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).     **
18433C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).     **
18434C               ********************************************************
18435C
18436      ISTEPN='8'
18437      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BLOC')
18438     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18439C
18440      CALL DPBLO2(Y1,X1,TAG,NLOCAL,ICASPL,
18441     1            DIST,Y2,X2,TAG2,DTAG,DTAG2,TAG9,DTAG9,
18442     1            TEMP,TEMP2,TEMP3,
18443     1            XTEMP1,XTEMP2,XTEMP3,X2JITT,
18444     1            DISTL2,DISTLA,NLABEL,
18445     1            ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
18446     1            DTEMP1,DTEMP2,DTEMP3,
18447     1            BARHEF,BARWEF,MAXNXT,IBPLFI,PBPLWI,IBPLLA,IBPLBG,
18448     1            ISEED,
18449     1            Y,X,D,NPLOTP,NPLOTV,IBUGG3,ISUBRO,IERROR)
18450C
18451C               **************************************************
18452C               **  STEP 9--                                    **
18453C               **  REDEFINE ICASPL FOR USE                     **
18454C               **  IN THE    PLOTGE   SUBROUTINE               **
18455C               **************************************************
18456C
18457      ICASPL='BLPL'
18458C
18459C               *****************
18460C               **  STEP 90--  **
18461C               **  EXIT       **
18462C               *****************
18463C
18464 9000 CONTINUE
18465      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BLOC')THEN
18466        WRITE(ICOUT,999)
18467        CALL DPWRST('XXX','BUG ')
18468        WRITE(ICOUT,9011)
18469 9011   FORMAT('***** AT THE END       OF DPBLOC--')
18470        CALL DPWRST('XXX','BUG ')
18471        WRITE(ICOUT,9012)IFOUND,ISUBRO,IERROR
18472 9012   FORMAT('IFOUND,ISUBRO,IERROR = ',2(A4,2X),A4)
18473        CALL DPWRST('XXX','BUG ')
18474        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
18475 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
18476     1         3I8,3(2X,A4))
18477        CALL DPWRST('XXX','BUG ')
18478        WRITE(ICOUT,9014)BARHEF,BARWEF,PBPLWI,IBPLFI
18479 9014   FORMAT('BARHEF,BARWEF,PBPLWI,IBPLFI = ',3G15.7,2X,A4)
18480        CALL DPWRST('XXX','BUG ')
18481        IF(NPLOTP.GT.0)THEN
18482          DO9015I=1,NPLOTP
18483            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
18484 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
18485            CALL DPWRST('XXX','BUG ')
18486 9015     CONTINUE
18487        ENDIF
18488      ENDIF
18489C
18490      RETURN
18491      END
18492      SUBROUTINE DPBLO2(Y,X,TAG,N,ICASPL,
18493     1            DIST,Y2,X2,TAG2,DTAG,DTAG2,TAG9,DTAG9,
18494     1            TEMP,TEMP2,TEMP3,
18495     1            XTEMP1,XTEMP2,XTEMP3,X2JITT,
18496     1            DISTL2,DISTLA,NLABEL,
18497     1            ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
18498     1            DTEMP1,DTEMP2,DTEMP3,
18499     1            BARHEF,BARWEF,MAXNXT,IBPLFI,PBPLWI,IBPLLA,IBPLBG,
18500     1            ISEED,
18501     1            Y3,X3,D3,N3,NPLOTV,IBUGG3,ISUBRO,IERROR)
18502C
18503C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
18504C              THAT WILL DEFINE A BLOCK PLOT
18505C     WRITTEN BY--JAMES J. FILLIBEN
18506C                 NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY
18507C                 GAITHERSBURG, MARYLAND 20899
18508C                 PHONE--301-975-2855
18509C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
18510C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
18511C     ORIGINAL VERSION--MAY      1992
18512C     UPDATED         --MARCH    1995 MAXNXT TO ARGUMENT LIST
18513C     UPDATED         --JUNE     1995 FIX VERTICES JUNK
18514C     UPDATED         --APRIL    2012 SUPPORT FOR FIXED WIDTH BARS
18515C     UPDATED         --APRIL    2012 SUPPORT FOR FILTERING WHEN
18516C                                     ONLY ONE VALUE FOR A PARTICULAR
18517C                                     COMBINATION OF FACTOR LEVELS
18518C     UPDATED         --APRIL    2012 SUPPORT FOR LABELING LAST NUISANCE
18519C                                     VARIABLE (USEFUL FOR FILTERING CASE)
18520C     UPDATED         --NOVEMBER 2016 SUPPORT FOR "JITTERING"
18521C
18522C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
18523C
18524      CHARACTER*4 ICASPL
18525      CHARACTER*4 IBPLFI
18526      CHARACTER*4 IBPLLA
18527      CHARACTER*4 IBPLBG
18528      CHARACTER*4 IBUGG3
18529      CHARACTER*4 ISUBRO
18530      CHARACTER*4 IERROR
18531C
18532      CHARACTER*4 ISUBN1
18533      CHARACTER*4 ISUBN2
18534      CHARACTER*4 ISTEPN
18535C
18536C---------------------------------------------------------------------
18537C
18538      DIMENSION Y(*)
18539      DIMENSION X(*)
18540      DIMENSION TAG(*)
18541C
18542      DIMENSION Y3(*)
18543      DIMENSION X3(*)
18544      DIMENSION D3(*)
18545C
18546      DIMENSION DIST(*)
18547      DIMENSION DISTL2(*)
18548      DIMENSION DISTLA(*)
18549C
18550      DIMENSION Y2(*)
18551      DIMENSION X2(*)
18552      DIMENSION TAG2(*)
18553C
18554      DIMENSION DTAG(*)
18555      DIMENSION DTAG2(*)
18556      DIMENSION DTAG9(*)
18557      DIMENSION TAG9(*)
18558      DIMENSION TEMP(*)
18559      DIMENSION TEMP2(*)
18560      DIMENSION TEMP3(*)
18561      DIMENSION XTEMP1(*)
18562      DIMENSION XTEMP2(*)
18563      DIMENSION XTEMP3(*)
18564      DIMENSION X2JITT(*)
18565C
18566      INTEGER ITEMP1(*)
18567      INTEGER ITEMP2(*)
18568      INTEGER ITEMP3(*)
18569      INTEGER ITEMP4(*)
18570      INTEGER ITEMP5(*)
18571      INTEGER ITEMP6(*)
18572C
18573      DOUBLE PRECISION DTEMP1(*)
18574      DOUBLE PRECISION DTEMP2(*)
18575      DOUBLE PRECISION DTEMP3(*)
18576C
18577      INCLUDE 'DPCOPA.INC'
18578      INCLUDE 'DPCOHK.INC'
18579C
18580      CHARACTER*4 IFOUNN
18581C
18582      DOUBLE PRECISION DCDF
18583C
18584C---------------------------------------------------------------------
18585C
18586      INCLUDE 'DPCOP2.INC'
18587C
18588C-----START POINT-----------------------------------------------------
18589C
18590      ISUBN1='DPBL'
18591      ISUBN2='O2  '
18592C
18593      XWIDTH=0.0
18594      XWIDT2=0.0
18595C
18596C     CHECK THE INPUT ARGUMENTS FOR ERRORS
18597C
18598      IF(N.LT.2)THEN
18599        WRITE(ICOUT,999)
18600        CALL DPWRST('XXX','BUG ')
18601        WRITE(ICOUT,46)
18602   46   FORMAT('***** ERROR IN BLOCK PLOT--')
18603        CALL DPWRST('XXX','BUG ')
18604        WRITE(ICOUT,47)
18605   47   FORMAT('      THE NUMBER OF OBSERVATIONS WAS LESS THAN 2.')
18606        CALL DPWRST('XXX','BUG ')
18607        WRITE(ICOUT,999)
18608        CALL DPWRST('XXX','BUG ')
18609        IERROR='YES'
18610        GOTO9000
18611      ENDIF
18612C
18613      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2')THEN
18614        WRITE(ICOUT,999)
18615  999   FORMAT(1X)
18616        CALL DPWRST('XXX','BUG ')
18617        WRITE(ICOUT,70)
18618   70   FORMAT('AT THE BEGINNING OF DPBLO2--')
18619        CALL DPWRST('XXX','BUG ')
18620        WRITE(ICOUT,53)ICASPL,ISUBRO,IBPLFI,IBPLBG
18621   53   FORMAT('ICASPL,ISUBRO,IBPLFI,IBPLBG = ',3(A4,2X),A4)
18622        CALL DPWRST('XXX','BUG ')
18623        WRITE(ICOUT,54)BARHEF,BARWEF,PBPLWI,N,NLABEL
18624   54   FORMAT('BARHEF,BARWEF,PBPLWI,N,NLABEL = ',3G15.7,2I8)
18625        CALL DPWRST('XXX','BUG ')
18626        DO75I=1,N
18627         WRITE(ICOUT,76)I,Y(I),X(I),TAG(I)
18628   76    FORMAT('I, Y(I), X(I),TAG(I) = ',I8,3G15.7)
18629         CALL DPWRST('XXX','BUG ')
18630   75   CONTINUE
18631      ENDIF
18632C
18633C               ********************************************************
18634C               **  STEP 11--                                         **
18635C               **  DETERMINE THE NUMBER OF DISTINCT VALUES           **
18636C               **  FOR VARIABLE 2 (THE HOR. AXIS VARIABLE).          **
18637C               ********************************************************
18638C
18639      ISTEPN='11'
18640      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2')
18641     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18642C
18643      CALL DISTIN(X,N,'OFF ',DIST,NDIST,IBUGG3,IERROR)
18644      CALL SORT(DIST,NDIST,DIST)
18645C
18646C               **************************************************
18647C               **  STEP 12--                                   **
18648C               **  IF NO STATISTIC IS CALLED FOR,              **
18649C               **  CARRY OVER THE RAW DATA INTO Y2,X2,TAG2,N2. **
18650C               **  IF A STATISTIC IS CALLED FOR,               **
18651C               **  COMPUTE THE STATISTICS AND COPY IT INTO     **
18652C               **  Y2,X**2,TAG2,N2.                            **
18653C               **************************************************
18654C
18655      ISTEPN='12'
18656      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2')
18657     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18658C
18659      CALL DPBLO3(Y,X,TAG,N,ICASPL,DIST,NDIST,
18660     1            TAG9,DTAG9,TEMP,TEMP2,TEMP3,
18661     1            XTEMP1,XTEMP2,XTEMP3,X2JITT,NJITT,
18662     1            DISTL2,DISTLA,NLABEL,
18663     1            ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
18664     1            DTEMP1,DTEMP2,DTEMP3,
18665     1            MAXNXT,ISEED,
18666     1            Y2,X2,TAG2,N2,IBUGG3,ISUBRO,IERROR)
18667C
18668      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2')THEN
18669        WRITE(ICOUT,999)
18670        CALL DPWRST('XXX','BUG ')
18671        WRITE(ICOUT,1001)
18672 1001   FORMAT('DPBLO2: AFTER CALL DPBLO3')
18673        CALL DPWRST('XXX','BUG ')
18674        WRITE(ICOUT,1003)NDIST,N2
18675 1003   FORMAT('NDIST,N2 = ',2I8)
18676        CALL DPWRST('XXX','BUG ')
18677        DO1010I=1,NDIST
18678          WRITE(ICOUT,1011)I,DIST(I)
18679 1011     FORMAT('I,DIST(I) = ',I8,G15.7)
18680          CALL DPWRST('XXX','BUG ')
18681 1010   CONTINUE
18682        DO1020I=1,N2
18683          WRITE(ICOUT,1021)I,Y2(I),X2(I),TAG2(I)
18684 1021     FORMAT('I,Y2(I),X2(I),TAG2(I) = ',I8,3G15.7)
18685          CALL DPWRST('XXX','BUG ')
18686 1020   CONTINUE
18687      ENDIF
18688C
18689C               ***************************************
18690C               **  STEP 13--                        **
18691C               **  COMPUTE 'COIN' PROBABILITY       **
18692C               **  FOR OBSERVED PATTERN.            **
18693C               **  UPDATE INTERNAL DATAPLOT ARRAYS  **
18694C               ***************************************
18695C
18696      CALL DISTIN(TAG2,N2,'OFF ',DTAG2,NDTAG2,IBUGG3,IERROR)
18697      FACES=NDTAG2
18698      PROB=1.0/FACES
18699C
18700C     NOTE 08/2010: PASS SEVERAL TEMPORARY ARRAYS INSTEAD OF
18701C                   DECLARING THEM IN "HEADS".  CAUSED A CONFLICT
18702C                   WITH NEW TEMPORARY ARRARYS CREATED IN DPBLOC.
18703C
18704      CALL HEADS(Y2,X2,TAG2,N2,
18705     1DIST,DTAG,
18706CCCCC1TEMP3,DTAG,
18707CCCCC ADD FOLLOWING LINE 08/2010
18708     1XTEMP1,XTEMP2,XTEMP3,
18709     1HEADS2,NTRIAL,AVEDEL,SDAVED,IBUGG3,ISUBRO,IERROR)
18710      HEADS3=HEADS2-1.0
18711      TRIALS=NTRIAL
18712C
18713      CALL BINCDF(DBLE(HEADS3),DBLE(PROB),NTRIAL,DCDF)
18714      CDF=REAL(DCDF)
18715      TAILPR=1.0-CDF
18716C
18717      CALL UPDATP('HEAD','S   ',HEADS2,'CHAD','NO  ',
18718     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
18719     1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR)
18720      IF(IERROR.EQ.'YES')GOTO9000
18721C
18722      CALL UPDATP('TRIA','LS  ',TRIALS,'CHAD','NO  ',
18723     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
18724     1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR)
18725      IF(IERROR.EQ.'YES')GOTO9000
18726C
18727      CALL UPDATP('FACE','S   ',FACES,'CHAD','NO  ',
18728     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
18729     1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR)
18730      IF(IERROR.EQ.'YES')GOTO9000
18731C
18732      CALL UPDATP('TAIL','PROB',TAILPR,'CHAD','NO  ',
18733     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
18734     1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR)
18735      IF(IERROR.EQ.'YES')GOTO9000
18736C
18737      CALL UPDATP('AVED','EL  ',AVEDEL,'CHAD','NO  ',
18738     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
18739     1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR)
18740      IF(IERROR.EQ.'YES')GOTO9000
18741C
18742      CALL UPDATP('SDAV','EDEL',SDAVED,'CHAD','NO  ',
18743     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
18744     1IANS,IWIDTH,IBUGG3,ILOCN,IFOUNN,IERROR)
18745      IF(IERROR.EQ.'YES')GOTO9000
18746C
18747C               *****************************************************
18748C               **  STEP 20--FORM PLOT COORDINATES                 **
18749C               **           BASED ON THE TAG VARIABLE (VAR.3).    **
18750C               **           THIS WILL BE A STRAIGHT COPY.         **
18751C               **           THIS WILL YIELD THE CHARACTERS PORTION**
18752C               **           OF THE FINAL PLOT.                    **
18753C               *****************************************************
18754C
18755      DO1100I=1,N2
18756         Y3(I)=Y2(I)
18757         X3(I)=X2(I)
18758         D3(I)=TAG2(I)
18759 1100 CONTINUE
18760      J=N2
18761C
18762      TAGMAX=CPUMIN
18763      DO1200I=1,N2
18764         IF(TAG2(I).GT.TAGMAX)TAGMAX=TAG2(I)
18765 1200 CONTINUE
18766C
18767      IOFFST=0
18768      IF(IBPLLA.EQ.'ON')IOFFST=INT(TAGMAX+0.1)
18769C
18770CCCCC THE FOLLOWING LINE WAS CORRECTED               JUNE 1995
18771CCCCC DUE TO EXTRANEOUS CHARACTERS ON THE VERTICES   JUNE 1995
18772CCCCC OF CHARLES HAGWOOD BLOCK PLOTS                 JUNE 1995
18773CCCCC JD=TAGMAX+0.5
18774      JD=100
18775C
18776C               *****************************************************
18777C               **  STEP 21--FORM PLOT COORDINATES                 **
18778C               **           BASED ON THE HOR. AXIS VAR. (VAR. 2)  **
18779C               **           THIS WILL YIELD THE BOXES PORTION     **
18780C               **           OF THE FINAL PLOT.                    **
18781C               *****************************************************
18782C
18783C               ***********************************
18784C               **  STEP 23--                    **
18785C               **  COMPUTE MINIMUM CLASS WIDTH  **
18786C               ***********************************
18787C
18788      ISTEPN='23'
18789      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2')
18790     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18791C
18792      IF(NDIST.EQ.1)THEN
18793         XWIDTH=0.10*DIST(1)
18794      ENDIF
18795C
18796      IF(NDIST.GE.2)THEN
18797         XWIDTH=CPUMAX
18798         IMAX=NDIST-1
18799         DO2300I=1,IMAX
18800            IP1=I+1
18801            XWIDT2=DIST(IP1)-DIST(I)
18802            IF(XWIDT2.LT.XWIDTH)XWIDTH=XWIDT2
18803 2300    CONTINUE
18804      ENDIF
18805      BARHAW=XWIDTH/3.0
18806      BARHAW=BARWEF*BARHAW
18807      IF(PBPLWI.GT.0.0)THEN
18808        BARHAW=PBPLWI
18809      ENDIF
18810C
18811C     COMPUTE RANGE OF VERTICAL AXIS DATA
18812C
18813      CALL RANGDP(Y2,N2,'OFF ',Y2RANG,IBUGG3,IERROR)
18814      Y2GAP=0.04*Y2RANG
18815      Y2GAP=BARHEF*Y2GAP
18816C
18817C               **************************************************
18818C               **  STEP 24--                                   **
18819C               **  LOOP THROUGH EACH DISTINCT HOR. AXIS VALUE. **
18820C               **  FOR A GIVEN HORIZONTAL AXIS VALUE--         **
18821C               **     FIND THE VERTICAL AXIS MINIMUM;          **
18822C               **     FIND THE VERTICAL AXIS MAXIMUM;          **
18823C               **     FORM PLOT COORDINATES OF THE BOX.        **
18824C               **************************************************
18825C
18826      ISTEPN='24'
18827      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2')
18828     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
18829C
18830      IF(IBPLLA.EQ.'ON')THEN
18831        DO2400ISET=1,NDIST
18832C
18833          Y2MIN=CPUMAX
18834          Y2MAX=CPUMIN
18835          ICNT=0
18836          DO2410I=1,N2
18837            IF(X2(I).EQ.DIST(ISET))THEN
18838              ICNT=ICNT+1
18839              IF(Y2(I).LT.Y2MIN)Y2MIN=Y2(I)
18840              IF(Y2(I).GT.Y2MAX)Y2MAX=Y2(I)
18841            ENDIF
18842 2410     CONTINUE
18843          IF(ICNT.LT.2 .AND. IBPLFI.EQ.'ON')GOTO2400
18844          Y2MING=Y2MIN-Y2GAP
18845          Y2MAXG=Y2MAX+Y2GAP
18846C
18847          Y2OFF=0.05*Y2RANG
18848          JDTEMP=INT(IOFFST + DISTLA(ISET)+0.1)
18849          J=J+1
18850          X3(J)=DIST(ISET)
18851          Y3(J)=Y2MAXG+Y2OFF
18852          D3(J)=JDTEMP
18853C
18854 2400   CONTINUE
18855      ENDIF
18856C
18857C     2012/12: "BACKGROUND" CASE WILL DRAW EACH BLOCK AS A SINGLE TRACE.
18858C              THIS WILL ALLOW THE USER TO USE THE REGION ATTRIBUTE COMMANDS
18859C              TO FILL THE BLOCKS.
18860C
18861C              SET THE TAG VALUE FOR THE BLOCKS TO -1, -2, ETC.
18862C              THE PLOTGE ROUTINE WILL HANDLE THIS VERSION OF THE BLOCK
18863C              PLOT AS A SPECIAL CASE (POSITIVE VALUES WILL IDENTIFY THE
18864C              "CHARACTER" TRACES AND NEGATIVE VALUES WILL IDENTIFY THE
18865C              "BLOCK" TRACES).
18866C
18867      IF(IBPLBG.EQ.'ON')THEN
18868C
18869        JD=0
18870        DO2600ISET=1,NDIST
18871C
18872          Y2MIN=CPUMAX
18873          Y2MAX=CPUMIN
18874          ICNT=0
18875          DO2610I=1,N2
18876            IF(X2(I).EQ.DIST(ISET))THEN
18877              ICNT=ICNT+1
18878              IF(Y2(I).LT.Y2MIN)Y2MIN=Y2(I)
18879              IF(Y2(I).GT.Y2MAX)Y2MAX=Y2(I)
18880            ENDIF
18881 2610     CONTINUE
18882          IF(ICNT.LT.2 .AND. IBPLFI.EQ.'ON')GOTO2600
18883          Y2MING=Y2MIN-Y2GAP
18884          Y2MAXG=Y2MAX+Y2GAP
18885C
18886          JD=JD-1
18887          J=J+1
18888          X3(J)=DIST(ISET)-BARHAW
18889          Y3(J)=Y2MING
18890          D3(J)=JD
18891          J=J+1
18892          X3(J)=DIST(ISET)+BARHAW
18893          Y3(J)=Y2MING
18894          D3(J)=JD
18895          J=J+1
18896          X3(J)=DIST(ISET)+BARHAW
18897          Y3(J)=Y2MAXG
18898          D3(J)=JD
18899          J=J+1
18900          X3(J)=DIST(ISET)-BARHAW
18901          Y3(J)=Y2MAXG
18902          D3(J)=JD
18903          J=J+1
18904          X3(J)=DIST(ISET)-BARHAW
18905          Y3(J)=Y2MING
18906          D3(J)=JD
18907 2600   CONTINUE
18908      ELSE
18909        DO2500ISET=1,NDIST
18910C
18911          Y2MIN=CPUMAX
18912          Y2MAX=CPUMIN
18913          ICNT=0
18914          DO2510I=1,N2
18915            IF(X2(I).EQ.DIST(ISET))THEN
18916              ICNT=ICNT+1
18917              IF(Y2(I).LT.Y2MIN)Y2MIN=Y2(I)
18918              IF(Y2(I).GT.Y2MAX)Y2MAX=Y2(I)
18919            ENDIF
18920 2510     CONTINUE
18921          IF(ICNT.LT.2 .AND. IBPLFI.EQ.'ON')GOTO2500
18922          Y2MING=Y2MIN-Y2GAP
18923          Y2MAXG=Y2MAX+Y2GAP
18924C
18925          JD=JD+1
18926          J=J+1
18927          X3(J)=DIST(ISET)-BARHAW
18928          Y3(J)=Y2MING
18929          D3(J)=JD
18930          J=J+1
18931          X3(J)=DIST(ISET)+BARHAW
18932          Y3(J)=Y2MING
18933          D3(J)=JD
18934C
18935          JD=JD+1
18936          J=J+1
18937          X3(J)=DIST(ISET)+BARHAW
18938          Y3(J)=Y2MING
18939          D3(J)=JD
18940          J=J+1
18941          X3(J)=DIST(ISET)+BARHAW
18942          Y3(J)=Y2MAXG
18943          D3(J)=JD
18944C
18945          JD=JD+1
18946          J=J+1
18947          X3(J)=DIST(ISET)+BARHAW
18948          Y3(J)=Y2MAXG
18949          D3(J)=JD
18950          J=J+1
18951          X3(J)=DIST(ISET)-BARHAW
18952          Y3(J)=Y2MAXG
18953          D3(J)=JD
18954C
18955          JD=JD+1
18956          J=J+1
18957          X3(J)=DIST(ISET)-BARHAW
18958          Y3(J)=Y2MAXG
18959          D3(J)=JD
18960          J=J+1
18961          X3(J)=DIST(ISET)-BARHAW
18962          Y3(J)=Y2MING
18963          D3(J)=JD
18964C
18965 2500   CONTINUE
18966      ENDIF
18967C
18968      IF(NJITT.GT.0)THEN
18969        DO3010I=1,NJITT
18970          X3(I)=X3(I)+X2JITT(I)
18971 3010   CONTINUE
18972      ENDIF
18973      N3=J
18974      NPLOTV=3
18975      GOTO9000
18976C
18977C               ******************
18978C               **   STEP 90--  **
18979C               **   EXIT       **
18980C               ******************
18981C
18982 9000 CONTINUE
18983      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO2')THEN
18984        WRITE(ICOUT,999)
18985        CALL DPWRST('XXX','BUG ')
18986        WRITE(ICOUT,9011)
18987 9011   FORMAT('***** AT THE END       OF DPBLO2--')
18988        CALL DPWRST('XXX','BUG ')
18989        WRITE(ICOUT,9012)ICASPL,ISUBRO,BARHEF,BARWEF
18990 9012   FORMAT('ICASPL,ISUBRO,BARHEF,BARWEF = ',2(A4,2X),2G15.7)
18991        CALL DPWRST('XXX','BUG ')
18992        WRITE(ICOUT,9013)N,NDIST,N2,N3,IERROR
18993 9013   FORMAT('N,NDIST,N2,N3,IERROR = ',4I8,2X,A4)
18994        CALL DPWRST('XXX','BUG ')
18995        WRITE(ICOUT,9015)XWIDT2,XWIDTH,BARHAW
18996 9015   FORMAT('XWIDT2,XWIDTH,BARHAW = ',3G15.7)
18997        CALL DPWRST('XXX','BUG ')
18998C
18999        DO9021I=1,N2
19000          WRITE(ICOUT,9022)I,Y2(I),X2(I),TAG2(I)
19001 9022     FORMAT('I,Y2(I),X2(I),TAG2(I) = ',I8,2G15.7,F9.2)
19002          CALL DPWRST('XXX','BUG ')
19003 9021   CONTINUE
19004C
19005        WRITE(ICOUT,9031)Y2RANG,Y2GAP
19006 9031   FORMAT('Y2RANG,Y2GAP = ',2G15.7)
19007        CALL DPWRST('XXX','BUG ')
19008        WRITE(ICOUT,9032)Y2MIN,Y2MAX,Y2MING,Y2MAXG
19009 9032   FORMAT('Y2MIN,Y2MAX,Y2MING,Y2MAXG = ',4G15.7)
19010        CALL DPWRST('XXX','BUG ')
19011        DO9035I=1,N3
19012          WRITE(ICOUT,9036)I,Y3(I),X3(I),D3(I)
19013 9036     FORMAT('I,Y3(I),X3(I),D3(I) = ',I8,2G15.7,F9.2)
19014          CALL DPWRST('XXX','BUG ')
19015 9035   CONTINUE
19016      ENDIF
19017C
19018      RETURN
19019      END
19020      SUBROUTINE DPBLO3(Y,X,TAG,N,ICASPL,DIST,NDIST,
19021     1                  TAG9,DTAG9,TEMP,TEMPZ,TEMPZ2,
19022     1                  XTEMP1,XTEMP2,XTEMP3,X2JITT,NJITT,
19023     1                  DISTL2,DISTLA,NLABEL,
19024     1                  ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
19025     1                  DTEMP1,DTEMP2,DTEMP3,
19026     1                  MAXNXT,ISEED,
19027     1                  Y2,X2,TAG2,N2,IBUGG3,ISUBRO,IERROR)
19028C
19029C     PURPOSE--IF NO STATISTIC IS CALLED FOR,
19030C              CARRY OVER THE RAW DATA INTO Y2,X2,TAG2,N2.
19031C              IF A STATISTIC IS CALLED FOR,
19032C              COMPUTE THE STATISTICS AND COPY IT INTO Y2,X2,TAG2,N2.
19033C     WRITTEN BY--JAMES J. FILLIBEN
19034C                 NATIONAL INSTITUTE OF STANDARDS & TECHNOLOGY
19035C                 GAITHERSBURG, MARYLAND 20899
19036C                 PHONE--301-975-2855
19037C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19038C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19039C     ORIGINAL VERSION--JUNE    1992.
19040C     UPDATED         --AUGUST  1993.  ADD SOME DECLARATIONS
19041C     UPDATED         --DECEMBER  1993. LINFIT ARGS + GARBAGE VECTORS
19042C     UPDATED         --DECEMBER  1993. LINFIT ARGS: PROTECT RESSD/DF
19043C     UPDATED         --FEBRUARY  1994. COMMENT OUT 2 VARIABLE STATS
19044C     UPDATED         --NOVEMBER  1994. ISUBN2 TO ISUBN3
19045C     UPDATED         --MARCH     1995. AAD AND MAD STATISTICS
19046C     UPDATED         --MAY       1995. ADDITIONAL EQUIVALENCE
19047C     UPDATED         --NOVEMBER  1998. AAD PERCENTILE
19048C     UPDATED         --AUGUST    2002. CALL "CMPSTA" TO COMPUTE
19049C                                       STATISTICS
19050C     UPDATED         --APRIL     2003. SUPPORT FOR SN AND QN REQUIRES
19051C                                       ADDITIONAL SCRATCH ARRAYS
19052C                                       FOR CMPSTA
19053C     UPDATED         --APRIL     2009. BUG FOR "RAW" BLOCK PLOT WHEN
19054C                                       THERE IS MORE THAN 1 VALUE
19055C                                       FOR DISTINCT COMBINATION OF
19056C                                       X AND TAG VARIABLE
19057C     UPDATED         --APRIL     2012. SUPPORT FOR FILTERING WHEN
19058C                                       ONLY ONE VALUE FOR A PARTICULAR
19059C                                       COMBINATION OF FACTOR LEVELS
19060C     UPDATED         --NOVEMBER  2016. SUPPORT FOR "JITTERING"
19061C
19062C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19063C
19064      CHARACTER*4 ICASPL
19065      CHARACTER*4 IBUGG3
19066      CHARACTER*4 ISUBRO
19067      CHARACTER*4 IERROR
19068C
19069CCCCC CHARACTER*4 ICHMAP
19070      CHARACTER*4 ISUBN1
19071      CHARACTER*4 ISUBN3
19072      CHARACTER*4 ISTEPN
19073      CHARACTER*4 IWRITE
19074C
19075C---------------------------------------------------------------------
19076C
19077      DIMENSION Y(*)
19078      DIMENSION X(*)
19079      DIMENSION TAG(*)
19080C
19081      DIMENSION DIST(*)
19082      DIMENSION DISTL2(*)
19083      DIMENSION DISTLA(*)
19084C
19085      DIMENSION Y2(*)
19086      DIMENSION X2(*)
19087      DIMENSION TAG2(*)
19088C
19089      INCLUDE 'DPCOPA.INC'
19090      INCLUDE 'DPCOHK.INC'
19091C
19092      DIMENSION TAG9(*)
19093      DIMENSION DTAG9(*)
19094      DIMENSION TEMP(*)
19095      DIMENSION TEMPZ(*)
19096      DIMENSION TEMPZ2(*)
19097C
19098      DIMENSION XTEMP1(*)
19099      DIMENSION XTEMP2(*)
19100      DIMENSION XTEMP3(*)
19101      DIMENSION X2JITT(*)
19102C
19103      INTEGER ITEMP1(*)
19104      INTEGER ITEMP2(*)
19105      INTEGER ITEMP3(*)
19106      INTEGER ITEMP4(*)
19107      INTEGER ITEMP5(*)
19108      INTEGER ITEMP6(*)
19109      DOUBLE PRECISION DTEMP1(*)
19110      DOUBLE PRECISION DTEMP2(*)
19111      DOUBLE PRECISION DTEMP3(*)
19112C
19113      DIMENSION UTEMP(1)
19114C
19115      INCLUDE 'DPCOST.INC'
19116C
19117C---------------------------------------------------------------------
19118C
19119      INCLUDE 'DPCOP2.INC'
19120C
19121C-----START POINT-----------------------------------------------------
19122C
19123      ISUBN1='DPBL'
19124      ISUBN3='O3  '
19125C
19126      NJITT=0
19127      ATEMP=0.0
19128C
19129C     CHECK THE INPUT ARGUMENTS FOR ERRORS
19130C
19131      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO3')THEN
19132        WRITE(ICOUT,999)
19133  999   FORMAT(1X)
19134        CALL DPWRST('XXX','BUG ')
19135        WRITE(ICOUT,51)
19136   51   FORMAT('AT THE BEGINNING OF DPBLO3--')
19137        CALL DPWRST('XXX','BUG ')
19138        WRITE(ICOUT,53)ICASPL,ISUBRO
19139   53   FORMAT('ICASPL,ISUBRO = ',A4,2X,A4)
19140        CALL DPWRST('XXX','BUG ')
19141        WRITE(ICOUT,54)N,NDIST,NLABEL,PBPLJI
19142   54   FORMAT('N,NDIST,NLABEL,PBPLJI = ',3I8,G15.7)
19143        CALL DPWRST('XXX','BUG ')
19144        DO55I=1,N
19145          WRITE(ICOUT,56)I,Y(I),X(I),TAG(I)
19146   56     FORMAT('I, Y(I), X(I),TAG(I) = ',I8,3G15.7)
19147          CALL DPWRST('XXX','BUG ')
19148   55   CONTINUE
19149        DO62I=1,NDIST
19150          WRITE(ICOUT,63)I,DIST(I)
19151   63     FORMAT('I, DIST(I) = ',I8,2G15.7)
19152          CALL DPWRST('XXX','BUG ')
19153   62   CONTINUE
19154      ENDIF
19155C
19156C               **************************************************
19157C               **  STEP 1--                                    **
19158C               **  LOOP THROUGH EACH DISTINCT HOR. AXIS VALUE. **
19159C               **  FOR A GIVEN HORIZONTAL AXIS VALUE--         **
19160C               **     COPY OVER THE RAW DATA, OR               **
19161C               **     COMPUTE THE STATISTIC                    **
19162C               **************************************************
19163C
19164      ISTEPN='24'
19165      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BLO3')
19166     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN3)
19167C
19168      IWRITE='OFF'
19169      N2=0
19170      DO1100ISET=1,NDIST
19171         NTAG9=0
19172         DO1200I=1,N
19173            IF(X(I).EQ.DIST(ISET))THEN
19174               NTAG9=NTAG9+1
19175               TAG9(NTAG9)=TAG(I)
19176               ATEMP=DISTL2(I)
19177            ENDIF
19178 1200    CONTINUE
19179         DISTLA(ISET)=ATEMP
19180         CALL DISTIN(TAG9,NTAG9,'OFF ',DTAG9,NDTAG9,IBUGG3,IERROR)
19181C
19182         IF(NDTAG9.LT.2 .AND. IBPLFI.EQ.'ON')THEN
19183           GOTO1100
19184         ENDIF
19185C
19186         CALL SORT(DTAG9,NDTAG9,DTAG9)
19187         DO1300K=1,NDTAG9
19188            NS2=0
19189            TAGVAL=DTAG9(K)
19190            DO1400I=1,N
19191               IF(X(I).EQ.DIST(ISET).AND.TAG(I).EQ.DTAG9(K))THEN
19192                  NS2=NS2+1
19193                  TEMP(NS2)=Y(I)
19194               ENDIF
19195 1400       CONTINUE
19196C
19197            IF(ICASPL.EQ.'RAW ')THEN
19198              IF(PBPLJI.GT.0.0)THEN
19199                NTEMP=1
19200                DO1411JJ=1,NS2
19201                  RIGHT=TEMP(JJ)
19202                  N2=N2+1
19203                  Y2(N2)=RIGHT
19204                  X2(N2)=DIST(ISET)
19205                  CALL UNIRAN(NTEMP,ISEED,UTEMP)
19206                  AVAL=-PBPLJI + UTEMP(1)*(2.0*PBPLJI)
19207                  NJITT=NJITT+1
19208                  X2JITT(NJITT)=AVAL
19209                  TAG2(N2)=DTAG9(K)
19210 1411           CONTINUE
19211              ELSE
19212                DO1410JJ=1,NS2
19213                  RIGHT=TEMP(JJ)
19214                  N2=N2+1
19215                  Y2(N2)=RIGHT
19216                  X2(N2)=DIST(ISET)
19217                  TAG2(N2)=DTAG9(K)
19218 1410           CONTINUE
19219              ENDIF
19220            ELSE
19221              CALL CMPSTA(
19222     1             TEMP,TEMPZ,TEMPZ2,XTEMP1,XTEMP2,XTEMP3,MAXNXT,
19223     1             NS2,NS2,NS2,NUMV2,ICASPL,
19224     1             ISEED,ITEMP1,ITEMP2,ITEMP3,ITEMP4,ITEMP5,ITEMP6,
19225     1             DTEMP1,DTEMP2,DTEMP3,
19226CCCCC1             IQUAME,IQUASE,PSTAMV,
19227     1             RIGHT,
19228     1             ISUBRO,IBUGG3,IERROR)
19229              N2=N2+1
19230              Y2(N2)=RIGHT
19231              X2(N2)=DIST(ISET)
19232              IF(PBPLJI.GT.0.0)THEN
19233                NTEMP=1
19234                CALL UNIRAN(NTEMP,ISEED,UTEMP)
19235                AVAL=-PBPLJI + UTEMP(1)*(2.0*PBPLJI)
19236                NJITT=NJITT+1
19237                X2JITT(NJITT)=AVAL
19238              ENDIF
19239              TAG2(N2)=DTAG9(K)
19240            ENDIF
19241C
19242 1300    CONTINUE
19243 1100 CONTINUE
19244C
19245C               ******************
19246C               **   STEP 90--  **
19247C               **   EXIT       **
19248C               ******************
19249C
19250      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BLO3')THEN
19251        WRITE(ICOUT,999)
19252        CALL DPWRST('XXX','BUG ')
19253        WRITE(ICOUT,9011)
19254 9011   FORMAT('***** AT THE END       OF DPBLO3--')
19255        CALL DPWRST('XXX','BUG ')
19256        WRITE(ICOUT,9012)ICASPL,ISUBRO,IERROR
19257 9012   FORMAT('ICASPL,ISUBRO,IERROR = ',2(A4,2X),A4)
19258        CALL DPWRST('XXX','BUG ')
19259        WRITE(ICOUT,9013)N,NDIST,N2
19260 9013   FORMAT('N,NDIST,N2 = ',3I8)
19261        CALL DPWRST('XXX','BUG ')
19262        WRITE(ICOUT,9014)NTAG9,NDTAG9,NS2
19263 9014   FORMAT('NTAG9,NDTAG9,NS2 = ',3I8)
19264        CALL DPWRST('XXX','BUG ')
19265C
19266        DO9021I=1,N2
19267          WRITE(ICOUT,9022)I,Y2(I),X2(I),TAG2(I)
19268 9022     FORMAT('I,Y2(I),X2(I),TAG2(I) = ',I8,2G15.7,F9.2)
19269          CALL DPWRST('XXX','BUG ')
19270 9021   CONTINUE
19271C
19272      ENDIF
19273C
19274      RETURN
19275      END
19276      SUBROUTINE DPBLPA(IHARG,NUMARG,
19277     1                  IPSTBP,IFOUND,IERROR)
19278C
19279C     PURPOSE--TURN ON/OFF THE (INITIAL) BLANK PAGE SWITCH
19280C              FOR POSTSCRIPT.
19281C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
19282C                     --IHARG2 (A CHARACTER VECTOR)
19283C                     --NUMARG
19284C     OUTPUT ARGUMENTS--IPSTBP (A CHARACTER VECTOR
19285C                              WHICH CONTAINS THE
19286C                              POSTSCRIPT BLANK PAGE SWITCH (ON/OFF)
19287C                     --IFOUND ('YES' OR 'NO')
19288C                     --IERROR ('YES' OR 'NO' )
19289C     WRITTEN BY--ALAN HECKERT
19290C                 STATISTICAL ENGINEERING DIVISION
19291C                 INFORMATION TECHNOLOGY LABORATORY
19292C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19293C                 GAITHERSBURG, MD 20899-8980
19294C                 PHONE--301-975-2899
19295C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19296C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
19297C     LANGUAGE--ANSI FORTRAN (1977)
19298C     VERSION NUMBER--92/6
19299C     ORIGINAL VERSION--MAY       1992.
19300C
19301C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19302C
19303      CHARACTER*4 IHARG
19304      CHARACTER*4 IPSTBP
19305      CHARACTER*4 IFOUND
19306      CHARACTER*4 IERROR
19307C
19308C---------------------------------------------------------------------
19309C
19310      DIMENSION IHARG(*)
19311C
19312C---------------------------------------------------------------------
19313C
19314      INCLUDE 'DPCOP2.INC'
19315C
19316C-----START POINT-----------------------------------------------------
19317C
19318      IFOUND='NO'
19319      IERROR='NO'
19320C
19321      IF(NUMARG.LE.0)THEN
19322         IPSTBP='ON'
19323      ELSE
19324         IF(IHARG(NUMARG).EQ.'ON')IPSTBP='ON'
19325         IF(IHARG(NUMARG).EQ.'OFF')IPSTBP='OFF'
19326         IF(IHARG(NUMARG).EQ.'AUTO')IPSTBP='ON'
19327         IF(IHARG(NUMARG).EQ.'DEFA')IPSTBP='OFF'
19328      ENDIF
19329C
19330      IFOUND='YES'
19331      IF(IFEEDB.EQ.'ON')THEN
19332         WRITE(ICOUT,999)
19333  999    FORMAT(1X)
19334         CALL DPWRST('XXX','BUG ')
19335         WRITE(ICOUT,1181)
19336 1181    FORMAT('THE POSTSCRIPT (INITIAL) BLANK PAGE SWITCH')
19337         CALL DPWRST('XXX','BUG ')
19338         WRITE(ICOUT,1182)IPSTBP
19339 1182    FORMAT('HAS JUST BEEN SET TO ',A4)
19340        CALL DPWRST('XXX','BUG ')
19341      ENDIF
19342C
19343      RETURN
19344      END
19345      SUBROUTINE DPBNPV(P1,N1,P2,N2,ALPHA,ICASAN,IWRITE,PVALUE,
19346     1                  IBUGA3,IERROR)
19347C
19348C     PURPOSE--FOR A GIVEN P1, N1, P2, N2, AND ALPHA, COMPUTE THE
19349C              HYPOTHESIS TEST FOR EQUAL PROPORTIONS AND RETURN
19350C              THE APPROPRIATE P-VALUE.
19351C     WRITTEN BY--ALAN HECKERT
19352C                 STATISTICAL ENGINEERING DIVISION
19353C                 INFORMATION TECHNOLOGY LABORATORY
19354C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19355C                 GAITHERSBURG, MD 20899-8980
19356C                 PHONE--301-975-2899
19357C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19358C           OF THE NATIONAL BUREAU OF STANDARDS.
19359C     LANGUAGE--ANSI FORTRAN (1977)
19360C     VERSION NUMBER--2008/8
19361C     ORIGINAL VERSION--AUGUST    2008.
19362C
19363C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19364C
19365      CHARACTER*4 ICASAN
19366      CHARACTER*4 IWRITE
19367      CHARACTER*4 IBUGA3
19368      CHARACTER*4 IERROR
19369C
19370      CHARACTER*4 ISUBN1
19371      CHARACTER*4 ISUBN2
19372C
19373C---------------------------------------------------------------------
19374C
19375      REAL P1
19376      REAL P2
19377      REAL ALPHA
19378      INTEGER N1
19379      INTEGER N2
19380C
19381C---------------------------------------------------------------------
19382C
19383      INCLUDE 'DPCOP2.INC'
19384C
19385C-----START POINT-----------------------------------------------------
19386C
19387      ISUBN1='DPBN'
19388      ISUBN2='PV  '
19389C
19390      IERROR='NO'
19391C
19392      IF(IBUGA3.EQ.'ON')THEN
19393        WRITE(ICOUT,999)
19394  999   FORMAT(1X)
19395        CALL DPWRST('XXX','BUG ')
19396        WRITE(ICOUT,51)
19397   51   FORMAT('***** AT THE BEGINNING OF DPBNPV--')
19398        CALL DPWRST('XXX','BUG ')
19399        WRITE(ICOUT,52)IBUGA3,ICASAN,IWRITE
19400   52   FORMAT('IBUGA3,ICASAN,IWRITE = ',2A4,2X,A4)
19401        CALL DPWRST('XXX','BUG ')
19402        WRITE(ICOUT,53)P1,N1,P2,N2,ALPHA
19403   53   FORMAT('P1,N1,P2,N2,ALPHA = ',2(G15.7,I8),G15.7)
19404        CALL DPWRST('XXX','BUG ')
19405        WRITE(ICOUT,999)
19406        CALL DPWRST('XXX','BUG ')
19407      ENDIF
19408C
19409C               ********************************
19410C               **  STEP 1--                  **
19411C               **  CHECK FOR INPUT ERRORS    **
19412C               ********************************
19413C
19414      PVALUE=0.0
19415C
19416      IF(N1.LT.1)THEN
19417        WRITE(ICOUT,999)
19418        CALL DPWRST('XXX','WRIT')
19419        WRITE(ICOUT,111)
19420  111   FORMAT('****** ERROR IN DIFFERENCE OF PROPORTION ',
19421     1         'HYPOTHESIS TEST--')
19422        CALL DPWRST('XXX','BUG ')
19423        WRITE(ICOUT,113)
19424  113   FORMAT('         THE NUMBER OF OBSERVATIONS FOR THE FIRST ',
19425     1         'RESPONSE VARIABLE IS LESS THAN 2.')
19426        CALL DPWRST('XXX','WRIT')
19427        WRITE(ICOUT,114)N1
19428  114   FORMAT('SAMPLE SIZE = ',I8)
19429        CALL DPWRST('XXX','WRIT')
19430        IERROR='YES'
19431        GOTO9000
19432      ENDIF
19433C
19434      IF(N2.LT.2)THEN
19435        WRITE(ICOUT,999)
19436        CALL DPWRST('XXX','WRIT')
19437        WRITE(ICOUT,111)
19438        CALL DPWRST('XXX','BUG ')
19439        WRITE(ICOUT,123)
19440  123   FORMAT('         THE NUMBER OF OBSERVATIONS FOR THE ',
19441     1         'SECOND RESPONSE VARIABLE IS LESS THAN 2.')
19442        CALL DPWRST('XXX','WRIT')
19443        WRITE(ICOUT,124)N2
19444  124   FORMAT('SAMPLE SIZE = ',I8)
19445        CALL DPWRST('XXX','WRIT')
19446        IERROR='YES'
19447        GOTO9000
19448      ENDIF
19449C
19450      IF(P1.LT.0.0 .OR. P1.GT.1.0)THEN
19451        IERROR='YES'
19452        WRITE(ICOUT,999)
19453        CALL DPWRST('XXX','BUG ')
19454        WRITE(ICOUT,111)
19455        CALL DPWRST('XXX','BUG ')
19456        WRITE(ICOUT,162)
19457  162   FORMAT('      THE BINOMIAL PROBABILITY OF SUCCESS PARAMETER ',
19458     1         'FOR THE')
19459        CALL DPWRST('XXX','BUG ')
19460        WRITE(ICOUT,164)
19461  164   FORMAT('      FIRST RESPONSE VARIABLE IS OUTSIDE THE ',
19462     1         '(0,1) INTERVAL.')
19463        CALL DPWRST('XXX','BUG ')
19464        WRITE(ICOUT,167)P1
19465  167   FORMAT('      THE PROBABILITY OF SUCCESS PARAMETER = ',G15.7)
19466        CALL DPWRST('XXX','BUG ')
19467        GOTO9000
19468      ENDIF
19469C
19470      IF(P2.LT.0.0 .OR. P2.GT.1.0)THEN
19471        IERROR='YES'
19472        WRITE(ICOUT,999)
19473        CALL DPWRST('XXX','BUG ')
19474        WRITE(ICOUT,111)
19475        CALL DPWRST('XXX','BUG ')
19476        WRITE(ICOUT,162)
19477        CALL DPWRST('XXX','BUG ')
19478        WRITE(ICOUT,174)
19479  174   FORMAT('      SECOND RESPONSE VARIABLE IS OUTSIDE THE ',
19480     1         '(0,1) INTERVAL.')
19481        CALL DPWRST('XXX','BUG ')
19482        WRITE(ICOUT,167)P2
19483        CALL DPWRST('XXX','BUG ')
19484        GOTO9000
19485      ENDIF
19486C
19487      ALPHSV=ALPHA
19488      IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0
19489      IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN
19490        IERROR='YES'
19491        WRITE(ICOUT,999)
19492        CALL DPWRST('XXX','BUG ')
19493        WRITE(ICOUT,111)
19494        CALL DPWRST('XXX','BUG ')
19495        WRITE(ICOUT,182)
19496  182   FORMAT('      THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ',
19497     1         'INTERVAL.')
19498        CALL DPWRST('XXX','BUG ')
19499        WRITE(ICOUT,187)ALPHA
19500  187   FORMAT('      THE VALUE OF ALPHA = ',G15.7)
19501        CALL DPWRST('XXX','BUG ')
19502        GOTO9000
19503      ENDIF
19504C
19505      IF(ALPHA.LT.0.5)ALPHA=1.0 - ALPHA
19506C
19507C               ********************************************
19508C               **  STEP 2--                              **
19509C               **  COMPUTE THE DIFFERENCE OF PROPORTIONS **
19510C               **  CONFIDENCE INTERVAL.                  **
19511C               ********************************************
19512C
19513      IF(P1.GE.1.0 .AND. P2.GE.1.0)THEN
19514        STATVA=0.0
19515        PVALUE=1.0
19516        GOTO9000
19517      ELSEIF(P1.LE.0.0 .AND. P2.LE.0.0)THEN
19518        STATVA=0.0
19519        PVALUE=1.0
19520        GOTO9000
19521      ENDIF
19522C
19523      AN1=REAL(N1)
19524      AN2=REAL(N2)
19525C
19526      IX1=INT(AN1*P1 + 0.5)
19527      IX2=INT(AN2*P2 + 0.5)
19528      PHAT=REAL(IX1+IX2)/(AN1+AN2)
19529      SDP=SQRT(PHAT*(1.0-PHAT)*((1.0/AN1) + (1.0/AN2)))
19530C
19531      STATVA=(P1-P2)/SDP
19532      IF(ICASAN.EQ.'BPLT')THEN
19533        CALL NORCDF(STATVA,PVALUE)
19534      ELSEIF(ICASAN.EQ.'BPUT')THEN
19535        CALL NORCDF(STATVA,PVALUE)
19536        PVALUE=1.0-PVALUE
19537      ELSE
19538        CALL NORCDF(ABS(STATVA),PVALUE)
19539        PVALUE=2.0*(1.0-PVALUE)
19540      ENDIF
19541C
19542C               *****************
19543C               **  STEP 90--  **
19544C               **  EXIT.      **
19545C               *****************
19546C
19547 9000 CONTINUE
19548C
19549      IF(IBUGA3.EQ.'ON')THEN
19550        WRITE(ICOUT,999)
19551        CALL DPWRST('XXX','BUG ')
19552        WRITE(ICOUT,9011)
19553 9011   FORMAT('***** AT THE END       OF DPBNPV--')
19554        CALL DPWRST('XXX','BUG ')
19555        WRITE(ICOUT,9012)IBUGA3,IERROR
19556 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
19557        CALL DPWRST('XXX','BUG ')
19558        WRITE(ICOUT,9013)PHAT,SDP
19559 9013   FORMAT('PHAT,SDP = ',2(G15.7,2X))
19560        CALL DPWRST('XXX','BUG ')
19561        WRITE(ICOUT,9014)STATVA,PVALUE
19562 9014   FORMAT('STATVA,PVALUE = ',2(G15.7,2X))
19563        CALL DPWRST('XXX','BUG ')
19564      ENDIF
19565C
19566      RETURN
19567      END
19568      SUBROUTINE DPBNTE(MAXNXT,ICASAN,ICAPSW,IFORSW,
19569     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
19570C
19571C     PURPOSE--PERFORM A HYPOTHESIS TEST FOR THE EQUALITY OF
19572C              TWO BINOMIAL PROPORTIONS.  NOTE THAT THE DATA
19573C              CAN BE GIVEN IN EITHER RAW FORM OR SUMMARY FORM
19574C     NOTE--1 = SUCCESS, 0 = FAILURE
19575C     EXAMPLE--BINOMIAL PROPORTIONS TEST Y1 Y2
19576C            --BINOMIAL PROPORTIONS TEST P1 N1 P2 N2
19577C     WRITTEN BY--ALAN HECKERT
19578C                 STATISTICAL ENGINEERING DIVISION
19579C                 INFORMATION TECHNOLOGY LABORATORY
19580C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
19581C                 GAITHERSBURG, MD 20899-8980
19582C                 PHONE--301-975-2899
19583C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
19584C           OF THE NATIONAL BUREAU OF STANDARDS.
19585C     LANGUAGE--ANSI FORTRAN (1977)
19586C     VERSION NUMBER--2008/8
19587C     ORIGINAL VERSION--AUGUST    2008.
19588C     UPDATED  VERSION--FEBRUARY  2011. USE DPPARS, DPPAR3, DPPAR6
19589C
19590C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
19591C
19592      CHARACTER*4 ICASAN
19593      CHARACTER*4 ICAPSW
19594      CHARACTER*4 IFORSW
19595C
19596      CHARACTER*4 IBUGA2
19597      CHARACTER*4 IBUGA3
19598      CHARACTER*4 IBUGQ
19599      CHARACTER*4 ISUBRO
19600      CHARACTER*4 IFOUND
19601      CHARACTER*4 IERROR
19602C
19603      CHARACTER*4 ISUBN1
19604      CHARACTER*4 ISUBN2
19605      CHARACTER*4 ISTEPN
19606      CHARACTER*4 IH
19607      CHARACTER*4 IH2
19608      CHARACTER*4 IHOST1
19609      CHARACTER*4 ISUBN0
19610C
19611      CHARACTER*4 ICASE
19612      CHARACTER*40 INAME
19613      PARAMETER (MAXSPN=20)
19614      CHARACTER*4 IVARN1(MAXSPN)
19615      CHARACTER*4 IVARN2(MAXSPN)
19616      CHARACTER*4 IVARTY(MAXSPN)
19617      REAL PVAR(MAXSPN)
19618      INTEGER ILIS(MAXSPN)
19619      INTEGER NRIGHT(MAXSPN)
19620      INTEGER ICOLR(MAXSPN)
19621C
19622C---------------------------------------------------------------------
19623C
19624      PARAMETER (MAXLEV=2)
19625      DIMENSION XMAT(MAXLEV,MAXLEV)
19626C
19627C-----COMMON----------------------------------------------------------
19628C
19629      INCLUDE 'DPCOPA.INC'
19630      INCLUDE 'DPCOZZ.INC'
19631C
19632      REAL TEMP1(MAXOBV)
19633C
19634      EQUIVALENCE (GARBAG(IGARB1),TEMP1(1))
19635      EQUIVALENCE (GARBAG(IGARB2),XMAT(1,1))
19636C
19637      INCLUDE 'DPCOHK.INC'
19638      INCLUDE 'DPCOSU.INC'
19639      INCLUDE 'DPCOST.INC'
19640      INCLUDE 'DPCODA.INC'
19641C
19642C-----COMMON VARIABLES (GENERAL)--------------------------------------
19643C
19644      INCLUDE 'DPCOP2.INC'
19645C
19646C-----START POINT-----------------------------------------------------
19647C
19648      ISUBN1='DPBN'
19649      ISUBN2='TE  '
19650C
19651      MAXCP1=MAXCOL+1
19652      MAXCP2=MAXCOL+2
19653      MAXCP3=MAXCOL+3
19654      MAXCP4=MAXCOL+4
19655      MAXCP5=MAXCOL+5
19656      MAXCP6=MAXCOL+6
19657C
19658      IFOUND='YES'
19659      IERROR='NO'
19660C
19661      N1=(-999)
19662      N2=(-999)
19663      P1=(-999.)
19664      P2=(-999.)
19665C
19666      ICASE='PARA'
19667C
19668C               ***************************************************
19669C               **  TREAT THE BINOMIAL PROPORTIONS TEST CASE     **
19670C               ***************************************************
19671C
19672      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BNTE')THEN
19673        WRITE(ICOUT,999)
19674  999   FORMAT(1X)
19675        CALL DPWRST('XXX','BUG ')
19676        WRITE(ICOUT,51)
19677   51   FORMAT('***** AT THE BEGINNING OF DPBNTE--')
19678        CALL DPWRST('XXX','BUG ')
19679        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
19680   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
19681        CALL DPWRST('XXX','BUG ')
19682        WRITE(ICOUT,55)MAXNXT,NUMARG,IFORSW
19683   55   FORMAT('MAXNXT,NUMARG,IFORSW = ',2I8,2X,A4)
19684        CALL DPWRST('XXX','BUG ')
19685        DO59I=1,NUMARG
19686          WRITE(ICOUT,57)I,IHARG(I),IHARG2(I),ARG(I)
19687   57     FORMAT('I,IHARG(I),IHARG2(I),ARG(I) = ',I5,A4,A4,G15.7)
19688   59   CONTINUE
19689      ENDIF
19690C
19691C               *********************************
19692C               **  STEP 4--                   **
19693C               **  EXTRACT THE VARIABLE LIST  **
19694C               *********************************
19695C
19696      ISTEPN='4'
19697      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BNTE')
19698     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19699C
19700      INAME='BINOMIAL PROPORTION TEST'
19701      MINNA=1
19702      MAXNA=100
19703      MINN2=2
19704      IFLAGE=0
19705      IFLAGM=9
19706      IFLAGP=9
19707      JMIN=1
19708      JMAX=NUMARG
19709      MINNVA=1
19710      MAXNVA=4
19711C
19712      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
19713     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
19714     1            JMIN,JMAX,
19715     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
19716     1            IVARN1,IVARN2,IVARTY,PVAR,
19717     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
19718     1            MINNVA,MAXNVA,
19719     1            IFLAGM,IFLAGP,
19720     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
19721      IF(IERROR.EQ.'YES')GOTO9000
19722C
19723      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BNTE')THEN
19724        WRITE(ICOUT,999)
19725        CALL DPWRST('XXX','BUG ')
19726        WRITE(ICOUT,281)
19727  281   FORMAT('***** AFTER CALL DPPARS--')
19728        CALL DPWRST('XXX','BUG ')
19729        WRITE(ICOUT,282)NQ,NUMVAR
19730  282   FORMAT('NQ,NUMVAR = ',2I8)
19731        CALL DPWRST('XXX','BUG ')
19732        IF(NUMVAR.GT.0)THEN
19733          DO285I=1,NUMVAR
19734            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
19735     1                      ICOLR(I),PVAR(I)
19736  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
19737     1             'ICOLR(I),PVAR(I) = ',I8,2X,A4,A4,2X,3I8,G15.7)
19738            CALL DPWRST('XXX','BUG ')
19739  285     CONTINUE
19740        ENDIF
19741      ENDIF
19742C
19743C               ***********************************
19744C               **  STEP 22--                    **
19745C               **  CHECK FOR PROPER VALUES FOR  **
19746C               **  INPUT PARAMETERS             **
19747C               ***********************************
19748C
19749      IF(IVARTY(1).EQ.'PARA' .OR. IVARTY(1).EQ.'NUMB')THEN
19750        P1=PVAR(1)
19751        AN1=PVAR(2)
19752        P2=PVAR(3)
19753        AN2=PVAR(4)
19754        ICASE='PARA'
19755        N1=INT(AN1+0.1)
19756        N2=INT(AN2+0.1)
19757C
19758        ISTEPN='22'
19759        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BNTE')
19760     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19761C
19762        IF(P1.LT.0.0 .OR. P1.GT.1.0)THEN
19763          WRITE(ICOUT,999)
19764          CALL DPWRST('XXX','BUG ')
19765          WRITE(ICOUT,2201)
19766 2201     FORMAT('***** ERROR FROM BINOMIAL PROPORTION TEST--')
19767          CALL DPWRST('XXX','BUG ')
19768          WRITE(ICOUT,2203)
19769 2203     FORMAT('      THE VALUE OF THE FIRST PARAMETER (P1 = THE ',
19770     1           'PROBABILITY OF SUCCESS')
19771          CALL DPWRST('XXX','BUG ')
19772          WRITE(ICOUT,2204)
19773 2204     FORMAT('      FOR THE FIRST VARIABLE MUST BE IN THE ',
19774     1           'INTERVAL (0,1).')
19775          CALL DPWRST('XXX','BUG ')
19776          WRITE(ICOUT,2205)P1
19777 2205     FORMAT('      P1 = ',G15.7)
19778          CALL DPWRST('XXX','BUG ')
19779          IERROR='YES'
19780          GOTO9000
19781C
19782        ELSEIF(N1.LT.0)THEN
19783          WRITE(ICOUT,999)
19784          CALL DPWRST('XXX','BUG ')
19785          WRITE(ICOUT,2201)
19786          CALL DPWRST('XXX','BUG ')
19787          WRITE(ICOUT,2213)
19788 2213     FORMAT('      THE VALUE OF THE SECOND PARAMETER (N1 = THE ',
19789     1           'NUMBER OF TRIALS')
19790          CALL DPWRST('XXX','BUG ')
19791          WRITE(ICOUT,2214)
19792 2214     FORMAT('      FOR THE FIRST VARIABLE MUST BE NON-NEGATIVE.')
19793          CALL DPWRST('XXX','BUG ')
19794          WRITE(ICOUT,2215)N1
19795 2215     FORMAT('      N1 = ',I8)
19796          CALL DPWRST('XXX','BUG ')
19797          IERROR='YES'
19798          GOTO9000
19799C
19800        ELSEIF(P2.LT.0.0 .OR. P2.GT.1.0)THEN
19801          WRITE(ICOUT,999)
19802          CALL DPWRST('XXX','BUG ')
19803          WRITE(ICOUT,2201)
19804          CALL DPWRST('XXX','BUG ')
19805          WRITE(ICOUT,2223)
19806 2223     FORMAT('      THE VALUE OF THE THIRD PARAMETER (P2 = THE ',
19807     1           'PROBABILITY OF SUCCESS')
19808          CALL DPWRST('XXX','BUG ')
19809          WRITE(ICOUT,2224)
19810 2224     FORMAT('      FOR THE SECOND VARIABLE MUST BE IN THE ',
19811     1           'INTERVAL (0,1).')
19812          CALL DPWRST('XXX','BUG ')
19813          WRITE(ICOUT,2225)P2
19814 2225     FORMAT('      P2 = ',G15.7)
19815          CALL DPWRST('XXX','BUG ')
19816          IERROR='YES'
19817          GOTO9000
19818C
19819        ELSEIF(N2.LT.0)THEN
19820          WRITE(ICOUT,999)
19821          CALL DPWRST('XXX','BUG ')
19822          WRITE(ICOUT,2201)
19823          CALL DPWRST('XXX','BUG ')
19824          WRITE(ICOUT,2233)
19825 2233     FORMAT('      THE VALUE OF THE FOURTH PARAMETER (N2 = THE ',
19826     1           'NUMBER OF TRIALS')
19827          CALL DPWRST('XXX','BUG ')
19828          WRITE(ICOUT,2234)
19829 2234     FORMAT('      FOR THE SECOND VARIABLE MUST BE NON-NEGATIVE.')
19830          CALL DPWRST('XXX','BUG ')
19831          WRITE(ICOUT,2235)N2
19832 2235     FORMAT('      N2 = ',I8)
19833          CALL DPWRST('XXX','BUG ')
19834          IERROR='YES'
19835          GOTO9000
19836C
19837        ENDIF
19838C
19839      ELSEIF(IVARTY(1).EQ.'VARI' .OR.
19840     1      (IVARTY(1).EQ.'MATR' .AND. NUMVAR.GT.1))THEN
19841C
19842        ICASE='VARI'
19843        ICOL=1
19844        IF(NUMVAR.NE.2)THEN
19845          WRITE(ICOUT,999)
19846          CALL DPWRST('XXX','BUG ')
19847          WRITE(ICOUT,2201)
19848          CALL DPWRST('XXX','BUG ')
19849          WRITE(ICOUT,2303)
19850 2303     FORMAT('      EXACTLY TWO VARIABLES MUST BE GIVEN.')
19851          CALL DPWRST('XXX','BUG ')
19852          WRITE(ICOUT,2305)NUMVAR
19853 2305     FORMAT('      THE NUMBER OF VARIABLES GIVEN  = ',I5)
19854          CALL DPWRST('XXX','BUG ')
19855          IERROR='YES'
19856          GOTO9000
19857        ENDIF
19858        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
19859     1              INAME,IVARN1,IVARN2,IVARTY,
19860     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
19861     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
19862     1              MAXCP4,MAXCP5,MAXCP6,
19863     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
19864     1              Y,X,X,N1,N2,NLOCA3,ICASE,
19865     1              IBUGA3,ISUBRO,IFOUND,IERROR)
19866        IF(IERROR.EQ.'YES')GOTO9000
19867C
19868      ELSEIF(NUMVAR.EQ.1 .AND. IVARTY(1).EQ.'MATR')THEN
19869C
19870C       IF A SINGLE MATRIX IS GIVEN, ASSUME THAT IT IS IN
19871C       THE FORMAT:
19872C
19873C                                |  VARIABLE ONE    VARIABLE TWO
19874C          =====================================================
19875C          NUMBER OF SUCCESES:   |
19876C          NUMBER OF FAILURES:   |
19877C
19878        ICASE='MATR'
19879        ICOL=1
19880        NUMVAR=1
19881        CALL DPPAR6(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
19882     1              INAME,IVARN1,IVARN2,IVARTY,
19883     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
19884     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
19885     1              MAXCP4,MAXCP5,MAXCP6,
19886     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
19887     1              XMAT,MAXLEV,NROW,NCOL,ICASE,
19888     1              IBUGA3,ISUBRO,IFOUND,IERROR)
19889        IF(IERROR.EQ.'YES')GOTO9000
19890C
19891        IF(NROW.NE.2 .OR. NCOL.NE.2)THEN
19892          WRITE(ICOUT,999)
19893          CALL DPWRST('XXX','BUG ')
19894          WRITE(ICOUT,2201)
19895          CALL DPWRST('XXX','BUG ')
19896          WRITE(ICOUT,2403)
19897 2403     FORMAT('      IF A SINGLE MATRIX IS GIVEN, IT MUST HAVE')
19898          CALL DPWRST('XXX','BUG ')
19899          WRITE(ICOUT,2405)
19900 2405     FORMAT('      EXACTLY TWO ROWS AND TWO COLUMNS.')
19901          CALL DPWRST('XXX','BUG ')
19902          WRITE(ICOUT,2407)NROW
19903 2407     FORMAT('      NUMBER OF ROWS          = ',I8)
19904          CALL DPWRST('XXX','BUG ')
19905          WRITE(ICOUT,2409)NCOL
19906 2409     FORMAT('      NUMBER OF COLUMNS       = ',I8)
19907          CALL DPWRST('XXX','BUG ')
19908          IERROR='YES'
19909          GOTO9000
19910        ENDIF
19911C
19912        DO2420I=1,NROW
19913          DO2430J=1,NCOL
19914            IJUNK=INT(XMAT(I,J)+0.1)
19915            IF(IJUNK.LT.0)THEN
19916              WRITE(ICOUT,999)
19917              CALL DPWRST('XXX','BUG ')
19918              WRITE(ICOUT,2201)
19919              CALL DPWRST('XXX','BUG ')
19920              WRITE(ICOUT,2433)I,J
19921 2433         FORMAT('      NEGATIVE COUNT ENCOUNTERED IN ROW ',I5,
19922     1               ' AND COLUMN ',I5,' OF THE TABLE.')
19923              CALL DPWRST('XXX','BUG ')
19924              WRITE(ICOUT,2435)XMAT(I,J)
19925 2435         FORMAT('      THE COUNT = ',G15.7)
19926              CALL DPWRST('XXX','BUG ')
19927              IERROR='YES'
19928              GOTO9000
19929            ENDIF
19930            XMAT(I,J)=REAL(IJUNK)
19931 2430     CONTINUE
19932 2420   CONTINUE
19933C
19934        AN1=XMAT(1,1) + XMAT(2,1)
19935        P1=XMAT(1,1)/AN1
19936        N1=INT(AN1+0.1)
19937        AN2=XMAT(1,2) + XMAT(2,2)
19938        P2=XMAT(1,2)/AN2
19939        N2=INT(AN2+0.1)
19940        ICASE='PARA'
19941      ENDIF
19942C
19943C               *********************************************
19944C               **  STEP 61--                              **
19945C               **  COMPUTE THE BINOMIAL PROPORTIONS TEST  **
19946C               *********************************************
19947C
19948      ISTEPN='61'
19949      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BNTE')
19950     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19951C
19952      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'BNTE')THEN
19953        WRITE(ICOUT,999)
19954        CALL DPWRST('XXX','BUG ')
19955        WRITE(ICOUT,6111)
19956 6111   FORMAT('***** FROM DPBNTE--READY TO COMPUTE TEST')
19957        CALL DPWRST('XXX','BUG ')
19958        IF(ICASE.EQ.'PARA')THEN
19959          WRITE(ICOUT,6112)P1,P2,N1,N2
19960 6112     FORMAT('P1,P2,N1,N2 = ',2G15.7,2I8)
19961          CALL DPWRST('XXX','BUG ')
19962        ELSE
19963          WRITE(ICOUT,6122)N1,N2
19964 6122     FORMAT('N1,N2 = ',2I8)
19965          CALL DPWRST('XXX','BUG ')
19966          DO6129I=1,MIN(N1,N2)
19967            WRITE(ICOUT,6125)I,Y(I),X(I)
19968 6125       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
19969            CALL DPWRST('XXX','BUG ')
19970 6129     CONTINUE
19971        ENDIF
19972      ENDIF
19973C
19974      CALL DPBNTZ(Y,N1,X,N2,
19975     1            P1,P2,
19976     1            TEMP1,MAXOBV,
19977     1            ICASAN,ICASE,
19978     1            ICAPSW,ICAPTY,IFORSW,
19979     1            STATVA,CDF,PVAL,
19980     1            ISUBRO,IBUGA3,IERROR)
19981C
19982C               ***************************************
19983C               **  STEP 62--                        **
19984C               **  UPDATE INTERNAL DATAPLOT TABLES  **
19985C               ***************************************
19986C
19987      ISTEPN='62'
19988      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BNTE')
19989     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
19990C
19991      ISUBN0='BNTE'
19992C
19993      IH='STAT'
19994      IH2='VAL '
19995      VALUE0=STATVA
19996      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
19997     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
19998     1IANS,IWIDTH,IBUGA3,IERROR)
19999C
20000      IH='STAT'
20001      IH2='CDF '
20002      VALUE0=CDF
20003      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
20004     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
20005     1IANS,IWIDTH,IBUGA3,IERROR)
20006C
20007      IH='PVAL'
20008      IH2='UE  '
20009      VALUE0=PVAL
20010      CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
20011     1IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
20012     1IANS,IWIDTH,IBUGA3,IERROR)
20013C
20014C               *****************
20015C               **  STEP 90--  **
20016C               **  EXIT       **
20017C               *****************
20018C
20019 9000 CONTINUE
20020      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BNTE')THEN
20021        WRITE(ICOUT,999)
20022        CALL DPWRST('XXX','BUG ')
20023        WRITE(ICOUT,9011)
20024 9011   FORMAT('***** AT THE END       OF DPBNTE--')
20025        CALL DPWRST('XXX','BUG ')
20026        WRITE(ICOUT,9012)IBUGA2,IBUGA3
20027 9012   FORMAT('IBUGA2,IBUGA3 = ',A4,2X,A4)
20028        CALL DPWRST('XXX','BUG ')
20029        WRITE(ICOUT,9016)IERROR
20030 9016   FORMAT('IERROR = ',A4,2X,A4)
20031        CALL DPWRST('XXX','BUG ')
20032      ENDIF
20033C
20034      RETURN
20035      END
20036      SUBROUTINE DPBNTZ(Y1,N1,Y2,N2,
20037     1                  P1,P2,
20038     1                  XIDTEM,MAXNXT,
20039     1                  ICASAN,ICASE,
20040     1                  ICAPSW,ICAPTY,IFORSW,
20041     1                  STATVA,CDF,PVAL,
20042     1                  ISUBRO,IBUGA3,IERROR)
20043C
20044C     PURPOSE--PERFORM A BINOMIAL PROPORTION TEST FOR THE EQUALITY
20045C              OF TWO BINOMIAL PROPORTIONS (NOTE THAT THE SAMPLE
20046c              SIZES NEED NOT BE EQUAL).
20047C     EXAMPLE--BINOMIAL PROPORTION TEST Y1 Y2
20048C              SAMPLE 1 IS IN INPUT VECTOR Y1 (WITH N1 OBSERVATIONS).
20049C              SAMPLE 2 IS IN INPUT VECTOR Y2 (WITH N2 OBSERVATIONS).
20050C            --BINOMIAL PROPORTION TEST P1 N1 P2 N2
20051C              USE THIS SYNTAX FOR PRE-COMPUTED FREQUENCIES
20052C     WRITTEN BY--ALAN HECKERT
20053C                 STATISTICAL ENGINEERING DIVISION
20054C                 INFORMATION TECHNOLOGYU LABORATORY
20055C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20056C                 GAITHERSBURG, MD 20899-8980
20057C                 PHONE--301-975-2899
20058C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20059C           OF THE NATIONAL BUREAU OF STANDARDS.
20060C     LANGUAGE--ANSI FORTRAN (1977)
20061C     VERSION NUMBER--2008/8
20062C     ORIGINAL VERSION--AUGUST    2008.
20063C     UPDATED         --FEBRUARY  2011. USE DPDTA1, DPDTA5 TO PRINT
20064C                                       TABLES
20065C
20066C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20067C
20068      CHARACTER*4 ISUBRO
20069      CHARACTER*4 IBUGA3
20070      CHARACTER*4 IERROR
20071      CHARACTER*4 ICASAN
20072      CHARACTER*4 ICASE
20073      CHARACTER*4 ICAPSW
20074      CHARACTER*4 ICAPTY
20075      CHARACTER*4 IFORSW
20076C
20077      CHARACTER*4 IWRITE
20078C
20079      CHARACTER*4 ISUBN1
20080      CHARACTER*4 ISUBN2
20081      CHARACTER*4 ISTEPN
20082C
20083C---------------------------------------------------------------------
20084C
20085      DIMENSION Y1(*)
20086      DIMENSION Y2(*)
20087      DIMENSION XIDTEM(*)
20088C
20089      PARAMETER (NUMALP=6)
20090      DIMENSION SIGVAL(NUMALP)
20091CCCCC DIMENSION ALOWCL(NUMALP)
20092CCCCC DIMENSION AUPPCL(NUMALP)
20093CCCCC DIMENSION ALOWC2(NUMALP)
20094CCCCC DIMENSION AUPPC2(NUMALP)
20095      DIMENSION CV(NUMALP)
20096      CHARACTER*6 ICONC(NUMALP)
20097C
20098      PARAMETER(NUMCLI=5)
20099      PARAMETER(MAXLIN=3)
20100      PARAMETER (MAXROW=NUMALP)
20101      PARAMETER (MAXRO2=25)
20102      CHARACTER*60 ITITLE
20103      CHARACTER*60 ITITLZ
20104      CHARACTER*60 ITITL9
20105      CHARACTER*60 ITEXT(MAXRO2)
20106      CHARACTER*4  ALIGN(NUMCLI)
20107      CHARACTER*4  VALIGN(NUMCLI)
20108      REAL         AVALUE(MAXRO2)
20109      INTEGER      NCTEXT(MAXRO2)
20110      INTEGER      IDIGIT(MAXRO2)
20111      INTEGER      NTOT(MAXRO2)
20112      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
20113      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
20114      CHARACTER*4  ITYPCO(NUMCLI)
20115      INTEGER      NCTIT2(MAXLIN,NUMCLI)
20116      INTEGER      NCVALU(MAXROW,NUMCLI)
20117      INTEGER      IWHTML(NUMCLI)
20118      INTEGER      IWRTF(NUMCLI)
20119      REAL         AMAT(MAXROW,NUMCLI)
20120      LOGICAL IFRST
20121      LOGICAL ILAST
20122      LOGICAL IFLAGS
20123      LOGICAL IFLAGE
20124C
20125      INCLUDE 'DPCOST.INC'
20126C
20127C---------------------------------------------------------------------
20128C
20129      INCLUDE 'DPCOP2.INC'
20130C
20131      DATA SIGVAL /0.50, 0.80, 0.90, 0.95, 0.975, 0.99/
20132C
20133C-----START POINT-----------------------------------------------------
20134C
20135      ISUBN1='DPBN'
20136      ISUBN2='TZ  '
20137      IERROR='NO'
20138      IWRITE='NO'
20139C
20140      DO20I=1,6
20141        ICONC(I)='REJECT'
20142   20 CONTINUE
20143C
20144      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BNTZ')THEN
20145        WRITE(ICOUT,999)
20146  999   FORMAT(1X)
20147        CALL DPWRST('XXX','WRIT')
20148        WRITE(ICOUT,51)
20149   51   FORMAT('**** AT THE BEGINNING OF DPBNTZ--')
20150        CALL DPWRST('XXX','WRIT')
20151        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASE,IBINCC,MAXNXT
20152   52   FORMAT('IBUGA3,ISUBRO,ICASE,IBINCC,MAXNXT = ',4(A4,2X),I8)
20153        CALL DPWRST('XXX','WRIT')
20154        IF(ICASE.EQ.'VARI')THEN
20155          WRITE(ICOUT,55)N1
20156   55     FORMAT('N1 = ',I8)
20157          CALL DPWRST('XXX','WRIT')
20158          DO56I=1,N1
20159            WRITE(ICOUT,57)I,Y1(I)
20160   57       FORMAT('I,Y1(I) = ',I8,E15.7)
20161            CALL DPWRST('XXX','WRIT')
20162   56     CONTINUE
20163          WRITE(ICOUT,65)N2
20164   65     FORMAT('N2 = ',I8)
20165          CALL DPWRST('XXX','WRIT')
20166          DO66I=1,N2
20167            WRITE(ICOUT,67)I,Y2(I)
20168   67       FORMAT('I,Y2(I) = ',I8,E15.7)
20169            CALL DPWRST('XXX','WRIT')
20170   66     CONTINUE
20171        ELSE
20172          WRITE(ICOUT,75)P1,P2,N1,N2
20173   75     FORMAT('P1,P2,N1,N2 = ',2G15.7,2I8)
20174          CALL DPWRST('XXX','WRIT')
20175        ENDIF
20176      ENDIF
20177C
20178C               ********************************************
20179C               **  STEP 0--                              **
20180C               **  BRANCH TO APPROPRIATE CASE (PARAMETER **
20181C               **  OR VARIABLE)                          **
20182C               ********************************************
20183C
20184      ISTEPN='00'
20185      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BNTZ')
20186     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20187C
20188      IF(ICASE.EQ.'PARA')GOTO1000
20189      IF(ICASE.EQ.'VARI')GOTO2000
20190C
20191C               ********************************************
20192C               **  STEP 11--                             **
20193C               **  PARAMETER CASE                        **
20194C               ********************************************
20195C
20196 1000 CONTINUE
20197C
20198      ISTEPN='11'
20199      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BNTZ')
20200     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20201C
20202C               ********************************************
20203C               **  STEP 12--                             **
20204C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
20205C               ********************************************
20206C
20207      AN1=REAL(N1)
20208      AN2=REAL(N2)
20209C
20210      IX1=INT(AN1*P1 + 0.5)
20211      IX2=INT(AN2*P2 + 0.5)
20212      PHAT=REAL(IX1+IX2)/(AN1+AN2)
20213      SDP=SQRT(PHAT*(1.0-PHAT)*((1.0/AN1) + (1.0/AN2)))
20214      GOTO4000
20215C
20216C               ********************************************
20217C               **  STEP 20--                             **
20218C               **  VARIABLE  CASE                        **
20219C               ********************************************
20220C
20221 2000 CONTINUE
20222C
20223C               ********************************************
20224C               **  STEP 21--                             **
20225C               **  CHECK THAT THE VARIABLES HAVE AT MOST **
20226C               **  TWO DISTINCT VALUES (1 INDICATES A    **
20227C               **  SUCCESS, 0 INDICATES A FAILURE).      **
20228C               ********************************************
20229C
20230      ISTEPN='21'
20231      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BNTZ')
20232     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20233C
20234      CALL DISTIN(Y1,N1,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
20235      IF(NDIST.EQ.1)THEN
20236        AVAL=XIDTEM(1)
20237        IF(ABS(AVAL).LE.0.5)THEN
20238          AVAL=0.0
20239        ELSE
20240          AVAL=1.0
20241        ENDIF
20242        DO2202I=1,N1
20243          Y1(I)=1.0
20244 2202   CONTINUE
20245      ELSEIF(NDIST.EQ.2)THEN
20246        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
20247          DO2203I=1,N1
20248            IF(Y1(I).NE.1.0)Y1(I)=0.0
20249 2203     CONTINUE
20250        ELSE
20251          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
20252          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
20253          DO2208I=1,N1
20254            IF(Y1(I).EQ.ATEMP1)Y1(I)=0.0
20255            IF(Y1(I).EQ.ATEMP2)Y1(I)=1.0
20256 2208     CONTINUE
20257        ENDIF
20258      ELSE
20259        WRITE(ICOUT,999)
20260        CALL DPWRST('XXX','BUG ')
20261        WRITE(ICOUT,2201)
20262 2201   FORMAT('***** ERROR IN BINOMIAL TEST FOR EQUAL ',
20263     1         'PROPORTIONS--')
20264        CALL DPWRST('XXX','BUG ')
20265        WRITE(ICOUT,2211)
20266 2211   FORMAT('      RESPONSE VARIABLE ONE SHOULD CONTAIN AT MOST')
20267        CALL DPWRST('XXX','BUG ')
20268        WRITE(ICOUT,2213)
20269 2213   FORMAT('      TWO DISTINCT VALUES.')
20270        CALL DPWRST('XXX','BUG ')
20271        WRITE(ICOUT,2215)NDIST
20272 2215   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
20273        CALL DPWRST('XXX','BUG ')
20274        IERROR='YES'
20275        GOTO9000
20276      ENDIF
20277C
20278      CALL DISTIN(Y2,N2,IWRITE,XIDTEM,NDIST,IBUGA3,IERROR)
20279      IF(NDIST.EQ.1)THEN
20280        AVAL=XIDTEM(1)
20281        IF(ABS(AVAL).LE.0.5)THEN
20282          AVAL=0.0
20283        ELSE
20284          AVAL=1.0
20285        ENDIF
20286        DO2302I=1,N2
20287          Y2(I)=1.0
20288 2302   CONTINUE
20289      ELSEIF(NDIST.EQ.2)THEN
20290        IF(XIDTEM(1).EQ.1.0 .OR. XIDTEM(2).EQ.1.0)THEN
20291          DO2303I=1,N2
20292            IF(Y2(I).NE.1.0)Y2(I)=0.0
20293 2303     CONTINUE
20294        ELSE
20295          ATEMP1=MIN(XIDTEM(1),XIDTEM(2))
20296          ATEMP2=MAX(XIDTEM(1),XIDTEM(2))
20297          DO2308I=1,N2
20298            IF(Y2(I).EQ.ATEMP1)Y2(I)=0.0
20299            IF(Y2(I).EQ.ATEMP2)Y2(I)=1.0
20300 2308     CONTINUE
20301        ENDIF
20302      ELSE
20303        WRITE(ICOUT,999)
20304        CALL DPWRST('XXX','BUG ')
20305        WRITE(ICOUT,2201)
20306        CALL DPWRST('XXX','BUG ')
20307        WRITE(ICOUT,2311)
20308 2311   FORMAT('      RESPONSE VARIABLE TWO SHOULD CONTAIN AT MOST')
20309        CALL DPWRST('XXX','BUG ')
20310        WRITE(ICOUT,2313)
20311 2313   FORMAT('      TWO DISTINCT VALUES.')
20312        CALL DPWRST('XXX','BUG ')
20313        WRITE(ICOUT,2315)NDIST
20314 2315   FORMAT('      ',I8,' DISTINCT VALUES FOUND.')
20315        CALL DPWRST('XXX','BUG ')
20316        IERROR='YES'
20317        GOTO9000
20318      ENDIF
20319C
20320      AN1=REAL(N1)
20321      AN2=REAL(N2)
20322      CALL SUMDP(Y1,N1,IWRITE,XSUM1,IBUGA3,IERROR)
20323      P1=XSUM1/AN1
20324      CALL SUMDP(Y2,N2,IWRITE,XSUM2,IBUGA3,IERROR)
20325      P2=XSUM2/AN2
20326      PHAT=(XSUM1+XSUM2)/(AN1+AN2)
20327      SDP=SQRT(PHAT*(1.0-PHAT)*((1.0/AN1) + (1.0/AN2)))
20328C
20329      GOTO4000
20330C
20331 4000 CONTINUE
20332C
20333      ISTEPN='41'
20334      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BNTZ')
20335     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20336C
20337      IWRITE='OFF'
20338C
20339      STATVA=(P1-P2)/SDP
20340      CALL NORCDF(STATVA,CDF)
20341      IF(ICASAN.EQ.'BPLT')THEN
20342        PVAL=CDF
20343      ELSEIF(ICASAN.EQ.'BPUT')THEN
20344        PVAL=1.0-CDF
20345      ELSE
20346        CALL NORCDF(ABS(STATVA),ATEMP)
20347        PVAL=2.0*(1.0-ATEMP)
20348      ENDIF
20349C
20350      IF(ICASAN.EQ.'BPLT')THEN
20351        DO4010I=1,6
20352          ALPHA=SIGVAL(I)
20353          CALL NORPPF(1.0-ALPHA,CV(I))
20354          IF(CDF.LE.1.0-ALPHA)ICONC(I)='ACCEPT'
20355 4010   CONTINUE
20356      ELSEIF(ICASAN.EQ.'BPUT')THEN
20357        DO4020I=1,6
20358          ALPHA=SIGVAL(I)
20359          CALL NORPPF(ALPHA,CV(I))
20360          IF(CDF.GT.1.0-ALPHA)ICONC(I)='ACCEPT'
20361 4020   CONTINUE
20362      ELSE
20363        DO4030I=1,6
20364          ALPHA=SIGVAL(I)
20365          ALPHAT=(1.0 - ALPHA)/2.
20366          ALPHAL=ALPHAT
20367          ALPHAU=1.0 - ALPHAT
20368          CALL NORPPF(ALPHAU,CV(I))
20369          IF(ALPHAL.LE.CDF .AND. CDF.LE.ALPHAU)ICONC(I)='ACCEPT'
20370 4030   CONTINUE
20371      ENDIF
20372C
20373C               **************************************
20374C               **   STEP 42--                      **
20375C               **   WRITE OUT EVERYTHING           **
20376C               **   FOR BINOMIAL PROPORTION  TEST  **
20377C               **************************************
20378C
20379      ISTEPN='42'
20380      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BNTZ')
20381     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20382C
20383C     PRINT SUMMARY STATISTICS TABLE
20384C
20385      IF(IPRINT.EQ.'OFF')GOTO9000
20386C
20387      NUMDIG=7
20388      IF(IFORSW.EQ.'1')NUMDIG=1
20389      IF(IFORSW.EQ.'2')NUMDIG=2
20390      IF(IFORSW.EQ.'3')NUMDIG=3
20391      IF(IFORSW.EQ.'4')NUMDIG=4
20392      IF(IFORSW.EQ.'5')NUMDIG=5
20393      IF(IFORSW.EQ.'6')NUMDIG=6
20394      IF(IFORSW.EQ.'7')NUMDIG=7
20395      IF(IFORSW.EQ.'8')NUMDIG=8
20396      IF(IFORSW.EQ.'9')NUMDIG=9
20397      IF(IFORSW.EQ.'0')NUMDIG=0
20398      IF(IFORSW.EQ.'E')NUMDIG=-2
20399      IF(IFORSW.EQ.'-2')NUMDIG=-2
20400      IF(IFORSW.EQ.'-3')NUMDIG=-3
20401      IF(IFORSW.EQ.'-4')NUMDIG=-4
20402      IF(IFORSW.EQ.'-5')NUMDIG=-5
20403      IF(IFORSW.EQ.'-6')NUMDIG=-6
20404      IF(IFORSW.EQ.'-7')NUMDIG=-7
20405      IF(IFORSW.EQ.'-8')NUMDIG=-8
20406      IF(IFORSW.EQ.'-9')NUMDIG=-9
20407C
20408      ITITLE='Binomial Test for Equal Proportions'
20409      NCTITL=35
20410      ITITLZ='(Large Sample Case)'
20411      NCTITZ=19
20412C
20413      ICNT=0
20414      ICNT=ICNT+1
20415      ITEXT(ICNT)=' '
20416      NCTEXT(ICNT)=0
20417      AVALUE(ICNT)=0.0
20418      IDIGIT(ICNT)=-1
20419      ICNT=ICNT+1
20420      ITEXT(ICNT)='H0: P1 = P2'
20421      NCTEXT(ICNT)=11
20422      AVALUE(ICNT)=0.0
20423      IDIGIT(ICNT)=-1
20424      ICNT=ICNT+1
20425      IF(ICASAN.EQ.'BP2T')THEN
20426        ITEXT(ICNT)='Ha: P1 <> P2'
20427        NCTEXT(ICNT)=12
20428      ELSEIF(ICASAN.EQ.'BPLT')THEN
20429        ITEXT(ICNT)='Ha: P1 < P2'
20430        NCTEXT(ICNT)=11
20431      ELSEIF(ICASAN.EQ.'BPUT')THEN
20432        ITEXT(ICNT)='Ha: P1 > P2'
20433        NCTEXT(ICNT)=11
20434      ENDIF
20435      AVALUE(ICNT)=0.0
20436      IDIGIT(ICNT)=-1
20437      ICNT=ICNT+1
20438      ITEXT(ICNT)=' '
20439      NCTEXT(ICNT)=0
20440      AVALUE(ICNT)=0.0
20441      IDIGIT(ICNT)=-1
20442C
20443      ICNT=ICNT+1
20444      ITEXT(ICNT)='Sample 1:'
20445      NCTEXT(ICNT)=9
20446      AVALUE(ICNT)=0.0
20447      IDIGIT(ICNT)=-1
20448      ICNT=ICNT+1
20449      ITEXT(ICNT)='Number of Observations:'
20450      NCTEXT(ICNT)=23
20451      AVALUE(ICNT)=REAL(N1)
20452      IDIGIT(ICNT)=0
20453      ICNT=ICNT+1
20454      ITEXT(ICNT)='Probability of Successes:'
20455      NCTEXT(ICNT)=25
20456      AVALUE(ICNT)=P1
20457      IDIGIT(ICNT)=NUMDIG
20458      ICNT=ICNT+1
20459      ITEXT(ICNT)=' '
20460      NCTEXT(ICNT)=0
20461      AVALUE(ICNT)=0.0
20462      IDIGIT(ICNT)=-1
20463C
20464      ICNT=ICNT+1
20465      ITEXT(ICNT)='Sample 2:'
20466      NCTEXT(ICNT)=9
20467      AVALUE(ICNT)=0.0
20468      IDIGIT(ICNT)=-1
20469      ICNT=ICNT+1
20470      ITEXT(ICNT)='Number of Observations:'
20471      NCTEXT(ICNT)=23
20472      AVALUE(ICNT)=REAL(N2)
20473      IDIGIT(ICNT)=0
20474      ICNT=ICNT+1
20475      ITEXT(ICNT)='Probability of Successes:'
20476      NCTEXT(ICNT)=25
20477      AVALUE(ICNT)=P2
20478      IDIGIT(ICNT)=NUMDIG
20479      ICNT=ICNT+1
20480      ITEXT(ICNT)=' '
20481      NCTEXT(ICNT)=0
20482      AVALUE(ICNT)=0.0
20483      IDIGIT(ICNT)=-1
20484      ICNT=ICNT+1
20485      ITEXT(ICNT)='Pooled Probability of Success:'
20486      NCTEXT(ICNT)=30
20487      AVALUE(ICNT)=PHAT
20488      IDIGIT(ICNT)=NUMDIG
20489      ICNT=ICNT+1
20490      ITEXT(ICNT)='Pooled Standard Deviation:'
20491      NCTEXT(ICNT)=26
20492      AVALUE(ICNT)=SDP
20493      IDIGIT(ICNT)=NUMDIG
20494      ICNT=ICNT+1
20495      ITEXT(ICNT)=' '
20496      NCTEXT(ICNT)=0
20497      AVALUE(ICNT)=0.0
20498      IDIGIT(ICNT)=-1
20499      ICNT=ICNT+1
20500      ITEXT(ICNT)='Test Statistic:'
20501      NCTEXT(ICNT)=15
20502      AVALUE(ICNT)=STATVA
20503      IDIGIT(ICNT)=NUMDIG
20504C
20505      ICNT=ICNT+1
20506      ITEXT(ICNT)='P-Value:'
20507      NCTEXT(ICNT)=8
20508      AVALUE(ICNT)=PVAL
20509      IDIGIT(ICNT)=NUMDIG
20510      ICNT=ICNT+1
20511      ITEXT(ICNT)='CDF of Test Statistic:'
20512      NCTEXT(ICNT)=22
20513      AVALUE(ICNT)=CDF
20514      IDIGIT(ICNT)=NUMDIG
20515C
20516      NUMROW=ICNT
20517      DO2310I=1,NUMROW
20518        NTOT(I)=15
20519 2310 CONTINUE
20520C
20521      IFRST=.TRUE.
20522      ILAST=.TRUE.
20523      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,
20524     1            NCTEXT,AVALUE,IDIGIT,
20525     1            NTOT,NUMROW,
20526     1            ICAPSW,ICAPTY,ILAST,IFRST,
20527     1            ISUBRO,IBUGA3,IERROR)
20528C
20529      ITITLE(1:25)=' '
20530      NCTITL=0
20531      ITITL9=' '
20532      NCTIT9=0
20533C
20534      ITITL2(1,1)=' '
20535      NCTIT2(1,1)=0
20536      ITITL2(2,1)='Null'
20537      NCTIT2(2,1)=4
20538      ITITL2(3,1)='Hypothesis'
20539      NCTIT2(3,1)=10
20540      ITITL2(1,2)=' '
20541      NCTIT2(1,2)=0
20542      ITITL2(2,2)='Confidence'
20543      NCTIT2(2,2)=10
20544      ITITL2(3,2)='Level'
20545      NCTIT2(3,2)=5
20546      ITITL2(1,3)=' '
20547      NCTIT2(1,3)=0
20548      ITITL2(2,3)='Critical'
20549      NCTIT2(2,3)=8
20550      IF(ICASAN.EQ.'BPLT')THEN
20551        ITITL2(3,3)='Value (>)'
20552        NCTIT2(3,3)=9
20553      ELSEIF(ICASAN.EQ.'BPUT')THEN
20554        ITITL2(3,3)='Value (<)'
20555        NCTIT2(3,3)=9
20556      ELSE
20557        ITITL2(3,3)='Value (+/-)'
20558        NCTIT2(3,3)=11
20559      ENDIF
20560      ITITL2(1,4)='Null Hypothesis'
20561      NCTIT2(1,4)=15
20562      ITITL2(2,4)='Acceptance'
20563      NCTIT2(2,4)=10
20564      ITITL2(3,4)='Interval'
20565      NCTIT2(3,4)=8
20566      ITITL2(1,5)='Null'
20567      NCTIT2(1,5)=4
20568      ITITL2(2,5)='Hypothesis'
20569      NCTIT2(2,5)=10
20570      ITITL2(3,5)='Conclusion'
20571      NCTIT2(3,5)=10
20572C
20573      NMAX=0
20574      NUMCOL=5
20575      DO5210I=1,NUMCOL
20576        VALIGN(I)='b'
20577        ALIGN(I)='r'
20578        NTOT(I)=15
20579        IF(I.EQ.4)NTOT(I)=18
20580        NMAX=NMAX+NTOT(I)
20581        IF(I.EQ.3)THEN
20582          ITYPCO(I)='NUME'
20583        ELSE
20584          ITYPCO(I)='ALPH'
20585        ENDIF
20586        IF(I.EQ.2)THEN
20587          IDIGIT(I)=1
20588        ELSEIF(I.EQ.3)THEN
20589          IDIGIT(I)=2
20590        ELSE
20591          IDIGIT(I)=NUMDIG
20592        ENDIF
20593        IWHTML(1)=150
20594        IWHTML(2)=125
20595        IWHTML(3)=125
20596        IWHTML(4)=150
20597        IWHTML(5)=150
20598        IINC=1600
20599        IINC2=1400
20600        IINC3=2200
20601        IWRTF(1)=IINC
20602        IWRTF(2)=IWRTF(1)+IINC
20603        IWRTF(3)=IWRTF(2)+IINC2
20604        IWRTF(4)=IWRTF(3)+IINC3
20605        IWRTF(5)=IWRTF(4)+IINC2
20606C
20607        DO5289J=1,NUMALP
20608          IF(J.EQ.1)THEN
20609            IVALUE(J,2)='50.0%'
20610            NCVALU(J,2)=5
20611            AMAT(J,3)=CV(1)
20612            IVALUE(J,5)(1:6)=ICONC(1)(1:6)
20613            NCVALU(J,5)=6
20614            IF(ICASAN.EQ.'BPLT')THEN
20615              IVALUE(J,4)='(0,0.500)'
20616              NCVALU(J,4)=9
20617            ELSEIF(ICASAN.EQ.'BPUT')THEN
20618              IVALUE(J,4)='(0.500,1)'
20619              NCVALU(J,4)=9
20620            ELSE
20621              IVALUE(J,4)='(0.250,0.750)'
20622              NCVALU(J,4)=13
20623            ENDIF
20624          ELSEIF(J.EQ.2)THEN
20625            IVALUE(J,2)='80.0%'
20626            NCVALU(J,2)=5
20627            AMAT(J,3)=CV(2)
20628            IVALUE(J,5)(1:6)=ICONC(2)(1:6)
20629            NCVALU(J,5)=6
20630            IF(ICASAN.EQ.'BPLT')THEN
20631              IVALUE(J,4)='(0.0.800)'
20632              NCVALU(J,4)=9
20633            ELSEIF(ICASAN.EQ.'BPUT')THEN
20634              IVALUE(J,4)='(0.200,1)'
20635              NCVALU(J,4)=9
20636            ELSE
20637              IVALUE(J,4)='(0.100,0.900)'
20638              NCVALU(J,4)=13
20639            ENDIF
20640          ELSEIF(J.EQ.3)THEN
20641            IVALUE(J,2)='90.0%'
20642            NCVALU(J,2)=5
20643            AMAT(J,3)=CV(3)
20644            IVALUE(J,5)(1:6)=ICONC(3)(1:6)
20645            NCVALU(J,5)=6
20646            IF(ICASAN.EQ.'BPLT')THEN
20647              IVALUE(J,4)='(0,0.900)'
20648              NCVALU(J,4)=9
20649            ELSEIF(ICASAN.EQ.'BPUT')THEN
20650              IVALUE(J,4)='(0.100,1)'
20651              NCVALU(J,4)=9
20652            ELSE
20653              IVALUE(J,4)='(0.050,0.950)'
20654              NCVALU(J,4)=13
20655            ENDIF
20656          ELSEIF(J.EQ.4)THEN
20657            IVALUE(J,2)='95.0%'
20658            NCVALU(J,2)=5
20659            AMAT(J,3)=CV(4)
20660            IVALUE(J,5)(1:6)=ICONC(4)(1:6)
20661            NCVALU(J,5)=6
20662            IF(ICASAN.EQ.'BPLT')THEN
20663              IVALUE(J,4)='(0,0.950)'
20664              NCVALU(J,4)=9
20665            ELSEIF(ICASAN.EQ.'BPUT')THEN
20666              IVALUE(J,4)='(0.050,1)'
20667              NCVALU(J,4)=9
20668            ELSE
20669              IVALUE(J,4)='(0.025,0.975)'
20670              NCVALU(J,4)=13
20671            ENDIF
20672          ELSEIF(J.EQ.5)THEN
20673            IVALUE(J,2)='97.5%'
20674            NCVALU(J,2)=5
20675            AMAT(J,3)=CV(5)
20676            IVALUE(J,5)(1:6)=ICONC(5)(1:6)
20677            NCVALU(J,5)=6
20678            IVALUE(J,4)='(0,0.975)'
20679            NCVALU(J,4)=9
20680            IF(ICASAN.EQ.'BPLT')THEN
20681              IVALUE(J,4)='(0,0.975)'
20682              NCVALU(J,4)=9
20683            ELSEIF(ICASAN.EQ.'BPUT')THEN
20684              IVALUE(J,4)='(0.025,1)'
20685              NCVALU(J,4)=9
20686            ELSE
20687              IVALUE(J,4)='(0.0125,0.9875)'
20688              NCVALU(J,4)=15
20689            ENDIF
20690          ELSEIF(J.EQ.6)THEN
20691            IVALUE(J,2)='99.0%'
20692            NCVALU(J,2)=5
20693            AMAT(J,3)=CV(6)
20694            IVALUE(J,5)(1:6)=ICONC(6)(1:6)
20695            NCVALU(J,5)=6
20696            IF(ICASAN.EQ.'BPLT')THEN
20697              IVALUE(J,4)='(0,0.990)'
20698              NCVALU(J,4)=9
20699            ELSEIF(ICASAN.EQ.'BPUT')THEN
20700              IVALUE(J,4)='(0.010,1)'
20701              NCVALU(J,4)=9
20702            ELSE
20703              IVALUE(J,4)='(0.005,0.995)'
20704              NCVALU(J,4)=13
20705            ENDIF
20706          ENDIF
20707          AMAT(J,1)=0.0
20708          AMAT(J,2)=0.0
20709          AMAT(J,4)=0.0
20710          AMAT(J,5)=0.0
20711          IF(ICASAN.EQ.'BPLT')THEN
20712            IVALUE(J,1)='P1 < P2'
20713            NCVALU(J,1)=7
20714          ELSEIF(ICASAN.EQ.'BPUT')THEN
20715            IVALUE(J,1)='P1 > P2'
20716            NCVALU(J,1)=7
20717          ELSE
20718            IVALUE(J,1)='P1 = P2'
20719            NCVALU(J,1)=7
20720          ENDIF
20721 5289   CONTINUE
20722C
20723 5210 CONTINUE
20724C
20725      ICNT=NUMALP
20726      NUMLIN=3
20727      NUMCOL=5
20728      IFRST=.TRUE.
20729      ILAST=.TRUE.
20730      IFLAGS=.TRUE.
20731      IFLAGE=.TRUE.
20732      CALL DPDTA5(ITITLE,NCTITL,
20733     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
20734     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
20735     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
20736     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
20737     1            ICAPSW,ICAPTY,IFRST,ILAST,
20738     1            IFLAGS,IFLAGE,
20739     1            ISUBRO,IBUGA3,IERROR)
20740C
20741C               *****************
20742C               **  STEP 90--  **
20743C               **  EXIT       **
20744C               *****************
20745C
20746 9000 CONTINUE
20747      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BNTZ')THEN
20748        WRITE(ICOUT,999)
20749        CALL DPWRST('XXX','WRIT')
20750        WRITE(ICOUT,9011)
20751 9011   FORMAT('***** AT THE END       OF DPBNTZ--')
20752        CALL DPWRST('XXX','WRIT')
20753        WRITE(ICOUT,9013)N1,N2
20754 9013   FORMAT('N1,N2 =',2I8)
20755        CALL DPWRST('XXX','WRIT')
20756        WRITE(ICOUT,9015)P1,P2
20757 9015   FORMAT('P1,P2 =',2G15.7)
20758        CALL DPWRST('XXX','WRIT')
20759      ENDIF
20760C
20761      RETURN
20762      END
20763      SUBROUTINE DPBNTR(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
20764     1IBUGG2,IBUGG3,ISUBRO,IBUGQ,IFOUND,IERROR)
20765C
20766C     PURPOSE--GENERATE A BIVARIATE NORMAL TOLERANCE REGION PLOT.
20767C     REFERENCE--HALL AND SHELDON, "IMPROVED BIVARIATE NORMAL
20768C                TOLERANCE REGIONS WITH SOME APPLICATIONS",
20769C                JOURNAL OF QUALITY TECHNOLOGY, VOL 11,
20770C                NO. 1, JANUARY 1979.
20771C              --ISO 13528, "STATISTICAL METHODS FOR USE IN PROFICIENCY
20772C                TESTING BY INTERLABORATORY COMPARISONS", 2005.
20773C              --JACKSON, "QUALITY CONTROL METHODS FOR TWO RELATED
20774C                VARIABLES", INDUSTRIAL QUALITY CONTROL, 7, 1956,
20775C                PP. 2-6.
20776C     WRITTEN BY--ALAN HECKERT
20777C                 STATISTICAL ENGINEERING DIVISION
20778C                 INFORMATION TECHNOLOGY LABORATORY
20779C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
20780C                 GAITHERSBURG, MD 20899-8980
20781C                 PHONE--301-975-2899
20782C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
20783C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
20784C     LANGUAGE--ANSI FORTRAN (1977)
20785C     VERSION NUMBER--2007/4
20786C     ORIGINAL VERSION--APRIL     2007.
20787C     UPDATED         --FEBRUARY  2011. USE DPPARS, DPPAR5
20788C     UPDATED         --NOVEMBER  2013. SUPPORT CONFIDENCE ELLIPSE
20789C                                       (AS OPPOSED TO TOLERANCE
20790C     UPDATED         --JULY      2017. SUPPORT POINCARE PLOT
20791C
20792C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
20793C
20794      CHARACTER*4 ICASPL
20795      CHARACTER*4 IAND1
20796      CHARACTER*4 IAND2
20797      CHARACTER*4 IBUGG2
20798      CHARACTER*4 IBUGG3
20799      CHARACTER*4 ISUBRO
20800      CHARACTER*4 IBUGQ
20801      CHARACTER*4 IFOUND
20802      CHARACTER*4 IERROR
20803C
20804      CHARACTER*4 IHWUSE
20805      CHARACTER*4 MESSAG
20806C
20807      CHARACTER*4 IH
20808      CHARACTER*4 IH2
20809C
20810      CHARACTER*4 ISUBN0
20811      CHARACTER*4 IHOST1
20812      CHARACTER*4 ISUBN1
20813      CHARACTER*4 ISUBN2
20814      CHARACTER*4 ISTEPN
20815C
20816      CHARACTER*4 ICASE
20817      CHARACTER*40 INAME
20818      PARAMETER (MAXSPN=30)
20819      CHARACTER*4 IVARN1(MAXSPN)
20820      CHARACTER*4 IVARN2(MAXSPN)
20821      CHARACTER*4 IVARTY(MAXSPN)
20822      REAL PVAR(MAXSPN)
20823      INTEGER ILIS(MAXSPN)
20824      INTEGER NRIGHT(MAXSPN)
20825      INTEGER ICOLR(MAXSPN)
20826C
20827C---------------------------------------------------------------------
20828C
20829C-----COMMON----------------------------------------------------------
20830C
20831      INCLUDE 'DPCOPA.INC'
20832C
20833      DIMENSION Y1(MAXOBV)
20834      DIMENSION Y2(MAXOBV)
20835      DIMENSION XGROUP(MAXOBV)
20836      DIMENSION DELTAV(MAXOBV)
20837      DIMENSION XIDTEM(MAXOBV)
20838      DIMENSION TEMP1(MAXOBV)
20839      DIMENSION TEMP2(MAXOBV)
20840C
20841      INCLUDE 'DPCOZZ.INC'
20842      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
20843      EQUIVALENCE (GARBAG(IGARB2),Y2(1))
20844      EQUIVALENCE (GARBAG(IGARB3),XGROUP(1))
20845      EQUIVALENCE (GARBAG(IGARB4),DELTAV(1))
20846      EQUIVALENCE (GARBAG(IGARB5),XIDTEM(1))
20847      EQUIVALENCE (GARBAG(IGARB6),TEMP1(1))
20848      EQUIVALENCE (GARBAG(IGARB7),TEMP2(1))
20849C
20850      INCLUDE 'DPCOHK.INC'
20851      INCLUDE 'DPCODA.INC'
20852      INCLUDE 'DPCOST.INC'
20853C
20854C-----COMMON VARIABLES (GENERAL)--------------------------------------
20855C
20856      INCLUDE 'DPCOP2.INC'
20857C
20858C-----START POINT-----------------------------------------------------
20859C
20860      IFOUND='NO'
20861      IERROR='NO'
20862      ISUBN1='DPBN'
20863      ISUBN2='TR  '
20864C
20865      MAXCP1=MAXCOL+1
20866      MAXCP2=MAXCOL+2
20867      MAXCP3=MAXCOL+3
20868      MAXCP4=MAXCOL+4
20869      MAXCP5=MAXCOL+5
20870      MAXCP6=MAXCOL+6
20871C
20872C               ***************************************************
20873C               **  TREAT THE BIVARIATE NORMAL TOLERANCE REGION  **
20874C               **  PLOT CASE                                    **
20875C               ***************************************************
20876C
20877      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BNTR')THEN
20878        WRITE(ICOUT,999)
20879  999   FORMAT(1X)
20880        CALL DPWRST('XXX','BUG ')
20881        WRITE(ICOUT,51)
20882   51   FORMAT('***** AT THE BEGINNING OF DPBNTR--')
20883        CALL DPWRST('XXX','BUG ')
20884        WRITE(ICOUT,53)ICASPL,IAND1,IAND2
20885   53   FORMAT('ICASPL,IAND1,IAND2 = ',2(A4,2X),A4)
20886        CALL DPWRST('XXX','BUG ')
20887        WRITE(ICOUT,54)IBUGG2,IBUGG3,ISUBRO,IBUGQ
20888   54   FORMAT('IBUGG2,IBUGG3,ISUBRO,IBUGQ = ',3(A4,2X),A4)
20889        CALL DPWRST('XXX','BUG ')
20890      ENDIF
20891C
20892C               *********************************************
20893C               **  STEP 1--                               **
20894C               **  SEARCH FOR BIVARIATE NORMAL TOLERANCE  **
20895C               **  REGION PLOT                            **
20896C               *********************************************
20897C
20898      ISTEPN='1'
20899      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BNTR')
20900     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20901C
20902      ICASPL='BNTR'
20903      IF(NUMARG.GE.4.AND.
20904     1  IHARG(1).EQ.'NORM' .AND. IHARG(2).EQ.'TOLE' .AND.
20905     1  (IHARG(3).EQ.'REGI' .OR. IHARG(3).EQ.'INTE' .OR.
20906     1   IHARG(3).EQ.'LIMI') .AND.
20907     1  IHARG(4).EQ.'PLOT')THEN
20908        ILASTC=4
20909        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
20910        IFOUND='YES'
20911      ELSEIF(NUMARG.GE.4.AND.
20912     1  IHARG(1).EQ.'NORM' .AND. IHARG(2).EQ.'CONF' .AND.
20913     1  (IHARG(3).EQ.'REGI' .OR. IHARG(3).EQ.'INTE' .OR.
20914     1   IHARG(3).EQ.'LIMI') .AND.
20915     1  IHARG(4).EQ.'PLOT')THEN
20916        ICASPL='BNCR'
20917        ILASTC=4
20918        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
20919        IFOUND='YES'
20920      ELSEIF(NUMARG.GE.3.AND.
20921     1  IHARG(1).EQ.'NORM' .AND. IHARG(2).EQ.'TOLE' .AND.
20922     1  (IHARG(3).EQ.'REGI' .OR. IHARG(3).EQ.'INTE' .OR.
20923     1   IHARG(3).EQ.'LIMI'))THEN
20924        ILASTC=3
20925        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
20926        IFOUND='YES'
20927      ELSEIF(NUMARG.GE.3.AND.
20928     1  IHARG(1).EQ.'NORM' .AND. IHARG(2).EQ.'CONF' .AND.
20929     1  (IHARG(3).EQ.'REGI' .OR. IHARG(3).EQ.'INTE' .OR.
20930     1   IHARG(3).EQ.'LIMI'))THEN
20931        ICASPL='BNCR'
20932        ILASTC=3
20933        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
20934        IFOUND='YES'
20935      ELSEIF(ICOM.EQ.'POIN' .AND. IHARG(1).EQ.'PLOT')THEN
20936        ICASPL='POIN'
20937        ILASTC=1
20938        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
20939        IFOUND='YES'
20940      ELSE
20941        ICASPL='    '
20942        IFOUND='NO'
20943        GOTO9000
20944      ENDIF
20945C
20946C               ****************************************
20947C               **  STEP 2--                          **
20948C               **  EXTRACT THE VARIABLE LIST         **
20949C               ****************************************
20950C
20951      ISTEPN='2'
20952      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BNTR')
20953     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
20954C
20955      INAME='BIVARIATE NORMAL TOLERANCE REGION PLOT'
20956      IF(ICASPL.EQ.'BNCR')
20957     1  INAME='BIVARIATE NORMAL CONFIDENCE REGION PLOT'
20958      IF(ICASPL.EQ.'POIN')
20959     1  INAME='POINCARE PLOT'
20960      MINNA=2
20961      MAXNA=100
20962      MINN2=3
20963      IFLAGE=99
20964      IFLAGM=0
20965      IFLAGP=0
20966      JMIN=1
20967      JMAX=NUMARG
20968      MINNVA=2
20969      MAXNVA=4
20970      IF(ICASPL.EQ.'POIN')THEN
20971        MINNA=1
20972        MINNVA=1
20973        MAXNVA=1
20974      ENDIF
20975C
20976      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
20977     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
20978     1            JMIN,JMAX,
20979     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
20980     1            IVARN1,IVARN2,IVARTY,PVAR,
20981     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
20982     1            MINNVA,MAXNVA,
20983     1            IFLAGM,IFLAGP,
20984     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
20985      IF(IERROR.EQ.'YES')GOTO9000
20986C
20987      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BNTL')THEN
20988        WRITE(ICOUT,999)
20989        CALL DPWRST('XXX','BUG ')
20990        WRITE(ICOUT,281)
20991  281   FORMAT('***** AFTER CALL DPPARS--')
20992        CALL DPWRST('XXX','BUG ')
20993        WRITE(ICOUT,282)NQ,NUMVAR
20994  282   FORMAT('NQ,NUMVAR = ',2I8)
20995        CALL DPWRST('XXX','BUG ')
20996        IF(NUMVAR.GT.0)THEN
20997          DO285I=1,NUMVAR
20998            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
20999     1                      ICOLR(I),IVARTY(I)
21000  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
21001     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
21002            CALL DPWRST('XXX','BUG ')
21003  285     CONTINUE
21004        ENDIF
21005      ENDIF
21006C
21007C               **********************************************
21008C               **  STEP 33--                               **
21009C               **  FORM THE SUBSETTED VARIABLES            **
21010C               **********************************************
21011C
21012      ISTEPN='33'
21013      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BNTR')
21014     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21015C
21016      ICOL=1
21017      NUMVA2=NUMVAR
21018      IF(NUMVAR.EQ.4)NUMVA2=3
21019      CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
21020     1            INAME,IVARN1,IVARN2,IVARTY,
21021     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
21022     1            MAXCOL,MAXCP1,MAXCP2,MAXCP3,
21023     1            MAXCP4,MAXCP5,MAXCP6,
21024     1            V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
21025     1            Y1,Y2,XGROUP,TEMP1,TEMP1,TEMP1,TEMP1,NS,
21026     1            IBUGG3,ISUBRO,IFOUND,IERROR)
21027      IF(IERROR.EQ.'YES')GOTO9000
21028C
21029C               **********************************************
21030C               **  STEP 33B--                              **
21031C               **  FOR POINCAIRE PLOT, CREATE VARIABLES    **
21032C               **********************************************
21033C
21034      IF(ICASPL.EQ.'POIN')THEN
21035        ICNT=0
21036        ILAG=INT(PPPLLA+0.1)
21037        IVAL=NS/4
21038        IF(ILAG.GT.IVAL)ILAG=1
21039C
21040        DO3321II=ILAG+1,NS
21041          ICNT=ICNT+1
21042          Y2(ICNT)=Y1(II)
21043 3321   CONTINUE
21044C
21045        DO3325II=1,NS-ILAG
21046          XGROUP(II)=1.0
21047 3325   CONTINUE
21048        NS=NS-ILAG
21049        NUMVAR=2
21050      ENDIF
21051C
21052C               **********************************************
21053C               **  STEP 34--                               **
21054C               **  EXTRACT DELTAV VARIABLE (IF GIVEN)      **
21055C               **********************************************
21056C
21057      ISTEPN='34'
21058      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BNTR')
21059     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21060C
21061      IF(NUMVAR.GE.4)THEN
21062        ICOL=4
21063        NUMVA2=1
21064        NQ=NRIGHT(4)
21065        DO3410I=1,NQ
21066          ISUB(I)=1
21067 3410   CONTINUE
21068C
21069        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
21070     1              INAME,IVARN1,IVARN2,IVARTY,
21071     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
21072     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
21073     1              MAXCP4,MAXCP5,MAXCP6,
21074     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
21075     1              DELTAV,DELTAV,DELTAV,NRESPD,NLOCA2,NLOCA3,ICASE,
21076     1              IBUGG3,ISUBRO,IFOUND,IERROR)
21077        IF(IERROR.EQ.'YES')GOTO9000
21078      ELSE
21079        NRESPD=0
21080      ENDIF
21081C
21082C               *****************************************************
21083C               **  STEP 41--                                      **
21084C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
21085C               **  VARIABLES (Y(.) AND X(.), RESPECTIVELY) FOR    **
21086C               **  THE PLOT.                                      **
21087C               **  FORM THE CURVE DESIGNATION VARIABLE D(.)  .    **
21088C               **  DEFINE THE NUMBER OF PLOT POINTS   (NPLOTP).   **
21089C               **  DEFINE THE NUMBER OF PLOT VARIABLES(NPLOTV).   **
21090C               *****************************************************
21091C
21092      ISTEPN='61'
21093      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'BNTR')
21094     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21095C
21096c     NOTE 11/2013: FOR THE CONFIDENCE REGION CASE, USE DELTA TO
21097C                   SPECIFY THE CONFIDENCE LIMITS (AND GAMMA WILL
21098C                   BE IGNORED).  FOR THE TOLERANCE REGION CASE,
21099C                   DELTA SPECIFIES THE COVERAGES AND GAMMA THE
21100C                   CONFIDENCE.
21101C
21102C     GAMMA CAN ONLY BE 0.75, 0.90, 0.95.  MATCH ENTERED GAMMA
21103C     VALUE TO CLOSEST OF THESE.
21104C
21105C     2014/01: ONLY RESTRICT GAMMA TO 0.75, 0.90, 0.95 FOR N <= 50.
21106C              IF N > 50, ACCEPT ANY VALUE BETWEEN 0.50 AND 0.99.
21107C
21108      IH='GAMM'
21109      IH2='A   '
21110      IHWUSE='P'
21111      MESSAG='NO'
21112      CALL CHECKN(IH,IH2,IHWUSE,
21113     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21114     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21115      IF(IERROR.EQ.'YES')THEN
21116        GAMMA=0.95
21117      ELSE
21118        GAMMA=VALUE(ILOCP)
21119        IF(GAMMA.GE.1.0 .AND. GAMMA.LT.100.0)GAMMA=GAMMA/100.
21120CCCCC   IF(GAMMA.NE.0.75 .AND. GAMMA.NE.0.90 .AND.
21121CCCCC1     GAMMA.NE.0.95)GAMMA=0.95
21122C
21123        IF(NS.LE.50)THEN
21124          IF(GAMMA.GE.0.70 .AND. GAMMA.LE.0.82)THEN
21125            GAMMA=0.75
21126          ELSEIF(GAMMA.GT.0.82 .AND. GAMMA.LE.0.925)THEN
21127            GAMMA=0.90
21128          ELSEIF(GAMMA.GT.0.925 .AND. GAMMA.LT.1.0)THEN
21129            GAMMA=0.95
21130          ELSE
21131            GAMMA=0.95
21132          ENDIF
21133        ELSE
21134          IF(GAMMA.LT.0.50)GAMMA=0.50
21135          IF(GAMMA.GT.0.99)GAMMA=0.99
21136        ENDIF
21137      ENDIF
21138C
21139      IF(NRESPD.EQ.0)THEN
21140        IH='DELT'
21141        IH2='A   '
21142        IHWUSE='P'
21143        MESSAG='NO'
21144        CALL CHECKN(IH,IH2,IHWUSE,
21145     1              IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
21146     1              ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOCP,IERROR)
21147        IF(IERROR.EQ.'YES')THEN
21148          DELTA=0.90
21149        ELSE
21150          DELTA=VALUE(ILOCP)
21151          IF(DELTA.GE.1.0 .AND. DELTA.LE.100.0)DELTA=DELTA/100.0
21152          IF(DELTA.LT.0.75 .OR. DELTA.GE.1.0)DELTA=0.90
21153        ENDIF
21154      ENDIF
21155C
21156      CALL DPBNT2(Y1,Y2,XGROUP,NS,DELTAV,NRESPD,NUMVAR,
21157     1            ICASPL,MAXN,DELTA,GAMMA,
21158     1            XIDTEM,TEMP1,TEMP2,
21159     1            Y,X,X3D,D,NPLOTP,NPLOTV,
21160     1            SD1,SD2,SAREA,CCM,
21161     1            IBUGG3,ISUBRO,IERROR)
21162C
21163      IF(ICASPL.EQ.'POIN')THEN
21164        IH='SD1 '
21165        IH2='    '
21166        VALUE0=SD1
21167        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
21168     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
21169     1              IANS,IWIDTH,IBUGG3,IERROR)
21170C
21171        IH='SD2 '
21172        IH2='    '
21173        VALUE0=SD2
21174        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
21175     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
21176     1              IANS,IWIDTH,IBUGG3,IERROR)
21177C
21178        IH='SARE'
21179        IH2='A   '
21180        VALUE0=SAREA
21181        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
21182     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
21183     1              IANS,IWIDTH,IBUGG3,IERROR)
21184C
21185        IH='CCM '
21186        IH2='    '
21187        VALUE0=CCM
21188        CALL DPADDP(IH,IH2,VALUE0,IHOST1,ISUBN0,
21189     1              IHNAME,IHNAM2,IUSE,VALUE,IVALUE,NUMNAM,MAXNAM,
21190     1              IANS,IWIDTH,IBUGG3,IERROR)
21191C
21192      ENDIF
21193C               *****************
21194C               **  STEP 90--  **
21195C               **  EXIT.      **
21196C               *****************
21197C
21198 9000 CONTINUE
21199      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'BNTR')THEN
21200        WRITE(ICOUT,999)
21201        CALL DPWRST('XXX','BUG ')
21202        WRITE(ICOUT,9011)
21203 9011   FORMAT('***** AT THE END OF DPBNTR--')
21204        CALL DPWRST('XXX','BUG ')
21205        WRITE(ICOUT,9012)IFOUND,IERROR
21206 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
21207        CALL DPWRST('XXX','BUG ')
21208        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
21209 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
21210     1         3I8,2X,2(A4,2X),A4)
21211        CALL DPWRST('XXX','BUG ')
21212        WRITE(ICOUT,9014)NRESPD,GAMMA,DELTA
21213 9014   FORMAT('NRESPD,GAMMA,DELTA = ',I8,2G15.7)
21214        CALL DPWRST('XXX','BUG ')
21215        WRITE(ICOUT,9020)
21216 9020   FORMAT('I,Y(.),X(.),D(.),ISUB(.)--')
21217        CALL DPWRST('XXX','BUG ')
21218        DO9021I=1,NPLOTP
21219          WRITE(ICOUT,9022)I,Y(I),X(I),D(I),ISUB(I)
21220 9022     FORMAT(I8,3G15.7,I8)
21221          CALL DPWRST('XXX','BUG ')
21222 9021   CONTINUE
21223      ENDIF
21224C
21225      RETURN
21226      END
21227      SUBROUTINE DPBNT2(Y1,Y2,X,N,DELTAV,NDELTA,NUMV2,
21228     1            ICASPL,MAXN,DELTA,GAMMA,
21229     1            XIDTEM,TEMP1,TEMP2,
21230     1            YPLOT,XPLOT,X3D,D2,NPLOTP,NPLOTV,
21231     1            SD1,SD2,SAREA,CCM,
21232     1            IBUGG3,ISUBRO,IERROR)
21233C
21234C     PURPOSE--GENERATE A BIVARIATE NORMAL TOLERANCE REGION PLOT
21235C     REFERENCE--HALL AND SHELDON, "IMPROVED BIVARIATE NORMAL
21236C                TOLERANCE REGIONS WITH SOME APPLICATIONS",
21237C                JOURNAL OF QUALITY TECHNOLOGY, VOL 11,
21238C                NO. 1, JANUARY 1979.
21239C              --ISO 13528, "STATISTICAL METHODS FOR USE IN PROFICIENCY
21240C                TESTING BY INTERLABORATORY COMPARISONS", 2005.
21241C              --JACKSON, "QUALITY CONTROL METHODS FOR TWO RELATED
21242C                VARIABLES", INDUSTRIAL QUALITY CONTROL, 7, 1956,
21243C                PP. 2-6.
21244C              --TAYEL AND ALSABA (2015), "POINCARE PLOT FOR HEART RATE
21245C                VARIABILITY", INTERNATIONAL JOURNAL OF MEDICAL, HEALTH,
21246C                BIOMEDICAL, BIOENGINEERING AND PHARMACEUTICAL
21247C                ENGINEERING", VOL. 9, NO. 9, PP. 708-711.
21248C     WRITTEN BY--ALAN HECKERT
21249C                 STATISTICAL ENGINEERING DIVISION
21250C                 INFORMATION TECHNOLOGY LABORATORY
21251C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
21252C                 GAITHERSBURG, MD 20899-8980
21253C                 PHONE--301-975-2899
21254C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
21255C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
21256C     LANGUAGE--ANSI FORTRAN (1977)
21257C     VERSION NUMBER--2007/5
21258C     ORIGINAL VERSION--MAY       2007.
21259C     UPDATED         --SEPTEMBER 2007. COMMENT OUT STEP 4
21260C                                       (THIS IS ARTIFACT FROM EARLIER
21261C                                       VERSION OF ALGORITHM)
21262C     UPDATED         --NOVEMBER  2013. SUPPORT CONFIDENCE ELLIPSE
21263C                                       (AS OPPOSED TO TOLERANCE
21264C                                       ELLIPSE)
21265C     UPDATED         --JANUARY   2014. BUG IN KRISHNAMOOORTHY
21266C                                       APPROXIMATION
21267C     UPDATED         --JULY      2017. SUPPORT POINCARE PLOT OPTION
21268C
21269C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
21270C
21271      CHARACTER*4 ICASPL
21272      CHARACTER*4 IBUGG3
21273      CHARACTER*4 ISUBRO
21274      CHARACTER*4 IERROR
21275C
21276      CHARACTER*4 ISUBN1
21277      CHARACTER*4 ISUBN2
21278      CHARACTER*4 ISTEPN
21279      CHARACTER*4 IWRITE
21280C
21281      DIMENSION Y1(*)
21282      DIMENSION Y2(*)
21283      DIMENSION X(*)
21284      DIMENSION DELTAV(*)
21285      DIMENSION XIDTEM(*)
21286      DIMENSION TEMP1(*)
21287      DIMENSION TEMP2(*)
21288      DIMENSION YPLOT(*)
21289      DIMENSION XPLOT(*)
21290      DIMENSION X3D(*)
21291      DIMENSION D2(*)
21292C
21293      DIMENSION ZX(4)
21294      DIMENSION ZY(4)
21295      DIMENSION AMAT(3,3)
21296      INTEGER   INDX(3)
21297C
21298      DOUBLE PRECISION DSUM
21299      DOUBLE PRECISION DVAL
21300      DOUBLE PRECISION DTERM1
21301C
21302C-----COMMON----------------------------------------------------------
21303C
21304C-----COMMON VARIABLES (GENERAL)--------------------------------------
21305C
21306      INCLUDE 'DPCOP2.INC'
21307C
21308      DATA PI/3.141592653E+00/
21309C
21310C-----START POINT-----------------------------------------------------
21311C
21312      ISUBN1='DPBN'
21313      ISUBN2='T2  '
21314      IERROR='NO'
21315      IWRITE='OFF'
21316C
21317      XMIN=CPUMAX
21318      XMAX=CPUMAX
21319C
21320      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BNT2')THEN
21321        WRITE(ICOUT,999)
21322  999   FORMAT(1X)
21323        CALL DPWRST('XXX','BUG ')
21324        WRITE(ICOUT,51)
21325   51   FORMAT('***** AT THE BEGINNING OF DPBNT2--')
21326        CALL DPWRST('XXX','BUG ')
21327        WRITE(ICOUT,52)NUMV2,N,MAXN,NDELTA
21328   52   FORMAT('NUMV2,N,MAXN,NDELTA = ',4I8)
21329        CALL DPWRST('XXX','BUG ')
21330        WRITE(ICOUT,53)ICASPL,IBUGG3,IERROR
21331   53   FORMAT('ICASPL,IBUGG3,IERROR = ',A4,2X,A4,2X,A4)
21332        CALL DPWRST('XXX','BUG ')
21333        WRITE(ICOUT,54)GAMMA,DELTA
21334   54   FORMAT('GAMMA,DELTA = ',2G15.7)
21335        CALL DPWRST('XXX','BUG ')
21336        DO55I=1,MIN(N,100)
21337          WRITE(ICOUT,56)I,Y1(I),Y2(I),X(I)
21338   56     FORMAT('I,Y1(I),Y2(I),X(I) = ',I8,3G15.7)
21339          CALL DPWRST('XXX','BUG ')
21340   55   CONTINUE
21341        IF(NDELTA.GT.0)THEN
21342          DO60I=1,NDELTA
21343            WRITE(ICOUT,61)I,DELTAV(I)
21344   61       FORMAT('I,DELTAV(I) = ',I8,G15.7)
21345            CALL DPWRST('XXX','BUG ')
21346   60     CONTINUE
21347        ENDIF
21348      ENDIF
21349C
21350C               ********************************************
21351C               **  STEP 1--                              **
21352C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
21353C               ********************************************
21354C
21355      ISTEPN='1'
21356      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BNT2')
21357     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
21358C
21359C               ****************************************************
21360C               **  STEP 2--                                      **
21361C               **  COMPUTE COORDINATES FOR THE ELLIPSE           **
21362C               **  LOOP THROUGH POSSIBLY MULTIPLE VALUES OF DELTA**
21363C               ****************************************************
21364C
21365      IF(ICASPL.EQ.'POIN')GOTO299
21366      IF(NDELTA.GT.0)THEN
21367        EPS=0.01
21368        ICNT=0
21369        DO90I=1,NDELTA
21370          ATEMP=DELTAV(I)
21371          IF(ATEMP.GE.1.0 .AND. ATEMP.LE.100.0)ATEMP=ATEMP/100.0
21372          IF(ATEMP.GT.0.0 .AND. ATEMP.LT.1.0)THEN
21373            ICNT=ICNT+1
21374            DELTAV(ICNT)=ATEMP
21375          ENDIF
21376   90   CONTINUE
21377C
21378        IF(ICNT.GT.0)THEN
21379          NDELTA=ICNT
21380          CALL SORT(DELTAV,NDELTA,DELTAV)
21381        ELSE
21382          NDELTA=1
21383          DELTAV(1)=0.90
21384          IF(ICASPL.EQ.'BNCR')DELTAV(1)=0.95
21385        ENDIF
21386C
21387        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BNT2')THEN
21388          WRITE(ICOUT,999)
21389          CALL DPWRST('XXX','BUG ')
21390          WRITE(ICOUT,81)NDELTA
21391   81     FORMAT('***** AFTER CHECK DELTAS: NDELTA = ',I8)
21392          CALL DPWRST('XXX','BUG ')
21393          IF(NDELTA.GT.0)THEN
21394            DO83I=1,NDELTA
21395              WRITE(ICOUT,84)I,DELTAV(I)
21396   84         FORMAT('I,DELTAV(I) = ',I8,G15.7)
21397              CALL DPWRST('XXX','BUG ')
21398   83       CONTINUE
21399          ENDIF
21400        ENDIF
21401C
21402      ELSE
21403        NDELTA=1
21404        DELTAV(1)=DELTA
21405      ENDIF
21406C
21407  299 CONTINUE
21408C
21409      CALL MEAN(Y1,N,IWRITE,YBAR,IBUGG3,IERROR)
21410      CALL SD(Y1,N,IWRITE,SY,IBUGG3,IERROR)
21411      CALL MEAN(Y2,N,IWRITE,XBAR,IBUGG3,IERROR)
21412      CALL SD(Y2,N,IWRITE,SX,IBUGG3,IERROR)
21413      CALL CORR(Y1,Y2,N,IWRITE,R,IBUGG3,IERROR)
21414C
21415      K=0
21416      ITAG=0
21417      IF(ICASPL.EQ.'POIN')NDELTA=1
21418      DO100IDELTA=1,NDELTA
21419C
21420C       FOR POINCARE PLOT, COMPUTE SD1 AND SD2 AS GIVEN IN:
21421C
21422C         TAYEL AND ALSABA (2015), "POINCARE PLOT FOR HEART RATE
21423C         VARIABILITY", INTERNATIONAL JOURNAL OF MEDICAL HEALTH,
21424C         BIOMEDICAL, BIOENGINEERING AND PHARMACEUTICAL ENGINEERING",
21425C         VOLUME 9, NO. 9, PP. 708-711.
21426C
21427C         SD1 = SD(X1)
21428C         SD2 = SD(X2)
21429C
21430C         WHERE
21431C
21432C         X1 = (Y1 - Y2)/SQRT(2)
21433C         X2 = (Y1 + Y2)/SQRT(2)
21434C
21435C         X1 AND X2 CORRESPOND TO THE ROTATION OF Y1 AND Y2 BY PI/4.
21436C
21437      IF(ICASPL.EQ.'POIN')THEN
21438        THETA=PI/4.0
21439C
21440        DO260II=1,N
21441          TEMP1(II)=(Y1(II)-Y2(II))/SQRT(2.0)
21442          TEMP2(II)=(Y1(II)+Y2(II))/SQRT(2.0)
21443  260   CONTINUE
21444        CALL SD(TEMP1,N,IWRITE,SD1,IBUGG3,IERROR)
21445        CALL SD(TEMP2,N,IWRITE,SD2,IBUGG3,IERROR)
21446C
21447        A=SD2
21448        B=SD1
21449        SAREA=PI*SD1*SD2
21450        XINC=A/SQRT(2.0)
21451        YINC=A/SQRT(2.0)
21452        XINC2=B/SQRT(2.0)
21453        YINC2=B/SQRT(2.0)
21454        ZX(1)=XBAR - XINC
21455        ZY(1)=YBAR - YINC
21456        ZX(2)=XBAR - XINC2
21457        ZY(2)=YBAR + YINC2
21458        ZX(3)=XBAR + XINC
21459        ZY(3)=YBAR + YINC
21460        ZX(4)=XBAR + XINC2
21461        ZY(4)=YBAR - YINC2
21462C
21463C       COMPUTE COMPLEX CORRELATION MEASURE:
21464C
21465C       CCM = (1/(SAREA*(N-1))*SUM[i=1 to N-2][0.5*|A(i)|]
21466C
21467C       WHERE |A(i)| IS THE DETERMINANT OF
21468C
21469C        A(i) = | x1  y1  1  |
21470C               | x2  y2  1  |
21471C               | x3  y3  1  |
21472C
21473C       WITH (x1,y1), (x2,y2), (x3,y3) DENOTING 3 SUCCESSIVE POINTS IN
21474C       THE TIME SERIES
21475C
21476        ANM1=REAL(N-1)
21477        DTERM1=1.0D0/DBLE(SAREA*ANM1)
21478        MAXROM=3
21479        NR1=3
21480        EPS=1.0E-10
21481C
21482        DSUM=0.0D0
21483        DO270II=1,N-2
21484          AMAT(1,1)=Y1(II)
21485          AMAT(1,2)=Y2(II)
21486          AMAT(2,1)=Y1(II+1)
21487          AMAT(2,2)=Y2(II+1)
21488          AMAT(3,1)=Y1(II+2)
21489          AMAT(3,2)=Y2(II+2)
21490          AMAT(1,3)=1.0
21491          AMAT(2,3)=1.0
21492          AMAT(3,3)=1.0
21493          CALL SGECO(AMAT,MAXROM,NR1,INDX,RCOND,TEMP1)
21494          IF(RCOND.LE.EPS)THEN
21495            CCM=CPUMIN
21496            GOTO119
21497          ENDIF
21498          IJOB=10
21499          CALL SGEDI(AMAT,MAXROM,NR1,INDX,TEMP1,TEMP2,IJOB)
21500          DET=TEMP1(1)*10.0**TEMP1(2)
21501          DSUM=DSUM + DBLE(0.5*DET)
21502  270   CONTINUE
21503        DVAL=DTERM1*DSUM
21504        CCM=REAL(DVAL)
21505        GOTO119
21506      ENDIF
21507C
21508C     COMPUTE VALUE OF K FOR CONFIDENCE REGION CASE
21509C
21510      DELTA=DELTAV(IDELTA)
21511      IF(ICASPL.EQ.'BNCR')THEN
21512        AN=REAL(N)
21513        TERM1=2.0*((AN-1.0)/(AN-2.0))
21514        IDF1=2
21515        IDF2=N-1
21516        CALL FPPF(DELTA,IDF1,IDF2,TERM2)
21517        AK=TERM1*TERM2
21518        GOTO99
21519      ENDIF
21520C
21521C     SET APPROPRIATE VALUE OF K
21522C
21523      IF(GAMMA.EQ.0.75)THEN
21524        IF(DELTA.EQ.0.50)THEN
21525          IF(N.LE.10)THEN
21526            AK=2.48
21527          ELSEIF(N.EQ.11)THEN
21528            AK=2.37
21529          ELSEIF(N.EQ.12)THEN
21530            AK=2.28
21531          ELSEIF(N.EQ.13)THEN
21532            AK=2.20
21533          ELSEIF(N.EQ.14)THEN
21534            AK=2.13
21535          ELSEIF(N.EQ.15)THEN
21536            AK=2.07
21537          ELSEIF(N.EQ.16)THEN
21538            AK=2.02
21539          ELSEIF(N.EQ.17)THEN
21540            AK=1.97
21541          ELSEIF(N.EQ.18)THEN
21542            AK=1.94
21543          ELSEIF(N.EQ.19)THEN
21544            AK=1.89
21545          ELSEIF(N.EQ.20)THEN
21546            AK=1.87
21547          ELSEIF(N.EQ.21)THEN
21548            AK=(1.87+1.82)/2.0
21549          ELSEIF(N.EQ.22)THEN
21550            AK=1.82
21551          ELSEIF(N.EQ.23)THEN
21552            AK=(1.78+1.82)/2.0
21553          ELSEIF(N.EQ.24)THEN
21554            AK=1.78
21555          ELSEIF(N.EQ.25)THEN
21556            AK=(1.78+1.76)/2.0
21557          ELSEIF(N.EQ.26)THEN
21558            AK=1.76
21559          ELSEIF(N.EQ.27)THEN
21560            AK=(1.74+1.76)/2.0
21561          ELSEIF(N.EQ.28)THEN
21562            AK=1.74
21563          ELSEIF(N.EQ.29)THEN
21564            AK=(1.74+1.73)/2.0
21565          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
21566            AK=1.73
21567          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
21568            AK=1.69
21569          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
21570            AK=1.66
21571          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
21572            AK=1.64
21573          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
21574            AK=1.62
21575          ELSE
21576            GOTO91
21577          ENDIF
21578        ELSEIF(DELTA.EQ.0.80)THEN
21579          IF(N.LE.10)THEN
21580            AK=6.25
21581          ELSEIF(N.EQ.11)THEN
21582            AK=5.87
21583          ELSEIF(N.EQ.12)THEN
21584            AK=5.58
21585          ELSEIF(N.EQ.13)THEN
21586            AK=5.38
21587          ELSEIF(N.EQ.14)THEN
21588            AK=5.18
21589          ELSEIF(N.EQ.15)THEN
21590            AK=5.03
21591          ELSEIF(N.EQ.16)THEN
21592            AK=4.91
21593          ELSEIF(N.EQ.17)THEN
21594            AK=4.80
21595          ELSEIF(N.EQ.18)THEN
21596            AK=4.71
21597          ELSEIF(N.EQ.19)THEN
21598            AK=4.63
21599          ELSEIF(N.EQ.20)THEN
21600            AK=4.57
21601          ELSEIF(N.EQ.21)THEN
21602            AK=(4.57+4.44)/2.0
21603          ELSEIF(N.EQ.22)THEN
21604            AK=4.44
21605          ELSEIF(N.EQ.23)THEN
21606            AK=(4.44+4.34)/2.0
21607          ELSEIF(N.EQ.24)THEN
21608            AK=4.34
21609          ELSEIF(N.EQ.25)THEN
21610            AK=(4.34+4.26)/2.0
21611          ELSEIF(N.EQ.26)THEN
21612            AK=4.26
21613          ELSEIF(N.EQ.27)THEN
21614            AK=(4.26+4.18)/2.0
21615          ELSEIF(N.EQ.28)THEN
21616            AK=4.18
21617          ELSEIF(N.EQ.29)THEN
21618            AK=(4.18+4.13)/2.0
21619          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
21620            AK=4.13
21621          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
21622            AK=4.01
21623          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
21624            AK=3.90
21625          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
21626            AK=3.82
21627          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
21628            AK=3.75
21629          ELSE
21630            GOTO91
21631          ENDIF
21632        ELSEIF(DELTA.EQ.0.90)THEN
21633          IF(N.LE.10)THEN
21634            AK=9.40
21635          ELSEIF(N.EQ.11)THEN
21636            AK=8.90
21637          ELSEIF(N.EQ.12)THEN
21638            AK=8.51
21639          ELSEIF(N.EQ.13)THEN
21640            AK=8.08
21641          ELSEIF(N.EQ.14)THEN
21642            AK=7.80
21643          ELSEIF(N.EQ.15)THEN
21644            AK=7.57
21645          ELSEIF(N.EQ.16)THEN
21646            AK=7.36
21647          ELSEIF(N.EQ.17)THEN
21648            AK=7.17
21649          ELSEIF(N.EQ.18)THEN
21650            AK=7.01
21651          ELSEIF(N.EQ.19)THEN
21652            AK=6.85
21653          ELSEIF(N.EQ.20)THEN
21654            AK=6.71
21655          ELSEIF(N.EQ.21)THEN
21656            AK=(6.71+6.46)/2.0
21657          ELSEIF(N.EQ.22)THEN
21658            AK=6.46
21659          ELSEIF(N.EQ.23)THEN
21660            AK=(6.46+6.26)/2.0
21661          ELSEIF(N.EQ.24)THEN
21662            AK=6.26
21663          ELSEIF(N.EQ.25)THEN
21664            AK=(6.26+6.08)/2.0
21665          ELSEIF(N.EQ.26)THEN
21666            AK=6.08
21667          ELSEIF(N.EQ.27)THEN
21668            AK=(6.08+5.95)/2.0
21669          ELSEIF(N.EQ.28)THEN
21670            AK=5.95
21671          ELSEIF(N.EQ.29)THEN
21672            AK=(5.95+5.85)/2.0
21673          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
21674            AK=5.85
21675          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
21676            AK=5.65
21677          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
21678            AK=5.53
21679          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
21680            AK=5.46
21681          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
21682            AK=5.42
21683          ELSE
21684            GOTO91
21685          ENDIF
21686        ELSEIF(DELTA.EQ.0.95)THEN
21687          IF(N.LE.10)THEN
21688            AK=12.10
21689          ELSEIF(N.EQ.11)THEN
21690            AK=11.36
21691          ELSEIF(N.EQ.12)THEN
21692            AK=10.78
21693          ELSEIF(N.EQ.13)THEN
21694            AK=10.35
21695          ELSEIF(N.EQ.14)THEN
21696            AK=9.97
21697          ELSEIF(N.EQ.15)THEN
21698            AK=9.67
21699          ELSEIF(N.EQ.16)THEN
21700            AK=9.42
21701          ELSEIF(N.EQ.17)THEN
21702            AK=9.19
21703          ELSEIF(N.EQ.18)THEN
21704            AK=9.02
21705          ELSEIF(N.EQ.19)THEN
21706            AK=8.85
21707          ELSEIF(N.EQ.20)THEN
21708            AK=8.70
21709          ELSEIF(N.EQ.21)THEN
21710            AK=(8.70+8.48)/2.0
21711          ELSEIF(N.EQ.22)THEN
21712            AK=8.48
21713          ELSEIF(N.EQ.23)THEN
21714            AK=(8.48+8.28)/2.0
21715          ELSEIF(N.EQ.24)THEN
21716            AK=8.28
21717          ELSEIF(N.EQ.25)THEN
21718            AK=(8.28+8.10)/2.0
21719          ELSEIF(N.EQ.26)THEN
21720            AK=8.10
21721          ELSEIF(N.EQ.27)THEN
21722            AK=(8.10+7.94)/2.0
21723          ELSEIF(N.EQ.28)THEN
21724            AK=7.94
21725          ELSEIF(N.EQ.29)THEN
21726            AK=(7.94+7.81)/2.0
21727          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
21728            AK=7.81
21729          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
21730            AK=7.53
21731          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
21732            AK=7.34
21733          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
21734            AK=7.20
21735          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
21736            AK=7.10
21737          ELSE
21738            GOTO91
21739          ENDIF
21740        ELSE
21741          GOTO91
21742        ENDIF
21743      ELSEIF(GAMMA.EQ.0.90)THEN
21744        IF(DELTA.EQ.0.50)THEN
21745          IF(N.LE.10)THEN
21746            AK=3.10
21747          ELSEIF(N.EQ.11)THEN
21748            AK=2.93
21749          ELSEIF(N.EQ.12)THEN
21750            AK=2.79
21751          ELSEIF(N.EQ.13)THEN
21752            AK=2.66
21753          ELSEIF(N.EQ.14)THEN
21754            AK=2.56
21755          ELSEIF(N.EQ.15)THEN
21756            AK=2.48
21757          ELSEIF(N.EQ.16)THEN
21758            AK=2.40
21759          ELSEIF(N.EQ.17)THEN
21760            AK=2.34
21761          ELSEIF(N.EQ.18)THEN
21762            AK=2.29
21763          ELSEIF(N.EQ.19)THEN
21764            AK=2.24
21765          ELSEIF(N.EQ.20)THEN
21766            AK=2.20
21767          ELSEIF(N.EQ.21)THEN
21768            AK=(2.20+2.14)/2.0
21769          ELSEIF(N.EQ.22)THEN
21770            AK=2.14
21771          ELSEIF(N.EQ.23)THEN
21772            AK=(2.14+2.08)/2.0
21773          ELSEIF(N.EQ.24)THEN
21774            AK=2.08
21775          ELSEIF(N.EQ.25)THEN
21776            AK=(2.08+2.03)/2.0
21777          ELSEIF(N.EQ.26)THEN
21778            AK=2.03
21779          ELSEIF(N.EQ.27)THEN
21780            AK=(2.03+2.00)/2.0
21781          ELSEIF(N.EQ.28)THEN
21782            AK=2.00
21783          ELSEIF(N.EQ.29)THEN
21784            AK=(2.00+1.97)/2.0
21785          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
21786            AK=1.97
21787          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
21788            AK=1.90
21789          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
21790            AK=1.86
21791          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
21792            AK=1.82
21793          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
21794            AK=1.78
21795          ELSE
21796            GOTO91
21797          ENDIF
21798        ELSEIF(DELTA.EQ.0.80)THEN
21799          IF(N.LE.10)THEN
21800            AK=8.30
21801          ELSEIF(N.EQ.11)THEN
21802            AK=7.64
21803          ELSEIF(N.EQ.12)THEN
21804            AK=7.13
21805          ELSEIF(N.EQ.13)THEN
21806            AK=6.74
21807          ELSEIF(N.EQ.14)THEN
21808            AK=6.44
21809          ELSEIF(N.EQ.15)THEN
21810            AK=6.18
21811          ELSEIF(N.EQ.16)THEN
21812            AK=5.98
21813          ELSEIF(N.EQ.17)THEN
21814            AK=5.80
21815          ELSEIF(N.EQ.18)THEN
21816            AK=5.66
21817          ELSEIF(N.EQ.19)THEN
21818            AK=5.51
21819          ELSEIF(N.EQ.20)THEN
21820            AK=5.35
21821          ELSEIF(N.EQ.21)THEN
21822            AK=(5.35+5.20)/2.0
21823          ELSEIF(N.EQ.22)THEN
21824            AK=5.20
21825          ELSEIF(N.EQ.23)THEN
21826            AK=(5.20+5.02)/2.0
21827          ELSEIF(N.EQ.24)THEN
21828            AK=5.02
21829          ELSEIF(N.EQ.25)THEN
21830            AK=(5.02+4.88)/2.0
21831          ELSEIF(N.EQ.26)THEN
21832            AK=4.88
21833          ELSEIF(N.EQ.27)THEN
21834            AK=(4.88+4.77)/2.0
21835          ELSEIF(N.EQ.28)THEN
21836            AK=4.77
21837          ELSEIF(N.EQ.29)THEN
21838            AK=(4.77+4.67)/2.0
21839          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
21840            AK=4.67
21841          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
21842            AK=4.49
21843          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
21844            AK=4.36
21845          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
21846            AK=4.26
21847          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
21848            AK=4.17
21849          ELSE
21850            GOTO91
21851          ENDIF
21852        ELSEIF(DELTA.EQ.0.90)THEN
21853          IF(N.LE.10)THEN
21854            AK=12.82
21855          ELSEIF(N.EQ.11)THEN
21856            AK=11.75
21857          ELSEIF(N.EQ.12)THEN
21858            AK=10.84
21859          ELSEIF(N.EQ.13)THEN
21860            AK=10.13
21861          ELSEIF(N.EQ.14)THEN
21862            AK=9.57
21863          ELSEIF(N.EQ.15)THEN
21864            AK=9.10
21865          ELSEIF(N.EQ.16)THEN
21866            AK=8.73
21867          ELSEIF(N.EQ.17)THEN
21868            AK=8.41
21869          ELSEIF(N.EQ.18)THEN
21870            AK=8.15
21871          ELSEIF(N.EQ.19)THEN
21872            AK=7.93
21873          ELSEIF(N.EQ.20)THEN
21874            AK=7.75
21875          ELSEIF(N.EQ.21)THEN
21876            AK=(7.75+7.48)/2.0
21877          ELSEIF(N.EQ.22)THEN
21878            AK=7.48
21879          ELSEIF(N.EQ.23)THEN
21880            AK=(7.48+7.26)/2.0
21881          ELSEIF(N.EQ.24)THEN
21882            AK=7.26
21883          ELSEIF(N.EQ.25)THEN
21884            AK=(7.26+7.07)/2.0
21885          ELSEIF(N.EQ.26)THEN
21886            AK=7.07
21887          ELSEIF(N.EQ.27)THEN
21888            AK=(7.07+6.92)/2.0
21889          ELSEIF(N.EQ.28)THEN
21890            AK=6.92
21891          ELSEIF(N.EQ.29)THEN
21892            AK=(6.92+6.79)/2.0
21893          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
21894            AK=6.79
21895          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
21896            AK=6.53
21897          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
21898            AK=6.32
21899          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
21900            AK=6.15
21901          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
21902            AK=6.02
21903          ELSE
21904            GOTO91
21905          ENDIF
21906        ELSEIF(DELTA.EQ.0.95)THEN
21907          IF(N.LE.10)THEN
21908            AK=17.23
21909          ELSEIF(N.EQ.11)THEN
21910            AK=15.80
21911          ELSEIF(N.EQ.12)THEN
21912            AK=14.85
21913          ELSEIF(N.EQ.13)THEN
21914            AK=14.00
21915          ELSEIF(N.EQ.14)THEN
21916            AK=13.30
21917          ELSEIF(N.EQ.15)THEN
21918            AK=12.74
21919          ELSEIF(N.EQ.16)THEN
21920            AK=12.26
21921          ELSEIF(N.EQ.17)THEN
21922            AK=11.85
21923          ELSEIF(N.EQ.18)THEN
21924            AK=11.50
21925          ELSEIF(N.EQ.19)THEN
21926            AK=11.16
21927          ELSEIF(N.EQ.20)THEN
21928            AK=10.83
21929          ELSEIF(N.EQ.21)THEN
21930            AK=(10.83+10.33)/2.0
21931          ELSEIF(N.EQ.22)THEN
21932            AK=10.33
21933          ELSEIF(N.EQ.23)THEN
21934            AK=(10.33+9.88)/2.0
21935          ELSEIF(N.EQ.24)THEN
21936            AK=9.88
21937          ELSEIF(N.EQ.25)THEN
21938            AK=(9.88+9.52)/2.0
21939          ELSEIF(N.EQ.26)THEN
21940            AK=9.52
21941          ELSEIF(N.EQ.27)THEN
21942            AK=(9.52+9.23)/2.0
21943          ELSEIF(N.EQ.28)THEN
21944            AK=9.23
21945          ELSEIF(N.EQ.29)THEN
21946            AK=(9.23+8.99)/2.0
21947          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
21948            AK=8.99
21949          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
21950            AK=8.56
21951          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
21952            AK=8.26
21953          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
21954            AK=8.07
21955          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
21956            AK=7.94
21957          ELSE
21958            GOTO91
21959          ENDIF
21960        ELSE
21961          GOTO91
21962        ENDIF
21963      ELSEIF(GAMMA.EQ.0.95)THEN
21964        IF(DELTA.EQ.0.50)THEN
21965          IF(N.LE.10)THEN
21966            AK=3.75
21967          ELSEIF(N.EQ.11)THEN
21968            AK=3.48
21969          ELSEIF(N.EQ.12)THEN
21970            AK=3.28
21971          ELSEIF(N.EQ.13)THEN
21972            AK=3.11
21973          ELSEIF(N.EQ.14)THEN
21974            AK=2.97
21975          ELSEIF(N.EQ.15)THEN
21976            AK=2.85
21977          ELSEIF(N.EQ.16)THEN
21978            AK=2.75
21979          ELSEIF(N.EQ.17)THEN
21980            AK=2.67
21981          ELSEIF(N.EQ.18)THEN
21982            AK=2.60
21983          ELSEIF(N.EQ.19)THEN
21984            AK=2.52
21985          ELSEIF(N.EQ.20)THEN
21986            AK=2.45
21987          ELSEIF(N.EQ.21)THEN
21988            AK=(2.45+2.36)/2.0
21989          ELSEIF(N.EQ.22)THEN
21990            AK=2.36
21991          ELSEIF(N.EQ.23)THEN
21992            AK=(2.36+2.29)/2.0
21993          ELSEIF(N.EQ.24)THEN
21994            AK=2.29
21995          ELSEIF(N.EQ.25)THEN
21996            AK=(2.29+2.24)/2.0
21997          ELSEIF(N.EQ.26)THEN
21998            AK=2.24
21999          ELSEIF(N.EQ.27)THEN
22000            AK=(2.24+2.20)/2.0
22001          ELSEIF(N.EQ.28)THEN
22002            AK=2.20
22003          ELSEIF(N.EQ.29)THEN
22004            AK=(2.20+2.16)/2.0
22005          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
22006            AK=2.16
22007          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
22008            AK=2.08
22009          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
22010            AK=2.01
22011          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
22012            AK=1.95
22013          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
22014            AK=1.89
22015          ELSE
22016            GOTO91
22017          ENDIF
22018        ELSEIF(DELTA.EQ.0.80)THEN
22019          IF(N.LE.10)THEN
22020            AK=10.15
22021          ELSEIF(N.EQ.11)THEN
22022            AK=9.11
22023          ELSEIF(N.EQ.12)THEN
22024            AK=8.37
22025          ELSEIF(N.EQ.13)THEN
22026            AK=7.83
22027          ELSEIF(N.EQ.14)THEN
22028            AK=7.42
22029          ELSEIF(N.EQ.15)THEN
22030            AK=7.10
22031          ELSEIF(N.EQ.16)THEN
22032            AK=6.84
22033          ELSEIF(N.EQ.17)THEN
22034            AK=6.62
22035          ELSEIF(N.EQ.18)THEN
22036            AK=6.43
22037          ELSEIF(N.EQ.19)THEN
22038            AK=6.26
22039          ELSEIF(N.EQ.20)THEN
22040            AK=6.11
22041          ELSEIF(N.EQ.21)THEN
22042            AK=(6.11+5.84)/2.0
22043          ELSEIF(N.EQ.22)THEN
22044            AK=5.84
22045          ELSEIF(N.EQ.23)THEN
22046            AK=(5.84+5.61)/2.0
22047          ELSEIF(N.EQ.24)THEN
22048            AK=5.61
22049          ELSEIF(N.EQ.25)THEN
22050            AK=(5.61+5.42)/2.0
22051          ELSEIF(N.EQ.26)THEN
22052            AK=5.42
22053          ELSEIF(N.EQ.27)THEN
22054            AK=(5.42+5.26)/2.0
22055          ELSEIF(N.EQ.28)THEN
22056            AK=5.26
22057          ELSEIF(N.EQ.29)THEN
22058            AK=(5.26+5.11)/2.0
22059          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
22060            AK=5.11
22061          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
22062            AK=4.85
22063          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
22064            AK=4.67
22065          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
22066            AK=4.57
22067          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
22068            AK=4.54
22069          ELSE
22070            GOTO91
22071          ENDIF
22072        ELSEIF(DELTA.EQ.0.90)THEN
22073          IF(N.LE.10)THEN
22074            AK=14.80
22075          ELSEIF(N.EQ.11)THEN
22076            AK=13.50
22077          ELSEIF(N.EQ.12)THEN
22078            AK=12.50
22079          ELSEIF(N.EQ.13)THEN
22080            AK=11.69
22081          ELSEIF(N.EQ.14)THEN
22082            AK=11.03
22083          ELSEIF(N.EQ.15)THEN
22084            AK=10.50
22085          ELSEIF(N.EQ.16)THEN
22086            AK=10.07
22087          ELSEIF(N.EQ.17)THEN
22088            AK=9.72
22089          ELSEIF(N.EQ.18)THEN
22090            AK=9.42
22091          ELSEIF(N.EQ.19)THEN
22092            AK=9.15
22093          ELSEIF(N.EQ.20)THEN
22094            AK=8.90
22095          ELSEIF(N.EQ.21)THEN
22096            AK=(8.90+8.43)/2.0
22097          ELSEIF(N.EQ.22)THEN
22098            AK=8.43
22099          ELSEIF(N.EQ.23)THEN
22100            AK=(8.43+8.15)/2.0
22101          ELSEIF(N.EQ.24)THEN
22102            AK=8.15
22103          ELSEIF(N.EQ.25)THEN
22104            AK=(8.15+7.88)/2.0
22105          ELSEIF(N.EQ.26)THEN
22106            AK=7.88
22107          ELSEIF(N.EQ.27)THEN
22108            AK=(7.88+7.65)/2.0
22109          ELSEIF(N.EQ.28)THEN
22110            AK=7.65
22111          ELSEIF(N.EQ.29)THEN
22112            AK=(7.65+7.45)/2.0
22113          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
22114            AK=7.45
22115          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
22116            AK=7.07
22117          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
22118            AK=6.80
22119          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
22120            AK=6.62
22121          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
22122            AK=6.50
22123          ELSE
22124            GOTO91
22125          ENDIF
22126        ELSEIF(DELTA.EQ.0.95)THEN
22127          IF(N.LE.10)THEN
22128            AK=22.15
22129          ELSEIF(N.EQ.11)THEN
22130            AK=19.80
22131          ELSEIF(N.EQ.12)THEN
22132            AK=18.00
22133          ELSEIF(N.EQ.13)THEN
22134            AK=16.55
22135          ELSEIF(N.EQ.14)THEN
22136            AK=15.46
22137          ELSEIF(N.EQ.15)THEN
22138            AK=14.50
22139          ELSEIF(N.EQ.16)THEN
22140            AK=13.75
22141          ELSEIF(N.EQ.17)THEN
22142            AK=13.09
22143          ELSEIF(N.EQ.18)THEN
22144            AK=12.60
22145          ELSEIF(N.EQ.19)THEN
22146            AK=12.16
22147          ELSEIF(N.EQ.20)THEN
22148            AK=11.83
22149          ELSEIF(N.EQ.21)THEN
22150            AK=(11.83+11.23)/2.0
22151          ELSEIF(N.EQ.22)THEN
22152            AK=11.23
22153          ELSEIF(N.EQ.23)THEN
22154            AK=(11.23+10.78)/2.0
22155          ELSEIF(N.EQ.24)THEN
22156            AK=10.78
22157          ELSEIF(N.EQ.25)THEN
22158            AK=(10.78+10.41)/2.0
22159          ELSEIF(N.EQ.26)THEN
22160            AK=10.41
22161          ELSEIF(N.EQ.27)THEN
22162            AK=(10.41+10.11)/2.0
22163          ELSEIF(N.EQ.28)THEN
22164            AK=10.11
22165          ELSEIF(N.EQ.29)THEN
22166            AK=(10.11+9.83)/2.0
22167          ELSEIF(N.GE.30 .AND. N.LE.32)THEN
22168            AK=9.83
22169          ELSEIF(N.GE.33 .AND. N.LE.37)THEN
22170            AK=9.30
22171          ELSEIF(N.GE.38 .AND. N.LE.42)THEN
22172            AK=8.87
22173          ELSEIF(N.GE.43 .AND. N.LE.47)THEN
22174            AK=8.56
22175          ELSEIF(N.GE.48 .AND. N.LE.50)THEN
22176            AK=8.32
22177          ELSE
22178            GOTO91
22179          ENDIF
22180        ELSE
22181          GOTO91
22182        ENDIF
22183      ELSE
22184        GOTO91
22185      ENDIF
22186C
22187      GOTO99
22188C
22189   91 CONTINUE
22190C
22191C     KRISHNAMOORTHY APPROXIMATION (PP. 325-327)
22192C
22193C     NOTE 2014/1: GAMMA IS THE CONFIDENCE AND DELTA IS THE
22194C                  COVERAGE.  KRISHNAMOORTHY USES P FOR COVERAGE
22195C                  AND G FOR CONFIDENCE.
22196C
22197CCCCC P=GAMMA
22198CCCCC G=DELTA
22199      P=DELTA
22200      G=GAMMA
22201      AN=REAL(N)
22202      AM=2.0
22203      ADELTA=AM/AN
22204      CALL NCCPPF(P,AM,ADELTA,CHI1)
22205      ANUM=4.0*AM*(AN-AM-1.0)*(AN-AM) - 12.0*(AM-1.0)*(AN-AM-2.0)
22206      ADEN=3.0*(AN-2.0) + AM*(AN-AM-1.0)
22207      E=ANUM/ADEN
22208      D=(E-2.0)/(AN-AM-2.0)
22209      IDF=INT(E+0.5)
22210      IF(IDF.EQ.0)IDF=1
22211CCCCC CALL CHSPPF(1.0-G,IDF,CHI2)
22212      ATEMP=E/2.0
22213      CALL GAMPPF(1.0-G,ATEMP,CHI2)
22214      CHI2=2.0*CHI2
22215      AK=D*(AN-1.0)*CHI1/CHI2
22216      GOTO99
22217C
22218   99 CONTINUE
22219C
22220      CUTOFF=AK*(1.0 - R**2)
22221C
22222      ISTEPN='2'
22223      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BNT2')
22224     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22225C
22226      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BNT2')THEN
22227        WRITE(ICOUT,103)YBAR,SY
22228  103   FORMAT('YBAR,SY = ',2G15.7)
22229        CALL DPWRST('XXX','BUG ')
22230        WRITE(ICOUT,105)XBAR,SX,R
22231  105   FORMAT('XBAR,SX = ',3G15.7)
22232        CALL DPWRST('XXX','BUG ')
22233        WRITE(ICOUT,107)P,G,AK
22234  107   FORMAT('P,G,AK = ',3G15.7)
22235        CALL DPWRST('XXX','BUG ')
22236        WRITE(ICOUT,108)AN,AM,ADELTA,CUTOFF
22237  108   FORMAT('AN,AM,ADELTA,CUTOFF = ',4G15.7)
22238        CALL DPWRST('XXX','BUG ')
22239        WRITE(ICOUT,109)IDF,E,D,CHI1,CHI2
22240  109   FORMAT('IDF,E,D,CHI1,CHI2 = ',I8,4G15.7)
22241        CALL DPWRST('XXX','BUG ')
22242      ENDIF
22243C
22244C     DEFINE THE ROTATION ANGLE FOR THE ELLIPSE
22245C
22246      THETA=ATAN(2.0*R*SX*SY/(SX**2 - SY**2))
22247      THETA=THETA/2.0
22248      IF(THETA.LT.0.0)THETA=THETA+(PI/2.0)
22249C
22250C     COMPUTE A AND B
22251C
22252      TERM1=1.0/(AK*(1.0 - R**2))
22253      TERM2=COS(THETA)**2/(SX**2)
22254      TERM3=COS(THETA)*SIN(THETA)*2.0*R/(SX*SY)
22255      TERM4=SIN(THETA)**2/(SY**2)
22256      A2=(TERM2 - TERM3 + TERM4)*TERM1
22257      TERM2=SIN(THETA)**2/(SX**2)
22258      TERM4=COS(THETA)**2/(SY**2)
22259      B2=(TERM2 + TERM3 + TERM4)*TERM1
22260C
22261      A=SQRT(A2)
22262      B=SQRT(B2)
22263C
22264      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BNT2')THEN
22265        WRITE(ICOUT,113)TERM1,TERM2,TERM3,TERM4
22266  113   FORMAT('TERM1,TERM2,TERM3,TERM4 = ',4G15.7)
22267        CALL DPWRST('XXX','BUG ')
22268        WRITE(ICOUT,115)A,B
22269  115   FORMAT('A,B = ',2G15.7)
22270        CALL DPWRST('XXX','BUG ')
22271      ENDIF
22272C
22273C     COMPLETE THE SQUARE ON THE TRANSOFRMED X AND Y TO GET THE
22274C     EQUATION FOR THE TRANSFORMED ELLIPSE
22275C
22276      ZX(1) = XBAR + COS(THETA)/A
22277      ZY(1) = YBAR + SIN(THETA)/A
22278C
22279      ZX(3) = XBAR - COS(THETA)/A
22280      ZY(3) = YBAR - SIN(THETA)/A
22281C
22282      ZX(2) = XBAR + SIN(THETA)/B
22283      ZY(2) = YBAR - COS(THETA)/B
22284C
22285      ZX(4) = XBAR - SIN(THETA)/B
22286      ZY(4) = YBAR + COS(THETA)/B
22287C
22288  119 CONTINUE
22289C
22290      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BNT2')THEN
22291        WRITE(ICOUT,123)ZX(1),ZX(2),ZX(3),ZX(4)
22292  123   FORMAT('ZX(1),ZX(2),ZX(3),ZX(4) = ',4G15.7)
22293        CALL DPWRST('XXX','BUG ')
22294        WRITE(ICOUT,125)ZY(1),ZY(2),ZY(3),ZY(4)
22295  125   FORMAT('ZY(1),ZY(2),ZY(3),ZY(4) = ',4G15.7)
22296        CALL DPWRST('XXX','BUG ')
22297      ENDIF
22298C
22299      DELX=ZX(3)-ZX(1)
22300      DELY=ZY(3)-ZY(1)
22301      ALEN=0.0
22302      TERM=DELX**2+DELY**2
22303      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
22304      A=ALEN/2.0
22305C
22306      IF(ABS(DELX).GE.0.00001)THETA=ATAN(DELY/DELX)
22307      IF(ABS(DELX).LT.0.00001.AND.DELY.GE.0.0)THETA=3.1415926/2.0
22308      IF(ABS(DELX).LT.0.00001.AND.DELY.LT.0.0)THETA=-3.1415926/2.0
22309C
22310      XCENT=(ZX(1)+ZX(3))/2.0
22311      YCENT=(ZY(1)+ZY(3))/2.0
22312C
22313      DELX2=ZX(2)-XCENT
22314      DELY2=ZY(2)-YCENT
22315      ALEN=0.0
22316      TERM=DELX2**2+DELY2**2
22317      IF(TERM.GT.0.0)ALEN=SQRT(TERM)
22318      B=ALEN
22319C
22320      ITAG=ITAG+1
22321C
22322      XTEMP=0.0
22323      YTEMP=0.0
22324      CALL TRANS(XTEMP,YTEMP,ZX(1),ZY(1),THETA,DELX,DELY,XP,YP,KXP,KYP)
22325      K=K+1
22326      XPLOT(K)=XP
22327      YPLOT(K)=YP
22328      D2(K)=REAL(ITAG)
22329C
22330      DO510I=181,541,5
22331        IREV=541-I+181
22332        PHI2=IREV-1
22333        PHI2=PHI2*(2.0*3.1415926)/360.0
22334        XTEMP=A*COS(PHI2)+A
22335        YTEMP=B*SIN(PHI2)
22336        CALL TRANS(XTEMP,YTEMP,ZX(1),ZY(1),THETA,DELX,DELY,XP,YP,
22337     1             KXP,KYP)
22338        K=K+1
22339        XPLOT(K)=XP
22340        YPLOT(K)=YP
22341        D2(K)=REAL(ITAG)
22342C
22343        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BNT2')THEN
22344          WRITE(ICOUT,999)
22345          CALL DPWRST('XXX','BUG ')
22346          WRITE(ICOUT,531)
22347  531     FORMAT('***** MIDDLE OF DPBNR2 (510 LOOP)--')
22348          CALL DPWRST('XXX','BUG ')
22349          WRITE(ICOUT,532)I,IREV,PHI2,XTEMP,YTEMP
22350 532      FORMAT('I,IREV,PHI2,XTEMP,YTEMP=',2I8,3G15.7)
22351          CALL DPWRST('XXX','BUG ')
22352          WRITE(ICOUT,533)K,ZX(1),ZY(1),THETA
22353 533      FORMAT('K,ZX(1),ZY(1),THETA=',I8,3G15.7)
22354          CALL DPWRST('XXX','BUG ')
22355          WRITE(ICOUT,534)DELX,DELY,XP,YP,KXP,KYP
22356 534      FORMAT('DELX,DELY,XP,YP,KXP,KYP=',4G15.7,2I8)
22357          CALL DPWRST('XXX','BUG ')
22358          WRITE(ICOUT,535)K,XPLOT(K),YPLOT(K)
22359 535      FORMAT('K,XPLOT(K),YPLOT(K) = ',I8,2G15.7)
22360          CALL DPWRST('XXX','BUG ')
22361C
22362        ENDIF
22363C
22364  510 CONTINUE
22365C
22366  100 CONTINUE
22367      NP=K
22368C
22369C               ****************************************************
22370C               **  STEP 3--                                      **
22371C               **  NOW PLOT THE POINTS                           **
22372C               ****************************************************
22373C
22374      ISTEPN='3'
22375      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BNT2')
22376     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
22377C
22378      IF(NUMV2.EQ.2)THEN
22379        ITAG=ITAG+1
22380        XMIN=CPUMAX
22381        XMAX=CPUMIN
22382        DO600I=1,N
22383          NP=NP+1
22384          XPLOT(NP)=Y2(I)
22385          YPLOT(NP)=Y1(I)
22386          IF(XPLOT(NP).LT.XMIN)XMIN=XPLOT(NP)
22387          IF(XPLOT(NP).GT.XMAX)XMAX=XPLOT(NP)
22388          D2(NP)=REAL(ITAG)
22389  600   CONTINUE
22390      ELSEIF(NUMV2.GE.3)THEN
22391        CALL DISTIN(X,N,IWRITE,XIDTEM,NUMSET,IBUGG3,IERROR)
22392        CALL SORT(XIDTEM,NUMSET,XIDTEM)
22393        XMIN=CPUMAX
22394        XMAX=CPUMIN
22395        DO700ISET=1,NUMSET
22396          HOLD=XIDTEM(ISET)
22397C
22398          ITAG=ITAG+1
22399          DO710I=1,N
22400            IF(X(I).EQ.HOLD)THEN
22401              NP=NP+1
22402              XPLOT(NP)=Y2(I)
22403              IF(XPLOT(NP).LT.XMIN)XMIN=XPLOT(NP)
22404              IF(XPLOT(NP).GT.XMAX)XMAX=XPLOT(NP)
22405              YPLOT(NP)=Y1(I)
22406              D2(NP)=REAL(ITAG)
22407            ENDIF
22408  710     CONTINUE
22409C
22410  700   CONTINUE
22411C
22412      ENDIF
22413C
22414C               ****************************************************
22415C               **  STEP 4--                                      **
22416C               **  FOR POINCARE PLOT, ADD LINES THROUGH          **
22417C               **  (XBAR,YBAR) WITH SLOPES +1 AND -1.            **
22418C               ****************************************************
22419C
22420      IF(ICASPL.EQ.'POIN')THEN
22421        ITAG=ITAG+1
22422        YVAL=XMIN - XBAR + YBAR
22423        NP=NP+1
22424        XPLOT(NP)=XMIN
22425        YPLOT(NP)=YVAL
22426        D2(NP)=REAL(ITAG)
22427        YVAL=XMAX - XBAR + YBAR
22428        NP=NP+1
22429        XPLOT(NP)=XMAX
22430        YPLOT(NP)=YVAL
22431        D2(NP)=REAL(ITAG)
22432C
22433        ITAG=ITAG+1
22434        YVAL=-XMIN + XBAR + YBAR
22435        NP=NP+1
22436        XPLOT(NP)=XMIN
22437        YPLOT(NP)=YVAL
22438        D2(NP)=REAL(ITAG)
22439        YVAL=-XMAX + XBAR + YBAR
22440        NP=NP+1
22441        XPLOT(NP)=XMAX
22442        YPLOT(NP)=YVAL
22443        D2(NP)=REAL(ITAG)
22444      ENDIF
22445C
22446      N2=NP
22447      NPLOTP=N2
22448      NPLOTV=2
22449C
22450C               *****************
22451C               **  STEP 90--  **
22452C               **  EXIT       **
22453C               *****************
22454C
22455      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BNT2')THEN
22456        WRITE(ICOUT,999)
22457        CALL DPWRST('XXX','BUG ')
22458        WRITE(ICOUT,9011)
22459 9011   FORMAT('***** AT THE END OF DPBNR2--')
22460        CALL DPWRST('XXX','BUG ')
22461        WRITE(ICOUT,9012)IFOUND,IERROR
22462 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
22463        CALL DPWRST('XXX','BUG ')
22464        WRITE(ICOUT,9013)NPLOTV,NPLOTP,N,ICASPL
22465 9013   FORMAT('NPLOTV,NPLOTP,N,ICASPL = ',
22466     1         I8,I8,I8,2X,A4)
22467        CALL DPWRST('XXX','BUG ')
22468        WRITE(ICOUT,9020)
22469 9020   FORMAT('I,YPLOT(.),XPLOT(.),X3D(.),D2(.)--')
22470        CALL DPWRST('XXX','BUG ')
22471        DO9021I=1,NPLOTP
22472          WRITE(ICOUT,9022)I,YPLOT(I),XPLOT(I),X3D(I),D2(I)
22473 9022     FORMAT(I8,4G15.7)
22474          CALL DPWRST('XXX','BUG ')
22475 9021   CONTINUE
22476      ENDIF
22477C
22478      RETURN
22479      END
22480      SUBROUTINE DPBOB(NPTS,NLAB,
22481     1                 AMEAN,ASD,AMNX,AMXX,SW,
22482     1                 ASM,ASB,AKU,AKUK1,AKUK2,
22483     1                 DLOWBO,DHIGBO,
22484     1                 IWRITE,ICAPSW,ICAPTY,NUMDIG,
22485     1                 ISUBRO,IBUGA3,IERROR)
22486C
22487C     PURPOSE--IMPLEMENT BOUNDS ON BIAS (BOB) APPROACH TO
22488C              CONSENSUS MEANS.  BASED ON MACRO PROVIDED BY
22489C              STEFAN LEIGH.
22490C     PRINTING--YES
22491C     SUBROUTINES NEEDED--NONE
22492C     WRITTEN BY--JAMES J. FILLIBEN
22493C                 STATISTICAL ENGINEERING DIVISION
22494C                 INFORMATION TECHNOLOGY LABORATORY
22495C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22496C                 GAITHERSBURG, MD 20899-8980
22497C                 PHONE--301-975-2899
22498C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22499C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22500C     LANGUAGE--ANSI FORTRAN (1977)
22501C     VERSION NUMBER--2006/3
22502C     ORIGINAL VERSION--MARCH     2006. EXTRACTED FROM DPMAN2 ROUTINE
22503C     UPDATED         --FEBRUARY  2010. USE DPDTA1 TO PRINT
22504C
22505C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES--------------
22506C
22507      IMPLICIT DOUBLE PRECISION (A-H, O-Z)
22508C
22509      CHARACTER*4 ICAPSW
22510      CHARACTER*4 ICAPTY
22511      CHARACTER*4 ISUBRO
22512      CHARACTER*4 IBUGA3
22513      CHARACTER*4 IERROR
22514C
22515      CHARACTER*4 IWRITE
22516      CHARACTER*4 ISUBN1
22517      CHARACTER*4 ISUBN2
22518C
22519      REAL ASM
22520      REAL AMNX
22521      REAL AMXX
22522      REAL ASB
22523      REAL AKU
22524      REAL AKUK1
22525      REAL AKUK2
22526      REAL SW
22527      REAL AMEAN(*)
22528      REAL ASD(*)
22529C
22530C----------------------------------------------------------------
22531C
22532      INCLUDE 'DPCOST.INC'
22533C
22534      PARAMETER (MAXROW=20)
22535      CHARACTER*60 ITITLE
22536      CHARACTER*60 ITITLZ
22537      CHARACTER*60 ITITL9
22538      CHARACTER*60 ITEXT(MAXROW)
22539      REAL         AVALUE(MAXROW)
22540      INTEGER      NCTEXT(MAXROW)
22541      INTEGER      IDIGIT(MAXROW)
22542      INTEGER      NTOT(MAXROW)
22543      LOGICAL IFRST
22544      LOGICAL ILAST
22545C
22546      INCLUDE 'DPCOP2.INC'
22547C
22548C-----START POINT------------------------------------------------
22549C
22550      IERROR='NO'
22551      ISUBN1='DPBO'
22552      ISUBN2='B   '
22553C
22554      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PBOB')THEN
22555        WRITE(ICOUT,999)
22556  999   FORMAT(1X)
22557        CALL DPWRST('XXX','BUG ')
22558        WRITE(ICOUT,51)
22559   51   FORMAT('***** AT THE BEGINNING OF DPBOB--')
22560        CALL DPWRST('XXX','BUG ')
22561        WRITE(ICOUT,52)NPTS,NLAB,SW
22562   52   FORMAT('NPTS,NLAB,SW = ',2I8,3G15.7)
22563        CALL DPWRST('XXX','BUG ')
22564        DO55I=1,NLAB
22565          WRITE(ICOUT,56)I,AMEAN(I),ASD(I)
22566   56     FORMAT('I,AMEAN(I),ASD(I) = ',I8,2G15.7)
22567          CALL DPWRST('XXX','BUG ')
22568   55   CONTINUE
22569      ENDIF
22570C
22571      CALL MEAN(AMEAN,NLAB,IWRITE,ASM,IBUGA3,IERROR)
22572      DSB=DBLE(AMXX - AMNX)/DSQRT(12.0D0)
22573      DKU=2.0D0*DSQRT((SW**2) + (DSB**2))
22574      ASB=REAL(DSB)
22575      AKU=REAL(DKU)
22576      AKUK2=AKU
22577      AKUK1=AKU/2.0
22578      DLOWBO=DBLE(ASM - AKU)
22579      DHIGBO=DBLE(ASM + AKU)
22580C
22581      ITITLE=' '
22582      NCTITL=0
22583      ITITLZ=' '
22584      NCTITZ=0
22585C
22586      ICNT=1
22587      ITEXT(ICNT)='11. Method: BOB (Bound on Bias)'
22588      NCTEXT(ICNT)=31
22589      AVALUE(ICNT)=0.0
22590      IDIGIT(ICNT)=-1
22591C
22592      ICNT=ICNT+1
22593      ITEXT(ICNT)='    Estimate of Consensus Mean:'
22594      NCTEXT(ICNT)=31
22595      AVALUE(ICNT)=ASM
22596      IDIGIT(ICNT)=NUMDIG
22597      ICNT=ICNT+1
22598      ITEXT(ICNT)='    Within Lab Uncertainty:'
22599      NCTEXT(ICNT)=27
22600      AVALUE(ICNT)=SW
22601      IDIGIT(ICNT)=NUMDIG
22602      ICNT=ICNT+1
22603      ITEXT(ICNT)='    Between Lab Uncertainty:'
22604      NCTEXT(ICNT)=37
22605      AVALUE(ICNT)=ASB
22606      IDIGIT(ICNT)=NUMDIG
22607      ICNT=ICNT+1
22608      ITEXT(ICNT)='    Standard Uncertainty (k = 1):'
22609      NCTEXT(ICNT)=33
22610      AVALUE(ICNT)=AKU/2.0
22611      IDIGIT(ICNT)=NUMDIG
22612      ICNT=ICNT+1
22613      ITEXT(ICNT)='    Expanded Uncertainty (k = 2):'
22614      NCTEXT(ICNT)=33
22615      AVALUE(ICNT)=AKU
22616      IDIGIT(ICNT)=NUMDIG
22617      ICNT=ICNT+1
22618      ITEXT(ICNT)='    Lower 95% (k = 2) Confidence Limit:'
22619      NCTEXT(ICNT)=39
22620      AVALUE(ICNT)=DLOWBO
22621      IDIGIT(ICNT)=NUMDIG
22622      ICNT=ICNT+1
22623      ITEXT(ICNT)='    Upper 95% (k = 2) Confidence Limit:'
22624      NCTEXT(ICNT)=40
22625      AVALUE(ICNT)=DHIGBO
22626      IDIGIT(ICNT)=NUMDIG
22627      ICNT=ICNT+1
22628      ITEXT(ICNT)='    Note: BOB Best Usage:'
22629      NCTEXT(ICNT)=25
22630      AVALUE(ICNT)=0.0
22631      IDIGIT(ICNT)=-1
22632      ICNT=ICNT+1
22633      ITEXT(ICNT)='          5 or Fewer Labs:'
22634      NCTEXT(ICNT)=26
22635      AVALUE(ICNT)=0.0
22636      IDIGIT(ICNT)=-1
22637C
22638      NUMROW=ICNT
22639      DO310I=1,NUMROW
22640        NTOT(I)=15
22641  310 CONTINUE
22642C
22643      IFRST=.TRUE.
22644      ILAST=.TRUE.
22645      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
22646     1            AVALUE,IDIGIT,
22647     1            NTOT,NUMROW,
22648     1            ICAPSW,ICAPTY,ILAST,IFRST,
22649     1            ISUBRO,IBUGA3,IERROR)
22650      ITITLE=' '
22651      NCTITL=0
22652      ITITLZ=' '
22653      NCTITZ=0
22654      ITITL9=' '
22655      NCTIT9=0
22656C
22657C               *****************
22658C               **  STEP 90--  **
22659C               **  EXIT       **
22660C               *****************
22661C
22662      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'PBOB')THEN
22663        WRITE(ICOUT,999)
22664        CALL DPWRST('XXX','BUG ')
22665        WRITE(ICOUT,9011)
22666 9011   FORMAT('***** AT THE END       OF DPBOB--')
22667        CALL DPWRST('XXX','BUG ')
22668        WRITE(ICOUT,9012)IERROR
22669 9012   FORMAT('IERROR = ',A4)
22670        CALL DPWRST('XXX','BUG ')
22671        WRITE(ICOUT,9013)NPTS,NLAB
22672 9013   FORMAT('NPTS,NLAB = ',2I8)
22673        CALL DPWRST('XXX','BUG ')
22674        WRITE(ICOUT,9014)ASM,ASB,AKU
22675 9014   FORMAT('ASM,ASB,AKU = ',3G15.7)
22676        CALL DPWRST('XXX','BUG ')
22677        WRITE(ICOUT,9015)DLOWBO,DHIGBO
22678 9015   FORMAT('DLOWBO,DHIGBO = ',2G15.7)
22679        CALL DPWRST('XXX','BUG ')
22680      ENDIF
22681C
22682      RETURN
22683      END
22684      SUBROUTINE DPBOCC(IHARG,IHARG2,IARGT,IARG,ARG,NUMARG,
22685     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,IANS,IWIDTH,
22686     1MAXBOX,PBOXXC,PBOXYC,NUMBOX,IBUGP2,IFOUND,IERROR)
22687C
22688C     PURPOSE--DEFINE THE 2 PAIRS OF (X,Y) COORDINATES
22689C              FOR A BOX.
22690C              THE FIRST PAIR WILL BE FOR THE LOWER LEFT CORNER
22691C              OF THE BOX;
22692C              THE SECOND PAIR WILL BE FOR THE UPPER RIGHT CORNER
22693C              OF THE BOX.
22694C              THE (X1,Y1), (X2,Y2) COORDINATES WILL BE PLACED IN THE
22695C              FIRST AND SECOND ELEMENTS (RESPECTIVELY) OF
22696C              THE 2 BOXAYS PBOXXC(.,.) AND PBOXYC(.,.)
22697C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
22698C                     --IARGT  (A HOLLERITH VECTOR)
22699C                     --IARG   (A HOLLERITH VECTOR)
22700C                     --ARG    (A HOLLERITH VECTOR)
22701C                     --NUMARG
22702C                     --MAXBOX
22703C     OUTPUT ARGUMENTS--PBOXXC (A FLOATING POINT VECTOR
22704C                              WHOSE (I,1)-TH ELEMENT CONTAINS THE
22705C                              X COORDINATE FOR THE ONE CORNER OF BOX I;
22706C                              WHOSE (I,2)-TH ELEMENT CONTAINS THE
22707C                              X COORDINATE FOR THE OPPOSITE CORNER OF BOX I;
22708C                     --PBOXYC (A FLOATING POINT VECTOR
22709C                              WHOSE (I,1)-TH ELEMENT CONTAINS THE
22710C                              Y COORDINATE FOR THE ONE CORNER OF BOX I;
22711C                              WHOSE (I,2)-TH ELEMENT CONTAINS THE
22712C                              Y COORDINATE FOR THE OPPOSITE CORNER OF BOX I;
22713C                     --NUMBOX = THE NUMBER OF BOXES DEFINED SO FAR
22714C                              (ACTUALLY, THE HIGHEST REFERENCED BOX SO FAR)
22715C                     --IFOUND ('YES' OR 'NO' )
22716C                     --IERROR ('YES' OR 'NO' )
22717C     WRITTEN BY--JAMES J. FILLIBEN
22718C                 STATISTICAL ENGINEERING DIVISION
22719C                 INFORMATION TECHNOLOGY LABORATORY
22720C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
22721C                 GAITHERSBURG, MD 20899-8980
22722C                 PHONE--301-975-2855
22723C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
22724C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
22725C     LANGUAGE--ANSI FORTRAN (1977)
22726C     VERSION NUMBER--82/7
22727C     ORIGINAL VERSION--SEPTEMBER 1980.
22728C     UPDATED         --MARCH     1981.
22729C     UPDATED         --MAY       1982.
22730C     UPDATED         --OCTOBER   1992. FIX BUG (ALAN)
22731C
22732C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
22733C
22734      CHARACTER*4 IHARG
22735      CHARACTER*4 IHARG2
22736      CHARACTER*4 IARGT
22737      CHARACTER*4 IHNAME
22738      CHARACTER*4 IHNAM2
22739      CHARACTER*4 IUSE
22740      CHARACTER*4 IANS
22741      CHARACTER*4 IBUGP2
22742      CHARACTER*4 IFOUND
22743      CHARACTER*4 IERROR
22744C
22745      CHARACTER*4 IHWUSE
22746      CHARACTER*4 MESSAG
22747      CHARACTER*4 IHWORD
22748      CHARACTER*4 IHWOR2
22749C
22750      CHARACTER*4 ISUBN1
22751      CHARACTER*4 ISUBN2
22752C
22753C---------------------------------------------------------------------
22754C
22755      DIMENSION IHARG(*)
22756      DIMENSION IHARG2(*)
22757      DIMENSION IARGT(*)
22758      DIMENSION IARG(*)
22759      DIMENSION ARG(*)
22760C
22761      DIMENSION IHNAME(*)
22762      DIMENSION IHNAM2(*)
22763      DIMENSION IUSE(*)
22764      DIMENSION IN(*)
22765      DIMENSION IVALUE(*)
22766      DIMENSION VALUE(*)
22767      DIMENSION IANS(*)
22768C
22769      DIMENSION PBOXXC(100,2)
22770      DIMENSION PBOXYC(100,2)
22771C
22772C---------------------------------------------------------------------
22773C
22774      INCLUDE 'DPCOP2.INC'
22775C
22776C-----START POINT-----------------------------------------------------
22777C
22778      ISUBN1='DPBO'
22779      ISUBN2='CC  '
22780C
22781      IFOUND='NO'
22782      IERROR='NO'
22783C
22784      HOLD1=0.0
22785      HOLD2=0.0
22786      HOLD3=0.0
22787      HOLD4=0.0
22788C
22789      IF(NUMARG.EQ.0)GOTO9000
22790CCCCC OCTOBER 1992.  DISTINGUISH: BOX 1 COORDINATES FROM
22791CCCCC BOX CORNER COORDINATES CASE
22792      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'CORN'.AND.IHARG(2).EQ.'COOR')
22793     1GOTO1110
22794      IF(NUMARG.GE.2.AND.IHARG(1).NE.'CORN'.AND.IHARG(2).EQ.'COOR')THEN
22795        ILASTC=2
22796        GOTO1140
22797      ENDIF
22798      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'COOR')GOTO1110
22799      ILASTC=3
22800C  END CHANGE
22801      IF(NUMARG.GE.3.AND.IHARG(3).EQ.'COOR')GOTO1140
22802      GOTO9000
22803C
22804 1110 CONTINUE
22805      IF(NUMARG.LE.1)GOTO1120
22806      IF(IHARG(3).EQ.'ON')GOTO1120
22807      IF(IHARG(3).EQ.'OFF')GOTO1120
22808      IF(IHARG(3).EQ.'AUTO')GOTO1120
22809      IF(IHARG(3).EQ.'DEFA')GOTO1120
22810      IF(NUMARG.GE.6)GOTO1125
22811C
22812      IERROR='YES'
22813      WRITE(ICOUT,999)
22814  999 FORMAT(1X)
22815      CALL DPWRST('XXX','BUG ')
22816      WRITE(ICOUT,1111)
22817 1111 FORMAT('***** ERROR IN DPBOCC--')
22818      CALL DPWRST('XXX','BUG ')
22819      WRITE(ICOUT,1112)
22820 1112 FORMAT('      IN THE BOX ... CORNER COORDINATES COMMAND,')
22821      CALL DPWRST('XXX','BUG ')
22822      WRITE(ICOUT,1113)
22823 1113 FORMAT('      THE CORNER COORDINATES ARE SPECIFIED ',
22824     1'BY 4 NUMBERS, AS IN--')
22825      CALL DPWRST('XXX','BUG ')
22826      WRITE(ICOUT,1114)
22827 1114 FORMAT('      BOX 3 CORNER COORDINATES 30 50 40 60')
22828      CALL DPWRST('XXX','BUG ')
22829      GOTO9000
22830C
22831 1120 CONTINUE
22832      HOLD1=CPUMIN
22833      HOLD2=CPUMIN
22834      HOLD3=CPUMIN
22835      HOLD4=CPUMIN
22836      NUMBOX=0
22837      GOTO1130
22838C
22839 1125 CONTINUE
22840      DO1126J=3,6
22841      IF(IARGT(J).EQ.'NUMB')GOTO1127
22842      GOTO1128
22843 1127 CONTINUE
22844      IF(J.EQ.3)HOLD1=ARG(J)
22845      IF(J.EQ.4)HOLD2=ARG(J)
22846      IF(J.EQ.5)HOLD3=ARG(J)
22847      IF(J.EQ.6)HOLD4=ARG(J)
22848      GOTO1126
22849 1128 CONTINUE
22850      IHWORD=IHARG(J)
22851      IHWOR2=IHARG2(J)
22852      IHWUSE='P'
22853      MESSAG='YES'
22854      CALL CHECKN(IHWORD,IHWOR2,IHWUSE,
22855     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
22856     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
22857      IF(IERROR.EQ.'YES')GOTO9000
22858      IF(J.EQ.3)HOLD1=VALUE(ILOC)
22859      IF(J.EQ.4)HOLD2=VALUE(ILOC)
22860      IF(J.EQ.5)HOLD3=VALUE(ILOC)
22861      IF(J.EQ.6)HOLD4=VALUE(ILOC)
22862 1126 CONTINUE
22863      NUMBOX=MAXBOX
22864      GOTO1130
22865C
22866 1130 CONTINUE
22867      IFOUND='YES'
22868      DO1135I=1,MAXBOX
22869      PBOXXC(I,1)=HOLD1
22870      PBOXYC(I,1)=HOLD2
22871      PBOXXC(I,2)=HOLD3
22872      PBOXYC(I,2)=HOLD4
22873 1135 CONTINUE
22874C
22875      IF(IFEEDB.EQ.'OFF')GOTO1139
22876      WRITE(ICOUT,999)
22877      CALL DPWRST('XXX','BUG ')
22878      I=1
22879      WRITE(ICOUT,1136)
22880 1136 FORMAT('ALL BOX CORNER COORDINATES HAVE JUST BEEN SET TO--')
22881      CALL DPWRST('XXX','BUG ')
22882      WRITE(ICOUT,1137)PBOXXC(I,1),PBOXYC(I,1)
22883 1137 FORMAT('    (X,Y) FOR LOWER LEFT  CORNER OF BOX = ',2E15.7)
22884      CALL DPWRST('XXX','BUG ')
22885      WRITE(ICOUT,1138)PBOXXC(I,2),PBOXYC(I,2)
22886 1138 FORMAT('    (X,Y) FOR LOWER RIGHT CORNER OF BOX = ',2E15.7)
22887      CALL DPWRST('XXX','BUG ')
22888 1139 CONTINUE
22889      GOTO9000
22890C
22891CCCCC OCTOBER 1992.  FOLLOWING SECTION MODIFIED TO HANDLE
22892CCCCC BOX <ID> COOR CASE.
22893 1140 CONTINUE
22894      IF(IARGT(1).EQ.'NUMB')GOTO1150
22895      IERROR='YES'
22896      WRITE(ICOUT,999)
22897      CALL DPWRST('XXX','BUG ')
22898      WRITE(ICOUT,1141)
22899 1141 FORMAT('***** ERROR IN DPBOCC--')
22900      CALL DPWRST('XXX','BUG ')
22901      WRITE(ICOUT,1142)
22902 1142 FORMAT('      IN THE BOX ... CORNER COORDINATES COMMAND,')
22903      CALL DPWRST('XXX','BUG ')
22904      WRITE(ICOUT,1143)
22905 1143 FORMAT('      THE BOX IS IDENTIFIED BY A NUMBER, AS IN--')
22906      CALL DPWRST('XXX','BUG ')
22907      WRITE(ICOUT,1144)
22908 1144 FORMAT('      BOX 3 CORNER COORDINATES 30 50 40 60')
22909      CALL DPWRST('XXX','BUG ')
22910      GOTO9000
22911C
22912 1150 CONTINUE
22913      I=IARG(1)
22914      IF(1.LE.I.AND.I.LE.MAXBOX)GOTO1160
22915      IERROR='YES'
22916      WRITE(ICOUT,999)
22917      CALL DPWRST('XXX','BUG ')
22918      WRITE(ICOUT,1151)
22919 1151 FORMAT('***** ERROR IN DPBOCC--')
22920      CALL DPWRST('XXX','BUG ')
22921      WRITE(ICOUT,1152)
22922 1152 FORMAT('      IN THE BOX ... CORNER COORDINATES COMMAND,')
22923      CALL DPWRST('XXX','BUG ')
22924      WRITE(ICOUT,1153)
22925 1153 FORMAT('      THE NUMBER OF BOXES MUST BE ')
22926      CALL DPWRST('XXX','BUG ')
22927      WRITE(ICOUT,1154)MAXBOX
22928 1154 FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
22929      CALL DPWRST('XXX','BUG ')
22930      WRITE(ICOUT,1155)
22931 1155 FORMAT('      SUCH WAS NOT THE CASE HERE--')
22932      CALL DPWRST('XXX','BUG ')
22933      WRITE(ICOUT,1156)I
22934 1156 FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
22935     1'BOX.')
22936      CALL DPWRST('XXX','BUG ')
22937      GOTO9000
22938C
22939 1160 CONTINUE
22940CCCCC IF(NUMARG.LE.3)GOTO1170
22941      IF(NUMARG.LE.ILASTC)GOTO1170
22942CCCCC IF(IHARG(4).EQ.'ON')GOTO1170
22943CCCCC IF(IHARG(4).EQ.'OFF')GOTO1170
22944CCCCC IF(IHARG(4).EQ.'AUTO')GOTO1170
22945CCCCC IF(IHARG(4).EQ.'DEFA')GOTO1170
22946      IFRSTC=ILASTC+1
22947      IF(IHARG(IFRSTC).EQ.'ON')GOTO1170
22948      IF(IHARG(IFRSTC).EQ.'OFF')GOTO1170
22949      IF(IHARG(IFRSTC).EQ.'AUTO')GOTO1170
22950      IF(IHARG(IFRSTC).EQ.'DEFA')GOTO1170
22951CCCCC IF(NUMARG.GE.7)GOTO1175
22952      IF(NUMARG.GE.IFRSTC+3)GOTO1175
22953      IERROR='YES'
22954      WRITE(ICOUT,999)
22955      CALL DPWRST('XXX','BUG ')
22956      WRITE(ICOUT,1111)
22957      CALL DPWRST('XXX','BUG ')
22958      WRITE(ICOUT,1112)
22959      CALL DPWRST('XXX','BUG ')
22960      WRITE(ICOUT,1113)
22961      CALL DPWRST('XXX','BUG ')
22962      WRITE(ICOUT,1114)
22963      CALL DPWRST('XXX','BUG ')
22964      GOTO9000
22965C
22966 1170 CONTINUE
22967      HOLD1=CPUMIN
22968      HOLD2=CPUMIN
22969      HOLD3=CPUMIN
22970      HOLD4=CPUMIN
22971      IF(I.EQ.NUMBOX)NUMBOX=I-1
22972      GOTO1180
22973C
22974 1175 CONTINUE
22975CCCCC DO1176J=4,7
22976      DO1176J=IFRSTC,IFRSTC+3
22977      IF(IARGT(J).EQ.'NUMB')GOTO1177
22978      GOTO1178
22979 1177 CONTINUE
22980      IF(J.EQ.4)HOLD1=ARG(J)
22981      IF(J.EQ.5)HOLD2=ARG(J)
22982      IF(J.EQ.6)HOLD3=ARG(J)
22983      IF(J.EQ.7)HOLD4=ARG(J)
22984      GOTO1176
22985 1178 CONTINUE
22986      IHWORD=IHARG(J)
22987      IHWOR2=IHARG2(J)
22988      IHWUSE='P'
22989      MESSAG='YES'
22990      CALL CHECKN(IHWORD,IHWOR2,IHWUSE,
22991     1IHNAME,IHNAM2,IUSE,IN,IVALUE,VALUE,NUMNAM,MAXNAM,
22992     1ISUBN1,ISUBN2,MESSAG,IANS,IWIDTH,ILOC,IERROR)
22993      IF(IERROR.EQ.'YES')GOTO9000
22994      IF(J.EQ.4)HOLD1=VALUE(ILOC)
22995      IF(J.EQ.5)HOLD2=VALUE(ILOC)
22996      IF(J.EQ.6)HOLD3=VALUE(ILOC)
22997      IF(J.EQ.7)HOLD4=VALUE(ILOC)
22998 1176 CONTINUE
22999      IF(I.GT.NUMBOX)NUMBOX=I
23000      GOTO1180
23001C
23002 1180 CONTINUE
23003      IFOUND='YES'
23004      PBOXXC(I,1)=HOLD1
23005      PBOXYC(I,1)=HOLD2
23006      PBOXXC(I,2)=HOLD3
23007      PBOXYC(I,2)=HOLD4
23008C
23009      IF(IFEEDB.EQ.'OFF')GOTO1189
23010      WRITE(ICOUT,999)
23011      CALL DPWRST('XXX','BUG ')
23012      WRITE(ICOUT,1186)I
23013 1186 FORMAT('THE CORNER COORDINATES FOR BOX ',I8,
23014     1' HAVE JUST BEEN SET TO--')
23015      CALL DPWRST('XXX','BUG ')
23016      WRITE(ICOUT,1137)PBOXXC(I,1),PBOXYC(I,1)
23017      CALL DPWRST('XXX','BUG ')
23018      WRITE(ICOUT,1138)PBOXXC(I,2),PBOXYC(I,2)
23019      CALL DPWRST('XXX','BUG ')
23020 1189 CONTINUE
23021      GOTO9000
23022C
23023C               *****************
23024C               **  STEP 90--  **
23025C               **  EXIT       **
23026C               *****************
23027C
23028 9000 CONTINUE
23029      IF(IBUGP2.EQ.'OFF')GOTO9090
23030      WRITE(ICOUT,999)
23031      CALL DPWRST('XXX','BUG ')
23032      WRITE(ICOUT,9011)
23033 9011 FORMAT('***** AT THE END       OF DPBOCC--')
23034      CALL DPWRST('XXX','BUG ')
23035      WRITE(ICOUT,9012)IFOUND,IERROR
23036 9012 FORMAT('IFOUND,IERROR = ',A4,2X,A4)
23037      CALL DPWRST('XXX','BUG ')
23038 9090 CONTINUE
23039C
23040      RETURN
23041      END
23042      SUBROUTINE DPBOCL(IHARG,IARGT,IARG,NUMARG,IDEFXC,
23043     1                  MAXBOX,IBOFCO,IFOUND,IERROR)
23044C
23045C     PURPOSE--DEFINE THE COLOR FOR A BOX.
23046C              THE COLOR FOR A BOX IS THE COLOR
23047C              THAT WILL APPEAR ON THE BORDER OF THE BOX.
23048C              THE COLOR FOR BOX I WILL BE PLACED
23049C              IN THE I-TH ELEMENT OF THE HOLLERITH
23050C              VECTOR IBOFCO(.).
23051C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
23052C                     --IARGT  (A HOLLERITH VECTOR)
23053C                     --IARG   (A HOLLERITH VECTOR)
23054C                     --NUMARG
23055C                     --IDEFXC
23056C                     --MAXBOX
23057C     OUTPUT ARGUMENTS--IBOFCO (A HOLLERITH VECTOR
23058C                              WHOSE I-TH ELEMENT CONTAINS THE
23059C                              COLOR FOR BOX I.
23060C                     --IFOUND ('YES' OR 'NO' )
23061C                     --IERROR ('YES' OR 'NO' )
23062C     WRITTEN BY--JAMES J. FILLIBEN
23063C                 STATISTICAL ENGINEERING DIVISION
23064C                 INFORMATION TECHNOLOGY LABORATORY
23065C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23066C                 GAITHERSBURG, MD 20899-8980
23067C                 PHONE--301-975-2855
23068C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23069C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23070C     LANGUAGE--ANSI FORTRAN (1977)
23071C     VERSION NUMBER--82/7
23072C     ORIGINAL VERSION--SEPTEMBER 1980.
23073C     UPDATED         --MAY       1982.
23074C     UPDATED         --AUGUST    1992.  FEEDBACK MESSAGES
23075C
23076C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23077C
23078      CHARACTER*4 IHARG
23079      CHARACTER*4 IARGT
23080      CHARACTER*4 IDEFXC
23081      CHARACTER*4 IBOFCO
23082      CHARACTER*4 IFOUND
23083      CHARACTER*4 IERROR
23084C
23085      CHARACTER*4 IHOLD
23086C
23087C---------------------------------------------------------------------
23088C
23089      DIMENSION IHARG(*)
23090      DIMENSION IARGT(*)
23091      DIMENSION IARG(*)
23092      DIMENSION IBOFCO(*)
23093C
23094C---------------------------------------------------------------------
23095C
23096      INCLUDE 'DPCOP2.INC'
23097C
23098C-----START POINT-----------------------------------------------------
23099C
23100      IFOUND='NO'
23101      IERROR='NO'
23102C
23103      IF(NUMARG.EQ.0)THEN
23104        GOTO1199
23105      ELSEIF(NUMARG.GE.1.AND.IHARG(1).EQ.'COLO')THEN
23106        IF(NUMARG.LE.1 .OR. IHARG(2).EQ.'ON' .OR.
23107     1     IHARG(2).EQ.'OFF' .OR. IHARG(2).EQ.'AUTO' .OR.
23108     1     IHARG(2).EQ.'DEFA')THEN
23109          IHOLD=IDEFXC
23110        ELSE
23111          IHOLD=IHARG(2)
23112        ENDIF
23113        IFOUND='YES'
23114        DO1135I=1,MAXBOX
23115          IBOFCO(I)=IHOLD
23116 1135   CONTINUE
23117        IF(IFEEDB.EQ.'ON')THEN
23118          WRITE(ICOUT,999)
23119  999     FORMAT(1X)
23120          CALL DPWRST('XXX','BUG ')
23121          I=1
23122          WRITE(ICOUT,1136)IBOFCO(I)
23123 1136     FORMAT('ALL BOX BORDER COLORS HAVE JUST BEEN SET TO ',A4)
23124          CALL DPWRST('XXX','BUG ')
23125          GOTO1199
23126        ENDIF
23127      ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'COLO')THEN
23128        IF(IARGT(1).NE.'NUMB')THEN
23129          IERROR='YES'
23130          WRITE(ICOUT,999)
23131          CALL DPWRST('XXX','BUG ')
23132          WRITE(ICOUT,1141)
23133 1141     FORMAT('***** ERROR IN BOX COLOR (DPBOCL)--')
23134          CALL DPWRST('XXX','BUG ')
23135          WRITE(ICOUT,1142)
23136 1142     FORMAT('      IN THE BOX ... COLOR COMMAND,')
23137          CALL DPWRST('XXX','BUG ')
23138          WRITE(ICOUT,1143)
23139 1143     FORMAT('      THE BOX IS IDENTIFIED BY A NUMBER, AS IN--')
23140          CALL DPWRST('XXX','BUG ')
23141          WRITE(ICOUT,1144)
23142 1144     FORMAT('      BOX 3 COLOR GREEN')
23143          CALL DPWRST('XXX','BUG ')
23144          GOTO1199
23145        ENDIF
23146        I=IARG(1)
23147        IF(I.LT.1 .OR. I.GT.MAXBOX)THEN
23148          IERROR='YES'
23149          WRITE(ICOUT,999)
23150          CALL DPWRST('XXX','BUG ')
23151          WRITE(ICOUT,1141)
23152          CALL DPWRST('XXX','BUG ')
23153          WRITE(ICOUT,1142)
23154          CALL DPWRST('XXX','BUG ')
23155          WRITE(ICOUT,1153)
23156 1153     FORMAT('      THE NUMBER OF BOXES MUST BE ')
23157          CALL DPWRST('XXX','BUG ')
23158          WRITE(ICOUT,1154)MAXBOX
23159 1154     FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
23160          CALL DPWRST('XXX','BUG ')
23161          WRITE(ICOUT,1155)
23162 1155     FORMAT('      SUCH WAS NOT THE CASE HERE--')
23163          CALL DPWRST('XXX','BUG ')
23164          WRITE(ICOUT,1156)I
23165 1156     FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
23166     1           'BOX.')
23167          CALL DPWRST('XXX','BUG ')
23168          GOTO1199
23169        ENDIF
23170        IF(NUMARG.LE.2 .OR. IHARG(3).EQ.'ON' .OR.
23171     1     IHARG(3).EQ.'OFF' .OR. IHARG(3).EQ.'AUTO' .OR.
23172     1     IHARG(3).EQ.'DEFA')THEN
23173          IHOLD=IDEFXC
23174        ELSE
23175          IHOLD=IHARG(3)
23176        ENDIF
23177        IFOUND='YES'
23178        IBOFCO(I)=IHOLD
23179        IF(IFEEDB.EQ.'ON')THEN
23180          WRITE(ICOUT,999)
23181          CALL DPWRST('XXX','BUG ')
23182          WRITE(ICOUT,1186)I,IBOFCO(I)
23183 1186     FORMAT('THE BORDER COLOR FOR BOX ',I8,
23184     1           ' HAS JUST BEEN SET TO ',A4)
23185          CALL DPWRST('XXX','BUG ')
23186          GOTO1199
23187        ENDIF
23188      ENDIF
23189C
23190 1199 CONTINUE
23191      RETURN
23192      END
23193      SUBROUTINE DPBOFC(IHARG,IARGT,IARG,NUMARG,IDEFXC,
23194     1                  MAXBOX,IBOFCO,IFOUND,IERROR)
23195C
23196C     PURPOSE--DEFINE THE COLOR FOR THE FILL PATTERN IN A BOX
23197C              I.E., THE COLOR
23198C              THAT WILL APPEAR IN THE INSIDE REGION OF THE BOX.
23199C              THE COLOR FOR BOX I WILL BE PLACED
23200C              IN THE I-TH ELEMENT OF THE HOLLERITH
23201C              VECTOR IBOFCO(.).
23202C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
23203C                     --IARGT  (A HOLLERITH VECTOR)
23204C                     --IARG   (A HOLLERITH VECTOR)
23205C                     --NUMARG
23206C                     --IDEFXC
23207C                     --MAXBOX
23208C     OUTPUT ARGUMENTS--IBOFCO (A HOLLERITH VECTOR
23209C                              WHOSE I-TH ELEMENT CONTAINS THE
23210C                              COLOR FOR BOX I.
23211C                     --IFOUND ('YES' OR 'NO' )
23212C                     --IERROR ('YES' OR 'NO' )
23213C     WRITTEN BY--JAMES J. FILLIBEN
23214C                 STATISTICAL ENGINEERING DIVISION
23215C                 INFORMATION TECHNOLOGY LABORATORY
23216C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23217C                 GAITHERSBURG, MD 20899-8980
23218C                 PHONE--301-975-2855
23219C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23220C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23221C     LANGUAGE--ANSI FORTRAN (1977)
23222C     ORIGINAL VERSION--AUGUST    1992.
23223C
23224C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23225C
23226      CHARACTER*4 IHARG
23227      CHARACTER*4 IARGT
23228      CHARACTER*4 IDEFXC
23229      CHARACTER*4 IBOFCO
23230      CHARACTER*4 IFOUND
23231      CHARACTER*4 IERROR
23232C
23233      CHARACTER*4 IHOLD
23234C
23235C---------------------------------------------------------------------
23236C
23237      DIMENSION IHARG(*)
23238      DIMENSION IARGT(*)
23239      DIMENSION IARG(*)
23240      DIMENSION IBOFCO(*)
23241C
23242C---------------------------------------------------------------------
23243C
23244      INCLUDE 'DPCOP2.INC'
23245C
23246C-----START POINT-----------------------------------------------------
23247C
23248      IFOUND='NO'
23249      IERROR='NO'
23250C
23251      IF(NUMARG.EQ.0)GOTO1199
23252      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.IHARG(2).EQ.'COLO')
23253     1   THEN
23254        IF(NUMARG.LE.2 .OR. IHARG(3).EQ.'ON' .OR.
23255     1     IHARG(3).EQ.'OFF' .OR. IHARG(3).EQ.'AUTO' .OR.
23256     1     IHARG(3).EQ.'DEFA')THEN
23257          IHOLD=IDEFXC
23258        ELSE
23259          IHOLD=IHARG(3)
23260        ENDIF
23261C
23262        IFOUND='YES'
23263        DO1135I=1,MAXBOX
23264          IBOFCO(I)=IHOLD
23265 1135   CONTINUE
23266        IF(IFEEDB.EQ.'ON')THEN
23267          WRITE(ICOUT,999)
23268  999     FORMAT(1X)
23269          CALL DPWRST('XXX','BUG ')
23270          I=1
23271          WRITE(ICOUT,1136)IBOFCO(I)
23272 1136     FORMAT('ALL BOX FILL COLORS HAVE JUST BEEN SET TO ',A4)
23273          CALL DPWRST('XXX','BUG ')
23274          GOTO1199
23275        ENDIF
23276      ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.
23277     1       IHARG(3).EQ.'COLO')THEN
23278        IF(IARGT(1).NE.'NUMB')THEN
23279          IERROR='YES'
23280          WRITE(ICOUT,999)
23281          CALL DPWRST('XXX','BUG ')
23282          WRITE(ICOUT,1141)
23283 1141     FORMAT('***** ERROR IN BOX FILL COLOR (DPBOFC)--')
23284          CALL DPWRST('XXX','BUG ')
23285          WRITE(ICOUT,1142)
23286 1142     FORMAT('      IN THE BOX ... FILL COLOR COMMAND,')
23287          CALL DPWRST('XXX','BUG ')
23288          WRITE(ICOUT,1143)
23289 1143     FORMAT('      THE BOX IS IDENTIFIED BY A NUMBER, AS IN--')
23290          CALL DPWRST('XXX','BUG ')
23291          WRITE(ICOUT,1144)
23292 1144     FORMAT('      BOX 3 FILL COLOR GREEN')
23293          CALL DPWRST('XXX','BUG ')
23294          GOTO1199
23295        ENDIF
23296C
23297        I=IARG(1)
23298        IF(I.LT.1 .OR. I.GT.MAXBOX)THEN
23299          IERROR='YES'
23300          WRITE(ICOUT,999)
23301          CALL DPWRST('XXX','BUG ')
23302          WRITE(ICOUT,1141)
23303          CALL DPWRST('XXX','BUG ')
23304          WRITE(ICOUT,1152)
23305 1152     FORMAT('      IN THE BOX ... FILL COLOR COMMAND,')
23306          CALL DPWRST('XXX','BUG ')
23307          WRITE(ICOUT,1153)
23308 1153     FORMAT('      THE NUMBER OF BOXES MUST BE ')
23309          CALL DPWRST('XXX','BUG ')
23310          WRITE(ICOUT,1154)MAXBOX
23311 1154     FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
23312          CALL DPWRST('XXX','BUG ')
23313          WRITE(ICOUT,1155)
23314 1155     FORMAT('      SUCH WAS NOT THE CASE HERE--')
23315          CALL DPWRST('XXX','BUG ')
23316          WRITE(ICOUT,1156)I
23317 1156     FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
23318     1           'BOX.')
23319          CALL DPWRST('XXX','BUG ')
23320          GOTO1199
23321        ENDIF
23322C
23323        IF(NUMARG.LE.3 .OR. IHARG(4).EQ.'ON' .OR.
23324     1     IHARG(4).EQ.'OFF' .OR. IHARG(4).EQ.'AUTO' .OR.
23325     1     IHARG(4).EQ.'DEFA')THEN
23326          IHOLD=IDEFXC
23327        ELSE
23328         IHOLD=IHARG(4)
23329        ENDIF
23330C
23331        IFOUND='YES'
23332        IBOFCO(I)=IHOLD
23333        IF(IFEEDB.EQ.'ON')THEN
23334          WRITE(ICOUT,999)
23335          CALL DPWRST('XXX','BUG ')
23336          WRITE(ICOUT,1186)I,IBOFCO(I)
23337 1186     FORMAT('THE FILL COLOR FOR BOX ',I8,
23338     1           ' HAS JUST BEEN SET TO ',A4)
23339          CALL DPWRST('XXX','BUG ')
23340          GOTO1199
23341        ENDIF
23342      ENDIF
23343C
23344 1199 CONTINUE
23345      RETURN
23346      END
23347      SUBROUTINE DPBOFI(ICAPSW,IFORSW,
23348     1                  ISEED,IBOOSS,
23349     1                  IBUGA2,IBUGA3,IBUGCO,IBUGEV,IBUGQ,ISUBRO,
23350     1                  IFOUND,IERROR)
23351C
23352C     PURPOSE--GENERATE BOOTSTRAP BASED MULTI-LINEAR FIT.
23353C              BOOTSTRAP ESTIMATES FOR A0, A1, ETC. WILL BE
23354C              WRITTEN TO FILE DPST1F.DAT.
23355C     WRITTEN BY--ALAN HECKERT
23356C                 STATISTICAL ENGINEERING DIVISION
23357C                 INFORMATION TECHNOLOGY LABORATORY
23358C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23359C                 GAITHERSBURG, MD 20899-8980
23360C                 PHONE--301-975-2899
23361C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23362C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23363C     LANGUAGE--ANSI FORTRAN (1977)
23364C     VERSION NUMBER--2002/6
23365C     ORIGINAL VERSION--JULY     2002.
23366C     UPDATED         --MAY      2009. REPLACE USE OF DPSWAP WITH
23367C                                      BUILT-IN STORAGE
23368C     UPDATED         --AUGUST   2011. USE DPPARS
23369C     UPDATED         --AUGUST   2011. SUPPORT FOR HTML, LATEX, RTF OUTPUT
23370C     UPDATED         --AUGUST   2011. SUPPORT FOR "REPLICATED" FIT
23371C                                      (WHEN SINGLE X VARIABLE, ALLOW
23372C                                      BOOTSTRAP SAMPLES FROM WITHIN EACH
23373C                                      DISTINCT X VARIABLE)
23374C     UPDATED         --JULY     2019. TWEAK SCRATCH STORAGE
23375C
23376C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23377C
23378      CHARACTER*4 ICAPSW
23379      CHARACTER*4 IFORSW
23380      CHARACTER*4 IBUGA2
23381      CHARACTER*4 IBUGA3
23382      CHARACTER*4 IBUGCO
23383      CHARACTER*4 IBUGEV
23384      CHARACTER*4 IBUGQ
23385      CHARACTER*4 IBUGAZ
23386      CHARACTER*4 ISUBRO
23387      CHARACTER*4 IFOUND
23388      CHARACTER*4 IERROR
23389C
23390      INCLUDE 'DPCOPA.INC'
23391C
23392      CHARACTER*4 ICASFI
23393      CHARACTER*4 ICASJB
23394      CHARACTER*4 IREPL
23395      CHARACTER*4 ISUBN1
23396      CHARACTER*4 ISUBN2
23397      CHARACTER*4 ISTEPN
23398C
23399      CHARACTER*40 INAME
23400      PARAMETER (MAXSPN=MAXCMF)
23401      CHARACTER*4 IVARN1(MAXSPN)
23402      CHARACTER*4 IVARN2(MAXSPN)
23403      CHARACTER*4 IVARTY(MAXSPN)
23404      REAL PVAR(MAXSPN)
23405      INTEGER ILIS(MAXSPN)
23406      INTEGER NRIGHT(MAXSPN)
23407      INTEGER ICOLR(MAXSPN)
23408C
23409C---------------------------------------------------------------------
23410C
23411      DIMENSION PARAM(100)
23412      DIMENSION T(101)
23413      DIMENSION S(102)
23414      DIMENSION PARAM2(100)
23415      DIMENSION T2(101)
23416C
23417      INCLUDE 'DPCOZZ.INC'
23418      INCLUDE 'DPCOZD.INC'
23419      INCLUDE 'DPCOZI.INC'
23420C
23421      DIMENSION W(MAXOBV)
23422      DIMENSION VSDPRD(MAXOBV)
23423      DIMENSION RES2(MAXOBV)
23424      DIMENSION RES3(MAXOBV)
23425      DIMENSION RES4(MAXOBV)
23426      DIMENSION TEMP1(MAXOBV)
23427      DIMENSION TEMP2(MAXOBV)
23428      DIMENSION TEMP3(MAXOBV)
23429      DIMENSION TEMP4(MAXOBV)
23430C
23431      DIMENSION ITEMP1(MAXOBV)
23432      DIMENSION ITEMP2(MAXOBV)
23433C
23434      DIMENSION VSCRT(10*MAXOBV)
23435C
23436      DIMENSION XMAT(MAXOBV,MAXCMF)
23437C
23438C-----COMMON----------------------------------------------------------
23439C
23440      INCLUDE 'DPCOST.INC'
23441      INCLUDE 'DPCOMC.INC'
23442      INCLUDE 'DPCOHK.INC'
23443      INCLUDE 'DPCOSU.INC'
23444      INCLUDE 'DPCODA.INC'
23445      INCLUDE 'DPCOHO.INC'
23446C
23447      EQUIVALENCE (W(1),X3D(1))
23448      EQUIVALENCE (TEMP4(1),X3D(MAXOBV+1))
23449      EQUIVALENCE (RES4(1),D(1))
23450      EQUIVALENCE (RES2(1),DSIZE(1))
23451      EQUIVALENCE (RES3(1),DSIZE(MAXOBV+1))
23452      EQUIVALENCE (VSDPRD(1),DSYMB(1))
23453      EQUIVALENCE (TEMP3(1),DSYMB(MAXOBV+1))
23454      EQUIVALENCE (TEMP1(1),DCOLOR(1))
23455      EQUIVALENCE (TEMP2(1),DFILL(1))
23456      EQUIVALENCE (PARAM(1),DFILL(MAXOBV+1))
23457      EQUIVALENCE (T(1),DFILL(MAXOBV+201))
23458      EQUIVALENCE (S(1),DFILL(MAXOBV+401))
23459      EQUIVALENCE (PARAM2(1),DFILL(MAXOBV+601))
23460      EQUIVALENCE (T2(1),DFILL(MAXOBV+801))
23461C
23462      EQUIVALENCE (GARBAG(IGARB1),XMAT(1,1))
23463C
23464      EQUIVALENCE (DGARBG(IDGAR1),VSCRT(1))
23465      EQUIVALENCE (IGARBG(IIGAR1),ITEMP1(1))
23466      EQUIVALENCE (IGARBG(IIGAR2),ITEMP2(1))
23467C
23468C---------------------------------------------------------------------
23469C
23470      INCLUDE 'DPCOP2.INC'
23471C
23472C-----START POINT-----------------------------------------------------
23473C
23474      ISUBN1='DPBO'
23475      ISUBN2='FI  '
23476C
23477      MAXCP1=MAXCOL+1
23478      MAXCP2=MAXCOL+2
23479      MAXCP3=MAXCOL+3
23480      MAXCP4=MAXCOL+4
23481      MAXCP5=MAXCOL+5
23482      MAXCP6=MAXCOL+6
23483C
23484      IFACT=1
23485      IF(IFITAC.EQ.'OFF')IFACT=0
23486      IERROR='NO'
23487C
23488C               ************************************
23489C               **  TREAT THE BOOTSTRAP FIT CASE  **
23490C               ************************************
23491C
23492      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')THEN
23493        WRITE(ICOUT,999)
23494  999   FORMAT(1X)
23495        CALL DPWRST('XXX','BUG ')
23496        WRITE(ICOUT,51)
23497   51   FORMAT('***** AT THE BEGINNING OF DPBOFI--')
23498        CALL DPWRST('XXX','BUG ')
23499        WRITE(ICOUT,53)IBUGA2,IBUGA3,IBUGCO,IBUGEV
23500   53   FORMAT('IBUGA2,IBUGA3,IBUGCO,IBUGEV = ',3(A4,2X),A4)
23501        CALL DPWRST('XXX','BUG ')
23502        WRITE(ICOUT,54)IBUGQ,ISUBRO,NUMNAM
23503   54   FORMAT('IBUGQ,ISUBRO,NUMNAM = ',2(A4,2X),I8)
23504        CALL DPWRST('XXX','BUG ')
23505        DO57I=1,NUMNAM
23506          WRITE(ICOUT,58)I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I),
23507     1                   VALUE(I)
23508   58     FORMAT('I,IHNAME(I),IHNAM2(I),IUSE(I),IN(I),IVALUE(I)',
23509     1           'VALUE(I) = ',I8,2X,2A4,2X,A4,2I8,G15.7)
23510          CALL DPWRST('XXX','BUG ')
23511   57   CONTINUE
23512      ENDIF
23513C
23514C     ***************************
23515C     **  STEP 1--             **
23516C     **  EXTRACT THE COMMAND  **
23517C     ***************************
23518C
23519      ISTEPN='1'
23520      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')
23521     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23522C
23523      IREPL='OFF'
23524      IF(ICOM.EQ.'BOOT'.AND.IHARG(1).EQ.'FIT  ')THEN
23525        ICASJB='BOOT'
23526        ILASTC=1
23527      ELSEIF(ICOM.EQ.'BOOT'.AND.IHARG(1).EQ.'REPL'.AND.
23528     1       IHARG(2).EQ.'FIT  ')THEN
23529        ICASJB='BOOT'
23530        ILASTC=2
23531        IREPL='ON'
23532      ELSE
23533        IFOUND='NO'
23534        GOTO9000
23535      ENDIF
23536C
23537      ICASFI='MLIN'
23538      IFOUND='YES'
23539      CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
23540C
23541C               *********************************
23542C               **  STEP 2--                   **
23543C               **  EXTRACT THE VARIABLE LIST  **
23544C               *********************************
23545C
23546      ISTEPN='2'
23547      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')
23548     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23549C
23550      INAME='BOOTSTRAP FIT'
23551      MINNA=1
23552      MAXNA=100
23553      MINN2=2
23554      IFLAGE=1
23555      IFLAGM=0
23556      IFLAGP=0
23557      JMIN=1
23558      JMAX=NUMARG
23559      MINNVA=2
23560      MAXNVA=MAXSPN
23561      IF(IREPL.EQ.'ON')THEN
23562        MINNVA=3
23563        MAXNVA=3
23564      ENDIF
23565C
23566      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
23567     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
23568     1            JMIN,JMAX,
23569     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
23570     1            IVARN1,IVARN2,IVARTY,PVAR,
23571     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
23572     1            MINNVA,MAXNVA,
23573     1            IFLAGM,IFLAGP,
23574     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
23575      IF(IERROR.EQ.'YES')GOTO9000
23576C
23577      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')THEN
23578        WRITE(ICOUT,999)
23579        CALL DPWRST('XXX','BUG ')
23580        WRITE(ICOUT,281)
23581  281   FORMAT('***** AFTER CALL DPPARS--')
23582        CALL DPWRST('XXX','BUG ')
23583        WRITE(ICOUT,282)NQ,NUMVAR
23584  282   FORMAT('NQ,NUMVAR = ',2I8)
23585        CALL DPWRST('XXX','BUG ')
23586        IF(NUMVAR.GT.0)THEN
23587          DO285I=1,NUMVAR
23588            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
23589     1                      ICOLR(I)
23590  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
23591     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
23592            CALL DPWRST('XXX','BUG ')
23593  285     CONTINUE
23594        ENDIF
23595      ENDIF
23596C
23597C               ************************************************
23598C               **  STEP 5.1--                                **
23599C               **  CHECK TO SEE IF HAVE A WEIGHTS VARIABLE.  **
23600C               **  IF DO HAVE, CHECK TO SEE IF A VARIABLE    **
23601C               **  (AS OPPOSED TO A PARAMETER).              **
23602C               ************************************************
23603C
23604      ISTEPN='5.1'
23605      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'PBOFI')
23606     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23607C
23608      ILOCW=-99
23609      ICOLW=-99
23610      NWEIGH=-99
23611      IF(IWEIGH.EQ.'ON')THEN
23612        DO2410I=1,NUMNAM
23613          I2=I
23614          IF(IWEIG1.EQ.IHNAME(I2).AND.IWEIG2.EQ.IHNAM2(I2).AND.
23615     1       IUSE(I2).EQ.'V')THEN
23616            ILOCW=I2
23617            ICOLW=IVALUE(ILOCW)
23618            NWEIGH=IN(ILOCW)
23619            IF(NWEIGH.NE.NRIGHT(1))THEN
23620              WRITE(ICOUT,999)
23621              CALL DPWRST('XXX','BUG ')
23622              WRITE(ICOUT,2461)
23623              CALL DPWRST('XXX','BUG ')
23624              WRITE(ICOUT,2411)
23625 2411         FORMAT('      THE WEIGHT VARIABLE MUST HAVE THE SAME ',
23626     1               'NUMBER OF OBSERVATIONS')
23627              CALL DPWRST('XXX','BUG ')
23628              WRITE(ICOUT,2413)
23629 2413         FORMAT('      AS THE RESPONSE VARIABLE.')
23630              CALL DPWRST('XXX','BUG ')
23631              WRITE(ICOUT,2415)IWEIGH,IWEIG2,NWEIGH
23632 2415         FORMAT('  WEIGHT VARIABLE ',A4,A4,' HAS ',I8,
23633     1               'OBSERVATIONS.')
23634              CALL DPWRST('XXX','BUG ')
23635              WRITE(ICOUT,2417)NRIGHT(1)
23636 2417         FORMAT('      NUMBER OF OBSEVATIONS EXPECTED: ',I8)
23637              CALL DPWRST('XXX','BUG ')
23638              IERROR='YES'
23639              GOTO9000
23640            ENDIF
23641            GOTO2490
23642          ENDIF
23643 2410   CONTINUE
23644C
23645        WRITE(ICOUT,999)
23646        CALL DPWRST('XXX','BUG ')
23647        WRITE(ICOUT,2461)
23648 2461   FORMAT('***** ERROR IN BOOTSTRAP FIT--')
23649        CALL DPWRST('XXX','BUG ')
23650        WRITE(ICOUT,2463)
23651 2463   FORMAT('      THE WEIGHTS VARIABLE (AS SPECIFIED BY THE ',
23652     1         'WEIGHTS COMMAND) EITHER')
23653        CALL DPWRST('XXX','BUG ')
23654        WRITE(ICOUT,2465)
23655 2465   FORMAT('      DOES NOT EXIST AS A VARIABLE IN THE CURRENT ',
23656     1         'LIST OF AVAILABLE NAMES.')
23657        CALL DPWRST('XXX','BUG ')
23658        WRITE(ICOUT,2469)IWEIG1,IWEIG2
23659 2469   FORMAT('      THE NAME OF SPECIFIED WEIGHTS VARIABLE = ',A4,A4)
23660        CALL DPWRST('XXX','BUG ')
23661        IERROR='YES'
23662        GOTO9000
23663C
23664      ENDIF
23665C
23666 2490 CONTINUE
23667C
23668      IF(IFITAC.EQ.'ON')THEN
23669        DO2510I=1,MAXOBV
23670          XMAT(I,1)=1.0
23671 2510   CONTINUE
23672        NVARS=1
23673      ELSE
23674        NVARS=0
23675      ENDIF
23676C
23677      NUMFAC=NUMVAR-1
23678      J=0
23679      IMAX=NRIGHT(1)
23680      IF(NQ.LT.NRIGHT(1))IMAX=NQ
23681      DO2560I=1,IMAX
23682        IF(ISUB(I).EQ.0)GOTO2560
23683        J=J+1
23684C
23685        IJ=MAXN*(ICOLR(1)-1)+I
23686        IF(ICOLR(1).LE.MAXCOL)Y(J)=V(IJ)
23687        IF(ICOLR(1).EQ.MAXCP1)Y(J)=PRED(I)
23688        IF(ICOLR(1).EQ.MAXCP2)Y(J)=RES(I)
23689        IF(ICOLR(1).EQ.MAXCP3)Y(J)=YPLOT(I)
23690        IF(ICOLR(1).EQ.MAXCP4)Y(J)=XPLOT(I)
23691        IF(ICOLR(1).EQ.MAXCP5)Y(J)=X2PLOT(I)
23692        IF(ICOLR(1).EQ.MAXCP6)Y(J)=TAGPLO(I)
23693C
23694        W(J)=1.0
23695        IF(IWEIGH.EQ.'ON')THEN
23696          K=ICOLW
23697          IJ=MAXN*(K-1)+I
23698          IF(K.LE.MAXCOL)W(J)=V(IJ)
23699          IF(K.EQ.MAXCP1)W(J)=PRED(I)
23700          IF(K.EQ.MAXCP2)W(J)=RES(I)
23701          IF(K.EQ.MAXCP3)W(J)=YPLOT(I)
23702          IF(K.EQ.MAXCP4)W(J)=XPLOT(I)
23703          IF(K.EQ.MAXCP5)W(J)=X2PLOT(I)
23704          IF(K.EQ.MAXCP6)W(J)=TAGPLO(I)
23705        ENDIF
23706C
23707        DO2569LL=1,NUMFAC
23708          ICOLT=ICOLR(LL+1)
23709          IJ=MAXN*(ICOLT-1)+I
23710          IF(ICOLT.LE.MAXCOL)XMAT(J,LL+NVARS)=V(IJ)
23711          IF(ICOLT.EQ.MAXCP1)XMAT(J,LL+NVARS)=PRED(I)
23712          IF(ICOLT.EQ.MAXCP2)XMAT(J,LL+NVARS)=RES(I)
23713          IF(ICOLT.EQ.MAXCP3)XMAT(J,LL+NVARS)=YPLOT(I)
23714          IF(ICOLT.EQ.MAXCP4)XMAT(J,LL+NVARS)=XPLOT(I)
23715          IF(ICOLT.EQ.MAXCP5)XMAT(J,LL+NVARS)=X2PLOT(I)
23716          IF(ICOLT.EQ.MAXCP6)XMAT(J,LL+NVARS)=TAGPLO(I)
23717 2569   CONTINUE
23718 2560 CONTINUE
23719      NS=J
23720      NVARS=NVARS+NUMFAC
23721      IF(IWEIGH.EQ.'ON')NVARS=NVARS+1
23722C
23723C
23724C               *************************************************
23725C               **  STEP 14--                                  **
23726C               **  CARRY OUT THE ACTUAL FIT                   **
23727C               **  VIA CALLING                                **
23728C               **  DPBOF2 (FOR GENERAL MODELS), OR            **
23729C               *************************************************
23730C
23731      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')THEN
23732        ISTEPN='14'
23733        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23734        IBUGAZ=IBUGA3
23735        WRITE(ICOUT,999)
23736        CALL DPWRST('XXX','BUG ')
23737        WRITE(ICOUT,6081)
23738 6081   FORMAT('***** FROM DPBOFI, AS ABOUT TO CALL DPBOF2--')
23739        CALL DPWRST('XXX','BUG ')
23740        DO6083I=1,NS
23741          WRITE(ICOUT,6084)I,(XMAT(I,J),J=1,5)
23742 6084     FORMAT('I,(XMAT(I,J),J=1,5) = ',I6,2X,5G15.7)
23743          CALL DPWRST('XXX','BUG ')
23744 6083   CONTINUE
23745        WRITE(ICOUT,6082)NRIGHT(1),MAXN,NS,NVARS
23746 6082   FORMAT('NRIGHT(1),MAXN,NS,NVARS = ',4I8)
23747        CALL DPWRST('XXX','BUG ')
23748      ENDIF
23749C
23750      MAXNXT=MAXOBV
23751      MAXCFI=MAXCMF
23752      CALL DPBOF2(Y,XMAT,NS,NVARS,MAXNXT,MAXCFI,
23753     1            PARAM,T,S,W,VSDPRD,RES2,VSCRT,
23754     1            PARAM2,T2,RES3,RES4,
23755     1            TEMP1,TEMP2,TEMP3,TEMP4,ITEMP1,ITEMP2,
23756     1            ICASFI,ICASJB,IBOOSS,ISEED,
23757     1            ICAPSW,ICAPTY,IFORSW,IREPL,IFITAC,
23758     1            IBUGA3,ISUBRO,IERROR)
23759      IF(IERROR.EQ.'YES')GOTO9000
23760C
23761C               ***************************************
23762C               **  STEP 15--                        **
23763C               **  UPDATE INTERNAL DATAPLOT TABLES  **
23764C               ***************************************
23765C
23766      ISTEPN='15'
23767      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')
23768     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23769C
23770C               *****************
23771C               **  STEP 90--  **
23772C               **  EXIT       **
23773C               *****************
23774C
23775 9000 CONTINUE
23776C
23777      IF(IERROR.EQ.'YES')THEN
23778        IF(IWIDTH.GE.1)THEN
23779          WRITE(ICOUT,9003)(IANS(JJ),JJ=1,MIN(100,IWIDTH))
23780 9003     FORMAT('      COMMAND LINE--',100A1)
23781          CALL DPWRST('XXX','BUG ')
23782        ENDIF
23783      ENDIF
23784C
23785      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BOFI')THEN
23786        WRITE(ICOUT,999)
23787        CALL DPWRST('XXX','BUG ')
23788        WRITE(ICOUT,9011)
23789 9011   FORMAT('***** AT THE END       OF DPBOFI--')
23790        CALL DPWRST('XXX','BUG ')
23791        WRITE(ICOUT,9051)NRIGHT(1),NS,V(1),PRED(1),RES(1)
23792 9051   FORMAT('NRIGHT(1),NS,V(1),PRED(1),RES(1) = ',2I8,3G15.7)
23793        CALL DPWRST('XXX','BUG ')
23794        WRITE(ICOUT,9069)IFOUND,IERROR
23795 9069   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
23796        CALL DPWRST('XXX','BUG ')
23797      ENDIF
23798C
23799      RETURN
23800      END
23801      SUBROUTINE DPBOF2(Y,XMAT,N,NVARS,MAXNXT,MAXCFI,
23802     1                  B,T,S,W,VSDPRD,RES,SCR,
23803     1                  BORG,TORG,RES1,RES2,
23804     1                  TEMP1,TEMP2,TEMP3,TEMP4,ITEMP1,ITEMP2,
23805     1                  ICASFI,ICASJB,IBOOSS,ISEED,
23806     1                  ICAPSW,ICAPTY,IFORSW,IREPL,IFITAC,
23807     1                  IBUGA3,ISUBRO,IERROR)
23808C
23809C     BOOTSTRAP MULTILINEAR FIT.
23810C
23811C     WRITTEN BY--ALAN HECKERT
23812C                 STATISTICAL ENGINEERING DIVISION
23813C                 INFORMATION TECHNOLOGY LABORATORY
23814C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
23815C                 GAITHERSBURG, MD 20899-8980
23816C                 PHONE--301-975-2899
23817C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
23818C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
23819C     LANGUAGE--ANSI FORTRAN (1977)
23820C     VERSION NUMBER--2002/7
23821C     ORIGINAL VERSION--JULY      2002.
23822C     UPDATED         --AUGUST    2011. USE DPDTA1, DPDT5B TO PRINT
23823C                                       TABLES
23824C     UPDATED         --AUGUST    2011. USE DPAUFI
23825C     UPDATED         --AUGUST    2011. MODIFY UNFORMATTED WRITE FOR
23826C                                       "DATA" CASE
23827C     UPDATED         --AUGUST    2011. WHEN THERE IS A SINGLE X
23828C                                       VARIABLE, SUPPORT A TAG VARIABLE
23829C                                       FOR BOOTSTRAPPING WITHIN GROUPS
23830C
23831C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
23832C
23833      CHARACTER*4 ICASFI
23834      CHARACTER*4 ICASJB
23835      CHARACTER*4 ICAPSW
23836      CHARACTER*4 ICAPTY
23837      CHARACTER*4 IFORSW
23838      CHARACTER*4 IREPL
23839      CHARACTER*4 IFITAC
23840      CHARACTER*4 IBUGA3
23841      CHARACTER*4 ISUBRO
23842      CHARACTER*4 IERROR
23843C
23844      CHARACTER*4 ISUBN1
23845      CHARACTER*4 ISUBN2
23846      CHARACTER*4 ISTEPN
23847      CHARACTER*4 IWRITE
23848      CHARACTER*4 IOP
23849      CHARACTER*3 IPARNM
23850C
23851C---------------------------------------------------------------------
23852C
23853      INTEGER N, NVARS
23854      INTEGER ITEMP1(*)
23855      INTEGER ITEMP2(*)
23856C
23857      REAL Y(*)
23858      REAL XMAT(MAXNXT,MAXCFI)
23859      REAL B(*)
23860      REAL T(*)
23861      REAL S(*)
23862      REAL BORG(*)
23863      REAL TORG(*)
23864      REAL W(*)
23865      REAL VSDPRD(*)
23866      REAL RES(*)
23867      REAL RES1(*)
23868      REAL RES2(*)
23869      REAL SCR(*)
23870      REAL TEMP1(*)
23871      REAL TEMP2(*)
23872      REAL TEMP3(*)
23873      REAL TEMP4(*)
23874C
23875      DOUBLE PRECISION DSUM1
23876C
23877      INCLUDE 'DPCOPA.INC'
23878      INCLUDE 'DPCOF2.INC'
23879C
23880      PARAMETER(NUMCLI=7)
23881      PARAMETER(MAXLIN=2)
23882      PARAMETER (MAXROW=50)
23883      CHARACTER*60 ITITLE
23884      CHARACTER*60 ITITLZ
23885      CHARACTER*60 ITITL9
23886      CHARACTER*60 ITEXT(MAXROW)
23887      CHARACTER*4  ALIGN(NUMCLI)
23888      CHARACTER*4  VALIGN(NUMCLI)
23889      REAL         AVALUE(MAXROW)
23890      INTEGER      NCTEXT(MAXROW)
23891      INTEGER      IDIGIT(MAXROW)
23892      INTEGER      IDIGI2(MAXROW,NUMCLI)
23893      INTEGER      NTOT(MAXROW)
23894      INTEGER      ROWSEP(MAXROW)
23895      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
23896      CHARACTER*30 IVALUE(MAXROW,NUMCLI)
23897      CHARACTER*4  ITYPCO(NUMCLI)
23898      INTEGER      NCTIT2(MAXLIN,NUMCLI)
23899      INTEGER      NCVALU(MAXROW,NUMCLI)
23900      INTEGER      NCOLSP(MAXLIN,NUMCLI)
23901      INTEGER      IWHTML(NUMCLI)
23902      INTEGER      IWRTF(NUMCLI)
23903      REAL         AMAT(MAXROW,NUMCLI)
23904      LOGICAL IFRST
23905      LOGICAL ILAST
23906      LOGICAL IFLAGS
23907      LOGICAL IFLAGE
23908C
23909      INCLUDE 'DPCOST.INC'
23910      INCLUDE 'DPCOP2.INC'
23911C
23912C-----START POINT-----------------------------------------------------
23913C
23914      ISUBN1='DPBO'
23915      ISUBN2='F2  '
23916      IERROR='NO'
23917C
23918      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN
23919        WRITE(ICOUT,999)
23920  999   FORMAT(1X)
23921        CALL DPWRST('XXX','BUG ')
23922        WRITE(ICOUT,51)
23923   51   FORMAT('***** AT THE BEGINNING OF DPBOF2--')
23924        CALL DPWRST('XXX','BUG ')
23925        WRITE(ICOUT,54)ICASFI,IBOOME,IBOOSS,N,NVARS
23926   54   FORMAT('ICASFI,IBOOME,IBOOSS,N,NVARS = ',2(A4,2X),3I8)
23927        CALL DPWRST('XXX','BUG ')
23928        DO55I=1,N
23929          WRITE(ICOUT,56)I,Y(I),W(I)
23930   56     FORMAT('I,Y(I),W(I) = ',I8,2G15.7)
23931          CALL DPWRST('XXX','BUG ')
23932   55   CONTINUE
23933        DO65I=1,N
23934          WRITE(ICOUT,66)I,(XMAT(I,J),J=1,MIN(5,NVARS))
23935   66     FORMAT('I,(XMAT(I,J),J=1,MIN(NVARS,5) = ',I8,5G15.7)
23936          CALL DPWRST('XXX','BUG ')
23937   65   CONTINUE
23938       ENDIF
23939C
23940C               **************************************************
23941C               **  STEP 0.5--                                  **
23942C               **   OPEN THE STORAGE FILES                     **
23943C               **************************************************
23944C
23945      ISTEPN='0.5'
23946      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'FIT2')
23947     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
23948C
23949      IOP='OPEN'
23950      IFLG1=1
23951      IFLG2=1
23952      IFLG3=1
23953      IFLG4=0
23954      IFLG5=1
23955      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
23956     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
23957     1            IBUGA3,ISUBRO,IERROR)
23958C
23959C               *****************************************************
23960C               **  STEP 1--                                       **
23961C               **  PRINT SUMMARY INFORMATION.                     **
23962C               *****************************************************
23963C
23964      NUMDIG=7
23965      IF(IFORSW.EQ.'1')NUMDIG=1
23966      IF(IFORSW.EQ.'2')NUMDIG=2
23967      IF(IFORSW.EQ.'3')NUMDIG=3
23968      IF(IFORSW.EQ.'4')NUMDIG=4
23969      IF(IFORSW.EQ.'5')NUMDIG=5
23970      IF(IFORSW.EQ.'6')NUMDIG=6
23971      IF(IFORSW.EQ.'7')NUMDIG=7
23972      IF(IFORSW.EQ.'8')NUMDIG=8
23973      IF(IFORSW.EQ.'9')NUMDIG=9
23974      IF(IFORSW.EQ.'0')NUMDIG=0
23975      IF(IFORSW.EQ.'E')NUMDIG=-2
23976      IF(IFORSW.EQ.'-2')NUMDIG=-2
23977      IF(IFORSW.EQ.'-3')NUMDIG=-3
23978      IF(IFORSW.EQ.'-4')NUMDIG=-4
23979      IF(IFORSW.EQ.'-5')NUMDIG=-5
23980      IF(IFORSW.EQ.'-6')NUMDIG=-6
23981      IF(IFORSW.EQ.'-7')NUMDIG=-7
23982      IF(IFORSW.EQ.'-8')NUMDIG=-8
23983      IF(IFORSW.EQ.'-9')NUMDIG=-9
23984C
23985      IF(IPRINT.EQ.'OFF')GOTO199
23986C
23987      ITITLE='Bootstrap Linear/Multilinear Fit'
23988      NCTITL=32
23989      ITITLZ=' '
23990      NCTITZ=0
23991      IF(IREPL.EQ.'ON')THEN
23992        ITITLZ='(Bootstrap by Groups)'
23993        NCTITZ=21
23994      ENDIF
23995C
23996      ICNT=0
23997      ICNT=ICNT+1
23998      ITEXT(ICNT)=' '
23999      NCTEXT(ICNT)=0
24000      AVALUE(ICNT)=0.0
24001      IDIGIT(ICNT)=-1
24002      ICNT=ICNT+1
24003      ITEXT(ICNT)='Number of Observations:'
24004      NCTEXT(ICNT)=23
24005      AVALUE(ICNT)=REAL(N)
24006      IDIGIT(ICNT)=0
24007      ICNT=ICNT+1
24008      ITEXT(ICNT)='Number of Bootstrap Samples:'
24009      NCTEXT(ICNT)=26
24010      AVALUE(ICNT)=REAL(IBOOSS)
24011      IDIGIT(ICNT)=0
24012      IF(IBOOME.EQ.'DATA')THEN
24013        ICNT=ICNT+1
24014        ITEXT(ICNT)='Bootstrap Method: Data (Wu)'
24015        NCTEXT(ICNT)=27
24016        AVALUE(ICNT)=0.0
24017        IDIGIT(ICNT)=-1
24018      ELSE
24019        ICNT=ICNT+1
24020        ITEXT(ICNT)='Bootstrap Method: Residuals (Efron)'
24021        NCTEXT(ICNT)=35
24022        AVALUE(ICNT)=0.0
24023        IDIGIT(ICNT)=-1
24024      ENDIF
24025C
24026      NUMROW=ICNT
24027      DO181I=1,NUMROW
24028        NTOT(I)=15
24029  181 CONTINUE
24030C
24031      IFRST=.TRUE.
24032      ILAST=.TRUE.
24033      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,
24034     1            NCTEXT,AVALUE,IDIGIT,
24035     1            NTOT,NUMROW,
24036     1            ICAPSW,ICAPTY,ILAST,IFRST,
24037     1            ISUBRO,IBUGA3,IERROR)
24038C
24039      ITITLE(1:13)='Summary Table'
24040      NCTITL=13
24041      ITITL9=' '
24042      NCTIT9=0
24043C
24044      NUMCOL=6
24045      NUMLIN=3
24046C
24047      DO183I=1,MAXLIN
24048        DO185J=1,NUMCLI
24049          ITITL2(I,J)=' '
24050          NCTIT2(I,J)=0
24051          NCOLSP(I,J)=0
24052  185   CONTINUE
24053  183 CONTINUE
24054C
24055      ITITL2(1,1)='Para-'
24056      NCTIT2(1,1)=5
24057      NCOLSP(1,1)=1
24058      ITITL2(2,1)='meter'
24059      NCTIT2(2,1)=5
24060      NCOLSP(2,1)=1
24061C
24062      ITITL2(1,2)='Estimates From Original Fit'
24063      NCTIT2(1,2)=27
24064      NCOLSP(1,2)=2
24065      ITITL2(2,2)='Coef'
24066      NCTIT2(2,2)=4
24067      NCOLSP(2,2)=1
24068      ITITL2(2,3)='SD'
24069      NCTIT2(2,3)=2
24070      NCOLSP(2,3)=1
24071C
24072      ITITL2(1,4)='Estimates From Bootstrap Fit'
24073      NCTIT2(1,4)=28
24074      NCOLSP(1,4)=4
24075      ITITL2(2,4)='Mean'
24076      NCTIT2(2,4)=4
24077      NCOLSP(2,4)=1
24078      ITITL2(2,5)='SD'
24079      NCTIT2(2,5)=2
24080      NCOLSP(2,5)=1
24081      ITITL2(2,6)='2.5'
24082      NCTIT2(2,6)=3
24083      NCOLSP(2,6)=1
24084      ITITL2(2,7)='97.5'
24085      NCTIT2(2,7)=4
24086      NCOLSP(2,7)=1
24087C
24088      NMAX=0
24089      NUMCOL=7
24090      DO193I=1,NUMCOL
24091        VALIGN(I)='b'
24092        ALIGN(I)='r'
24093        NTOT(I)=15
24094        IF(I.EQ.1)NTOT(I)=8
24095        NMAX=NMAX+NTOT(I)
24096        ITYPCO(I)='NUME'
24097        IF(I.EQ.1)ITYPCO(I)='ALPH'
24098        DO195J=1,MAXROW
24099          IDIGI2(J,I)=NUMDIG
24100          IF(I.EQ.1)THEN
24101            IDIGI2(J,I)=-1
24102          ENDIF
24103          IVALUE(J,I)=' '
24104          NCVALU(J,I)=0
24105          AMAT(J,I)=0.0
24106          ROWSEP(J)=0
24107  195   CONTINUE
24108  193 CONTINUE
24109C
24110  199 CONTINUE
24111C
24112C               *****************************************************
24113C               **  STEP 2--GENERATE ORIGINAL FIT OF THE DATA.     **
24114C               **          THIS IS THE SAME FOR BOTH METHODS.     **
24115C               *****************************************************
24116C
24117      ISTEPN='2'
24118      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')
24119     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24120C
24121      NPAR=NVARS
24122      ICASJB='BOOT'
24123      NRESAM=IBOOSS
24124      IT=2
24125C
24126C     FOR REPLICATED FIT, THE TAG VARIABLE IS IN COLUMN 2 OF XMAT.
24127C     STORE DISTINCT VALUES OF THIS TAG VARIABLE IN COLUMN 3.
24128C
24129C     CHECK THAT EACH GROUP HAS AT LEAST 2 ELEMENTS.
24130C
24131      IF(IREPL.EQ.'ON')THEN
24132        NPAR=2
24133        CALL DISTIN(XMAT(1,3),N,IWRITE,TEMP4,NDIST,IBUGA3,IERROR)
24134        IF(IERROR.EQ.'YES')GOTO9000
24135        DO210I=1,NDIST
24136          XMAT(I,4)=TEMP4(I)
24137  210   CONTINUE
24138C
24139        DO220I=1,NDIST
24140          HOLD=XMAT(I,4)
24141          NTEMP=0
24142          DO230J=1,N
24143            IF(XMAT(J,3).EQ.HOLD)THEN
24144              NTEMP=NTEMP+1
24145            ENDIF
24146  230     CONTINUE
24147C
24148          IF(NTEMP.LT.2)THEN
24149            WRITE(ICOUT,999)
24150            CALL DPWRST('XXX','BUG ')
24151            WRITE(ICOUT,221)
24152  221       FORMAT('***** ERROR IN BOOTSTRAP FIT--')
24153            CALL DPWRST('XXX','BUG ')
24154            WRITE(ICOUT,223)
24155  223       FORMAT('      FOR THE "REPLICATED" CASE, EACH GROUP ',
24156     1             'MUST HAVE AT LEAST 2 ELEMENTS.')
24157            CALL DPWRST('XXX','BUG ')
24158            WRITE(ICOUT,225)HOLD
24159  225       FORMAT('      VALUE FOR GROUP-ID = ',G15.7)
24160            CALL DPWRST('XXX','BUG ')
24161            WRITE(ICOUT,227)NTEMP
24162  227       FORMAT('      NUMBER OF ELEMENTS = ',I8)
24163            CALL DPWRST('XXX','BUG ')
24164            IERROR='YES'
24165            GOTO9000
24166          ELSE
24167            XMAT(I,5)=REAL(NTEMP)
24168          ENDIF
24169  220   CONTINUE
24170      ENDIF
24171C
24172      CALL LSQRTX(Y,W,N,XMAT,MAXOBV,NPAR,IT,
24173     1            B,RES,T,VSDPRD,S,RESSSQ,D,RESSD,NDF,SCR,ID,IFITAC,
24174     1            IBUGA3,ISUBRO,IERROR)
24175      DO240I=1,NPAR
24176        BORG(I)=B(I)
24177        TORG(I)=T(I)
24178  240 CONTINUE
24179C
24180C               *****************************************************
24181C               **  STEP 3--                                       **
24182C               **  BOOTSTRAP FIT BY "DATA" METHOD.                **
24183C               *****************************************************
24184C
24185      ISTEPN='3'
24186      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')
24187     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24188C
24189      IF(IBOOME.EQ.'DATA')THEN
24190C
24191C  SAVE ORIGINAL DATA TO UNFORMATTED FILE FOR FAST ACCESS
24192C
24193        NSAVE=NVARS
24194        IF(IREPL.EQ.'ON')NSAVE=5
24195C
24196        IOP='OPEN'
24197        IFLG1=0
24198        IFLG2=0
24199        IFLG3=0
24200        IFLG4=1
24201        IFLG5=0
24202        IST4FO='UNFORMATTED'
24203        CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
24204     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24205     1              IBUGA3,ISUBRO,IERROR)
24206        WRITE(IOUNI4)(Y(I),I=1,N)
24207        WRITE(IOUNI4)(W(I),I=1,N)
24208        WRITE(IOUNI4)((XMAT(I,J),I=1,N),J=1,NSAVE)
24209        IOP='CLOS'
24210        CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
24211     1              IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24212     1              IBUGA3,ISUBRO,IERROR)
24213C
24214        DO310IRESAM=1,NRESAM
24215C
24216          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN
24217             WRITE(ICOUT,312)IRESAM
24218  312        FORMAT('FROM DPBOFI, IRESAM = ',I8)
24219             CALL DPWRST('XXX','BUG ')
24220          ENDIF
24221C
24222          IOP='OPEN'
24223          IFLG1=0
24224          IFLG2=0
24225          IFLG3=0
24226          IFLG4=1
24227          IFLG5=0
24228          CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
24229     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24230     1                IBUGA3,ISUBRO,IERROR)
24231          READ(IOUNI4)(Y(I),I=1,N)
24232          READ(IOUNI4)(W(I),I=1,N)
24233          READ(IOUNI4)((XMAT(I,J),I=1,N),J=1,NSAVE)
24234CCCCC     READ(IOUNI4)Y
24235CCCCC     READ(IOUNI4)XMAT
24236CCCCC     READ(IOUNI4)W
24237C
24238          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN
24239            DO320I=1,N
24240              WRITE(ICOUT,321)I,Y(I),W(I)
24241  321         FORMAT('I,Y(I),W(I) = ',I8,2G15.7)
24242              CALL DPWRST('XXX','BUG ')
24243  320       CONTINUE
24244            DO325I=1,N
24245              WRITE(ICOUT,326)I,(XMAT(I,J),J=1,MIN(5,NSAVE))
24246  326         FORMAT('I,(XMAT(I,J),J=1,MIN(NSAVE,5) = ',I8,5G15.7)
24247              CALL DPWRST('XXX','BUG ')
24248  325       CONTINUE
24249          ENDIF
24250C
24251          IOP='CLOS'
24252          CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
24253     1                IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24254     1                IBUGA3,ISUBRO,IERROR)
24255C
24256          IF(IREPL.EQ.'ON')THEN
24257            DO331K=1,NDIST
24258              HOLD=XMAT(K,4)
24259              NTEMP1=INT(XMAT(K,5)+0.1)
24260              NTEMP2=0
24261              DO333I=1,N
24262                XMAT(I,7)=REAL(I)
24263                IF(XMAT(I,3).EQ.HOLD)THEN
24264                  NTEMP2=NTEMP2+1
24265                  ITEMP2(NTEMP2)=I
24266                ENDIF
24267  333         CONTINUE
24268C
24269              IF(NTEMP1.NE.NTEMP2)THEN
24270                WRITE(ICOUT,999)
24271                CALL DPWRST('XXX','BUG ')
24272                WRITE(ICOUT,221)
24273                CALL DPWRST('XXX','BUG ')
24274                WRITE(ICOUT,436)HOLD,NTEMP1
24275                CALL DPWRST('XXX','BUG ')
24276                WRITE(ICOUT,437)NTEMP2
24277                CALL DPWRST('XXX','BUG ')
24278                IERROR='YES'
24279                GOTO9000
24280              ENDIF
24281C
24282C             USE GATHER/SCATTER OPERATION TO PUT X,Y IN CORRECT ROW.
24283C             GENERATE BOOTSTRAP SAMPLE FROM THE INDEX VARIABLE AND
24284C             THEN USE THIS TO EXTRACT THE X,Y PAIRS.
24285C
24286              CALL GATHER(NTEMP2,XMAT(1,6),XMAT(1,7),ITEMP2,MAXOBV,
24287     1                    ISUBRO,IBUGA3,IERROR)
24288C
24289              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BOF2')THEN
24290                DO341II=1,NTEMP2
24291                  WRITE(ICOUT,343)II,ITEMP2(II),XMAT(II,6)
24292  343             FORMAT('II,ITEMP2(II),XMAT(II,6)=',2I8,G15.7)
24293                  CALL DPWRST('XXX','BUG ')
24294  341           CONTINUE
24295              ENDIF
24296C
24297              NOUT=N
24298              CALL DPJBS3(XMAT(1,6),NTEMP2,ICASJB,IRESAM,ISEED,
24299     1                    TEMP1,NOUT,ITEMP1,TEMP4,IBUGA3,IERROR)
24300C
24301              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BOF2')THEN
24302                DO347II=1,NTEMP2
24303                  WRITE(ICOUT,348)II,TEMP1(II)
24304  348             FORMAT('II,TEMP1(II) = ',I8,G15.7)
24305                  CALL DPWRST('XXX','BUG ')
24306  347           CONTINUE
24307              ENDIF
24308C
24309              NMAX=N
24310              CALL SCATTR(NTEMP2,XMAT(1,8),ITEMP2,TEMP1,NMAX,MAXOBV,
24311     1                    ISUBRO,IBUGA3,IERROR)
24312C
24313  331       CONTINUE
24314C
24315            DO349J=1,N
24316              ITEMP1(J)=INT(XMAT(J,8)+0.1)
24317              TEMP3(J)=Y(ITEMP1(J))
24318              TEMP2(J)=W(ITEMP1(J))
24319  349       CONTINUE
24320            DO351J=1,N
24321              Y(J)=TEMP3(J)
24322              W(J)=TEMP2(J)
24323  351       CONTINUE
24324          ELSE
24325            CALL DPJBS3(Y,N,ICASJB,IRESAM,ISEED,
24326     1                  TEMP1,N2,ITEMP1,TEMP4,IBUGA3,IERROR)
24327            DO370J=1,N
24328              Y(J)=TEMP1(J)
24329              TEMP2(J)=W(ITEMP1(J))
24330  370       CONTINUE
24331            DO375J=1,N
24332              W(J)=TEMP2(J)
24333  375       CONTINUE
24334          ENDIF
24335C
24336          DO380L=1,NPAR
24337            DO385J=1,N
24338              TEMP3(J)=XMAT(ITEMP1(J),L)
24339  385       CONTINUE
24340            DO388J=1,N
24341              XMAT(J,L)=TEMP3(J)
24342  388       CONTINUE
24343  380     CONTINUE
24344C
24345          CALL LSQRTX(Y,W,N,XMAT,MAXOBV,NPAR,IT,
24346     1               B,RES,T,VSDPRD,S,RESSSQ,D,RESSD,NDF,SCR,ID,IFITAC,
24347     1               IBUGA3,ISUBRO,IERROR)
24348C
24349          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN
24350             WRITE(ICOUT,392)
24351  392        FORMAT('FROM DPBOFI, BEFORE WRITE TO FILES')
24352             CALL DPWRST('XXX','BUG ')
24353          ENDIF
24354C
24355          WRITE(IOUNI1,'(35E15.7)')(B(LL),LL=1,NPAR)
24356          WRITE(IOUNI2,'(35E15.7)')(T(LL),LL=1,NPAR)
24357          WRITE(IOUNI3,'(E15.7)')RESSD
24358C
24359          IF(IRESAM.GE.1)THEN
24360            DO395II=1,N
24361              APRED=Y(II) - RES(II)
24362              WRITE(IOUNI5,'(I8,7E15.7)')IRESAM,APRED,RES(II),
24363     1              (XMAT(II,JJ),JJ=1,NPAR)
24364  395       CONTINUE
24365          ENDIF
24366C
24367  310   CONTINUE
24368      ELSE
24369C
24370C               *****************************************************
24371C               **  STEP 4--                                       **
24372C               **  BOOTSTRAP FIT BY "RESIDUAL" METHOD             **
24373C               *****************************************************
24374C
24375      ISTEPN='4'
24376      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')
24377     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24378C
24379C     COMPUTE AND STORE RESIDUALS FROM ORIGINAL FIT
24380C
24381        DO401I=1,N
24382          DSUM1=0.0
24383          DO405J=1,NPAR
24384            DSUM1 = DSUM1 + DBLE(BORG(J)*XMAT(I,J))
24385  405     CONTINUE
24386          RES1(I) = Y(I) - REAL(DSUM1)
24387  401   CONTINUE
24388C
24389C       RESAMPLE RESIDUALS, COMPUTE NEW Y (XMAT STAYS CONSTANT,
24390C       SO NO NEED TO SAVE/RELOAD ORIGINAL X MATRIX).
24391C
24392        DO410IRESAM=1,NRESAM
24393C
24394          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN
24395             WRITE(ICOUT,422)IRESAM
24396  422        FORMAT('FROM DPBOFI, IRESAM = ',I8)
24397             CALL DPWRST('XXX','BUG ')
24398          ENDIF
24399C
24400          IF(IREPL.EQ.'ON')THEN
24401            DO431K=1,NDIST
24402              HOLD=XMAT(K,4)
24403              NTEMP1=INT(XMAT(K,5)+0.1)
24404              NTEMP2=0
24405              DO433I=1,N
24406                IF(XMAT(I,3).EQ.HOLD)THEN
24407                  NTEMP2=NTEMP2+1
24408                  ITEMP2(NTEMP2)=I
24409                ENDIF
24410  433         CONTINUE
24411C
24412              IF(NTEMP1.NE.NTEMP2)THEN
24413                WRITE(ICOUT,999)
24414                CALL DPWRST('XXX','BUG ')
24415                WRITE(ICOUT,221)
24416                CALL DPWRST('XXX','BUG ')
24417                WRITE(ICOUT,436)HOLD,NTEMP1
24418  436           FORMAT('      FOR GROUP-ID ',G15.7,' EXPECTED ',I8)
24419                CALL DPWRST('XXX','BUG ')
24420                WRITE(ICOUT,437)NTEMP2
24421  437           FORMAT('      ROWS BUT ONLY EXTRACTED ',I8,' ROWS.')
24422                CALL DPWRST('XXX','BUG ')
24423                IERROR='YES'
24424                GOTO9000
24425              ENDIF
24426C
24427C             USE GATHER/SCATTER OPERATION TO PUT RESIDUALS IN
24428C             CORRECT ROW.
24429C
24430              IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BOF2')THEN
24431                DO441II=1,NTEMP2
24432                  WRITE(ICOUT,443)II,ITEMP2(II)
24433  443             FORMAT('II,ITEMP2(II) = ',2I8)
24434                  CALL DPWRST('XXX','BUG ')
24435  441           CONTINUE
24436              ENDIF
24437C
24438              CALL GATHER(NTEMP2,XMAT(1,6),RES1,ITEMP2,MAXOBV,
24439     1                    ISUBRO,IBUGA3,IERROR)
24440              NOUT=N
24441              CALL DPJBS3(XMAT(1,6),NTEMP2,ICASJB,IRESAM,ISEED,
24442     1                    RES2,NOUT,ITEMP1,TEMP4,IBUGA3,IERROR)
24443              NMAX=N
24444              CALL SCATTR(NTEMP2,RES1,ITEMP2,RES2,NMAX,MAXOBV,
24445     1                    ISUBRO,IBUGA3,IERROR)
24446  431       CONTINUE
24447          ELSE
24448            CALL DPJBS3(RES1,N,ICASJB,IRESAM,ISEED,RES2,N2,ITEMP1,
24449     1                  TEMP4,IBUGA3,IERROR)
24450          ENDIF
24451C
24452          DO460I=1,N
24453            DSUM1=0.0
24454            DO465J=1,NPAR
24455              DSUM1 = DSUM1 + DBLE(BORG(J)*XMAT(I,J))
24456  465       CONTINUE
24457            TEMP3(I) = RES2(I) + REAL(DSUM1)
24458  460     CONTINUE
24459C
24460          CALL LSQRTX(TEMP3,W,N,XMAT,MAXOBV,NPAR,IT,
24461     1               B,RES,T,VSDPRD,S,RESSSQ,D,RESSD,NDF,SCR,ID,IFITAC,
24462     1               IBUGA3,ISUBRO,IERROR)
24463C
24464          IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN
24465             WRITE(ICOUT,472)
24466  472        FORMAT('FROM DPBOF2, BEFORE WRITE TO FILES')
24467             CALL DPWRST('XXX','BUG ')
24468          ENDIF
24469C
24470          WRITE(IOUNI1,'(35E15.7)')(B(LL),LL=1,NPAR)
24471          WRITE(IOUNI2,'(35E15.7)')(T(LL),LL=1,NPAR)
24472          WRITE(IOUNI3,'(E15.7)')RESSD
24473C
24474          IF(IRESAM.GE.1)THEN
24475            DO495II=1,N
24476              APRED=Y(II) - RES(II)
24477              WRITE(IOUNI5,'(I8,7E15.7)')IRESAM,APRED,RES(II),
24478     1              (XMAT(II,JJ),JJ=1,NPAR)
24479  495       CONTINUE
24480          ENDIF
24481C
24482  410   CONTINUE
24483      ENDIF
24484C
24485      IOP='CLOS'
24486      IFLG1=1
24487      IFLG2=1
24488      IFLG3=1
24489      IFLG4=0
24490      IFLG5=1
24491      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
24492     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24493     1            IBUGA3,ISUBRO,IERROR)
24494C
24495C               *********************************************
24496C               **  STEP 5--                               **
24497C               **  COMPUTE AND PRINT SUMMARY INFORMATION. **
24498C               *********************************************
24499C
24500      ISTEPN='85'
24501      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')
24502     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24503C
24504C  REOPEN DPST1F.DAT, DPST2F.DAT TO RETRIEVE PARAMETER AND
24505C  PARAMETER SD ESTIMATES.
24506C
24507      IOP='OPEN'
24508      IFLG1=1
24509      IFLG2=1
24510      IFLG3=0
24511      IFLG4=0
24512      IFLG5=0
24513      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
24514     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24515     1            IBUGA3,ISUBRO,IERROR)
24516C
24517      IWRITE='OFF'
24518      DO8510J=1,NPAR
24519        DO8520I=1,NRESAM
24520          READ(IOUNI1,'(35E15.7)',END=8599,ERR=8599)(B(LL),LL=1,NPAR)
24521          READ(IOUNI2,'(35E15.7)',END=8599,ERR=8599)(T(LL),LL=1,NPAR)
24522          TEMP1(I)=B(J)
24523          TEMP2(I)=T(J)
24524 8520   CONTINUE
24525        CALL MEDIAN(TEMP1,NRESAM,IWRITE,TEMP3,MAXOBV,XMED,
24526     1              IBUGA3,IERROR)
24527        CALL MEAN(TEMP1,NRESAM,IWRITE,XMEAN,IBUGA3,IERROR)
24528        CALL MEAN(TEMP2,NRESAM,IWRITE,XSD,IBUGA3,IERROR)
24529        P100=2.5
24530        CALL PERCEN(P100,TEMP1,NRESAM,IWRITE,TEMP3,MAXOBV,
24531     1              X025,IBUGA3,IERROR)
24532        P100=97.5
24533        CALL PERCEN(P100,TEMP1,NRESAM,IWRITE,TEMP3,MAXOBV,
24534     1              X975,IBUGA3,IERROR)
24535        IPARNM(1:3)='A  '
24536        IF(J.LE.9)THEN
24537          WRITE(IPARNM(2:2),'(I1)')J-1
24538          NCVALU(J,1)=2
24539        ELSE
24540          NCVALU(J,1)=3
24541          WRITE(IPARNM(2:3),'(I2)')J-1
24542        ENDIF
24543CCCCC   WRITE(ICOUT,8529)IPARNM,BORG(J),TORG(J),XMEAN,XSD,X025,X975
24544C8529   FORMAT(A3,3X,6(E12.5))
24545CCCCC   CALL DPWRST('XXX','BUG ')
24546        IVALUE(J,1)(1:3)=IPARNM(1:3)
24547        AMAT(J,2)=BORG(J)
24548        AMAT(J,3)=TORG(J)
24549        AMAT(J,4)=XMEAN
24550        AMAT(J,5)=XSD
24551        AMAT(J,6)=X025
24552        AMAT(J,7)=X975
24553        REWIND(IOUNI1)
24554        REWIND(IOUNI2)
24555 8510 CONTINUE
24556 8599 CONTINUE
24557C
24558      IOP='CLOS'
24559      CALL DPAUFI(IOP,IFLG1,IFLG2,IFLG3,IFLG4,IFLG5,
24560     1            IOUNI1,IOUNI2,IOUNI3,IOUNI4,IOUNI5,
24561     1            IBUGA3,ISUBRO,IERROR)
24562C
24563      NUMLIN=2
24564      ICNT=NPAR
24565      IFRST=.TRUE.
24566      ILAST=.TRUE.
24567      IFLAGS=.TRUE.
24568      IFLAGE=.TRUE.
24569      CALL DPDT5B(ITITLE,NCTITL,
24570     1            ITITL9,NCTIT9,ITITL2,NCTIT2,
24571     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
24572     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,ICNT,
24573     1            IDIGI2,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
24574     1            NCOLSP,ROWSEP,
24575     1            ICAPSW,ICAPTY,IFRST,ILAST,
24576     1            IFLAGS,IFLAGE,
24577     1            ISUBRO,IBUGA3,IERROR)
24578C
24579C               ****************************************************
24580C               **  STEP 6--                                      **
24581C               **  WRITE INFO OUT TO FILES--                     **
24582C               **     1) DPST1F.DAT--XXXXX                       **
24583C               ****************************************************
24584C
24585      ISTEPN='81'
24586      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')
24587     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
24588C
24589      IF(IFEEDB.EQ.'ON')THEN
24590        WRITE(ICOUT,999)
24591        CALL DPWRST('XXX','BUG ')
24592        WRITE(ICOUT,8112)
24593 8112   FORMAT('COEFFICIENT ESTIMATES WRITTEN  TO FILE DPST1F.DAT')
24594        CALL DPWRST('XXX','BUG ')
24595        WRITE(ICOUT,8114)
24596 8114   FORMAT('COEFFICIENT STANDARD DEVIATIONS WRITTEN TO FILE ',
24597     1         'DPST2F.DAT')
24598        CALL DPWRST('XXX','BUG ')
24599        WRITE(ICOUT,8116)
24600 8116   FORMAT('RESIDUAL STANDARD DEVIATIONS WRITTEN TO FILE ',
24601     1         'DPST3F.DAT')
24602        CALL DPWRST('XXX','BUG ')
24603        WRITE(ICOUT,8118)
24604 8118   FORMAT('RESIDUAL AND PREDICTED VALUES FOR BOOTSTRAP SAMPLES ',
24605     1         'WRITTEN TO DPST5F.DAT')
24606        CALL DPWRST('XXX','BUG ')
24607      ENDIF
24608C
24609C               *****************
24610C               **  STEP 90--  **
24611C               **  EXIT       **
24612C               *****************
24613C
24614 9000 CONTINUE
24615C
24616CCCCC BE SURE TO RESET DPST4F.DAT TO FORMATTED.
24617C
24618      IST4FO='FORMATTED'
24619C
24620      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BOF2')THEN
24621        WRITE(ICOUT,999)
24622        CALL DPWRST('XXX','BUG ')
24623        WRITE(ICOUT,9011)
24624 9011   FORMAT('***** AT THE END       OF DPBOF2--')
24625        CALL DPWRST('XXX','BUG ')
24626        WRITE(ICOUT,9012)IERROR
24627 9012   FORMAT('IERROR = ',A4)
24628        CALL DPWRST('XXX','BUG ')
24629      ENDIF
24630C
24631      RETURN
24632      END
24633      SUBROUTINE DPBOFP(IHARG,IARGT,IARG,NUMARG,IDEFPA,
24634     1                  MAXBOX,IBOFPA,IFOUND,IERROR)
24635C
24636C     PURPOSE--DEFINE THE FILL PATTERN FOR A BOX.
24637C              THE FILL PATTERN FOR A BOX IS THE PATTERN
24638C              THAT WILL APPEAR IN THE INSIDE REGION OF THE BOX.
24639C              THE PATTERN FOR BOX I WILL BE PLACED
24640C              IN THE I-TH ELEMENT OF THE HOLLERITH
24641C              VECTOR IBOFPA(.).
24642C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
24643C                     --IARGT  (A HOLLERITH VECTOR)
24644C                     --IARG   (A HOLLERITH VECTOR)
24645C                     --NUMARG
24646C                     --IDEFPA
24647C                     --MAXBOX
24648C     OUTPUT ARGUMENTS--IBOFPA (A HOLLERITH VECTOR
24649C                              WHOSE I-TH ELEMENT CONTAINS THE
24650C                              PATTERN FOR BOX I.
24651C                     --IFOUND ('YES' OR 'NO' )
24652C                     --IERROR ('YES' OR 'NO' )
24653C     WRITTEN BY--JAMES J. FILLIBEN
24654C                 STATISTICAL ENGINEERING DIVISION
24655C                 INFORMATION TECHNOLOGY LABORATORY
24656C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24657C                 GAITHERSBURG, MD 20899-8980
24658C                 PHONE--301-975-2855
24659C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24660C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24661C     LANGUAGE--ANSI FORTRAN (1977)
24662C     VERSION NUMBER--92/8
24663C     ORIGINAL VERSION--AUGUST    1992.
24664C
24665C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24666C
24667      CHARACTER*4 IHARG
24668      CHARACTER*4 IARGT
24669      CHARACTER*4 IDEFPA
24670      CHARACTER*4 IBOFPA
24671      CHARACTER*4 IFOUND
24672      CHARACTER*4 IERROR
24673C
24674      CHARACTER*4 IHOLD
24675C
24676C---------------------------------------------------------------------
24677C
24678      DIMENSION IHARG(*)
24679      DIMENSION IARGT(*)
24680      DIMENSION IARG(*)
24681      DIMENSION IBOFPA(*)
24682C
24683C---------------------------------------------------------------------
24684C
24685      INCLUDE 'DPCOP2.INC'
24686C
24687C-----START POINT-----------------------------------------------------
24688C
24689      IFOUND='NO'
24690      IERROR='NO'
24691C
24692      IF(NUMARG.EQ.0)GOTO1199
24693      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.
24694     1   IHARG(2).EQ.'PATT')THEN
24695        IF(NUMARG.LE.2 .OR. IHARG(3).EQ.'AUTO' .OR.
24696     1     IHARG(3).EQ.'DEFA')THEN
24697          IHOLD=IDEFPA
24698        ELSEIF(IHARG(3).EQ.'ON' .OR. IHARG(3).EQ.'SOLI')THEN
24699          IHOLD='ON'
24700        ELSEIF(IHARG(3).EQ.'EMPT' .OR. IHARG(3).EQ.'OFF' .OR.
24701     1         IHARG(3).EQ.'BLAN' .OR. IHARG(3).EQ.'NONE' .OR.
24702     1         IHARG(3).EQ.'HOLL')THEN
24703          IHOLD='OFF'
24704        ELSE
24705          IHOLD=IHARG(3)
24706        ENDIF
24707C
24708        IFOUND='YES'
24709        DO1135I=1,MAXBOX
24710          IBOFPA(I)=IHOLD
24711 1135   CONTINUE
24712        WRITE(ICOUT,999)
24713  999   FORMAT(1X)
24714        CALL DPWRST('XXX','BUG ')
24715        I=1
24716        IF(IFEEDB.EQ.'ON')THEN
24717          WRITE(ICOUT,1136)IBOFPA(I)
24718 1136     FORMAT('ALL BOX FILL PATTERNS HAVE JUST BEEN SET TO ',A4)
24719          CALL DPWRST('XXX','BUG ')
24720          GOTO1199
24721        ENDIF
24722      ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.
24723     1       IHARG(3).EQ.'PATT')THEN
24724        IF(IARGT(1).NE.'NUMB')THEN
24725          IERROR='YES'
24726          WRITE(ICOUT,999)
24727          CALL DPWRST('XXX','BUG ')
24728          WRITE(ICOUT,1141)
24729 1141     FORMAT('***** ERROR IN BOX FILL PATTERN (DPBOFP)--')
24730          CALL DPWRST('XXX','BUG ')
24731          WRITE(ICOUT,1142)
24732 1142     FORMAT('      IN THE BOX ... FILL PATTERN COMMAND,')
24733          CALL DPWRST('XXX','BUG ')
24734          WRITE(ICOUT,1143)
24735 1143     FORMAT('      THE BOX IS IDENTIFIED BY A NUMBER, AS IN--')
24736          CALL DPWRST('XXX','BUG ')
24737          WRITE(ICOUT,1144)
24738 1144     FORMAT('      BOX 3 FILL PATTERN ON')
24739          CALL DPWRST('XXX','BUG ')
24740          GOTO1199
24741        ENDIF
24742C
24743        I=IARG(1)
24744        IF(I.LT.1 .OR. I.GT.MAXBOX)THEN
24745          IERROR='YES'
24746          WRITE(ICOUT,999)
24747          CALL DPWRST('XXX','BUG ')
24748          WRITE(ICOUT,1141)
24749          CALL DPWRST('XXX','BUG ')
24750          WRITE(ICOUT,1142)
24751          CALL DPWRST('XXX','BUG ')
24752          WRITE(ICOUT,1153)
24753 1153     FORMAT('      THE NUMBER OF BOXES MUST BE ')
24754          CALL DPWRST('XXX','BUG ')
24755          WRITE(ICOUT,1154)MAXBOX
24756 1154     FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
24757          CALL DPWRST('XXX','BUG ')
24758          WRITE(ICOUT,1155)
24759 1155     FORMAT('      SUCH WAS NOT THE CASE HERE--')
24760          CALL DPWRST('XXX','BUG ')
24761          WRITE(ICOUT,1156)I
24762 1156     FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
24763     1           'BOX.')
24764          CALL DPWRST('XXX','BUG ')
24765          GOTO1199
24766        ENDIF
24767C
24768        IF(NUMARG.LE.3 .OR. IHARG(4).EQ.'AUTO' .OR.
24769     1     IHARG(4).EQ.'DEFA')THEN
24770          IHOLD=IDEFPA
24771        ELSEIF(IHARG(4).EQ.'ON' .OR. IHARG(4).EQ.'SOLI')THEN
24772          IHOLD='ON'
24773        ELSEIF(IHARG(4).EQ.'OFF' .OR. IHARG(4).EQ.'EMPT' .OR.
24774     1         IHARG(4).EQ.'BLAN' .OR. IHARG(4).EQ.'NONE' .OR.
24775     1         IHARG(4).EQ.'HOLL')THEN
24776          IHOLD='OFF'
24777        ELSE
24778          IHOLD=IHARG(4)
24779        ENDIF
24780C
24781        IFOUND='YES'
24782        IBOFPA(I)=IHOLD
24783        IF(IFEEDB.EQ.'ON')THEN
24784          WRITE(ICOUT,999)
24785          CALL DPWRST('XXX','BUG ')
24786          WRITE(ICOUT,1186)I,IBOFPA(I)
24787 1186     FORMAT('THE FILL PATTERN FOR BOX ',I8,
24788     1           ' HAS JUST BEEN SET TO ',A4)
24789          CALL DPWRST('XXX','BUG ')
24790          GOTO1199
24791        ENDIF
24792      ENDIF
24793C
24794 1199 CONTINUE
24795      RETURN
24796      END
24797      SUBROUTINE DPBOFT(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH,
24798     1                  MAXBOX,PBOFTH,IFOUND,IERROR)
24799C
24800C     PURPOSE--DEFINE THE THICKNESS FOR A BOX.
24801C              THE THICKNESS FOR A BOX IS THE THICKNESS
24802C              THAT WILL APPEAR IN THE INSIDE REGION OF THE BOX.
24803C              THE THICKNESS FOR BOX I WILL BE PLACED
24804C              IN THE I-TH ELEMENT OF THE REAL
24805C              VECTOR PBOFTH(.).
24806C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
24807C                     --IARGT  (A HOLLERITH VECTOR)
24808C                     --IARG   (A HOLLERITH VECTOR)
24809C                     --ARG    (A REAL VECTOR)
24810C                     --NUMARG
24811C                     --PDEFTH
24812C                     --MAXBOX
24813C     OUTPUT ARGUMENTS--PBOFTH (A REAL VECTOR
24814C                              WHOSE I-TH ELEMENT CONTAINS THE
24815C                              THICKNESS FOR BOX I.
24816C                     --IFOUND ('YES' OR 'NO' )
24817C                     --IERROR ('YES' OR 'NO' )
24818C     WRITTEN BY--JAMES J. FILLIBEN
24819C                 STATISTICAL ENGINEERING DIVISION
24820C                 INFORMATION TECHNOLOGY LABORATORY
24821C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24822C                 GAITHERSBURG, MD 20899-8980
24823C                 PHONE--301-975-2855
24824C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24825C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24826C     LANGUAGE--ANSI FORTRAN (1977)
24827C     VERSION NUMBER--92/8
24828C     ORIGINAL VERSION--AUGUST    1992.
24829C
24830C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24831C
24832      CHARACTER*4 IHARG
24833      CHARACTER*4 IARGT
24834      REAL        PDEFTH
24835      REAL        PBOFTH
24836      CHARACTER*4 IFOUND
24837      CHARACTER*4 IERROR
24838C
24839      REAL        PHOLD
24840C
24841C---------------------------------------------------------------------
24842C
24843      DIMENSION IHARG(*)
24844      DIMENSION IARGT(*)
24845      DIMENSION IARG(*)
24846      DIMENSION ARG(*)
24847      DIMENSION PBOFTH(*)
24848C
24849C---------------------------------------------------------------------
24850C
24851      INCLUDE 'DPCOP2.INC'
24852C
24853C-----START POINT-----------------------------------------------------
24854C
24855      IFOUND='NO'
24856      IERROR='NO'
24857C
24858      IF(NUMARG.EQ.0)GOTO1199
24859      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.
24860     1   IHARG(2).EQ.'THIC')THEN
24861        IF(NUMARG.LE.2 .OR. IHARG(3).EQ.'ON' .OR.
24862     1     IHARG(3).EQ.'OFF' .OR. IHARG(3).EQ.'AUTO' .OR.
24863     1     IHARG(3).EQ.'DEFA')THEN
24864          PHOLD=PDEFTH
24865        ELSE
24866          PHOLD=ARG(3)
24867        ENDIF
24868C
24869        IFOUND='YES'
24870        DO1135I=1,MAXBOX
24871          PBOFTH(I)=PHOLD
24872 1135   CONTINUE
24873        IF(IFEEDB.EQ.'ON')THEN
24874          WRITE(ICOUT,999)
24875  999     FORMAT(1X)
24876          CALL DPWRST('XXX','BUG ')
24877          I=1
24878          WRITE(ICOUT,1136)PBOFTH(I)
24879 1136     FORMAT('ALL BOX FILL THICKNESSS HAVE JUST BEEN SET TO ',
24880     1           E15.7)
24881          CALL DPWRST('XXX','BUG ')
24882          GOTO1199
24883        ENDIF
24884C
24885      ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.
24886     1       IHARG(3).EQ.'THIC')THEN
24887        IF(IARGT(1).NE.'NUMB')THEN
24888          IERROR='YES'
24889          WRITE(ICOUT,999)
24890          CALL DPWRST('XXX','BUG ')
24891          WRITE(ICOUT,1141)
24892 1141     FORMAT('***** ERROR IN BOX FILL THICKNESS (DPBOFT)--')
24893          CALL DPWRST('XXX','BUG ')
24894          WRITE(ICOUT,1142)
24895 1142     FORMAT('      IN THE BOX ... FILL THICKNESS COMMAND,')
24896          CALL DPWRST('XXX','BUG ')
24897          WRITE(ICOUT,1143)
24898 1143     FORMAT('      THE BOX IS IDENTIFIED BY A NUMBER, AS IN--')
24899          CALL DPWRST('XXX','BUG ')
24900          WRITE(ICOUT,1144)
24901 1144     FORMAT('      BOX 3 FILL THICKNESS 0.3')
24902          CALL DPWRST('XXX','BUG ')
24903          GOTO1199
24904        ENDIF
24905C
24906        I=IARG(1)
24907        IF(I.LT.1 .OR. I.GT.MAXBOX)THEN
24908          IERROR='YES'
24909          WRITE(ICOUT,999)
24910          CALL DPWRST('XXX','BUG ')
24911          WRITE(ICOUT,1141)
24912          CALL DPWRST('XXX','BUG ')
24913          WRITE(ICOUT,1142)
24914          CALL DPWRST('XXX','BUG ')
24915          WRITE(ICOUT,1153)
24916 1153     FORMAT('      THE NUMBER OF BOXES MUST BE ')
24917          CALL DPWRST('XXX','BUG ')
24918          WRITE(ICOUT,1154)MAXBOX
24919 1154     FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
24920          CALL DPWRST('XXX','BUG ')
24921          WRITE(ICOUT,1155)
24922 1155     FORMAT('      SUCH WAS NOT THE CASE HERE--')
24923          CALL DPWRST('XXX','BUG ')
24924          WRITE(ICOUT,1156)I
24925 1156     FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
24926     1           'BOX.')
24927          CALL DPWRST('XXX','BUG ')
24928          GOTO1199
24929        ENDIF
24930C
24931        IF(NUMARG.LE.3 .OR. IHARG(4).EQ.'ON' .OR.
24932     1     IHARG(4).EQ.'OFF' .OR. IHARG(4).EQ.'AUTO' .OR.
24933     1     IHARG(4).EQ.'DEFA')THEN
24934          PHOLD=PDEFTH
24935        ELSE
24936          PHOLD=ARG(4)
24937        ENDIF
24938C
24939        IFOUND='YES'
24940        PBOFTH(I)=PHOLD
24941        IF(IFEEDB.EQ.'ON')THEN
24942          WRITE(ICOUT,999)
24943          CALL DPWRST('XXX','BUG ')
24944          WRITE(ICOUT,1186)I,PBOFTH(I)
24945 1186     FORMAT('THE FILL THICKNESS FOR BOX ',I8,
24946     1           ' HAS JUST BEEN SET TO ',E15.7)
24947          CALL DPWRST('XXX','BUG ')
24948          GOTO1199
24949        ENDIF
24950      ENDIF
24951C
24952 1199 CONTINUE
24953      RETURN
24954      END
24955      SUBROUTINE DPBOFG(IHARG,IARGT,IARG,ARG,NUMARG,PDEFGA,
24956     1                  MAXBOX,PBOPGA,IFOUND,IERROR)
24957C
24958C     PURPOSE--DEFINE THE GAP FOR A BOX.
24959C              THE GAP FOR A BOX IS THE GAP
24960C              BETWEEN THE LINES OF A REGION FILL PATTERN.
24961C              THE GAP FOR BOX I WILL BE PLACED
24962C              IN THE I-TH ELEMENT OF THE REAL
24963C              VECTOR PBOPGA(.).
24964C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
24965C                     --IARGT  (A HOLLERITH VECTOR)
24966C                     --IARG   (A HOLLERITH VECTOR)
24967C                     --ARG    (A REAL VECTOR)
24968C                     --NUMARG
24969C                     --PDEFGA
24970C                     --MAXBOX
24971C     OUTPUT ARGUMENTS--PBOPGA (A REAL VECTOR
24972C                              WHOSE I-TH ELEMENT CONTAINS THE
24973C                              GAP FOR BOX I.
24974C                     --IFOUND ('YES' OR 'NO' )
24975C                     --IERROR ('YES' OR 'NO' )
24976C     WRITTEN BY--JAMES J. FILLIBEN
24977C                 STATISTICAL ENGINEERING DIVISION
24978C                 INFORMATION TECHNOLOGY LABORATORY
24979C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
24980C                 GAITHERSBURG, MD 20899-8980
24981C                 PHONE--301-975-2855
24982C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
24983C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
24984C     LANGUAGE--ANSI FORTRAN (1977)
24985C     VERSION NUMBER--92/8
24986C     ORIGINAL VERSION--AUGUST    1992.
24987C
24988C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
24989C
24990      CHARACTER*4 IHARG
24991      CHARACTER*4 IARGT
24992      REAL        PDEFGA
24993      REAL        PBOPGA
24994      CHARACTER*4 IFOUND
24995      CHARACTER*4 IERROR
24996C
24997      REAL        PHOLD
24998C
24999C---------------------------------------------------------------------
25000C
25001      DIMENSION IHARG(*)
25002      DIMENSION IARGT(*)
25003      DIMENSION IARG(*)
25004      DIMENSION ARG(*)
25005      DIMENSION PBOPGA(*)
25006C
25007C---------------------------------------------------------------------
25008C
25009      INCLUDE 'DPCOP2.INC'
25010C
25011C-----START POINT-----------------------------------------------------
25012C
25013      IFOUND='NO'
25014      IERROR='NO'
25015C
25016      IF(NUMARG.EQ.0)GOTO1199
25017      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.
25018     1   IHARG(2).EQ.'GAP')THEN
25019        IF(NUMARG.LE.2 .OR. IHARG(3).EQ.'ON' .OR.
25020     1     IHARG(3).EQ.'OFF' .OR. IHARG(3).EQ.'AUTO' .OR.
25021     1     IHARG(3).EQ.'DEFA')THEN
25022          PHOLD=PDEFGA
25023        ELSE
25024          PHOLD=ARG(3)
25025        ENDIF
25026C
25027        IFOUND='YES'
25028        DO1135I=1,MAXBOX
25029          PBOPGA(I)=PHOLD
25030 1135   CONTINUE
25031        IF(IFEEDB.EQ.'ON')THEN
25032          WRITE(ICOUT,999)
25033  999     FORMAT(1X)
25034          CALL DPWRST('XXX','BUG ')
25035          I=1
25036          WRITE(ICOUT,1136)PBOPGA(I)
25037 1136     FORMAT('ALL BOX FILL GAPS HAVE JUST BEEN SET TO ',E15.7)
25038          CALL DPWRST('XXX','BUG ')
25039          GOTO1199
25040        ENDIF
25041      ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.
25042     1       IHARG(3).EQ.'GAP')THEN
25043        IF(IARGT(1).NE.'NUMB')THEN
25044          IERROR='YES'
25045          WRITE(ICOUT,999)
25046          CALL DPWRST('XXX','BUG ')
25047          WRITE(ICOUT,1141)
25048 1141     FORMAT('***** ERROR IN BOX FILL GAP (DPBOFG)--')
25049          CALL DPWRST('XXX','BUG ')
25050          WRITE(ICOUT,1142)
25051 1142     FORMAT('      IN THE BOX ... FILL GAP COMMAND,')
25052          CALL DPWRST('XXX','BUG ')
25053          WRITE(ICOUT,1143)
25054 1143     FORMAT('      THE BOX IS IDENTIFIED BY A NUMBER, AS IN--')
25055          CALL DPWRST('XXX','BUG ')
25056          WRITE(ICOUT,1144)
25057 1144     FORMAT('      BOX 3 FILL GAP 1.0')
25058          CALL DPWRST('XXX','BUG ')
25059          GOTO1199
25060        ENDIF
25061C
25062        I=IARG(1)
25063        IF(I.LT.1 .OR. I.GT.MAXBOX)THEN
25064          IERROR='YES'
25065          WRITE(ICOUT,999)
25066          CALL DPWRST('XXX','BUG ')
25067          WRITE(ICOUT,1141)
25068          CALL DPWRST('XXX','BUG ')
25069          WRITE(ICOUT,1142)
25070          CALL DPWRST('XXX','BUG ')
25071          WRITE(ICOUT,1153)
25072 1153     FORMAT('      THE NUMBER OF BOXES MUST BE ')
25073          CALL DPWRST('XXX','BUG ')
25074          WRITE(ICOUT,1154)MAXBOX
25075 1154     FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
25076          CALL DPWRST('XXX','BUG ')
25077          WRITE(ICOUT,1155)
25078 1155     FORMAT('      SUCH WAS NOT THE CASE HERE--')
25079          CALL DPWRST('XXX','BUG ')
25080          WRITE(ICOUT,1156)I
25081 1156     FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
25082     1           'BOX.')
25083          CALL DPWRST('XXX','BUG ')
25084          GOTO1199
25085        ENDIF
25086C
25087        IF(NUMARG.LE.3 .OR. IHARG(4).EQ.'ON' .OR.
25088     1     IHARG(4).EQ.'OFF' .OR. IHARG(4).EQ.'AUTO' .OR.
25089     1     IHARG(4).EQ.'DEFA')THEN
25090          PHOLD=PDEFGA
25091        ELSE
25092          PHOLD=ARG(4)
25093        ENDIF
25094C
25095        IFOUND='YES'
25096        PBOPGA(I)=PHOLD
25097        IF(IFEEDB.EQ.'ON')THEN
25098          WRITE(ICOUT,999)
25099          CALL DPWRST('XXX','BUG ')
25100          WRITE(ICOUT,1186)I,PBOPGA(I)
25101 1186     FORMAT('THE FILL GAP FOR BOX ',I8,
25102     1           ' HAS JUST BEEN SET TO ',E15.7)
25103          CALL DPWRST('XXX','BUG ')
25104          GOTO1199
25105        ENDIF
25106      ENDIF
25107C
25108 1199 CONTINUE
25109      RETURN
25110      END
25111      SUBROUTINE DPBOFL(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA,
25112     1                  MAXBOX,IBOPPA,IFOUND,IERROR)
25113C
25114C     PURPOSE--DEFINE THE LINE PATTERN FOR THE FILL OF
25115C              A BOX.  THIS ONLY APPLIES FOR NON-SOLID FILL
25116C              PATTERNS (E.G., HORI, VERT, ETC.)
25117C              THE PATTERN FOR BOX I WILL BE PLACED
25118C              IN THE I-TH ELEMENT OF THE HOLLERITH
25119C              VECTOR IBOPPA(.).
25120C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
25121C                     --IARGT  (A HOLLERITH VECTOR)
25122C                     --IARG   (A HOLLERITH VECTOR)
25123C                     --NUMARG
25124C                     --IDEFPA
25125C                     --MAXBOX
25126C     OUTPUT ARGUMENTS--IBOPPA (A HOLLERITH VECTOR
25127C                              WHOSE I-TH ELEMENT CONTAINS THE
25128C                              PATTERN FOR BOX I.
25129C                     --IFOUND ('YES' OR 'NO' )
25130C                     --IERROR ('YES' OR 'NO' )
25131C     WRITTEN BY--JAMES J. FILLIBEN
25132C                 STATISTICAL ENGINEERING DIVISION
25133C                 INFORMATION TECHNOLOGY LABORATORY
25134C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
25135C                 GAITHERSBURG, MD 20899-8980
25136C                 PHONE--301-975-2855
25137C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25138C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
25139C     LANGUAGE--ANSI FORTRAN (1977)
25140C     VERSION NUMBER--92/8
25141C     ORIGINAL VERSION--AUGUST    1992.
25142C     UPDATED         --AUGUST    1995.  DASH2 BUG
25143C
25144C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25145C
25146      CHARACTER*4 IHARG
25147      CHARACTER*4 IHARG2
25148      CHARACTER*4 IARGT
25149      CHARACTER*4 IDEFPA
25150      CHARACTER*4 IBOPPA
25151      CHARACTER*4 IFOUND
25152      CHARACTER*4 IERROR
25153C
25154      CHARACTER*4 IHOLD
25155C
25156C---------------------------------------------------------------------
25157C
25158      DIMENSION IHARG(*)
25159      DIMENSION IHARG2(*)
25160      DIMENSION IARGT(*)
25161      DIMENSION IARG(*)
25162      DIMENSION IBOPPA(*)
25163C
25164C---------------------------------------------------------------------
25165C
25166      INCLUDE 'DPCOP2.INC'
25167C
25168C-----START POINT-----------------------------------------------------
25169C
25170      IFOUND='NO'
25171      IERROR='NO'
25172C
25173      IF(NUMARG.EQ.0)GOTO1199
25174      IF(NUMARG.GE.2.AND.IHARG(1).EQ.'FILL'.AND.
25175     1   IHARG(2).EQ.'LINE')THEN
25176        IF(NUMARG.LE.2 .OR. IHARG(3).EQ.'AUTO' .OR.
25177     1     IHARG(3).EQ.'DEFA')THEN
25178          IHOLD=IDEFPA
25179        ELSEIF(IHARG(3).EQ.'ON' .OR. IHARG(3).EQ.'SOLI')THEN
25180          IHOLD='SOLI'
25181        ELSEIF(IHARG(3).EQ.'EMPT' .OR. IHARG(3).EQ.'OFF' .OR.
25182     1         IHARG(3).EQ.'BLAN' .OR. IHARG(3).EQ.'NONE' .OR.
25183     1         IHARG(3).EQ.'HOLL')THEN
25184          IHOLD='BLAN'
25185        ELSE
25186          IHOLD=IHARG(3)
25187          IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'2')IHOLD='DA2'
25188          IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'3')IHOLD='DA3'
25189          IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'4')IHOLD='DA4'
25190          IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'5')IHOLD='DA5'
25191          IF(IHOLD.EQ.'DOTT')IHOLD='DOTT'
25192        ENDIF
25193C
25194        IFOUND='YES'
25195        DO1135I=1,MAXBOX
25196          IBOPPA(I)=IHOLD
25197 1135   CONTINUE
25198        IF(IFEEDB.EQ.'ON')THEN
25199          WRITE(ICOUT,999)
25200  999     FORMAT(1X)
25201          CALL DPWRST('XXX','BUG ')
25202          I=1
25203          WRITE(ICOUT,1136)IBOPPA(I)
25204 1136     FORMAT('ALL BOX FILL LINES HAVE JUST BEEN SET TO ',A4)
25205          CALL DPWRST('XXX','BUG ')
25206          GOTO1199
25207        ENDIF
25208      ELSEIF(NUMARG.GE.3.AND.IHARG(2).EQ.'FILL'.AND.
25209     1       IHARG(3).EQ.'LINE')THEN
25210        IF(IARGT(1).NE.'NUMB')THEN
25211          IERROR='YES'
25212          WRITE(ICOUT,999)
25213          CALL DPWRST('XXX','BUG ')
25214          WRITE(ICOUT,1141)
25215 1141     FORMAT('***** ERROR IN BOX FILL LINE PATTERN (DPBOFL)--')
25216          CALL DPWRST('XXX','BUG ')
25217          WRITE(ICOUT,1142)
25218 1142     FORMAT('      IN THE BOX ... FILL LINE COMMAND,')
25219          CALL DPWRST('XXX','BUG ')
25220          WRITE(ICOUT,1143)
25221 1143     FORMAT('      THE BOX IS IDENTIFIED BY A NUMBER, AS IN--')
25222          CALL DPWRST('XXX','BUG ')
25223          WRITE(ICOUT,1144)
25224 1144     FORMAT('      BOX 3 FILL LINE ON')
25225          CALL DPWRST('XXX','BUG ')
25226          GOTO1199
25227        ENDIF
25228C
25229        I=IARG(1)
25230        IF(I.LT.1 .OR. I.GT.MAXBOX)THEN
25231          IERROR='YES'
25232          WRITE(ICOUT,999)
25233          CALL DPWRST('XXX','BUG ')
25234          WRITE(ICOUT,1141)
25235          CALL DPWRST('XXX','BUG ')
25236          WRITE(ICOUT,1142)
25237          CALL DPWRST('XXX','BUG ')
25238          WRITE(ICOUT,1153)
25239 1153     FORMAT('      THE NUMBER OF BOXES MUST BE ')
25240          CALL DPWRST('XXX','BUG ')
25241          WRITE(ICOUT,1154)MAXBOX
25242 1154     FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
25243          CALL DPWRST('XXX','BUG ')
25244          WRITE(ICOUT,1155)
25245 1155     FORMAT('      SUCH WAS NOT THE CASE HERE--')
25246          CALL DPWRST('XXX','BUG ')
25247          WRITE(ICOUT,1156)I
25248 1156     FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
25249     1           'BOX.')
25250          CALL DPWRST('XXX','BUG ')
25251          GOTO1199
25252        ENDIF
25253C
25254        IF(NUMARG.LE.3 .OR. IHARG(4).EQ.'AUTO' .OR.
25255     1     IHARG(4).EQ.'DEFA')THEN
25256          IHOLD=IDEFPA
25257        ELSEIF(IHARG(4).EQ.'ON' .OR. IHARG(4).EQ.'SOLI')THEN
25258          IHOLD='SOLI'
25259        ELSEIF(IHARG(4).EQ.'OFF' .OR. IHARG(4).EQ.'EMPT' .OR.
25260     1         IHARG(4).EQ.'BLAN' .OR. IHARG(4).EQ.'NONE' .OR.
25261     1         IHARG(4).EQ.'HOLL')THEN
25262          IHOLD='BLAN'
25263        ELSE
25264          IHOLD=IHARG(4)
25265          IF(IHOLD.EQ.'DASH'.AND.IHARG2(4).EQ.'2')IHOLD='DA2'
25266          IF(IHOLD.EQ.'DASH'.AND.IHARG2(4).EQ.'3')IHOLD='DA3'
25267          IF(IHOLD.EQ.'DASH'.AND.IHARG2(4).EQ.'4')IHOLD='DA4'
25268          IF(IHOLD.EQ.'DASH'.AND.IHARG2(4).EQ.'5')IHOLD='DA5'
25269          IF(IHOLD.EQ.'DASH'.AND.IHARG2(4).EQ.'5')IHOLD='DOTT'
25270          IF(IHOLD.EQ.'DOTT')IHOLD='DOTT'
25271        ENDIF
25272C
25273        IFOUND='YES'
25274        IBOPPA(I)=IHOLD
25275        IF(IFEEDB.EQ.'ON')THEN
25276          WRITE(ICOUT,999)
25277          CALL DPWRST('XXX','BUG ')
25278          WRITE(ICOUT,1186)I,IBOPPA(I)
25279 1186     FORMAT('THE FILL LINE FOR BOX ',I8,
25280     1           ' HAS JUST BEEN SET TO ',A4)
25281          CALL DPWRST('XXX','BUG ')
25282          GOTO1199
25283        ENDIF
25284      ENDIF
25285C
25286 1199 CONTINUE
25287      RETURN
25288      END
25289      SUBROUTINE DPBOPA(IHARG,IHARG2,IARGT,IARG,NUMARG,IDEFPA,
25290     1                  MAXBOX,IBOFPA,IFOUND,IERROR)
25291C
25292C     PURPOSE--DEFINE THE LINE TYPE FOR THE BORDER BOX.
25293C              THE PATTERN FOR BOX I WILL BE PLACED
25294C              IN THE I-TH ELEMENT OF THE HOLLERITH
25295C              VECTOR IBOFPA(.).
25296C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
25297C                     --IARGT  (A HOLLERITH VECTOR)
25298C                     --IARG   (A HOLLERITH VECTOR)
25299C                     --NUMARG
25300C                     --IDEFPA
25301C                     --MAXBOX
25302C     OUTPUT ARGUMENTS--IBOFPA (A HOLLERITH VECTOR
25303C                              WHOSE I-TH ELEMENT CONTAINS THE
25304C                              PATTERN FOR BOX I.
25305C                     --IFOUND ('YES' OR 'NO' )
25306C                     --IERROR ('YES' OR 'NO' )
25307C     WRITTEN BY--JAMES J. FILLIBEN
25308C                 STATISTICAL ENGINEERING DIVISION
25309C                 INFORMATION TECHNOLOGY LABORATORY
25310C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
25311C                 GAITHERSBURG, MD 20899-8980
25312C                 PHONE--301-975-2855
25313C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25314C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
25315C     LANGUAGE--ANSI FORTRAN (1977)
25316C     VERSION NUMBER--82/7
25317C     ORIGINAL VERSION--SEPTEMBER 1980.
25318C     UPDATED         --MAY       1982.
25319C     UPDATED         --AUGUST    1992.  FORMAT STATEMENTS
25320C     UPDATED         --AUGUST    1995.  DASH2 BUG
25321C
25322C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25323C
25324      CHARACTER*4 IHARG
25325CCCCC AUGUST 1995.  ADD FOLLOWING LINE
25326      CHARACTER*4 IHARG2
25327      CHARACTER*4 IARGT
25328      CHARACTER*4 IDEFPA
25329      CHARACTER*4 IBOFPA
25330      CHARACTER*4 IFOUND
25331      CHARACTER*4 IERROR
25332C
25333      CHARACTER*4 IHOLD
25334C
25335C---------------------------------------------------------------------
25336C
25337      DIMENSION IHARG(*)
25338      DIMENSION IHARG2(*)
25339      DIMENSION IARGT(*)
25340      DIMENSION IARG(*)
25341      DIMENSION IBOFPA(*)
25342C
25343C---------------------------------------------------------------------
25344C
25345      INCLUDE 'DPCOP2.INC'
25346C
25347C-----START POINT-----------------------------------------------------
25348C
25349      IFOUND='NO'
25350      IERROR='NO'
25351C
25352      IF(NUMARG.EQ.0)GOTO1199
25353      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'PATT')THEN
25354        IF(NUMARG.LE.1 .OR. IHARG(2).EQ.'ON' .OR.
25355     1     IHARG(2).EQ.'OFF' .OR. IHARG(2).EQ.'AUTO' .OR.
25356     1     IHARG(2).EQ.'DEFA')THEN
25357          IHOLD=IDEFPA
25358        ELSE
25359          IHOLD=IHARG(2)
25360          IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'2')IHOLD='DA2'
25361          IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'3')IHOLD='DA3'
25362          IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'4')IHOLD='DA4'
25363          IF(IHOLD.EQ.'DASH'.AND.IHARG2(2).EQ.'5')IHOLD='DA5'
25364          IF(IHOLD.EQ.'DOTT')IHOLD='DOTT'
25365        ENDIF
25366C
25367        IFOUND='YES'
25368        DO1135I=1,MAXBOX
25369          IBOFPA(I)=IHOLD
25370 1135   CONTINUE
25371        IF(IFEEDB.EQ.'ON')THEN
25372          WRITE(ICOUT,999)
25373  999     FORMAT(1X)
25374          CALL DPWRST('XXX','BUG ')
25375          I=1
25376          WRITE(ICOUT,1136)IBOFPA(I)
25377          CALL DPWRST('XXX','BUG ')
25378 1136     FORMAT('ALL BOX BORDER PATTERNS HAVE JUST BEEN SET TO ',A4)
25379          GOTO1199
25380        ENDIF
25381      ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'PATT')THEN
25382        IF(IARGT(1).NE.'NUMB')THEN
25383          IERROR='YES'
25384          WRITE(ICOUT,999)
25385          CALL DPWRST('XXX','BUG ')
25386          WRITE(ICOUT,1141)
25387 1141     FORMAT('***** ERROR IN BOX PATTERN (DPBOPA)--')
25388          CALL DPWRST('XXX','BUG ')
25389          WRITE(ICOUT,1142)
25390 1142     FORMAT('      IN THE BOX ... PATTERN COMMAND,')
25391          CALL DPWRST('XXX','BUG ')
25392          WRITE(ICOUT,1143)
25393 1143     FORMAT('      THE BOX IS IDENTIFIED BY A NUMBER, AS IN--')
25394          CALL DPWRST('XXX','BUG ')
25395          WRITE(ICOUT,1144)
25396 1144     FORMAT('      BOX 3 PATTERN SOLID')
25397          CALL DPWRST('XXX','BUG ')
25398          GOTO1199
25399        ENDIF
25400C
25401        I=IARG(1)
25402        IF(I.LT.1 .OR. I.GT.MAXBOX)THEN
25403          IERROR='YES'
25404          WRITE(ICOUT,999)
25405          CALL DPWRST('XXX','BUG ')
25406          WRITE(ICOUT,1141)
25407          CALL DPWRST('XXX','BUG ')
25408          WRITE(ICOUT,1142)
25409          CALL DPWRST('XXX','BUG ')
25410          WRITE(ICOUT,1153)
25411 1153     FORMAT('      THE NUMBER OF BOXES MUST BE ')
25412          CALL DPWRST('XXX','BUG ')
25413          WRITE(ICOUT,1154)MAXBOX
25414 1154     FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
25415          CALL DPWRST('XXX','BUG ')
25416          WRITE(ICOUT,1155)
25417 1155     FORMAT('      SUCH WAS NOT THE CASE HERE--')
25418          CALL DPWRST('XXX','BUG ')
25419          WRITE(ICOUT,1156)I
25420 1156     FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
25421     1           'BOX.')
25422          CALL DPWRST('XXX','BUG ')
25423          GOTO1199
25424        ENDIF
25425C
25426        IF(NUMARG.LE.2 .OR. IHARG(3).EQ.'ON' .OR.
25427     1     IHARG(3).EQ.'OFF' .OR. IHARG(3).EQ.'AUTO' .OR.
25428     1     IHARG(3).EQ.'DEFA')THEN
25429          IHOLD=IDEFPA
25430        ELSE
25431          IHOLD=IHARG(3)
25432          IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'2')IHOLD='DA2'
25433          IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'3')IHOLD='DA3'
25434          IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'4')IHOLD='DA4'
25435          IF(IHOLD.EQ.'DASH'.AND.IHARG2(3).EQ.'5')IHOLD='DA5'
25436          IF(IHOLD.EQ.'DOTT')IHOLD='DOTT'
25437        ENDIF
25438C
25439        IFOUND='YES'
25440        IBOFPA(I)=IHOLD
25441        IF(IFEEDB.EQ.'ON')THEN
25442          WRITE(ICOUT,999)
25443          CALL DPWRST('XXX','BUG ')
25444          WRITE(ICOUT,1186)I,IBOFPA(I)
25445          CALL DPWRST('XXX','BUG ')
25446 1186     FORMAT('THE BORDER PATTERN FOR BOX ',I8,
25447     1           ' HAS JUST BEEN SET TO ',A4)
25448          GOTO1199
25449        ENDIF
25450      ENDIF
25451C
25452 1199 CONTINUE
25453      RETURN
25454      END
25455      SUBROUTINE DPBOSS(IHARG,IARGT,IARG,NUMARG,
25456     1IBOOSS,IDEBOO,IFOUND,IERROR)
25457C
25458C     PURPOSE--DEFINE THE BOOTSTRAP SAMPLE SIZE
25459C              THE SPECIFIED BOOTSTRAP SAMPLE SIZE WILL BE PLACED
25460C              IN THE INTEGER VARIABLE    IBOOSS
25461C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
25462C                     --IARGT  (A  HOLLERITH VECTOR)
25463C                     --IARG    (AN INTEGER VECTOR)
25464C                     --NUMARG (AN INTEGER VARIABLE)
25465C     OUTPUT ARGUMENTS--IBOOSS (AN INTEGER VARIABLE)
25466C                     --IFOUND ('YES' OR 'NO' )
25467C                     --IERROR ('YES' OR 'NO' )
25468C     WRITTEN BY--JAMES J. FILLIBEN
25469C                 STATISTICAL ENGINEERING DIVISION
25470C                 INFORMATION TECHNOLOGY LABORATORY
25471C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
25472C                 GAITHERSBURG, MD 20899-8980
25473C                 PHONE--301-975-2855
25474C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25475C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
25476C     LANGUAGE--ANSI FORTRAN (1977)
25477C     VERSION NUMBER--89/2
25478C     ORIGINAL VERSION--JANUARY   1989.
25479C
25480C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25481C
25482      CHARACTER*4 IHARG
25483      CHARACTER*4 IARGT
25484      CHARACTER*4 IFOUND
25485      CHARACTER*4 IERROR
25486C
25487C---------------------------------------------------------------------
25488C
25489      DIMENSION IHARG(*)
25490      DIMENSION IARGT(*)
25491      DIMENSION IARG(*)
25492C
25493C---------------------------------------------------------------------
25494C
25495      INCLUDE 'DPCOP2.INC'
25496C
25497C-----START POINT-----------------------------------------------------
25498C
25499      IFOUND='NO'
25500      IERROR='NO'
25501C
25502      IF(NUMARG.EQ.0)GOTO1199
25503      IF(NUMARG.GE.2.AND.IHARG(2).EQ.'=')GOTO1199
25504      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SAMP')GOTO1110
25505      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'SIZE')GOTO1110
25506      GOTO1199
25507C
25508 1110 CONTINUE
25509      IF(IHARG(NUMARG).EQ.'SAMP')GOTO1150
25510      IF(IHARG(NUMARG).EQ.'SIZE')GOTO1150
25511      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
25512      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
25513      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
25514      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
25515      IF(IARGT(NUMARG).EQ.'NUMB')GOTO1160
25516      GOTO1120
25517C
25518 1120 CONTINUE
25519      IERROR='YES'
25520      WRITE(ICOUT,1121)
25521 1121 FORMAT('***** ERROR IN DPBOSS--')
25522      CALL DPWRST('XXX','BUG ')
25523      WRITE(ICOUT,1122)
25524 1122 FORMAT('      ILLEGAL FORM FOR BOOTSTRAP SAMPLE SIZE ',
25525     1'COMMAND.')
25526      CALL DPWRST('XXX','BUG ')
25527      WRITE(ICOUT,1124)
25528 1124 FORMAT('      EXAMPLES OF ALLOWABLE FORMS--')
25529      CALL DPWRST('XXX','BUG ')
25530      WRITE(ICOUT,1131)
25531 1131 FORMAT('          BOOTSTRAP SAMPLE SIZE 200')
25532      CALL DPWRST('XXX','BUG ')
25533      WRITE(ICOUT,1132)
25534 1132 FORMAT('          BOOTSTRAP SIZE 50')
25535      CALL DPWRST('XXX','BUG ')
25536      WRITE(ICOUT,1133)IDEBOO
25537 1133 FORMAT('      THE DEFAULT BOOTSTRAP SAMPLE SIZE ',
25538     1'IS ',I8)
25539      CALL DPWRST('XXX','BUG ')
25540      GOTO1199
25541C
25542 1150 CONTINUE
25543      IHOLD=IDEBOO
25544      GOTO1180
25545C
25546 1160 CONTINUE
25547      IHOLD=IARG(NUMARG)
25548      GOTO1180
25549C
25550 1180 CONTINUE
25551      IFOUND='YES'
25552      IBOOSS=IHOLD
25553C
25554      IF(IFEEDB.EQ.'OFF')GOTO1189
25555      WRITE(ICOUT,999)
25556  999 FORMAT(1X)
25557      CALL DPWRST('XXX','BUG ')
25558      WRITE(ICOUT,1181)IBOOSS
25559 1181 FORMAT('THE BOOTSTRAP SAMPLE SIZE HAS JUST BEEN SET TO ',
25560     1I8)
25561      CALL DPWRST('XXX','BUG ')
25562 1189 CONTINUE
25563      GOTO1199
25564C
25565 1199 CONTINUE
25566      RETURN
25567      END
25568      SUBROUTINE DPBOTH(IHARG,IARGT,IARG,ARG,NUMARG,PDEFTH,
25569     1                  MAXBOX,PBOFTH,IFOUND,IERROR)
25570C
25571C     PURPOSE--DEFINE THE THICKNESS FOR A BOX.
25572C              THE THICKNESS FOR A BOX IS THE THICKNESS
25573C              OF THE BORDER REGION OF THE BOX.
25574C              THE THICKNESS FOR BOX I WILL BE PLACED
25575C              IN THE I-TH ELEMENT OF THE REAL
25576C              VECTOR PBOFTH(.).
25577C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
25578C                     --IARGT  (A HOLLERITH VECTOR)
25579C                     --IARG   (A HOLLERITH VECTOR)
25580C                     --ARG    (A REAL VECTOR)
25581C                     --NUMARG
25582C                     --PDEFTH
25583C                     --MAXBOX
25584C     OUTPUT ARGUMENTS--PBOFTH (A REAL VECTOR
25585C                              WHOSE I-TH ELEMENT CONTAINS THE
25586C                              THICKNESS FOR BOX I.
25587C                     --IFOUND ('YES' OR 'NO' )
25588C                     --IERROR ('YES' OR 'NO' )
25589C     WRITTEN BY--JAMES J. FILLIBEN
25590C                 STATISTICAL ENGINEERING DIVISION
25591C                 INFORMATION TECHNOLOGY LABORATORY
25592C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
25593C                 GAITHERSBURG, MD 20899-8980
25594C                 PHONE--301-975-2855
25595C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25596C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
25597C     LANGUAGE--ANSI FORTRAN (1977)
25598C     VERSION NUMBER--82/7
25599C     ORIGINAL VERSION--SEPTEMBER 1980.
25600C     UPDATED         --MAY       1982.
25601C     UPDATED         --AUGUST    1992.  FORMAT STATEMENTS
25602C
25603C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25604C
25605      CHARACTER*4 IHARG
25606      CHARACTER*4 IARGT
25607      REAL        PDEFTH
25608      REAL        PBOFTH
25609      CHARACTER*4 IFOUND
25610      CHARACTER*4 IERROR
25611C
25612      REAL        PHOLD
25613C
25614C---------------------------------------------------------------------
25615C
25616      DIMENSION IHARG(*)
25617      DIMENSION IARGT(*)
25618      DIMENSION IARG(*)
25619      DIMENSION ARG(*)
25620      DIMENSION PBOFTH(*)
25621C
25622C---------------------------------------------------------------------
25623C
25624      INCLUDE 'DPCOP2.INC'
25625C
25626C-----START POINT-----------------------------------------------------
25627C
25628      IFOUND='NO'
25629      IERROR='NO'
25630C
25631      IF(NUMARG.EQ.0)GOTO1199
25632      IF(NUMARG.GE.1.AND.IHARG(1).EQ.'THIC')THEN
25633        IF(NUMARG.LE.1 .OR. IHARG(2).EQ.'ON' .OR.
25634     1     IHARG(2).EQ.'OFF' .OR. IHARG(2).EQ.'AUTO' .OR.
25635     1     IHARG(2).EQ.'DEFA')THEN
25636          PHOLD=PDEFTH
25637        ELSE
25638          PHOLD=ARG(2)
25639        ENDIF
25640C
25641        IFOUND='YES'
25642        DO1135I=1,MAXBOX
25643          PBOFTH(I)=PHOLD
25644 1135   CONTINUE
25645        IF(IFEEDB.EQ.'ON')THEN
25646          WRITE(ICOUT,999)
25647  999     FORMAT(1X)
25648          CALL DPWRST('XXX','BUG ')
25649          I=1
25650          WRITE(ICOUT,1136)PBOFTH(I)
25651          CALL DPWRST('XXX','BUG ')
25652 1136     FORMAT('ALL BOX BORDER THICKNESSS HAVE JUST BEEN SET TO ',
25653     1           E15.7)
25654          GOTO1199
25655        ENDIF
25656      ELSEIF(NUMARG.GE.2.AND.IHARG(2).EQ.'THIC')THEN
25657        IF(IARGT(1).NE.'NUMB')THEN
25658          IERROR='YES'
25659          WRITE(ICOUT,999)
25660          CALL DPWRST('XXX','BUG ')
25661          WRITE(ICOUT,1141)
25662 1141     FORMAT('***** ERROR IN BOX THICKNESS (DPBOTH)--')
25663          CALL DPWRST('XXX','BUG ')
25664          WRITE(ICOUT,1142)
25665 1142     FORMAT('      IN THE BOX ... THICKNESS COMMAND,')
25666          CALL DPWRST('XXX','BUG ')
25667          WRITE(ICOUT,1143)
25668 1143     FORMAT('      THE BOX IS IDENTIFIED BY A NUMBER, AS IN--')
25669          CALL DPWRST('XXX','BUG ')
25670          WRITE(ICOUT,1144)
25671 1144     FORMAT('      BOX 3 THICKNESS 0.3')
25672          CALL DPWRST('XXX','BUG ')
25673          GOTO1199
25674        ENDIF
25675C
25676        I=IARG(1)
25677        IF(I.LT.1 .OR. I.GT.MAXBOX)THEN
25678          IERROR='YES'
25679          WRITE(ICOUT,999)
25680          CALL DPWRST('XXX','BUG ')
25681          WRITE(ICOUT,1141)
25682          CALL DPWRST('XXX','BUG ')
25683          WRITE(ICOUT,1152)
25684 1152     FORMAT('      IN THE BOX ... THICKNESS COMMAND,')
25685          CALL DPWRST('XXX','BUG ')
25686          WRITE(ICOUT,1153)
25687 1153     FORMAT('      THE NUMBER OF BOXES MUST BE ')
25688          CALL DPWRST('XXX','BUG ')
25689          WRITE(ICOUT,1154)MAXBOX
25690 1154     FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
25691          CALL DPWRST('XXX','BUG ')
25692          WRITE(ICOUT,1155)
25693 1155     FORMAT('      SUCH WAS NOT THE CASE HERE--')
25694          CALL DPWRST('XXX','BUG ')
25695          WRITE(ICOUT,1156)I
25696 1156     FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
25697     1           'BOX.')
25698          CALL DPWRST('XXX','BUG ')
25699          GOTO1199
25700        ENDIF
25701C
25702        IF(NUMARG.LE.2 .OR. IHARG(3).EQ.'ON' .OR.
25703     1     IHARG(3).EQ.'OFF' .OR.  IHARG(3).EQ.'AUTO' .OR.
25704     1     IHARG(3).EQ.'DEFA')THEN
25705          PHOLD=PDEFTH
25706        ELSE
25707          PHOLD=ARG(3)
25708        ENDIF
25709C
25710        IFOUND='YES'
25711        PBOFTH(I)=PHOLD
25712        IF(IFEEDB.EQ.'ON')THEN
25713          WRITE(ICOUT,999)
25714          CALL DPWRST('XXX','BUG ')
25715          WRITE(ICOUT,1186)I,PBOFTH(I)
25716          CALL DPWRST('XXX','BUG ')
25717 1186     FORMAT('THE BORDER THICKNESS FOR BOX ',I8,
25718     1           ' HAS JUST BEEN SET TO ',E15.7)
25719          GOTO1199
25720        ENDIF
25721      ENDIF
25722C
25723 1199 CONTINUE
25724      RETURN
25725      END
25726      SUBROUTINE DPBOX(NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2,
25727     1                 ICONT,IFENCE,
25728     1                 IBUGG2,IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
25729C
25730C     PURPOSE--GENERATE ONE OF THE FOLLOWING 2 BOX PLOTS--
25731C              1) MEDIAN;
25732C              2) MEAN;
25733C     WRITTEN BY--JAMES J. FILLIBEN
25734C                 STATISTICAL ENGINEERING DIVISION
25735C                 INFORMATION TECHNOLOGY LABORATORY
25736C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
25737C                 GAITHERSBURG, MD 20899-8980
25738C                 PHONE--301-975-2855
25739C     REFERENCE--WALKER, DOVOEDO, CHAKRABORTI, AND HILTON (2019),
25740C                "AN IMPROVED BOXPLOT FOR UNIVARIATE DATA",
25741C                AMERICAN STATISTICIAN, VOL. 72, NO. 4, PP. 348-353.
25742C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
25743C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
25744C     LANGUAGE--ANSI FORTRAN (1977)
25745C     VERSION NUMBER--82/7
25746C     ORIGINAL VERSION--JANUARY   1981.
25747C     UPDATED         --AUGUST    1981.
25748C     UPDATED         --MAY       1982.
25749C     UPDATED         --MARCH     2002. SUPPORT FOR FIXED WIDTH BOX PLOT
25750C     UPDATED         --JUNE      2010. USE DPPARS AND DPPAR3 TO PERFORM
25751C                                       THE COMMAND PARSING
25752C     UPDATED         --JUNE      2010. SUPPORT FOR "MULTIPLE" CASE
25753C     UPDATED         --JUNE      2010. SUPPORT FOR TWO GROUP-ID VARIABLES
25754C     UPDATED         --JUNE      2016. DON'T STACK FOR MULTIPLE CASE IF
25755C                                       4 OR FEWER VARIABLES
25756C     UPDATED         --JUNE      2016. HANDLE DEGENERATE CASE (I.E.,
25757C                                       WHERE SD IS 0 (N = 1 OR WHEN
25758C                                       ALL VALUES ARE EQUAL))
25759C     UPDATED         --JUNE      2016. OPTION TO DRAW LINE AT 1, 5, 10,
25760C                                       90, 95, 99 PERCENTILE VALUES
25761C
25762C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
25763C
25764      CHARACTER*4 ICASPL
25765      CHARACTER*4 IAND1
25766      CHARACTER*4 IAND2
25767      CHARACTER*4 ICONT
25768      CHARACTER*4 IFENCE
25769      CHARACTER*4 IBUGG2
25770      CHARACTER*4 IBUGG3
25771      CHARACTER*4 IBUGQ
25772      CHARACTER*4 ISUBRO
25773      CHARACTER*4 IFOUND
25774      CHARACTER*4 IERROR
25775      CHARACTER*4 IFOUN1
25776      CHARACTER*4 IFOUN2
25777      CHARACTER*4 IWRITE
25778C
25779      CHARACTER*4 IREPL
25780      CHARACTER*4 IMULT
25781C
25782      CHARACTER*40 INAME
25783      PARAMETER (MAXSPN=30)
25784      CHARACTER*4 IVARN1(MAXSPN)
25785      CHARACTER*4 IVARN2(MAXSPN)
25786      CHARACTER*4 IVARTY(MAXSPN)
25787      REAL PVAR(MAXSPN)
25788      INTEGER ILIS(MAXSPN)
25789      INTEGER NRIGHT(MAXSPN)
25790      INTEGER ICOLR(MAXSPN)
25791C
25792      CHARACTER*4 ICASE
25793      CHARACTER*4 ISUBN1
25794      CHARACTER*4 ISUBN2
25795      CHARACTER*4 ISTEPN
25796C
25797C---------------------------------------------------------------------
25798C
25799      INCLUDE 'DPCOPA.INC'
25800C
25801      DIMENSION Y1(MAXOBV)
25802      DIMENSION X1(MAXOBV)
25803      DIMENSION X2(MAXOBV)
25804      DIMENSION X3(MAXOBV)
25805      DIMENSION X4(MAXOBV)
25806      DIMENSION X5(MAXOBV)
25807      DIMENSION X6(MAXOBV)
25808      DIMENSION XTEMP1(MAXOBV)
25809      DIMENSION XTEMP2(MAXOBV)
25810      DIMENSION XTEMP3(MAXOBV)
25811      DIMENSION XTEMP4(MAXOBV)
25812      DIMENSION XTEMP5(MAXOBV)
25813      DIMENSION XTEMP6(MAXOBV)
25814      DIMENSION XTEMP0(MAXOBV)
25815C
25816      DIMENSION XIDTEM(MAXOBV)
25817      INCLUDE 'DPCOZZ.INC'
25818      EQUIVALENCE (GARBAG(IGARB1),Y1(1))
25819      EQUIVALENCE (GARBAG(IGARB2),X1(1))
25820      EQUIVALENCE (GARBAG(IGARB3),X2(1))
25821      EQUIVALENCE (GARBAG(IGARB4),X3(1))
25822      EQUIVALENCE (GARBAG(IGARB5),X4(1))
25823      EQUIVALENCE (GARBAG(IGARB6),X5(1))
25824      EQUIVALENCE (GARBAG(IGARB7),X6(1))
25825      EQUIVALENCE (GARBAG(IGARB8),XIDTEM(1))
25826      EQUIVALENCE (GARBAG(IGARB9),XTEMP1(1))
25827      EQUIVALENCE (GARBAG(IGAR10),XTEMP2(1))
25828      EQUIVALENCE (GARBAG(JGAR11),XTEMP3(1))
25829      EQUIVALENCE (GARBAG(JGAR12),XTEMP4(1))
25830      EQUIVALENCE (GARBAG(JGAR13),XTEMP5(1))
25831      EQUIVALENCE (GARBAG(JGAR14),XTEMP6(1))
25832      EQUIVALENCE (GARBAG(JGAR15),XTEMP0(1))
25833C
25834C-----COMMON----------------------------------------------------------
25835C
25836      INCLUDE 'DPCOHK.INC'
25837      INCLUDE 'DPCODA.INC'
25838      INCLUDE 'DPCOST.INC'
25839C
25840C-----COMMON VARIABLES (GENERAL)--------------------------------------
25841C
25842      INCLUDE 'DPCOP2.INC'
25843C
25844C-----START POINT-----------------------------------------------------
25845C
25846      IFOUND='NO'
25847      IERROR='NO'
25848C
25849      ISUBN1='DPBO'
25850      ISUBN2='X   '
25851C
25852      MAXCP1=MAXCOL+1
25853      MAXCP2=MAXCOL+2
25854      MAXCP3=MAXCOL+3
25855      MAXCP4=MAXCOL+4
25856      MAXCP5=MAXCOL+5
25857      MAXCP6=MAXCOL+6
25858C
25859C               *******************************
25860C               **  TREAT THE BOX PLOT CASE  **
25861C               *******************************
25862C
25863      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PBOX')THEN
25864        WRITE(ICOUT,999)
25865  999   FORMAT(1X)
25866        CALL DPWRST('XXX','BUG ')
25867        WRITE(ICOUT,51)
25868   51   FORMAT('***** AT THE BEGINNING OF DPBOX--')
25869        CALL DPWRST('XXX','BUG ')
25870        WRITE(ICOUT,52)ICASPL,IAND1,IAND2,IFENCE
25871   52   FORMAT('ICASPL,IAND1,IAND2,IFENCE = ',3(A4,2X),A4)
25872        CALL DPWRST('XXX','BUG ')
25873        WRITE(ICOUT,53)ICONT,IBUGG2,IBUGG3,IBUGQ
25874   53   FORMAT('ICONT,IBUGG2,IBUGG3,IBUGQ = ',3(A4,2X),A4)
25875        CALL DPWRST('XXX','BUG ')
25876      ENDIF
25877C
25878C               ******************************************************
25879C               **  STEP 1--                                        **
25880C               **  EXTRACT THE COMMAND                             **
25881C               **  LOOK FOR ONE OF THE FOLLOWING COMMANDS:         **
25882C               **    1) BOX PLOT Y X1 ... X2                       **
25883C               **    2) MULTIPLE BOX PLOT Y1 ... YK                **
25884C               **    3) REPLICATED BOX PLOT Y X1 X2                **
25885C               **  THE "REPLICATION" CASE IS ACTUALLY THE DEFAULT  **
25886C               **  AND THE KEYWORD "REPLICATION" IS OPTIONAL.      **
25887C               **  HOWEVER, SUPPORT IT FOR COMPATABILITY WITH      **
25888C               **  OTHER COMMANDS.                                 **
25889C               ******************************************************
25890C
25891      ISTEPN='1'
25892      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PBOX')
25893     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25894C
25895      IF(ICOM.EQ.'BOX')GOTO89
25896      IF(ICOM.EQ.'MULT')GOTO89
25897      IF(ICOM.EQ.'REPL')GOTO89
25898      IF(ICOM.EQ.'MEAN')GOTO89
25899      IF(ICOM.EQ.'MEDI')GOTO89
25900      GOTO9000
25901C
25902   89 CONTINUE
25903      ICASPL='MDBP'
25904      IMULT='OFF'
25905      IREPL='OFF'
25906      ILASTC=-9999
25907C
25908      IF(ICOM.EQ.'BOX' .AND. IHARG(1).NE.'COX')THEN
25909        IFOUN1='YES'
25910      ELSEIF(ICOM.EQ.'MULT')THEN
25911        IMULT='ON'
25912      ELSEIF(ICOM.EQ.'REPL')THEN
25913        IREPL='ON'
25914      ENDIF
25915C
25916      ISTOP=NUMARG-1
25917      DO90I=1,NUMARG
25918        IF(IHARG(I).EQ.'PLOT')THEN
25919          ISTOP=I
25920          IFOUN2='YES'
25921          GOTO99
25922        ENDIF
25923   90 CONTINUE
25924   99 CONTINUE
25925C
25926      IFOUND='NO'
25927      DO100I=1,ISTOP
25928        IF(IHARG(I).EQ.'=')THEN
25929          IFOUND='NO'
25930          GOTO9000
25931        ELSEIF(IHARG(I).EQ.'BOX' .AND. IHARG(I+1).NE.'COX')THEN
25932          IFOUN1='YES'
25933          ILASTC=MAX(ILASTC,I)
25934        ELSEIF(IHARG(I).EQ.'PLOT')THEN
25935          IFOUN2='YES'
25936          ILASTC=MAX(ILASTC,I)
25937        ELSEIF(IHARG(I).EQ.'MEDI')THEN
25938          ICASPL='MDBP'
25939        ELSEIF(IHARG(I).EQ.'MEAN')THEN
25940          ICASPL='MEBP'
25941        ELSEIF(IHARG(I).EQ.'REPL')THEN
25942          IREPL='ON'
25943        ELSEIF(IHARG(I).EQ.'MULT')THEN
25944          IMULT='ON'
25945        ELSEIF(IHARG(I).EQ.'COX')THEN
25946          IFOUND='NO'
25947          GOTO9000
25948        ENDIF
25949  100 CONTINUE
25950C
25951      IF(IFOUN1.EQ.'YES' .AND. IFOUN2.EQ.'YES')IFOUND='YES'
25952      IF(IFOUND.EQ.'NO')GOTO9000
25953C
25954      IF(IMULT.EQ.'ON')THEN
25955        IF(IREPL.EQ.'ON')THEN
25956          WRITE(ICOUT,999)
25957          CALL DPWRST('XXX','BUG ')
25958          WRITE(ICOUT,101)
25959  101     FORMAT('***** ERROR IN BOX PLOT--')
25960          CALL DPWRST('XXX','BUG ')
25961          WRITE(ICOUT,107)
25962  107     FORMAT('      YOU CANNOT SPECIFY BOTH "MULTIPLE" AND ',
25963     1           '"REPLICATION" FOR THIS PLOT.')
25964          CALL DPWRST('XXX','BUG ')
25965          IERROR='YES'
25966          GOTO9000
25967        ENDIF
25968      ENDIF
25969C
25970      IF(ILASTC.GE.1)THEN
25971        CALL ADJUST(ILASTC,IHARG,IHARG2,IARG,ARG,IARGT,NUMARG)
25972        ILASTC=0
25973      ENDIF
25974C
25975      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PBOX')THEN
25976        WRITE(ICOUT,112)ICASPL,IMULT,IREPL
25977  112   FORMAT('ICASPL,IMULT,IREPL = ',2(A4,2X),A4)
25978        CALL DPWRST('XXX','BUG ')
25979      ENDIF
25980C
25981C               ****************************************
25982C               **  STEP 2--                          **
25983C               **  EXTRACT THE VARIABLE LIST         **
25984C               ****************************************
25985C
25986      ISTEPN='2'
25987      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PBOX')
25988     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
25989C
25990      INAME='BOX PLOT'
25991      MINNA=1
25992      MAXNA=100
25993      MINN2=1
25994      IFLAGE=1
25995      IF(IMULT.EQ.'ON')THEN
25996        IFLAGE=0
25997      ELSE
25998        IREPL='ON'
25999      ENDIF
26000      IFLAGM=1
26001      IFLAGP=0
26002      JMIN=1
26003      JMAX=NUMARG
26004      MINNVA=1
26005      MAXNVA=2
26006C
26007C     NOTE: NEED TO KEEP "BOX PLOT Y" AS VALID SYNTAX, SO
26008C           MINIMUM NUMBER OF VARIABLES IS 1 EVEN FOR REPLICATION
26009C           CASE.
26010C
26011      IF(IREPL.EQ.'ON')THEN
26012CCCCC   MINNVA=MINNVA+1
26013        MAXNVA=7
26014      ELSEIF(IMULT.EQ.'ON')THEN
26015        MAXNVA=30
26016      ENDIF
26017C
26018      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
26019     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
26020     1            JMIN,JMAX,
26021     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
26022     1            IVARN1,IVARN2,IVARTY,PVAR,
26023     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
26024     1            MINNVA,MAXNVA,
26025     1            IFLAGM,IFLAGP,
26026     1            IBUGG3,IBUGQ,ISUBRO,IFOUND,IERROR)
26027      IF(IERROR.EQ.'YES')GOTO9000
26028C
26029      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PBOX')THEN
26030        WRITE(ICOUT,999)
26031        CALL DPWRST('XXX','BUG ')
26032        WRITE(ICOUT,281)
26033  281   FORMAT('***** AFTER CALL DPPARS--')
26034        CALL DPWRST('XXX','BUG ')
26035        WRITE(ICOUT,282)NQ,NUMVAR
26036  282   FORMAT('NQ,NUMVAR = ',2I8)
26037        CALL DPWRST('XXX','BUG ')
26038        IF(NUMVAR.GT.0)THEN
26039          DO285I=1,NUMVAR
26040            WRITE(ICOUT,287)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
26041     1                      ICOLR(I),IVARTY(I)
26042  287       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
26043     1             'ICOLR(I),IVARTY(I) = ',I8,2X,A4,A4,2X,3I8,2X,A4)
26044            CALL DPWRST('XXX','BUG ')
26045  285     CONTINUE
26046        ENDIF
26047      ENDIF
26048C
26049      NRESP=1
26050C
26051      NREPL=0
26052      IF(IMULT.EQ.'ON')THEN
26053        NRESP=NUMVAR
26054      ELSE
26055        NREPL=NUMVAR-NRESP
26056        IF(NREPL.LT.0 .OR. NREPL.GT.6)THEN
26057          WRITE(ICOUT,999)
26058          CALL DPWRST('XXX','BUG ')
26059          WRITE(ICOUT,101)
26060          CALL DPWRST('XXX','BUG ')
26061          WRITE(ICOUT,511)
26062  511     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
26063     1           'REPLICATION VARIABLES')
26064          CALL DPWRST('XXX','BUG ')
26065          WRITE(ICOUT,512)
26066  512     FORMAT('      MUST BE BETWEEN 0 AND 6;  SUCH WAS NOT THE ',
26067     1           'CASE HERE.')
26068          CALL DPWRST('XXX','BUG ')
26069          WRITE(ICOUT,513)NREPL
26070  513     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
26071          CALL DPWRST('XXX','BUG ')
26072          IERROR='YES'
26073          GOTO9000
26074        ENDIF
26075      ENDIF
26076C
26077      IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PBOX')THEN
26078        ISTEPN='6'
26079        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26080        WRITE(ICOUT,601)NRESP,NREPL
26081  601   FORMAT('NRESP,NREPL = ',2I5)
26082        CALL DPWRST('XXX','BUG ')
26083      ENDIF
26084C
26085C               **************************************************
26086C               **  STEP 7A--                                   **
26087C               **  CASE 1: NO "MULTIPLE" CASE--CAN HAVE EITHER **
26088C               **          1, 2, OR 3 VARIABLES.  THE FIRST    **
26089C               **          VARIABLE IS A RESPONSE VARIABLE     **
26090C               **          AND THE SECOND AND THIRD VARIABLES  **
26091C               **          ARE REPLICATION VARIABLES (IF       **
26092C               **          PRESENT).  NOTE THAT THIS VERSION   **
26093C               **          DOES NOT ACCEPT MATRIX ARGUMENTS    **
26094C               **          EVEN IF ONLY A SINGLE ARGUMENT IS   **
26095C               **          GIVEN (YOU CAN USE THE MULTIPLE     **
26096C               **          OPTION IN THAT CASE).               **
26097C               **************************************************
26098C
26099      IF(IMULT.EQ.'OFF')THEN
26100        ISTEPN='7A'
26101        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PBOX')
26102     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26103C
26104        ICOL=1
26105        CALL DPPAR5(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
26106     1              INAME,IVARN1,IVARN2,IVARTY,
26107     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVAR,
26108     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
26109     1              MAXCP4,MAXCP5,MAXCP6,
26110     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
26111     1              Y1,X1,X2,X3,X4,X5,X6,NLOCAL,
26112     1              IBUGG3,ISUBRO,IFOUND,IERROR)
26113        IF(IERROR.EQ.'YES')GOTO9000
26114C
26115C       IF THERE ARE TWO OR MORE REPLICATION VARIABLES, COMBINE
26116C       THEM TO CREATE A SINGLE REPLICATION VARIABLE.
26117C
26118        IF(NUMVAR.EQ.3)THEN
26119          CALL CODCT2(X1,X2,NLOCAL,ICCTOF,ICCTG1,IWRITE,
26120     1                XTEMP0,XTEMP1,XTEMP2,
26121     1                IBUGG3,ISUBRO,IERROR)
26122          DO7011I=1,NLOCAL
26123            X1(I)=XTEMP0(I)
26124 7011     CONTINUE
26125          NUMVAR=2
26126        ELSEIF(NUMVAR.EQ.4)THEN
26127          CALL CODCT3(X1,X2,X3,NLOCAL,ICCTOF,ICCTG1,ICCTG2,IWRITE,
26128     1                XTEMP0,XTEMP1,XTEMP2,XTEMP3,
26129     1                IBUGG3,ISUBRO,IERROR)
26130          DO7012I=1,NLOCAL
26131            X1(I)=XTEMP0(I)
26132 7012     CONTINUE
26133          NUMVAR=2
26134        ELSEIF(NUMVAR.EQ.5)THEN
26135          CALL CODCT4(X1,X2,X3,X4,NLOCAL,
26136     1                ICCTOF,ICCTG1,ICCTG2,ICCTG3,IWRITE,
26137     1                XTEMP0,XTEMP1,XTEMP2,XTEMP3,XTEMP4,
26138     1                IBUGG3,ISUBRO,IERROR)
26139          DO7013I=1,NLOCAL
26140            X1(I)=XTEMP0(I)
26141 7013     CONTINUE
26142          NUMVAR=2
26143        ELSEIF(NUMVAR.EQ.6)THEN
26144          CALL CODCT5(X1,X2,X3,X4,X5,NLOCAL,
26145     1                ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,IWRITE,
26146     1                XTEMP0,XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,
26147     1                IBUGG3,ISUBRO,IERROR)
26148          DO7014I=1,NLOCAL
26149            X1(I)=XTEMP0(I)
26150 7014     CONTINUE
26151          NUMVAR=2
26152        ELSEIF(NUMVAR.EQ.7)THEN
26153          CALL CODCT6(X1,X2,X3,X4,X5,X6,NLOCAL,
26154     1                ICCTOF,ICCTG1,ICCTG2,ICCTG3,ICCTG4,ICCTG5,IWRITE,
26155     1                XTEMP0,XTEMP1,XTEMP2,XTEMP3,XTEMP4,XTEMP5,XTEMP6,
26156     1                IBUGG3,ISUBRO,IERROR)
26157          DO7015I=1,NLOCAL
26158            X1(I)=XTEMP0(I)
26159 7015     CONTINUE
26160          NUMVAR=2
26161        ENDIF
26162C
26163C               *********************************************************
26164C               **  STEP 7B--                                         **
26165C               **  COMPUTE THE APPROPRIATE BOX PLOT      STATISTIC-- **
26166C               **  (MEDIAN OR MEDAN ).                               **
26167C               **  COMPUTE CONFIDENCE LINES.                         **
26168C               **  FORM THE VERTICAL AND HORIZONTAL AXIS             **
26169C               **  VALUES Y(.) AND X(.) FOR THE PLOT.                **
26170C               **  DEFINE THE VECTOR D(.) TO 1'S, 2'S, AND 3'S       **
26171C               **  FOR THE PLOTTED VALUE, THE LOWER CONFIDENCE LINE, **
26172C               **  AND THE UPPER CONFIDENCE LINE.                    **
26173C               **  DEFINE THE NUMBER OF PLOT POINTS    (NPLOTP).     **
26174C               **  DEFINE THE NUMBER OF PLOT VARIABLES (NPLOTV).     **
26175C               *********************************************************
26176C
26177        CALL DPBOX2(Y1,X1,X2,X3,NLOCAL,NLOCAL,NLOCAL,NLOCAL,NUMVAR,
26178     1              ICASPL,ISIZE,ICONT,MAXOBV,
26179     1              IFENCE,IBXPWI,IBXPDI,IMULT,IBXPSK,
26180     1              XIDTEM,XTEMP1,XTEMP2,
26181     1              Y,X,D,NPLOTP,NPLOTV,
26182     1              IBUGG3,ISUBRO,IERROR)
26183C
26184C               ***********************************************
26185C               **  STEP 8A--                                **
26186C               **  CASE 2: MULTIPLE RESPONSE VARIABLES.     **
26187C               **          THESE CAN BE EITHER VARIABLE OR  **
26188C               **          MATRIX ARGUMENTS.                **
26189C               ***********************************************
26190C
26191      ELSEIF(IMULT.EQ.'ON')THEN
26192        ISTEPN='8A'
26193        IF(IBUGG2.EQ.'ON'.OR.ISUBRO.EQ.'PBOX')
26194     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26195C
26196C       2016/06: IF THERE ARE 4 OR FEWER RESPONSE VARIABLES, THEN
26197C                DON'T STACK.
26198        ICOL=1
26199        NUMVA2=NUMVAR
26200        IF(NUMVA2.GT.4)THEN
26201          CALL DPPAR8(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
26202     1                INAME,IVARN1,IVARN2,IVARTY,
26203     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
26204     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
26205     1                MAXCP4,MAXCP5,MAXCP6,
26206     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
26207     1                XTEMP1,Y1,X1,NLOCAL,ICASE,
26208     1                IBUGG3,ISUBRO,IFOUND,IERROR)
26209          NUMVAR=2
26210          IMULT='OFF'
26211        ELSE
26212          CALL DPPAR7(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
26213     1                INAME,IVARN1,IVARN2,IVARTY,
26214     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
26215     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
26216     1                MAXCP4,MAXCP5,MAXCP6,
26217     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
26218     1                Y1,X1,X2,X3,NLOCAL,NLOCA2,NLOCA3,NLOCA4,
26219     1                IBUGG3,ISUBRO,IFOUND,IERROR)
26220          NUMVAR=NUMVA2
26221        ENDIF
26222        IF(IERROR.EQ.'YES')GOTO9000
26223C
26224C               *****************************************************
26225C               **  STEP 8B--                                      **
26226C               **  FORM THE VERTICAL AND HORIZONTAL AXIS          **
26227C               **  VALUES Y(.) AND X(.) FOR THE PLOT.             **
26228C               *****************************************************
26229C
26230        CALL DPBOX2(Y1,X1,X2,X3,NLOCAL,NLOCA2,NLOCA3,NLOCA4,NUMVAR,
26231     1              ICASPL,ISIZE,ICONT,MAXOBV,
26232     1              IFENCE,IBXPWI,IBXPDI,IMULT,IBXPSK,
26233     1              XIDTEM,XTEMP1,XTEMP2,
26234     1              Y,X,D,NPLOTP,NPLOTV,
26235     1              IBUGG3,ISUBRO,IERROR)
26236      ENDIF
26237C
26238C               *****************
26239C               **  STEP 90--  **
26240C               **  EXIT       **
26241C               *****************
26242C
26243 9000 CONTINUE
26244      IF(IBUGG2.EQ.'ON' .OR. ISUBRO.EQ.'PBOX')THEN
26245        WRITE(ICOUT,999)
26246        CALL DPWRST('XXX','BUG ')
26247        WRITE(ICOUT,9011)
26248 9011   FORMAT('***** AT THE END       OF DPBOX--')
26249        CALL DPWRST('XXX','BUG ')
26250        WRITE(ICOUT,9012)IFOUND,IERROR
26251 9012   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
26252        CALL DPWRST('XXX','BUG ')
26253        WRITE(ICOUT,9013)NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2
26254 9013   FORMAT('NPLOTV,NPLOTP,NS,ICASPL,IAND1,IAND2 = ',
26255     1         I8,I8,I8,2X,A4,2X,A4,2X,A4)
26256        CALL DPWRST('XXX','BUG ')
26257        WRITE(ICOUT,9014)IFENCE,ISIZE
26258 9014   FORMAT('IFENCE,ISIZE = ',A4,I8)
26259        CALL DPWRST('XXX','BUG ')
26260        IF(NPLOTP.GT.0)THEN
26261          DO9015I=1,NPLOTP
26262            WRITE(ICOUT,9016)I,Y(I),X(I),D(I)
26263 9016       FORMAT('I,Y(I),X(I),D(I) = ',I8,3F12.5)
26264            CALL DPWRST('XXX','BUG ')
26265 9015     CONTINUE
26266        ENDIF
26267      ENDIF
26268C
26269      RETURN
26270      END
26271      SUBROUTINE DPBOX2(Y,X,TEMP2,TEMP3,N,N2Z,N3,N4,NUMV2,
26272     1                  ICASPL,ISIZE,ICONT,MAXNXT,
26273     1                  IFENCE,IBXPWI,IBXPDI,IMULT,IBXPSK,
26274     1                  XIDTEM,TEMP,TEMP4,
26275     1                  Y2,X2,D2,N2,NPLOTV,
26276     1                  IBUGG3,ISUBRO,IERROR)
26277C
26278C     PURPOSE--GENERATE A PAIR OF COORDINATE VECTORS
26279C              THAT WILL DEFINE A BOX PLOT
26280C              OF THE FOLLOWING TYPES--
26281C                 1) (MEDIAN) BOX PLOT;
26282C                 2) MEAN BOX PLOT;
26283C     WRITTEN BY--JAMES J. FILLIBEN
26284C                 STATISTICAL ENGINEERING DIVISION
26285C                 INFORMATION TECHNOLOGY LABORATORY
26286C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
26287C                 GAITHERSBURG, MD 20899-8980
26288C                 PHONE--301-975-2855
26289C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
26290C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
26291C     LANGUAGE--ANSI FORTRAN (1977)
26292C     VERSION NUMBER--82/7
26293C     ORIGINAL VERSION--JUNE      1978.
26294C     UPDATED         --OCTOBER   1978.
26295C     UPDATED         --JANUARY   1981.
26296C     UPDATED         --MARCH     1981.
26297C     UPDATED         --DECEMBER  1981.
26298C     UPDATED         --MARCH     1982.
26299C     UPDATED         --MAY       1982.
26300C     UPDATED         --JANUARY   1989. BUG--MULTI-BOX PLOTS W/FENCES (ALAN)
26301C     UPDATED         --MARCH     2002. SUPPORT FIXED WIDTH BOX PLOTS
26302C     UPDATED         --JUNE      2016. FOR MULTIPLE CASE, DO NOT STACK
26303C                                       FOR 4 OR FEWER VARIABLES
26304C     UPDATED         --JUNE      2016. HANDLE DEGENERATE CASE (I.E.,
26305C                                       WHERE SD IS 0 (N = 1 OR WHEN
26306C                                       ALL VALUES ARE EQUAL))
26307C     UPDATED         --JUNE      2016. OPTION TO DRAW LINE AT 1, 5, 10,
26308C                                       90, 95, 99 PERCENTILE VALUES
26309C     UPDATED         --AUGUST    2019. OPTION FOR FENCES FOR SKEWED
26310C                                       BOX PLOT
26311C
26312C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
26313C
26314      CHARACTER*4 ICASPL
26315      CHARACTER*4 ICONT
26316      CHARACTER*4 IFENCE
26317      CHARACTER*4 IBXPWI
26318      CHARACTER*4 IBXPDI
26319      CHARACTER*4 IMULT
26320      CHARACTER*4 IBXPSK
26321      CHARACTER*4 IBUGG3
26322      CHARACTER*4 ISUBRO
26323      CHARACTER*4 IERROR
26324C
26325      CHARACTER*4 ISUBN1
26326      CHARACTER*4 ISUBN2
26327      CHARACTER*4 ISTEPN
26328      CHARACTER*4 ISTACK
26329      CHARACTER*4 IWRITE
26330C
26331C---------------------------------------------------------------------
26332C
26333      DIMENSION Y(*)
26334      DIMENSION X(*)
26335      DIMENSION Y2(*)
26336      DIMENSION X2(*)
26337      DIMENSION D2(*)
26338      DIMENSION XIDTEM(*)
26339      DIMENSION TEMP(*)
26340      DIMENSION TEMP2(*)
26341      DIMENSION TEMP3(*)
26342      DIMENSION TEMP4(*)
26343C
26344      INCLUDE 'DPCOPA.INC'
26345      INCLUDE 'DPCOP2.INC'
26346C
26347C-----START POINT-----------------------------------------------------
26348C
26349      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BOX2')THEN
26350        WRITE(ICOUT,70)
26351   70   FORMAT('AT THE BEGINNING OF DPBOX2--')
26352        CALL DPWRST('XXX','BUG ')
26353        WRITE(ICOUT,71)N,N2Z,N3,N4,NUMV2,ISIZE
26354   71   FORMAT('N,N2Z,N3,N4,NUMV2,ISIZE, = ',6I8)
26355        CALL DPWRST('XXX','BUG ')
26356        WRITE(ICOUT,72)ICASPL,IFENCE,IBXPWI,IBXPDI,IBXPSKI,ICONT
26357   72   FORMAT('ICASPL,IFENCE,IBXPWI,IBXPDI,IBXPSK,ICONT=',4(A4,2X),A4)
26358        CALL DPWRST('XXX','BUG ')
26359        DO75I=1,N
26360          WRITE(ICOUT,76)I,Y(I),X(I),TEMP2(I),TEMP3(I)
26361   76     FORMAT('I,Y(I),X(I),TEMP2(I),TEMP3(I) = ',I8,4G15.7)
26362          CALL DPWRST('XXX','BUG ')
26363   75   CONTINUE
26364      ENDIF
26365C
26366      ISUBN1='DPBO'
26367      ISUBN2='X2  '
26368      ISTACK='ON'
26369      IF(IMULT.EQ.'ON' .AND. NUMV2.LE.4)ISTACK='OFF'
26370      IWRITE='OFF'
26371C
26372      I2=0
26373      ISIZE2=0
26374C
26375      AN=0.0
26376      SIZE=0.0
26377      SIZE2=0.0
26378      XWIDTH=0.0
26379      XWIDT2=0.0
26380      YBARI=0.0
26381      SDI=0.0
26382      YMED=0.0
26383C
26384      H=0.0
26385      STEP=0.0
26386      STEPL=0.0
26387      AINNFU=0.0
26388      AOUTFU=0.0
26389      IREV=0
26390      AINNFL=0.0
26391      AOUTFL=0.0
26392C
26393C  BUG FIX: AUGUST, 1987
26394C           IF FENCES ON AND MORE THAN ONE SET OF BOX PLOTS DONE,
26395C           CAN GET GARBAGE.  NEED TO INITIALIZE X2, Y2, D2
26396C
26397      DO 10 I=1,MAXOBV
26398        X2(I)=0.0
26399        Y2(I)=0.0
26400        D2(I)=0.0
26401 10   CONTINUE
26402C  END FIX
26403C
26404C     CHECK THE INPUT ARGUMENTS FOR ERRORS
26405C
26406C     2016/06: TREAT CASE WITH EITHER SINGLE OBSERVATION OR SINGLE
26407C              UNIQUE OBSERVATION AS SPECIAL DEGENERATE CASE.
26408C
26409C              FOR NOW, JUST SUPPRESS THIS CHECK.  CHECK FOR DEGENERATE
26410C              CASE FOR EACH DISTINCT GROUP.
26411C
26412      IF(N.LT.1)THEN
26413        WRITE(ICOUT,999)
26414  999   FORMAT(1X)
26415        CALL DPWRST('XXX','BUG ')
26416        WRITE(ICOUT,41)
26417   41   FORMAT('***** ERROR IN BOX PLOT--')
26418        CALL DPWRST('XXX','BUG ')
26419        WRITE(ICOUT,47)
26420   47   FORMAT('      THE NUMBER OF OBSERVATIONS MUST BE AT LEAST ONE.')
26421        CALL DPWRST('XXX','BUG ')
26422        WRITE(ICOUT,49)N
26423   49   FORMAT('      THE NUMBER OF OBSERVATIONS = ',I8)
26424        CALL DPWRST('XXX','BUG ')
26425        WRITE(ICOUT,999)
26426        CALL DPWRST('XXX','BUG ')
26427        IERROR='YES'
26428        GOTO9000
26429      ENDIF
26430C
26431CCCCC HOLD=Y(1)
26432CCCCC DO60I=1,N
26433CCCCC   IF(Y(I).NE.HOLD)GOTO69
26434CCC60 CONTINUE
26435CCCCC WRITE(ICOUT,999)
26436CCCCC CALL DPWRST('XXX','BUG ')
26437CCCCC WRITE(ICOUT,61)
26438CCC61 FORMAT('***** WARNING IN BOX PLOT--')
26439CCCCC CALL DPWRST('XXX','BUG ')
26440CCCCC WRITE(ICOUT,62)
26441CCC62 FORMAT('      ALL RESPONSE VARIABLE ELEMENTS ARE IDENTICALLY')
26442CCCCC CALL DPWRST('XXX','BUG ')
26443CCCCC WRITE(ICOUT,63)HOLD
26444CCC63 FORMAT('      EQUAL TO ',G15.7)
26445CCCCC CALL DPWRST('XXX','BUG ')
26446CCCCC WRITE(ICOUT,999)
26447CCCCC CALL DPWRST('XXX','BUG ')
26448CCCCC IERROR='YES'
26449CCCCC GOTO9000
26450C
26451C               ******************************************************
26452C               **  STEP 1--                                        **
26453C               **  DETERMINE THE NUMBER OF DISTINCT VALUES         **
26454C               **  FOR VARIABLE 2 (THE GROUP VARIABLE).            **
26455C               **  IF ALL VALUES ARE DISTINCT, THEN THIS           **
26456C               **  IMPLIES WE HAVE THE NO REPLICATION CASE         **
26457C               **  WHICH IS AN ERROR CONDITION FOR A BOX PLOT.     **
26458C               ******************************************************
26459C
26460      ISTEPN='1'
26461      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BOX2')
26462     1   CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26463C
26464      IF(NUMV2.EQ.1)THEN
26465        DO120I=1,N
26466          X(I)=1.0
26467  120   CONTINUE
26468        NUMSET=1
26469        XIDTEM(1)=X(1)
26470C
26471      ELSEIF(NUMV2.EQ.2 .AND. ISTACK.EQ.'ON')THEN
26472        NUMSET=0
26473        DO160I=1,N
26474          IF(NUMSET.EQ.0)GOTO165
26475          DO170J=1,NUMSET
26476            IF(X(I).EQ.XIDTEM(J))GOTO160
26477  170     CONTINUE
26478  165     CONTINUE
26479          NUMSET=NUMSET+1
26480          XIDTEM(NUMSET)=X(I)
26481  160   CONTINUE
26482        CALL SORT(XIDTEM,NUMSET,XIDTEM)
26483C
26484        XID1=XIDTEM(1)
26485        XID2=XIDTEM(NUMSET)
26486C
26487      ELSE
26488        IF(NUMV2.EQ.2)THEN
26489          XIDTEM(1)=1.0
26490          XIDTEM(2)=2.0
26491          NUMSET=2
26492        ELSEIF(NUMV2.EQ.3)THEN
26493          XIDTEM(1)=1.0
26494          XIDTEM(2)=2.0
26495          XIDTEM(3)=3.0
26496          NUMSET=3
26497        ELSEIF(NUMV2.EQ.4)THEN
26498          XIDTEM(1)=1.0
26499          XIDTEM(2)=2.0
26500          XIDTEM(3)=3.0
26501          XIDTEM(4)=4.0
26502          NUMSET=4
26503        ENDIF
26504        XID1=XIDTEM(1)
26505        XID2=XIDTEM(NUMSET)
26506      ENDIF
26507C
26508      IF(NUMSET.EQ.0)THEN
26509        WRITE(ICOUT,41)
26510        CALL DPWRST('XXX','BUG ')
26511        WRITE(ICOUT,191)
26512  191   FORMAT('      NUMSET = 0')
26513        CALL DPWRST('XXX','BUG ')
26514        IERROR='YES'
26515        GOTO9000
26516      ELSEIF(NUMSET.EQ.N)THEN
26517C
26518C       2016/06: THIS IS DEGENERATE CASE.  HOWEVER, WE NOW ALLOW EACH
26519C                GROUP TO CONTAIN A SINGLE VALUE.
26520C
26521CCCCC   WRITE(ICOUT,41)
26522CCCCC   CALL DPWRST('XXX','BUG ')
26523CCCCC   WRITE(ICOUT,192)
26524CC192   FORMAT('      THE NUMBER OF GROUPS EQUALS THE NUMBER OF ',
26525CCCCC1         'OBSERVATIONS.')
26526CCCCC   CALL DPWRST('XXX','BUG ')
26527CCCCC   IERROR='YES'
26528CCCCC   GOTO9000
26529      ENDIF
26530C
26531C               **********************************
26532C               **  STEP 2--                    **
26533C               **  IF NECESSARY,               **
26534C               **  COMPUTE AVERAGE CLASS SIZE  **
26535C               **********************************
26536C
26537      ISTEPN='2'
26538      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BOX2')
26539     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26540C
26541      IF(ISTACK.EQ.'ON')THEN
26542        AN=N
26543        ANUMSE=NUMSET
26544C
26545        SIZE=ISIZE
26546        SIZE2=SIZE
26547        SIZE2=AN/ANUMSE
26548        ISIZE2=INT(SIZE2+0.5)
26549      ELSE
26550        AN=REAL(N)
26551        IF(NUMSET.EQ.2)AN=REAL(N+N2Z)
26552        IF(NUMSET.EQ.3)AN=REAL(N+N2Z+N3)
26553        IF(NUMSET.EQ.4)AN=REAL(N+N2Z+N3+N4)
26554        ANUMSE=NUMSET
26555      ENDIF
26556C
26557C               ***********************************
26558C               **  STEP 3--                     **
26559C               **  COMPUTE MINIMUM CLASS WIDTH  **
26560C               ***********************************
26561C
26562      ISTEPN='3'
26563      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BOX2')
26564     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26565C
26566      IF(NUMSET.EQ.1)THEN
26567        XWIDTH=0.10*XIDTEM(1)
26568      ELSE
26569        XWIDTH=CPUMAX
26570        IMAX=NUMSET-1
26571        DO300I=1,IMAX
26572          IP1=I+1
26573          XWIDT2=XIDTEM(IP1)-XIDTEM(I)
26574          IF(XWIDT2.LT.XWIDTH)XWIDTH=XWIDT2
26575  300   CONTINUE
26576      ENDIF
26577C
26578C               **************************************
26579C               **  STEP 4--                        **
26580C               **  COMPUTE MAXIMUM SUBSAMPLE SIZE  **
26581C               **************************************
26582C
26583      ISTEPN='4'
26584      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BOX2')
26585     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26586C
26587      IF(ISTACK.EQ.'ON')THEN
26588        NIMAX=0
26589        DO400ISET=1,NUMSET
26590C
26591          K=0
26592          DO420I=1,N
26593            IF(X(I).EQ.XIDTEM(ISET))K=K+1
26594            IF(X(I).EQ.XIDTEM(ISET))TEMP(K)=Y(I)
26595  420     CONTINUE
26596          NI=K
26597          IF(NI.GT.NIMAX)NIMAX=NI
26598C
26599  400   CONTINUE
26600        ANIMAX=NIMAX
26601      ELSE
26602        NIMAX=N
26603        IF(NUMSET.GE.2)NIMAX=MAX(NIMAX,N2Z)
26604        IF(NUMSET.GE.3)NIMAX=MAX(NIMAX,N3)
26605        IF(NUMSET.GE.4)NIMAX=MAX(NIMAX,N4)
26606        ANIMAX=NIMAX
26607      ENDIF
26608C
26609C               **************************************************************
26610C               **  STEP 5--                                                **
26611C               **  IN ORDER TO DETERMINE THE PROPER PLOT COOORDINATES      **
26612C               **  FOR THE DESIRED PLOT,                                   **
26613C               **  FIRST BRANCH TO THE PROPER SUBCASE--                    **
26614C               **         1) (MEDIAN) BOX PLOT;                            **
26615C               **         2) MEAN BOX PLOT;                                **
26616C               **************************************************************
26617C
26618      ISTEPN='5'
26619      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BOX2')
26620     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26621C
26622      IF(ICASPL.EQ.'MDBP')GOTO1100
26623      IF(ICASPL.EQ.'MEBP')GOTO1100
26624C
26625      WRITE(ICOUT,999)
26626      CALL DPWRST('XXX','BUG ')
26627      WRITE(ICOUT,261)
26628  261 FORMAT('***** INTERNAL ERROR IN DPBOX2')
26629      CALL DPWRST('XXX','BUG ')
26630      WRITE(ICOUT,262)
26631  262 FORMAT('      AT BRANCH POINT 261--')
26632      CALL DPWRST('XXX','BUG ')
26633      WRITE(ICOUT,263)
26634  263 FORMAT('      ICASPL NOT EQUAL ONE OF THE ALLOWABLE 2--')
26635      CALL DPWRST('XXX','BUG ')
26636      WRITE(ICOUT,264)
26637  264 FORMAT('      MDBP    OR    MEBP,')
26638      CALL DPWRST('XXX','BUG ')
26639      WRITE(ICOUT,266)ICASPL
26640  266 FORMAT('      ICASPL = ',A4)
26641      CALL DPWRST('XXX','BUG ')
26642      IERROR='YES'
26643      GOTO9000
26644C
26645C               ***************************************************
26646C               **  STEP 5A--                                    **
26647C               **  DETERMINE PLOT COORDINATES FOR 2 SUBCASES--  **
26648C               **      1) (MEDIAN) BOX PLOT;                    **
26649C               **      2) MEAN BOX PLOT;                        **
26650C               ***************************************************
26651C
26652 1100 CONTINUE
26653C
26654      ISTEPN='4A'
26655      IF(IBUGG3.EQ.'ON'.OR.ISUBRO.EQ.'BOX2')
26656     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
26657C
26658      NUMCPL=11
26659      J=0
26660      JD=0
26661      DO1110ISET=1,NUMSET
26662C
26663        IF(ISTACK.EQ.'ON')THEN
26664          K=0
26665          DO1120I=1,N
26666            IF(X(I).EQ.XIDTEM(ISET))THEN
26667              K=K+1
26668              TEMP(K)=Y(I)
26669            ENDIF
26670 1120     CONTINUE
26671          NI=K
26672          ANI=NI
26673        ELSE
26674          IF(ISET.EQ.1)THEN
26675            K=N
26676            DO1131I=1,K
26677              TEMP(I)=Y(I)
26678 1131       CONTINUE
26679          ELSEIF(ISET.EQ.2)THEN
26680            K=N2Z
26681            DO1132I=1,K
26682              TEMP(I)=X(I)
26683 1132       CONTINUE
26684          ELSEIF(ISET.EQ.3)THEN
26685            K=N3
26686            DO1133I=1,K
26687              TEMP(I)=TEMP2(I)
26688 1133       CONTINUE
26689          ELSEIF(ISET.EQ.4)THEN
26690            K=N4
26691            DO1134I=1,K
26692              TEMP(I)=TEMP3(I)
26693 1134       CONTINUE
26694          ENDIF
26695          NI=K
26696          ANI=NI
26697        ENDIF
26698C
26699        IF(NI.LE.0)THEN
26700          WRITE(ICOUT,999)
26701          CALL DPWRST('XXX','BUG ')
26702          WRITE(ICOUT,1141)
26703 1141     FORMAT('***** INTERNAL ERROR IN DPBOX2--')
26704          CALL DPWRST('XXX','BUG ')
26705          WRITE(ICOUT,1142)
26706 1142     FORMAT('NI FOR SOME CLASS = 0')
26707          CALL DPWRST('XXX','BUG ')
26708          WRITE(ICOUT,1143)ISET,XIDTEM(ISET),NI
26709 1143     FORMAT('ISET,XIDTEM(ISET),NI = ',I8,E15.7,I8)
26710          CALL DPWRST('XXX','BUG ')
26711          IERROR='YES'
26712          GOTO9000
26713        ENDIF
26714C
26715C       2016/06: SET IFLAGD TO 1 IF ONLY A SINGLE VALUE OR IF
26716C                ALL VALUES EQUAL TO SAME VALUE.
26717C
26718        CALL SORT(TEMP,NI,TEMP)
26719        IFLAGD=0
26720        IF(TEMP(1).EQ.TEMP(NI))IFLAGD=1
26721C
26722        XMID=XIDTEM(ISET)
26723C
26724C       2016/06: IF "SET BOX PLOT PERCENTILES ON" ENTERED, COMPUTE
26725C                THE 1, 5, 10, 90, 95, 99 PERCENTILES OF THE DATA.
26726C
26727        IF(IBXPDI.EQ.'ON')THEN
26728          P100=1.0
26729          CALL PERCEN(P100,TEMP,NI,IWRITE,TEMP4,MAXOBV,
26730     1                Y01,IBUGG3,IERROR)
26731          P100=5.0
26732          CALL PERCEN(P100,TEMP,NI,IWRITE,TEMP4,MAXOBV,
26733     1                Y05,IBUGG3,IERROR)
26734          P100=10.0
26735          CALL PERCEN(P100,TEMP,NI,IWRITE,TEMP4,MAXOBV,
26736     1                Y10,IBUGG3,IERROR)
26737          P100=90.0
26738          CALL PERCEN(P100,TEMP,NI,IWRITE,TEMP4,MAXOBV,
26739     1                Y90,IBUGG3,IERROR)
26740          P100=95.0
26741          CALL PERCEN(P100,TEMP,NI,IWRITE,TEMP4,MAXOBV,
26742     1                Y95,IBUGG3,IERROR)
26743          P100=99.0
26744          CALL PERCEN(P100,TEMP,NI,IWRITE,TEMP4,MAXOBV,
26745     1                Y99,IBUGG3,IERROR)
26746        ENDIF
26747C
26748C
26749CCCCC   MARCH 2002: SUPPORT EITHER FIXED OR VARIABLE WIDTH
26750CCCCC   BOX PLOTS.
26751        IF(IBXPWI.EQ.'FIXE')THEN
26752          FACTOR=1.0
26753        ELSE
26754          FACTOR=SQRT(ANI/ANIMAX)
26755        ENDIF
26756        XLEFT=XMID-(XWIDTH/4.0)*FACTOR
26757        XRIGHT=XMID+(XWIDTH/4.0)*FACTOR
26758C
26759C               ***************************
26760C               **  STEP 5.1--           **
26761C               **  COMPUTE THE MAXIMUM  **
26762C               ***************************
26763C
26764        YMAX=TEMP(NI)
26765C
26766C               ***********************************************
26767C               **  STEP 5.2--                               **
26768C               **  COMPUTE THE POINT AT THE TOP OF THE BOX  **
26769C               **  (THE UPPER HINGE FOR A MEDIAN BOX PLOT)  **
26770C               **  (XBAR + 2 STANDARD DEVIATIONS            **
26771C               **  FOR A MEAN BOX PLOT)                     **
26772C               ***********************************************
26773C
26774C               ***************************************
26775C               **  STEP 5.3--                       **
26776C               **  COMPUTE UPPER CONFIDENCE LIMITS  **
26777C               **  FOR THE MEAN                     **
26778C               ***************************************
26779C
26780        IF(IFLAGD.EQ.1)THEN
26781          Y75=TEMP(1)
26782          YUCL=Y75
26783        ELSEIF(ICASPL.EQ.'MDBP')THEN
26784          NI2=(NI+1)/2
26785          IARG1=(NI2+1)/2
26786          IARG2=(NI2+1)-IARG1
26787          IARG1R=NI-IARG1+1
26788          IARG2R=NI-IARG2+1
26789          Y75=(TEMP(IARG1R)+TEMP(IARG2R))/2.0
26790          YUCL=YBARI+2.0*SDI/SQRT(ANI)
26791        ELSEIF(ICASPL.EQ.'MEBP')THEN
26792          SUM=0.0
26793          DO1124I=1,NI
26794            SUM=SUM+TEMP(I)
26795 1124     CONTINUE
26796          YBARI=SUM/ANI
26797C
26798          SUM=0.0
26799          DO1126I=1,NI
26800            SUM=SUM+(TEMP(I)-YBARI)**2
26801 1126     CONTINUE
26802          DENOM=ANI-1.0
26803          VARI=0.0
26804          IF(NI.GE.2)VARI=SUM/DENOM
26805          SDI=0.0
26806          IF(VARI.GT.0.0)SDI=SQRT(VARI)
26807          Y75=YBARI+2.0*SDI
26808          YUCL=Y75
26809        ENDIF
26810C
26811C               *********************************
26812C               **  STEP 5.4--                 **
26813C               **  COMPUTE THE TYPICAL VALUE  **
26814C               **  (MEDIAN OR MEAN)           **
26815C               *********************************
26816C
26817C               ****************************************************
26818C               **  STEP 5.5--                                    **
26819C               **  COMPUTE LOWER CONFIDENCE LIMITS FOR THE MEAN  **
26820C               ****************************************************
26821C
26822        IF(IFLAGD.EQ.1)THEN
26823          Y50=TEMP(1)
26824          YLCL=Y50
26825        ELSEIF(ICASPL.EQ.'MDBP')THEN
26826          N50=NI/2
26827          N50P1=N50+1
26828          IEVODD=NI-2*(NI/2)
26829          IF(IEVODD.EQ.0)YMED=(TEMP(N50)+TEMP(N50P1))/2.0
26830          IF(IEVODD.EQ.1)YMED=TEMP(N50P1)
26831          Y50=YMED
26832          YLCL=Y50
26833        ELSEIF(ICASPL.EQ.'MEBP')THEN
26834          Y50=YBARI
26835          YLCL=YBARI-2.0*SDI/SQRT(ANI)
26836        ENDIF
26837C
26838C
26839C               ****************************************************
26840C               **  STEP 5.6--                                    **
26841C               **  COMPUTE THE POINT AT THE BOTTOM OF THE BOX    **
26842C               **  (THE LOWER HINGE FOR A MEDIAN BOX PLOT)       **
26843C               **  (XBAR - 2 STANDARD DEVIATIONS                 **
26844C               **  FOR A MEAN BOX PLOT)                          **
26845C               ****************************************************
26846C
26847        IF(IFLAGD.EQ.1)THEN
26848          Y25=TEMP(1)
26849        ELSEIF(ICASPL.EQ.'MDBP')THEN
26850          NI2=(NI+1)/2
26851          IARG1=(NI2+1)/2
26852          IARG2=(NI2+1)-IARG1
26853          Y25=(TEMP(IARG1)+TEMP(IARG2))/2.0
26854        ELSEIF(ICASPL.EQ.'MEBP')THEN
26855          Y25=YBARI-2.0*SDI
26856        ENDIF
26857C
26858C               ***************************
26859C               **  STEP 5.7--           **
26860C               **  COMPUTE THE MINIMUM  **
26861C               ***************************
26862C
26863        YMIN=TEMP(1)
26864C
26865C               *********************************************************
26866C               **  STEP 5.7A--                                        **
26867C               **  FOR THE UPPER HALF OF THE DATA--                   **
26868C               **  COMPUTE THE OUTER FENCE, THE INNER FENCE, AND THE  **
26869C               **  ADJACENT VALUE                                     **
26870C               *********************************************************
26871C
26872        IF(IFLAGD.EQ.1)THEN
26873          AINNFU=TEMP(1)
26874          AOUTFU=TEMP(1)
26875          YADJU=TEMP(1)
26876        ELSE
26877          H=Y75-Y25
26878          STEP=1.5*H
26879C
26880C         2019/08: SKEWED OPTION FOR FENCES
26881C
26882          AINNFU=Y75+STEP
26883          AOUTFU=Y75+2.0*STEP
26884          IF(IBXPSK.EQ.'GALT')THEN
26885            CALL LOWQUA(TEMP,NI,IWRITE,TEMP4,MAXNXT,RIGH1,
26886     1                  IBUGG3,IERROR)
26887            CALL UPPQUA(TEMP,NI,IWRITE,TEMP4,MAXNXT,RIGH2,
26888     1                  IBUGG3,IERROR)
26889            CALL MEDIAN(TEMP,NI,IWRITE,TEMP4,MAXNXT,RIGH3,
26890     1                  IBUGG3,IERROR)
26891            SIQU=RIGH2-RIGH3
26892            SIQL=RIGH3-RIGH1
26893            STEPU=STEP*(SIQU/SIQL)
26894            STEPL=STEP*(SIQL/SIQU)
26895            AINNFU=Y75+STEPU
26896            AOUTFU=Y75+2.0*STEPU
26897          ELSEIF(IBXPSK.EQ.'KIMB')THEN
26898            CALL LOWQUA(TEMP,NI,IWRITE,TEMP4,MAXNXT,RIGH1,
26899     1                  IBUGG3,IERROR)
26900            CALL UPPQUA(TEMP,NI,IWRITE,TEMP4,MAXNXT,RIGH2,
26901     1                  IBUGG3,IERROR)
26902            CALL MEDIAN(TEMP,NI,IWRITE,TEMP4,MAXNXT,RIGH3,
26903     1                  IBUGG3,IERROR)
26904            STEPL=2.0*(RIGH3-RIGH1)
26905            STEPU=2.0*(RIGH2-RIGH3)
26906            AINNFU=Y75+1.5*STEPU
26907            AOUTFU=Y75+3.0*STEPU
26908          ENDIF
26909C
26910          YADJU=Y75
26911          DO1155I=1,NI
26912            IREV=NI-I+1
26913            IF(TEMP(IREV).LE.AINNFU)GOTO1156
26914 1155     CONTINUE
26915          GOTO1159
26916 1156     CONTINUE
26917          YADJU=TEMP(IREV)
26918 1159     CONTINUE
26919        ENDIF
26920C
26921        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BOX2')THEN
26922          WRITE(ICOUT,1157)Y75,YADJU,TEMP(IREV),IREV
26923 1157     FORMAT('Y75,YADJU,TEMP(IREV),IREV = ',3E15.7,I8)
26924          CALL DPWRST('XXX','BUG ')
26925        ENDIF
26926C
26927C               *******************************************************
26928C               **  STEP 5.7B--                                      **
26929C               **  FOR THE LOWER HALF OF THE DATA--                 **
26930C               **  COMPUTE THE OUTER FENCE, THE INNER FENCE, AND    **
26931C               **  THE ADJACENT VALUE                               **
26932C               *******************************************************
26933C
26934        IF(IFLAGD.EQ.1)THEN
26935          AINNFU=TEMP(1)
26936          AOUTFU=TEMP(1)
26937          YADJL=TEMP(1)
26938        ELSE
26939          AINNFL=Y25-STEP
26940          AOUTFL=Y25-2.0*STEP
26941          IF(IBXPSK.EQ.'GALT')THEN
26942            AINNFL=Y25-STEPL
26943            AOUTFL=Y25-2.0*STEPL
26944          ELSEIF(IBXPSK.EQ.'GALT' .OR. IBXPSK.EQ.'KIMB')THEN
26945            AINNFL=Y25-1.5*STEPL
26946            AOUTFL=Y25-3.0*STEPL
26947          ENDIF
26948          YADJL=Y25
26949          DO1165I=1,NI
26950            I2=I
26951            IF(TEMP(I2).GE.AINNFL)GOTO1166
26952 1165     CONTINUE
26953          GOTO1169
26954 1166     CONTINUE
26955          YADJL=TEMP(I2)
26956 1169     CONTINUE
26957C
26958        ENDIF
26959C
26960C               ******************************************************
26961C               **  STEP 6.1--                                      **
26962C               **  IF IFENCE IS OFF, THEN DEFINE THE CHARACTER AT  **
26963C               **  THE MAXIMUM.  IF IFENCE IS ON, THEN  DEFINE THE **
26964C               **  CHARACTER AT THE UPPER ADJACENT VALUE.          **
26965C               ******************************************************
26966C
26967        IF(IFENCE.EQ.'OFF')THEN
26968          CALL DPCHLI(ICONT,NUMCPL,YMAX,YMAX,XMID,XMID,J,JD,Y2,X2,D2,
26969     1                IERROR)
26970        ELSEIF(IFENCE.EQ.'ON')THEN
26971          CALL DPCHLI(ICONT,NUMCPL,YADJU,YADJU,XMID,XMID,J,JD,Y2,X2,D2,
26972     1                IERROR)
26973        ENDIF
26974C
26975C               ****************************************
26976C               **  STEP 6.2--                        **
26977C               **  DEFINE THE CHARACTER AT THE TOP   **
26978C               **  OF THE BOX                        **
26979C               **  (UPPER HINGE CHARACTER, IF ANY).  **
26980C               ****************************************
26981C
26982        CALL DPCHLI(ICONT,NUMCPL,Y75,Y75,XMID,XMID,J,JD,Y2,X2,D2,
26983     1              IERROR)
26984C
26985C               *********************************************************
26986C               **  STEP 6.3--                                         **
26987C               **  DEFINE THE CHARACTER IN THE BOX BUT TOWARDS THE    **
26988C               **  TOP OF THE BOX  (SUCH AS AN UPPER CONFIDENCE LIMIT **
26989C               **  FOR THE MEAN, IF ANY)                              **
26990C               *********************************************************
26991C
26992        CALL DPCHLI(ICONT,NUMCPL,YUCL,YUCL,XMID,XMID,J,JD,Y2,X2,D2,
26993     1              IERROR)
26994C
26995C               ***************************************
26996C               **  STEP 6.4--                       **
26997C               **  DEFINE THE CHARACTER IN THE BOX  **
26998C               **  NEAR THE MIDDLE                  **
26999C               **  (SUCH AS THE MEDIAN OR MEAN)     **
27000C               ***************************************
27001C
27002        CALL DPCHLI(ICONT,NUMCPL,Y50,Y50,XMID,XMID,J,JD,Y2,X2,D2,
27003     1              IERROR)
27004C
27005C               ********************************************************
27006C               **  STEP 6.5--                                        **
27007C               **  DEFINE THE CHARACTER IN THE BOX BUT TOWARDS THE   **
27008C               **  BOX OF THE BOX (SUCH AS A LOWER CONFIDENCE LIMIT  **
27009C               **  FOR THE MEAN, IF ANY)                             **
27010C               ********************************************************
27011C
27012        CALL DPCHLI(ICONT,NUMCPL,YLCL,YLCL,XMID,XMID,J,JD,Y2,X2,D2,
27013     1              IERROR)
27014C
27015C               ******************************************
27016C               **  STEP 6.6--                         **
27017C               **  DEFINE THE CHARACTER AT THE BOTTOM  **
27018C               **  OF THE BOX                          **
27019C               **  (LOWER HINGE CHARACTER, IF ANY).    **
27020C               ******************************************
27021C
27022        CALL DPCHLI(ICONT,NUMCPL,Y25,Y25,XMID,XMID,J,JD,Y2,X2,D2,
27023     1              IERROR)
27024C
27025C               *****************************************************
27026C               **  STEP 6.7--                                     **
27027C               **  IF IFENCE IS OFF, THEN DEFINE THE CHARACTER    **
27028C               **  AT THE MINIMUM.  IF IFENCE IS ON, THEN DEFINE  **
27029C               **  THE CHARACTER AT THE LOWER ADJACENT VALUE.     **
27030C               *****************************************************
27031C
27032        IF(IFENCE.EQ.'OFF')THEN
27033          CALL DPCHLI(ICONT,NUMCPL,YMIN,YMIN,XMID,XMID,J,JD,Y2,X2,D2,
27034     1                IERROR)
27035        ELSEIF(IFENCE.EQ.'ON')THEN
27036          CALL DPCHLI(ICONT,NUMCPL,YADJL,YADJL,XMID,XMID,J,JD,Y2,X2,D2,
27037     1                IERROR)
27038        ENDIF
27039C
27040C               ********************************************
27041C               **  STEP 6.8--                            **
27042C               **  IF IFENCE IS OFF, THEN DEFINE THE     **
27043C               **  VERTICAL LINE FROM  THE MAXIMUM VALUE **
27044C               **  TO THE TOP OF THE BOX  IF IFENCE IS   **
27045C               **  ON, THEN DEFINE THE VERTICAL LINE     **
27046C               **  FROM  THE UPPER ADJACENT VALUE TO THE **
27047C               **  TOP OF THE BOX                        **
27048C               ********************************************
27049C
27050        IF(IFENCE.EQ.'OFF')THEN
27051          CALL DPCHLI(ICONT,NUMCPL,YMAX,Y75,XMID,XMID,J,JD,Y2,X2,D2,
27052     1                IERROR)
27053        ELSEIF(IFENCE.EQ.'ON')THEN
27054          CALL DPCHLI(ICONT,NUMCPL,YADJU,Y75,XMID,XMID,J,JD,Y2,X2,D2,
27055     1                IERROR)
27056        ENDIF
27057C
27058C               *******************************************************
27059C               **  STEP 6.9--                                      **
27060C               **  DEFINE THE VERTICAL LINE                         **
27061C               **  FROM THE TOP OF THE BOX (THE UPPER HINGE POINT)  **
27062C               **  TO THE POINT IN THE BOX TOWARD THE TOP           **
27063C               **  (SUCH AS THE UPPER CONFIDENCE LIMIT POINT)       **
27064C               *******************************************************
27065C
27066        CALL DPCHLI(ICONT,NUMCPL,Y75,YUCL,XMID,XMID,J,JD,Y2,X2,D2,
27067     1              IERROR)
27068C
27069C               **************************************************
27070C               **  STEP 6.10--                                 **
27071C               **  DEFINE THE VERTICAL LINE                    **
27072C               **  FROM THE POINT IN THE BOX TOWARD THE TOP    **
27073C               **  (SUCH AS THE UPPER CONFIDENCE LIMIT POINT)  **
27074C               **  TO THE POINT IN THE BOX                     **
27075C               **  IN THE MIDDLE                               **
27076C               **  (SUCH AS THE MEDIAN OR MEAN)                **
27077C               **************************************************
27078C
27079        CALL DPCHLI(ICONT,NUMCPL,YUCL,Y50,XMID,XMID,J,JD,Y2,X2,D2,
27080     1              IERROR)
27081C
27082C               **************************************************
27083C               **  STEP 6.11--                                 **
27084C               **  DEFINE THE VERTICAL LINE                    **
27085C               **  FROM THE POINT IN THE BOX                   **
27086C               **  IN THE MIDDLE                               **
27087C               **  (SUCH AS THE MEDIAN OR MEAN)                **
27088C               **  TO THE POINT IN THE BOX TOWARD THE BOTTOM   **
27089C               **  (SUCH AS THE LOWER CONFIDENCE LIMIT POINT)  **
27090C               **************************************************
27091C
27092        CALL DPCHLI(ICONT,NUMCPL,Y50,YLCL,XMID,XMID,J,JD,Y2,X2,D2,
27093     1              IERROR)
27094C
27095C               ********************************************************
27096C               **  STEP 6.12--                                       **
27097C               **  DEFINE THE VERTICAL LINE                          **
27098C               **  FROM THE POINT IN THE BOX TOWARD THE BOTTOM       **
27099C               **  (SUCH AS THE LOWER CONFIDENCE LIMIT POINT)        **
27100C               **  TO THE BOTTOM OF THE BOX (THE LOWER HINGE POINT)  **
27101C               ********************************************************
27102C
27103        CALL DPCHLI(ICONT,NUMCPL,YLCL,Y25,XMID,XMID,J,JD,Y2,X2,D2,
27104     1              IERROR)
27105C
27106C               **********************************
27107C               **  STEP 6.13--                 **
27108C               **  IF IFENCE IS OFF, THEN      **
27109C               **  DEFINE THE VERTICAL LINE    **
27110C               **  FROM THE BOTTOM OF THE BOX  **
27111C               **  TO THE MINIMUM VALUE        **
27112C               **  IF IFENCE IS ON, THEN       **
27113C               **  DEFINE THE VERTICAL LINE    **
27114C               **  FROM THE BOTTOM OF THE BOX  **
27115C               **  TO THE LOWER ADJACENT VALUE **
27116C               **********************************
27117C
27118        IF(IFENCE.EQ.'OFF')THEN
27119          CALL DPCHLI(ICONT,NUMCPL,Y25,YMIN,XMID,XMID,J,JD,Y2,X2,D2,
27120     1                IERROR)
27121        ELSEIF(IFENCE.EQ.'ON')THEN
27122          CALL DPCHLI(ICONT,NUMCPL,Y25,YADJL,XMID,XMID,J,JD,Y2,X2,D2,
27123     1                IERROR)
27124        ENDIF
27125C
27126C               *********************************************
27127C               **  STEP 6.14--                            **
27128C               **  DEFINE THE VERTICAL LINE               **
27129C               **  CONSTITUTING THE LEFT SIDE OF THE BOX  **
27130C               **  WHICH GOES FROM THE TOP OF THE BOX     **
27131C               **  TO THE BOTTOM OF THE BOX               **
27132C               *********************************************
27133C
27134        CALL DPCHLI(ICONT,NUMCPL,Y75,Y25,XLEFT,XLEFT,J,JD,Y2,X2,D2,
27135     1              IERROR)
27136C
27137C               **********************************************
27138C               **  STEP 6.15--                             **
27139C               **  DEFINE THE VERTICAL LINE                **
27140C               **  CONSTITUTING THE RIGHT SIDE OF THE BOX  **
27141C               **  WHICH GOES FROM THE TOP OF THE BOX      **
27142C               **  TO THE BOTTOM OF THE BOX                **
27143C               **********************************************
27144C
27145        CALL DPCHLI(ICONT,NUMCPL,Y75,Y25,XRIGHT,XRIGHT,J,JD,Y2,X2,D2,
27146     1              IERROR)
27147C
27148C               ***********************************************
27149C               **  STEP 6.16--                              **
27150C               **  DEFINE THE HORIZONTAL LINE               **
27151C               **  AT THE TOP OF THE BOX                    **
27152C               **  (RUNNING THROUGH THE UPPER HINGE POINT)  **
27153C               ***********************************************
27154C
27155        CALL DPCHLI(ICONT,NUMCPL,Y75,Y75,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27156     1              IERROR)
27157C
27158C               ****************************************************
27159C               **  STEP 6.17--                                   **
27160C               **  DEFINE THE HORIZONTAL LINE                    **
27161C               **  IN THE BOX                                    **
27162C               **  (RUNNING THROUGH THE UPPER CONFIDENCE LIMIT)  **
27163C               ****************************************************
27164C
27165        CALL DPCHLI(ICONT,NUMCPL,YUCL,YUCL,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27166     1              IERROR)
27167C
27168C               *********************************************
27169C               **  STEP 6.18--                            **
27170C               **  DEFINE THE HORIZONTAL LINE             **
27171C               **  IN THE BOX                             **
27172C               **  (RUNNING THROUGHT THE MEDIAN OR MEAN)  **
27173C               *********************************************
27174C
27175        CALL DPCHLI(ICONT,NUMCPL,Y50,Y50,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27176     1              IERROR)
27177C
27178C               ****************************************************
27179C               **  STEP 6.19--                                   **
27180C               **  DEFINE THE HORIZONTAL LINE                    **
27181C               **  IN THE BOX                                    **
27182C               **  (RUNNING THROUGH THE LOWER CONFIDENCE LIMIT)  **
27183C               ****************************************************
27184C
27185        CALL DPCHLI(ICONT,NUMCPL,YLCL,YLCL,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27186     1              IERROR)
27187C
27188C               ***********************************************
27189C               **  STEP 6.20--                              **
27190C               **  DEFINE THE HORIZONTAL LINE               **
27191C               **  AT THE BOTTOM OF THE BOX                 **
27192C               **  (RUNNING THROUGH THE LOWER HINGE POINT)  **
27193C               ***********************************************
27194C
27195        CALL DPCHLI(ICONT,NUMCPL,Y25,Y25,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27196     1              IERROR)
27197C
27198C               *********************************************************
27199C               **  STEP 6.20B--                                       **
27200C               **  IF A BOX PLOT WITH NO FENCES HAS BEEN CALLED FOR,  **
27201C               **  THEN SKIP PAST THE FINAL 4 SPECIFICATIONS.         **
27202C               *********************************************************
27203C
27204CCCCC   IF(IFENCE.EQ.'OFF')GOTO1110
27205        IF(IFENCE.EQ.'OFF')GOTO1259
27206C
27207C               *********************************************************
27208C               **  STEP 6.21--                                        **
27209C               **  DEFINE THE CHARACTER FOR THE UPPER FAR OUT VALUES  **
27210C               **  (BEYOND THE UPPER OUTER FENCE)                     **
27211C               *********************************************************
27212C
27213        YTEMP=Y25
27214        CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2,
27215     1              IERROR)
27216        JD=JD-1
27217C
27218        IPASS=0
27219        DO1215I=1,NI
27220          IREV=NI-I+1
27221          YTEMP=TEMP(IREV)
27222          IF(YTEMP.LE.AOUTFU)GOTO1219
27223          IPASS=IPASS+1
27224          IF(IPASS.EQ.1)J=J-1
27225          CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2,
27226     1                IERROR)
27227          JD=JD-1
27228 1215   CONTINUE
27229 1219   CONTINUE
27230        JD=JD+1
27231C
27232C               *********************************************************
27233C               **  STEP 6.22--                                        **
27234C               **  DEFINE THE CHARACTER FOR THE UPPER NEAR OUT VALUES **
27235C               **  (BETWEEN THE UPPER INNER AND OUTER FENCES)         **
27236C               *********************************************************
27237C
27238        YTEMP=Y25
27239        CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2,
27240     1              IERROR)
27241        JD=JD-1
27242C
27243        IPASS=0
27244        DO1225I=1,NI
27245          IREV=NI-I+1
27246          YTEMP=TEMP(IREV)
27247          IF(YTEMP.GE.AOUTFU)GOTO1225
27248          IF(YTEMP.LE.AINNFU)GOTO1229
27249          IPASS=IPASS+1
27250          IF(IPASS.EQ.1)J=J-1
27251          CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2,
27252     1                IERROR)
27253          JD=JD-1
27254 1225   CONTINUE
27255 1229   CONTINUE
27256        JD=JD+1
27257C
27258C               *********************************************************
27259C               **  STEP 6.23--                                        **
27260C               **  DEFINE THE CHARACTER FOR THE LOWER NEAR OUT VALUES **
27261C               **  (BETWEEN THE LOWER INNER AND OUTER FENCES)         **
27262C               *********************************************************
27263C
27264        YTEMP=Y25
27265        CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2,
27266     1              IERROR)
27267        JD=JD-1
27268C
27269        IPASS=0
27270        DO1235I=1,NI
27271          I2=I
27272          YTEMP=TEMP(I2)
27273          IF(YTEMP.LE.AOUTFL)GOTO1235
27274          IF(YTEMP.GE.AINNFL)GOTO1239
27275          IPASS=IPASS+1
27276          IF(IPASS.EQ.1)J=J-1
27277          CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2,
27278     1                IERROR)
27279          JD=JD-1
27280 1235   CONTINUE
27281 1239   CONTINUE
27282        JD=JD+1
27283C
27284C               *********************************************************
27285C               **  STEP 6.24--                                        **
27286C               **  DEFINE THE CHARACTER FOR THE LOWER FAR OUT VALUES  **
27287C               **  (BEYOND THE LOWER OUTER FENCE)                     **
27288C               *********************************************************
27289C
27290        YTEMP=Y25
27291        CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2,
27292     1              IERROR)
27293        JD=JD-1
27294C
27295        IPASS=0
27296        DO1245I=1,NI
27297          I2=I
27298          YTEMP=TEMP(I2)
27299          IF(YTEMP.GE.AOUTFL)GOTO1249
27300          IPASS=IPASS+1
27301          IF(IPASS.EQ.1)J=J-1
27302          CALL DPCHLI(ICONT,NUMCPL,YTEMP,YTEMP,XMID,XMID,J,JD,Y2,X2,D2,
27303     1                IERROR)
27304          JD=JD-1
27305 1245   CONTINUE
27306 1249   CONTINUE
27307        JD=JD+1
27308C
27309C               ********************************************
27310C               **  STEP 6.25--                           **
27311C               **  IF SET BOX PLOT PERCENTILES ON IS     **
27312C               **  GIVEN, THEN DRAW LINES AT PERCENTILES **
27313C               ********************************************
27314C
27315 1259   CONTINUE
27316C
27317        IF(IBXPDI.EQ.'ON')THEN
27318          CALL DPCHLI(ICONT,NUMCPL,Y01,Y01,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27319     1                IERROR)
27320          CALL DPCHLI(ICONT,NUMCPL,Y05,Y05,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27321     1                IERROR)
27322          CALL DPCHLI(ICONT,NUMCPL,Y10,Y10,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27323     1                IERROR)
27324          CALL DPCHLI(ICONT,NUMCPL,Y90,Y90,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27325     1                IERROR)
27326          CALL DPCHLI(ICONT,NUMCPL,Y95,Y95,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27327     1                IERROR)
27328          CALL DPCHLI(ICONT,NUMCPL,Y99,Y99,XLEFT,XRIGHT,J,JD,Y2,X2,D2,
27329     1                IERROR)
27330        ENDIF
27331C
27332        IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BOX2')THEN
27333          WRITE(ICOUT,999)
27334          CALL DPWRST('XXX','BUG ')
27335          WRITE(ICOUT,1251)
27336 1251     FORMAT('***** FROM THE MIDDLE OF DPBOX2--')
27337          CALL DPWRST('XXX','BUG ')
27338          WRITE(ICOUT,1252)ANI,J,JD,XMID
27339 1252     FORMAT('ANI,J,JD,XMID = ',E15.7,I8,I8,E15.7)
27340          CALL DPWRST('XXX','BUG ')
27341          WRITE(ICOUT,1253)YMAX,Y75,Y50,Y25,YMIN
27342 1253     FORMAT('YMAX,Y75,Y50,Y25,YMIN = ',5E15.7)
27343          CALL DPWRST('XXX','BUG ')
27344          WRITE(ICOUT,1254)H,STEP,Y75,YADJU,AINNFU,AOUTFU
27345 1254     FORMAT('H,STEP,Y75,YADJU,AINNFU,AOUTFU = ',6E15.7)
27346          CALL DPWRST('XXX','BUG ')
27347          WRITE(ICOUT,1255)H,STEP,Y25,YADJL,AINNFL,AOUTFL
27348 1255     FORMAT('H,STEP,Y25,YADJL,AINNFL,AOUTFL = ',6E15.7)
27349          CALL DPWRST('XXX','BUG ')
27350        ENDIF
27351C
27352 1110 CONTINUE
27353C
27354      N2=J
27355      NPLOTV=3
27356      GOTO9000
27357C
27358C               ******************
27359C               **   STEP 90--  **
27360C               **   EXIT       **
27361C               ******************
27362C
27363 9000 CONTINUE
27364      IF(IBUGG3.EQ.'ON' .OR. ISUBRO.EQ.'BOX2')THEN
27365        WRITE(ICOUT,999)
27366        CALL DPWRST('XXX','BUG ')
27367        WRITE(ICOUT,9011)
27368 9011   FORMAT('***** AT THE END       OF DPBOX2--')
27369        CALL DPWRST('XXX','BUG ')
27370        WRITE(ICOUT,9012)ICASPL,N,NUMSET,N2,IERROR
27371 9012   FORMAT('ICASPL,N,NUMSET,N2,IERROR = ',A4,3I8,2X,A4)
27372        CALL DPWRST('XXX','BUG ')
27373        WRITE(ICOUT,9013)IFENCE
27374 9013   FORMAT('IFENCE = ',A4)
27375        CALL DPWRST('XXX','BUG ')
27376        WRITE(ICOUT,9014)NUMV2,ISIZE,SIZE,SIZE2,ISIZE2
27377 9014   FORMAT('NUMV2,ISIZE,SIZE,SIZE2,ISIZE2 = ',2I8,2E15.7,I8)
27378        CALL DPWRST('XXX','BUG ')
27379        WRITE(ICOUT,9015)AN,XWIDT2,XWIDTH
27380 9015   FORMAT('AN,XWIDT2,XWIDTH = ',3E15.7)
27381        CALL DPWRST('XXX','BUG ')
27382        WRITE(ICOUT,9021)YMAX,Y75,Y50,Y25,YMIN
27383 9021   FORMAT('YMAX,Y75,Y50,Y25,YMIN = ',5E15.7)
27384        CALL DPWRST('XXX','BUG ')
27385        WRITE(ICOUT,9022)H,STEP,Y75,YADJU,AINNFU,AOUTFU
27386 9022   FORMAT('H,STEP,Y75,YADJU,AINNFU,AOUTFU = ',6E15.7)
27387        CALL DPWRST('XXX','BUG ')
27388        WRITE(ICOUT,9023)H,STEP,Y25,YADJL,AINNFL,AOUTFL
27389 9023   FORMAT('H,STEP,Y25,YADJL,AINNFL,AOUTFL = ',6E15.7)
27390        CALL DPWRST('XXX','BUG ')
27391        DO9035I=1,N2
27392          WRITE(ICOUT,9036)I,Y2(I),X2(I),D2(I)
27393 9036     FORMAT('I,Y2(I),X2(I),D2(I) = ',I8,2E15.7,F9.2)
27394          CALL DPWRST('XXX','BUG ')
27395 9035   CONTINUE
27396      ENDIF
27397C
27398      RETURN
27399      END
27400      SUBROUTINE DPBPCO(IHARG,NUMARG,IDEBPC,MAXBAR,IBAPCO,
27401     1IBUGP2,IFOUND,IERROR)
27402C
27403C     PURPOSE--DEFINE THE BAR PATTERN COLORS = THE COLORS
27404C              OF THE LINES MAKING UP A PATTERN WITHIN A BAR.
27405C              THESE ARE LOCATED IN THE VECTOR IBAPCO(.).
27406C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
27407C                     --NUMARG
27408C                     --IDEBPC
27409C                     --MAXBAR
27410C                     --IBUGP2 ('ON' OR 'OFF' )
27411C     OUTPUT ARGUMENTS--IBAPCO (A CHARACTER VECTOR)
27412C                     --IFOUND ('YES' OR 'NO' )
27413C                     --IERROR ('YES' OR 'NO' )
27414C     WRITTEN BY--JAMES J. FILLIBEN
27415C                 STATISTICAL ENGINEERING DIVISION
27416C                 INFORMATION TECHNOLOGY LABORATORY
27417C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
27418C                 GAITHERSBURG, MD 20899-8980
27419C                 PHONE--301-975-2855
27420C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27421C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
27422C     LANGUAGE--ANSI FORTRAN (1977)
27423C     VERSION NUMBER--82/7
27424C     ORIGINAL VERSION--DECEMBER  1983.
27425C
27426C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27427C
27428      CHARACTER*4 IHARG
27429      CHARACTER*4 IDEBPC
27430      CHARACTER*4 IBAPCO
27431C
27432      CHARACTER*4 IBUGP2
27433      CHARACTER*4 IFOUND
27434      CHARACTER*4 IERROR
27435C
27436      CHARACTER*4 IHOLD1
27437      CHARACTER*4 IHOLD2
27438C
27439      CHARACTER*4 ISUBN1
27440      CHARACTER*4 ISUBN2
27441      CHARACTER*4 ISTEPN
27442C
27443      DIMENSION IHARG(*)
27444      DIMENSION IBAPCO(*)
27445C
27446C---------------------------------------------------------------------
27447C
27448      INCLUDE 'DPCOP2.INC'
27449C
27450C-----START POINT-----------------------------------------------------
27451C
27452      IFOUND='NO'
27453      IERROR='NO'
27454      ISUBN1='DPBP'
27455      ISUBN2='CO  '
27456C
27457      NUMBAR=0
27458      IHOLD1='-999'
27459      IHOLD2='-999'
27460C
27461      IF(IBUGP2.EQ.'OFF')GOTO90
27462      WRITE(ICOUT,999)
27463  999 FORMAT(1X)
27464      CALL DPWRST('XXX','BUG ')
27465      WRITE(ICOUT,51)
27466   51 FORMAT('***** AT THE BEGINNING OF DPBPCO--')
27467      CALL DPWRST('XXX','BUG ')
27468      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
27469   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
27470      CALL DPWRST('XXX','BUG ')
27471      WRITE(ICOUT,53)MAXBAR,NUMBAR
27472   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
27473      CALL DPWRST('XXX','BUG ')
27474      WRITE(ICOUT,54)IHOLD1,IHOLD2
27475   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
27476      CALL DPWRST('XXX','BUG ')
27477      WRITE(ICOUT,55)IDEBPC
27478   55 FORMAT('IDEBPC = ',A4)
27479      CALL DPWRST('XXX','BUG ')
27480      WRITE(ICOUT,60)NUMARG
27481   60 FORMAT('NUMARG = ',I8)
27482      CALL DPWRST('XXX','BUG ')
27483      DO65I=1,NUMARG
27484      WRITE(ICOUT,66)IHARG(I)
27485   66 FORMAT('IHARG(I) = ',A4)
27486      CALL DPWRST('XXX','BUG ')
27487   65 CONTINUE
27488      WRITE(ICOUT,70)IBAPCO(1)
27489   70 FORMAT('IBAPCO(1) = ',A4)
27490      CALL DPWRST('XXX','BUG ')
27491      DO75I=1,10
27492      WRITE(ICOUT,76)I,IBAPCO(I)
27493   76 FORMAT('I,IBAPCO(I) = ',I8,2X,A4)
27494      CALL DPWRST('XXX','BUG ')
27495   75 CONTINUE
27496   90 CONTINUE
27497C
27498C               **************************************
27499C               **  STEP 1--                        **
27500C               **  BRANCH TO THE APPROPRIATE CASE  **
27501C               **************************************
27502C
27503      ISTEPN='1'
27504      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27505C
27506      IF(NUMARG.LE.1)GOTO9000
27507      IF(NUMARG.EQ.2)GOTO1120
27508      IF(NUMARG.EQ.3)GOTO1130
27509      IF(NUMARG.EQ.4)GOTO1140
27510      GOTO1150
27511C
27512 1120 CONTINUE
27513      GOTO1200
27514C
27515 1130 CONTINUE
27516      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
27517      IF(IHARG(3).EQ.'ALL')GOTO1300
27518      GOTO1200
27519C
27520 1140 CONTINUE
27521      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
27522      IF(IHARG(3).EQ.'ALL')GOTO1300
27523      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
27524      IF(IHARG(4).EQ.'ALL')GOTO1300
27525      GOTO1200
27526C
27527 1150 CONTINUE
27528      GOTO1200
27529C
27530C               *************************************************
27531C               **  STEP 2--                                   **
27532C               **  TREAT THE SINGLE      SPECIFICATION  CASE  **
27533C               *************************************************
27534C
27535 1200 CONTINUE
27536      ISTEPN='2'
27537      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27538C
27539      IF(NUMARG.LE.2)GOTO1210
27540      GOTO1220
27541C
27542 1210 CONTINUE
27543      NUMBAR=1
27544      IBAPCO(1)=IDEBPC
27545      GOTO1270
27546C
27547 1220 CONTINUE
27548      NUMBAR=NUMARG-2
27549      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
27550      DO1225I=1,NUMBAR
27551      J=I+2
27552      IHOLD1=IHARG(J)
27553      IHOLD2=IHOLD1
27554      IF(IHOLD1.EQ.'ON')IHOLD2=IDEBPC
27555      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBPC
27556      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPC
27557      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPC
27558      IBAPCO(I)=IHOLD2
27559 1225 CONTINUE
27560      GOTO1270
27561C
27562 1270 CONTINUE
27563      IF(IFEEDB.EQ.'OFF')GOTO1279
27564      WRITE(ICOUT,999)
27565      CALL DPWRST('XXX','BUG ')
27566      DO1278I=1,NUMBAR
27567      WRITE(ICOUT,1276)I,IBAPCO(I)
27568 1276 FORMAT('THE COLOR OF BAR PATTERN ',I6,
27569     1' HAS JUST BEEN SET TO ',A4)
27570      CALL DPWRST('XXX','BUG ')
27571 1278 CONTINUE
27572 1279 CONTINUE
27573      IFOUND='YES'
27574      GOTO9000
27575C
27576C               **************************
27577C               **  STEP 3--            **
27578C               **  TREAT THE ALL CASE  **
27579C               **************************
27580C
27581 1300 CONTINUE
27582      ISTEPN='3'
27583      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27584C
27585      NUMBAR=MAXBAR
27586      IHOLD2=IHOLD1
27587      IF(IHOLD1.EQ.'ON')IHOLD2=IDEBPC
27588      IF(IHOLD1.EQ.'OFF')IHOLD2=IDEBPC
27589      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPC
27590      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPC
27591      DO1315I=1,NUMBAR
27592      IBAPCO(I)=IHOLD2
27593 1315 CONTINUE
27594      GOTO1370
27595C
27596 1370 CONTINUE
27597      IF(IFEEDB.EQ.'OFF')GOTO1319
27598      WRITE(ICOUT,999)
27599      CALL DPWRST('XXX','BUG ')
27600      I=1
27601      WRITE(ICOUT,1316)IBAPCO(I)
27602 1316 FORMAT('THE COLOR OF ALL BAR PATTERNS',
27603     1' HAS JUST BEEN SET TO ',A4)
27604      CALL DPWRST('XXX','BUG ')
27605 1319 CONTINUE
27606      IFOUND='YES'
27607      GOTO9000
27608C
27609C               *****************
27610C               **  STEP 90--  **
27611C               **  EXIT       **
27612C               *****************
27613C
27614 9000 CONTINUE
27615      IF(IBUGP2.EQ.'OFF')GOTO9090
27616      WRITE(ICOUT,9011)
27617 9011 FORMAT('***** AT THE END       OF DPBPCO--')
27618      CALL DPWRST('XXX','BUG ')
27619      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
27620 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
27621      CALL DPWRST('XXX','BUG ')
27622      WRITE(ICOUT,9013)MAXBAR,NUMBAR
27623 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
27624      CALL DPWRST('XXX','BUG ')
27625      WRITE(ICOUT,9014)IHOLD1,IHOLD2
27626 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
27627      CALL DPWRST('XXX','BUG ')
27628      WRITE(ICOUT,9015)IDEBPC
27629 9015 FORMAT('IDEBPC = ',A4)
27630      CALL DPWRST('XXX','BUG ')
27631      WRITE(ICOUT,9020)NUMARG
27632 9020 FORMAT('NUMARG = ',I8)
27633      CALL DPWRST('XXX','BUG ')
27634      DO9025I=1,NUMARG
27635      WRITE(ICOUT,9026)IHARG(I)
27636 9026 FORMAT('IHARG(I) = ',A4)
27637      CALL DPWRST('XXX','BUG ')
27638 9025 CONTINUE
27639      WRITE(ICOUT,9030)IBAPCO(1)
27640 9030 FORMAT('IBAPCO(1) = ',A4)
27641      CALL DPWRST('XXX','BUG ')
27642      DO9035I=1,10
27643      WRITE(ICOUT,9036)I,IBAPCO(I)
27644 9036 FORMAT('I,IBAPCO(I) = ',I8,2X,A4)
27645      CALL DPWRST('XXX','BUG ')
27646 9035 CONTINUE
27647 9090 CONTINUE
27648C
27649      RETURN
27650      END
27651      SUBROUTINE DPBPLI(IHARG,IHARG2,NUMARG,IDEBPL,MAXBAR,IBAPLI,
27652CCCCC AUGUST 1995.  ADD IHARG2 FOR DASH2, ETC
27653CCCCC SUBROUTINE DPBPLI(IHARG,NUMARG,IDEBPL,MAXBAR,IBAPLI,
27654     1IBUGP2,IFOUND,IERROR)
27655C
27656C     PURPOSE--DEFINE THE PATTERN LINES = THE LINES TYPES
27657C              OF THE PATTERN WITHIN THE BARS.
27658C              THESE ARE LOCATED IN THE VECTOR IBAPLI(.).
27659C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
27660C                     --NUMARG
27661C                     --IDEBPL
27662C                     --MAXBAR
27663C                     --IBUGP2 ('ON' OR 'OFF' )
27664C     OUTPUT ARGUMENTS--IBAPLI (A CHARACTER VECTOR)
27665C                     --IFOUND ('YES' OR 'NO' )
27666C                     --IERROR ('YES' OR 'NO' )
27667C     WRITTEN BY--JAMES J. FILLIBEN
27668C                 STATISTICAL ENGINEERING DIVISION
27669C                 INFORMATION TECHNOLOGY LABORATORY
27670C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
27671C                 GAITHERSBURG, MD 20899-8980
27672C                 PHONE--301-975-2855
27673C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27674C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
27675C     LANGUAGE--ANSI FORTRAN (1977)
27676C     VERSION NUMBER--82/7
27677C     ORIGINAL VERSION--DECEMBER  1983.
27678C     UPDATED  VERSION--AUGUST    1995.  DASH2 BUG
27679C
27680C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27681C
27682      CHARACTER*4 IHARG
27683CCCCC AUGUST 1995.  ADD FOLLOWING LINE
27684      CHARACTER*4 IHARG2
27685      CHARACTER*4 IDEBPL
27686      CHARACTER*4 IBAPLI
27687C
27688      CHARACTER*4 IBUGP2
27689      CHARACTER*4 IFOUND
27690      CHARACTER*4 IERROR
27691C
27692      CHARACTER*4 IHOLD1
27693      CHARACTER*4 IHOLD2
27694C
27695      CHARACTER*4 ISUBN1
27696      CHARACTER*4 ISUBN2
27697      CHARACTER*4 ISTEPN
27698C
27699      DIMENSION IHARG(*)
27700CCCCC AUGUST 1995.  ADD FOLLOWING LINE
27701      DIMENSION IHARG2(*)
27702      DIMENSION IBAPLI(*)
27703C
27704C---------------------------------------------------------------------
27705C
27706      INCLUDE 'DPCOP2.INC'
27707C
27708C-----START POINT-----------------------------------------------------
27709C
27710      IFOUND='NO'
27711      IERROR='NO'
27712      ISUBN1='DPBP'
27713      ISUBN2='LI  '
27714C
27715      NUMBAR=0
27716      IHOLD1='-999'
27717      IHOLD2='-999'
27718C
27719      IF(IBUGP2.EQ.'OFF')GOTO90
27720      WRITE(ICOUT,999)
27721  999 FORMAT(1X)
27722      CALL DPWRST('XXX','BUG ')
27723      WRITE(ICOUT,51)
27724   51 FORMAT('***** AT THE BEGINNING OF DPBPLI--')
27725      CALL DPWRST('XXX','BUG ')
27726      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
27727   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
27728      CALL DPWRST('XXX','BUG ')
27729      WRITE(ICOUT,53)MAXBAR,NUMBAR
27730   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
27731      CALL DPWRST('XXX','BUG ')
27732      WRITE(ICOUT,54)IHOLD1,IHOLD2
27733   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
27734      CALL DPWRST('XXX','BUG ')
27735      WRITE(ICOUT,55)IDEBPL
27736   55 FORMAT('IDEBPL = ',A4)
27737      CALL DPWRST('XXX','BUG ')
27738      WRITE(ICOUT,60)NUMARG
27739   60 FORMAT('NUMARG = ',I8)
27740      CALL DPWRST('XXX','BUG ')
27741      DO65I=1,NUMARG
27742      WRITE(ICOUT,66)IHARG(I)
27743   66 FORMAT('IHARG(I) = ',A4)
27744      CALL DPWRST('XXX','BUG ')
27745   65 CONTINUE
27746      WRITE(ICOUT,70)IBAPLI(1)
27747   70 FORMAT('IBAPLI(1) = ',A4)
27748      CALL DPWRST('XXX','BUG ')
27749      DO75I=1,10
27750      WRITE(ICOUT,76)I,IBAPLI(I)
27751   76 FORMAT('I,IBAPLI(I) = ',I8,2X,A4)
27752      CALL DPWRST('XXX','BUG ')
27753   75 CONTINUE
27754   90 CONTINUE
27755C
27756C               **************************************
27757C               **  STEP 1--                        **
27758C               **  BRANCH TO THE APPROPRIATE CASE  **
27759C               **************************************
27760C
27761      ISTEPN='1'
27762      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27763C
27764      IF(NUMARG.LE.2)GOTO9000
27765      IF(NUMARG.EQ.3)GOTO1130
27766      IF(NUMARG.EQ.4)GOTO1140
27767      IF(NUMARG.EQ.5)GOTO1150
27768      GOTO1160
27769C
27770 1130 CONTINUE
27771      GOTO1200
27772C
27773 1140 CONTINUE
27774      IF(IHARG(5).EQ.'ALL')IHOLD1='    '
27775      IF(IHARG(5).EQ.'ALL')GOTO1300
27776      GOTO1200
27777C
27778 1150 CONTINUE
27779      IF(IHARG(5).EQ.'ALL')THEN
27780CCCCC APRIL 1996.  CHANGE IHOLD TO IHOLD1
27781        IHOLD1=IHARG(6)
27782        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'2')IHOLD1='DA2'
27783        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'3')IHOLD1='DA3'
27784        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'4')IHOLD1='DA4'
27785        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(6).EQ.'5')IHOLD1='DA5'
27786        GOTO1300
27787      ENDIF
27788      IF(IHARG(6).EQ.'ALL')THEN
27789        IHOLD1=IHARG(5)
27790        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'2')IHOLD1='DA2'
27791        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'3')IHOLD1='DA3'
27792        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'4')IHOLD1='DA4'
27793        IF(IHOLD1.EQ.'DASH'.AND.IHARG2(5).EQ.'5')IHOLD1='DA5'
27794        GOTO1300
27795      ENDIF
27796      GOTO1200
27797C
27798 1160 CONTINUE
27799      GOTO1200
27800C
27801C               *************************************************
27802C               **  STEP 2--                                   **
27803C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
27804C               *************************************************
27805C
27806 1200 CONTINUE
27807      ISTEPN='2'
27808      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27809C
27810      IF(NUMARG.LE.3)GOTO1210
27811      GOTO1220
27812C
27813 1210 CONTINUE
27814      NUMBAR=1
27815      IBAPLI(1)='    '
27816      GOTO1270
27817C
27818 1220 CONTINUE
27819      NUMBAR=NUMARG-3
27820      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
27821      DO1225I=1,NUMBAR
27822      J=I+3
27823      IHOLD1=IHARG(J)
27824      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'2')IHOLD1='DA2'
27825      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'3')IHOLD1='DA3'
27826      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'4')IHOLD1='DA4'
27827      IF(IHOLD1.EQ.'DASH'.AND.IHARG2(J).EQ.'5')IHOLD1='DA5'
27828      IHOLD2=IHOLD1
27829      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
27830      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
27831      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPL
27832      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPL
27833      IBAPLI(I)=IHOLD2
27834 1225 CONTINUE
27835      GOTO1270
27836C
27837 1270 CONTINUE
27838      IF(IFEEDB.EQ.'OFF')GOTO1279
27839      WRITE(ICOUT,999)
27840      CALL DPWRST('XXX','BUG ')
27841      DO1278I=1,NUMBAR
27842      WRITE(ICOUT,1276)I,IBAPLI(I)
27843 1276 FORMAT('THE LINE TYPE FOR BAR PATTERN ',I6,
27844     1' HAS JUST BEEN SET TO ',A4)
27845      CALL DPWRST('XXX','BUG ')
27846 1278 CONTINUE
27847 1279 CONTINUE
27848      IFOUND='YES'
27849      GOTO9000
27850C
27851C               **************************
27852C               **  STEP 3--            **
27853C               **  TREAT THE ALL CASE  **
27854C               **************************
27855C
27856 1300 CONTINUE
27857      ISTEPN='3'
27858      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
27859C
27860      NUMBAR=MAXBAR
27861      IHOLD2=IHOLD1
27862      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
27863      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
27864      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPL
27865      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPL
27866      DO1315I=1,NUMBAR
27867      IBAPLI(I)=IHOLD2
27868 1315 CONTINUE
27869      GOTO1370
27870C
27871 1370 CONTINUE
27872      IF(IFEEDB.EQ.'OFF')GOTO1319
27873      WRITE(ICOUT,999)
27874      CALL DPWRST('XXX','BUG ')
27875      I=1
27876      WRITE(ICOUT,1316)IBAPLI(I)
27877 1316 FORMAT('THE LINE TYPE FOR ALL BAR PATTERNS',
27878     1' HAS JUST BEEN SET TO ',A4)
27879      CALL DPWRST('XXX','BUG ')
27880 1319 CONTINUE
27881      IFOUND='YES'
27882      GOTO9000
27883C
27884C               *****************
27885C               **  STEP 90--  **
27886C               **  EXIT       **
27887C               *****************
27888C
27889 9000 CONTINUE
27890      IF(IBUGP2.EQ.'OFF')GOTO9090
27891      WRITE(ICOUT,9011)
27892 9011 FORMAT('***** AT THE END       OF DPBPLI--')
27893      CALL DPWRST('XXX','BUG ')
27894      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
27895 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
27896      CALL DPWRST('XXX','BUG ')
27897      WRITE(ICOUT,9013)MAXBAR,NUMBAR
27898 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
27899      CALL DPWRST('XXX','BUG ')
27900      WRITE(ICOUT,9014)IHOLD1,IHOLD2
27901 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
27902      CALL DPWRST('XXX','BUG ')
27903      WRITE(ICOUT,9015)IDEBPL
27904 9015 FORMAT('IDEBPL = ',A4)
27905      CALL DPWRST('XXX','BUG ')
27906      WRITE(ICOUT,9020)NUMARG
27907 9020 FORMAT('NUMARG = ',I8)
27908      CALL DPWRST('XXX','BUG ')
27909      DO9025I=1,NUMARG
27910      WRITE(ICOUT,9026)IHARG(I)
27911 9026 FORMAT('IHARG(I) = ',A4)
27912      CALL DPWRST('XXX','BUG ')
27913 9025 CONTINUE
27914      WRITE(ICOUT,9030)IBAPLI(1)
27915 9030 FORMAT('IBAPLI(1) = ',A4)
27916      CALL DPWRST('XXX','BUG ')
27917      DO9035I=1,10
27918      WRITE(ICOUT,9036)I,IBAPLI(I)
27919 9036 FORMAT('I,IBAPLI(I) = ',I8,2X,A4)
27920      CALL DPWRST('XXX','BUG ')
27921 9035 CONTINUE
27922 9090 CONTINUE
27923C
27924      RETURN
27925      END
27926      SUBROUTINE DPBPSE(P1,N1,P2,N2,ALPHA,ICASAN,IWRITE,
27927     1                  STATVA,STATSE,ALOWLM,AUPPLM,
27928     1                  IBUGA3,ISUBRO,IERROR)
27929C
27930C     PURPOSE--FOR TWO BINOMIAL PROPORTIONS (P1, N1, P2, N2),
27931C              COMPUTE THE STANDARD ERROR OF THE PRODUCT P1*P2.
27932C
27933C                 SE = SQRT(P2HAT**2*P1HAT*(1 - P1PHAT)/N1 +
27934C                           P1HAT**2*P2HAT*(1 - P2HAT)/N2)
27935C
27936C              WHERE
27937C
27938C                 PHAT(i) = (X(i) + 0.5)/(N(i) + 1)
27939C
27940C              RETURN THE PRODUCT, THE STANDARD ERROR, AND THE
27941C              LOWER AND UPPER CONFIDENCE LIMITS.
27942C     REFERENCE--PRIVATE COMMUNICATION WITH ANDREW RUHKIN AND
27943C                BILL STRAWDERMAN OF THE NIST STATISTICAL ENGINEERING
27944C                DIVISION.
27945C     WRITTEN BY--JAMES J. FILLIBEN
27946C                 STATISTICAL ENGINEERING DIVISION
27947C                 INFORMATION TECHNOLOGY LABORATORY
27948C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
27949C                 GAITHERSBURG, MD 20899-8980
27950C                 PHONE--301-975-2855
27951C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
27952C           OF THE NATIONAL BUREAU OF STANDARDS.
27953C     LANGUAGE--ANSI FORTRAN (1977)
27954C     VERSION NUMBER--2010/7
27955C     ORIGINAL VERSION--JULY      2010.
27956C
27957C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
27958C
27959      CHARACTER*4 ICASAN
27960      CHARACTER*4 IWRITE
27961      CHARACTER*4 IBUGA3
27962      CHARACTER*4 ISUBRO
27963      CHARACTER*4 IERROR
27964C
27965      CHARACTER*4 ISUBN1
27966      CHARACTER*4 ISUBN2
27967C
27968C---------------------------------------------------------------------
27969C
27970      REAL P1
27971      REAL P2
27972      REAL STATVA
27973      REAL STATSE
27974      REAL ALOWLM
27975      REAL AUPPLM
27976      INTEGER N1
27977      INTEGER N2
27978C
27979      DOUBLE PRECISION DTERM1
27980      DOUBLE PRECISION DTERM2
27981      DOUBLE PRECISION DDELTA
27982      DOUBLE PRECISION DP1
27983      DOUBLE PRECISION DP2
27984      DOUBLE PRECISION DN1
27985      DOUBLE PRECISION DN2
27986      DOUBLE PRECISION DPPF
27987C
27988C---------------------------------------------------------------------
27989C
27990      INCLUDE 'DPCOP2.INC'
27991C
27992C-----START POINT-----------------------------------------------------
27993C
27994      ISUBN1='DPRU'
27995      ISUBN2='H3  '
27996      IERROR='NO'
27997C
27998      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BPSE')THEN
27999        WRITE(ICOUT,999)
28000  999   FORMAT(1X)
28001        CALL DPWRST('XXX','BUG ')
28002        WRITE(ICOUT,51)
28003   51   FORMAT('***** AT THE BEGINNING OF DPBPSE--')
28004        CALL DPWRST('XXX','BUG ')
28005        WRITE(ICOUT,52)IBUGA3,ICASAN,IWRITE
28006   52   FORMAT('IBUGA3,ICASAN,IWRITE = ',2A4,2X,A4)
28007        CALL DPWRST('XXX','BUG ')
28008        WRITE(ICOUT,53)P1,N1,P2,N2,ALPHA
28009   53   FORMAT('P1,N1,P2,N2 = ',2(G15.7,I8),G15.7)
28010        CALL DPWRST('XXX','BUG ')
28011        WRITE(ICOUT,999)
28012        CALL DPWRST('XXX','BUG ')
28013      ENDIF
28014C
28015C               ********************************
28016C               **  STEP 1--                  **
28017C               **  CHECK FOR INPUT ERRORS    **
28018C               ********************************
28019C
28020      STATVA=0.0
28021      STATSE=0.0
28022      ALOWLM=0.0
28023      AUPPLM=1.0
28024C
28025      IF(N1.LT.1)THEN
28026        WRITE(ICOUT,999)
28027        CALL DPWRST('XXX','WRIT')
28028        WRITE(ICOUT,111)
28029  111   FORMAT('****** ERROR IN BINOMIAL PRODUCT STANDARD ERROR--')
28030        CALL DPWRST('XXX','BUG ')
28031        WRITE(ICOUT,113)
28032  113   FORMAT('         THE NUMBER OF OBSERVATIONS FOR THE FIRST ',
28033     1         'RESPONSE VARIABLE IS LESS THAN 1.')
28034        CALL DPWRST('XXX','WRIT')
28035        WRITE(ICOUT,114)N1
28036  114   FORMAT('SAMPLE SIZE = ',I8)
28037        CALL DPWRST('XXX','WRIT')
28038        IERROR='YES'
28039        GOTO9000
28040      ENDIF
28041C
28042      IF(N2.LT.2)THEN
28043        WRITE(ICOUT,999)
28044        CALL DPWRST('XXX','WRIT')
28045        WRITE(ICOUT,111)
28046        CALL DPWRST('XXX','BUG ')
28047        WRITE(ICOUT,123)
28048  123   FORMAT('         THE NUMBER OF OBSERVATIONS FOR THE ',
28049     1         'SECOND RESPONSE VARIABLE IS LESS THAN 1.')
28050        CALL DPWRST('XXX','WRIT')
28051        WRITE(ICOUT,114)N2
28052        CALL DPWRST('XXX','WRIT')
28053        IERROR='YES'
28054        GOTO9000
28055      ENDIF
28056C
28057      IF(P1.LT.0.0 .OR. P1.GT.1.0)THEN
28058        IERROR='YES'
28059        WRITE(ICOUT,999)
28060        CALL DPWRST('XXX','BUG ')
28061        WRITE(ICOUT,111)
28062        CALL DPWRST('XXX','BUG ')
28063        WRITE(ICOUT,162)
28064  162   FORMAT('      THE BINOMIAL PROBABILITY OF SUCCESS PARAMETER ',
28065     1         'FOR THE')
28066        CALL DPWRST('XXX','BUG ')
28067        WRITE(ICOUT,164)
28068  164   FORMAT('      FIRST RESPONSE VARIABLE IS OUTSIDE THE ',
28069     1         '(0,1) INTERVAL.')
28070        CALL DPWRST('XXX','BUG ')
28071        WRITE(ICOUT,167)P1
28072  167   FORMAT('      THE PROBABILITY OF SUCCESS PARAMETER = ',G15.7)
28073        CALL DPWRST('XXX','BUG ')
28074        GOTO9000
28075      ENDIF
28076C
28077      IF(P2.LT.0.0 .OR. P2.GT.1.0)THEN
28078        IERROR='YES'
28079        WRITE(ICOUT,999)
28080        CALL DPWRST('XXX','BUG ')
28081        WRITE(ICOUT,111)
28082        CALL DPWRST('XXX','BUG ')
28083        WRITE(ICOUT,162)
28084        CALL DPWRST('XXX','BUG ')
28085        WRITE(ICOUT,174)
28086  174   FORMAT('      SECOND RESPONSE VARIABLE IS OUTSIDE THE ',
28087     1         '(0,1) INTERVAL.')
28088        CALL DPWRST('XXX','BUG ')
28089        WRITE(ICOUT,167)P2
28090        CALL DPWRST('XXX','BUG ')
28091        GOTO9000
28092      ENDIF
28093C
28094      ALPHSV=ALPHA
28095      IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0
28096      IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN
28097        IERROR='YES'
28098        WRITE(ICOUT,999)
28099        CALL DPWRST('XXX','BUG ')
28100        WRITE(ICOUT,111)
28101        CALL DPWRST('XXX','BUG ')
28102        WRITE(ICOUT,192)
28103  192   FORMAT('      THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ',
28104     1         'INTERVAL.')
28105        CALL DPWRST('XXX','BUG ')
28106        WRITE(ICOUT,197)ALPHA
28107  197   FORMAT('      THE VALUE OF ALPHA = ',G15.7)
28108        CALL DPWRST('XXX','BUG ')
28109        GOTO9000
28110      ENDIF
28111C
28112CCCCC FOR THESE FORMULAS, WE WANT ALPHA AS 0.05 RATHER THAN
28113CCCCC 0.95.
28114C
28115CCCCC IF(ALPHA.LT.0.5)ALPHA=1.0 - ALPHA
28116      IF(ALPHA.GT.0.5)ALPHA=1.0 - ALPHA
28117C
28118C               ********************************************
28119C               **  STEP 2--                              **
28120C               **  COMPUTE THE PRODUCT OF TWO BINOMOAL   **
28121C               **  PROPORTIONS CONFIDENCE INTERVAL.      **
28122C               ********************************************
28123C
28124C     DEFINE CORRECTION TERM:
28125C
28126C        P(i) = (X(i) + 0.5)/(N(i) + 1)
28127C
28128      X1=P1*REAL(N1)
28129      IX1=INT(X1+0.01)
28130      X1=REAL(IX1)
28131      P1=(X1+0.5)/(REAL(N1)+1.0)
28132      X2=P2*REAL(N2)
28133      IX2=INT(X2+0.01)
28134      X2=REAL(IX2)
28135      P2=(X2+0.5)/(REAL(N2)+1.0)
28136C
28137      STATVA=P1*P2
28138C
28139      DN1=DBLE(N1)
28140      DN2=DBLE(N2)
28141      DP1=DBLE(P1)
28142      DP2=DBLE(P2)
28143C
28144      DTERM1=(DP2**2)*DP1*(1.0D0 - DP1)/DN1
28145      DTERM2=(DP1**2)*DP2*(1.0D0 - DP2)/DN2
28146      DDELTA=DSQRT(DTERM1 + DTERM2)
28147      STATSE=REAL(DDELTA)
28148C
28149      ALP2=ALPHA/2.0
28150      IF(ALP2.LE.0.5)ALP2=1.0 - ALP2
28151      CALL NODPPF(DBLE(ALP2),DPPF)
28152      A1=STATVA - REAL(DPPF*DDELTA)
28153      A2=STATVA + REAL(DPPF*DDELTA)
28154      ALOWLM=MIN(A1,A2)
28155      AUPPLM=MAX(A1,A2)
28156      IF(ALOWLM.LT.0.0)ALOWLM=0.0
28157      IF(AUPPLM.GT.1.0)AUPPLM=1.0
28158C
28159C
28160C               *****************
28161C               **  STEP 90--  **
28162C               **  EXIT.      **
28163C               *****************
28164C
28165 9000 CONTINUE
28166C
28167      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BPSE')THEN
28168        WRITE(ICOUT,999)
28169        CALL DPWRST('XXX','BUG ')
28170        WRITE(ICOUT,9011)
28171 9011   FORMAT('***** AT THE END       OF DPBPSE--')
28172        CALL DPWRST('XXX','BUG ')
28173        WRITE(ICOUT,9012)IBUGA3,IERROR
28174 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
28175        CALL DPWRST('XXX','BUG ')
28176        WRITE(ICOUT,9013)STATVA,STATSE,ALP2,DPPF
28177 9013   FORMAT('STATVA,STATSE,ALP2,DPPF = ',3G15.7,2X,G15.7)
28178        CALL DPWRST('XXX','BUG ')
28179        WRITE(ICOUT,9014)A1,A2,ALOWLM,AUPPLM
28180 9014   FORMAT('A1,A2,ALOWLM,AUPPLM = ',4(G15.7,2X))
28181        CALL DPWRST('XXX','BUG ')
28182        WRITE(ICOUT,9019)STATVA,STATSE
28183 9019   FORMAT('STATVA,STATSE = ',2(G15.7,2X))
28184        CALL DPWRST('XXX','BUG ')
28185      ENDIF
28186C
28187      RETURN
28188      END
28189      SUBROUTINE DPBPSP(IHARG,IARGT,ARG,NUMARG,PDEBPS,MAXBAR,PBAPSP,
28190     1IBUGP2,IFOUND,IERROR)
28191C
28192C     PURPOSE--DEFINE THE BAR PATTERN SPACINGS = THE SPACINGS
28193C              BETWEEN THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE BARS.
28194C              THESE ARE LOCATED IN THE VECTOR PBAPSP(.).
28195C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
28196C                     --IARGT  (A  CHARACTER VECTOR)
28197C                     --ARG
28198C                     --NUMARG
28199C                     --PDEBPS
28200C                     --MAXBAR
28201C                     --IBUGP2 ('ON' OR 'OFF' )
28202C     OUTPUT ARGUMENTS--PBAPSP (A FLOATING POINT VECTOR)
28203C                     --IFOUND ('YES' OR 'NO' )
28204C                     --IERROR ('YES' OR 'NO' )
28205C     WRITTEN BY--JAMES J. FILLIBEN
28206C                 STATISTICAL ENGINEERING DIVISION
28207C                 INFORMATION TECHNOLOGY LABORATORY
28208C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
28209C                 GAITHERSBURG, MD 20899-8980
28210C                 PHONE--301-975-2855
28211C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28212C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
28213C     LANGUAGE--ANSI FORTRAN (1977)
28214C     VERSION NUMBER--82/7
28215C     ORIGINAL VERSION--DECEMBER  1983.
28216C
28217C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28218C
28219      CHARACTER*4 IHARG
28220      CHARACTER*4 IARGT
28221C
28222      CHARACTER*4 IBUGP2
28223      CHARACTER*4 IFOUND
28224      CHARACTER*4 IERROR
28225C
28226      CHARACTER*4 IHOLD1
28227C
28228      CHARACTER*4 ISUBN1
28229      CHARACTER*4 ISUBN2
28230      CHARACTER*4 ISTEPN
28231C
28232      DIMENSION IHARG(*)
28233      DIMENSION IARGT(*)
28234      DIMENSION ARG(*)
28235      DIMENSION PBAPSP(*)
28236C
28237C---------------------------------------------------------------------
28238C
28239      INCLUDE 'DPCOP2.INC'
28240C
28241C-----START POINT-----------------------------------------------------
28242C
28243      IFOUND='NO'
28244      IERROR='NO'
28245C
28246      ISUBN1='DPBP'
28247      ISUBN2='SP  '
28248C
28249      NUMBAR=0
28250      IHOLD1='-999'
28251      HOLD1=-999.0
28252      HOLD2=-999.0
28253C
28254      IF(IBUGP2.EQ.'OFF')GOTO90
28255      WRITE(ICOUT,999)
28256  999 FORMAT(1X)
28257      CALL DPWRST('XXX','BUG ')
28258      WRITE(ICOUT,51)
28259   51 FORMAT('***** AT THE BEGINNING OF DPBPSP--')
28260      CALL DPWRST('XXX','BUG ')
28261      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
28262   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
28263      CALL DPWRST('XXX','BUG ')
28264      WRITE(ICOUT,53)MAXBAR,NUMBAR
28265   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
28266      CALL DPWRST('XXX','BUG ')
28267      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
28268   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
28269      CALL DPWRST('XXX','BUG ')
28270      WRITE(ICOUT,55)PDEBPS
28271   55 FORMAT('PDEBPS = ',E15.7)
28272      CALL DPWRST('XXX','BUG ')
28273      WRITE(ICOUT,60)NUMARG
28274   60 FORMAT('NUMARG = ',I8)
28275      CALL DPWRST('XXX','BUG ')
28276      DO65I=1,NUMARG
28277      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
28278   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
28279      CALL DPWRST('XXX','BUG ')
28280   65 CONTINUE
28281      WRITE(ICOUT,70)PBAPSP(1)
28282   70 FORMAT('PBAPSP(1) = ',E15.7)
28283      CALL DPWRST('XXX','BUG ')
28284      DO75I=1,10
28285      WRITE(ICOUT,76)I,PBAPSP(I)
28286   76 FORMAT('I,PBAPSP(I) = ',I8,2X,E15.7)
28287      CALL DPWRST('XXX','BUG ')
28288   75 CONTINUE
28289   90 CONTINUE
28290C
28291C               **************************************
28292C               **  STEP 1--                        **
28293C               **  BRANCH TO THE APPROPRIATE CASE  **
28294C               **************************************
28295C
28296      ISTEPN='1'
28297      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28298C
28299      IF(NUMARG.LE.1)GOTO9000
28300      IF(NUMARG.EQ.2)GOTO1120
28301      IF(NUMARG.EQ.3)GOTO1130
28302      IF(NUMARG.EQ.4)GOTO1140
28303      GOTO1150
28304C
28305 1120 CONTINUE
28306      GOTO1200
28307C
28308 1130 CONTINUE
28309      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
28310      IF(IHARG(3).EQ.'ALL')HOLD1=PDEBPS
28311      IF(IHARG(3).EQ.'ALL')GOTO1300
28312      GOTO1200
28313C
28314 1140 CONTINUE
28315      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
28316      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4)
28317      IF(IHARG(3).EQ.'ALL')GOTO1300
28318      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
28319      IF(IHARG(4).EQ.'ALL')HOLD1=ARG(3)
28320      IF(IHARG(4).EQ.'ALL')GOTO1300
28321      GOTO1200
28322C
28323 1150 CONTINUE
28324      GOTO1200
28325C
28326C               *************************************************
28327C               **  STEP 2--                                   **
28328C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
28329C               *************************************************
28330C
28331 1200 CONTINUE
28332      ISTEPN='2'
28333      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28334C
28335      IF(NUMARG.LE.2)GOTO1210
28336      GOTO1220
28337C
28338 1210 CONTINUE
28339      NUMBAR=1
28340      PBAPSP(1)=PDEBPS
28341      GOTO1270
28342C
28343 1220 CONTINUE
28344      NUMBAR=NUMARG-2
28345      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
28346      DO1225I=1,NUMBAR
28347      J=I+2
28348      IHOLD1=IHARG(J)
28349      HOLD1=ARG(J)
28350      HOLD2=HOLD1
28351      IF(IHOLD1.EQ.'ON')HOLD2=PDEBPS
28352      IF(IHOLD1.EQ.'OFF')HOLD2=PDEBPS
28353      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBPS
28354      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBPS
28355      PBAPSP(I)=HOLD2
28356 1225 CONTINUE
28357      GOTO1270
28358C
28359 1270 CONTINUE
28360      IF(IFEEDB.EQ.'OFF')GOTO1279
28361      WRITE(ICOUT,999)
28362      CALL DPWRST('XXX','BUG ')
28363      DO1278I=1,NUMBAR
28364      WRITE(ICOUT,1276)I,PBAPSP(I)
28365 1276 FORMAT('THE SPACING BETWEEN (LINES WITHIN) PATTERN ',I6,
28366     1' HAS JUST BEEN SET TO ',E15.7)
28367      CALL DPWRST('XXX','BUG ')
28368 1278 CONTINUE
28369 1279 CONTINUE
28370      IFOUND='YES'
28371      GOTO9000
28372C
28373C               **************************
28374C               **  STEP 3--            **
28375C               **  TREAT THE ALL CASE  **
28376C               **************************
28377C
28378 1300 CONTINUE
28379      ISTEPN='3'
28380      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28381C
28382      NUMBAR=MAXBAR
28383      HOLD2=HOLD1
28384      IF(IHOLD1.EQ.'ON')HOLD2=PDEBPS
28385      IF(IHOLD1.EQ.'OFF')HOLD2=PDEBPS
28386      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBPS
28387      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBPS
28388      DO1315I=1,NUMBAR
28389      PBAPSP(I)=HOLD2
28390 1315 CONTINUE
28391      GOTO1370
28392C
28393 1370 CONTINUE
28394      IF(IFEEDB.EQ.'OFF')GOTO1319
28395      WRITE(ICOUT,999)
28396      CALL DPWRST('XXX','BUG ')
28397      I=1
28398      WRITE(ICOUT,1316)PBAPSP(I)
28399 1316 FORMAT('THE SPACING BETWEEN (LINES WITHIN) ALL PATTERNS',
28400     1' HAS JUST BEEN SET TO ',E15.7)
28401      CALL DPWRST('XXX','BUG ')
28402 1319 CONTINUE
28403      IFOUND='YES'
28404      GOTO9000
28405C
28406C               *****************
28407C               **  STEP 90--  **
28408C               **  EXIT       **
28409C               *****************
28410C
28411 9000 CONTINUE
28412      IF(IBUGP2.EQ.'OFF')GOTO9090
28413      WRITE(ICOUT,9011)
28414 9011 FORMAT('***** AT THE END       OF DPBPSP--')
28415      CALL DPWRST('XXX','BUG ')
28416      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
28417 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
28418      CALL DPWRST('XXX','BUG ')
28419      WRITE(ICOUT,9013)MAXBAR,NUMBAR
28420 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
28421      CALL DPWRST('XXX','BUG ')
28422      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
28423 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
28424      CALL DPWRST('XXX','BUG ')
28425      WRITE(ICOUT,9015)PDEBPS
28426 9015 FORMAT('PDEBPS = ',E15.7)
28427      CALL DPWRST('XXX','BUG ')
28428      WRITE(ICOUT,9020)NUMARG
28429 9020 FORMAT('NUMARG = ',I8)
28430      CALL DPWRST('XXX','BUG ')
28431      DO9025I=1,NUMARG
28432      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
28433 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
28434      CALL DPWRST('XXX','BUG ')
28435 9025 CONTINUE
28436      WRITE(ICOUT,9030)PBAPSP(1)
28437 9030 FORMAT('PBAPSP(1) = ',E15.7)
28438      CALL DPWRST('XXX','BUG ')
28439      DO9035I=1,10
28440      WRITE(ICOUT,9036)I,PBAPSP(I)
28441 9036 FORMAT('I,PBAPSP(I) = ',I8,2X,E15.7)
28442      CALL DPWRST('XXX','BUG ')
28443 9035 CONTINUE
28444 9090 CONTINUE
28445C
28446      RETURN
28447      END
28448      SUBROUTINE DPBPTH(IHARG,IARGT,ARG,NUMARG,PDEBPT,MAXBAR,PBAPTH,
28449     1IBUGP2,IFOUND,IERROR)
28450C
28451C     PURPOSE--DEFINE THE BAR PATTERN THICKNESSES = THE THICKNESSES
28452C              OF THE LINES WHICH MAKE UP THE PATTERNS WITHIN THE BARS.
28453C              THESE ARE LOCATED IN THE VECTOR PBAPTH(.).
28454C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
28455C                     --IARGT  (A  CHARACTER VECTOR)
28456C                     --ARG
28457C                     --NUMARG
28458C                     --PDEBPT
28459C                     --MAXBAR
28460C                     --IBUGP2 ('ON' OR 'OFF' )
28461C     OUTPUT ARGUMENTS--PBAPTH (A FLOATING POINT VECTOR)
28462C                     --IFOUND ('YES' OR 'NO' )
28463C                     --IERROR ('YES' OR 'NO' )
28464C     WRITTEN BY--JAMES J. FILLIBEN
28465C                 STATISTICAL ENGINEERING DIVISION
28466C                 INFORMATION TECHNOLOGY LABORATORY
28467C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
28468C                 GAITHERSBURG, MD 20899-8980
28469C                 PHONE--301-975-2855
28470C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28471C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
28472C     LANGUAGE--ANSI FORTRAN (1977)
28473C     VERSION NUMBER--82/7
28474C     ORIGINAL VERSION--DECEMBER  1983.
28475C
28476C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28477C
28478      CHARACTER*4 IHARG
28479      CHARACTER*4 IARGT
28480C
28481      CHARACTER*4 IBUGP2
28482      CHARACTER*4 IFOUND
28483      CHARACTER*4 IERROR
28484C
28485      CHARACTER*4 IHOLD1
28486C
28487      CHARACTER*4 ISUBN1
28488      CHARACTER*4 ISUBN2
28489      CHARACTER*4 ISTEPN
28490C
28491      DIMENSION IHARG(*)
28492      DIMENSION IARGT(*)
28493      DIMENSION ARG(*)
28494      DIMENSION PBAPTH(*)
28495C
28496C---------------------------------------------------------------------
28497C
28498      INCLUDE 'DPCOP2.INC'
28499C
28500C-----START POINT-----------------------------------------------------
28501C
28502      IFOUND='NO'
28503      IERROR='NO'
28504C
28505      ISUBN1='DPBP'
28506      ISUBN2='TH  '
28507C
28508      NUMBAR=0
28509      IHOLD1='-999'
28510      HOLD1=-999.0
28511      HOLD2=-999.0
28512C
28513      IF(IBUGP2.EQ.'OFF')GOTO90
28514      WRITE(ICOUT,999)
28515  999 FORMAT(1X)
28516      CALL DPWRST('XXX','BUG ')
28517      WRITE(ICOUT,51)
28518   51 FORMAT('***** AT THE BEGINNING OF DPBPTH--')
28519      CALL DPWRST('XXX','BUG ')
28520      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
28521   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
28522      CALL DPWRST('XXX','BUG ')
28523      WRITE(ICOUT,53)MAXBAR,NUMBAR
28524   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
28525      CALL DPWRST('XXX','BUG ')
28526      WRITE(ICOUT,54)IHOLD1,HOLD1,HOLD2
28527   54 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
28528      CALL DPWRST('XXX','BUG ')
28529      WRITE(ICOUT,55)PDEBPT
28530   55 FORMAT('PDEBPT = ',E15.7)
28531      CALL DPWRST('XXX','BUG ')
28532      WRITE(ICOUT,60)NUMARG
28533   60 FORMAT('NUMARG = ',I8)
28534      CALL DPWRST('XXX','BUG ')
28535      DO65I=1,NUMARG
28536      WRITE(ICOUT,66)IHARG(I),IARGT(I),ARG(I)
28537   66 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
28538      CALL DPWRST('XXX','BUG ')
28539   65 CONTINUE
28540      WRITE(ICOUT,70)PBAPTH(1)
28541   70 FORMAT('PBAPTH(1) = ',E15.7)
28542      CALL DPWRST('XXX','BUG ')
28543      DO75I=1,10
28544      WRITE(ICOUT,76)I,PBAPTH(I)
28545   76 FORMAT('I,PBAPTH(I) = ',I8,2X,E15.7)
28546      CALL DPWRST('XXX','BUG ')
28547   75 CONTINUE
28548   90 CONTINUE
28549C
28550C               **************************************
28551C               **  STEP 1--                        **
28552C               **  BRANCH TO THE APPROPRIATE CASE  **
28553C               **************************************
28554C
28555      ISTEPN='1'
28556      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28557C
28558      IF(NUMARG.LE.1)GOTO9000
28559      IF(NUMARG.EQ.2)GOTO1120
28560      IF(NUMARG.EQ.3)GOTO1130
28561      IF(NUMARG.EQ.4)GOTO1140
28562      GOTO1150
28563C
28564 1120 CONTINUE
28565      GOTO1200
28566C
28567 1130 CONTINUE
28568      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
28569      IF(IHARG(3).EQ.'ALL')HOLD1=PDEBPT
28570      IF(IHARG(3).EQ.'ALL')GOTO1300
28571      GOTO1200
28572C
28573 1140 CONTINUE
28574      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
28575      IF(IHARG(3).EQ.'ALL')HOLD1=ARG(4)
28576      IF(IHARG(3).EQ.'ALL')GOTO1300
28577      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
28578      IF(IHARG(4).EQ.'ALL')HOLD1=ARG(2)
28579      IF(IHARG(4).EQ.'ALL')GOTO1300
28580      GOTO1200
28581C
28582 1150 CONTINUE
28583      GOTO1200
28584C
28585C               *************************************************
28586C               **  STEP 2--                                   **
28587C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
28588C               *************************************************
28589C
28590 1200 CONTINUE
28591      ISTEPN='2'
28592      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28593C
28594      IF(NUMARG.LE.2)GOTO1210
28595      GOTO1220
28596C
28597 1210 CONTINUE
28598      NUMBAR=1
28599      PBAPTH(1)=PDEBPT
28600      GOTO1270
28601C
28602 1220 CONTINUE
28603      NUMBAR=NUMARG-2
28604      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
28605      DO1225I=1,NUMBAR
28606      J=I+2
28607      IHOLD1=IHARG(J)
28608      HOLD1=ARG(J)
28609      HOLD2=HOLD1
28610      IF(IHOLD1.EQ.'ON')HOLD2=PDEBPT
28611      IF(IHOLD1.EQ.'OFF')HOLD2=PDEBPT
28612      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBPT
28613      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBPT
28614      PBAPTH(I)=HOLD2
28615 1225 CONTINUE
28616      GOTO1270
28617C
28618 1270 CONTINUE
28619      IF(IFEEDB.EQ.'OFF')GOTO1279
28620      WRITE(ICOUT,999)
28621      CALL DPWRST('XXX','BUG ')
28622      DO1278I=1,NUMBAR
28623      WRITE(ICOUT,1276)I,PBAPTH(I)
28624 1276 FORMAT('THE THICKNESS OF (LINES WITHIN) PATTERN ',I6,
28625     1' HAS JUST BEEN SET TO ',E15.7)
28626      CALL DPWRST('XXX','BUG ')
28627 1278 CONTINUE
28628 1279 CONTINUE
28629      IFOUND='YES'
28630      GOTO9000
28631C
28632C               **************************
28633C               **  STEP 3--            **
28634C               **  TREAT THE ALL CASE  **
28635C               **************************
28636C
28637 1300 CONTINUE
28638      ISTEPN='3'
28639      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28640C
28641      NUMBAR=MAXBAR
28642      HOLD2=HOLD1
28643      IF(IHOLD1.EQ.'ON')HOLD2=PDEBPT
28644      IF(IHOLD1.EQ.'OFF')HOLD2=PDEBPT
28645      IF(IHOLD1.EQ.'AUTO')HOLD2=PDEBPT
28646      IF(IHOLD1.EQ.'DEFA')HOLD2=PDEBPT
28647      DO1315I=1,NUMBAR
28648      PBAPTH(I)=HOLD2
28649 1315 CONTINUE
28650      GOTO1370
28651C
28652 1370 CONTINUE
28653      IF(IFEEDB.EQ.'OFF')GOTO1319
28654      WRITE(ICOUT,999)
28655      CALL DPWRST('XXX','BUG ')
28656      I=1
28657      WRITE(ICOUT,1316)PBAPTH(I)
28658 1316 FORMAT('THE THICKNESS OF (LINES WITHIN) ALL PATTERNS',
28659     1' HAS JUST BEEN SET TO ',E15.7)
28660      CALL DPWRST('XXX','BUG ')
28661 1319 CONTINUE
28662      IFOUND='YES'
28663      GOTO9000
28664C
28665C               *****************
28666C               **  STEP 90--  **
28667C               **  EXIT       **
28668C               *****************
28669C
28670 9000 CONTINUE
28671      IF(IBUGP2.EQ.'OFF')GOTO9090
28672      WRITE(ICOUT,9011)
28673 9011 FORMAT('***** AT THE END       OF DPBPTH--')
28674      CALL DPWRST('XXX','BUG ')
28675      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
28676 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
28677      CALL DPWRST('XXX','BUG ')
28678      WRITE(ICOUT,9013)MAXBAR,NUMBAR
28679 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
28680      CALL DPWRST('XXX','BUG ')
28681      WRITE(ICOUT,9014)IHOLD1,HOLD1,HOLD2
28682 9014 FORMAT('IHOLD1,HOLD1,HOLD2 = ',A4,2E15.7)
28683      CALL DPWRST('XXX','BUG ')
28684      WRITE(ICOUT,9015)PDEBPT
28685 9015 FORMAT('PDEBPT = ',E15.7)
28686      CALL DPWRST('XXX','BUG ')
28687      WRITE(ICOUT,9020)NUMARG
28688 9020 FORMAT('NUMARG = ',I8)
28689      CALL DPWRST('XXX','BUG ')
28690      DO9025I=1,NUMARG
28691      WRITE(ICOUT,9026)IHARG(I),IARGT(I),ARG(I)
28692 9026 FORMAT('IHARG(I),IARGT(I),ARG(I) = ',A4,2X,A4,I8)
28693      CALL DPWRST('XXX','BUG ')
28694 9025 CONTINUE
28695      WRITE(ICOUT,9030)PBAPTH(1)
28696 9030 FORMAT('PBAPTH(1) = ',E15.7)
28697      CALL DPWRST('XXX','BUG ')
28698      DO9035I=1,10
28699      WRITE(ICOUT,9036)I,PBAPTH(I)
28700 9036 FORMAT('I,PBAPTH(I) = ',I8,2X,E15.7)
28701      CALL DPWRST('XXX','BUG ')
28702 9035 CONTINUE
28703 9090 CONTINUE
28704C
28705      RETURN
28706      END
28707      SUBROUTINE DPBPTY(IHARG,NUMARG,IDEBPT,MAXBAR,IBAPTY,
28708     1IBUGP2,IFOUND,IERROR)
28709C
28710C     PURPOSE--DEFINE THE PATTERN TYPES = THE TYPES
28711C              OF THE PATTERN WITHIN THE BARS.
28712C              THESE ARE LOCATED IN THE VECTOR IBAPTY(.).
28713C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
28714C                     --NUMARG
28715C                     --IDEBPT
28716C                     --MAXBAR
28717C                     --IBUGP2 ('ON' OR 'OFF' )
28718C     OUTPUT ARGUMENTS--IBAPTY (A CHARACTER VECTOR)
28719C                     --IFOUND ('YES' OR 'NO' )
28720C                     --IERROR ('YES' OR 'NO' )
28721C     WRITTEN BY--JAMES J. FILLIBEN
28722C                 STATISTICAL ENGINEERING DIVISION
28723C                 INFORMATION TECHNOLOGY LABORATORY
28724C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
28725C                 GAITHERSBURG, MD 20899-8980
28726C                 PHONE--301-975-2855
28727C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28728C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
28729C     LANGUAGE--ANSI FORTRAN (1977)
28730C     VERSION NUMBER--82/7
28731C     ORIGINAL VERSION--DECEMBER  1983.
28732C
28733C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28734C
28735      CHARACTER*4 IHARG
28736      CHARACTER*4 IDEBPT
28737      CHARACTER*4 IBAPTY
28738C
28739      CHARACTER*4 IBUGP2
28740      CHARACTER*4 IFOUND
28741      CHARACTER*4 IERROR
28742C
28743      CHARACTER*4 IHOLD1
28744      CHARACTER*4 IHOLD2
28745C
28746      CHARACTER*4 ISUBN1
28747      CHARACTER*4 ISUBN2
28748      CHARACTER*4 ISTEPN
28749C
28750      DIMENSION IHARG(*)
28751      DIMENSION IBAPTY(*)
28752C
28753C---------------------------------------------------------------------
28754C
28755      INCLUDE 'DPCOP2.INC'
28756C
28757C-----START POINT-----------------------------------------------------
28758C
28759      IFOUND='NO'
28760      IERROR='NO'
28761C
28762      ISUBN1='DPBP'
28763      ISUBN2='TY  '
28764C
28765      NUMBAR=0
28766      IHOLD1='-999'
28767      IHOLD2='-999'
28768C
28769      IF(IBUGP2.EQ.'OFF')GOTO90
28770      WRITE(ICOUT,999)
28771  999 FORMAT(1X)
28772      CALL DPWRST('XXX','BUG ')
28773      WRITE(ICOUT,51)
28774   51 FORMAT('***** AT THE BEGINNING OF DPBPTY--')
28775      CALL DPWRST('XXX','BUG ')
28776      WRITE(ICOUT,52)IBUGP2,IFOUND,IERROR
28777   52 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
28778      CALL DPWRST('XXX','BUG ')
28779      WRITE(ICOUT,53)MAXBAR,NUMBAR
28780   53 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
28781      CALL DPWRST('XXX','BUG ')
28782      WRITE(ICOUT,54)IHOLD1,IHOLD2
28783   54 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
28784      CALL DPWRST('XXX','BUG ')
28785      WRITE(ICOUT,55)IDEBPT
28786   55 FORMAT('IDEBPT = ',A4)
28787      CALL DPWRST('XXX','BUG ')
28788      WRITE(ICOUT,60)NUMARG
28789   60 FORMAT('NUMARG = ',I8)
28790      CALL DPWRST('XXX','BUG ')
28791      DO65I=1,NUMARG
28792      WRITE(ICOUT,66)IHARG(I)
28793   66 FORMAT('IHARG(I) = ',A4)
28794      CALL DPWRST('XXX','BUG ')
28795   65 CONTINUE
28796      WRITE(ICOUT,70)IBAPTY(1)
28797   70 FORMAT('IBAPTY(1) = ',A4)
28798      CALL DPWRST('XXX','BUG ')
28799      DO75I=1,10
28800      WRITE(ICOUT,76)I,IBAPTY(I)
28801   76 FORMAT('I,IBAPTY(I) = ',I8,2X,A4)
28802      CALL DPWRST('XXX','BUG ')
28803   75 CONTINUE
28804   90 CONTINUE
28805C
28806C               **************************************
28807C               **  STEP 1--                        **
28808C               **  BRANCH TO THE APPROPRIATE CASE  **
28809C               **************************************
28810C
28811      ISTEPN='1'
28812      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28813C
28814      IF(NUMARG.LE.1)GOTO9000
28815      IF(NUMARG.EQ.2)GOTO1120
28816      IF(NUMARG.EQ.3)GOTO1130
28817      IF(NUMARG.EQ.4)GOTO1140
28818      GOTO1150
28819C
28820 1120 CONTINUE
28821      GOTO1200
28822C
28823 1130 CONTINUE
28824      IF(IHARG(3).EQ.'ALL')IHOLD1='    '
28825      IF(IHARG(3).EQ.'ALL')GOTO1300
28826      GOTO1200
28827C
28828 1140 CONTINUE
28829      IF(IHARG(3).EQ.'ALL')IHOLD1=IHARG(4)
28830      IF(IHARG(3).EQ.'ALL')GOTO1300
28831      IF(IHARG(4).EQ.'ALL')IHOLD1=IHARG(3)
28832      IF(IHARG(4).EQ.'ALL')GOTO1300
28833      GOTO1200
28834C
28835 1150 CONTINUE
28836      GOTO1200
28837C
28838C               *************************************************
28839C               **  STEP 2--                                   **
28840C               **  TREAT THE SINGLE     SPECIFICATION  CASE  **
28841C               *************************************************
28842C
28843 1200 CONTINUE
28844      ISTEPN='2'
28845      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28846C
28847      IF(NUMARG.LE.2)GOTO1210
28848      GOTO1220
28849C
28850 1210 CONTINUE
28851      NUMBAR=1
28852      IBAPTY(1)='    '
28853      GOTO1270
28854C
28855 1220 CONTINUE
28856      NUMBAR=NUMARG-2
28857      IF(NUMBAR.GT.MAXBAR)NUMBAR=MAXBAR
28858      DO1225I=1,NUMBAR
28859      J=I+2
28860      IHOLD1=IHARG(J)
28861      IHOLD2=IHOLD1
28862      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
28863      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
28864      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPT
28865      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPT
28866      IBAPTY(I)=IHOLD2
28867 1225 CONTINUE
28868      GOTO1270
28869C
28870 1270 CONTINUE
28871      IF(IFEEDB.EQ.'OFF')GOTO1279
28872      WRITE(ICOUT,999)
28873      CALL DPWRST('XXX','BUG ')
28874      DO1278I=1,NUMBAR
28875      WRITE(ICOUT,1276)I,IBAPTY(I)
28876 1276 FORMAT('THE TYPE FOR BAR PATTERN ',I6,
28877     1' HAS JUST BEEN SET TO ',A4)
28878      CALL DPWRST('XXX','BUG ')
28879 1278 CONTINUE
28880 1279 CONTINUE
28881      IFOUND='YES'
28882      GOTO9000
28883C
28884C               **************************
28885C               **  STEP 3--            **
28886C               **  TREAT THE ALL CASE  **
28887C               **************************
28888C
28889 1300 CONTINUE
28890      ISTEPN='3'
28891      IF(IBUGP2.EQ.'ON')CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
28892C
28893      NUMBAR=MAXBAR
28894      IHOLD2=IHOLD1
28895      IF(IHOLD1.EQ.'ON')IHOLD2='SOLI'
28896      IF(IHOLD1.EQ.'OFF')IHOLD2='    '
28897      IF(IHOLD1.EQ.'AUTO')IHOLD2=IDEBPT
28898      IF(IHOLD1.EQ.'DEFA')IHOLD2=IDEBPT
28899      DO1315I=1,NUMBAR
28900      IBAPTY(I)=IHOLD2
28901 1315 CONTINUE
28902      GOTO1370
28903C
28904 1370 CONTINUE
28905      IF(IFEEDB.EQ.'OFF')GOTO1319
28906      WRITE(ICOUT,999)
28907      CALL DPWRST('XXX','BUG ')
28908      I=1
28909      WRITE(ICOUT,1316)IBAPTY(I)
28910 1316 FORMAT('THE TYPE FOR ALL BAR PATTERNS',
28911     1' HAS JUST BEEN SET TO ',A4)
28912      CALL DPWRST('XXX','BUG ')
28913 1319 CONTINUE
28914      IFOUND='YES'
28915      GOTO9000
28916C
28917C               *****************
28918C               **  STEP 90--  **
28919C               **  EXIT       **
28920C               *****************
28921C
28922 9000 CONTINUE
28923      IF(IBUGP2.EQ.'OFF')GOTO9090
28924      WRITE(ICOUT,9011)
28925 9011 FORMAT('***** AT THE END       OF DPBPTY--')
28926      CALL DPWRST('XXX','BUG ')
28927      WRITE(ICOUT,9012)IBUGP2,IFOUND,IERROR
28928 9012 FORMAT('IBUGP2,IFOUND,IERROR = ',A4,2X,A4,2X,A4)
28929      CALL DPWRST('XXX','BUG ')
28930      WRITE(ICOUT,9013)MAXBAR,NUMBAR
28931 9013 FORMAT('MAXBAR,NUMBAR = ',I8,I8)
28932      CALL DPWRST('XXX','BUG ')
28933      WRITE(ICOUT,9014)IHOLD1,IHOLD2
28934 9014 FORMAT('IHOLD1,IHOLD2 = ',A4,2X,A4)
28935      CALL DPWRST('XXX','BUG ')
28936      WRITE(ICOUT,9015)IDEBPT
28937 9015 FORMAT('IDEBPT = ',A4)
28938      CALL DPWRST('XXX','BUG ')
28939      WRITE(ICOUT,9020)NUMARG
28940 9020 FORMAT('NUMARG = ',I8)
28941      CALL DPWRST('XXX','BUG ')
28942      DO9025I=1,NUMARG
28943      WRITE(ICOUT,9026)IHARG(I)
28944 9026 FORMAT('IHARG(I) = ',A4)
28945      CALL DPWRST('XXX','BUG ')
28946 9025 CONTINUE
28947      WRITE(ICOUT,9030)IBAPTY(1)
28948 9030 FORMAT('IBAPTY(1) = ',A4)
28949      CALL DPWRST('XXX','BUG ')
28950      DO9035I=1,10
28951      WRITE(ICOUT,9036)I,IBAPTY(I)
28952 9036 FORMAT('I,IBAPTY(I) = ',I8,2X,A4)
28953      CALL DPWRST('XXX','BUG ')
28954 9035 CONTINUE
28955 9090 CONTINUE
28956C
28957      RETURN
28958      END
28959      SUBROUTINE DPBRAT(P1,N1,P2,N2,ALPHA,IWRITE,
28960     1                  ARATIO,ALOWLM,AUPPLM,
28961     1                  IBUGA3,ISUBRO,IERROR)
28962C
28963C     PURPOSE--FOR TWO BINOMIAL PROPORTIONS (P1, N1, P2, N2)
28964C              AND ALPHA, COMPUTE THE CONFIDENCE LIMITS FOR THE
28965C              RATIO OF THE PROBABILITIES.
28966C
28967C              THE BASIC FORMULAT IS:
28968C
28969C              (phat/qhat)*EXP{+/-NORPPF(ALPHA/2)*
28970C              SQRT((1-phat)/(n1*phat) + (1-qhat)/(n2*qhat))}
28971C
28972C
28973C              NOTE THAT PHAT AND QHAT ARE BOTH 1 RESULTS IN  "ZERO"
28974C              UNCERTAINTY AND THAT PHAT OR QHAT OF 0 RESULTS IN
28975C              DIVISION BY ZERO.  FOR THAT REASON, WE USE THE
28976C              BAYES ESTIMATORS OF P AND Q:
28977C
28978C                 PHAT = (V + 0.5)/(N1+1)
28979C                 QHAT = (U + 0.5)/(N2+1)
28980C
28981C              WHERE V AND U DENOTE THE NUMBER OF SUCCESSES IN THE
28982C              BINOMIAL TRIALS.
28983C
28984C     REFERENCE--PRIVATE COMMUNICATION WITH ANDREW RUHKIN OF THE
28985C                NIST STATISTICAL ENGINEERING DIVISION.
28986C     WRITTEN BY--ALAN HECKERT
28987C                 STATISTICAL ENGINEERING DIVISION
28988C                 INFORMATION TECHNOLOGY LABORATORY
28989C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
28990C                 GAITHERSBURG, MD 20899-8980
28991C                 PHONE--301-975-2899
28992C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
28993C           OF THE NATIONAL BUREAU OF STANDARDS.
28994C     LANGUAGE--ANSI FORTRAN (1977)
28995C     VERSION NUMBER--2009/10
28996C     ORIGINAL VERSION--OCTOBER   2009.
28997C
28998C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
28999C
29000      CHARACTER*4 IWRITE
29001      CHARACTER*4 IBUGA3
29002      CHARACTER*4 ISUBRO
29003      CHARACTER*4 IERROR
29004C
29005      CHARACTER*4 ISUBN1
29006      CHARACTER*4 ISUBN2
29007C
29008C---------------------------------------------------------------------
29009C
29010      REAL P1
29011      REAL P2
29012      REAL ALPHA
29013      REAL ALOWLM
29014      REAL AUPPLM
29015      INTEGER N1
29016      INTEGER N2
29017C
29018      REAL TERM1
29019      REAL TERM2
29020      REAL TERM3
29021      REAL TERM4
29022      REAL ARATIO
29023      REAL PPF
29024      REAL PHAT
29025      REAL QHAT
29026      REAL AN1
29027      REAL AN2
29028      INTEGER IV
29029      INTEGER IU
29030C
29031C---------------------------------------------------------------------
29032C
29033      INCLUDE 'DPCOP2.INC'
29034C
29035C-----START POINT-----------------------------------------------------
29036C
29037      ISUBN1='DPBR'
29038      ISUBN2='AT  '
29039C
29040      IERROR='NO'
29041C
29042      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BRAT')THEN
29043        WRITE(ICOUT,999)
29044  999   FORMAT(1X)
29045        CALL DPWRST('XXX','BUG ')
29046        WRITE(ICOUT,51)
29047   51   FORMAT('***** AT THE BEGINNING OF DPBRAT--')
29048        CALL DPWRST('XXX','BUG ')
29049        WRITE(ICOUT,52)IBUGA3,ISUBRO,IWRITE
29050   52   FORMAT('IBUGA3,ISUBRO,IWRITE = ',2A4,2X,A4)
29051        CALL DPWRST('XXX','BUG ')
29052        WRITE(ICOUT,53)P1,N1,P2,N2,ALPHA
29053   53   FORMAT('P1,N1,P2,N2,ALPHA = ',2(G15.7,I8),G15.7)
29054        CALL DPWRST('XXX','BUG ')
29055        WRITE(ICOUT,999)
29056        CALL DPWRST('XXX','BUG ')
29057      ENDIF
29058C
29059C               ********************************
29060C               **  STEP 1--                  **
29061C               **  CHECK FOR INPUT ERRORS    **
29062C               ********************************
29063C
29064      ALOWLM=0.0
29065      AUPPLM=1.0
29066C
29067      IF(N1.LT.1)THEN
29068        WRITE(ICOUT,999)
29069        CALL DPWRST('XXX','WRIT')
29070        WRITE(ICOUT,111)
29071  111   FORMAT('****** ERROR IN BINOMIAL RATIO CONFIDENCE LIMITS-- ')
29072        CALL DPWRST('XXX','BUG ')
29073        WRITE(ICOUT,113)
29074  113   FORMAT('         THE NUMBER OF OBSERVATIONS FOR THE FIRST ',
29075     1         'RESPONSE VARIABLE IS LESS THAN 2.')
29076        CALL DPWRST('XXX','WRIT')
29077        WRITE(ICOUT,114)N1
29078  114   FORMAT('SAMPLE SIZE = ',I8)
29079        CALL DPWRST('XXX','WRIT')
29080        IERROR='YES'
29081        GOTO9000
29082      ENDIF
29083C
29084      IF(N2.LT.2)THEN
29085        WRITE(ICOUT,999)
29086        CALL DPWRST('XXX','WRIT')
29087        WRITE(ICOUT,111)
29088        CALL DPWRST('XXX','BUG ')
29089        WRITE(ICOUT,123)
29090  123   FORMAT('         THE NUMBER OF OBSERVATIONS FOR THE ',
29091     1         'SECOND RESPONSE VARIABLE IS LESS THAN 2.')
29092        CALL DPWRST('XXX','WRIT')
29093        WRITE(ICOUT,114)N2
29094        CALL DPWRST('XXX','WRIT')
29095        IERROR='YES'
29096        GOTO9000
29097      ENDIF
29098C
29099      IF(P1.LT.0.0 .OR. P1.GT.1.0)THEN
29100        IERROR='YES'
29101        WRITE(ICOUT,999)
29102        CALL DPWRST('XXX','BUG ')
29103        WRITE(ICOUT,111)
29104        CALL DPWRST('XXX','BUG ')
29105        WRITE(ICOUT,162)
29106  162   FORMAT('      THE BINOMIAL PROBABILITY OF SUCCESS PARAMETER ',
29107     1         'FOR THE')
29108        CALL DPWRST('XXX','BUG ')
29109        WRITE(ICOUT,164)
29110  164   FORMAT('      FIRST RESPONSE VARIABLE IS OUTSIDE THE ',
29111     1         '(0,1) INTERVAL.')
29112        CALL DPWRST('XXX','BUG ')
29113        WRITE(ICOUT,167)P1
29114  167   FORMAT('      THE PROBABILITY OF SUCCESS PARAMETER = ',G15.7)
29115        CALL DPWRST('XXX','BUG ')
29116        GOTO9000
29117      ENDIF
29118C
29119      IF(P2.LT.0.0 .OR. P2.GT.1.0)THEN
29120        IERROR='YES'
29121        WRITE(ICOUT,999)
29122        CALL DPWRST('XXX','BUG ')
29123        WRITE(ICOUT,111)
29124        CALL DPWRST('XXX','BUG ')
29125        WRITE(ICOUT,162)
29126        CALL DPWRST('XXX','BUG ')
29127        WRITE(ICOUT,174)
29128  174   FORMAT('      SECOND RESPONSE VARIABLE IS OUTSIDE THE ',
29129     1         '(0,1) INTERVAL.')
29130        CALL DPWRST('XXX','BUG ')
29131        WRITE(ICOUT,167)P2
29132        CALL DPWRST('XXX','BUG ')
29133        GOTO9000
29134      ENDIF
29135C
29136      ALPHSV=ALPHA
29137      IF(ALPHA.GT.1.0 .AND. ALPHA.LE.100.0)ALPHA=ALPHA/100.0
29138      IF(ALPHA.LE.0.0 .OR. ALPHA.GE.1.0)THEN
29139        IERROR='YES'
29140        WRITE(ICOUT,999)
29141        CALL DPWRST('XXX','BUG ')
29142        WRITE(ICOUT,111)
29143        CALL DPWRST('XXX','BUG ')
29144        WRITE(ICOUT,192)
29145  192   FORMAT('      THE VALUE OF ALPHA IS OUTSIDE THE (0,1) ',
29146     1         'INTERVAL.')
29147        CALL DPWRST('XXX','BUG ')
29148        WRITE(ICOUT,197)ALPHA
29149  197   FORMAT('      THE VALUE OF ALPHA = ',G15.7)
29150        CALL DPWRST('XXX','BUG ')
29151        GOTO9000
29152      ENDIF
29153C
29154CCCCC FOR THESE FORMULAS, WE WANT ALPHA AS 0.05 RATHER THAN
29155CCCCC 0.95.
29156C
29157CCCCC IF(ALPHA.LT.0.5)ALPHA=1.0 - ALPHA
29158      IF(ALPHA.GT.0.5)ALPHA=1.0 - ALPHA
29159C
29160C               ********************************************
29161C               **  STEP 2--                              **
29162C               **  COMPUTE THE BINOMIAL RATIO            **
29163C               **  CONFIDENCE INTERVAL.                  **
29164C               ********************************************
29165C
29166      AV=P1*REAL(N1)
29167      IV=INT(AV+0.01)
29168      AV=REAL(IV)
29169      AU=P2*REAL(N2)
29170      IU=INT(AU+0.01)
29171      AU=REAL(IU)
29172      AN1=REAL(N1)
29173      AN2=REAL(N2)
29174C
29175      PHAT=(AV+0.5)/(AN1+1.0)
29176      QHAT=(AU+0.5)/(AN2+1.0)
29177      TERM1=(1.0-PHAT)/(AN1*PHAT)
29178      TERM2=(1.0-QHAT)/(AN2*QHAT)
29179      TERM3=SQRT(TERM1+TERM2)
29180C
29181      ARATIO=PHAT/QHAT
29182      ALP2=1.0 - (ALPHA/2.0)
29183      CALL NORPPF(ALP2,PPF)
29184      TERM4=PPF*TERM3
29185      ALOWLM=ARATIO*EXP(-TERM4)
29186      AUPPLM=ARATIO*EXP(TERM4)
29187C
29188C               *****************
29189C               **  STEP 90--  **
29190C               **  EXIT.      **
29191C               *****************
29192C
29193 9000 CONTINUE
29194C
29195      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BRAT')THEN
29196        WRITE(ICOUT,999)
29197        CALL DPWRST('XXX','BUG ')
29198        WRITE(ICOUT,9011)
29199 9011   FORMAT('***** AT THE END       OF DPBRAT--')
29200        CALL DPWRST('XXX','BUG ')
29201        WRITE(ICOUT,9012)IBUGA3,IERROR
29202 9012   FORMAT('IBUGA3,IERROR = ',A4,2X,A4)
29203        CALL DPWRST('XXX','BUG ')
29204        WRITE(ICOUT,9013)TERM1,TERM2,TERM3,TERM4
29205 9013   FORMAT('TERM1,TERM2,TERM3,TERM4 = ',4(G15.7,2X))
29206        CALL DPWRST('XXX','BUG ')
29207        WRITE(ICOUT,9014)AV,AU,PHAT,QHAT
29208 9014   FORMAT('AV,AU,PHAT,QHAT = ',4(G15.7,2X))
29209        CALL DPWRST('XXX','BUG ')
29210        WRITE(ICOUT,9015)ARATIO,ALP2,PPF,ALOWLM,AUPPLM
29211 9015   FORMAT('ARATIO,ALP2,PPF,ALOWLM,AUPPLM = ',5(G15.7,2X))
29212        CALL DPWRST('XXX','BUG ')
29213      ENDIF
29214C
29215      RETURN
29216      END
29217      SUBROUTINE DPBSCL(IHARG,NUMARG,IDBSCO,IBSPCO,IFOUND,IERROR)
29218C
29219C     PURPOSE--DEFINE THE COLOR FOR THE 3-D BASEPLANE.
29220C              THE COLOR FOR THE BASEPLANE WILL BE PLACED
29221C              IN THE CHARACTER VARIABLE IBSPCO.
29222C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
29223C                     --NUMARG
29224C                     --IDBSCO
29225C     OUTPUT ARGUMENTS--IBSPCO
29226C                     --IFOUND ('YES' OR 'NO' )
29227C                     --IERROR ('YES' OR 'NO' )
29228C     NOTE--THIS SUBROUTINE ASSUMES A
29229C           COMPLICATED-TO-SIMPLE CHECKING ORDER
29230C           (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS.
29231C     WRITTEN BY--JAMES J. FILLIBEN
29232C                 STATISTICAL ENGINEERING DIVISION
29233C                 INFORMATION TECHNOLOGY LABORATORY
29234C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29235C                 GAITHERSBURG, MD 20899-8980
29236C                 PHONE--301-975-2855
29237C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29238C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
29239C     LANGUAGE--ANSI FORTRAN (1977)
29240C     VERSION NUMBER--88/10
29241C     ORIGINAL VERSION--SEPTEMBER 1988.
29242C
29243C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29244C
29245      CHARACTER*4 IHARG
29246      CHARACTER*4 IDBSCO
29247      CHARACTER*4 IBSPCO
29248      CHARACTER*4 IFOUND
29249      CHARACTER*4 IERROR
29250C
29251C---------------------------------------------------------------------
29252C
29253      DIMENSION IHARG(*)
29254C
29255C---------------------------------------------------------------------
29256C
29257      INCLUDE 'DPCOP2.INC'
29258C
29259C-----START POINT-----------------------------------------------------
29260C
29261      IFOUND='NO'
29262      IERROR='NO'
29263C
29264      IF(NUMARG.EQ.0)GOTO1199
29265      IF(NUMARG.EQ.1)GOTO1150
29266C
29267      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
29268      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
29269      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
29270      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
29271      GOTO1160
29272C
29273 1150 CONTINUE
29274      IBSPCO=IDBSCO
29275      GOTO1180
29276C
29277 1160 CONTINUE
29278      IBSPCO=IHARG(NUMARG)
29279      GOTO1180
29280C
29281 1180 CONTINUE
29282      IFOUND='YES'
29283C
29284      IF(IFEEDB.EQ.'OFF')GOTO1189
29285      WRITE(ICOUT,999)
29286  999 FORMAT(1X)
29287      CALL DPWRST('XXX','BUG ')
29288      WRITE(ICOUT,1181)IBSPCO
29289 1181 FORMAT('THE (3-D) BASEPLANE COLOR ',
29290     1'HAS JUST BEEN SET TO ',A4)
29291      CALL DPWRST('XXX','BUG ')
29292 1189 CONTINUE
29293      GOTO1199
29294C
29295 1199 CONTINUE
29296      RETURN
29297      END
29298      SUBROUTINE DPBSGC(IHARG,NUMARG,IDBSGC,IBSPGC,IFOUND,IERROR)
29299C
29300C     PURPOSE--DEFINE THE COLOR FOR THE 3-D BASEPLANE GRID.
29301C              THE COLOR FOR THE BASEPLANE GRID WILL BE PLACED
29302C              IN THE CHARACTER VARIABLE IBSPGC.
29303C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
29304C                     --NUMARG
29305C                     --IDBSGC
29306C     OUTPUT ARGUMENTS--IBSPGC
29307C                     --IFOUND ('YES' OR 'NO' )
29308C                     --IERROR ('YES' OR 'NO' )
29309C     NOTE--THIS SUBROUTINE ASSUMES A
29310C           COMPLICATED-TO-SIMPLE CHECKING ORDER
29311C           (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS.
29312C     WRITTEN BY--JAMES J. FILLIBEN
29313C                 STATISTICAL ENGINEERING DIVISION
29314C                 INFORMATION TECHNOLOGY LABORATORY
29315C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29316C                 WASHINGPON, D. C. 20234
29317C                 PHONE--301-975-2855
29318C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29319C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
29320C     LANGUAGE--ANSI FORTRAN (1977)
29321C     VERSION NUMBER--88/10
29322C     ORIGINAL VERSION--SEPTEMBER 1988.
29323C
29324C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29325C
29326      CHARACTER*4 IHARG
29327      CHARACTER*4 IDBSGC
29328      CHARACTER*4 IBSPGC
29329      CHARACTER*4 IFOUND
29330      CHARACTER*4 IERROR
29331C
29332C---------------------------------------------------------------------
29333C
29334      DIMENSION IHARG(*)
29335C
29336C---------------------------------------------------------------------
29337C
29338      INCLUDE 'DPCOP2.INC'
29339C
29340C-----START POINT-----------------------------------------------------
29341C
29342      IFOUND='NO'
29343      IERROR='NO'
29344C
29345      IF(NUMARG.LE.1)GOTO1199
29346      IF(NUMARG.EQ.2)GOTO1150
29347C
29348      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
29349      IF(IHARG(NUMARG).EQ.'OFF')GOTO1150
29350      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
29351      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1150
29352      GOTO1160
29353C
29354 1150 CONTINUE
29355      IBSPGC=IDBSGC
29356      GOTO1180
29357C
29358 1160 CONTINUE
29359      IBSPGC=IHARG(NUMARG)
29360      GOTO1180
29361C
29362 1180 CONTINUE
29363      IFOUND='YES'
29364C
29365      IF(IFEEDB.EQ.'OFF')GOTO1189
29366      WRITE(ICOUT,999)
29367  999 FORMAT(1X)
29368      CALL DPWRST('XXX','BUG ')
29369      WRITE(ICOUT,1181)IBSPGC
29370 1181 FORMAT('THE (3-D) BASEPLANE GRID COLOR ',
29371     1'HAS JUST BEEN SET TO ',A4)
29372      CALL DPWRST('XXX','BUG ')
29373 1189 CONTINUE
29374      GOTO1199
29375C
29376 1199 CONTINUE
29377      RETURN
29378      END
29379      SUBROUTINE DPBSGP(IHARG,NUMARG,IDBSGP,IBSPGP,IFOUND,IERROR)
29380C
29381C     PURPOSE--DEFINE THE PATTERN FOR THE 3-D BASEPLANE GRID.
29382C              THE PATTERN FOR THE BASEPLANE GRID WILL BE PLACED
29383C              IN THE CHARACTER VARIABLE IBSPGP.
29384C     INPUT  ARGUMENTS--IHARG  (A  CHARACTER VECTOR)
29385C                     --NUMARG
29386C                     --IDBSGP
29387C     OUTPUT ARGUMENTS--IBSPGP
29388C                     --IFOUND ('YES' OR 'NO' )
29389C                     --IERROR ('YES' OR 'NO' )
29390C     NOTE--THIS SUBROUTINE ASSUMES A
29391C           COMPLICATED-TO-SIMPLE CHECKING ORDER
29392C           (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS.
29393C     WRITTEN BY--JAMES J. FILLIBEN
29394C                 STATISTICAL ENGINEERING DIVISION
29395C                 INFORMATION TECHNOLOGY LABORATORY
29396C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29397C                 WASHINGPON, D. C. 20234
29398C                 PHONE--301-975-2855
29399C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29400C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
29401C     LANGUAGE--ANSI FORTRAN (1977)
29402C     VERSION NUMBER--88/10
29403C     ORIGINAL VERSION--SEPTEMBER 1988.
29404C
29405C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29406C
29407      CHARACTER*4 IHARG
29408      CHARACTER*4 IDBSGP
29409      CHARACTER*4 IBSPGP
29410      CHARACTER*4 IFOUND
29411      CHARACTER*4 IERROR
29412C
29413C---------------------------------------------------------------------
29414C
29415      DIMENSION IHARG(*)
29416C
29417C---------------------------------------------------------------------
29418C
29419      INCLUDE 'DPCOP2.INC'
29420C
29421C-----START POINT-----------------------------------------------------
29422C
29423      IFOUND='NO'
29424      IERROR='NO'
29425C
29426      IF(NUMARG.LE.1)GOTO1199
29427      IF(NUMARG.EQ.2)GOTO1160
29428C
29429      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
29430      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
29431      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
29432      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170
29433      GOTO1175
29434C
29435 1150 CONTINUE
29436      IBSPGP='SOLI'
29437      GOTO1180
29438C
29439 1160 CONTINUE
29440      IBSPGP='BLAN'
29441      GOTO1180
29442C
29443 1170 CONTINUE
29444      IBSPGP=IDBSGP
29445      GOTO1180
29446C
29447 1175 CONTINUE
29448      IBSPGP=IHARG(NUMARG)
29449      GOTO1180
29450C
29451 1180 CONTINUE
29452      IFOUND='YES'
29453C
29454      IF(IFEEDB.EQ.'OFF')GOTO1189
29455      WRITE(ICOUT,999)
29456  999 FORMAT(1X)
29457      CALL DPWRST('XXX','BUG ')
29458      WRITE(ICOUT,1181)IBSPGP
29459 1181 FORMAT('THE (3-D) BASEPLANE GRID PATTERN ',
29460     1'HAS JUST BEEN SET TO ',A4)
29461      CALL DPWRST('XXX','BUG ')
29462 1189 CONTINUE
29463      GOTO1199
29464C
29465 1199 CONTINUE
29466      RETURN
29467      END
29468      SUBROUTINE DPBSGR(IHARG,NUMARG,IDBSGR,IBSPGR,IFOUND,IERROR)
29469C
29470C     PURPOSE--DEFINE THE 3-D BASEPLANE GRID SWITCH IBSPGR.
29471C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
29472C                     --NUMARG
29473C                     --IDBSGR
29474C     OUTPUT ARGUMENTS--IBSPGR   ('ON'  OR 'OFF')
29475C                     --IFOUND ('YES' OR 'NO' )
29476C                     --IERROR ('YES' OR 'NO' )
29477C     NOTE--THIS SUBROUTINE ASSUMES A
29478C           COMPLICATED-TO-SIMPLE CHECKING ORDER
29479C           (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS.
29480C     WRITTEN BY--JAMES J. FILLIBEN
29481C                 STATISTICAL ENGINEERING DIVISION
29482C                 INFORMATION TECHNOLOGY LABORATORY
29483C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29484C                 GAITHERSBURG, MD 20899-8980
29485C                 PHONE--301-975-2855
29486C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29487C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
29488C     LANGUAGE--ANSI FORTRAN (1977)
29489C     VERSION NUMBER--88/10
29490C     ORIGINAL VERSION--SEPTEMBER 1988.
29491C
29492C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29493C
29494      CHARACTER*4 IHARG
29495      CHARACTER*4 IDBSGR
29496      CHARACTER*4 IBSPGR
29497      CHARACTER*4 IFOUND
29498      CHARACTER*4 IERROR
29499C
29500C---------------------------------------------------------------------
29501C
29502      DIMENSION IHARG(*)
29503C
29504C---------------------------------------------------------------------
29505C
29506      INCLUDE 'DPCOP2.INC'
29507C
29508C-----START POINT-----------------------------------------------------
29509C
29510      IFOUND='NO'
29511      IERROR='NO'
29512C
29513      IF(NUMARG.EQ.0)GOTO1199
29514      IF(NUMARG.EQ.1)GOTO1150
29515C
29516      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
29517      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
29518      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
29519      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1170
29520      GOTO1199
29521C
29522 1150 CONTINUE
29523      IBSPGR='ON'
29524      GOTO1180
29525C
29526 1160 CONTINUE
29527      IBSPGR='OFF'
29528      GOTO1180
29529C
29530 1170 CONTINUE
29531      IBSPGR=IDBSGR
29532      GOTO1180
29533C
29534 1180 CONTINUE
29535      IFOUND='YES'
29536C
29537      IF(IFEEDB.EQ.'OFF')GOTO1189
29538      WRITE(ICOUT,999)
29539  999 FORMAT(1X)
29540      CALL DPWRST('XXX','BUG ')
29541      WRITE(ICOUT,1181)IBSPGR
29542 1181 FORMAT('THE (3-D) BASEPLANE GRID SWITCH ',
29543     1'HAS JUST BEEN SET TO ',A4)
29544      CALL DPWRST('XXX','BUG ')
29545 1189 CONTINUE
29546      GOTO1199
29547C
29548 1199 CONTINUE
29549      RETURN
29550      END
29551      SUBROUTINE DPBSP(IHARG,NUMARG,IBSPSW,IFOUND,IERROR)
29552C
29553C     PURPOSE--DEFINE THE 3-D BASEPLANE SWITCH IBSPSW.
29554C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
29555C                     --NUMARG
29556C     OUTPUT ARGUMENTS--IBSPSW   ('ON'  OR 'OFF')
29557C                     --IFOUND ('YES' OR 'NO' )
29558C                     --IERROR ('YES' OR 'NO' )
29559C     NOTE--THIS SUBROUTINE ASSUMES A
29560C           COMPLICATED-TO-SIMPLE CHECKING ORDER
29561C           (IN MAIPC4) OF THE VARIOUS BASEPLANE COMMANDS.
29562C     WRITTEN BY--JAMES J. FILLIBEN
29563C                 STATISTICAL ENGINEERING DIVISION
29564C                 INFORMATION TECHNOLOGY LABORATORY
29565C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29566C                 GAITHERSBURG, MD 20899-8980
29567C                 PHONE--301-975-2855
29568C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
29569C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
29570C     LANGUAGE--ANSI FORTRAN (1977)
29571C     VERSION NUMBER--88/10
29572C     ORIGINAL VERSION--SEPTEMBER 1988.
29573C
29574C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29575C
29576      CHARACTER*4 IHARG
29577      CHARACTER*4 IBSPSW
29578      CHARACTER*4 IFOUND
29579      CHARACTER*4 IERROR
29580C
29581C---------------------------------------------------------------------
29582C
29583      DIMENSION IHARG(*)
29584C
29585C---------------------------------------------------------------------
29586C
29587      INCLUDE 'DPCOP2.INC'
29588C
29589C-----START POINT-----------------------------------------------------
29590C
29591      IFOUND='NO'
29592      IERROR='NO'
29593C
29594      IF(NUMARG.EQ.0)GOTO1150
29595C
29596      IF(IHARG(NUMARG).EQ.'ON')GOTO1150
29597      IF(IHARG(NUMARG).EQ.'OFF')GOTO1160
29598      IF(IHARG(NUMARG).EQ.'AUTO')GOTO1150
29599      IF(IHARG(NUMARG).EQ.'DEFA')GOTO1160
29600      GOTO1199
29601C
29602 1150 CONTINUE
29603      IBSPSW='ON'
29604      GOTO1180
29605C
29606 1160 CONTINUE
29607      IBSPSW='OFF'
29608      GOTO1180
29609C
29610 1180 CONTINUE
29611      IFOUND='YES'
29612C
29613      IF(IFEEDB.EQ.'OFF')GOTO1189
29614      WRITE(ICOUT,999)
29615  999 FORMAT(1X)
29616      CALL DPWRST('XXX','BUG ')
29617      WRITE(ICOUT,1181)IBSPSW
29618 1181 FORMAT('THE (3-D) BASEPLANE SWITCH ',
29619     1'HAS JUST BEEN SET TO ',A4)
29620      CALL DPWRST('XXX','BUG ')
29621 1189 CONTINUE
29622      GOTO1199
29623C
29624 1199 CONTINUE
29625      RETURN
29626      END
29627      SUBROUTINE DPBSHW(IHARG,IARGT,IARG,ARG,NUMARG,PDEFSH,PDEFSW,
29628     1                  MAXBOX,PBOSHE,PBOSWI,IFOUND,IERROR)
29629C
29630C     PURPOSE--DEFINE THE SHADOW HEIGHT & WIDTH FOR A BOX.
29631C              THE SHADOW HEIGHT & WIDTH FOR A BOX IS THE THICKNESS
29632C              OF THE SHADOW THAT WILL APPEAR BELOW AND TO THE RIGHT
29633C              OF THE BOX.
29634C     INPUT  ARGUMENTS--IHARG  (A  HOLLERITH VECTOR)
29635C                     --IARGT  (A HOLLERITH VECTOR)
29636C                     --IARG   (A HOLLERITH VECTOR)
29637C                     --ARG    (A REAL VECTOR)
29638C                     --NUMARG
29639C                     --PDEFSH
29640C                     --PDEFSW
29641C                     --MAXBOX
29642C     OUTPUT ARGUMENTS--PBOSHE (A REAL VECTOR
29643C                              WHOSE I-TH ELEMENT CONTAINS THE
29644C                              SHADOW HEIGHT FOR BOX I)
29645C                     --PBOSWI (A REAL VECTOR
29646C                              WHOSE I-TH ELEMENT CONTAINS THE
29647C                              SHADOW WIDTH FOR BOX I)
29648C                     --IFOUND ('YES' OR 'NO' )
29649C                     --IERROR ('YES' OR 'NO' )
29650C     WRITTEN BY--JAMES J. FILLIBEN
29651C                 STATISTICAL ENGINEERING DIVISION
29652C                 INFORMATION TECHNOLOGY LABORATORY
29653C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
29654C                 GAITHERSBURG, MD 20899-8980
29655C                 PHONE--301-975-2855
29656C     LANGUAGE--ANSI FORTRAN (1977)
29657C     VERSION NUMBER--92/9
29658C     ORIGINAL VERSION--AUGUST    1992.
29659C     UPDATED         --DECEMBER  1999. ADD "OFF" OPTION
29660C
29661C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
29662C
29663      CHARACTER*4 IHARG
29664      CHARACTER*4 IARGT
29665      REAL        PDEFSH
29666      REAL        PDEFSW
29667      REAL        PBOSHE
29668      REAL        PBOSWI
29669      CHARACTER*4 IFOUND
29670      CHARACTER*4 IERROR
29671C
29672      REAL        PHOLDH
29673      REAL        PHOLDW
29674C
29675C---------------------------------------------------------------------
29676C
29677      DIMENSION IHARG(*)
29678      DIMENSION IARGT(*)
29679      DIMENSION IARG(*)
29680      DIMENSION ARG(*)
29681C
29682      DIMENSION PBOSHE(*)
29683      DIMENSION PBOSWI(*)
29684C
29685C---------------------------------------------------------------------
29686C
29687      INCLUDE 'DPCOP2.INC'
29688C
29689C-----START POINT-----------------------------------------------------
29690C
29691      IFOUND='NO'
29692      IERROR='NO'
29693C
29694      PHOLDW=CPUMIN
29695C
29696C               **************************************************
29697C               **  STEP 1--                                    **
29698C               **  TREAT THE BOX SHADOW HEIGHT           CASE  **
29699C               **************************************************
29700C
29701      IF(NUMARG.GE.2)THEN
29702         IF(IHARG(1).EQ.'SHAD')THEN
29703            IF(IHARG(2).EQ.'HEIG')THEN
29704               IF(NUMARG.EQ.2)THEN
29705                  PHOLDH=PDEFSH
29706                  GOTO1100
29707               ELSE IF(IHARG(3).EQ.'ON'.OR.
29708     1         IHARG(3).EQ.'AUTO'.OR. IHARG(3).EQ.'DEFA')THEN
29709                  PHOLDH=PDEFSH
29710                  GOTO1100
29711               ELSE IF(IHARG(3).EQ.'OFF')THEN
29712                  PHOLDH=0.0
29713                  GOTO1100
29714               ELSE IF(IHARG(3).EQ.'?')THEN
29715                  GOTO1150
29716               ELSE
29717                  PHOLDH=ARG(3)
29718                  GOTO1100
29719               ENDIF
29720            ELSEIF(IHARG(2).EQ.'OFF')THEN
29721              PHOLDH=0.0
29722              GOTO3100
29723            ENDIF
29724         ENDIF
29725      ENDIF
29726      GOTO1190
29727C
29728 1100 CONTINUE
29729      IFOUND='YES'
29730      DO1110I=1,MAXBOX
29731         PBOSHE(I)=PHOLDH
29732 1110 CONTINUE
29733      IF(IFEEDB.EQ.'ON')THEN
29734        WRITE(ICOUT,999)
29735  999   FORMAT(1X)
29736        CALL DPWRST('XXX','BUG ')
29737        WRITE(ICOUT,1130)PBOSHE(1)
29738 1130   FORMAT('ALL BOX SHADOW HEIGHTS ',
29739     1         'HAVE JUST BEEN SET TO ',F10.4)
29740        CALL DPWRST('XXX','BUG ')
29741        GOTO9000
29742      ENDIF
29743C
29744 1150 CONTINUE
29745      IFOUND='YES'
29746      IF(IFEEDB.EQ.'ON')THEN
29747        WRITE(ICOUT,999)
29748        CALL DPWRST('XXX','BUG ')
29749        WRITE(ICOUT,1160)PBOSHE(1)
29750 1160   FORMAT('ALL BOX SHADOW HEIGHTS ',
29751     1         'HAVE THE CURRENT VALUE ',F10.4)
29752        CALL DPWRST('XXX','BUG ')
29753        GOTO9000
29754      ENDIF
29755C
29756 1190 CONTINUE
29757C
29758C               **************************************************
29759C               **  STEP 2--                                    **
29760C               **  TREAT THE BOX SHADOW WIDTH            CASE  **
29761C               **************************************************
29762C
29763      IF(NUMARG.GE.2)THEN
29764         IF(IHARG(1).EQ.'SHAD')THEN
29765            IF(IHARG(2).EQ.'WIDT')THEN
29766               IF(NUMARG.EQ.2)THEN
29767                  PHOLDW=PDEFSW
29768                  GOTO2100
29769               ELSE IF(IHARG(3).EQ.'ON'.OR.
29770     1         IHARG(3).EQ.'AUTO'.OR. IHARG(3).EQ.'DEFA')THEN
29771                  PHOLDW=PDEFSW
29772                  GOTO2100
29773               ELSE IF(IHARG(3).EQ.'OFF')THEN
29774                  PHOLDW=0.0
29775                  GOTO2100
29776               ELSE IF(IHARG(3).EQ.'?')THEN
29777                  GOTO2150
29778               ELSE
29779                  PHOLDW=ARG(3)
29780                  GOTO2100
29781               ENDIF
29782            ENDIF
29783         ENDIF
29784      ENDIF
29785      GOTO2190
29786C
29787 2100 CONTINUE
29788      IFOUND='YES'
29789      DO2110I=1,MAXBOX
29790         PBOSWI(I)=PHOLDW
29791 2110 CONTINUE
29792      IF(IFEEDB.EQ.'ON')THEN
29793        WRITE(ICOUT,999)
29794        CALL DPWRST('XXX','BUG ')
29795        WRITE(ICOUT,2130)PBOSWI(1)
29796 2130   FORMAT('ALL BOX SHADOW WIDTHS  ',
29797     1         'HAVE JUST BEEN SET TO ',F10.4)
29798        CALL DPWRST('XXX','BUG ')
29799        GOTO9000
29800      ENDIF
29801C
29802 2150 CONTINUE
29803      IFOUND='YES'
29804      IF(IFEEDB.EQ.'ON')THEN
29805        WRITE(ICOUT,999)
29806        CALL DPWRST('XXX','BUG ')
29807        WRITE(ICOUT,2160)PBOSWI(1)
29808 2160   FORMAT('ALL BOX SHADOW WIDTHS  ',
29809     1         'HAVE THE CURRENT VALUE ',F10.4)
29810        CALL DPWRST('XXX','BUG ')
29811        GOTO9000
29812      ENDIF
29813C
29814 2190 CONTINUE
29815C
29816C               **************************************************
29817C               **  STEP 3--                                    **
29818C               **  TREAT THE BOX SHADOW HEIGHT AND WIDTH CASE  **
29819C               **************************************************
29820C
29821      IF(NUMARG.GE.2)THEN
29822         IF(IHARG(1).EQ.'SHAD')THEN
29823            IF(IHARG(2).EQ.'HW')THEN
29824               IF(NUMARG.EQ.2)THEN
29825                  PHOLDH=PDEFSH
29826                  PHOLDW=PDEFSW
29827                  GOTO3100
29828               ELSE IF(IHARG(3).EQ.'ON'.OR.
29829     1         IHARG(3).EQ.'AUTO'.OR. IHARG(3).EQ.'DEFA')THEN
29830                  PHOLDH=PDEFSH
29831                  PHOLDW=PDEFSW
29832                  GOTO3100
29833               ELSE IF(IHARG(3).EQ.'OFF')THEN
29834                  PHOLDH=0.0
29835                  PHOLDW=0.0
29836                  GOTO3100
29837               ELSE IF(IHARG(3).EQ.'?')THEN
29838                  GOTO3150
29839               ELSE
29840                  PHOLDH=ARG(3)
29841                  IF(NUMARG.LE.3)PHOLDW=ARG(3)
29842                  IF(NUMARG.GE.4)PHOLDW=ARG(4)
29843                  GOTO3100
29844               ENDIF
29845            ELSEIF(IHARG(2).EQ.'HW')THEN
29846              PHOLDH=0.0
29847              PHOLDW=0.0
29848              GOTO3100
29849            ENDIF
29850         ENDIF
29851      ENDIF
29852      GOTO3190
29853C
29854 3100 CONTINUE
29855      IFOUND='YES'
29856      DO3110I=1,MAXBOX
29857         PBOSHE(I)=PHOLDH
29858         PBOSWI(I)=PHOLDW
29859 3110 CONTINUE
29860      IF(IFEEDB.EQ.'ON')THEN
29861        WRITE(ICOUT,999)
29862        CALL DPWRST('XXX','BUG ')
29863        WRITE(ICOUT,3131)PBOSHE(1)
29864 3131   FORMAT('ALL BOX SHADOW HEIGHTS ',
29865     1         'HAVE JUST BEEN SET TO ',F10.4)
29866        CALL DPWRST('XXX','BUG ')
29867        WRITE(ICOUT,3132)PBOSWI(1)
29868 3132   FORMAT('ALL BOX SHADOW WIDTHS  ',
29869     1         'HAVE JUST BEEN SET TO ',F10.4)
29870        CALL DPWRST('XXX','BUG ')
29871        GOTO9000
29872      ENDIF
29873C
29874 3150 CONTINUE
29875      IFOUND='YES'
29876      IF(IFEEDB.EQ.'ON')THEN
29877        WRITE(ICOUT,999)
29878        CALL DPWRST('XXX','BUG ')
29879        WRITE(ICOUT,3161)PBOSHE(1)
29880 3161   FORMAT('ALL BOX SHADOW HEIGHTS ',
29881     1         'HAVE THE CURRENT VALUE ',F10.4)
29882        CALL DPWRST('XXX','BUG ')
29883        WRITE(ICOUT,3162)PBOSWI(1)
29884 3162   FORMAT('ALL BOX SHADOW WIDTHS  ',
29885     1         'HAVE THE CURRENT VALUE ',F10.4)
29886        CALL DPWRST('XXX','BUG ')
29887        GOTO9000
29888      ENDIF
29889C
29890 3190 CONTINUE
29891C
29892C               **************************************************
29893C               **  STEP 4--                                    **
29894C               **  TREAT THE BOX ... SHADOW HEIGHT       CASE  **
29895C               **************************************************
29896C
29897      IF(NUMARG.GE.3)THEN
29898         IF(IHARG(2).EQ.'SHAD')THEN
29899            IF(IHARG(3).EQ.'HEIG')THEN
29900               IF(NUMARG.EQ.3)THEN
29901                  PHOLDH=PDEFSH
29902                  GOTO4100
29903               ELSE IF(IHARG(4).EQ.'ON'.OR.
29904     1         IHARG(4).EQ.'AUTO'.OR. IHARG(4).EQ.'DEFA')THEN
29905                  PHOLDH=PDEFSH
29906                  GOTO4100
29907               ELSE IF(IHARG(4).EQ.'OFF')THEN
29908                  PHOLDH=0.0
29909                  GOTO4100
29910               ELSE IF(IHARG(4).EQ.'?')THEN
29911                  GOTO4150
29912               ELSE
29913                  PHOLDH=ARG(4)
29914                  GOTO4100
29915               ENDIF
29916            ENDIF
29917         ENDIF
29918      ENDIF
29919      GOTO4190
29920C
29921 4100 CONTINUE
29922      IF(IARGT(1).EQ.'NUMB')THEN
29923         I=IARG(1)
29924         IF(1.LE.I.AND.I.LE.MAXBOX)THEN
29925            IFOUND='YES'
29926            IF(IFEEDB.EQ.'ON')THEN
29927              WRITE(ICOUT,999)
29928              CALL DPWRST('XXX','BUG ')
29929              WRITE(ICOUT,4110)I,PBOSHE(1)
29930 4110         FORMAT('THE SHADOW HEIGHT FOR BOX ',I8,
29931     1               ' HAS JUST BEEN SET TO ',F10.4)
29932              CALL DPWRST('XXX','BUG ')
29933              GOTO9000
29934           ENDIF
29935         ELSE
29936            GOTO8200
29937         ENDIF
29938      ENDIF
29939      GOTO8100
29940C
29941 4150 CONTINUE
29942      IF(IARGT(1).EQ.'NUMB')THEN
29943         I=IARG(1)
29944         IF(1.LE.I.AND.I.LE.MAXBOX)THEN
29945            IFOUND='YES'
29946            IF(IFEEDB.EQ.'ON')THEN
29947              WRITE(ICOUT,999)
29948              CALL DPWRST('XXX','BUG ')
29949              WRITE(ICOUT,4160)I,PBOSHE(I)
29950 4160         FORMAT('THE SHADOW HEIGHT FOR BOX ',I8,
29951     1               ' HAS THE CURRENT VALUE ',F10.4)
29952              CALL DPWRST('XXX','BUG ')
29953              GOTO9000
29954           ENDIF
29955         ELSE
29956            GOTO8200
29957         ENDIF
29958      ENDIF
29959      GOTO8100
29960C
29961 4190 CONTINUE
29962C
29963C               **************************************************
29964C               **  STEP 5--                                    **
29965C               **  TREAT THE BOX ... SHADOW WIDTH        CASE  **
29966C               **************************************************
29967C
29968      IF(NUMARG.GE.3)THEN
29969CCCCC    IF(IHARG(1).EQ.'SHAD')THEN
29970         IF(IHARG(2).EQ.'SHAD')THEN
29971            IF(IHARG(3).EQ.'WIDT')THEN
29972               IF(NUMARG.EQ.3)THEN
29973                  PHOLDW=PDEFSW
29974                  GOTO5100
29975               ELSE IF(IHARG(4).EQ.'ON'.OR.
29976     1         IHARG(4).EQ.'AUTO'.OR. IHARG(4).EQ.'DEFA')THEN
29977                  PHOLDW=PDEFSW
29978                  GOTO5100
29979               ELSE IF(IHARG(4).EQ.'OFF')THEN
29980                  PHOLDW=0.0
29981                  GOTO5100
29982               ELSE IF(IHARG(4).EQ.'?')THEN
29983                  GOTO5150
29984               ELSE
29985                  PHOLDW=ARG(4)
29986                  GOTO5100
29987               ENDIF
29988            ENDIF
29989         ENDIF
29990      ENDIF
29991      GOTO5190
29992C
29993 5100 CONTINUE
29994      IF(IARGT(1).EQ.'NUMB')THEN
29995         I=IARG(1)
29996         IF(1.LE.I.AND.I.LE.MAXBOX)THEN
29997            IFOUND='YES'
29998            PBOSWI(I)=PHOLDW
29999            IF(IFEEDB.EQ.'ON')THEN
30000              WRITE(ICOUT,999)
30001              CALL DPWRST('XXX','BUG ')
30002              WRITE(ICOUT,5110)I,PBOSWI(1)
30003 5110         FORMAT('THE SHADOW WIDTH  FOR BOX ',I8,
30004     1               ' HAS JUST BEEN SET TO ',F10.4)
30005              CALL DPWRST('XXX','BUG ')
30006              GOTO9000
30007           ENDIF
30008         ELSE
30009            GOTO8200
30010         ENDIF
30011      ENDIF
30012      GOTO8100
30013C
30014 5150 CONTINUE
30015      IF(IARGT(1).EQ.'NUMB')THEN
30016         I=IARG(1)
30017         IF(1.LE.I.AND.I.LE.MAXBOX)THEN
30018            IFOUND='YES'
30019            IF(IFEEDB.EQ.'ON')THEN
30020              WRITE(ICOUT,999)
30021              CALL DPWRST('XXX','BUG ')
30022              WRITE(ICOUT,5160)I,PBOSWI(I)
30023 5160         FORMAT('THE SHADOW WIDTH  FOR BOX ',I8,
30024     1               ' HAS THE CURRENT VALUE ',F10.4)
30025              CALL DPWRST('XXX','BUG ')
30026              GOTO9000
30027           ENDIF
30028         ELSE
30029            GOTO8200
30030         ENDIF
30031      ENDIF
30032      GOTO8100
30033C
30034 5190 CONTINUE
30035C
30036C               **************************************************
30037C               **  STEP 6--                                    **
30038C               **  TREAT THE BOX ... SHADOW HEIGHT & WIDTH CASE**
30039C               **************************************************
30040C
30041      IF(NUMARG.GE.3)THEN
30042         IF(IHARG(2).EQ.'SHAD')THEN
30043            IF(IHARG(3).EQ.'HW')THEN
30044               IF(NUMARG.EQ.3)THEN
30045                  PHOLDH=PDEFSH
30046                  PHOLDW=PDEFSW
30047                  GOTO6100
30048               ELSE IF(IHARG(4).EQ.'ON'.OR.
30049     1         IHARG(4).EQ.'AUTO'.OR. IHARG(4).EQ.'DEFA')THEN
30050                  PHOLDH=PDEFSH
30051                  PHOLDW=PDEFSW
30052                  GOTO6100
30053               ELSE IF(IHARG(4).EQ.'OFF')THEN
30054                  PHOLDH=PDEFSH
30055                  PHOLDW=PDEFSW
30056                  GOTO6100
30057               ELSE IF(IHARG(4).EQ.'?')THEN
30058                  GOTO6150
30059               ELSE
30060                  PHOLDH=ARG(4)
30061                  IF(NUMARG.LE.4)PHOLDW=ARG(4)
30062                  IF(NUMARG.GE.5)PHOLDW=ARG(5)
30063                  GOTO6100
30064               ENDIF
30065            ELSEIF(IHARG(3).EQ.'OFF')THEN
30066              PHOLDH=PDEFSH
30067              PHOLDW=PDEFSW
30068              GOTO6100
30069            ENDIF
30070         ENDIF
30071      ENDIF
30072      GOTO6190
30073C
30074 6100 CONTINUE
30075      IF(IARGT(1).EQ.'NUMB')THEN
30076         I=IARG(1)
30077         IF(1.LE.I.AND.I.LE.MAXBOX)THEN
30078            IFOUND='YES'
30079            PBOSHE(I)=PHOLDH
30080            PBOSWI(I)=PHOLDW
30081            IF(IFEEDB.EQ.'ON')THEN
30082              WRITE(ICOUT,999)
30083              CALL DPWRST('XXX','BUG ')
30084              WRITE(ICOUT,6110)I,PBOSHE(1)
30085 6110         FORMAT('THE SHADOW HEIGHT FOR BOX ',I8,
30086     1               ' HAS JUST BEEN SET TO ',F10.4)
30087              CALL DPWRST('XXX','BUG ')
30088              WRITE(ICOUT,6120)I,PBOSWI(1)
30089 6120         FORMAT('THE SHADOW WIDTH  FOR BOX ',I8,
30090     1               ' HAS JUST BEEN SET TO ',F10.4)
30091              CALL DPWRST('XXX','BUG ')
30092              GOTO9000
30093           ENDIF
30094         ELSE
30095            GOTO8200
30096         ENDIF
30097      ENDIF
30098      GOTO8100
30099C
30100 6150 CONTINUE
30101      IF(IARGT(1).EQ.'NUMB')THEN
30102         I=IARG(1)
30103         IF(1.LE.I.AND.I.LE.MAXBOX)THEN
30104            IFOUND='YES'
30105            IF(IFEEDB.EQ.'ON')THEN
30106              WRITE(ICOUT,999)
30107              CALL DPWRST('XXX','BUG ')
30108              WRITE(ICOUT,6161)I,PBOSHE(I)
30109 6161         FORMAT('THE SHADOW HEIGHT FOR BOX ',I8,
30110     1               ' HAS THE CURRENT VALUE ',F10.4)
30111              CALL DPWRST('XXX','BUG ')
30112              WRITE(ICOUT,6162)I,PBOSWI(I)
30113 6162         FORMAT('THE SHADOW WIDTH  FOR BOX ',I8,
30114     1               ' HAS THE CURRENT VALUE ',F10.4)
30115              CALL DPWRST('XXX','BUG ')
30116              GOTO9000
30117           ENDIF
30118         ELSE
30119            GOTO8200
30120         ENDIF
30121      ENDIF
30122      GOTO8100
30123C
30124 6190 CONTINUE
30125      GOTO9000
30126C
30127C               **************************************************
30128C               **  STEP 11--                                   **
30129C               **  WRITE OUT MESSAGES FOR ERROR CONDITIONS
30130C               **************************************************
30131C
30132 8100 CONTINUE
30133      IERROR='YES'
30134      WRITE(ICOUT,999)
30135      CALL DPWRST('XXX','BUG ')
30136      WRITE(ICOUT,8111)
30137 8111 FORMAT('***** ERROR IN BOX SHADOW (DPBSHW)--')
30138      CALL DPWRST('XXX','BUG ')
30139      WRITE(ICOUT,8112)
30140 8112 FORMAT('      IN THE BOX ... HEIGHT COMMAND,')
30141      CALL DPWRST('XXX','BUG ')
30142      WRITE(ICOUT,8113)
30143 8113 FORMAT('      IN THE BOX ... WIDTH  COMMAND,')
30144      CALL DPWRST('XXX','BUG ')
30145      WRITE(ICOUT,8114)
30146 8114 FORMAT('      IN THE BOX ... HW COMMAND,')
30147      CALL DPWRST('XXX','BUG ')
30148      WRITE(ICOUT,8115)
30149 8115 FORMAT('      THE BOX MUST BE IDENTIFIED BY A NUMBER,')
30150      CALL DPWRST('XXX','BUG ')
30151      WRITE(ICOUT,8116)
30152 8116 FORMAT('      AS IN--')
30153      CALL DPWRST('XXX','BUG ')
30154      WRITE(ICOUT,8117)
30155 8117 FORMAT('      BOX 3 HW 1 .8')
30156      CALL DPWRST('XXX','BUG ')
30157      GOTO9000
30158C
30159 8200 CONTINUE
30160      IERROR='YES'
30161      WRITE(ICOUT,999)
30162      CALL DPWRST('XXX','BUG ')
30163      WRITE(ICOUT,8111)
30164      CALL DPWRST('XXX','BUG ')
30165      WRITE(ICOUT,8212)
30166 8212 FORMAT('      IN THE BOX ... HEIGHT COMMAND,')
30167      CALL DPWRST('XXX','BUG ')
30168      WRITE(ICOUT,8213)
30169 8213 FORMAT('      IN THE BOX ... WIDTH  COMMAND,')
30170      CALL DPWRST('XXX','BUG ')
30171      WRITE(ICOUT,8214)
30172 8214 FORMAT('      IN THE BOX ... HW COMMAND,')
30173      CALL DPWRST('XXX','BUG ')
30174      WRITE(ICOUT,8216)
30175 8216 FORMAT('      THE NUMBER OF BOXES MUST BE ')
30176      CALL DPWRST('XXX','BUG ')
30177      WRITE(ICOUT,8217)MAXBOX
30178 8217 FORMAT('      BETWEEN 1 AND ',I8,' (INCLUSIVELY);')
30179      CALL DPWRST('XXX','BUG ')
30180      WRITE(ICOUT,8218)
30181 8218 FORMAT('      SUCH WAS NOT THE CASE HERE--')
30182      CALL DPWRST('XXX','BUG ')
30183      WRITE(ICOUT,8219)I
30184 8219 FORMAT('      A REFERENCE WAS MADE TO THE ',I8,'-TH ',
30185     1'BOX.')
30186      CALL DPWRST('XXX','BUG ')
30187      GOTO9000
30188C
30189C               *****************
30190C               **  STEP 90--  **
30191C               **  EXIT       **
30192C               *****************
30193C
30194 9000 CONTINUE
30195      RETURN
30196      END
30197      SUBROUTINE DPBTES(XTEMP1,MAXNXT,
30198     1                  ICASAN,ICAPSW,IFORSW,IMULT,
30199     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
30200C
30201C     PURPOSE--CARRY OUT BARTLETT TEST
30202C              (K-SAMPLE HOMOGENEITY OF VARIANCES)
30203C     EXAMPLE--BARTLETT TEST Y X
30204C     REFERENCE--DIXON & MASSEY, PAGE 179-180
30205C     WRITTEN BY--JAMES J. FILLIBEN
30206C                 STATISTICAL ENGINEERING DIVISION
30207C                 INFORMATION TECHNOLOGY LABORATORY
30208C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
30209C                 GAITHERSBURG, MD 20899-8980
30210C                 PHONE--301-975-2855
30211C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
30212C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
30213C     LANGUAGE--ANSI FORTRAN (1977)
30214C     VERSION NUMBER--94/12
30215C     ORIGINAL VERSION--DECEMBER  1994.
30216C     UPDATED         --MAY       1995.  BUG FIX
30217C     UPDATED         --AUGUST    1999.  CHANGE DEFINITION TO USE
30218C                                        MORE COMMONLY ACCEPTED
30219C                                        FORM.  ADD "DIXON BARTLETT
30220C                                        TEST" TO USE PREVIOUS
30221C                                        DEFINITION.
30222C     UPDATED         --MAY       2011.  SUPPORT FOR HTML, RTF AND LATEX
30223C                                        OUTPUT
30224C     UPDATED         --MAY       2011.  USE DPPARS
30225C     UPDATED         --MAY       2011.  SUPPORT FOR "MULTIPLE" CASE
30226C
30227C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
30228C
30229      CHARACTER*4 ICASAN
30230      CHARACTER*4 ICAPSW
30231      CHARACTER*4 IFORSW
30232      CHARACTER*4 IMULT
30233      CHARACTER*4 IBUGA2
30234      CHARACTER*4 IBUGA3
30235      CHARACTER*4 IBUGQ
30236      CHARACTER*4 ISUBRO
30237      CHARACTER*4 IFOUND
30238      CHARACTER*4 IERROR
30239C
30240      CHARACTER*4 ISUBN1
30241      CHARACTER*4 ISUBN2
30242      CHARACTER*4 ISTEPN
30243      CHARACTER*4 ICASE
30244      CHARACTER*4 IFLAGU
30245C
30246      LOGICAL IFRST
30247      LOGICAL ILAST
30248      CHARACTER*40 INAME
30249      PARAMETER (MAXSPN=30)
30250      CHARACTER*4 IVARN1(MAXSPN)
30251      CHARACTER*4 IVARN2(MAXSPN)
30252      CHARACTER*4 IVARTY(MAXSPN)
30253      REAL PVAR(MAXSPN)
30254      INTEGER ILIS(MAXSPN)
30255      INTEGER NRIGHT(MAXSPN)
30256      INTEGER ICOLR(MAXSPN)
30257C
30258C---------------------------------------------------------------------
30259C
30260      DIMENSION XTEMP1(*)
30261C
30262C-----COMMON----------------------------------------------------------
30263C
30264      INCLUDE 'DPCOPA.INC'
30265      INCLUDE 'DPCOHK.INC'
30266      INCLUDE 'DPCOSU.INC'
30267      INCLUDE 'DPCODA.INC'
30268C
30269C-----COMMON VARIABLES (GENERAL)--------------------------------------
30270C
30271      INCLUDE 'DPCOP2.INC'
30272C
30273C-----START POINT-----------------------------------------------------
30274C
30275      ISUBN1='DPBT'
30276      ISUBN2='ES  '
30277C
30278      MAXCP1=MAXCOL+1
30279      MAXCP2=MAXCOL+2
30280      MAXCP3=MAXCOL+3
30281      MAXCP4=MAXCOL+4
30282      MAXCP5=MAXCOL+5
30283      MAXCP6=MAXCOL+6
30284C
30285      IFOUND='YES'
30286      IERROR='NO'
30287C
30288C               **************************************
30289C               **  TREAT THE BARTLETT TEST CASE    **
30290C               **************************************
30291C
30292      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'BTES')THEN
30293        WRITE(ICOUT,999)
30294  999   FORMAT(1X)
30295        CALL DPWRST('XXX','BUG ')
30296        WRITE(ICOUT,51)
30297   51   FORMAT('***** AT THE BEGINNING OF DPBTES--')
30298        CALL DPWRST('XXX','BUG ')
30299        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ISUBRO
30300   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ISUBRO = ',3(A4,2X),A4)
30301        CALL DPWRST('XXX','BUG ')
30302        WRITE(ICOUT,55)IMULT,MAXNXT
30303   55   FORMAT('IMULT,MAXNXT = ',A4,2X,I8)
30304        CALL DPWRST('XXX','BUG ')
30305      ENDIF
30306C
30307C               *********************************
30308C               **  STEP 1--                   **
30309C               **  EXTRACT THE VARIABLE LIST  **
30310C               *********************************
30311C
30312      ISTEPN='1'
30313      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BTES')
30314     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30315C
30316      INAME='BARTLETT TEST'
30317      MAXNA=100
30318      MINNVA=1
30319      MAXNVA=100
30320      MINNA=1
30321      IFLAGE=1
30322      IFLAGM=0
30323      IF(IMULT.EQ.'ON')THEN
30324        IFLAGE=0
30325        IFLAGM=1
30326      ENDIF
30327      MINN2=2
30328      IFLAGP=0
30329      JMIN=1
30330      JMAX=NUMARG
30331C
30332      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
30333     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
30334     1            JMIN,JMAX,
30335     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
30336     1            IVARN1,IVARN2,IVARTY,PVAR,
30337     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
30338     1            MINNVA,MAXNVA,
30339     1            IFLAGM,IFLAGP,
30340     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
30341      IF(IERROR.EQ.'YES')GOTO9000
30342C
30343      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BTES')THEN
30344        WRITE(ICOUT,999)
30345        CALL DPWRST('XXX','BUG ')
30346        WRITE(ICOUT,181)
30347  181   FORMAT('***** AFTER CALL DPPARS--')
30348        CALL DPWRST('XXX','BUG ')
30349        WRITE(ICOUT,182)NQ,NUMVAR,IMULT
30350  182   FORMAT('NQ,NUMVAR,IMULT = ',2I8,2X,A4)
30351        CALL DPWRST('XXX','BUG ')
30352        IF(NUMVAR.GT.0)THEN
30353          DO185I=1,NUMVAR
30354            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
30355     1                      ICOLR(I)
30356  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
30357     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
30358            CALL DPWRST('XXX','BUG ')
30359  185     CONTINUE
30360        ENDIF
30361      ENDIF
30362C
30363C               *******************************************************
30364C               **  STEP 3--                                         **
30365C               **  GENERATE THE BARTLETT       TEST FOR THE VARIOUS **
30366C               **  CASES                                            **
30367C               *******************************************************
30368C
30369      ISTEPN='3'
30370      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BTES')
30371     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30372C
30373C               *****************************************
30374C               **  STEP 3A--                          **
30375C               **  CASE 1: TWO RESPONSE VARIABLES     **
30376C               **          WITH NO REPLICATION        **
30377C               *****************************************
30378C
30379      IF(IMULT.EQ.'OFF')THEN
30380        ISTEPN='3A'
30381        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BTES')
30382     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30383C
30384        ICOL=1
30385        NUMVA2=2
30386        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
30387     1              INAME,IVARN1,IVARN2,IVARTY,
30388     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
30389     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
30390     1              MAXCP4,MAXCP5,MAXCP6,
30391     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
30392     1              Y,X,XTEMP1,NLOCAL,NLOCA2,NLOCA3,ICASE,
30393     1              IBUGA3,ISUBRO,IFOUND,IERROR)
30394        IF(IERROR.EQ.'YES')GOTO9000
30395C
30396C
30397C               ********************************************
30398C               **  STEP 3B--                             **
30399C               **  PREPARE FOR ENTRANCE INTO DPBTES--    **
30400C               ********************************************
30401C
30402        ISTEPN='3B'
30403        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BTES')THEN
30404          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30405          WRITE(ICOUT,999)
30406          CALL DPWRST('XXX','BUG ')
30407          WRITE(ICOUT,331)
30408  331     FORMAT('***** FROM DPBTES, AS WE ARE ABOUT TO CALL DPBTE2--')
30409          CALL DPWRST('XXX','BUG ')
30410          WRITE(ICOUT,332)NLOCAL
30411  332     FORMAT('NLOCAL = ',I8)
30412          CALL DPWRST('XXX','BUG ')
30413          DO335I=1,NLOCAL
30414            WRITE(ICOUT,336)I,Y(I),X(I)
30415  336       FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
30416            CALL DPWRST('XXX','BUG ')
30417  335     CONTINUE
30418        ENDIF
30419C
30420        CALL DPBTE2(Y,X,NLOCAL,IVARN1,IVARN2,ICASAN,
30421     1              STATVA,STATCD,PVAL,STANU1,STANU2,
30422     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999,
30423     1              ICAPSW,ICAPTY,IFORSW,IMULT,
30424     1              IBUGA3,ISUBRO,IERROR)
30425C
30426C               ***************************************
30427C               **  STEP 8C--                        **
30428C               **  UPDATE INTERNAL DATAPLOT TABLES  **
30429C               ***************************************
30430C
30431          ISTEPN='8C'
30432          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BTES')
30433     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30434C
30435          IFLAGU='ON'
30436          IFRST=.TRUE.
30437          ILAST=.TRUE.
30438          CALL DPFRT5(STATVA,STATCD,PVAL,
30439     1                CUT0,CUT50,CUT75,CUT90,CUT95,
30440     1                CUT975,CUT99,CUT999,
30441     1                IFLAGU,IFRST,ILAST,
30442     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
30443C
30444C               *******************************************************
30445C               **  STEP 4A--                                        **
30446C               **  CASE 2: MULTIPLE RESPONSE VARIABLES.  NOTE THAT  **
30447C               **          FOR F LOCATION     TEST, THE MULTIPLE    **
30448C               **          LABS ARE CONVERTED INTO A "Y X" STACKED  **
30449C               **          PAIR WHERE "X" IS THE LAB-ID VARIABLE.   **
30450C               *******************************************************
30451C
30452      ELSEIF(IMULT.EQ.'ON')THEN
30453        ISTEPN='4A'
30454        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'FLTE')
30455     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30456C
30457        ICOL=1
30458        NUMVA2=NUMVAR
30459        CALL DPPAR8(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
30460     1              INAME,IVARN1,IVARN2,IVARTY,
30461     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
30462     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
30463     1              MAXCP4,MAXCP5,MAXCP6,
30464     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
30465     1              XTEMP1,Y,X,NLOCAL,ICASE,
30466     1              IBUGA3,ISUBRO,IFOUND,IERROR)
30467        NUMVAR=2
30468        IF(IERROR.EQ.'YES')GOTO9000
30469C
30470        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'FLTE')THEN
30471          ISTEPN='4B'
30472          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30473          WRITE(ICOUT,999)
30474          CALL DPWRST('XXX','BUG ')
30475          WRITE(ICOUT,442)
30476  442     FORMAT('***** FROM THE MIDDLE  OF DPFLTE--')
30477          CALL DPWRST('XXX','BUG ')
30478          WRITE(ICOUT,443)ICASAN,NUMVAR,NLOCAL
30479  443     FORMAT('ICASAN,NUMVAR,NLOCAL = ',A4,2I8)
30480          CALL DPWRST('XXX','BUG ')
30481          IF(NLOCAL.GE.1)THEN
30482            DO445I=1,NLOCAL
30483              WRITE(ICOUT,446)I,Y(I),X(I)
30484  446         FORMAT('I,Y(I),X(I) = ',I8,2G15.7)
30485              CALL DPWRST('XXX','BUG ')
30486  445       CONTINUE
30487          ENDIF
30488        ENDIF
30489C
30490        CALL DPBTE2(Y,X,NLOCAL,IVARN1,IVARN2,ICASAN,
30491     1              STATVA,STATCD,PVAL,STANU1,STANU2,
30492     1              CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999,
30493     1              ICAPSW,ICAPTY,IFORSW,IMULT,
30494     1              IBUGA3,ISUBRO,IERROR)
30495C
30496C         ***************************************
30497C         **  STEP 8C--                        **
30498C         **  UPDATE INTERNAL DATAPLOT TABLES  **
30499C         ***************************************
30500C
30501          ISTEPN='8C'
30502          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BTES')
30503     1      CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30504C
30505          IFLAGU='ON'
30506          IFRST=.TRUE.
30507          ILAST=.TRUE.
30508          CALL DPFRT5(STATVA,STATCD,PVAL,
30509     1                CUT0,CUT50,CUT75,CUT90,CUT95,
30510     1                CUT975,CUT99,CUT999,
30511     1                IFLAGU,IFRST,ILAST,
30512     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
30513C
30514      ENDIF
30515C
30516C               *****************
30517C               **  STEP 90--  **
30518C               **  EXIT       **
30519C               *****************
30520C
30521 9000 CONTINUE
30522      IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'BTES')THEN
30523        WRITE(ICOUT,999)
30524        CALL DPWRST('XXX','BUG ')
30525        WRITE(ICOUT,9011)
30526 9011   FORMAT('***** AT THE END       OF DPBTES--')
30527        CALL DPWRST('XXX','BUG ')
30528        WRITE(ICOUT,9014)NLOCAL,STATVA,STATCD
30529 9014   FORMAT('NLOCAL,STATVA,STATCD = ',I8,2G15.7)
30530        CALL DPWRST('XXX','BUG ')
30531        WRITE(ICOUT,9016)IFOUND,IERROR
30532 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
30533        CALL DPWRST('XXX','BUG ')
30534      ENDIF
30535C
30536      RETURN
30537      END
30538      SUBROUTINE DPBTE2(Y,TAG,N,IVARID,IVARI2,ICASAN,
30539     1                  STATVA,STATCD,PVAL,STANU1,STANU2,
30540     1                  CUT0,CUT50,CUT75,CUT90,CUT95,CUT99,CUT999,
30541     1                  ICAPSW,ICAPTY,IFORSW,IMULT,
30542     1                  IBUGA3,ISUBRO,IERROR)
30543C
30544C     PURPOSE--THIS ROUTINE CARRIES OUT BARTLETT'S TEST
30545C              (K-SAMPLE HOMOSCEDASTICITY TEST)
30546C     EXAMPLE--BARTLETT'S TEST Y TAG
30547C     REFERENCE--DIXON & MASSEY, PAGE 179-180
30548C     WRITTEN BY--JAMES J. FILLIBEN
30549C                 STATISTICAL ENGINEERING DIVISION
30550C                 INFORMATION TECHNOLOGY LABORATORY
30551C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
30552C                 GAITHERSBURG, MD 20899-8980
30553C                 PHONE--301-975-2855
30554C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
30555C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
30556C     LANGUAGE--ANSI FORTRAN (1977)
30557C     VERSION NUMBER--94/2
30558C     ORIGINAL VERSION--FEBRUARY  1994.
30559C     UPDATED         --AUGUST    1999.  ADD NEW DEFINITION
30560C     UPDATED         --MAY       2011. USE DPTAB1 AND DPDTA4 TO PRINT
30561C                                       OUTPUT TABLES.  THIS ADDS
30562C                                       HTML/LATEX/RTF SUPPORT AS WELL.
30563C
30564C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
30565C
30566      CHARACTER*4 ICASAN
30567      CHARACTER*4 ICAPSW
30568      CHARACTER*4 ICAPTY
30569      CHARACTER*4 IFORSW
30570      CHARACTER*4 IMULT
30571      CHARACTER*4 ISUBRO
30572      CHARACTER*4 IBUGA3
30573      CHARACTER*4 IERROR
30574      CHARACTER*4 IVARID(*)
30575      CHARACTER*4 IVARI2(*)
30576C
30577      CHARACTER*4 IWRITE
30578      CHARACTER*4 ISUBN1
30579      CHARACTER*4 ISUBN2
30580      CHARACTER*4 ISTEPN
30581C
30582C---------------------------------------------------------------------
30583C
30584      DIMENSION Y(*)
30585      DIMENSION TAG(*)
30586C
30587      DIMENSION DTAG(1000)
30588      DIMENSION YTEMP(1000)
30589      DIMENSION ANI(1000)
30590      DIMENSION VARI(1000)
30591C
30592      PARAMETER (NUMALP=8)
30593      REAL ALPHA(NUMALP)
30594C
30595      PARAMETER(NUMCLI=4)
30596      PARAMETER(MAXLIN=1)
30597      PARAMETER (MAXROW=15)
30598      CHARACTER*60 ITITLE
30599      CHARACTER*60 ITITLZ
30600      CHARACTER*1  ITITL9
30601      CHARACTER*60 ITEXT(MAXROW)
30602      CHARACTER*4  ALIGN(NUMCLI)
30603      CHARACTER*4  VALIGN(NUMCLI)
30604      REAL         AVALUE(MAXROW)
30605      INTEGER      NCTEXT(MAXROW)
30606      INTEGER      IDIGIT(MAXROW)
30607      INTEGER      NTOT(MAXROW)
30608      CHARACTER*60 ITITL2(MAXLIN,NUMCLI)
30609      CHARACTER*15 IVALUE(MAXROW,NUMCLI)
30610      CHARACTER*4  ITYPCO(NUMCLI)
30611      INTEGER      NCTIT2(MAXLIN,NUMCLI)
30612      INTEGER      NCVALU(MAXROW,NUMCLI)
30613      INTEGER      IWHTML(NUMCLI)
30614      INTEGER      IWRTF(NUMCLI)
30615      REAL         AMAT(MAXROW,NUMCLI)
30616      LOGICAL IFRST
30617      LOGICAL ILAST
30618C
30619C---------------------------------------------------------------------
30620C
30621      INCLUDE 'DPCOP2.INC'
30622C
30623C-----START POINT-----------------------------------------------------
30624C
30625      DATA ALPHA/
30626     1 0.0, 50.0, 75.0, 90.0, 95.0, 97.5, 99.0, 99.9/
30627C
30628      ISUBN1='DPBT'
30629      ISUBN2='E2  '
30630C
30631      IERROR='NO'
30632      IWRITE='OFF'
30633C
30634      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BTE2')THEN
30635        WRITE(ICOUT,999)
30636  999   FORMAT(1X)
30637        CALL DPWRST('XXX','WRIT')
30638        WRITE(ICOUT,51)
30639   51   FORMAT('**** AT THE BEGINNING OF DPBTE2--')
30640        CALL DPWRST('XXX','WRIT')
30641        WRITE(ICOUT,52)IBUGA3,ISUBRO,ICASAN,N
30642   52   FORMAT('IBUGA3,ISUBRO,ICASAN,N = ',3(A4,2X),I8)
30643        CALL DPWRST('XXX','WRIT')
30644        DO56I=1,N
30645          WRITE(ICOUT,57)I,Y(I),TAG(I)
30646   57     FORMAT('I,Y(I),TAG(I) = ',I8,2G15.7)
30647          CALL DPWRST('XXX','WRIT')
30648   56   CONTINUE
30649      ENDIF
30650C
30651C               ********************************************
30652C               **  STEP 11--                             **
30653C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
30654C               ********************************************
30655C
30656      ISTEPN='11'
30657      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BTE2')
30658     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30659C
30660      IF(N.LE.1)THEN
30661        WRITE(ICOUT,999)
30662        CALL DPWRST('XXX','WRIT')
30663        WRITE(ICOUT,1111)
30664 1111   FORMAT('***** ERROR IN BARTLETT TEST--')
30665        CALL DPWRST('XXX','WRIT')
30666        WRITE(ICOUT,1113)
30667 1113   FORMAT('      THE NUMBER OF OBSERVATIONS FOR THE RESPONSE ',
30668     1         'VARIABLE IS LESS THAN 2.')
30669        WRITE(ICOUT,1115)N
30670 1115   FORMAT('      THE SAMPLE SIZE = ',I8)
30671        CALL DPWRST('XXX','WRIT')
30672        IERROR='YES'
30673        GOTO9000
30674      ENDIF
30675C
30676      HOLD=Y(1)
30677      DO1135I=2,N
30678        IF(Y(I).NE.HOLD)GOTO1139
30679 1135 CONTINUE
30680      WRITE(ICOUT,999)
30681      CALL DPWRST('XXX','WRIT')
30682      WRITE(ICOUT,1111)
30683      CALL DPWRST('XXX','WRIT')
30684      WRITE(ICOUT,1133)HOLD
30685 1133 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
30686      CALL DPWRST('XXX','WRIT')
30687      GOTO9000
30688 1139 CONTINUE
30689C
30690      HOLD=TAG(1)
30691      DO1235I=2,N
30692        IF(TAG(I).NE.HOLD)GOTO1239
30693 1235 CONTINUE
30694      WRITE(ICOUT,999)
30695      CALL DPWRST('XXX','WRIT')
30696      WRITE(ICOUT,1111)
30697      CALL DPWRST('XXX','WRIT')
30698      WRITE(ICOUT,1231)HOLD
30699 1231 FORMAT('      THE GROUP-ID VARIABLE HAS ALL ELEMENTS = ',G15.7)
30700      CALL DPWRST('XXX','WRIT')
30701      GOTO9000
30702 1239 CONTINUE
30703C
30704C               **************************************************
30705C               **  STEP 21--                                   **
30706C               **  CARRY OUT CALCULATIONS FOR BARTLETT'S TEST  **
30707C               **  THAT ARE COMMON TO BOTH THE DIXON-MASSEY    **
30708C               **  DEFINITION AND THE STANDARD DEFINITION.     **
30709C               **************************************************
30710C
30711      ISTEPN='21'
30712      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BTE2')
30713     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30714C
30715      CALL DISTIN(TAG,N,IWRITE,DTAG,NUMDIS,IBUGA3,IERROR)
30716C
30717      KPRIME=0
30718      NPRIME=0
30719      DO2120IDIS=1,NUMDIS
30720        J=0
30721        DO2130I=1,N
30722          IF(TAG(I).EQ.DTAG(IDIS))THEN
30723            J=J+1
30724            YTEMP(J)=Y(I)
30725          ENDIF
30726 2130   CONTINUE
30727        ANI(IDIS)=J
30728        IF(J.GE.2)THEN
30729          KPRIME=KPRIME+1
30730          NPRIME=NPRIME+J
30731          CALL VAR(YTEMP,J,IWRITE,VARI(IDIS),IBUGA3,IERROR)
30732        ENDIF
30733 2120 CONTINUE
30734      ANPRIM=NPRIME
30735      AKPRIM=KPRIME
30736C
30737      TERM1=0.0
30738      TERM2=0.0
30739      TERM3=0.0
30740      DO2140IDIS=1,NUMDIS
30741        J=INT(ANI(IDIS)+0.5)
30742        IF(J.GE.2)THEN
30743          TERM1=TERM1+(ANI(IDIS)-1.0)*VARI(IDIS)
30744          TERM2=TERM2+(ANI(IDIS)-1.0)*LOG(VARI(IDIS))
30745          TERM3=TERM3+(1.0/(ANI(IDIS)-1.0))
30746        ENDIF
30747 2140 CONTINUE
30748C
30749      ANUM=TERM1
30750      ADEN=NPRIME-KPRIME
30751      VARPOO=ANUM/ADEN
30752C
30753      AM=(ANPRIM-AKPRIM)*LOG(VARPOO)-TERM2
30754C
30755      TERM4=1.0/(3.0*(AKPRIM-1.0))
30756      TERM5=1.0/(ANPRIM-AKPRIM)
30757      A=TERM4*(TERM3-TERM5)
30758C
30759      ANU1=AKPRIM-1.0
30760      NU1=INT(ANU1+0.5)
30761      ANU1=REAL(NU1)
30762      STANU1=ANU1
30763C
30764C               **************************************************
30765C               **  STEP 22--                                   **
30766C               **  CARRY OUT CALCULATIONS FOR BARTLETT'S TEST  **
30767C               **  DIXON-MASSEY DEFINITION                     **
30768C               **************************************************
30769C
30770      IF(ICASAN.EQ.'DMBT')THEN
30771        ISTEPN='22'
30772        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BTE2')
30773     1  CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30774C
30775        ANU2=(AKPRIM+1.0)/(A**2)
30776        NU2=INT(ANU2+0.5)
30777        ANU2=REAL(NU2)
30778        STANU2=ANU2
30779C
30780        B=ANU2/(1.0-A+(2.0/ANU2))
30781C
30782        ANUM=ANU2*AM
30783        ADEN=ANU1*(B-AM)
30784        STATVA=ANUM/ADEN
30785        CALL FCDF(STATVA,NU1,NU2,STATCD)
30786        PVAL=1.0 - STATCD
30787        CUT0=0.0
30788        CALL FPPF(.50,NU1,NU2,CUT50)
30789        CALL FPPF(.75,NU1,NU2,CUT75)
30790        CALL FPPF(.90,NU1,NU2,CUT90)
30791        CALL FPPF(.95,NU1,NU2,CUT95)
30792        CALL FPPF(.975,NU1,NU2,CUT975)
30793        CALL FPPF(.99,NU1,NU2,CUT99)
30794        CALL FPPF(.999,NU1,NU2,CUT999)
30795C
30796C               **************************************************
30797C               **  STEP 23--                                   **
30798C               **  CARRY OUT CALCULATIONS FOR BARTLETT'S TEST  **
30799C               **  STANDARD     DEFINITION                     **
30800C               **************************************************
30801      ELSE
30802C
30803        ISTEPN='23'
30804        IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BTE2')
30805     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30806C
30807        ANU2=0.0
30808        NU2=0
30809        STANU2=ANU2
30810C
30811        C=1.0 + A
30812        STATVA=AM/C
30813C
30814        CUT0=0.0
30815        CALL CHSCDF(STATVA,NU1,STATCD)
30816        PVAL=1.0 - STATCD
30817        CALL CHSPPF(.50,NU1,CUT50)
30818        CALL CHSPPF(.75,NU1,CUT75)
30819        CALL CHSPPF(.90,NU1,CUT90)
30820        CALL CHSPPF(.95,NU1,CUT95)
30821        CALL CHSPPF(.975,NU1,CUT975)
30822        CALL CHSPPF(.99,NU1,CUT99)
30823        CALL CHSPPF(.999,NU1,CUT999)
30824      ENDIF
30825C
30826C               ******************************
30827C               **   STEP 42--              **
30828C               **   WRITE OUT EVERYTHING   **
30829C               **   FOR   BARTLETT'S TEST  **
30830C               ******************************
30831C
30832      ISTEPN='42'
30833      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BTE2')
30834     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30835C
30836      IF(IPRINT.EQ.'OFF')GOTO9000
30837C
30838      NUMDIG=7
30839      IF(IFORSW.EQ.'1')NUMDIG=1
30840      IF(IFORSW.EQ.'2')NUMDIG=2
30841      IF(IFORSW.EQ.'3')NUMDIG=3
30842      IF(IFORSW.EQ.'4')NUMDIG=4
30843      IF(IFORSW.EQ.'5')NUMDIG=5
30844      IF(IFORSW.EQ.'6')NUMDIG=6
30845      IF(IFORSW.EQ.'7')NUMDIG=7
30846      IF(IFORSW.EQ.'8')NUMDIG=8
30847      IF(IFORSW.EQ.'9')NUMDIG=9
30848      IF(IFORSW.EQ.'0')NUMDIG=0
30849      IF(IFORSW.EQ.'E')NUMDIG=-2
30850      IF(IFORSW.EQ.'-2')NUMDIG=-2
30851      IF(IFORSW.EQ.'-3')NUMDIG=-3
30852      IF(IFORSW.EQ.'-4')NUMDIG=-4
30853      IF(IFORSW.EQ.'-5')NUMDIG=-5
30854      IF(IFORSW.EQ.'-6')NUMDIG=-6
30855      IF(IFORSW.EQ.'-7')NUMDIG=-7
30856      IF(IFORSW.EQ.'-8')NUMDIG=-8
30857      IF(IFORSW.EQ.'-9')NUMDIG=-9
30858C
30859      ITITLE='Bartlett Test for Homogeneous Variance'
30860      NCTITL=38
30861      IF(ICASAN.EQ.'DMBT')THEN
30862        ITITLZ='(Dixon-Massey Definition)'
30863        NCTITZ=25
30864      ELSE
30865        ITITLZ='(Standard Definition)'
30866        NCTITZ=21
30867      ENDIF
30868C
30869      ICNT=1
30870      ITEXT(ICNT)=' '
30871      NCTEXT(ICNT)=0
30872      AVALUE(ICNT)=0.0
30873      IDIGIT(ICNT)=-1
30874      IF(IMULT.EQ.'OFF')THEN
30875        ICNT=ICNT+1
30876        ITEXT(ICNT)='Response Variable: '
30877        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
30878        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
30879        NCTEXT(ICNT)=27
30880        AVALUE(ICNT)=0.0
30881        IDIGIT(ICNT)=-1
30882C
30883        ICNT=ICNT+1
30884        ITEXT(ICNT)='Group-ID Variable: '
30885        WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(2)(1:4)
30886        WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(2)(1:4)
30887        NCTEXT(ICNT)=27
30888        AVALUE(ICNT)=0.0
30889        IDIGIT(ICNT)=-1
30890      ENDIF
30891C
30892      ICNT=ICNT+1
30893      ITEXT(ICNT)=' '
30894      NCTEXT(ICNT)=1
30895      AVALUE(ICNT)=0.0
30896      IDIGIT(ICNT)=-1
30897C
30898      ICNT=ICNT+1
30899      ITEXT(ICNT)='H0: Groups are Homogeneous with'
30900      NCTEXT(ICNT)=31
30901      AVALUE(ICNT)=0.0
30902      IDIGIT(ICNT)=-1
30903      ICNT=ICNT+1
30904      ITEXT(ICNT)='    Respect to Variance'
30905      NCTEXT(ICNT)=23
30906      AVALUE(ICNT)=0.0
30907      IDIGIT(ICNT)=-1
30908      ICNT=ICNT+1
30909      ITEXT(ICNT)='Ha: Groups are Not Homogeneous with'
30910      NCTEXT(ICNT)=35
30911      AVALUE(ICNT)=0.0
30912      IDIGIT(ICNT)=-1
30913      ICNT=ICNT+1
30914      ITEXT(ICNT)='    Respect to Variance'
30915      NCTEXT(ICNT)=23
30916      AVALUE(ICNT)=0.0
30917      IDIGIT(ICNT)=-1
30918C
30919      ICNT=ICNT+1
30920      ITEXT(ICNT)=' '
30921      NCTEXT(ICNT)=1
30922      AVALUE(ICNT)=0.0
30923      IDIGIT(ICNT)=-1
30924      ICNT=ICNT+1
30925      ITEXT(ICNT)='Summary Statistics:'
30926      NCTEXT(ICNT)=19
30927      AVALUE(ICNT)=0.0
30928      IDIGIT(ICNT)=-1
30929      ICNT=ICNT+1
30930      ITEXT(ICNT)='Total Number of Observations:'
30931      NCTEXT(ICNT)=29
30932      AVALUE(ICNT)=REAL(N)
30933      IDIGIT(ICNT)=0
30934      ICNT=ICNT+1
30935      ITEXT(ICNT)='Number of Groups:'
30936      NCTEXT(ICNT)=17
30937      AVALUE(ICNT)=REAL(NUMDIS)
30938      IDIGIT(ICNT)=0
30939      ICNT=ICNT+1
30940      ITEXT(ICNT)=' '
30941      NCTEXT(ICNT)=1
30942      AVALUE(ICNT)=0.0
30943      IDIGIT(ICNT)=-1
30944C
30945      ICNT=ICNT+1
30946      ITEXT(ICNT)='Bartlett Test Statistic Value:'
30947      NCTEXT(ICNT)=30
30948      AVALUE(ICNT)=STATVA
30949      IDIGIT(ICNT)=NUMDIG
30950      ICNT=ICNT+1
30951      ITEXT(ICNT)='CDF of Test Statistic:'
30952      NCTEXT(ICNT)=22
30953      AVALUE(ICNT)=STATCD
30954      IDIGIT(ICNT)=NUMDIG
30955      ICNT=ICNT+1
30956      ITEXT(ICNT)='P-Value:'
30957      NCTEXT(ICNT)=8
30958      AVALUE(ICNT)=PVAL
30959      IDIGIT(ICNT)=NUMDIG
30960C
30961      NUMROW=ICNT
30962      DO4210I=1,NUMROW
30963        NTOT(I)=15
30964 4210 CONTINUE
30965C
30966      IFRST=.TRUE.
30967      ILAST=.TRUE.
30968C
30969      ISTEPN='42A'
30970      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BTE2')
30971     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
30972C
30973      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
30974     1            AVALUE,IDIGIT,
30975     1            NTOT,NUMROW,
30976     1            ICAPSW,ICAPTY,ILAST,IFRST,
30977     1            ISUBRO,IBUGA3,IERROR)
30978C
30979      ITITLE=' '
30980      NCTITL=0
30981C
30982      ITITL9=' '
30983      NCTIT9=0
30984      IF(ICASAN.EQ.'DMBT')THEN
30985        ITITLE(1:55)=
30986     1  'Percent Points of the F Reference Distribution'
30987        NCTITL=46
30988      ELSE
30989        ITITLE(1:55)=
30990     1  'Percent Points of the Chi-Square Reference Distribution'
30991        NCTITL=55
30992      ENDIF
30993      NUMLIN=1
30994      NUMROW=8
30995      NUMCOL=3
30996      ITITL2(1,1)='Percent Point'
30997      ITITL2(1,2)=' '
30998      ITITL2(1,3)='Value'
30999      NCTIT2(1,1)=13
31000      NCTIT2(1,2)=1
31001      NCTIT2(1,3)=5
31002C
31003      NMAX=0
31004      DO4221I=1,NUMCOL
31005        VALIGN(I)='b'
31006        ALIGN(I)='r'
31007        NTOT(I)=15
31008        IF(I.EQ.2)NTOT(I)=5
31009        NMAX=NMAX+NTOT(I)
31010        IDIGIT(I)=NUMDIG
31011        ITYPCO(I)='NUME'
31012 4221 CONTINUE
31013      ITYPCO(2)='ALPH'
31014      IDIGIT(1)=1
31015      IDIGIT(3)=3
31016      DO4223I=1,NUMROW
31017        DO4225J=1,NUMCOL
31018          NCVALU(I,J)=0
31019          IVALUE(I,J)=' '
31020          NCVALU(I,J)=0
31021          AMAT(I,J)=0.0
31022          IF(J.EQ.1)THEN
31023            AMAT(I,J)=ALPHA(I)
31024          ELSEIF(J.EQ.2)THEN
31025            IVALUE(I,J)='='
31026            NCVALU(I,J)=1
31027          ELSEIF(J.EQ.3)THEN
31028            IF(I.EQ.1)THEN
31029              AMAT(I,J)=RND(CUT0,IDIGIT(J))
31030            ELSEIF(I.EQ.2)THEN
31031              AMAT(I,J)=RND(CUT50,IDIGIT(J))
31032            ELSEIF(I.EQ.3)THEN
31033              AMAT(I,J)=RND(CUT75,IDIGIT(J))
31034            ELSEIF(I.EQ.4)THEN
31035              AMAT(I,J)=RND(CUT90,IDIGIT(J))
31036            ELSEIF(I.EQ.5)THEN
31037              AMAT(I,J)=RND(CUT95,IDIGIT(J))
31038            ELSEIF(I.EQ.6)THEN
31039              AMAT(I,J)=RND(CUT975,IDIGIT(J))
31040            ELSEIF(I.EQ.7)THEN
31041              AMAT(I,J)=RND(CUT99,IDIGIT(J))
31042            ELSEIF(I.EQ.8)THEN
31043              AMAT(I,J)=RND(CUT999,IDIGIT(J))
31044            ENDIF
31045          ENDIF
31046 4225   CONTINUE
31047 4223 CONTINUE
31048C
31049      IWHTML(1)=150
31050      IWHTML(2)=50
31051      IWHTML(3)=150
31052      IWRTF(1)=2000
31053      IWRTF(2)=IWRTF(1)+500
31054      IWRTF(3)=IWRTF(2)+2000
31055      IFRST=.TRUE.
31056      ILAST=.FALSE.
31057C
31058      ISTEPN='42C'
31059      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BTE2')
31060     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31061C
31062      CALL DPDTA4(ITITL9,NCTIT9,
31063     1            ITITLE,NCTITL,ITITL2,NCTIT2,
31064     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
31065     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
31066     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
31067     1            ICAPSW,ICAPTY,IFRST,ILAST,
31068     1            ISUBRO,IBUGA3,IERROR)
31069C
31070      ISTEPN='42D'
31071      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BTE2')
31072     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31073C
31074      CDF1=CUT90
31075      CDF2=CUT95
31076      CDF3=CUT975
31077      CDF4=CUT99
31078C
31079      ITITL9=' '
31080      NCTIT9=0
31081      ITITLE='Conclusions (Upper 1-Tailed Test)'
31082      NCTITL=33
31083      NUMLIN=1
31084      NUMROW=4
31085      NUMCOL=4
31086      ITITL2(1,1)='Alpha'
31087      ITITL2(1,2)='CDF'
31088      ITITL2(1,3)='Critical Value'
31089      ITITL2(1,4)='Conclusion'
31090      NCTIT2(1,1)=5
31091      NCTIT2(1,2)=3
31092      NCTIT2(1,3)=14
31093      NCTIT2(1,4)=10
31094C
31095      NMAX=0
31096      DO4321I=1,NUMCOL
31097        VALIGN(I)='b'
31098        ALIGN(I)='r'
31099        NTOT(I)=15
31100        IF(I.EQ.1 .OR. I.EQ.2)NTOT(I)=7
31101        IF(I.EQ.3)NTOT(I)=17
31102        NMAX=NMAX+NTOT(I)
31103        IDIGIT(I)=3
31104        ITYPCO(I)='ALPH'
31105 4321 CONTINUE
31106      ITYPCO(3)='NUME'
31107      IDIGIT(1)=0
31108      IDIGIT(2)=0
31109      DO4323I=1,NUMROW
31110        DO4325J=1,NUMCOL
31111          NCVALU(I,J)=0
31112          IVALUE(I,J)=' '
31113          NCVALU(I,J)=0
31114          AMAT(I,J)=0.0
31115 4325   CONTINUE
31116 4323 CONTINUE
31117      IVALUE(1,1)='10%'
31118      IVALUE(2,1)='5%'
31119      IVALUE(3,1)='2.5%'
31120      IVALUE(4,1)='1%'
31121      IVALUE(1,2)='90%'
31122      IVALUE(2,2)='95%'
31123      IVALUE(3,2)='97.5%'
31124      IVALUE(4,2)='99%'
31125      NCVALU(1,1)=3
31126      NCVALU(2,1)=2
31127      NCVALU(3,1)=4
31128      NCVALU(4,1)=2
31129      NCVALU(1,2)=3
31130      NCVALU(2,2)=3
31131      NCVALU(3,2)=5
31132      NCVALU(4,2)=3
31133      IVALUE(1,4)='Accept H0'
31134      IVALUE(2,4)='Accept H0'
31135      IVALUE(3,4)='Accept H0'
31136      IVALUE(4,4)='Accept H0'
31137      NCVALU(1,4)=9
31138      NCVALU(2,4)=9
31139      NCVALU(3,4)=9
31140      NCVALU(4,4)=9
31141      IF(STATVA.GT.CUT90)IVALUE(1,4)='Reject H0'
31142      IF(STATVA.GT.CUT95)IVALUE(2,4)='Reject H0'
31143      IF(STATVA.GT.CUT975)IVALUE(3,4)='Reject H0'
31144      IF(STATVA.GT.CUT99)IVALUE(4,4)='Reject H0'
31145      AMAT(1,3)=RND(CUT90,IDIGIT(3))
31146      AMAT(2,3)=RND(CUT95,IDIGIT(3))
31147      AMAT(3,3)=RND(CUT975,IDIGIT(3))
31148      AMAT(4,3)=RND(CUT99,IDIGIT(3))
31149C
31150      IWHTML(1)=150
31151      IWHTML(2)=150
31152      IWHTML(3)=150
31153      IWHTML(4)=150
31154      IWRTF(1)=1500
31155      IWRTF(2)=IWRTF(1)+1500
31156      IWRTF(3)=IWRTF(2)+2000
31157      IWRTF(4)=IWRTF(3)+2000
31158      IFRST=.FALSE.
31159      ILAST=.TRUE.
31160C
31161      ISTEPN='42E'
31162      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BTE2')
31163     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31164C
31165      CALL DPDTA4(ITITL9,NCTIT9,
31166     1            ITITLE,NCTITL,ITITL2,NCTIT2,
31167     1            MAXLIN,NUMLIN,NUMCLI,NUMCOL,
31168     1            IVALUE,NCVALU,AMAT,ITYPCO,MAXROW,NUMROW,
31169     1            IDIGIT,NTOT,IWHTML,IWRTF,VALIGN,ALIGN,NMAX,
31170     1            ICAPSW,ICAPTY,IFRST,ILAST,
31171     1            ISUBRO,IBUGA3,IERROR)
31172C
31173C               *****************
31174C               **  STEP 90--  **
31175C               **  EXIT       **
31176C               *****************
31177C
31178 9000 CONTINUE
31179      IF(IBUGA3.EQ.'ON' .OR. ISUBRO.EQ.'BTE2')THEN
31180        WRITE(ICOUT,999)
31181        CALL DPWRST('XXX','WRIT')
31182        WRITE(ICOUT,9011)
31183 9011   FORMAT('***** AT THE END       OF DPBTE2--')
31184        CALL DPWRST('XXX','WRIT')
31185        WRITE(ICOUT,9012)IERROR,STATVA,STATCD,PVAL
31186 9012   FORMAT('IERROR,STATVA,STATCD,PVAL = ',A4,2X,3G15.7)
31187        CALL DPWRST('XXX','WRIT')
31188      ENDIF
31189C
31190      RETURN
31191      END
31192      SUBROUTINE DPBUGS(IBUGS2,ISUBRO,IFOUND,IERROR)
31193C
31194C     PURPOSE--DISPLAY CONTENTS OF DATAPLOT BUGS FILE.
31195C     WRITTEN BY--JAMES J. FILLIBEN
31196C                 STATISTICAL ENGINEERING DIVISION
31197C                 INFORMATION TECHNOLOGY LABORATORY
31198C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31199C                 GAITHERSBURG, MD 20899-8980
31200C                 PHONE--301-975-2855
31201C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31202C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
31203C     LANGUAGE--ANSI FORTRAN (1977)
31204C     VERSION NUMBER--86/1
31205C     ORIGINAL VERSION--OCTOBER   1981.
31206C     UPDATED         --NOVEMBER  1981.
31207C     UPDATED         --MAY       1982.
31208C     UPDATED         --DECEMBER  1985.
31209C     UPDATED         --APRIL     1992.  COMMENT OUT
31210C
31211C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31212C
31213      CHARACTER*4 IBUGS2
31214      CHARACTER*4 ISUBRO
31215      CHARACTER*4 IFOUND
31216      CHARACTER*4 IERROR
31217C
31218      INCLUDE 'DPCOPA.INC'
31219C
31220      CHARACTER (LEN=MAXFNC) :: IFILE
31221      CHARACTER*12 ISTAT
31222      CHARACTER*12 IFORM
31223      CHARACTER*12 IACCES
31224      CHARACTER*12 IPROT
31225      CHARACTER*12 ICURST
31226      CHARACTER*4 IENDFI
31227      CHARACTER*4 IREWIN
31228      CHARACTER*4 ISUBN0
31229      CHARACTER*4 IERRFI
31230C
31231      CHARACTER*4 ISUBN1
31232      CHARACTER*4 ISUBN2
31233      CHARACTER*4 ISTEPN
31234C
31235      CHARACTER (LEN=MAXFNC) :: ISTRIN
31236C
31237C-----COMMON----------------------------------------------------------
31238C
31239      INCLUDE 'DPCOF2.INC'
31240C
31241C-----COMMON VARIABLES (GENERAL)--------------------------------------
31242C
31243      INCLUDE 'DPCOP2.INC'
31244C
31245C-----START POINT-----------------------------------------------------
31246C
31247      ISUBN1='DPBU'
31248      ISUBN2='GS  '
31249      ISUBN0='BUGS'
31250      IFOUND='YES'
31251      IERROR='NO'
31252C
31253      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'BUGS')THEN
31254        WRITE(ICOUT,999)
31255  999   FORMAT(1X)
31256        CALL DPWRST('XXX','BUG ')
31257        WRITE(ICOUT,51)
31258   51   FORMAT('***** AT THE BEGINNING OF DPBUGS--')
31259        CALL DPWRST('XXX','BUG ')
31260        WRITE(ICOUT,53)IBUGS2,ISUBRO,IERROR,IBUGNU
31261   53   FORMAT('IBUGS2,ISUBRO,IERROR,IBUGNU = ',2(A4,2X),I8)
31262        CALL DPWRST('XXX','BUG ')
31263        WRITE(ICOUT,62)IBUGNA(1:80)
31264   62   FORMAT('IBUGNA = ',A80)
31265        CALL DPWRST('XXX','BUG ')
31266        WRITE(ICOUT,63)IBUGST,IBUGFO,IBUGAC,IBUGCS
31267   63   FORMAT('IBUGST,IBUGFO,IBUGAC,IBUGCS = ',3(A12,2X),A12)
31268        CALL DPWRST('XXX','BUG ')
31269      ENDIF
31270C
31271C               **************************
31272C               **  STEP 11--           **
31273C               **  COPY OVER VARIABLES **
31274C               **************************
31275C
31276      ISTEPN='11'
31277      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'BUGS')
31278     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31279C
31280      IOUNIT=IBUGNU
31281      IFILE=IBUGNA
31282      ISTAT=IBUGST
31283      IFORM=IBUGFO
31284      IACCES=IBUGAC
31285      IPROT=IBUGPR
31286      ICURST=IBUGCS
31287C
31288      IERRFI='NO'
31289C
31290      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'BUGS')THEN
31291        WRITE(ICOUT,1193)ISUBN0,IERRFI,IOUNIT
31292 1193   FORMAT('ISUBB0,IERRFI,IOUNIT = ',2(A4,2X),I8)
31293        CALL DPWRST('XXX','BUG ')
31294        WRITE(ICOUT,1194)IFILE(1:80)
31295 1194   FORMAT('IFILE = ',A80)
31296        CALL DPWRST('XXX','BUG ')
31297        WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IPROT,ICURST
31298 1195   FORMAT('ISTAT,IFORM,IACCES,IPROT,ICURST = ',4(A12,2X),A12)
31299        CALL DPWRST('XXX','BUG ')
31300      ENDIF
31301C
31302C               ****************************************
31303C               **  STEP 12--                         **
31304C               **  CHECK TO SEE IF BUGS FILE EXISTS  **
31305C               ****************************************
31306C
31307      ISTEPN='12'
31308      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'BUGS')
31309     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31310C
31311      IF(ISTAT.EQ.'NONE')THEN
31312        IERROR='YES'
31313        WRITE(ICOUT,999)
31314        CALL DPWRST('XXX','BUG ')
31315        WRITE(ICOUT,1211)
31316 1211   FORMAT('***** ERROR IN DPBUGS--')
31317        CALL DPWRST('XXX','BUG ')
31318        WRITE(ICOUT,1212)
31319 1212   FORMAT('      THE DESIRED BUGS FILE CANNOT BE LISTED BECAUSE')
31320        CALL DPWRST('XXX','BUG ')
31321        WRITE(ICOUT,1214)
31322 1214   FORMAT('      THE REQUIRED SYSTEM MASS STORAGE FILE WHICH ',
31323     1         'STORES ANY BUGS')
31324        CALL DPWRST('XXX','BUG ')
31325        WRITE(ICOUT,1216)
31326 1216   FORMAT('      IS NOT AVAILABLE AT THIS INSTALLATION.')
31327        CALL DPWRST('XXX','BUG ')
31328        WRITE(ICOUT,1217)ISTAT,IBUGST
31329 1217   FORMAT('ISTAT,IBUGST = ',A12,2X,A12)
31330        CALL DPWRST('XXX','BUG ')
31331        GOTO9000
31332      ENDIF
31333C
31334C               *********************
31335C               **  STEP 31--      **
31336C               **  OPEN THE FILE  **
31337C               *********************
31338C
31339      ISTEPN='31'
31340      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'BUGS')
31341     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31342C
31343      IREWIN='ON'
31344      CALL DPOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
31345     1IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
31346      IF(IERRFI.EQ.'YES')GOTO9000
31347C
31348C               ******************************
31349C               **  STEP 41--               **
31350C               **  READ THE FILE.          **
31351C               **  WRITE OUT THE BUGS.     **
31352C               ******************************
31353C
31354      ISTEPN='41'
31355      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'MESS')
31356     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31357C
31358      ANUMLI=0.0
31359      READ(IOUNIT,4111,END=4190)ANUMLI
31360 4111 FORMAT(F10.0)
31361      NUMLIN=INT(ANUMLI+0.5)
31362C
31363      IF(NUMLIN.GT.1)THEN
31364        DO4120I=1,NUMLIN
31365          READ(IOUNIT,4121,END=4190)(ISTRIN(J:J),J=1,80)
31366 4121     FORMAT(80A1)
31367          NMAX=80
31368          CALL DPDB80(ISTRIN,JMAX,NMAX,IBUGS2,ISUBRO,IERROR)
31369          IF(JMAX.GE.1)THEN
31370            WRITE(ICOUT,4122)(ISTRIN(J:J),J=1,JMAX)
31371 4122       FORMAT(5X,80A1)
31372            CALL DPWRST('XXX','BUG ')
31373          ELSE
31374            WRITE(ICOUT,999)
31375            CALL DPWRST('XXX','BUG ')
31376          ENDIF
31377 4120   CONTINUE
31378      ENDIF
31379C
31380 4190 CONTINUE
31381C
31382C               ***********************
31383C               **  STEP 51--        **
31384C               **  CLOSE THE FILE.  **
31385C               ***********************
31386C
31387      ISTEPN='51'
31388      IF(IBUGS2.EQ.'ON'.OR.ISUBRO.EQ.'BUGS')
31389     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31390C
31391      IENDFI='OFF'
31392      IREWIN='ON'
31393      CALL DPCLFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IPROT,ICURST,
31394     1IENDFI,IREWIN,ISUBN0,IERRFI,IBUGS2,ISUBRO,IERROR)
31395C
31396C               ****************
31397C               **  STEP 90-- **
31398C               **  EXIT.     **
31399C               ****************
31400C
31401 9000 CONTINUE
31402      IF(IBUGS2.EQ.'ON' .OR. ISUBRO.EQ.'BUGS')THEN
31403        WRITE(ICOUT,999)
31404        CALL DPWRST('XXX','BUG ')
31405        WRITE(ICOUT,9011)
31406 9011   FORMAT('***** AT THE END       OF DPBUGS--')
31407        CALL DPWRST('XXX','BUG ')
31408        WRITE(ICOUT,9012)IERROR
31409 9012   FORMAT('IERROR = ',A4)
31410        CALL DPWRST('XXX','BUG ')
31411      ENDIF
31412C
31413      RETURN
31414      END
31415      SUBROUTINE DPBWCO(XTEMP1,XTEMP2,MAXNXT,ICASAN,
31416     1                  ICAPSW,IFORSW,IMULT,IREPL,
31417     1                  IBUGA2,IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
31418C
31419C     PURPOSE--GENERATE (SYMMETRIC) CONFIDENCE LIMITS FOR THE MEAN
31420C              FOR PROBABILITY VALUE P = .90, .95, .99, .999, AND .9999.
31421C              BASED ON BIWEIGHT LOCATION AND SCALE ESTIMATES.
31422C     WRITTEN BY--JAMES J. FILLIBEN
31423C                 STATISTICAL ENGINEERING DIVISION
31424C                 INFORMATION TECHNOLOGY LABORATORY
31425C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
31426C                 GAITHERSBURG, MD 20899-8980
31427C                 PHONE--301-975-2855
31428C     REFERENCE--"DATA ANALYSIS AND RGRESSION: A SECOND COURSE IN
31429C                STATISTICS", MOSTELLER AND TUKEY, ADDISON-WESLEY,
31430C                1977.
31431C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
31432C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
31433C     LANGUAGE--ANSI FORTRAN (1977)
31434C     VERSION NUMBER--2001/11
31435C     ORIGINAL VERSION--NOVEMBER  2001.
31436C     UPDATED         --OCTOBER   2003. ADD SUPPORT FOR HTML, LATEX OUTPUT
31437C     UPDATED         --MARCH     2010. USE DPPARS
31438C     UPDATED         --MARCH     2010. USE DPDTA1, DPDTA4 TO GENERATE
31439C                                       HTML, LATEX, RTF FORMAT
31440C     UPDATED         --MARCH     2010. SUPPORT FOR MULTIPLE RESPONSE
31441C                                       VARIABLES AND FOR GROUP-ID
31442C                                       VARIABLES (I.E., REPLICATION
31443C                                       CASE)
31444C     UPDATED         --MARCH     2010. USE DPPAR3 TO EXTRACT EITHER A
31445C                                       RESPONSE VARIABLE OR A MATRIX
31446C                                       NAME
31447C     UPDATED         --AUGUST    2019. ADD CTL999, CTU999
31448C
31449C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
31450C
31451      CHARACTER*4 ICAPSW
31452      CHARACTER*4 IFORSW
31453      CHARACTER*4 IBUGA2
31454      CHARACTER*4 IBUGA3
31455      CHARACTER*4 IBUGQ
31456      CHARACTER*4 ISUBRO
31457      CHARACTER*4 IFOUND
31458      CHARACTER*4 IERROR
31459C
31460      CHARACTER*4 ICASEQ
31461      CHARACTER*4 ICASAN
31462      CHARACTER*4 ICASE
31463      CHARACTER*4 ISUBN1
31464      CHARACTER*4 ISUBN2
31465      CHARACTER*4 ISTEPN
31466      CHARACTER*4 IFLAGU
31467      CHARACTER*4 IREPL
31468      CHARACTER*4 IMULT
31469C
31470      LOGICAL IFRST
31471      LOGICAL ILAST
31472C
31473      CHARACTER*40 INAME
31474      PARAMETER (MAXSPN=30)
31475      CHARACTER*4 IVARN1(MAXSPN)
31476      CHARACTER*4 IVARN2(MAXSPN)
31477      CHARACTER*4 IVARTY(MAXSPN)
31478      CHARACTER*4 IVARID(MAXSPN)
31479      CHARACTER*4 IVARI2(MAXSPN)
31480      REAL PVAR(MAXSPN)
31481      REAL PID(MAXSPN)
31482      INTEGER ILIS(MAXSPN)
31483      INTEGER NRIGHT(MAXSPN)
31484      INTEGER ICOLR(MAXSPN)
31485C
31486C---------------------------------------------------------------------
31487C
31488      INCLUDE 'DPCOPA.INC'
31489C
31490      DIMENSION XTEMP1(*)
31491      DIMENSION XTEMP2(*)
31492      DIMENSION W(MAXOBV)
31493      DIMENSION TEMP1(MAXOBV)
31494      DIMENSION TEMP2(MAXOBV)
31495C
31496      DIMENSION XDESGN(MAXOBV,6)
31497      DIMENSION XIDTEM(MAXOBV)
31498      DIMENSION XIDTE2(MAXOBV)
31499      DIMENSION XIDTE3(MAXOBV)
31500      DIMENSION XIDTE4(MAXOBV)
31501      DIMENSION XIDTE5(MAXOBV)
31502      DIMENSION XIDTE6(MAXOBV)
31503C
31504      INCLUDE 'DPCOZZ.INC'
31505      EQUIVALENCE (GARBAG(IGARB1),XIDTEM(1))
31506      EQUIVALENCE (GARBAG(IGARB2),XIDTE2(1))
31507      EQUIVALENCE (GARBAG(IGARB3),XIDTE3(1))
31508      EQUIVALENCE (GARBAG(IGARB4),XIDTE4(1))
31509      EQUIVALENCE (GARBAG(IGARB5),XIDTE5(1))
31510      EQUIVALENCE (GARBAG(IGARB6),XIDTE6(1))
31511      EQUIVALENCE (GARBAG(IGARB7),TEMP1(1))
31512      EQUIVALENCE (GARBAG(IGARB8),TEMP2(1))
31513      EQUIVALENCE (GARBAG(IGARB9),W(1))
31514      EQUIVALENCE (GARBAG(IGAR10),XDESGN(1,1))
31515C
31516C-----COMMON----------------------------------------------------------
31517C
31518      INCLUDE 'DPCOHK.INC'
31519      INCLUDE 'DPCOSU.INC'
31520      INCLUDE 'DPCODA.INC'
31521      INCLUDE 'DPCOHO.INC'
31522      INCLUDE 'DPCOST.INC'
31523      INCLUDE 'DPCOP2.INC'
31524C
31525C-----START POINT-----------------------------------------------------
31526C
31527      ISUBN1='DPBW'
31528      ISUBN2='CO  '
31529      IFOUND='YES'
31530      IERROR='NO'
31531C
31532      MAXCP1=MAXCOL+1
31533      MAXCP2=MAXCOL+2
31534      MAXCP3=MAXCOL+3
31535      MAXCP4=MAXCOL+4
31536      MAXCP5=MAXCOL+5
31537      MAXCP6=MAXCOL+6
31538C
31539C               *************************************************
31540C               **  TREAT THE BIWEIGHT CONFIDENCE LIMITS CASE  **
31541C               *************************************************
31542C
31543      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')THEN
31544        WRITE(ICOUT,999)
31545  999   FORMAT(1X)
31546        CALL DPWRST('XXX','BUG ')
31547        WRITE(ICOUT,51)
31548   51   FORMAT('***** AT THE BEGINNING OF DPBWCO--')
31549        CALL DPWRST('XXX','BUG ')
31550        WRITE(ICOUT,52)IBUGA2,IBUGA3,IBUGQ,ICASAN,MAXNXT
31551   52   FORMAT('IBUGA2,IBUGA3,IBUGQ,ICASAN,MAXNXT = ',4(A4,2X),I8)
31552        CALL DPWRST('XXX','BUG ')
31553      ENDIF
31554C
31555C               *********************************
31556C               **  STEP 1--                   **
31557C               **  EXTRACT THE VARIABLE LIST  **
31558C               *********************************
31559C
31560      ISTEPN='1'
31561      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')
31562     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31563C
31564      INAME='BIWEIGHT CONFIDENCE LIMITS'
31565      MAXNA=100
31566      MINNVA=1
31567      MAXNVA=100
31568      MINNA=1
31569      IFLAGE=1
31570      IF(IREPL.EQ.'ON')THEN
31571        MAXNVA=7
31572      ELSE
31573        MAXNVA=100
31574        IFLAGE=0
31575      ENDIF
31576      MINN2=2
31577      IFLAGM=1
31578      IFLAGP=0
31579      JMIN=1
31580      JMAX=NUMARG
31581C
31582      CALL DPPARS(IHARG,IHARG2,IARGT,ARG,NUMARG,IANS,IWIDTH,
31583     1            IHNAME,IHNAM2,IUSE,NUMNAM,IN,IVALUE,VALUE,
31584     1            JMIN,JMAX,
31585     1            MINN2,MINNA,MAXNA,MAXSPN,IFLAGE,INAME,
31586     1            IVARN1,IVARN2,IVARTY,PVAR,
31587     1            ILIS,NRIGHT,ICOLR,ISUB,NQ,ILOCQ,NUMVAR,
31588     1            MINNVA,MAXNVA,
31589     1            IFLAGM,IFLAGP,
31590     1            IBUGA3,IBUGQ,ISUBRO,IFOUND,IERROR)
31591      IF(IERROR.EQ.'YES')GOTO9000
31592C
31593      IF(NUMVAR.GT.1 .AND. IREPL.EQ.'OFF')IMULT='ON'
31594C
31595      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')THEN
31596        WRITE(ICOUT,999)
31597        CALL DPWRST('XXX','BUG ')
31598        WRITE(ICOUT,181)
31599  181   FORMAT('***** AFTER CALL DPPARS--')
31600        CALL DPWRST('XXX','BUG ')
31601        WRITE(ICOUT,182)NQ,NUMVAR,IMULT,IREPL
31602  182   FORMAT('NQ,NUMVAR,IMULT,IREPL = ',2I8,2X,A4,2X,A4)
31603        CALL DPWRST('XXX','BUG ')
31604        IF(NUMVAR.GT.0)THEN
31605          DO185I=1,NUMVAR
31606            WRITE(ICOUT,187)I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),
31607     1                      ICOLR(I)
31608  187       FORMAT('I,IVARN1(I),IVARN2(I),ILIS(I),NRIGHT(I),',
31609     1             'ICOLR(I) = ',I8,2X,A4,A4,2X,3I8)
31610            CALL DPWRST('XXX','BUG ')
31611  185     CONTINUE
31612        ENDIF
31613      ENDIF
31614C
31615C               ***********************************************
31616C               **  STEP 2--                                 **
31617C               **  DETERMINE:                               **
31618C               **  1) NUMBER OF REPLICATION VARIABLES (0-6) **
31619C               **  2) NUMBER OF RESPONSE    VARIABLES (>= 1)**
31620C               ***********************************************
31621C
31622      ISTEPN='2'
31623      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')
31624     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31625C
31626      NRESP=0
31627      NREPL=0
31628C
31629      IF(IMULT.EQ.'ON')THEN
31630        NRESP=NUMVAR
31631      ELSEIF(IREPL.EQ.'ON')THEN
31632        NRESP=1
31633        NREPL=NUMVAR-NRESP
31634        IF(NREPL.LT.1 .OR. NREPL.GT.6)THEN
31635          WRITE(ICOUT,999)
31636          CALL DPWRST('XXX','BUG ')
31637          WRITE(ICOUT,101)
31638  101     FORMAT('***** ERROR IN BIWEIGHT CONFIDENCE LIMITS--')
31639          CALL DPWRST('XXX','BUG ')
31640          WRITE(ICOUT,211)
31641  211     FORMAT('      FOR THE REPLICATION CASE, THE NUMBER OF ',
31642     1           'REPLICATION VARIABLES')
31643          CALL DPWRST('XXX','BUG ')
31644          WRITE(ICOUT,213)NREPL
31645  213     FORMAT('      THE NUMBER OF REPLICATION VARIABLES = ',I5)
31646          CALL DPWRST('XXX','BUG ')
31647          IERROR='YES'
31648          GOTO9000
31649        ENDIF
31650      ELSE
31651        NRESP=1
31652      ENDIF
31653C
31654      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')THEN
31655        WRITE(ICOUT,221)NRESP,NREPL
31656  221   FORMAT('NRESP,NREPL = ',2I5)
31657        CALL DPWRST('XXX','BUG ')
31658      ENDIF
31659C
31660C               ******************************************************
31661C               **  STEP 3--                                        **
31662C               **  GENERATE THE CONFIDENCE LIMITS FOR THE VARIOUS  **
31663C               **  CASES                                           **
31664C               ******************************************************
31665C
31666      ISTEPN='3'
31667      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')
31668     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31669C
31670C               *****************************************
31671C               **  STEP 3A--                          **
31672C               **  CASE 1: SINGLE RESPONSE VARIABLE   **
31673C               **          WITH NO REPLICATION        **
31674C               *****************************************
31675C
31676      IF(IMULT.EQ.'OFF' .AND. NREPL.EQ.0)THEN
31677        ISTEPN='3A'
31678        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')
31679     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31680C
31681        PID(1)=CPUMIN
31682        IVARID(1)=IVARN1(1)
31683        IVARI2(1)=IVARN2(1)
31684        IF(ICASAN.EQ.'TWOV')THEN
31685          PID(2)=CPUMIN
31686          IVARID(2)=IVARN1(2)
31687          IVARI2(2)=IVARN2(2)
31688        ENDIF
31689C
31690        ICOL=1
31691        NUMVA2=1
31692        CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
31693     1              INAME,IVARN1,IVARN2,IVARTY,
31694     1              ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
31695     1              MAXCOL,MAXCP1,MAXCP2,MAXCP3,
31696     1              MAXCP4,MAXCP5,MAXCP6,
31697     1              V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
31698     1              Y,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
31699     1              IBUGA3,ISUBRO,IFOUND,IERROR)
31700        IF(IERROR.EQ.'YES')GOTO9000
31701C
31702        IF(ICASAN.EQ.'TWOV')THEN
31703          ICOL=2
31704          NUMVA2=1
31705          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
31706     1                INAME,IVARN1,IVARN2,IVARTY,
31707     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
31708     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
31709     1                MAXCP4,MAXCP5,MAXCP6,
31710     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
31711     1                X,XTEMP1,XTEMP2,NLOCA2,NLOCA3,NLOCA3,ICASE,
31712     1                IBUGA3,ISUBRO,IFOUND,IERROR)
31713          IF(IERROR.EQ.'YES')GOTO9000
31714        ENDIF
31715C
31716C               ******************************************************
31717C               **  STEP 3B--
31718C               **  PREPARE FOR ENTRANCE INTO DPBWC2--
31719C               **  SET THE WEIGHT VECTOR TO UNITY THROUGHOUT.
31720C               ******************************************************
31721C
31722        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')THEN
31723          ISTEPN='3B'
31724          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31725          WRITE(ICOUT,999)
31726          CALL DPWRST('XXX','BUG ')
31727          WRITE(ICOUT,331)
31728  331     FORMAT('***** FROM DPBWCO, AS WE ARE ABOUT TO CALL DPBWC2--')
31729          CALL DPWRST('XXX','BUG ')
31730          WRITE(ICOUT,332)NLOCAL,NLOCA2,MAXN
31731  332     FORMAT('NLOCAL,NLOCA2,MAXN = ',3I8)
31732          CALL DPWRST('XXX','BUG ')
31733          DO335I=1,N
31734            WRITE(ICOUT,336)I,Y(I)
31735  336       FORMAT('I,Y(I) = ',I8,G15.7)
31736            CALL DPWRST('XXX','BUG ')
31737  335     CONTINUE
31738        ENDIF
31739C
31740        CALL DPBWC2(Y,NLOCAL,X,NLOCA2,W,
31741     1              XTEMP1,XTEMP2,MAXNXT,
31742     1              PID,IVARID,IVARI2,NREPL,
31743     1              CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
31744     1              CTL999,CTU999,
31745     1              ICAPSW,ICAPTY,IFORSW,
31746     1              ICASAN,ISUBRO,IBUGA3,IERROR)
31747C
31748        IFLAGU='ON'
31749        IFRST=.FALSE.
31750        ILAST=.FALSE.
31751        CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
31752     1              CTL999,CTU999,
31753     1              IFLAGU,IFRST,ILAST,ICASAN,
31754     1              IBUGA2,IBUGA3,ISUBRO,IERROR)
31755C
31756C               *******************************************
31757C               **  STEP 4A--                            **
31758C               **  CASE 2: MULTIPLE RESPONSE VARIABLES  **
31759C               *******************************************
31760C
31761      ELSEIF(IMULT.EQ.'ON' .AND. ICASAN.EQ.'ONEV')THEN
31762        ISTEPN='4A'
31763        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')
31764     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31765C
31766C       LOOP THROUGH EACH OF THE RESPONSE VARIABLES
31767C
31768        NCURVE=0
31769        DO410IRESP=1,NRESP
31770          NCURVE=NCURVE+1
31771C
31772          IINDX=ICOLR(IRESP)
31773          PID(1)=CPUMIN
31774          IVARID(1)=IVARN1(IRESP)
31775          IVARI2(1)=IVARN2(IRESP)
31776C
31777          IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')THEN
31778            WRITE(ICOUT,999)
31779            CALL DPWRST('XXX','BUG ')
31780            WRITE(ICOUT,411)IRESP,NCURVE
31781  411       FORMAT('IRESP,NCURVE = ',2I5)
31782            CALL DPWRST('XXX','BUG ')
31783          ENDIF
31784C
31785          ICOL=IRESP
31786          NUMVA2=1
31787          CALL DPPAR3(ICOL,IVALUE,IVALU2,IN,MAXN,MAXOBV,
31788     1                INAME,IVARN1,IVARN2,IVARTY,
31789     1                ILIS,NRIGHT,ICOLR,ISUB,NQ,NUMVA2,
31790     1                MAXCOL,MAXCP1,MAXCP2,MAXCP3,
31791     1                MAXCP4,MAXCP5,MAXCP6,
31792     1                V,PRED,RES,YPLOT,XPLOT,X2PLOT,TAGPLO,
31793     1                Y,XTEMP1,XTEMP2,NLOCAL,NLOCA2,NLOCA3,ICASE,
31794     1                IBUGA3,ISUBRO,IFOUND,IERROR)
31795          IF(IERROR.EQ.'YES')GOTO9000
31796C
31797C         *****************************************************
31798C         **  STEP 4B--                                      **
31799C         *****************************************************
31800C
31801          IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'BWCO')THEN
31802            ISTEPN='4B'
31803            CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31804            WRITE(ICOUT,999)
31805            CALL DPWRST('XXX','BUG ')
31806            WRITE(ICOUT,422)
31807  422       FORMAT('***** FROM THE MIDDLE  OF DPBWCO--')
31808            CALL DPWRST('XXX','BUG ')
31809            WRITE(ICOUT,423)ICASAN,NUMVAR,NLOCAL,IRESP
31810  423       FORMAT('ICASAN,NUMVAR,NLOCAL,IRESP = ',A4,3I8)
31811            CALL DPWRST('XXX','BUG ')
31812            IF(NLOCAL.GE.1)THEN
31813              DO425I=1,NLOCAL
31814                WRITE(ICOUT,426)I,Y(I)
31815  426           FORMAT('I,Y(I) = ',I8,F12.5)
31816                CALL DPWRST('XXX','BUG ')
31817  425         CONTINUE
31818            ENDIF
31819          ENDIF
31820C
31821          CALL DPBWC2(Y,NLOCAL,X,NLOCA2,W,
31822     1                XTEMP1,XTEMP2,MAXNXT,
31823     1                PID,IVARID,IVARI2,NREPL,
31824     1                CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
31825     1                CTL999,CTU999,
31826     1                ICAPSW,ICAPTY,IFORSW,
31827     1                ICASAN,ISUBRO,IBUGA3,IERROR)
31828C
31829          IFLAGU='FILE'
31830          IFRST=.FALSE.
31831          ILAST=.FALSE.
31832          IF(IRESP.EQ.1)IFRST=.TRUE.
31833          IF(IRESP.EQ.NRESP)ILAST=.TRUE.
31834          CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
31835     1                CTL999,CTU999,
31836     1                IFLAGU,IFRST,ILAST,ICASAN,
31837     1                IBUGA2,IBUGA3,ISUBRO,IERROR)
31838C
31839  410   CONTINUE
31840C
31841C               ****************************************************
31842C               **  STEP 5A--                                     **
31843C               **  CASE 3: ONE OR MORE REPLICATION VARIABLES.    **
31844C               **          FOR THIS CASE, ALL VARIABLES MUST     **
31845C               **          HAVE THE SAME LENGTH.                 **
31846C               ****************************************************
31847C
31848      ELSEIF(IREPL.EQ.'ON')THEN
31849        ISTEPN='5A'
31850        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')
31851     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31852C
31853        J=0
31854        IMAX=NRIGHT(1)
31855        IF(NQ.LT.NRIGHT(1))IMAX=NQ
31856        DO510I=1,IMAX
31857          IF(ISUB(I).EQ.0)GOTO510
31858          J=J+1
31859C
31860C         RESPONSE VARIABLE IN Y
31861C
31862          ICOLC=1
31863          IJ=MAXN*(ICOLR(ICOLC)-1)+I
31864          IF(ICOLR(ICOLC).LE.MAXCOL)Y(J)=V(IJ)
31865          IF(ICOLR(ICOLC).EQ.MAXCP1)Y(J)=PRED(I)
31866          IF(ICOLR(ICOLC).EQ.MAXCP2)Y(J)=RES(I)
31867          IF(ICOLR(ICOLC).EQ.MAXCP3)Y(J)=YPLOT(I)
31868          IF(ICOLR(ICOLC).EQ.MAXCP4)Y(J)=XPLOT(I)
31869          IF(ICOLR(ICOLC).EQ.MAXCP5)Y(J)=X2PLOT(I)
31870          IF(ICOLR(ICOLC).EQ.MAXCP6)Y(J)=TAGPLO(I)
31871C
31872C         SECOND RESPONSE VARIABLE FOR DIFFERENCE OF MEANS CASE
31873C
31874          IF(ICASAN.EQ.'TWOV')THEN
31875            ICOLC=ICOLC+1
31876            ICOLT=ICOLR(ICOLC)
31877            IJ=MAXN*(ICOLT-1)+I
31878            IF(ICOLT.LE.MAXCOL)X(J)=V(IJ)
31879            IF(ICOLT.EQ.MAXCP1)X(J)=PRED(I)
31880            IF(ICOLT.EQ.MAXCP2)X(J)=RES(I)
31881            IF(ICOLT.EQ.MAXCP3)X(J)=YPLOT(I)
31882            IF(ICOLT.EQ.MAXCP4)X(J)=XPLOT(I)
31883            IF(ICOLT.EQ.MAXCP5)X(J)=X2PLOT(I)
31884            IF(ICOLT.EQ.MAXCP6)X(J)=TAGPLO(I)
31885          ELSE
31886            X(J)=0.0
31887          ENDIF
31888C
31889          IF(NREPL.GE.1)THEN
31890            DO520IR=1,MIN(NREPL,6)
31891              ICOLC=ICOLC+1
31892              ICOLT=ICOLR(ICOLC)
31893              IJ=MAXN*(ICOLT-1)+I
31894              IF(ICOLT.LE.MAXCOL)XDESGN(J,IR)=V(IJ)
31895              IF(ICOLT.EQ.MAXCP1)XDESGN(J,IR)=PRED(I)
31896              IF(ICOLT.EQ.MAXCP2)XDESGN(J,IR)=RES(I)
31897              IF(ICOLT.EQ.MAXCP3)XDESGN(J,IR)=YPLOT(I)
31898              IF(ICOLT.EQ.MAXCP4)XDESGN(J,IR)=XPLOT(I)
31899              IF(ICOLT.EQ.MAXCP5)XDESGN(J,IR)=X2PLOT(I)
31900              IF(ICOLT.EQ.MAXCP6)XDESGN(J,IR)=TAGPLO(I)
31901  520       CONTINUE
31902          ENDIF
31903C
31904  510   CONTINUE
31905        NLOCAL=J
31906C
31907        ISTEPN='5B'
31908        IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'CONF')
31909     1    CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31910C
31911        PID(1)=CPUMIN
31912        IVARID(1)=IVARN1(1)
31913        IVARI2(1)=IVARN2(1)
31914        IADD=1
31915        IF(ICASAN.EQ.'TWOV')THEN
31916          IADD=2
31917          PID(2)=CPUMIN
31918          IVARID(2)=IVARN1(2)
31919          IVARI2(2)=IVARN2(2)
31920        ENDIF
31921        DO540II=1,NREPL
31922          IVARID(II+IADD)=IVARN1(II+IADD)
31923          IVARI2(II+IADD)=IVARN2(II+IADD)
31924  540   CONTINUE
31925C
31926C       *****************************************************
31927C       **  STEP 5C--                                      **
31928C       **                                                 **
31929C       **  FOR THIS CASE, WE NEED TO LOOP THROUGH THE     **
31930C       **  VARIOUS REPLICATIONS.                          **
31931C       *****************************************************
31932C
31933C
31934        IF(IBUGA2.EQ.'ON' .OR. ISUBRO.EQ.'CONF')THEN
31935          ISTEPN='5C'
31936          CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
31937          WRITE(ICOUT,999)
31938          CALL DPWRST('XXX','BUG ')
31939          WRITE(ICOUT,541)
31940  541     FORMAT('***** FROM THE MIDDLE  OF DPCONF--')
31941          CALL DPWRST('XXX','BUG ')
31942          WRITE(ICOUT,542)ICASAN,NUMVAR,NLOCAL,NLOCA2,NREPL
31943  542     FORMAT('ICASAN,NUMVAR,NLOCAL,NLOCA2,NREPL = ',A4,2X,4I8)
31944          CALL DPWRST('XXX','BUG ')
31945          IF(NLOCAL.GE.1)THEN
31946            DO545I=1,NLOCAL
31947              WRITE(ICOUT,546)I,Y(I),X(I),XDESGN(I,1),XDESGN(I,2)
31948  546         FORMAT('I,Y(I),X(I),XDESGN(I,1),XDESGN(I,2) = ',
31949     1               I8,4F12.5)
31950              CALL DPWRST('XXX','BUG ')
31951  545       CONTINUE
31952          ENDIF
31953        ENDIF
31954C
31955C       *****************************************************
31956C       **  STEP 5C--                                      **
31957C       **  FIND THE DISTINCT VALUES IN EACH OF THE        **
31958C       **  REPLICATION VARIABLES.                         **
31959C       *****************************************************
31960C
31961        CALL DPPP5(XDESGN(1,1),XDESGN(1,2),XDESGN(1,3),
31962     1             XDESGN(1,4),XDESGN(1,5),XDESGN(1,6),
31963     1             NREPL,NLOCAL,MAXOBV,
31964     1             XIDTEM,XIDTE2,XIDTE3,XIDTE4,XIDTE5,XIDTE6,
31965     1             XTEMP1,XTEMP2,
31966     1             NUMSE1,NUMSE2,NUMSE3,NUMSE4,NUMSE5,NUMSE6,
31967     1             IBUGA3,ISUBRO,IERROR)
31968C
31969C       *****************************************************
31970C       **  STEP 5D--                                      **
31971C       **  NOW LOOP THROUGH THE VARIOUS REPLICATIONS      **
31972C       *****************************************************
31973C
31974        NPLOTP=0
31975        NCURVE=0
31976        IF(NREPL.EQ.1)THEN
31977          J=0
31978          DO1110ISET1=1,NUMSE1
31979            K=0
31980            PID(IADD+1)=XIDTEM(ISET1)
31981            DO1130I=1,NLOCAL
31982              IF(XIDTEM(ISET1).EQ.XDESGN(I,1))THEN
31983                K=K+1
31984                TEMP1(K)=Y(I)
31985                TEMP2(K)=X(I)
31986              ENDIF
31987 1130       CONTINUE
31988            NTEMP=K
31989            NCURVE=NCURVE+1
31990            IF(NTEMP.GT.0)THEN
31991              CALL DPBWC2(TEMP1,NTEMP,TEMP2,NTEMP,W,
31992     1                    XTEMP1,XTEMP2,MAXNXT,
31993     1                    PID,IVARID,IVARI2,NREPL,
31994     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
31995     1                    CTL999,CTU999,
31996     1                    ICAPSW,ICAPTY,IFORSW,
31997     1                    ICASAN,ISUBRO,IBUGA3,IERROR)
31998            ENDIF
31999C
32000            IFLAGU='FILE'
32001            IFRST=.FALSE.
32002            ILAST=.FALSE.
32003            IF(NCURVE.EQ.1)IFRST=.TRUE.
32004            IF(NCURVE.EQ.NUMSE1)ILAST=.TRUE.
32005            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32006     1                  CTL999,CTU999,
32007     1                  IFLAGU,IFRST,ILAST,ICASAN,
32008     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
32009 1110     CONTINUE
32010        ELSEIF(NREPL.EQ.2)THEN
32011          J=0
32012          NTOT=NUMSE1*NUMSE2
32013          DO1210ISET1=1,NUMSE1
32014          DO1220ISET2=1,NUMSE2
32015            K=0
32016            PID(1+IADD)=XIDTEM(ISET1)
32017            PID(2+IADD)=XIDTE2(ISET2)
32018            DO1290I=1,NLOCAL
32019              IF(
32020     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
32021     1           XIDTE2(ISET2).EQ.XDESGN(I,2)
32022     1          )THEN
32023                K=K+1
32024                TEMP1(K)=Y(I)
32025                TEMP2(K)=X(I)
32026              ENDIF
32027 1290       CONTINUE
32028            NTEMP=K
32029            NCURVE=NCURVE+1
32030            NPLOT1=NPLOTP
32031            IF(NTEMP.GT.0)THEN
32032              CALL DPBWC2(TEMP1,NTEMP,TEMP2,NTEMP,W,
32033     1                    XTEMP1,XTEMP2,MAXNXT,
32034     1                    PID,IVARID,IVARI2,NREPL,
32035     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32036     1                    CTL999,CTU999,
32037     1                    ICAPSW,ICAPTY,IFORSW,
32038     1                    ICASAN,ISUBRO,IBUGA3,IERROR)
32039            ENDIF
32040            NPLOT2=NPLOTP
32041            IFLAGU='FILE'
32042            IFRST=.FALSE.
32043            ILAST=.FALSE.
32044            IF(NCURVE.EQ.1)IFRST=.TRUE.
32045            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
32046            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32047     1                  CTL999,CTU999,
32048     1                  IFLAGU,IFRST,ILAST,ICASAN,
32049     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
32050 1220     CONTINUE
32051 1210     CONTINUE
32052        ELSEIF(NREPL.EQ.3)THEN
32053          J=0
32054          NTOT=NUMSE1*NUMSE2*NUMSE3
32055          DO1310ISET1=1,NUMSE1
32056          DO1320ISET2=1,NUMSE2
32057          DO1330ISET3=1,NUMSE3
32058            K=0
32059            PID(1+IADD)=XIDTEM(ISET1)
32060            PID(2+IADD)=XIDTE2(ISET2)
32061            PID(3+IADD)=XIDTE3(ISET3)
32062            DO1390I=1,NLOCAL
32063              IF(
32064     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
32065     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
32066     1           XIDTE3(ISET3).EQ.XDESGN(I,3)
32067     1          )THEN
32068                K=K+1
32069                TEMP1(K)=Y(I)
32070                TEMP2(K)=X(I)
32071              ENDIF
32072 1390       CONTINUE
32073            NTEMP=K
32074            NCURVE=NCURVE+1
32075            IF(NTEMP.GT.0)THEN
32076              CALL DPBWC2(TEMP1,NTEMP,TEMP2,NTEMP,W,
32077     1                    XTEMP1,XTEMP2,MAXNXT,
32078     1                    PID,IVARID,IVARI2,NREPL,
32079     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32080     1                    CTL999,CTU999,
32081     1                    ICAPSW,ICAPTY,IFORSW,
32082     1                    ICASAN,ISUBRO,IBUGA3,IERROR)
32083            ENDIF
32084            IFLAGU='FILE'
32085            IFRST=.FALSE.
32086            ILAST=.FALSE.
32087            IF(NCURVE.EQ.1)IFRST=.TRUE.
32088            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
32089            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32090     1                  CTL999,CTU999,
32091     1                  IFLAGU,IFRST,ILAST,ICASAN,
32092     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
32093 1330     CONTINUE
32094 1320     CONTINUE
32095 1310     CONTINUE
32096        ELSEIF(NREPL.EQ.4)THEN
32097          J=0
32098          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4
32099          DO1410ISET1=1,NUMSE1
32100          DO1420ISET2=1,NUMSE2
32101          DO1430ISET3=1,NUMSE3
32102          DO1440ISET4=1,NUMSE4
32103            K=0
32104            PID(1+IADD)=XIDTEM(ISET1)
32105            PID(2+IADD)=XIDTE2(ISET2)
32106            PID(3+IADD)=XIDTE3(ISET3)
32107            PID(4+IADD)=XIDTE4(ISET4)
32108            DO1490I=1,NLOCAL
32109              IF(
32110     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
32111     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
32112     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
32113     1           XIDTE4(ISET4).EQ.XDESGN(I,4)
32114     1          )THEN
32115                K=K+1
32116                TEMP1(K)=Y(I)
32117                TEMP2(K)=X(I)
32118              ENDIF
32119 1490       CONTINUE
32120            NTEMP=K
32121            NCURVE=NCURVE+1
32122            IF(NTEMP.GT.0)THEN
32123              CALL DPBWC2(TEMP1,NTEMP,TEMP2,NTEMP,W,
32124     1                    XTEMP1,XTEMP2,MAXNXT,
32125     1                    PID,IVARID,IVARI2,NREPL,
32126     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32127     1                    CTL999,CTU999,
32128     1                    ICAPSW,ICAPTY,IFORSW,
32129     1                    ICASAN,ISUBRO,IBUGA3,IERROR)
32130            ENDIF
32131            IFLAGU='FILE'
32132            IFRST=.FALSE.
32133            ILAST=.FALSE.
32134            IF(NCURVE.EQ.1)IFRST=.TRUE.
32135            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
32136            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32137     1                  CTL999,CTU999,
32138     1                  IFLAGU,IFRST,ILAST,ICASAN,
32139     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
32140 1440     CONTINUE
32141 1430     CONTINUE
32142 1420     CONTINUE
32143 1410     CONTINUE
32144        ELSEIF(NREPL.EQ.5)THEN
32145          J=0
32146          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5
32147          DO1510ISET1=1,NUMSE1
32148          DO1520ISET2=1,NUMSE2
32149          DO1530ISET3=1,NUMSE3
32150          DO1540ISET4=1,NUMSE4
32151          DO1550ISET5=1,NUMSE5
32152            K=0
32153            PID(1+IADD)=XIDTEM(ISET1)
32154            PID(2+IADD)=XIDTE2(ISET2)
32155            PID(3+IADD)=XIDTE3(ISET3)
32156            PID(4+IADD)=XIDTE4(ISET4)
32157            PID(5+IADD)=XIDTE5(ISET4)
32158            DO1590I=1,NLOCAL
32159              IF(
32160     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
32161     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
32162     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
32163     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
32164     1           XIDTE5(ISET5).EQ.XDESGN(I,5)
32165     1          )THEN
32166                K=K+1
32167                TEMP1(K)=Y(I)
32168                TEMP2(K)=X(I)
32169              ENDIF
32170 1590       CONTINUE
32171            NTEMP=K
32172            NCURVE=NCURVE+1
32173            IF(NTEMP.GT.0)THEN
32174              CALL DPBWC2(TEMP1,NTEMP,TEMP2,NTEMP,W,
32175     1                    XTEMP1,XTEMP2,MAXNXT,
32176     1                    PID,IVARID,IVARI2,NREPL,
32177     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32178     1                    CTL999,CTU999,
32179     1                    ICAPSW,ICAPTY,IFORSW,
32180     1                    ICASAN,ISUBRO,IBUGA3,IERROR)
32181            ENDIF
32182            IFLAGU='FILE'
32183            IFRST=.FALSE.
32184            ILAST=.FALSE.
32185            IF(NCURVE.EQ.1)IFRST=.TRUE.
32186            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
32187            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32188     1                  CTL999,CTU999,
32189     1                  IFLAGU,IFRST,ILAST,ICASAN,
32190     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
32191 1550     CONTINUE
32192 1540     CONTINUE
32193 1530     CONTINUE
32194 1520     CONTINUE
32195 1510     CONTINUE
32196        ELSEIF(NREPL.EQ.6)THEN
32197          J=0
32198          NTOT=NUMSE1*NUMSE2*NUMSE3*NUMSE4*NUMSE5*NUMSE6
32199          DO1610ISET1=1,NUMSE1
32200          DO1620ISET2=1,NUMSE2
32201          DO1630ISET3=1,NUMSE3
32202          DO1640ISET4=1,NUMSE4
32203          DO1650ISET5=1,NUMSE5
32204          DO1660ISET6=1,NUMSE6
32205            K=0
32206            PID(1+IADD)=XIDTEM(ISET1)
32207            PID(2+IADD)=XIDTE2(ISET2)
32208            PID(3+IADD)=XIDTE3(ISET3)
32209            PID(4+IADD)=XIDTE4(ISET4)
32210            PID(5+IADD)=XIDTE5(ISET4)
32211            PID(6+IADD)=XIDTE6(ISET4)
32212            DO1690I=1,NLOCAL
32213              IF(
32214     1           XIDTEM(ISET1).EQ.XDESGN(I,1) .AND.
32215     1           XIDTE2(ISET2).EQ.XDESGN(I,2) .AND.
32216     1           XIDTE3(ISET3).EQ.XDESGN(I,3) .AND.
32217     1           XIDTE4(ISET4).EQ.XDESGN(I,4) .AND.
32218     1           XIDTE5(ISET5).EQ.XDESGN(I,5) .AND.
32219     1           XIDTE6(ISET6).EQ.XDESGN(I,6)
32220     1          )THEN
32221                K=K+1
32222                TEMP1(K)=Y(I)
32223                TEMP2(K)=X(I)
32224              ENDIF
32225 1690       CONTINUE
32226            NTEMP=K
32227            NCURVE=NCURVE+1
32228            IF(NTEMP.GT.0)THEN
32229              CALL DPBWC2(TEMP1,NTEMP,TEMP2,NTEMP,W,
32230     1                    XTEMP1,XTEMP2,MAXNXT,
32231     1                    PID,IVARID,IVARI2,NREPL,
32232     1                    CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32233     1                    CTL999,CTU999,
32234     1                    ICAPSW,ICAPTY,IFORSW,
32235     1                    ICASAN,ISUBRO,IBUGA3,IERROR)
32236            ENDIF
32237            IFLAGU='FILE'
32238            IFRST=.FALSE.
32239            ILAST=.FALSE.
32240            IF(NCURVE.EQ.1)IFRST=.TRUE.
32241            IF(NCURVE.EQ.NTOT)ILAST=.TRUE.
32242            CALL DPCNF3(CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32243     1                  CTL999,CTU999,
32244     1                  IFLAGU,IFRST,ILAST,ICASAN,
32245     1                  IBUGA2,IBUGA3,ISUBRO,IERROR)
32246 1660     CONTINUE
32247 1650     CONTINUE
32248 1640     CONTINUE
32249 1630     CONTINUE
32250 1620     CONTINUE
32251 1610     CONTINUE
32252        ENDIF
32253C
32254      ENDIF
32255C
32256C               *****************
32257C               **  STEP 90--  **
32258C               **  EXIT       **
32259C               *****************
32260C
32261 9000 CONTINUE
32262      IF(IBUGA2.EQ.'ON'.OR.ISUBRO.EQ.'BWCO')THEN
32263        WRITE(ICOUT,999)
32264        CALL DPWRST('XXX','BUG ')
32265        WRITE(ICOUT,9011)
32266 9011   FORMAT('***** AT THE END       OF DPBWCO--')
32267        CALL DPWRST('XXX','BUG ')
32268        WRITE(ICOUT,9014)ICASEQ,NRIGHT(1),NS
32269 9014   FORMAT('ICASEQ,NRIGHT(1),NS = ',A4,2X,2I8)
32270        CALL DPWRST('XXX','BUG ')
32271        WRITE(ICOUT,9016)IFOUND,IERROR
32272 9016   FORMAT('IFOUND,IERROR = ',A4,2X,A4)
32273        CALL DPWRST('XXX','BUG ')
32274      ENDIF
32275C
32276      RETURN
32277      END
32278      SUBROUTINE DPBWC2(Y,N,X,N2,W,
32279     1                  XTEMP1,XTEMP2,MAXNXT,
32280     1                  PID,IVARID,IVARI2,NREPL,
32281     1                  CUTL90,CUTU90,CUTL95,CUTU95,CUTL99,CUTU99,
32282     1                  CTL999,CTU999,
32283     1                  ICAPSW,ICAPTY,IFORSW,
32284     1                  ICASAN,ISUBRO,IBUGA3,IERROR)
32285C
32286C     PURPOSE--THIS ROUTINE GENERATES BIWEIGHT CONFIDENCE LIMITS
32287C              FOR THE DATA IN THE INPUT VECTOR Y.
32288C     NOTE--ASSUMPTION--MODEL IS   RESPONSE = CONSTANT + ERROR.
32289C     NOTE--WEIGHTS AND TWO VARIABLE (=DIFFERENCE OF TWO MEANS)
32290C           NOT YET SUPPORTED.  ARGUMENTS PASSED FOR POSSIBLE
32291C           FUTURE IMPLEMENTATION.
32292C     INPUT  ARGUMENTS--Y      = THE SINGLE PRECISION VECTOR
32293C                                OF OBSERVATIONS
32294C                       N      = THE INTEGER NUMBER OF
32295C                                OBSERVATIONS IN THE VECTOR Y.
32296C     WRITTEN BY--ALAN HECKERT
32297C                 STATISTICAL ENGINEERING DIVISION
32298C                 INFORMATION TECHNOLOGY LABORATORY
32299C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32300C                 GAITHERSBURG, MD 20899-8980
32301C                 PHONE--301-975-2899
32302C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32303C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
32304C     LANGUAGE--ANSI FORTRAN (1977)
32305C     VERSION NUMBER--2001/11
32306C     ORIGINAL VERSION--NOVEMBER  2001.
32307C     UPDATED         --OCTOBER   2003. ADD SUPPORT FOR HTML, LATEX
32308C                                       OUTPUT
32309C     UPDATED         --OCTOBER   2006. CALL LIST TO TPPF
32310C     UPDATED         --MARCH     2010. USE DPDTA2 AND DPDTA4 TO
32311C                                       GENERATE OUTPUT (ADDS RTF
32312C                                       SUPPORT)
32313C     UPDATED         --MARCH     2010. SOME MODIFICATIONS TO THE
32314C                                       OUTPUT (AESTHETIC, NOT
32315C                                       SUBSTANTIVE)
32316C     UPDATED         --AUGUST    2019. ADD CTL999, CTU999
32317C
32318C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES-------------------
32319C
32320      CHARACTER*4 IBUGA3
32321      CHARACTER*4 ISUBRO
32322      CHARACTER*4 IERROR
32323C
32324      CHARACTER*4 IWRITE
32325      CHARACTER*4 ICASAN
32326      CHARACTER*4 ICASA2
32327      CHARACTER*4 ICAPSW
32328      CHARACTER*4 ICAPTY
32329      CHARACTER*4 IFORSW
32330C
32331      CHARACTER*4 IVARID(*)
32332      CHARACTER*4 IVARI2(*)
32333C
32334C
32335      CHARACTER*4 ISUBN1
32336      CHARACTER*4 ISUBN2
32337      CHARACTER*4 ISTEPN
32338C
32339C---------------------------------------------------------------------
32340C
32341      DIMENSION Y(*)
32342      DIMENSION X(*)
32343      DIMENSION W(*)
32344      DIMENSION XTEMP1(*)
32345      DIMENSION XTEMP2(*)
32346      DIMENSION PID(*)
32347C
32348      PARAMETER (NCONF=8)
32349C
32350      DIMENSION CONF(NCONF)
32351      DIMENSION T(NCONF)
32352      DIMENSION TSDM(NCONF)
32353      DIMENSION ALOWER(NCONF)
32354      DIMENSION AUPPER(NCONF)
32355C
32356      PARAMETER(NUMCLI=5)
32357      PARAMETER(MAXLIN=2)
32358      PARAMETER (MAXROW=20)
32359      CHARACTER*60 ITITLE
32360      CHARACTER*60 ITITLZ
32361      CHARACTER*60 ITEXT(MAXROW)
32362      REAL         AVALUE(MAXROW)
32363      INTEGER      NCTEXT(MAXROW)
32364      INTEGER      IDIGIT(MAXROW)
32365      INTEGER      NTOT(MAXROW)
32366      LOGICAL IFRST
32367      LOGICAL ILAST
32368C
32369C---------------------------------------------------------------------
32370C
32371      INCLUDE 'DPCOP2.INC'
32372C
32373C-----START POINT-----------------------------------------------------
32374C
32375      IF(ICASAN.EQ.'TWOV')GOTO9000
32376C
32377      ISUBN1='DPBW'
32378      ISUBN2='C2  '
32379      IERROR='NO'
32380      IWRITE='OFF'
32381      ICASA2='BWCO'
32382C
32383      NUMDIG=7
32384      IF(IFORSW.EQ.'1')NUMDIG=1
32385      IF(IFORSW.EQ.'2')NUMDIG=2
32386      IF(IFORSW.EQ.'3')NUMDIG=3
32387      IF(IFORSW.EQ.'4')NUMDIG=4
32388      IF(IFORSW.EQ.'5')NUMDIG=5
32389      IF(IFORSW.EQ.'6')NUMDIG=6
32390      IF(IFORSW.EQ.'7')NUMDIG=7
32391      IF(IFORSW.EQ.'8')NUMDIG=8
32392      IF(IFORSW.EQ.'9')NUMDIG=9
32393      IF(IFORSW.EQ.'0')NUMDIG=0
32394      IF(IFORSW.EQ.'E')NUMDIG=-2
32395      IF(IFORSW.EQ.'-2')NUMDIG=-2
32396      IF(IFORSW.EQ.'-3')NUMDIG=-3
32397      IF(IFORSW.EQ.'-4')NUMDIG=-4
32398      IF(IFORSW.EQ.'-5')NUMDIG=-5
32399      IF(IFORSW.EQ.'-6')NUMDIG=-6
32400      IF(IFORSW.EQ.'-7')NUMDIG=-7
32401      IF(IFORSW.EQ.'-8')NUMDIG=-8
32402      IF(IFORSW.EQ.'-9')NUMDIG=-9
32403C
32404      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2')THEN
32405        ISTEPN='1'
32406        CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32407        WRITE(ICOUT,999)
32408  999   FORMAT(1X)
32409        CALL DPWRST('XXX','WRIT')
32410        WRITE(ICOUT,51)
32411   51   FORMAT('**** AT THE BEGINNING OF DPBWC2--')
32412        CALL DPWRST('XXX','WRIT')
32413        WRITE(ICOUT,52)N,N2,NUMDIG,IBUGA3,ICASAN
32414   52   FORMAT('N,N2,NUMDIG,IBUGA3,ICASAN = ',3I8,2X,A4,2X,A4)
32415        CALL DPWRST('XXX','WRIT')
32416        DO56I=1,N
32417          WRITE(ICOUT,57)I,Y(I),W(I),X(I)
32418   57     FORMAT('I,Y(I),W(I),X(I) = ',I8,3G15.7)
32419          CALL DPWRST('XXX','WRIT')
32420   56   CONTINUE
32421      ENDIF
32422C
32423C
32424C               ********************************************
32425C               **  STEP 1--                              **
32426C               **  CHECK THE INPUT ARGUMENTS FOR ERRORS  **
32427C               ********************************************
32428C
32429C
32430      IF(N.LE.1)THEN
32431        WRITE(ICOUT,999)
32432        CALL DPWRST('XXX','WRIT')
32433        WRITE(ICOUT,111)
32434  111   FORMAT('***** ERROR IN BIWEIGHT CONFIDENCE LIMITS--')
32435        CALL DPWRST('XXX','WRIT')
32436        WRITE(ICOUT,112)
32437  112   FORMAT('      THE NUMBER OF OBSERVATIONS IN THE RESPONSE ',
32438     1         'VARIABLE IS LESS THAN TWO.')
32439        CALL DPWRST('XXX','WRIT')
32440        WRITE(ICOUT,113)N
32441  113   FORMAT('SAMPLE SIZE = ',I8)
32442        CALL DPWRST('XXX','WRIT')
32443        IERROR='YES'
32444        GOTO9000
32445      ENDIF
32446C
32447      HOLD=Y(1)
32448      DO135I=2,N
32449      IF(Y(I).NE.HOLD)GOTO139
32450  135 CONTINUE
32451      WRITE(ICOUT,999)
32452      CALL DPWRST('XXX','WRIT')
32453      WRITE(ICOUT,111)
32454      CALL DPWRST('XXX','WRIT')
32455      WRITE(ICOUT,131)HOLD
32456  131 FORMAT('      THE RESPONSE VARIABLE HAS ALL ELEMENTS = ',G15.7)
32457      CALL DPWRST('XXX','WRIT')
32458      GOTO9000
32459  139 CONTINUE
32460C
32461C               ***************************************************
32462C               **  STEP 3--                                     **
32463C               **  COMPUTE THE BIWEIGHT LOCATION ESTIMATE       **
32464C               **  COMPUTE THE BIWEIGHT SCALE ESTIMATE          **
32465C               **  COMPUTE THE SQRT(BIWEIGHT SCALE/N).          **
32466C               ***************************************************
32467C
32468C
32469      ISTEPN='3'
32470      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2')
32471     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32472C
32473      CALL BIWLOC(Y,N,IWRITE,XTEMP1,XTEMP2,MAXNXT,YBW,IBUGA3,IERROR)
32474      CALL BIWSCA(Y,N,IWRITE,XTEMP1,XTEMP2,MAXNXT,YBSC,IBUGA3,IERROR)
32475      AN1=N
32476      YSTERR=SQRT(YBSC/AN1)
32477C
32478      V=0.7*(AN1-1.0)
32479      IV=INT(V+0.5)
32480C
32481C               ***************************************
32482C               **  STEP 4--                         **
32483C               **  COMPUTE CONFIDENCE LIMITS        **
32484C               **  FOR VARIOUS PROBABILITY VALUES.  **
32485C               ***************************************
32486C
32487      ISTEPN='4'
32488      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2')
32489     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32490C
32491      CONF(1)=50.0
32492      CONF(2)=75.0
32493      CONF(3)=90.0
32494      CONF(4)=95.0
32495      CONF(5)=99.0
32496      CONF(6)=99.9
32497      CONF(7)=99.99
32498      CONF(8)=99.999
32499C
32500      DO1400I=1,8
32501        PCONF=CONF(I)/100.0
32502        CDF=0.5+PCONF/2.0
32503        CALL TPPF(CDF,REAL(IV),T(I))
32504        TSDM(I)=T(I)*YSTERR
32505        ALOWER(I)=YBW-TSDM(I)
32506        AUPPER(I)=YBw+TSDM(I)
32507 1400 CONTINUE
32508      CUTL90=ALOWER(3)
32509      CUTU90=AUPPER(3)
32510      CUTL95=ALOWER(4)
32511      CUTU95=AUPPER(4)
32512      CUTL99=ALOWER(5)
32513      CUTU99=AUPPER(5)
32514      CTL999=ALOWER(6)
32515      CTU999=AUPPER(6)
32516C
32517C     ADD A FUDGE FACTOR SO THAT CONFIDENCE LEVEL WILL
32518C     BE PRINTED CORRECTLY TO 3 DECIMAL PLACES.
32519C
32520      CONF(1)=50.0001
32521      CONF(2)=75.0001
32522      CONF(3)=90.0001
32523      CONF(4)=95.0001
32524      CONF(5)=99.0001
32525      CONF(6)=99.9001
32526      CONF(7)=99.9901
32527      CONF(8)=99.9991
32528C
32529C               ****************************
32530C               **  STEP 7--              **
32531C               **  WRITE EVERYTHING OUT  **
32532C               ****************************
32533C
32534      ISTEPN='7'
32535      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2')
32536     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32537C
32538      IF(IPRINT.EQ.'OFF')GOTO9000
32539C
32540      ITITLE='Confidence Limits for Biweight Location'
32541      NCTITL=39
32542      ITITLZ='(Two-Sided)'
32543      NCTITZ=11
32544C
32545      ICNT=1
32546      ITEXT(ICNT)=' '
32547      NCTEXT(ICNT)=0
32548      AVALUE(ICNT)=0.0
32549      IDIGIT(ICNT)=-1
32550      ICNT=ICNT+1
32551      ITEXT(ICNT)='Response Variable: '
32552      WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(1)(1:4)
32553      WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(1)(1:4)
32554      NCTEXT(ICNT)=27
32555      AVALUE(ICNT)=0.0
32556      IDIGIT(ICNT)=-1
32557C
32558      IF(NREPL.GT.0)THEN
32559        NRESP=1
32560        DO4101I=1,NREPL
32561          ICNT=ICNT+1
32562          ITEMP=I+NRESP
32563          ITEXT(ICNT)='Factor Variable  : '
32564          WRITE(ITEXT(ICNT)(17:17),'(I1)')I
32565          WRITE(ITEXT(ICNT)(20:23),'(A4)')IVARID(ITEMP)(1:4)
32566          WRITE(ITEXT(ICNT)(24:27),'(A4)')IVARI2(ITEMP)(1:4)
32567          NCTEXT(ICNT)=27
32568          AVALUE(ICNT)=PID(ITEMP)
32569          IDIGIT(ICNT)=NUMDIG
32570 4101   CONTINUE
32571      ENDIF
32572C
32573      ICNT=ICNT+1
32574      ITEXT(ICNT)=' '
32575      NCTEXT(ICNT)=1
32576      AVALUE(ICNT)=0.0
32577      IDIGIT(ICNT)=-1
32578C
32579      ICNT=ICNT+1
32580      ITEXT(ICNT)='Summary Statistics:'
32581      NCTEXT(ICNT)=19
32582      AVALUE(ICNT)=0.0
32583      IDIGIT(ICNT)=-1
32584      ICNT=ICNT+1
32585      ITEXT(ICNT)='Number of Observations:'
32586      NCTEXT(ICNT)=23
32587      AVALUE(ICNT)=REAL(N)
32588      IDIGIT(ICNT)=0
32589      ICNT=ICNT+1
32590      ITEXT(ICNT)='Sample Biweight Location:'
32591      NCTEXT(ICNT)=25
32592      AVALUE(ICNT)=YBW
32593      IDIGIT(ICNT)=NUMDIG
32594      ICNT=ICNT+1
32595      ITEXT(ICNT)='Sample Biweight Scale:'
32596      NCTEXT(ICNT)=21
32597      AVALUE(ICNT)=YBSC
32598      IDIGIT(ICNT)=NUMDIG
32599      ICNT=ICNT+1
32600      ITEXT(ICNT)='Standard Error:'
32601      NCTEXT(ICNT)=15
32602      AVALUE(ICNT)=YSTERR
32603      IDIGIT(ICNT)=NUMDIG
32604      ICNT=ICNT+1
32605      ITEXT(ICNT)='Degrees of Freedom:'
32606      NCTEXT(ICNT)=19
32607      AVALUE(ICNT)=REAL(IV)
32608      IDIGIT(ICNT)=NUMDIG
32609      ICNT=ICNT+1
32610      ITEXT(ICNT)=' '
32611      NCTEXT(ICNT)=1
32612      AVALUE(ICNT)=0.0
32613      IDIGIT(ICNT)=-1
32614C
32615      NUMROW=ICNT
32616      DO4210I=1,NUMROW
32617        NTOT(I)=15
32618 4210 CONTINUE
32619C
32620      IFRST=.TRUE.
32621      ILAST=.TRUE.
32622C
32623      ISTEPN='5A'
32624      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2')
32625     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32626C
32627      CALL DPDTA1(ITITLE,NCTITL,ITITLZ,NCTITZ,ITEXT,NCTEXT,
32628     1            AVALUE,IDIGIT,
32629     1            NTOT,NUMROW,
32630     1            ICAPSW,ICAPTY,ILAST,IFRST,
32631     1            ISUBRO,IBUGA3,IERROR)
32632C
32633      ISTEPN='5B'
32634      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'CNF2')
32635     1CALL TRACE2(ISTEPN,ISUBN1,ISUBN2)
32636C
32637      CALL DPDT11(CONF,T,TSDM,ALOWER,AUPPER,
32638     1            ICASA2,ICAPSW,ICAPTY,NUMDIG,
32639     1            ISUBRO,IBUGA3,IERROR)
32640C
32641C               *****************
32642C               **  STEP 90--  **
32643C               **  EXIT       **
32644C               *****************
32645C
32646 9000 CONTINUE
32647      IF(IBUGA3.EQ.'ON'.OR.ISUBRO.EQ.'BWC2')THEN
32648        WRITE(ICOUT,999)
32649        CALL DPWRST('XXX','WRIT')
32650        WRITE(ICOUT,9011)
32651 9011   FORMAT('***** AT THE END       OF DPBWC2--')
32652        CALL DPWRST('XXX','WRIT')
32653        WRITE(ICOUT,9012)N,IBUGA3,IERROR
32654 9012   FORMAT('N,IBUGA3,IERROR = ',I8,2X,A4,2X,A4)
32655        CALL DPWRST('XXX','WRIT')
32656        WRITE(ICOUT,9013)YBW,YBSC,YSTERR,IV
32657 9013   FORMAT('YBW,YBSC,YSTERR,IV = ',3G15.7,I8)
32658        CALL DPWRST('XXX','WRIT')
32659      ENDIF
32660C
32661      RETURN
32662      END
32663      SUBROUTINE DPBX(IHARG,IARGT,ARG,NUMARG,
32664     1                PXSTAR,PYSTAR,PXEND,PYEND,
32665     1                IBOBPA,IBOBCO,PBOPTH,
32666     1                AREGBA,IREBLI,IREBCO,PREBTH,
32667     1                IREFSW,IREFCO,
32668     1                IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
32669     1                PBOSHE,PBOSWI,
32670     1                PTEXHE,PTEXWI,PTEXVG,PTEXHG,
32671     1                IGRASW,IDIASW,
32672     1                PGRAXF,PGRAYF,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
32673     1                PDIAHE,PDIAWI,PDIAVG,PDIAHG,
32674     1                NUMDEV,IDMANU,IDMODE,IDMOD2,IDMOD3,
32675     1                IDPOWE,IDCONT,IDCOLO,IDNVPP,IDNHPP,IDUNIT,
32676     1                IDNVOF,IDNHOF,IDFONT,UNITSW,PDSCAL,
32677     1                IBUGD2,IFOUND,IERROR)
32678C
32679C     PURPOSE--DRAW ONE OR MORE BOXES (DEPENDING ON HOW MANY NUMBERS ARE
32680C              PROVIDED).  THE COORDINATES ARE IN STANDARDIZED UNITS OF
32681C              0 TO 100.
32682C     NOTE--THE INPUT COORDINATES DEFINE THE OPPOSING CORNERS OF THE BOX.
32683C     NOTE-THE USUAL INPUT NUMBER OF COORDINATES IS 2 AND THEREFORE THE
32684C          USUAL INPUT NUMBER OF NUMBERS IS 2*2 = 4.
32685C     NOTE--IF 2 NUMBERS ARE PROVIDED, THEN THE DRAWN BOX WILL GO FROM
32686C           THE LAST CURSOR POSITION TO THE (X,Y) POINT (EITHER ABSOLUTE
32687C           OR RELATIVE) AS DEFINED BY THE 2 NUMBERS.
32688C     NOTE--IF 4 NUMBERS ARE PROVIDED, THEN THE DRAWN BOX WILL GO FROM
32689C           THE ABSOLUTE (X,Y) POSITION AS DEFINED BY THE FIRST 2 NUMBERS
32690C           TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE) AS DEFINED
32691C           BY THE THIRD AND FOURTH NUMBERS.
32692C     NOTE--IF 6 NUMBERS ARE PROVIDED, THEN THE DRAWN BOX WILL GO FROM
32693C           THE (X,Y) POSITION AS RESULTING FROM THE THIRD AND FOURTH
32694C           NUMBERS TO THE (X,Y) POINT (EITHER ABSOLUTE OR RELATIVE)
32695C           AS DEFINED BY THE FIFTH AND SIXTH NUMBERS.
32696C     NOTE--AND SO FORTH FOR 8, 10, 12, ... NUMBERS.
32697C     INPUT  ARGUMENTS--IHARG
32698C                     --IARGT
32699C                     --ARG
32700C                     --NUMARG
32701C                     --PXSTAR
32702C                     --PYSTAR
32703C     OUTPUT ARGUMENTS--PXEND
32704C                     --PYEND
32705C                     --IFOUND ('YES' OR 'NO' )
32706C                     --IERROR ('YES' OR 'NO' )
32707C     WRITTEN BY--JAMES J. FILLIBEN
32708C                 STATISTICAL ENGINEERING DIVISION
32709C                 INFORMATION TECHNOLOGY LABORATORY
32710C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
32711C                 GAITHERSBURG, MD 20899-8980
32712C                 PHONE--301-975-2855
32713C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
32714C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
32715C     LANGUAGE--ANSI FORTRAN (1977)
32716C     VERSION NUMBER--82/7
32717C     ORIGINAL VERSION--APRIL     1981.
32718C     UPDATED         --MARCH     1982.
32719C     UPDATED         --MAY       1982.
32720C     UPDATED         --NOVEMBER  1982.
32721C     UPDATED         --JANUARY   1989.  CALL LIST FOR OFFSET VAR (ALAN)
32722C     UPDATED         --JANUARY   1989.  USE COMMON PARAMETERS (ALAN)
32723C     UPDATED         --MARCH     1993. ADD BOX SHADOW, PATTERN LINE
32724C     UPDATED         --MARCH     1993. GLOBALLY RENAMED IBOFPA, IBOFCO
32725C                                       PBOFTH TO IBOBPA, IBOBCO, PBOPTH
32726C     UPDATED         --MARCH     1997. SUPPORT FOR DEVICE FONT (ALAN)
32727C     UPDATED         --JULY      1997. SUPPORT FOR "DATA" UNITS (ALAN)
32728C     UPDATED         --APRIL     2010. SUPPORT FOR "DSDS" AND
32729C                                       "SDSD" UNITS (ALAN)
32730C                                       THIS ALLOWS X AND Y TO USE
32731C                                       DIFFERENT SETTINGS FOR
32732C                                       "SCREEN" AND "DATA" (HOWEVER,
32733C                                       CURRENTLY CANNOT SPECIFY
32734C                                       DIFFERENTLY FOR X1 AND X2 OR
32735C                                       Y1 AND Y2)
32736C     UPDATED         --DECEMBER  2018. SUPPORT FOR "DEVICE ... SCALE"
32737C                                       COMMAND
32738C
32739C-----NON-COMMON VARIABLES-----------------------------------------
32740C
32741      CHARACTER*4 IHARG
32742      CHARACTER*4 IARGT
32743C
32744      CHARACTER*4 IBOBPA
32745      CHARACTER*4 IBOBCO
32746C
32747      CHARACTER*4 IREBLI
32748      CHARACTER*4 IREBCO
32749      CHARACTER*4 IREFSW
32750      CHARACTER*4 IREFCO
32751      CHARACTER*4 IREPTY
32752      CHARACTER*4 IREPLI
32753      CHARACTER*4 IREPCO
32754C
32755      CHARACTER*4 IGRASW
32756      CHARACTER*4 IDIASW
32757C
32758      CHARACTER*4 IDMANU
32759      CHARACTER*4 IDMODE
32760      CHARACTER*4 IDMOD2
32761      CHARACTER*4 IDMOD3
32762      CHARACTER*4 IDPOWE
32763      CHARACTER*4 IDCONT
32764      CHARACTER*4 IDCOLO
32765CCCCC ADD FOLLOWING LINE MARCH 1997.
32766      CHARACTER*4 IDFONT
32767CCCCC ADD FOLLOWING LINE JULY 1997.
32768      CHARACTER*4 UNITSW
32769      CHARACTER*4 UNITSX
32770      CHARACTER*4 UNITSY
32771C
32772      CHARACTER*4 IFOUND
32773      CHARACTER*4 IBUGD2
32774      CHARACTER*4 IERROR
32775      CHARACTER*4 ISUBRO
32776C
32777      CHARACTER*4 IFIG
32778      CHARACTER*4 IBELSW
32779      CHARACTER*4 IERASW
32780      CHARACTER*4 IBACCO
32781      CHARACTER*4 ICOPSW
32782      CHARACTER*4 ITYPEO
32783C
32784      DIMENSION IHARG(*)
32785      DIMENSION IARGT(*)
32786      DIMENSION ARG(*)
32787C
32788      DIMENSION IBOBPA(*)
32789      DIMENSION IBOBCO(*)
32790      DIMENSION PBOPTH(*)
32791C
32792      DIMENSION AREGBA(*)
32793      DIMENSION IREBLI(*)
32794      DIMENSION IREBCO(*)
32795      DIMENSION PREBTH(*)
32796      DIMENSION IREFSW(*)
32797      DIMENSION IREFCO(*)
32798      DIMENSION IREPTY(*)
32799      DIMENSION IREPLI(*)
32800      DIMENSION IREPCO(*)
32801      DIMENSION PREPTH(*)
32802      DIMENSION PREPSP(*)
32803CCCCC MARCH 1993.  ADD FOLLOWING 2 LINES
32804      DIMENSION PBOSHE(*)
32805      DIMENSION PBOSWI(*)
32806      DIMENSION PDSCAL(*)
32807C
32808      DIMENSION IDMANU(*)
32809      DIMENSION IDMODE(*)
32810      DIMENSION IDMOD2(*)
32811      DIMENSION IDMOD3(*)
32812      DIMENSION IDPOWE(*)
32813      DIMENSION IDCONT(*)
32814      DIMENSION IDCOLO(*)
32815CCCCC ADD FOLLOWING LINE MARCH 1997.
32816      DIMENSION IDFONT(*)
32817      DIMENSION IDNVPP(*)
32818      DIMENSION IDNHPP(*)
32819      DIMENSION IDUNIT(*)
32820C
32821      DIMENSION IDNVOF(*)
32822      DIMENSION IDNHOF(*)
32823C
32824C-----COMMON----------------------------------------------------------
32825C
32826      INCLUDE 'DPCOGR.INC'
32827      INCLUDE 'DPCOBE.INC'
32828C
32829C-----COMMON VARIABLES (GENERAL)--------------------------------------
32830C
32831      INCLUDE 'DPCOP2.INC'
32832C
32833C-----START POINT-----------------------------------------------------
32834C
32835      IFOUND='NO'
32836      IERROR='NO'
32837      IERRG4=IERROR
32838CCCCC IBUGG4=IBUGD2
32839CCCCC ISUBG4=ISUBRO
32840C
32841      IF(UNITSW.EQ.'DATA')THEN
32842        UNITSX='DATA'
32843        UNITSY='DATA'
32844      ELSEIF(UNITSW.EQ.'SCRE')THEN
32845        UNITSX='SCRE'
32846        UNITSY='SCRE'
32847      ELSEIF(UNITSW(1:2).EQ.'SD')THEN
32848        UNITSX='SCRE'
32849        UNITSY='DATA'
32850      ELSEIF(UNITSW(1:2).EQ.'DS')THEN
32851        UNITSX='DATA'
32852        UNITSY='SCRE'
32853      ENDIF
32854C
32855      ILOCFN=0
32856      NUMNUM=0
32857C
32858      X1=0.0
32859      Y1=0.0
32860      X2=0.0
32861      Y2=0.0
32862C
32863      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'BX')GOTO90
32864      WRITE(ICOUT,999)
32865  999 FORMAT(1X)
32866      CALL DPWRST('XXX','BUG ')
32867      WRITE(ICOUT,51)
32868   51 FORMAT('***** AT THE BEGINNING OF DPBX--')
32869      CALL DPWRST('XXX','BUG ')
32870      WRITE(ICOUT,53)NUMARG
32871   53 FORMAT('NUMARG = ',I8)
32872      CALL DPWRST('XXX','BUG ')
32873      DO55I=1,NUMARG
32874      WRITE(ICOUT,56)I,IHARG(I),IARGT(I),ARG(I)
32875   56 FORMAT('I,IHARG(I),IARGT(I),ARG(I) = ',I8,2X,A4,2X,A4,E15.7)
32876      CALL DPWRST('XXX','BUG ')
32877   55 CONTINUE
32878      WRITE(ICOUT,57)PXSTAR,PYSTAR
32879   57 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
32880      CALL DPWRST('XXX','BUG ')
32881      WRITE(ICOUT,58)PXEND,PYEND
32882   58 FORMAT('PXEND,PYEND = ',2E15.7)
32883      CALL DPWRST('XXX','BUG ')
32884      WRITE(ICOUT,61)IBOBPA(1),IBOBCO(1),PBOPTH(1)
32885   61 FORMAT('IBOBPA(1),IBOBCO(1),PBOPTH(1) = ',A4,2X,A4,E15.7)
32886      CALL DPWRST('XXX','BUG ')
32887      WRITE(ICOUT,62)AREGBA(1)
32888   62 FORMAT('AREGBA(1) = ',E15.7)
32889      CALL DPWRST('XXX','BUG ')
32890      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
32891   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
32892      CALL DPWRST('XXX','BUG ')
32893      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
32894   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
32895      CALL DPWRST('XXX','BUG ')
32896      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
32897   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
32898     1A4,2X,A4,2X,A4,2E15.7)
32899      CALL DPWRST('XXX','BUG ')
32900      WRITE(ICOUT,69)PTEXHE,PTEXWI
32901   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
32902      CALL DPWRST('XXX','BUG ')
32903      WRITE(ICOUT,70)PTEXVG,PTEXHG
32904   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
32905      CALL DPWRST('XXX','BUG ')
32906      WRITE(ICOUT,76)IGRASW,IDIASW
32907   76 FORMAT('IGRASW,IDIASW = ',A4,2X,A4)
32908      CALL DPWRST('XXX','BUG ')
32909      WRITE(ICOUT,77)PGRAXF,PGRAYF,PDIAXC,PDIAYC
32910   77 FORMAT('PGRAXF,PGRAYF,PDIAXC,PDIAYC = ',4E15.7)
32911      CALL DPWRST('XXX','BUG ')
32912      WRITE(ICOUT,78)PDIAHE,PDIAWI,PDIAVG,PDIAHG
32913   78 FORMAT('PDIAHE,PDIAWI,PDIAVG,PDIAHG = ',4E15.7)
32914      CALL DPWRST('XXX','BUG ')
32915      WRITE(ICOUT,80)NUMDEV
32916   80 FORMAT('NUMDEV= ',I8)
32917      CALL DPWRST('XXX','BUG ')
32918      DO81I=1,NUMDEV
32919      WRITE(ICOUT,82)IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I)
32920   82 FORMAT('IDMANU(I),IDMODE(I),IDMOD2(I),IDMOD3(I) = ',
32921     1A4,2X,A4,2X,A4,2X,A4)
32922      CALL DPWRST('XXX','BUG ')
32923      WRITE(ICOUT,83)IDPOWE(I),IDCONT(I),IDCOLO(I)
32924   83 FORMAT('IDPOWE(I),IDCONT(I),IDCOLO(I) = ',
32925     1A4,2X,A4,2X,A4)
32926      CALL DPWRST('XXX','BUG ')
32927      WRITE(ICOUT,84)IDNVPP(I),IDNHPP(I),IDUNIT(I)
32928   84 FORMAT('IDNVPP(I),IDNHPP(I),IDUNIT(I) = ',
32929     1I8,I8,I8)
32930      CALL DPWRST('XXX','BUG ')
32931   81 CONTINUE
32932      WRITE(ICOUT,87)IFOUND
32933   87 FORMAT('IFOUND= ',A4)
32934      CALL DPWRST('XXX','BUG ')
32935      WRITE(ICOUT,88)IBUGG4,ISUBG4,IERRG4
32936   88 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
32937      CALL DPWRST('XXX','BUG ')
32938      WRITE(ICOUT,89)IBUGD2,IERROR
32939   89 FORMAT('IBUGD2,IERROR= ',A4,2X,A4)
32940      CALL DPWRST('XXX','BUG ')
32941   90 CONTINUE
32942C
32943      IFIG='BOX'
32944      NUMPT=2
32945      NUMPT2=2*NUMPT
32946C
32947C               ********************************
32948C               **  STEP 0--                  **
32949C               **  STEP THROUGH EACH DEVICE  **
32950C               ********************************
32951C
32952      IF(NUMDEV.LE.0)GOTO9000
32953      DO8000IDEVIC=1,NUMDEV
32954C
32955      IF(IDPOWE(IDEVIC).EQ.'OFF')GOTO8000
32956      IF(IDMANU(IDEVIC).EQ.'OFF')GOTO8000
32957      IF(IDMANU(IDEVIC).EQ.'NULL')GOTO8000
32958      IF(IDMANU(IDEVIC).EQ.'NONE')GOTO8000
32959      IF(IDMANU(IDEVIC).EQ.'DISC')GOTO8000
32960C
32961      IMANUF=IDMANU(IDEVIC)
32962      IMODEL=IDMODE(IDEVIC)
32963      IMODE2=IDMOD2(IDEVIC)
32964      IMODE3=IDMOD3(IDEVIC)
32965      IGCONT=IDCONT(IDEVIC)
32966      IGCOLO=IDCOLO(IDEVIC)
32967      IGFONT=IDFONT(IDEVIC)
32968      NUMVPP=IDNVPP(IDEVIC)
32969      NUMHPP=IDNHPP(IDEVIC)
32970      ANUMVP=NUMVPP
32971      ANUMHP=NUMHPP
32972      IOFFSV=IDNVOF(IDEVIC)
32973      IOFFSH=IDNHOF(IDEVIC)
32974      IGUNIT=IDUNIT(IDEVIC)
32975      PCHSCA=PDSCAL(IDEVIC)
32976C
32977C               ************************************
32978C               **  STEP 1--                      **
32979C               **  CARRY OUT OPENING OPERATIONS  **
32980C               **  ON THE GRAPHICS DEVICES       **
32981C               ************************************
32982C
32983      CALL DPOPDE
32984C
32985      IBELSW='OFF'
32986      NUMRIN=0
32987      IERASW='OFF'
32988      IBACCO='JUNK'
32989C
32990      CALL DPOPPL(IGRASW,
32991     1IBELSW,NUMRIN,IERASW,
32992     1IBACCO)
32993C
32994C               *****************************************
32995C               **  STEP 2--                           **
32996C               **  SEARCH FOR COMMAND SPECIFICATIONS  **
32997C               *****************************************
32998C
32999      IF(NUMARG.GE.2.AND.
33000     1IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')
33001     1GOTO1111
33002      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'ABSO'.AND.
33003     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
33004     1GOTO1112
33005      IF(NUMARG.GE.3.AND.IHARG(1).EQ.'RELA'.AND.
33006     1IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')
33007     1GOTO1113
33008      GOTO1130
33009C
33010 1111 CONTINUE
33011      ITYPEO='ABSO'
33012      ILOCFN=1
33013      GOTO1119
33014C
33015 1112 CONTINUE
33016      ITYPEO='ABSO'
33017      ILOCFN=2
33018      GOTO1119
33019C
33020 1113 CONTINUE
33021      ITYPEO='RELA'
33022      ILOCFN=2
33023      GOTO1119
33024 1119 CONTINUE
33025C
33026      IF(ILOCFN.GT.NUMARG)GOTO1129
33027      DO1120I=ILOCFN,NUMARG
33028      IF(IARGT(I).EQ.'NUMB')GOTO1120
33029      GOTO1129
33030 1120 CONTINUE
33031      IFOUND='YES'
33032      GOTO1149
33033 1129 CONTINUE
33034      GOTO1130
33035C
33036 1130 CONTINUE
33037      IERRG4='YES'
33038      WRITE(ICOUT,1131)
33039 1131 FORMAT('***** ERROR IN DPBX--')
33040      CALL DPWRST('XXX','BUG ')
33041      WRITE(ICOUT,1132)
33042 1132 FORMAT('      ILLEGAL FORM FOR DRAW ',
33043     1'COMMAND.')
33044      CALL DPWRST('XXX','BUG ')
33045      WRITE(ICOUT,1134)
33046 1134 FORMAT('      TEST EXAMPLE TO DEMONSTRATE THE ',
33047     1'PROPER FORM--')
33048      CALL DPWRST('XXX','BUG ')
33049      WRITE(ICOUT,1135)
33050 1135 FORMAT('      SUPPOSE IT IS DESIRED TO DRAW A BOX ')
33051      CALL DPWRST('XXX','BUG ')
33052      WRITE(ICOUT,1136)
33053 1136 FORMAT('      WITH ONE CORNER AT THE POINT 20 20 ')
33054      CALL DPWRST('XXX','BUG ')
33055      WRITE(ICOUT,1137)
33056 1137 FORMAT('      AND WITH OPPOSITE CORNER AT THE POINT 40 60')
33057      CALL DPWRST('XXX','BUG ')
33058      WRITE(ICOUT,1141)
33059 1141 FORMAT('      THEN THE ALLOWABLE FORMS ARE--')
33060      CALL DPWRST('XXX','BUG ')
33061      WRITE(ICOUT,1142)
33062 1142 FORMAT('      BOX 20 20 40 60 ')
33063      CALL DPWRST('XXX','BUG ')
33064      WRITE(ICOUT,1143)
33065 1143 FORMAT('      BOX ABSOLUTE 20 20 40 60 ')
33066      CALL DPWRST('XXX','BUG ')
33067      GOTO9000
33068 1149 CONTINUE
33069C
33070C               ****************************
33071C               **  STEP 3--              **
33072C               **  DRAW OUT THE LINE(S)  **
33073C               ****************************
33074C
33075      NUMNUM=NUMARG-ILOCFN+1
33076      IF(NUMNUM.LT.NUMPT2)GOTO1151
33077      GOTO1152
33078C
33079 1151 CONTINUE
33080      J=ILOCFN-1
33081      X1=PXSTAR
33082      Y1=PYSTAR
33083      GOTO1159
33084C
33085 1152 CONTINUE
33086      J=ILOCFN
33087      IF(J.GT.NUMARG)GOTO1190
33088      X1=ARG(J)
33089CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
33090CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
33091      IF(UNITSX.EQ.'DATA')CALL DPCODS('X',X1,X1,IBUGD2,ISUBRO,IERROR)
33092      J=J+1
33093      IF(J.GT.NUMARG)GOTO1190
33094      Y1=ARG(J)
33095CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
33096CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
33097      IF(UNITSY.EQ.'DATA')CALL DPCODS('Y',Y1,Y1,IBUGD2,ISUBRO,IERROR)
33098      GOTO1159
33099 1159 CONTINUE
33100C
33101 1160 CONTINUE
33102      J=J+1
33103      IF(J.GT.NUMARG)GOTO1190
33104      X2=ARG(J)
33105CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
33106CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
33107      IF(UNITSX.EQ.'DATA')CALL DPCODS('X',X2,X2,IBUGD2,ISUBRO,IERROR)
33108      IF(ITYPEO.EQ.'RELA')X2=X1+X2
33109      J=J+1
33110      IF(J.GT.NUMARG)GOTO1190
33111      Y2=ARG(J)
33112CCCCC THE FOLLOWING LINE WAS ADDED JULY 1997
33113CCCCC IF(UNITSW.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
33114      IF(UNITSY.EQ.'DATA')CALL DPCODS('Y',Y2,Y2,IBUGD2,ISUBRO,IERROR)
33115      IF(ITYPEO.EQ.'RELA')Y2=Y1+Y2
33116C
33117      CALL DPBX2(X1,Y1,X2,Y2,
33118     1IFIG,
33119     1IBOBPA,IBOBCO,PBOPTH,
33120     1AREGBA,
33121     1IREBLI,IREBCO,PREBTH,
33122     1IREFSW,IREFCO,
33123     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
33124CCCCC MARCH 1993.  ADD FOLLOWING LINE (BOX SHADOW)  (ALAN)
33125     1PBOSHE,PBOSWI,
33126     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
33127C
33128      X1=X2
33129      Y1=Y2
33130C
33131      GOTO1160
33132 1190 CONTINUE
33133C
33134      PXEND=X2
33135      PYEND=Y2
33136C
33137C               ************************************
33138C               **  STEP 4--                      **
33139C               **  CARRY OUT CLOSING OPERATIONS  **
33140C               **  ON THE GRAPHICS DEVICES       **
33141C               ************************************
33142C
33143      ICOPSW='OFF'
33144      NUMCOP=0
33145      CALL DPCLPL(ICOPSW,NUMCOP,
33146     1PGRAXF,PGRAYF,
33147     1IGRASW,PDIAXC,PDIAYC,PDIAX2,PDIAY2,
33148     1PDIAHE,PDIAWI,PDIAVG,PDIAHG)
33149C
33150      CALL DPCLDE
33151C
33152 8000 CONTINUE
33153C
33154C               *****************
33155C               **  STEP 90--  **
33156C               **  EXIT       **
33157C               *****************
33158C
33159 9000 CONTINUE
33160      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'BX')GOTO9090
33161      WRITE(ICOUT,999)
33162      CALL DPWRST('XXX','BUG ')
33163      WRITE(ICOUT,9011)
33164 9011 FORMAT('***** AT THE END       OF DPBX--')
33165      CALL DPWRST('XXX','BUG ')
33166      WRITE(ICOUT,9012)ILOCFN,NUMNUM
33167 9012 FORMAT('ILOCFN,NUMNUM = ',2I8)
33168      CALL DPWRST('XXX','BUG ')
33169      WRITE(ICOUT,9013)X1,Y1,X2,Y2
33170 9013 FORMAT('X1,Y1,X2,Y2 = ',4E15.7)
33171      CALL DPWRST('XXX','BUG ')
33172      WRITE(ICOUT,9015)PXSTAR,PYSTAR
33173 9015 FORMAT('PXSTAR,PYSTAR = ',2E15.7)
33174      CALL DPWRST('XXX','BUG ')
33175      WRITE(ICOUT,9016)PXEND,PYEND
33176 9016 FORMAT('PXEND,PYEND = ',2E15.7)
33177      CALL DPWRST('XXX','BUG ')
33178      WRITE(ICOUT,9017)IFIG
33179 9017 FORMAT('IFIG = ',A4)
33180      CALL DPWRST('XXX','BUG ')
33181      WRITE(ICOUT,9027)IFOUND
33182 9027 FORMAT('IFOUND = ',A4)
33183      CALL DPWRST('XXX','BUG ')
33184      WRITE(ICOUT,9028)IBUGG4,ISUBG4,IERRG4
33185 9028 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4)
33186      CALL DPWRST('XXX','BUG ')
33187      WRITE(ICOUT,9029)IBUGD2,IERROR
33188 9029 FORMAT('IBUGD2,IERROR = ',A4,2X,A4)
33189      CALL DPWRST('XXX','BUG ')
33190 9090 CONTINUE
33191C
33192      RETURN
33193      END
33194      SUBROUTINE DPBX2(X1,Y1,X2,Y2,
33195     1IFIG,
33196     1IBOBPA,IBOBCO,PBOPTH,
33197     1AREGBA,
33198     1IREBLI,IREBCO,PREBTH,
33199     1IREFSW,IREFCO,
33200     1IREPTY,IREPLI,IREPCO,PREPTH,PREPSP,
33201CCCCC MARCH 1993.  BOX SHADOW PARAMETERS
33202     1PBOSHE,PBOSWI,
33203     1PTEXHE,PTEXWI,PTEXVG,PTEXHG)
33204C
33205C     PURPOSE--DRAW A BOX
33206C              WITH ONE END OF THE DIAGONAL AT (X1,Y1)
33207C              AND THE OTHER END AT (X2,Y2).
33208C     WRITTEN BY--JAMES J. FILLIBEN
33209C                 STATISTICAL ENGINEERING DIVISION
33210C                 INFORMATION TECHNOLOGY LABORATORY
33211C                 NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY
33212C                 GAITHERSBURG, MD 20899-8980
33213C                 PHONE--301-975-2855
33214C     NOTE--DATAPLOT IS A REGISTERED TRADEMARK
33215C           OF THE NATIONAL INSTITUTE OF STANDARDS AND TECHNOLOGY.
33216C     LANGUAGE--ANSI FORTRAN (1977)
33217C     VERSION NUMBER--82/7
33218C     ORIGINAL VERSION--APRIL     1981.
33219C     UPDATED         --MAY       1982.
33220C     UPDATED         --JANUARY   1989.  MODIFY CALLS TO DPDRPL (ALAN)
33221C     UPDATED         --JANUARY   1989.  MODIFY CALL  TO DPFIRE (ALAN)
33222C     UPDATED         --JANUARY   1989.  USE COMMON PARAMETERS (ALAN)
33223C     UPDATED         --MARCH     1993. BOX SHADOW, PATTERN LINE TYPE
33224C     UPDATED         --MARCH     1993. GLOBALLY RENAMED IBOFPA, IBOFCO
33225C                                       PBOFTH TO IBOBPA, IBOBCO, PBOPTH
33226C
33227C-----NON-COMMON VARIABLES-------------------------------------
33228C
33229      CHARACTER*4 IFIG
33230      CHARACTER*4 IPATT2
33231C
33232      CHARACTER*4 IBOBPA
33233      CHARACTER*4 IBOBCO
33234C
33235      CHARACTER*4 IREBLI
33236      CHARACTER*4 IREBCO
33237      CHARACTER*4 IREFSW
33238      CHARACTER*4 IREFCO
33239      CHARACTER*4 IREPTY
33240      CHARACTER*4 IREPLI
33241      CHARACTER*4 IREPCO
33242C
33243      CHARACTER*4 IPATT
33244      CHARACTER*4 ICOLF
33245      CHARACTER*4 ICOLP
33246      CHARACTER*4 ICOL
33247      CHARACTER*4 IFLAG
33248C
33249      DIMENSION PX(10)
33250      DIMENSION PY(10)
33251CCCCC DIMENSION PX3(10)
33252CCCCC DIMENSION PY3(10)
33253C
33254      DIMENSION IBOBPA(*)
33255      DIMENSION IBOBCO(*)
33256      DIMENSION PBOPTH(*)
33257C
33258      DIMENSION AREGBA(*)
33259      DIMENSION IREBLI(*)
33260      DIMENSION IREBCO(*)
33261      DIMENSION PREBTH(*)
33262      DIMENSION IREFSW(*)
33263      DIMENSION IREFCO(*)
33264      DIMENSION IREPTY(*)
33265      DIMENSION IREPLI(*)
33266      DIMENSION IREPCO(*)
33267      DIMENSION PREPTH(*)
33268      DIMENSION PREPSP(*)
33269CCCCC MARCH 1993.  ADD FOLLOWING 2 LINES
33270      DIMENSION PBOSHE(*)
33271      DIMENSION PBOSWI(*)
33272C
33273C-----COMMON----------------------------------------------------------
33274C
33275      INCLUDE 'DPCOGR.INC'
33276      INCLUDE 'DPCOBE.INC'
33277C
33278C-----COMMON VARIABLES (GENERAL)--------------------------------------
33279C
33280      INCLUDE 'DPCOP2.INC'
33281C
33282C-----START POINT-----------------------------------------------------
33283C
33284      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'BX2')GOTO90
33285      WRITE(ICOUT,999)
33286  999 FORMAT(1X)
33287      CALL DPWRST('XXX','BUG ')
33288      WRITE(ICOUT,51)
33289   51 FORMAT('***** AT THE BEGINNING OF DPBX2--')
33290      CALL DPWRST('XXX','BUG ')
33291      WRITE(ICOUT,53)X1,Y1
33292   53 FORMAT('X1,Y1 = ',2E15.7)
33293      CALL DPWRST('XXX','BUG ')
33294      WRITE(ICOUT,54)X2,Y2
33295   54 FORMAT('X2,Y2 = ',2E15.7)
33296      CALL DPWRST('XXX','BUG ')
33297      WRITE(ICOUT,59)IFIG
33298   59 FORMAT('IFIG = ',A4)
33299      CALL DPWRST('XXX','BUG ')
33300      WRITE(ICOUT,61)IBOBPA(1),IBOBCO(1),PBOPTH(1)
33301   61 FORMAT('IBOBPA(1),IBOBCO(1),PBOPTH(1) = ',A4,2X,A4,E15.7)
33302      CALL DPWRST('XXX','BUG ')
33303      WRITE(ICOUT,62)AREGBA(1)
33304   62 FORMAT('AREGBA(1) = ',E15.7)
33305      CALL DPWRST('XXX','BUG ')
33306      WRITE(ICOUT,63)IREBLI(1),IREBCO(1),PREBTH(1)
33307   63 FORMAT('IREBLI(1),IREBCO(1),PREBTH(1) = ',A4,2X,A4,E15.7)
33308      CALL DPWRST('XXX','BUG ')
33309      WRITE(ICOUT,64)IREFSW(1),IREFCO(1)
33310   64 FORMAT('IREFSW(1),IREFCO(1) = ',A4,2X,A4)
33311      CALL DPWRST('XXX','BUG ')
33312      WRITE(ICOUT,65)IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1)
33313   65 FORMAT('IREPTY(1),IREPLI(1),IREPCO(1),PREPTH(1),PREPSP(1) = ',
33314     1A4,2X,A4,2X,A4,2E15.7)
33315      CALL DPWRST('XXX','BUG ')
33316      WRITE(ICOUT,69)PTEXHE,PTEXWI
33317   69 FORMAT('PTEXHE,PTEXWI= ',2E15.7)
33318      CALL DPWRST('XXX','BUG ')
33319      WRITE(ICOUT,70)PTEXVG,PTEXHG
33320   70 FORMAT('PTEXVG,PTEXHG= ',2E15.6)
33321      CALL DPWRST('XXX','BUG ')
33322      WRITE(ICOUT,79)IBUGG4,ISUBG4,IERRG4
33323   79 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
33324      CALL DPWRST('XXX','BUG ')
33325   90 CONTINUE
33326C
33327C               *********************************
33328C               **  STEP 1--                   **
33329C               **  DETERMINE THE COORDINATES  **
33330C               **  FOR THE BOX                **
33331C               *********************************
33332C
33333      PX(1)=X1
33334      PY(1)=Y1
33335C
33336      PX(2)=X2
33337      PY(2)=Y1
33338C
33339      PX(3)=X2
33340      PY(3)=Y2
33341C
33342      PX(4)=X1
33343      PY(4)=Y2
33344C
33345      PX(5)=X1
33346      PY(5)=Y1
33347C
33348      NP=5
33349C
33350C               ***********************
33351C               **  STEP 2--         **
33352C               **  FILL THE FIGURE  **
33353C               **  (IF CALLED FOR)  **
33354C               ***********************
33355C
33356CCCCC FOLLOWING BLOCK MODIFIED MARCH 1993.
33357CCCCC USE BOX PARAMETERS RATHER THAN REGION PARAMETERS.
33358CCCCC IF(IREFSW(1).EQ.'OFF')GOTO2190
33359      IPATT=IREPTY(1)
33360      IF(IPATT.EQ.'OFF')GOTO2190
33361      IF(IPATT.EQ.'EMPT')GOTO2190
33362      IF(IPATT.EQ.'    ')GOTO2190
33363      IF(IPATT.EQ.'NONE')GOTO2190
33364      IF(IPATT.EQ.'BLAN')GOTO2190
33365      IF(IPATT.EQ.'BLAN')GOTO2190
33366      IF(IPATT.EQ.'ON')IPATT='SOLI'
33367CCCCC IPATT2='SOLI'
33368      IPATT2=IREPLI(1)
33369      PTHICK=PREPTH(1)
33370      PXGAP=PREPSP(1)
33371      PYGAP=PREPSP(1)
33372CCCCC ICOLF=IREFCO(1)
33373CCCCC ICOLP=IREPCO(1)
33374      ICOLF=IREPCO(1)
33375      ICOLP=ICOLF
33376      CALL DPFIRE(PX,PY,NP,
33377     1IFIG,IPATT,PTHICK,PXGAP,PYGAP,ICOLF,ICOLP,IPATT2)
33378 2190 CONTINUE
33379C
33380C               ***************************
33381C               **  STEP 3--             **
33382C               **  DRAW OUT THE FIGURE  **
33383C               ***************************
33384C
33385      IPATT=IBOBPA(1)
33386      PTHICK=PBOPTH(1)
33387      ICOL=IBOBCO(1)
33388      IFLAG='ON'
33389CCCCC CALL DPDRPL(PX,PY,NP,PX3,PY3,NP3,
33390CCCCC1IFIG,IPATT,PTHICK,ICOL)
33391      CALL DPDRPL(PX,PY,NP,
33392     1IFIG,IPATT,PTHICK,ICOL,
33393     1JPATT,JTHICK,PTHIC2,JCOL,IFLAG)
33394C
33395CCCCC THE FOLLOWING 2 SECTIONS WERE ADDED
33396CCCCC TO ADD A SHADOW TO THE BOX   MARCH 1993
33397C               ***************************
33398C               **  STEP 4--             **
33399C               **  DRAW THE BOX SHADOW  **
33400C               ***************************
33401C
33402C
33403      PSH=PBOSHE(1)
33404      PSW=PBOSWI(1)
33405      EPSBS=0.000001
33406      IF(PSH.LT.EPSBS.AND.PSW.LT.EPSBS)GOTO4190
33407      PLEFT=X1
33408      PRIGHT=X2
33409      IF(X2.LT.X1)THEN
33410         PLEFT=X2
33411         PRIGHT=X1
33412      ENDIF
33413      PBOTTO=Y1
33414      PTOP=Y2
33415      IF(Y2.LT.Y1)THEN
33416         PBOTTO=Y2
33417         PTOP=Y1
33418      ENDIF
33419      PX(1)=PLEFT+PSW
33420      PY(1)=PBOTTO-PSH
33421      PX(2)=PRIGHT+PSW
33422      PY(2)=PBOTTO-PSH
33423      PX(3)=PRIGHT+PSW
33424      PY(3)=PBOTTO
33425      PX(4)=PLEFT+PSW
33426      PY(4)=PBOTTO
33427      PX(5)=PLEFT+PSW
33428      PY(5)=PBOTTO-PSH
33429      NP=5
33430      IPATT='SOLI'
33431      IPATT2='SOLI'
33432      ICOLF=IBOBCO(1)
33433      ICOLP=ICOLF
33434      CALL DPFIRE(PX,PY,NP,
33435     1IFIG,IPATT,PTHICK,PXSPA,PYSPA,ICOLF,ICOLP,IPATT2)
33436C
33437      PX(1)=PRIGHT
33438      PY(1)=PBOTTO-PSH
33439      PX(2)=PRIGHT+PSW
33440      PY(2)=PBOTTO-PSH
33441      PX(3)=PRIGHT+PSW
33442      PY(3)=PTOP-PSH
33443      PX(4)=PRIGHT
33444      PY(4)=PTOP-PSH
33445      PX(5)=PRIGHT
33446      PY(5)=PBOTTO-PSH
33447      CALL DPFIRE(PX,PY,NP,
33448     1IFIG,IPATT,PTHICK,PXSPA,PYSPA,ICOLF,ICOLP,IPATT2)
33449C
33450 4190 CONTINUE
33451C
33452C               *****************
33453C               **  STEP 90--  **
33454C               **  EXIT       **
33455C               *****************
33456C
33457      IF(IBUGG4.EQ.'OFF'.AND.ISUBG4.NE.'BX2')GOTO9090
33458      WRITE(ICOUT,999)
33459      CALL DPWRST('XXX','BUG ')
33460      WRITE(ICOUT,9011)
33461 9011 FORMAT('***** AT THE END       OF DPBX2--')
33462      CALL DPWRST('XXX','BUG ')
33463      WRITE(ICOUT,9013)NP
33464 9013 FORMAT('NP = ',I8)
33465      CALL DPWRST('XXX','BUG ')
33466      DO9015I=1,NP
33467      WRITE(ICOUT,9016)I,PX(I),PY(I)
33468 9016 FORMAT('I,PX(I),PY(I) = ',I8,2E15.7)
33469      CALL DPWRST('XXX','BUG ')
33470 9015 CONTINUE
33471      WRITE(ICOUT,9039)IBUGG4,ISUBG4,IERRG4
33472 9039 FORMAT('IBUGG4,ISUBG4,IERRG4 = ',A4,2X,A4,2X,A4)
33473      CALL DPWRST('XXX','BUG ')
33474 9090 CONTINUE
33475C
33476      RETURN
33477      END
33478